diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 17abc9b0e3..cdacb620b0 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -8,7 +8,7 @@ stages: # Merges MOM6 with dev/gfdl. Changes directory to test directory, if it exists. before_script: - MOM6_SRC=$CI_PROJECT_DIR - - CACHE_DIR=/lustre/f1/oar.gfdl.ogrp-account/runner/cache/ + - echo Cache directory set to ${CACHE_DIR:=/lustre/f2/scratch/oar.gfdl.ogrp-account/runner/cache/} - git pull --no-edit https://github.com/NOAA-GFDL/MOM6.git dev/gfdl && git submodule init && git submodule update - pwd ; ls @@ -34,10 +34,12 @@ setup: - git clone https://github.com/adcroft/MRS.git MRS # Update MOM6-examples and submodules - (cd MOM6-examples && git checkout . && git checkout dev/gfdl && git pull && git submodule init && git submodule update) + - (cd MOM6-examples/src/MOM6 && git submodule update) - test -d MOM6-examples/src/LM3 || make -f MRS/Makefile.clone clone_gfdl -s - make -f MRS/Makefile.clone MOM6-examples/.datasets -s #- (cd MOM6-examples/src/mkmf && git pull https://github.com/adcroft/mkmf.git add_coverage_mode) - env > gitlab_session.log + # Cache everything under tests to unpack for each subsequent stage - cd ../ ; time tar zcf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz tests # Compiles @@ -114,8 +116,9 @@ run: - 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:29: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 + - 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 - cat log.$CI_PIPELINE_ID + - test -f restart_results_gnu.tar.gz - time tar zvcf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz *.tar.gz # Tests @@ -218,6 +221,16 @@ gnu:restart: - time tar zxf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz - make -f MRS/Makefile.tests gnu_check_restarts +gnu:params: + stage: tests + tags: + - ncrc4 + script: + - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests + - time tar zxf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz + - make -f MRS/Makefile.tests params_gnu_symmetric + allow_failure: true + cleanup: stage: cleanup tags: diff --git a/.travis.yml b/.travis.yml index f211d9f162..2886eb09bd 100644 --- a/.travis.yml +++ b/.travis.yml @@ -4,14 +4,13 @@ # This is a not a c-language project but we use the same environment. language: c dist: trusty -sudo: false addons: apt: sources: - ubuntu-toolchain-r-test packages: - - tcsh pkg-config netcdf-bin libnetcdf-dev openmpi-bin libopenmpi-dev gfortran + - tcsh pkg-config netcdf-bin libnetcdf-dev mpich2 libmpich2-dev gfortran # For saving time... cache: diff --git a/config_src/coupled_driver/MOM_surface_forcing.F90 b/config_src/coupled_driver/MOM_surface_forcing.F90 index 370cc9ad99..09d7da3119 100644 --- a/config_src/coupled_driver/MOM_surface_forcing.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing.F90 @@ -14,9 +14,10 @@ module MOM_surface_forcing use MOM_domains, only : pass_vector, pass_var, fill_symmetric_edges use MOM_domains, only : global_field_sum, BITWISE_EXACT_SUM use MOM_domains, only : AGRID, BGRID_NE, CGRID_NE, To_All +use MOM_domains, only : To_North, To_East, Omit_Corners use MOM_error_handler, only : MOM_error, WARNING, FATAL, is_root_pe, MOM_mesg use MOM_file_parser, only : get_param, log_version, param_file_type -use MOM_forcing_type, only : forcing, mech_forcing, copy_common_forcing_fields +use MOM_forcing_type, only : forcing, mech_forcing use MOM_forcing_type, only : forcing_diags, mech_forcing_diags, register_forcing_type_diags use MOM_forcing_type, only : allocate_forcing_type, deallocate_forcing_type use MOM_forcing_type, only : allocate_mech_forcing, deallocate_mech_forcing @@ -27,6 +28,7 @@ module MOM_surface_forcing use MOM_restart, only : restart_init_end, save_restart, restore_state use MOM_string_functions, only : uppercase use MOM_spatial_means, only : adjust_area_mean_to_zero +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface use user_revise_forcing, only : user_alter_forcing, user_revise_forcing_init use user_revise_forcing, only : user_revise_forcing_CS @@ -44,231 +46,198 @@ module MOM_surface_forcing #include -public convert_IOB_to_fluxes +public convert_IOB_to_fluxes, convert_IOB_to_forces public surface_forcing_init public ice_ocn_bnd_type_chksum public forcing_save_restart +! 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. -! surface_forcing_CS is a structure containing pointers to the forcing fields -! which may be used to drive MOM. All fluxes are positive downward. +!> surface_forcing_CS is a structure containing pointers to the forcing fields +!! which may be used to drive MOM. All fluxes are positive downward. type, public :: surface_forcing_CS ; private - integer :: wind_stagger ! AGRID, BGRID_NE, or CGRID_NE (integer values - ! from MOM_domains) to indicate the staggering of - ! the winds that are being provided in calls to - ! update_ocean_model. - logical :: use_temperature ! If true, temp and saln used as state variables - real :: wind_stress_multiplier !< A multiplier applied to incoming wind stress (nondim). - - ! smg: remove when have A=B code reconciled - logical :: bulkmixedlayer ! If true, model based on bulk mixed layer code - - real :: Rho0 ! Boussinesq reference density (kg/m^3) - real :: area_surf = -1.0 ! total ocean surface area (m^2) - real :: latent_heat_fusion ! latent heat of fusion (J/kg) - real :: latent_heat_vapor ! latent heat of vaporization (J/kg) - - real :: max_p_surf ! maximum surface pressure that can be - ! exerted by the atmosphere and floating sea-ice, - ! in Pa. 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. - logical :: use_limited_P_SSH ! 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. The default is true. - - real :: gust_const ! constant unresolved background gustiness for ustar (Pa) - logical :: read_gust_2d ! If true, use a 2-dimensional gustiness supplied - ! from an input file. + integer :: wind_stagger !< AGRID, BGRID_NE, or CGRID_NE (integer values + !! from MOM_domains) to indicate the staggering of + !! the winds that are being provided in calls to + !! update_ocean_model. + logical :: use_temperature !< If true, temp and saln used as state variables + real :: wind_stress_multiplier !< A multiplier applied to incoming wind stress [nondim]. + + real :: Rho0 !< Boussinesq reference density [kg m-3] + real :: area_surf = -1.0 !< Total ocean surface area [m2] + real :: latent_heat_fusion !< Latent heat of fusion [J kg-1] + real :: latent_heat_vapor !< Latent heat of vaporization [J kg-1] + + real :: max_p_surf !< The maximum surface pressure that can be + !! exerted by the atmosphere and floating sea-ice [Pa]. + !! 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. + logical :: use_limited_P_SSH !< 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. The default is true. + logical :: approx_net_mass_src !< 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 corrections. + + real :: gust_const !< Constant unresolved background gustiness for ustar [Pa] + logical :: read_gust_2d !< If true, use a 2-dimensional gustiness supplied from an input file. real, pointer, dimension(:,:) :: & - TKE_tidal => NULL(), & ! turbulent kinetic energy introduced to the - ! bottom boundary layer by drag on the tidal flows, - ! in W m-2. - gust => NULL(), & ! spatially varying unresolved background - ! gustiness that contributes to ustar (Pa). - ! gust is used when read_gust_2d is true. - ustar_tidal => NULL() ! tidal contribution to the bottom friction velocity (m/s) - real :: cd_tides ! drag coefficient that applies to the tides (nondimensional) - real :: utide ! constant tidal velocity to use if read_tideamp - ! is false, in m s-1. - logical :: read_tideamp ! If true, spatially varying tidal amplitude read from a file. - - logical :: rigid_sea_ice ! If true, sea-ice exerts a rigidity that acts - ! to damp surface deflections (especially surface - ! gravity waves). The default is false. - real :: Kv_sea_ice ! viscosity in sea-ice that resists sheared vertical motions (m^2/s) - real :: density_sea_ice ! typical density of sea-ice (kg/m^3). The value is - ! only used to convert the ice pressure into - ! appropriate units for use with Kv_sea_ice. - real :: rigid_sea_ice_mass ! A mass per unit area of sea-ice beyond which - ! sea-ice viscosity becomes effective, in kg m-2, - ! typically of order 1000 kg m-2. - logical :: allow_flux_adjustments ! If true, use data_override to obtain flux adjustments - - real :: Flux_const ! piston velocity for surface restoring (m/s) - logical :: salt_restore_as_sflux ! If true, SSS restore as salt flux instead of water flux - logical :: adjust_net_srestore_to_zero ! adjust srestore to zero (for both salt_flux or vprec) - logical :: adjust_net_srestore_by_scaling ! adjust srestore w/o moving zero contour - logical :: adjust_net_fresh_water_to_zero ! adjust net surface fresh-water (w/ restoring) to zero - logical :: use_net_FW_adjustment_sign_bug ! use the wrong sign when adjusting net FW - logical :: adjust_net_fresh_water_by_scaling ! adjust net surface fresh-water w/o moving zero contour - logical :: mask_srestore_under_ice ! If true, use an ice mask defined by frazil - ! criteria for salinity restoring. - real :: ice_salt_concentration ! salt concentration for sea ice (kg/kg) - logical :: mask_srestore_marginal_seas ! if true, then mask SSS restoring in marginal seas - real :: max_delta_srestore ! maximum delta salinity used for restoring - real :: max_delta_trestore ! maximum delta sst used for restoring - real, pointer, dimension(:,:) :: basin_mask => NULL() ! mask for SSS restoring by basin - - type(diag_ctrl), pointer :: diag ! structure to regulate diagnostic output timing - character(len=200) :: inputdir ! directory where NetCDF input files are - character(len=200) :: salt_restore_file ! filename for salt restoring data - character(len=30) :: salt_restore_var_name ! name of surface salinity in salt_restore_file - logical :: mask_srestore ! if true, apply a 2-dimensional mask to the surface - ! salinity restoring fluxes. The masking file should be - ! in inputdir/salt_restore_mask.nc and the field should be name 'mask' - real, pointer, dimension(:,:) :: srestore_mask => NULL() ! mask for SSS restoring - character(len=200) :: temp_restore_file ! filename for sst restoring data - character(len=30) :: temp_restore_var_name ! name of surface temperature in temp_restore_file - logical :: mask_trestore ! if true, apply a 2-dimensional mask to the surface - ! temperature restoring fluxes. The masking file should be - ! in inputdir/temp_restore_mask.nc and the field should be name 'mask' - real, pointer, dimension(:,:) :: trestore_mask => NULL() ! mask for SST restoring - integer :: id_srestore = -1 ! id number for time_interp_external. - integer :: id_trestore = -1 ! id number for time_interp_external. - - ! Diagnostics handles - type(forcing_diags), public :: handles + TKE_tidal => NULL() !< Turbulent kinetic energy introduced to the bottom boundary layer + !! by drag on the tidal flows [W m-2]. + real, pointer, dimension(:,:) :: & + gust => NULL() !< A spatially varying unresolved background gustiness that + !! contributes to ustar [Pa]. gust is used when read_gust_2d is true. + real, pointer, dimension(:,:) :: & + ustar_tidal => NULL() !< Tidal contribution to the bottom friction velocity [m s-1] + real :: cd_tides !< Drag coefficient that applies to the tides (nondimensional) + real :: utide !< Constant tidal velocity to use if read_tideamp is false [m s-1]. + logical :: read_tideamp !< If true, spatially varying tidal amplitude read from a file. + + logical :: rigid_sea_ice !< If true, sea-ice exerts a rigidity that acts to damp surface + !! deflections (especially surface gravity waves). The default is false. + real :: Kv_sea_ice !< Viscosity in sea-ice that resists sheared vertical motions [m2 s-1] + real :: density_sea_ice !< Typical density of sea-ice (kg/m^3). The value is only used to convert + !! the ice pressure into appropriate units for use with Kv_sea_ice. + real :: rigid_sea_ice_mass !< A mass per unit area of sea-ice beyond which sea-ice viscosity + !! becomes effective [kg m-2], typically of order 1000 kg m-2. + logical :: allow_flux_adjustments !< If true, use data_override to obtain flux adjustments + + logical :: restore_salt !< If true, the coupled MOM driver adds a term to restore surface + !! salinity to a specified value. + logical :: restore_temp !< If true, the coupled MOM driver adds a term to restore sea + !! surface temperature to a specified value. + real :: Flux_const !< Piston velocity for surface restoring [m s-1] + logical :: salt_restore_as_sflux !< If true, SSS restore as salt flux instead of water flux + logical :: adjust_net_srestore_to_zero !< Adjust srestore to zero (for both salt_flux or vprec) + logical :: adjust_net_srestore_by_scaling !< Adjust srestore w/o moving zero contour + logical :: adjust_net_fresh_water_to_zero !< Adjust net surface fresh-water (with restoring) to zero + logical :: use_net_FW_adjustment_sign_bug !< Use the wrong sign when adjusting net FW + logical :: adjust_net_fresh_water_by_scaling !< Adjust net surface fresh-water w/o moving zero contour + logical :: mask_srestore_under_ice !< If true, use an ice mask defined by frazil criteria + !! for salinity restoring. + real :: ice_salt_concentration !< Salt concentration for sea ice [kg/kg] + logical :: mask_srestore_marginal_seas !< If true, then mask SSS restoring in marginal seas + real :: max_delta_srestore !< Maximum delta salinity used for restoring + real :: max_delta_trestore !< Maximum delta sst used for restoring + real, pointer, dimension(:,:) :: basin_mask => NULL() !< Mask for surface salinity restoring by basin + + type(diag_ctrl), pointer :: diag => NULL() !< Structure to regulate diagnostic output timing + character(len=200) :: inputdir !< Directory where NetCDF input files are + character(len=200) :: salt_restore_file !< Filename for salt restoring data + character(len=30) :: salt_restore_var_name !< Name of surface salinity in salt_restore_file + logical :: mask_srestore !< If true, apply a 2-dimensional mask to the surface + !! salinity restoring fluxes. The masking file should be + !! in inputdir/salt_restore_mask.nc and the field should + !! be named 'mask' + real, pointer, dimension(:,:) :: srestore_mask => NULL() !< mask for SSS restoring + character(len=200) :: temp_restore_file !< Filename for sst restoring data + character(len=30) :: temp_restore_var_name !< Name of surface temperature in temp_restore_file + logical :: mask_trestore !< If true, apply a 2-dimensional mask to the surface + !! temperature restoring fluxes. The masking file should be + !! in inputdir/temp_restore_mask.nc and the field should + !! be named 'mask' + real, pointer, dimension(:,:) :: trestore_mask => NULL() !< Mask for SST restoring + integer :: id_srestore = -1 !< An id number for time_interp_external. + integer :: id_trestore = -1 !< An id number for time_interp_external. + + type(forcing_diags), public :: handles !< Diagnostics handles !### type(ctrl_forcing_CS), pointer :: ctrl_forcing_CSp => NULL() - type(MOM_restart_CS), pointer :: restart_CSp => NULL() - type(user_revise_forcing_CS), pointer :: urf_CS => NULL() + type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< A pointer to the restart control structure + type(user_revise_forcing_CS), pointer :: urf_CS => NULL() !< A control structure for user forcing revisions end type surface_forcing_CS -! ice_ocean_boundary_type is a structure corresponding to forcing, but with -! the elements, units, and conventions that exactly conform to the use for -! MOM-based coupled models. +!> ice_ocean_boundary_type is a structure corresponding to forcing, but with the elements, units, +!! and conventions that exactly conform to the use for MOM6-based coupled models. type, public :: ice_ocean_boundary_type - real, pointer, dimension(:,:) :: u_flux =>NULL() ! i-direction wind stress (Pa) - real, pointer, dimension(:,:) :: v_flux =>NULL() ! j-direction wind stress (Pa) - real, pointer, dimension(:,:) :: t_flux =>NULL() ! sensible heat flux (W/m2) - real, pointer, dimension(:,:) :: q_flux =>NULL() ! specific humidity flux (kg/m2/s) - real, pointer, dimension(:,:) :: salt_flux =>NULL() ! salt flux (kg/m2/s) - real, pointer, dimension(:,:) :: lw_flux =>NULL() ! long wave radiation (W/m2) - real, pointer, dimension(:,:) :: sw_flux_vis_dir =>NULL() ! direct visible sw radiation (W/m2) - real, pointer, dimension(:,:) :: sw_flux_vis_dif =>NULL() ! diffuse visible sw radiation (W/m2) - real, pointer, dimension(:,:) :: sw_flux_nir_dir =>NULL() ! direct Near InfraRed sw radiation (W/m2) - real, pointer, dimension(:,:) :: sw_flux_nir_dif =>NULL() ! diffuse Near InfraRed sw radiation (W/m2) - real, pointer, dimension(:,:) :: lprec =>NULL() ! mass flux of liquid precip (kg/m2/s) - real, pointer, dimension(:,:) :: fprec =>NULL() ! mass flux of frozen precip (kg/m2/s) - real, pointer, dimension(:,:) :: runoff =>NULL() ! mass flux of liquid runoff (kg/m2/s) - real, pointer, dimension(:,:) :: calving =>NULL() ! mass flux of frozen runoff (kg/m2/s) - real, pointer, dimension(:,:) :: ustar_berg =>NULL() ! frictional velocity beneath icebergs (m/s) - real, pointer, dimension(:,:) :: area_berg =>NULL() ! area covered by icebergs(m2/m2) - real, pointer, dimension(:,:) :: mass_berg =>NULL() ! mass of icebergs(kg/m2) - real, pointer, dimension(:,:) :: runoff_hflx =>NULL() ! heat content of liquid runoff (W/m2) - real, pointer, dimension(:,:) :: calving_hflx =>NULL() ! heat content of frozen runoff (W/m2) - real, pointer, dimension(:,:) :: p =>NULL() ! pressure of overlying ice and atmosphere - ! on ocean surface (Pa) - real, pointer, dimension(:,:) :: mi =>NULL() ! mass of ice (kg/m2) - integer :: xtype ! REGRID, REDIST or DIRECT - type(coupler_2d_bc_type) :: fluxes ! A structure that may contain an - ! array of named fields used for - ! passive tracer fluxes. - integer :: wind_stagger = -999 ! A flag indicating the spatial discretization of - ! wind stresses. This flag may be set by the - ! flux-exchange code, based on what the sea-ice - ! model is providing. Otherwise, the value from - ! the surface_forcing_CS is used. + real, pointer, dimension(:,:) :: u_flux =>NULL() !< i-direction wind stress [Pa] + real, pointer, dimension(:,:) :: v_flux =>NULL() !< j-direction wind stress [Pa] + real, pointer, dimension(:,:) :: t_flux =>NULL() !< sensible heat flux [W m-2] + real, pointer, dimension(:,:) :: q_flux =>NULL() !< specific humidity flux [kg m-2 s-1] + real, pointer, dimension(:,:) :: salt_flux =>NULL() !< salt flux [kg m-2 s-1] + real, pointer, dimension(:,:) :: lw_flux =>NULL() !< long wave radiation [W m-2] + real, pointer, dimension(:,:) :: sw_flux_vis_dir =>NULL() !< direct visible sw radiation [W m-2] + real, pointer, dimension(:,:) :: sw_flux_vis_dif =>NULL() !< diffuse visible sw radiation [W m-2] + real, pointer, dimension(:,:) :: sw_flux_nir_dir =>NULL() !< direct Near InfraRed sw radiation [W m-2] + real, pointer, dimension(:,:) :: sw_flux_nir_dif =>NULL() !< diffuse Near InfraRed sw radiation [W m-2] + real, pointer, dimension(:,:) :: lprec =>NULL() !< mass flux of liquid precip [kg m-2 s-1] + real, pointer, dimension(:,:) :: fprec =>NULL() !< mass flux of frozen precip [kg m-2 s-1] + real, pointer, dimension(:,:) :: runoff =>NULL() !< mass flux of liquid runoff [kg m-2 s-1] + real, pointer, dimension(:,:) :: calving =>NULL() !< mass flux of frozen runoff [kg m-2 s-1] + real, pointer, dimension(:,:) :: stress_mag =>NULL() !< The time-mean magnitude of the stress on the ocean [Pa] + real, pointer, dimension(:,:) :: ustar_berg =>NULL() !< frictional velocity beneath icebergs [m s-1] + real, pointer, dimension(:,:) :: area_berg =>NULL() !< fractional area covered by icebergs [m2 m-2] + real, pointer, dimension(:,:) :: mass_berg =>NULL() !< mass of icebergs per unit ocean area [kg m-2] + real, pointer, dimension(:,:) :: runoff_hflx =>NULL() !< heat content of liquid runoff [W m-2] + real, pointer, dimension(:,:) :: calving_hflx =>NULL() !< heat content of frozen runoff [W m-2] + real, pointer, dimension(:,:) :: p =>NULL() !< pressure of overlying ice and atmosphere + !< on ocean surface [Pa] + real, pointer, dimension(:,:) :: mi =>NULL() !< mass of ice per unit ocean area [kg m-2] + real, pointer, dimension(:,:) :: ice_rigidity =>NULL() !< rigidity of the sea ice, sea-ice and + !! ice-shelves, expressed as a coefficient + !! for divergence damping, as determined + !! outside of the ocean model [m3 s-1] + integer :: xtype !< The type of the exchange - REGRID, REDIST or DIRECT + type(coupler_2d_bc_type) :: fluxes !< A structure that may contain an array of named fields + !! used for passive tracer fluxes. + integer :: wind_stagger = -999 !< A flag indicating the spatial discretization of wind stresses. + !! This flag may be set by the flux-exchange code, based on what + !! the sea-ice model is providing. Otherwise, the value from + !! the surface_forcing_CS is used. end type ice_ocean_boundary_type -integer :: id_clock_forcing +integer :: id_clock_forcing !< A CPU time clock contains -subroutine convert_IOB_to_fluxes(IOB, forces, fluxes, index_bounds, Time, G, CS, & - sfc_state, restore_salt, restore_temp) +!> This subroutine translates the Ice_ocean_boundary_type into a MOM +!! thermodynamic forcing type, including changes of units, sign conventions, +!! and putting the fields into arrays with MOM-standard halos. +subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, US, CS, sfc_state) type(ice_ocean_boundary_type), & target, intent(in) :: IOB !< An ice-ocean boundary type with fluxes to drive !! the ocean in a coupled model - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(forcing), intent(inout) :: fluxes !< A structure containing pointers to - !! all possible mass, heat or salt flux forcing fields. + type(forcing), intent(inout) :: fluxes !< A structure containing pointers to all + !! possible mass, heat or salt flux forcing fields. !! Unused fields have NULL ptrs. integer, dimension(4), intent(in) :: index_bounds !< The i- and j- size of the arrays in IOB. type(time_type), intent(in) :: Time !< The time of the fluxes, used for interpolating the !! salinity to the right time, when it is being restored. type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(surface_forcing_CS),pointer :: CS !< A pointer to the control structure returned by a !! previous call to surface_forcing_init. type(surface), intent(in) :: sfc_state !< A structure containing fields that describe the !! surface state of the ocean. - logical, optional, intent(in) :: restore_salt, restore_temp - -! This subroutine translates the Ice_ocean_boundary_type into a -! MOM forcing type, including changes of units, sign conventions, -! and puting the fields into arrays with MOM-standard halos. - -! Arguments: -! IOB ice-ocean boundary type w/ fluxes to drive ocean in a coupled model -! (out) fluxes - A structure containing pointers to any possible -! forcing fields. Unused fields have NULL ptrs. -! (in) index_bounds - the i- and j- size of the arrays in IOB. -! (in) Time - The time of the fluxes, used for interpolating the salinity -! to the right time, when it is being restored. -! (in) G - The ocean's grid structure. -! (in) CS - A pointer to the control structure returned by a previous -! call to surface_forcing_init. -! (in) state - A structure containing fields that describe the -! surface state of the ocean. -! (in) restore_salt - if true, salinity is restored to a target value. -! (in) restore_temp - if true, temperature is restored to a target value. - - real, dimension(SZIB_(G),SZJB_(G)) :: & - taux_at_q, & ! Zonal wind stresses at q points (Pa) - tauy_at_q ! Meridional wind stresses at q points (Pa) real, dimension(SZI_(G),SZJ_(G)) :: & - taux_at_h, & ! Zonal wind stresses at h points (Pa) - tauy_at_h, & ! Meridional wind stresses at h points (Pa) - data_restore, & ! The surface value toward which to restore (g/kg or degC) - SST_anom, & ! Instantaneous sea surface temperature anomalies from a target value (deg C) - SSS_anom, & ! Instantaneous sea surface salinity anomalies from a target value (g/kg) + data_restore, & ! The surface value toward which to restore [ppt] or [degC] + SST_anom, & ! Instantaneous sea surface temperature anomalies from a target value [degC] + SSS_anom, & ! Instantaneous sea surface salinity anomalies from a target value [ppt] SSS_mean, & ! A (mean?) salinity about which to normalize local salinity - ! anomalies when calculating restorative precipitation anomalies (g/kg) + ! anomalies when calculating restorative precipitation anomalies [ppt] PmE_adj, & ! The adjustment to PminusE that will cause the salinity - ! to be restored toward its target value (kg/(m^2 * s)) - net_FW, & ! The area integrated net freshwater flux into the ocean (kg/s) - net_FW2, & ! The area integrated net freshwater flux into the ocean (kg/s) - work_sum, & ! A 2-d array that is used as the work space for a global - ! sum, used with units of m2 or (kg/s) - open_ocn_mask ! a binary field indicating where ice is present based on frazil criteria - - real :: gustiness ! unresolved gustiness that contributes to ustar (Pa) - real :: Irho0 ! inverse of the mean density in (m^3/kg) - real :: taux2, tauy2 ! squared wind stresses (Pa^2) - real :: tau_mag ! magnitude of the wind stress (Pa) - real :: I_GEarth ! 1.0 / G%G_Earth (s^2/m) - real :: Kv_rho_ice ! (CS%kv_sea_ice / CS%density_sea_ice) ( m^5/(s*kg) ) - real :: mass_ice ! mass of sea ice at a face (kg/m^2) - real :: mass_eff ! effective mass of sea ice for rigidity (kg/m^2) + ! to be restored toward its target value [kg m-1 s-1] + net_FW, & ! The area integrated net freshwater flux into the ocean [kg s-1] + net_FW2, & ! The area integrated net freshwater flux into the ocean [kg s-1] + work_sum, & ! A 2-d array that is used as the work space for global sums [m2] or [kg s-1] + open_ocn_mask ! a binary field indicating where ice is present based on frazil criteria [nondim] - integer :: wind_stagger ! AGRID, BGRID_NE, or CGRID_NE (integers from MOM_domains) integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq, i0, j0 integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, isr, ier, jsr, jer integer :: isc_bnd, iec_bnd, jsc_bnd, jec_bnd - logical :: restore_salinity ! local copy of the argument restore_salt, if it - ! is present, or false (no restoring) otherwise. - logical :: restore_sst ! local copy of the argument restore_temp, if it - ! is present, or false (no restoring) otherwise. - real :: delta_sss ! temporary storage for sss diff from restoring value - real :: delta_sst ! temporary storage for sst diff from restoring value + real :: delta_sss ! temporary storage for sss diff from restoring value [ppt] + real :: delta_sst ! temporary storage for sst diff from restoring value [degC] - real :: C_p ! heat capacity of seawater ( J/(K kg) ) + real :: C_p ! heat capacity of seawater [J degC-1 kg-1] real :: sign_for_net_FW_bug ! Should be +1. but an old bug can be recovered by using -1. call cpu_clock_begin(id_clock_forcing) @@ -282,7 +251,6 @@ subroutine convert_IOB_to_fluxes(IOB, forces, fluxes, index_bounds, Time, G, CS, isr = is-isd+1 ; ier = ie-isd+1 ; jsr = js-jsd+1 ; jer = je-jsd+1 C_p = fluxes%C_p - Irho0 = 1.0/CS%Rho0 open_ocn_mask(:,:) = 1.0 pme_adj(:,:) = 0.0 fluxes%vPrecGlobalAdj = 0.0 @@ -292,18 +260,11 @@ subroutine convert_IOB_to_fluxes(IOB, forces, fluxes, index_bounds, Time, G, CS, fluxes%netFWGlobalAdj = 0.0 fluxes%netFWGlobalScl = 0.0 - restore_salinity = .false. - if (present(restore_salt)) restore_salinity = restore_salt - restore_sst = .false. - if (present(restore_temp)) restore_sst = restore_temp - ! allocation and initialization if this is the first time that this ! flux type has been used. if (fluxes%dt_buoy_accum < 0) then call allocate_forcing_type(G, fluxes, water=.true., heat=.true., & ustar=.true., press=.true.) - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., & - press=.true.) call safe_alloc_ptr(fluxes%sw_vis_dir,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%sw_vis_dif,isd,ied,jsd,jed) @@ -312,6 +273,11 @@ subroutine convert_IOB_to_fluxes(IOB, forces, fluxes, index_bounds, Time, G, CS, call safe_alloc_ptr(fluxes%p_surf,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%p_surf_full,isd,ied,jsd,jed) + if (CS%use_limited_P_SSH) then + fluxes%p_surf_SSH => fluxes%p_surf + else + fluxes%p_surf_SSH => fluxes%p_surf_full + endif call safe_alloc_ptr(fluxes%salt_flux,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%salt_flux_in,isd,ied,jsd,jed) @@ -328,21 +294,19 @@ subroutine convert_IOB_to_fluxes(IOB, forces, fluxes, index_bounds, Time, G, CS, do j=js-2,je+2 ; do i=is-2,ie+2 fluxes%TKE_tidal(i,j) = CS%TKE_tidal(i,j) fluxes%ustar_tidal(i,j) = CS%ustar_tidal(i,j) - enddo; enddo - - call safe_alloc_ptr(forces%p_surf,isd,ied,jsd,jed) - call safe_alloc_ptr(forces%p_surf_full,isd,ied,jsd,jed) - - if (CS%rigid_sea_ice) then - call safe_alloc_ptr(forces%rigidity_ice_u,IsdB,IedB,jsd,jed) - call safe_alloc_ptr(forces%rigidity_ice_v,isd,ied,JsdB,JedB) - endif + enddo ; enddo - if (restore_temp) call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) + if (CS%restore_temp) call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) fluxes%dt_buoy_accum = 0.0 endif ! endif for allocation and initialization + + if (((associated(IOB%ustar_berg) .and. (.not.associated(fluxes%ustar_berg))) & + .or. (associated(IOB%area_berg) .and. (.not.associated(fluxes%area_berg)))) & + .or. (associated(IOB%mass_berg) .and. (.not.associated(fluxes%mass_berg)))) & + call allocate_forcing_type(G, fluxes, iceberg=.true.) + if ((.not.coupler_type_initialized(fluxes%tr_fluxes)) .and. & coupler_type_initialized(IOB%fluxes)) & call coupler_type_spawn(IOB%fluxes, fluxes%tr_fluxes, & @@ -351,10 +315,9 @@ subroutine convert_IOB_to_fluxes(IOB, forces, fluxes, index_bounds, Time, G, CS, ! ocean model, rather than using haloless arrays, in which case the last line ! would be: ( (/isd,is,ie,ied/), (/jsd,js,je,jed/)) - if (CS%allow_flux_adjustments) then - fluxes%heat_added(:,:)=0.0 - fluxes%salt_flux_added(:,:)=0.0 + fluxes%heat_added(:,:)=0.0 + fluxes%salt_flux_added(:,:)=0.0 endif ! allocation and initialization on first call to this routine @@ -371,14 +334,14 @@ subroutine convert_IOB_to_fluxes(IOB, forces, fluxes, index_bounds, Time, G, CS, enddo ; enddo ! Salinity restoring logic - if (restore_salinity) then + if (CS%restore_salt) then call time_interp_external(CS%id_srestore,Time,data_restore) ! open_ocn_mask indicates where to restore salinity (1 means restore, 0 does not) open_ocn_mask(:,:) = 1.0 if (CS%mask_srestore_under_ice) then ! Do not restore under sea-ice do j=js,je ; do i=is,ie - if (sfc_state%SST(i,j) .le. -0.0539*sfc_state%SSS(i,j)) open_ocn_mask(i,j)=0.0 - enddo; enddo + if (sfc_state%SST(i,j) <= -0.0539*sfc_state%SSS(i,j)) open_ocn_mask(i,j)=0.0 + enddo ; enddo endif if (CS%salt_restore_as_sflux) then do j=js,je ; do i=is,ie @@ -386,7 +349,7 @@ subroutine convert_IOB_to_fluxes(IOB, forces, fluxes, index_bounds, Time, G, CS, delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) fluxes%salt_flux(i,j) = 1.e-3*G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)* & (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j)) *delta_sss ! kg Salt m-2 s-1 - enddo; enddo + enddo ; enddo if (CS%adjust_net_srestore_to_zero) then if (CS%adjust_net_srestore_by_scaling) then call adjust_area_mean_to_zero(fluxes%salt_flux, G, fluxes%saltFluxGlobalScl) @@ -407,7 +370,7 @@ subroutine convert_IOB_to_fluxes(IOB, forces, fluxes, index_bounds, Time, G, CS, (CS%Rho0*CS%Flux_const) * & delta_sss / (0.5*(sfc_state%SSS(i,j) + data_restore(i,j))) endif - enddo; enddo + enddo ; enddo if (CS%adjust_net_srestore_to_zero) then if (CS%adjust_net_srestore_by_scaling) then call adjust_area_mean_to_zero(fluxes%vprec, G, fluxes%vPrecGlobalScl) @@ -417,32 +380,21 @@ subroutine convert_IOB_to_fluxes(IOB, forces, fluxes, index_bounds, Time, G, CS, fluxes%vPrecGlobalAdj = reproducing_sum(work_sum(:,:), isr, ier, jsr, jer) / CS%area_surf do j=js,je ; do i=is,ie fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - fluxes%vPrecGlobalAdj ) * G%mask2dT(i,j) - enddo; enddo + enddo ; enddo endif endif endif endif ! SST restoring logic - if (restore_sst) then + if (CS%restore_temp) then call time_interp_external(CS%id_trestore,Time,data_restore) do j=js,je ; do i=is,ie - delta_sst = data_restore(i,j)- sfc_state%SST(i,j) - delta_sst = sign(1.0,delta_sst)*min(abs(delta_sst),CS%max_delta_trestore) - fluxes%heat_added(i,j) = G%mask2dT(i,j) * CS%trestore_mask(i,j) * (CS%Rho0*fluxes%C_p) * delta_sst * CS%Flux_const ! W m-2 - enddo; enddo - endif - - wind_stagger = CS%wind_stagger - if ((IOB%wind_stagger == AGRID) .or. (IOB%wind_stagger == BGRID_NE) .or. & - (IOB%wind_stagger == CGRID_NE)) wind_stagger = IOB%wind_stagger - if (wind_stagger == BGRID_NE) then - ! This is necessary to fill in the halo points. - taux_at_q(:,:) = 0.0 ; tauy_at_q(:,:) = 0.0 - endif - if (wind_stagger == AGRID) then - ! This is necessary to fill in the halo points. - taux_at_h(:,:) = 0.0 ; tauy_at_h(:,:) = 0.0 + delta_sst = data_restore(i,j)- sfc_state%SST(i,j) + delta_sst = sign(1.0,delta_sst)*min(abs(delta_sst),CS%max_delta_trestore) + fluxes%heat_added(i,j) = G%mask2dT(i,j) * CS%trestore_mask(i,j) * & + (CS%Rho0*fluxes%C_p) * delta_sst * CS%Flux_const ! W m-2 + enddo ; enddo endif @@ -450,17 +402,6 @@ subroutine convert_IOB_to_fluxes(IOB, forces, fluxes, index_bounds, Time, G, CS, i0 = is - isc_bnd ; j0 = js - jsc_bnd do j=js,je ; do i=is,ie - if (wind_stagger == BGRID_NE) then - if (associated(IOB%u_flux)) taux_at_q(I,J) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier - if (associated(IOB%v_flux)) tauy_at_q(I,J) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier - elseif (wind_stagger == AGRID) then - if (associated(IOB%u_flux)) taux_at_h(i,j) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier - if (associated(IOB%v_flux)) tauy_at_h(i,j) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier - else ! C-grid wind stresses. - if (associated(IOB%u_flux)) forces%taux(I,j) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier - if (associated(IOB%v_flux)) forces%tauy(i,J) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier - endif - if (associated(IOB%lprec)) & fluxes%lprec(i,j) = IOB%lprec(i-i0,j-j0) * G%mask2dT(i,j) @@ -476,13 +417,8 @@ subroutine convert_IOB_to_fluxes(IOB, forces, fluxes, index_bounds, Time, G, CS, if (associated(IOB%calving)) & fluxes%frunoff(i,j) = IOB%calving(i-i0,j-j0) * G%mask2dT(i,j) - if (((associated(IOB%ustar_berg) .and. (.not. associated(fluxes%ustar_berg))) & - .or. (associated(IOB%area_berg) .and. (.not. associated(fluxes%area_berg)))) & - .or. (associated(IOB%mass_berg) .and. (.not. associated(fluxes%mass_berg)))) & - call allocate_forcing_type(G, fluxes, iceberg=.true.) - if (associated(IOB%ustar_berg)) & - fluxes%ustar_berg(i,j) = IOB%ustar_berg(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%ustar_berg(i,j) = US%m_to_Z * IOB%ustar_berg(i-i0,j-j0) * G%mask2dT(i,j) if (associated(IOB%area_berg)) & fluxes%area_berg(i,j) = IOB%area_berg(i-i0,j-j0) * G%mask2dT(i,j) @@ -531,6 +467,22 @@ subroutine convert_IOB_to_fluxes(IOB, forces, fluxes, index_bounds, Time, G, CS, enddo ; enddo + ! applied surface pressure from atmosphere and cryosphere + if (associated(IOB%p)) then + if (CS%max_p_surf >= 0.0) then + do j=js,je ; do i=is,ie + fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * IOB%p(i-i0,j-j0) + fluxes%p_surf(i,j) = MIN(fluxes%p_surf_full(i,j),CS%max_p_surf) + enddo ; enddo + else + do j=js,je ; do i=is,ie + fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * IOB%p(i-i0,j-j0) + fluxes%p_surf(i,j) = fluxes%p_surf_full(i,j) + enddo ; enddo + endif + fluxes%accumulate_p_surf = .true. ! Multiple components may contribute to surface pressure. + endif + ! more salt restoring logic if (associated(IOB%salt_flux)) then do j=js,je ; do i=is,ie @@ -573,14 +525,141 @@ subroutine convert_IOB_to_fluxes(IOB, forces, fluxes, index_bounds, Time, G, CS, call adjust_area_mean_to_zero(net_FW2, G, fluxes%netFWGlobalScl) do j=js,je ; do i=is,ie fluxes%vprec(i,j) = fluxes%vprec(i,j) + (net_FW2(i,j) - net_FW(i,j)/G%areaT(i,j)) * G%mask2dT(i,j) - enddo; enddo + enddo ; enddo else fluxes%netFWGlobalAdj = reproducing_sum(net_FW(:,:), isr, ier, jsr, jer) / CS%area_surf do j=js,je ; do i=is,ie fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - fluxes%netFWGlobalAdj ) * G%mask2dT(i,j) - enddo; enddo + enddo ; enddo + endif + + endif + + ! Set the wind stresses and ustar. + if (associated(fluxes%ustar) .and. associated(fluxes%ustar_gustless)) then + call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, ustar=fluxes%ustar, & + gustless_ustar=fluxes%ustar_gustless) + elseif (associated(fluxes%ustar)) then + call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, ustar=fluxes%ustar) + elseif (associated(fluxes%ustar_gustless)) then + call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, gustless_ustar=fluxes%ustar_gustless) + endif + + if (coupler_type_initialized(fluxes%tr_fluxes) .and. & + coupler_type_initialized(IOB%fluxes)) & + call coupler_type_copy_data(IOB%fluxes, fluxes%tr_fluxes) + + if (CS%allow_flux_adjustments) then + ! Apply adjustments to fluxes + call apply_flux_adjustments(G, CS, Time, fluxes) + endif + + ! Allow for user-written code to alter fluxes after all the above + call user_alter_forcing(sfc_state, fluxes, Time, G, CS%urf_CS) + + call cpu_clock_end(id_clock_forcing) + +end subroutine convert_IOB_to_fluxes + +!> This subroutine translates the Ice_ocean_boundary_type into a MOM +!! mechanical forcing type, including changes of units, sign conventions, +!! and putting the fields into arrays with MOM-standard halos. +subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_forcing, reset_avg) + type(ice_ocean_boundary_type), & + target, intent(in) :: IOB !< An ice-ocean boundary type with fluxes to drive + !! the ocean in a coupled model + type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces + integer, dimension(4), intent(in) :: index_bounds !< The i- and j- size of the arrays in IOB. + type(time_type), intent(in) :: Time !< The time of the fluxes, used for interpolating the + !! salinity to the right time, when it is being restored. + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(surface_forcing_CS),pointer :: CS !< A pointer to the control structure returned by a + !! previous call to surface_forcing_init. + real, optional, intent(in) :: dt_forcing !< A time interval over which to apply the + !! current value of ustar as a weighted running + !! average [s], or if 0 do not average ustar. + !! Missing is equivalent to 0. + logical, optional, intent(in) :: reset_avg !< If true, reset the time average. + + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: & + rigidity_at_h, & ! Ice rigidity at tracer points [m3 s-1] + net_mass_src, & ! A temporary of net mass sources [kg m-2 s-1]. + ustar_tmp ! A temporary array of ustar values [m s-1]. + + real :: I_GEarth ! 1.0 / G%G_Earth [s2 m-1] + real :: Kv_rho_ice ! (CS%kv_sea_ice / CS%density_sea_ice) [m5 s-1 kg-1] + real :: mass_ice ! mass of sea ice at a face [kg m-2] + real :: mass_eff ! effective mass of sea ice for rigidity [kg m-2] + real :: wt1, wt2 ! Relative weights of previous and current values of ustar, ND. + + integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq, i0, j0 + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, isr, ier, jsr, jer + integer :: isc_bnd, iec_bnd, jsc_bnd, jec_bnd + + call cpu_clock_begin(id_clock_forcing) + + isc_bnd = index_bounds(1) ; iec_bnd = index_bounds(2) + jsc_bnd = index_bounds(3) ; jec_bnd = index_bounds(4) + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + isr = is-isd+1 ; ier = ie-isd+1 ; jsr = js-jsd+1 ; jer = je-jsd+1 + i0 = is - isc_bnd ; j0 = js - jsc_bnd + + ! allocation and initialization if this is the first time that this + ! mechanical forcing type has been used. + if (.not.forces%initialized) then + call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., & + press=.true.) + + call safe_alloc_ptr(forces%p_surf,isd,ied,jsd,jed) + call safe_alloc_ptr(forces%p_surf_full,isd,ied,jsd,jed) + if (CS%use_limited_P_SSH) then + forces%p_surf_SSH => forces%p_surf + else + forces%p_surf_SSH => forces%p_surf_full + endif + + if (CS%rigid_sea_ice) then + call safe_alloc_ptr(forces%rigidity_ice_u,IsdB,IedB,jsd,jed) + call safe_alloc_ptr(forces%rigidity_ice_v,isd,ied,JsdB,JedB) endif + forces%initialized = .true. + endif + + if ( (associated(IOB%area_berg) .and. (.not. associated(forces%area_berg))) .or. & + (associated(IOB%mass_berg) .and. (.not. associated(forces%mass_berg))) ) & + call allocate_mech_forcing(G, forces, iceberg=.true.) + + if (associated(IOB%ice_rigidity)) then + rigidity_at_h(:,:) = 0.0 + call safe_alloc_ptr(forces%rigidity_ice_u,IsdB,IedB,jsd,jed) + call safe_alloc_ptr(forces%rigidity_ice_v,isd,ied,JsdB,JedB) + endif + + forces%accumulate_rigidity = .true. ! Multiple components may contribute to rigidity. + if (associated(forces%rigidity_ice_u)) forces%rigidity_ice_u(:,:) = 0.0 + if (associated(forces%rigidity_ice_v)) forces%rigidity_ice_v(:,:) = 0.0 + + ! Set the weights for forcing fields that use running time averages. + if (present(reset_avg)) then ; if (reset_avg) forces%dt_force_accum = 0.0 ; endif + wt1 = 0.0 ; wt2 = 1.0 + if (present(dt_forcing)) then + if ((forces%dt_force_accum > 0.0) .and. (dt_forcing > 0.0)) then + wt1 = forces%dt_force_accum / (forces%dt_force_accum + dt_forcing) + wt2 = 1.0 - wt1 + endif + if (dt_forcing > 0.0) then + forces%dt_force_accum = max(forces%dt_force_accum, 0.0) + dt_forcing + else + forces%dt_force_accum = 0.0 ! Reset the averaging time interval. + endif + else + forces%dt_force_accum = 0.0 ! Reset the averaging time interval. endif ! applied surface pressure from atmosphere and cryosphere @@ -596,170 +675,354 @@ subroutine convert_IOB_to_fluxes(IOB, forces, fluxes, index_bounds, Time, G, CS, forces%p_surf(i,j) = forces%p_surf_full(i,j) enddo ; enddo endif - if (CS%use_limited_P_SSH) then - forces%p_surf_SSH => forces%p_surf - else - forces%p_surf_SSH => forces%p_surf_full - endif - endif - - ! surface momentum stress related fields as function of staggering - if (wind_stagger == BGRID_NE) then - if (G%symmetric) & - call fill_symmetric_edges(taux_at_q, tauy_at_q, G%Domain, stagger=BGRID_NE) - call pass_vector(taux_at_q, tauy_at_q, G%Domain, stagger=BGRID_NE) - - do j=js,je ; do I=Isq,Ieq - forces%taux(I,j) = 0.0 - if ((G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) > 0) & - forces%taux(I,j) = (G%mask2dBu(I,J)*taux_at_q(I,J) + & - G%mask2dBu(I,J-1)*taux_at_q(I,J-1)) / & - (G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) - enddo ; enddo - - do J=Jsq,Jeq ; do i=is,ie - forces%tauy(i,J) = 0.0 - if ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) > 0) & - forces%tauy(i,J) = (G%mask2dBu(I,J)*tauy_at_q(I,J) + & - G%mask2dBu(I-1,J)*tauy_at_q(I-1,J)) / & - (G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) + else + do j=js,je ; do i=is,ie + forces%p_surf_full(i,j) = 0.0 + forces%p_surf(i,j) = 0.0 enddo ; enddo + endif + forces%accumulate_p_surf = .true. ! Multiple components may contribute to surface pressure. - ! ustar is required for the bulk mixed layer formulation. The background value - ! of 0.02 Pa is a relatively small value intended to give reasonable behavior - ! in regions of very weak winds. - + ! Set the wind stresses and ustar. + if (wt1 <= 0.0) then + call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux=forces%taux, tauy=forces%tauy, & + ustar=forces%ustar, tau_halo=1) + else + call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux=forces%taux, tauy=forces%tauy, & + ustar=ustar_tmp, tau_halo=1) do j=js,je ; do i=is,ie - tau_mag = 0.0 ; gustiness = CS%gust_const - if (((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + & - (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0) then - tau_mag = sqrt(((G%mask2dBu(I,J)*(taux_at_q(I,J)**2 + tauy_at_q(I,J)**2) + & - G%mask2dBu(I-1,J-1)*(taux_at_q(I-1,J-1)**2 + tauy_at_q(I-1,J-1)**2)) + & - (G%mask2dBu(I,J-1)*(taux_at_q(I,J-1)**2 + tauy_at_q(I,J-1)**2) + & - G%mask2dBu(I-1,J)*(taux_at_q(I-1,J)**2 + tauy_at_q(I-1,J)**2)) ) / & - ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) ) - if (CS%read_gust_2d) gustiness = CS%gust(i,j) - endif - forces%ustar(i,j) = sqrt(gustiness*Irho0 + Irho0*tau_mag) + forces%ustar(i,j) = wt1*forces%ustar(i,j) + wt2*ustar_tmp(i,j) enddo ; enddo + endif - elseif (wind_stagger == AGRID) then - call pass_vector(taux_at_h, tauy_at_h, G%Domain,stagger=AGRID) + ! Find the net mass source in the input forcing without other adjustments. + if (CS%approx_net_mass_src .and. associated(forces%net_mass_src)) then + net_mass_src(:,:) = 0.0 + i0 = is - isc_bnd ; j0 = js - jsc_bnd + do j=js,je ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then + if (associated(IOB%lprec)) & + net_mass_src(i,j) = net_mass_src(i,j) + IOB%lprec(i-i0,j-j0) + if (associated(IOB%fprec)) & + net_mass_src(i,j) = net_mass_src(i,j) + IOB%fprec(i-i0,j-j0) + if (associated(IOB%runoff)) & + net_mass_src(i,j) = net_mass_src(i,j) + IOB%runoff(i-i0,j-j0) + if (associated(IOB%calving)) & + net_mass_src(i,j) = net_mass_src(i,j) + IOB%calving(i-i0,j-j0) + if (associated(IOB%q_flux)) & + net_mass_src(i,j) = net_mass_src(i,j) - IOB%q_flux(i-i0,j-j0) + endif ; enddo ; enddo + if (wt1 <= 0.0) then + do j=js,je ; do i=is,ie + forces%net_mass_src(i,j) = wt2*net_mass_src(i,j) + enddo ; enddo + else + do j=js,je ; do i=is,ie + forces%net_mass_src(i,j) = wt1*forces%net_mass_src(i,j) + wt2*net_mass_src(i,j) + enddo ; enddo + endif + forces%net_mass_src_set = .true. + else + forces%net_mass_src_set = .false. + endif - do j=js,je ; do I=Isq,Ieq - forces%taux(I,j) = 0.0 - if ((G%mask2dT(i,j) + G%mask2dT(i+1,j)) > 0) & - forces%taux(I,j) = (G%mask2dT(i,j)*taux_at_h(i,j) + & - G%mask2dT(i+1,j)*taux_at_h(i+1,j)) / & - (G%mask2dT(i,j) + G%mask2dT(i+1,j)) - enddo ; enddo + ! Obtain optional ice-berg related fluxes from the IOB type: + if (associated(IOB%area_berg)) then ; do j=js,je ; do i=is,ie + forces%area_berg(i,j) = IOB%area_berg(i-i0,j-j0) * G%mask2dT(i,j) + enddo ; enddo ; endif - do J=Jsq,Jeq ; do i=is,ie - forces%tauy(i,J) = 0.0 - if ((G%mask2dT(i,j) + G%mask2dT(i,j+1)) > 0) & - forces%tauy(i,J) = (G%mask2dT(i,j)*tauy_at_h(i,j) + & - G%mask2dT(i,J+1)*tauy_at_h(i,j+1)) / & - (G%mask2dT(i,j) + G%mask2dT(i,j+1)) - enddo ; enddo + if (associated(IOB%mass_berg)) then ; do j=js,je ; do i=is,ie + forces%mass_berg(i,j) = IOB%mass_berg(i-i0,j-j0) * G%mask2dT(i,j) + enddo ; enddo ; endif + ! Obtain sea ice related dynamic fields + if (associated(IOB%ice_rigidity)) then do j=js,je ; do i=is,ie - gustiness = CS%gust_const - if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0)) gustiness = CS%gust(i,j) - forces%ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * G%mask2dT(i,j) * & - sqrt(taux_at_h(i,j)**2 + tauy_at_h(i,j)**2)) + rigidity_at_h(i,j) = IOB%ice_rigidity(i-i0,j-j0) * G%mask2dT(i,j) enddo ; enddo - - else ! C-grid wind stresses. - if (G%symmetric) & - call fill_symmetric_edges(forces%taux, forces%tauy, G%Domain) - call pass_vector(forces%taux, forces%tauy, G%Domain) - - do j=js,je ; do i=is,ie - taux2 = 0.0 - if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0) & - taux2 = (G%mask2dCu(I-1,j)*forces%taux(I-1,j)**2 + & - G%mask2dCu(I,j)*forces%taux(I,j)**2) / (G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) - - tauy2 = 0.0 - if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0) & - tauy2 = (G%mask2dCv(i,J-1)*forces%tauy(i,J-1)**2 + & - G%mask2dCv(i,J)*forces%tauy(i,J)**2) / (G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) - - if (CS%read_gust_2d) then - forces%ustar(i,j) = sqrt(CS%gust(i,j)*Irho0 + Irho0*sqrt(taux2 + tauy2)) - else - forces%ustar(i,j) = sqrt(CS%gust_const*Irho0 + Irho0*sqrt(taux2 + tauy2)) - endif + call pass_var(rigidity_at_h, G%Domain, halo=1) + do I=is-1,ie ; do j=js,je + forces%rigidity_ice_u(I,j) = forces%rigidity_ice_u(I,j) + & + min(rigidity_at_h(i,j), rigidity_at_h(i+1,j)) enddo ; enddo + do i=is,ie ; do J=js-1,je + forces%rigidity_ice_v(i,J) = forces%rigidity_ice_v(i,J) + & + min(rigidity_at_h(i,j), rigidity_at_h(i,j+1)) + enddo ; enddo + endif - endif ! endif for wind related fields - - - ! sea ice related fields if (CS%rigid_sea_ice) then - ! The commented out code here and in the following lines is the correct - ! version, but the incorrect version is being retained temporarily to avoid - ! changing answers. - call pass_var(forces%p_surf_full, G%Domain) + call pass_var(forces%p_surf_full, G%Domain, halo=1) I_GEarth = 1.0 / G%G_Earth Kv_rho_ice = (CS%kv_sea_ice / CS%density_sea_ice) - do I=isd,ied-1 ; do j=jsd,jed + do I=is-1,ie ; do j=js,je mass_ice = min(forces%p_surf_full(i,j), forces%p_surf_full(i+1,j)) * I_GEarth mass_eff = 0.0 if (mass_ice > CS%rigid_sea_ice_mass) then mass_eff = (mass_ice - CS%rigid_sea_ice_mass) **2 / & (mass_ice + CS%rigid_sea_ice_mass) endif - ! CAUTION: with both rigid_sea_ice and ice shelves, we will need to make this - ! a maximum for the second call. - forces%rigidity_ice_u(I,j) = Kv_rho_ice * mass_eff + forces%rigidity_ice_u(I,j) = forces%rigidity_ice_u(I,j) + Kv_rho_ice * mass_eff enddo ; enddo - do i=isd,ied ; do J=jsd,jed-1 + do i=is,ie ; do J=js-1,je mass_ice = min(forces%p_surf_full(i,j), forces%p_surf_full(i,j+1)) * I_GEarth mass_eff = 0.0 if (mass_ice > CS%rigid_sea_ice_mass) then mass_eff = (mass_ice - CS%rigid_sea_ice_mass) **2 / & (mass_ice + CS%rigid_sea_ice_mass) endif - forces%rigidity_ice_v(i,J) = Kv_rho_ice * mass_eff + forces%rigidity_ice_v(i,J) = forces%rigidity_ice_v(i,J) + Kv_rho_ice * mass_eff enddo ; enddo endif - if (coupler_type_initialized(fluxes%tr_fluxes) .and. & - coupler_type_initialized(IOB%fluxes)) & - call coupler_type_copy_data(IOB%fluxes, fluxes%tr_fluxes) - if (CS%allow_flux_adjustments) then - ! Apply adjustments to fluxes - call apply_flux_adjustments(G, CS, Time, forces, fluxes) + ! Apply adjustments to forces + call apply_force_adjustments(G, CS, Time, forces) endif - ! Allow for user-written code to alter fluxes after all the above - call user_alter_forcing(sfc_state, fluxes, Time, G, CS%urf_CS) +!### ! Allow for user-written code to alter fluxes after all the above +!### call user_alter_mech_forcing(forces, Time, G, CS%urf_CS) call cpu_clock_end(id_clock_forcing) -end subroutine convert_IOB_to_fluxes +end subroutine convert_IOB_to_forces + + +!> This subroutine extracts the wind stresses and related fields like ustar from an +!! Ice_ocean_boundary_type into optional argument arrays, including changes of units, sign +!! conventions, and putting the fields into arrays with MOM-standard sized halos. +subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, ustar, & + gustless_ustar, tau_halo) + type(ice_ocean_boundary_type), & + target, intent(in) :: IOB !< An ice-ocean boundary type with fluxes to drive + !! the ocean in a coupled model + integer, dimension(4), intent(in) :: index_bounds !< The i- and j- size of the arrays in IOB. + type(time_type), intent(in) :: Time !< The time of the fluxes, used for interpolating the + !! salinity to the right time, when it is being restored. + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(surface_forcing_CS),pointer :: CS !< A pointer to the control structure returned by a + !! previous call to surface_forcing_init. + real, dimension(SZIB_(G),SZJ_(G)), & + optional, intent(inout) :: taux !< The zonal wind stresses on a C-grid [Pa]. + real, dimension(SZI_(G),SZJB_(G)), & + optional, intent(inout) :: tauy !< The meridional wind stresses on a C-grid [Pa]. + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(inout) :: ustar !< The surface friction velocity [Z s-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(out) :: gustless_ustar !< The surface friction velocity without + !! any contributions from gustiness [Z s-1 ~> m s-1]. + integer, optional, intent(in) :: tau_halo !< The halo size of wind stresses to set, 0 by default. + + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: taux_in_A ! Zonal wind stresses [Pa] at h points + real, dimension(SZI_(G),SZJ_(G)) :: tauy_in_A ! Meridional wind stresses [Pa] at h points + real, dimension(SZIB_(G),SZJ_(G)) :: taux_in_C ! Zonal wind stresses [Pa] at u points + real, dimension(SZI_(G),SZJB_(G)) :: tauy_in_C ! Meridional wind stresses [Pa] at v points + real, dimension(SZIB_(G),SZJB_(G)) :: taux_in_B ! Zonal wind stresses [Pa] at q points + real, dimension(SZIB_(G),SZJB_(G)) :: tauy_in_B ! Meridional wind stresses [Pa] at q points + + real :: gustiness ! unresolved gustiness that contributes to ustar [Pa] + real :: Irho0 ! Inverse of the mean density rescaled to [Z2 m kg-1 ~> m3 kg-1] + real :: taux2, tauy2 ! squared wind stresses [Pa2] + real :: tau_mag ! magnitude of the wind stress [Pa] + + logical :: do_ustar, do_gustless + integer :: wind_stagger ! AGRID, BGRID_NE, or CGRID_NE (integers from MOM_domains) + integer :: i, j, is, ie, js, je, ish, ieh, jsh, jeh, Isqh, Ieqh, Jsqh, Jeqh, i0, j0, halo + + halo = 0 ; if (present(tau_halo)) halo = tau_halo + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + ish = G%isc-halo ; ieh = G%iec+halo ; jsh = G%jsc-halo ; jeh = G%jec+halo + Isqh = G%IscB-halo ; Ieqh = G%IecB+halo ; Jsqh = G%JscB-halo ; Jeqh = G%JecB+halo + i0 = is - index_bounds(1) ; j0 = js - index_bounds(3) + + Irho0 = US%m_to_Z**2 / CS%Rho0 + + do_ustar = present(ustar) ; do_gustless = present(gustless_ustar) + + wind_stagger = CS%wind_stagger + if ((IOB%wind_stagger == AGRID) .or. (IOB%wind_stagger == BGRID_NE) .or. & + (IOB%wind_stagger == CGRID_NE)) wind_stagger = IOB%wind_stagger + + if (associated(IOB%u_flux).neqv.associated(IOB%v_flux)) call MOM_error(FATAL,"extract_IOB_stresses: "//& + "associated(IOB%u_flux) /= associated(IOB%v_flux !!!") + if (present(taux).neqv.present(tauy)) call MOM_error(FATAL,"extract_IOB_stresses: "//& + "present(taux) /= present(tauy) !!!") + + ! Set surface momentum stress related fields as a function of staggering. + if (present(taux) .or. present(tauy) .or. & + ((do_ustar.or.do_gustless) .and. .not.associated(IOB%stress_mag)) ) then -!> Adds flux adjustments obtained via data_override + if (wind_stagger == BGRID_NE) then + taux_in_B(:,:) = 0.0 ; tauy_in_B(:,:) = 0.0 + if (associated(IOB%u_flux).and.associated(IOB%v_flux)) then + do J=js,je ; do I=is,ie + taux_in_B(I,J) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier + tauy_in_B(I,J) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier + enddo ; enddo + endif + + if (G%symmetric) call fill_symmetric_edges(taux_in_B, tauy_in_B, G%Domain, stagger=BGRID_NE) + call pass_vector(taux_in_B, tauy_in_B, G%Domain, stagger=BGRID_NE, halo=max(1,halo)) + + if (present(taux).and.present(tauy)) then + do j=jsh,jeh ; do I=Isqh,Ieqh + taux(I,j) = 0.0 + if ((G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) > 0) & + taux(I,j) = (G%mask2dBu(I,J)*taux_in_B(I,J) + G%mask2dBu(I,J-1)*taux_in_B(I,J-1)) / & + (G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) + enddo ; enddo + do J=Jsqh,Jeqh ; do i=ish,ieh + tauy(i,J) = 0.0 + if ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) > 0) & + tauy(i,J) = (G%mask2dBu(I,J)*tauy_in_B(I,J) + G%mask2dBu(I-1,J)*tauy_in_B(I-1,J)) / & + (G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) + enddo ; enddo + endif + elseif (wind_stagger == AGRID) then + taux_in_A(:,:) = 0.0 ; tauy_in_A(:,:) = 0.0 + if (associated(IOB%u_flux).and.associated(IOB%v_flux)) then + do j=js,je ; do i=is,ie + taux_in_A(i,j) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier + tauy_in_A(i,j) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier + enddo ; enddo + endif + + if (halo == 0) then + call pass_vector(taux_in_A, tauy_in_A, G%Domain, To_All+Omit_Corners, stagger=AGRID, halo=1) + else + call pass_vector(taux_in_A, tauy_in_A, G%Domain, stagger=AGRID, halo=max(1,halo)) + endif + + if (present(taux)) then ; do j=jsh,jeh ; do I=Isqh,Ieqh + taux(I,j) = 0.0 + if ((G%mask2dT(i,j) + G%mask2dT(i+1,j)) > 0) & + taux(I,j) = (G%mask2dT(i,j)*taux_in_A(i,j) + G%mask2dT(i+1,j)*taux_in_A(i+1,j)) / & + (G%mask2dT(i,j) + G%mask2dT(i+1,j)) + enddo ; enddo ; endif + + if (present(tauy)) then ; do J=Jsqh,Jeqh ; do i=ish,ieh + tauy(i,J) = 0.0 + if ((G%mask2dT(i,j) + G%mask2dT(i,j+1)) > 0) & + tauy(i,J) = (G%mask2dT(i,j)*tauy_in_A(i,j) + G%mask2dT(i,J+1)*tauy_in_A(i,j+1)) / & + (G%mask2dT(i,j) + G%mask2dT(i,j+1)) + enddo ; enddo ; endif + + else ! C-grid wind stresses. + taux_in_C(:,:) = 0.0 ; tauy_in_C(:,:) = 0.0 + if (associated(IOB%u_flux).and.associated(IOB%v_flux)) then + do j=js,je ; do i=is,ie + taux_in_C(I,j) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier + tauy_in_C(i,J) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier + enddo ; enddo + endif + + if (G%symmetric) call fill_symmetric_edges(taux_in_C, tauy_in_C, G%Domain) + call pass_vector(taux_in_C, tauy_in_C, G%Domain, halo=max(1,halo)) + + if (present(taux).and.present(tauy)) then + do j=jsh,jeh ; do I=Isqh,Ieqh + taux(I,j) = G%mask2dCu(I,j)*taux_in_C(I,j) + enddo ; enddo + do J=Jsqh,Jeqh ; do i=ish,ieh + tauy(i,J) = G%mask2dCv(i,J)*tauy_in_C(i,J) + enddo ; enddo + endif + endif ! endif for extracting wind stress fields with various staggerings + endif + + if (do_ustar .or. do_gustless) then + ! Set surface friction velocity directly or as a function of staggering. + ! ustar is required for the bulk mixed layer formulation and other turbulent mixing + ! parametizations. The background gustiness (for example with a relatively small value + ! of 0.02 Pa) is intended to give reasonable behavior in regions of very weak winds. + if (associated(IOB%stress_mag)) then + if (do_ustar) then ; do j=js,je ; do i=is,ie + gustiness = CS%gust_const + !### SIMPLIFY THE TREATMENT OF GUSTINESS! + if (CS%read_gust_2d) then + if ((wind_stagger == CGRID_NE) .or. & + ((wind_stagger == AGRID) .and. (G%mask2dT(i,j) > 0)) .or. & + ((wind_stagger == BGRID_NE) .and. & + (((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + & + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0)) ) & + gustiness = CS%gust(i,j) + endif + ustar(i,j) = sqrt(gustiness*Irho0 + Irho0*IOB%stress_mag(i-i0,j-j0)) + enddo ; enddo ; endif + if (do_gustless) then ; do j=js,je ; do i=is,ie + gustless_ustar(i,j) = US%m_to_Z * sqrt(IOB%stress_mag(i-i0,j-j0) / CS%Rho0) +!### Change to: +! gustless_ustar(i,j) = sqrt(Irho0 * IOB%stress_mag(i-i0,j-j0)) + enddo ; enddo ; endif + elseif (wind_stagger == BGRID_NE) then + do j=js,je ; do i=is,ie + tau_mag = 0.0 ; gustiness = CS%gust_const + if (((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + & + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0) then + tau_mag = sqrt(((G%mask2dBu(I,J)*(taux_in_B(I,J)**2 + tauy_in_B(I,J)**2) + & + G%mask2dBu(I-1,J-1)*(taux_in_B(I-1,J-1)**2 + tauy_in_B(I-1,J-1)**2)) + & + (G%mask2dBu(I,J-1)*(taux_in_B(I,J-1)**2 + tauy_in_B(I,J-1)**2) + & + G%mask2dBu(I-1,J)*(taux_in_B(I-1,J)**2 + tauy_in_B(I-1,J)**2)) ) / & + ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) ) + if (CS%read_gust_2d) gustiness = CS%gust(i,j) + endif + if (do_ustar) ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * tau_mag) + if (do_gustless) gustless_ustar(i,j) = US%m_to_Z * sqrt(tau_mag / CS%Rho0) +!### Change to: +! if (do_gustless) gustless_ustar(i,j) = sqrt(Irho0 * tau_mag) + enddo ; enddo + elseif (wind_stagger == AGRID) then + do j=js,je ; do i=is,ie + tau_mag = G%mask2dT(i,j) * sqrt(taux_in_A(i,j)**2 + tauy_in_A(i,j)**2) + gustiness = CS%gust_const + if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0)) gustiness = CS%gust(i,j) + if (do_ustar) ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * tau_mag) + if (do_gustless) gustless_ustar(i,j) = US%m_to_Z * sqrt(tau_mag / CS%Rho0) +!### Change to: +! if (do_gustless) gustless_ustar(i,j) = sqrt(Irho0 * tau_mag) + enddo ; enddo + else ! C-grid wind stresses. + do j=js,je ; do i=is,ie + taux2 = 0.0 ; tauy2 = 0.0 + if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0) & + taux2 = (G%mask2dCu(I-1,j)*taux_in_C(I-1,j)**2 + & + G%mask2dCu(I,j)*taux_in_C(I,j)**2) / (G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) + if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0) & + tauy2 = (G%mask2dCv(i,J-1)*tauy_in_C(i,J-1)**2 + & + G%mask2dCv(i,J)*tauy_in_C(i,J)**2) / (G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) + tau_mag = sqrt(taux2 + tauy2) + + gustiness = CS%gust_const + if (CS%read_gust_2d) gustiness = CS%gust(i,j) + + if (do_ustar) ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * tau_mag) + if (do_gustless) gustless_ustar(i,j) = US%m_to_Z * sqrt(tau_mag / CS%Rho0) +!### Change to: +! if (do_gustless) gustless_ustar(i,j) = sqrt(Irho0 * tau_mag) + enddo ; enddo + endif ! endif for wind friction velocity fields + endif + +end subroutine extract_IOB_stresses + + +!> Adds thermodynamic flux adjustments obtained via data_override !! Component name is 'OCN' !! Available adjustments are: -!! - taux_adj (Zonal wind stress delta, positive to the east, in Pa) -!! - tauy_adj (Meridional wind stress delta, positive to the north, in Pa) -subroutine apply_flux_adjustments(G, CS, Time, forces, fluxes) +!! - hflx_adj (Heat flux into the ocean [W m-2]) +!! - sflx_adj (Salt flux into the ocean [kg salt m-2 s-1]) +!! - prcme_adj (Fresh water flux into the ocean [kg m-2 s-1]) +subroutine apply_flux_adjustments(G, CS, Time, fluxes) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(surface_forcing_CS), pointer :: CS !< Surface forcing control structure type(time_type), intent(in) :: Time !< Model time structure - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces type(forcing), intent(inout) :: fluxes !< Surface fluxes structure ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: tempx_at_h ! Delta to zonal wind stress at h points (Pa) - real, dimension(SZI_(G),SZJ_(G)) :: tempy_at_h ! Delta to meridional wind stress at h points (Pa) - real, dimension(SZI_(G),SZJ_(G)) :: temp_at_h ! Fluxes at h points (W m-2 or kg m-2 s-1) + real, dimension(SZI_(G),SZJ_(G)) :: temp_at_h ! Various fluxes at h points [W m-2] or [kg m-2 s-1] integer :: isc, iec, jsc, jec, i, j - real :: dLonDx, dLonDy, rDlon, cosA, sinA, zonal_tau, merid_tau - logical :: overrode_x, overrode_y, overrode_h + logical :: overrode_h isc = G%isc; iec = G%iec ; jsc = G%jsc; jec = G%jec @@ -769,7 +1032,7 @@ subroutine apply_flux_adjustments(G, CS, Time, forces, fluxes) if (overrode_h) then ; do j=jsc,jec ; do i=isc,iec fluxes%heat_added(i,j) = fluxes%heat_added(i,j) + temp_at_h(i,j)* G%mask2dT(i,j) enddo ; enddo ; endif - if (overrode_h) call pass_var(fluxes%heat_added, G%Domain) + ! Not needed? ! if (overrode_h) call pass_var(fluxes%heat_added, G%Domain) overrode_h = .false. call data_override('OCN', 'sflx_adj', temp_at_h(isc:iec,jsc:jec), Time, override=overrode_h) @@ -777,7 +1040,7 @@ subroutine apply_flux_adjustments(G, CS, Time, forces, fluxes) if (overrode_h) then ; do j=jsc,jec ; do i=isc,iec fluxes%salt_flux_added(i,j) = fluxes%salt_flux_added(i,j) + temp_at_h(i,j)* G%mask2dT(i,j) enddo ; enddo ; endif - if (overrode_h) call pass_var(fluxes%salt_flux_added, G%Domain) + ! Not needed? ! if (overrode_h) call pass_var(fluxes%salt_flux_added, G%Domain) overrode_h = .false. call data_override('OCN', 'prcme_adj', temp_at_h(isc:iec,jsc:jec), Time, override=overrode_h) @@ -785,7 +1048,29 @@ subroutine apply_flux_adjustments(G, CS, Time, forces, fluxes) if (overrode_h) then ; do j=jsc,jec ; do i=isc,iec fluxes%vprec(i,j) = fluxes%vprec(i,j) + temp_at_h(i,j)* G%mask2dT(i,j) enddo ; enddo ; endif - if (overrode_h) call pass_var(fluxes%vprec, G%Domain) + ! Not needed? ! if (overrode_h) call pass_var(fluxes%vprec, G%Domain) +end subroutine apply_flux_adjustments + +!> Adds mechanical forcing adjustments obtained via data_override +!! Component name is 'OCN' +!! Available adjustments are: +!! - taux_adj (Zonal wind stress delta, positive to the east [Pa]) +!! - tauy_adj (Meridional wind stress delta, positive to the north [Pa]) +subroutine apply_force_adjustments(G, CS, Time, forces) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(surface_forcing_CS), pointer :: CS !< Surface forcing control structure + type(time_type), intent(in) :: Time !< Model time structure + type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces + + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: tempx_at_h ! Delta to zonal wind stress at h points [Pa] + real, dimension(SZI_(G),SZJ_(G)) :: tempy_at_h ! Delta to meridional wind stress at h points [Pa] + + integer :: isc, iec, jsc, jec, i, j + real :: dLonDx, dLonDy, rDlon, cosA, sinA, zonal_tau, merid_tau + logical :: overrode_x, overrode_y + + isc = G%isc; iec = G%iec ; jsc = G%jsc; jec = G%jec tempx_at_h(:,:) = 0.0 ; tempy_at_h(:,:) = 0.0 ! Either reads data or leaves contents unchanged @@ -798,7 +1083,7 @@ subroutine apply_flux_adjustments(G, CS, Time, forces, fluxes) "Both taux_adj and tauy_adj must be specified, or neither, in data_table") ! Rotate winds - call pass_vector(tempx_at_h, tempy_at_h, G%Domain, To_All, AGRID) + call pass_vector(tempx_at_h, tempy_at_h, G%Domain, To_All, AGRID, halo=1) do j=jsc-1,jec+1 ; do i=isc-1,iec+1 dLonDx = G%geoLonCu(I,j) - G%geoLonCu(I-1,j) dLonDy = G%geoLonCv(i,J) - G%geoLonCv(i,J-1) @@ -822,25 +1107,21 @@ subroutine apply_flux_adjustments(G, CS, Time, forces, fluxes) enddo ; enddo endif ! overrode_x .or. overrode_y -end subroutine apply_flux_adjustments +end subroutine apply_force_adjustments +!> Save any restart files associated with the surface forcing. subroutine forcing_save_restart(CS, G, Time, directory, time_stamped, & filename_suffix) - type(surface_forcing_CS), pointer :: CS + type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned + !! by a previous call to surface_forcing_init type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(time_type), intent(in) :: Time - character(len=*), intent(in) :: directory - logical, optional, intent(in) :: time_stamped - character(len=*), optional, intent(in) :: filename_suffix -! Arguments: CS - A pointer to the control structure returned by a previous -! call to surface_forcing_init. -! (in) G - The ocean's grid structure. -! (in) Time - The model time at this call. This is needed for mpp_write calls. -! (in, opt) directory - An optional directory into which to write these restart files. -! (in, opt) time_stamped - If true, the restart file names include -! a unique time stamp. The default is false. -! (in, opt) filename_suffix - An optional suffix (e.g., a time-stamp) to append -! to the restart file names. + type(time_type), intent(in) :: Time !< The current model time + character(len=*), intent(in) :: directory !< The directory into which to write the + !! restart files + logical, optional, intent(in) :: time_stamped !< If true, the restart file names include + !! a unique time stamp. The default is false. + character(len=*), optional, intent(in) :: filename_suffix !< An optional suffix (e.g., a time- + !! stamp) to append to the restart file names. if (.not.associated(CS)) return if (.not.associated(CS%restart_CSp)) return @@ -848,23 +1129,19 @@ subroutine forcing_save_restart(CS, G, Time, directory, time_stamped, & end subroutine forcing_save_restart -subroutine surface_forcing_init(Time, G, param_file, diag, CS, restore_salt, restore_temp) - type(time_type), intent(in) :: Time +!> Initialize the surface forcing, including setting parameters and allocating permanent memory. +subroutine surface_forcing_init(Time, G, US, param_file, diag, CS) + type(time_type), intent(in) :: Time !< The current model time type(ocean_grid_type), intent(in) :: G !< The ocean's 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 - type(surface_forcing_CS), pointer :: CS - logical, optional, intent(in) :: restore_salt, restore_temp -! Arguments: Time - The current model time. -! (in) G - The ocean's grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in) diag - A structure that is used to regulate diagnostic output. -! (in/out) CS - A pointer that is set to point to the control structure -! for this module -! (in) restore_salt - If present and true, salinity restoring will be -! applied in this model. - real :: utide ! The RMS tidal velocity, in m s-1. + type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to regulate + !! diagnostic output + type(surface_forcing_CS), pointer :: CS !< A pointer that is set to point to the control + !! structure for this module + + ! Local variables + real :: utide ! The RMS tidal velocity [m s-1]. type(directories) :: dirs logical :: new_sim, iceberg_flux_diags type(time_type) :: Time_frc @@ -891,7 +1168,7 @@ subroutine surface_forcing_init(Time, G, param_file, diag, CS, restore_salt, res CS%diag => diag - call write_version_number (version) + call write_version_number(version) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") @@ -920,11 +1197,19 @@ subroutine surface_forcing_init(Time, G, param_file, diag, CS, restore_salt, res "the ice-ocean heat fluxes are treated explicitly. No \n"//& "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"//& + "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"//& + "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"//& "whether restoring is via a salt flux or virtual precip.",& - default=restore_salt) + 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"//& @@ -954,11 +1239,11 @@ subroutine surface_forcing_init(Time, G, param_file, diag, CS, restore_salt, res "correction for the atmospheric (and sea-ice) pressure \n"//& "limited by max_p_surf instead of the full atmospheric \n"//& "pressure.", default=.true.) - -! smg: should get_param call should be removed when have A=B code reconciled. -! this param is used to distinguish how to diagnose surface heat content from water. - call get_param(param_file, mdl, "BULKMIXEDLAYER", CS%bulkmixedlayer, & - default=CS%use_temperature,do_not_log=.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"//& + "due to internal corrections.", default=.false.) call get_param(param_file, mdl, "WIND_STAGGER", stagger, & "A case-insensitive character string to indicate the \n"//& @@ -974,7 +1259,7 @@ subroutine surface_forcing_init(Time, G, param_file, diag, CS, restore_salt, res "coupler. This is used for testing and should be =1.0 for any\n"//& "production runs.", default=1.0) - if (restore_salt) then + 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"//& @@ -1022,7 +1307,7 @@ subroutine surface_forcing_init(Time, G, param_file, diag, CS, restore_salt, res "a mask for SSS restoring.", default=.false.) endif - if (restore_temp) then + 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"//& @@ -1035,7 +1320,7 @@ subroutine surface_forcing_init(Time, G, param_file, diag, CS, restore_salt, res "The name of the surface temperature variable to read from "//& "SST_RESTORE_FILE for restoring sst.", & default="temp") -! Convert CS%Flux_const from m day-1 to m s-1. + ! 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, "MAX_DELTA_TRESTORE", CS%max_delta_trestore, & @@ -1047,7 +1332,7 @@ subroutine surface_forcing_init(Time, G, param_file, diag, CS, restore_salt, res endif -! Optionally read tidal amplitude from input file (m s-1) on model grid. +! Optionally read tidal amplitude from input file [m s-1] on model grid. ! Otherwise use default tidal amplitude for bottom frictionally-generated ! dissipation. Default cd_tides is chosen to yield approx 1 TWatt of ! work done against tides globally using OSU tidal amplitude. @@ -1131,17 +1416,16 @@ subroutine surface_forcing_init(Time, G, param_file, diag, CS, restore_salt, res call get_param(param_file, mdl, "ALLOW_ICEBERG_FLUX_DIAGNOSTICS", iceberg_flux_diags, & "If true, makes available diagnostics of fluxes from icebergs\n"//& "as seen by MOM6.", default=.false.) - call register_forcing_type_diags(Time, diag, CS%use_temperature, CS%handles, & + 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"//& "data_table using the component name 'OCN'.", default=.false.) - if (CS%allow_flux_adjustments) then - call data_override_init(Ocean_domain_in=G%Domain%mpp_domain) - endif - if (present(restore_salt)) then ; if (restore_salt) then + call data_override_init(Ocean_domain_in=G%Domain%mpp_domain) + + if (CS%restore_salt) then salt_file = trim(CS%inputdir) // trim(CS%salt_restore_file) CS%id_srestore = init_external_field(salt_file, CS%salt_restore_var_name, domain=G%Domain%mpp_domain) call safe_alloc_ptr(CS%srestore_mask,isd,ied,jsd,jed); CS%srestore_mask(:,:) = 1.0 @@ -1149,9 +1433,9 @@ subroutine surface_forcing_init(Time, G, param_file, diag, CS, restore_salt, res flnam = trim(CS%inputdir) // 'salt_restore_mask.nc' call MOM_read_data(flnam,'mask', CS%srestore_mask, G%domain, timelevel=1) endif - endif ; endif + endif - if (present(restore_temp)) then ; if (restore_temp) then + if (CS%restore_temp) then temp_file = trim(CS%inputdir) // trim(CS%temp_restore_file) CS%id_trestore = init_external_field(temp_file, CS%temp_restore_var_name, domain=G%Domain%mpp_domain) call safe_alloc_ptr(CS%trestore_mask,isd,ied,jsd,jed); CS%trestore_mask(:,:) = 1.0 @@ -1159,7 +1443,7 @@ subroutine surface_forcing_init(Time, G, param_file, diag, CS, restore_salt, res flnam = trim(CS%inputdir) // 'temp_restore_mask.nc' call MOM_read_data(flnam, 'mask', CS%trestore_mask, G%domain, timelevel=1) endif - endif ; endif + endif ! Set up any restart fields associated with the forcing. call restart_init(param_file, CS%restart_CSp, "MOM_forcing.res") @@ -1186,13 +1470,14 @@ subroutine surface_forcing_init(Time, G, param_file, diag, CS, restore_salt, res call cpu_clock_end(id_clock_forcing) end subroutine surface_forcing_init +!> Clean up and deallocate any memory associated with this module and its children. subroutine surface_forcing_end(CS, fluxes) - type(surface_forcing_CS), pointer :: CS - type(forcing), optional, intent(inout) :: fluxes -! Arguments: CS - A pointer to the control structure returned by a previous -! call to surface_forcing_init, it will be deallocated here. -! (inout) fluxes - A structure containing pointers to any possible -! forcing fields. Unused fields have NULL ptrs. + type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by + !! a previous call to surface_forcing_init, it will + !! be deallocated here. + type(forcing), optional, intent(inout) :: fluxes !< A structure containing pointers to all + !! possible mass, heat or salt flux forcing fields. + !! If present, it will be deallocated here. if (present(fluxes)) call deallocate_forcing_type(fluxes) @@ -1203,40 +1488,43 @@ subroutine surface_forcing_end(CS, fluxes) end subroutine surface_forcing_end +!> Write out a set of messages with checksums of the fields in an ice_ocen_boundary type subroutine ice_ocn_bnd_type_chksum(id, timestep, iobt) - character(len=*), intent(in) :: id - integer , intent(in) :: timestep - type(ice_ocean_boundary_type), intent(in) :: iobt - integer :: n,m, outunit - - outunit = stdout() - - write(outunit,*) "BEGIN CHECKSUM(ice_ocean_boundary_type):: ", id, timestep - write(outunit,100) 'iobt%u_flux ', mpp_chksum( iobt%u_flux ) - write(outunit,100) 'iobt%v_flux ', mpp_chksum( iobt%v_flux ) - write(outunit,100) 'iobt%t_flux ', mpp_chksum( iobt%t_flux ) - write(outunit,100) 'iobt%q_flux ', mpp_chksum( iobt%q_flux ) - write(outunit,100) 'iobt%salt_flux ', mpp_chksum( iobt%salt_flux ) - write(outunit,100) 'iobt%lw_flux ', mpp_chksum( iobt%lw_flux ) - write(outunit,100) 'iobt%sw_flux_vis_dir', mpp_chksum( iobt%sw_flux_vis_dir) - write(outunit,100) 'iobt%sw_flux_vis_dif', mpp_chksum( iobt%sw_flux_vis_dif) - write(outunit,100) 'iobt%sw_flux_nir_dir', mpp_chksum( iobt%sw_flux_nir_dir) - write(outunit,100) 'iobt%sw_flux_nir_dif', mpp_chksum( iobt%sw_flux_nir_dif) - write(outunit,100) 'iobt%lprec ', mpp_chksum( iobt%lprec ) - write(outunit,100) 'iobt%fprec ', mpp_chksum( iobt%fprec ) - write(outunit,100) 'iobt%runoff ', mpp_chksum( iobt%runoff ) - write(outunit,100) 'iobt%calving ', mpp_chksum( iobt%calving ) - write(outunit,100) 'iobt%p ', mpp_chksum( iobt%p ) - if (associated(iobt%ustar_berg)) & - write(outunit,100) 'iobt%ustar_berg ', mpp_chksum( iobt%ustar_berg ) - if (associated(iobt%area_berg)) & - write(outunit,100) 'iobt%area_berg ', mpp_chksum( iobt%area_berg ) - if (associated(iobt%mass_berg)) & - write(outunit,100) 'iobt%mass_berg ', mpp_chksum( iobt%mass_berg ) + character(len=*), intent(in) :: id !< An identifying string for this call + integer, intent(in) :: timestep !< The number of elapsed timesteps + type(ice_ocean_boundary_type), & + intent(in) :: iobt !< An ice-ocean boundary type with fluxes to drive the + !! ocean in a coupled model whose checksums are reported + integer :: n,m, outunit + + outunit = stdout() + + write(outunit,*) "BEGIN CHECKSUM(ice_ocean_boundary_type):: ", id, timestep + write(outunit,100) 'iobt%u_flux ', mpp_chksum( iobt%u_flux ) + write(outunit,100) 'iobt%v_flux ', mpp_chksum( iobt%v_flux ) + write(outunit,100) 'iobt%t_flux ', mpp_chksum( iobt%t_flux ) + write(outunit,100) 'iobt%q_flux ', mpp_chksum( iobt%q_flux ) + write(outunit,100) 'iobt%salt_flux ', mpp_chksum( iobt%salt_flux ) + write(outunit,100) 'iobt%lw_flux ', mpp_chksum( iobt%lw_flux ) + write(outunit,100) 'iobt%sw_flux_vis_dir', mpp_chksum( iobt%sw_flux_vis_dir) + write(outunit,100) 'iobt%sw_flux_vis_dif', mpp_chksum( iobt%sw_flux_vis_dif) + write(outunit,100) 'iobt%sw_flux_nir_dir', mpp_chksum( iobt%sw_flux_nir_dir) + write(outunit,100) 'iobt%sw_flux_nir_dif', mpp_chksum( iobt%sw_flux_nir_dif) + write(outunit,100) 'iobt%lprec ', mpp_chksum( iobt%lprec ) + write(outunit,100) 'iobt%fprec ', mpp_chksum( iobt%fprec ) + write(outunit,100) 'iobt%runoff ', mpp_chksum( iobt%runoff ) + write(outunit,100) 'iobt%calving ', mpp_chksum( iobt%calving ) + write(outunit,100) 'iobt%p ', mpp_chksum( iobt%p ) + if (associated(iobt%ustar_berg)) & + write(outunit,100) 'iobt%ustar_berg ', mpp_chksum( iobt%ustar_berg ) + if (associated(iobt%area_berg)) & + write(outunit,100) 'iobt%area_berg ', mpp_chksum( iobt%area_berg ) + if (associated(iobt%mass_berg)) & + write(outunit,100) 'iobt%mass_berg ', mpp_chksum( iobt%mass_berg ) 100 FORMAT(" CHECKSUM::",A20," = ",Z20) - call coupler_type_write_chksums(iobt%fluxes, outunit, 'iobt%') + call coupler_type_write_chksums(iobt%fluxes, outunit, 'iobt%') end subroutine ice_ocn_bnd_type_chksum diff --git a/config_src/coupled_driver/coupler_util.F90 b/config_src/coupled_driver/coupler_util.F90 index dde67c2976..2c72c56cce 100644 --- a/config_src/coupled_driver/coupler_util.F90 +++ b/config_src/coupled_driver/coupler_util.F90 @@ -1,9 +1,9 @@ +!> 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. -! 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 @@ -15,24 +15,20 @@ module coupler_util 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 - 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. - + 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 @@ -78,24 +74,21 @@ subroutine extract_coupler_values(BC_struc, BC_index, BC_element, array_out, & 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 - 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, 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 diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index d153a2f04c..b62f479354 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -1,21 +1,15 @@ +!> Top-level module for the MOM6 ocean model in coupled mode. module ocean_model_mod ! This file is part of MOM6. See LICENSE.md for the license. -!----------------------------------------------------------------------- -! ! This is the top level module for the MOM6 ocean model. It contains routines ! for initialization, termination and update of ocean model state. This ! particular version wraps all of the calls for MOM6 in the calls that had ! been used for MOM4. ! -! Robert Hallberg -! -! -! ! This code is a stop-gap wrapper of the MOM6 code to enable it to be called ! in the same way as MOM4. -! use MOM, only : initialize_MOM, step_MOM, MOM_control_struct, MOM_end use MOM, only : extract_surface_state, allocate_surface_state, finish_MOM_initialization @@ -24,34 +18,36 @@ module ocean_model_mod use MOM_constants, only : CELSIUS_KELVIN_OFFSET, hlf use MOM_diag_mediator, only : diag_ctrl, enable_averaging, disable_averaging use MOM_diag_mediator, only : diag_mediator_close_registration, diag_mediator_end -use MOM_domains, only : pass_vector, AGRID, BGRID_NE, CGRID_NE -use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe +use MOM_domains, only : pass_var, pass_vector, AGRID, BGRID_NE, CGRID_NE +use MOM_domains, only : TO_ALL, Omit_Corners +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe use MOM_error_handler, only : callTree_enter, callTree_leave use MOM_file_parser, only : get_param, log_version, close_param_file, param_file_type -use MOM_forcing_type, only : forcing, mech_forcing -use MOM_forcing_type, only : forcing_accumulate, copy_common_forcing_fields -use MOM_forcing_type, only : copy_back_forcing_fields, set_net_mass_forcing -use MOM_forcing_type, only : set_derived_forcing_fields +use MOM_forcing_type, only : forcing, mech_forcing, allocate_forcing_type +use MOM_forcing_type, only : fluxes_accumulate, get_net_mass_forcing +use MOM_forcing_type, only : copy_back_forcing_fields use MOM_forcing_type, only : forcing_diagnostics, mech_forcing_diags use MOM_get_input, only : Get_MOM_Input, directories use MOM_grid, only : ocean_grid_type use MOM_io, only : close_file, file_exists, read_data, write_version_number +use MOM_marine_ice, only : iceberg_forces, iceberg_fluxes, marine_ice_init, marine_ice_CS use MOM_restart, only : MOM_restart_CS, save_restart use MOM_string_functions, only : uppercase use MOM_surface_forcing, only : surface_forcing_init, convert_IOB_to_fluxes -use MOM_surface_forcing, only : ice_ocn_bnd_type_chksum +use MOM_surface_forcing, only : convert_IOB_to_forces, ice_ocn_bnd_type_chksum use MOM_surface_forcing, only : ice_ocean_boundary_type, surface_forcing_CS use MOM_surface_forcing, only : forcing_save_restart -use MOM_time_manager, only : time_type, get_time, set_time, operator(>) -use MOM_time_manager, only : operator(+), operator(-), operator(*), operator(/) -use MOM_time_manager, only : operator(/=), operator(<=), operator(>=) -use MOM_time_manager, only : operator(<), real_to_time_type, time_type_to_real +use MOM_time_manager, only : time_type, operator(>), operator(+), operator(-) +use MOM_time_manager, only : operator(*), operator(/), operator(/=) +use MOM_time_manager, only : operator(<=), operator(>=), operator(<) +use MOM_time_manager, only : real_to_time, time_type_to_real use MOM_tracer_flow_control, only : call_tracer_register, tracer_flow_control_init use MOM_tracer_flow_control, only : call_tracer_flux_init +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type use MOM_ice_shelf, only : initialize_ice_shelf, shelf_calc_flux, ice_shelf_CS -use MOM_ice_shelf, only : ice_shelf_end, ice_shelf_save_restart +use MOM_ice_shelf, only : add_shelf_forces, ice_shelf_end, ice_shelf_save_restart use coupler_types_mod, only : coupler_1d_bc_type, coupler_2d_bc_type use coupler_types_mod, only : coupler_type_spawn, coupler_type_write_chksums use coupler_types_mod, only : coupler_type_initialized, coupler_type_copy_data @@ -59,10 +55,8 @@ module ocean_model_mod use mpp_domains_mod, only : domain2d, mpp_get_layout, mpp_get_global_domain use mpp_domains_mod, only : mpp_define_domains, mpp_get_compute_domain, mpp_get_data_domain use atmos_ocean_fluxes_mod, only : aof_set_coupler_flux -use MOM_forcing_type, only : allocate_forcing_type use fms_mod, only : stdout use mpp_mod, only : mpp_chksum -use MOM_domains, only : pass_var, pass_vector, TO_ALL, CGRID_NE, BGRID_NE use MOM_EOS, only : gsw_sp_from_sr, gsw_pt_from_ct use MOM_wave_interface, only: wave_parameters_CS, MOM_wave_interface_init use MOM_wave_interface, only: MOM_wave_interface_init_lite, Update_Surface_Waves @@ -84,6 +78,7 @@ module ocean_model_mod public ocean_public_type_chksum public ocean_model_data_get +!> This interface extracts a named scalar field or array from the ocean surface or public type interface ocean_model_data_get module procedure ocean_model_data1D_get module procedure ocean_model_data2D_get @@ -118,13 +113,13 @@ module ocean_model_mod real, pointer, dimension(:,:) :: & t_surf => NULL(), & !< SST on t-cell (degrees Kelvin) s_surf => NULL(), & !< SSS on t-cell (psu) - u_surf => NULL(), & !< i-velocity at the locations indicated by stagger, m/s. - v_surf => NULL(), & !< j-velocity at the locations indicated by stagger, m/s. + u_surf => NULL(), & !< i-velocity at the locations indicated by stagger [m s-1]. + v_surf => NULL(), & !< j-velocity at the locations indicated by stagger [m s-1]. sea_lev => NULL(), & !< Sea level in m after correction for surface pressure, - !! i.e. dzt(1) + eta_t + patm/rho0/grav (m) - frazil =>NULL(), & !< Accumulated heating (in Joules/m^2) from frazil + !! i.e. dzt(1) + eta_t + patm/rho0/grav [m] + frazil =>NULL(), & !< Accumulated heating [J m-2] from frazil !! formation in the ocean. - area => NULL() !< cell area of the ocean surface, in m2. + area => NULL() !< cell area of the ocean surface [m2]. type(coupler_2d_bc_type) :: fields !< A structure that may contain named !! arrays of tracer-related surface fields. integer :: avg_kount !< A count of contributions to running @@ -141,34 +136,26 @@ module ocean_model_mod type, public :: ocean_state_type ; private ! This type is private, and can therefore vary between different ocean models. logical :: is_ocean_PE = .false. !< True if this is an ocean PE. - type(time_type) :: Time !< The ocean model's time and master clock. - integer :: Restart_control !< An integer that is bit-tested to determine whether - !! incremental restart files are saved and whether they - !! have a time stamped name. +1 (bit 0) for generic - !! files and +2 (bit 1) for time-stamped files. A - !! restart file is saved at the end of a run segment - !! unless Restart_control is negative. - - integer :: nstep = 0 !< The number of calls to update_ocean. + type(time_type) :: Time !< The ocean model's time and master clock. + type(time_type) :: Time_dyn !< The ocean model's time for the dynamics. Time and Time_dyn + !! should be the same after a full time step. + integer :: Restart_control !< An integer that is bit-tested to determine whether + !! incremental restart files are saved and whether they + !! have a time stamped name. +1 (bit 0) for generic + !! files and +2 (bit 1) for time-stamped files. A + !! restart file is saved at the end of a run segment + !! unless Restart_control is negative. + + integer :: nstep = 0 !< The number of calls to update_ocean that update the dynamics. + integer :: nstep_thermo = 0 !< The number of calls to update_ocean that update the thermodynamics. logical :: use_ice_shelf !< If true, the ice shelf model is enabled. - logical :: use_waves = .false.! If true use wave coupling. - - ! Many of the following variables do not appear to belong here. -RWH - logical :: icebergs_apply_rigid_boundary ! If true, the icebergs can change ocean bd condition. - real :: kv_iceberg ! The viscosity of the icebergs in m2/s (for ice rigidity) - real :: berg_area_threshold ! Fraction of grid cell which iceberg must occupy - !so that fluxes below are set to zero. (0.5 is a - !good value to use. Not applied for negative values. - real :: latent_heat_fusion ! Latent heat of fusion - real :: density_iceberg ! A typical density of icebergs in kg/m3 (for ice rigidity) - - logical :: restore_salinity !< If true, the coupled MOM driver adds a term to - !! restore salinity to a specified value. - logical :: restore_temp !< If true, the coupled MOM driver adds a term to - !! restore sst to a specified value. + logical :: use_waves !< If true use wave coupling. + + logical :: icebergs_alter_ocean !< If true, the icebergs can change ocean the + !! ocean dynamics and forcing fluxes. real :: press_to_z !< A conversion factor between pressure and ocean - !! depth in m, usually 1/(rho_0*g), in m Pa-1. - real :: C_p !< The heat capacity of seawater, in J K-1 kg-1. + !! depth in m, usually 1/(rho_0*g) [m Pa-1]. + real :: C_p !< The heat capacity of seawater [J degC-1 kg-1]. logical :: offline_tracer_mode = .false. !< If false, use the model in prognostic mode !! with the barotropic and baroclinic dynamics, thermodynamics, !! etc. stepped forward integrated in time. @@ -182,8 +169,8 @@ module ocean_model_mod !! If false, the two phases are advanced with !! separate calls. The default is true. ! The following 3 variables are only used here if single_step_call is false. - real :: dt !< (baroclinic) dynamics time step (seconds) - real :: dt_therm !< thermodynamics time step (seconds) + real :: dt !< (baroclinic) dynamics time step [s] + real :: dt_therm !< thermodynamics time step [s] logical :: thermo_spans_coupling !< If true, thermodynamic and tracer time !! steps can span multiple coupled time steps. logical :: diabatic_first !< If true, apply diabatic and thermodynamic @@ -204,12 +191,18 @@ module ocean_model_mod type(verticalGrid_type), pointer :: & GV => NULL() !< A pointer to a structure containing information !! about the vertical grid. + type(unit_scale_type), pointer :: & + US => NULL() !< A pointer to a structure containing dimensional + !! unit scaling factors. type(MOM_control_struct), pointer :: & MOM_CSp => NULL() !< A pointer to the MOM control structure type(ice_shelf_CS), pointer :: & Ice_shelf_CSp => NULL() !< A pointer to the control structure for the !! ice shelf model that couples with MOM6. This !! is null if there is no ice shelf. + type(marine_ice_CS), pointer :: & + marine_ice_CSp => NULL() !< A pointer to the control structure for the + !! marine ice effects module. type(wave_parameters_cs), pointer :: & Waves !< A structure containing pointers to the surface wave fields type(surface_forcing_CS), pointer :: & @@ -223,20 +216,17 @@ module ocean_model_mod contains -!======================================================================= -! -! -! -! Initialize the ocean model. -! - !> ocean_model_init initializes the ocean model, including registering fields !! for restarts and reading restart files if appropriate. +!! +!! This subroutine initializes both the ocean state and the ocean surface type. +!! Because of the way that indicies and domains are handled, Ocean_sfc must have +!! been used in a previous call to initialize_ocean_type. subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) type(ocean_public_type), target, & - intent(inout) :: Ocean_sfc !< A structure containing various - !! publicly visible ocean surface properties after initialization, - !! the data in this type is intent(out). + intent(inout) :: Ocean_sfc !< A structure containing various publicly + !! visible ocean surface properties after initialization, + !! the data in this type is intent out. type(ocean_state_type), pointer :: OS !< A structure whose internal !! contents are private to ocean_model_mod that may be used to !! contain all information about the ocean's interior state. @@ -248,28 +238,22 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) !! in the calculation of additional gas or other !! tracer fluxes, and can be used to spawn related !! internal variables in the ice model. + ! Local variables + real :: Rho0 ! The Boussinesq ocean density [kg m-3]. + real :: G_Earth ! The gravitational acceleration [m s-2]. + real :: HFrz !< If HFrz > 0 (m), melt potential will be computed. + !! The actual depth over which melt potential is computed will + !! min(HFrz, OBLD), where OBLD is the boundary layer depth. + !! If HFrz <= 0 (default), melt potential will not be computed. + logical :: use_melt_pot!< If true, allocate melt_potential array -! This subroutine initializes both the ocean state and the ocean surface type. -! Because of the way that indicies and domains are handled, Ocean_sfc must have -! been used in a previous call to initialize_ocean_type. - -! Arguments: Ocean_sfc - A structure containing various publicly visible ocean -! surface properties after initialization, this is intent(out). -! (out,private) OS - A structure whose internal contents are private -! to ocean_model_mod that may be used to contain all -! information about the ocean's interior state. -! (in) Time_init - The start time for the coupled model's calendar. -! (in) Time_in - The time at which to initialize the ocean model. - real :: Rho0 ! The Boussinesq ocean density, in kg m-3. - real :: G_Earth ! The gravitational acceleration in m s-2. ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "ocean_model_init" ! This module's name. - character(len=48) :: stagger - integer :: secs, days + character(len=48) :: stagger ! A string indicating the staggering locations for the + ! surface velocities returned to the coupler. type(param_file_type) :: param_file !< A structure to parse for run-time parameters - logical :: use_temperature - type(time_type) :: dt_geometric, dt_savedays, dt_from_base + logical :: use_temperature ! If true, temperature and salinity are state variables. call callTree_enter("ocean_model_init(), ocean_model_MOM.F90") if (associated(OS)) then @@ -282,11 +266,11 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) OS%is_ocean_pe = Ocean_sfc%is_ocean_pe if (.not.OS%is_ocean_pe) return - OS%Time = Time_in + OS%Time = Time_in ; OS%Time_dyn = Time_in call initialize_MOM(OS%Time, Time_init, param_file, OS%dirs, OS%MOM_CSp, & OS%restart_CSp, Time_in, offline_tracer_mode=OS%offline_tracer_mode, & diag_ptr=OS%diag, count_calls=.true.) - call get_MOM_state_elements(OS%MOM_CSp, G=OS%grid, GV=OS%GV, C_p=OS%C_p, & + call get_MOM_state_elements(OS%MOM_CSp, G=OS%grid, GV=OS%GV, US=OS%US, C_p=OS%C_p, & use_temp=use_temperature) OS%fluxes%C_p = OS%C_p @@ -336,14 +320,6 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) else ; call MOM_error(FATAL,"ocean_model_init: OCEAN_SURFACE_STAGGER = "// & trim(stagger)//" is invalid.") ; endif - call get_param(param_file, mdl, "RESTORE_SALINITY",OS%restore_salinity, & - "If true, the coupled driver will add a globally-balanced \n"//& - "fresh-water flux that drives sea-surface salinity \n"//& - "toward specified values.", default=.false.) - call get_param(param_file, mdl, "RESTORE_TEMPERATURE",OS%restore_temp, & - "If true, the coupled driver will add a \n"//& - "heat flux that drives sea-surface temperauture \n"//& - "toward specified values.", default=.false.) 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"//& @@ -357,47 +333,45 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) call get_param(param_file, mdl, "ICE_SHELF", OS%use_ice_shelf, & "If true, enables the ice shelf model.", default=.false.) - call get_param(param_file, mdl, "ICEBERGS_APPLY_RIGID_BOUNDARY", OS%icebergs_apply_rigid_boundary, & + call get_param(param_file, mdl, "ICEBERGS_APPLY_RIGID_BOUNDARY", OS%icebergs_alter_ocean, & "If true, allows icebergs to change boundary condition felt by ocean", default=.false.) - if (OS%icebergs_apply_rigid_boundary) then - call get_param(param_file, mdl, "KV_ICEBERG", OS%kv_iceberg, & - "The viscosity of the icebergs", units="m2 s-1",default=1.0e10) - call get_param(param_file, mdl, "DENSITY_ICEBERGS", OS%density_iceberg, & - "A typical density of icebergs.", units="kg m-3", default=917.0) - call get_param(param_file, mdl, "LATENT_HEAT_FUSION", OS%latent_heat_fusion, & - "The latent heat of fusion.", units="J/kg", default=hlf) - call get_param(param_file, mdl, "BERG_AREA_THRESHOLD", OS%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"//& - " values.", units="non-dim", default=-1.0) - endif - OS%press_to_z = 1.0/(Rho0*G_Earth) ! 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 allocate_surface_state(OS%sfc_state, OS%grid, use_temperature, & - do_integrals=.true., gas_fields_ocn=gas_fields_ocn) + 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"//& + "melt potential will not be computed.", units="m", default=-1.0, do_not_log=.true.) + + if (HFrz .gt. 0.0) then + use_melt_pot=.true. + else + use_melt_pot=.false. + endif - call surface_forcing_init(Time_in, OS%grid, param_file, OS%diag, & - OS%forcing_CSp, OS%restore_salinity, OS%restore_temp) + call allocate_surface_state(OS%sfc_state, OS%grid, use_temperature, do_integrals=.true., & + gas_fields_ocn=gas_fields_ocn, use_meltpot=use_melt_pot) + + call surface_forcing_init(Time_in, OS%grid, OS%US, param_file, OS%diag, & + OS%forcing_CSp) if (OS%use_ice_shelf) then call initialize_ice_shelf(param_file, OS%grid, OS%Time, OS%ice_shelf_CSp, & OS%diag, OS%forces, OS%fluxes) endif - if (OS%icebergs_apply_rigid_boundary) then - !call allocate_forcing_type(OS%grid, OS%fluxes, iceberg=.true.) - !This assumes that the iceshelf and ocean are on the same grid. I hope this is true + if (OS%icebergs_alter_ocean) then + call marine_ice_init(OS%Time, OS%grid, param_file, OS%diag, OS%marine_ice_CSp) if (.not. OS%use_ice_shelf) & call allocate_forcing_type(OS%grid, OS%fluxes, shelf=.true.) endif - call get_param(param_file,mdl,"USE_WAVES",OS%Use_Waves,& - "If true, enables surface wave modules.",default=.false.) + call get_param(param_file, mdl, "USE_WAVES", OS%Use_Waves, & + "If true, enables surface wave modules.", default=.false.) if (OS%use_waves) then - call MOM_wave_interface_init(OS%Time,OS%grid,OS%GV,param_file,OS%Waves,OS%diag) + call MOM_wave_interface_init(OS%Time, OS%grid, OS%GV, OS%US, param_file, OS%Waves, OS%diag) else call MOM_wave_interface_init_lite(param_file) endif @@ -426,81 +400,75 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) call close_param_file(param_file) call diag_mediator_close_registration(OS%diag) - if (is_root_pe()) & - write(*,'(/12x,a/)') '======== COMPLETED MOM INITIALIZATION ========' + call MOM_mesg('==== Completed MOM6 Coupled Initialization ====', 2) call callTree_leave("ocean_model_init(") end subroutine ocean_model_init -! NAME="ocean_model_init" - - -!======================================================================= -! -! -! -! Update in time the ocean model fields. This code wraps the call to step_MOM -! with MOM4's call. -! -! !> update_ocean_model uses the forcing in Ice_ocean_boundary to advance the !! ocean model's state from the input value of Ocean_state (which must be for !! time time_start_update) for a time interval of Ocean_coupling_time_step, !! returning the publicly visible ocean surface properties in Ocean_sfc and !! storing the new ocean properties in Ocean_state. -subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & - time_start_update, Ocean_coupling_time_step, & - update_dyn, update_thermo) +subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_update, & + Ocean_coupling_time_step, update_dyn, update_thermo, & + Ocn_fluxes_used, start_cycle, end_cycle, cycle_length) type(ice_ocean_boundary_type), & - intent(in) :: Ice_ocean_boundary !< A structure containing the - !! various forcing fields coming from the ice. + intent(in) :: Ice_ocean_boundary !< A structure containing the various + !! forcing fields coming from the ice and atmosphere. type(ocean_state_type), & - pointer :: OS !< A pointer to a private structure containing - !! the internal ocean state. + pointer :: OS !< A pointer to a private structure containing the + !! internal ocean state. type(ocean_public_type), & - intent(inout) :: Ocean_sfc !< A structure containing all the - !! publicly visible ocean surface fields after - !! a coupling time step. The data in this type is - !! intent out. + intent(inout) :: Ocean_sfc !< A structure containing all the publicly visible + !! ocean surface fields after a coupling time step. + !! The data in this type is intent out. type(time_type), intent(in) :: time_start_update !< The time at the beginning of the update step. - type(time_type), intent(in) :: Ocean_coupling_time_step !< The amount of time over - !! which to advance the ocean. + type(time_type), intent(in) :: Ocean_coupling_time_step !< The amount of time over which to + !! advance the ocean. logical, optional, intent(in) :: update_dyn !< If present and false, do not do updates !! due to the ocean dynamics. logical, optional, intent(in) :: update_thermo !< If present and false, do not do updates !! due to the ocean thermodynamics or remapping. - - type(time_type) :: Master_time ! This allows step_MOM to temporarily change - ! the time that is seen by internal modules. - type(time_type) :: Time1 ! The value of the ocean model's time at the - ! start of a call to step_MOM. - integer :: index_bnds(4) ! The computational domain index bounds in the - ! ice-ocean boundary type. - real :: weight ! Flux accumulation weight - real :: dt_coupling ! The coupling time step in seconds. - integer :: nts ! The number of baroclinic dynamics time steps - ! within dt_coupling. - real :: dt_therm ! A limited and quantized version of OS%dt_therm (sec) - real :: dt_dyn ! The dynamics time step in sec. - real :: dtdia ! The diabatic time step in sec. - real :: t_elapsed_seg ! The elapsed time in this update segment, in s. - integer :: n, n_max, n_last_thermo - type(time_type) :: Time2 ! A temporary time. - logical :: thermo_does_span_coupling ! If true, thermodynamic forcing spans - ! multiple dynamic timesteps. - logical :: do_dyn, do_thermo - logical :: step_thermo ! If true, take a thermodynamic step. - integer :: secs, days + logical, optional, intent(in) :: Ocn_fluxes_used !< If present, this indicates whether the + !! cumulative thermodynamic fluxes from the ocean, + !! like frazil, have been used and should be reset. + logical, optional, intent(in) :: start_cycle !< This indicates whether this call is to be + !! treated as the first call to step_MOM in a + !! time-stepping cycle; missing is like true. + logical, optional, intent(in) :: end_cycle !< This indicates whether this call is to be + !! treated as the last call to step_MOM in a + !! time-stepping cycle; missing is like true. + real, optional, intent(in) :: cycle_length !< The duration of a coupled time stepping cycle [s]. + + ! Local variables + type(time_type) :: Time_seg_start ! Stores the dynamic or thermodynamic ocean model time at the + ! start of this call to allow step_MOM to temporarily change the time + ! as seen by internal modules. + type(time_type) :: Time_thermo_start ! Stores the ocean model thermodynamics time at the start of + ! this call to allow step_MOM to temporarily change the time as seen by + ! internal modules. + type(time_type) :: Time1 ! The value of the ocean model's time at the start of a call to step_MOM. + integer :: index_bnds(4) ! The computational domain index bounds in the ice-ocean boundary type. + real :: weight ! Flux accumulation weight of the current fluxes. + real :: dt_coupling ! The coupling time step [s]. + real :: dt_therm ! A limited and quantized version of OS%dt_therm [s]. + real :: dt_dyn ! The dynamics time step [s]. + real :: dtdia ! The diabatic time step [s]. + real :: t_elapsed_seg ! The elapsed time in this update segment [s]. + integer :: n ! The internal iteration counter. + integer :: nts ! The number of baroclinic dynamics time steps in a thermodynamic step. + integer :: n_max ! The number of calls to step_MOM dynamics in this call to update_ocean_model. + integer :: n_last_thermo ! The iteration number the last time thermodynamics were updated. + logical :: thermo_does_span_coupling ! If true, thermodynamic forcing spans multiple dynamic timesteps. + logical :: do_dyn ! If true, step the ocean dynamics and transport. + logical :: do_thermo ! If true, step the ocean thermodynamics. + logical :: step_thermo ! If true, take a thermodynamic step. integer :: is, ie, js, je call callTree_enter("update_ocean_model(), ocean_model_MOM.F90") - call get_time(Ocean_coupling_time_step, secs, days) - dt_coupling = 86400.0*real(days) + real(secs) + dt_coupling = time_type_to_real(Ocean_coupling_time_step) - if (time_start_update /= OS%Time) then - call MOM_error(WARNING, "update_ocean_model: internal clock does not "//& - "agree with time_start_update argument.") - endif if (.not.associated(OS)) then call MOM_error(FATAL, "update_ocean_model called with an unassociated "// & "ocean_state_type structure. ocean_model_init must be "// & @@ -511,89 +479,112 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & do_dyn = .true. ; if (present(update_dyn)) do_dyn = update_dyn do_thermo = .true. ; if (present(update_thermo)) do_thermo = update_thermo + if (do_thermo .and. (time_start_update /= OS%Time)) & + call MOM_error(WARNING, "update_ocean_model: internal clock does not "//& + "agree with time_start_update argument.") + if (do_dyn .and. (time_start_update /= OS%Time_dyn)) & + call MOM_error(WARNING, "update_ocean_model: internal dynamics clock does not "//& + "agree with time_start_update argument.") + + if (.not.(do_dyn .or. do_thermo)) call MOM_error(FATAL, & + "update_ocean_model called without updating either dynamics or thermodynamics.") + if (do_dyn .and. do_thermo .and. (OS%Time /= OS%Time_dyn)) call MOM_error(FATAL, & + "update_ocean_model called to update both dynamics and thermodynamics with inconsistent clocks.") + ! This is benign but not necessary if ocean_model_init_sfc was called or if ! OS%sfc_state%tr_fields was spawned in ocean_model_init. Consider removing it. is = OS%grid%isc ; ie = OS%grid%iec ; js = OS%grid%jsc ; je = OS%grid%jec call coupler_type_spawn(Ocean_sfc%fields, OS%sfc_state%tr_fields, & (/is,is,ie,ie/), (/js,js,je,je/), as_needed=.true.) - ! Translate Ice_ocean_boundary into fluxes. + ! Translate Ice_ocean_boundary into fluxes and forces. call mpp_get_compute_domain(Ocean_sfc%Domain, index_bnds(1), index_bnds(2), & index_bnds(3), index_bnds(4)) - weight = 1.0 - - if (OS%fluxes%fluxes_used) then - call enable_averaging(dt_coupling, OS%Time + Ocean_coupling_time_step, OS%diag) ! Needed to allow diagnostics in convert_IOB - call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%forces, OS%fluxes, index_bnds, OS%Time, & - OS%grid, OS%forcing_CSp, OS%sfc_state, OS%restore_salinity,OS%restore_temp) + if (do_dyn) then + call convert_IOB_to_forces(Ice_ocean_boundary, OS%forces, index_bnds, OS%Time_dyn, OS%grid, OS%US, & + OS%forcing_CSp, dt_forcing=dt_coupling, reset_avg=OS%fluxes%fluxes_used) + if (OS%use_ice_shelf) & + call add_shelf_forces(OS%grid, OS%Ice_shelf_CSp, OS%forces) + if (OS%icebergs_alter_ocean) & + call iceberg_forces(OS%grid, OS%forces, OS%use_ice_shelf, & + OS%sfc_state, dt_coupling, OS%marine_ice_CSp) + endif - ! Add ice shelf fluxes - if (OS%use_ice_shelf) then - call shelf_calc_flux(OS%sfc_state, OS%forces, OS%fluxes, OS%Time, dt_coupling, OS%Ice_shelf_CSp) - endif - if (OS%icebergs_apply_rigid_boundary) then - !This assumes that the iceshelf and ocean are on the same grid. I hope this is true - call add_berg_flux_to_shelf(OS%grid, OS%forces, OS%fluxes, OS%use_ice_shelf, & - OS%density_iceberg, OS%kv_iceberg, OS%latent_heat_fusion, OS%sfc_state, & - dt_coupling, OS%berg_area_threshold) - endif + if (do_thermo) then + if (OS%fluxes%fluxes_used) then + call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%fluxes, index_bnds, OS%Time, & + OS%grid, OS%US, OS%forcing_CSp, OS%sfc_state) - ! Fields that exist in both the forcing and mech_forcing types must be copied. - call copy_common_forcing_fields(OS%forces, OS%fluxes, OS%grid) + ! Add ice shelf fluxes + if (OS%use_ice_shelf) & + call shelf_calc_flux(OS%sfc_state, OS%fluxes, OS%Time, dt_coupling, OS%Ice_shelf_CSp) + if (OS%icebergs_alter_ocean) & + call iceberg_fluxes(OS%grid, OS%fluxes, OS%use_ice_shelf, & + OS%sfc_state, dt_coupling, OS%marine_ice_CSp) #ifdef _USE_GENERIC_TRACER - call MOM_generic_tracer_fluxes_accumulate(OS%fluxes, weight) !here weight=1, just saving the current fluxes + call enable_averaging(dt_coupling, OS%Time + Ocean_coupling_time_step, OS%diag) !Is this needed? + call MOM_generic_tracer_fluxes_accumulate(OS%fluxes, 1.0) ! Here weight=1, so just store the current fluxes + call disable_averaging(OS%diag) #endif - ! Indicate that there are new unused fluxes. - OS%fluxes%fluxes_used = .false. - OS%fluxes%dt_buoy_accum = dt_coupling - else - OS%flux_tmp%C_p = OS%fluxes%C_p - call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%forces, OS%flux_tmp, index_bnds, OS%Time, & - OS%grid, OS%forcing_CSp, OS%sfc_state, OS%restore_salinity,OS%restore_temp) - if (OS%use_ice_shelf) then - call shelf_calc_flux(OS%sfc_state, OS%forces, OS%flux_tmp, OS%Time, dt_coupling, OS%Ice_shelf_CSp) - endif - if (OS%icebergs_apply_rigid_boundary) then - !This assumes that the iceshelf and ocean are on the same grid. I hope this is true - call add_berg_flux_to_shelf(OS%grid, OS%forces, OS%flux_tmp, OS%use_ice_shelf, OS%density_iceberg, & - OS%kv_iceberg, OS%latent_heat_fusion, OS%sfc_state, dt_coupling, OS%berg_area_threshold) - endif - - call forcing_accumulate(OS%flux_tmp, OS%forces, OS%fluxes, dt_coupling, OS%grid, weight) - ! Some of the fields that exist in both the forcing and mech_forcing types - ! are time-averages must be copied back to the forces type. - call copy_back_forcing_fields(OS%fluxes, OS%forces, OS%grid) - + ! Indicate that there are new unused fluxes. + OS%fluxes%fluxes_used = .false. + OS%fluxes%dt_buoy_accum = dt_coupling + else + ! The previous fluxes have not been used yet, so translate the input fluxes + ! into a temporary type and then accumulate them in about 20 lines. + OS%flux_tmp%C_p = OS%fluxes%C_p + call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%flux_tmp, index_bnds, OS%Time, & + OS%grid, OS%US, OS%forcing_CSp, OS%sfc_state) + + if (OS%use_ice_shelf) & + call shelf_calc_flux(OS%sfc_state, OS%flux_tmp, OS%Time, dt_coupling, OS%Ice_shelf_CSp) + if (OS%icebergs_alter_ocean) & + call iceberg_fluxes(OS%grid, OS%flux_tmp, OS%use_ice_shelf, & + OS%sfc_state, dt_coupling, OS%marine_ice_CSp) + + call fluxes_accumulate(OS%flux_tmp, OS%fluxes, dt_coupling, OS%grid, weight) #ifdef _USE_GENERIC_TRACER - call MOM_generic_tracer_fluxes_accumulate(OS%flux_tmp, weight) !weight of the current flux in the running average + ! Incorporate the current tracer fluxes into the running averages + call MOM_generic_tracer_fluxes_accumulate(OS%flux_tmp, weight) #endif + endif endif - call set_derived_forcing_fields(OS%forces, OS%fluxes, OS%grid, OS%GV%Rho0) - call set_net_mass_forcing(OS%fluxes, OS%forces, OS%grid) - if (OS%use_waves) then - call Update_Surface_Waves(OS%grid, OS%GV, OS%time, ocean_coupling_time_step, OS%waves) + ! The net mass forcing is not currently used in the MOM6 dynamics solvers, so this is may be unnecessary. + if (do_dyn .and. associated(OS%forces%net_mass_src) .and. .not.OS%forces%net_mass_src_set) & + call get_net_mass_forcing(OS%fluxes, OS%grid, OS%forces%net_mass_src) + + if (OS%use_waves .and. do_thermo) then + ! For now, the waves are only updated on the thermodynamics steps, because that is where + ! the wave intensities are actually used to drive mixing. At some point, the wave updates + ! might also need to become a part of the ocean dynamics, according to B. Reichl. + call Update_Surface_Waves(OS%grid, OS%GV, OS%US, OS%time, ocean_coupling_time_step, OS%waves) endif - if (OS%nstep==0) then - call finish_MOM_initialization(OS%Time, OS%dirs, OS%MOM_CSp, OS%fluxes, & - OS%restart_CSp) + if ((OS%nstep==0) .and. (OS%nstep_thermo==0)) then ! This is the first call to update_ocean_model. + call finish_MOM_initialization(OS%Time, OS%dirs, OS%MOM_CSp, OS%restart_CSp) endif - call disable_averaging(OS%diag) - Master_time = OS%Time ; Time1 = OS%Time + Time_thermo_start = OS%Time + Time_seg_start = OS%Time ; if (do_dyn) Time_seg_start = OS%Time_dyn + Time1 = Time_seg_start - if(OS%offline_tracer_mode) then + if (OS%offline_tracer_mode .and. do_thermo) then call step_offline(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp) + elseif ((.not.do_thermo) .or. (.not.do_dyn)) then + ! The call sequence is being orchestrated from outside of update_ocean_model. + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, & + Waves=OS%Waves, do_dynamics=do_dyn, do_thermodynamics=do_thermo, & + start_cycle=start_cycle, end_cycle=end_cycle, cycle_length=cycle_length, & + reset_therm=Ocn_fluxes_used) elseif (OS%single_step_call) then call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, Waves=OS%Waves) - else + else ! Step both the dynamics and thermodynamics with separate calls. n_max = 1 ; if (dt_coupling > OS%dt) n_max = ceiling(dt_coupling/OS%dt - 0.001) dt_dyn = dt_coupling / real(n_max) - thermo_does_span_coupling = (OS%thermo_spans_coupling .and. & - (OS%dt_therm > 1.5*dt_coupling)) + thermo_does_span_coupling = (OS%thermo_spans_coupling .and. (OS%dt_therm > 1.5*dt_coupling)) if (thermo_does_span_coupling) then dt_therm = dt_coupling * floor(OS%dt_therm / dt_coupling + 0.001) @@ -603,7 +594,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & n_last_thermo = 0 endif - Time2 = Time1 ; t_elapsed_seg = 0.0 + Time1 = Time_seg_start ; t_elapsed_seg = 0.0 do n=1,n_max if (OS%diabatic_first) then if (thermo_does_span_coupling) call MOM_error(FATAL, & @@ -611,17 +602,17 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & "THERMO_SPANS_COUPLING and DIABATIC_FIRST.") if (modulo(n-1,nts)==0) then dtdia = dt_dyn*min(nts,n_max-(n-1)) - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dtdia, OS%MOM_CSp, & - do_dynamics=.false., do_thermodynamics=.true., & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dtdia, OS%MOM_CSp, & + Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) endif - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dt_dyn, OS%MOM_CSp, & - do_dynamics=.true., do_thermodynamics=.false., & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_dyn, OS%MOM_CSp, & + Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) else - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dt_dyn, OS%MOM_CSp, & - do_dynamics=.true., do_thermodynamics=.false., & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_dyn, OS%MOM_CSp, & + Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) step_thermo = .false. @@ -635,28 +626,32 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & endif if (step_thermo) then - ! Back up Time2 to the start of the thermodynamic segment. - Time2 = Time2 - set_time(int(floor((dtdia - dt_dyn) + 0.5))) - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dtdia, OS%MOM_CSp, & - do_dynamics=.false., do_thermodynamics=.true., & + ! Back up Time1 to the start of the thermodynamic segment. + Time1 = Time1 - real_to_time(dtdia - dt_dyn) + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dtdia, OS%MOM_CSp, & + Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) endif endif t_elapsed_seg = t_elapsed_seg + dt_dyn - Time2 = Time1 + set_time(int(floor(t_elapsed_seg + 0.5))) + Time1 = Time_seg_start + real_to_time(t_elapsed_seg) enddo endif - OS%Time = Master_time + Ocean_coupling_time_step - OS%nstep = OS%nstep + 1 + if (do_dyn) OS%Time_dyn = Time_seg_start + Ocean_coupling_time_step + if (do_dyn) OS%nstep = OS%nstep + 1 + OS%Time = Time_thermo_start ! Reset the clock to compensate for shared pointers. + if (do_thermo) OS%Time = OS%Time + Ocean_coupling_time_step + if (do_thermo) OS%nstep_thermo = OS%nstep_thermo + 1 - call enable_averaging(dt_coupling, OS%Time, OS%diag) - call mech_forcing_diags(OS%forces, OS%fluxes, dt_coupling, OS%grid, & - OS%diag, OS%forcing_CSp%handles) - call disable_averaging(OS%diag) + if (do_dyn) then + call enable_averaging(dt_coupling, OS%Time_dyn, OS%diag) + call mech_forcing_diags(OS%forces, dt_coupling, OS%grid, OS%diag, OS%forcing_CSp%handles) + call disable_averaging(OS%diag) + endif - if (OS%fluxes%fluxes_used) then + if (OS%fluxes%fluxes_used .and. do_thermo) then call enable_averaging(OS%fluxes%dt_buoy_accum, OS%Time, OS%diag) call forcing_diagnostics(OS%fluxes, OS%sfc_state, OS%fluxes%dt_buoy_accum, & OS%grid, OS%diag, OS%forcing_CSp%handles) @@ -667,131 +662,18 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & ! call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, & ! Ice_ocean_boundary%p, OS%press_to_z) call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid) - call coupler_type_send_data(Ocean_sfc%fields, OS%Time) + Time1 = OS%Time ; if (do_dyn) Time1 = OS%Time_dyn + call coupler_type_send_data(Ocean_sfc%fields, Time1) call callTree_leave("update_ocean_model()") end subroutine update_ocean_model -! NAME="update_ocean_model" - -!======================================================================= -! -! -! -! write out restart file. -! Arguments: -! timestamp (optional, intent(in)) : A character string that represents the model time, -! used for writing restart. timestamp will append to -! the any restart file name as a prefix. -! -! - -subroutine add_berg_flux_to_shelf(G, forces, fluxes, use_ice_shelf, density_ice, kv_ice, & - latent_heat_fusion, sfc_state, time_step, berg_area_threshold) - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(forcing), intent(inout) :: fluxes - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - logical, intent(in) :: use_ice_shelf !< If true, this configuration uses ice shelves. - real, intent(in) :: kv_ice !< The viscosity of ice, in m2 s-1. - real, intent(in) :: density_ice !< A typical density of ice, in kg m-3. - real, intent(in) :: latent_heat_fusion !< The latent heat of fusion, in J kg-1. - real, intent(in) :: time_step !< The coupling time step, in s. - real, intent(in) :: berg_area_threshold !< Area threshold for zeroing fluxes below iceberg -! Arguments: -! (in) fluxes - A structure of surface fluxes that may be used. -! (in) G - The ocean's grid structure. - real :: fraz ! refreezing rate in kg m-2 s-1 - real :: I_dt_LHF ! The inverse of the timestep times the latent heat of fusion, in kg J-1 s-1. - real :: kv_rho_ice ! The viscosity of ice divided by its density, in m5 kg-1 s-1. - integer :: i, j, is, ie, js, je, isd, ied, jsd, jed - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed - !This routine adds iceberg data to the ice shelf data (if ice shelf is used) - !which can then be used to change the top of ocean boundary condition used in - !the ocean model. This routine is taken from the add_shelf_flux subroutine - !within the ice shelf model. - - if (.not. (((associated(fluxes%frac_shelf_h) .and. associated(forces%frac_shelf_u)) & - .and.(associated(forces%frac_shelf_v) .and. associated(fluxes%ustar_shelf)))& - .and.(associated(forces%rigidity_ice_u) .and. associated(forces%rigidity_ice_v)))) return - - if (.not.(associated(fluxes%area_berg) .and. associated(fluxes%ustar_berg) .and. & - associated(fluxes%mass_berg) ) ) return - - if (.not. use_ice_shelf) then - fluxes%frac_shelf_h(:,:) = 0. - forces%frac_shelf_u(:,:) = 0. - forces%frac_shelf_v(:,:) = 0. - fluxes%ustar_shelf(:,:) = 0. - forces%rigidity_ice_u(:,:) = 0. - forces%rigidity_ice_v(:,:) = 0. - endif - - kv_rho_ice = kv_ice / density_ice - - do j=jsd,jed ; do i=isd,ied - if (G%areaT(i,j) > 0.0) & - fluxes%frac_shelf_h(i,j) = fluxes%frac_shelf_h(i,j) + fluxes%area_berg(i,j) - fluxes%ustar_shelf(i,j) = fluxes%ustar_shelf(i,j) + fluxes%ustar_berg(i,j) - enddo ; enddo - do j=jsd,jed ; do I=isd,ied-1 - forces%frac_shelf_u(I,j) = 0.0 - if ((G%areaT(i,j) + G%areaT(i+1,j) > 0.0)) & ! .and. (G%dxdy_u(I,j) > 0.0)) & - forces%frac_shelf_u(I,j) = forces%frac_shelf_u(I,j) + & - (((fluxes%area_berg(i,j)*G%areaT(i,j)) + & - (fluxes%area_berg(i+1,j)*G%areaT(i+1,j))) / & - (G%areaT(i,j) + G%areaT(i+1,j)) ) - forces%rigidity_ice_u(I,j) = forces%rigidity_ice_u(I,j) + kv_rho_ice * & - min(fluxes%mass_berg(i,j), fluxes%mass_berg(i+1,j)) - enddo ; enddo - do J=jsd,jed-1 ; do i=isd,ied - forces%frac_shelf_v(i,J) = 0.0 - if ((G%areaT(i,j) + G%areaT(i,j+1) > 0.0)) & ! .and. (G%dxdy_v(i,J) > 0.0)) & - forces%frac_shelf_v(i,J) = forces%frac_shelf_v(i,J) + & - (((fluxes%area_berg(i,j)*G%areaT(i,j)) + & - (fluxes%area_berg(i,j+1)*G%areaT(i,j+1))) / & - (G%areaT(i,j) + G%areaT(i,j+1)) ) - forces%rigidity_ice_v(i,J) = forces%rigidity_ice_v(i,J) + kv_rho_ice * & - min(fluxes%mass_berg(i,j), fluxes%mass_berg(i,j+1)) - enddo ; enddo - call pass_vector(forces%frac_shelf_u, forces%frac_shelf_v, G%domain, TO_ALL, CGRID_NE) - - !Zero'ing out other fluxes under the tabular icebergs - if (berg_area_threshold >= 0.) then - I_dt_LHF = 1.0 / (time_step * latent_heat_fusion) - do j=jsd,jed ; do i=isd,ied - if (fluxes%frac_shelf_h(i,j) > berg_area_threshold) then !Only applying for ice shelf covering most of cell - - if (associated(fluxes%sw)) fluxes%sw(i,j) = 0.0 - if (associated(fluxes%lw)) fluxes%lw(i,j) = 0.0 - if (associated(fluxes%latent)) fluxes%latent(i,j) = 0.0 - if (associated(fluxes%evap)) fluxes%evap(i,j) = 0.0 - - ! Add frazil formation diagnosed by the ocean model (J m-2) in the - ! form of surface layer evaporation (kg m-2 s-1). Update lprec in the - ! control structure for diagnostic purposes. - - if (associated(sfc_state%frazil)) then - fraz = sfc_state%frazil(i,j) * I_dt_LHF - if (associated(fluxes%evap)) fluxes%evap(i,j) = fluxes%evap(i,j) - fraz - !CS%lprec(i,j)=CS%lprec(i,j) - fraz - sfc_state%frazil(i,j) = 0.0 - endif - - !Alon: Should these be set to zero too? - if (associated(fluxes%sens)) fluxes%sens(i,j) = 0.0 - if (associated(fluxes%salt_flux)) fluxes%salt_flux(i,j) = 0.0 - if (associated(fluxes%lprec)) fluxes%lprec(i,j) = 0.0 - endif - enddo ; enddo - endif - -end subroutine add_berg_flux_to_shelf +!> This subroutine writes out the ocean model restart file. subroutine ocean_model_restart(OS, timestamp) - type(ocean_state_type), pointer :: OS - character(len=*), intent(in), optional :: timestamp + type(ocean_state_type), pointer :: OS !< A pointer to the structure containing the + !! internal ocean state being saved to a restart file + character(len=*), optional, intent(in) :: timestamp !< An optional timestamp string that should be + !! prepended to the file name. (Currently this is unused.) if (.not.MOM_state_is_synchronized(OS%MOM_CSp)) & call MOM_error(WARNING, "End of MOM_main reached with inconsistent "//& @@ -823,13 +705,6 @@ subroutine ocean_model_restart(OS, timestamp) end subroutine ocean_model_restart ! NAME="ocean_model_restart" -!======================================================================= -! -! -! -! Close down the ocean model -! - !> ocean_model_end terminates the model run, saving the ocean state in a restart !! and deallocating any data associated with the ocean. subroutine ocean_model_end(Ocean_sfc, Ocean_state, Time) @@ -840,22 +715,11 @@ subroutine ocean_model_end(Ocean_sfc, Ocean_state, Time) !! upon termination. type(time_type), intent(in) :: Time !< The model time, used for writing restarts. -! This subroutine terminates the model run, saving the ocean state in a -! restart file and deallocating any data associated with the ocean. - -! Arguments: Ocean_sfc - An ocean_public_type structure that is to be -! deallocated upon termination. -! (inout) Ocean_state - A pointer to the structure containing the internal -! ocean state to be deallocated upon termination. -! (in) Time - The model time, used for writing restarts. - call ocean_model_save_restart(Ocean_state, Time) call diag_mediator_end(Time, Ocean_state%diag) call MOM_end(Ocean_state%MOM_CSp) if (Ocean_state%use_ice_shelf) call ice_shelf_end(Ocean_state%Ice_shelf_CSp) end subroutine ocean_model_end -! NAME="ocean_model_end" - !> ocean_model_save_restart causes restart files associated with the ocean to be !! written out. @@ -867,12 +731,6 @@ subroutine ocean_model_save_restart(OS, Time, directory, filename_suffix) !! write these restart files. character(len=*), optional, intent(in) :: filename_suffix !< An optional suffix (e.g., a time-stamp) !! to append to the restart file names. -! Arguments: Ocean_state - A structure containing the internal ocean state (in). -! (in) Time - The model time at this call. This is needed for mpp_write calls. -! (in, opt) directory - An optional directory into which to write these restart files. -! (in, opt) filename_suffix - An optional suffix (e.g., a time-stamp) to append -! to the restart file names. - ! Note: This is a new routine - it will need to exist for the new incremental ! checkpointing. It will also be called by ocean_model_end, giving the same ! restart behavior as now in FMS. @@ -899,14 +757,17 @@ subroutine ocean_model_save_restart(OS, Time, directory, filename_suffix) end subroutine ocean_model_save_restart -!======================================================================= - +!> Initialize the public ocean type subroutine initialize_ocean_public_type(input_domain, Ocean_sfc, diag, maskmap, & gas_fields_ocn) - type(domain2D), intent(in) :: input_domain - type(ocean_public_type), intent(inout) :: Ocean_sfc - type(diag_ctrl), intent(in) :: diag - logical, intent(in), optional :: maskmap(:,:) + type(domain2D), intent(in) :: input_domain !< The ocean model domain description + type(ocean_public_type), intent(inout) :: Ocean_sfc !< A structure containing various publicly + !! visible ocean surface properties after initialization, whose + !! elements are allocated here. + type(diag_ctrl), intent(in) :: diag !< A structure that regulates diagnsotic output + logical, dimension(:,:), & + optional, intent(in) :: maskmap !< A mask indicating which virtual processors + !! are actually in use. If missing, all are used. type(coupler_1d_bc_type), & optional, intent(in) :: gas_fields_ocn !< If present, this type describes the !! ocean and surface-ice fields that will participate @@ -920,7 +781,7 @@ subroutine initialize_ocean_public_type(input_domain, Ocean_sfc, diag, maskmap, call mpp_get_layout(input_domain,layout) call mpp_get_global_domain(input_domain, xsize=xsz, ysize=ysz) - if(PRESENT(maskmap)) then + if (PRESENT(maskmap)) then call mpp_define_domains((/1,xsz,1,ysz/),layout,Ocean_sfc%Domain, maskmap=maskmap) else call mpp_define_domains((/1,xsz,1,ysz/),layout,Ocean_sfc%Domain) @@ -951,20 +812,23 @@ subroutine initialize_ocean_public_type(input_domain, Ocean_sfc, diag, maskmap, end subroutine initialize_ocean_public_type -subroutine convert_state_to_ocean_type(sfc_state, Ocean_sfc, G, & - patm, press_to_z) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. +!> This subroutine translates the coupler's ocean_data_type into MOM's +!! surface state variable. This may eventually be folded into the MOM +!! code that calculates the surface state in the first place. +!! Note the offset in the arrays because the ocean_data_type has no +!! halo points in its arrays and always uses absolute indicies. +subroutine convert_state_to_ocean_type(sfc_state, Ocean_sfc, G, patm, press_to_z) + type(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. type(ocean_public_type), & - target, intent(inout) :: Ocean_sfc - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, optional, intent(in) :: patm(:,:) - real, optional, intent(in) :: press_to_z -! This subroutine translates the coupler's ocean_data_type into MOM's -! surface state variable. This may eventually be folded into the MOM -! code that calculates the surface state in the first place. -! Note the offset in the arrays because the ocean_data_type has no -! halo points in its arrays and always uses absolute indicies. + target, intent(inout) :: Ocean_sfc !< A structure containing various publicly + !! visible ocean surface fields, whose elements + !! have their data set here. + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, optional, intent(in) :: patm(:,:) !< The pressure at the ocean surface [Pa]. + real, optional, intent(in) :: press_to_z !< A conversion factor between pressure and + !! ocean depth in m, usually 1/(rho_0*g) [m Pa-1]. + ! Local variables real :: IgR0 character(len=48) :: val_str integer :: isc_bnd, iec_bnd, jsc_bnd, jec_bnd @@ -1057,21 +921,15 @@ subroutine convert_state_to_ocean_type(sfc_state, Ocean_sfc, G, & end subroutine convert_state_to_ocean_type - -!======================================================================= -! -! -! -! This subroutine extracts the surface properties from the ocean's internal -! state and stores them in the ocean type returned to the calling ice model. -! It has to be separate from the ocean_initialization call because the coupler -! module allocates the space for some of these variables. -! - +!> This subroutine extracts the surface properties from the ocean's internal +!! state and stores them in the ocean type returned to the calling ice model. +!! It has to be separate from the ocean_initialization call because the coupler +!! module allocates the space for some of these variables. subroutine ocean_model_init_sfc(OS, Ocean_sfc) - type(ocean_state_type), pointer :: OS - type(ocean_public_type), intent(inout) :: Ocean_sfc - + type(ocean_state_type), pointer :: OS !< The structure with the complete ocean state + type(ocean_public_type), intent(inout) :: Ocean_sfc !< A structure containing various publicly + !! visible ocean surface properties after initialization, whose + !! elements have their data set here. integer :: is, ie, js, je is = OS%grid%isc ; ie = OS%grid%iec ; js = OS%grid%jsc ; je = OS%grid%jec @@ -1083,7 +941,6 @@ subroutine ocean_model_init_sfc(OS, Ocean_sfc) call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid) end subroutine ocean_model_init_sfc -! !> ocean_model_flux_init is used to initialize properties of the air-sea fluxes !! as determined by various run-time parameters. It can be called from @@ -1108,16 +965,13 @@ subroutine ocean_model_flux_init(OS, verbosity) end subroutine ocean_model_flux_init -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! -! Ocean_stock_pe - returns stocks of heat, water, etc. for conservation checks.! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! !> Ocean_stock_pe - returns the integrated stocks of heat, water, etc. for conservation checks. !! Because of the way FMS is coded, only the root PE has the integrated amount, !! while all other PEs get 0. subroutine Ocean_stock_pe(OS, index, value, time_index) use stock_constants_mod, only : ISTOCK_WATER, ISTOCK_HEAT,ISTOCK_SALT type(ocean_state_type), pointer :: OS !< A structure containing the internal ocean state. - !! The data in OS is intent(in). + !! The data in OS is intent in. integer, intent(in) :: index !< The stock index for the quantity of interest. real, intent(out) :: value !< Sum returned for the conservation quantity of interest. integer, optional, intent(in) :: time_index !< An unused optional argument, present only for @@ -1153,13 +1007,18 @@ subroutine Ocean_stock_pe(OS, index, value, time_index) end subroutine Ocean_stock_pe -subroutine ocean_model_data2D_get(OS,Ocean, name, array2D,isc,jsc) +!> This subroutine extracts a named 2-D field from the ocean surface or public type +subroutine ocean_model_data2D_get(OS, Ocean, name, array2D, isc, jsc) use MOM_constants, only : CELSIUS_KELVIN_OFFSET - type(ocean_state_type), pointer :: OS - type(ocean_public_type), intent(in) :: Ocean - character(len=*) , intent(in) :: name - real, dimension(isc:,jsc:), intent(out):: array2D - integer , intent(in) :: isc,jsc + type(ocean_state_type), pointer :: OS !< A pointer to the structure containing the + !! internal ocean state (intent in). + type(ocean_public_type), intent(in) :: Ocean !< A structure containing various publicly + !! visible ocean surface fields. + character(len=*) , intent(in) :: name !< The name of the field to extract + real, dimension(isc:,jsc:), intent(out):: array2D !< The values of the named field, it must + !! cover only the computational domain + integer , intent(in) :: isc !< The starting i-index of array2D + integer , intent(in) :: jsc !< The starting j-index of array2D integer :: g_isc, g_iec, g_jsc, g_jec,g_isd, g_ied, g_jsd, g_jed, i, j @@ -1181,9 +1040,9 @@ subroutine ocean_model_data2D_get(OS,Ocean, name, array2D,isc,jsc) case('mask') array2D(isc:,jsc:) = OS%grid%mask2dT(g_isc:g_iec,g_jsc:g_jec) !OR same result -! do j=g_jsc,g_jec; do i=g_isc,g_iec +! do j=g_jsc,g_jec ; do i=g_isc,g_iec ! array2D(isc+i-g_isc,jsc+j-g_jsc) = OS%grid%mask2dT(i,j) -! enddo; enddo +! enddo ; enddo case('t_surf') array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET case('t_pme') @@ -1198,14 +1057,16 @@ subroutine ocean_model_data2D_get(OS,Ocean, name, array2D,isc,jsc) call MOM_error(FATAL,'get_ocean_grid_data2D: unknown argument name='//name) end select - end subroutine ocean_model_data2D_get -subroutine ocean_model_data1D_get(OS,Ocean, name, value) - type(ocean_state_type), pointer :: OS - type(ocean_public_type), intent(in) :: Ocean - character(len=*) , intent(in) :: name - real , intent(out):: value +!> This subroutine extracts a named scalar field from the ocean surface or public type +subroutine ocean_model_data1D_get(OS, Ocean, name, value) + type(ocean_state_type), pointer :: OS !< A pointer to the structure containing the + !! internal ocean state (intent in). + type(ocean_public_type), intent(in) :: Ocean !< A structure containing various publicly + !! visible ocean surface fields. + character(len=*) , intent(in) :: name !< The name of the field to extract + real , intent(out):: value !< The value of the named field if (.not.associated(OS)) return if (.not.OS%is_ocean_pe) return @@ -1217,27 +1078,28 @@ subroutine ocean_model_data1D_get(OS,Ocean, name, value) call MOM_error(FATAL,'get_ocean_grid_data1D: unknown argument name='//name) end select - end subroutine ocean_model_data1D_get +!> Write out FMS-format checsums on fields from the ocean surface state subroutine ocean_public_type_chksum(id, timestep, ocn) - character(len=*), intent(in) :: id - integer , intent(in) :: timestep - type(ocean_public_type), intent(in) :: ocn - integer :: n,m, outunit + character(len=*), intent(in) :: id !< An identifying string for this call + integer, intent(in) :: timestep !< The number of elapsed timesteps + type(ocean_public_type), intent(in) :: ocn !< A structure containing various publicly + !! visible ocean surface fields. + integer :: n, m, outunit - outunit = stdout() + outunit = stdout() - write(outunit,*) "BEGIN CHECKSUM(ocean_type):: ", id, timestep - write(outunit,100) 'ocean%t_surf ',mpp_chksum(ocn%t_surf ) - write(outunit,100) 'ocean%s_surf ',mpp_chksum(ocn%s_surf ) - write(outunit,100) 'ocean%u_surf ',mpp_chksum(ocn%u_surf ) - write(outunit,100) 'ocean%v_surf ',mpp_chksum(ocn%v_surf ) - write(outunit,100) 'ocean%sea_lev ',mpp_chksum(ocn%sea_lev) - write(outunit,100) 'ocean%frazil ',mpp_chksum(ocn%frazil ) + write(outunit,*) "BEGIN CHECKSUM(ocean_type):: ", id, timestep + write(outunit,100) 'ocean%t_surf ',mpp_chksum(ocn%t_surf ) + write(outunit,100) 'ocean%s_surf ',mpp_chksum(ocn%s_surf ) + write(outunit,100) 'ocean%u_surf ',mpp_chksum(ocn%u_surf ) + write(outunit,100) 'ocean%v_surf ',mpp_chksum(ocn%v_surf ) + write(outunit,100) 'ocean%sea_lev ',mpp_chksum(ocn%sea_lev) + write(outunit,100) 'ocean%frazil ',mpp_chksum(ocn%frazil ) - call coupler_type_write_chksums(ocn%fields, outunit, 'ocean%') + call coupler_type_write_chksums(ocn%fields, outunit, 'ocean%') 100 FORMAT(" CHECKSUM::",A20," = ",Z20) end subroutine ocean_public_type_chksum diff --git a/config_src/dynamic/MOM_memory.h b/config_src/dynamic/MOM_memory.h index b2773188de..c3385b8b9a 100644 --- a/config_src/dynamic/MOM_memory.h +++ b/config_src/dynamic/MOM_memory.h @@ -1,50 +1,39 @@ -!********+*********+*********+*********+*********+*********+*********+* -!* This include file determines the compile-time memory settings * -!* for the Modular Ocean Model (MOM), versions 6 and later. * -!********+*********+*********+*********+*********+*********+*********+* +!/// \brief Compile-time memory settings +!/// \details This include file determines the compile-time memory settings. +!/// There are several variants of this file and only one should be in the search path for compilation. +!/// \file MOM_memory.h -! Specify the numerical domain. +!/// The number of thickness grid points in the i-direction of the global domain. #define NIGLOBAL_ NONSENSE_NIGLOBAL +!/// The number of thickness grid points in the j-direction of the global domain. #define NJGLOBAL_ NONSENSE_NJGLOBAL - ! NIGLOBAL_ and NJGLOBAL_ are the number of thickness - ! grid points in the zonal and meridional - ! directions of the physical domain. +!/// The number of layers in the vertical direction. #define NK_ NONSENSE_NK - ! The number of layers. - -#undef STATIC_MEMORY_ - ! 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. -#undef SYMMETRIC_MEMORY_ - ! 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. +!/// The number of processors in the i-direction. #define NIPROC_ NONSENSE_NIPROC - ! NIPROC_ is the number of processors in the - ! x-direction. + +!/// The number of processors in the j-direction. #define NJPROC_ NONSENSE_NJPROC - ! NJPROC_ is the number of processors in the - ! y-direction. +!/// The maximum permitted number (each) of restart variables, time derivatives, etc. +!/// This is mostly used for the size of pointer arrays, so it should be set generously. #ifndef MAX_FIELDS_ #define MAX_FIELDS_ 50 #endif - ! The maximum permitted number (each) of - ! restart variables, time derivatives, etc. - ! This is mostly used for the size of pointer - ! arrays, so it should be set generously. +!/// The number of memory halo cells on each side of the computational domain in the i-direction. #define NIHALO_ 2 + +!/// The number of memory halo cells on each side of the computational domain in the j-direction. #define NJHALO_ 2 - ! NIHALO_ and NJHALO_ are the sizes of the - ! memory halos on each side. + +!/// If SYMMETRIC_MEMORY_() is 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. +#undef SYMMETRIC_MEMORY_ + +!/// If STATIC_MEMORY_ is defined, the principle variables have sizes that are statically determined at compile time. +!/// Otherwise the sizes are not determined until run time. +#undef STATIC_MEMORY_ #include diff --git a/config_src/dynamic_symmetric/MOM_memory.h b/config_src/dynamic_symmetric/MOM_memory.h index 125dcf212f..4188663a2c 100644 --- a/config_src/dynamic_symmetric/MOM_memory.h +++ b/config_src/dynamic_symmetric/MOM_memory.h @@ -1,33 +1,39 @@ -!/*! \brief Compile-time memory settings */ -!/*! \details This include file determines the compile-time memory settings. There are several variants of this file and only one should be in the search path for compilation. */ -!/*! \file MOM_memory.h */ +!/// \brief Compile-time memory settings +!/// \details This include file determines the compile-time memory settings. +!/// There are several variants of this file and only one should be in the search path for compilation. +!/// \file MOM_memory.h -!/*! The number of thickness grid points in the i-direction of the global domain. */ +!/// The number of thickness grid points in the i-direction of the global domain. #define NIGLOBAL_ NONSENSE_NIGLOBAL -!/*! The number of thickness grid points in the j-direction of the global domain. */ +!/// The number of thickness grid points in the j-direction of the global domain. #define NJGLOBAL_ NONSENSE_NJGLOBAL -!/*! The number of layers in the vertical direction. */ +!/// The number of layers in the vertical direction. #define NK_ NONSENSE_NK -!/*! \def STATIC_MEMORY_ 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. */ -#undef STATIC_MEMORY_ - -!/*! If SYMMETRIC_MEMORY_ is 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. */ -#define SYMMETRIC_MEMORY_ - -!/*! The number of processors in the i-direction. */ +!/// The number of processors in the i-direction. #define NIPROC_ NONSENSE_NIPROC -!/*! The number of processors in the j-direction. */ +!/// The number of processors in the j-direction. #define NJPROC_ NONSENSE_NJPROC -!/*! The maximum permitted number (each) of restart variables, time derivatives, etc. This is mostly used for the size of pointer arrays, so it should be set generously. */ +!/// The maximum permitted number (each) of restart variables, time derivatives, etc. +!/// This is mostly used for the size of pointer arrays, so it should be set generously. +#ifndef MAX_FIELDS_ #define MAX_FIELDS_ 50 +#endif -!/*! The number of memory halo cells on each side of the computational domain in the i-direction */ +!/// The number of memory halo cells on each side of the computational domain in the i-direction. #define NIHALO_ 2 -!/*! The number of memory halo cells on each side of the computational domain in the j-direction */ +!/// The number of memory halo cells on each side of the computational domain in the j-direction. #define NJHALO_ 2 +!/// If SYMMETRIC_MEMORY_() is 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. +#define SYMMETRIC_MEMORY_ + +!/// If STATIC_MEMORY_ is defined, the principle variables have sizes that are statically determined at compile time. +!/// Otherwise the sizes are not determined until run time. +#undef STATIC_MEMORY_ + #include diff --git a/config_src/ice_solo_driver/MOM_surface_forcing.F90 b/config_src/ice_solo_driver/MOM_surface_forcing.F90 index 5e4a52b69d..aec37b2a4a 100644 --- a/config_src/ice_solo_driver/MOM_surface_forcing.F90 +++ b/config_src/ice_solo_driver/MOM_surface_forcing.F90 @@ -72,9 +72,8 @@ module MOM_surface_forcing use MOM_time_manager, only : time_type, operator(+), operator(/), get_time, set_time use MOM_tracer_flow_control, only : call_tracer_set_forcing use MOM_tracer_flow_control, only : tracer_flow_control_CS +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface -! use MESO_surface_forcing, only : MESO_wind_forcing, MESO_buoyancy_forcing -! use MESO_surface_forcing, only : MESO_surface_forcing_init, MESO_surface_forcing_CS use user_surface_forcing, only : USER_wind_forcing, USER_buoyancy_forcing use user_surface_forcing, only : USER_surface_forcing_init, user_surface_forcing_CS use user_revise_forcing, only : user_alter_forcing, user_revise_forcing_init @@ -101,18 +100,18 @@ module MOM_surface_forcing real :: south_lat ! southern latitude of the domain real :: len_lat ! domain length in latitude - real :: Rho0 ! Boussinesq reference density (kg/m^3) - real :: G_Earth ! gravitational acceleration (m/s^2) - real :: Flux_const ! piston velocity for surface restoring (m/s) + real :: Rho0 ! Boussinesq reference density [kg m-3] + real :: G_Earth ! gravitational acceleration [m s-2] + real :: Flux_const ! piston velocity for surface restoring [m s-1] - real :: gust_const ! constant unresolved background gustiness for ustar (Pa) + real :: gust_const ! constant unresolved background gustiness for ustar [Pa] logical :: read_gust_2d ! if true, use 2-dimensional gustiness supplied from a file - real, pointer :: gust(:,:) => NULL() ! spatially varying unresolved background gustiness (Pa) + real, pointer :: gust(:,:) => NULL() ! spatially varying unresolved background gustiness [Pa] ! gust is used when read_gust_2d is true. - real, pointer :: T_Restore(:,:) => NULL() ! temperature to damp (restore) the SST to (deg C) - real, pointer :: S_Restore(:,:) => NULL() ! salinity to damp (restore) the SSS (g/kg) - real, pointer :: Dens_Restore(:,:) => NULL() ! density to damp (restore) surface density (kg/m^3) + real, pointer :: T_Restore(:,:) => NULL() ! temperature to damp (restore) the SST to [degC] + real, pointer :: S_Restore(:,:) => NULL() ! salinity to damp (restore) the SSS [ppt] + real, pointer :: Dens_Restore(:,:) => NULL() ! density to damp (restore) surface density [kg m-3] integer :: wind_last_lev_read = -1 ! The last time level read from the wind input files integer :: buoy_last_lev_read = -1 ! The last time level read from buoyancy input files @@ -166,28 +165,22 @@ module MOM_surface_forcing contains -subroutine set_forcing(sfc_state, forcing, fluxes, day_start, day_interval, G, CS) +!> This subroutine calls other subroutines in this file to get surface forcing fields. +!! It also allocates and initializes the fields in the flux type. +subroutine set_forcing(sfc_state, forcing, fluxes, day_start, day_interval, G, US, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(forcing), intent(inout) :: fluxes - type(time_type), intent(in) :: day_start - type(time_type), intent(in) :: day_interval + type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields + type(time_type), intent(in) :: day_start !< The start time of the fluxes + type(time_type), intent(in) :: day_interval !< Length of time over which these fluxes applied type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a + !! previous surface_forcing_init call -! This subroutine calls other subroutines in this file to get surface forcing fields. -! It also allocates and initializes the fields in the flux type. - -! Arguments: -! (inout) state = structure describing ocean surface state -! (inout) fluxes = structure with pointers to forcing fields; unused have NULL ptrs -! (in) day_start = Start time of the fluxes -! (in) day_interval = Length of time over which these fluxes applied -! (in) G = ocean grid structure -! (in) CS = pointer to control struct returned by previous surface_forcing_init call - - real :: dt ! length of time in seconds over which fluxes applied + ! Local variables + real :: dt ! length of time over which fluxes applied [s] type(time_type) :: day_center ! central time of the fluxes. integer :: intdt integer :: isd, ied, jsd, jed @@ -281,7 +274,7 @@ subroutine set_forcing(sfc_state, forcing, fluxes, day_start, day_interval, G, C ! Fields that exist in both the forcing and mech_forcing types must be copied. if (CS%variable_winds .or. CS%first_call_set_forcing) then call copy_common_forcing_fields(forces, fluxes, G) - call set_derived_forcing_fields(forces, fluxes, G, CS%Rho0) + call set_derived_forcing_fields(forces, fluxes, G, US, CS%Rho0) endif if ((CS%variable_buoyforce .or. CS%first_call_set_forcing) .and. & @@ -294,17 +287,13 @@ subroutine set_forcing(sfc_state, forcing, fluxes, day_start, day_interval, G, C call cpu_clock_end(id_clock_forcing) end subroutine set_forcing +!> This subroutine allocates arrays for buoyancy forcing. subroutine buoyancy_forcing_allocate(fluxes, G, CS) - type(forcing), intent(inout) :: fluxes + type(forcing), intent(inout) :: fluxes !< A structure with pointers to thermodynamic + !! forcing fields that will be allocated here type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS - -! This subroutine allocates arrays for buoyancy forcing. - -! Arguments: -! (inout) fluxes = structure with pointers to forcing fields; unused have NULL ptrs -! (in) G = ocean grid structure -! (in) CS = pointer to control struct returned by previous surface_forcing_init call + type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a + !! previous surface_forcing_init call integer :: isd, ied, jsd, jed isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -333,22 +322,16 @@ subroutine buoyancy_forcing_allocate(fluxes, G, CS) end subroutine buoyancy_forcing_allocate -subroutine wind_forcing_zero(sfc_state, forces, day, G, CS) +! This subroutine sets the surface wind stresses to zero +subroutine wind_forcing_zero(sfc_state, forces, day, G, US, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS - -! subroutine sets the surface wind stresses to zero - -! Arguments: -! state = structure describing ocean surface state -! (out) fluxes = structure with pointers to forcing fields; unused have NULL ptrs -! (in) day = time of the fluxes -! (in) G = ocean grid structure -! (in) CS = pointer to control struct returned by previous surface_forcing_init call + type(time_type), intent(in) :: day !< Time used for determining the fluxes. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a + !! previous surface_forcing_init call real :: PI integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq @@ -373,11 +356,11 @@ subroutine wind_forcing_zero(sfc_state, forces, day, G, CS) if (CS%read_gust_2d) then if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt(CS%gust(i,j)/CS%Rho0) + forces%ustar(i,j) = US%m_to_Z * sqrt(CS%gust(i,j)/CS%Rho0) enddo ; enddo ; endif else if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt(CS%gust_const/CS%Rho0) + forces%ustar(i,j) = US%m_to_Z * sqrt(CS%gust_const/CS%Rho0) enddo ; enddo ; endif endif @@ -385,23 +368,17 @@ subroutine wind_forcing_zero(sfc_state, forces, day, G, CS) end subroutine wind_forcing_zero +!> This subroutine sets the surface wind stresses according to double gyre. subroutine wind_forcing_2gyre(sfc_state, forces, day, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS - -! This subroutine sets the surface wind stresses according to double gyre. - -! Arguments: -! state = structure describing ocean surface state -! (out) fluxes = structure with pointers to forcing fields; unused have NULL ptrs -! (in) day = time of the fluxes -! (in) G = ocean grid structure -! (in) CS = pointer to control struct returned by previous surface_forcing_init call + type(time_type), intent(in) :: day !< Time used for determining the fluxes. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a + !! previous surface_forcing_init call + ! Local variables real :: PI integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB @@ -428,23 +405,17 @@ subroutine wind_forcing_2gyre(sfc_state, forces, day, G, CS) end subroutine wind_forcing_2gyre +!> This subroutine sets the surface wind stresses according to single gyre. subroutine wind_forcing_1gyre(sfc_state, forces, day, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS - -! This subroutine sets the surface wind stresses according to single gyre. - -! Arguments: -! state = structure describing ocean surface state -! (out) fluxes = structure with pointers to forcing fields; unused have NULL ptrs -! (in) day = time of the fluxes -! (in) G = ocean grid structure -! (in) CS = pointer to control struct returned by previous surface_forcing_init call + type(time_type), intent(in) :: day !< Time used for determining the fluxes. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a + !! previous surface_forcing_init call + ! Local variables real :: PI integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB @@ -470,23 +441,18 @@ subroutine wind_forcing_1gyre(sfc_state, forces, day, G, CS) end subroutine wind_forcing_1gyre -subroutine wind_forcing_gyres(sfc_state, forces, day, G, CS) +!> This subroutine sets the surface wind stresses according to gyres. +subroutine wind_forcing_gyres(sfc_state, forces, day, G, US, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS - -! This subroutine sets the surface wind stresses according to gyres. - -! Arguments: -! state = structure describing ocean surface state -! (out) fluxes = structure with pointers to forcing fields; unused have NULL ptrs -! (in) day = time of the fluxes -! (in) G = ocean grid structure -! (in) CS = pointer to control struct returned by previous surface_forcing_init call + type(time_type), intent(in) :: day !< Time used for determining the fluxes. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a + !! previous surface_forcing_init call + ! Local variables real :: PI, y integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB @@ -497,7 +463,7 @@ subroutine wind_forcing_gyres(sfc_state, forces, day, G, CS) isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - ! steady surface wind stresses (Pa) + ! steady surface wind stresses [Pa] PI = 4.0*atan(1.0) do j=jsd,jed ; do I=IsdB,IedB @@ -513,7 +479,7 @@ subroutine wind_forcing_gyres(sfc_state, forces, day, G, CS) ! set the friction velocity do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt(sqrt(0.5*(forces%tauy(i,j-1)*forces%tauy(i,j-1) + & + forces%ustar(i,j) = US%m_to_Z * sqrt(sqrt(0.5*(forces%tauy(i,j-1)*forces%tauy(i,j-1) + & forces%tauy(i,j)*forces%tauy(i,j) + forces%taux(i-1,j)*forces%taux(i-1,j) + & forces%taux(i,j)*forces%taux(i,j)))/CS%Rho0 + (CS%gust_const/CS%Rho0)) enddo ; enddo @@ -521,31 +487,25 @@ subroutine wind_forcing_gyres(sfc_state, forces, day, G, CS) call callTree_leave("wind_forcing_gyres") end subroutine wind_forcing_gyres - -subroutine wind_forcing_from_file(sfc_state, forces, day, G, CS) +!> This subroutine sets the surface wind stresses by reading a file. +subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS - -! This subroutine sets the surface wind stresses. - -! Arguments: -! state = structure describing ocean surface state -! (out) fluxes = structure with pointers to forcing fields; unused have NULL ptrs -! (in) day = time of the fluxes -! (in) G = ocean grid structure -! (in) CS = pointer to control struct returned by previous surface_forcing_init call + type(time_type), intent(in) :: day !< Time used for determining the fluxes. + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a + !! previous surface_forcing_init call + ! Local variables integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB integer :: time_lev ! With fields from a file, this must ! be reset, depending on the time. character(len=200) :: filename ! The name of the input file. real :: temp_x(SZI_(G),SZJ_(G)) ! Pseudo-zonal and psuedo-meridional - real :: temp_y(SZI_(G),SZJ_(G)) ! wind stresses at h-points, in Pa. + real :: temp_y(SZI_(G),SZJ_(G)) ! wind stresses at h-points [Pa]. integer :: days, seconds call callTree_enter("wind_forcing_from_file, MOM_surface_forcing.F90") @@ -580,12 +540,12 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, CS) if (CS%read_gust_2d) then do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt((sqrt(temp_x(i,j)*temp_x(i,j) + & + forces%ustar(i,j) = US%m_to_Z * sqrt((sqrt(temp_x(i,j)*temp_x(i,j) + & temp_y(i,j)*temp_y(i,j)) + CS%gust(i,j)) / CS%Rho0) enddo ; enddo else do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt(sqrt(temp_x(i,j)*temp_x(i,j) + & + forces%ustar(i,j) = US%m_to_Z * sqrt(sqrt(temp_x(i,j)*temp_x(i,j) + & temp_y(i,j)*temp_y(i,j))/CS%Rho0 + (CS%gust_const/CS%Rho0)) enddo ; enddo endif @@ -605,13 +565,13 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, CS) call pass_vector(forces%taux, forces%tauy, G%Domain, To_All) if (CS%read_gust_2d) then do j=js, je ; do i=is, ie - forces%ustar(i,j) = sqrt((sqrt(0.5*((forces%tauy(i,j-1)**2 + & + forces%ustar(i,j) = US%m_to_Z * sqrt((sqrt(0.5*((forces%tauy(i,j-1)**2 + & forces%tauy(i,j)**2) + (forces%taux(i-1,j)**2 + & forces%taux(i,j)**2))) + CS%gust(i,j)) / CS%Rho0 ) enddo ; enddo else do j=js, je ; do i=is, ie - forces%ustar(i,j) = sqrt(sqrt(0.5*((forces%tauy(i,j-1)**2 + & + forces%ustar(i,j) = US%m_to_Z * sqrt(sqrt(0.5*((forces%tauy(i,j-1)**2 + & forces%tauy(i,j)**2) + (forces%taux(i-1,j)**2 + & forces%taux(i,j)**2)))/CS%Rho0 + (CS%gust_const/CS%Rho0)) enddo ; enddo @@ -627,30 +587,21 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, CS) end subroutine wind_forcing_from_file +!> This subroutine specifies the current surface fluxes of buoyancy, temperature and fresh water +!! by reading a file. It may also be modified to add surface fluxes of user provided tracers. subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. - type(forcing), intent(inout) :: fluxes - type(time_type), intent(in) :: day + type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields + type(time_type), intent(in) :: day !< Time used for determining the fluxes. real, intent(in) :: dt !< The amount of time over which - !! the fluxes apply, in s + !! the fluxes apply [s] type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS - -! This subroutine specifies the current surface fluxes of buoyancy -! temperature and fresh water. It may also be modified to add -! surface fluxes of user provided tracers. -! -! Arguments: -! state = structure describing ocean surface state -! (out) fluxes = structure with pointers to forcing fields; unused have NULL ptrs -! (in) day = time of the fluxes -! (in) dt = amount of time over which the fluxes apply -! (in) G = ocean grid structure -! (in) CS = pointer to control struct returned by previous surface_forcing_init call - - real :: rhoXcp ! mean density times the heat capacity, in J m-3 K-1. - real :: Irho0 ! inverse Boussinesq reference density, in m3 kg-1. + type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a + !! previous surface_forcing_init call + + real :: rhoXcp ! mean density times the heat capacity [J m-3 degC-1]. + real :: Irho0 ! inverse Boussinesq reference density [m3 kg-1]. integer :: i, j, is, ie, js, je, isd, ied, jsd, jed integer :: time_lev ! With fields from a file, this must @@ -661,12 +612,12 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, CS) real, dimension(SZI_(G),SZJ_(G)) :: & temp, & ! A 2-d temporary work array with various units. SST_anom, & ! Instantaneous sea surface temperature anomalies from a - ! target (observed) value, in deg C. + ! target (observed) value [degC]. SSS_anom, & ! Instantaneous sea surface salinity anomalies from a target - ! (observed) value, in g kg-1. + ! (observed) value [ppt]. SSS_mean ! A (mean?) salinity about which to normalize local salinity ! anomalies when calculating restorative precipitation - ! anomalies, in g kg-1. + ! anomalies [ppt]. call callTree_enter("buoyancy_forcing_from_files, MOM_surface_forcing.F90") @@ -832,28 +783,19 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, CS) end subroutine buoyancy_forcing_from_files +!> This subroutine specifies the current surface fluxes of buoyancy, temperature and fresh water. +!! It may also be modified to add surface fluxes of user provided tracers. +!! This case has zero surface buoyancy forcing. subroutine buoyancy_forcing_zero(sfc_state, fluxes, day, dt, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. - type(forcing), intent(inout) :: fluxes - type(time_type), intent(in) :: day + type(forcing), intent(inout) :: fluxes !< A structure with pointers to thermodynamic forcing fields + type(time_type), intent(in) :: day !< Time used for determining the fluxes. real, intent(in) :: dt !< The amount of time over which - !! the fluxes apply, in s + !! the fluxes apply [s] type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS - -! This subroutine specifies the current surface fluxes of buoyancy -! temperature and fresh water. It may also be modified to add -! surface fluxes of user provided tracers. -! This case has zero surface buoyancy forcing. - -! Arguments: -! (inout) state = structure describing ocean surface state -! (inout) fluxes = structure with pointers to forcing fields; unused have NULL ptrs -! (in) day = time of the fluxes -! (in) dt = amount of time over which the fluxes apply -! (in) G = ocean grid structure -! (in) CS = pointer to control struct returned by previous surface_forcing_init call + type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a + !! previous surface_forcing_init call integer :: i, j, is, ie, js, je @@ -861,7 +803,6 @@ subroutine buoyancy_forcing_zero(sfc_state, fluxes, day, dt, G, CS) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - ! allocate and initialize arrays call buoyancy_forcing_allocate(fluxes, G, CS) @@ -890,29 +831,20 @@ subroutine buoyancy_forcing_zero(sfc_state, fluxes, day, dt, G, CS) call callTree_leave("buoyancy_forcing_zero") end subroutine buoyancy_forcing_zero - +!> This subroutine specifies the current surface fluxes of buoyancy, temperature and fresh water. +!! It may also be modified to add surface fluxes of user provided tracers. subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. - type(forcing), intent(inout) :: fluxes - type(time_type), intent(in) :: day + type(forcing), intent(inout) :: fluxes !< A structure with pointers to thermodynamic forcing fields + type(time_type), intent(in) :: day !< Time used for determining the fluxes. real, intent(in) :: dt !< The amount of time over which !! the fluxes apply, in s type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS - -! This subroutine specifies the current surface fluxes of buoyancy -! temperature and fresh water. It may also be modified to add -! surface fluxes of user provided tracers. -! -! Arguments: -! (inout) state = structure describing ocean surface state -! (inout) fluxes = structure with pointers to forcing fields; unused have NULL ptrs -! (in) day = time of the fluxes -! (in) dt = amount of time over which the fluxes apply -! (in) G = ocean grid structure -! (in) CS = pointer to control struct returned by previous surface_forcing_init call + type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a + !! previous surface_forcing_init call + ! Local variables real :: y, T_restore, S_restore integer :: i, j, is, ie, js, je @@ -985,24 +917,19 @@ subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, CS) call callTree_leave("buoyancy_forcing_linear") end subroutine buoyancy_forcing_linear - +!> Save any restart files associated with the surface forcing. subroutine forcing_save_restart(CS, G, Time, directory, time_stamped, & filename_suffix) - type(surface_forcing_CS), pointer :: CS + type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned + !! by a previous call to surface_forcing_init type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(time_type), intent(in) :: Time - character(len=*), intent(in) :: directory - logical, optional, intent(in) :: time_stamped - character(len=*), optional, intent(in) :: filename_suffix -! Arguments: CS - A pointer to the control structure returned by a previous -! call to surface_forcing_init. -! (in) G - The ocean's grid structure. -! (in) Time - The model time at this call. This is needed for mpp_write calls. -! (in, opt) directory - An optional directory into which to write these restart files. -! (in, opt) time_stamped - If true, the restart file names include -! a unique time stamp. The default is false. -! (in, opt) filename_suffix - An optional suffix (e.g., a time-stamp) to append -! to the restart file names. + type(time_type), intent(in) :: Time !< The current model time + character(len=*), intent(in) :: directory !< The directory into which to write the + !! restart files + logical, optional, intent(in) :: time_stamped !< If true, the restart file names include + !! a unique time stamp. The default is false. + character(len=*), optional, intent(in) :: filename_suffix !< An optional suffix (e.g., a time- + !! stamp) to append to the restart file names. if (.not.associated(CS)) return if (.not.associated(CS%restart_CSp)) return @@ -1011,22 +938,19 @@ subroutine forcing_save_restart(CS, G, Time, directory, time_stamped, & end subroutine forcing_save_restart -subroutine surface_forcing_init(Time, G, param_file, diag, CS, tracer_flow_CSp) - type(time_type), intent(in) :: Time +!> Initialize the surface forcing, including setting parameters and allocating permanent memory. +subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_CSp) + type(time_type), intent(in) :: Time !< The current model time type(ocean_grid_type), intent(in) :: G !< The ocean's 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(in) :: diag - type(surface_forcing_CS), pointer :: CS - type(tracer_flow_control_CS), pointer :: tracer_flow_CSp -! Arguments: Time - The current model time. -! (in) G - The ocean's grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in) diag - A structure that is used to regulate diagnostic output. -! (in/out) CS - A pointer that is set to point to the control structure -! for this module -! (in) tracer_flow_CSp - A pointer to the control structure of the tracer -! flow control module. + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate diagnostic output. + type(surface_forcing_CS), pointer :: CS !< A pointer that is set to point to the control structure + !! for this module + type(tracer_flow_control_CS), pointer :: tracer_flow_CSp !< A pointer to the control structure of + !! the tracer flow control module. + + ! Local variables type(directories) :: dirs logical :: new_sim type(time_type) :: Time_frc @@ -1228,7 +1152,7 @@ subroutine surface_forcing_init(Time, G, param_file, diag, CS, tracer_flow_CSp) ! call MESO_surface_forcing_init(Time, G, param_file, diag, CS%MESO_forcing_CSp) endif - call register_forcing_type_diags(Time, diag, CS%use_temperature, CS%handles) + call register_forcing_type_diags(Time, diag, US, CS%use_temperature, CS%handles) ! Set up any restart fields associated with the forcing. call restart_init(G, param_file, CS%restart_CSp, "MOM_forcing.res") @@ -1255,14 +1179,13 @@ subroutine surface_forcing_init(Time, G, param_file, diag, CS, tracer_flow_CSp) call cpu_clock_end(id_clock_forcing) end subroutine surface_forcing_init - +!> Clean up and deallocate any memory associated with this module and its children. subroutine surface_forcing_end(CS, fluxes) - type(surface_forcing_CS), pointer :: CS - type(forcing), optional, intent(inout) :: fluxes -! Arguments: CS - A pointer to the control structure returned by a previous -! call to surface_forcing_init, it will be deallocated here. -! (inout) fluxes - A structure containing pointers to any possible -! forcing fields. Unused fields have NULL ptrs. + type(surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned + !! by a previous surface_forcing_init call + !! that will be deallocated here. + type(forcing), optional, intent(inout) :: fluxes !< A structure containing pointers to any possible + !! forcing fields that will be deallocated here. if (present(fluxes)) call deallocate_forcing_type(fluxes) diff --git a/config_src/ice_solo_driver/atmos_ocean_fluxes.F90 b/config_src/ice_solo_driver/atmos_ocean_fluxes.F90 index 66b2463ae7..5494954398 100644 --- a/config_src/ice_solo_driver/atmos_ocean_fluxes.F90 +++ b/config_src/ice_solo_driver/atmos_ocean_fluxes.F90 @@ -10,21 +10,23 @@ module atmos_ocean_fluxes_mod contains +!> This subroutine duplicates an interface used by the FMS coupler, but only +!! returns a value of -1. None of the arguments are used for anything. function aof_set_coupler_flux(name, flux_type, implementation, atm_tr_index, & param, flag, ice_restart_file, ocean_restart_file, & units, caller, verbosity) result (coupler_index) - character(len=*), intent(in) :: name - character(len=*), intent(in) :: flux_type - character(len=*), intent(in) :: implementation - integer, intent(in), optional :: atm_tr_index - real, intent(in), dimension(:), optional :: param - logical, intent(in), dimension(:), optional :: flag - character(len=*), intent(in), optional :: ice_restart_file - character(len=*), intent(in), optional :: ocean_restart_file - character(len=*), intent(in), optional :: units - character(len=*), intent(in), optional :: caller - integer, intent(in), optional :: verbosity + character(len=*), intent(in) :: name !< An unused argument + character(len=*), intent(in) :: flux_type !< An unused argument + character(len=*), intent(in) :: implementation !< An unused argument + integer, optional, intent(in) :: atm_tr_index !< An unused argument + real, dimension(:), optional, intent(in) :: param !< An unused argument + logical, dimension(:), optional, intent(in) :: flag !< An unused argument + character(len=*), optional, intent(in) :: ice_restart_file !< An unused argument + character(len=*), optional, intent(in) :: ocean_restart_file !< An unused argument + character(len=*), optional, intent(in) :: units !< An unused argument + character(len=*), optional, intent(in) :: caller !< An unused argument + integer, optional, intent(in) :: verbosity !< An unused argument ! None of these arguments are used for anything. diff --git a/config_src/ice_solo_driver/coupler_types.F90 b/config_src/ice_solo_driver/coupler_types.F90 index bc4a941b04..99a74e085c 100644 --- a/config_src/ice_solo_driver/coupler_types.F90 +++ b/config_src/ice_solo_driver/coupler_types.F90 @@ -68,7 +68,8 @@ module coupler_types_mod 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 + 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 @@ -115,7 +116,8 @@ module coupler_types_mod 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 + 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 @@ -156,7 +158,8 @@ module coupler_types_mod 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 + 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 @@ -291,10 +294,11 @@ subroutine coupler_type_copy_1d_2d(var_in, var_out, is, ie, js, je, & 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 + 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=*), intent(in), optional :: suffix !< optional suffix to make the name identifier unique + 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):' @@ -310,7 +314,7 @@ subroutine coupler_type_copy_1d_2d(var_in, var_out, is, ie, js, je, & 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 .ne. ' ')) & + 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 @@ -340,10 +344,11 @@ subroutine coupler_type_copy_1d_3d(var_in, var_out, is, ie, js, je, kd, & 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 + 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=*), intent(in), optional :: suffix !< optional suffix to make the name identifier unique + 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):' @@ -360,7 +365,7 @@ subroutine coupler_type_copy_1d_3d(var_in, var_out, is, ie, js, je, kd, & 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 .ne. ' ')) & + 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 @@ -383,10 +388,11 @@ subroutine coupler_type_copy_2d_2d(var_in, var_out, is, ie, js, je, & 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 + 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=*), intent(in), optional :: suffix !< optional suffix to make the name identifier unique + 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):' @@ -402,7 +408,7 @@ subroutine coupler_type_copy_2d_2d(var_in, var_out, is, ie, js, je, & 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 .ne. ' ')) & + 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 @@ -432,10 +438,11 @@ subroutine coupler_type_copy_2d_3d(var_in, var_out, is, ie, js, je, kd, & 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 + 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=*), intent(in), optional :: suffix !< optional suffix to make the name identifier unique + 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):' @@ -452,7 +459,7 @@ subroutine coupler_type_copy_2d_3d(var_in, var_out, is, ie, js, je, kd, & 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 .ne. ' ')) & + 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 @@ -475,10 +482,11 @@ subroutine coupler_type_copy_3d_2d(var_in, var_out, is, ie, js, je, & 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 + 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=*), intent(in), optional :: suffix !< optional suffix to make the name identifier unique + 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):' @@ -494,7 +502,7 @@ subroutine coupler_type_copy_3d_2d(var_in, var_out, is, ie, js, je, & 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 .ne. ' ')) & + 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 @@ -524,10 +532,11 @@ subroutine coupler_type_copy_3d_3d(var_in, var_out, is, ie, js, je, kd, & 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 + 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=*), intent(in), optional :: suffix !< optional suffix to make the name identifier unique + 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):' @@ -544,7 +553,7 @@ subroutine coupler_type_copy_3d_3d(var_in, var_out, is, ie, js, je, kd, & 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 .ne. ' ')) & + 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 @@ -1174,8 +1183,10 @@ subroutine CT_copy_data_2d(var_in, var, halo_size, bc_index, field_index, & !! 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. + 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 @@ -1249,8 +1260,10 @@ subroutine CT_copy_data_3d(var_in, var, halo_size, bc_index, field_index, & !! 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. + 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 @@ -1329,8 +1342,10 @@ subroutine CT_copy_data_2d_3d(var_in, var, halo_size, bc_index, field_index, & !! 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. + 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 @@ -1563,8 +1578,10 @@ subroutine CT_rescale_data_2d(var, scale, halo_size, bc_index, field_index, & !! 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. + 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 @@ -1640,8 +1657,10 @@ subroutine CT_rescale_data_3d(var, scale, halo_size, bc_index, field_index, & !! 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. + 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 @@ -1718,8 +1737,10 @@ subroutine CT_increment_data_2d_2d(var_in, var, halo_size, bc_index, field_index !! 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. + 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 @@ -1802,8 +1823,10 @@ subroutine CT_increment_data_3d_3d(var_in, var, halo_size, bc_index, field_index !! 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. + 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 @@ -1893,8 +1916,10 @@ subroutine CT_increment_data_2d_3d(var_in, weights, var, halo_size, bc_index, fi !! 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. + 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 @@ -1946,7 +1971,8 @@ subroutine CT_increment_data_2d_3d(var_in, weights, var, halo_size, bc_index, fi 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.") + 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 @@ -1955,7 +1981,8 @@ subroutine CT_increment_data_2d_3d(var_in, weights, var, halo_size, bc_index, fi 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.") + 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 @@ -2720,7 +2747,8 @@ 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 + 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 @@ -2746,7 +2774,8 @@ 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 + 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 @@ -3106,9 +3135,9 @@ 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(in) :: var !< BC_type structure to override - type(time_type), intent(in) :: time !< The current model 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 @@ -3120,9 +3149,9 @@ 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(in) :: var !< BC_type structure to override - type(time_type), intent(in) :: time !< The current model 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 diff --git a/config_src/ice_solo_driver/ice_shelf_driver.F90 b/config_src/ice_solo_driver/ice_shelf_driver.F90 index 628b138639..7bfc7ec5ad 100644 --- a/config_src/ice_solo_driver/ice_shelf_driver.F90 +++ b/config_src/ice_solo_driver/ice_shelf_driver.F90 @@ -265,7 +265,8 @@ program SHELF_main Time_end = daymax endif - if (is_root_pe()) print *,"Time_step_shelf", time_type_to_real(Time_step_shelf), "TIme_end", time_type_to_real(Time_end) + if (is_root_pe()) print *,"Time_step_shelf", time_type_to_real(Time_step_shelf), & + "TIme_end", time_type_to_real(Time_end) if (Time >= Time_end) call MOM_error(FATAL, & "MOM_driver: The run has been started at or after the end time of the run.") diff --git a/config_src/ice_solo_driver/user_surface_forcing.F90 b/config_src/ice_solo_driver/user_surface_forcing.F90 index 098931351c..33c66a3c40 100644 --- a/config_src/ice_solo_driver/user_surface_forcing.F90 +++ b/config_src/ice_solo_driver/user_surface_forcing.F90 @@ -22,8 +22,8 @@ module user_surface_forcing !* * !* USER_buoyancy forcing is used to set the surface buoyancy * !* forcing, which may include a number of fresh water flux fields * -!* (evap, liq_precip, froz_precip, liq_runoff, froz_runoff, and * -!* virt_precip) and the surface heat fluxes (sw, lw, latent and sens) * +!* (evap, lprec, fprec, lrunoff, frunoff, and * +!* vprec) and the surface heat fluxes (sw, lw, latent and sens) * !* if temperature and salinity are state variables, or it may simply * !* be the buoyancy flux if it is not. This routine also has coded a * !* restoring to surface values of temperature and salinity. * @@ -44,22 +44,29 @@ module user_surface_forcing !* * !********+*********+*********+*********+*********+*********+*********+** use MOM_diag_mediator, only : post_data, query_averaging_enabled -use MOM_diag_mediator, only : register_diag_field, diag_ctrl +use MOM_diag_mediator, only : register_diag_field, diag_ctrl, safe_alloc_ptr use MOM_domains, only : pass_var, pass_vector, AGRID use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe -use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_file_parser, only : get_param, param_file_type, log_version use MOM_forcing_type, only : forcing, mech_forcing +use MOM_forcing_type, only : allocate_forcing_type, allocate_mech_forcing use MOM_grid, only : ocean_grid_type -use MOM_io, only : file_exists, MOM_read_data +use MOM_io, only : file_exists, read_data use MOM_time_manager, only : time_type, operator(+), operator(/), get_time use MOM_tracer_flow_control, only : call_tracer_set_forcing use MOM_tracer_flow_control, only : tracer_flow_control_CS +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface implicit none ; private public USER_wind_forcing, USER_buoyancy_forcing, USER_surface_forcing_init +! 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. + type, public :: user_surface_forcing_CS ; private ! This control structure should be used to store any run-time variables ! associated with the user-specified forcing. It can be readily modified @@ -72,11 +79,11 @@ module user_surface_forcing ! state variables. logical :: restorebuoy ! If true, use restoring surface buoyancy forcing. real :: Rho0 ! The density used in the Boussinesq - ! approximation, in kg m-3. - real :: G_Earth ! The gravitational acceleration in m s-2. - real :: Flux_const ! The restoring rate at the surface, in m s-1. + ! approximation [kg m-3]. + real :: G_Earth ! The gravitational acceleration [m s-2]. + real :: Flux_const ! The restoring rate at the surface [m s-1]. real :: gust_const ! A constant unresolved background gustiness - ! that contributes to ustar, in Pa. + ! that contributes to ustar [Pa]. type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the ! timing of diagnostic output. @@ -84,29 +91,22 @@ module user_surface_forcing contains -subroutine USER_wind_forcing(sfc_state, forces, day, G, CS) +!> This subroutine sets the surface wind stresses, forces%taux and forces%tauy, in [Pa]. +!! These are the stresses in the direction of the model grid (i.e. the same +!! direction as the u- and v- velocities). +subroutine USER_wind_forcing(sfc_state, forces, day, G, US, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day + type(time_type), intent(in) :: day !< The time of the fluxes type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(user_surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by - !! a previous call to user_surface_forcing_init - -! This subroutine sets the surface wind stresses, forces%taux and forces%tauy. -! These are the stresses in the direction of the model grid (i.e. the same -! direction as the u- and v- velocities.) They are both in Pa. -! In addition, this subroutine can be used to set the surface friction -! velocity, forces%ustar, in m s-1. This is needed with a bulk mixed layer. -! -! Arguments: state - A structure containing fields that describe the -! surface state of the ocean. -! (out) fluxes - A structure containing pointers to any possible -! forcing fields. Unused fields have NULL ptrs. -! (in) day - Time of the fluxes. -! (in) G - The ocean's grid structure. -! (in) CS - A pointer to the control structure returned by a previous -! call to user_surface_forcing_init + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(user_surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned + !! by a previous call to user_surface_forcing_init + +! This subroutine sets the surface wind stresses, forces%taux and forces%tauy [Pa]. +! In addition, this subroutine can be used to set the surface friction velocity, +! forces%ustar [Z s-1 ~> m s-1], which is needed with a bulk mixed layer. integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB @@ -121,7 +121,10 @@ subroutine USER_wind_forcing(sfc_state, forces, day, G, CS) isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - ! Set the surface wind stresses, in units of Pa. A positive taux + ! Allocate the forcing arrays, if necessary. + call allocate_mech_forcing(G, forces, stress=.true., ustar=.true.) + + ! Set the surface wind stresses [Pa]. A positive taux ! accelerates the ocean to the (pseudo-)east. ! The i-loop extends to is-1 so that taux can be used later in the @@ -133,26 +136,29 @@ subroutine USER_wind_forcing(sfc_state, forces, day, G, CS) forces%tauy(i,J) = G%mask2dCv(i,J) * 0.0 ! Change this to the desired expression. enddo ; enddo - ! Set the surface friction velocity, in units of m s-1. ustar - ! is always positive. + ! Set the surface friction velocity [Z s-1 ~> m s-1]. ustar is always positive. if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie ! This expression can be changed if desired, but need not be. - forces%ustar(i,j) = G%mask2dT(i,j) * sqrt(CS%gust_const/CS%Rho0 + & + forces%ustar(i,j) = US%m_to_Z * G%mask2dT(i,j) * sqrt(CS%gust_const/CS%Rho0 + & sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))/CS%Rho0) enddo ; enddo ; endif end subroutine USER_wind_forcing +!> This subroutine specifies the current surface fluxes of buoyancy or +!! temperature and fresh water. It may also be modified to add +!! surface fluxes of user provided tracers. subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(forcing), intent(inout) :: fluxes - type(time_type), intent(in) :: day + !! describe the surface state of the ocean. + type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields + type(time_type), intent(in) :: day !< The time of the fluxes real, intent(in) :: dt !< The amount of time over which - !! the fluxes apply, in s + !! the fluxes apply [s] type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(user_surface_forcing_CS), pointer :: CS + type(user_surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned + !! by a previous call to user_surface_forcing_init ! This subroutine specifies the current surface fluxes of buoyancy or ! temperature and fresh water. It may also be modified to add @@ -161,31 +167,20 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) ! When temperature is used, there are long list of fluxes that need to be ! set - essentially the same as for a full coupled model, but most of these ! can be simply set to zero. The net fresh water flux should probably be -! set in fluxes%evap and fluxes%liq_precip, with any salinity restoring -! appearing in fluxes%virt_precip, and the other water flux components -! (froz_precip, liq_runoff and froz_runoff) left as arrays full of zeros. +! set in fluxes%evap and fluxes%lprec, with any salinity restoring +! appearing in fluxes%vprec, and the other water flux components +! (fprec, lrunoff and frunoff) left as arrays full of zeros. ! Evap is usually negative and precip is usually positive. All heat fluxes ! are in W m-2 and positive for heat going into the ocean. All fresh water ! fluxes are in kg m-2 s-1 and positive for water moving into the ocean. -! Arguments: state - A structure containing fields that describe the -! surface state of the ocean. -! (out) fluxes - A structure containing pointers to any possible -! forcing fields. Unused fields have NULL ptrs. -! (in) day_start - Start time of the fluxes. -! (in) day_interval - Length of time over which these fluxes -! will be applied. -! (in) G - The ocean's grid structure. -! (in) CS - A pointer to the control structure returned by a previous -! call to user_surface_forcing_init - - real :: Temp_restore ! The temperature that is being restored toward, in C. - real :: Salin_restore ! The salinity that is being restored toward, in PSU. + real :: Temp_restore ! The temperature that is being restored toward [C]. + real :: Salin_restore ! The salinity that is being restored toward [ppt] real :: density_restore ! The potential density that is being restored - ! toward, in kg m-3. - real :: rhoXcp ! The mean density times the heat capacity, in J m-3 K-1. + ! toward [kg m-3]. + real :: rhoXcp ! The mean density times the heat capacity [J m-3 degC-1]. real :: buoy_rest_const ! A constant relating density anomalies to the - ! restoring buoyancy flux, in m5 s-3 kg-1. + ! restoring buoyancy flux [m5 s-3 kg-1]. integer :: i, j, is, ie, js, je integer :: isd, ied, jsd, jed @@ -201,19 +196,19 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) ! Allocate and zero out the forcing arrays, as necessary. This portion is ! usually not changed. if (CS%use_temperature) then - call alloc_if_needed(fluxes%evap, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%liq_precip, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%froz_precip, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%liq_runoff, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%froz_runoff, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%virt_precip, isd, ied, jsd, jed) - - call alloc_if_needed(fluxes%sw, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%lw, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%latent, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%sens, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%evap, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%lprec, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%fprec, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%lrunoff, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%frunoff, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%vprec, isd, ied, jsd, jed) + + call safe_alloc_ptr(fluxes%sw, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%lw, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%latent, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%sens, isd, ied, jsd, jed) else ! This is the buoyancy only mode. - call alloc_if_needed(fluxes%buoy, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%buoy, isd, ied, jsd, jed) endif @@ -223,15 +218,15 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) ! Set whichever fluxes are to be used here. Any fluxes that ! are always zero do not need to be changed here. do j=js,je ; do i=is,ie - ! Fluxes of fresh water through the surface are in units of kg m-2 s-1 + ! Fluxes of fresh water through the surface are in units of [kg m-2 s-1] ! and are positive downward - i.e. evaporation should be negative. fluxes%evap(i,j) = -0.0 * G%mask2dT(i,j) - fluxes%liq_precip(i,j) = 0.0 * G%mask2dT(i,j) + fluxes%lprec(i,j) = 0.0 * G%mask2dT(i,j) - ! virt_precip will be set later, if it is needed for salinity restoring. - fluxes%virt_precip(i,j) = 0.0 + ! vprec will be set later, if it is needed for salinity restoring. + fluxes%vprec(i,j) = 0.0 - ! Heat fluxes are in units of W m-2 and are positive into the ocean. + ! Heat fluxes are in units of [W m-2] and are positive into the ocean. fluxes%lw(i,j) = 0.0 * G%mask2dT(i,j) fluxes%latent(i,j) = 0.0 * G%mask2dT(i,j) fluxes%sens(i,j) = 0.0 * G%mask2dT(i,j) @@ -239,7 +234,7 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) enddo ; enddo else ! This is the buoyancy only mode. do j=js,je ; do i=is,ie - ! fluxes%buoy is the buoyancy flux into the ocean in m2 s-3. A positive + ! fluxes%buoy is the buoyancy flux into the ocean [m2 s-3]. A positive ! buoyancy flux is of the same sign as heating the ocean. fluxes%buoy(i,j) = 0.0 * G%mask2dT(i,j) enddo ; enddo @@ -247,7 +242,7 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) if (CS%restorebuoy) then if (CS%use_temperature) then - call alloc_if_needed(fluxes%heat_restore, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%heat_added, isd, ied, jsd, jed) ! When modifying the code, comment out this error message. It is here ! so that the original (unmodified) version is not accidentally used. call MOM_error(FATAL, "User_buoyancy_surface_forcing: " // & @@ -255,14 +250,14 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) rhoXcp = CS%Rho0 * fluxes%C_p do j=js,je ; do i=is,ie - ! Set Temp_restore and Salin_restore to the temperature (in C) and - ! salinity (in PSU) that are being restored toward. + ! Set Temp_restore and Salin_restore to the temperature (in degC) and + ! salinity (in ppt or PSU) that are being restored toward. Temp_restore = 0.0 Salin_restore = 0.0 - fluxes%heat_restore(i,j) = (G%mask2dT(i,j) * (rhoXcp * CS%Flux_const)) * & + fluxes%heat_added(i,j) = (G%mask2dT(i,j) * (rhoXcp * CS%Flux_const)) * & (Temp_restore - sfc_state%SST(i,j)) - fluxes%virt_precip(i,j) = - (G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)) * & + fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)) * & ((Salin_restore - sfc_state%SSS(i,j)) / & (0.5 * (Salin_restore + sfc_state%SSS(i,j)))) enddo ; enddo @@ -276,7 +271,7 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) buoy_rest_const = -1.0 * (CS%G_Earth * CS%Flux_const) / CS%Rho0 do j=js,je ; do i=is,ie ! Set density_restore to an expression for the surface potential - ! density in kg m-3 that is being restored toward. + ! density [kg m-3] that is being restored toward. density_restore = 1030.0 fluxes%buoy(i,j) = G%mask2dT(i,j) * buoy_rest_const * & @@ -287,34 +282,17 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) end subroutine USER_buoyancy_forcing -subroutine alloc_if_needed(ptr, isd, ied, jsd, jed) - ! If ptr is not associated, this routine allocates it with the given size - ! and zeros out its contents. This is equivalent to safe_alloc_ptr in - ! MOM_diag_mediator, but is here so as to be completely transparent. - real, pointer :: ptr(:,:) - integer :: isd, ied, jsd, jed - if (.not.associated(ptr)) then - allocate(ptr(isd:ied,jsd:jed)) - ptr(:,:) = 0.0 - endif -end subroutine alloc_if_needed - +!> This subroutine initializes the USER_surface_forcing module subroutine USER_surface_forcing_init(Time, G, param_file, diag, CS) - type(time_type), intent(in) :: Time + type(time_type), intent(in) :: Time !< The current model time type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(diag_ctrl), target, intent(in) :: diag - type(user_surface_forcing_CS), pointer :: CS -! Arguments: Time - The current model time. -! (in) G - The ocean's grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in) diag - A structure that is used to regulate diagnostic output. -! (in/out) CS - A pointer that is set to point to the control structure -! for this module - -! This include declares and sets the variable "version". -#include "version_variable.h" + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate diagnostic output. + type(user_surface_forcing_CS), pointer :: CS !< A pointer that is set to point to + !! the control structure for this module + + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "user_surface_forcing" ! This module's name. if (associated(CS)) then @@ -330,18 +308,20 @@ subroutine USER_surface_forcing_init(Time, G, param_file, diag, CS) call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & "If true, Temperature and salinity are used as state \n"//& "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, "GUST_CONST", CS%gust_const, & - "The background gustiness in the winds.", units="Pa", & - default=0.02) 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"//& "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, & + "The background gustiness in the winds.", units="Pa", & + 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"//& diff --git a/config_src/mct_driver/MOM_ocean_model.F90 b/config_src/mct_driver/MOM_ocean_model.F90 new file mode 100644 index 0000000000..64ef660dbf --- /dev/null +++ b/config_src/mct_driver/MOM_ocean_model.F90 @@ -0,0 +1,1070 @@ +module MOM_ocean_model + +! This file is part of MOM6. See LICENSE.md for the license. + +!----------------------------------------------------------------------- +! +! This is the top level module for the MOM6 ocean model. It contains routines +! for initialization, termination and update of ocean model state. This +! particular version wraps all of the calls for MOM6 in the calls that had +! been used for MOM4. +! +! Robert Hallberg +! +! +! +! This code is a stop-gap wrapper of the MOM6 code to enable it to be called +! in the same way as MOM4. +! + +use MOM, only : initialize_MOM, step_MOM, MOM_control_struct, MOM_end +use MOM, only : extract_surface_state, allocate_surface_state, finish_MOM_initialization +use MOM, only : get_MOM_state_elements, MOM_state_is_synchronized +use MOM, only : get_ocean_stocks, step_offline +use MOM_constants, only : CELSIUS_KELVIN_OFFSET, hlf +use MOM_diag_mediator, only : diag_ctrl, enable_averaging, disable_averaging +use MOM_diag_mediator, only : diag_mediator_close_registration, diag_mediator_end +use MOM_domains, only : pass_var, pass_vector, AGRID, BGRID_NE, CGRID_NE +use MOM_domains, only : TO_ALL, Omit_Corners, fill_symmetric_edges +use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe +use MOM_error_handler, only : callTree_enter, callTree_leave +use MOM_file_parser, only : get_param, log_version, close_param_file, param_file_type +use MOM_forcing_type, only : allocate_forcing_type +use MOM_forcing_type, only : forcing, mech_forcing +use MOM_forcing_type, only : forcing_accumulate, copy_common_forcing_fields +use MOM_forcing_type, only : copy_back_forcing_fields, set_net_mass_forcing +use MOM_forcing_type, only : set_derived_forcing_fields +use MOM_forcing_type, only : forcing_diagnostics, mech_forcing_diags +use MOM_forcing_type, only : allocate_mech_forcing +use MOM_get_input, only : Get_MOM_Input, directories +use MOM_grid, only : ocean_grid_type +use MOM_io, only : close_file, file_exists, read_data, write_version_number +use MOM_marine_ice, only : iceberg_forces, iceberg_fluxes, marine_ice_init, marine_ice_CS +use MOM_restart, only : MOM_restart_CS, save_restart +use MOM_string_functions, only : uppercase +use MOM_surface_forcing, only : surface_forcing_init +use MOM_surface_forcing, only : convert_IOB_to_fluxes +use MOM_surface_forcing, only : convert_IOB_to_forces, ice_ocn_bnd_type_chksum +use MOM_surface_forcing, only : ice_ocean_boundary_type, surface_forcing_CS +use MOM_surface_forcing, only : forcing_save_restart +use MOM_time_manager, only : time_type, get_time, set_time, operator(>) +use MOM_time_manager, only : operator(+), operator(-), operator(*), operator(/) +use MOM_time_manager, only : operator(/=), operator(<=), operator(>=) +use MOM_time_manager, only : operator(<), real_to_time_type, time_type_to_real +use MOM_tracer_flow_control, only : call_tracer_register, tracer_flow_control_init +use MOM_tracer_flow_control, only : call_tracer_flux_init +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface +use MOM_verticalGrid, only : verticalGrid_type +use MOM_ice_shelf, only : initialize_ice_shelf, shelf_calc_flux, ice_shelf_CS +use MOM_ice_shelf, only : add_shelf_forces, ice_shelf_end, ice_shelf_save_restart +use coupler_types_mod, only : coupler_1d_bc_type, coupler_2d_bc_type +use coupler_types_mod, only : coupler_type_spawn, coupler_type_write_chksums +use coupler_types_mod, only : coupler_type_initialized, coupler_type_copy_data +use coupler_types_mod, only : coupler_type_set_diags, coupler_type_send_data +use mpp_domains_mod, only : domain2d, mpp_get_layout, mpp_get_global_domain +use mpp_domains_mod, only : mpp_define_domains, mpp_get_compute_domain, mpp_get_data_domain +use fms_mod, only : stdout +use mpp_mod, only : mpp_chksum +use MOM_EOS, only : gsw_sp_from_sr, gsw_pt_from_ct +use MOM_wave_interface, only : wave_parameters_CS, MOM_wave_interface_init +use MOM_wave_interface, only : MOM_wave_interface_init_lite, Update_Surface_Waves + +! MCT specfic routines +use ocn_cpl_indices, only : cpl_indices_type +use MOM_coms, only : reproducing_sum +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_spatial_means, only : adjust_area_mean_to_zero +use MOM_diag_mediator, only : safe_alloc_ptr +use MOM_domains, only : MOM_infra_end +use user_revise_forcing, only : user_alter_forcing +use data_override_mod, only : data_override + +! FMS modules +use time_interp_external_mod, only : time_interp_external + +#include + +#ifdef _USE_GENERIC_TRACER +use MOM_generic_tracer, only : MOM_generic_tracer_fluxes_accumulate +#endif + +implicit none ; public + +public ocean_model_init, ocean_model_end, update_ocean_model +public get_ocean_grid ! add by Jiande +public ocean_model_save_restart, Ocean_stock_pe +public ocean_model_init_sfc, ocean_model_flux_init +public ocean_model_restart +public ocean_public_type_chksum +public ocean_model_data_get +public ice_ocn_bnd_type_chksum + +interface ocean_model_data_get + module procedure ocean_model_data1D_get + module procedure ocean_model_data2D_get +end interface + +!> This type is used for communication with other components via the FMS coupler. +!! The element names and types can be changed only with great deliberation, hence +!! the persistnce of things like the cutsy element name "avg_kount". +type, public :: ocean_public_type + type(domain2d) :: Domain !< The domain for the surface fields. + logical :: is_ocean_pe !! .true. on processors that run the ocean model. + character(len=32) :: instance_name = '' !< A name that can be used to identify + !! this instance of an ocean model, for example + !! in ensembles when writing messages. + integer, pointer, dimension(:) :: pelist => NULL() !< The list of ocean PEs. + logical, pointer, dimension(:,:) :: maskmap =>NULL() !< A pointer to an array + !! indicating which logical processors are actually + !! used for the ocean code. The other logical + !! processors would be all land points and are not + !! assigned to actual processors. This need not be + !! assigned if all logical processors are used. + + integer :: stagger = -999 !< The staggering relative to the tracer points + !! points of the two velocity components. Valid entries + !! include AGRID, BGRID_NE, CGRID_NE, BGRID_SW, and CGRID_SW, + !! corresponding to the community-standard Arakawa notation. + !! (These are named integers taken from mpp_parameter_mod.) + !! Following MOM5, stagger is BGRID_NE by default when the + !! ocean is initialized, but here it is set to -999 so that + !! a global max across ocean and non-ocean processors can be + !! used to determine its value. + real, pointer, dimension(:,:) :: & + t_surf => NULL(), & !< SST on t-cell (degrees Kelvin) + s_surf => NULL(), & !< SSS on t-cell (psu) + u_surf => NULL(), & !< i-velocity at the locations indicated by stagger, m/s. + v_surf => NULL(), & !< j-velocity at the locations indicated by stagger, m/s. + sea_lev => NULL(), & !< Sea level in m after correction for surface pressure, + !! i.e. dzt(1) + eta_t + patm/rho0/grav (m) + frazil =>NULL(), & !< Accumulated heating (in Joules/m^2) from frazil + !! formation in the ocean. + melt_potential => NULL(), & !< Accumulated heat used to melt sea ice (in W/m^2) + area => NULL(), & !< cell area of the ocean surface, in m2. + OBLD => NULL() !< Ocean boundary layer depth, in m. + type(coupler_2d_bc_type) :: fields !< A structure that may contain an + !! array of named tracer-related fields. + integer :: avg_kount !< Used for accumulating averages of this type. + integer, dimension(2) :: axes = 0 !< Axis numbers that are available + ! for I/O using this surface data. +end type ocean_public_type + +!> Contains information about the ocean state, although it is not necessary that +!! this is implemented with all models. This type is NOT private, and can therefore CANNOT vary +!! between different ocean models. +type, public :: ocean_state_type + logical :: is_ocean_PE = .false. !< True if this is an ocean PE. + type(time_type) :: Time !< The ocean model's time and master clock. + integer :: Restart_control !< An integer that is bit-tested to determine whether + !! incremental restart files are saved and whether they + !! have a time stamped name. +1 (bit 0) for generic + !! files and +2 (bit 1) for time-stamped files. A + !! restart file is saved at the end of a run segment + !! unless Restart_control is negative. + integer :: nstep = 0 !< The number of calls to update_ocean. + logical :: use_ice_shelf !< If true, the ice shelf model is enabled. + logical :: icebergs_apply_rigid_boundary !< If true, the icebergs can change ocean bd condition. + real :: kv_iceberg !< The viscosity of the icebergs in m2/s (for ice rigidity) + real :: berg_area_threshold !< Fraction of grid cell which iceberg must occupy + !! so that fluxes below are set to zero. (0.5 is a + !! good value to use. Not applied for negative values. + real :: latent_heat_fusion !< Latent heat of fusion + real :: density_iceberg !< A typical density of icebergs in kg/m3 (for ice rigidity) + type(ice_shelf_CS), pointer :: Ice_shelf_CSp => NULL() !< ice shelf structure. + logical :: restore_salinity !< If true, the coupled MOM driver adds a term to + !! restore salinity to a specified value. + logical :: restore_temp !< If true, the coupled MOM driver adds a term to + !! restore sst to a specified value. + real :: press_to_z !< A conversion factor between pressure and ocean + !! depth in m, usually 1/(rho_0*g), in m Pa-1. + real :: C_p !< The heat capacity of seawater, in J K-1 kg-1. + logical :: offline_tracer_mode = .false. !< If false, use the model in prognostic mode + !! with the barotropic and baroclinic dynamics, thermodynamics, + !! etc. stepped forward integrated in time. + !! If true, all of the above are bypassed with all + !! fields necessary to integrate only the tracer advection + !! and diffusion equation read in from files stored from + !! a previous integration of the prognostic model. + type(directories) :: dirs !< A structure containing several relevant directory paths. + type(mech_forcing) :: forces!< A structure with the driving mechanical surface forces + type(forcing) :: fluxes !< A structure containing pointers to + !! the ocean forcing fields. + type(forcing) :: flux_tmp !< A secondary structure containing pointers to the + !! ocean forcing fields for when multiple coupled + !! timesteps are taken per thermodynamic step. + type(surface) :: sfc_state !< A structure containing pointers to + !! the ocean surface state fields. + type(ocean_grid_type), pointer :: grid => NULL() !< A pointer to a grid structure + !! containing metrics and related information. + type(verticalGrid_type), pointer :: GV => NULL() !< A pointer to a vertical grid + !! structure containing metrics and related information. + type(unit_scale_type), pointer :: US => NULL() !< A pointer to a structure containing + !! dimensional unit scaling factors. + type(MOM_control_struct), pointer :: MOM_CSp => NULL() + type(surface_forcing_CS), pointer :: forcing_CSp => NULL() + type(MOM_restart_CS), pointer :: & + restart_CSp => NULL() !< A pointer set to the restart control structure + !! that will be used for MOM restart files. + type(diag_ctrl), pointer :: & + diag => NULL() !< A pointer to the diagnostic regulatory structure +end type ocean_state_type + +integer :: id_clock_forcing + +!======================================================================= +contains +!======================================================================= + +!======================================================================= +! +! +! +! Initialize the ocean model. +! + +!> Initializes the ocean model, including registering fields +!! for restarts and reading restart files if appropriate. +subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, input_restart_file) + type(ocean_public_type), target, & + intent(inout) :: Ocean_sfc !< A structure containing various + !! publicly visible ocean surface properties after initialization, + !! the data in this type is intent(out). + type(ocean_state_type), pointer :: OS !< A structure whose internal + !! contents are private to ocean_model_mod that may be used to + !! contain all information about the ocean's interior state. + type(time_type), intent(in) :: Time_init !< The start time for the coupled model's calendar + type(time_type), intent(in) :: Time_in !< The time at which to initialize the ocean model. + type(coupler_1d_bc_type), & + optional, intent(in) :: gas_fields_ocn !< If present, this type describes the + !! ocean and surface-ice fields that will participate + !! in the calculation of additional gas or other + !! tracer fluxes, and can be used to spawn related + !! internal variables in the ice model. + character(len=*), optional, intent(in) :: input_restart_file !< If present, name of restart file to read + +! This subroutine initializes both the ocean state and the ocean surface type. +! Because of the way that indicies and domains are handled, Ocean_sfc must have +! been used in a previous call to initialize_ocean_type. + + real :: Rho0 !< The Boussinesq ocean density [kg m-3]. + real :: G_Earth !< The gravitational acceleration [m s-2]. + !! This include declares and sets the variable "version". + real :: HFrz !< If HFrz > 0 (m), melt potential will be computed. + !! The actual depth over which melt potential is computed will + !! min(HFrz, OBLD), where OBLD is the boundary layer depth. + !! If HFrz <= 0 (default), melt potential will not be computed. + logical :: use_melt_pot!< If true, allocate melt_potential array + +#include "version_variable.h" + character(len=40) :: mdl = "ocean_model_init" !< This module's name. + character(len=48) :: stagger + logical :: use_temperature + integer :: secs, days + type(param_file_type) :: param_file !< A structure to parse for run-time parameters + + call callTree_enter("ocean_model_init(), ocn_comp_mct.F90") + if (associated(OS)) then + call MOM_error(WARNING, "ocean_model_init called with an associated "// & + "ocean_state_type structure. Model is already initialized.") + return + endif + allocate(OS) + + OS%is_ocean_pe = Ocean_sfc%is_ocean_pe + if (.not.OS%is_ocean_pe) return + + OS%Time = Time_in + call initialize_MOM(OS%Time, Time_init, param_file, OS%dirs, OS%MOM_CSp, & + OS%restart_CSp, Time_in, offline_tracer_mode=OS%offline_tracer_mode, & + input_restart_file=input_restart_file, diag_ptr=OS%diag, & + count_calls=.true.) + call get_MOM_state_elements(OS%MOM_CSp, G=OS%grid, GV=OS%GV, US=OS%US, C_p=OS%fluxes%C_p, & + use_temp=use_temperature) + OS%C_p = OS%fluxes%C_p + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + 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"//& + "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', '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 + elseif (uppercase(stagger(1:1)) == 'C') then + Ocean_sfc%stagger = CGRID_NE + else + call MOM_error(FATAL,"ocean_model_init: OCEAN_SURFACE_STAGGER = "// & + trim(stagger)//" is invalid.") + end if + + call get_param(param_file, mdl, "RESTORE_SALINITY",OS%restore_salinity, & + "If true, the coupled driver will add a globally-balanced \n"//& + "fresh-water flux that drives sea-surface salinity \n"//& + "toward specified values.", default=.false.) + call get_param(param_file, mdl, "RESTORE_TEMPERATURE",OS%restore_temp, & + "If true, the coupled driver will add a \n"//& + "heat flux that drives sea-surface temperauture \n"//& + "toward specified values.", default=.false.) + 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"//& + "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, & + "The gravitational acceleration of the Earth.", & + units="m s-2", default = 9.80) + + call get_param(param_file, mdl, "ICE_SHELF", OS%use_ice_shelf, & + "If true, enables the ice shelf model.", default=.false.) + + call get_param(param_file, mdl, "ICEBERGS_APPLY_RIGID_BOUNDARY", OS%icebergs_apply_rigid_boundary, & + "If true, allows icebergs to change boundary condition felt by ocean", default=.false.) + + if (OS%icebergs_apply_rigid_boundary) then + call get_param(param_file, mdl, "KV_ICEBERG", OS%kv_iceberg, & + "The viscosity of the icebergs", units="m2 s-1",default=1.0e10) + call get_param(param_file, mdl, "DENSITY_ICEBERGS", OS%density_iceberg, & + "A typical density of icebergs.", units="kg m-3", default=917.0) + call get_param(param_file, mdl, "LATENT_HEAT_FUSION", OS%latent_heat_fusion, & + "The latent heat of fusion.", units="J/kg", default=hlf) + call get_param(param_file, mdl, "BERG_AREA_THRESHOLD", OS%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"//& + " values.", units="non-dim", default=-1.0) + endif + + OS%press_to_z = 1.0/(Rho0*G_Earth) + + ! 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"//& + "melt potential will not be computed.", units="m", default=-1.0, do_not_log=.true.) + + if (HFrz .gt. 0.0) then + use_melt_pot=.true. + else + use_melt_pot=.false. + endif + + call allocate_surface_state(OS%sfc_state, OS%grid, use_temperature, do_integrals=.true., & + gas_fields_ocn=gas_fields_ocn, use_meltpot=use_melt_pot) + + call surface_forcing_init(Time_in, OS%grid, OS%US, param_file, OS%diag, & + OS%forcing_CSp, OS%restore_salinity, OS%restore_temp) + + if (OS%use_ice_shelf) then + call initialize_ice_shelf(param_file, OS%grid, OS%Time, OS%ice_shelf_CSp, & + OS%diag, OS%forces, OS%fluxes) + endif + if (OS%icebergs_apply_rigid_boundary) then + !call allocate_forcing_type(OS%grid, OS%fluxes, iceberg=.true.) + !This assumes that the iceshelf and ocean are on the same grid. I hope this is true + if (.not. OS%use_ice_shelf) call allocate_forcing_type(OS%grid, OS%fluxes, ustar=.true., shelf=.true.) + endif + + if (associated(OS%grid%Domain%maskmap)) then + call initialize_ocean_public_type(OS%grid%Domain%mpp_domain, Ocean_sfc, & + OS%diag, maskmap=OS%grid%Domain%maskmap, & + gas_fields_ocn=gas_fields_ocn) + else + call initialize_ocean_public_type(OS%grid%Domain%mpp_domain, Ocean_sfc, & + OS%diag, gas_fields_ocn=gas_fields_ocn) + endif + + ! This call can only occur here if the coupler_bc_type variables have been + ! initialized already using the information from gas_fields_ocn. + if (present(gas_fields_ocn)) then + call extract_surface_state(OS%MOM_CSp, OS%sfc_state) + + call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid) + endif + + call close_param_file(param_file) + call diag_mediator_close_registration(OS%diag) + + call callTree_leave("ocean_model_init(") + +end subroutine ocean_model_init +! NAME="ocean_model_init" + +!======================================================================= +! +! +! +! Update in time the ocean model fields. This code wraps the call to step_MOM +! with MOM4's call. +! +! + +!> Updates the ocean model fields. This code wraps the call to step_MOM with MOM6's call. +!! It uses the forcing to advance the ocean model's state from the +!! input value of Ocean_state (which must be for time time_start_update) for a time interval +!! of Ocean_coupling_time_step, returning the publicly visible ocean surface properties in +!! Ocean_sfc and storing the new ocean properties in Ocean_state. +subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & + time_start_update, Ocean_coupling_time_step) + + type(ice_ocean_boundary_type), & + intent(in) :: Ice_ocean_boundary !< A structure containing the + !! various forcing fields coming from the ice. + + type(ocean_state_type), & + pointer :: OS !< A pointer to a private structure containing + !! the internal ocean state. + + type(ocean_public_type), & + intent(inout) :: Ocean_sfc !< A structure containing all the + !! publicly visible ocean surface fields after + !! a coupling time step. The data in this type is + !! intent out. + + type(time_type), intent(in) :: time_start_update !< The time at the beginning of the update step. + type(time_type), intent(in) :: Ocean_coupling_time_step !< The amount of time over + !! which to advance the ocean. + + ! local variables + type(time_type) :: Master_time !< This allows step_MOM to temporarily change + !! the time that is seen by internal modules. + type(time_type) :: Time1 !< The value of the ocean model's time at the + !! start of a call to step_MOM. + integer :: index_bnds(4) ! The computational domain index bounds in the ice-ocn boundary type + real :: weight !< Flux accumulation weight + real :: time_step !< The time step of a call to step_MOM in seconds. + integer :: secs, days + integer :: is, ie, js, je + + call callTree_enter("update_ocean_model(), MOM_ocean_model.F90") + call get_time(Ocean_coupling_time_step, secs, days) + time_step = 86400.0*real(days) + real(secs) + + if (time_start_update /= OS%Time) then + call MOM_error(WARNING, "update_ocean_model: internal clock does not "//& + "agree with time_start_update argument.") + endif + + if (.not.associated(OS)) then + call MOM_error(FATAL, "update_ocean_model called with an unassociated "// & + "ocean_state_type structure. ocean_model_init must be "// & + "called first to allocate this structure.") + return + endif + + ! This is benign but not necessary if ocean_model_init_sfc was called or if + ! OS%sfc_state%tr_fields was spawned in ocean_model_init. Consider removing it. + is = OS%grid%isc ; ie = OS%grid%iec ; js = OS%grid%jsc ; je = OS%grid%jec + call coupler_type_spawn(Ocean_sfc%fields, OS%sfc_state%tr_fields, & + (/is,is,ie,ie/), (/js,js,je,je/), as_needed=.true.) + + ! Translate Ice_ocean_boundary into fluxes. + call mpp_get_compute_domain(Ocean_sfc%Domain, index_bnds(1), index_bnds(2), & + index_bnds(3), index_bnds(4)) + weight = 1.0 + + call convert_IOB_to_forces(Ice_ocean_boundary, OS%forces, index_bnds, OS%Time, & + OS%grid, OS%US, OS%forcing_CSp) + + if (OS%fluxes%fluxes_used) then + + ! GMM, is enable_averaging needed now? + call enable_averaging(time_step, OS%Time + Ocean_coupling_time_step, OS%diag) + + ! Import fluxes from coupler to ocean. Also, perform do SST and SSS restoring, if needed. + call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%fluxes, OS%Time, OS%grid, OS%US, OS%forcing_CSp, & + OS%sfc_state, OS%restore_salinity, OS%restore_temp) + + ! Fields that exist in both the forcing and mech_forcing types must be copied. + call copy_common_forcing_fields(OS%forces, OS%fluxes, OS%grid) + +#ifdef _USE_GENERIC_TRACER + call MOM_generic_tracer_fluxes_accumulate(OS%fluxes, weight) !here weight=1, just saving the current fluxes +#endif + + ! Add ice shelf fluxes + if (OS%use_ice_shelf) then + call shelf_calc_flux(OS%sfc_state, OS%fluxes, OS%Time, time_step, OS%Ice_shelf_CSp) + call add_shelf_forces(OS%grid, OS%Ice_shelf_CSp, OS%forces) + endif + + ! GMM, check ocean_model_MOM.F90 to enable the following option + !if (OS%icebergs_apply_rigid_boundary) then + ! This assumes that the iceshelf and ocean are on the same grid. I hope this is true. + ! call add_berg_flux_to_shelf(OS%grid, OS%forces,OS%fluxes,OS%use_ice_shelf,OS%density_iceberg, & + ! OS%kv_iceberg, OS%latent_heat_fusion, OS%sfc_state, time_step, OS%berg_area_threshold) + !endif + + ! Indicate that there are new unused fluxes. + OS%fluxes%fluxes_used = .false. + OS%fluxes%dt_buoy_accum = time_step + + else + + OS%flux_tmp%C_p = OS%fluxes%C_p + + ! Import fluxes from coupler to ocean. Also, perform do SST and SSS restoring, if needed. + call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%fluxes, OS%Time, OS%grid, OS%US, OS%forcing_CSp, & + OS%sfc_state, OS%restore_salinity, OS%restore_temp) + + if (OS%use_ice_shelf) then + call shelf_calc_flux(OS%sfc_state, OS%flux_tmp, OS%Time, time_step, OS%Ice_shelf_CSp) + call add_shelf_forces(OS%grid, OS%Ice_shelf_CSp, OS%forces) + endif + + ! GMM, check ocean_model_MOM.F90 to enable the following option + !if (OS%icebergs_apply_rigid_boundary) then + !This assumes that the iceshelf and ocean are on the same grid. I hope this is true + ! call add_berg_flux_to_shelf(OS%grid, OS%forces, OS%flux_tmp, OS%use_ice_shelf,OS%density_iceberg, & + ! OS%kv_iceberg, OS%latent_heat_fusion, OS%sfc_state, time_step, OS%berg_area_threshold) + !endif + + ! Accumulate the forcing over time steps + call forcing_accumulate(OS%flux_tmp, OS%forces, OS%fluxes, time_step, OS%grid, weight) + + ! Some of the fields that exist in both the forcing and mech_forcing types + ! are time-averages must be copied back to the forces type. + call copy_back_forcing_fields(OS%fluxes, OS%forces, OS%grid) +#ifdef _USE_GENERIC_TRACER + call MOM_generic_tracer_fluxes_accumulate(OS%flux_tmp, weight) !weight of the current flux in the running average +#endif + endif + + call set_derived_forcing_fields(OS%forces, OS%fluxes, OS%grid, OS%US, OS%GV%Rho0) + call set_net_mass_forcing(OS%fluxes, OS%forces, OS%grid) + + if (OS%nstep==0) then + call finish_MOM_initialization(OS%Time, OS%dirs, OS%MOM_CSp, OS%restart_CSp) + endif + + call disable_averaging(OS%diag) + Master_time = OS%Time ; Time1 = OS%Time + + if(OS%offline_tracer_mode) then + call step_offline(OS%forces, OS%fluxes, OS%sfc_state, Time1, time_step, OS%MOM_CSp) + else + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, time_step, OS%MOM_CSp) + endif + + OS%Time = Master_time + Ocean_coupling_time_step + OS%nstep = OS%nstep + 1 + + call enable_averaging(time_step, OS%Time, OS%diag) + call mech_forcing_diags(OS%forces, time_step, OS%grid, OS%diag, OS%forcing_CSp%handles) + call disable_averaging(OS%diag) + + if (OS%fluxes%fluxes_used) then + call enable_averaging(OS%fluxes%dt_buoy_accum, OS%Time, OS%diag) + call forcing_diagnostics(OS%fluxes, OS%sfc_state, OS%fluxes%dt_buoy_accum, & + OS%grid, OS%diag, OS%forcing_CSp%handles) + call disable_averaging(OS%diag) + endif + +! Translate state into Ocean. +! call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, & +! Ice_ocean_boundary%p, OS%press_to_z) + call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid) + + call callTree_leave("update_ocean_model()") + +end subroutine update_ocean_model +! NAME="update_ocean_model" + +!======================================================================= +! +! +! +! write out restart file. +! Arguments: +! timestamp (optional, intent(in)) : A character string that represents the model time, +! used for writing restart. timestamp will prepend to +! the any restart file name as a prefix. +! +! +subroutine ocean_model_restart(OS, timestamp) + type(ocean_state_type), pointer :: OS !< A pointer to the structure containing the + !! internal ocean state being saved to a restart file + character(len=*), optional, intent(in) :: timestamp !< An optional timestamp string that should be + !! prepended to the file name. (Currently this is unused.) + + if (.not.MOM_state_is_synchronized(OS%MOM_CSp)) & + call MOM_error(WARNING, "End of MOM_main reached with inconsistent "//& + "dynamics and advective times. Additional restart fields "//& + "that have not been coded yet would be required for reproducibility.") + if (.not.OS%fluxes%fluxes_used) call MOM_error(FATAL, "ocean_model_restart "//& + "was called with unused buoyancy fluxes. For conservation, the ocean "//& + "restart files can only be created after the buoyancy forcing is applied.") + + if (BTEST(OS%Restart_control,1)) then + call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & + OS%restart_CSp, .true., GV=OS%GV) + call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & + OS%dirs%restart_output_dir, .true.) + if (OS%use_ice_shelf) then + call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir, .true.) + endif + endif + if (BTEST(OS%Restart_control,0)) then + call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & + OS%restart_CSp, GV=OS%GV) + call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & + OS%dirs%restart_output_dir) + if (OS%use_ice_shelf) then + call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir) + endif + endif + +end subroutine ocean_model_restart +! NAME="ocean_model_restart" + +!======================================================================= +! +! +! +! Close down the ocean model +! + +!> Terminates the model run, saving the ocean state in a +!! restart file and deallocating any data associated with the ocean. +subroutine ocean_model_end(Ocean_sfc, Ocean_state, Time) + type(ocean_public_type), intent(inout) :: Ocean_sfc !< An ocean_public_type structure that is to be + !! deallocated upon termination. + type(ocean_state_type), pointer :: Ocean_state!< pointer to the structure containing the internal + ! !! ocean state to be deallocated upon termination. + type(time_type), intent(in) :: Time !< The model time, used for writing restarts. + + call diag_mediator_end(Time, Ocean_state%diag, end_diag_manager=.true.) + ! print time stats + call MOM_infra_end + call MOM_end(Ocean_state%MOM_CSp) + if (Ocean_state%use_ice_shelf) call ice_shelf_end(Ocean_state%Ice_shelf_CSp) + +end subroutine ocean_model_end +! NAME="ocean_model_end" + +!======================================================================= + +!> ocean_model_save_restart causes restart files associated with the ocean to be +!! written out. +subroutine ocean_model_save_restart(OS, Time, directory, filename_suffix) + type(ocean_state_type), pointer :: OS !< A pointer to the structure containing the + !! internal ocean state (in). + type(time_type), intent(in) :: Time !< The model time at this call, needed for mpp_write calls. + character(len=*), optional, intent(in) :: directory !< An optional directory into which to + !! write these restart files. + character(len=*), optional, intent(in) :: filename_suffix !< An optional suffix (e.g., a time-stamp) + !! to append to the restart file names. +! Arguments: Ocean_state - A structure containing the internal ocean state (in). +! (in) Time - The model time at this call. This is needed for mpp_write calls. +! (in, opt) directory - An optional directory into which to write these restart files. +! (in, opt) filename_suffix - An optional suffix (e.g., a time-stamp) to append +! to the restart file names. + +! Note: This is a new routine - it will need to exist for the new incremental +! checkpointing. It will also be called by ocean_model_end, giving the same +! restart behavior as now in FMS. + character(len=200) :: restart_dir + + if (.not.MOM_state_is_synchronized(OS%MOM_CSp)) & + call MOM_error(WARNING, "ocean_model_save_restart called with inconsistent "//& + "dynamics and advective times. Additional restart fields "//& + "that have not been coded yet would be required for reproducibility.") + if (.not.OS%fluxes%fluxes_used) call MOM_error(FATAL, "ocean_model_save_restart "//& + "was called with unused buoyancy fluxes. For conservation, the ocean "//& + "restart files can only be created after the buoyancy forcing is applied.") + + if (present(directory)) then + restart_dir = directory + else + restart_dir = OS%dirs%restart_output_dir + endif + + call save_restart(restart_dir, Time, OS%grid, OS%restart_CSp, GV=OS%GV) + + call forcing_save_restart(OS%forcing_CSp, OS%grid, Time, restart_dir) + + if (OS%use_ice_shelf) then + call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir) + endif + +end subroutine ocean_model_save_restart + +!======================================================================= + +!> Initializes domain and state variables contained in the ocean public type. +subroutine initialize_ocean_public_type(input_domain, Ocean_sfc, diag, maskmap, & + gas_fields_ocn) + type(domain2D), intent(in) :: input_domain !< The FMS domain for the input structure + type(ocean_public_type), intent(inout) :: Ocean_sfc !< Ocean surface state + type(diag_ctrl), intent(in) :: diag !< A structure used to control diagnostics. + logical, intent(in), optional :: maskmap(:,:) !< A pointer to an array indicating which + !! logical processors are actually used for the ocean code. + type(coupler_1d_bc_type), & + optional, intent(in) :: gas_fields_ocn !< If present, this type describes the + !! ocean and surface-ice fields that will participate + !! in the calculation of additional gas or other + !! tracer fluxes. + ! local variables + integer :: xsz, ysz, layout(2) + integer :: isc, iec, jsc, jec + + call mpp_get_layout(input_domain,layout) + call mpp_get_global_domain(input_domain, xsize=xsz, ysize=ysz) + if(PRESENT(maskmap)) then + call mpp_define_domains((/1,xsz,1,ysz/),layout,Ocean_sfc%Domain, maskmap=maskmap) + else + call mpp_define_domains((/1,xsz,1,ysz/),layout,Ocean_sfc%Domain) + endif + call mpp_get_compute_domain(Ocean_sfc%Domain, isc, iec, jsc, jec) + + allocate (Ocean_sfc%t_surf (isc:iec,jsc:jec), & + Ocean_sfc%s_surf (isc:iec,jsc:jec), & + Ocean_sfc%u_surf (isc:iec,jsc:jec), & + Ocean_sfc%v_surf (isc:iec,jsc:jec), & + Ocean_sfc%sea_lev(isc:iec,jsc:jec), & + Ocean_sfc%area (isc:iec,jsc:jec), & + Ocean_sfc%OBLD (isc:iec,jsc:jec), & + Ocean_sfc%melt_potential(isc:iec,jsc:jec), & + Ocean_sfc%frazil (isc:iec,jsc:jec)) + + Ocean_sfc%t_surf = 0.0 ! time averaged sst (Kelvin) passed to atmosphere/ice model + Ocean_sfc%s_surf = 0.0 ! time averaged sss (psu) passed to atmosphere/ice models + Ocean_sfc%u_surf = 0.0 ! time averaged u-current (m/sec) passed to atmosphere/ice models + Ocean_sfc%v_surf = 0.0 ! time averaged v-current (m/sec) passed to atmosphere/ice models + Ocean_sfc%sea_lev = 0.0 ! time averaged thickness of top model grid cell (m) plus patm/rho0/grav + Ocean_sfc%frazil = 0.0 ! time accumulated frazil (J/m^2) passed to ice model + Ocean_sfc%melt_potential = 0.0 ! time accumulated melt potential (J/m^2) passed to ice model + Ocean_sfc%OBLD = 0.0 ! ocean boundary layer depth, in m + Ocean_sfc%area = 0.0 + Ocean_sfc%axes = diag%axesT1%handles !diag axes to be used by coupler tracer flux diagnostics + + if (present(gas_fields_ocn)) then + call coupler_type_spawn(gas_fields_ocn, Ocean_sfc%fields, (/isc,isc,iec,iec/), & + (/jsc,jsc,jec,jec/), suffix = '_ocn', as_needed=.true.) + endif + +end subroutine initialize_ocean_public_type + +!> Translates the coupler's ocean_data_type into MOM6's surface state variable. +!! This may eventually be folded into the MOM6's code that calculates the +!! surface state in the first place. +subroutine convert_state_to_ocean_type(state, Ocean_sfc, G, patm, press_to_z) + type(surface), intent(inout) :: state + type(ocean_public_type), target, intent(inout) :: Ocean_sfc !< Ocean surface state + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, optional, intent(in) :: patm(:,:) !< Atmospheric pressure. + real, optional, intent(in) :: press_to_z !< Factor to tranform atmospheric + !! pressure to z? + + ! local variables + real :: IgR0 + character(len=48) :: val_str + integer :: isc_bnd, iec_bnd, jsc_bnd, jec_bnd + integer :: i, j, i0, j0, is, ie, js, je + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + call pass_vector(state%u,state%v,G%Domain) + + call mpp_get_compute_domain(Ocean_sfc%Domain, isc_bnd, iec_bnd, & + jsc_bnd, jec_bnd) + if (present(patm)) then + ! Check that the inidicies in patm are (isc_bnd:iec_bnd,jsc_bnd:jec_bnd). + if (.not.present(press_to_z)) call MOM_error(FATAL, & + 'convert_state_to_ocean_type: press_to_z must be present if patm is.') + endif + + i0 = is - isc_bnd ; j0 = js - jsc_bnd + if (state%T_is_conT) then + ! Convert the surface T from conservative T to potential T. + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + Ocean_sfc%t_surf(i,j) = gsw_pt_from_ct(state%SSS(i+i0,j+j0), & + state%SST(i+i0,j+j0)) + CELSIUS_KELVIN_OFFSET + enddo ; enddo + else + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + Ocean_sfc%t_surf(i,j) = state%SST(i+i0,j+j0) + CELSIUS_KELVIN_OFFSET + enddo ; enddo + endif + if (state%S_is_absS) then + ! Convert the surface S from absolute salinity to practical salinity. + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + Ocean_sfc%s_surf(i,j) = gsw_sp_from_sr(state%SSS(i+i0,j+j0)) + enddo ; enddo + else + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + Ocean_sfc%s_surf(i,j) = state%SSS(i+i0,j+j0) + enddo ; enddo + endif + + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + Ocean_sfc%sea_lev(i,j) = state%sea_lev(i+i0,j+j0) + Ocean_sfc%area(i,j) = G%areaT(i+i0,j+j0) + if (present(patm)) & + Ocean_sfc%sea_lev(i,j) = Ocean_sfc%sea_lev(i,j) + patm(i,j) * press_to_z + if (associated(state%frazil)) & + Ocean_sfc%frazil(i,j) = state%frazil(i+i0,j+j0) + if (allocated(state%melt_potential)) & + Ocean_sfc%melt_potential(i,j) = state%melt_potential(i+i0,j+j0) + if (allocated(state%Hml)) & + Ocean_sfc%OBLD(i,j) = state%Hml(i+i0,j+j0) + enddo ; enddo + + if (Ocean_sfc%stagger == AGRID) then + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + Ocean_sfc%u_surf(i,j) = G%mask2dT(i+i0,j+j0)*0.5*(state%u(I+i0,j+j0)+state%u(I-1+i0,j+j0)) + Ocean_sfc%v_surf(i,j) = G%mask2dT(i+i0,j+j0)*0.5*(state%v(i+i0,J+j0)+state%v(i+i0,J-1+j0)) + enddo ; enddo + elseif (Ocean_sfc%stagger == BGRID_NE) then + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + Ocean_sfc%u_surf(i,j) = G%mask2dBu(I+i0,J+j0)*0.5*(state%u(I+i0,j+j0)+state%u(I+i0,j+j0+1)) + Ocean_sfc%v_surf(i,j) = G%mask2dBu(I+i0,J+j0)*0.5*(state%v(i+i0,J+j0)+state%v(i+i0+1,J+j0)) + enddo ; enddo + elseif (Ocean_sfc%stagger == CGRID_NE) then + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + Ocean_sfc%u_surf(i,j) = G%mask2dCu(I+i0,j+j0)*state%u(I+i0,j+j0) + Ocean_sfc%v_surf(i,j) = G%mask2dCv(i+i0,J+j0)*state%v(i+i0,J+j0) + enddo ; enddo + else + write(val_str, '(I8)') Ocean_sfc%stagger + call MOM_error(FATAL, "convert_state_to_ocean_type: "//& + "Ocean_sfc%stagger has the unrecognized value of "//trim(val_str)) + endif + + if (coupler_type_initialized(state%tr_fields)) then + if (.not.coupler_type_initialized(Ocean_sfc%fields)) then + call MOM_error(FATAL, "convert_state_to_ocean_type: "//& + "Ocean_sfc%fields has not been initialized.") + endif + call coupler_type_copy_data(state%tr_fields, Ocean_sfc%fields) + endif + +end subroutine convert_state_to_ocean_type + +!> This subroutine extracts the surface properties from the ocean's internal +!! state and stores them in the ocean type returned to the calling ice model. +!! It has to be separate from the ocean_initialization call because the coupler +!! module allocates the space for some of these variables. +subroutine ocean_model_init_sfc(OS, Ocean_sfc) + type(ocean_state_type), pointer :: OS !< A pointer to the structure containing the + !! internal ocean state (in). + type(ocean_public_type), intent(inout) :: Ocean_sfc !< Ocean surface state + + integer :: is, ie, js, je + + is = OS%grid%isc ; ie = OS%grid%iec ; js = OS%grid%jsc ; je = OS%grid%jec + call coupler_type_spawn(Ocean_sfc%fields, OS%sfc_state%tr_fields, & + (/is,is,ie,ie/), (/js,js,je,je/), as_needed=.true.) + + call extract_surface_state(OS%MOM_CSp, OS%sfc_state) + + call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid) + +end subroutine ocean_model_init_sfc +! + +!======================================================================= + +!> ocean_model_flux_init is used to initialize properties of the air-sea fluxes +!! as determined by various run-time parameters. It can be called from +!! non-ocean PEs, or PEs that have not yet been initialzed, and it can safely +!! be called multiple times. +subroutine ocean_model_flux_init(OS, verbosity) + type(ocean_state_type), optional, pointer :: OS !< An optional pointer to the ocean state, + !! used to figure out if this is an ocean PE that + !! has already been initialized. + integer, optional, intent(in) :: verbosity !< A 0-9 integer indicating a level of verbosity. + + logical :: OS_is_set + integer :: verbose + + OS_is_set = .false. ; if (present(OS)) OS_is_set = associated(OS) + + ! Use this to control the verbosity of output; consider rethinking this logic later. + verbose = 5 ; if (OS_is_set) verbose = 3 + if (present(verbosity)) verbose = verbosity + + call call_tracer_flux_init(verbosity=verbose) + +end subroutine ocean_model_flux_init + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! +! Ocean_stock_pe - returns stocks of heat, water, etc. for conservation checks.! +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! +!> Ocean_stock_pe - returns the integrated stocks of heat, water, etc. for conservation checks. +!! Because of the way FMS is coded, only the root PE has the integrated amount, +!! while all other PEs get 0. +subroutine Ocean_stock_pe(OS, index, value, time_index) + use stock_constants_mod, only : ISTOCK_WATER, ISTOCK_HEAT,ISTOCK_SALT + type(ocean_state_type), pointer :: OS !< A structure containing the internal ocean state. + !! The data in OS is intent(in). + integer, intent(in) :: index !< The stock index for the quantity of interest. + real, intent(out) :: value !< Sum returned for the conservation quantity of interest. + integer, optional, intent(in) :: time_index !< An unused optional argument, present only for + !! interfacial compatibility with other models. +! Arguments: OS - A structure containing the internal ocean state. +! (in) index - Index of conservation quantity of interest. +! (in) value - Sum returned for the conservation quantity of interest. +! (in,opt) time_index - Index for time level to use if this is necessary. + + real :: salt + + value = 0.0 + if (.not.associated(OS)) return + if (.not.OS%is_ocean_pe) return + + select case (index) + case (ISTOCK_WATER) ! Return the mass of fresh water in the ocean in kg. + if (OS%GV%Boussinesq) then + call get_ocean_stocks(OS%MOM_CSp, mass=value, on_PE_only=.true.) + else ! In non-Boussinesq mode, the mass of salt needs to be subtracted. + call get_ocean_stocks(OS%MOM_CSp, mass=value, salt=salt, on_PE_only=.true.) + value = value - salt + endif + case (ISTOCK_HEAT) ! Return the heat content of the ocean in J. + call get_ocean_stocks(OS%MOM_CSp, heat=value, on_PE_only=.true.) + case (ISTOCK_SALT) ! Return the mass of the salt in the ocean in kg. + call get_ocean_stocks(OS%MOM_CSp, salt=value, on_PE_only=.true.) + case default ; value = 0.0 + end select + ! If the FMS coupler is changed so that Ocean_stock_PE is only called on + ! ocean PEs, uncomment the following and eliminate the on_PE_only flags above. + ! if (.not.is_root_pe()) value = 0.0 + +end subroutine Ocean_stock_pe + +subroutine ocean_model_data2D_get(OS,Ocean, name, array2D,isc,jsc) + use MOM_constants, only : CELSIUS_KELVIN_OFFSET + type(ocean_state_type), pointer :: OS + type(ocean_public_type), intent(in) :: Ocean + character(len=*) , intent(in) :: name + real, dimension(isc:,jsc:), intent(out):: array2D + integer , intent(in) :: isc,jsc + + integer :: g_isc, g_iec, g_jsc, g_jec,g_isd, g_ied, g_jsd, g_jed, i, j + + if (.not.associated(OS)) return + if (.not.OS%is_ocean_pe) return + +! The problem is %areaT is on MOM domain but Ice_Ocean_Boundary%... is on mpp domain. +! We want to return the MOM data on the mpp (compute) domain +! Get MOM domain extents + call mpp_get_compute_domain(OS%grid%Domain%mpp_domain, g_isc, g_iec, g_jsc, g_jec) + call mpp_get_data_domain (OS%grid%Domain%mpp_domain, g_isd, g_ied, g_jsd, g_jed) + + g_isc = g_isc-g_isd+1 ; g_iec = g_iec-g_isd+1 ; g_jsc = g_jsc-g_jsd+1 ; g_jec = g_jec-g_jsd+1 + + + select case(name) + case('area') + array2D(isc:,jsc:) = OS%grid%areaT(g_isc:g_iec,g_jsc:g_jec) + case('mask') + array2D(isc:,jsc:) = OS%grid%mask2dT(g_isc:g_iec,g_jsc:g_jec) +!OR same result +! do j=g_jsc,g_jec ; do i=g_isc,g_iec +! array2D(isc+i-g_isc,jsc+j-g_jsc) = OS%grid%mask2dT(i,j) +! enddo ; enddo + case('t_surf') + array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET + case('t_pme') + array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET + case('t_runoff') + array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET + case('t_calving') + array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET + case('btfHeat') + array2D(isc:,jsc:) = 0 + case('tlat') + array2D(isc:,jsc:) = OS%grid%geoLatT(g_isc:g_iec,g_jsc:g_jec) + case('tlon') + array2D(isc:,jsc:) = OS%grid%geoLonT(g_isc:g_iec,g_jsc:g_jec) + case('ulat') + array2D(isc:,jsc:) = OS%grid%geoLatCu(g_isc:g_iec,g_jsc:g_jec) + case('ulon') + array2D(isc:,jsc:) = OS%grid%geoLonCu(g_isc:g_iec,g_jsc:g_jec) + case('vlat') + array2D(isc:,jsc:) = OS%grid%geoLatCv(g_isc:g_iec,g_jsc:g_jec) + case('vlon') + array2D(isc:,jsc:) = OS%grid%geoLonCv(g_isc:g_iec,g_jsc:g_jec) + case('geoLatBu') + array2D(isc:,jsc:) = OS%grid%geoLatBu(g_isc:g_iec,g_jsc:g_jec) + case('geoLonBu') + array2D(isc:,jsc:) = OS%grid%geoLonBu(g_isc:g_iec,g_jsc:g_jec) + case('cos_rot') + array2D(isc:,jsc:) = OS%grid%cos_rot(g_isc:g_iec,g_jsc:g_jec) ! =1 + case('sin_rot') + array2D(isc:,jsc:) = OS%grid%sin_rot(g_isc:g_iec,g_jsc:g_jec) ! =0 + case default + call MOM_error(FATAL,'ocean_model_data2D_get: unknown argument name='//name) + end select +end subroutine ocean_model_data2D_get + +subroutine ocean_model_data1D_get(OS,Ocean, name, value) + type(ocean_state_type), pointer :: OS + type(ocean_public_type), intent(in) :: Ocean + character(len=*) , intent(in) :: name + real , intent(out):: value + + if (.not.associated(OS)) return + if (.not.OS%is_ocean_pe) return + + select case(name) + case('c_p') + value = OS%C_p + case default + call MOM_error(FATAL,'ocean_model_data1D_get: unknown argument name='//name) + end select +end subroutine ocean_model_data1D_get + +subroutine ocean_public_type_chksum(id, timestep, ocn) + + character(len=*), intent(in) :: id + integer , intent(in) :: timestep + type(ocean_public_type), intent(in) :: ocn + integer :: n,m, outunit + + outunit = stdout() + + write(outunit,*) "BEGIN CHECKSUM(ocean_type):: ", id, timestep + write(outunit,100) 'ocean%t_surf ',mpp_chksum(ocn%t_surf ) + write(outunit,100) 'ocean%s_surf ',mpp_chksum(ocn%s_surf ) + write(outunit,100) 'ocean%u_surf ',mpp_chksum(ocn%u_surf ) + write(outunit,100) 'ocean%v_surf ',mpp_chksum(ocn%v_surf ) + write(outunit,100) 'ocean%sea_lev ',mpp_chksum(ocn%sea_lev) + write(outunit,100) 'ocean%frazil ',mpp_chksum(ocn%frazil ) + write(outunit,100) 'ocean%OBLD ',mpp_chksum(ocn%OBLD ) + write(outunit,100) 'ocean%melt_potential ',mpp_chksum(ocn%melt_potential) + + call coupler_type_write_chksums(ocn%fields, outunit, 'ocean%') +100 FORMAT(" CHECKSUM::",A20," = ",Z20) +end subroutine ocean_public_type_chksum + +!======================================================================= +! +! +! +! Obtain the ocean grid. +! +! +subroutine get_ocean_grid(OS, Gridp) + type(ocean_state_type) :: OS + type(ocean_grid_type) , pointer :: Gridp + + Gridp => OS%grid + return + +end subroutine get_ocean_grid +! NAME="get_ocean_grid" + +end module MOM_ocean_model diff --git a/config_src/mct_driver/MOM_surface_forcing.F90 b/config_src/mct_driver/MOM_surface_forcing.F90 new file mode 100644 index 0000000000..fc9e7b7eeb --- /dev/null +++ b/config_src/mct_driver/MOM_surface_forcing.F90 @@ -0,0 +1,1369 @@ +module MOM_surface_forcing + +! This file is part of MOM6. See LICENSE.md for the license. + +!### use MOM_controlled_forcing, only : apply_ctrl_forcing, register_ctrl_forcing_restarts +!### use MOM_controlled_forcing, only : controlled_forcing_init, controlled_forcing_end +!### use MOM_controlled_forcing, only : ctrl_forcing_CS +use MOM_coms, only : reproducing_sum +use MOM_constants, only : hlv, hlf +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_SUBCOMPONENT +use MOM_diag_mediator, only : diag_ctrl +use MOM_diag_mediator, only : safe_alloc_ptr, time_type +use MOM_domains, only : pass_vector, pass_var, fill_symmetric_edges +use MOM_domains, only : global_field_sum, BITWISE_EXACT_SUM +use MOM_domains, only : AGRID, BGRID_NE, CGRID_NE, To_All +use MOM_domains, only : To_North, To_East, Omit_Corners +use MOM_error_handler, only : MOM_error, WARNING, FATAL, is_root_pe, MOM_mesg +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_forcing_type, only : forcing, mech_forcing +use MOM_forcing_type, only : forcing_diags, mech_forcing_diags, register_forcing_type_diags +use MOM_forcing_type, only : allocate_forcing_type, deallocate_forcing_type +use MOM_forcing_type, only : allocate_mech_forcing, deallocate_mech_forcing +use MOM_get_input, only : Get_MOM_Input, directories +use MOM_grid, only : ocean_grid_type +use MOM_io, only : slasher, write_version_number, MOM_read_data +use MOM_restart, only : register_restart_field, restart_init, MOM_restart_CS +use MOM_restart, only : restart_init_end, save_restart, restore_state +use MOM_string_functions, only : uppercase +use MOM_spatial_means, only : adjust_area_mean_to_zero +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface +use user_revise_forcing, only : user_alter_forcing, user_revise_forcing_init +use user_revise_forcing, only : user_revise_forcing_CS + +use coupler_types_mod, only : coupler_2d_bc_type, coupler_type_write_chksums +use coupler_types_mod, only : coupler_type_initialized, coupler_type_spawn +use coupler_types_mod, only : coupler_type_copy_data +use data_override_mod, only : data_override_init, data_override +use fms_mod, only : stdout +use fms_mod, only : read_data +use mpp_mod, only : mpp_chksum +use time_interp_external_mod, only : init_external_field, time_interp_external +use time_interp_external_mod, only : time_interp_external_init + +! MCT specfic routines +use ocn_cpl_indices, only : cpl_indices_type + +implicit none ; private + +#include + +public IOB_allocate +public convert_IOB_to_fluxes +public convert_IOB_to_forces +public surface_forcing_init +public ice_ocn_bnd_type_chksum +public forcing_save_restart +public apply_flux_adjustments + +!> Contains pointers to the forcing fields which may be used to drive MOM. +!! All fluxes are positive downward. +type, public :: surface_forcing_CS ; + integer :: wind_stagger !< AGRID, BGRID_NE, or CGRID_NE (integer values + !! from MOM_domains) to indicate the staggering of + !! the winds that are being provided in calls to + !! update_ocean_model. CIME uses AGRID, so this option + !! is being hard coded for now. + logical :: use_temperature !< If true, temp and saln used as state variables + real :: wind_stress_multiplier!< A multiplier applied to incoming wind stress (nondim). + ! smg: remove when have A=B code reconciled + logical :: bulkmixedlayer !< If true, model based on bulk mixed layer code + real :: Rho0 !< Boussinesq reference density (kg/m^3) + real :: area_surf = -1.0 !< total ocean surface area (m^2) + real :: latent_heat_fusion ! latent heat of fusion (J/kg) + real :: latent_heat_vapor ! latent heat of vaporization (J/kg) + real :: max_p_surf !< maximum surface pressure that can be + !! exerted by the atmosphere and floating sea-ice, + !! in Pa. 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. + logical :: use_limited_P_SSH !< 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. The default is true. + real :: gust_const !< constant unresolved background gustiness for ustar (Pa) + logical :: read_gust_2d !< If true, use a 2-dimensional gustiness supplied + !! from an input file. + real, pointer, dimension(:,:) :: & + TKE_tidal => NULL(), & !< turbulent kinetic energy introduced to the + !! bottom boundary layer by drag on the tidal flows, + !! in W m-2. + gust => NULL(), & !< spatially varying unresolved background + !! gustiness that contributes to ustar (Pa). + !! gust is used when read_gust_2d is true. + ustar_tidal => NULL() !< tidal contribution to the bottom friction velocity [m s-1] + real :: cd_tides !< drag coefficient that applies to the tides (nondimensional) + real :: utide !< constant tidal velocity to use if read_tideamp + !! is false [m s-1]. + logical :: read_tideamp !< If true, spatially varying tidal amplitude read from a file. + logical :: rigid_sea_ice !< If true, sea-ice exerts a rigidity that acts + !! to damp surface deflections (especially surface + !! gravity waves). The default is false. + real :: Kv_sea_ice !< viscosity in sea-ice that resists sheared vertical motions (m^2/s) + real :: density_sea_ice !< typical density of sea-ice (kg/m^3). The value is + !! only used to convert the ice pressure into + !! appropriate units for use with Kv_sea_ice. + real :: rigid_sea_ice_mass !< A mass per unit area of sea-ice beyond which + !! sea-ice viscosity becomes effective, in kg m-2, + !! typically of order 1000 kg m-2. + logical :: allow_flux_adjustments !< If true, use data_override to obtain flux adjustments + real :: Flux_const !< piston velocity for surface restoring [m s-1] + logical :: salt_restore_as_sflux !< If true, SSS restore as salt flux instead of water flux + logical :: adjust_net_srestore_to_zero !< adjust srestore to zero (for both salt_flux or vprec) + logical :: adjust_net_srestore_by_scaling !< adjust srestore w/o moving zero contour + logical :: adjust_net_fresh_water_to_zero !< adjust net surface fresh-water (w/ restoring) to zero + logical :: use_net_FW_adjustment_sign_bug ! use the wrong sign when adjusting net FW + logical :: adjust_net_fresh_water_by_scaling !< adjust net surface fresh-water w/o moving zero contour + logical :: mask_srestore_under_ice !< If true, use an ice mask defined by frazil + !! criteria for salinity restoring. + real :: ice_salt_concentration !< salt concentration for sea ice (kg/kg) + logical :: mask_srestore_marginal_seas !< if true, then mask SSS restoring in marginal seas + real :: max_delta_srestore !< maximum delta salinity used for restoring + real :: max_delta_trestore !< maximum delta sst used for restoring + real, pointer, dimension(:,:) :: basin_mask => NULL() !< mask for SSS restoring + type(diag_ctrl), pointer :: diag !< structure to regulate diagnostic output timing + character(len=200) :: inputdir !< directory where NetCDF input files are + character(len=200) :: salt_restore_file !< filename for salt restoring data + character(len=30) :: salt_restore_var_name !< name of surface salinity in salt_restore_file + logical :: mask_srestore ! if true, apply a 2-dimensional mask to the surface + ! salinity restoring fluxes. The masking file should be + ! in inputdir/salt_restore_mask.nc and the field should + ! be named 'mask' + real, pointer, dimension(:,:) :: srestore_mask => NULL() ! mask for SSS restoring + character(len=200) :: temp_restore_file !< filename for sst restoring data + character(len=30) :: temp_restore_var_name !< name of surface temperature in temp_restore_file + logical :: mask_trestore ! if true, apply a 2-dimensional mask to the surface + ! temperature restoring fluxes. The masking file should be + ! in inputdir/temp_restore_mask.nc and the field should + ! be named 'mask' + real, pointer, dimension(:,:) :: trestore_mask => NULL() ! mask for SST restoring + integer :: id_srestore = -1 !< id number for time_interp_external. + integer :: id_trestore = -1 !< id number for time_interp_external. + type(forcing_diags), public :: handles !< diagnostics handles + !### type(ctrl_forcing_CS), pointer :: ctrl_forcing_CSp => NULL() + type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< restart pointer + type(user_revise_forcing_CS), pointer :: urf_CS => NULL()!< user revise pointer +end type surface_forcing_CS + +! ice_ocean_boundary_type is a structure corresponding to forcing, but with +! the elements, units, and conventions that exactly conform to the use for +! MOM-based coupled models. +type, public :: ice_ocean_boundary_type + real, pointer, dimension(:,:) :: latent_flux =>NULL() !< latent flux (W/m2) + real, pointer, dimension(:,:) :: rofl_flux =>NULL() !< liquid runoff (W/m2) + real, pointer, dimension(:,:) :: rofi_flux =>NULL() !< ice runoff (W/m2) + real, pointer, dimension(:,:) :: u_flux =>NULL() !< i-direction wind stress (Pa) + real, pointer, dimension(:,:) :: v_flux =>NULL() !< j-direction wind stress (Pa) + real, pointer, dimension(:,:) :: t_flux =>NULL() !< sensible heat flux (W/m2) + real, pointer, dimension(:,:) :: seaice_melt_heat =>NULL() !< sea ice and snow melt heat flux (W/m2) + real, pointer, dimension(:,:) :: seaice_melt =>NULL() !< water flux due to sea ice and snow melting (kg/m2/s) + real, pointer, dimension(:,:) :: q_flux =>NULL() !< specific humidity flux (kg/m2/s) + real, pointer, dimension(:,:) :: salt_flux =>NULL() !< salt flux (kg/m2/s) + real, pointer, dimension(:,:) :: lw_flux =>NULL() !< long wave radiation (W/m2) + real, pointer, dimension(:,:) :: sw_flux_vis_dir =>NULL() !< direct visible sw radiation (W/m2) + real, pointer, dimension(:,:) :: sw_flux_vis_dif =>NULL() !< diffuse visible sw radiation (W/m2) + real, pointer, dimension(:,:) :: sw_flux_nir_dir =>NULL() !< direct Near InfraRed sw radiation (W/m2) + real, pointer, dimension(:,:) :: sw_flux_nir_dif =>NULL() !< diffuse Near InfraRed sw radiation (W/m2) + real, pointer, dimension(:,:) :: lprec =>NULL() !< mass flux of liquid precip (kg/m2/s) + real, pointer, dimension(:,:) :: fprec =>NULL() !< mass flux of frozen precip (kg/m2/s) + real, pointer, dimension(:,:) :: runoff =>NULL() !< mass flux of liquid runoff (kg/m2/s) + real, pointer, dimension(:,:) :: calving =>NULL() !< mass flux of frozen runoff (kg/m2/s) + real, pointer, dimension(:,:) :: ustar_berg =>NULL() !< frictional velocity beneath icebergs [m s-1] + real, pointer, dimension(:,:) :: area_berg =>NULL() !< area covered by icebergs(m2/m2) + real, pointer, dimension(:,:) :: mass_berg =>NULL() !< mass of icebergs(kg/m2) + real, pointer, dimension(:,:) :: runoff_hflx =>NULL() !< heat content of liquid runoff (W/m2) + real, pointer, dimension(:,:) :: calving_hflx =>NULL() !< heat content of frozen runoff (W/m2) + real, pointer, dimension(:,:) :: p =>NULL() !< pressure of overlying ice and atmosphere + !< on ocean surface (Pa) + real, pointer, dimension(:,:) :: mi =>NULL() !< mass of ice (kg/m2) + real, pointer, dimension(:,:) :: ice_rigidity =>NULL() !< rigidity of the sea ice, sea-ice and + !! ice-shelves, expressed as a coefficient + !! for divergence damping, as determined + !! outside of the ocean model in (m3/s) + integer :: xtype !< The type of the exchange - REGRID, REDIST or DIRECT + type(coupler_2d_bc_type) :: fluxes !< A structure that may contain an array of + !! named fields used for passive tracer fluxes. + integer :: wind_stagger = -999 !< A flag indicating the spatial discretization of + !! wind stresses. This flag may be set by the + !! flux-exchange code, based on what the sea-ice + !! model is providing. Otherwise, the value from + !! the surface_forcing_CS is used. +end type ice_ocean_boundary_type + +integer :: id_clock_forcing + +!======================================================================= +contains +!======================================================================= + +!> This function has a few purposes: 1) it allocates and initializes the data +!! in the fluxes structure; 2) it imports surface fluxes using data from +!! the coupler; and 3) it can apply restoring in SST and SSS. +!! See \ref section_ocn_import for a summary of the surface fluxes that are +!! passed from MCT to MOM6, including fluxes that need to be included in +!! the future. +subroutine convert_IOB_to_fluxes(IOB, fluxes, Time, G, US, CS, & + sfc_state, restore_salt, restore_temp) + + type(ice_ocean_boundary_type), & + target, intent(in) :: IOB !< An ice-ocean boundary type with fluxes to drive + !! the ocean in a coupled model + + type(forcing), intent(inout) :: fluxes !< A structure containing pointers to + !! all possible mass, heat or salt flux forcing fields. + !! Unused fields have NULL ptrs. + + type(time_type), intent(in) :: Time !< The time of the fluxes, used for interpolating the + !! salinity to the right time, when it is being restored. + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(surface_forcing_CS),pointer :: CS !< A pointer to the control structure returned by a + !! previous call to surface_forcing_init. + type(surface), intent(in) :: sfc_state !< A structure containing fields that describe the + !! surface state of the ocean. + logical, optional, intent(in) :: restore_salt !< If true, salinity is restored to a target value. + logical, optional, intent(in) :: restore_temp !< If true, temperature is restored to a target value. + + ! local variables + real, dimension(SZI_(G),SZJ_(G)) :: & + data_restore, & ! The surface value toward which to restore (g/kg or degC) + SST_anom, & ! Instantaneous sea surface temperature anomalies from a target value (deg C) + SSS_anom, & ! Instantaneous sea surface salinity anomalies from a target value (g/kg) + SSS_mean, & ! A (mean?) salinity about which to normalize local salinity + ! anomalies when calculating restorative precipitation anomalies (g/kg) + PmE_adj, & ! The adjustment to PminusE that will cause the salinity + ! to be restored toward its target value (kg/(m^2 * s)) + net_FW, & ! The area integrated net freshwater flux into the ocean (kg/s) + net_FW2, & ! The area integrated net freshwater flux into the ocean (kg/s) + work_sum, & ! A 2-d array that is used as the work space for a global + ! sum, used with units of m2 or (kg/s) + open_ocn_mask ! a binary field indicating where ice is present based on frazil criteria + + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, i0, j0 + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, isr, ier, jsr, jer + integer :: isc_bnd, iec_bnd, jsc_bnd, jec_bnd + + logical :: restore_salinity ! local copy of the argument restore_salt, if it + ! is present, or false (no restoring) otherwise. + logical :: restore_sst ! local copy of the argument restore_temp, if it + ! is present, or false (no restoring) otherwise. + real :: delta_sss ! temporary storage for sss diff from restoring value + real :: delta_sst ! temporary storage for sst diff from restoring value + + real :: C_p ! heat capacity of seawater ( J/(K kg) ) + real :: sign_for_net_FW_bug ! Should be +1. but an old bug can be recovered by using -1. + + call cpu_clock_begin(id_clock_forcing) + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + isr = is-isd+1 ; ier = ie-isd+1 ; jsr = js-jsd+1 ; jer = je-jsd+1 + + C_p = fluxes%C_p + open_ocn_mask(:,:) = 1.0 + pme_adj(:,:) = 0.0 + fluxes%vPrecGlobalAdj = 0.0 + fluxes%vPrecGlobalScl = 0.0 + fluxes%saltFluxGlobalAdj = 0.0 + fluxes%saltFluxGlobalScl = 0.0 + fluxes%netFWGlobalAdj = 0.0 + fluxes%netFWGlobalScl = 0.0 + + restore_salinity = .false. + if (present(restore_salt)) restore_salinity = restore_salt + restore_sst = .false. + if (present(restore_temp)) restore_sst = restore_temp + + ! allocation and initialization if this is the first time that this + ! flux type has been used. + if (fluxes%dt_buoy_accum < 0) then + call allocate_forcing_type(G, fluxes, water=.true., heat=.true., & + ustar=.true., press=.true.) + + call safe_alloc_ptr(fluxes%sw_vis_dir,isd,ied,jsd,jed) + call safe_alloc_ptr(fluxes%sw_vis_dif,isd,ied,jsd,jed) + call safe_alloc_ptr(fluxes%sw_nir_dir,isd,ied,jsd,jed) + call safe_alloc_ptr(fluxes%sw_nir_dif,isd,ied,jsd,jed) + + call safe_alloc_ptr(fluxes%p_surf,isd,ied,jsd,jed) + call safe_alloc_ptr(fluxes%p_surf_full,isd,ied,jsd,jed) + + call safe_alloc_ptr(fluxes%salt_flux,isd,ied,jsd,jed) + call safe_alloc_ptr(fluxes%salt_flux_in,isd,ied,jsd,jed) + call safe_alloc_ptr(fluxes%salt_flux_added,isd,ied,jsd,jed) + + call safe_alloc_ptr(fluxes%TKE_tidal,isd,ied,jsd,jed) + call safe_alloc_ptr(fluxes%ustar_tidal,isd,ied,jsd,jed) + + if (CS%allow_flux_adjustments) then + call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) + call safe_alloc_ptr(fluxes%salt_flux_added,isd,ied,jsd,jed) + endif + + do j=js-2,je+2 ; do i=is-2,ie+2 + fluxes%TKE_tidal(i,j) = CS%TKE_tidal(i,j) + fluxes%ustar_tidal(i,j) = CS%ustar_tidal(i,j) + enddo; enddo + + if (restore_temp) call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) + + fluxes%dt_buoy_accum = 0.0 + endif ! endif for allocation and initialization + + if (CS%allow_flux_adjustments) then + fluxes%heat_added(:,:)=0.0 + fluxes%salt_flux_added(:,:)=0.0 + endif + + if (CS%area_surf < 0.0) then + do j=js,je ; do i=is,ie + work_sum(i,j) = G%areaT(i,j) * G%mask2dT(i,j) + enddo; enddo + CS%area_surf = reproducing_sum(work_sum, isr, ier, jsr, jer) + endif ! endif for allocation and initialization + + do j=js,je ; do i=is,ie + fluxes%salt_flux(i,j) = 0.0 + fluxes%vprec(i,j) = 0.0 + enddo; enddo + + ! Salinity restoring logic + if (restore_salinity) then + call time_interp_external(CS%id_srestore,Time,data_restore) + ! open_ocn_mask indicates where to restore salinity (1 means restore, 0 does not) + open_ocn_mask(:,:) = 1.0 + if (CS%mask_srestore_under_ice) then ! Do not restore under sea-ice + do j=js,je ; do i=is,ie + if (sfc_state%SST(i,j) <= -0.0539*sfc_state%SSS(i,j)) open_ocn_mask(i,j)=0.0 + enddo; enddo + endif + if (CS%salt_restore_as_sflux) then + do j=js,je ; do i=is,ie + delta_sss = data_restore(i,j)- sfc_state%SSS(i,j) + delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) + fluxes%salt_flux(i,j) = 1.e-3*G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)* & + (CS%basin_mask(i,j)*open_ocn_mask(i,j)) *delta_sss ! kg Salt m-2 s-1 + enddo; enddo + if (CS%adjust_net_srestore_to_zero) then + if (CS%adjust_net_srestore_by_scaling) then + call adjust_area_mean_to_zero(fluxes%salt_flux, G, fluxes%saltFluxGlobalScl) + fluxes%saltFluxGlobalAdj = 0. + else + work_sum(is:ie,js:je) = G%areaT(is:ie,js:je)*fluxes%salt_flux(is:ie,js:je) + fluxes%saltFluxGlobalAdj = reproducing_sum(work_sum(:,:), isr,ier, jsr,jer)/CS%area_surf + fluxes%salt_flux(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) - fluxes%saltFluxGlobalAdj + endif + endif + fluxes%salt_flux_added(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) ! Diagnostic + else + do j=js,je ; do i=is,ie + if (G%mask2dT(i,j) > 0.5) then + delta_sss = sfc_state%SSS(i,j) - data_restore(i,j) + delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) + fluxes%vprec(i,j) = (CS%basin_mask(i,j)*open_ocn_mask(i,j))* & + (CS%Rho0*CS%Flux_const) * & + delta_sss / (0.5*(sfc_state%SSS(i,j) + data_restore(i,j))) + endif + enddo; enddo + if (CS%adjust_net_srestore_to_zero) then + if (CS%adjust_net_srestore_by_scaling) then + call adjust_area_mean_to_zero(fluxes%vprec, G, fluxes%vPrecGlobalScl) + fluxes%vPrecGlobalAdj = 0. + else + work_sum(is:ie,js:je) = G%areaT(is:ie,js:je)*fluxes%vprec(is:ie,js:je) + fluxes%vPrecGlobalAdj = reproducing_sum(work_sum(:,:), isr, ier, jsr, jer) / CS%area_surf + do j=js,je ; do i=is,ie + fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - fluxes%vPrecGlobalAdj ) * G%mask2dT(i,j) + enddo; enddo + endif + endif + endif + endif + + ! SST restoring logic + if (restore_sst) then + call time_interp_external(CS%id_trestore,Time,data_restore) + do j=js,je ; do i=is,ie + delta_sst = data_restore(i,j)- sfc_state%SST(i,j) + delta_sst = sign(1.0,delta_sst)*min(abs(delta_sst),CS%max_delta_trestore) + fluxes%heat_added(i,j) = G%mask2dT(i,j) * (CS%Rho0*fluxes%C_p) * delta_sst * CS%Flux_const ! W m-2 + enddo; enddo + endif + + !i0 = is - isc_bnd ; j0 = js - jsc_bnd ??? + i0 = 0; j0 = 0 ! TODO: is this right? + + do j=js,je ; do i=is,ie + ! liquid precipitation (rain) + if (associated(fluxes%lprec)) & + fluxes%lprec(i,j) = G%mask2dT(i,j) * IOB%lprec(i-i0,j-j0) + + ! frozen precipitation (snow) + if (associated(fluxes%fprec)) & + fluxes%fprec(i,j) = G%mask2dT(i,j) * IOB%fprec(i-i0,j-j0) + + ! evaporation + if (associated(fluxes%evap)) & + fluxes%evap(i,j) = G%mask2dT(i,j) * IOB%q_flux(i-i0,j-j0) + + ! river runoff flux + if (associated(fluxes%lrunoff)) & + fluxes%lrunoff(i,j) = G%mask2dT(i,j) * IOB%rofl_flux(i-i0,j-j0) + + ! ice runoff flux + if (associated(fluxes%frunoff)) & + fluxes%frunoff(i,j) = G%mask2dT(i,j) * IOB%rofi_flux(i-i0,j-j0) + + ! GMM, we don't have an icebergs yet so the following is not needed + !if (((associated(IOB%ustar_berg) .and. (.not. associated(fluxes%ustar_berg))) & + ! .or. (associated(IOB%area_berg) .and. (.not. associated(fluxes%area_berg)))) & + ! .or. (associated(IOB%mass_berg) .and. (.not. associated(fluxes%mass_berg)))) & + ! call allocate_forcing_type(G, fluxes, iceberg=.true.) + !if (associated(IOB%ustar_berg)) & + ! fluxes%ustar_berg(i,j) = US%m_to_Z * IOB%ustar_berg(i-i0,j-j0) * G%mask2dT(i,j) + !if (associated(IOB%area_berg)) & + ! fluxes%area_berg(i,j) = IOB%area_berg(i-i0,j-j0) * G%mask2dT(i,j) + !if (associated(IOB%mass_berg)) & + ! fluxes%mass_berg(i,j) = IOB%mass_berg(i-i0,j-j0) * G%mask2dT(i,j) + + ! GMM, cime does not not have an equivalent for heat_content_lrunoff and + ! heat_content_frunoff. I am seeting these to zero for now. + if (associated(fluxes%heat_content_lrunoff)) & + fluxes%heat_content_lrunoff(i,j) = 0.0 * G%mask2dT(i,j) + + if (associated(fluxes%heat_content_frunoff)) & + fluxes%heat_content_frunoff(i,j) = 0.0 * G%mask2dT(i,j) + + ! longwave radiation, sum up and down (W/m2) + if (associated(fluxes%LW)) & + fluxes%LW(i,j) = G%mask2dT(i,j) * IOB%lw_flux(i-i0,j-j0) + + ! sensible heat flux (W/m2) + if (associated(fluxes%sens)) & + fluxes%sens(i,j) = G%mask2dT(i,j) * IOB%t_flux(i-i0,j-j0) + + ! sea ice and snow melt heat flux (W/m2) + if (associated(fluxes%seaice_melt_heat)) & + fluxes%seaice_melt_heat(i,j) = G%mask2dT(i,j) * IOB%seaice_melt_heat(i-i0,j-j0) + + ! water flux due to sea ice and snow melt (kg/m2/s) + if (associated(fluxes%seaice_melt)) & + fluxes%seaice_melt(i,j) = G%mask2dT(i,j) * IOB%seaice_melt(i-i0,j-j0) + + ! latent heat flux (W/m^2) + if (associated(fluxes%latent)) & + fluxes%latent(i,j) = G%mask2dT(i,j) * IOB%latent_flux(i-i0,j-j0) + + if (associated(IOB%sw_flux_vis_dir)) & + fluxes%sw_vis_dir(i,j) = G%mask2dT(i,j) * IOB%sw_flux_vis_dir(i-i0,j-j0) + if (associated(IOB%sw_flux_vis_dif)) & + fluxes%sw_vis_dif(i,j) = G%mask2dT(i,j) * IOB%sw_flux_vis_dif(i-i0,j-j0) + if (associated(IOB%sw_flux_nir_dir)) & + fluxes%sw_nir_dir(i,j) = G%mask2dT(i,j) * IOB%sw_flux_nir_dir(i-i0,j-j0) + if (associated(IOB%sw_flux_nir_dif)) & + fluxes%sw_nir_dif(i,j) = G%mask2dT(i,j) * IOB%sw_flux_nir_dif(i-i0,j-j0) + + fluxes%sw(i,j) = fluxes%sw_vis_dir(i,j) + fluxes%sw_vis_dif(i,j) + & + fluxes%sw_nir_dir(i,j) + fluxes%sw_nir_dif(i,j) + + ! salt flux + ! more salt restoring logic + if (associated(fluxes%salt_flux)) & + fluxes%salt_flux(i,j) = G%mask2dT(i,j)*(fluxes%salt_flux(i,j) - IOB%salt_flux(i-i0,j-j0)) + + if (associated(fluxes%salt_flux_in)) & + fluxes%salt_flux_in(i,j) = G%mask2dT(i,j)*(-IOB%salt_flux(i-i0,j-j0)) + + enddo; enddo + + ! adjust the NET fresh-water flux to zero, if flagged + if (CS%adjust_net_fresh_water_to_zero) then + sign_for_net_FW_bug = 1. + if (CS%use_net_FW_adjustment_sign_bug) sign_for_net_FW_bug = -1. + do j=js,je ; do i=is,ie + net_FW(i,j) = (((fluxes%lprec(i,j) + fluxes%fprec(i,j) + fluxes%seaice_melt(i,j)) + & + (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j))) + & + (fluxes%evap(i,j) + fluxes%vprec(i,j)) ) * G%areaT(i,j) + ! The following contribution appears to be calculating the volume flux of sea-ice + ! melt. This calculation is clearly WRONG if either sea-ice has variable + ! salinity or the sea-ice is completely fresh. + ! Bob thinks this is trying ensure the net fresh-water of the ocean + sea-ice system + ! is constant. + ! To do this correctly we will need a sea-ice melt field added to IOB. -AJA + ! GMM: as stated above, the following is wrong. CIME deals with volume/mass and + ! heat from sea ice/snow via seaice_melt and seaice_melt_heat, respectively. + if (associated(fluxes%salt_flux) .and. (CS%ice_salt_concentration>0.0)) & + net_FW(i,j) = net_FW(i,j) + G%areaT(i,j) * & + (fluxes%salt_flux(i,j) / CS%ice_salt_concentration) + + net_FW2(i,j) = net_FW(i,j)/G%areaT(i,j) + enddo; enddo + + if (CS%adjust_net_fresh_water_by_scaling) then + call adjust_area_mean_to_zero(net_FW2, G, fluxes%netFWGlobalScl) + do j=js,je ; do i=is,ie + fluxes%vprec(i,j) = fluxes%vprec(i,j) + (net_FW2(i,j) - net_FW(i,j)/G%areaT(i,j)) * G%mask2dT(i,j) + enddo; enddo + else + fluxes%netFWGlobalAdj = reproducing_sum(net_FW(:,:), isr, ier, jsr, jer) / CS%area_surf + do j=js,je ; do i=is,ie + fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - fluxes%netFWGlobalAdj ) * G%mask2dT(i,j) + enddo; enddo + endif + endif + + if (CS%allow_flux_adjustments) then + ! Apply adjustments to fluxes + call apply_flux_adjustments(G, CS, Time, fluxes) + endif + + ! Allow for user-written code to alter fluxes after all the above + call user_alter_forcing(sfc_state, fluxes, Time, G, CS%urf_CS) + + call cpu_clock_end(id_clock_forcing) + +end subroutine convert_IOB_to_fluxes + +!======================================================================= + +!> This subroutine translates the Ice_ocean_boundary_type into a MOM +!! mechanical forcing type, including changes of units, sign conventions, +!! and putting the fields into arrays with MOM-standard halos. +subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) + type(ice_ocean_boundary_type), & + target, intent(in) :: IOB !< An ice-ocean boundary type with fluxes to drive + !! the ocean in a coupled model + type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces + integer, dimension(4), intent(in) :: index_bounds !< The i- and j- size of the arrays in IOB. + type(time_type), intent(in) :: Time !< The time of the fluxes, used for interpolating the + !! salinity to the right time, when it is being restored. + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(surface_forcing_CS),pointer :: CS !< A pointer to the control structure returned by a + !! previous call to surface_forcing_init. + + real, dimension(SZIB_(G),SZJB_(G)) :: & + taux_at_q, & ! Zonal wind stresses at q points (Pa) + tauy_at_q ! Meridional wind stresses at q points (Pa) + + real, dimension(SZI_(G),SZJ_(G)) :: & + rigidity_at_h, & ! Ice rigidity at tracer points (m3 s-1) + taux_at_h, & ! Zonal wind stresses at h points (Pa) + tauy_at_h ! Meridional wind stresses at h points (Pa) + + real :: gustiness ! unresolved gustiness that contributes to ustar (Pa) + real :: Irho0 ! inverse of the mean density in (m^3/kg) + real :: taux2, tauy2 ! squared wind stresses (Pa^2) + real :: tau_mag ! magnitude of the wind stress (Pa) + real :: I_GEarth ! 1.0 / G%G_Earth (s^2/m) + real :: Kv_rho_ice ! (CS%kv_sea_ice / CS%density_sea_ice) ( m^5/(s*kg) ) + real :: mass_ice ! mass of sea ice at a face (kg/m^2) + real :: mass_eff ! effective mass of sea ice for rigidity (kg/m^2) + + integer :: wind_stagger ! AGRID, BGRID_NE, or CGRID_NE (integers from MOM_domains) + integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq, i0, j0 + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, isr, ier, jsr, jer + integer :: isc_bnd, iec_bnd, jsc_bnd, jec_bnd + + call cpu_clock_begin(id_clock_forcing) + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + isr = is-isd+1 ; ier = ie-isd+1 ; jsr = js-jsd+1 ; jer = je-jsd+1 + + !isc_bnd = index_bounds(1) ; iec_bnd = index_bounds(2) + !jsc_bnd = index_bounds(3) ; jec_bnd = index_bounds(4) + !i0 = is - isc_bnd ; j0 = js - jsc_bnd + i0 = 0; j0 = 0 ! TODO: is this right? + + Irho0 = 1.0/CS%Rho0 + + ! allocation and initialization if this is the first time that this + ! mechanical forcing type has been used. + if (.not.forces%initialized) then + call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., & + press=.true.) + call safe_alloc_ptr(forces%p_surf,isd,ied,jsd,jed) + call safe_alloc_ptr(forces%p_surf_full,isd,ied,jsd,jed) + if (CS%rigid_sea_ice) then + call safe_alloc_ptr(forces%rigidity_ice_u,IsdB,IedB,jsd,jed) + call safe_alloc_ptr(forces%rigidity_ice_v,isd,ied,JsdB,JedB) + endif + + forces%initialized = .true. + endif + + if (associated(forces%rigidity_ice_u)) forces%rigidity_ice_u(:,:) = 0.0 + if (associated(forces%rigidity_ice_v)) forces%rigidity_ice_v(:,:) = 0.0 + + !applied surface pressure from atmosphere and cryosphere + !sea-level pressure (Pa) + do j=js,je ; do i=is,ie + if (associated(forces%p_surf_full) .and. associated(forces%p_surf)) then + forces%p_surf_full(i,j) = G%mask2dT(i,j) * IOB%p(i-i0,j-j0) + + if (CS%max_p_surf >= 0.0) then + forces%p_surf(i,j) = MIN(forces%p_surf_full(i,j),CS%max_p_surf) + else + forces%p_surf(i,j) = forces%p_surf_full(i,j) + endif + + endif + enddo; enddo + + if (CS%use_limited_P_SSH) then + forces%p_surf_SSH => forces%p_surf + else + forces%p_surf_SSH => forces%p_surf_full + endif + + ! GMM, CIME uses AGRID. All the BGRID_NE code can be cleaned later + wind_stagger = AGRID + + if (wind_stagger == BGRID_NE) then + ! This is necessary to fill in the halo points. + taux_at_q(:,:) = 0.0 ; tauy_at_q(:,:) = 0.0 + endif + if (wind_stagger == AGRID) then + ! This is necessary to fill in the halo points. + taux_at_h(:,:) = 0.0 ; tauy_at_h(:,:) = 0.0 + endif + + ! obtain fluxes from IOB; note the staggering of indices + do j=js,je ; do i=is,ie + if (wind_stagger == BGRID_NE) then + if (associated(IOB%u_flux)) taux_at_q(I,J) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier + if (associated(IOB%v_flux)) tauy_at_q(I,J) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier + elseif (wind_stagger == AGRID) then + if (associated(IOB%u_flux)) taux_at_h(i,j) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier + if (associated(IOB%v_flux)) tauy_at_h(i,j) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier + else ! C-grid wind stresses. + if (associated(IOB%u_flux)) forces%taux(I,j) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier + if (associated(IOB%v_flux)) forces%tauy(i,J) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier + endif + + enddo ; enddo + + ! surface momentum stress related fields as function of staggering + if (wind_stagger == BGRID_NE) then + if (G%symmetric) & + call fill_symmetric_edges(taux_at_q, tauy_at_q, G%Domain, stagger=BGRID_NE) + call pass_vector(taux_at_q, tauy_at_q, G%Domain, stagger=BGRID_NE) + + do j=js,je ; do I=Isq,Ieq + forces%taux(I,j) = 0.0 + if ((G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) > 0) & + forces%taux(I,j) = (G%mask2dBu(I,J)*taux_at_q(I,J) + & + G%mask2dBu(I,J-1)*taux_at_q(I,J-1)) / & + (G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) + enddo; enddo + + do J=Jsq,Jeq ; do i=is,ie + forces%tauy(i,J) = 0.0 + if ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) > 0) & + forces%tauy(i,J) = (G%mask2dBu(I,J)*tauy_at_q(I,J) + & + G%mask2dBu(I-1,J)*tauy_at_q(I-1,J)) / & + (G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) + enddo; enddo + + ! ustar is required for the bulk mixed layer formulation. The background value + ! of 0.02 Pa is a relatively small value intended to give reasonable behavior + ! in regions of very weak winds. + + do j=js,je ; do i=is,ie + tau_mag = 0.0 ; gustiness = CS%gust_const + if (((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + & + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0) then + tau_mag = sqrt(((G%mask2dBu(I,J)*(taux_at_q(I,J)**2 + tauy_at_q(I,J)**2) + & + G%mask2dBu(I-1,J-1)*(taux_at_q(I-1,J-1)**2 + tauy_at_q(I-1,J-1)**2)) + & + (G%mask2dBu(I,J-1)*(taux_at_q(I,J-1)**2 + tauy_at_q(I,J-1)**2) + & + G%mask2dBu(I-1,J)*(taux_at_q(I-1,J)**2 + tauy_at_q(I-1,J)**2)) ) / & + ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) ) + if (CS%read_gust_2d) gustiness = CS%gust(i,j) + endif + forces%ustar(i,j) = US%m_to_Z * sqrt(gustiness*Irho0 + Irho0*tau_mag) + enddo; enddo + + elseif (wind_stagger == AGRID) then + call pass_vector(taux_at_h, tauy_at_h, G%Domain,stagger=AGRID) + + do j=js,je ; do I=Isq,Ieq + forces%taux(I,j) = 0.0 + if ((G%mask2dT(i,j) + G%mask2dT(i+1,j)) > 0) & + forces%taux(I,j) = (G%mask2dT(i,j)*taux_at_h(i,j) + & + G%mask2dT(i+1,j)*taux_at_h(i+1,j)) / & + (G%mask2dT(i,j) + G%mask2dT(i+1,j)) + enddo; enddo + + do J=Jsq,Jeq ; do i=is,ie + forces%tauy(i,J) = 0.0 + if ((G%mask2dT(i,j) + G%mask2dT(i,j+1)) > 0) & + forces%tauy(i,J) = (G%mask2dT(i,j)*tauy_at_h(i,j) + & + G%mask2dT(i,J+1)*tauy_at_h(i,j+1)) / & + (G%mask2dT(i,j) + G%mask2dT(i,j+1)) + enddo; enddo + + do j=js,je ; do i=is,ie + gustiness = CS%gust_const + if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0)) gustiness = CS%gust(i,j) + forces%ustar(i,j) = US%m_to_Z * sqrt(gustiness*Irho0 + Irho0 * G%mask2dT(i,j) * & + sqrt(taux_at_h(i,j)**2 + tauy_at_h(i,j)**2)) + enddo; enddo + + else ! C-grid wind stresses. + if (G%symmetric) & + call fill_symmetric_edges(forces%taux, forces%tauy, G%Domain) + call pass_vector(forces%taux, forces%tauy, G%Domain) + + do j=js,je ; do i=is,ie + taux2 = 0.0 + if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0) & + taux2 = (G%mask2dCu(I-1,j)*forces%taux(I-1,j)**2 + & + G%mask2dCu(I,j)*forces%taux(I,j)**2) / (G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) + + tauy2 = 0.0 + if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0) & + tauy2 = (G%mask2dCv(i,J-1)*forces%tauy(i,J-1)**2 + & + G%mask2dCv(i,J)*forces%tauy(i,J)**2) / (G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) + + if (CS%read_gust_2d) then + forces%ustar(i,j) = US%m_to_Z * sqrt(CS%gust(i,j)*Irho0 + Irho0*sqrt(taux2 + tauy2)) + else + forces%ustar(i,j) = US%m_to_Z * sqrt(CS%gust_const*Irho0 + Irho0*sqrt(taux2 + tauy2)) + endif + enddo; enddo + + endif ! endif for wind related fields + + ! sea ice related dynamic fields + if (CS%rigid_sea_ice) then + call pass_var(forces%p_surf_full, G%Domain, halo=1) + I_GEarth = 1.0 / G%G_Earth + Kv_rho_ice = (CS%kv_sea_ice / CS%density_sea_ice) + do I=is-1,ie ; do j=js,je + mass_ice = min(forces%p_surf_full(i,j), forces%p_surf_full(i+1,j)) * I_GEarth + mass_eff = 0.0 + if (mass_ice > CS%rigid_sea_ice_mass) then + mass_eff = (mass_ice - CS%rigid_sea_ice_mass) **2 / & + (mass_ice + CS%rigid_sea_ice_mass) + endif + forces%rigidity_ice_u(I,j) = forces%rigidity_ice_u(I,j) + Kv_rho_ice * mass_eff + enddo ; enddo + do i=is,ie ; do J=js-1,je + mass_ice = min(forces%p_surf_full(i,j), forces%p_surf_full(i,j+1)) * I_GEarth + mass_eff = 0.0 + if (mass_ice > CS%rigid_sea_ice_mass) then + mass_eff = (mass_ice - CS%rigid_sea_ice_mass) **2 / & + (mass_ice + CS%rigid_sea_ice_mass) + endif + forces%rigidity_ice_v(i,J) = forces%rigidity_ice_v(i,J) + Kv_rho_ice * mass_eff + enddo ; enddo + endif + + if (CS%allow_flux_adjustments) then + ! Apply adjustments to forces + call apply_force_adjustments(G, CS, Time, forces) + endif + +!### ! Allow for user-written code to alter fluxes after all the above +!### call user_alter_mech_forcing(forces, Time, G, CS%urf_CS) + + call cpu_clock_end(id_clock_forcing) +end subroutine convert_IOB_to_forces + +!======================================================================= + +!> Allocates ice-ocean boundary type containers and sets to 0. +subroutine IOB_allocate(IOB, isc, iec, jsc, jec) + type(ice_ocean_boundary_type), intent(inout) :: IOB !< An ice-ocean boundary type with fluxes to drive + integer, intent(in) :: isc, iec, jsc, jec !< The ocean's local grid size + + allocate ( IOB% latent_flux (isc:iec,jsc:jec), & + IOB% rofl_flux (isc:iec,jsc:jec), & + IOB% rofi_flux (isc:iec,jsc:jec), & + IOB% u_flux (isc:iec,jsc:jec), & + IOB% v_flux (isc:iec,jsc:jec), & + IOB% t_flux (isc:iec,jsc:jec), & + IOB% seaice_melt_heat (isc:iec,jsc:jec),& + IOB% seaice_melt (isc:iec,jsc:jec), & + IOB% q_flux (isc:iec,jsc:jec), & + IOB% salt_flux (isc:iec,jsc:jec), & + IOB% lw_flux (isc:iec,jsc:jec), & + IOB% sw_flux_vis_dir (isc:iec,jsc:jec), & + IOB% sw_flux_vis_dif (isc:iec,jsc:jec), & + IOB% sw_flux_nir_dir (isc:iec,jsc:jec), & + IOB% sw_flux_nir_dif (isc:iec,jsc:jec), & + IOB% lprec (isc:iec,jsc:jec), & + IOB% fprec (isc:iec,jsc:jec), & + IOB% ustar_berg (isc:iec,jsc:jec), & + IOB% area_berg (isc:iec,jsc:jec), & + IOB% mass_berg (isc:iec,jsc:jec), & + IOB% calving (isc:iec,jsc:jec), & + IOB% runoff_hflx (isc:iec,jsc:jec), & + IOB% calving_hflx (isc:iec,jsc:jec), & + IOB% mi (isc:iec,jsc:jec), & + IOB% p (isc:iec,jsc:jec)) + + IOB%latent_flux = 0.0 + IOB%rofl_flux = 0.0 + IOB%rofi_flux = 0.0 + IOB%u_flux = 0.0 + IOB%v_flux = 0.0 + IOB%t_flux = 0.0 + IOB%seaice_melt_heat = 0.0 + IOB%seaice_melt = 0.0 + IOB%q_flux = 0.0 + IOB%salt_flux = 0.0 + IOB%lw_flux = 0.0 + IOB%sw_flux_vis_dir = 0.0 + IOB%sw_flux_vis_dif = 0.0 + IOB%sw_flux_nir_dir = 0.0 + IOB%sw_flux_nir_dif = 0.0 + IOB%lprec = 0.0 + IOB%fprec = 0.0 + IOB%ustar_berg = 0.0 + IOB%area_berg = 0.0 + IOB%mass_berg = 0.0 + IOB%calving = 0.0 + IOB%runoff_hflx = 0.0 + IOB%calving_hflx = 0.0 + IOB%mi = 0.0 + IOB%p = 0.0 + +end subroutine IOB_allocate + +!======================================================================= + +!> Adds flux adjustments obtained via data_override +!! Component name is 'OCN' +!! Available adjustments are: +!! - taux_adj (Zonal wind stress delta, positive to the east, in Pa) +!! - tauy_adj (Meridional wind stress delta, positive to the north, in Pa) +subroutine apply_flux_adjustments(G, CS, Time, fluxes) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(surface_forcing_CS), pointer :: CS !< Surface forcing control structure + type(time_type), intent(in) :: Time !< Model time structure + type(forcing), optional, intent(inout) :: fluxes !< Surface fluxes structure + + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: tempx_at_h ! Delta to zonal wind stress at h points (Pa) + real, dimension(SZI_(G),SZJ_(G)) :: tempy_at_h ! Delta to meridional wind stress at h points (Pa) + real, dimension(SZI_(G),SZJ_(G)) :: temp_at_h ! Fluxes at h points (W m-2 or kg m-2 s-1) + + integer :: isc, iec, jsc, jec, i, j + real :: dLonDx, dLonDy, rDlon, cosA, sinA, zonal_tau, merid_tau + logical :: overrode_x, overrode_y, overrode_h + + isc = G%isc; iec = G%iec + jsc = G%jsc; jec = G%jec + + overrode_h = .false. + call data_override('OCN', 'hflx_adj', temp_at_h(isc:iec,jsc:jec), Time, override=overrode_h) + + if (overrode_h) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec + fluxes%heat_added(i,j) = fluxes%heat_added(i,j) + temp_at_h(i,j)* G%mask2dT(i,j) + enddo; enddo + endif + + call pass_var(fluxes%heat_added, G%Domain) + + overrode_h = .false. + call data_override('OCN', 'sflx_adj', temp_at_h(isc:iec,jsc:jec), Time, override=overrode_h) + + if (overrode_h) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec + fluxes%salt_flux_added(i,j) = fluxes%salt_flux_added(i,j) + temp_at_h(i,j)* G%mask2dT(i,j) + enddo; enddo + endif + + call pass_var(fluxes%salt_flux_added, G%Domain) + overrode_h = .false. + + call data_override('OCN', 'prcme_adj', temp_at_h(isc:iec,jsc:jec), Time, override=overrode_h) + + if (overrode_h) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec + fluxes%vprec(i,j) = fluxes%vprec(i,j) + temp_at_h(i,j)* G%mask2dT(i,j) + enddo; enddo + endif + + call pass_var(fluxes%vprec, G%Domain) + +end subroutine apply_flux_adjustments + +!======================================================================= + +!> Adds mechanical forcing adjustments obtained via data_override +!! Component name is 'OCN' +!! Available adjustments are: +!! - taux_adj (Zonal wind stress delta, positive to the east, in Pa) +!! - tauy_adj (Meridional wind stress delta, positive to the north, in Pa) +subroutine apply_force_adjustments(G, CS, Time, forces) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(surface_forcing_CS), pointer :: CS !< Surface forcing control structure + type(time_type), intent(in) :: Time !< Model time structure + type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces + + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: tempx_at_h ! Delta to zonal wind stress at h points (Pa) + real, dimension(SZI_(G),SZJ_(G)) :: tempy_at_h ! Delta to meridional wind stress at h points (Pa) + + integer :: isc, iec, jsc, jec, i, j + real :: dLonDx, dLonDy, rDlon, cosA, sinA, zonal_tau, merid_tau + logical :: overrode_x, overrode_y + + isc = G%isc; iec = G%iec ; jsc = G%jsc; jec = G%jec + + tempx_at_h(:,:) = 0.0 ; tempy_at_h(:,:) = 0.0 + ! Either reads data or leaves contents unchanged + overrode_x = .false. ; overrode_y = .false. + call data_override('OCN', 'taux_adj', tempx_at_h(isc:iec,jsc:jec), Time, override=overrode_x) + call data_override('OCN', 'tauy_adj', tempy_at_h(isc:iec,jsc:jec), Time, override=overrode_y) + + if (overrode_x .or. overrode_y) then + if (.not. (overrode_x .and. overrode_y)) call MOM_error(FATAL,"apply_flux_adjustments: "//& + "Both taux_adj and tauy_adj must be specified, or neither, in data_table") + + ! Rotate winds + call pass_vector(tempx_at_h, tempy_at_h, G%Domain, To_All, AGRID, halo=1) + do j=jsc-1,jec+1 ; do i=isc-1,iec+1 + dLonDx = G%geoLonCu(I,j) - G%geoLonCu(I-1,j) + dLonDy = G%geoLonCv(i,J) - G%geoLonCv(i,J-1) + rDlon = sqrt( dLonDx * dLonDx + dLonDy * dLonDy ) + if (rDlon > 0.) rDlon = 1. / rDlon + cosA = dLonDx * rDlon + sinA = dLonDy * rDlon + zonal_tau = tempx_at_h(i,j) + merid_tau = tempy_at_h(i,j) + tempx_at_h(i,j) = cosA * zonal_tau - sinA * merid_tau + tempy_at_h(i,j) = sinA * zonal_tau + cosA * merid_tau + enddo ; enddo + + ! Average to C-grid locations + do j=jsc,jec ; do I=isc-1,iec + forces%taux(I,j) = forces%taux(I,j) + 0.5 * ( tempx_at_h(i,j) + tempx_at_h(i+1,j) ) + enddo ; enddo + + do J=jsc-1,jec ; do i=isc,iec + forces%tauy(i,J) = forces%tauy(i,J) + 0.5 * ( tempy_at_h(i,j) + tempy_at_h(i,j+1) ) + enddo ; enddo + endif ! overrode_x .or. overrode_y + +end subroutine apply_force_adjustments + +!======================================================================= + +!> Saves restart fields associated with the forcing +subroutine forcing_save_restart(CS, G, Time, directory, time_stamped, & + filename_suffix) + type(surface_forcing_CS), pointer :: CS !< pointer to the control structure + !! returned by a previous call to + !! surface_forcing_init + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(time_type), intent(in) :: Time !< model time at this call + character(len=*), intent(in) :: directory !< optional directory into which + !! to write these restart files + logical, optional, intent(in) :: time_stamped !< If true, the restart file + !! names include a unique time + !! stamp + character(len=*), optional, intent(in) :: filename_suffix !< optional suffix + !! (e.g., a time-stamp) to append to the + !! restart file names + if (.not.associated(CS)) return + if (.not.associated(CS%restart_CSp)) return + call save_restart(directory, Time, G, CS%restart_CSp, time_stamped) + +end subroutine forcing_save_restart + +!======================================================================= + +!> Initializes surface forcing: get relevant parameters and allocate arrays. +subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, restore_temp) + type(time_type), intent(in) :: Time !< The current model time + type(ocean_grid_type), intent(in) :: G !< The ocean's 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 !< A structure that is used to regulate diagnostic output + type(surface_forcing_CS), pointer :: CS !< A pointer that is set to point to the + !! control structure for this module + logical, optional, intent(in) :: restore_salt, restore_temp !< If present and true, + !! temp/salt restoring will be applied + + ! local variables + real :: utide !< The RMS tidal velocity [m s-1]. + type(directories) :: dirs + logical :: new_sim, iceberg_flux_diags + type(time_type) :: Time_frc + character(len=200) :: TideAmp_file, gust_file, salt_file, temp_file ! Input file names. +! This include declares and sets the variable "version". +#include "version_variable.h" + character(len=40) :: mdl = "ocn_comp_mct" ! This module's name. + character(len=48) :: stagger + character(len=240) :: basin_file + integer :: i, j, isd, ied, jsd, jed + + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + if (associated(CS)) then + call MOM_error(WARNING, "surface_forcing_init called with an associated "// & + "control structure.") + return + endif + allocate(CS) + + id_clock_forcing=cpu_clock_id('Ocean surface forcing', grain=CLOCK_SUBCOMPONENT) + call cpu_clock_begin(id_clock_forcing) + + CS%diag => diag + + call write_version_number (version) + ! 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, & + "The directory in which all input files are found.", & + 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"//& + "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"//& + "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, & + "The latent heat of fusion.", units="J/kg", default=hlf) + 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"//& + "limit is applied if a negative value is used.", units="Pa", & + default=-1.0) + 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"//& + "whether restoring is via a salt flux or virtual precip.",& + default=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"//& + "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"//& + "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"//& + "the net fresh-water.", default=.false.) + 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"//& + "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"//& + "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"//& + "pressure.", default=.true.) + +! smg: should get_param call should be removed when have A=B code reconciled. +! this param is used to distinguish how to diagnose surface heat content from water. + call get_param(param_file, mdl, "BULKMIXEDLAYER", CS%bulkmixedlayer, & + default=CS%use_temperature,do_not_log=.true.) + + 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"//& + "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 + elseif (uppercase(stagger(1:1)) == 'C') then ; CS%wind_stagger = CGRID_NE + 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"//& + "production runs.", default=1.0) + + if (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"//& + "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, & + "A file in which to find the surface salinity to use for restoring.", & + default="salt_restore.nc") + call get_param(param_file, mdl, "SALT_RESTORE_VARIABLE", CS%salt_restore_var_name, & + "The name of the surface salinity variable to read from "//& + "SALT_RESTORE_FILE for restoring salinity.", & + default="salt") +! 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, "SRESTORE_AS_SFLUX", CS%salt_restore_as_sflux, & + "If true, the restoring of salinity is applied as a salt \n"//& + "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"//& + "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"//& + "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'.", & + default="basin.nc") + basin_file = trim(CS%inputdir) // trim(basin_file) + call safe_alloc_ptr(CS%basin_mask,isd,ied,jsd,jed) ; CS%basin_mask(:,:) = 1.0 + if (CS%mask_srestore_marginal_seas) then + call read_data(basin_file,'basin',CS%basin_mask,domain=G%domain%mpp_domain,timelevel=1) + do j=jsd,jed ; do i=isd,ied + if (CS%basin_mask(i,j) >= 6.0) then ; CS%basin_mask(i,j) = 0.0 + else ; CS%basin_mask(i,j) = 1.0 ; endif + enddo ; enddo + endif + endif + + if (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"//& + "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, & + "A file in which to find the surface temperature to use for restoring.", & + default="temp_restore.nc") + call get_param(param_file, mdl, "SST_RESTORE_VARIABLE", CS%temp_restore_var_name, & + "The name of the surface temperature variable to read from "//& + "SST_RESTORE_FILE for restoring sst.", & + default="temp") +! 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, "MAX_DELTA_TRESTORE", CS%max_delta_trestore, & + "The maximum sst difference used in restoring terms.", & + units="degC ", default=999.0) + + endif + +! Optionally read tidal amplitude from input file [m s-1] on model grid. +! Otherwise use default tidal amplitude for bottom frictionally-generated +! dissipation. Default cd_tides is chosen to yield approx 1 TWatt of +! work done against tides globally using OSU tidal amplitude. + call get_param(param_file, mdl, "CD_TIDES", CS%cd_tides, & + "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"//& + "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"//& + "tidal amplitudes with INT_TIDE_DISSIPATION.", & + default="tideamp.nc") + CS%utide=0.0 + else + 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) + endif + + call safe_alloc_ptr(CS%TKE_tidal,isd,ied,jsd,jed) + call safe_alloc_ptr(CS%ustar_tidal,isd,ied,jsd,jed) + + if (CS%read_TIDEAMP) then + TideAmp_file = trim(CS%inputdir) // trim(TideAmp_file) + call read_data(TideAmp_file,'tideamp',CS%TKE_tidal,domain=G%domain%mpp_domain,timelevel=1) + do j=jsd, jed; do i=isd, ied + utide = CS%TKE_tidal(i,j) + CS%TKE_tidal(i,j) = G%mask2dT(i,j)*CS%Rho0*CS%cd_tides*(utide*utide*utide) + CS%ustar_tidal(i,j)=sqrt(CS%cd_tides)*utide + enddo ; enddo + else + do j=jsd,jed; do i=isd,ied + utide=CS%utide + CS%TKE_tidal(i,j) = CS%Rho0*CS%cd_tides*(utide*utide*utide) + CS%ustar_tidal(i,j)=sqrt(CS%cd_tides)*utide + enddo ; enddo + endif + + call time_interp_external_init + +! Optionally read a x-y gustiness field in place of a global +! constant. + + call get_param(param_file, mdl, "READ_GUST_2D", CS%read_gust_2d, & + "If true, use a 2-dimensional gustiness supplied from \n"//& + "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"//& + "variable gustiness.") + + call safe_alloc_ptr(CS%gust,isd,ied,jsd,jed) + gust_file = trim(CS%inputdir) // trim(gust_file) + call read_data(gust_file,'gustiness',CS%gust,domain=G%domain%mpp_domain, & + timelevel=1) ! units should be Pa + endif + +! 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"//& + "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"//& + "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"//& + "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"//& + "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"//& + "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"//& + "data_table using the component name 'OCN'.", default=.false.) + if (CS%allow_flux_adjustments) then + call data_override_init(Ocean_domain_in=G%Domain%mpp_domain) + endif + + if (present(restore_salt)) then ; if (restore_salt) then + salt_file = trim(CS%inputdir) // trim(CS%salt_restore_file) + CS%id_srestore = init_external_field(salt_file, CS%salt_restore_var_name, domain=G%Domain%mpp_domain) + endif ; endif + + if (present(restore_temp)) then ; if (restore_temp) then + temp_file = trim(CS%inputdir) // trim(CS%temp_restore_file) + CS%id_trestore = init_external_field(temp_file, CS%temp_restore_var_name, domain=G%Domain%mpp_domain) + endif ; endif + + ! Set up any restart fields associated with the forcing. + call restart_init(param_file, CS%restart_CSp, "MOM_forcing.res") +!### call register_ctrl_forcing_restarts(G, param_file, CS%ctrl_forcing_CSp, & +!### CS%restart_CSp) + call restart_init_end(CS%restart_CSp) + + if (associated(CS%restart_CSp)) then + call Get_MOM_Input(dirs=dirs) + + new_sim = .false. + if ((dirs%input_filename(1:1) == 'n') .and. & + (LEN_TRIM(dirs%input_filename) == 1)) new_sim = .true. + if (.not.new_sim) then + call restore_state(dirs%input_filename, dirs%restart_input_dir, Time_frc, & + G, CS%restart_CSp) + endif + endif + +!### call controlled_forcing_init(Time, G, param_file, diag, CS%ctrl_forcing_CSp) + + call user_revise_forcing_init(param_file, CS%urf_CS) + + call cpu_clock_end(id_clock_forcing) +end subroutine surface_forcing_init + +!======================================================================= + +!> Finalizes surface forcing: deallocate surface forcing control structure +subroutine surface_forcing_end(CS, fluxes) + type(surface_forcing_CS), pointer :: CS + type(forcing), optional, intent(inout) :: fluxes +! Arguments: CS - A pointer to the control structure returned by a previous +! call to surface_forcing_init, it will be deallocated here. +! (inout) fluxes - A structure containing pointers to any possible +! forcing fields. Unused fields have NULL ptrs. + + if (present(fluxes)) call deallocate_forcing_type(fluxes) + +!### call controlled_forcing_end(CS%ctrl_forcing_CSp) + + if (associated(CS)) deallocate(CS) + CS => NULL() + +end subroutine surface_forcing_end + +!======================================================================= + +subroutine ice_ocn_bnd_type_chksum(id, timestep, iobt) + + character(len=*), intent(in) :: id + integer , intent(in) :: timestep + type(ice_ocean_boundary_type), intent(in) :: iobt + integer :: n,m, outunit + + outunit = stdout() + + write(outunit,*) "BEGIN CHECKSUM(ice_ocean_boundary_type):: ", id, timestep + write(outunit,100) 'iobt%u_flux ', mpp_chksum( iobt%u_flux ) + write(outunit,100) 'iobt%v_flux ', mpp_chksum( iobt%v_flux ) + write(outunit,100) 'iobt%t_flux ', mpp_chksum( iobt%t_flux ) + write(outunit,100) 'iobt%seaice_melt_heat', mpp_chksum( iobt%seaice_melt_heat) + write(outunit,100) 'iobt%seaice_melt ', mpp_chksum( iobt%seaice_melt ) + write(outunit,100) 'iobt%q_flux ', mpp_chksum( iobt%q_flux ) + write(outunit,100) 'iobt%rofl_flux ', mpp_chksum( iobt%rofl_flux ) + write(outunit,100) 'iobt%rofi_flux ', mpp_chksum( iobt%rofi_flux ) + write(outunit,100) 'iobt%salt_flux ', mpp_chksum( iobt%salt_flux ) + write(outunit,100) 'iobt%lw_flux ', mpp_chksum( iobt%lw_flux ) + write(outunit,100) 'iobt%sw_flux_vis_dir ', mpp_chksum( iobt%sw_flux_vis_dir ) + write(outunit,100) 'iobt%sw_flux_vis_dif ', mpp_chksum( iobt%sw_flux_vis_dif ) + write(outunit,100) 'iobt%sw_flux_nir_dir ', mpp_chksum( iobt%sw_flux_nir_dir ) + write(outunit,100) 'iobt%sw_flux_nir_dif ', mpp_chksum( iobt%sw_flux_nir_dif ) + write(outunit,100) 'iobt%lprec ', mpp_chksum( iobt%lprec ) + write(outunit,100) 'iobt%fprec ', mpp_chksum( iobt%fprec ) + write(outunit,100) 'iobt%calving ', mpp_chksum( iobt%calving ) + write(outunit,100) 'iobt%p ', mpp_chksum( iobt%p ) + if (associated(iobt%ustar_berg)) & + write(outunit,100) 'iobt%ustar_berg ', mpp_chksum( iobt%ustar_berg ) + if (associated(iobt%area_berg)) & + write(outunit,100) 'iobt%area_berg ', mpp_chksum( iobt%area_berg ) + if (associated(iobt%mass_berg)) & + write(outunit,100) 'iobt%mass_berg ', mpp_chksum( iobt%mass_berg ) +100 FORMAT(" CHECKSUM::",A20," = ",Z20) + + call coupler_type_write_chksums(iobt%fluxes, outunit, 'iobt%') + +end subroutine ice_ocn_bnd_type_chksum + +end module MOM_surface_forcing diff --git a/config_src/mct_driver/ocn_cap_methods.F90 b/config_src/mct_driver/ocn_cap_methods.F90 new file mode 100644 index 0000000000..a8ac5310c7 --- /dev/null +++ b/config_src/mct_driver/ocn_cap_methods.F90 @@ -0,0 +1,279 @@ +module ocn_cap_methods + + use ESMF, only: ESMF_clock, ESMF_time, ESMF_ClockGet, ESMF_TimeGet + use MOM_ocean_model, only: ocean_public_type, ocean_state_type + use MOM_surface_forcing, only: ice_ocean_boundary_type + use MOM_grid, only: ocean_grid_type + use MOM_domains, only: pass_var + use MOM_error_handler, only: is_root_pe + use mpp_domains_mod, only: mpp_get_compute_domain + use ocn_cpl_indices, only: cpl_indices_type + + implicit none + private + + public :: ocn_import + public :: ocn_export + + logical, parameter :: debug=.false. + +!======================================================================= +contains +!======================================================================= + +!> Maps incomping ocean data to MOM6 data structures +subroutine ocn_import(x2o, ind, grid, ice_ocean_boundary, ocean_public, logunit, Eclock, c1, c2, c3, c4) + real(kind=8) , intent(in) :: x2o(:,:) !< incoming data + type(cpl_indices_type) , intent(in) :: ind !< Structure with MCT attribute vects and indices + type(ocean_grid_type) , intent(in) :: grid !< Ocean model grid + type(ice_ocean_boundary_type) , intent(inout) :: ice_ocean_boundary !< Ocean boundary forcing + type(ocean_public_type) , intent(in) :: ocean_public !< Ocean surface state + integer , intent(in) :: logunit !< Unit for stdout output + type(ESMF_Clock) , intent(in) :: EClock !< Time and time step ? \todo Why must this + real(kind=8), optional , intent(in) :: c1, c2, c3, c4 !< Coeffs. used in the shortwave decomposition + + ! Local variables + integer :: i, j, isc, iec, jsc, jec ! Grid indices + integer :: k + integer :: day, secs, rc + type(ESMF_time) :: currTime + character(*), parameter :: F01 = "('(ocn_import) ',a,4(i6,2x),d21.14)" + !----------------------------------------------------------------------- + + isc = GRID%isc; iec = GRID%iec ; jsc = GRID%jsc; jec = GRID%jec + + k = 0 + do j = jsc, jec + do i = isc, iec + k = k + 1 ! Increment position within gindex + + ! rotate taux and tauy from true zonal/meridional to local coordinates + ! taux + ice_ocean_boundary%u_flux(i,j) = GRID%cos_rot(i,j) * x2o(ind%x2o_Foxx_taux,k) & + + GRID%sin_rot(i,j) * x2o(ind%x2o_Foxx_tauy,k) + + ! tauy + ice_ocean_boundary%v_flux(i,j) = GRID%cos_rot(i,j) * x2o(ind%x2o_Foxx_tauy,k) & + - GRID%sin_rot(i,j) * x2o(ind%x2o_Foxx_taux,k) + + ! liquid precipitation (rain) + ice_ocean_boundary%lprec(i,j) = x2o(ind%x2o_Faxa_rain,k) + + ! frozen precipitation (snow) + ice_ocean_boundary%fprec(i,j) = x2o(ind%x2o_Faxa_snow,k) + + ! longwave radiation, sum up and down (W/m2) + ice_ocean_boundary%lw_flux(i,j) = (x2o(ind%x2o_Faxa_lwdn,k) + x2o(ind%x2o_Foxx_lwup,k)) + + ! specific humitidy flux + ice_ocean_boundary%q_flux(i,j) = x2o(ind%x2o_Foxx_evap,k) + + ! sensible heat flux (W/m2) + ice_ocean_boundary%t_flux(i,j) = x2o(ind%x2o_Foxx_sen,k) + + ! latent heat flux (W/m^2) + ice_ocean_boundary%latent_flux(i,j) = x2o(ind%x2o_Foxx_lat,k) + + ! snow&ice melt heat flux (W/m^2) + ice_ocean_boundary%seaice_melt_heat(i,j) = x2o(ind%x2o_Fioi_melth,k) + + ! water flux from snow&ice melt (kg/m2/s) + ice_ocean_boundary%seaice_melt(i,j) = x2o(ind%x2o_Fioi_meltw,k) + + ! liquid runoff + ice_ocean_boundary%rofl_flux(i,j) = x2o(ind%x2o_Foxx_rofl,k) * GRID%mask2dT(i,j) + + ! ice runoff + ice_ocean_boundary%rofi_flux(i,j) = x2o(ind%x2o_Foxx_rofi,k) * GRID%mask2dT(i,j) + + ! surface pressure + ice_ocean_boundary%p(i,j) = x2o(ind%x2o_Sa_pslv,k) * GRID%mask2dT(i,j) + + ! salt flux (minus sign needed here -GMM) + ice_ocean_boundary%salt_flux(i,j) = -x2o(ind%x2o_Fioi_salt,k) * GRID%mask2dT(i,j) + + ! 1) visible, direct shortwave (W/m2) + ! 2) visible, diffuse shortwave (W/m2) + ! 3) near-IR, direct shortwave (W/m2) + ! 4) near-IR, diffuse shortwave (W/m2) + if (present(c1) .and. present(c2) .and. present(c3) .and. present(c4)) then + ! Use runtime coefficients to decompose net short-wave heat flux into 4 components + ice_ocean_boundary%sw_flux_vis_dir(i,j) = x2o(ind%x2o_Foxx_swnet,k) * c1 * GRID%mask2dT(i,j) + ice_ocean_boundary%sw_flux_vis_dif(i,j) = x2o(ind%x2o_Foxx_swnet,k) * c2 * GRID%mask2dT(i,j) + ice_ocean_boundary%sw_flux_nir_dir(i,j) = x2o(ind%x2o_Foxx_swnet,k) * c3 * GRID%mask2dT(i,j) + ice_ocean_boundary%sw_flux_nir_dif(i,j) = x2o(ind%x2o_Foxx_swnet,k) * c4 * GRID%mask2dT(i,j) + else + ice_ocean_boundary%sw_flux_vis_dir(i,j) = x2o(ind%x2o_Faxa_swvdr,k) * GRID%mask2dT(i,j) + ice_ocean_boundary%sw_flux_vis_dif(i,j) = x2o(ind%x2o_Faxa_swvdf,k) * GRID%mask2dT(i,j) + ice_ocean_boundary%sw_flux_nir_dir(i,j) = x2o(ind%x2o_Faxa_swndr,k) * GRID%mask2dT(i,j) + ice_ocean_boundary%sw_flux_nir_dif(i,j) = x2o(ind%x2o_Faxa_swndf,k) * GRID%mask2dT(i,j) + endif + enddo + enddo + + if (debug .and. is_root_pe()) then + call ESMF_ClockGet(EClock, CurrTime=CurrTime, rc=rc) + call ESMF_TimeGet(CurrTime, d=day, s=secs, rc=rc) + + do j = GRID%jsc, GRID%jec + do i = GRID%isc, GRID%iec + write(logunit,F01)'import: day, secs, j, i, u_flux = ',day,secs,j,i,ice_ocean_boundary%u_flux(i,j) + write(logunit,F01)'import: day, secs, j, i, v_flux = ',day,secs,j,i,ice_ocean_boundary%v_flux(i,j) + write(logunit,F01)'import: day, secs, j, i, lprec = ',day,secs,j,i,ice_ocean_boundary%lprec(i,j) + write(logunit,F01)'import: day, secs, j, i, lwrad = ',day,secs,j,i,ice_ocean_boundary%lw_flux(i,j) + write(logunit,F01)'import: day, secs, j, i, q_flux = ',day,secs,j,i,ice_ocean_boundary%q_flux(i,j) + write(logunit,F01)'import: day, secs, j, i, t_flux = ',day,secs,j,i,ice_ocean_boundary%t_flux(i,j) + write(logunit,F01)'import: day, secs, j, i, seaice_melt_heat = ',& + day,secs,j,i,ice_ocean_boundary%seaice_melt_heat(i,j) + write(logunit,F01)'import: day, secs, j, i, seaice_melt = ',& + day,secs,j,i,ice_ocean_boundary%seaice_melt(i,j) + write(logunit,F01)'import: day, secs, j, i, latent_flux = ',& + day,secs,j,i,ice_ocean_boundary%latent_flux(i,j) + write(logunit,F01)'import: day, secs, j, i, runoff = ',& + day,secs,j,i,ice_ocean_boundary%rofl_flux(i,j) + ice_ocean_boundary%rofi_flux(i,j) + write(logunit,F01)'import: day, secs, j, i, psurf = ',& + day,secs,j,i,ice_ocean_boundary%p(i,j) + write(logunit,F01)'import: day, secs, j, i, salt_flux = ',& + day,secs,j,i,ice_ocean_boundary%salt_flux(i,j) + write(logunit,F01)'import: day, secs, j, i, sw_flux_vis_dir = ',& + day,secs,j,i,ice_ocean_boundary%sw_flux_vis_dir(i,j) + write(logunit,F01)'import: day, secs, j, i, sw_flux_vis_dif = ',& + day,secs,j,i,ice_ocean_boundary%sw_flux_vis_dif(i,j) + write(logunit,F01)'import: day, secs, j, i, sw_flux_nir_dir = ',& + day,secs,j,i,ice_ocean_boundary%sw_flux_nir_dir(i,j) + write(logunit,F01)'import: day, secs, j, i, sw_flux_nir_dif = ',& + day,secs,j,i,ice_ocean_boundary%sw_flux_nir_dir(i,j) + enddo + enddo + endif + +end subroutine ocn_import + +!======================================================================= + +!> Maps outgoing ocean data to MCT attribute vector real array +subroutine ocn_export(ind, ocn_public, grid, o2x, dt_int, ncouple_per_day) + type(cpl_indices_type), intent(inout) :: ind !< Structure with coupler indices and vectors + type(ocean_public_type), intent(in) :: ocn_public !< Ocean surface state + type(ocean_grid_type), intent(in) :: grid !< Ocean model grid + real(kind=8), intent(inout) :: o2x(:,:) !< MCT outgoing bugger + real(kind=8), intent(in) :: dt_int !< Amount of time over which to advance the + !! ocean (ocean_coupling_time_step), in sec + integer, intent(in) :: ncouple_per_day !< Number of ocean coupling calls per day + + ! Local variables + real, dimension(grid%isd:grid%ied,grid%jsd:grid%jed) :: ssh !< Local copy of sea_lev with updated halo + real, dimension(grid%isd:grid%ied,grid%jsd:grid%jed) :: sshx!< Zonal SSH gradient, local coordinate. + real, dimension(grid%isd:grid%ied,grid%jsd:grid%jed) :: sshy!< Meridional SSH gradient, local coordinate. + integer :: i, j, n, ig, jg !< Grid indices + real :: slp_L, slp_R, slp_C, slope, u_min, u_max + real :: I_time_int !< The inverse of coupling time interval [s-1]. + + !----------------------------------------------------------------------- + + ! Use Adcroft's rule of reciprocals; it does the right thing here. + I_time_int = 0.0 ; if (dt_int > 0.0) I_time_int = 1.0 / dt_int + + ! Copy from ocn_public to o2x. ocn_public uses global indexing with no halos. + ! The mask comes from "grid" that uses the usual MOM domain that has halos + ! and does not use global indexing. + + n = 0 + do j=grid%jsc, grid%jec + jg = j + grid%jdg_offset + do i=grid%isc,grid%iec + n = n+1 + ig = i + grid%idg_offset + ! surface temperature in Kelvin + o2x(ind%o2x_So_t, n) = ocn_public%t_surf(ig,jg) * grid%mask2dT(i,j) + o2x(ind%o2x_So_s, n) = ocn_public%s_surf(ig,jg) * grid%mask2dT(i,j) + ! rotate ocn current from local tripolar grid to true zonal/meridional (inverse transformation) + o2x(ind%o2x_So_u, n) = (grid%cos_rot(i,j) * ocn_public%u_surf(ig,jg) - & + grid%sin_rot(i,j) * ocn_public%v_surf(ig,jg)) * grid%mask2dT(i,j) + o2x(ind%o2x_So_v, n) = (grid%cos_rot(i,j) * ocn_public%v_surf(ig,jg) + & + grid%sin_rot(i,j) * ocn_public%u_surf(ig,jg)) * grid%mask2dT(i,j) + + ! boundary layer depth (m) + o2x(ind%o2x_So_bldepth, n) = ocn_public%OBLD(ig,jg) * grid%mask2dT(i,j) + ! ocean melt and freeze potential (o2x_Fioo_q), W m-2 + if (ocn_public%frazil(ig,jg) > 0.0) then + ! Frazil: change from J/m^2 to W/m^2 + o2x(ind%o2x_Fioo_q, n) = ocn_public%frazil(ig,jg) * grid%mask2dT(i,j) * I_time_int + else + ! Melt_potential: change from J/m^2 to W/m^2 + o2x(ind%o2x_Fioo_q, n) = -ocn_public%melt_potential(ig,jg) * grid%mask2dT(i,j) * I_time_int !* ncouple_per_day + ! make sure Melt_potential is always <= 0 + if (o2x(ind%o2x_Fioo_q, n) > 0.0) o2x(ind%o2x_Fioo_q, n) = 0.0 + endif + ! Make a copy of ssh in order to do a halo update. We use the usual MOM domain + ! in order to update halos. i.e. does not use global indexing. + ssh(i,j) = ocn_public%sea_lev(ig,jg) + enddo + enddo + + ! Update halo of ssh so we can calculate gradients + call pass_var(ssh, grid%domain) + + ! d/dx ssh + do j=grid%jsc, grid%jec ; do i=grid%isc,grid%iec + ! This is a simple second-order difference + ! o2x(ind%o2x_So_dhdx, n) = 0.5 * (ssh(i+1,j) - ssh(i-1,j)) * grid%IdxT(i,j) * grid%mask2dT(i,j) + ! This is a PLM slope which might be less prone to the A-grid null mode + slp_L = (ssh(I,j) - ssh(I-1,j)) * grid%mask2dCu(I-1,j) + if (grid%mask2dCu(I-1,j)==0.) slp_L = 0. + slp_R = (ssh(I+1,j) - ssh(I,j)) * grid%mask2dCu(I,j) + if (grid%mask2dCu(I+1,j)==0.) slp_R = 0. + slp_C = 0.5 * (slp_L + slp_R) + if ( (slp_L * slp_R) > 0.0 ) then + ! This limits the slope so that the edge values are bounded by the + ! two cell averages spanning the edge. + u_min = min( ssh(i-1,j), ssh(i,j), ssh(i+1,j) ) + u_max = max( ssh(i-1,j), ssh(i,j), ssh(i+1,j) ) + slope = sign( min( abs(slp_C), 2.*min( ssh(i,j) - u_min, u_max - ssh(i,j) ) ), slp_C ) + else + ! Extrema in the mean values require a PCM reconstruction avoid generating + ! larger extreme values. + slope = 0.0 + endif + sshx(i,j) = slope * grid%IdxT(i,j) * grid%mask2dT(i,j) + if (grid%mask2dT(i,j)==0.) sshx(i,j) = 0.0 + enddo; enddo + + ! d/dy ssh + do j=grid%jsc, grid%jec ; do i=grid%isc,grid%iec + ! This is a simple second-order difference + ! o2x(ind%o2x_So_dhdy, n) = 0.5 * (ssh(i,j+1) - ssh(i,j-1)) * grid%IdyT(i,j) * grid%mask2dT(i,j) + ! This is a PLM slope which might be less prone to the A-grid null mode + slp_L = ssh(i,J) - ssh(i,J-1) * grid%mask2dCv(i,J-1) + if (grid%mask2dCv(i,J-1)==0.) slp_L = 0. + + slp_R = ssh(i,J+1) - ssh(i,J) * grid%mask2dCv(i,J) + if (grid%mask2dCv(i,J+1)==0.) slp_R = 0. + + slp_C = 0.5 * (slp_L + slp_R) + if ((slp_L * slp_R) > 0.0) then + ! This limits the slope so that the edge values are bounded by the + ! two cell averages spanning the edge. + u_min = min( ssh(i,j-1), ssh(i,j), ssh(i,j+1) ) + u_max = max( ssh(i,j-1), ssh(i,j), ssh(i,j+1) ) + slope = sign( min( abs(slp_C), 2.*min( ssh(i,j) - u_min, u_max - ssh(i,j) ) ), slp_C ) + else + ! Extrema in the mean values require a PCM reconstruction avoid generating + ! larger extreme values. + slope = 0.0 + endif + sshy(i,j) = slope * grid%IdyT(i,j) * grid%mask2dT(i,j) + if (grid%mask2dT(i,j)==0.) sshy(i,j) = 0.0 + enddo; enddo + + ! rotate ssh gradients from local coordinates to true zonal/meridional (inverse transformation) + n = 0 + do j=grid%jsc, grid%jec ; do i=grid%isc,grid%iec + n = n+1 + o2x(ind%o2x_So_dhdx, n) = grid%cos_rot(i,j) * sshx(i,j) - grid%sin_rot(i,j) * sshy(i,j) + o2x(ind%o2x_So_dhdy, n) = grid%cos_rot(i,j) * sshy(i,j) + grid%sin_rot(i,j) * sshx(i,j) + enddo; enddo + +end subroutine ocn_export + +end module ocn_cap_methods diff --git a/config_src/mct_driver/ocn_comp_mct.F90 b/config_src/mct_driver/ocn_comp_mct.F90 index 35217b5c8e..5ce89fc9f7 100644 --- a/config_src/mct_driver/ocn_comp_mct.F90 +++ b/config_src/mct_driver/ocn_comp_mct.F90 @@ -4,84 +4,61 @@ module ocn_comp_mct ! This file is part of MOM6. See LICENSE.md for the license. ! mct modules -use ESMF, only: ESMF_clock, ESMF_time, ESMF_timeInterval, ESMF_TimeInc +use ESMF, only: ESMF_clock, ESMF_time, ESMF_timeInterval use ESMF, only: ESMF_ClockGet, ESMF_TimeGet, ESMF_TimeIntervalGet use seq_cdata_mod, only: seq_cdata, seq_cdata_setptrs -use seq_flds_mod, only: ice_ncat, seq_flds_i2o_per_cat +use seq_flds_mod, only: seq_flds_x2o_fields, seq_flds_o2x_fields use mct_mod, only: mct_gsMap, mct_gsmap_init, mct_gsMap_lsize, & mct_gsmap_orderedpoints use mct_mod, only: mct_aVect, mct_aVect_init, mct_aVect_zero, & mct_aVect_nRattr use mct_mod, only: mct_gGrid, mct_gGrid_init, mct_gGrid_importRAttr, & mct_gGrid_importIAttr -use mct_mod, only: mct_avect_indexra, mct_aVect_clean -use seq_flds_mod, only: seq_flds_x2o_fields, seq_flds_o2x_fields, seq_flds_dom_coord, & - seq_flds_dom_other use seq_infodata_mod, only: seq_infodata_type, seq_infodata_GetData, & seq_infodata_start_type_start, seq_infodata_start_type_cont, & seq_infodata_start_type_brnch, seq_infodata_PutData use seq_comm_mct, only: seq_comm_name, seq_comm_inst, seq_comm_suffix use seq_timemgr_mod, only: seq_timemgr_EClockGetData, seq_timemgr_RestartAlarmIsOn use perf_mod, only: t_startf, t_stopf -use shr_kind_mod, only: shr_kind_r8 use shr_file_mod, only: shr_file_getUnit, shr_file_freeUnit, shr_file_setIO, & shr_file_getLogUnit, shr_file_getLogLevel, & shr_file_setLogUnit, shr_file_setLogLevel +use MOM_surface_forcing, only: IOB_allocate, ice_ocean_boundary_type + ! MOM6 modules -use MOM_domains, only : MOM_infra_init, MOM_infra_end -use MOM_coms, only : reproducing_sum -use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end -use MOM_cpu_clock, only : CLOCK_SUBCOMPONENT -use MOM, only: initialize_MOM, step_MOM, MOM_control_struct, MOM_end -use MOM, only: extract_surface_state, allocate_surface_state -use MOM, only: finish_MOM_initialization, step_offline -use MOM, only: get_MOM_state_elements, MOM_state_is_synchronized -use MOM_forcing_type, only: forcing, forcing_diags, register_forcing_type_diags -use MOM_forcing_type, only: allocate_forcing_type, deallocate_forcing_type -use MOM_forcing_type, only: mech_forcing_diags, forcing_accumulate, forcing_diagnostics -use MOM_forcing_type, only: mech_forcing, allocate_mech_forcing, copy_back_forcing_fields -use MOM_forcing_type, only: set_net_mass_forcing, set_derived_forcing_fields -use MOM_forcing_type, only: copy_common_forcing_fields +use MOM, only: extract_surface_state +use MOM_variables, only: surface +use MOM_domains, only: MOM_infra_init use MOM_restart, only: save_restart +use MOM_ice_shelf, only: ice_shelf_save_restart use MOM_domains, only: num_pes, root_pe, pe_here -use MOM_domains, only: pass_vector, BGRID_NE, CGRID_NE, To_All -use MOM_domains, only: pass_var, AGRID, fill_symmetric_edges use MOM_grid, only: ocean_grid_type, get_global_grid_size -use MOM_verticalGrid, only: verticalGrid_type -use MOM_variables, only: surface use MOM_error_handler, only: MOM_error, FATAL, is_root_pe, WARNING -use MOM_error_handler, only: callTree_enter, callTree_leave -use MOM_time_manager, only: time_type, set_date, set_time, set_calendar_type, NOLEAP, get_date +use MOM_time_manager, only: time_type, set_date, set_time, set_calendar_type, NOLEAP use MOM_time_manager, only: operator(+), operator(-), operator(*), operator(/) use MOM_time_manager, only: operator(==), operator(/=), operator(>), get_time -use MOM_file_parser, only: get_param, log_version, param_file_type, close_param_file +use MOM_file_parser, only: get_param, log_version, param_file_type use MOM_get_input, only: Get_MOM_Input, directories -use MOM_diag_mediator, only: diag_ctrl, enable_averaging, disable_averaging -use MOM_diag_mediator, only: diag_mediator_close_registration, diag_mediator_end -use MOM_diag_mediator, only: safe_alloc_ptr -use MOM_ice_shelf, only: initialize_ice_shelf, shelf_calc_flux, ice_shelf_CS -use MOM_ice_shelf, only: ice_shelf_end, ice_shelf_save_restart -use MOM_string_functions, only: uppercase -use MOM_constants, only: CELSIUS_KELVIN_OFFSET, hlf, hlv use MOM_EOS, only: gsw_sp_from_sr, gsw_pt_from_ct -use user_revise_forcing, only : user_alter_forcing, user_revise_forcing_init -use user_revise_forcing, only : user_revise_forcing_CS -use MOM_restart, only : restart_init, MOM_restart_CS -use MOM_restart, only : restart_init_end, save_restart, restore_state -use data_override_mod, only : data_override_init, data_override -use MOM_io, only : slasher, write_version_number -use MOM_spatial_means, only : adjust_area_mean_to_zero +use MOM_constants, only: CELSIUS_KELVIN_OFFSET +use MOM_domains, only: AGRID, BGRID_NE, CGRID_NE, pass_vector +use mpp_domains_mod, only: mpp_get_compute_domain + +! Previously inlined - now in separate modules +use MOM_ocean_model, only: ocean_public_type, ocean_state_type +use MOM_ocean_model, only: ocean_model_init , update_ocean_model, ocean_model_end +use MOM_ocean_model, only: convert_state_to_ocean_type +use MOM_surface_forcing, only: surface_forcing_CS, forcing_save_restart +use ocn_cap_methods, only: ocn_import, ocn_export ! FMS modules -use mpp_domains_mod, only : domain2d, mpp_get_layout, mpp_get_global_domain -use mpp_domains_mod, only : mpp_define_domains, mpp_get_compute_domain -use time_interp_external_mod, only : init_external_field, time_interp_external -use time_interp_external_mod, only : time_interp_external_init -use fms_mod, only : read_data +use time_interp_external_mod, only : time_interp_external + +! MCT indices structure and import and export routines that access mom data +use ocn_cpl_indices, only : cpl_indices_type, cpl_indices_init ! GFDL coupler modules -use coupler_types_mod, only : coupler_1d_bc_type, coupler_2d_bc_type use coupler_types_mod, only : coupler_type_spawn use coupler_types_mod, only : coupler_type_initialized, coupler_type_copy_data @@ -94,283 +71,36 @@ module ocn_comp_mct public :: ocn_init_mct public :: ocn_run_mct public :: ocn_final_mct + +! Private member functions +private :: ocn_SetGSMap_mct +private :: ocn_domain_mct +private :: get_runtype +private :: ocean_model_init_sfc + ! Flag for debugging logical, parameter :: debug=.true. -!> Structure with MCT attribute vectors and indices -type cpl_indices - - ! ocean to coupler - integer :: o2x_So_t !< Surface potential temperature (deg C) - integer :: o2x_So_u !< Surface zonal velocity (m/s) - integer :: o2x_So_v !< Surface meridional velocity (m/s) - integer :: o2x_So_s !< Surface salinity (PSU) - integer :: o2x_So_dhdx !< Zonal slope in the sea surface height - integer :: o2x_So_dhdy !< Meridional lope in the sea surface height - integer :: o2x_So_bldepth !< Boundary layer depth (m) - integer :: o2x_Fioo_q !< Heat flux? - integer :: o2x_Faoo_fco2_ocn!< CO2 flux - integer :: o2x_Faoo_fdms_ocn!< DMS flux - - ! coupler to ocean - integer :: x2o_Si_ifrac !< Fractional ice wrt ocean - integer :: x2o_So_duu10n !< 10m wind speed squared (m^2/s^2) - integer :: x2o_Sa_pslv !< Sea-level pressure (Pa) - integer :: x2o_Sa_co2prog !< Bottom atm level prognostic CO2 - integer :: x2o_Sa_co2diag !< Bottom atm level diagnostic CO2 - integer :: x2o_Sw_lamult !< Wave model langmuir multiplier - integer :: x2o_Sw_ustokes !< Surface Stokes drift, x-component - integer :: x2o_Sw_vstokes !< Surface Stokes drift, y-component - integer :: x2o_Foxx_taux !< Zonal wind stress (W/m2) - integer :: x2o_Foxx_tauy !< Meridonal wind stress (W/m2) - integer :: x2o_Foxx_swnet !< Net short-wave heat flux (W/m2) - integer :: x2o_Foxx_sen !< Sensible heat flux (W/m2) - integer :: x2o_Foxx_lat !< Latent heat flux (W/m2) - integer :: x2o_Foxx_lwup !< Longwave radiation, up (W/m2) - integer :: x2o_Faxa_lwdn !< Longwave radiation, down (W/m2) - integer :: x2o_Fioi_melth !< Heat flux from snow & ice melt (W/m2) - integer :: x2o_Fioi_meltw !< Snow melt flux (kg/m2/s) - integer :: x2o_Fioi_bcpho !< Black Carbon hydrophobic release - !! from sea ice component - integer :: x2o_Fioi_bcphi !< Black Carbon hydrophilic release from - !! sea ice component - integer :: x2o_Fioi_flxdst !< Dust release from sea ice component - integer :: x2o_Fioi_salt !< Salt flux (kg(salt)/m2/s) - integer :: x2o_Foxx_evap !< Evaporation flux (kg/m2/s) - integer :: x2o_Faxa_prec !< Total precipitation flux (kg/m2/s) - integer :: x2o_Faxa_snow !< Water flux due to snow (kg/m2/s) - integer :: x2o_Faxa_rain !< Water flux due to rain (kg/m2/s) - integer :: x2o_Faxa_bcphidry !< Black Carbon hydrophilic dry deposition - integer :: x2o_Faxa_bcphodry !< Black Carbon hydrophobic dry deposition - integer :: x2o_Faxa_bcphiwet !< Black Carbon hydrophilic wet deposition - integer :: x2o_Faxa_ocphidry !< Organic Carbon hydrophilic dry deposition - integer :: x2o_Faxa_ocphodry !< Organic Carbon hydrophobic dry deposition - integer :: x2o_Faxa_ocphiwet !< Organic Carbon hydrophilic dry deposition - integer :: x2o_Faxa_dstwet1 !< Size 1 dust -- wet deposition - integer :: x2o_Faxa_dstwet2 !< Size 2 dust -- wet deposition - integer :: x2o_Faxa_dstwet3 !< Size 3 dust -- wet deposition - integer :: x2o_Faxa_dstwet4 !< Size 4 dust -- wet deposition - integer :: x2o_Faxa_dstdry1 !< Size 1 dust -- dry deposition - integer :: x2o_Faxa_dstdry2 !< Size 2 dust -- dry deposition - integer :: x2o_Faxa_dstdry3 !< Size 3 dust -- dry deposition - integer :: x2o_Faxa_dstdry4 !< Size 4 dust -- dry deposition - integer :: x2o_Foxx_rofl !< River runoff flux (kg/m2/s) - integer :: x2o_Foxx_rofi !< Ice runoff flux (kg/m2/s) - - ! optional per thickness category fields - integer, dimension(:), allocatable :: x2o_frac_col !< Fraction of ocean cell, - !! per column - integer, dimension(:), allocatable :: x2o_fracr_col!< Fraction of ocean cell used - !! in radiation computations, - !! per column - integer, dimension(:), allocatable :: x2o_qsw_fracr_col !< qsw * fracr, per column -end type cpl_indices - -!> This type is used for communication with other components via the FMS coupler. -! The element names and types can be changed only with great deliberation, hence -! the persistnce of things like the cutsy element name "avg_kount". -type, public :: ocean_public_type - type(domain2d) :: Domain !< The domain for the surface fields. - logical :: is_ocean_pe !! .true. on processors that run the ocean model. - character(len=32) :: instance_name = '' !< A name that can be used to identify - !! this instance of an ocean model, for example - !! in ensembles when writing messages. - integer, pointer, dimension(:) :: pelist => NULL() !< The list of ocean PEs. - logical, pointer, dimension(:,:) :: maskmap =>NULL() !< A pointer to an array - !! indicating which logical processors are actually - !! used for the ocean code. The other logical - !! processors would be all land points and are not - !! assigned to actual processors. This need not be - !! assigned if all logical processors are used. - - integer :: stagger = -999 !< The staggering relative to the tracer points - !! of the two velocity components. Valid entries - !! include AGRID, BGRID_NE, CGRID_NE, BGRID_SW, and CGRID_SW, - !! corresponding to the community-standard Arakawa notation. - !! (These are named integers taken from mpp_parameter_mod.) - !! Following MOM, this is BGRID_NE by default when the ocean - !! is initialized, but here it is set to -999 so that a - !! global max across ocean and non-ocean processors can be - !! used to determine its value. - real, pointer, dimension(:,:) :: & - t_surf => NULL(), & !< SST on t-cell (degrees Kelvin) - s_surf => NULL(), & !< SSS on t-cell (psu) - u_surf => NULL(), & !< i-velocity at the locations indicated by stagger, m/s. - v_surf => NULL(), & !< j-velocity at the locations indicated by stagger, m/s. - sea_lev => NULL(), & !< Sea level in m after correction for surface pressure, - !! i.e. dzt(1) + eta_t + patm/rho0/grav (m) - frazil =>NULL(), & !< Accumulated heating (in Joules/m^2) from frazil - !! formation in the ocean. - area => NULL() !< cell area of the ocean surface, in m2. - type(coupler_2d_bc_type) :: fields !< A structure that may contain an - !! array of named tracer-related fields. - integer :: avg_kount !< Used for accumulating averages of this type. - integer, dimension(2) :: axes = 0 !< Axis numbers that are available - ! for I/O using this surface data. -end type ocean_public_type - -!> Contains pointers to the forcing fields which may be used to drive MOM. -!! All fluxes are positive downward. -type, public :: surface_forcing_CS ; private - integer :: wind_stagger !< AGRID, BGRID_NE, or CGRID_NE (integer values - !! from MOM_domains) to indicate the staggering of - !! the winds that are being provided in calls to - !! update_ocean_model. CIME uses AGRID, so this option - !! is being hard coded for now. - logical :: use_temperature !< If true, temp and saln used as state variables - real :: wind_stress_multiplier!< A multiplier applied to incoming wind stress (nondim). - ! smg: remove when have A=B code reconciled - logical :: bulkmixedlayer !< If true, model based on bulk mixed layer code - real :: Rho0 !< Boussinesq reference density (kg/m^3) - real :: area_surf = -1.0 !< total ocean surface area (m^2) - real :: latent_heat_fusion !< latent heat of fusion (J/kg) - real :: latent_heat_vapor !< latent heat of vaporization (J/kg) - real :: max_p_surf !< maximum surface pressure that can be - !! exerted by the atmosphere and floating sea-ice, - !! in Pa. 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. - logical :: use_limited_P_SSH !< 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. The default is true. - real :: gust_const !< constant unresolved background gustiness for ustar (Pa) - logical :: read_gust_2d !< If true, use a 2-dimensional gustiness supplied - !! from an input file. - real, pointer, dimension(:,:) :: & - TKE_tidal => NULL(), & !< turbulent kinetic energy introduced to the - !! bottom boundary layer by drag on the tidal flows, - !! in W m-2. - gust => NULL(), & !< spatially varying unresolved background - !! gustiness that contributes to ustar (Pa). - !! gust is used when read_gust_2d is true. - ustar_tidal => NULL() !< tidal contribution to the bottom friction velocity (m/s) - real :: cd_tides !< drag coefficient that applies to the tides (nondimensional) - real :: utide !< constant tidal velocity to use if read_tideamp - !! is false, in m s-1. - logical :: read_tideamp !< If true, spatially varying tidal amplitude read from a file. - logical :: rigid_sea_ice !< If true, sea-ice exerts a rigidity that acts - !! to damp surface deflections (especially surface - !! gravity waves). The default is false. - real :: Kv_sea_ice !< viscosity in sea-ice that resists sheared vertical motions (m^2/s) - real :: density_sea_ice !< typical density of sea-ice (kg/m^3). The value is - !! only used to convert the ice pressure into - !! appropriate units for use with Kv_sea_ice. - real :: rigid_sea_ice_mass !< A mass per unit area of sea-ice beyond which - !! sea-ice viscosity becomes effective, in kg m-2, - !! typically of order 1000 kg m-2. - logical :: allow_flux_adjustments !< If true, use data_override to obtain flux adjustments - real :: Flux_const !< piston velocity for surface restoring (m/s) - logical :: salt_restore_as_sflux !< If true, SSS restore as salt flux instead of water flux - logical :: adjust_net_srestore_to_zero !< adjust srestore to zero (for both salt_flux or vprec) - logical :: adjust_net_srestore_by_scaling !< adjust srestore w/o moving zero contour - logical :: adjust_net_fresh_water_to_zero !< adjust net surface fresh-water (w/ restoring) to zero - logical :: adjust_net_fresh_water_by_scaling !< adjust net surface fresh-water w/o moving zero contour - logical :: mask_srestore_under_ice !< If true, use an ice mask defined by frazil - !! criteria for salinity restoring. - real :: ice_salt_concentration !< salt concentration for sea ice (kg/kg) - logical :: mask_srestore_marginal_seas !< if true, then mask SSS restoring in marginal seas - real :: max_delta_srestore !< maximum delta salinity used for restoring - real :: max_delta_trestore !< maximum delta sst used for restoring - real, pointer, dimension(:,:) :: basin_mask => NULL() !< mask for SSS restoring - type(diag_ctrl), pointer :: diag !< structure to regulate diagnostic output timing - character(len=200) :: inputdir !< directory where NetCDF input files are - character(len=200) :: salt_restore_file !< filename for salt restoring data - character(len=30) :: salt_restore_var_name !< name of surface salinity in salt_restore_file - character(len=200) :: temp_restore_file !< filename for sst restoring data - character(len=30) :: temp_restore_var_name !< name of surface temperature in temp_restore_file - integer :: id_srestore = -1 !< id number for time_interp_external. - integer :: id_trestore = -1 !< id number for time_interp_external. - type(forcing_diags), public :: handles !< diagnostics handles - !### type(ctrl_forcing_CS), pointer :: ctrl_forcing_CSp => NULL() - type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< restart pointer - type(user_revise_forcing_CS), pointer :: urf_CS => NULL()!< user revise pointer -end type surface_forcing_CS - -!> Contains information about the ocean state, although it is not necessary that -!! this is implemented with all models. This type is private, and can therefore vary -!! between different ocean models. -type, public :: ocean_state_type ; private - logical :: is_ocean_PE = .false. !< True if this is an ocean PE. - type(time_type) :: Time !< The ocean model's time and master clock. - integer :: Restart_control !< An integer that is bit-tested to determine whether - !! incremental restart files are saved and whether they - !! have a time stamped name. +1 (bit 0) for generic - !! files and +2 (bit 1) for time-stamped files. A - !! restart file is saved at the end of a run segment - !! unless Restart_control is negative. - integer :: nstep = 0 !< The number of calls to update_ocean. - logical :: use_ice_shelf !< If true, the ice shelf model is enabled. - logical :: icebergs_apply_rigid_boundary !< If true, the icebergs can change ocean bd condition. - real :: kv_iceberg !< The viscosity of the icebergs in m2/s (for ice rigidity) - real :: berg_area_threshold !< Fraction of grid cell which iceberg must occupy - !! so that fluxes below are set to zero. (0.5 is a - !! good value to use. Not applied for negative values. - real :: latent_heat_fusion !< Latent heat of fusion - real :: density_iceberg !< A typical density of icebergs in kg/m3 (for ice rigidity) - type(ice_shelf_CS), pointer :: Ice_shelf_CSp => NULL() !< ice shelf structure. - logical :: restore_salinity !< If true, the coupled MOM driver adds a term to - !! restore salinity to a specified value. - logical :: restore_temp !< If true, the coupled MOM driver adds a term to - !! restore sst to a specified value. - real :: press_to_z !< A conversion factor between pressure and ocean - !! depth in m, usually 1/(rho_0*g), in m Pa-1. - real :: C_p !< The heat capacity of seawater, in J K-1 kg-1. - logical :: offline_tracer_mode = .false. !< If false, use the model in prognostic mode - !! with the barotropic and baroclinic dynamics, thermodynamics, - !! etc. stepped forward integrated in time. - !! If true, all of the above are bypassed with all - !! fields necessary to integrate only the tracer advection - !! and diffusion equation read in from files stored from - !! a previous integration of the prognostic model. - type(directories) :: dirs !< A structure containing several relevant directory paths. - type(mech_forcing) :: forces!< A structure with the driving mechanical surface forces - type(forcing) :: fluxes !< A structure containing pointers to - !! the ocean forcing fields. - type(forcing) :: flux_tmp !< A secondary structure containing pointers to the - !! ocean forcing fields for when multiple coupled - !! timesteps are taken per thermodynamic step. - type(surface) :: sfc_state !< A structure containing pointers to - !! the ocean surface state fields. - type(ocean_grid_type), pointer :: grid => NULL() !< A pointer to a grid structure - !! containing metrics and related information. - type(verticalGrid_type), pointer :: GV => NULL() !< A pointer to a vertical grid - !! structure containing metrics and related information. - type(MOM_control_struct), pointer :: MOM_CSp => NULL() - type(surface_forcing_CS), pointer :: forcing_CSp => NULL() - type(MOM_restart_CS), pointer :: & - restart_CSp => NULL() !< A pointer set to the restart control structure - !! that will be used for MOM restart files. - type(diag_ctrl), pointer :: & - diag => NULL() !< A pointer to the diagnostic regulatory structure -end type ocean_state_type - !> Control structure for this module type MCT_MOM_Data - - type(ocean_state_type), pointer :: ocn_state => NULL() !< The private state of ocean - type(ocean_public_type), pointer :: ocn_public => NULL() !< The public state of ocean - type(ocean_grid_type), pointer :: grid => NULL() !< The grid structure - type(surface), pointer :: ocn_surface => NULL() !< The ocean surface state - type(forcing) :: fluxes !< Structure that contains pointers to the - !! boundary forcing used to drive the liquid - !! ocean simulated by MOM. - type(seq_infodata_type), pointer :: infodata !< The input info type - type(cpl_indices), public :: ind !< Variable IDs - ! runtime params - logical :: sw_decomp !< Controls whether shortwave is decomposed into four components - real :: c1, c2, c3, c4 !< Coeffs. used in the shortwave decomposition - ! i/o - character(len=384) :: pointer_filename !< Name of the ascii file that contains the path - !! and filename of the latest restart file. - integer :: stdout !< standard output unit. (by default, it should point to ocn.log.* file) + type(ocean_state_type), pointer :: ocn_state => NULL() !< The private state of ocean + type(ocean_public_type), pointer :: ocn_public => NULL() !< The public state of ocean + type(ocean_grid_type), pointer :: grid => NULL() !< The grid structure + type(seq_infodata_type), pointer :: infodata !< The input info type + type(cpl_indices_type) :: ind !< Variable IDs + logical :: sw_decomp !< Controls whether shortwave is decomposed into 4 components + real :: c1, c2, c3, c4 !< Coeffs. used in the shortwave decomposition i/o + integer :: stdout !< standard output unit. (by default, points to ocn.log.* ) + character(len=384) :: pointer_filename !< Name of the ascii file that contains the path + !! and filename of the latest restart file. end type MCT_MOM_Data -type(MCT_MOM_Data) :: glb !< global structure -integer :: id_clock_forcing +type(MCT_MOM_Data) :: glb !< global structure +type(ice_ocean_boundary_type) :: ice_ocean_boundary +!======================================================================= contains +!======================================================================= !> This subroutine initializes MOM6. subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) @@ -382,24 +112,24 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) character(len=*), optional , intent(in) :: NLFilename !< Namelist filename ! local variables - type(time_type) :: time0 !< Model start time - type(ESMF_time) :: time_var !< ESMF_time variable to query time - type(ESMF_time) :: time_in_ESMF !< Initial time for ocean - type(ESMF_timeInterval) :: ocn_cpl_interval !< Ocean coupling interval - integer :: ncouple_per_day - integer :: year, month, day, hour, minute, seconds, seconds_n, seconds_d, rc - character(len=240) :: runid !< Run ID - character(len=32) :: runtype !< Run type - character(len=240) :: restartfile !< Path/Name of restart file - integer :: nu !< i/o unit to read pointer file - character(len=240) :: restart_pointer_file !< File name for restart pointer file - character(len=240) :: restartpath !< Path of the restart file - integer :: mpicom_ocn !< MPI ocn communicator - integer :: npes, pe0 !< # of processors and current processor - integer :: i, errorCode - integer :: lsize, nsend, nrecv - logical :: ldiag_cpl = .false. - integer :: isc, iec, jsc, jec, ni, nj !< Indices for the start and end of the domain + type(time_type) :: time0 !< Model start time + type(ESMF_time) :: time_var !< ESMF_time variable to query time + type(ESMF_time) :: time_in_ESMF !< Initial time for ocean + type(ESMF_timeInterval) :: ocn_cpl_interval !< Ocean coupling interval + integer :: ncouple_per_day + integer :: year, month, day, hour, minute, seconds, seconds_n, seconds_d, rc + character(len=240) :: runid !< Run ID + character(len=32) :: runtype !< Run type + character(len=240) :: restartfile !< Path/Name of restart file + integer :: nu !< i/o unit to read pointer file + character(len=240) :: restart_pointer_file !< File name for restart pointer file + character(len=240) :: restartpath !< Path of the restart file + integer :: mpicom_ocn !< MPI ocn communicator + integer :: npes, pe0 !< # of processors and current processor + integer :: i, errorCode + integer :: lsize, nsend, nrecv + logical :: ldiag_cpl = .false. + integer :: isc, iec, jsc, jec, ni, nj !< Indices for the start and end of the domain !! in the x and y dir., respectively. ! runtime params type(param_file_type) :: param_file !< A structure to parse for run-time parameters @@ -441,7 +171,7 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) gsMap=MOM_MCT_gsMap, dom=MOM_MCT_dom, infodata=glb%infodata) ! Determine attribute vector indices - call coupler_indices_init(glb%ind) + call cpl_indices_init(glb%ind) call seq_infodata_GetData( glb%infodata, case_name=runid ) @@ -482,15 +212,19 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) ! Debugging clocks if (debug .and. is_root_pe()) then write(glb%stdout,*) 'ocn_init_mct, current time: y,m,d-',year,month,day,'h,m,s=',hour,minute,seconds + call ESMF_ClockGet(EClock, StartTime=time_var, rc=rc) call ESMF_TimeGet(time_var, yy=year, mm=month, dd=day, h=hour, m=minute, s=seconds, rc=rc) write(glb%stdout,*) 'ocn_init_mct, start time: y,m,d-',year,month,day,'h,m,s=',hour,minute,seconds + call ESMF_ClockGet(EClock, StopTime=time_var, rc=rc) call ESMF_TimeGet(time_var, yy=year, mm=month, dd=day, h=hour, m=minute, s=seconds, rc=rc) write(glb%stdout,*) 'ocn_init_mct, stop time: y,m,d-',year,month,day,'h,m,s=',hour,minute,seconds + call ESMF_ClockGet(EClock, PrevTime=time_var, rc=rc) call ESMF_TimeGet(time_var, yy=year, mm=month, dd=day, h=hour, m=minute, s=seconds, rc=rc) write(glb%stdout,*) 'ocn_init_mct, previous time: y,m,d-',year,month,day,'h,m,s=',hour,minute,seconds + call ESMF_ClockGet(EClock, TimeStep=ocn_cpl_interval, rc=rc) call ESMF_TimeIntervalGet(ocn_cpl_interval, yy=year, mm=month, d=day, s=seconds, sn=seconds_n, sd=seconds_d, rc=rc) write(glb%stdout,*) 'ocn_init_mct, time step: y,m,d-',year,month,day,'s,sn,sd=',seconds,seconds_n,seconds_d @@ -501,6 +235,7 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) allocate(glb%ocn_public) glb%ocn_public%is_ocean_PE = .true. + allocate(glb%ocn_public%pelist(npes)) glb%ocn_public%pelist(:) = (/(i,i=pe0,pe0+npes)/) ! \todo Set other bits of glb$ocn_public @@ -509,9 +244,11 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) ! read useful runtime params call get_MOM_Input(param_file, dirs_tmp, check_params=.false.) !call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "POINTER_FILENAME", glb%pointer_filename, & "Name of the ascii file that contains the path and filename of" // & " the latest restart file.", default='rpointer.ocn') + call get_param(param_file, mdl, "SW_DECOMP", glb%sw_decomp, & "If True, read coeffs c1, c2, c3 and c4 and decompose" // & "the net shortwave radiation (SW) into four components:\n" // & @@ -519,16 +256,20 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) "visible, diffuse shortwave = c2 * SW \n" // & "near-IR, direct shortwave = c3 * SW \n" // & "near-IR, diffuse shortwave = c4 * SW", default=.true.) + if (glb%sw_decomp) then call get_param(param_file, mdl, "SW_c1", glb%c1, & "Coeff. used to convert net shortwave rad. into \n"//& "visible, direct shortwave.", units="nondim", default=0.285) + call get_param(param_file, mdl, "SW_c2", glb%c2, & "Coeff. used to convert net shortwave rad. into \n"//& "visible, diffuse shortwave.", units="nondim", default=0.285) + call get_param(param_file, mdl, "SW_c3", glb%c3, & "Coeff. used to convert net shortwave rad. into \n"//& "near-IR, direct shortwave.", units="nondim", default=0.215) + call get_param(param_file, mdl, "SW_c4", glb%c4, & "Coeff. used to convert net shortwave rad. into \n"//& "near-IR, diffuse shortwave.", units="nondim", default=0.215) @@ -538,11 +279,11 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) ! Initialize the MOM6 model runtype = get_runtype() - if (runtype == "initial") then ! startup (new run) - 'n' is needed below since we don't - ! specify input_filename in input.nml + if (runtype == "initial") then + ! startup (new run) - 'n' is needed below since we don't specify input_filename in input.nml call ocean_model_init(glb%ocn_public, glb%ocn_state, time0, time0, input_restart_file = 'n') - else ! hybrid or branch or continuos runs - ! output path root + else ! hybrid or branch or continuos runs + ! get output path root call seq_infodata_GetData( glb%infodata, outPathRoot=restartpath ) ! read name of restart file in the pointer file nu = shr_file_getUnit() @@ -552,17 +293,25 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) read(nu,'(a)') restartfile close(nu) !restartfile = trim(restartpath) // trim(restartfile) - if (is_root_pe()) write(glb%stdout,*) 'Reading restart file: ',trim(restartfile) - !endif + if (is_root_pe()) then + write(glb%stdout,*) 'Reading restart file: ',trim(restartfile) + end if call shr_file_freeUnit(nu) call ocean_model_init(glb%ocn_public, glb%ocn_state, time0, time0, input_restart_file=trim(restartfile)) endif + if (is_root_pe()) then + write(glb%stdout,'(/12x,a/)') '======== COMPLETED MOM INITIALIZATION ========' + end if ! Initialize ocn_state%sfc_state out of sight call ocean_model_init_sfc(glb%ocn_state, glb%ocn_public) - ! store pointers to components inside MOM - call get_state_pointers(glb%ocn_state, grid=glb%grid) + ! Store pointers to components inside MOM + glb%grid => glb%ocn_state%grid + + ! Allocate IOB data type (needs to be called after glb%grid is set) + !write(6,*)'DEBUG: isc,iec,jsc,jec= ',glb%grid%isc, glb%grid%iec, glb%grid%jsc, glb%grid%jec + call IOB_allocate(ice_ocean_boundary, glb%grid%isc, glb%grid%iec, glb%grid%jsc, glb%grid%jec) call t_stopf('MOM_init') @@ -612,8 +361,8 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) ncouple_per_day = seconds_in_day / ocn_cpl_dt mom_cpl_dt = seconds_in_day / ncouple_per_day if (mom_cpl_dt /= ocn_cpl_dt) then - write(glb%stdout,*) 'ERROR mom_cpl_dt and ocn_cpl_dt must be identical' - call exit(0) + write(glb%stdout,*) 'ERROR mom_cpl_dt and ocn_cpl_dt must be identical' + call exit(0) end if ! send initial state to driver @@ -623,23 +372,20 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) ! call seq_infodata_PutData( infodata, precip_fact=precip_fact) ! end if - if (debug .and. root_pe().eq.pe_here()) print *, "calling ocn_export" - call ocn_export(glb%ind, glb%ocn_public, glb%grid, o2x_o%rattr) + call ocn_export(glb%ind, glb%ocn_public, glb%grid, o2x_o%rattr, mom_cpl_dt, ncouple_per_day) call t_stopf('MOM_mct_init') - if (debug .and. root_pe().eq.pe_here()) print *, "calling get_state_pointers" - ! Size of global domain call get_global_grid_size(glb%grid, ni, nj) if (debug .and. root_pe().eq.pe_here()) print *, "calling seq_infodata_putdata" - call seq_infodata_PutData( glb%infodata, & - ocn_nx = ni , ocn_ny = nj) - call seq_infodata_PutData( glb%infodata, & - ocn_prognostic=.true., ocnrof_prognostic=.true.) + call seq_infodata_PutData( glb%infodata, & + ocn_nx = ni , ocn_ny = nj) + call seq_infodata_PutData( glb%infodata, & + ocn_prognostic=.true., ocnrof_prognostic=.true.) if (debug .and. root_pe().eq.pe_here()) print *, "leaving ocean_init_mct" @@ -651,849 +397,7 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) end subroutine ocn_init_mct -!> Determines attribute vector indices -subroutine coupler_indices_init(ind) - - type(cpl_indices), intent(inout) :: ind !< Structure with coupler indices - !! and vectors - - ! Local Variables - type(mct_aVect) :: o2x !< Array with ocean to coupler data - type(mct_aVect) :: x2o !< Array with coupler to ocean data - - integer :: ncat !< Thickness category index - character(len=2) :: cncat !< Character version of ncat - integer :: ncol !< Column index - integer :: mcog_ncols !< Number of ice thickness categories? - integer :: lmcog_flds_sent !< Used to convert per thickness - !! category fields? - - ! create temporary attribute vectors - call mct_aVect_init(x2o, rList=seq_flds_x2o_fields, lsize=1) - call mct_aVect_init(o2x, rList=seq_flds_o2x_fields, lsize=1) - - ! ocean to coupler - ind%o2x_So_t = mct_avect_indexra(o2x,'So_t') - ind%o2x_So_u = mct_avect_indexra(o2x,'So_u') - ind%o2x_So_v = mct_avect_indexra(o2x,'So_v') - ind%o2x_So_s = mct_avect_indexra(o2x,'So_s') - ind%o2x_So_dhdx = mct_avect_indexra(o2x,'So_dhdx') - ind%o2x_So_dhdy = mct_avect_indexra(o2x,'So_dhdy') - ! QL, 150526, to wav, boundary layer depth - ind%o2x_So_bldepth = mct_avect_indexra(o2x,'So_bldepth') - ind%o2x_Fioo_q = mct_avect_indexra(o2x,'Fioo_q') - ind%o2x_Faoo_fco2_ocn = mct_avect_indexra(o2x,'Faoo_fco2_ocn',perrWith='quiet') - ind%o2x_Faoo_fdms_ocn = mct_avect_indexra(o2x,'Faoo_fdms_ocn',perrWith='quiet') - - ! coupler to ocean - ind%x2o_Si_ifrac = mct_avect_indexra(x2o,'Si_ifrac') - ind%x2o_Sa_pslv = mct_avect_indexra(x2o,'Sa_pslv') - ind%x2o_So_duu10n = mct_avect_indexra(x2o,'So_duu10n') - ! QL, 150526, from wav - ind%x2o_Sw_lamult = mct_avect_indexra(x2o,'Sw_lamult') - ind%x2o_Sw_ustokes = mct_avect_indexra(x2o,'Sw_ustokes') - ind%x2o_Sw_vstokes = mct_avect_indexra(x2o,'Sw_vstokes') - ind%x2o_Foxx_tauy = mct_avect_indexra(x2o,'Foxx_tauy') - ind%x2o_Foxx_taux = mct_avect_indexra(x2o,'Foxx_taux') - ind%x2o_Foxx_swnet = mct_avect_indexra(x2o,'Foxx_swnet') - ind%x2o_Foxx_lat = mct_avect_indexra(x2o,'Foxx_lat') - ind%x2o_Foxx_sen = mct_avect_indexra(x2o,'Foxx_sen') - ind%x2o_Foxx_lwup = mct_avect_indexra(x2o,'Foxx_lwup') - ind%x2o_Faxa_lwdn = mct_avect_indexra(x2o,'Faxa_lwdn') - ind%x2o_Fioi_melth = mct_avect_indexra(x2o,'Fioi_melth') - ind%x2o_Fioi_meltw = mct_avect_indexra(x2o,'Fioi_meltw') - ind%x2o_Fioi_salt = mct_avect_indexra(x2o,'Fioi_salt') - ind%x2o_Fioi_bcpho = mct_avect_indexra(x2o,'Fioi_bcpho') - ind%x2o_Fioi_bcphi = mct_avect_indexra(x2o,'Fioi_bcphi') - ind%x2o_Fioi_flxdst = mct_avect_indexra(x2o,'Fioi_flxdst') - ind%x2o_Faxa_prec = mct_avect_indexra(x2o,'Faxa_prec') - ind%x2o_Faxa_snow = mct_avect_indexra(x2o,'Faxa_snow') - ind%x2o_Faxa_rain = mct_avect_indexra(x2o,'Faxa_rain') - ind%x2o_Foxx_evap = mct_avect_indexra(x2o,'Foxx_evap') - ind%x2o_Foxx_rofl = mct_avect_indexra(x2o,'Foxx_rofl') - ind%x2o_Foxx_rofi = mct_avect_indexra(x2o,'Foxx_rofi') - ind%x2o_Faxa_bcphidry = mct_avect_indexra(x2o,'Faxa_bcphidry') - ind%x2o_Faxa_bcphodry = mct_avect_indexra(x2o,'Faxa_bcphodry') - ind%x2o_Faxa_bcphiwet = mct_avect_indexra(x2o,'Faxa_bcphiwet') - ind%x2o_Faxa_ocphidry = mct_avect_indexra(x2o,'Faxa_ocphidry') - ind%x2o_Faxa_ocphodry = mct_avect_indexra(x2o,'Faxa_ocphodry') - ind%x2o_Faxa_ocphiwet = mct_avect_indexra(x2o,'Faxa_ocphiwet') - ind%x2o_Faxa_dstdry1 = mct_avect_indexra(x2o,'Faxa_dstdry1') - ind%x2o_Faxa_dstdry2 = mct_avect_indexra(x2o,'Faxa_dstdry2') - ind%x2o_Faxa_dstdry3 = mct_avect_indexra(x2o,'Faxa_dstdry3') - ind%x2o_Faxa_dstdry4 = mct_avect_indexra(x2o,'Faxa_dstdry4') - ind%x2o_Faxa_dstwet1 = mct_avect_indexra(x2o,'Faxa_dstwet1') - ind%x2o_Faxa_dstwet2 = mct_avect_indexra(x2o,'Faxa_dstwet2') - ind%x2o_Faxa_dstwet3 = mct_avect_indexra(x2o,'Faxa_dstwet3') - ind%x2o_Faxa_dstwet4 = mct_avect_indexra(x2o,'Faxa_dstwet4') - ind%x2o_Sa_co2prog = mct_avect_indexra(x2o,'Sa_co2prog',perrWith='quiet') - ind%x2o_Sa_co2diag = mct_avect_indexra(x2o,'Sa_co2diag',perrWith='quiet') - ! optional per thickness category fields - - ! convert cpl indices to mcog column indices - ! this implementation only handles columns due to ice thickness categories - lmcog_flds_sent = seq_flds_i2o_per_cat - - if (seq_flds_i2o_per_cat) then - mcog_ncols = ice_ncat+1 - allocate(ind%x2o_frac_col(mcog_ncols)) - allocate(ind%x2o_fracr_col(mcog_ncols)) - allocate(ind%x2o_qsw_fracr_col(mcog_ncols)) - ncol = 1 - ind%x2o_frac_col(ncol) = mct_avect_indexra(x2o,'Sf_afrac') - ind%x2o_fracr_col(ncol) = mct_avect_indexra(x2o,'Sf_afracr') - ind%x2o_qsw_fracr_col(ncol) = mct_avect_indexra(x2o,'Foxx_swnet_afracr') - - do ncat = 1, ice_ncat - write(cncat,'(i2.2)') ncat - ncol = ncat+1 - ind%x2o_frac_col(ncol) = mct_avect_indexra(x2o,'Si_ifrac_'//cncat) - ind%x2o_fracr_col(ncol) = ind%x2o_frac_col(ncol) - ind%x2o_qsw_fracr_col(ncol) = mct_avect_indexra(x2o,'PFioi_swpen_ifrac_'//cncat) - enddo - else - mcog_ncols = 1 - endif - - call mct_aVect_clean(x2o) - call mct_aVect_clean(o2x) - -end subroutine coupler_indices_init - -!> Initializes the ocean model, including registering fields -!! for restarts and reading restart files if appropriate. -subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, input_restart_file) - type(ocean_public_type), target, & - intent(inout) :: Ocean_sfc !< A structure containing various - !! publicly visible ocean surface properties after initialization, - !! the data in this type is intent(out). - type(ocean_state_type), pointer :: OS !< A structure whose internal - !! contents are private to ocean_model_mod that may be used to - !! contain all information about the ocean's interior state. - type(time_type), intent(in) :: Time_init !< The start time for the coupled model's calendar - type(time_type), intent(in) :: Time_in !< The time at which to initialize the ocean model. - type(coupler_1d_bc_type), & - optional, intent(in) :: gas_fields_ocn !< If present, this type describes the - !! ocean and surface-ice fields that will participate - !! in the calculation of additional gas or other - !! tracer fluxes, and can be used to spawn related - !! internal variables in the ice model. - character(len=*), optional, intent(in) :: input_restart_file !< If present, name of restart file to read - -! This subroutine initializes both the ocean state and the ocean surface type. -! Because of the way that indicies and domains are handled, Ocean_sfc must have -! been used in a previous call to initialize_ocean_type. - - real :: Rho0 !< The Boussinesq ocean density, in kg m-3. - real :: G_Earth !< The gravitational acceleration in m s-2. - !! This include declares and sets the variable "version". -#include "version_variable.h" - character(len=40) :: mdl = "ocean_model_init" !< This module's name. - character(len=48) :: stagger - logical :: use_temperature - integer :: secs, days - type(param_file_type) :: param_file !< A structure to parse for run-time parameters - - call callTree_enter("ocean_model_init(), ocn_comp_mct.F90") - if (associated(OS)) then - call MOM_error(WARNING, "ocean_model_init called with an associated "// & - "ocean_state_type structure. Model is already initialized.") - return - endif - allocate(OS) - - OS%is_ocean_pe = Ocean_sfc%is_ocean_pe - if (.not.OS%is_ocean_pe) return - - OS%Time = Time_in - call initialize_MOM(OS%Time, Time_init, param_file, OS%dirs, OS%MOM_CSp, & - OS%restart_CSp, Time_in, offline_tracer_mode=OS%offline_tracer_mode, & - input_restart_file=input_restart_file, diag_ptr=OS%diag, & - count_calls=.true.) - call get_MOM_state_elements(OS%MOM_CSp, G=OS%grid, GV=OS%GV, C_p=OS%fluxes%C_p, & - use_temp=use_temperature) - OS%C_p = OS%fluxes%C_p - - ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "") - 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"//& - "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', '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 - elseif (uppercase(stagger(1:1)) == 'C') then ; Ocean_sfc%stagger = CGRID_NE - else ; call MOM_error(FATAL,"ocean_model_init: OCEAN_SURFACE_STAGGER = "// & - trim(stagger)//" is invalid.") ; endif - - call get_param(param_file, mdl, "RESTORE_SALINITY",OS%restore_salinity, & - "If true, the coupled driver will add a globally-balanced \n"//& - "fresh-water flux that drives sea-surface salinity \n"//& - "toward specified values.", default=.false.) - call get_param(param_file, mdl, "RESTORE_TEMPERATURE",OS%restore_temp, & - "If true, the coupled driver will add a \n"//& - "heat flux that drives sea-surface temperauture \n"//& - "toward specified values.", default=.false.) - 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"//& - "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, & - "The gravitational acceleration of the Earth.", & - units="m s-2", default = 9.80) - - call get_param(param_file, mdl, "ICE_SHELF", OS%use_ice_shelf, & - "If true, enables the ice shelf model.", default=.false.) - - call get_param(param_file, mdl, "ICEBERGS_APPLY_RIGID_BOUNDARY", OS%icebergs_apply_rigid_boundary, & - "If true, allows icebergs to change boundary condition felt by ocean", default=.false.) - - if (OS%icebergs_apply_rigid_boundary) then - call get_param(param_file, mdl, "KV_ICEBERG", OS%kv_iceberg, & - "The viscosity of the icebergs", units="m2 s-1",default=1.0e10) - call get_param(param_file, mdl, "DENSITY_ICEBERGS", OS%density_iceberg, & - "A typical density of icebergs.", units="kg m-3", default=917.0) - call get_param(param_file, mdl, "LATENT_HEAT_FUSION", OS%latent_heat_fusion, & - "The latent heat of fusion.", units="J/kg", default=hlf) - call get_param(param_file, mdl, "BERG_AREA_THRESHOLD", OS%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"//& - " values.", units="non-dim", default=-1.0) - endif - - OS%press_to_z = 1.0/(Rho0*G_Earth) - - ! 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 allocate_surface_state(OS%sfc_state, OS%grid, use_temperature, & - do_integrals=.true., gas_fields_ocn=gas_fields_ocn) - - call surface_forcing_init(Time_in, OS%grid, param_file, OS%diag, & - OS%forcing_CSp, OS%restore_salinity, OS%restore_temp) - - if (OS%use_ice_shelf) then - call initialize_ice_shelf(param_file, OS%grid, OS%Time, OS%ice_shelf_CSp, & - OS%diag, OS%forces, OS%fluxes) - endif - if (OS%icebergs_apply_rigid_boundary) then - !call allocate_forcing_type(OS%grid, OS%fluxes, iceberg=.true.) - !This assumes that the iceshelf and ocean are on the same grid. I hope this is true - if (.not. OS%use_ice_shelf) call allocate_forcing_type(OS%grid, OS%fluxes, ustar=.true., shelf=.true.) - endif - - if (associated(OS%grid%Domain%maskmap)) then - call initialize_ocean_public_type(OS%grid%Domain%mpp_domain, Ocean_sfc, & - OS%diag, maskmap=OS%grid%Domain%maskmap, & - gas_fields_ocn=gas_fields_ocn) - else - call initialize_ocean_public_type(OS%grid%Domain%mpp_domain, Ocean_sfc, & - OS%diag, gas_fields_ocn=gas_fields_ocn) - endif - - ! This call can only occur here if the coupler_bc_type variables have been - ! initialized already using the information from gas_fields_ocn. - if (present(gas_fields_ocn)) then - call extract_surface_state(OS%MOM_CSp, OS%sfc_state) - - call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid) - endif - - call close_param_file(param_file) - call diag_mediator_close_registration(OS%diag) - - if (is_root_pe()) & - write(glb%stdout,'(/12x,a/)') '======== COMPLETED MOM INITIALIZATION ========' - - call callTree_leave("ocean_model_init(") -end subroutine ocean_model_init - -!> Extracts the surface properties from the ocean's internal -!! state and stores them in the ocean type returned to the calling ice model. -!! It has to be separate from the ocean_initialization call because the coupler -!! module allocates the space for some of these variables. -subroutine ocean_model_init_sfc(OS, Ocean_sfc) - type(ocean_state_type), pointer :: OS - type(ocean_public_type), intent(inout) :: Ocean_sfc - - integer :: is, ie, js, je - - is = OS%grid%isc ; ie = OS%grid%iec ; js = OS%grid%jsc ; je = OS%grid%jec - call coupler_type_spawn(Ocean_sfc%fields, OS%sfc_state%tr_fields, & - (/is,is,ie,ie/), (/js,js,je,je/), as_needed=.true.) - - call extract_surface_state(OS%MOM_CSp, OS%sfc_state) - - call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid) - -end subroutine ocean_model_init_sfc - -!> Initializes surface forcing: get relevant parameters and allocate arrays. -subroutine surface_forcing_init(Time, G, param_file, diag, CS, restore_salt, restore_temp) - type(time_type), intent(in) :: Time !< The current model time - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to regulate diagnostic output - type(surface_forcing_CS), pointer :: CS !< A pointer that is set to point to the - !! control structure for this module - logical, optional, intent(in) :: restore_salt, restore_temp !< If present and true, - !! temp/salt restoring will be applied - - ! local variables - real :: utide !< The RMS tidal velocity, in m s-1. - type(directories) :: dirs - logical :: new_sim, iceberg_flux_diags - type(time_type) :: Time_frc - character(len=200) :: TideAmp_file, gust_file, salt_file, temp_file ! Input file names. -! This include declares and sets the variable "version". -#include "version_variable.h" - character(len=40) :: mdl = "ocn_comp_mct" ! This module's name. - character(len=48) :: stagger - character(len=240) :: basin_file - integer :: i, j, isd, ied, jsd, jed - - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - - if (associated(CS)) then - call MOM_error(WARNING, "surface_forcing_init called with an associated "// & - "control structure.") - return - endif - allocate(CS) - - id_clock_forcing=cpu_clock_id('Ocean surface forcing', grain=CLOCK_SUBCOMPONENT) - call cpu_clock_begin(id_clock_forcing) - - CS%diag => diag - - call write_version_number (version) - ! 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, & - "The directory in which all input files are found.", & - 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"//& - "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"//& - "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, & - "The latent heat of fusion.", units="J/kg", default=hlf) - 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"//& - "limit is applied if a negative value is used.", units="Pa", & - default=-1.0) - 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"//& - "whether restoring is via a salt flux or virtual precip.",& - default=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"//& - "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"//& - "by the ocean (including restoring) to zero.", default=.false.) - 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"//& - "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"//& - "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"//& - "pressure.", default=.true.) - -! smg: should get_param call should be removed when have A=B code reconciled. -! this param is used to distinguish how to diagnose surface heat content from water. - call get_param(param_file, mdl, "BULKMIXEDLAYER", CS%bulkmixedlayer, & - default=CS%use_temperature,do_not_log=.true.) - - 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"//& - "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 - elseif (uppercase(stagger(1:1)) == 'C') then ; CS%wind_stagger = CGRID_NE - 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"//& - "production runs.", default=1.0) - - if (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"//& - "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, & - "A file in which to find the surface salinity to use for restoring.", & - default="salt_restore.nc") - call get_param(param_file, mdl, "SALT_RESTORE_VARIABLE", CS%salt_restore_var_name, & - "The name of the surface salinity variable to read from "//& - "SALT_RESTORE_FILE for restoring salinity.", & - default="salt") -! 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, "SRESTORE_AS_SFLUX", CS%salt_restore_as_sflux, & - "If true, the restoring of salinity is applied as a salt \n"//& - "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"//& - "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"//& - "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'.", & - default="basin.nc") - basin_file = trim(CS%inputdir) // trim(basin_file) - call safe_alloc_ptr(CS%basin_mask,isd,ied,jsd,jed) ; CS%basin_mask(:,:) = 1.0 - if (CS%mask_srestore_marginal_seas) then - call read_data(basin_file,'basin',CS%basin_mask,domain=G%domain%mpp_domain,timelevel=1) - do j=jsd,jed ; do i=isd,ied - if (CS%basin_mask(i,j) >= 6.0) then ; CS%basin_mask(i,j) = 0.0 - else ; CS%basin_mask(i,j) = 1.0 ; endif - enddo ; enddo - endif - endif - - if (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"//& - "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, & - "A file in which to find the surface temperature to use for restoring.", & - default="temp_restore.nc") - call get_param(param_file, mdl, "SST_RESTORE_VARIABLE", CS%temp_restore_var_name, & - "The name of the surface temperature variable to read from "//& - "SST_RESTORE_FILE for restoring sst.", & - default="temp") -! 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, "MAX_DELTA_TRESTORE", CS%max_delta_trestore, & - "The maximum sst difference used in restoring terms.", & - units="degC ", default=999.0) - - endif - -! Optionally read tidal amplitude from input file (m s-1) on model grid. -! Otherwise use default tidal amplitude for bottom frictionally-generated -! dissipation. Default cd_tides is chosen to yield approx 1 TWatt of -! work done against tides globally using OSU tidal amplitude. - call get_param(param_file, mdl, "CD_TIDES", CS%cd_tides, & - "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"//& - "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"//& - "tidal amplitudes with INT_TIDE_DISSIPATION.", & - default="tideamp.nc") - CS%utide=0.0 - else - 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) - endif - - call safe_alloc_ptr(CS%TKE_tidal,isd,ied,jsd,jed) - call safe_alloc_ptr(CS%ustar_tidal,isd,ied,jsd,jed) - - if (CS%read_TIDEAMP) then - TideAmp_file = trim(CS%inputdir) // trim(TideAmp_file) - call read_data(TideAmp_file,'tideamp',CS%TKE_tidal,domain=G%domain%mpp_domain,timelevel=1) - do j=jsd, jed; do i=isd, ied - utide = CS%TKE_tidal(i,j) - CS%TKE_tidal(i,j) = G%mask2dT(i,j)*CS%Rho0*CS%cd_tides*(utide*utide*utide) - CS%ustar_tidal(i,j)=sqrt(CS%cd_tides)*utide - enddo ; enddo - else - do j=jsd,jed; do i=isd,ied - utide=CS%utide - CS%TKE_tidal(i,j) = CS%Rho0*CS%cd_tides*(utide*utide*utide) - CS%ustar_tidal(i,j)=sqrt(CS%cd_tides)*utide - enddo ; enddo - endif - - call time_interp_external_init - -! Optionally read a x-y gustiness field in place of a global -! constant. - - call get_param(param_file, mdl, "READ_GUST_2D", CS%read_gust_2d, & - "If true, use a 2-dimensional gustiness supplied from \n"//& - "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"//& - "variable gustiness.") - - call safe_alloc_ptr(CS%gust,isd,ied,jsd,jed) - gust_file = trim(CS%inputdir) // trim(gust_file) - call read_data(gust_file,'gustiness',CS%gust,domain=G%domain%mpp_domain, & - timelevel=1) ! units should be Pa - endif - -! 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"//& - "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"//& - "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"//& - "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"//& - "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"//& - "as seen by MOM6.", default=.false.) - call register_forcing_type_diags(Time, diag, 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"//& - "data_table using the component name 'OCN'.", default=.false.) - if (CS%allow_flux_adjustments) then - call data_override_init(Ocean_domain_in=G%Domain%mpp_domain) - endif - - if (present(restore_salt)) then ; if (restore_salt) then - salt_file = trim(CS%inputdir) // trim(CS%salt_restore_file) - CS%id_srestore = init_external_field(salt_file, CS%salt_restore_var_name, domain=G%Domain%mpp_domain) - endif ; endif - - if (present(restore_temp)) then ; if (restore_temp) then - temp_file = trim(CS%inputdir) // trim(CS%temp_restore_file) - CS%id_trestore = init_external_field(temp_file, CS%temp_restore_var_name, domain=G%Domain%mpp_domain) - endif ; endif - - ! Set up any restart fields associated with the forcing. - call restart_init(param_file, CS%restart_CSp, "MOM_forcing.res") -!### call register_ctrl_forcing_restarts(G, param_file, CS%ctrl_forcing_CSp, & -!### CS%restart_CSp) - call restart_init_end(CS%restart_CSp) - - if (associated(CS%restart_CSp)) then - call Get_MOM_Input(dirs=dirs) - - new_sim = .false. - if ((dirs%input_filename(1:1) == 'n') .and. & - (LEN_TRIM(dirs%input_filename) == 1)) new_sim = .true. - if (.not.new_sim) then - call restore_state(dirs%input_filename, dirs%restart_input_dir, Time_frc, & - G, CS%restart_CSp) - endif - endif - -!### call controlled_forcing_init(Time, G, param_file, diag, CS%ctrl_forcing_CSp) - - call user_revise_forcing_init(param_file, CS%urf_CS) - - call cpu_clock_end(id_clock_forcing) -end subroutine surface_forcing_init - -!> Initializes domain and state variables contained in the ocean public type. -subroutine initialize_ocean_public_type(input_domain, Ocean_sfc, diag, maskmap, & - gas_fields_ocn) - type(domain2D), intent(in) :: input_domain !< The FMS domain for the input structure - type(ocean_public_type), intent(inout) :: Ocean_sfc !< Ocean surface state - type(diag_ctrl), intent(in) :: diag !< A structure used to control diagnostics. - logical, intent(in), optional :: maskmap(:,:) !< A pointer to an array indicating which - !! logical processors are actually used for the ocean code. - type(coupler_1d_bc_type), & - optional, intent(in) :: gas_fields_ocn !< If present, this type describes the - !! ocean and surface-ice fields that will participate - !! in the calculation of additional gas or other - !! tracer fluxes. - ! local variables - integer :: xsz, ysz, layout(2) - integer :: isc, iec, jsc, jec - - call mpp_get_layout(input_domain,layout) - call mpp_get_global_domain(input_domain, xsize=xsz, ysize=ysz) - if(PRESENT(maskmap)) then - call mpp_define_domains((/1,xsz,1,ysz/),layout,Ocean_sfc%Domain, maskmap=maskmap) - else - call mpp_define_domains((/1,xsz,1,ysz/),layout,Ocean_sfc%Domain) - endif - call mpp_get_compute_domain(Ocean_sfc%Domain, isc, iec, jsc, jec) - - allocate ( Ocean_sfc%t_surf (isc:iec,jsc:jec), & - Ocean_sfc%s_surf (isc:iec,jsc:jec), & - Ocean_sfc%u_surf (isc:iec,jsc:jec), & - Ocean_sfc%v_surf (isc:iec,jsc:jec), & - Ocean_sfc%sea_lev(isc:iec,jsc:jec), & - Ocean_sfc%area (isc:iec,jsc:jec), & - Ocean_sfc%frazil (isc:iec,jsc:jec)) - - Ocean_sfc%t_surf = 0.0 ! time averaged sst (Kelvin) passed to atmosphere/ice model - Ocean_sfc%s_surf = 0.0 ! time averaged sss (psu) passed to atmosphere/ice models - Ocean_sfc%u_surf = 0.0 ! time averaged u-current (m/sec) passed to atmosphere/ice models - Ocean_sfc%v_surf = 0.0 ! time averaged v-current (m/sec) passed to atmosphere/ice models - Ocean_sfc%sea_lev = 0.0 ! time averaged thickness of top model grid cell (m) plus patm/rho0/grav - Ocean_sfc%frazil = 0.0 ! time accumulated frazil (J/m^2) passed to ice model - Ocean_sfc%area = 0.0 - Ocean_sfc%axes = diag%axesT1%handles !diag axes to be used by coupler tracer flux diagnostics - - if (present(gas_fields_ocn)) then - call coupler_type_spawn(gas_fields_ocn, Ocean_sfc%fields, (/isc,isc,iec,iec/), & - (/jsc,jsc,jec,jec/), suffix = '_ocn', as_needed=.true.) - endif - -end subroutine initialize_ocean_public_type - -!> Translates the coupler's ocean_data_type into MOM6's surface state variable. -!! This may eventually be folded into the MOM6's code that calculates the -!! surface state in the first place. -subroutine convert_state_to_ocean_type(state, Ocean_sfc, G, patm, press_to_z) - type(surface), intent(inout) :: state - type(ocean_public_type), target, intent(inout) :: Ocean_sfc !< Ocean surface state - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, optional, intent(in) :: patm(:,:) !< Atmospheric pressure. - real, optional, intent(in) :: press_to_z !< Factor to tranform atmospheric - !! pressure to z? - - ! local variables - real :: IgR0 - character(len=48) :: val_str - integer :: isc_bnd, iec_bnd, jsc_bnd, jec_bnd - integer :: i, j, i0, j0, is, ie, js, je - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - call pass_vector(state%u,state%v,G%Domain) - - call mpp_get_compute_domain(Ocean_sfc%Domain, isc_bnd, iec_bnd, & - jsc_bnd, jec_bnd) - if (present(patm)) then - ! Check that the inidicies in patm are (isc_bnd:iec_bnd,jsc_bnd:jec_bnd). - if (.not.present(press_to_z)) call MOM_error(FATAL, & - 'convert_state_to_ocean_type: press_to_z must be present if patm is.') - endif - - i0 = is - isc_bnd ; j0 = js - jsc_bnd - if (state%T_is_conT) then - ! Convert the surface T from conservative T to potential T. - do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%t_surf(i,j) = gsw_pt_from_ct(state%SSS(i+i0,j+j0), & - state%SST(i+i0,j+j0)) + CELSIUS_KELVIN_OFFSET - enddo ; enddo - else - do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%t_surf(i,j) = state%SST(i+i0,j+j0) + CELSIUS_KELVIN_OFFSET - enddo ; enddo - endif - if (state%S_is_absS) then - ! Convert the surface S from absolute salinity to practical salinity. - do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%s_surf(i,j) = gsw_sp_from_sr(state%SSS(i+i0,j+j0)) - enddo ; enddo - else - do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%s_surf(i,j) = state%SSS(i+i0,j+j0) - enddo ; enddo - endif - - do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%sea_lev(i,j) = state%sea_lev(i+i0,j+j0) - if (present(patm)) & - Ocean_sfc%sea_lev(i,j) = Ocean_sfc%sea_lev(i,j) + patm(i,j) * press_to_z - if (associated(state%frazil)) & - Ocean_sfc%frazil(i,j) = state%frazil(i+i0,j+j0) - Ocean_sfc%area(i,j) = G%areaT(i+i0,j+j0) - enddo ; enddo - - if (Ocean_sfc%stagger == AGRID) then - do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%u_surf(i,j) = G%mask2dT(i+i0,j+j0)*0.5*(state%u(I+i0,j+j0)+state%u(I-1+i0,j+j0)) - Ocean_sfc%v_surf(i,j) = G%mask2dT(i+i0,j+j0)*0.5*(state%v(i+i0,J+j0)+state%v(i+i0,J-1+j0)) - enddo ; enddo - elseif (Ocean_sfc%stagger == BGRID_NE) then - do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%u_surf(i,j) = G%mask2dBu(I+i0,J+j0)*0.5*(state%u(I+i0,j+j0)+state%u(I+i0,j+j0+1)) - Ocean_sfc%v_surf(i,j) = G%mask2dBu(I+i0,J+j0)*0.5*(state%v(i+i0,J+j0)+state%v(i+i0+1,J+j0)) - enddo ; enddo - elseif (Ocean_sfc%stagger == CGRID_NE) then - do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%u_surf(i,j) = G%mask2dCu(I+i0,j+j0)*state%u(I+i0,j+j0) - Ocean_sfc%v_surf(i,j) = G%mask2dCv(i+i0,J+j0)*state%v(i+i0,J+j0) - enddo ; enddo - else - write(val_str, '(I8)') Ocean_sfc%stagger - call MOM_error(FATAL, "convert_state_to_ocean_type: "//& - "Ocean_sfc%stagger has the unrecognized value of "//trim(val_str)) - endif - - if (coupler_type_initialized(state%tr_fields)) then - if (.not.coupler_type_initialized(Ocean_sfc%fields)) then - call MOM_error(FATAL, "convert_state_to_ocean_type: "//& - "Ocean_sfc%fields has not been initialized.") - endif - call coupler_type_copy_data(state%tr_fields, Ocean_sfc%fields) - endif - -end subroutine convert_state_to_ocean_type - -!> Returns pointers to objects within ocean_state_type -subroutine get_state_pointers(OS, grid, surf) - type(ocean_state_type), pointer :: OS !< Ocean state type - type(ocean_grid_type), optional, pointer :: grid !< Ocean grid - type(surface), optional, pointer :: surf !< Ocean surface state - - if (present(grid)) grid => OS%grid - if (present(surf)) surf=> OS%sfc_state - -end subroutine get_state_pointers - -!> Maps outgoing ocean data to MCT buffer. -!! See \ref section_ocn_export for a summary of the data -!! that is transferred from MOM6 to MCT. -subroutine ocn_export(ind, ocn_public, grid, o2x) - type(cpl_indices), intent(inout) :: ind !< Structure with coupler - !! indices and vectors - type(ocean_public_type), intent(in) :: ocn_public !< Ocean surface state - type(ocean_grid_type), intent(in) :: grid !< Ocean model grid - real(kind=8), intent(inout) :: o2x(:,:) !< MCT outgoing bugger - ! Local variables - real, dimension(grid%isd:grid%ied,grid%jsd:grid%jed) :: ssh !< Local copy of sea_lev with updated halo - integer :: i, j, n, ig, jg !< Grid indices - real :: slp_L, slp_R, slp_C, slope, u_min, u_max - - ! Copy from ocn_public to o2x. ocn_public uses global indexing with no halos. - ! The mask comes from "grid" that uses the usual MOM domain that has halos - ! and does not use global indexing. - n = 0 - do j=grid%jsc, grid%jec - jg = j + grid%jdg_offset - do i=grid%isc,grid%iec - n = n+1 - ig = i + grid%idg_offset - ! surface temperature in Kelvin - o2x(ind%o2x_So_t, n) = ocn_public%t_surf(ig,jg) * grid%mask2dT(i,j) - o2x(ind%o2x_So_s, n) = ocn_public%s_surf(ig,jg) * grid%mask2dT(i,j) - o2x(ind%o2x_So_u, n) = ocn_public%u_surf(ig,jg) * grid%mask2dT(i,j) - o2x(ind%o2x_So_v, n) = ocn_public%v_surf(ig,jg) * grid%mask2dT(i,j) - ! Make a copy of ssh in order to do a halo update. We use the usual MOM domain - ! in order to update halos. i.e. does not use global indexing. - ssh(i,j) = ocn_public%sea_lev(ig,jg) - end do - end do - - ! Update halo of ssh so we can calculate gradients - call pass_var(ssh, grid%domain) - - ! d/dx ssh - n = 0 - do j=grid%jsc, grid%jec ; do i=grid%isc,grid%iec - n = n+1 - ! This is a simple second-order difference - !o2x(ind%o2x_So_dhdx, n) = 0.5 * (ssh(i+1,j) - ssh(i-1,j)) * grid%IdxT(i,j) * grid%mask2dT(i,j) - ! This is a PLM slope which might be less prone to the A-grid null mode - slp_L = (ssh(I,j) - ssh(I-1,j)) * grid%mask2dCu(I-1,j) - if (grid%mask2dCu(I-1,j)==0.) slp_L = 0. - slp_R = (ssh(I+1,j) - ssh(I,j)) * grid%mask2dCu(I,j) - if (grid%mask2dCu(I+1,j)==0.) slp_R = 0. - slp_C = 0.5 * (slp_L + slp_R) - if ( (slp_L * slp_R) > 0.0 ) then - ! This limits the slope so that the edge values are bounded by the - ! two cell averages spanning the edge. - u_min = min( ssh(i-1,j), ssh(i,j), ssh(i+1,j) ) - u_max = max( ssh(i-1,j), ssh(i,j), ssh(i+1,j) ) - slope = sign( min( abs(slp_C), 2.*min( ssh(i,j) - u_min, u_max - ssh(i,j) ) ), slp_C ) - else - ! Extrema in the mean values require a PCM reconstruction avoid generating - ! larger extreme values. - slope = 0.0 - end if - o2x(ind%o2x_So_dhdx, n) = slope * grid%IdxT(i,j) * grid%mask2dT(i,j) - if (grid%mask2dT(i,j)==0.) o2x(ind%o2x_So_dhdx, n) = 0.0 - end do; end do - - ! d/dy ssh - n = 0 - do j=grid%jsc, grid%jec ; do i=grid%isc,grid%iec - n = n+1 - ! This is a simple second-order difference - !o2x(ind%o2x_So_dhdy, n) = 0.5 * (ssh(i,j+1) - ssh(i,j-1)) * grid%IdyT(i,j) * grid%mask2dT(i,j) - ! This is a PLM slope which might be less prone to the A-grid null mode - slp_L = ssh(i,J) - ssh(i,J-1) * grid%mask2dCv(i,J-1) - if (grid%mask2dCv(i,J-1)==0.) slp_L = 0. - slp_R = ssh(i,J+1) - ssh(i,J) * grid%mask2dCv(i,J) - if (grid%mask2dCv(i,J+1)==0.) slp_R = 0. - slp_C = 0.5 * (slp_L + slp_R) - !write(6,*)'slp_L, slp_R,i,j,slp_L*slp_R', slp_L, slp_R,i,j,slp_L*slp_R - if ((slp_L * slp_R) > 0.0) then - ! This limits the slope so that the edge values are bounded by the - ! two cell averages spanning the edge. - u_min = min( ssh(i,j-1), ssh(i,j), ssh(i,j+1) ) - u_max = max( ssh(i,j-1), ssh(i,j), ssh(i,j+1) ) - slope = sign( min( abs(slp_C), 2.*min( ssh(i,j) - u_min, u_max - ssh(i,j) ) ), slp_C ) - else - ! Extrema in the mean values require a PCM reconstruction avoid generating - ! larger extreme values. - slope = 0.0 - end if - o2x(ind%o2x_So_dhdy, n) = slope * grid%IdyT(i,j) * grid%mask2dT(i,j) - if (grid%mask2dT(i,j)==0.) o2x(ind%o2x_So_dhdy, n) = 0.0 - end do; end do - -end subroutine ocn_export +!======================================================================= !> Step forward ocean model for coupling interval subroutine ocn_run_mct( EClock, cdata_o, x2o_o, o2x_o) @@ -1519,6 +423,10 @@ subroutine ocn_run_mct( EClock, cdata_o, x2o_o, o2x_o) integer :: shrlogunit ! original log file unit integer :: shrloglev ! original log level logical, save :: firstCall = .true. + real (kind=8), parameter :: seconds_in_day = 86400.0 !< number of seconds in one day + integer :: ocn_cpl_dt !< one ocn coupling interval in seconds. (to be received from cesm) + real (kind=8) :: mom_cpl_dt !< one ocn coupling interval in seconds. (internal) + integer :: ncouple_per_day !< number of ocean coupled call in one day (non-dim) ! reset shr logging to ocn log file: if (is_root_pe()) then @@ -1537,6 +445,10 @@ subroutine ocn_run_mct( EClock, cdata_o, x2o_o, o2x_o) call ESMF_TimeIntervalGet(ocn_cpl_interval, yy=year, mm=month, d=day, s=seconds, sn=seconds_n, sd=seconds_d, rc=rc) coupling_timestep = set_time(seconds, days=day, err_msg=err_msg) + call seq_timemgr_EClockGetData(EClock, dtime=ocn_cpl_dt) + ncouple_per_day = seconds_in_day / ocn_cpl_dt + mom_cpl_dt = seconds_in_day / ncouple_per_day + ! The following if-block is to correct monthly mean outputs: ! With this change, MOM6 starts at the same date as the other components, and runs for the same ! duration as other components, unlike POP, which would have one missing interval due to ocean @@ -1583,11 +495,22 @@ subroutine ocn_run_mct( EClock, cdata_o, x2o_o, o2x_o) ! GMM, check if this is needed! call seq_cdata_setptrs(cdata_o, infodata=glb%infodata) - call update_ocean_model(glb%ocn_state, glb%ocn_public, time_start, coupling_timestep, & - x2o_o%rattr, glb%ind, glb%sw_decomp, glb%c1, glb%c2, glb%c3, glb%c4) + ! Translate import fields to ice_ocean_boundary + !TODO: make this an input variable + !glb%sw_decomp = .false. + !END TODO: + if (glb%sw_decomp) then + call ocn_import(x2o_o%rattr, glb%ind, glb%grid, Ice_ocean_boundary, glb%ocn_public, glb%stdout, Eclock, & + c1=glb%c1, c2=glb%c2, c3=glb%c3, c4=glb%c4) + else + call ocn_import(x2o_o%rattr, glb%ind, glb%grid, Ice_ocean_boundary, glb%ocn_public, glb%stdout, Eclock ) + end if - ! return export state to driver - call ocn_export(glb%ind, glb%ocn_public, glb%grid, o2x_o%rattr) + ! Update internal ocean + call update_ocean_model(ice_ocean_boundary, glb%ocn_state, glb%ocn_public, time_start, coupling_timestep) + + ! Return export state to driver + call ocn_export(glb%ind, glb%ocn_public, glb%grid, o2x_o%rattr, mom_cpl_dt, ncouple_per_day) !--- write out intermediate restart file when needed. ! Check alarms for flag to write restart at end of day @@ -1604,7 +527,7 @@ subroutine ocn_run_mct( EClock, cdata_o, x2o_o, o2x_o) write(restartname,'(A,".mom6.r.",I4.4,"-",I2.2,"-",I2.2,"-",I5.5)') trim(runid), year, month, day, seconds call save_restart(glb%ocn_state%dirs%restart_output_dir, glb%ocn_state%Time, glb%grid, & - glb%ocn_state%restart_CSp, .false., filename=restartname,GV=glb%ocn_state%GV) + glb%ocn_state%restart_CSp, .false., filename=restartname, GV=glb%ocn_state%GV) ! write name of restart file in the rpointer file nu = shr_file_getUnit() @@ -1620,9 +543,11 @@ subroutine ocn_run_mct( EClock, cdata_o, x2o_o, o2x_o) ! Is this needed? call forcing_save_restart(glb%ocn_state%forcing_CSp, glb%grid, glb%ocn_state%Time, & glb%ocn_state%dirs%restart_output_dir, .true.) + ! Once we start using the ice shelf module, the following will be needed if (glb%ocn_state%use_ice_shelf) then - call ice_shelf_save_restart(glb%ocn_state%Ice_shelf_CSp, glb%ocn_state%Time, glb%ocn_state%dirs%restart_output_dir, .true.) + call ice_shelf_save_restart(glb%ocn_state%Ice_shelf_CSp, glb%ocn_state%Time, & + glb%ocn_state%dirs%restart_output_dir, .true.) endif endif @@ -1635,783 +560,7 @@ subroutine ocn_run_mct( EClock, cdata_o, x2o_o, o2x_o) end subroutine ocn_run_mct -!> Saves restart fields associated with the forcing -subroutine forcing_save_restart(CS, G, Time, directory, time_stamped, & - filename_suffix) - type(surface_forcing_CS), pointer :: CS !< pointer to the control structure - !! returned by a previous call to - !! surface_forcing_init - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(time_type), intent(in) :: Time !< model time at this call - character(len=*), intent(in) :: directory !< optional directory into which - !! to write these restart files - logical, optional, intent(in) :: time_stamped !< If true, the restart file - !! names include a unique time - !! stamp - character(len=*), optional, intent(in) :: filename_suffix !< optional suffix - !! (e.g., a time-stamp) to append to the - !! restart file names - if (.not.associated(CS)) return - if (.not.associated(CS%restart_CSp)) return - call save_restart(directory, Time, G, CS%restart_CSp, time_stamped) - -end subroutine forcing_save_restart - -!> Updates the ocean model fields. This code wraps the call to step_MOM with MOM6's call. -!! It uses the forcing to advance the ocean model's state from the -!! input value of Ocean_state (which must be for time time_start_update) for a time interval -!! of Ocean_coupling_time_step, returning the publicly visible ocean surface properties in -!! Ocean_sfc and storing the new ocean properties in Ocean_state. -subroutine update_ocean_model(OS, Ocean_sfc, time_start_update, & - Ocean_coupling_time_step, x2o_o, ind, sw_decomp, & - c1, c2, c3, c4) - type(ocean_state_type), pointer :: OS !< Structure containing the internal ocean state - type(ocean_public_type), intent(inout) :: Ocean_sfc !< Structure containing all the publicly - !! visible ocean surface fields after a coupling time step - type(time_type), intent(in) :: time_start_update !< Time at the beginning of the update step - type(time_type), intent(in) :: Ocean_coupling_time_step !< Amount of time over which to - !! advance the ocean - real(kind=8), intent(in) :: x2o_o(:,:) !< Fluxes from coupler to ocean, computed by ocean - type(cpl_indices), intent(inout) :: ind !< Structure with MCT attribute vectors and indices - logical, intent(in) :: sw_decomp !< controls if shortwave is - !!decomposed into four components - real(kind=8), intent(in), optional :: c1, c2, c3, c4 !< Coeffs. used in the shortwave decomposition - - ! local variables - type(time_type) :: Master_time !< This allows step_MOM to temporarily change - !! the time that is seen by internal modules. - type(time_type) :: Time1 !< The value of the ocean model's time at the - !! start of a call to step_MOM. - real :: weight !< Flux accumulation weight - real :: time_step !< The time step of a call to step_MOM in seconds. - integer :: secs, days - integer :: is, ie, js, je - - call callTree_enter("update_ocean_model(), ocn_comp_mct.F90") - call get_time(Ocean_coupling_time_step, secs, days) - time_step = 86400.0*real(days) + real(secs) - - if (time_start_update /= OS%Time) then - call MOM_error(WARNING, "update_ocean_model: internal clock does not "//& - "agree with time_start_update argument.") - endif - - if (.not.associated(OS)) then - call MOM_error(FATAL, "update_ocean_model called with an unassociated "// & - "ocean_state_type structure. ocean_model_init must be "// & - "called first to allocate this structure.") - return - endif - - ! This is benign but not necessary if ocean_model_init_sfc was called or if - ! OS%sfc_state%tr_fields was spawned in ocean_model_init. Consider removing it. - is = OS%grid%isc ; ie = OS%grid%iec ; js = OS%grid%jsc ; je = OS%grid%jec - call coupler_type_spawn(Ocean_sfc%fields, OS%sfc_state%tr_fields, & - (/is,is,ie,ie/), (/js,js,je,je/), as_needed=.true.) - - weight = 1.0 - - if (OS%fluxes%fluxes_used) then - ! GMM, is enable_averaging needed now? - call enable_averaging(time_step, OS%Time + Ocean_coupling_time_step, OS%diag) - call ocn_import(OS%forces, OS%fluxes, OS%Time, OS%grid, OS%forcing_CSp, OS%sfc_state, x2o_o, ind, sw_decomp, & - c1, c2, c3, c4, OS%restore_salinity,OS%restore_temp) - - ! Fields that exist in both the forcing and mech_forcing types must be copied. - call copy_common_forcing_fields(OS%forces, OS%fluxes, OS%grid) - -#ifdef _USE_GENERIC_TRACER - call MOM_generic_tracer_fluxes_accumulate(OS%fluxes, weight) !here weight=1, just saving the current fluxes -#endif - - ! Add ice shelf fluxes - if (OS%use_ice_shelf) then - call shelf_calc_flux(OS%sfc_state, OS%forces, OS%fluxes, OS%Time, time_step, OS%Ice_shelf_CSp) - endif - - ! GMM, check ocean_model_MOM.F90 to enable the following option - !if (OS%icebergs_apply_rigid_boundary) then - ! This assumes that the iceshelf and ocean are on the same grid. I hope this is true. - ! call add_berg_flux_to_shelf(OS%grid, OS%forces,OS%fluxes,OS%use_ice_shelf,OS%density_iceberg,OS%kv_iceberg, OS%latent_heat_fusion, OS%sfc_state, time_step, OS%berg_area_threshold) - !endif - - ! Indicate that there are new unused fluxes. - OS%fluxes%fluxes_used = .false. - OS%fluxes%dt_buoy_accum = time_step - else - OS%flux_tmp%C_p = OS%fluxes%C_p - ! Import fluxes from coupler to ocean. Also, perform do SST and SSS restoring, if needed. - call ocn_import(OS%forces, OS%flux_tmp, OS%Time, OS%grid, OS%forcing_CSp, & - OS%sfc_state, x2o_o, ind, sw_decomp, c1, c2, c3, c4, & - OS%restore_salinity,OS%restore_temp) - - if (OS%use_ice_shelf) then - call shelf_calc_flux(OS%sfc_state, OS%forces, OS%flux_tmp, OS%Time, time_step, OS%Ice_shelf_CSp) - endif - - ! GMM, check ocean_model_MOM.F90 to enable the following option - !if (OS%icebergs_apply_rigid_boundary) then - !This assumes that the iceshelf and ocean are on the same grid. I hope this is true - ! call add_berg_flux_to_shelf(OS%grid, OS%forces, OS%flux_tmp, OS%use_ice_shelf,OS%density_iceberg,OS%kv_iceberg, OS%latent_heat_fusion, OS%sfc_state, time_step, OS%berg_area_threshold) - !endif - - ! Accumulate the forcing over time steps - call forcing_accumulate(OS%flux_tmp, OS%forces, OS%fluxes, time_step, OS%grid, weight) - ! Some of the fields that exist in both the forcing and mech_forcing types - ! are time-averages must be copied back to the forces type. - call copy_back_forcing_fields(OS%fluxes, OS%forces, OS%grid) -#ifdef _USE_GENERIC_TRACER - call MOM_generic_tracer_fluxes_accumulate(OS%flux_tmp, weight) !weight of the current flux in the running average -#endif - endif - - call set_derived_forcing_fields(OS%forces, OS%fluxes, OS%grid, OS%GV%Rho0) - call set_net_mass_forcing(OS%fluxes, OS%forces, OS%grid) - - if (OS%nstep==0) then - call finish_MOM_initialization(OS%Time, OS%dirs, OS%MOM_CSp, OS%fluxes, & - OS%restart_CSp) - endif - - call disable_averaging(OS%diag) - Master_time = OS%Time ; Time1 = OS%Time - - if(OS%offline_tracer_mode) then - call step_offline(OS%forces, OS%fluxes, OS%sfc_state, Time1, time_step, OS%MOM_CSp) - else - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, time_step, OS%MOM_CSp) - endif - - OS%Time = Master_time + Ocean_coupling_time_step - OS%nstep = OS%nstep + 1 - - call enable_averaging(time_step, OS%Time, OS%diag) - call mech_forcing_diags(OS%forces, OS%fluxes, time_step, OS%grid, & - OS%diag, OS%forcing_CSp%handles) - call disable_averaging(OS%diag) - - if (OS%fluxes%fluxes_used) then - call enable_averaging(OS%fluxes%dt_buoy_accum, OS%Time, OS%diag) - call forcing_diagnostics(OS%fluxes, OS%sfc_state, OS%fluxes%dt_buoy_accum, & - OS%grid, OS%diag, OS%forcing_CSp%handles) - call disable_averaging(OS%diag) - endif - -! Translate state into Ocean. -! call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, & -! Ice_ocean_boundary%p, OS%press_to_z) - call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid) - - call callTree_leave("update_ocean_model()") -end subroutine update_ocean_model - -!> This function has a few purposes: 1) it allocates and initializes the data -!! in the fluxes structure; 2) it imports surface fluxes using data from -!! the coupler; and 3) it can apply restoring in SST and SSS. -!! See \ref section_ocn_import for a summary of the surface fluxes that are -!! passed from MCT to MOM6, including fluxes that need to be included in -!! the future. -subroutine ocn_import(forces, fluxes, Time, G, CS, state, x2o_o, ind, sw_decomp, & - c1, c2, c3, c4, restore_salt, restore_temp) - type(mech_forcing), intent(inout) :: forces !< Driving mechanical forces - type(forcing), intent(inout) :: fluxes !< Surface fluxes - type(time_type), intent(in) :: Time !< Model time - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid - type(surface_forcing_CS), pointer :: CS !< control structure returned by - !! a previous call to surface_forcing_init - type(surface), intent(in) :: state !< control structure to ocean - !! surface state fields. - real(kind=8), intent(in) :: x2o_o(:,:)!< Fluxes from coupler to ocean, computed by ocean - type(cpl_indices), intent(inout) :: ind !< Structure with MCT attribute vectors and indices - logical, intent(in) :: sw_decomp !< controls if shortwave is - !!decomposed into four components - real(kind=8), intent(in), optional :: c1, c2, c3, c4 !< Coeffs. used in the shortwave decomposition - logical, optional, intent(in) :: restore_salt, restore_temp !< Controls if salt and temp are - !! restored - - ! local variables - real, dimension(SZIB_(G),SZJB_(G)) :: & - taux_at_q, & ! Zonal wind stresses at q points (Pa) - tauy_at_q ! Meridional wind stresses at q points (Pa) - - real, dimension(SZI_(G),SZJ_(G)) :: & - taux_at_h, & ! Zonal wind stresses at h points (Pa) - tauy_at_h, & ! Meridional wind stresses at h points (Pa) - data_restore, & ! The surface value toward which to restore (g/kg or degC) - SST_anom, & ! Instantaneous sea surface temperature anomalies from a target value (deg C) - SSS_anom, & ! Instantaneous sea surface salinity anomalies from a target value (g/kg) - SSS_mean, & ! A (mean?) salinity about which to normalize local salinity - ! anomalies when calculating restorative precipitation anomalies (g/kg) - PmE_adj, & ! The adjustment to PminusE that will cause the salinity - ! to be restored toward its target value (kg/(m^2 * s)) - net_FW, & ! The area integrated net freshwater flux into the ocean (kg/s) - net_FW2, & ! The area integrated net freshwater flux into the ocean (kg/s) - work_sum, & ! A 2-d array that is used as the work space for a global - ! sum, used with units of m2 or (kg/s) - open_ocn_mask ! a binary field indicating where ice is present based on frazil criteria - - real :: gustiness ! unresolved gustiness that contributes to ustar (Pa) - real :: Irho0 ! inverse of the mean density in (m^3/kg) - real :: taux2, tauy2 ! squared wind stresses (Pa^2) - real :: tau_mag ! magnitude of the wind stress (Pa) - real :: I_GEarth ! 1.0 / G%G_Earth (s^2/m) - real :: Kv_rho_ice ! (CS%kv_sea_ice / CS%density_sea_ice) ( m^5/(s*kg) ) - real :: mass_ice ! mass of sea ice at a face (kg/m^2) - real :: mass_eff ! effective mass of sea ice for rigidity (kg/m^2) - - integer :: wind_stagger ! AGRID, BGRID_NE, or CGRID_NE (integers from MOM_domains) - integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, i0, j0 - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, isr, ier, jsr, jer - integer :: isc_bnd, iec_bnd, jsc_bnd, jec_bnd - - logical :: restore_salinity ! local copy of the argument restore_salt, if it - ! is present, or false (no restoring) otherwise. - logical :: restore_sst ! local copy of the argument restore_temp, if it - ! is present, or false (no restoring) otherwise. - real :: delta_sss ! temporary storage for sss diff from restoring value - real :: delta_sst ! temporary storage for sst diff from restoring value - - real :: C_p ! heat capacity of seawater ( J/(K kg) ) - - call cpu_clock_begin(id_clock_forcing) - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - isr = is-isd+1 ; ier = ie-isd+1 ; jsr = js-jsd+1 ; jer = je-jsd+1 - - C_p = fluxes%C_p - Irho0 = 1.0/CS%Rho0 - open_ocn_mask(:,:) = 1.0 - pme_adj(:,:) = 0.0 - fluxes%vPrecGlobalAdj = 0.0 - fluxes%vPrecGlobalScl = 0.0 - fluxes%saltFluxGlobalAdj = 0.0 - fluxes%saltFluxGlobalScl = 0.0 - fluxes%netFWGlobalAdj = 0.0 - fluxes%netFWGlobalScl = 0.0 - - restore_salinity = .false. - if (present(restore_salt)) restore_salinity = restore_salt - restore_sst = .false. - if (present(restore_temp)) restore_sst = restore_temp - - ! if true, allocation and initialization - if (fluxes%dt_buoy_accum < 0) then - call allocate_forcing_type(G, fluxes, water=.true., heat=.true., & - ustar=.true., press=.true.) - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., & - press=.true.) - call safe_alloc_ptr(fluxes%sw_vis_dir,isd,ied,jsd,jed) - call safe_alloc_ptr(fluxes%sw_vis_dif,isd,ied,jsd,jed) - call safe_alloc_ptr(fluxes%sw_nir_dir,isd,ied,jsd,jed) - call safe_alloc_ptr(fluxes%sw_nir_dif,isd,ied,jsd,jed) - - call safe_alloc_ptr(fluxes%p_surf,isd,ied,jsd,jed) - call safe_alloc_ptr(fluxes%p_surf_full,isd,ied,jsd,jed) - - call safe_alloc_ptr(fluxes%salt_flux,isd,ied,jsd,jed) - call safe_alloc_ptr(fluxes%salt_flux_in,isd,ied,jsd,jed) - call safe_alloc_ptr(fluxes%salt_flux_added,isd,ied,jsd,jed) - - call safe_alloc_ptr(fluxes%TKE_tidal,isd,ied,jsd,jed) - call safe_alloc_ptr(fluxes%ustar_tidal,isd,ied,jsd,jed) - - if (CS%allow_flux_adjustments) then - call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) - call safe_alloc_ptr(fluxes%salt_flux_added,isd,ied,jsd,jed) - endif - - do j=js-2,je+2 ; do i=is-2,ie+2 - fluxes%TKE_tidal(i,j) = CS%TKE_tidal(i,j) - fluxes%ustar_tidal(i,j) = CS%ustar_tidal(i,j) - enddo; enddo - - call safe_alloc_ptr(forces%p_surf,isd,ied,jsd,jed) - call safe_alloc_ptr(forces%p_surf_full,isd,ied,jsd,jed) - - if (CS%rigid_sea_ice) then - call safe_alloc_ptr(forces%rigidity_ice_u,IsdB,IedB,jsd,jed) - call safe_alloc_ptr(forces%rigidity_ice_v,isd,ied,JsdB,JedB) - endif - - if (restore_temp) call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) - - fluxes%dt_buoy_accum = 0.0 - endif ! endif for allocation and initialization - - if (CS%allow_flux_adjustments) then - fluxes%heat_added(:,:)=0.0 - fluxes%salt_flux_added(:,:)=0.0 - endif - - if (CS%area_surf < 0.0) then - do j=js,je ; do i=is,ie - work_sum(i,j) = G%areaT(i,j) * G%mask2dT(i,j) - enddo ; enddo - CS%area_surf = reproducing_sum(work_sum, isr, ier, jsr, jer) - endif ! endif for allocation and initialization - - do j=js,je ; do i=is,ie - fluxes%salt_flux(i,j) = 0.0 - fluxes%vprec(i,j) = 0.0 - enddo ; enddo - - ! Salinity restoring logic - if (restore_salinity) then - call time_interp_external(CS%id_srestore,Time,data_restore) - ! open_ocn_mask indicates where to restore salinity (1 means restore, 0 does not) - open_ocn_mask(:,:) = 1.0 - if (CS%mask_srestore_under_ice) then ! Do not restore under sea-ice - do j=js,je ; do i=is,ie - if (state%SST(i,j) .le. -0.0539*state%SSS(i,j)) open_ocn_mask(i,j)=0.0 - enddo; enddo - endif - if (CS%salt_restore_as_sflux) then - do j=js,je ; do i=is,ie - delta_sss = data_restore(i,j)- state%SSS(i,j) - delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) - fluxes%salt_flux(i,j) = 1.e-3*G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)* & - (CS%basin_mask(i,j)*open_ocn_mask(i,j)) *delta_sss ! kg Salt m-2 s-1 - enddo; enddo - if (CS%adjust_net_srestore_to_zero) then - if (CS%adjust_net_srestore_by_scaling) then - call adjust_area_mean_to_zero(fluxes%salt_flux, G, fluxes%saltFluxGlobalScl) - fluxes%saltFluxGlobalAdj = 0. - else - work_sum(is:ie,js:je) = G%areaT(is:ie,js:je)*fluxes%salt_flux(is:ie,js:je) - fluxes%saltFluxGlobalAdj = reproducing_sum(work_sum(:,:), isr,ier, jsr,jer)/CS%area_surf - fluxes%salt_flux(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) - fluxes%saltFluxGlobalAdj - endif - endif - fluxes%salt_flux_added(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) ! Diagnostic - else - do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0.5) then - delta_sss = state%SSS(i,j) - data_restore(i,j) - delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) - fluxes%vprec(i,j) = (CS%basin_mask(i,j)*open_ocn_mask(i,j))* & - (CS%Rho0*CS%Flux_const) * & - delta_sss / (0.5*(state%SSS(i,j) + data_restore(i,j))) - endif - enddo; enddo - if (CS%adjust_net_srestore_to_zero) then - if (CS%adjust_net_srestore_by_scaling) then - call adjust_area_mean_to_zero(fluxes%vprec, G, fluxes%vPrecGlobalScl) - fluxes%vPrecGlobalAdj = 0. - else - work_sum(is:ie,js:je) = G%areaT(is:ie,js:je)*fluxes%vprec(is:ie,js:je) - fluxes%vPrecGlobalAdj = reproducing_sum(work_sum(:,:), isr, ier, jsr, jer) / CS%area_surf - do j=js,je ; do i=is,ie - fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - fluxes%vPrecGlobalAdj ) * G%mask2dT(i,j) - enddo; enddo - endif - endif - endif - endif - - ! SST restoring logic - if (restore_sst) then - call time_interp_external(CS%id_trestore,Time,data_restore) - do j=js,je ; do i=is,ie - delta_sst = data_restore(i,j)- state%SST(i,j) - delta_sst = sign(1.0,delta_sst)*min(abs(delta_sst),CS%max_delta_trestore) - fluxes%heat_added(i,j) = G%mask2dT(i,j) * (CS%Rho0*fluxes%C_p) * delta_sst * CS%Flux_const ! W m-2 - enddo; enddo - endif - - ! GMM, CIME uses AGRID. All the BGRID_NE code can be cleaned later - wind_stagger = AGRID - - if (wind_stagger == BGRID_NE) then - ! This is necessary to fill in the halo points. - taux_at_q(:,:) = 0.0 ; tauy_at_q(:,:) = 0.0 - endif - if (wind_stagger == AGRID) then - ! This is necessary to fill in the halo points. - taux_at_h(:,:) = 0.0 ; tauy_at_h(:,:) = 0.0 - endif - - k = 0 - do j=js,je ; do i=is,ie - k = k + 1 ! Increment position within gindex - - if (wind_stagger == BGRID_NE) then - taux_at_q(I,J) = x2o_o(ind%x2o_Foxx_taux,k) * CS%wind_stress_multiplier - tauy_at_q(I,J) = x2o_o(ind%x2o_Foxx_tauy,k) * CS%wind_stress_multiplier - ! GMM, cime uses AGRID - elseif (wind_stagger == AGRID) then - taux_at_h(i,j) = x2o_o(ind%x2o_Foxx_taux,k) * CS%wind_stress_multiplier - tauy_at_h(i,j) = x2o_o(ind%x2o_Foxx_tauy,k) * CS%wind_stress_multiplier - else ! C-grid wind stresses. - forces%taux(I,j) = x2o_o(ind%x2o_Foxx_taux,k) * CS%wind_stress_multiplier - forces%tauy(i,J) = x2o_o(ind%x2o_Foxx_tauy,k) * CS%wind_stress_multiplier - endif - - ! liquid precipitation (rain) - if (associated(fluxes%lprec)) & - fluxes%lprec(i,j) = x2o_o(ind%x2o_Faxa_rain,k) * G%mask2dT(i,j) - - ! frozen precipitation (snow) - if (associated(fluxes%fprec)) & - fluxes%fprec(i,j) = x2o_o(ind%x2o_Faxa_snow,k) * G%mask2dT(i,j) - - ! evaporation - if (associated(fluxes%evap)) & - fluxes%evap(i,j) = x2o_o(ind%x2o_Foxx_evap,k) * G%mask2dT(i,j) - - ! river runoff flux - if (associated(fluxes%lrunoff)) & - fluxes%lrunoff(i,j) = x2o_o(ind%x2o_Foxx_rofl,k) * G%mask2dT(i,j) - - ! ice runoff flux - if (associated(fluxes%frunoff)) & - fluxes%frunoff(i,j) = x2o_o(ind%x2o_Foxx_rofi,k) * G%mask2dT(i,j) - - ! GMM, we don't have an icebergs yet so the following is not needed - !if (((associated(IOB%ustar_berg) .and. (.not. associated(fluxes%ustar_berg))) & - ! .or. (associated(IOB%area_berg) .and. (.not. associated(fluxes%area_berg)))) & - ! .or. (associated(IOB%mass_berg) .and. (.not. associated(fluxes%mass_berg)))) & - ! call allocate_forcing_type(G, fluxes, iceberg=.true.) - !if (associated(IOB%ustar_berg)) & - ! fluxes%ustar_berg(i,j) = IOB%ustar_berg(i-i0,j-j0) * G%mask2dT(i,j) - !if (associated(IOB%area_berg)) & - ! fluxes%area_berg(i,j) = IOB%area_berg(i-i0,j-j0) * G%mask2dT(i,j) - !if (associated(IOB%mass_berg)) & - ! fluxes%mass_berg(i,j) = IOB%mass_berg(i-i0,j-j0) * G%mask2dT(i,j) - - ! GMM, cime does not not have an equivalent for heat_content_lrunoff and - ! heat_content_frunoff. I am seeting these to zero for now. - if (associated(fluxes%heat_content_lrunoff)) & - fluxes%heat_content_lrunoff(i,j) = 0.0 * G%mask2dT(i,j) - - if (associated(fluxes%heat_content_frunoff)) & - fluxes%heat_content_frunoff(i,j) = 0.0 * G%mask2dT(i,j) - - ! longwave radiation, sum up and down (W/m2) - if (associated(fluxes%LW)) & - fluxes%LW(i,j) = (x2o_o(ind%x2o_Faxa_lwdn,k) + x2o_o(ind%x2o_Foxx_lwup,k)) * G%mask2dT(i,j) - - ! sensible heat flux (W/m2) - if (associated(fluxes%sens)) & - fluxes%sens(i,j) = x2o_o(ind%x2o_Foxx_sen,k) * G%mask2dT(i,j) - - ! latent heat flux (W/m^2) - if (associated(fluxes%latent)) & - fluxes%latent(i,j) = x2o_o(ind%x2o_Foxx_lat,k) * G%mask2dT(i,j) - - if (sw_decomp) then - ! Use runtime coefficients to decompose net short-wave heat flux into 4 components - ! 1) visible, direct shortwave (W/m2) - if (associated(fluxes%sw_vis_dir)) & - fluxes%sw_vis_dir(i,j) = G%mask2dT(i,j) * x2o_o(ind%x2o_Foxx_swnet,k)*c1 - ! 2) visible, diffuse shortwave (W/m2) - if (associated(fluxes%sw_vis_dif)) & - fluxes%sw_vis_dif(i,j) = G%mask2dT(i,j) * x2o_o(ind%x2o_Foxx_swnet,k)*c2 - ! 3) near-IR, direct shortwave (W/m2) - if (associated(fluxes%sw_nir_dir)) & - fluxes%sw_nir_dir(i,j) = G%mask2dT(i,j) * x2o_o(ind%x2o_Foxx_swnet,k)*c3 - ! 4) near-IR, diffuse shortwave (W/m2) - if (associated(fluxes%sw_nir_dif)) & - fluxes%sw_nir_dif(i,j) = G%mask2dT(i,j) * x2o_o(ind%x2o_Foxx_swnet,k)*c4 - - fluxes%sw(i,j) = fluxes%sw_vis_dir(i,j) + fluxes%sw_vis_dif(i,j) + & - fluxes%sw_nir_dir(i,j) + fluxes%sw_nir_dif(i,j) - else - call MOM_error(FATAL,"fill_ice_ocean_bnd: this option has not been implemented yet."// & - "Shortwave must be decomposed using coeffs. c1, c2, c3, c4."); - endif - - ! applied surface pressure from atmosphere and cryosphere - ! sea-level pressure (Pa) - if (associated(forces%p_surf_full) .and. associated(forces%p_surf)) then - forces%p_surf_full(i,j) = G%mask2dT(i,j) * x2o_o(ind%x2o_Sa_pslv,k) - if (CS%max_p_surf >= 0.0) then - forces%p_surf(i,j) = MIN(forces%p_surf_full(i,j),CS%max_p_surf) - else - forces%p_surf(i,j) = forces%p_surf_full(i,j) - endif - - if (CS%use_limited_P_SSH) then - forces%p_surf_SSH => forces%p_surf - else - forces%p_surf_SSH => forces%p_surf_full - endif - - endif - - ! salt flux - ! more salt restoring logic - if (associated(fluxes%salt_flux)) & - fluxes%salt_flux(i,j) = G%mask2dT(i,j)*(x2o_o(ind%x2o_Fioi_salt,k) + fluxes%salt_flux(i,j)) - - if (associated(fluxes%salt_flux_in)) & - fluxes%salt_flux_in(i,j) = G%mask2dT(i,j)*x2o_o(ind%x2o_Fioi_salt,k) - - enddo ; enddo - ! ############################ END OF MCT to MOM ############################## - - ! adjust the NET fresh-water flux to zero, if flagged - if (CS%adjust_net_fresh_water_to_zero) then - do j=js,je ; do i=is,ie - net_FW(i,j) = (((fluxes%lprec(i,j) + fluxes%fprec(i,j)) + & - (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j))) + & - (fluxes%evap(i,j) + fluxes%vprec(i,j)) ) * G%areaT(i,j) - ! The following contribution appears to be calculating the volume flux of sea-ice - ! melt. This calculation is clearly WRONG if either sea-ice has variable - ! salinity or the sea-ice is completely fresh. - ! Bob thinks this is trying ensure the net fresh-water of the ocean + sea-ice system - ! is constant. - ! To do this correctly we will need a sea-ice melt field added to IOB. -AJA - if (associated(fluxes%salt_flux) .and. (CS%ice_salt_concentration>0.0)) & - net_FW(i,j) = net_FW(i,j) + G%areaT(i,j) * & - (fluxes%salt_flux(i,j) / CS%ice_salt_concentration) - net_FW2(i,j) = net_FW(i,j)/G%areaT(i,j) - enddo ; enddo - - if (CS%adjust_net_fresh_water_by_scaling) then - call adjust_area_mean_to_zero(net_FW2, G, fluxes%netFWGlobalScl) - do j=js,je ; do i=is,ie - fluxes%vprec(i,j) = fluxes%vprec(i,j) + (net_FW2(i,j) - net_FW(i,j)/G%areaT(i,j)) * G%mask2dT(i,j) - enddo; enddo - else - fluxes%netFWGlobalAdj = reproducing_sum(net_FW(:,:), isr, ier, jsr, jer) / CS%area_surf - do j=js,je ; do i=is,ie - fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - fluxes%netFWGlobalAdj ) * G%mask2dT(i,j) - enddo; enddo - endif - - endif - - ! surface momentum stress related fields as function of staggering - if (wind_stagger == BGRID_NE) then - if (G%symmetric) & - call fill_symmetric_edges(taux_at_q, tauy_at_q, G%Domain, stagger=BGRID_NE) - call pass_vector(taux_at_q, tauy_at_q, G%Domain, stagger=BGRID_NE) - - do j=js,je ; do I=Isq,Ieq - forces%taux(I,j) = 0.0 - if ((G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) > 0) & - forces%taux(I,j) = (G%mask2dBu(I,J)*taux_at_q(I,J) + & - G%mask2dBu(I,J-1)*taux_at_q(I,J-1)) / & - (G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) - enddo ; enddo - - do J=Jsq,Jeq ; do i=is,ie - forces%tauy(i,J) = 0.0 - if ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) > 0) & - forces%tauy(i,J) = (G%mask2dBu(I,J)*tauy_at_q(I,J) + & - G%mask2dBu(I-1,J)*tauy_at_q(I-1,J)) / & - (G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) - enddo ; enddo - - ! ustar is required for the bulk mixed layer formulation. The background value - ! of 0.02 Pa is a relatively small value intended to give reasonable behavior - ! in regions of very weak winds. - - do j=js,je ; do i=is,ie - tau_mag = 0.0 ; gustiness = CS%gust_const - if (((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + & - (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0) then - tau_mag = sqrt(((G%mask2dBu(I,J)*(taux_at_q(I,J)**2 + tauy_at_q(I,J)**2) + & - G%mask2dBu(I-1,J-1)*(taux_at_q(I-1,J-1)**2 + tauy_at_q(I-1,J-1)**2)) + & - (G%mask2dBu(I,J-1)*(taux_at_q(I,J-1)**2 + tauy_at_q(I,J-1)**2) + & - G%mask2dBu(I-1,J)*(taux_at_q(I-1,J)**2 + tauy_at_q(I-1,J)**2)) ) / & - ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) ) - if (CS%read_gust_2d) gustiness = CS%gust(i,j) - endif - forces%ustar(i,j) = sqrt(gustiness*Irho0 + Irho0*tau_mag) - enddo ; enddo - - elseif (wind_stagger == AGRID) then - call pass_vector(taux_at_h, tauy_at_h, G%Domain,stagger=AGRID) - - do j=js,je ; do I=Isq,Ieq - forces%taux(I,j) = 0.0 - if ((G%mask2dT(i,j) + G%mask2dT(i+1,j)) > 0) & - forces%taux(I,j) = (G%mask2dT(i,j)*taux_at_h(i,j) + & - G%mask2dT(i+1,j)*taux_at_h(i+1,j)) / & - (G%mask2dT(i,j) + G%mask2dT(i+1,j)) - enddo ; enddo - - do J=Jsq,Jeq ; do i=is,ie - forces%tauy(i,J) = 0.0 - if ((G%mask2dT(i,j) + G%mask2dT(i,j+1)) > 0) & - forces%tauy(i,J) = (G%mask2dT(i,j)*tauy_at_h(i,j) + & - G%mask2dT(i,J+1)*tauy_at_h(i,j+1)) / & - (G%mask2dT(i,j) + G%mask2dT(i,j+1)) - enddo ; enddo - - do j=js,je ; do i=is,ie - gustiness = CS%gust_const - if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0)) gustiness = CS%gust(i,j) - forces%ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * G%mask2dT(i,j) * & - sqrt(taux_at_h(i,j)**2 + tauy_at_h(i,j)**2)) - enddo ; enddo - - else ! C-grid wind stresses. - if (G%symmetric) & - call fill_symmetric_edges(forces%taux, forces%tauy, G%Domain) - call pass_vector(forces%taux, forces%tauy, G%Domain) - - do j=js,je ; do i=is,ie - taux2 = 0.0 - if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0) & - taux2 = (G%mask2dCu(I-1,j)*forces%taux(I-1,j)**2 + & - G%mask2dCu(I,j)*forces%taux(I,j)**2) / (G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) - - tauy2 = 0.0 - if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0) & - tauy2 = (G%mask2dCv(i,J-1)*forces%tauy(i,J-1)**2 + & - G%mask2dCv(i,J)*forces%tauy(i,J)**2) / (G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) - - if (CS%read_gust_2d) then - forces%ustar(i,j) = sqrt(CS%gust(i,j)*Irho0 + Irho0*sqrt(taux2 + tauy2)) - else - forces%ustar(i,j) = sqrt(CS%gust_const*Irho0 + Irho0*sqrt(taux2 + tauy2)) - endif - enddo ; enddo - - endif ! endif for wind related fields - - - ! sea ice related fields - if (CS%rigid_sea_ice) then - ! The commented out code here and in the following lines is the correct - ! version, but the incorrect version is being retained temporarily to avoid - ! changing answers. - call pass_var(forces%p_surf_full, G%Domain) - I_GEarth = 1.0 / G%G_Earth - Kv_rho_ice = (CS%kv_sea_ice / CS%density_sea_ice) - do I=isd,ied-1 ; do j=jsd,jed - mass_ice = min(forces%p_surf_full(i,j), forces%p_surf_full(i+1,j)) * I_GEarth - mass_eff = 0.0 - if (mass_ice > CS%rigid_sea_ice_mass) then - mass_eff = (mass_ice - CS%rigid_sea_ice_mass) **2 / & - (mass_ice + CS%rigid_sea_ice_mass) - endif - ! CAUTION: with both rigid_sea_ice and ice shelves, we will need to make this - ! a maximum for the second call. - forces%rigidity_ice_u(I,j) = Kv_rho_ice * mass_eff - enddo ; enddo - do i=isd,ied ; do J=jsd,jed-1 - mass_ice = min(forces%p_surf_full(i,j), forces%p_surf_full(i,j+1)) * I_GEarth - mass_eff = 0.0 - if (mass_ice > CS%rigid_sea_ice_mass) then - mass_eff = (mass_ice - CS%rigid_sea_ice_mass) **2 / & - (mass_ice + CS%rigid_sea_ice_mass) - endif - forces%rigidity_ice_v(i,J) = Kv_rho_ice * mass_eff - enddo ; enddo - endif - - if (CS%allow_flux_adjustments) then - ! Apply adjustments to fluxes - call apply_flux_adjustments(G, CS, Time, forces, fluxes) - endif - - ! Allow for user-written code to alter fluxes after all the above - call user_alter_forcing(state, fluxes, Time, G, CS%urf_CS) - - call cpu_clock_end(id_clock_forcing) - -end subroutine ocn_import - -!> Adds flux adjustments obtained via data_override -!! Component name is 'OCN' -!! Available adjustments are: -!! - taux_adj (Zonal wind stress delta, positive to the east, in Pa) -!! - tauy_adj (Meridional wind stress delta, positive to the north, in Pa) -subroutine apply_flux_adjustments(G, CS, Time, forces, fluxes) - type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure - type(surface_forcing_CS), pointer :: CS !< Surface forcing control structure - type(time_type), intent(in) :: Time !< Model time structure - type(mech_forcing), intent(inout) :: forces !< Driving mechanical forces - type(forcing), optional, intent(inout) :: fluxes !< Surface fluxes structure - - ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: tempx_at_h ! Delta to zonal wind stress at h points (Pa) - real, dimension(SZI_(G),SZJ_(G)) :: tempy_at_h ! Delta to meridional wind stress at h points (Pa) - real, dimension(SZI_(G),SZJ_(G)) :: temp_at_h ! Fluxes at h points (W m-2 or kg m-2 s-1) - - integer :: isc, iec, jsc, jec, i, j - real :: dLonDx, dLonDy, rDlon, cosA, sinA, zonal_tau, merid_tau - logical :: overrode_x, overrode_y, overrode_h - - isc = G%isc; iec = G%iec - jsc = G%jsc; jec = G%jec - - overrode_h = .false. - call data_override('OCN', 'hflx_adj', temp_at_h(isc:iec,jsc:jec), Time, override=overrode_h) - - if (overrode_h) then - do j=G%jsc,G%jec ; do i=G%isc,G%iec - fluxes%heat_added(i,j) = fluxes%heat_added(i,j) + temp_at_h(i,j)* G%mask2dT(i,j) - enddo; enddo - endif - - call pass_var(fluxes%heat_added, G%Domain) - - overrode_h = .false. - call data_override('OCN', 'sflx_adj', temp_at_h(isc:iec,jsc:jec), Time, override=overrode_h) - - if (overrode_h) then - do j=G%jsc,G%jec ; do i=G%isc,G%iec - fluxes%salt_flux_added(i,j) = fluxes%salt_flux_added(i,j) + temp_at_h(i,j)* G%mask2dT(i,j) - enddo; enddo - endif - - call pass_var(fluxes%salt_flux_added, G%Domain) - overrode_h = .false. - - call data_override('OCN', 'prcme_adj', temp_at_h(isc:iec,jsc:jec), Time, override=overrode_h) - - if (overrode_h) then - do j=G%jsc,G%jec ; do i=G%isc,G%iec - fluxes%vprec(i,j) = fluxes%vprec(i,j) + temp_at_h(i,j)* G%mask2dT(i,j) - enddo; enddo - endif - - call pass_var(fluxes%vprec, G%Domain) - - - tempx_at_h(:,:) = 0.0 ; tempy_at_h(:,:) = 0.0 - ! Either reads data or leaves contents unchanged - overrode_x = .false. ; overrode_y = .false. - call data_override('OCN', 'taux_adj', tempx_at_h(isc:iec,jsc:jec), Time, override=overrode_x) - call data_override('OCN', 'tauy_adj', tempy_at_h(isc:iec,jsc:jec), Time, override=overrode_y) - - if (overrode_x .or. overrode_y) then - if (.not. (overrode_x .and. overrode_y)) call MOM_error(FATAL,"apply_flux_adjustments: "//& - "Both taux_adj and tauy_adj must be specified, or neither, in data_table") - - ! Rotate winds - call pass_vector(tempx_at_h, tempy_at_h, G%Domain, To_All, AGRID) - do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 - dLonDx = G%geoLonCu(I,j) - G%geoLonCu(I-1,j) - dLonDy = G%geoLonCv(i,J) - G%geoLonCv(i,J-1) - rDlon = sqrt( dLonDx * dLonDx + dLonDy * dLonDy ) - if (rDlon > 0.) rDlon = 1. / rDlon - cosA = dLonDx * rDlon - sinA = dLonDy * rDlon - zonal_tau = tempx_at_h(i,j) - merid_tau = tempy_at_h(i,j) - tempx_at_h(i,j) = cosA * zonal_tau - sinA * merid_tau - tempy_at_h(i,j) = sinA * zonal_tau + cosA * merid_tau - enddo ; enddo - - ! Average to C-grid locations - do j=G%jsc,G%jec ; do I=G%isc-1,G%iec - forces%taux(I,j) = forces%taux(I,j) + 0.5 * ( tempx_at_h(i,j) + tempx_at_h(i+1,j) ) - enddo ; enddo - - do J=G%jsc-1,G%jec ; do i=G%isc,G%iec - forces%tauy(i,J) = forces%tauy(i,J) + 0.5 * ( tempy_at_h(i,j) + tempy_at_h(i,j+1) ) - enddo ; enddo - endif ! overrode_x .or. overrode_y - -end subroutine apply_flux_adjustments +!======================================================================= !> Finalizes MOM6 !! @@ -2426,22 +575,7 @@ subroutine ocn_final_mct( EClock, cdata_o, x2o_o, o2x_o) end subroutine ocn_final_mct -!> Terminates the model run, saving the ocean state in a -!! restart file and deallocating any data associated with the ocean. -subroutine ocean_model_end(Ocean_sfc, Ocean_state, Time) - type(ocean_public_type), intent(inout) :: Ocean_sfc !< An ocean_public_type structure that is to be - !! deallocated upon termination. - type(ocean_state_type), pointer :: Ocean_state!< pointer to the structure containing the internal - ! !! ocean state to be deallocated upon termination. - type(time_type), intent(in) :: Time !< The model time, used for writing restarts. - - call diag_mediator_end(Time, Ocean_state%diag, end_diag_manager=.true.) - ! print time stats - call MOM_infra_end - call MOM_end(Ocean_state%MOM_CSp) - if (Ocean_state%use_ice_shelf) call ice_shelf_end(Ocean_state%Ice_shelf_CSp) - -end subroutine ocean_model_end +!======================================================================= !> Sets mct global segment maps for the MOM decomposition. !! @@ -2451,17 +585,18 @@ subroutine ocn_SetGSMap_mct(mpicom_ocn, MOM_MCT_ID, gsMap_ocn, gsMap3d_ocn) integer, intent(in) :: MOM_MCT_ID !< MCT component ID type(mct_gsMap), intent(inout) :: gsMap_ocn !< MCT global segment map for 2d data type(mct_gsMap), intent(inout) :: gsMap3d_ocn !< MCT global segment map for 3d data + ! Local variables - integer :: lsize !< Local size of indirect indexing array - integer :: i, j, k !< Local indices - integer :: ni, nj !< Declared sizes of h-point arrays - integer :: ig, jg !< Global indices + integer :: lsize !< Local size of indirect indexing array + integer :: i, j, k !< Local indices + integer :: ni, nj !< Declared sizes of h-point arrays + integer :: ig, jg !< Global indices type(ocean_grid_type), pointer :: grid => NULL() !< A pointer to a grid structure integer, allocatable :: gindex(:) !< Indirect indices grid => glb%grid ! for convenience if (.not. associated(grid)) call MOM_error(FATAL, 'ocn_comp_mct.F90, ocn_SetGSMap_mct():' // & - 'grid returned from get_state_pointers() was not associated!') + 'grid is not associated!') ! Size of computational domain lsize = ( grid%iec - grid%isc + 1 ) * ( grid%jec - grid%jsc + 1 ) @@ -2490,6 +625,8 @@ subroutine ocn_SetGSMap_mct(mpicom_ocn, MOM_MCT_ID, gsMap_ocn, gsMap3d_ocn) end subroutine ocn_SetGSMap_mct +!======================================================================= + !> Sets MCT global segment maps for the MOM6 decomposition subroutine ocn_domain_mct( lsize, gsMap_ocn, dom_ocn) integer , intent(in) :: lsize !< Size of attr. vector @@ -2507,8 +644,7 @@ subroutine ocn_domain_mct( lsize, gsMap_ocn, dom_ocn) grid => glb%grid ! for convenience ! set coords to lat and lon, and areas to rad^2 - call mct_gGrid_init(GGrid=dom_ocn, CoordChars=trim(seq_flds_dom_coord), & - OtherChars=trim(seq_flds_dom_other), lsize=lsize ) + call mct_gGrid_init(GGrid=dom_ocn, CoordChars='lat:lon:hgt', OtherChars='area:aream:mask:frac', lsize=lsize ) call mct_avect_zero(dom_ocn%data) allocate(data(lsize)) @@ -2571,6 +707,8 @@ subroutine ocn_domain_mct( lsize, gsMap_ocn, dom_ocn) end subroutine ocn_domain_mct +!======================================================================= + !> Returns the CESM run type character(32) function get_runtype() character(len=32) :: starttype !< infodata start type @@ -2591,6 +729,27 @@ end subroutine ocn_domain_mct end function +!======================================================================= + +!> It has to be separate from the ocean_initialization call because the coupler +!! module allocates the space for some of these variables. +subroutine ocean_model_init_sfc(OS, Ocean_sfc) + type(ocean_state_type), pointer :: OS + type(ocean_public_type), intent(inout) :: Ocean_sfc + + integer :: is, ie, js, je + + is = OS%grid%isc ; ie = OS%grid%iec ; js = OS%grid%jsc ; je = OS%grid%jec + call coupler_type_spawn(Ocean_sfc%fields, OS%sfc_state%tr_fields, & + (/is,is,ie,ie/), (/js,js,je,je/), as_needed=.true.) + + call extract_surface_state(OS%MOM_CSp, OS%sfc_state) + + call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid) + +end subroutine ocean_model_init_sfc + +!======================================================================= !> \namespace ocn_comp_mct !! @@ -2606,7 +765,7 @@ end subroutine ocn_domain_mct !! x2o_Foxx_rof !! !! Variables in MOM6 fluxes that are **NOT** filled by the coupler: -!! ustar_berg, frictional velocity beneath icebergs (m/s) +!! ustar_berg, frictional velocity beneath icebergs [m s-1] !! area_berg, area covered by icebergs(m2/m2) !! mass_berg, mass of icebergs(kg/m2) !! runoff_hflx, heat content of liquid runoff (W/m2) @@ -2614,8 +773,6 @@ end subroutine ocn_domain_mct !! mi, mass of ice (kg/m2) !! !! Variables in the coupler that are **NOT** used in MOM6 (i.e., no corresponding field in fluxes): -!! x2o_Fioi_melth, heat flux from snow & ice melt (W/m2) -!! x2o_Fioi_meltw, snow melt flux (kg/m2/s) !! x2o_Si_ifrac, fractional ice wrt ocean !! x2o_So_duu10n, 10m wind speed squared (m^2/s^2) !! x2o_Sa_co2prog, bottom atm level prognostic CO2 @@ -2645,8 +802,8 @@ end subroutine ocn_domain_mct !! !! Surface temperature (Kelvin) !! Surface salinity (psu) -!! Surface eastward velocity (m/s) -!! Surface northward velocity (m/s) +!! Surface eastward velocity [m s-1] +!! Surface northward velocity [m s-1] !! Zonal slope in the sea surface height !! Meridional slope in the sea surface height !! @@ -2655,6 +812,5 @@ end subroutine ocn_domain_mct !! Boundary layer depth !! CO2 !! DMS -!! o2x_Fioo_q !< Heat flux? end module ocn_comp_mct diff --git a/config_src/mct_driver/ocn_cpl_indices.F90 b/config_src/mct_driver/ocn_cpl_indices.F90 new file mode 100644 index 0000000000..a701083c0c --- /dev/null +++ b/config_src/mct_driver/ocn_cpl_indices.F90 @@ -0,0 +1,192 @@ +module ocn_cpl_indices + + use mct_mod, only: mct_avect_init, mct_avect_indexra, mct_aVect_clean, mct_aVect + use seq_flds_mod, only: ice_ncat, seq_flds_i2o_per_cat + use seq_flds_mod, only: seq_flds_x2o_fields, seq_flds_o2x_fields + + implicit none ; public + + !> Structure with indices needed for MCT attribute vectors + type cpl_indices_type + ! ocean to coupler + integer :: o2x_So_t !< Surface potential temperature (deg C) + integer :: o2x_So_u !< Surface zonal velocity [m s-1] + integer :: o2x_So_v !< Surface meridional velocity [m s-1] + integer :: o2x_So_s !< Surface salinity (PSU) + integer :: o2x_So_dhdx !< Zonal slope in the sea surface height + integer :: o2x_So_dhdy !< Meridional lope in the sea surface height + integer :: o2x_So_bldepth !< Boundary layer depth (m) + integer :: o2x_Fioo_q !< Ocean melt and freeze potential (W/m2) + integer :: o2x_Faoo_fco2_ocn !< CO2 flux + integer :: o2x_Faoo_fdms_ocn !< DMS flux + + ! coupler to ocean + integer :: x2o_Si_ifrac !< Fractional ice wrt ocean + integer :: x2o_So_duu10n !< 10m wind speed squared (m^2/s^2) + integer :: x2o_Sa_pslv !< Sea-level pressure (Pa) + integer :: x2o_Sa_co2prog !< Bottom atm level prognostic CO2 + integer :: x2o_Sa_co2diag !< Bottom atm level diagnostic CO2 + integer :: x2o_Sw_lamult !< Wave model langmuir multiplier + integer :: x2o_Sw_ustokes !< Surface Stokes drift, x-component + integer :: x2o_Sw_vstokes !< Surface Stokes drift, y-component + integer :: x2o_Foxx_taux !< Zonal wind stress (W/m2) + integer :: x2o_Foxx_tauy !< Meridonal wind stress (W/m2) + integer :: x2o_Foxx_swnet !< Net short-wave heat flux (W/m2) + integer :: x2o_Foxx_sen !< Sensible heat flux (W/m2) + integer :: x2o_Foxx_lat !< Latent heat flux (W/m2) + integer :: x2o_Foxx_lwup !< Longwave radiation, up (W/m2) + integer :: x2o_Faxa_lwdn !< Longwave radiation, down (W/m2) + integer :: x2o_Faxa_swvdr !< Visible, direct shortwave (W/m2) + integer :: x2o_Faxa_swvdf !< Visible, diffuse shortwave (W/m2) + integer :: x2o_Faxa_swndr !< near-IR, direct shortwave (W/m2) + integer :: x2o_Faxa_swndf !< near-IR, direct shortwave (W/m2) + integer :: x2o_Fioi_melth !< Heat flux from snow & ice melt (W/m2) + integer :: x2o_Fioi_meltw !< Water flux from sea ice and snow melt (kg/m2/s) + integer :: x2o_Fioi_bcpho !< Black Carbon hydrophobic release from sea ice component + integer :: x2o_Fioi_bcphi !< Black Carbon hydrophilic release from sea ice component + integer :: x2o_Fioi_flxdst !< Dust release from sea ice component + integer :: x2o_Fioi_salt !< Salt flux (kg(salt)/m2/s) + integer :: x2o_Foxx_evap !< Evaporation flux (kg/m2/s) + integer :: x2o_Faxa_prec !< Total precipitation flux (kg/m2/s) + integer :: x2o_Faxa_snow !< Water flux due to snow (kg/m2/s) + integer :: x2o_Faxa_rain !< Water flux due to rain (kg/m2/s) + integer :: x2o_Faxa_bcphidry !< Black Carbon hydrophilic dry deposition + integer :: x2o_Faxa_bcphodry !< Black Carbon hydrophobic dry deposition + integer :: x2o_Faxa_bcphiwet !< Black Carbon hydrophilic wet deposition + integer :: x2o_Faxa_ocphidry !< Organic Carbon hydrophilic dry deposition + integer :: x2o_Faxa_ocphodry !< Organic Carbon hydrophobic dry deposition + integer :: x2o_Faxa_ocphiwet !< Organic Carbon hydrophilic dry deposition + integer :: x2o_Faxa_dstwet1 !< Size 1 dust -- wet deposition + integer :: x2o_Faxa_dstwet2 !< Size 2 dust -- wet deposition + integer :: x2o_Faxa_dstwet3 !< Size 3 dust -- wet deposition + integer :: x2o_Faxa_dstwet4 !< Size 4 dust -- wet deposition + integer :: x2o_Faxa_dstdry1 !< Size 1 dust -- dry deposition + integer :: x2o_Faxa_dstdry2 !< Size 2 dust -- dry deposition + integer :: x2o_Faxa_dstdry3 !< Size 3 dust -- dry deposition + integer :: x2o_Faxa_dstdry4 !< Size 4 dust -- dry deposition + integer :: x2o_Foxx_rofl !< River runoff flux (kg/m2/s) + integer :: x2o_Foxx_rofi !< Ice runoff flux (kg/m2/s) + + ! optional per thickness category fields + integer, dimension(:), allocatable :: x2o_frac_col !< Fraction of ocean cell, per column + integer, dimension(:), allocatable :: x2o_fracr_col !< Fraction of ocean cell used in radiation computations, + !! per column + integer, dimension(:), allocatable :: x2o_qsw_fracr_col !< qsw * fracr, per column + end type cpl_indices_type + + public :: cpl_indices_init + +!======================================================================= +contains +!======================================================================= + + !> Determines attribute vector indices + subroutine cpl_indices_init(ind) + type(cpl_indices_type), intent(inout) :: ind !< Structure with coupler indices and vectors + + ! Local Variables + type(mct_aVect) :: o2x !< Array with ocean to coupler data + type(mct_aVect) :: x2o !< Array with coupler to ocean data + integer :: ncat !< Thickness category index + character(len=2) :: cncat !< Character version of ncat + integer :: ncol !< Column index + integer :: mcog_ncols !< Number of ice thickness categories? + integer :: lmcog_flds_sent !< Used to convert per thickness category fields? + + ! create temporary attribute vectors + call mct_aVect_init(x2o, rList=seq_flds_x2o_fields, lsize=1) + call mct_aVect_init(o2x, rList=seq_flds_o2x_fields, lsize=1) + + ! ocean to coupler + ind%o2x_So_t = mct_avect_indexra(o2x,'So_t') + ind%o2x_So_u = mct_avect_indexra(o2x,'So_u') + ind%o2x_So_v = mct_avect_indexra(o2x,'So_v') + ind%o2x_So_s = mct_avect_indexra(o2x,'So_s') + ind%o2x_So_dhdx = mct_avect_indexra(o2x,'So_dhdx') + ind%o2x_So_dhdy = mct_avect_indexra(o2x,'So_dhdy') + ind%o2x_So_bldepth = mct_avect_indexra(o2x,'So_bldepth') + ind%o2x_Fioo_q = mct_avect_indexra(o2x,'Fioo_q') + ind%o2x_Faoo_fco2_ocn = mct_avect_indexra(o2x,'Faoo_fco2_ocn',perrWith='quiet') + ind%o2x_Faoo_fdms_ocn = mct_avect_indexra(o2x,'Faoo_fdms_ocn',perrWith='quiet') + + ! coupler to ocean + ind%x2o_Si_ifrac = mct_avect_indexra(x2o,'Si_ifrac') + ind%x2o_Sa_pslv = mct_avect_indexra(x2o,'Sa_pslv') + ind%x2o_So_duu10n = mct_avect_indexra(x2o,'So_duu10n') + ind%x2o_Sw_lamult = mct_avect_indexra(x2o,'Sw_lamult') + ind%x2o_Sw_ustokes = mct_avect_indexra(x2o,'Sw_ustokes') + ind%x2o_Sw_vstokes = mct_avect_indexra(x2o,'Sw_vstokes') + ind%x2o_Foxx_tauy = mct_avect_indexra(x2o,'Foxx_tauy') + ind%x2o_Foxx_taux = mct_avect_indexra(x2o,'Foxx_taux') + ind%x2o_Foxx_swnet = mct_avect_indexra(x2o,'Foxx_swnet') + ind%x2o_Foxx_lat = mct_avect_indexra(x2o,'Foxx_lat') + ind%x2o_Foxx_sen = mct_avect_indexra(x2o,'Foxx_sen') + ind%x2o_Foxx_lwup = mct_avect_indexra(x2o,'Foxx_lwup') + ind%x2o_Faxa_lwdn = mct_avect_indexra(x2o,'Faxa_lwdn') + ind%x2o_Faxa_swvdr = mct_avect_indexra(x2o,'Faxa_swvdr',perrWith='quiet') + ind%x2o_Faxa_swvdf = mct_avect_indexra(x2o,'Faxa_swvdf',perrWith='quiet') + ind%x2o_Faxa_swndr = mct_avect_indexra(x2o,'Faxa_swndr',perrWith='quiet') + ind%x2o_Faxa_swndf = mct_avect_indexra(x2o,'Faxa_swndf',perrWith='quiet') + ind%x2o_Fioi_melth = mct_avect_indexra(x2o,'Fioi_melth') + ind%x2o_Fioi_meltw = mct_avect_indexra(x2o,'Fioi_meltw') + ind%x2o_Fioi_salt = mct_avect_indexra(x2o,'Fioi_salt') + ind%x2o_Fioi_bcpho = mct_avect_indexra(x2o,'Fioi_bcpho') + ind%x2o_Fioi_bcphi = mct_avect_indexra(x2o,'Fioi_bcphi') + ind%x2o_Fioi_flxdst = mct_avect_indexra(x2o,'Fioi_flxdst') + ind%x2o_Faxa_prec = mct_avect_indexra(x2o,'Faxa_prec') + ind%x2o_Faxa_snow = mct_avect_indexra(x2o,'Faxa_snow') + ind%x2o_Faxa_rain = mct_avect_indexra(x2o,'Faxa_rain') + ind%x2o_Foxx_evap = mct_avect_indexra(x2o,'Foxx_evap') + ind%x2o_Foxx_rofl = mct_avect_indexra(x2o,'Foxx_rofl') + ind%x2o_Foxx_rofi = mct_avect_indexra(x2o,'Foxx_rofi') + ind%x2o_Faxa_bcphidry = mct_avect_indexra(x2o,'Faxa_bcphidry') + ind%x2o_Faxa_bcphodry = mct_avect_indexra(x2o,'Faxa_bcphodry') + ind%x2o_Faxa_bcphiwet = mct_avect_indexra(x2o,'Faxa_bcphiwet') + ind%x2o_Faxa_ocphidry = mct_avect_indexra(x2o,'Faxa_ocphidry') + ind%x2o_Faxa_ocphodry = mct_avect_indexra(x2o,'Faxa_ocphodry') + ind%x2o_Faxa_ocphiwet = mct_avect_indexra(x2o,'Faxa_ocphiwet') + ind%x2o_Faxa_dstdry1 = mct_avect_indexra(x2o,'Faxa_dstdry1') + ind%x2o_Faxa_dstdry2 = mct_avect_indexra(x2o,'Faxa_dstdry2') + ind%x2o_Faxa_dstdry3 = mct_avect_indexra(x2o,'Faxa_dstdry3') + ind%x2o_Faxa_dstdry4 = mct_avect_indexra(x2o,'Faxa_dstdry4') + ind%x2o_Faxa_dstwet1 = mct_avect_indexra(x2o,'Faxa_dstwet1') + ind%x2o_Faxa_dstwet2 = mct_avect_indexra(x2o,'Faxa_dstwet2') + ind%x2o_Faxa_dstwet3 = mct_avect_indexra(x2o,'Faxa_dstwet3') + ind%x2o_Faxa_dstwet4 = mct_avect_indexra(x2o,'Faxa_dstwet4') + ind%x2o_Sa_co2prog = mct_avect_indexra(x2o,'Sa_co2prog',perrWith='quiet') + ind%x2o_Sa_co2diag = mct_avect_indexra(x2o,'Sa_co2diag',perrWith='quiet') + + ! optional per thickness category fields + ! convert cpl indices to mcog column indices + ! this implementation only handles columns due to ice thickness categories + lmcog_flds_sent = seq_flds_i2o_per_cat + + if (seq_flds_i2o_per_cat) then + mcog_ncols = ice_ncat+1 + allocate(ind%x2o_frac_col(mcog_ncols)) + allocate(ind%x2o_fracr_col(mcog_ncols)) + allocate(ind%x2o_qsw_fracr_col(mcog_ncols)) + ncol = 1 + ind%x2o_frac_col(ncol) = mct_avect_indexra(x2o,'Sf_afrac') + ind%x2o_fracr_col(ncol) = mct_avect_indexra(x2o,'Sf_afracr') + ind%x2o_qsw_fracr_col(ncol) = mct_avect_indexra(x2o,'Foxx_swnet_afracr') + + do ncat = 1, ice_ncat + write(cncat,'(i2.2)') ncat + ncol = ncat+1 + ind%x2o_frac_col(ncol) = mct_avect_indexra(x2o,'Si_ifrac_'//cncat) + ind%x2o_fracr_col(ncol) = ind%x2o_frac_col(ncol) + ind%x2o_qsw_fracr_col(ncol) = mct_avect_indexra(x2o,'PFioi_swpen_ifrac_'//cncat) + enddo + else + mcog_ncols = 1 + endif + + call mct_aVect_clean(x2o) + call mct_aVect_clean(o2x) + + end subroutine cpl_indices_init + +!======================================================================= + +end module ocn_cpl_indices diff --git a/config_src/solo_driver/MESO_surface_forcing.F90 b/config_src/solo_driver/MESO_surface_forcing.F90 index 513358932e..28dc5305f1 100644 --- a/config_src/solo_driver/MESO_surface_forcing.F90 +++ b/config_src/solo_driver/MESO_surface_forcing.F90 @@ -1,50 +1,10 @@ +!> Sets forcing for the MESO configuration module MESO_surface_forcing ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* Rewritten by Robert Hallberg, June 2009 * -!* * -!* This file contains the subroutines that a user should modify to * -!* to set the surface wind stresses and fluxes of buoyancy or * -!* temperature and fresh water. They are called when the run-time * -!* parameters WIND_CONFIG or BUOY_CONFIG are set to "USER". The * -!* standard version has simple examples, along with run-time error * -!* messages that will cause the model to abort if this code has not * -!* been modified. This code is intended for use with relatively * -!* simple specifications of the forcing. For more complicated forms, * -!* it is probably a good idea to read the forcing from input files * -!* using "file" for WIND_CONFIG and BUOY_CONFIG. * -!* * -!* MESO_wind_forcing should set the surface wind stresses (taux and * -!* tauy) perhaps along with the surface friction velocity (ustar). * -!* * -!* MESO_buoyancy forcing is used to set the surface buoyancy * -!* forcing, which may include a number of fresh water flux fields * -!* (evap, liq_precip, froz_precip, liq_runoff, froz_runoff, and * -!* vprec) and the surface heat fluxes (sw, lw, latent and sens) * -!* if temperature and salinity are state variables, or it may simply * -!* be the buoyancy flux if it is not. This routine also has coded a * -!* restoring to surface values of temperature and salinity. * -!* * -!* Macros written all in capital letters are defined in MOM_memory.h. * -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q * -!* j+1 > o > o > At ^: v, tauy * -!* j x ^ x ^ x At >: u, taux * -!* j > o > o > At o: h, fluxes. * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** use MOM_diag_mediator, only : post_data, query_averaging_enabled -use MOM_diag_mediator, only : register_diag_field, diag_ctrl +use MOM_diag_mediator, only : register_diag_field, diag_ctrl, safe_alloc_ptr use MOM_domains, only : pass_var, pass_vector, AGRID use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type @@ -52,127 +12,58 @@ module MESO_surface_forcing use MOM_forcing_type, only : allocate_forcing_type, allocate_mech_forcing use MOM_grid, only : ocean_grid_type use MOM_io, only : file_exists, MOM_read_data, slasher -use MOM_time_manager, only : time_type, operator(+), operator(/), get_time +use MOM_time_manager, only : time_type, operator(+), operator(/) use MOM_tracer_flow_control, only : call_tracer_set_forcing use MOM_tracer_flow_control, only : tracer_flow_control_CS use MOM_variables, only : surface implicit none ; private -public MESO_wind_forcing, MESO_buoyancy_forcing, MESO_surface_forcing_init +public MESO_buoyancy_forcing, MESO_surface_forcing_init +!> This control structure is used to store parameters associated with the MESO forcing. type, public :: MESO_surface_forcing_CS ; private - ! This control structure should be used to store any run-time variables - ! associated with the user-specified forcing. It can be readily modified - ! for a specific case, and because it is private there will be no changes - ! needed in other code (although they will have to be recompiled). - ! The variables in the cannonical example are used for some common - ! cases, but do not need to be used. - - logical :: use_temperature ! If true, temperature and salinity are used as - ! state variables. - logical :: restorebuoy ! If true, use restoring surface buoyancy forcing. - real :: Rho0 ! The density used in the Boussinesq - ! approximation, in kg m-3. - real :: G_Earth ! The gravitational acceleration in m s-2. - real :: Flux_const ! The restoring rate at the surface, in m s-1. - real :: gust_const ! A constant unresolved background gustiness - ! that contributes to ustar, in Pa. + + logical :: use_temperature !< If true, temperature and salinity are used as state variables. + logical :: restorebuoy !< If true, use restoring surface buoyancy forcing. + real :: Rho0 !< The density used in the Boussinesq approximation [kg m-3]. + real :: G_Earth !< The gravitational acceleration [m s-2]. + real :: Flux_const !< The restoring rate at the surface [m s-1]. + real :: gust_const !< A constant unresolved background gustiness + !! that contributes to ustar [Pa]. real, dimension(:,:), pointer :: & - T_Restore(:,:) => NULL(), & ! The temperature to restore the SST to, in C. - S_Restore(:,:) => NULL(), & ! The salinity to restore the sea surface salnity - ! toward, in PSU. - PmE(:,:) => NULL(), & ! The prescribed precip minus evap, in m s-1. - Solar(:,:) => NULL(), & ! The shortwave forcing into the ocean, in W m-2 m s-1. - Heat(:,:) => NULL() ! The prescribed longwave, latent and sensible - ! heat flux into the ocean, in W m-2. - character(len=200) :: inputdir ! The directory where NetCDF input files are. - character(len=200) :: salinityrestore_file, SSTrestore_file - character(len=200) :: Solar_file, heating_file, PmE_file - type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the - ! timing of diagnostic output. + T_Restore(:,:) => NULL(), & !< The temperature to restore the SST toward [degC]. + S_Restore(:,:) => NULL(), & !< The salinity to restore the sea surface salnity toward [ppt] + PmE(:,:) => NULL(), & !< The prescribed precip minus evap [m s-1]. + Solar(:,:) => NULL() !< The shortwave forcing into the ocean [W m-2]. + real, dimension(:,:), pointer :: Heat(:,:) => NULL() !< The prescribed longwave, latent and sensible + !! heat flux into the ocean [W m-2]. + character(len=200) :: inputdir !< The directory where NetCDF input files are. + character(len=200) :: salinityrestore_file !< The file with the target sea surface salinity + character(len=200) :: SSTrestore_file !< The file with the target sea surface temperature + character(len=200) :: Solar_file !< The file with the shortwave forcing + character(len=200) :: heating_file !< The file with the longwave, latent, and sensible heating + character(len=200) :: PmE_file !< The file with precipitation minus evaporation + type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the + !! timing of diagnostic output. end type MESO_surface_forcing_CS -logical :: first_call = .true. +logical :: first_call = .true. !< True until after the first call to the MESO forcing routines contains -subroutine MESO_wind_forcing(sfc_state, forces, day, G, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(MESO_surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a previous - !! call to MESO_surface_forcing_init - -! This subroutine sets the surface wind stresses, forces%taux and forces%tauy. -! These are the stresses in the direction of the model grid (i.e. the same -! direction as the u- and v- velocities.) They are both in Pa. -! In addition, this subroutine can be used to set the surface friction -! velocity, forces%ustar, in m s-1. This is needed with a bulk mixed layer. -! -! Arguments: state - A structure containing fields that describe the -! surface state of the ocean. -! (out) fluxes - A structure containing pointers to any possible -! forcing fields. Unused fields have NULL ptrs. -! (in) day - Time of the fluxes. -! (in) G - The ocean's grid structure. -! (in) CS - A pointer to the control structure returned by a previous -! call to MESO_surface_forcing_init - - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - - ! When modifying the code, comment out this error message. It is here - ! so that the original (unmodified) version is not accidentally used. - call MOM_error(FATAL, "MESO_wind_surface_forcing: " // & - "User forcing routine called without modification." ) - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - - ! Allocate the forcing arrays, if necessary. - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true.) - - ! Set the surface wind stresses, in units of Pa. A positive taux - ! accelerates the ocean to the (pseudo-)east. - - ! The i-loop extends to is-1 so that taux can be used later in the - ! calculation of ustar - otherwise the lower bound would be Isq. - do j=js,je ; do I=is-1,Ieq - forces%taux(I,j) = G%mask2dCu(I,j) * 0.0 ! Change this to the desired expression. - enddo ; enddo - do J=js-1,Jeq ; do i=is,ie - forces%tauy(i,J) = G%mask2dCv(i,J) * 0.0 ! Change this to the desired expression. - enddo ; enddo - - ! Set the surface friction velocity, in units of m s-1. ustar - ! is always positive. - if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie - ! This expression can be changed if desired, but need not be. - forces%ustar(i,j) = G%mask2dT(i,j) * sqrt(CS%gust_const/CS%Rho0 + & - sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & - 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))/CS%Rho0) - enddo ; enddo ; endif - -end subroutine MESO_wind_forcing - +!> This subroutine sets up the MESO buoyancy forcing, which uses control-theory style +!! specification restorative buoyancy fluxes at large scales. subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. - type(forcing), intent(inout) :: fluxes - type(time_type), intent(in) :: day + type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields + type(time_type), intent(in) :: day !< The time of the fluxes real, intent(in) :: dt !< The amount of time over which - !! the fluxes apply, in s + !! the fluxes apply [s] type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(MESO_surface_forcing_CS), pointer :: CS - -! This subroutine specifies the current surface fluxes of buoyancy or -! temperature and fresh water. It may also be modified to add -! surface fluxes of user provided tracers. + type(MESO_surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by + !! a previous call to MESO_surface_forcing_init ! When temperature is used, there are long list of fluxes that need to be ! set - essentially the same as for a full coupled model, but most of these @@ -184,24 +75,13 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) ! are in W m-2 and positive for heat going into the ocean. All fresh water ! fluxes are in kg m-2 s-1 and positive for water moving into the ocean. -! Arguments: state - A structure containing fields that describe the -! surface state of the ocean. -! (out) fluxes - A structure containing pointers to any possible -! forcing fields. Unused fields have NULL ptrs. -! (in) day_start - Start time of the fluxes. -! (in) day_interval - Length of time over which these fluxes -! will be applied. -! (in) G - The ocean's grid structure. -! (in) CS - A pointer to the control structure returned by a previous -! call to MESO_surface_forcing_init - - real :: Temp_restore ! The temperature that is being restored toward, in C. - real :: Salin_restore ! The salinity that is being restored toward, in PSU. + real :: Temp_restore ! The temperature that is being restored toward [degC]. + real :: Salin_restore ! The salinity that is being restored toward [ppt] real :: density_restore ! The potential density that is being restored - ! toward, in kg m-3. - real :: rhoXcp ! The mean density times the heat capacity, in J m-3 K-1. + ! toward [kg m-3]. + real :: rhoXcp ! The mean density times the heat capacity [J m-3 degC-1]. real :: buoy_rest_const ! A constant relating density anomalies to the - ! restoring buoyancy flux, in m5 s-3 kg-1. + ! restoring buoyancy flux [m5 s-3 kg-1]. integer :: i, j, is, ie, js, je integer :: isd, ied, jsd, jed @@ -215,30 +95,30 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) ! Allocate and zero out the forcing arrays, as necessary. This portion is ! usually not changed. if (CS%use_temperature) then - call alloc_if_needed(fluxes%evap, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%lprec, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%fprec, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%lrunoff, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%frunoff, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%vprec, isd, ied, jsd, jed) - - call alloc_if_needed(fluxes%sw, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%lw, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%latent, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%sens, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%heat_content_lprec, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%evap, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%lprec, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%fprec, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%lrunoff, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%frunoff, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%vprec, isd, ied, jsd, jed) + + call safe_alloc_ptr(fluxes%sw, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%lw, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%latent, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%sens, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%heat_content_lprec, isd, ied, jsd, jed) else ! This is the buoyancy only mode. - call alloc_if_needed(fluxes%buoy, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%buoy, isd, ied, jsd, jed) endif ! MODIFY THE CODE IN THE FOLLOWING LOOPS TO SET THE BUOYANCY FORCING TERMS. if (CS%restorebuoy .and. first_call) then !### .or. associated(CS%ctrl_forcing_CSp)) then - call alloc_if_needed(CS%T_Restore, isd, ied, jsd, jed) - call alloc_if_needed(CS%S_Restore, isd, ied, jsd, jed) - call alloc_if_needed(CS%Heat, isd, ied, jsd, jed) - call alloc_if_needed(CS%PmE, isd, ied, jsd, jed) - call alloc_if_needed(CS%Solar, isd, ied, jsd, jed) + call safe_alloc_ptr(CS%T_Restore, isd, ied, jsd, jed) + call safe_alloc_ptr(CS%S_Restore, isd, ied, jsd, jed) + call safe_alloc_ptr(CS%Heat, isd, ied, jsd, jed) + call safe_alloc_ptr(CS%PmE, isd, ied, jsd, jed) + call safe_alloc_ptr(CS%Solar, isd, ied, jsd, jed) call MOM_read_data(trim(CS%inputdir)//trim(CS%SSTrestore_file), "SST", & CS%T_Restore(:,:), G%Domain) @@ -257,7 +137,7 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) ! Set whichever fluxes are to be used here. Any fluxes that ! are always zero do not need to be changed here. do j=js,je ; do i=is,ie - ! Fluxes of fresh water through the surface are in units of kg m-2 s-1 + ! Fluxes of fresh water through the surface are in units of [kg m-2 s-1] ! and are positive downward - i.e. evaporation should be negative. fluxes%evap(i,j) = -0.0 * G%mask2dT(i,j) fluxes%lprec(i,j) = CS%PmE(i,j) * CS%Rho0 * G%mask2dT(i,j) @@ -265,7 +145,7 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) ! vprec will be set later, if it is needed for salinity restoring. fluxes%vprec(i,j) = 0.0 - ! Heat fluxes are in units of W m-2 and are positive into the ocean. + ! Heat fluxes are in units of [W m-2] and are positive into the ocean. fluxes%lw(i,j) = 0.0 * G%mask2dT(i,j) fluxes%latent(i,j) = 0.0 * G%mask2dT(i,j) fluxes%sens(i,j) = CS%Heat(i,j) * G%mask2dT(i,j) @@ -273,7 +153,7 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) enddo ; enddo else ! This is the buoyancy only mode. do j=js,je ; do i=is,ie - ! fluxes%buoy is the buoyancy flux into the ocean in m2 s-3. A positive + ! fluxes%buoy is the buoyancy flux into the ocean [m2 s-3]. A positive ! buoyancy flux is of the same sign as heating the ocean. fluxes%buoy(i,j) = 0.0 * G%mask2dT(i,j) enddo ; enddo @@ -281,7 +161,7 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) if (CS%restorebuoy) then if (CS%use_temperature) then - call alloc_if_needed(fluxes%heat_added, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%heat_added, isd, ied, jsd, jed) ! When modifying the code, comment out this error message. It is here ! so that the original (unmodified) version is not accidentally used. ! call MOM_error(FATAL, "MESO_buoyancy_surface_forcing: " // & @@ -289,8 +169,8 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) rhoXcp = CS%Rho0 * fluxes%C_p do j=js,je ; do i=is,ie - ! Set Temp_restore and Salin_restore to the temperature (in C) and - ! salinity (in PSU) that are being restored toward. + ! Set Temp_restore and Salin_restore to the temperature (in degC) and + ! salinity (in ppt or PSU) that are being restored toward. if (G%mask2dT(i,j) > 0) then fluxes%heat_added(i,j) = G%mask2dT(i,j) * & ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * CS%Flux_const) @@ -312,7 +192,7 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) buoy_rest_const = -1.0 * (CS%G_Earth * CS%Flux_const) / CS%Rho0 do j=js,je ; do i=is,ie ! Set density_restore to an expression for the surface potential - ! density in kg m-3 that is being restored toward. + ! density [kg m-3] that is being restored toward. density_restore = 1030.0 fluxes%buoy(i,j) = G%mask2dT(i,j) * buoy_rest_const * & @@ -323,31 +203,15 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) end subroutine MESO_buoyancy_forcing -subroutine alloc_if_needed(ptr, isd, ied, jsd, jed) - ! If ptr is not associated, this routine allocates it with the given size - ! and zeros out its contents. This is equivalent to safe_alloc_ptr in - ! MOM_diag_mediator, but is here so as to be completely transparent. - real, pointer :: ptr(:,:) - integer :: isd, ied, jsd, jed - if (.not.associated(ptr)) then - allocate(ptr(isd:ied,jsd:jed)) - ptr(:,:) = 0.0 - endif -end subroutine alloc_if_needed - +!> Initialize the MESO surface forcing module subroutine MESO_surface_forcing_init(Time, G, param_file, diag, CS) - type(time_type), intent(in) :: Time - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(diag_ctrl), target, intent(in) :: diag - type(MESO_surface_forcing_CS), pointer :: CS -! Arguments: Time - The current model time. -! (in) G - The ocean's grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in) diag - A structure that is used to regulate diagnostic output. -! (in/out) CS - A pointer that is set to point to the control structure -! for this module + + type(time_type), intent(in) :: Time !< The current model time + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(diag_ctrl), target, intent(inout) :: diag !< structure used to regulate diagnostic output + type(MESO_surface_forcing_CS), pointer :: CS !< A pointer that is set to point to the + !! control structure for this module ! This include declares and sets the variable "version". #include "version_variable.h" @@ -416,4 +280,27 @@ subroutine MESO_surface_forcing_init(Time, G, param_file, diag, CS) end subroutine MESO_surface_forcing_init +!> \namespace meso_surface_forcing +!! +!! Rewritten by Robert Hallberg, June 2009 +!! +!! This file contains the subroutines that a user should modify to +!! to set the surface wind stresses and fluxes of buoyancy or +!! temperature and fresh water. They are called when the run-time +!! parameters WIND_CONFIG or BUOY_CONFIG are set to "USER". The +!! standard version has simple examples, along with run-time error +!! messages that will cause the model to abort if this code has not +!! been modified. This code is intended for use with relatively +!! simple specifications of the forcing. For more complicated forms, +!! it is probably a good idea to read the forcing from input files +!! using "file" for WIND_CONFIG and BUOY_CONFIG. +!! +!! MESO_buoyancy forcing is used to set the surface buoyancy +!! forcing, which may include a number of fresh water flux fields +!! (evap, liq_precip, froz_precip, liq_runoff, froz_runoff, and +!! vprec) and the surface heat fluxes (sw, lw, latent and sens) +!! if temperature and salinity are state variables, or it may simply +!! be the buoyancy flux if it is not. This routine also has coded a +!! restoring to surface values of temperature and salinity. + end module MESO_surface_forcing diff --git a/config_src/solo_driver/MOM_driver.F90 b/config_src/solo_driver/MOM_driver.F90 index c2ac628909..14890af0f8 100644 --- a/config_src/solo_driver/MOM_driver.F90 +++ b/config_src/solo_driver/MOM_driver.F90 @@ -48,13 +48,15 @@ program MOM_main use MOM_string_functions,only : uppercase use MOM_surface_forcing, only : set_forcing, forcing_save_restart use MOM_surface_forcing, only : surface_forcing_init, surface_forcing_CS - use MOM_time_manager, only : time_type, set_date, set_time, get_date, time_type_to_real + use MOM_time_manager, only : time_type, set_date, get_date + use MOM_time_manager, only : real_to_time, time_type_to_real use MOM_time_manager, only : operator(+), operator(-), operator(*), operator(/) use MOM_time_manager, only : operator(>), operator(<), operator(>=) use MOM_time_manager, only : increment_date, set_calendar_type, month_name use MOM_time_manager, only : JULIAN, GREGORIAN, NOLEAP, THIRTY_DAY_MONTHS use MOM_time_manager, only : NO_CALENDAR use MOM_tracer_flow_control, only : tracer_flow_control_CS + use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type use MOM_write_cputime, only : write_cputime, MOM_write_cputime_init @@ -66,7 +68,7 @@ program MOM_main use time_interp_external_mod, only : time_interp_external_init use MOM_ice_shelf, only : initialize_ice_shelf, ice_shelf_end, ice_shelf_CS - use MOM_ice_shelf, only : shelf_calc_flux, ice_shelf_save_restart + use MOM_ice_shelf, only : shelf_calc_flux, add_shelf_forces, ice_shelf_save_restart ! , add_shelf_flux_forcing, add_shelf_flux_IOB use MOM_wave_interface, only: wave_parameters_CS, MOM_wave_interface_init @@ -88,6 +90,8 @@ program MOM_main ! A pointer to a structure containing metrics and related information. type(ocean_grid_type), pointer :: grid type(verticalGrid_type), pointer :: GV + ! A pointer to a structure containing dimensional unit scaling factors. + type(unit_scale_type), pointer :: US ! If .true., use the ice shelf model for part of the domain. logical :: use_ice_shelf @@ -104,7 +108,7 @@ program MOM_main ! simulation does not exceed its CPU time limit. nmax is determined by ! evaluating the CPU time used between successive calls to write_cputime. ! Initially it is set to be very large. - integer :: nmax=2000000000; + integer :: nmax=2000000000 ! A structure containing several relevant directory paths. type(directories) :: dirs @@ -123,21 +127,21 @@ program MOM_main type(time_type) :: restart_time ! The next time to write restart files. type(time_type) :: Time_step_ocean ! A time_type version of dt_forcing. - real :: elapsed_time = 0.0 ! Elapsed time in this run in seconds. + real :: elapsed_time = 0.0 ! Elapsed time in this run [s]. logical :: elapsed_time_master ! If true, elapsed time is used to set the ! model's master clock (Time). This is needed ! if Time_step_ocean is not an exact ! representation of dt_forcing. - real :: dt_forcing ! The coupling time step in seconds. - real :: dt ! The baroclinic dynamics time step, in seconds. - real :: dt_off ! Offline time step in seconds + real :: dt_forcing ! The coupling time step [s]. + real :: dt ! The baroclinic dynamics time step [s]. + real :: dt_off ! Offline time step [s]. integer :: ntstep ! The number of baroclinic dynamics time steps ! within dt_forcing. real :: dt_therm real :: dt_dyn, dtdia, t_elapsed_seg integer :: n, n_max, nts, n_last_thermo logical :: diabatic_first, single_step_call - type(time_type) :: Time2 + type(time_type) :: Time2, time_chg integer :: Restart_control ! An integer that is bit-tested to determine whether ! incremental restart files are saved and whether they @@ -146,7 +150,7 @@ program MOM_main ! restart file is saved at the end of a run segment ! unless Restart_control is negative. - real :: Time_unit ! The time unit in seconds for the following input fields. + real :: Time_unit ! The time unit for the following input fields [s]. type(time_type) :: restint ! The time between saves of the restart file. type(time_type) :: daymax ! The final day of the simulation. @@ -246,8 +250,8 @@ program MOM_main endif !$ call omp_set_num_threads(ocean_nthreads) -!$OMP PARALLEL private(adder) !$ base_cpu = get_cpu_affinity() +!$OMP PARALLEL private(adder) !$ if (use_hyper_thread) then !$ if (mod(omp_get_thread_num(),2) == 0) then !$ adder = omp_get_thread_num()/2 @@ -258,7 +262,7 @@ program MOM_main !$ adder = omp_get_thread_num() !$ endif !$ call set_cpu_affinity (base_cpu + adder) -!$ write(6,*) " ocean ", omp_get_num_threads(), get_cpu_affinity(), adder, omp_get_thread_num() +!$ write(6,*) " ocean ", base_cpu, get_cpu_affinity(), adder, omp_get_thread_num(), omp_get_num_threads() !$ call flush(6) !$OMP END PARALLEL @@ -273,11 +277,11 @@ program MOM_main else calendar = uppercase(calendar) if (calendar(1:6) == 'JULIAN') then ; calendar_type = JULIAN - else if (calendar(1:9) == 'GREGORIAN') then ; calendar_type = GREGORIAN - else if (calendar(1:6) == 'NOLEAP') then ; calendar_type = NOLEAP - else if (calendar(1:10)=='THIRTY_DAY') then ; calendar_type = THIRTY_DAY_MONTHS - else if (calendar(1:11)=='NO_CALENDAR') then; calendar_type = NO_CALENDAR - else if (calendar(1:1) /= ' ') then + elseif (calendar(1:9) == 'GREGORIAN') then ; calendar_type = GREGORIAN + elseif (calendar(1:6) == 'NOLEAP') then ; calendar_type = NOLEAP + elseif (calendar(1:10)=='THIRTY_DAY') then ; calendar_type = THIRTY_DAY_MONTHS + elseif (calendar(1:11)=='NO_CALENDAR') then; calendar_type = NO_CALENDAR + elseif (calendar(1:1) /= ' ') then call MOM_error(FATAL,'MOM_driver: Invalid namelist value '//trim(calendar)//' for calendar') else call MOM_error(FATAL,'MOM_driver: No namelist value for calendar') @@ -290,7 +294,7 @@ program MOM_main Start_time = set_date(date_init(1),date_init(2), date_init(3), & date_init(4),date_init(5),date_init(6)) else - Start_time = set_time(0,days=0) + Start_time = real_to_time(0.0) endif call time_interp_external_init @@ -311,14 +315,14 @@ program MOM_main tracer_flow_CSp=tracer_flow_CSp) endif - call get_MOM_state_elements(MOM_CSp, G=grid, GV=GV, C_p=fluxes%C_p) + call get_MOM_state_elements(MOM_CSp, G=grid, GV=GV, US=US, C_p=fluxes%C_p) Master_Time = Time call callTree_waypoint("done initialize_MOM") call extract_surface_state(MOM_CSp, sfc_state) - call surface_forcing_init(Time, grid, param_file, diag, & + call surface_forcing_init(Time, grid, US, param_file, diag, & surface_forcing_CSp, tracer_flow_CSp) call callTree_waypoint("done surface_forcing_init") @@ -334,7 +338,7 @@ program MOM_main call get_param(param_file,mod_name,"USE_WAVES",Use_Waves,& "If true, enables surface wave modules.",default=.false.) if (use_waves) then - call MOM_wave_interface_init(Time,grid,GV,param_file,Waves_CSp,diag) + call MOM_wave_interface_init(Time, grid, GV, US, param_file, Waves_CSp, diag) else call MOM_wave_interface_init_lite(param_file) endif @@ -356,7 +360,7 @@ program MOM_main endif ntstep = MAX(1,ceiling(dt_forcing/dt - 0.001)) - Time_step_ocean = set_time(int(floor(dt_forcing+0.5))) + Time_step_ocean = real_to_time(dt_forcing) elapsed_time_master = (abs(dt_forcing - time_type_to_real(Time_step_ocean)) > 1.0e-12*dt_forcing) if (elapsed_time_master) & call MOM_mesg("Using real elapsed time for the master clock.", 2) @@ -415,7 +419,7 @@ program MOM_main 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"//& - "incremental restart files at all.", default=set_time(0), & + "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"//& @@ -454,7 +458,7 @@ program MOM_main if (((.not.BTEST(Restart_control,1)) .and. (.not.BTEST(Restart_control,0))) & .or. (Restart_control < 0)) permit_incr_restart = .false. - if (restint > set_time(0)) then + if (restint > real_to_time(0.0)) then ! restart_time is the next integral multiple of restint. restart_time = Start_time + restint * & (1 + ((Time + Time_step_ocean) - Start_time) / restint) @@ -474,29 +478,27 @@ program MOM_main ! Set the forcing for the next steps. if (.not. offline_tracer_mode) then - call set_forcing(sfc_state, forces, fluxes, Time, Time_step_ocean, grid, & + call set_forcing(sfc_state, forces, fluxes, Time, Time_step_ocean, grid, US, & surface_forcing_CSp) endif if (debug) then - call MOM_mech_forcing_chksum("After set forcing", forces, grid, haloshift=0) - call MOM_forcing_chksum("After set forcing", fluxes, grid, haloshift=0) + call MOM_mech_forcing_chksum("After set forcing", forces, grid, US, haloshift=0) + call MOM_forcing_chksum("After set forcing", fluxes, grid, US, haloshift=0) endif if (use_ice_shelf) then - call shelf_calc_flux(sfc_state, forces, fluxes, Time, dt_forcing, ice_shelf_CSp) -!###IS call add_shelf_flux_forcing(fluxes, ice_shelf_CSp) -!###IS ! With a coupled ice/ocean run, use the following call. -!###IS call add_shelf_flux_IOB(ice_ocean_bdry_type, ice_shelf_CSp) + call shelf_calc_flux(sfc_state, fluxes, Time, dt_forcing, ice_shelf_CSp) + call add_shelf_forces(grid, Ice_shelf_CSp, forces) endif fluxes%fluxes_used = .false. fluxes%dt_buoy_accum = dt_forcing if (use_waves) then - call Update_Surface_Waves(grid,GV,time,time_step_ocean,waves_csp) + call Update_Surface_Waves(grid, GV, US, time, time_step_ocean, waves_csp) endif if (ns==1) then - call finish_MOM_initialization(Time, dirs, MOM_CSp, fluxes, restart_CSp) + call finish_MOM_initialization(Time, dirs, MOM_CSp, restart_CSp) endif ! This call steps the model over a time dt_forcing. @@ -534,7 +536,7 @@ program MOM_main dtdia = dt_dyn*(n - n_last_thermo) ! Back up Time2 to the start of the thermodynamic segment. if (n > n_last_thermo+1) & - Time2 = Time2 - set_time(int(floor((dtdia - dt_dyn) + 0.5))) + Time2 = Time2 - real_to_time(dtdia - dt_dyn) call step_MOM(forces, fluxes, sfc_state, Time2, dtdia, MOM_CSp, & do_dynamics=.false., do_thermodynamics=.true., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_forcing) @@ -543,7 +545,7 @@ program MOM_main endif t_elapsed_seg = t_elapsed_seg + dt_dyn - Time2 = Time1 + set_time(int(floor(t_elapsed_seg + 0.5))) + Time2 = Time1 + real_to_time(t_elapsed_seg) enddo endif @@ -551,17 +553,17 @@ program MOM_main ! This is here to enable fractional-second time steps. elapsed_time = elapsed_time + dt_forcing if (elapsed_time > 2e9) then - ! This is here to ensure that the conversion from a real to an integer - ! can be accurately represented in long runs (longer than ~63 years). - ! It will also ensure that elapsed time does not lose resolution of order - ! the timetype's resolution, provided that the timestep and tick are - ! larger than 10-5 seconds. If a clock with a finer resolution is used, - ! a smaller value would be required. - segment_start_time = segment_start_time + set_time(int(floor(elapsed_time))) - elapsed_time = elapsed_time - floor(elapsed_time) + ! This is here to ensure that the conversion from a real to an integer can be accurately + ! represented in long runs (longer than ~63 years). It will also ensure that elapsed time + ! does not lose resolution of order the timetype's resolution, provided that the timestep and + ! tick are larger than 10-5 seconds. If a clock with a finer resolution is used, a smaller + ! value would be required. + time_chg = real_to_time(elapsed_time) + segment_start_time = segment_start_time + time_chg + elapsed_time = elapsed_time - time_type_to_real(time_chg) endif if (elapsed_time_master) then - Master_Time = segment_start_time + set_time(int(floor(elapsed_time+0.5))) + Master_Time = segment_start_time + real_to_time(elapsed_time) else Master_Time = Master_Time + Time_step_ocean endif @@ -572,8 +574,7 @@ program MOM_main endif ; endif call enable_averaging(dt_forcing, Time, diag) - call mech_forcing_diags(forces, fluxes, dt_forcing, grid, diag, & - surface_forcing_CSp%handles) + call mech_forcing_diags(forces, dt_forcing, grid, diag, surface_forcing_CSp%handles) call disable_averaging(diag) if (.not. offline_tracer_mode) then @@ -641,7 +642,7 @@ program MOM_main call get_date(Time, yr, mon, day, hr, mins, sec) write(unit, '(6i6,8x,a)') yr, mon, day, hr, mins, sec, & 'Current model time: year, month, day, hour, minute, second' - end if + endif call close_file(unit) endif diff --git a/config_src/solo_driver/MOM_surface_forcing.F90 b/config_src/solo_driver/MOM_surface_forcing.F90 index 37bcaea17e..75a1ec321a 100644 --- a/config_src/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/solo_driver/MOM_surface_forcing.F90 @@ -1,53 +1,14 @@ +!> Functions that calculate the surface wind stresses and fluxes of buoyancy +!! or temperature/salinity andfresh water, in ocean-only (solo) mode. +!! +!! These functions are called every time step, even if the wind stresses +!! or buoyancy fluxes are constant in time - in that case these routines +!! return quickly without doing anything. In addition, any I/O of forcing +!! fields is controlled by surface_forcing_init, located in this file. module MOM_surface_forcing ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Robert Hallberg, November 1998 - May 2002 * -!* Edited by Stephen Griffies, June 2014 * -!* * -!* This program contains the subroutines that calculate the * -!* surface wind stresses and fluxes of buoyancy or temp/saln and * -!* fresh water. These subroutines are called every time step, * -!* even if the wind stresses or buoyancy fluxes are constant in time * -!* - in that case these routines return quickly without doing * -!* anything. In addition, any I/O of forcing fields is controlled * -!* by surface_forcing_init, located in this file. * -!* * -!* set_forcing is a small entry subroutine for the subroutines in * -!* this file. It provides the external access to these subroutines. * -!* * -!* wind_forcing determines the wind stresses and places them into * -!* forces%taux and forces%tauy. Often wind_forcing must be tailored * -!* for a particular application - either by specifying file and input * -!* variable names or by providing appropriate internal expressions * -!* for the stresses within a modified version of USER_wind_forcing. * -!* * -!* buoyancy_forcing determines the surface fluxes of heat, fresh * -!* water and salt, as appropriate. A restoring boundary * -!* condition plus a specified flux from a file is implemented here, * -!* but a user-provided internal expression can be set by modifying * -!* and calling USER_buoyancy_forcing. * -!* * -!* Macros written all in capital letters are defined in MOM_memory.h. * -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q * -!* j+1 > o > o > At ^: v, tauy * -!* j x ^ x ^ x At >: u, taux * -!* j > o > o > At o: h, fluxes. * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** -!### use MOM_controlled_forcing, only : apply_ctrl_forcing, register_ctrl_forcing_restarts -!### use MOM_controlled_forcing, only : controlled_forcing_init, controlled_forcing_end -!### use MOM_controlled_forcing, only : ctrl_forcing_CS use MOM_constants, only : hlv, hlf use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_MODULE @@ -71,11 +32,12 @@ module MOM_surface_forcing use MOM_io, only : EAST_FACE, NORTH_FACE, num_timelevels use MOM_restart, only : register_restart_field, restart_init, MOM_restart_CS use MOM_restart, only : restart_init_end, save_restart, restore_state -use MOM_time_manager, only : time_type, operator(+), operator(/), get_time, set_time +use MOM_time_manager, only : time_type, operator(+), operator(/), get_time, time_type_to_real use MOM_tracer_flow_control, only : call_tracer_set_forcing use MOM_tracer_flow_control, only : tracer_flow_control_CS +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface -use MESO_surface_forcing, only : MESO_wind_forcing, MESO_buoyancy_forcing +use MESO_surface_forcing, only : MESO_buoyancy_forcing use MESO_surface_forcing, only : MESO_surface_forcing_init, MESO_surface_forcing_CS use Neverland_surface_forcing, only : Neverland_wind_forcing, Neverland_buoyancy_forcing use Neverland_surface_forcing, only : Neverland_surface_forcing_init, Neverland_surface_forcing_CS @@ -83,9 +45,9 @@ module MOM_surface_forcing use user_surface_forcing, only : USER_surface_forcing_init, user_surface_forcing_CS use user_revise_forcing, only : user_alter_forcing, user_revise_forcing_init use user_revise_forcing, only : user_revise_forcing_CS -use SCM_idealized_hurricane, only : SCM_idealized_hurricane_wind_init -use SCM_idealized_hurricane, only : SCM_idealized_hurricane_wind_forcing -use SCM_idealized_hurricane, only : SCM_idealized_hurricane_CS +use idealized_hurricane, only : idealized_hurricane_wind_init +use idealized_hurricane, only : idealized_hurricane_wind_forcing, SCM_idealized_hurricane_wind_forcing +use idealized_hurricane, only : idealized_hurricane_CS use SCM_CVmix_tests, only : SCM_CVmix_tests_surface_forcing_init use SCM_CVmix_tests, only : SCM_CVmix_tests_wind_forcing use SCM_CVmix_tests, only : SCM_CVmix_tests_buoyancy_forcing @@ -104,144 +66,168 @@ module MOM_surface_forcing public surface_forcing_init public forcing_save_restart -! surface_forcing_CS is a structure containing pointers to the forcing fields -! which may be used to drive MOM. All fluxes are positive into the ocean. +!> Structure containing pointers to the forcing fields that may be used to drive MOM. +!! All fluxes are positive into the ocean. type, public :: surface_forcing_CS ; private - logical :: use_temperature ! if true, temp & salinity used as state variables - logical :: restorebuoy ! if true, use restoring surface buoyancy forcing - logical :: adiabatic ! if true, no diapycnal mass fluxes or surface buoyancy forcing - logical :: variable_winds ! if true, wind stresses vary with time - logical :: variable_buoyforce ! if true, buoyancy forcing varies with time. - real :: south_lat ! southern latitude of the domain - real :: len_lat ! domain length in latitude - - real :: Rho0 ! Boussinesq reference density (kg/m^3) - real :: G_Earth ! gravitational acceleration (m/s^2) - real :: Flux_const ! piston velocity for surface restoring (m/s) - real :: Flux_const_T ! piston velocity for surface temperature restoring (m/s) - real :: Flux_const_S ! piston velocity for surface salinity restoring (m/s) - real :: latent_heat_fusion ! latent heat of fusion (J/kg) - real :: latent_heat_vapor ! latent heat of vaporization (J/kg) - real :: tau_x0, tau_y0 ! Constant wind stresses used in the WIND_CONFIG="const" forcing - - real :: gust_const ! constant unresolved background gustiness for ustar (Pa) - logical :: read_gust_2d ! if true, use 2-dimensional gustiness supplied from a file - real, pointer :: gust(:,:) => NULL() ! spatially varying unresolved background gustiness (Pa) - ! gust is used when read_gust_2d is true. - - real, pointer :: T_Restore(:,:) => NULL() ! temperature to damp (restore) the SST to (deg C) - real, pointer :: S_Restore(:,:) => NULL() ! salinity to damp (restore) the SSS (g/kg) - real, pointer :: Dens_Restore(:,:) => NULL() ! density to damp (restore) surface density (kg/m^3) - - integer :: buoy_last_lev_read = -1 ! The last time level read from buoyancy input files - - real :: gyres_taux_const, gyres_taux_sin_amp, gyres_taux_cos_amp, gyres_taux_n_pis - ! if WIND_CONFIG=='gyres' then use - ! = A, B, C and n respectively for - ! taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L) - - real :: T_north, T_south ! target temperatures at north and south used in - ! buoyancy_forcing_linear - real :: S_north, S_south ! target salinity at north and south used in - ! buoyancy_forcing_linear - - logical :: first_call_set_forcing = .true. - logical :: archaic_OMIP_file = .true. - logical :: dataOverrideIsInitialized = .false. - - real :: wind_scale ! value by which wind-stresses are scaled, ND. - real :: constantHeatForcing ! value used for sensible heat flux when buoy_config="const" - - character(len=8) :: wind_stagger - type(tracer_flow_control_CS), pointer :: tracer_flow_CSp => NULL() + logical :: use_temperature !< if true, temp & salinity used as state variables + logical :: restorebuoy !< if true, use restoring surface buoyancy forcing + logical :: adiabatic !< if true, no diapycnal mass fluxes or surface buoyancy forcing + logical :: variable_winds !< if true, wind stresses vary with time + logical :: variable_buoyforce !< if true, buoyancy forcing varies with time. + real :: south_lat !< southern latitude of the domain + real :: len_lat !< domain length in latitude + + real :: Rho0 !< Boussinesq reference density [kg m-3] + real :: G_Earth !< gravitational acceleration [m s-2] + real :: Flux_const !< piston velocity for surface restoring [m s-1] + real :: Flux_const_T !< piston velocity for surface temperature restoring [m s-1] + real :: Flux_const_S !< piston velocity for surface salinity restoring [m s-1] + real :: latent_heat_fusion !< latent heat of fusion [J kg-1] + real :: latent_heat_vapor !< latent heat of vaporization [J kg-1] + real :: tau_x0 !< Constant zonal wind stress used in the WIND_CONFIG="const" forcing + real :: tau_y0 !< Constant meridional wind stress used in the WIND_CONFIG="const" forcing + + real :: gust_const !< constant unresolved background gustiness for ustar [Pa] + logical :: read_gust_2d !< if true, use 2-dimensional gustiness supplied from a file + real, pointer :: gust(:,:) => NULL() !< spatially varying unresolved background gustiness [Pa] + !! gust is used when read_gust_2d is true. + + real, pointer :: T_Restore(:,:) => NULL() !< temperature to damp (restore) the SST to [degC] + real, pointer :: S_Restore(:,:) => NULL() !< salinity to damp (restore) the SSS [ppt] + real, pointer :: Dens_Restore(:,:) => NULL() !< density to damp (restore) surface density [kg m-3] + + integer :: buoy_last_lev_read = -1 !< The last time level read from buoyancy input files + + ! if WIND_CONFIG=='gyres' then use the following as = A, B, C and n respectively for + ! taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L) + real :: gyres_taux_const !< A constant wind stress [Pa]. + real :: gyres_taux_sin_amp !< The amplitude of cosine wind stress gyres [Pa], if WIND_CONFIG=='gyres'. + real :: gyres_taux_cos_amp !< The amplitude of cosine wind stress gyres [Pa], if WIND_CONFIG=='gyres'. + real :: gyres_taux_n_pis !< The number of sine lobes in the basin if if WIND_CONFIG=='gyres' + + + real :: T_north !< target temperatures at north used in buoyancy_forcing_linear + real :: T_south !< target temperatures at south used in buoyancy_forcing_linear + real :: S_north !< target salinity at north used in buoyancy_forcing_linear + real :: S_south !< target salinity at south used in buoyancy_forcing_linear + + logical :: first_call_set_forcing = .true. !< True until after the first call to set_forcing + logical :: archaic_OMIP_file = .true. !< If true use the variable names and data fields from + !! a very old version of the OMIP forcing + logical :: dataOverrideIsInitialized = .false. !< If true, data override has been initialized + + real :: wind_scale !< value by which wind-stresses are scaled, ND. + real :: constantHeatForcing !< value used for sensible heat flux when buoy_config="const" + + character(len=8) :: wind_stagger !< A character indicating how the wind stress components + !! are staggered in WIND_FILE. Valid values are A or C for now. + type(tracer_flow_control_CS), pointer :: tracer_flow_CSp => NULL() !< A pointer to the structure + !! that is used to orchestrate the calling of tracer packages !### type(ctrl_forcing_CS), pointer :: ctrl_forcing_CSp => NULL() - type(MOM_restart_CS), pointer :: restart_CSp => NULL() - - type(diag_ctrl), pointer :: diag ! structure used to regulate timing of diagnostic output - - character(len=200) :: inputdir ! directory where NetCDF input files are. - character(len=200) :: wind_config ! indicator for wind forcing type (2gyre, USER, FILE..) - character(len=200) :: wind_file ! if wind_config is "file", file to use - character(len=200) :: buoy_config ! indicator for buoyancy forcing type - - character(len=200) :: longwave_file = '' - character(len=200) :: shortwave_file = '' - character(len=200) :: evaporation_file = '' - character(len=200) :: sensibleheat_file = '' - character(len=200) :: latentheat_file = '' - - character(len=200) :: rain_file = '' - character(len=200) :: snow_file = '' - character(len=200) :: runoff_file = '' - - character(len=200) :: longwaveup_file = '' - character(len=200) :: shortwaveup_file = '' - - character(len=200) :: SSTrestore_file = '' - character(len=200) :: salinityrestore_file = '' - - character(len=80) :: & ! Variable names in the input files - stress_x_var = '', stress_y_var = '', ustar_var = '', & - LW_var = '', SW_var = '', latent_var = '', sens_var = '', evap_var = '', & - rain_var = '', snow_var = '', lrunoff_var = '', frunoff_var = '', & - SST_restore_var = '', SSS_restore_var = '' + type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< A pointer to the restart control structure + + type(diag_ctrl), pointer :: diag !< structure used to regulate timing of diagnostic output + + character(len=200) :: inputdir !< directory where NetCDF input files are. + character(len=200) :: wind_config !< indicator for wind forcing type (2gyre, USER, FILE..) + character(len=200) :: wind_file !< if wind_config is "file", file to use + character(len=200) :: buoy_config !< indicator for buoyancy forcing type + + character(len=200) :: longwave_file = '' !< The file from which the longwave heat flux is read + character(len=200) :: shortwave_file = '' !< The file from which the shortwave heat flux is read + character(len=200) :: evaporation_file = '' !< The file from which the evaporation is read + character(len=200) :: sensibleheat_file = '' !< The file from which the sensible heat flux is read + character(len=200) :: latentheat_file = '' !< The file from which the latent heat flux is read + + character(len=200) :: rain_file = '' !< The file from which the rainfall is read + character(len=200) :: snow_file = '' !< The file from which the snowfall is read + character(len=200) :: runoff_file = '' !< The file from which the runoff is read + + character(len=200) :: longwaveup_file = '' !< The file from which the upward longwave heat flux is read + character(len=200) :: shortwaveup_file = '' !< The file from which the upward shorwave heat flux is read + + character(len=200) :: SSTrestore_file = '' !< The file from which to read the sea surface + !! temperature to restore toward + character(len=200) :: salinityrestore_file = '' !< The file from which to read the sea surface + !! salinity to restore toward + + character(len=80) :: stress_x_var = '' !< X-windstress variable name in the input file + character(len=80) :: stress_y_var = '' !< Y-windstress variable name in the input file + character(len=80) :: ustar_var = '' !< ustar variable name in the input file + character(len=80) :: LW_var = '' !< lonngwave heat flux variable name in the input file + character(len=80) :: SW_var = '' !< shortwave heat flux variable name in the input file + character(len=80) :: latent_var = '' !< latent heat flux variable name in the input file + character(len=80) :: sens_var = '' !< sensible heat flux variable name in the input file + character(len=80) :: evap_var = '' !< evaporation variable name in the input file + character(len=80) :: rain_var = '' !< rainfall variable name in the input file + character(len=80) :: snow_var = '' !< snowfall variable name in the input file + character(len=80) :: lrunoff_var = '' !< liquid runoff variable name in the input file + character(len=80) :: frunoff_var = '' !< frozen runoff variable name in the input file + character(len=80) :: SST_restore_var = '' !< target sea surface temeperature variable name in the input file + character(len=80) :: SSS_restore_var = '' !< target sea surface salinity variable name in the input file ! These variables give the number of time levels in the various forcing files. - integer :: SW_nlev = -1, LW_nlev = -1, latent_nlev = -1, sens_nlev = -1 - integer :: wind_nlev = -1, evap_nlev = -1, precip_nlev = -1, runoff_nlev = -1 - integer :: SST_nlev = -1, SSS_nlev = -1 + integer :: wind_nlev = -1 !< The number of time levels in the file of wind stress + integer :: SW_nlev = -1 !< The number of time levels in the file of shortwave heat flux + integer :: LW_nlev = -1 !< The number of time levels in the file of longwave heat flux + integer :: latent_nlev = -1 !< The number of time levels in the file of latent heat flux + integer :: sens_nlev = -1 !< The number of time levels in the file of sensible heat flux + integer :: evap_nlev = -1 !< The number of time levels in the file of evaporation + integer :: precip_nlev = -1 !< The number of time levels in the file of precipitation + integer :: runoff_nlev = -1 !< The number of time levels in the file of runoff + integer :: SST_nlev = -1 !< The number of time levels in the file of target SST + integer :: SSS_nlev = -1 !< The number of time levels in the file of target SSS ! These variables give the last time level read for the various forcing files. - integer :: wind_last_lev = -1 - integer :: SW_last_lev = -1, LW_last_lev = -1, latent_last_lev = -1 - integer :: sens_last_lev = -1 - integer :: evap_last_lev = -1, precip_last_lev = -1, runoff_last_lev = -1 - integer :: SST_last_lev = -1, SSS_last_lev = -1 - - ! Diagnostics handles - type(forcing_diags), public :: handles - + integer :: wind_last_lev = -1 !< The last time level read of wind stress + integer :: SW_last_lev = -1 !< The last time level read of shortwave heat flux + integer :: LW_last_lev = -1 !< The last time level read of longwave heat flux + integer :: latent_last_lev = -1 !< The last time level read of latent heat flux + integer :: sens_last_lev = -1 !< The last time level read of sensible heat flux + integer :: evap_last_lev = -1 !< The last time level read of evaporation + integer :: precip_last_lev = -1 !< The last time level read of precipitation + integer :: runoff_last_lev = -1 !< The last time level read of runoff + integer :: SST_last_lev = -1 !< The last time level read of target SST + integer :: SSS_last_lev = -1 !< The last time level read of target SSS + + type(forcing_diags), public :: handles !< A structure with diagnostics handles + + !>@{ Control structures for named forcing packages type(user_revise_forcing_CS), pointer :: urf_CS => NULL() type(user_surface_forcing_CS), pointer :: user_forcing_CSp => NULL() type(BFB_surface_forcing_CS), pointer :: BFB_forcing_CSp => NULL() type(dumbbell_surface_forcing_CS), pointer :: dumbbell_forcing_CSp => NULL() type(MESO_surface_forcing_CS), pointer :: MESO_forcing_CSp => NULL() type(Neverland_surface_forcing_CS), pointer :: Neverland_forcing_CSp => NULL() - type(SCM_idealized_hurricane_CS), pointer :: SCM_idealized_hurricane_CSp => NULL() + type(idealized_hurricane_CS), pointer :: idealized_hurricane_CSp => NULL() type(SCM_CVmix_tests_CS), pointer :: SCM_CVmix_tests_CSp => NULL() + !!@} end type surface_forcing_CS - -integer :: id_clock_forcing +integer :: id_clock_forcing !< A CPU time clock contains -subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, CS) +!> Calls subroutines in this file to get surface forcing fields. +!! +!! It also allocates and initializes the fields in the forcing and mech_forcing types +!! the first time it is called. +subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(forcing), intent(inout) :: fluxes - type(time_type), intent(in) :: day_start - type(time_type), intent(in) :: day_interval + type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields + type(time_type), intent(in) :: day_start !< The start time of the fluxes + type(time_type), intent(in) :: day_interval !< Length of time over which these fluxes applied type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS - -! This subroutine calls other subroutines in this file to get surface forcing fields. -! It also allocates and initializes the fields in the flux type. - -! Arguments: -! (inout) state = structure describing ocean surface state -! (inout) fluxes = structure with pointers to forcing fields; unused have NULL ptrs -! (in) day_start = Start time of the fluxes -! (in) day_interval = Length of time over which these fluxes applied -! (in) G = ocean grid structure -! (in) CS = pointer to control struct returned by previous surface_forcing_init call - - real :: dt ! length of time in seconds over which fluxes applied + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call + ! Local variables + real :: dt ! length of time over which fluxes applied [s] type(time_type) :: day_center ! central time of the fluxes. - integer :: intdt integer :: isd, ied, jsd, jed isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -249,8 +235,7 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, CS call callTree_enter("set_forcing, MOM_surface_forcing.F90") day_center = day_start + day_interval/2 - call get_time(day_interval, intdt) - dt = real(intdt) + dt = time_type_to_real(day_interval) if (CS%first_call_set_forcing) then ! Allocate memory for the mechanical and thermodyanmic forcing fields. @@ -277,29 +262,29 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, CS if (CS%variable_winds .or. CS%first_call_set_forcing) then if (trim(CS%wind_config) == "file") then - call wind_forcing_from_file(sfc_state, forces, day_center, G, CS) + call wind_forcing_from_file(sfc_state, forces, day_center, G, US, CS) elseif (trim(CS%wind_config) == "data_override") then - call wind_forcing_by_data_override(sfc_state, forces, day_center, G, CS) + call wind_forcing_by_data_override(sfc_state, forces, day_center, G, US, CS) elseif (trim(CS%wind_config) == "2gyre") then - call wind_forcing_2gyre(sfc_state, forces, day_center, G, CS) + call wind_forcing_2gyre(sfc_state, forces, day_center, G, US, CS) elseif (trim(CS%wind_config) == "1gyre") then - call wind_forcing_1gyre(sfc_state, forces, day_center, G, CS) + call wind_forcing_1gyre(sfc_state, forces, day_center, G, US, CS) elseif (trim(CS%wind_config) == "gyres") then - call wind_forcing_gyres(sfc_state, forces, day_center, G, CS) + call wind_forcing_gyres(sfc_state, forces, day_center, G, US, CS) elseif (trim(CS%wind_config) == "zero") then - call wind_forcing_const(sfc_state, forces, 0., 0., day_center, G, CS) + call wind_forcing_const(sfc_state, forces, 0., 0., day_center, G, US, CS) elseif (trim(CS%wind_config) == "const") then - call wind_forcing_const(sfc_state, forces, CS%tau_x0, CS%tau_y0, day_center, G, CS) - elseif (trim(CS%wind_config) == "MESO") then - call MESO_wind_forcing(sfc_state, forces, day_center, G, CS%MESO_forcing_CSp) + call wind_forcing_const(sfc_state, forces, CS%tau_x0, CS%tau_y0, day_center, G, US, CS) elseif (trim(CS%wind_config) == "Neverland") then - call Neverland_wind_forcing(sfc_state, forces, day_center, G, CS%Neverland_forcing_CSp) + call Neverland_wind_forcing(sfc_state, forces, day_center, G, US, CS%Neverland_forcing_CSp) + elseif (trim(CS%wind_config) == "ideal_hurr") then + call idealized_hurricane_wind_forcing(sfc_state, forces, day_center, G, US, CS%idealized_hurricane_CSp) elseif (trim(CS%wind_config) == "SCM_ideal_hurr") then - call SCM_idealized_hurricane_wind_forcing(sfc_state, forces, day_center, G, CS%SCM_idealized_hurricane_CSp) + call SCM_idealized_hurricane_wind_forcing(sfc_state, forces, day_center, G, US, CS%idealized_hurricane_CSp) elseif (trim(CS%wind_config) == "SCM_CVmix_tests") then - call SCM_CVmix_tests_wind_forcing(sfc_state, forces, day_center, G, CS%SCM_CVmix_tests_CSp) + call SCM_CVmix_tests_wind_forcing(sfc_state, forces, day_center, G, US, CS%SCM_CVmix_tests_CSp) elseif (trim(CS%wind_config) == "USER") then - call USER_wind_forcing(sfc_state, forces, day_center, G, CS%user_forcing_CSp) + call USER_wind_forcing(sfc_state, forces, day_center, G, US, CS%user_forcing_CSp) elseif (CS%variable_winds .and. .not.CS%first_call_set_forcing) then call MOM_error(FATAL, & "MOM_surface_forcing: Variable winds defined with no wind config") @@ -355,7 +340,7 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, CS ! Fields that exist in both the forcing and mech_forcing types must be copied. if (CS%variable_winds .or. CS%first_call_set_forcing) then call copy_common_forcing_fields(forces, fluxes, G) - call set_derived_forcing_fields(forces, fluxes, G, CS%Rho0) + call set_derived_forcing_fields(forces, fluxes, G, US, CS%Rho0) endif if ((CS%variable_buoyforce .or. CS%first_call_set_forcing) .and. & @@ -370,34 +355,25 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, CS end subroutine set_forcing -subroutine wind_forcing_const(sfc_state, forces, tau_x0, tau_y0, day, G, CS) +!> Sets the surface wind stresses to constant values +subroutine wind_forcing_const(sfc_state, forces, tau_x0, tau_y0, day, G, US, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - real, intent(in) :: tau_x0 - real, intent(in) :: tau_y0 - type(time_type), intent(in) :: day + real, intent(in) :: tau_x0 !< The zonal wind stress [Pa] + real, intent(in) :: tau_y0 !< The meridional wind stress [Pa] + type(time_type), intent(in) :: day !< The time of the fluxes type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS - -! subroutine sets the surface wind stresses to zero - -! Arguments: -! state = structure describing ocean surface state -! (out) fluxes = structure with pointers to forcing fields; unused have NULL ptrs -! (in) day = time of the fluxes -! (in) G = ocean grid structure -! (in) CS = pointer to control returned by previous surface_forcing_init call - + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call + ! Local variables real :: mag_tau integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB call callTree_enter("wind_forcing_const, MOM_surface_forcing.F90") is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB !set steady surface wind stresses, in units of Pa. mag_tau = sqrt( tau_x0**2 + tau_y0**2) @@ -412,11 +388,11 @@ subroutine wind_forcing_const(sfc_state, forces, tau_x0, tau_y0, day, G, CS) if (CS%read_gust_2d) then if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt( ( mag_tau + CS%gust(i,j) ) / CS%Rho0 ) + forces%ustar(i,j) = US%m_to_Z * sqrt( ( mag_tau + CS%gust(i,j) ) / CS%Rho0 ) enddo ; enddo ; endif else if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt( ( mag_tau + CS%gust_const ) / CS%Rho0 ) + forces%ustar(i,j) = US%m_to_Z * sqrt( ( mag_tau + CS%gust_const ) / CS%Rho0 ) enddo ; enddo ; endif endif @@ -424,32 +400,23 @@ subroutine wind_forcing_const(sfc_state, forces, tau_x0, tau_y0, day, G, CS) end subroutine wind_forcing_const -subroutine wind_forcing_2gyre(sfc_state, forces, day, G, CS) +!> Sets the surface wind stresses to set up two idealized gyres. +subroutine wind_forcing_2gyre(sfc_state, forces, day, G, US, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day + type(time_type), intent(in) :: day !< The time of the fluxes type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS - -! This subroutine sets the surface wind stresses according to double gyre. - -! Arguments: -! state = structure describing ocean surface state -! (out) fluxes = structure with pointers to forcing fields; unused have NULL ptrs -! (in) day = time of the fluxes -! (in) G = ocean grid structure -! (in) CS = pointer to control struct returned by previous surface_forcing_init call - + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call + ! Local variables real :: PI integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB call callTree_enter("wind_forcing_2gyre, MOM_surface_forcing.F90") is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB !set the steady surface wind stresses, in units of Pa. PI = 4.0*atan(1.0) @@ -467,32 +434,23 @@ subroutine wind_forcing_2gyre(sfc_state, forces, day, G, CS) end subroutine wind_forcing_2gyre -subroutine wind_forcing_1gyre(sfc_state, forces, day, G, CS) +!> Sets the surface wind stresses to set up a single idealized gyre. +subroutine wind_forcing_1gyre(sfc_state, forces, day, G, US, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day + type(time_type), intent(in) :: day !< The time of the fluxes type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS - -! This subroutine sets the surface wind stresses according to single gyre. - -! Arguments: -! state = structure describing ocean surface state -! (out) fluxes = structure with pointers to forcing fields; unused have NULL ptrs -! (in) day = time of the fluxes -! (in) G = ocean grid structure -! (in) CS = pointer to control struct returned by previous surface_forcing_init call - + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call + ! Local variables real :: PI integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB call callTree_enter("wind_forcing_1gyre, MOM_surface_forcing.F90") is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB ! set the steady surface wind stresses, in units of Pa. PI = 4.0*atan(1.0) @@ -508,51 +466,41 @@ subroutine wind_forcing_1gyre(sfc_state, forces, day, G, CS) call callTree_leave("wind_forcing_1gyre") end subroutine wind_forcing_1gyre - -subroutine wind_forcing_gyres(sfc_state, forces, day, G, CS) +!> Sets the surface wind stresses to set up idealized gyres. +subroutine wind_forcing_gyres(sfc_state, forces, day, G, US, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day + type(time_type), intent(in) :: day !< The time of the fluxes type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS - -! This subroutine sets the surface wind stresses according to gyres. - -! Arguments: -! state = structure describing ocean surface state -! (out) fluxes = structure with pointers to forcing fields; unused have NULL ptrs -! (in) day = time of the fluxes -! (in) G = ocean grid structure -! (in) CS = pointer to control struct returned by previous surface_forcing_init call - + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call + ! Local variables real :: PI, y integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB call callTree_enter("wind_forcing_gyres, MOM_surface_forcing.F90") is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - ! steady surface wind stresses (Pa) + ! steady surface wind stresses [Pa] PI = 4.0*atan(1.0) - do j=jsd,jed ; do I=is-1,IedB + do j=js-1,je+1 ; do I=is-1,Ieq y = (G%geoLatCu(I,j)-CS%South_lat)/CS%len_lat forces%taux(I,j) = CS%gyres_taux_const + & ( CS%gyres_taux_sin_amp*sin(CS%gyres_taux_n_pis*PI*y) & + CS%gyres_taux_cos_amp*cos(CS%gyres_taux_n_pis*PI*y) ) enddo ; enddo - do J=js-1,JedB ; do i=isd,ied + do J=js-1,Jeq ; do i=is-1,ie+1 forces%tauy(i,J) = 0.0 enddo ; enddo - ! set the friction velocity + ! set the friction velocity !### Add parenthesis so that this is rotationally invariant. do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt(sqrt(0.5*(forces%tauy(i,j-1)*forces%tauy(i,j-1) + & + forces%ustar(i,j) = US%m_to_Z * sqrt(sqrt(0.5*(forces%tauy(i,j-1)*forces%tauy(i,j-1) + & forces%tauy(i,j)*forces%tauy(i,j) + forces%taux(i-1,j)*forces%taux(i-1,j) + & forces%taux(i,j)*forces%taux(i,j)))/CS%Rho0 + (CS%gust_const/CS%Rho0)) enddo ; enddo @@ -561,54 +509,45 @@ subroutine wind_forcing_gyres(sfc_state, forces, day, G, CS) end subroutine wind_forcing_gyres -subroutine wind_forcing_from_file(sfc_state, forces, day, G, CS) +! Sets the surface wind stresses from input files. +subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day + type(time_type), intent(in) :: day !< The time of the fluxes type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS - -! This subroutine sets the surface wind stresses. - -! Arguments: -! state = structure describing ocean surface state -! (out) fluxes = structure with pointers to forcing fields; unused have NULL ptrs -! (in) day = time of the fluxes -! (in) G = ocean grid structure -! (in) CS = pointer to control struct returned by previous surface_forcing_init call - + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call + ! Local variables character(len=200) :: filename ! The name of the input file. real :: temp_x(SZI_(G),SZJ_(G)) ! Pseudo-zonal and psuedo-meridional - real :: temp_y(SZI_(G),SZJ_(G)) ! wind stresses at h-points, in Pa. + real :: temp_y(SZI_(G),SZJ_(G)) ! wind stresses at h-points [Pa]. integer :: time_lev_daily ! The time levels to read for fields with integer :: time_lev_monthly ! daily and montly cycles. integer :: time_lev ! The time level that is used for a field. integer :: days, seconds integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB logical :: read_Ustar call callTree_enter("wind_forcing_from_file, MOM_surface_forcing.F90") is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - call get_time(day,seconds,days) + call get_time(day, seconds, days) time_lev_daily = days - 365*floor(real(days) / 365.0) if (time_lev_daily < 31) then ; time_lev_monthly = 0 - else if (time_lev_daily < 59) then ; time_lev_monthly = 1 - else if (time_lev_daily < 90) then ; time_lev_monthly = 2 - else if (time_lev_daily < 120) then ; time_lev_monthly = 3 - else if (time_lev_daily < 151) then ; time_lev_monthly = 4 - else if (time_lev_daily < 181) then ; time_lev_monthly = 5 - else if (time_lev_daily < 212) then ; time_lev_monthly = 6 - else if (time_lev_daily < 243) then ; time_lev_monthly = 7 - else if (time_lev_daily < 273) then ; time_lev_monthly = 8 - else if (time_lev_daily < 304) then ; time_lev_monthly = 9 - else if (time_lev_daily < 334) then ; time_lev_monthly = 10 + elseif (time_lev_daily < 59) then ; time_lev_monthly = 1 + elseif (time_lev_daily < 90) then ; time_lev_monthly = 2 + elseif (time_lev_daily < 120) then ; time_lev_monthly = 3 + elseif (time_lev_daily < 151) then ; time_lev_monthly = 4 + elseif (time_lev_daily < 181) then ; time_lev_monthly = 5 + elseif (time_lev_daily < 212) then ; time_lev_monthly = 6 + elseif (time_lev_daily < 243) then ; time_lev_monthly = 7 + elseif (time_lev_daily < 273) then ; time_lev_monthly = 8 + elseif (time_lev_daily < 304) then ; time_lev_monthly = 9 + elseif (time_lev_daily < 334) then ; time_lev_monthly = 10 else ; time_lev_monthly = 11 endif @@ -645,12 +584,12 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, CS) if (.not.read_Ustar) then if (CS%read_gust_2d) then do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt((sqrt(temp_x(i,j)*temp_x(i,j) + & + forces%ustar(i,j) = US%m_to_Z * sqrt((sqrt(temp_x(i,j)*temp_x(i,j) + & temp_y(i,j)*temp_y(i,j)) + CS%gust(i,j)) / CS%Rho0) enddo ; enddo else do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt(sqrt(temp_x(i,j)*temp_x(i,j) + & + forces%ustar(i,j) = US%m_to_Z * sqrt(sqrt(temp_x(i,j)*temp_x(i,j) + & temp_y(i,j)*temp_y(i,j))/CS%Rho0 + (CS%gust_const/CS%Rho0)) enddo ; enddo endif @@ -690,13 +629,13 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, CS) if (.not.read_Ustar) then if (CS%read_gust_2d) then do j=js, je ; do i=is, ie - forces%ustar(i,j) = sqrt((sqrt(0.5*((forces%tauy(i,j-1)**2 + & + forces%ustar(i,j) = US%m_to_Z * sqrt((sqrt(0.5*((forces%tauy(i,j-1)**2 + & forces%tauy(i,j)**2) + (forces%taux(i-1,j)**2 + & forces%taux(i,j)**2))) + CS%gust(i,j)) / CS%Rho0 ) enddo ; enddo else do j=js, je ; do i=is, ie - forces%ustar(i,j) = sqrt(sqrt(0.5*((forces%tauy(i,j-1)**2 + & + forces%ustar(i,j) = US%m_to_Z * sqrt(sqrt(0.5*((forces%tauy(i,j-1)**2 + & forces%tauy(i,j)**2) + (forces%taux(i-1,j)**2 + & forces%taux(i,j)**2)))/CS%Rho0 + (CS%gust_const/CS%Rho0)) enddo ; enddo @@ -709,7 +648,7 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, CS) if (read_Ustar) then call MOM_read_data(filename, CS%Ustar_var, forces%ustar(:,:), & - G%Domain, timelevel=time_lev) + G%Domain, timelevel=time_lev, scale=US%Z_to_m) endif CS%wind_last_lev = time_lev @@ -720,24 +659,20 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, CS) end subroutine wind_forcing_from_file -subroutine wind_forcing_by_data_override(sfc_state, forces, day, G, CS) +! Sets the surface wind stresses via the data override facility. +subroutine wind_forcing_by_data_override(sfc_state, forces, day, G, US, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day + type(time_type), intent(in) :: day !< The time of the fluxes type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS -! This subroutine sets the surface wind stresses - -! Arguments: -! state = structure describing ocean surface state -! (out) fluxes = structure with pointers to forcing fields; unused have NULL ptrs -! (in) day = time of the fluxes -! (in) G = ocean grid structure -! (in) CS = pointer to control struct returned by previous surface_forcing_init call - + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call + ! Local variables real :: temp_x(SZI_(G),SZJ_(G)) ! Pseudo-zonal and psuedo-meridional - real :: temp_y(SZI_(G),SZJ_(G)) ! wind stresses at h-points, in Pa. + real :: temp_y(SZI_(G),SZJ_(G)) ! wind stresses at h-points [Pa]. + real :: temp_ustar(SZI_(G),SZJ_(G)) ! ustar [m s-1] (not rescaled). integer :: i, j, is_in, ie_in, js_in, je_in logical :: read_uStar @@ -768,17 +703,19 @@ subroutine wind_forcing_by_data_override(sfc_state, forces, day, G, CS) read_Ustar = (len_trim(CS%ustar_var) > 0) ! Need better control higher up ???? if (read_Ustar) then - call data_override('OCN', 'ustar', forces%ustar, day, is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) + do j=G%jsc,G%jec ; do i=G%isc,G%iec ; temp_ustar(i,j) = US%Z_to_m*forces%ustar(i,j) ; enddo ; enddo + call data_override('OCN', 'ustar', temp_ustar, day, is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) + do j=G%jsc,G%jec ; do i=G%isc,G%iec ; forces%ustar(i,j) = US%m_to_Z*temp_ustar(i,j) ; enddo ; enddo else if (CS%read_gust_2d) then call data_override('OCN', 'gust', CS%gust, day, is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) do j=G%jsc,G%jec ; do i=G%isc,G%iec - forces%ustar(i,j) = sqrt((sqrt(temp_x(i,j)*temp_x(i,j) + & + forces%ustar(i,j) = US%m_to_Z * sqrt((sqrt(temp_x(i,j)*temp_x(i,j) + & temp_y(i,j)*temp_y(i,j)) + CS%gust(i,j)) / CS%Rho0) enddo ; enddo else do j=G%jsc,G%jec ; do i=G%isc,G%iec - forces%ustar(i,j) = sqrt(sqrt(temp_x(i,j)*temp_x(i,j) + & + forces%ustar(i,j) = US%m_to_Z * sqrt(sqrt(temp_x(i,j)*temp_x(i,j) + & temp_y(i,j)*temp_y(i,j))/CS%Rho0 + (CS%gust_const/CS%Rho0)) enddo ; enddo endif @@ -791,41 +728,30 @@ subroutine wind_forcing_by_data_override(sfc_state, forces, day, G, CS) end subroutine wind_forcing_by_data_override +!> Specifies zero surface bouyancy fluxes from input files. subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. - type(forcing), intent(inout) :: fluxes - type(time_type), intent(in) :: day + type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields + type(time_type), intent(in) :: day !< The time of the fluxes real, intent(in) :: dt !< The amount of time over which - !! the fluxes apply, in s + !! the fluxes apply [s] type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS - -! This subroutine specifies the current surface fluxes of buoyancy -! temperature and fresh water. It may also be modified to add -! surface fluxes of user provided tracers. -! This case has surface buoyancy forcing from input files. - -! Arguments: -! state = structure describing ocean surface state -! (out) fluxes = structure with pointers to forcing fields; unused have NULL ptrs -! (in) day = time of the fluxes -! (in) dt = amount of time over which the fluxes apply -! (in) G = ocean grid structure -! (in) CS = pointer to control struct returned by previous surface_forcing_init call - + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call + ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & temp, & ! A 2-d temporary work array with various units. SST_anom, & ! Instantaneous sea surface temperature anomalies from a - ! target (observed) value, in deg C. + ! target (observed) value [degC]. SSS_anom, & ! Instantaneous sea surface salinity anomalies from a target - ! (observed) value, in g kg-1. + ! (observed) value [ppt]. SSS_mean ! A (mean?) salinity about which to normalize local salinity ! anomalies when calculating restorative precipitation - ! anomalies, in g kg-1. + ! anomalies [ppt]. - real :: rhoXcp ! reference density times heat capacity (J/(m^3 * K)) - real :: Irho0 ! inverse of the Boussinesq reference density (m^3/kg) + real :: rhoXcp ! reference density times heat capacity [J m-3 degC-1] + real :: Irho0 ! inverse of the Boussinesq reference density [m3 kg-1] integer :: time_lev_daily ! time levels to read for fields with daily cycle integer :: time_lev_monthly ! time levels to read for fields with monthly cycle @@ -842,21 +768,21 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, CS) Irho0 = 1.0/CS%Rho0 ! Read the buoyancy forcing file - call get_time(day,seconds,days) + call get_time(day, seconds, days) time_lev_daily = days - 365*floor(real(days) / 365.0) if (time_lev_daily < 31) then ; time_lev_monthly = 0 - else if (time_lev_daily < 59) then ; time_lev_monthly = 1 - else if (time_lev_daily < 90) then ; time_lev_monthly = 2 - else if (time_lev_daily < 120) then ; time_lev_monthly = 3 - else if (time_lev_daily < 151) then ; time_lev_monthly = 4 - else if (time_lev_daily < 181) then ; time_lev_monthly = 5 - else if (time_lev_daily < 212) then ; time_lev_monthly = 6 - else if (time_lev_daily < 243) then ; time_lev_monthly = 7 - else if (time_lev_daily < 273) then ; time_lev_monthly = 8 - else if (time_lev_daily < 304) then ; time_lev_monthly = 9 - else if (time_lev_daily < 334) then ; time_lev_monthly = 10 + elseif (time_lev_daily < 59) then ; time_lev_monthly = 1 + elseif (time_lev_daily < 90) then ; time_lev_monthly = 2 + elseif (time_lev_daily < 120) then ; time_lev_monthly = 3 + elseif (time_lev_daily < 151) then ; time_lev_monthly = 4 + elseif (time_lev_daily < 181) then ; time_lev_monthly = 5 + elseif (time_lev_daily < 212) then ; time_lev_monthly = 6 + elseif (time_lev_daily < 243) then ; time_lev_monthly = 7 + elseif (time_lev_daily < 273) then ; time_lev_monthly = 8 + elseif (time_lev_daily < 304) then ; time_lev_monthly = 9 + elseif (time_lev_daily < 334) then ; time_lev_monthly = 10 else ; time_lev_monthly = 11 endif @@ -1080,41 +1006,29 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, CS) call callTree_leave("buoyancy_forcing_from_files") end subroutine buoyancy_forcing_from_files - +!> Specifies zero surface bouyancy fluxes from data over-ride. subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(forcing), intent(inout) :: fluxes - type(time_type), intent(in) :: day - real, intent(in) :: dt !< The amount of time over which - !! the fluxes apply, in s - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS - -! This subroutine specifies the current surface fluxes of buoyancy -! temperature and fresh water. It may also be modified to add -! surface fluxes of user provided tracers. -! This case has surface buoyancy forcing from data over-ride. - -! Arguments: -! state = structure describing ocean surface state -! (out) fluxes = structure with pointers to forcing fields; unused have NULL ptrs -! (in) day = time of the fluxes -! (in) dt = amount of time over which the fluxes apply -! (in) G = ocean grid structure -! (in) CS = pointer to control struct returned by previous surface_forcing_init call - + type(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields + type(time_type), intent(in) :: day !< The time of the fluxes + real, intent(in) :: dt !< The amount of time over which + !! the fluxes apply [s] + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call + ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & temp, & ! A 2-d temporary work array with various units. SST_anom, & ! Instantaneous sea surface temperature anomalies from a - ! target (observed) value, in deg C. + ! target (observed) value [degC]. SSS_anom, & ! Instantaneous sea surface salinity anomalies from a target - ! (observed) value, in g kg-1. + ! (observed) value [ppt]. SSS_mean ! A (mean?) salinity about which to normalize local salinity ! anomalies when calculating restorative precipitation - ! anomalies, in g kg-1. - real :: rhoXcp ! The mean density times the heat capacity, in J m-3 K-1. - real :: Irho0 ! The inverse of the Boussinesq density, in m3 kg-1. + ! anomalies [ppt]. + real :: rhoXcp ! The mean density times the heat capacity [J m-3 degC-1]. + real :: Irho0 ! The inverse of the Boussinesq density [m3 kg-1]. integer :: time_lev_daily ! The time levels to read for fields with integer :: time_lev_monthly ! daily and montly cycles. @@ -1153,7 +1067,7 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, CS ! but evap is normally a positive quantity in the files fluxes%latent(i,j) = CS%latent_heat_vapor*fluxes%evap(i,j) fluxes%latent_evap_diag(i,j) = fluxes%latent(i,j) - enddo; enddo + enddo ; enddo call data_override('OCN', 'sens', fluxes%sens(:,:), day, & is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) @@ -1162,7 +1076,7 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, CS do j=js,je ; do i=is,ie fluxes%sens(i,j) = -fluxes%sens(i,j) ! Normal convention is positive into the ocean ! but sensible is normally a positive quantity in the files - enddo; enddo + enddo ; enddo call data_override('OCN', 'sw', fluxes%sw(:,:), day, & is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) @@ -1258,30 +1172,18 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, CS call callTree_leave("buoyancy_forcing_from_data_override") end subroutine buoyancy_forcing_from_data_override - +!> This subroutine specifies zero surface bouyancy fluxes subroutine buoyancy_forcing_zero(sfc_state, fluxes, day, dt, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. - type(forcing), intent(inout) :: fluxes - type(time_type), intent(in) :: day + type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields + type(time_type), intent(in) :: day !< The time of the fluxes real, intent(in) :: dt !< The amount of time over which - !! the fluxes apply, in s + !! the fluxes apply [s] type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS - -! This subroutine specifies the current surface fluxes of buoyancy -! temperature and fresh water. It may also be modified to add -! surface fluxes of user provided tracers. -! This case has zero surface buoyancy forcing. - -! Arguments: -! (inout) state = structure describing ocean surface state -! (inout) fluxes = structure with pointers to forcing fields; unused have NULL ptrs -! (in) day = time of the fluxes -! (in) dt = amount of time over which the fluxes apply -! (in) G = ocean grid structure -! (in) CS = pointer to control struct returned by previous surface_forcing_init call - + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call + ! Local variables integer :: i, j, is, ie, js, je call callTree_enter("buoyancy_forcing_zero, MOM_surface_forcing.F90") @@ -1313,29 +1215,18 @@ subroutine buoyancy_forcing_zero(sfc_state, fluxes, day, dt, G, CS) end subroutine buoyancy_forcing_zero +!> Sets up spatially and temporally constant surface heat fluxes. subroutine buoyancy_forcing_const(sfc_state, fluxes, day, dt, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. - type(forcing), intent(inout) :: fluxes - type(time_type), intent(in) :: day + type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields + type(time_type), intent(in) :: day !< The time of the fluxes real, intent(in) :: dt !< The amount of time over which - !! the fluxes apply, in s + !! the fluxes apply [s] type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS - -! This subroutine specifies the current surface fluxes of buoyancy -! temperature and fresh water. It may also be modified to add -! surface fluxes of user provided tracers. -! We here define a constant surface heat flux. - -! Arguments: -! (inout) state = structure describing ocean surface state -! (inout) fluxes = structure with pointers to forcing fields; unused have NULL ptrs -! (in) day = time of the fluxes -! (in) dt = amount of time over which the fluxes apply -! (in) G = ocean grid structure -! (in) CS = pointer to control struct returned by previous surface_forcing_init call - + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call + ! Local variables integer :: i, j, is, ie, js, je call callTree_enter("buoyancy_forcing_const, MOM_surface_forcing.F90") is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -1365,29 +1256,19 @@ subroutine buoyancy_forcing_const(sfc_state, fluxes, day, dt, G, CS) call callTree_leave("buoyancy_forcing_const") end subroutine buoyancy_forcing_const - +!> Sets surface fluxes of heat and salinity by restoring to temperature and +!! salinity profiles that vary linearly with latitude. subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. - type(forcing), intent(inout) :: fluxes - type(time_type), intent(in) :: day + type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields + type(time_type), intent(in) :: day !< The time of the fluxes real, intent(in) :: dt !< The amount of time over which - !! the fluxes apply, in s + !! the fluxes apply [s] type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS - -! This subroutine specifies the current surface fluxes of buoyancy -! temperature and fresh water. It may also be modified to add -! surface fluxes of user provided tracers. - -! Arguments: -! (inout) state = structure describing ocean surface state -! (inout) fluxes = structure with pointers to forcing fields; unused have NULL ptrs -! (in) day = time of the fluxes -! (in) dt = amount of time over which the fluxes apply -! (in) G = ocean grid structure -! (in) CS = pointer to control struct returned by previous surface_forcing_init call - + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call + ! Local variables real :: y, T_restore, S_restore integer :: i, j, is, ie, js, je @@ -1456,24 +1337,18 @@ subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, CS) call callTree_leave("buoyancy_forcing_linear") end subroutine buoyancy_forcing_linear - +!> Save a restart file for the forcing fields subroutine forcing_save_restart(CS, G, Time, directory, time_stamped, & filename_suffix) - type(surface_forcing_CS), pointer :: CS + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(time_type), intent(in) :: Time - character(len=*), intent(in) :: directory - logical, optional, intent(in) :: time_stamped - character(len=*), optional, intent(in) :: filename_suffix - -! Arguments: -! CS = pointer to control structure from previous surface_forcing_init call -! (in) G = ocean grid structure -! (in) Time = model time at this call; needed for mpp_write calls -! (in, opt) directory = optional directory into which to write these restart files -! (in, opt) time_stamped = if true, the restart file names include a unique time stamp -! default is false. -! (in, opt) filename_suffix = optional suffix (e.g., a time-stamp) to append to the restart fname + type(time_type), intent(in) :: Time !< model time at this call; needed for mpp_write calls + character(len=*), intent(in) :: directory !< directory into which to write these restart files + logical, optional, intent(in) :: time_stamped !< If true, the restart file names + !! include a unique time stamp; the default is false. + character(len=*), optional, intent(in) :: filename_suffix !< optional suffix (e.g., a time-stamp) + !! to append to the restart fname if (.not.associated(CS)) return if (.not.associated(CS%restart_CSp)) return @@ -1482,23 +1357,17 @@ subroutine forcing_save_restart(CS, G, Time, directory, time_stamped, & end subroutine forcing_save_restart - -subroutine surface_forcing_init(Time, G, param_file, diag, CS, tracer_flow_CSp) - type(time_type), intent(in) :: Time +!> Initialize the surface forcing module +subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_CSp) + type(time_type), intent(in) :: Time !< The current model time type(ocean_grid_type), intent(in) :: G !< The ocean's 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 - type(surface_forcing_CS), pointer :: CS - type(tracer_flow_control_CS), pointer :: tracer_flow_CSp - -! Arguments: -! Time = current model time -! (in) G = ocean grid structure -! (in) param_file = structure indicating the open file to parse for model parameter values -! (in) diag = structure used to regulate diagnostic output -! (in/out) CS = pointer set to point to the control structure for this module -! (in) tracer_flow_CSp = pointer to the control structure of the tracer flow control module - + type(diag_ctrl), target, intent(inout) :: diag !< structure used to regulate diagnostic output + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call + type(tracer_flow_control_CS), pointer :: tracer_flow_CSp !< Forcing for tracers? + ! Local variables type(directories) :: dirs logical :: new_sim type(time_type) :: Time_frc @@ -1830,14 +1699,15 @@ subroutine surface_forcing_init(Time, G, param_file, diag, CS, tracer_flow_CSp) call MESO_surface_forcing_init(Time, G, param_file, diag, CS%MESO_forcing_CSp) elseif (trim(CS%wind_config) == "Neverland") then call Neverland_surface_forcing_init(Time, G, param_file, diag, CS%Neverland_forcing_CSp) - elseif (trim(CS%wind_config) == "SCM_ideal_hurr") then - call SCM_idealized_hurricane_wind_init(Time, G, param_file, CS%SCM_idealized_hurricane_CSp) + elseif (trim(CS%wind_config) == "ideal_hurr" .or.& + trim(CS%wind_config) == "SCM_ideal_hurr") then + 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"//& "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 zonal\n"//& + "With wind_config const, this is the constant meridional\n"//& "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 @@ -1845,7 +1715,7 @@ subroutine surface_forcing_init(Time, G, param_file, diag, CS, tracer_flow_CSp) CS%SCM_CVmix_tests_CSp%Rho0 = CS%Rho0 !copy reference density for pass endif - call register_forcing_type_diags(Time, diag, CS%use_temperature, CS%handles) + call register_forcing_type_diags(Time, diag, US, CS%use_temperature, CS%handles) ! Set up any restart fields associated with the forcing. call restart_init(param_file, CS%restart_CSp, "MOM_forcing.res") @@ -1891,9 +1761,11 @@ subroutine surface_forcing_init(Time, G, param_file, diag, CS, tracer_flow_CSp) end subroutine surface_forcing_init +!> Deallocate memory associated with the surface forcing module subroutine surface_forcing_end(CS, fluxes) - type(surface_forcing_CS), pointer :: CS - type(forcing), optional, intent(inout) :: fluxes + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call + type(forcing), optional, intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields ! Arguments: CS - A pointer to the control structure returned by a previous ! call to surface_forcing_init, it will be deallocated here. ! (inout) fluxes - A structure containing pointers to any possible diff --git a/config_src/solo_driver/Neverland_surface_forcing.F90 b/config_src/solo_driver/Neverland_surface_forcing.F90 index 588fa5fde8..94726a62c3 100644 --- a/config_src/solo_driver/Neverland_surface_forcing.F90 +++ b/config_src/solo_driver/Neverland_surface_forcing.F90 @@ -4,7 +4,7 @@ module Neverland_surface_forcing ! This file is part of MOM6. See LICENSE.md for the license. use MOM_diag_mediator, only : post_data, query_averaging_enabled -use MOM_diag_mediator, only : register_diag_field, diag_ctrl +use MOM_diag_mediator, only : register_diag_field, diag_ctrl, safe_alloc_ptr use MOM_domains, only : pass_var, pass_vector, AGRID use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type @@ -12,7 +12,8 @@ module Neverland_surface_forcing use MOM_forcing_type, only : allocate_forcing_type, allocate_mech_forcing use MOM_grid, only : ocean_grid_type use MOM_io, only : file_exists, read_data, slasher -use MOM_time_manager, only : time_type, operator(+), operator(/), get_time +use MOM_time_manager, only : time_type, operator(+), operator(/) +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface implicit none ; private @@ -22,17 +23,18 @@ module Neverland_surface_forcing public Neverland_surface_forcing_init !> This control structure should be used to store any run-time variables -!! associated with the Neverland forcing. It can be readily modified -!! for a specific case, and because it is private there will be no changes -!! needed in other code (although they will have to be recompiled). +!! associated with the Neverland forcing. +!! +!! It can be readily modified for a specific case, and because it is private there +!! will be no changes needed in other code (although they will have to be recompiled). type, public :: Neverland_surface_forcing_CS ; private logical :: use_temperature !< If true, use temperature and salinity. logical :: restorebuoy !< If true, use restoring surface buoyancy forcing. real :: Rho0 !< The density used in the Boussinesq - !! approximation, in kg m-3. - real :: G_Earth !< The gravitational acceleration in m s-2. - real :: flux_const !< The restoring rate at the surface, in m s-1. + !! approximation [kg m-3]. + real :: G_Earth !< The gravitational acceleration [m s-2]. + real :: flux_const !< The restoring rate at the surface [m s-1]. real, dimension(:,:), pointer :: & buoy_restore(:,:) => NULL() !< The pattern to restore buoyancy to. character(len=200) :: inputdir !< The directory where NetCDF input files are. @@ -45,17 +47,18 @@ module Neverland_surface_forcing !> Sets the surface wind stresses, forces%taux and forces%tauy for the !! Neverland forcing configuration. -subroutine Neverland_wind_forcing(sfc_state, forces, day, G, CS) +subroutine Neverland_wind_forcing(sfc_state, forces, day, G, US, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. + !! describe the surface state of the ocean. type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day !< Time used for determining the fluxes. - type(ocean_grid_type), intent(inout) :: G !< Grid structure. - type(Neverland_surface_forcing_CS), pointer :: CS !< Control structure for this module. - ! Local variable + type(time_type), intent(in) :: day !< Time used for determining the fluxes. + type(ocean_grid_type), intent(inout) :: G !< Grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(Neverland_surface_forcing_CS), pointer :: CS !< Control structure for this module. + + ! Local variables integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - real :: x, y real :: PI real :: tau_max, off @@ -73,23 +76,23 @@ subroutine Neverland_wind_forcing(sfc_state, forces, day, G, CS) ! The i-loop extends to is-1 so that taux can be used later in the ! calculation of ustar - otherwise the lower bound would be Isq. - PI = 4.0*atan(1.0) - forces%taux(:,:) = 0.0 - tau_max = 0.2 - off = 0.02 + PI = 4.0*atan(1.0) + forces%taux(:,:) = 0.0 + tau_max = 0.2 + off = 0.02 do j=js,je ; do I=is-1,Ieq -! x=(G%geoLonT(i,j)-G%west_lon)/G%len_lon - y=(G%geoLatT(i,j)-G%south_lat)/G%len_lat -! forces%taux(I,j) = G%mask2dCu(I,j) * 0.0 +! x = (G%geoLonT(i,j)-G%west_lon)/G%len_lon + y = (G%geoLatT(i,j)-G%south_lat)/G%len_lat +! forces%taux(I,j) = G%mask2dCu(I,j) * 0.0 - if (y.le.0.29) then - forces%taux(I,j) = forces%taux(I,j) + tau_max * ( (1/0.29)*y - ( 1/(2*PI) )*sin( (2*PI*y) / 0.29 ) ) + if (y <= 0.29) then + forces%taux(I,j) = forces%taux(I,j) + tau_max * ( (1/0.29)*y - ( 1/(2*PI) )*sin( (2*PI*y) / 0.29 ) ) endif - if (y.gt.0.29 .and. y.le.(0.8-off)) then - forces%taux(I,j) = forces%taux(I,j) + tau_max *(0.35+0.65*cos(PI*(y-0.29)/(0.51-off)) ) + if ((y > 0.29) .and. (y <= (0.8-off))) then + forces%taux(I,j) = forces%taux(I,j) + tau_max *(0.35+0.65*cos(PI*(y-0.29)/(0.51-off)) ) endif - if (y.gt.(0.8-off) .and. y.le.(1-off) ) then - forces%taux(I,j) = forces%taux(I,j) + tau_max *( 1.5*( (y-1+off) - (0.1/PI)*sin(10.0*PI*(y-0.8+off)) ) ) + if ((y > (0.8-off)) .and. (y <= (1-off))) then + forces%taux(I,j) = forces%taux(I,j) + tau_max *( 1.5*( (y-1+off) - (0.1/PI)*sin(10.0*PI*(y-0.8+off)) ) ) endif enddo ; enddo @@ -101,7 +104,7 @@ subroutine Neverland_wind_forcing(sfc_state, forces, day, G, CS) ! is always positive. ! if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie ! ! This expression can be changed if desired, but need not be. -! forces%ustar(i,j) = G%mask2dT(i,j) * sqrt(CS%gust_const/CS%Rho0 + & +! forces%ustar(i,j) = US%m_to_Z * G%mask2dT(i,j) * sqrt(CS%gust_const/CS%Rho0 + & ! sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & ! 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))/CS%Rho0) ! enddo ; enddo ; endif @@ -109,26 +112,26 @@ subroutine Neverland_wind_forcing(sfc_state, forces, day, G, CS) end subroutine Neverland_wind_forcing !> Returns the value of a cosine-bell function evaluated at x/L - real function cosbell(x,L) +real function cosbell(x,L) - real , intent(in) :: x !< non-dimensional position - real , intent(in) :: L !< non-dimensional width - real :: PI !< 3.1415926... calculated as 4*atan(1) + real , intent(in) :: x !< non-dimensional position + real , intent(in) :: L !< non-dimensional width + real :: PI !< 3.1415926... calculated as 4*atan(1) - PI = 4.0*atan(1.0) - cosbell = 0.5 * (1 + cos(PI*MIN(ABS(x/L),1.0))) - end function cosbell + PI = 4.0*atan(1.0) + cosbell = 0.5 * (1 + cos(PI*MIN(ABS(x/L),1.0))) +end function cosbell !> Returns the value of a sin-spike function evaluated at x/L - real function spike(x,L) +real function spike(x,L) - real , intent(in) :: x !< non-dimensional position - real , intent(in) :: L !< non-dimensional width - real :: PI !< 3.1415926... calculated as 4*atan(1) + real , intent(in) :: x !< non-dimensional position + real , intent(in) :: L !< non-dimensional width + real :: PI !< 3.1415926... calculated as 4*atan(1) - PI = 4.0*atan(1.0) - spike = (1 - sin(PI*MIN(ABS(x/L),0.5))) - end function spike + PI = 4.0*atan(1.0) + spike = (1 - sin(PI*MIN(ABS(x/L),0.5))) +end function spike !> Surface fluxes of buoyancy for the Neverland configurations. @@ -142,7 +145,7 @@ subroutine Neverland_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) type(Neverland_surface_forcing_CS), pointer :: CS !< Control structure for this module. ! Local variables real :: buoy_rest_const ! A constant relating density anomalies to the - ! restoring buoyancy flux, in m5 s-3 kg-1. + ! restoring buoyancy flux [m5 s-3 kg-1]. real :: density_restore ! De integer :: i, j, is, ie, js, je integer :: isd, ied, jsd, jed @@ -160,13 +163,13 @@ subroutine Neverland_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) "Temperature and salinity mode not coded!" ) else ! This is the buoyancy only mode. - call alloc_if_needed(fluxes%buoy, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%buoy, isd, ied, jsd, jed) endif ! MODIFY THE CODE IN THE FOLLOWING LOOPS TO SET THE BUOYANCY FORCING TERMS. if (CS%restorebuoy .and. CS%first_call) then - call alloc_if_needed(CS%buoy_restore, isd, ied, jsd, jed) + call safe_alloc_ptr(CS%buoy_restore, isd, ied, jsd, jed) CS%first_call = .false. ! Set CS%buoy_restore(i,j) here endif @@ -176,7 +179,7 @@ subroutine Neverland_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) "Temperature/salinity restoring not coded!" ) else ! This is the buoyancy only mode. do j=js,je ; do i=is,ie - ! fluxes%buoy is the buoyancy flux into the ocean in m2 s-3. A positive + ! fluxes%buoy is the buoyancy flux into the ocean [m2 s-3]. A positive ! buoyancy flux is of the same sign as heating the ocean. fluxes%buoy(i,j) = 0.0 * G%mask2dT(i,j) enddo ; enddo @@ -194,7 +197,7 @@ subroutine Neverland_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) buoy_rest_const = -1.0 * (CS%G_Earth * CS%flux_const) / CS%Rho0 do j=js,je ; do i=is,ie ! Set density_restore to an expression for the surface potential - ! density in kg m-3 that is being restored toward. + ! density [kg m-3] that is being restored toward. density_restore = 1030.0 fluxes%buoy(i,j) = G%mask2dT(i,j) * buoy_rest_const * & @@ -205,18 +208,6 @@ subroutine Neverland_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) end subroutine Neverland_buoyancy_forcing -!> If ptr is not associated, this routine allocates it with the given size -!! and zeros out its contents. This is equivalent to safe_alloc_ptr in -!! MOM_diag_mediator, but is here so as to be completely transparent. -subroutine alloc_if_needed(ptr, isd, ied, jsd, jed) - real, pointer :: ptr(:,:) - integer :: isd, ied, jsd, jed - if (.not.associated(ptr)) then - allocate(ptr(isd:ied,jsd:jed)) - ptr(:,:) = 0.0 - endif -end subroutine alloc_if_needed - !> Initializes the Neverland control structure. subroutine Neverland_surface_forcing_init(Time, G, param_file, diag, CS) type(time_type), intent(in) :: Time !< The current model time. @@ -229,7 +220,7 @@ subroutine Neverland_surface_forcing_init(Time, G, param_file, diag, CS) ! This include declares and sets the variable "version". #include "version_variable.h" ! Local variables - character(len=40) :: mod = "Neverland_surface_forcing" ! This module's name. + character(len=40) :: mdl = "Neverland_surface_forcing" ! This module's name. if (associated(CS)) then call MOM_error(WARNING, "Neverland_surface_forcing_init called with an associated "// & @@ -240,31 +231,31 @@ subroutine Neverland_surface_forcing_init(Time, G, param_file, diag, CS) CS%diag => diag ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mod, version, "") - call get_param(param_file, mod, "ENABLE_THERMODYNAMICS", CS%use_temperature, & + 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"//& "variables.", default=.true.) - call get_param(param_file, mod, "G_EARTH", CS%G_Earth, & + 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, mod, "RHO_0", CS%Rho0, & + 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"//& "parameters from vertical units of m to kg m-2.", & units="kg m-3", default=1035.0) -! call get_param(param_file, mod, "GUST_CONST", CS%gust_const, & +! call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & ! "The background gustiness in the winds.", units="Pa", & ! default=0.02) - call get_param(param_file, mod, "RESTOREBUOY", CS%restorebuoy, & + 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"//& "given by FLUXCONST.", default= .false.) if (CS%restorebuoy) then - call get_param(param_file, mod, "FLUXCONST", CS%flux_const, & + 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"//& "velocity). Note the non-MKS units.", units="m day-1", & diff --git a/config_src/solo_driver/atmos_ocean_fluxes.F90 b/config_src/solo_driver/atmos_ocean_fluxes.F90 index 66b2463ae7..4a4ddf6da3 100644 --- a/config_src/solo_driver/atmos_ocean_fluxes.F90 +++ b/config_src/solo_driver/atmos_ocean_fluxes.F90 @@ -10,21 +10,24 @@ module atmos_ocean_fluxes_mod contains +!> This subroutine duplicates an interface used by the FMS coupler, but only +!! returns a value of -1. None of the arguments are used for anything. function aof_set_coupler_flux(name, flux_type, implementation, atm_tr_index, & - param, flag, ice_restart_file, ocean_restart_file, & + param, flag, mol_wt, ice_restart_file, ocean_restart_file, & units, caller, verbosity) result (coupler_index) - character(len=*), intent(in) :: name - character(len=*), intent(in) :: flux_type - character(len=*), intent(in) :: implementation - integer, intent(in), optional :: atm_tr_index - real, intent(in), dimension(:), optional :: param - logical, intent(in), dimension(:), optional :: flag - character(len=*), intent(in), optional :: ice_restart_file - character(len=*), intent(in), optional :: ocean_restart_file - character(len=*), intent(in), optional :: units - character(len=*), intent(in), optional :: caller - integer, intent(in), optional :: verbosity + character(len=*), intent(in) :: name !< An unused argument + character(len=*), intent(in) :: flux_type !< An unused argument + character(len=*), intent(in) :: implementation !< An unused argument + integer, optional, intent(in) :: atm_tr_index !< An unused argument + real, dimension(:), optional, intent(in) :: param !< An unused argument + logical, dimension(:), optional, intent(in) :: flag !< An unused argument + real, optional, intent(in) :: mol_wt !< An unused argument + character(len=*), optional, intent(in) :: ice_restart_file !< An unused argument + character(len=*), optional, intent(in) :: ocean_restart_file !< An unused argument + character(len=*), optional, intent(in) :: units !< An unused argument + character(len=*), optional, intent(in) :: caller !< An unused argument + integer, optional, intent(in) :: verbosity !< An unused argument ! None of these arguments are used for anything. diff --git a/config_src/solo_driver/coupler_types.F90 b/config_src/solo_driver/coupler_types.F90 index 819eac6de7..10d22a8eff 100644 --- a/config_src/solo_driver/coupler_types.F90 +++ b/config_src/solo_driver/coupler_types.F90 @@ -1,12 +1,13 @@ +!> 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. -! 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 @@ -28,9 +29,11 @@ module coupler_types_mod 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 @@ -47,6 +50,7 @@ module coupler_types_mod !! 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 @@ -66,18 +70,24 @@ module coupler_types_mod 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 + 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 + !>@{ 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 @@ -94,6 +104,7 @@ module coupler_types_mod !! 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 @@ -113,17 +124,22 @@ module coupler_types_mod 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 + 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 + !>@{ 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 @@ -137,6 +153,7 @@ module coupler_types_mod !! 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 @@ -154,9 +171,11 @@ module coupler_types_mod 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 + 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 @@ -291,10 +310,11 @@ subroutine coupler_type_copy_1d_2d(var_in, var_out, is, ie, js, je, & 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 + 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=*), intent(in), optional :: suffix !< optional suffix to make the name identifier unique + 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):' @@ -310,7 +330,7 @@ subroutine coupler_type_copy_1d_2d(var_in, var_out, is, ie, js, je, & 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 .ne. ' ')) & + 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 @@ -340,10 +360,11 @@ subroutine coupler_type_copy_1d_3d(var_in, var_out, is, ie, js, je, kd, & 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 + 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=*), intent(in), optional :: suffix !< optional suffix to make the name identifier unique + 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):' @@ -360,7 +381,7 @@ subroutine coupler_type_copy_1d_3d(var_in, var_out, is, ie, js, je, kd, & 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 .ne. ' ')) & + 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 @@ -383,10 +404,11 @@ subroutine coupler_type_copy_2d_2d(var_in, var_out, is, ie, js, je, & 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 + 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=*), intent(in), optional :: suffix !< optional suffix to make the name identifier unique + 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):' @@ -402,7 +424,7 @@ subroutine coupler_type_copy_2d_2d(var_in, var_out, is, ie, js, je, & 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 .ne. ' ')) & + 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 @@ -432,10 +454,11 @@ subroutine coupler_type_copy_2d_3d(var_in, var_out, is, ie, js, je, kd, & 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 + 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=*), intent(in), optional :: suffix !< optional suffix to make the name identifier unique + 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):' @@ -452,7 +475,7 @@ subroutine coupler_type_copy_2d_3d(var_in, var_out, is, ie, js, je, kd, & 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 .ne. ' ')) & + 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 @@ -475,10 +498,11 @@ subroutine coupler_type_copy_3d_2d(var_in, var_out, is, ie, js, je, & 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 + 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=*), intent(in), optional :: suffix !< optional suffix to make the name identifier unique + 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):' @@ -494,7 +518,7 @@ subroutine coupler_type_copy_3d_2d(var_in, var_out, is, ie, js, je, & 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 .ne. ' ')) & + 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 @@ -524,10 +548,11 @@ subroutine coupler_type_copy_3d_3d(var_in, var_out, is, ie, js, je, kd, & 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 + 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=*), intent(in), optional :: suffix !< optional suffix to make the name identifier unique + 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):' @@ -544,7 +569,7 @@ subroutine coupler_type_copy_3d_3d(var_in, var_out, is, ie, js, je, kd, & 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 .ne. ' ')) & + 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 @@ -1174,8 +1199,10 @@ subroutine CT_copy_data_2d(var_in, var, halo_size, bc_index, field_index, & !! 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. + 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 @@ -1249,8 +1276,10 @@ subroutine CT_copy_data_3d(var_in, var, halo_size, bc_index, field_index, & !! 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. + 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 @@ -1329,8 +1358,10 @@ subroutine CT_copy_data_2d_3d(var_in, var, halo_size, bc_index, field_index, & !! 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. + 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 @@ -1563,8 +1594,10 @@ subroutine CT_rescale_data_2d(var, scale, halo_size, bc_index, field_index, & !! 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. + 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 @@ -1640,8 +1673,10 @@ subroutine CT_rescale_data_3d(var, scale, halo_size, bc_index, field_index, & !! 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. + 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 @@ -1718,8 +1753,10 @@ subroutine CT_increment_data_2d_2d(var_in, var, halo_size, bc_index, field_index !! 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. + 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 @@ -1802,8 +1839,10 @@ subroutine CT_increment_data_3d_3d(var_in, var, halo_size, bc_index, field_index !! 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. + 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 @@ -1893,8 +1932,10 @@ subroutine CT_increment_data_2d_3d(var_in, weights, var, halo_size, bc_index, fi !! 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. + 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 @@ -1946,7 +1987,8 @@ subroutine CT_increment_data_2d_3d(var_in, weights, var, halo_size, bc_index, fi 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.") + 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 @@ -1955,7 +1997,8 @@ subroutine CT_increment_data_2d_3d(var_in, weights, var, halo_size, bc_index, fi 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.") + 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 @@ -2720,7 +2763,8 @@ 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 + 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 @@ -2746,7 +2790,8 @@ 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 + 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 diff --git a/config_src/solo_driver/coupler_util.F90 b/config_src/solo_driver/coupler_util.F90 index dde67c2976..cc63a9563d 100644 --- a/config_src/solo_driver/coupler_util.F90 +++ b/config_src/solo_driver/coupler_util.F90 @@ -1,9 +1,9 @@ +!> 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. -! 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 @@ -15,24 +15,19 @@ module coupler_util 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 - 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. - + 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 @@ -78,24 +73,20 @@ subroutine extract_coupler_values(BC_struc, BC_index, BC_element, array_out, & 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 - 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, 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 diff --git a/config_src/solo_driver/user_surface_forcing.F90 b/config_src/solo_driver/user_surface_forcing.F90 index 3127101cb4..a9787b9348 100644 --- a/config_src/solo_driver/user_surface_forcing.F90 +++ b/config_src/solo_driver/user_surface_forcing.F90 @@ -1,50 +1,10 @@ +!> Template for user to code up surface forcing. module user_surface_forcing ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* Rewritten by Robert Hallberg, June 2009 * -!* * -!* This file contains the subroutines that a user should modify to * -!* to set the surface wind stresses and fluxes of buoyancy or * -!* temperature and fresh water. They are called when the run-time * -!* parameters WIND_CONFIG or BUOY_CONFIG are set to "USER". The * -!* standard version has simple examples, along with run-time error * -!* messages that will cause the model to abort if this code has not * -!* been modified. This code is intended for use with relatively * -!* simple specifications of the forcing. For more complicated forms, * -!* it is probably a good idea to read the forcing from input files * -!* using "file" for WIND_CONFIG and BUOY_CONFIG. * -!* * -!* USER_wind_forcing should set the surface wind stresses (taux and * -!* tauy) perhaps along with the surface friction velocity (ustar). * -!* * -!* USER_buoyancy forcing is used to set the surface buoyancy * -!* forcing, which may include a number of fresh water flux fields * -!* (evap, lprec, fprec, lrunoff, frunoff, and * -!* vprec) and the surface heat fluxes (sw, lw, latent and sens) * -!* if temperature and salinity are state variables, or it may simply * -!* be the buoyancy flux if it is not. This routine also has coded a * -!* restoring to surface values of temperature and salinity. * -!* * -!* Macros written all in capital letters are defined in MOM_memory.h. * -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q * -!* j+1 > o > o > At ^: v, tauy * -!* j x ^ x ^ x At >: u, taux * -!* j > o > o > At o: h, fluxes. * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** use MOM_diag_mediator, only : post_data, query_averaging_enabled -use MOM_diag_mediator, only : register_diag_field, diag_ctrl +use MOM_diag_mediator, only : register_diag_field, diag_ctrl, safe_alloc_ptr use MOM_domains, only : pass_var, pass_vector, AGRID use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe use MOM_file_parser, only : get_param, param_file_type, log_version @@ -52,64 +12,54 @@ module user_surface_forcing use MOM_forcing_type, only : allocate_forcing_type, allocate_mech_forcing use MOM_grid, only : ocean_grid_type use MOM_io, only : file_exists, read_data -use MOM_time_manager, only : time_type, operator(+), operator(/), get_time +use MOM_time_manager, only : time_type, operator(+), operator(/) use MOM_tracer_flow_control, only : call_tracer_set_forcing use MOM_tracer_flow_control, only : tracer_flow_control_CS +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface implicit none ; private public USER_wind_forcing, USER_buoyancy_forcing, USER_surface_forcing_init +!> This control structure should be used to store any run-time variables +!! associated with the user-specified forcing. +!! +!! It can be readily modified for a specific case, and because it is private there +!! will be no changes needed in other code (although they will have to be recompiled). type, public :: user_surface_forcing_CS ; private - ! This control structure should be used to store any run-time variables - ! associated with the user-specified forcing. It can be readily modified - ! for a specific case, and because it is private there will be no changes - ! needed in other code (although they will have to be recompiled). ! The variables in the cannonical example are used for some common ! cases, but do not need to be used. - logical :: use_temperature ! If true, temperature and salinity are used as - ! state variables. - logical :: restorebuoy ! If true, use restoring surface buoyancy forcing. - real :: Rho0 ! The density used in the Boussinesq - ! approximation, in kg m-3. - real :: G_Earth ! The gravitational acceleration in m s-2. - real :: Flux_const ! The restoring rate at the surface, in m s-1. - real :: gust_const ! A constant unresolved background gustiness - ! that contributes to ustar, in Pa. - - type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the - ! timing of diagnostic output. + logical :: use_temperature !< If true, temperature and salinity are used as state variables. + logical :: restorebuoy !< If true, use restoring surface buoyancy forcing. + real :: Rho0 !< The density used in the Boussinesq approximation [kg m-3]. + real :: G_Earth !< The gravitational acceleration [m s-2]. + real :: Flux_const !< The restoring rate at the surface [m s-1]. + real :: gust_const !< A constant unresolved background gustiness + !! that contributes to ustar [Pa]. + + type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the + !! timing of diagnostic output. end type user_surface_forcing_CS contains -subroutine USER_wind_forcing(sfc_state, forces, day, G, CS) +!> This subroutine sets the surface wind stresses, forces%taux and forces%tauy, in [Pa]. +!! These are the stresses in the direction of the model grid (i.e. the same +!! direction as the u- and v- velocities). +subroutine USER_wind_forcing(sfc_state, forces, day, G, US, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. + !! describe the surface state of the ocean. type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day + type(time_type), intent(in) :: day !< The time of the fluxes type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(user_surface_forcing_CS), pointer :: CS - -! This subroutine sets the surface wind stresses, forces%taux and forces%tauy. -! These are the stresses in the direction of the model grid (i.e. the same -! direction as the u- and v- velocities.) They are both in Pa. -! In addition, this subroutine can be used to set the surface friction -! velocity, forces%ustar, in m s-1. This is needed with a bulk mixed layer. -! -! Arguments: state - A structure containing fields that describe the -! surface state of the ocean. -! (out) fluxes - A structure containing pointers to any possible -! forcing fields. Unused fields have NULL ptrs. -! (in) day - Time of the fluxes. -! (in) G - The ocean's grid structure. -! (in) CS - A pointer to the control structure returned by a previous -! call to user_surface_forcing_init + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(user_surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned + !! by a previous call to user_surface_forcing_init + ! Local variables integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB ! When modifying the code, comment out this error message. It is here ! so that the original (unmodified) version is not accidentally used. @@ -118,8 +68,6 @@ subroutine USER_wind_forcing(sfc_state, forces, day, G, CS) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB ! Allocate the forcing arrays, if necessary. call allocate_mech_forcing(G, forces, stress=.true., ustar=.true.) @@ -140,22 +88,26 @@ subroutine USER_wind_forcing(sfc_state, forces, day, G, CS) ! is always positive. if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie ! This expression can be changed if desired, but need not be. - forces%ustar(i,j) = G%mask2dT(i,j) * sqrt(CS%gust_const/CS%Rho0 + & + forces%ustar(i,j) = US%m_to_Z * G%mask2dT(i,j) * sqrt(CS%gust_const/CS%Rho0 + & sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))/CS%Rho0) enddo ; enddo ; endif end subroutine USER_wind_forcing +!> This subroutine specifies the current surface fluxes of buoyancy or +!! temperature and fresh water. It may also be modified to add +!! surface fluxes of user provided tracers. subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(forcing), intent(inout) :: fluxes - type(time_type), intent(in) :: day + !! describe the surface state of the ocean. + type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields + type(time_type), intent(in) :: day !< The time of the fluxes real, intent(in) :: dt !< The amount of time over which - !! the fluxes apply, in s + !! the fluxes apply [s] type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(user_surface_forcing_CS), pointer :: CS + type(user_surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned + !! by a previous call to user_surface_forcing_init ! This subroutine specifies the current surface fluxes of buoyancy or ! temperature and fresh water. It may also be modified to add @@ -171,24 +123,14 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) ! are in W m-2 and positive for heat going into the ocean. All fresh water ! fluxes are in kg m-2 s-1 and positive for water moving into the ocean. -! Arguments: state - A structure containing fields that describe the -! surface state of the ocean. -! (out) fluxes - A structure containing pointers to any possible -! forcing fields. Unused fields have NULL ptrs. -! (in) day_start - Start time of the fluxes. -! (in) day_interval - Length of time over which these fluxes -! will be applied. -! (in) G - The ocean's grid structure. -! (in) CS - A pointer to the control structure returned by a previous -! call to user_surface_forcing_init - - real :: Temp_restore ! The temperature that is being restored toward, in C. - real :: Salin_restore ! The salinity that is being restored toward, in PSU. + ! Local variables + real :: Temp_restore ! The temperature that is being restored toward [degC]. + real :: Salin_restore ! The salinity that is being restored toward [ppt] real :: density_restore ! The potential density that is being restored - ! toward, in kg m-3. - real :: rhoXcp ! The mean density times the heat capacity, in J m-3 K-1. + ! toward [kg m-3]. + real :: rhoXcp ! The mean density times the heat capacity [J m-3 degC-1]. real :: buoy_rest_const ! A constant relating density anomalies to the - ! restoring buoyancy flux, in m5 s-3 kg-1. + ! restoring buoyancy flux [m5 s-3 kg-1]. integer :: i, j, is, ie, js, je integer :: isd, ied, jsd, jed @@ -204,19 +146,19 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) ! Allocate and zero out the forcing arrays, as necessary. This portion is ! usually not changed. if (CS%use_temperature) then - call alloc_if_needed(fluxes%evap, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%lprec, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%fprec, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%lrunoff, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%frunoff, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%vprec, isd, ied, jsd, jed) - - call alloc_if_needed(fluxes%sw, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%lw, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%latent, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%sens, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%evap, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%lprec, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%fprec, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%lrunoff, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%frunoff, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%vprec, isd, ied, jsd, jed) + + call safe_alloc_ptr(fluxes%sw, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%lw, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%latent, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%sens, isd, ied, jsd, jed) else ! This is the buoyancy only mode. - call alloc_if_needed(fluxes%buoy, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%buoy, isd, ied, jsd, jed) endif @@ -226,7 +168,7 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) ! Set whichever fluxes are to be used here. Any fluxes that ! are always zero do not need to be changed here. do j=js,je ; do i=is,ie - ! Fluxes of fresh water through the surface are in units of kg m-2 s-1 + ! Fluxes of fresh water through the surface are in units of [kg m-2 s-1] ! and are positive downward - i.e. evaporation should be negative. fluxes%evap(i,j) = -0.0 * G%mask2dT(i,j) fluxes%lprec(i,j) = 0.0 * G%mask2dT(i,j) @@ -242,7 +184,7 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) enddo ; enddo else ! This is the buoyancy only mode. do j=js,je ; do i=is,ie - ! fluxes%buoy is the buoyancy flux into the ocean in m2 s-3. A positive + ! fluxes%buoy is the buoyancy flux into the ocean [m2 s-3]. A positive ! buoyancy flux is of the same sign as heating the ocean. fluxes%buoy(i,j) = 0.0 * G%mask2dT(i,j) enddo ; enddo @@ -250,7 +192,7 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) if (CS%restorebuoy) then if (CS%use_temperature) then - call alloc_if_needed(fluxes%heat_added, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%heat_added, isd, ied, jsd, jed) ! When modifying the code, comment out this error message. It is here ! so that the original (unmodified) version is not accidentally used. call MOM_error(FATAL, "User_buoyancy_surface_forcing: " // & @@ -258,8 +200,8 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) rhoXcp = CS%Rho0 * fluxes%C_p do j=js,je ; do i=is,ie - ! Set Temp_restore and Salin_restore to the temperature (in C) and - ! salinity (in PSU) that are being restored toward. + ! Set Temp_restore and Salin_restore to the temperature (in degC) and + ! salinity (in PSU or ppt) that are being restored toward. Temp_restore = 0.0 Salin_restore = 0.0 @@ -279,7 +221,7 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) buoy_rest_const = -1.0 * (CS%G_Earth * CS%Flux_const) / CS%Rho0 do j=js,je ; do i=is,ie ! Set density_restore to an expression for the surface potential - ! density in kg m-3 that is being restored toward. + ! density [kg m-3] that is being restored toward. density_restore = 1030.0 fluxes%buoy(i,j) = G%mask2dT(i,j) * buoy_rest_const * & @@ -290,31 +232,14 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) end subroutine USER_buoyancy_forcing -subroutine alloc_if_needed(ptr, isd, ied, jsd, jed) - ! If ptr is not associated, this routine allocates it with the given size - ! and zeros out its contents. This is equivalent to safe_alloc_ptr in - ! MOM_diag_mediator, but is here so as to be completely transparent. - real, pointer :: ptr(:,:) - integer :: isd, ied, jsd, jed - if (.not.associated(ptr)) then - allocate(ptr(isd:ied,jsd:jed)) - ptr(:,:) = 0.0 - endif -end subroutine alloc_if_needed - +!> This subroutine initializes the USER_surface_forcing module subroutine USER_surface_forcing_init(Time, G, param_file, diag, CS) - type(time_type), intent(in) :: Time + type(time_type), intent(in) :: Time !< The current model time type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(diag_ctrl), target, intent(in) :: diag - type(user_surface_forcing_CS), pointer :: CS -! Arguments: Time - The current model time. -! (in) G - The ocean's grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in) diag - A structure that is used to regulate diagnostic output. -! (in/out) CS - A pointer that is set to point to the control structure -! for this module + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate diagnostic output. + type(user_surface_forcing_CS), pointer :: CS !< A pointer that is set to point to + !! the control structure for this module ! This include declares and sets the variable "version". #include "version_variable.h" @@ -363,4 +288,28 @@ subroutine USER_surface_forcing_init(Time, G, param_file, diag, CS) end subroutine USER_surface_forcing_init +!! \namespace user_surface_forcing +!! +!! This file contains the subroutines that a user should modify to +!! to set the surface wind stresses and fluxes of buoyancy or +!! temperature and fresh water. They are called when the run-time +!! parameters WIND_CONFIG or BUOY_CONFIG are set to "USER". The +!! standard version has simple examples, along with run-time error +!! messages that will cause the model to abort if this code has no +!! been modified. This code is intended for use with relatively +!! simple specifications of the forcing. For more complicated forms, +!! it is probably a good idea to read the forcing from input files +!! using "file" for WIND_CONFIG and BUOY_CONFIG. +!! +!! USER_wind_forcing() should set the surface wind stresses (taux and +!! tauy) perhaps along with the surface friction velocity (ustar). +!! +!! USER_buoyancy() forcing is used to set the surface buoyancy +!! forcing, which may include a number of fresh water flux fields +!! (evap, lprec, fprec, lrunoff, frunoff, and +!! vprec) and the surface heat fluxes (sw, lw, latent and sens) +!! if temperature and salinity are state variables, or it may simply +!! be the buoyancy flux if it is not. This routine also has coded a +!! restoring to surface values of temperature and salinity. + end module user_surface_forcing diff --git a/config_src/unit_drivers/MOM_sum_driver.F90 b/config_src/unit_drivers/MOM_sum_driver.F90 index a5c3c029a6..4778bc2167 100644 --- a/config_src/unit_drivers/MOM_sum_driver.F90 +++ b/config_src/unit_drivers/MOM_sum_driver.F90 @@ -166,17 +166,13 @@ program MOM_main contains subroutine benchmark_init_topog_local(D, G, param_file, max_depth) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, intent(out), dimension(SZI_(G),SZJ_(G)) :: D - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - real, intent(in) :: max_depth -! Arguments: D - the bottom depth in m. Intent out. -! (in) G - The ocean's grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: D !< The ocean bottom depth in m + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + real, intent(in) :: max_depth !< The maximum ocean depth in m ! This subroutine sets up the benchmark test case topography - real :: min_depth ! The minimum and maximum depths in m. + real :: min_depth ! The minimum ocean depth in m. real :: PI ! 3.1415926... calculated as 4*atan(1) real :: D0 ! A constant to make the maximum ! ! basin depth MAXIMUM_DEPTH. ! diff --git a/docs/Doxyfile_nortd b/docs/Doxyfile_nortd index 0d34cc4764..e07ce4f0b6 100644 --- a/docs/Doxyfile_nortd +++ b/docs/Doxyfile_nortd @@ -1,4 +1,4 @@ -# Doxyfile 1.8.12 +# Doxyfile 1.8.15 # This file describes the settings to be used by the documentation system # doxygen (www.doxygen.org) for a project. @@ -17,11 +17,11 @@ # Project related configuration options #--------------------------------------------------------------------------- -# This tag specifies the encoding used for all characters in the config file -# that follow. The default is UTF-8 which is also the encoding used for all text -# before the first occurrence of this tag. Doxygen uses libiconv (or the iconv -# built into libc) for the transcoding. See http://www.gnu.org/software/libiconv -# for the list of possible encodings. +# This tag specifies the encoding used for all characters in the configuration +# file that follow. The default is UTF-8 which is also the encoding used for all +# text before the first occurrence of this tag. Doxygen uses libiconv (or the +# iconv built into libc) for the transcoding. See +# https://www.gnu.org/software/libiconv/ for the list of possible encodings. # The default value is: UTF-8. DOXYFILE_ENCODING = UTF-8 @@ -58,7 +58,7 @@ PROJECT_LOGO = # entered, it will be relative to the location where doxygen was started. If # left blank the current directory will be used. -#OUTPUT_DIRECTORY = +OUTPUT_DIRECTORY = # If the CREATE_SUBDIRS tag is set to YES then doxygen will create 4096 sub- # directories (in 2 levels) under the output directory of each output format and @@ -93,6 +93,14 @@ ALLOW_UNICODE_NAMES = NO OUTPUT_LANGUAGE = English +# The OUTPUT_TEXT_DIRECTION tag is used to specify the direction in which all +# documentation generated by doxygen is written. Doxygen will use this +# information to generate all generated output in the proper direction. +# Possible values are: None, LTR, RTL and Context. +# The default value is: None. + +OUTPUT_TEXT_DIRECTION = None + # If the BRIEF_MEMBER_DESC tag is set to YES, doxygen will include brief member # descriptions after the members that are listed in the file and class # documentation (similar to Javadoc). Set to NO to disable this. @@ -226,7 +234,8 @@ TAB_SIZE = 2 # will allow you to put the command \sideeffect (or @sideeffect) in the # documentation, which will result in a user-defined paragraph with heading # "Side Effects:". You can put \n's in the value part of an alias to insert -# newlines. +# newlines (in the resulting output). You can put ^^ in the value part of an +# alias to insert a newline as if a physical newline was in the original file. ALIASES = @@ -327,7 +336,7 @@ BUILTIN_STL_SUPPORT = NO CPP_CLI_SUPPORT = NO # Set the SIP_SUPPORT tag to YES if your project consists of sip (see: -# http://www.riverbankcomputing.co.uk/software/sip/intro) sources only. Doxygen +# https://www.riverbankcomputing.com/software/sip/intro) sources only. Doxygen # will parse them like normal C++ but will assume all classes use public instead # of private inheritance when no explicit protection keyword is present. # The default value is: NO. @@ -425,7 +434,7 @@ LOOKUP_CACHE_SIZE = 0 # normally produced when WARNINGS is set to YES. # The default value is: NO. -EXTRACT_ALL = YES +EXTRACT_ALL = NO # If the EXTRACT_PRIVATE tag is set to YES, all private members of a class will # be included in the documentation. @@ -698,7 +707,7 @@ LAYOUT_FILE = layout.xml # The CITE_BIB_FILES tag can be used to specify one or more bib files containing # the reference definitions. This must be a list of .bib files. The .bib # extension is automatically appended if omitted. This requires the bibtex tool -# to be installed. See also http://en.wikipedia.org/wiki/BibTeX for more info. +# to be installed. See also https://en.wikipedia.org/wiki/BibTeX for more info. # For LaTeX the style of the bibliography can be controlled using # LATEX_BIB_STYLE. To use this feature you need bibtex and perl available in the # search path. See also \cite for info how to create references. @@ -743,7 +752,8 @@ WARN_IF_DOC_ERROR = YES # This WARN_NO_PARAMDOC option can be enabled to get warnings for functions that # are documented, but have no documentation for their parameters or return # value. If set to NO, doxygen will only warn about wrong or incomplete -# parameter documentation, but not about the absence of documentation. +# parameter documentation, but not about the absence of documentation. If +# EXTRACT_ALL is set to YES then this flag will automatically be disabled. # The default value is: NO. WARN_NO_PARAMDOC = NO @@ -777,20 +787,19 @@ WARN_LOGFILE = doxygen.log # The INPUT tag is used to specify the files and/or directories that contain # documented source files. You may enter file names like myfile.cpp or # directories like /usr/src/myproject. Separate the files or directories with -# spaces. +# spaces. See also FILE_PATTERNS and EXTENSION_MAPPING # Note: If this tag is empty the current directory is searched. INPUT = ../src \ front_page.md \ ../config_src/solo_driver \ - ../config_src/dynamic_symmetric \ - ../config_src/coupled_driver/coupler_util.F90 \ + ../config_src/dynamic_symmetric ../config_src/coupled_driver/ocean_model_MOM.F90 # This tag can be used to specify the character encoding of the source files # that doxygen parses. Internally doxygen uses the UTF-8 encoding. Doxygen uses # libiconv (or the iconv built into libc) for the transcoding. See the libiconv -# documentation (see: http://www.gnu.org/software/libiconv) for the list of +# documentation (see: https://www.gnu.org/software/libiconv/) for the list of # possible encodings. # The default value is: UTF-8. @@ -807,8 +816,8 @@ INPUT_ENCODING = UTF-8 # If left blank the following patterns are tested:*.c, *.cc, *.cxx, *.cpp, # *.c++, *.java, *.ii, *.ixx, *.ipp, *.i++, *.inl, *.idl, *.ddl, *.odl, *.h, # *.hh, *.hxx, *.hpp, *.h++, *.cs, *.d, *.php, *.php4, *.php5, *.phtml, *.inc, -# *.m, *.markdown, *.md, *.mm, *.dox, *.py, *.pyw, *.f90, *.f, *.for, *.tcl, -# *.vhd, *.vhdl, *.ucf and *.qsf. +# *.m, *.markdown, *.md, *.mm, *.dox, *.py, *.pyw, *.f90, *.f95, *.f03, *.f08, +# *.f, *.for, *.tcl, *.vhd, *.vhdl, *.ucf and *.qsf. FILE_PATTERNS = *.c \ *.cc \ @@ -860,7 +869,9 @@ EXCLUDE_SYMLINKS = NO # Note that the wildcards are matched against the file with absolute path, so to # exclude all test directories for example use the pattern */test/* -EXCLUDE_PATTERNS = makedep.py Makefile INSTALL +EXCLUDE_PATTERNS = makedep.py \ + Makefile \ + INSTALL # The EXCLUDE_SYMBOLS tag can be used to specify one or more symbol names # (namespaces, classes, functions, etc.) that should be excluded from the @@ -897,7 +908,8 @@ EXAMPLE_RECURSIVE = NO # that contain images that are to be included in the documentation (see the # \image command). -IMAGE_PATH = images ../src +IMAGE_PATH = images \ + ../src # The INPUT_FILTER tag can be used to specify a program that doxygen should # invoke to filter for each input file. Doxygen will invoke the filter program @@ -982,7 +994,7 @@ INLINE_SOURCES = YES STRIP_CODE_COMMENTS = NO # If the REFERENCED_BY_RELATION tag is set to YES then for each documented -# function all documented functions referencing it will be listed. +# entity all documented functions referencing it will be listed. # The default value is: NO. REFERENCED_BY_RELATION = YES @@ -1014,12 +1026,12 @@ SOURCE_TOOLTIPS = YES # If the USE_HTAGS tag is set to YES then the references to source code will # point to the HTML generated by the htags(1) tool instead of doxygen built-in # source browser. The htags tool is part of GNU's global source tagging system -# (see http://www.gnu.org/software/global/global.html). You will need version +# (see https://www.gnu.org/software/global/global.html). You will need version # 4.8.6 or higher. # # To use it do the following: # - Install the latest version of global -# - Enable SOURCE_BROWSER and USE_HTAGS in the config file +# - Enable SOURCE_BROWSER and USE_HTAGS in the configuration file # - Make sure the INPUT points to the root of the source tree # - Run doxygen as normal # @@ -1159,7 +1171,7 @@ HTML_EXTRA_FILES = # The HTML_COLORSTYLE_HUE tag controls the color of the HTML output. Doxygen # will adjust the colors in the style sheet and background images according to # this color. Hue is specified as an angle on a colorwheel, see -# http://en.wikipedia.org/wiki/Hue for more information. For instance the value +# https://en.wikipedia.org/wiki/Hue for more information. For instance the value # 0 represents red, 60 is yellow, 120 is green, 180 is cyan, 240 is blue, 300 # purple, and 360 is red again. # Minimum value: 0, maximum value: 359, default value: 220. @@ -1189,12 +1201,23 @@ HTML_COLORSTYLE_GAMMA = 80 # If the HTML_TIMESTAMP tag is set to YES then the footer of each generated HTML # page will contain the date and time when the page was generated. Setting this # to YES can help to show when doxygen was last run and thus if the -# to NO can help when comparing the output of multiple runs. -# The default value is: YES. +# documentation is up to date. +# The default value is: NO. # This tag requires that the tag GENERATE_HTML is set to YES. HTML_TIMESTAMP = NO +# If the HTML_DYNAMIC_MENUS tag is set to YES then the generated HTML +# documentation will contain a main index with vertical navigation menus that +# are dynamically created via Javascript. If disabled, the navigation index will +# consists of multiple levels of tabs that are statically embedded in every HTML +# page. Disable this option to support browsers that do not have Javascript, +# like the Qt help browser. +# The default value is: YES. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_DYNAMIC_MENUS = YES + # If the HTML_DYNAMIC_SECTIONS tag is set to YES then the generated HTML # documentation will contain sections that can be hidden and shown after the # page has loaded. @@ -1218,12 +1241,12 @@ HTML_INDEX_NUM_ENTRIES = 900 # If the GENERATE_DOCSET tag is set to YES, additional index files will be # generated that can be used as input for Apple's Xcode 3 integrated development -# environment (see: http://developer.apple.com/tools/xcode/), introduced with +# environment (see: https://developer.apple.com/tools/xcode/), introduced with # OSX 10.5 (Leopard). To create a documentation set, doxygen will generate a # Makefile in the HTML output directory. Running make will produce the docset in # that directory and running make install will install the docset in # ~/Library/Developer/Shared/Documentation/DocSets so that Xcode will find it at -# startup. See http://developer.apple.com/tools/creatingdocsetswithdoxygen.html +# startup. See https://developer.apple.com/tools/creatingdocsetswithdoxygen.html # for more information. # The default value is: NO. # This tag requires that the tag GENERATE_HTML is set to YES. @@ -1339,7 +1362,7 @@ QCH_FILE = # The QHP_NAMESPACE tag specifies the namespace to use when generating Qt Help # Project output. For more information please see Qt Help Project / Namespace -# (see: http://qt-project.org/doc/qt-4.8/qthelpproject.html#namespace). +# (see: http://doc.qt.io/qt-4.8/qthelpproject.html#namespace). # The default value is: org.doxygen.Project. # This tag requires that the tag GENERATE_QHP is set to YES. @@ -1347,8 +1370,7 @@ QHP_NAMESPACE = org.doxygen.Project # The QHP_VIRTUAL_FOLDER tag specifies the namespace to use when generating Qt # Help Project output. For more information please see Qt Help Project / Virtual -# Folders (see: http://qt-project.org/doc/qt-4.8/qthelpproject.html#virtual- -# folders). +# Folders (see: http://doc.qt.io/qt-4.8/qthelpproject.html#virtual-folders). # The default value is: doc. # This tag requires that the tag GENERATE_QHP is set to YES. @@ -1356,23 +1378,21 @@ QHP_VIRTUAL_FOLDER = doc # If the QHP_CUST_FILTER_NAME tag is set, it specifies the name of a custom # filter to add. For more information please see Qt Help Project / Custom -# Filters (see: http://qt-project.org/doc/qt-4.8/qthelpproject.html#custom- -# filters). +# Filters (see: http://doc.qt.io/qt-4.8/qthelpproject.html#custom-filters). # This tag requires that the tag GENERATE_QHP is set to YES. QHP_CUST_FILTER_NAME = # The QHP_CUST_FILTER_ATTRS tag specifies the list of the attributes of the # custom filter to add. For more information please see Qt Help Project / Custom -# Filters (see: http://qt-project.org/doc/qt-4.8/qthelpproject.html#custom- -# filters). +# Filters (see: http://doc.qt.io/qt-4.8/qthelpproject.html#custom-filters). # This tag requires that the tag GENERATE_QHP is set to YES. QHP_CUST_FILTER_ATTRS = # The QHP_SECT_FILTER_ATTRS tag specifies the list of the attributes this # project's filter section matches. Qt Help Project / Filter Attributes (see: -# http://qt-project.org/doc/qt-4.8/qthelpproject.html#filter-attributes). +# http://doc.qt.io/qt-4.8/qthelpproject.html#filter-attributes). # This tag requires that the tag GENERATE_QHP is set to YES. QHP_SECT_FILTER_ATTRS = @@ -1465,7 +1485,7 @@ EXT_LINKS_IN_WINDOW = NO FORMULA_FONTSIZE = 10 -# Use the FORMULA_TRANPARENT tag to determine whether or not the images +# Use the FORMULA_TRANSPARENT tag to determine whether or not the images # generated for formulas are transparent PNGs. Transparent PNGs are not # supported properly for IE 6.0, but are supported on all modern browsers. # @@ -1477,7 +1497,7 @@ FORMULA_FONTSIZE = 10 FORMULA_TRANSPARENT = YES # Enable the USE_MATHJAX option to render LaTeX formulas using MathJax (see -# http://www.mathjax.org) which uses client side Javascript for the rendering +# https://www.mathjax.org) which uses client side Javascript for the rendering # instead of using pre-rendered bitmaps. Use this if you do not have LaTeX # installed or if you want to formulas look prettier in the HTML output. When # enabled you may also need to install MathJax separately and configure the path @@ -1504,8 +1524,8 @@ MATHJAX_FORMAT = HTML-CSS # MATHJAX_RELPATH should be ../mathjax. The default value points to the MathJax # Content Delivery Network so you can quickly see the result without installing # MathJax. However, it is strongly recommended to install a local copy of -# MathJax from http://www.mathjax.org before deployment. -# The default value is: http://cdn.mathjax.org/mathjax/latest. +# MathJax from https://www.mathjax.org before deployment. +# The default value is: https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.2/. # This tag requires that the tag USE_MATHJAX is set to YES. MATHJAX_RELPATH = http://cdn.mathjax.org/mathjax/latest @@ -1566,7 +1586,7 @@ SERVER_BASED_SEARCH = NO # # Doxygen ships with an example indexer (doxyindexer) and search engine # (doxysearch.cgi) which are based on the open source search engine library -# Xapian (see: http://xapian.org/). +# Xapian (see: https://xapian.org/). # # See the section "External Indexing and Searching" for details. # The default value is: NO. @@ -1579,7 +1599,7 @@ EXTERNAL_SEARCH = NO # # Doxygen ships with an example indexer (doxyindexer) and search engine # (doxysearch.cgi) which are based on the open source search engine library -# Xapian (see: http://xapian.org/). See the section "External Indexing and +# Xapian (see: https://xapian.org/). See the section "External Indexing and # Searching" for details. # This tag requires that the tag SEARCHENGINE is set to YES. @@ -1631,10 +1651,11 @@ LATEX_OUTPUT = latex # The LATEX_CMD_NAME tag can be used to specify the LaTeX command name to be # invoked. # -# Note that when enabling USE_PDFLATEX this option is only used for generating -# bitmaps for formulas in the HTML output, but not in the Makefile that is -# written to the output directory. -# The default file is: latex. +# Note that when not enabling USE_PDFLATEX the default is latex when enabling +# USE_PDFLATEX the default is pdflatex and when in the later case latex is +# chosen this is overwritten by pdflatex. For specific output languages the +# default can have been set differently, this depends on the implementation of +# the output language. # This tag requires that the tag GENERATE_LATEX is set to YES. LATEX_CMD_NAME = latex @@ -1766,7 +1787,7 @@ LATEX_SOURCE_CODE = NO # The LATEX_BIB_STYLE tag can be used to specify the style to use for the # bibliography, e.g. plainnat, or ieeetr. See -# http://en.wikipedia.org/wiki/BibTeX and \cite for more info. +# https://en.wikipedia.org/wiki/BibTeX and \cite for more info. # The default value is: plain. # This tag requires that the tag GENERATE_LATEX is set to YES. @@ -1819,9 +1840,9 @@ COMPACT_RTF = NO RTF_HYPERLINKS = NO -# Load stylesheet definitions from file. Syntax is similar to doxygen's config -# file, i.e. a series of assignments. You only have to provide replacements, -# missing definitions are set to their default value. +# Load stylesheet definitions from file. Syntax is similar to doxygen's +# configuration file, i.e. a series of assignments. You only have to provide +# replacements, missing definitions are set to their default value. # # See also section "Doxygen usage" for information on how to generate the # default style sheet that doxygen normally uses. @@ -1830,8 +1851,8 @@ RTF_HYPERLINKS = NO RTF_STYLESHEET_FILE = # Set optional variables used in the generation of an RTF document. Syntax is -# similar to doxygen's config file. A template extensions file can be generated -# using doxygen -e rtf extensionFile. +# similar to doxygen's configuration file. A template extensions file can be +# generated using doxygen -e rtf extensionFile. # This tag requires that the tag GENERATE_RTF is set to YES. RTF_EXTENSIONS_FILE = @@ -1949,9 +1970,9 @@ DOCBOOK_PROGRAMLISTING = NO #--------------------------------------------------------------------------- # If the GENERATE_AUTOGEN_DEF tag is set to YES, doxygen will generate an -# AutoGen Definitions (see http://autogen.sf.net) file that captures the -# structure of the code including all documentation. Note that this feature is -# still experimental and incomplete at the moment. +# AutoGen Definitions (see http://autogen.sourceforge.net/) file that captures +# the structure of the code including all documentation. Note that this feature +# is still experimental and incomplete at the moment. # The default value is: NO. GENERATE_AUTOGEN_DEF = NO @@ -2033,7 +2054,8 @@ SEARCH_INCLUDES = YES # preprocessor. # This tag requires that the tag SEARCH_INCLUDES is set to YES. -INCLUDE_PATH = ../src/framework ../config_src/dynamic_symmetric +INCLUDE_PATH = ../src/framework \ + ../config_src/dynamic_symmetric # You can use the INCLUDE_FILE_PATTERNS tag to specify one or more wildcard # patterns (like *.h and *.hpp) to filter out the header-files in the @@ -2373,6 +2395,11 @@ DIAFILE_DIRS = PLANTUML_JAR_PATH = +# When using plantuml, the PLANTUML_CFG_FILE tag can be used to specify a +# configuration file for plantuml. + +PLANTUML_CFG_FILE = + # When using plantuml, the specified paths are searched for files specified by # the !include statement in a plantuml block. diff --git a/docs/README.md b/docs/README.md index c861440fa2..8870a46a26 100644 --- a/docs/README.md +++ b/docs/README.md @@ -17,7 +17,7 @@ which will generate html in `docs/_build/html/`. Start at `docs/_build/html/inde The doxygen generated HTML can be obtained locally (and slightly more quickly) with ```bash -make nortd +make nortd SPHINXBUILD=false ``` which will generate html in `docs/APIs/`. Start at `docs/APIs/index.html`. If doxygen is not already available this will install a local copy of doxygen. @@ -38,11 +38,11 @@ If you are building the full generated sphinx documentation you will need the fo (.e.g `apt-get install libxml2-dev libxslt-dev`) -Before running sphinc (`make html`) you will need to issue: +Before running sphinx (`make html`) you will need to issue: ```bash pip install -r requirements.txt ``` ## Credits -The sphinx documentation of MOM6 is made possible by modifications by Angus Gibson to two packages, [sphinx-fortran](https://github.com/angus-g/sphinx-fortran) and [autodoc_doxygen](https://github.com/angus-g/sphinxcontrib-autodoc_doxygen). +The sphinx documentation of MOM6 is made possible by modifications by [Angus Gibson](https://github.com/angus-g) to two packages, [sphinx-fortran](https://github.com/angus-g/sphinx-fortran) and [autodoc_doxygen](https://github.com/angus-g/sphinxcontrib-autodoc_doxygen). diff --git a/docs/equations/ALE-algorithm.rst b/docs/equations/ALE-algorithm.rst index 694b050b8e..28e808f254 100644 --- a/docs/equations/ALE-algorithm.rst +++ b/docs/equations/ALE-algorithm.rst @@ -5,24 +5,24 @@ The semi-discrete, vertically integrated, Boussinesq hydrostatic equations of motion in general-coordinate :math:`r` are .. math:: - D_t \vec{u} + f \hat{k} \wedge \vec{u} + \nabla_z \Phi + \frac{1}{\rho_o} \nabla_z p &= \nabla \cdot \vec{\underline{\tau}} \\ - \rho \delta_k \Phi + \delta_k p &= 0 \\ - \partial_t h + \nabla_r \cdot ( h \vec{u} ) + \delta_k ( z_r \dot{r} ) &= 0 \\ - \partial_t h \theta + \nabla_r \cdot ( h \vec{u} \theta ) + \delta_k ( z_r \dot{r} \theta ) &= \nabla \cdot \vec{Q}_\theta \\ - \partial_t h S + \nabla_r \cdot ( h \vec{u} S ) + \delta_k ( z_r \dot{r} S ) &= \nabla \cdot \vec{Q}_S \\ - \rho &= \rho(S, \theta, z) + D_t \boldsymbol{u} + f \widehat{\boldsymbol{k}} \wedge \boldsymbol{u} + \frac{\rho}{\rho_o}\boldsymbol{\nabla}_z \Phi + \frac{1}{\rho_o} \boldsymbol{\nabla}_z p &= \boldsymbol{\nabla} \cdot \boldsymbol{\underline{\tau}} ,\\ + \rho \delta_k \Phi + \delta_k p &= 0 ,\\ + \partial_t h + \nabla_r \cdot ( h \boldsymbol{u} ) + \delta_k ( z_r \dot{r} ) &= 0 ,\\ + \partial_t (h \theta) + \nabla_r \cdot ( h \boldsymbol{u} \theta ) + \delta_k ( z_r \dot{r} \theta ) &= \boldsymbol{\nabla} \cdot \boldsymbol{Q}_\theta ,\\ + \partial_t (h S) + \nabla_r \cdot ( h \boldsymbol{u} S ) + \delta_k ( z_r \dot{r} S ) &= \boldsymbol{\nabla} \cdot \boldsymbol{Q}_S ,\\ + \rho &= \rho(S, \theta, z) . The Arbitrary-Lagrangian-Eulerian algorithm we use is quasi-Lagrangian in that in the first (Lagrangian) phase, regardless of the current mesh (or coordinate :math:`r`) we integrate the equations forward with :math:`\dot{r}=0`, i.e.: .. math:: - D_t \vec{u} + f \hat{k} \wedge \vec{u} + \nabla_z \Phi + \frac{1}{\rho_o} \nabla_z p &= \nabla \cdot \vec{\underline{\tau}} \\ - \rho \delta_k \Phi + \delta_k p &= 0 \\ - \partial_t h + \nabla_r \cdot ( h \vec{u} ) &= 0 \\ - \partial_t h \theta + \nabla_r \cdot ( h \vec{u} \theta ) &= \nabla \cdot \vec{Q}_\theta \\ - \partial_t h S + \nabla_r \cdot ( h \vec{u} S ) &= \nabla \cdot \vec{Q}_S \\ - \rho &= \rho(S, \theta, z) + D_t \boldsymbol{u} + f \widehat{\boldsymbol{k}} \wedge \boldsymbol{u} + \frac{\rho}{\rho_o}\boldsymbol{\nabla}_z \Phi + \frac{1}{\rho_o} \boldsymbol{\nabla}_z p &= \boldsymbol{\nabla} \cdot \boldsymbol{\underline{\tau}} ,\\ + \rho \delta_k \Phi + \delta_k p &= 0 ,\\ + \partial_t h + \nabla_r \cdot ( h \boldsymbol{u} ) &= 0 ,\\ + \partial_t (h \theta) + \nabla_r \cdot ( h \boldsymbol{u} \theta ) &= \boldsymbol{\nabla} \cdot \boldsymbol{Q}_\theta ,\\ + \partial_t (h S) + \nabla_r \cdot ( h \boldsymbol{u} S ) &= \boldsymbol{\nabla} \cdot \boldsymbol{Q}_S ,\\ + \rho &= \rho(S, \theta, z) . Notice that by setting :math:`\dot{r}=0` all the terms with the metric :math:`z_r` disappeared. @@ -31,4 +31,3 @@ After a finite amount of time, the mesh (:math:`h`) may become very distorted or unrelated to the intended mesh. At any point in time, we can simply define a new mesh and remap from the current mesh to the new mesh without an explicit change in the physical state. - diff --git a/docs/equations/general_coordinate.rst b/docs/equations/general_coordinate.rst index 377adc9421..6e35dacdd1 100644 --- a/docs/equations/general_coordinate.rst +++ b/docs/equations/general_coordinate.rst @@ -9,9 +9,9 @@ The Boussinesq hydrostatic equations of motion in general-coordinate :math:`r` are .. math:: - D_t \vec{u} + f \hat{k} \wedge \vec{u} + \nabla_z \Phi + \frac{1}{\rho_o} \nabla_z p &= \nabla \cdot \vec{\underline{\tau}} \\ - \rho \partial_z \Phi + \partial_z p &= 0 \\ - \partial_t z_r + \nabla_r \cdot ( z_r \vec{u} ) + \partial_r ( z_r \dot{r} ) &= 0 \\ - \partial_t z_r \theta + \nabla_r \cdot ( z_r \vec{u} \theta ) + \partial_r ( z_r \dot{r} \theta ) &= \nabla \cdot \vec{Q}_\theta \\ - \partial_t z_r S + \nabla_r \cdot ( z_r \vec{u} S ) + \partial_r ( z_r \dot{r} S ) &= \nabla \cdot \vec{Q}_S \\ - \rho &= \rho(S, \theta, z) + D_t \boldsymbol{u} + f \widehat{\boldsymbol{k}} \wedge \boldsymbol{u} + \frac{\rho}{\rho_o}\boldsymbol{\nabla}_z \Phi + \frac{1}{\rho_o} \boldsymbol{\nabla}_z p &= \boldsymbol{\nabla} \cdotp \boldsymbol{\underline{\tau}} ,\\ + \rho \partial_z \Phi + \partial_z p &= 0 ,\\ + \partial_t z_r + \boldsymbol{\nabla}_r \cdotp ( z_r \boldsymbol{u} ) + \partial_r ( z_r \dot{r} ) &= 0 ,\\ + \partial_t (z_r \theta) + \boldsymbol{\nabla}_r \cdotp ( z_r \boldsymbol{u} \theta ) + \partial_r ( z_r \dot{r} \theta ) &= \boldsymbol{\nabla} \cdotp \boldsymbol{Q}_\theta ,\\ + \partial_t (z_r S) + \boldsymbol{\nabla}_r \cdotp ( z_r \boldsymbol{u} S ) + \partial_r ( z_r \dot{r} S ) &= \boldsymbol{\nabla} \cdotp \boldsymbol{Q}_S ,\\ + \rho &= \rho(S, \theta, z) . diff --git a/docs/equations/governing.rst b/docs/equations/governing.rst index 4687b2f8fc..5b37e12118 100644 --- a/docs/equations/governing.rst +++ b/docs/equations/governing.rst @@ -6,39 +6,39 @@ Governing equations The Boussinesq hydrostatic equations of motion in height coordinates are .. math:: - D_t \vec{u} + f \hat{k} \wedge \vec{u} + \nabla_z \Phi + \frac{1}{\rho_o} \nabla_z p &= \nabla \cdot \vec{\underline{\tau}} \\ - \rho \partial_z \Phi + \partial_z p &= 0 \\ - \nabla_z \cdot \vec{u} + \partial_z w &= 0 \\ - D_t \theta &= \nabla \cdot \vec{Q}_\theta \\ - D_t S &= \nabla \cdot \vec{Q}_S \\ - \rho &= \rho(S, \theta, z) - -where notation is described in :ref:`equations-notation`. :math:`\vec{\underline{\tau}}` is the stress tensori and -:math:`\vec{Q}_\theta` and :math:`\vec{Q}_S` are fluxes of heat and salt respectively. + D_t \boldsymbol{u} + f \widehat{\boldsymbol{k}} \wedge \boldsymbol{u} + \frac{\rho}{\rho_o} \boldsymbol{\nabla}_z \Phi + \frac{1}{\rho_o} \boldsymbol{\nabla}_z p &= \boldsymbol{\nabla} \cdotp \boldsymbol{\underline{\tau}} , \\ + \rho \partial_z \Phi + \partial_z p &= 0 , \\ + \boldsymbol{\nabla}_z \cdotp \boldsymbol{u} + \partial_z w &= 0 , \\ + D_t \theta &= \boldsymbol{\nabla} \cdotp \boldsymbol{Q}_\theta , \\ + D_t S &= \boldsymbol{\nabla} \cdotp \boldsymbol{Q}_S , \\ + \rho &= \rho(S, \theta, z) , + +where notation is described in :ref:`equations-notation`. :math:`\boldsymbol{\underline{\tau}}` is the stress tensori and +:math:`\boldsymbol{Q}_\theta` and :math:`\boldsymbol{Q}_S` are fluxes of heat and salt respectively. .. :ref:`vector_invariant` The total derivative is .. math:: - D_t &\equiv \partial_t + \vec{v} \cdot \nabla \\ - &= \partial_t + \vec{u} \cdot \nabla_z + w \partial_z + D_t & \equiv \partial_t + \boldsymbol{v} \cdotp \boldsymbol{\nabla} \\ + &= \partial_t + \boldsymbol{u} \cdotp \boldsymbol{\nabla}_z + w \partial_z . The non-divergence of flow allows a total derivative to be re-written in flux form: .. math:: - D_t \theta &= \partial_t + \nabla \cdot ( \vec{v} \theta ) \\ - &= \partial_t + \nabla_z \cdot ( \vec{u} \theta ) + \partial_z ( w \theta ) + D_t \theta &= \partial_t + \boldsymbol{\nabla} \cdotp ( \boldsymbol{v} \theta ) \\ + &= \partial_t + \boldsymbol{\nabla}_z \cdotp ( \boldsymbol{u} \theta ) + \partial_z ( w \theta ) . The above equations of motion can thus be written as: .. math:: - D_t \vec{u} + f \hat{k} \wedge \vec{u} + \nabla_z \Phi + \frac{1}{\rho_o} \nabla_z p &= \nabla \cdot \vec{\underline{\tau}} \\ - \rho \partial_z \Phi + \partial_z p &= 0 \\ - \nabla_z \cdot \vec{u} + \partial_z w &= 0 \\ - \partial_t \theta + \nabla_z \cdot ( \vec{u} \theta ) + \partial_z ( w \theta ) &= \nabla \cdot \vec{Q}_\theta \\ - \partial_t S + \nabla_z \cdot ( \vec{u} S ) + \partial_z ( w S ) &= \nabla \cdot \vec{Q}_S \\ - \rho &= \rho(S, \theta, z) + D_t \boldsymbol{u} + f \widehat{\boldsymbol{k}} \wedge \boldsymbol{u} + \frac{\rho}{\rho_o}\boldsymbol{\nabla}_z \Phi + \frac{1}{\rho_o} \boldsymbol{\nabla}_z p &= \boldsymbol{\nabla} \cdotp \boldsymbol{\underline{\tau}} ,\\ + \rho \partial_z \Phi + \partial_z p &= 0 ,\\ + \boldsymbol{\nabla}_z \cdotp \boldsymbol{u} + \partial_z w &= 0 ,\\ + \partial_t \theta + \boldsymbol{\nabla}_z \cdotp ( \boldsymbol{u} \theta ) + \partial_z ( w \theta ) &= \boldsymbol{\nabla} \cdotp \boldsymbol{Q}_\theta ,\\ + \partial_t S + \boldsymbol{\nabla}_z \cdotp ( \boldsymbol{u} S ) + \partial_z ( w S ) &= \nabla \cdotp \boldsymbol{Q}_S ,\\ + \rho &= \rho(S, \theta, z) . .. toctree:: vector_invariant_eqns diff --git a/docs/equations/notation.rst b/docs/equations/notation.rst index e15cc204c9..17e320c131 100644 --- a/docs/equations/notation.rst +++ b/docs/equations/notation.rst @@ -16,28 +16,28 @@ Horizontal components of velocity are indicated by :math:`u` and :math:`v` and v :math:`p` is pressure and :math:`\Phi` is geo-potential: -.. math: - \Phi = g z +.. math:: + \Phi = g z . The thermodynamic state variables are usually salinity, :math:`S`, and potential temperature, :math:`\theta` or the absolute salinity and conservative temperature, depending on the equation of state. :math:`\rho` is in-situ density. Vector notation --------------- -The three-dimensional velocity vector is denoted :math:`\vec{v}` +The three-dimensional velocity vector is denoted :math:`\boldsymbol{v}` .. math:: - \vec{v} = \vec{u} + \vec{k} w + \boldsymbol{v} = \boldsymbol{u} + \widehat{\boldsymbol{k}} w , -where :math:`\vec{k}` is the unit vector pointed in the upward vertical direction and :math:`\vec{u} = (u,v,0)` is the horizontal +where :math:`\widehat{\boldsymbol{k}}` is the unit vector pointed in the upward vertical direction and :math:`\boldsymbol{u} = (u, v, 0)` is the horizontal component of velocity normal to the vertical. The gradient operator without a suffix is three dimensional: .. math:: - \nabla = ( \nabla_z, \partial_z ) . + \boldsymbol{\nabla} = ( \boldsymbol{\nabla}_z, \partial_z ) . but a suffix indicates a lateral gradient along a surface of constant property indicated by the suffix: .. math:: - \nabla_z = \left( \left. \partial_x \right|_z, \left. \partial_y \right|_z, 0 \right) . + \boldsymbol{\nabla}_z = \left( \left. \partial_x \right|_z, \left. \partial_y \right|_z, 0 \right) . diff --git a/docs/equations/overview.rst b/docs/equations/overview.rst index b6f8d60627..de7a4e484d 100644 --- a/docs/equations/overview.rst +++ b/docs/equations/overview.rst @@ -4,7 +4,7 @@ Equations The model equations are the layer-integrated vector-invariant form of the hydrostatic primitive equations (either Boussinesq or non-Boussinesq). -We present the equations starting from the hydrostatic Boussinesq equation is +We present the equations starting from the hydrostatic Boussinesq equation in height coordinates and progress through vector-invariant and general-coordinate equations to the final equations used in the A.L.E. algorithm. diff --git a/docs/equations/vector_invariant_eqns.rst b/docs/equations/vector_invariant_eqns.rst index 22c3b10ee1..f57eb8bafa 100644 --- a/docs/equations/vector_invariant_eqns.rst +++ b/docs/equations/vector_invariant_eqns.rst @@ -3,23 +3,23 @@ Vector Invariant Equations ========================== -MOM6 solve the momentum equations written in vector-invariant form. +MOM6 solves the momentum equations written in vector-invariant form. -An identity allows the total derivative of velocity to be written in the vector-invariant form: +A vector identity allows the total derivative of velocity to be written in the vector-invariant form: .. math:: - D_t \vec{u} &= \partial_t \vec{u} + \vec{v} \cdot \nabla \vec{u} \\ - &= \partial_t \vec{u} + \vec{u} \cdot \nabla_z \vec{u} + w \partial_z \vec{u} \\ - &= \partial_t \vec{u} + \left( \nabla \wedge \vec{u} \right) \wedge \vec{v} + \nabla \frac{1}{2} \left|\vec{u}\right|^2 + D_t \boldsymbol{u} &= \partial_t \boldsymbol{u} + \boldsymbol{v} \cdotp \boldsymbol{\nabla} \boldsymbol{u} \\ + &= \partial_t \boldsymbol{u} + \boldsymbol{u} \cdotp \boldsymbol{\nabla}_z \boldsymbol{u} + w \partial_z \boldsymbol{u} \\ + &= \partial_t \boldsymbol{u} + \left( \boldsymbol{\nabla} \wedge \boldsymbol{u} \right) \wedge \boldsymbol{v} + \boldsymbol{\nabla} \underbrace{\frac{1}{2} \left|\boldsymbol{u}\right|^2}_{\equiv K} . The flux-form equations of motion in height coordinates can thus be written succinctly as: .. math:: - \partial_t \vec{u} + \left( f \hat{k} + \nabla \wedge \vec{u} \right) \wedge \vec{v} + \nabla K - + \frac{\rho}{\rho_o} \nabla \Phi + \frac{1}{\rho_o} \nabla p &= \nabla \cdot \vec{\underline{\tau}} \\ - \nabla_z \cdot \vec{u} + \partial_z w &= 0 \\ - \partial_t \theta + \nabla_z \cdot ( \vec{u} \theta ) + \partial_z ( w \theta ) &= \nabla \cdot \vec{Q}_\theta \\ - \partial_t S + \nabla_z \cdot ( \vec{u} S ) + \partial_z ( w S ) &= \nabla \cdot \vec{Q}_S \\ - \rho &= \rho(S, \theta, z) + \partial_t \boldsymbol{u} + \left( f \widehat{\boldsymbol{k}} + \boldsymbol{\nabla} \wedge \boldsymbol{u} \right) \wedge \boldsymbol{v} + \boldsymbol{\nabla} K + + \frac{\rho}{\rho_o} \boldsymbol{\nabla} \Phi + \frac{1}{\rho_o} \boldsymbol{\nabla} p &= \boldsymbol{\nabla} \cdotp \boldsymbol{\underline{\tau}} ,\\ + \boldsymbol{\nabla}_z \cdotp \boldsymbol{u} + \partial_z w &= 0 ,\\ + \partial_t \theta + \boldsymbol{\nabla}_z \cdotp ( \boldsymbol{u} \theta ) + \partial_z ( w \theta ) &= \boldsymbol{\nabla} \cdotp \boldsymbol{Q}_\theta ,\\ + \partial_t S + \boldsymbol{\nabla}_z \cdotp ( \boldsymbol{u} S ) + \partial_z ( w S ) &= \boldsymbol{\nabla} \cdotp \boldsymbol{Q}_S ,\\ + \rho &= \rho(S, \theta, z) , where the horizontal momentum equations and vertical hydrostatic balance equation have been written as a single three-dimensional equation. diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 34ad978cd2..f6c84dff5a 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -1,8 +1,10 @@ !> This module contains the main regridding routines. +!! !! Regridding comprises two steps: -!! (1) Interpolation and creation of a new grid based on target interface -!! densities (or any other criterion). -!! (2) Remapping of quantities between old grid and new grid. +!! 1. Interpolation and creation of a new grid based on target interface +!! densities (or any other criterion). +!! 2. Remapping of quantities between old grid and new grid. +!! !! Original module written by Laurent White, 2008.06.09 module MOM_ALE @@ -24,14 +26,12 @@ module MOM_ALE use MOM_interface_heights,only : find_eta use MOM_regridding, only : initialize_regridding, regridding_main, end_regridding use MOM_regridding, only : uniformResolution -use MOM_regridding, only : inflate_vanished_layers_old, setCoordinateResolution +use MOM_regridding, only : inflate_vanished_layers_old use MOM_regridding, only : set_target_densities_from_GV, set_target_densities use MOM_regridding, only : regriddingCoordinateModeDoc, DEFAULT_COORDINATE_MODE use MOM_regridding, only : regriddingInterpSchemeDoc, regriddingDefaultInterpScheme use MOM_regridding, only : regriddingDefaultBoundaryExtrapolation use MOM_regridding, only : regriddingDefaultMinThickness -use MOM_regridding, only : set_regrid_max_depths -use MOM_regridding, only : set_regrid_max_thickness use MOM_regridding, only : regridding_CS, set_regrid_params use MOM_regridding, only : getCoordinateInterfaces, getCoordinateResolution use MOM_regridding, only : getCoordinateUnits, getCoordinateShortName @@ -42,6 +42,7 @@ module MOM_ALE use MOM_remapping, only : remapping_CS, dzFromH1H2 use MOM_string_functions, only : uppercase, extractWord, extract_integer use MOM_tracer_registry, only : tracer_registry_type, tracer_type, MOM_tracer_chkinv +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : ocean_grid_type, thermo_var_ptrs use MOM_verticalGrid, only : get_thickness_units, verticalGrid_type @@ -119,16 +120,22 @@ module MOM_ALE public ALE_remap_init_conds public ALE_register_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. + contains !> This routine is typically called (from initialize_MOM in file MOM.F90) !! before the main time integration loop to initialize the regridding stuff. !! We read the MOM_input file to register the values of different !! regridding/remapping parameters. -subroutine ALE_init( param_file, GV, max_depth, CS) +subroutine ALE_init( param_file, GV, US, max_depth, CS) type(param_file_type), intent(in) :: param_file !< Parameter file type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - real, intent(in) :: max_depth !< The maximum depth of the ocean, in m. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(in) :: max_depth !< The maximum depth of the ocean [Z ~> m]. type(ALE_CS), pointer :: CS !< Module control structure ! Local variables @@ -160,7 +167,7 @@ subroutine ALE_init( param_file, GV, max_depth, CS) default=.true.) ! Initialize and configure regridding - call ALE_initRegridding( GV, max_depth, param_file, mdl, CS%regridCS) + call ALE_initRegridding(GV, US, max_depth, param_file, mdl, CS%regridCS) ! Initialize and configure remapping call get_param(param_file, mdl, "REMAPPING_SCHEME", string, & @@ -203,14 +210,15 @@ subroutine ALE_init( param_file, GV, max_depth, CS) 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"//& - "final grid exactly matches the target (new) grid.", units="m", default=0.) + "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.", & - units="m", default=0.) - call set_regrid_params(CS%regridCS, depth_of_time_filter_shallow=filter_shallow_depth*GV%m_to_H, & - depth_of_time_filter_deep=filter_deep_depth*GV%m_to_H) + 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"//& @@ -225,9 +233,10 @@ subroutine ALE_init( param_file, GV, max_depth, CS) end subroutine ALE_init !> Initialize diagnostics for the ALE module. -subroutine ALE_register_diags(Time, G, GV, diag, CS) +subroutine ALE_register_diags(Time, G, GV, US, diag, CS) type(time_type),target, intent(in) :: Time !< Time structure type(ocean_grid_type), intent(in) :: G !< Grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(diag_ctrl), target, intent(in) :: diag !< Diagnostics control structure type(ALE_CS), pointer :: CS !< Module control structure @@ -247,7 +256,7 @@ subroutine ALE_register_diags(Time, G, GV, diag, CS) CS%id_S_preale = register_diag_field('ocean_model', 'S_preale', diag%axesTL, Time, & 'Salinity before remapping', 'PSU') CS%id_e_preale = register_diag_field('ocean_model', 'e_preale', diag%axesTi, Time, & - 'Interface Heights before remapping', 'm') + 'Interface Heights before remapping', 'm', conversion=US%Z_to_m) CS%id_dzRegrid = register_diag_field('ocean_model','dzRegrid',diag%axesTi,Time, & 'Change in interface height due to ALE regridding', 'm') @@ -268,7 +277,7 @@ subroutine adjustGridForIntegrity( CS, G, GV, h ) type(ocean_grid_type), intent(in) :: G !< Ocean grid informations type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Current 3D grid thickness that - !! are to be adjusted (m or Pa) + !! are to be adjusted [H ~> m or kg-2] call inflate_vanished_layers_old( CS%regridCS, G, GV, h(:,:,:) ) end subroutine adjustGridForIntegrity @@ -292,12 +301,14 @@ end subroutine ALE_end !! the old grid and the new grid. The creation of the new grid can be based !! on z coordinates, target interface densities, sigma coordinates or any !! arbitrary coordinate system. -subroutine ALE_main( G, GV, h, u, v, tv, Reg, CS, dt, frac_shelf_h) +subroutine ALE_main( G, GV, US, h, u, v, tv, Reg, CS, dt, frac_shelf_h) type(ocean_grid_type), intent(in) :: G !< Ocean grid informations type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Current 3D grid obtained after last time step (m or Pa) - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: u !< Zonal velocity field (m/s) - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: v !< Meridional velocity field (m/s) + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Current 3D grid obtained after the + !! last time step [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: u !< Zonal velocity field [m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: v !< Meridional velocity field [m s-1] type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamic variable structure type(tracer_registry_type), pointer :: Reg !< Tracer registry structure type(ALE_CS), pointer :: CS !< Regridding parameters and options @@ -306,7 +317,7 @@ subroutine ALE_main( G, GV, h, u, v, tv, Reg, CS, dt, frac_shelf_h) ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: dzRegrid ! The change in grid interface positions real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: eta_preale - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_new ! New 3D grid obtained after last time step (m or Pa) + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_new ! New 3D grid obtained after last time step [H ~> m or kg-2] integer :: nk, i, j, k, isc, iec, jsc, jec logical :: ice_shelf @@ -326,7 +337,7 @@ subroutine ALE_main( G, GV, h, u, v, tv, Reg, CS, dt, frac_shelf_h) if (CS%id_T_preale > 0) call post_data(CS%id_T_preale, tv%T, CS%diag) if (CS%id_S_preale > 0) call post_data(CS%id_S_preale, tv%S, CS%diag) if (CS%id_e_preale > 0) then - call find_eta(h, tv, GV%g_Earth, G, GV, eta_preale) + call find_eta(h, tv, G, GV, US, eta_preale) call post_data(CS%id_e_preale, eta_preale, CS%diag) endif @@ -360,12 +371,10 @@ subroutine ALE_main( G, GV, h, u, v, tv, Reg, CS, dt, frac_shelf_h) ! Override old grid with new one. The new grid 'h_new' is built in ! one of the 'build_...' routines above. -!$OMP parallel do default(none) shared(isc,iec,jsc,jec,nk,h,h_new,CS) - do k = 1,nk - do j = jsc-1,jec+1 ; do i = isc-1,iec+1 - h(i,j,k) = h_new(i,j,k) - enddo ; enddo - enddo + !$OMP parallel do default(shared) + do k = 1,nk ; do j = jsc-1,jec+1 ; do i = isc-1,iec+1 + h(i,j,k) = h_new(i,j,k) + enddo ; enddo ; enddo if (CS%show_call_tree) call callTree_leave("ALE_main()") @@ -381,14 +390,15 @@ end subroutine ALE_main subroutine ALE_main_offline( G, GV, h, tv, Reg, CS, dt) type(ocean_grid_type), intent(in) :: G !< Ocean grid informations type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Current 3D grid obtained after last time step (m or Pa) + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Current 3D grid obtained after the + !! last time step [H ~> m or kg-2] type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamic variable structure type(tracer_registry_type), pointer :: Reg !< Tracer registry structure type(ALE_CS), pointer :: CS !< Regridding parameters and options real, optional, intent(in) :: dt !< Time step between calls to ALE_main() ! Local variables real, dimension(SZI_(G), SZJ_(G), SZK_(GV)+1) :: dzRegrid ! The change in grid interface positions - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_new ! New 3D grid obtained after last time step (m or Pa) + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_new ! New 3D grid obtained after last time step [H ~> m or kg-2] integer :: nk, i, j, k, isc, iec, jsc, jec nk = GV%ke; isc = G%isc; iec = G%iec; jsc = G%jsc; jec = G%jec @@ -416,12 +426,10 @@ subroutine ALE_main_offline( G, GV, h, tv, Reg, CS, dt) ! Override old grid with new one. The new grid 'h_new' is built in ! one of the 'build_...' routines above. -!$OMP parallel do default(none) shared(isc,iec,jsc,jec,nk,h,h_new,CS) - do k = 1,nk - do j = jsc-1,jec+1 ; do i = isc-1,iec+1 - h(i,j,k) = h_new(i,j,k) - enddo ; enddo - enddo + !$OMP parallel do default(shared) + do k = 1,nk ; do j = jsc-1,jec+1 ; do i = isc-1,iec+1 + h(i,j,k) = h_new(i,j,k) + enddo ; enddo ; enddo if (CS%show_call_tree) call callTree_leave("ALE_main()") if (CS%id_dzRegrid>0 .and. present(dt)) call post_data(CS%id_dzRegrid, dzRegrid, CS%diag) @@ -492,7 +500,7 @@ subroutine ALE_offline_inputs(CS, G, GV, h, tv, Reg, uhtr, vhtr, Kd, debug) endif call interpolate_column(nk, h(i,j,:), Kd(i,j,:), nk, h_new(i,j,:), 0., Kd(i,j,:)) endif - enddo ; enddo; + enddo ; enddo call ALE_remap_scalar(CS%remapCS, G, GV, nk, h, tv%T, h_new, tv%T) call ALE_remap_scalar(CS%remapCS, G, GV, nk, h, tv%S, h_new, tv%S) @@ -514,11 +522,11 @@ end subroutine ALE_offline_inputs subroutine ALE_offline_tracer_final( G, GV, h, tv, h_target, Reg, CS) type(ocean_grid_type), intent(in) :: G !< Ocean grid informations type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Current 3D grid obtained after - !! last time step (m or Pa) + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Current 3D grid obtained after the + !! last time step [H ~> m or kg-2] type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamic variable structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h_target !< Current 3D grid obtained after - !! last time step (m or Pa) + !! last time step [H ~> m or kg-2] type(tracer_registry_type), pointer :: Reg !< Tracer registry structure type(ALE_CS), pointer :: CS !< Regridding parameters and options ! Local variables @@ -556,10 +564,12 @@ end subroutine ALE_offline_tracer_final !> Check grid for negative thicknesses subroutine check_grid( G, GV, h, threshold ) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Current 3D grid obtained after the last time step (H units) - real, intent(in) :: threshold !< Value below which to flag issues (H units) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Current 3D grid obtained after the + !! last time step [H ~> m or kg m-2] + real, intent(in) :: threshold !< Value below which to flag issues, + !! [H ~> m or kg m-2] ! Local variables integer :: i, j @@ -586,7 +596,8 @@ subroutine ALE_build_grid( G, GV, regridCS, remapCS, h, tv, debug, frac_shelf_h type(regridding_CS), intent(in) :: regridCS !< Regridding parameters and options type(remapping_CS), intent(in) :: remapCS !< Remapping parameters and options type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamical variable structure - real, dimension(SZI_(G),SZJ_(G), SZK_(GV)), intent(inout) :: h !< Current 3D grid obtained after the last time step (m or Pa) + real, dimension(SZI_(G),SZJ_(G), SZK_(GV)), intent(inout) :: h !< Current 3D grid obtained after the + !! last time step [H ~> m or kg-2] logical, optional, intent(in) :: debug !< If true, show the call tree real, dimension(:,:), optional, pointer :: frac_shelf_h !< Fractional ice shelf coverage ! Local variables @@ -640,13 +651,14 @@ subroutine ALE_regrid_accelerated(CS, G, GV, h, tv, n, u, v, Reg, dt, dzRegrid, real, optional, intent(in) :: dt !< Model timestep to provide a timescale for regridding real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & optional, intent(inout) :: dzRegrid !< Final change in interface positions - logical, optional, intent(in) :: initial !< Whether we're being called from an initialization routine (and expect diagnostics to work) + logical, optional, intent(in) :: initial !< Whether we're being called from an initialization + !! routine (and expect diagnostics to work) ! Local variables integer :: i, j, k, nz type(thermo_var_ptrs) :: tv_local ! local/intermediate temp/salt type(group_pass_type) :: pass_T_S_h ! group pass if the coordinate has a stencil - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_loc, h_orig ! A working copy of layer thickesses + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_loc, h_orig ! A working copy of layer thicknesses real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), target :: T, S ! local temporary state ! we have to keep track of the total dzInterface if for some reason ! we're using the old remapping algorithm for u/v @@ -707,18 +719,24 @@ end subroutine ALE_regrid_accelerated !! remap initiali conditions to the model grid. It is also called during a !! time step to update the state. subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, dxInterface, u, v, debug, dt) - type(remapping_CS), intent(in) :: CS_remapping !< Remapping control structure - type(ALE_CS), intent(in) :: CS_ALE !< ALE control structure - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_old !< Thickness of source grid (m or Pa) - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_new !< Thickness of destination grid (m or Pa) - type(tracer_registry_type), pointer :: Reg !< Tracer registry structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1),optional, intent(in) :: dxInterface !< Change in interface position (Hm or Pa) - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), optional, intent(inout) :: u !< Zonal velocity component (m/s) - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), optional, intent(inout) :: v !< Meridional velocity component (m/s) - logical, optional, intent(in) :: debug !< If true, show the call tree - real, optional, intent(in) :: dt !< time step for diagnostics + type(remapping_CS), intent(in) :: CS_remapping !< Remapping control structure + type(ALE_CS), intent(in) :: CS_ALE !< ALE control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_old !< Thickness of source grid + !! [H ~> m or kg-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_new !< Thickness of destination grid + !! [H ~> m or kg-2] + type(tracer_registry_type), pointer :: Reg !< Tracer registry structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & + optional, intent(in) :: dxInterface !< Change in interface position + !! [H ~> m or kg-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + optional, intent(inout) :: u !< Zonal velocity component [m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + optional, intent(inout) :: v !< Meridional velocity component [m s-1] + logical, optional, intent(in) :: debug !< If true, show the call tree + real, optional, intent(in) :: dt !< time step for diagnostics ! Local variables integer :: i, j, k, m integer :: nz, ntr @@ -740,8 +758,8 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, ! If remap_uv_using_old_alg is .true. and u or v is requested, then we must have dxInterface. Otherwise, ! u and v can be remapped without dxInterface if ( .not. present(dxInterface) .and. (CS_ALE%remap_uv_using_old_alg .and. (present(u) .or. present(v))) ) then - call MOM_error(FATAL, "remap_all_state_vars: dxInterface must be present if using old algorithm and u/v are to"// & - "be remapped") + call MOM_error(FATAL, "remap_all_state_vars: dxInterface must be present if using old algorithm "// & + "and u/v are to be remapped") endif !### Try replacing both of these with GV%H_subroundoff @@ -754,14 +772,12 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, nz = GV%ke ppt2mks = 0.001 - if (associated(Reg)) then - ntr = Reg%ntr - else - ntr = 0 - endif + ntr = 0 ; if (associated(Reg)) ntr = Reg%ntr if (present(dt)) then Idt = 1.0/dt + work_conc(:,:,:) = 0.0 + work_cont(:,:,:) = 0.0 endif ! Remap tracer @@ -770,53 +786,48 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, !$OMP parallel do default(shared) private(h1,h2,u_column,Tr) do m=1,ntr ! For each tracer Tr => Reg%Tr(m) - do j = G%jsc,G%jec - do i = G%isc,G%iec - if (G%mask2dT(i,j)>0.) then - ! Build the start and final grids - h1(:) = h_old(i,j,:) - h2(:) = h_new(i,j,:) - call remapping_core_h(CS_remapping, nz, h1, Tr%t(i,j,:), nz, h2, & - u_column, h_neglect, h_neglect_edge) - - ! Intermediate steps for tendency of tracer concentration and tracer content. - if (present(dt)) then - if (Tr%id_remap_conc>0) then - do k=1,GV%ke - work_conc(i,j,k) = (u_column(k) - Tr%t(i,j,k) ) * Idt - enddo - endif - if (Tr%id_remap_cont>0. .or. Tr%id_remap_cont_2d>0) then - do k=1,GV%ke - work_cont(i,j,k) = (u_column(k)*h2(k) - Tr%t(i,j,k)*h1(k)) * Idt - enddo - endif - endif - ! update tracer concentration - Tr%t(i,j,:) = u_column(:) + do j = G%jsc,G%jec ; do i = G%isc,G%iec ; if (G%mask2dT(i,j)>0.) then + ! Build the start and final grids + h1(:) = h_old(i,j,:) + h2(:) = h_new(i,j,:) + call remapping_core_h(CS_remapping, nz, h1, Tr%t(i,j,:), nz, h2, & + u_column, h_neglect, h_neglect_edge) + + ! Intermediate steps for tendency of tracer concentration and tracer content. + if (present(dt)) then + if (Tr%id_remap_conc>0) then + do k=1,GV%ke + work_conc(i,j,k) = (u_column(k) - Tr%t(i,j,k) ) * Idt + enddo endif - enddo ! i - enddo ! j + if (Tr%id_remap_cont>0. .or. Tr%id_remap_cont_2d>0) then + do k=1,GV%ke + work_cont(i,j,k) = (u_column(k)*h2(k) - Tr%t(i,j,k)*h1(k)) * Idt + enddo + endif + endif + ! update tracer concentration + Tr%t(i,j,:) = u_column(:) + endif ; enddo ; enddo ! tendency diagnostics. - if (Tr%id_remap_conc > 0) then - call post_data(Tr%id_remap_conc, work_conc, CS_ALE%diag) - endif - if (Tr%id_remap_cont > 0) then - call post_data(Tr%id_remap_cont, work_cont, CS_ALE%diag) - endif - if (Tr%id_remap_cont_2d > 0) then - do j = G%jsc,G%jec - do i = G%isc,G%iec + if (present(dt)) then + if (Tr%id_remap_conc > 0) then + call post_data(Tr%id_remap_conc, work_conc, CS_ALE%diag) + endif + if (Tr%id_remap_cont > 0) then + call post_data(Tr%id_remap_cont, work_cont, CS_ALE%diag) + endif + if (Tr%id_remap_cont_2d > 0) then + do j = G%jsc,G%jec ; do i = G%isc,G%iec work_2d(i,j) = 0.0 do k = 1,GV%ke work_2d(i,j) = work_2d(i,j) + work_cont(i,j,k) enddo - enddo - enddo - call post_data(Tr%id_remap_cont_2d, work_2d, CS_ALE%diag) + enddo ; enddo + call post_data(Tr%id_remap_cont_2d, work_2d, CS_ALE%diag) + endif endif - enddo ! m=1,ntr endif ! endif for ntr > 0 @@ -826,25 +837,21 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, ! Remap u velocity component if ( present(u) ) then !$OMP parallel do default(shared) private(h1,h2,dx,u_column) - do j = G%jsc,G%jec - do I = G%iscB,G%iecB - if (G%mask2dCu(I,j)>0.) then - ! Build the start and final grids - h1(:) = 0.5 * ( h_old(i,j,:) + h_old(i+1,j,:) ) - if (CS_ALE%remap_uv_using_old_alg) then - dx(:) = 0.5 * ( dxInterface(i,j,:) + dxInterface(i+1,j,:) ) - do k = 1, nz - h2(k) = max( 0., h1(k) + ( dx(k+1) - dx(k) ) ) - enddo - else - h2(:) = 0.5 * ( h_new(i,j,:) + h_new(i+1,j,:) ) - endif - call remapping_core_h(CS_remapping, nz, h1, u(I,j,:), nz, h2, & - u_column, h_neglect, h_neglect_edge) - u(I,j,:) = u_column(:) - endif - enddo - enddo + do j = G%jsc,G%jec ; do I = G%iscB,G%iecB ; if (G%mask2dCu(I,j)>0.) then + ! Build the start and final grids + h1(:) = 0.5 * ( h_old(i,j,:) + h_old(i+1,j,:) ) + if (CS_ALE%remap_uv_using_old_alg) then + dx(:) = 0.5 * ( dxInterface(i,j,:) + dxInterface(i+1,j,:) ) + do k = 1, nz + h2(k) = max( 0., h1(k) + ( dx(k+1) - dx(k) ) ) + enddo + else + h2(:) = 0.5 * ( h_new(i,j,:) + h_new(i+1,j,:) ) + endif + call remapping_core_h(CS_remapping, nz, h1, u(I,j,:), nz, h2, & + u_column, h_neglect, h_neglect_edge) + u(I,j,:) = u_column(:) + endif ; enddo ; enddo endif if (show_call_tree) call callTree_waypoint("u remapped (remap_all_state_vars)") @@ -852,29 +859,25 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, ! Remap v velocity component if ( present(v) ) then !$OMP parallel do default(shared) private(h1,h2,dx,u_column) - do J = G%jscB,G%jecB - do i = G%isc,G%iec - if (G%mask2dCv(i,j)>0.) then - ! Build the start and final grids - h1(:) = 0.5 * ( h_old(i,j,:) + h_old(i,j+1,:) ) - if (CS_ALE%remap_uv_using_old_alg) then - dx(:) = 0.5 * ( dxInterface(i,j,:) + dxInterface(i,j+1,:) ) - do k = 1, nz - h2(k) = max( 0., h1(k) + ( dx(k+1) - dx(k) ) ) - enddo - else - h2(:) = 0.5 * ( h_new(i,j,:) + h_new(i,j+1,:) ) - endif - call remapping_core_h(CS_remapping, nz, h1, v(i,J,:), nz, h2, & - u_column, h_neglect, h_neglect_edge) - v(i,J,:) = u_column(:) - endif - enddo - enddo + do J = G%jscB,G%jecB ; do i = G%isc,G%iec ; if (G%mask2dCv(i,j)>0.) then + ! Build the start and final grids + h1(:) = 0.5 * ( h_old(i,j,:) + h_old(i,j+1,:) ) + if (CS_ALE%remap_uv_using_old_alg) then + dx(:) = 0.5 * ( dxInterface(i,j,:) + dxInterface(i,j+1,:) ) + do k = 1, nz + h2(k) = max( 0., h1(k) + ( dx(k+1) - dx(k) ) ) + enddo + else + h2(:) = 0.5 * ( h_new(i,j,:) + h_new(i,j+1,:) ) + endif + call remapping_core_h(CS_remapping, nz, h1, v(i,J,:), nz, h2, & + u_column, h_neglect, h_neglect_edge) + v(i,J,:) = u_column(:) + endif ; enddo ; enddo endif if (CS_ALE%id_vert_remap_h > 0) call post_data(CS_ALE%id_vert_remap_h, h_old, CS_ALE%diag) - if (CS_ALE%id_vert_remap_h_tendency > 0) then + if ((CS_ALE%id_vert_remap_h_tendency > 0) .and. present(dt)) then do k = 1, nz ; do j = G%jsc,G%jec ; do i = G%isc,G%iec work_cont(i,j,k) = (h_new(i,j,k) - h_old(i,j,k))*Idt enddo ; enddo ; enddo @@ -894,9 +897,11 @@ subroutine ALE_remap_scalar(CS, G, GV, nk_src, h_src, s_src, h_dst, s_dst, all_c type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure integer, intent(in) :: nk_src !< Number of levels on source grid - real, dimension(SZI_(G),SZJ_(G),nk_src), intent(in) :: h_src !< Level thickness of source grid (m or Pa) + real, dimension(SZI_(G),SZJ_(G),nk_src), intent(in) :: h_src !< Level thickness of source grid + !! [H ~> m or kg-2] real, dimension(SZI_(G),SZJ_(G),nk_src), intent(in) :: s_src !< Scalar on source grid - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)),intent(in) :: h_dst !< Level thickness of destination grid (m or Pa) + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)),intent(in) :: h_dst !< Level thickness of destination grid + !! [H ~> m or kg-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)),intent(inout) :: s_dst !< Scalar on destination grid logical, optional, intent(in) :: all_cells !< If false, only reconstruct for !! non-vanished cells. Use all vanished @@ -967,7 +972,7 @@ subroutine pressure_gradient_plm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_ext intent(inout) :: T_b !< Temperature at the bottom edge of each layer type(thermo_var_ptrs), intent(in) :: tv !< thermodynamics structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< layer thickness in H + intent(in) :: h !< layer thickness [H ~> m or kg m-2] logical, intent(in) :: bdry_extrap !< If true, use high-order boundary !! extrapolation within boundary cells @@ -988,38 +993,36 @@ subroutine pressure_gradient_plm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_ext ! Determine reconstruction within each column !$OMP parallel do default(shared) private(hTmp,ppol_E,ppol_coefs,tmp) - do j = G%jsc-1,G%jec+1 - do i = G%isc-1,G%iec+1 - ! Build current grid - hTmp(:) = h(i,j,:) - tmp(:) = tv%S(i,j,:) - ! Reconstruct salinity profile - ppol_E(:,:) = 0.0 - ppol_coefs(:,:) = 0.0 - call PLM_reconstruction( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) - if (bdry_extrap) call & - PLM_boundary_extrapolation( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) - - do k = 1,GV%ke - S_t(i,j,k) = ppol_E(k,1) - S_b(i,j,k) = ppol_E(k,2) - end do - - ! Reconstruct temperature profile - ppol_E(:,:) = 0.0 - ppol_coefs(:,:) = 0.0 - tmp(:) = tv%T(i,j,:) - call PLM_reconstruction( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) - if (bdry_extrap) call & - PLM_boundary_extrapolation( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) - - do k = 1,GV%ke - T_t(i,j,k) = ppol_E(k,1) - T_b(i,j,k) = ppol_E(k,2) - end do - - end do - end do + do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1 + ! Build current grid + hTmp(:) = h(i,j,:) + tmp(:) = tv%S(i,j,:) + ! Reconstruct salinity profile + ppol_E(:,:) = 0.0 + ppol_coefs(:,:) = 0.0 + call PLM_reconstruction( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) + if (bdry_extrap) & + call PLM_boundary_extrapolation( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) + + do k = 1,GV%ke + S_t(i,j,k) = ppol_E(k,1) + S_b(i,j,k) = ppol_E(k,2) + enddo + + ! Reconstruct temperature profile + ppol_E(:,:) = 0.0 + ppol_coefs(:,:) = 0.0 + tmp(:) = tv%T(i,j,:) + call PLM_reconstruction( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) + if (bdry_extrap) & + call PLM_boundary_extrapolation( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) + + do k = 1,GV%ke + T_t(i,j,k) = ppol_E(k,1) + T_b(i,j,k) = ppol_E(k,2) + enddo + + enddo ; enddo end subroutine pressure_gradient_plm @@ -1043,7 +1046,7 @@ subroutine pressure_gradient_ppm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_ext intent(inout) :: T_b !< Temperature at the bottom edge of each layer type(thermo_var_ptrs), intent(in) :: tv !< thermodynamics structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< layer thicknesses in H + intent(in) :: h !< layer thicknesses [H ~> m or kg m-2] logical, intent(in) :: bdry_extrap !< If true, use high-order boundary !! extrapolation within boundary cells @@ -1066,52 +1069,51 @@ subroutine pressure_gradient_ppm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_ext ! Determine reconstruction within each column !$OMP parallel do default(shared) private(hTmp,tmp,ppol_E,ppol_coefs) - do j = G%jsc-1,G%jec+1 - do i = G%isc-1,G%iec+1 - - ! Build current grid - hTmp(:) = h(i,j,:) - tmp(:) = tv%S(i,j,:) - - ! Reconstruct salinity profile - ppol_E(:,:) = 0.0 - ppol_coefs(:,:) = 0.0 - !### Try to replace the following value of h_neglect with GV%H_subroundoff. - call edge_values_implicit_h4( GV%ke, hTmp, tmp, ppol_E, h_neglect=h_neglect_edge ) - call PPM_reconstruction( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) - if (bdry_extrap) call & - PPM_boundary_extrapolation( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) - - do k = 1,GV%ke - S_t(i,j,k) = ppol_E(k,1) - S_b(i,j,k) = ppol_E(k,2) - end do - - ! Reconstruct temperature profile - ppol_E(:,:) = 0.0 - ppol_coefs(:,:) = 0.0 - tmp(:) = tv%T(i,j,:) - !### Try to replace the following value of h_neglect with GV%H_subroundoff. - call edge_values_implicit_h4( GV%ke, hTmp, tmp, ppol_E, h_neglect=1.0e-10*GV%m_to_H ) - call PPM_reconstruction( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) - if (bdry_extrap) call & - PPM_boundary_extrapolation(GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) - - do k = 1,GV%ke - T_t(i,j,k) = ppol_E(k,1) - T_b(i,j,k) = ppol_E(k,2) - end do - - end do - end do + do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1 + + ! Build current grid + hTmp(:) = h(i,j,:) + tmp(:) = tv%S(i,j,:) + + ! Reconstruct salinity profile + ppol_E(:,:) = 0.0 + ppol_coefs(:,:) = 0.0 + !### Try to replace the following value of h_neglect with GV%H_subroundoff. + call edge_values_implicit_h4( GV%ke, hTmp, tmp, ppol_E, h_neglect=h_neglect_edge ) + call PPM_reconstruction( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) + if (bdry_extrap) & + call PPM_boundary_extrapolation( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) + + do k = 1,GV%ke + S_t(i,j,k) = ppol_E(k,1) + S_b(i,j,k) = ppol_E(k,2) + enddo + + ! Reconstruct temperature profile + ppol_E(:,:) = 0.0 + ppol_coefs(:,:) = 0.0 + tmp(:) = tv%T(i,j,:) + !### Try to replace the following value of h_neglect with GV%H_subroundoff. + call edge_values_implicit_h4( GV%ke, hTmp, tmp, ppol_E, h_neglect=1.0e-10*GV%m_to_H ) + call PPM_reconstruction( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) + if (bdry_extrap) & + call PPM_boundary_extrapolation(GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) + + do k = 1,GV%ke + T_t(i,j,k) = ppol_E(k,1) + T_b(i,j,k) = ppol_E(k,2) + enddo + + enddo ; enddo end subroutine pressure_gradient_ppm !> Initializes regridding for the main ALE algorithm -subroutine ALE_initRegridding(GV, max_depth, param_file, mdl, regridCS) +subroutine ALE_initRegridding(GV, US, max_depth, param_file, mdl, regridCS) type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - real, intent(in) :: max_depth !< The maximum depth of the ocean, in m. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(in) :: max_depth !< The maximum depth of the ocean [Z ~> m]. type(param_file_type), intent(in) :: param_file !< parameter file character(len=*), intent(in) :: mdl !< Name of calling module type(regridding_CS), intent(out) :: regridCS !< Regridding parameters and work arrays @@ -1124,7 +1126,7 @@ subroutine ALE_initRegridding(GV, max_depth, param_file, mdl, regridCS) trim(regriddingCoordinateModeDoc), & default=DEFAULT_COORDINATE_MODE, fail_if_missing=.true.) - call initialize_regridding(regridCS, GV, max_depth, param_file, mdl, coord_mode, '', '') + call initialize_regridding(regridCS, GV, US, max_depth, param_file, mdl, coord_mode, '', '') end subroutine ALE_initRegridding @@ -1133,7 +1135,7 @@ function ALE_getCoordinate( CS ) type(ALE_CS), pointer :: CS !< module control structure real, dimension(CS%nk+1) :: ALE_getCoordinate - ALE_getCoordinate(:) = getCoordinateInterfaces( CS%regridCS ) + ALE_getCoordinate(:) = getCoordinateInterfaces( CS%regridCS, undo_scaling=.true. ) end function ALE_getCoordinate @@ -1177,14 +1179,14 @@ end subroutine ALE_update_regrid_weights !> Update the vertical grid type with ALE information. !! This subroutine sets information in the verticalGrid_type to be !! consistent with the use of ALE mode. -subroutine ALE_updateVerticalGridType( CS, GV ) - type(ALE_CS), pointer :: CS ! module control structure - type(verticalGrid_type), pointer :: GV ! vertical grid information +subroutine ALE_updateVerticalGridType(CS, GV) + type(ALE_CS), pointer :: CS !< ALE control structure + type(verticalGrid_type), pointer :: GV !< vertical grid information integer :: nk nk = GV%ke - GV%sInterface(1:nk+1) = getCoordinateInterfaces( CS%regridCS ) + GV%sInterface(1:nk+1) = getCoordinateInterfaces( CS%regridCS, undo_scaling=.true. ) GV%sLayer(1:nk) = 0.5*( GV%sInterface(1:nk) + GV%sInterface(2:nk+1) ) GV%zAxisUnits = getCoordinateUnits( CS%regridCS ) GV%zAxisLongName = getCoordinateShortName( CS%regridCS ) @@ -1209,7 +1211,7 @@ subroutine ALE_writeCoordinateFile( CS, GV, directory ) real :: ds(GV%ke), dsi(GV%ke+1) filepath = trim(directory) // trim("Vertical_coordinate") - ds(:) = getCoordinateResolution( CS%regridCS ) + ds(:) = getCoordinateResolution( CS%regridCS, undo_scaling=.true. ) dsi(1) = 0.5*ds(1) dsi(2:GV%ke) = 0.5*( ds(1:GV%ke-1) + ds(2:GV%ke) ) dsi(GV%ke+1) = 0.5*ds(GV%ke) @@ -1232,14 +1234,14 @@ subroutine ALE_initThicknessToCoord( CS, G, GV, h ) type(ALE_CS), intent(inout) :: CS !< module control structure type(ocean_grid_type), intent(in) :: G !< module grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: h !< layer thickness in H + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: h !< layer thickness [H ~> m or kg m-2] ! Local variables integer :: i, j, k do j = G%jsd,G%jed ; do i = G%isd,G%ied - h(i,j,:) = GV%m_to_H * getStaticThickness( CS%regridCS, 0., G%bathyT(i,j) ) - enddo; enddo + h(i,j,:) = GV%Z_to_H * getStaticThickness( CS%regridCS, 0., G%bathyT(i,j) ) + enddo ; enddo end subroutine ALE_initThicknessToCoord diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 482909892b..2a1bcd5bcb 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -7,10 +7,11 @@ module MOM_regridding use MOM_file_parser, only : param_file_type, get_param, log_param use MOM_io, only : file_exists, field_exists, field_size, MOM_read_data use MOM_io, only : slasher +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : ocean_grid_type, thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use MOM_EOS, only : EOS_type, calculate_density -use MOM_string_functions,only : uppercase, extractWord, extract_integer, extract_real +use MOM_string_functions, only : uppercase, extractWord, extract_integer, extract_real use MOM_remapping, only : remapping_CS use regrid_consts, only : state_dependent, coordinateUnits @@ -35,30 +36,40 @@ module MOM_regridding #include +! 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. + !> Regridding control structure -type, public :: regridding_CS - private +type, public :: regridding_CS ; private !> This array is set by function setCoordinateResolution() !! It contains the "resolution" or delta coordinate of the target - !! coorindate. It has the units of the target coordiante, e.g. - !! meters for z*, non-dimensional for sigma, etc. + !! coorindate. It has the units of the target coordinate, e.g. + !! [Z ~> m] for z*, non-dimensional for sigma, etc. real, dimension(:), allocatable :: coordinateResolution + !> This is a scaling factor that restores coordinateResolution to values in + !! the natural units for output. + real :: coord_scale = 1.0 + !> This array is set by function set_target_densities() !! This array is the nominal coordinate of interfaces and is the !! running sum of coordinateResolution. i.e. !! target_density(k+1) = coordinateResolution(k) + coordinateResolution(k) !! It is only used in "rho" mode. real, dimension(:), allocatable :: target_density + + !> A flag to indicate that the target_density arrays has been filled with data. logical :: target_density_set = .false. !> This array is set by function set_regrid_max_depths() - !! It specifies the maximum depth that every interface is allowed to take, in H. + !! It specifies the maximum depth that every interface is allowed to take [H ~> m or kg m-2]. real, dimension(:), allocatable :: max_interface_depths !> This array is set by function set_regrid_max_thickness() - !! It specifies the maximum depth that every interface is allowed to take, in H. + !! It specifies the maximum depth that every interface is allowed to take [H ~> m or kg m-2]. real, dimension(:), allocatable :: max_layer_thickness integer :: nk !< Number of layers/levels in generated grid @@ -70,26 +81,26 @@ module MOM_regridding !> Interpolation control structure type(interp_CS_type) :: interp_CS - !> Minimum thickness allowed when building the new grid through regridding + !> Minimum thickness allowed when building the new grid through regridding [H ~> m or kg m-2]. real :: min_thickness !> Reference pressure for potential density calculations (Pa) real :: ref_pressure = 2.e7 - !> Weight given to old coordinate when blending between new and old grids (nondim) + !> Weight given to old coordinate when blending between new and old grids [nondim] !! Used only below depth_of_time_filter_shallow, with a cubic variation !! from zero to full effect between depth_of_time_filter_shallow and !! depth_of_time_filter_deep. real :: old_grid_weight = 0. - !> Depth above which no time-filtering of grid is applied (H units) + !> Depth above which no time-filtering of grid is applied [H ~> m or kg m-2] real :: depth_of_time_filter_shallow = 0. - !> Depth below which time-filtering of grid is applied at full effect (H units) + !> Depth below which time-filtering of grid is applied at full effect [H ~> m or kg m-2] real :: depth_of_time_filter_deep = 0. !> Fraction (between 0 and 1) of compressibility to add to potential density - !! profiles when interpolating for target grid positions. (nondim) + !! profiles when interpolating for target grid positions. [nondim] real :: compressibility_fraction = 0. !> If true, each interface is given a maximum depth based on a rescaling of @@ -104,12 +115,12 @@ module MOM_regridding !! If false, integrate from the bottom upward, as does the rest of the model. logical :: integrate_downward_for_e = .true. - type(zlike_CS), pointer :: zlike_CS => null() - type(sigma_CS), pointer :: sigma_CS => null() - type(rho_CS), pointer :: rho_CS => null() - type(hycom_CS), pointer :: hycom_CS => null() - type(slight_CS), pointer :: slight_CS => null() - type(adapt_CS), pointer :: adapt_CS => null() + type(zlike_CS), pointer :: zlike_CS => null() !< Control structure for z-like coordinate generator + type(sigma_CS), pointer :: sigma_CS => null() !< Control structure for sigma coordinate generator + type(rho_CS), pointer :: rho_CS => null() !< Control structure for rho coordinate generator + type(hycom_CS), pointer :: hycom_CS => null() !< Control structure for hybrid coordinate generator + type(slight_CS), pointer :: slight_CS => null() !< Control structure for Slight-coordinate generator + type(adapt_CS), pointer :: adapt_CS => null() !< Control structure for adaptive coordinate generator end type @@ -137,7 +148,7 @@ module MOM_regridding " SLIGHT - stretched coordinates above continuous isopycnal\n"//& " ADAPTIVE - optimize for smooth neutral density surfaces" -! Documentation for regridding interpolation schemes +!> Documentation for regridding interpolation schemes character(len=*), parameter, public :: regriddingInterpSchemeDoc = & " P1M_H2 (2nd-order accurate)\n"//& " P1M_H4 (2nd-order accurate)\n"//& @@ -149,8 +160,12 @@ module MOM_regridding " P3M_IH6IH5 (4th-order accurate)\n"//& " PQM_IH4IH3 (4th-order accurate)\n"//& " PQM_IH6IH5 (5th-order accurate)" + +!> Default interpolation scheme character(len=*), parameter, public :: regriddingDefaultInterpScheme = "P1M_H2" +!> Default mode for boundary extrapolation logical, parameter, public :: regriddingDefaultBoundaryExtrapolation = .false. +!> Default minimum thickness for some coordinate generation modes real, parameter, public :: regriddingDefaultMinThickness = 1.e-3 #undef __DO_SAFETY_CHECKS__ @@ -158,16 +173,18 @@ module MOM_regridding contains !> Initialization and configures a regridding control structure based on customizable run-time parameters -subroutine initialize_regridding(CS, GV, max_depth, param_file, mod, coord_mode, param_prefix, param_suffix) - type(regridding_CS), intent(inout) :: CS !< Regridding control structure - type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - real, intent(in) :: max_depth !< The maximum depth of the ocean, in m. +subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_mode, param_prefix, param_suffix) + type(regridding_CS), intent(inout) :: CS !< Regridding control structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(in) :: max_depth !< The maximum depth of the ocean [Z ~> m]. type(param_file_type), intent(in) :: param_file !< Parameter file - character(len=*), intent(in) :: mod !< Name of calling module. + character(len=*), intent(in) :: mdl !< Name of calling module. character(len=*), intent(in) :: coord_mode !< Coordinate mode character(len=*), intent(in) :: param_prefix !< String to prefix to parameter names. !! If empty, causes main model parameters to be used. character(len=*), intent(in) :: param_suffix !< String to append to parameter names. + ! Local variables integer :: ke ! Number of levels character(len=80) :: string, string2, varName ! Temporary strings @@ -178,37 +195,42 @@ subroutine initialize_regridding(CS, GV, max_depth, param_file, mod, coord_mode, logical :: tmpLogical, fix_haloclines, set_max, do_sum, main_parameters logical :: coord_is_state_dependent, ierr real :: filt_len, strat_tol, index_scale, tmpReal + real :: maximum_depth ! The maximum depth of the ocean [m] (not in Z). real :: dz_fixed_sfc, Rho_avg_depth, nlay_sfc_int real :: adaptTimeRatio, adaptZoom, adaptZoomCoeff, adaptBuoyCoeff, adaptAlpha integer :: nz_fixed_sfc, k, nzf(4) - real, dimension(:), allocatable :: dz ! Resolution (thickness) in units of coordinate - real, dimension(:), allocatable :: h_max ! Maximum layer thicknesses, in m. - real, dimension(:), allocatable :: dz_max ! Thicknesses used to find maximum interface depths, in m. - real, dimension(:), allocatable :: z_max ! Maximum interface depths, in m. - real, dimension(:), allocatable :: rho_target ! Target density used in HYBRID mode - ! Thicknesses that give level centers corresponding to table 2 of WOA09 + real, dimension(:), allocatable :: dz ! Resolution (thickness) in units of coordinate, which may be + ! [m] or [Z ~> m] or [H ~> m or kg m-2] or [kg m-3] or other units. + real, dimension(:), allocatable :: h_max ! Maximum layer thicknesses [H ~> m or kg m-2] + real, dimension(:), allocatable :: z_max ! Maximum interface depths [H ~> m or kg m-2] or other + ! units depending on the coordinate + real, dimension(:), allocatable :: dz_max ! Thicknesses used to find maximum interface depths + ! [H ~> m or kg m-2] or other units + real, dimension(:), allocatable :: rho_target ! Target density used in HYBRID mode [kg m-3] + ! Thicknesses [m] that give level centers corresponding to table 2 of WOA09 real, dimension(40) :: woa09_dz = (/ 5., 10., 10., 15., 22.5, 25., 25., 25., & 37.5, 50., 50., 75., 100., 100., 100., 100., & 100., 100., 100., 100., 100., 100., 100., 175., & 250., 375., 500., 500., 500., 500., 500., 500., & 500., 500., 500., 500., 500., 500., 500., 500. /) - call get_param(param_file, mod, "INPUTDIR", inputdir, default=".") + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") inputdir = slasher(inputdir) main_parameters=.false. if (len_trim(param_prefix)==0) main_parameters=.true. - if (main_parameters .and. len_trim(param_suffix)>0) call MOM_error(FATAL,trim(mod)//', initialize_regridding: '// & + if (main_parameters .and. len_trim(param_suffix)>0) call MOM_error(FATAL,trim(mdl)//', initialize_regridding: '// & 'Suffix provided without prefix for parameter names!') CS%nk = 0 CS%regridding_scheme = coordinateMode(coord_mode) coord_is_state_dependent = state_dependent(coord_mode) + maximum_depth = US%Z_to_m*max_depth if (main_parameters) then ! Read coordinate units parameter (main model = REGRIDDING_COORDINATE_UNITS) - call get_param(param_file, mod, "REGRIDDING_COORDINATE_UNITS", coord_units, & - "Units of the regridding coordinuate.",& + call get_param(param_file, mdl, "REGRIDDING_COORDINATE_UNITS", coord_units, & + "Units of the regridding coordinuate.",& !### Spelling error "coordinuate" default=coordinateUnits(coord_mode)) else coord_units=coordinateUnits(coord_mode) @@ -222,7 +244,7 @@ subroutine initialize_regridding(CS, GV, max_depth, param_file, mod, coord_mode, param_name = trim(param_prefix)//"_INTERP_SCHEME_"//trim(param_suffix) string2 = 'PPM_H4' ! Default for diagnostics endif - call get_param(param_file, mod, "INTERPOLATION_SCHEME", string, & + 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"//& @@ -233,7 +255,7 @@ subroutine initialize_regridding(CS, GV, max_depth, param_file, mod, coord_mode, endif if (main_parameters .and. coord_is_state_dependent) then - call get_param(param_file, mod, "BOUNDARY_EXTRAPOLATION", tmpLogical, & + 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"//& @@ -253,9 +275,9 @@ subroutine initialize_regridding(CS, GV, max_depth, param_file, mod, coord_mode, param_name = trim(param_prefix)//"_DEF_"//trim(param_suffix) coord_res_param = trim(param_prefix)//"_RES_"//trim(param_suffix) string2 = 'UNIFORM' - if (max_depth>3000.) string2='WOA09' ! For convenience + if (maximum_depth>3000.) string2='WOA09' ! For convenience endif - call get_param(param_file, mod, param_name, string, & + call get_param(param_file, mdl, param_name, string, & "Determines how to specify the coordinate\n"//& "resolution. Valid options are:\n"//& " PARAM - use the vector-parameter "//trim(coord_res_param)//"\n"//& @@ -279,13 +301,13 @@ subroutine initialize_regridding(CS, GV, max_depth, param_file, mod, coord_mode, if (index(trim(string),'UNIFORM')==1) then if (len_trim(string)==7) then ke = GV%ke ! Use model nk by default - tmpReal = max_depth + tmpReal = maximum_depth elseif (index(trim(string),'UNIFORM:')==1 .and. len_trim(string)>8) then ! Format is "UNIFORM:N" or "UNIFORM:N,dz" ke = extract_integer(string(9:len_trim(string)),'',1) - tmpReal = extract_real(string(9:len_trim(string)),',',2,missing_value=max_depth) + tmpReal = extract_real(string(9:len_trim(string)),',',2,missing_value=maximum_depth) else - call MOM_error(FATAL,trim(mod)//', initialize_regridding: '// & + call MOM_error(FATAL,trim(mdl)//', initialize_regridding: '// & 'Unable to interpret "'//trim(string)//'".') endif allocate(dz(ke)) @@ -296,13 +318,13 @@ subroutine initialize_regridding(CS, GV, max_depth, param_file, mod, coord_mode, GV%Rlay(1)+0.5*(GV%Rlay(1)-GV%Rlay(2)), & GV%Rlay(ke)+0.5*(GV%Rlay(ke)-GV%Rlay(ke-1)) ) endif - if (main_parameters) call log_param(param_file, mod, "!"//coord_res_param, dz, & + if (main_parameters) call log_param(param_file, mdl, "!"//coord_res_param, dz, & trim(message), units=trim(coord_units)) elseif (trim(string)=='PARAM') then ! Read coordinate resolution (main model = ALE_RESOLUTION) ke = GV%ke ! Use model nk by default allocate(dz(ke)) - call get_param(param_file, mod, coord_res_param, dz, & + call get_param(param_file, mdl, coord_res_param, dz, & trim(message), units=trim(coord_units), fail_if_missing=.true.) elseif (index(trim(string),'FILE:')==1) then ! FILE:filename,var_name is assumed to be reading level thickness variables @@ -314,7 +336,7 @@ subroutine initialize_regridding(CS, GV, max_depth, param_file, mod, coord_mode, ! Otherwise assume we should look for the file in INPUTDIR fileName = trim(inputdir) // trim( extractWord(trim(string(6:80)), 1) ) endif - if (.not. file_exists(fileName)) call MOM_error(FATAL,trim(mod)//", initialize_regridding: "// & + if (.not. file_exists(fileName)) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & "Specified file not found: Looking for '"//trim(fileName)//"' ("//trim(string)//")") varName = trim( extractWord(trim(string(6:)), 2) ) @@ -322,12 +344,12 @@ subroutine initialize_regridding(CS, GV, max_depth, param_file, mod, coord_mode, if (field_exists(fileName,'dz')) then; varName = 'dz' elseif (field_exists(fileName,'dsigma')) then; varName = 'dsigma' elseif (field_exists(fileName,'ztest')) then; varName = 'ztest' - else ; call MOM_error(FATAL,trim(mod)//", initialize_regridding: "// & + else ; call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & "Coordinate variable not specified and none could be guessed.") endif endif ! This check fails when the variable is a dimension variable! -AJA - !if (.not. field_exists(fileName,trim(varName))) call MOM_error(FATAL,trim(mod)//", initialize_regridding: "// & + !if (.not. field_exists(fileName,trim(varName))) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & ! "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")") if (CS%regridding_scheme == REGRIDDING_SIGMA) then expected_units = 'nondim' @@ -339,7 +361,7 @@ subroutine initialize_regridding(CS, GV, max_depth, param_file, mod, coord_mode, if (index(trim(varName),'interfaces=')==1) then varName=trim(varName(12:)) call check_grid_def(filename, varName, expected_units, message, ierr) - if (ierr) call MOM_error(FATAL,trim(mod)//", initialize_regridding: "//& + if (ierr) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "//& "Unsupported format in grid definition '"//trim(filename)//"'. Error message "//trim(message)) call field_size(trim(fileName), trim(varName), nzf) ke = nzf(1)-1 @@ -361,15 +383,15 @@ subroutine initialize_regridding(CS, GV, max_depth, param_file, mod, coord_mode, call MOM_read_data(trim(fileName), trim(varName), dz) endif if (main_parameters .and. ke/=GV%ke) then - call MOM_error(FATAL,trim(mod)//', initialize_regridding: '// & + call MOM_error(FATAL,trim(mdl)//', initialize_regridding: '// & 'Mismatch in number of model levels and "'//trim(string)//'".') endif - if (main_parameters) call log_param(param_file, mod, "!"//coord_res_param, dz, & + if (main_parameters) call log_param(param_file, mdl, "!"//coord_res_param, dz, & trim(message), units=coordinateUnits(coord_mode)) elseif (index(trim(string),'FNC1:')==1) then ke = GV%ke; allocate(dz(ke)) call dz_function1( trim(string(6:)), dz ) - if (main_parameters) call log_param(param_file, mod, "!"//coord_res_param, dz, & + if (main_parameters) call log_param(param_file, mdl, "!"//coord_res_param, dz, & trim(message), units=coordinateUnits(coord_mode)) elseif (index(trim(string),'RFNC1:')==1) then ! Function used for set target interface densities @@ -380,45 +402,45 @@ subroutine initialize_regridding(CS, GV, max_depth, param_file, mod, coord_mode, allocate(rho_target(ke+1)) fileName = trim( extractWord(trim(string(8:)), 1) ) if (fileName(1:1)/='.' .and. filename(1:1)/='/') fileName = trim(inputdir) // trim( fileName ) - if (.not. file_exists(fileName)) call MOM_error(FATAL,trim(mod)//", initialize_regridding: HYBRID "// & + if (.not. file_exists(fileName)) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: HYBRID "// & "Specified file not found: Looking for '"//trim(fileName)//"' ("//trim(string)//")") varName = trim( extractWord(trim(string(8:)), 2) ) - if (.not. field_exists(fileName,varName)) call MOM_error(FATAL,trim(mod)//", initialize_regridding: HYBRID "// & + if (.not. field_exists(fileName,varName)) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: HYBRID "// & "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")") call MOM_read_data(trim(fileName), trim(varName), rho_target) varName = trim( extractWord(trim(string(8:)), 3) ) if (varName(1:5) == 'FNC1:') then ! Use FNC1 to calculate dz call dz_function1( trim(string((index(trim(string),'FNC1:')+5):)), dz ) else ! Read dz from file - if (.not. field_exists(fileName,varName)) call MOM_error(FATAL,trim(mod)//", initialize_regridding: HYBRID "// & + if (.not. field_exists(fileName,varName)) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: HYBRID "// & "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")") call MOM_read_data(trim(fileName), trim(varName), dz) endif if (main_parameters) then - call log_param(param_file, mod, "!"//coord_res_param, dz, & + call log_param(param_file, mdl, "!"//coord_res_param, dz, & trim(message), units=coordinateUnits(coord_mode)) - call log_param(param_file, mod, "!TARGET_DENSITIES", rho_target, & + call log_param(param_file, mdl, "!TARGET_DENSITIES", rho_target, & 'HYBRID target densities for itnerfaces', units=coordinateUnits(coord_mode)) endif elseif (index(trim(string),'WOA09')==1) then if (len_trim(string)==5) then tmpReal = 0. ; ke = 0 - do while (tmpReal40 .or. ke<1) call MOM_error(FATAL,trim(mod)//', initialize_regridding: '// & + if (ke>40 .or. ke<1) call MOM_error(FATAL,trim(mdl)//', initialize_regridding: '// & 'For "WOA05:N" N must 0 max_depth) then - if ( dz(ke) + ( max_depth - tmpReal ) > 0. ) then - dz(ke) = dz(ke) + ( max_depth - tmpReal ) + if (tmpReal < maximum_depth) then + dz(ke) = dz(ke) + ( maximum_depth - tmpReal ) + elseif (tmpReal > maximum_depth) then + if ( dz(ke) + ( maximum_depth - tmpReal ) > 0. ) then + dz(ke) = dz(ke) + ( maximum_depth - tmpReal ) else - call MOM_error(FATAL,trim(mod)//", initialize_regridding: "// & + call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & "MAXIMUM_DEPTH was too shallow to adjust bottom layer of DZ!"//trim(string)) endif endif @@ -451,7 +473,18 @@ subroutine initialize_regridding(CS, GV, max_depth, param_file, mod, coord_mode, allocate( CS%target_density(CS%nk+1) ); CS%target_density(:) = -1.E30 endif - if (allocated(dz)) call setCoordinateResolution(dz, CS) + if (allocated(dz)) then + if ((coordinateMode(coord_mode) == REGRIDDING_SIGMA) .or. & + (coordinateMode(coord_mode) == REGRIDDING_RHO)) then + call setCoordinateResolution(dz, CS, scale=1.0) + elseif (coordinateMode(coord_mode) == REGRIDDING_ADAPTIVE) then + call setCoordinateResolution(dz, CS, scale=GV%m_to_H) + CS%coord_scale = GV%H_to_m + else + call setCoordinateResolution(dz, CS, scale=US%m_to_Z) + CS%coord_scale = US%Z_to_m + endif + endif if (allocated(rho_target)) then call set_target_densities(CS, rho_target) @@ -460,15 +493,15 @@ subroutine initialize_regridding(CS, GV, max_depth, param_file, mod, coord_mode, ! \todo This line looks like it would overwrite the target densities set just above? elseif (coordinateMode(coord_mode) == REGRIDDING_RHO) then call set_target_densities_from_GV(GV, CS) - call log_param(param_file, mod, "!TARGET_DENSITIES", CS%target_density, & + call log_param(param_file, mdl, "!TARGET_DENSITIES", CS%target_density, & 'RHO target densities for interfaces', units=coordinateUnits(coord_mode)) endif ! initialise coordinate-specific control structure - call initCoord(CS, coord_mode) + call initCoord(CS, GV, coord_mode) if (main_parameters .and. coord_is_state_dependent) then - call get_param(param_file, mod, "REGRID_COMPRESSIBILITY_FRACTION", tmpReal, & + 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"//& "regions appear stratified.", default=0.) @@ -476,32 +509,32 @@ subroutine initialize_regridding(CS, GV, max_depth, param_file, mod, coord_mode, endif if (main_parameters) then - call get_param(param_file, mod, "MIN_THICKNESS", tmpReal, & + call get_param(param_file, mdl, "MIN_THICKNESS", tmpReal, & "When regridding, this is the minimum layer\n"//& - "thickness allowed.", units="m",& + "thickness allowed.", units="m", scale=GV%m_to_H, & default=regriddingDefaultMinThickness ) - call set_regrid_params(CS, min_thickness=tmpReal*GV%m_to_H) + call set_regrid_params(CS, min_thickness=tmpReal) else call set_regrid_params(CS, min_thickness=0.) endif if (coordinateMode(coord_mode) == REGRIDDING_SLIGHT) then ! Set SLight-specific regridding parameters. - call get_param(param_file, mod, "SLIGHT_DZ_SURFACE", dz_fixed_sfc, & + call get_param(param_file, mdl, "SLIGHT_DZ_SURFACE", dz_fixed_sfc, & "The nominal thickness of fixed thickness near-surface\n"//& - "layers with the SLight coordinate.", units="m", default=1.0) - call get_param(param_file, mod, "SLIGHT_NZ_SURFACE_FIXED", nz_fixed_sfc, & + "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"//& "coordinate.", units="nondimensional", default=2) - call get_param(param_file, mod, "SLIGHT_SURFACE_AVG_DEPTH", Rho_avg_depth, & + 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"//& - "with the SLight coordinate.", units="m", default=1.0) - call get_param(param_file, mod, "SLIGHT_NLAY_TO_INTERIOR", nlay_sfc_int, & + "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"//& "defining where the interior ocean starts with SLight.", & units="nondimensional", default=2.0) - call get_param(param_file, mod, "SLIGHT_FIX_HALOCLINES", fix_haloclines, & + 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"//& @@ -512,11 +545,11 @@ subroutine initialize_regridding(CS, GV, max_depth, param_file, mod, coord_mode, nlay_ML_to_interior=nlay_sfc_int, fix_haloclines=fix_haloclines) if (fix_haloclines) then ! Set additional parameters related to SLIGHT_FIX_HALOCLINES. - call get_param(param_file, mod, "HALOCLINE_FILTER_LENGTH", filt_len, & + call get_param(param_file, mdl, "HALOCLINE_FILTER_LENGTH", filt_len, & "A length scale over which to smooth the temperature and\n"//& "salinity before identifying erroneously unstable haloclines.", & units="m", default=2.0) - call get_param(param_file, mod, "HALOCLINE_STRAT_TOL", strat_tol, & + 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"//& @@ -529,20 +562,20 @@ subroutine initialize_regridding(CS, GV, max_depth, param_file, mod, coord_mode, endif if (coordinateMode(coord_mode) == REGRIDDING_ADAPTIVE) then - call get_param(param_file, mod, "ADAPT_TIME_RATIO", adaptTimeRatio, & - "Ratio of ALE timestep to grid timescale.", units="s", default=1e-1) - call get_param(param_file, mod, "ADAPT_ZOOM_DEPTH", adaptZoom, & - "Depth of near-surface zooming region.", units="m", default=200.0) - call get_param(param_file, mod, "ADAPT_ZOOM_COEFF", adaptZoomCoeff, & + call get_param(param_file, mdl, "ADAPT_TIME_RATIO", adaptTimeRatio, & + "Ratio of ALE timestep to grid timescale.", units="s", default=1e-1) !### Should the units be "nondim"? + call get_param(param_file, mdl, "ADAPT_ZOOM_DEPTH", adaptZoom, & + "Depth of near-surface zooming region.", units="m", default=200.0, scale=GV%m_to_H) + call get_param(param_file, mdl, "ADAPT_ZOOM_COEFF", adaptZoomCoeff, & "Coefficient of near-surface zooming diffusivity.", & units="nondim", default=0.2) - call get_param(param_file, mod, "ADAPT_BUOY_COEFF", adaptBuoyCoeff, & + call get_param(param_file, mdl, "ADAPT_BUOY_COEFF", adaptBuoyCoeff, & "Coefficient of buoyancy diffusivity.", & units="nondim", default=0.8) - call get_param(param_file, mod, "ADAPT_ALPHA", adaptAlpha, & + call get_param(param_file, mdl, "ADAPT_ALPHA", adaptAlpha, & "Scaling on optimization tendency.", & units="nondim", default=1.0) - call get_param(param_file, mod, "ADAPT_DO_MIN_DEPTH", tmpLogical, & + call get_param(param_file, mdl, "ADAPT_DO_MIN_DEPTH", tmpLogical, & "If true, make a HyCOM-like mixed layer by preventing interfaces\n"//& "from being shallower than the depths specified by the regridding coordinate.", & default=.false.) @@ -553,7 +586,7 @@ subroutine initialize_regridding(CS, GV, max_depth, param_file, mod, coord_mode, endif if (main_parameters .and. coord_is_state_dependent) then - call get_param(param_file, mod, "MAXIMUM_INT_DEPTH_CONFIG", string, & + call get_param(param_file, mdl, "MAXIMUM_INT_DEPTH_CONFIG", string, & "Determines how to specify the maximum interface depths.\n"//& "Valid options are:\n"//& " NONE - there are no maximum interface depths\n"//& @@ -569,9 +602,9 @@ subroutine initialize_regridding(CS, GV, max_depth, param_file, mod, coord_mode, if ( trim(string) == "NONE") then ! Do nothing. elseif ( trim(string) == "PARAM") then - call get_param(param_file, mod, "MAXIMUM_INTERFACE_DEPTHS", z_max, & - trim(message), units="m", fail_if_missing=.true.) - call set_regrid_max_depths(CS, z_max, GV%m_to_H) + call get_param(param_file, mdl, "MAXIMUM_INTERFACE_DEPTHS", z_max, & + trim(message), units="m", scale=GV%m_to_H, fail_if_missing=.true.) + call set_regrid_max_depths(CS, z_max) elseif (index(trim(string),'FILE:')==1) then if (string(6:6)=='.' .or. string(6:6)=='/') then ! If we specified "FILE:./xyz" or "FILE:/xyz" then we have a relative or absolute path @@ -580,18 +613,18 @@ subroutine initialize_regridding(CS, GV, max_depth, param_file, mod, coord_mode, ! Otherwise assume we should look for the file in INPUTDIR fileName = trim(inputdir) // trim( extractWord(trim(string(6:80)), 1) ) endif - if (.not. file_exists(fileName)) call MOM_error(FATAL,trim(mod)//", initialize_regridding: "// & + if (.not. file_exists(fileName)) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & "Specified file not found: Looking for '"//trim(fileName)//"' ("//trim(string)//")") do_sum = .false. varName = trim( extractWord(trim(string(6:)), 2) ) - if (.not. field_exists(fileName,varName)) call MOM_error(FATAL,trim(mod)//", initialize_regridding: "// & + if (.not. field_exists(fileName,varName)) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")") if (len_trim(varName)==0) then if (field_exists(fileName,'z_max')) then; varName = 'z_max' elseif (field_exists(fileName,'dz')) then; varName = 'dz' ; do_sum = .true. elseif (field_exists(fileName,'dz_max')) then; varName = 'dz_max' ; do_sum = .true. - else ; call MOM_error(FATAL,trim(mod)//", initialize_regridding: "// & + else ; call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & "MAXIMUM_INT_DEPTHS variable not specified and none could be guessed.") endif endif @@ -601,7 +634,7 @@ subroutine initialize_regridding(CS, GV, max_depth, param_file, mod, coord_mode, else call MOM_read_data(trim(fileName), trim(varName), z_max) endif - call log_param(param_file, mod, "!MAXIMUM_INT_DEPTHS", z_max, & + call log_param(param_file, mdl, "!MAXIMUM_INT_DEPTHS", z_max, & trim(message), units=coordinateUnits(coord_mode)) call set_regrid_max_depths(CS, z_max, GV%m_to_H) elseif (index(trim(string),'FNC1:')==1) then @@ -611,11 +644,11 @@ subroutine initialize_regridding(CS, GV, max_depth, param_file, mod, coord_mode, do k=1,nz_fixed_sfc ; dz_max(k) = dz_fixed_sfc ; enddo endif z_max(1) = 0.0 ; do K=1,ke ; z_max(K+1) = z_max(K) + dz_max(K) ; enddo - call log_param(param_file, mod, "!MAXIMUM_INT_DEPTHS", z_max, & + call log_param(param_file, mdl, "!MAXIMUM_INT_DEPTHS", z_max, & trim(message), units=coordinateUnits(coord_mode)) call set_regrid_max_depths(CS, z_max, GV%m_to_H) else - call MOM_error(FATAL,trim(mod)//", initialize_regridding: "// & + call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & "Unrecognized MAXIMUM_INT_DEPTH_CONFIG "//trim(string)) endif deallocate(z_max) @@ -623,7 +656,7 @@ subroutine initialize_regridding(CS, GV, max_depth, param_file, mod, coord_mode, ! Optionally specify maximum thicknesses for each layer, enforced by moving ! the interface below a layer downward. - call get_param(param_file, mod, "MAX_LAYER_THICKNESS_CONFIG", string, & + call get_param(param_file, mdl, "MAX_LAYER_THICKNESS_CONFIG", string, & "Determines how to specify the maximum layer thicknesses.\n"//& "Valid options are:\n"//& " NONE - there are no maximum layer thicknesses\n"//& @@ -638,9 +671,9 @@ subroutine initialize_regridding(CS, GV, max_depth, param_file, mod, coord_mode, if ( trim(string) == "NONE") then ! Do nothing. elseif ( trim(string) == "PARAM") then - call get_param(param_file, mod, "MAX_LAYER_THICKNESS", h_max, & - trim(message), units="m", fail_if_missing=.true.) - call set_regrid_max_thickness(CS, h_max, GV%m_to_H) + call get_param(param_file, mdl, "MAX_LAYER_THICKNESS", h_max, & + trim(message), units="m", fail_if_missing=.true., scale=GV%m_to_H) + call set_regrid_max_thickness(CS, h_max) elseif (index(trim(string),'FILE:')==1) then if (string(6:6)=='.' .or. string(6:6)=='/') then ! If we specified "FILE:./xyz" or "FILE:/xyz" then we have a relative or absolute path @@ -649,30 +682,30 @@ subroutine initialize_regridding(CS, GV, max_depth, param_file, mod, coord_mode, ! Otherwise assume we should look for the file in INPUTDIR fileName = trim(inputdir) // trim( extractWord(trim(string(6:80)), 1) ) endif - if (.not. file_exists(fileName)) call MOM_error(FATAL,trim(mod)//", initialize_regridding: "// & + if (.not. file_exists(fileName)) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & "Specified file not found: Looking for '"//trim(fileName)//"' ("//trim(string)//")") varName = trim( extractWord(trim(string(6:)), 2) ) - if (.not. field_exists(fileName,varName)) call MOM_error(FATAL,trim(mod)//", initialize_regridding: "// & + if (.not. field_exists(fileName,varName)) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")") if (len_trim(varName)==0) then if (field_exists(fileName,'h_max')) then; varName = 'h_max' elseif (field_exists(fileName,'dz_max')) then; varName = 'dz_max' - else ; call MOM_error(FATAL,trim(mod)//", initialize_regridding: "// & + else ; call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & "MAXIMUM_INT_DEPTHS variable not specified and none could be guessed.") endif endif call MOM_read_data(trim(fileName), trim(varName), h_max) - call log_param(param_file, mod, "!MAX_LAYER_THICKNESS", h_max, & + call log_param(param_file, mdl, "!MAX_LAYER_THICKNESS", h_max, & trim(message), units=coordinateUnits(coord_mode)) call set_regrid_max_thickness(CS, h_max, GV%m_to_H) elseif (index(trim(string),'FNC1:')==1) then call dz_function1( trim(string(6:)), h_max ) - call log_param(param_file, mod, "!MAX_LAYER_THICKNESS", h_max, & + call log_param(param_file, mdl, "!MAX_LAYER_THICKNESS", h_max, & trim(message), units=coordinateUnits(coord_mode)) call set_regrid_max_thickness(CS, h_max, GV%m_to_H) else - call MOM_error(FATAL,trim(mod)//", initialize_regridding: "// & + call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & "Unrecognized MAX_LAYER_THICKNESS_CONFIG "//trim(string)) endif deallocate(h_max) @@ -694,7 +727,7 @@ subroutine check_grid_def(filename, varname, expected_units, msg, ierr) integer :: i ierr = .false. - status = NF90_OPEN(trim(filename), NF90_NOWRITE, ncid); + status = NF90_OPEN(trim(filename), NF90_NOWRITE, ncid) if (status /= NF90_NOERR) then ierr = .true. msg = 'File not found: '//trim(filename) @@ -756,8 +789,7 @@ subroutine end_regridding(CS) end subroutine end_regridding !------------------------------------------------------------------------------ -! Dispatching regridding routine: regridding & remapping -!------------------------------------------------------------------------------ +!> Dispatching regridding routine for orchestrating regridding & remapping subroutine regridding_main( remapCS, CS, G, GV, h, tv, h_new, dzInterface, frac_shelf_h, conv_adjust) !------------------------------------------------------------------------------ ! This routine takes care of (1) building a new grid and (2) remapping between @@ -781,12 +813,13 @@ subroutine regridding_main( remapCS, CS, G, GV, h, tv, h_new, dzInterface, frac_ type(regridding_CS), intent(in) :: CS !< Regridding control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G), SZK_(GV)), intent(inout) :: h !< Current 3D grid obtained after the last time step + real, dimension(SZI_(G),SZJ_(G), SZK_(GV)), intent(inout) :: h !< Current 3D grid obtained after + !! the last time step type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamical variables (T, S, ...) real, dimension(SZI_(G),SZJ_(G), CS%nk), intent(inout) :: h_new !< New 3D grid consistent with target coordinate real, dimension(SZI_(G),SZJ_(G), CS%nk+1), intent(inout) :: dzInterface !< The change in position of each interface - real, dimension(:,:), optional, pointer :: frac_shelf_h !< Fractional ice shelf coverage - logical, optional, intent(in ) :: conv_adjust ! If true, do convective adjustment + real, dimension(:,:), optional, pointer :: frac_shelf_h !< Fractional ice shelf coverage + logical, optional, intent(in ) :: conv_adjust !< If true, do convective adjustment ! Local variables real :: trickGnuCompiler logical :: use_ice_shelf @@ -853,11 +886,11 @@ end subroutine regridding_main !> Calculates h_new from h + delta_k dzInterface subroutine calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) type(regridding_CS), intent(in) :: CS !< Regridding control structure - type(ocean_grid_type), intent(in) :: G !< Grid structure + type(ocean_grid_type), intent(in) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Old layer thicknesses (m) - real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(in) :: dzInterface !< Change in interface positions (m) - real, dimension(SZI_(G),SZJ_(G),CS%nk), intent(inout) :: h_new !< New layer thicknesses (m) + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Old layer thicknesses (arbitrary units) + real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(in) :: dzInterface !< Change in interface positions (same as h) + real, dimension(SZI_(G),SZJ_(G),CS%nk), intent(inout) :: h_new !< New layer thicknesses (same as h) ! Local variables integer :: i, j, k, nki @@ -887,29 +920,28 @@ end subroutine calc_h_new_by_dz !> Check that the total thickness of two grids match subroutine check_remapping_grid( G, GV, h, dzInterface, msg ) - type(ocean_grid_type), intent(in) :: G !< Grid structure - type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses (m) - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: dzInterface !< Change in interface positions (m) + type(ocean_grid_type), intent(in) :: G !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: dzInterface !< Change in interface positions + !! [H ~> m or kg m-2] character(len=*), intent(in) :: msg !< Message to append to errors ! Local variables integer :: i, j !$OMP parallel do default(shared) - do j = G%jsc-1,G%jec+1 - do i = G%isc-1,G%iec+1 - if (G%mask2dT(i,j)>0.) call check_grid_column( GV%ke, G%bathyT(i,j), h(i,j,:), dzInterface(i,j,:), msg ) - enddo - enddo + do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1 + if (G%mask2dT(i,j)>0.) call check_grid_column( GV%ke, GV%Z_to_H*G%bathyT(i,j), h(i,j,:), dzInterface(i,j,:), msg ) + enddo ; enddo end subroutine check_remapping_grid !> Check that the total thickness of new and old grids are consistent subroutine check_grid_column( nk, depth, h, dzInterface, msg ) integer, intent(in) :: nk !< Number of cells - real, intent(in) :: depth !< Depth of bottom (m) - real, dimension(nk), intent(in) :: h !< Cell thicknesses (m) - real, dimension(nk+1), intent(in) :: dzInterface !< Change in interface positions (m) + real, intent(in) :: depth !< Depth of bottom [Z ~> m] or arbitrary units + real, dimension(nk), intent(in) :: h !< Cell thicknesses [Z ~> m] or arbitrary units + real, dimension(nk+1), intent(in) :: dzInterface !< Change in interface positions (same units as h) character(len=*), intent(in) :: msg !< Message to append to errors ! Local variables integer :: k @@ -969,9 +1001,9 @@ end subroutine check_grid_column subroutine filtered_grid_motion( CS, nk, z_old, z_new, dz_g ) type(regridding_CS), intent(in) :: CS !< Regridding control structure integer, intent(in) :: nk !< Number of cells in source grid - real, dimension(nk+1), intent(in) :: z_old !< Old grid position (m) - real, dimension(CS%nk+1), intent(in) :: z_new !< New grid position (m) - real, dimension(CS%nk+1), intent(inout) :: dz_g !< Change in interface positions (m) + real, dimension(nk+1), intent(in) :: z_old !< Old grid position [m] + real, dimension(CS%nk+1), intent(in) :: z_new !< New grid position [m] + real, dimension(CS%nk+1), intent(inout) :: dz_g !< Change in interface positions [m] ! Local variables real :: sgn ! The sign convention for downward. real :: dz_tgt, zr1, z_old_k @@ -1107,12 +1139,13 @@ end subroutine filtered_grid_motion subroutine build_zstar_grid( CS, G, GV, h, dzInterface, frac_shelf_h) ! Arguments - type(regridding_CS), intent(in) :: CS !< Regridding control structure - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses, in H - real, dimension(SZI_(G),SZJ_(G), CS%nk+1), intent(inout) :: dzInterface !< The change in interface depth in H. - real, dimension(:,:), optional, pointer :: frac_shelf_h !< Fractional ice shelf coverage. + type(regridding_CS), intent(in) :: CS !< Regridding control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G), CS%nk+1), intent(inout) :: dzInterface !< The change in interface depth + !! [H ~> m or kg m-2]. + real, dimension(:,:), optional, pointer :: frac_shelf_h !< Fractional ice shelf coverage. ! Local variables integer :: i, j, k integer :: nz @@ -1141,13 +1174,13 @@ subroutine build_zstar_grid( CS, G, GV, h, dzInterface, frac_shelf_h) endif ! Local depth (G%bathyT is positive) - nominalDepth = G%bathyT(i,j)*GV%m_to_H + nominalDepth = G%bathyT(i,j)*GV%Z_to_H ! Determine water column thickness totalThickness = 0.0 do k = 1,nz totalThickness = totalThickness + h(i,j,k) - end do + enddo zOld(nz+1) = - nominalDepth do k = nz,1,-1 @@ -1158,14 +1191,14 @@ subroutine build_zstar_grid( CS, G, GV, h, dzInterface, frac_shelf_h) if (frac_shelf_h(i,j) > 0.) then ! under ice shelf call build_zstar_column(CS%zlike_CS, nominalDepth, totalThickness, zNew, & z_rigid_top = totalThickness-nominalDepth, & - eta_orig=zOld(1), zScale=GV%m_to_H) + eta_orig=zOld(1), zScale=GV%Z_to_H) else call build_zstar_column(CS%zlike_CS, nominalDepth, totalThickness, & - zNew, zScale=GV%m_to_H) + zNew, zScale=GV%Z_to_H) endif else call build_zstar_column(CS%zlike_CS, nominalDepth, totalThickness, & - zNew, zScale=GV%m_to_H) + zNew, zScale=GV%Z_to_H) endif ! Calculate the final change in grid position after blending new and old grids @@ -1190,14 +1223,14 @@ subroutine build_zstar_grid( CS, G, GV, h, dzInterface, frac_shelf_h) call adjust_interface_motion( CS, nz, h(i,j,:), dzInterface(i,j,:) ) - end do - end do + enddo + enddo end subroutine build_zstar_grid !------------------------------------------------------------------------------ ! Build sigma grid -!------------------------------------------------------------------------------ +!> This routine builds a grid based on terrain-following coordinates. subroutine build_sigma_grid( CS, G, GV, h, dzInterface ) !------------------------------------------------------------------------------ ! This routine builds a grid based on terrain-following coordinates. @@ -1207,11 +1240,12 @@ subroutine build_sigma_grid( CS, G, GV, h, dzInterface ) !------------------------------------------------------------------------------ ! Arguments - type(regridding_CS), intent(in) :: CS !< Regridding control structure - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses, in H - real, dimension(SZI_(G),SZJ_(G), CS%nk+1), intent(inout) :: dzInterface !< The change in interface depth in H. + type(regridding_CS), intent(in) :: CS !< Regridding control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G), CS%nk+1), intent(inout) :: dzInterface !< The change in interface depth + !! [H ~> m or kg m-2] ! Local variables integer :: i, j, k @@ -1230,13 +1264,13 @@ subroutine build_sigma_grid( CS, G, GV, h, dzInterface ) endif ! The rest of the model defines grids integrating up from the bottom - nominalDepth = G%bathyT(i,j)*GV%m_to_H + nominalDepth = G%bathyT(i,j)*GV%Z_to_H ! Determine water column height totalThickness = 0.0 do k = 1,nz totalThickness = totalThickness + h(i,j,k) - end do + enddo call build_sigma_column(CS%sigma_CS, nominalDepth, totalThickness, zNew) @@ -1244,7 +1278,7 @@ subroutine build_sigma_grid( CS, G, GV, h, dzInterface ) zOld(nz+1) = -nominalDepth do k = nz,1,-1 zOld(k) = zOld(k+1) + h(i, j, k) - end do + enddo call filtered_grid_motion( CS, nz, zOld, zNew, dzInterface(i,j,:) ) @@ -1267,14 +1301,15 @@ subroutine build_sigma_grid( CS, G, GV, h, dzInterface ) dzInterface(i,j,CS%nk+1) = 0. #endif - end do - end do + enddo + enddo end subroutine build_sigma_grid !------------------------------------------------------------------------------ ! Build grid based on target interface densities !------------------------------------------------------------------------------ +!> This routine builds a new grid based on a given set of target interface densities. subroutine build_rho_grid( G, GV, h, tv, dzInterface, remapCS, CS ) !------------------------------------------------------------------------------ ! This routine builds a new grid based on a given set of target interface @@ -1294,9 +1329,10 @@ subroutine build_rho_grid( G, GV, h, tv, dzInterface, remapCS, CS ) ! Arguments type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses, in H + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure - real, dimension(SZI_(G),SZJ_(G), SZK_(GV)+1), intent(inout) :: dzInterface !< The change in interface depth in H + real, dimension(SZI_(G),SZJ_(G), SZK_(GV)+1), intent(inout) :: dzInterface !< The change in interface depth + !! [H ~> m or kg m-2] type(remapping_CS), intent(in) :: remapCS !< The remapping control structure type(regridding_CS), intent(in) :: CS !< Regridding control structure @@ -1333,7 +1369,7 @@ subroutine build_rho_grid( G, GV, h, tv, dzInterface, remapCS, CS ) ! Local depth (G%bathyT is positive) - nominalDepth = G%bathyT(i,j)*GV%m_to_H + nominalDepth = G%bathyT(i,j)*GV%Z_to_H call build_rho_column(CS%rho_CS, nz, nominalDepth, h(i, j, :), & tv%T(i, j, :), tv%S(i, j, :), tv%eqn_of_state, zNew, & @@ -1392,8 +1428,8 @@ subroutine build_rho_grid( G, GV, h, tv, dzInterface, remapCS, CS ) endif #endif - end do ! end loop on i - end do ! end loop on j + enddo ! end loop on i + enddo ! end loop on j end subroutine build_rho_grid @@ -1405,19 +1441,19 @@ end subroutine build_rho_grid !! hybrid isopycnic-Cartesian coordinates, Ocean Modelling 37, 55-88. !! http://dx.doi.org/10.1016/S1463-5003(01)00012-9 } subroutine build_grid_HyCOM1( G, GV, h, tv, h_new, dzInterface, CS ) - type(ocean_grid_type), intent(in) :: G !< Grid structure - type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Existing model thickness, in H units - type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure - type(regridding_CS), intent(in) :: CS !< Regridding control structure - real, dimension(SZI_(G),SZJ_(G),CS%nk), intent(inout) :: h_new !< New layer thicknesses (H units) - real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< Changes in interface position + type(ocean_grid_type), intent(in) :: G !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Existing model thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure + type(regridding_CS), intent(in) :: CS !< Regridding control structure + real, dimension(SZI_(G),SZJ_(G),CS%nk), intent(inout) :: h_new !< New layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< Changes in interface position ! Local variables - real, dimension(SZK_(GV)+1) :: z_col ! Source interface positions relative to the surface in H units (m or kg m-2) - real, dimension(CS%nk+1) :: z_col_new ! New interface positions relative to the surface in H units (m or kg m-2) - real, dimension(SZK_(GV)+1) :: dz_col ! The realized change in z_col in H units (m or kg m-2) - real, dimension(SZK_(GV)) :: p_col ! Layer pressure in Pa + real, dimension(SZK_(GV)+1) :: z_col ! Source interface positions relative to the surface [H ~> m or kg m-2] + real, dimension(CS%nk+1) :: z_col_new ! New interface positions relative to the surface [H ~> m or kg m-2] + real, dimension(SZK_(GV)+1) :: dz_col ! The realized change in z_col [H ~> m or kg m-2] + real, dimension(SZK_(GV)) :: p_col ! Layer center pressure [Pa] integer :: i, j, k, nki real :: depth real :: h_neglect, h_neglect_edge @@ -1438,18 +1474,18 @@ subroutine build_grid_HyCOM1( G, GV, h, tv, h_new, dzInterface, CS ) do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1 if (G%mask2dT(i,j)>0.) then - depth = G%bathyT(i,j) * GV%m_to_H + depth = G%bathyT(i,j) * GV%Z_to_H z_col(1) = 0. ! Work downward rather than bottom up do K = 1, GV%ke - z_col(K+1) = z_col(K) + h(i,j,k) ! Work in units of h (m or Pa) + z_col(K+1) = z_col(K) + h(i,j,k) p_col(k) = CS%ref_pressure + CS%compressibility_fraction * & ( 0.5 * ( z_col(K) + z_col(K+1) ) * GV%H_to_Pa - CS%ref_pressure ) enddo call build_hycom1_column(CS%hycom_CS, tv%eqn_of_state, GV%ke, depth, & h(i, j, :), tv%T(i, j, :), tv%S(i, j, :), p_col, & - z_col, z_col_new, zScale=GV%m_to_H, & + z_col, z_col_new, zScale=GV%Z_to_H, & h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) ! Calculate the final change in grid position after blending new and old grids @@ -1465,20 +1501,24 @@ subroutine build_grid_HyCOM1( G, GV, h, tv, h_new, dzInterface, CS ) else ! on land dzInterface(i,j,:) = 0. endif ! mask2dT - enddo; enddo ! i,j + enddo ; enddo ! i,j call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) end subroutine build_grid_HyCOM1 +!> This subroutine builds an adaptive grid that follows density surfaces where +!! possible, subject to constraints on the smoothness of interface heights. subroutine build_grid_adaptive(G, GV, h, tv, dzInterface, remapCS, 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 - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: dzInterface - type(remapping_CS), intent(in) :: remapCS - type(regridding_CS), intent(in) :: CS + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: dzInterface !< The change in interface depth + !! [H ~> m or kg m-2] + type(remapping_CS), intent(in) :: remapCS !< The remapping control structure + type(regridding_CS), intent(in) :: CS !< Regridding control structure ! local variables integer :: i, j, k, nz ! indices and dimension lengths @@ -1535,17 +1575,18 @@ end subroutine build_grid_adaptive !! shallow topography, this will tend to give a uniform sigma-like coordinate. !! For sufficiently shallow water, a minimum grid spacing is used to avoid !! certain instabilities. -subroutine build_grid_SLight( G, GV, h, tv, dzInterface, CS ) +subroutine build_grid_SLight(G, GV, h, tv, dzInterface, CS) type(ocean_grid_type), intent(in) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Existing model thickness, in H units + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Existing model thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: dzInterface !< Changes in interface position type(regridding_CS), intent(in) :: CS !< Regridding control structure - real, dimension(SZK_(GV)+1) :: z_col, z_col_new ! Interface positions relative to the surface in H units (m or kg m-2) - real, dimension(SZK_(GV)+1) :: dz_col ! The realized change in z_col in H units (m or kg m-2) - real, dimension(SZK_(GV)) :: p_col ! Layer pressure in Pa + real, dimension(SZK_(GV)+1) :: z_col ! Interface positions relative to the surface [H ~> m or kg m-2] + real, dimension(SZK_(GV)+1) :: z_col_new ! Interface positions relative to the surface [H ~> m or kg m-2] + real, dimension(SZK_(GV)+1) :: dz_col ! The realized change in z_col [H ~> m or kg m-2] + real, dimension(SZK_(GV)) :: p_col ! Layer center pressure [Pa] real :: depth integer :: i, j, k, nz real :: h_neglect, h_neglect_edge @@ -1566,15 +1607,15 @@ subroutine build_grid_SLight( G, GV, h, tv, dzInterface, CS ) do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1 if (G%mask2dT(i,j)>0.) then - depth = G%bathyT(i,j) * GV%m_to_H + depth = G%bathyT(i,j) * GV%Z_to_H z_col(1) = 0. ! Work downward rather than bottom up do K=1,nz - z_col(K+1) = z_col(K) + h(i, j, k) ! Work in units of h (m or Pa) + z_col(K+1) = z_col(K) + h(i,j,k) p_col(k) = CS%ref_pressure + CS%compressibility_fraction * & ( 0.5 * ( z_col(K) + z_col(K+1) ) * GV%H_to_Pa - CS%ref_pressure ) enddo - call build_slight_column(CS%slight_CS, tv%eqn_of_state, GV%H_to_Pa, GV%m_to_H, & + call build_slight_column(CS%slight_CS, tv%eqn_of_state, GV%H_to_Pa, & GV%H_subroundoff, nz, depth, h(i, j, :), & tv%T(i, j, :), tv%S(i, j, :), p_col, z_col, z_col_new, & h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) @@ -1593,7 +1634,7 @@ subroutine build_grid_SLight( G, GV, h, tv, dzInterface, CS ) else ! on land dzInterface(i,j,:) = 0. endif ! mask2dT - enddo; enddo ! i,j + enddo ; enddo ! i,j end subroutine build_grid_SLight @@ -1601,8 +1642,8 @@ end subroutine build_grid_SLight subroutine adjust_interface_motion( CS, nk, h_old, dz_int ) type(regridding_CS), intent(in) :: CS !< Regridding control structure integer, intent(in) :: nk !< Number of layers in h_old - real, dimension(nk), intent(in) :: h_old !< Minium allowed thickness of h (H units) - real, dimension(CS%nk+1), intent(inout) :: dz_int !< Minium allowed thickness of h (H units) + real, dimension(nk), intent(in) :: h_old !< Minium allowed thickness of h [H ~> m or kg m-2] + real, dimension(CS%nk+1), intent(inout) :: dz_int !< Minium allowed thickness of h [H ~> m or kg m-2] ! Local variables integer :: k real :: h_new, eps, h_total, h_err @@ -1637,9 +1678,11 @@ subroutine adjust_interface_motion( CS, nk, h_old, dz_int ) endif do k = min(CS%nk,nk),2,-1 h_new = h_old(k) + ( dz_int(k) - dz_int(k+1) ) - if (h_new m or kg m-2] ! Local variables integer :: i, j, k @@ -1786,35 +1827,33 @@ subroutine inflate_vanished_layers_old( CS, G, GV, h ) ! Build grid for current column do k = 1,GV%ke hTmp(k) = h(i,j,k) - end do + enddo call old_inflate_layers_1d( CS%min_thickness, GV%ke, hTmp ) ! Save modified grid do k = 1,GV%ke h(i,j,k) = hTmp(k) - end do + enddo - end do - end do + enddo + enddo end subroutine inflate_vanished_layers_old !------------------------------------------------------------------------------ -! Convective adjustment by swapping layers -!------------------------------------------------------------------------------ +!> Achieve convective adjustment by swapping layers subroutine convective_adjustment(G, GV, h, tv) + 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_(GV)), & + intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(inout) :: tv !< A structure pointing to various thermodynamic variables !------------------------------------------------------------------------------ ! Check each water column to see whether it is stratified. If not, sort the ! layers by successive swappings of water masses (bubble sort algorithm) !------------------------------------------------------------------------------ - ! Arguments - 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_(GV)), intent(inout) :: h !< Layer thicknesses, in H (usually m or kg m-2) - type(thermo_var_ptrs), intent(inout) :: tv !< A structure pointing to various thermodynamic variables - ! Local variables integer :: i, j, k real :: T0, T1 ! temperatures @@ -1855,7 +1894,7 @@ subroutine convective_adjustment(G, GV, h, tv) call calculate_density( tv%T(i,j,k+1), tv%S(i,j,k+1), p_col(k+1), & densities(k+1), tv%eqn_of_state ) stratified = .false. - end if + endif enddo ! k if ( stratified ) exit @@ -1867,17 +1906,21 @@ end subroutine convective_adjustment !------------------------------------------------------------------------------ -! Return uniform resolution vector based on coordiante mode -!------------------------------------------------------------------------------ +!> Return a uniform resolution vector in the units of the coordinate function uniformResolution(nk,coordMode,maxDepth,rhoLight,rhoHeavy) !------------------------------------------------------------------------------ ! Calculate a vector of uniform resolution in the units of the coordinate !------------------------------------------------------------------------------ ! Arguments - integer, intent(in) :: nk - character(len=*), intent(in) :: coordMode - real, intent(in) :: maxDepth, rhoLight, rhoHeavy - real :: uniformResolution(nk) + integer, intent(in) :: nk !< Number of cells in source grid + character(len=*), intent(in) :: coordMode !< A string indicating the coordinate mode. + !! See the documenttion for regrid_consts + !! for the recognized values. + real, intent(in) :: maxDepth !< The range of the grid values in some modes + real, intent(in) :: rhoLight !< The minimum value of the grid in RHO mode + real, intent(in) :: rhoHeavy !< The maximum value of the grid in RHO mode + + real :: uniformResolution(nk) !< The returned uniform resolution grid. ! Local variables integer :: scheme @@ -1903,9 +1946,14 @@ function uniformResolution(nk,coordMode,maxDepth,rhoLight,rhoHeavy) end function uniformResolution -subroutine initCoord(CS, coord_mode) - type(regridding_CS), intent(inout) :: CS - character(len=*), intent(in) :: coord_mode +!> Initialize the coordinate resolutions by calling the appropriate initialization +!! routine for the specified coordinate mode. +subroutine initCoord(CS, GV, coord_mode) + type(regridding_CS), intent(inout) :: CS !< Regridding control structure + character(len=*), intent(in) :: coord_mode !< A string indicating the coordinate mode. + !! See the documenttion for regrid_consts + !! for the recognized values. + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure select case (coordinateMode(coord_mode)) case (REGRIDDING_ZSTAR) @@ -1919,23 +1967,27 @@ subroutine initCoord(CS, coord_mode) case (REGRIDDING_HYCOM1) call init_coord_hycom(CS%hycom_CS, CS%nk, CS%coordinateResolution, CS%target_density, CS%interp_CS) case (REGRIDDING_SLIGHT) - call init_coord_slight(CS%slight_CS, CS%nk, CS%ref_pressure, CS%target_density, CS%interp_CS) + call init_coord_slight(CS%slight_CS, CS%nk, CS%ref_pressure, CS%target_density, CS%interp_CS, GV%m_to_H) case (REGRIDDING_ADAPTIVE) - call init_coord_adapt(CS%adapt_CS, CS%nk, CS%coordinateResolution) + call init_coord_adapt(CS%adapt_CS, CS%nk, CS%coordinateResolution, GV%m_to_H) end select end subroutine initCoord !------------------------------------------------------------------------------ -! Set the fixed resolution data -!------------------------------------------------------------------------------ -subroutine setCoordinateResolution( dz, CS ) - real, dimension(:), intent(in) :: dz - type(regridding_CS), intent(inout) :: CS +!> Set the fixed resolution data +subroutine setCoordinateResolution( dz, CS, scale ) + real, dimension(:), intent(in) :: dz !< A vector of vertical grid spacings + type(regridding_CS), intent(inout) :: CS !< Regridding control structure + real, optional, intent(in) :: scale !< A scaling factor converting dz to coordRes if (size(dz)/=CS%nk) call MOM_error( FATAL, & 'setCoordinateResolution: inconsistent number of levels' ) - CS%coordinateResolution(:) = dz(:) + if (present(scale)) then + CS%coordinateResolution(:) = scale*dz(:) + else + CS%coordinateResolution(:) = dz(:) + endif end subroutine setCoordinateResolution @@ -1951,7 +2003,7 @@ subroutine set_target_densities_from_GV( GV, CS ) CS%target_density(nz+1) = GV%Rlay(nz)+0.5*(GV%Rlay(nz)-GV%Rlay(nz-1)) do k = 2,nz CS%target_density(k) = CS%target_density(k-1) + CS%coordinateResolution(k) - end do + enddo CS%target_density_set = .true. end subroutine set_target_densities_from_GV @@ -1981,7 +2033,7 @@ subroutine set_regrid_max_depths( CS, max_depths, units_to_H ) if (.not.allocated(CS%max_interface_depths)) allocate(CS%max_interface_depths(1:CS%nk+1)) - val_to_H = 1.0 ; if (present( units_to_H)) val_to_H = units_to_H + val_to_H = 1.0 ; if (present(units_to_H)) val_to_H = units_to_H if (max_depths(CS%nk+1) < max_depths(1)) val_to_H = -1.0*val_to_H ! Check for sign reversals in the depths. @@ -2036,22 +2088,34 @@ end subroutine set_regrid_max_thickness !------------------------------------------------------------------------------ -! Query the fixed resolution data -!------------------------------------------------------------------------------ -function getCoordinateResolution( CS ) - type(regridding_CS), intent(in) :: CS +!> Query the fixed resolution data +function getCoordinateResolution( CS, undo_scaling ) + type(regridding_CS), intent(in) :: CS !< Regridding control structure + logical, optional, intent(in) :: undo_scaling !< If present and true, undo any internal + !! rescaling of the resolution data. real, dimension(CS%nk) :: getCoordinateResolution - getCoordinateResolution(:) = CS%coordinateResolution(:) + logical :: unscale + unscale = .false. ; if (present(undo_scaling)) unscale = undo_scaling + + if (unscale) then + getCoordinateResolution(:) = CS%coord_scale * CS%coordinateResolution(:) + else + getCoordinateResolution(:) = CS%coordinateResolution(:) + endif end function getCoordinateResolution !> Query the target coordinate interface positions -function getCoordinateInterfaces( CS ) +function getCoordinateInterfaces( CS, undo_scaling ) type(regridding_CS), intent(in) :: CS !< Regridding control structure + logical, optional, intent(in) :: undo_scaling !< If present and true, undo any internal + !! rescaling of the resolution data. real, dimension(CS%nk+1) :: getCoordinateInterfaces !< Interface positions in target coordinate integer :: k + logical :: unscale + unscale = .false. ; if (present(undo_scaling)) unscale = undo_scaling ! When using a coordinate with target densities, we need to get the actual ! densities, rather than computing the interfaces based on resolution @@ -2062,23 +2126,30 @@ function getCoordinateInterfaces( CS ) getCoordinateInterfaces(:) = CS%target_density(:) else - getCoordinateInterfaces(1) = 0. - do k = 1, CS%nk - getCoordinateInterfaces(k+1) = getCoordinateInterfaces(k) & - -CS%coordinateResolution(k) - enddo + if (unscale) then + getCoordinateInterfaces(1) = 0. + do k = 1, CS%nk + getCoordinateInterfaces(K+1) = getCoordinateInterfaces(K) - & + CS%coord_scale * CS%coordinateResolution(k) + enddo + else + getCoordinateInterfaces(1) = 0. + do k = 1, CS%nk + getCoordinateInterfaces(K+1) = getCoordinateInterfaces(K) - & + CS%coordinateResolution(k) + enddo + endif ! The following line has an "abs()" to allow ferret users to reference ! data by index. It is a temporary work around... :( -AJA getCoordinateInterfaces(:) = abs( getCoordinateInterfaces(:) ) - end if + endif end function getCoordinateInterfaces !------------------------------------------------------------------------------ -! Query the target coordinate units -!------------------------------------------------------------------------------ +!> Query the target coordinate units function getCoordinateUnits( CS ) - type(regridding_CS), intent(in) :: CS + type(regridding_CS), intent(in) :: CS !< Regridding control structure character(len=20) :: getCoordinateUnits select case ( CS%regridding_scheme ) @@ -2100,10 +2171,9 @@ function getCoordinateUnits( CS ) end function getCoordinateUnits !------------------------------------------------------------------------------ -! Query the short name of the coordinate -!------------------------------------------------------------------------------ +!> Query the short name of the coordinate function getCoordinateShortName( CS ) - type(regridding_CS), intent(in) :: CS + type(regridding_CS), intent(in) :: CS !< Regridding control structure character(len=20) :: getCoordinateShortName select case ( CS%regridding_scheme ) @@ -2141,22 +2211,35 @@ subroutine set_regrid_params( CS, boundary_extrapolation, min_thickness, old_gri adaptTimeRatio, adaptZoom, adaptZoomCoeff, adaptBuoyCoeff, adaptAlpha, adaptDoMin) type(regridding_CS), intent(inout) :: CS !< Regridding control structure logical, optional, intent(in) :: boundary_extrapolation !< Extrapolate in boundary cells - real, optional, intent(in) :: min_thickness !< Minimum thickness allowed when building the new grid (m) - real, optional, intent(in) :: old_grid_weight !< Weight given to old coordinate when time-filtering grid + real, optional, intent(in) :: min_thickness !< Minimum thickness allowed when building the + !! new grid [H ~> m or kg m-2] + real, optional, intent(in) :: old_grid_weight !< Weight given to old coordinate when time-filtering grid character(len=*), optional, intent(in) :: interp_scheme !< Interpolation method for state-dependent coordinates - real, optional, intent(in) :: depth_of_time_filter_shallow !< Depth to start cubic (H units) - real, optional, intent(in) :: depth_of_time_filter_deep !< Depth to end cubic (H units) + real, optional, intent(in) :: depth_of_time_filter_shallow !< Depth to start cubic [H ~> m or kg m-2] + real, optional, intent(in) :: depth_of_time_filter_deep !< Depth to end cubic [H ~> m or kg m-2] real, optional, intent(in) :: compress_fraction !< Fraction of compressibility to add to potential density - real, optional, intent(in) :: dz_min_surface !< The fixed resolution in the topmost SLight_nkml_min layers (m) - integer, optional, intent(in) :: nz_fixed_surface !< The number of fixed-thickess layers at the top of the model - real, optional, intent(in) :: Rho_ml_avg_depth !< Averaging depth over which to determine mixed layer potential density (m) - real, optional, intent(in) :: nlay_ML_to_interior !< Number of layers to offset the mixed layer density to find resolved stratification (nondim) - logical, optional, intent(in) :: fix_haloclines !< Detect regions with much weaker stratification in the coordinate - real, optional, intent(in) :: halocline_filt_len !< Length scale over which to filter T & S when looking for spuriously unstable water mass profiles (m) - real, optional, intent(in) :: halocline_strat_tol !< Value of the stratification ratio that defines a problematic halocline region. - logical, optional, intent(in) :: integrate_downward_for_e !< If true, integrate for interface positions downward from the top. - real, optional, intent(in) :: adaptTimeRatio, adaptZoom, adaptZoomCoeff, adaptBuoyCoeff, adaptAlpha - logical, optional, intent(in) :: adaptDoMin + real, optional, intent(in) :: dz_min_surface !< The fixed resolution in the topmost + !! SLight_nkml_min layers [H ~> m or kg m-2] + integer, optional, intent(in) :: nz_fixed_surface !< The number of fixed-thickness layers at the top of the model + real, optional, intent(in) :: Rho_ml_avg_depth !< Averaging depth over which to determine mixed layer potential + !! density [H ~> m or kg m-2] + real, optional, intent(in) :: nlay_ML_to_interior !< Number of layers to offset the mixed layer density to find + !! resolved stratification [nondim] + logical, optional, intent(in) :: fix_haloclines !< Detect regions with much weaker stratification in the coordinate + real, optional, intent(in) :: halocline_filt_len !< Length scale over which to filter T & S when looking for + !! spuriously unstable water mass profiles [m] + real, optional, intent(in) :: halocline_strat_tol !< Value of the stratification ratio that defines a problematic + !! halocline region. + logical, optional, intent(in) :: integrate_downward_for_e !< If true, integrate for interface positions downward + !! from the top. + real, optional, intent(in) :: adaptTimeRatio !< Ratio of the ALE timestep to the grid timescale [nondim]. + real, optional, intent(in) :: adaptZoom !< Depth of near-surface zooming region [H ~> m or kg m-2]. + real, optional, intent(in) :: adaptZoomCoeff !< Coefficient of near-surface zooming diffusivity [nondim]. + real, optional, intent(in) :: adaptBuoyCoeff !< Coefficient of buoyancy diffusivity [nondim]. + real, optional, intent(in) :: adaptAlpha !< Scaling factor on optimization tendency [nondim]. + logical, optional, intent(in) :: adaptDoMin !< If true, make a HyCOM-like mixed layer by + !! preventing interfaces from being shallower than + !! the depths specified by the regridding coordinate. if (present(interp_scheme)) call set_interp_scheme(CS%interp_CS, interp_scheme) if (present(boundary_extrapolation)) call set_interp_extrap(CS%interp_CS, boundary_extrapolation) @@ -2186,7 +2269,8 @@ subroutine set_regrid_params( CS, boundary_extrapolation, min_thickness, old_gri if (present(min_thickness)) call set_sigma_params(CS%sigma_CS, min_thickness=min_thickness) case (REGRIDDING_RHO) if (present(min_thickness)) call set_rho_params(CS%rho_CS, min_thickness=min_thickness) - if (present(integrate_downward_for_e)) call set_rho_params(CS%rho_CS, integrate_downward_for_e=integrate_downward_for_e) + if (present(integrate_downward_for_e)) & + call set_rho_params(CS%rho_CS, integrate_downward_for_e=integrate_downward_for_e) if (associated(CS%rho_CS) .and. (present(interp_scheme) .or. present(boundary_extrapolation))) & call set_rho_params(CS%rho_CS, interp_CS=CS%interp_CS) case (REGRIDDING_HYCOM1) @@ -2223,35 +2307,37 @@ integer function get_regrid_size(CS) end function get_regrid_size +!> This returns a copy of the zlike_CS stored in the regridding control structure. function get_zlike_CS(CS) - type(regridding_CS), intent(in) :: CS + type(regridding_CS), intent(in) :: CS !< Regridding control structure type(zlike_CS) :: get_zlike_CS get_zlike_CS = CS%zlike_CS end function get_zlike_CS +!> This returns a copy of the sigma_CS stored in the regridding control structure. function get_sigma_CS(CS) - type(regridding_CS), intent(in) :: CS + type(regridding_CS), intent(in) :: CS !< Regridding control structure type(sigma_CS) :: get_sigma_CS get_sigma_CS = CS%sigma_CS end function get_sigma_CS +!> This returns a copy of the rho_CS stored in the regridding control structure. function get_rho_CS(CS) - type(regridding_CS), intent(in) :: CS + type(regridding_CS), intent(in) :: CS !< Regridding control structure type(rho_CS) :: get_rho_CS get_rho_CS = CS%rho_CS end function get_rho_CS !------------------------------------------------------------------------------ -! Return coordinate-derived thicknesses for fixed coordinate systems -!------------------------------------------------------------------------------ +!> Return coordinate-derived thicknesses for fixed coordinate systems function getStaticThickness( CS, SSH, depth ) - type(regridding_CS), intent(in) :: CS - real, intent(in) :: SSH - real, intent(in) :: depth - real, dimension(CS%nk) :: getStaticThickness + type(regridding_CS), intent(in) :: CS !< Regridding control structure + real, intent(in) :: SSH !< The sea surface height, in the same units as depth + real, intent(in) :: depth !< The maximum depth of the grid, often [Z ~> m] + real, dimension(CS%nk) :: getStaticThickness !< The returned thicknesses in the units of depth ! Local integer :: k real :: z, dz @@ -2262,9 +2348,9 @@ function getStaticThickness( CS, SSH, depth ) z = ssh do k = 1, CS%nk dz = CS%coordinateResolution(k) * ( 1. + ssh/depth ) ! Nominal dz* - dz = max(dz, 0.) ! Avoid negative incase ssh=-depth - dz = min(dz, depth - z) ! Clip if below topography - z = z + dz ! Bottom of layer + dz = max(dz, 0.) ! Avoid negative incase ssh=-depth + dz = min(dz, depth - z) ! Clip if below topography + z = z + dz ! Bottom of layer getStaticThickness(k) = dz enddo else diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index a7879ae063..f399aa2c0f 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -71,7 +71,7 @@ module MOM_remapping ! outside of the range 0 to 1. #define __USE_ROUNDOFF_SAFE_ADJUSTMENTS__ -real, parameter :: hNeglect_dflt = 1.E-30 !< A dimensional (H units) number that can be +real, parameter :: hNeglect_dflt = 1.E-30 !< A thickness [H ~> m or kg m-2] that can be !! added to thicknesses in a denominator without !! changing the numerical result, except where !! a division by zero would otherwise occur. @@ -140,7 +140,7 @@ subroutine buildGridFromH(nz, h, x) x(1) = 0.0 do k = 1,nz x(k+1) = x(k) + h(k) - end do + enddo end subroutine buildGridFromH @@ -177,8 +177,7 @@ function isPosSumErrSignificant(n1, sum1, n2, sum2) endif end function isPosSumErrSignificant -!> Remaps column of values u0 on grid h0 to grid h1 -!! assuming the top edge is aligned. +!> Remaps column of values u0 on grid h0 to grid h1 assuming the top edge is aligned. subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, h_neglect, h_neglect_edge) type(remapping_CS), intent(in) :: CS !< Remapping control structure integer, intent(in) :: n0 !< Number of cells on source grid @@ -197,7 +196,7 @@ subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, h_neglect, h_neglect_ed integer :: iMethod real, dimension(n0,2) :: ppoly_r_E !Edge value of polynomial real, dimension(n0,2) :: ppoly_r_S !Edge slope of polynomial - real, dimension(n0,CS%degree+1) :: ppoly_r_coefficients !Coefficients of polynomial + real, dimension(n0,CS%degree+1) :: ppoly_r_coefs !Coefficients of polynomial integer :: k real :: eps, h0tot, h0err, h1tot, h1err, u0tot, u0err, u0min, u0max, u1tot, u1err, u1min, u1max, uh_err real :: hNeglect, hNeglect_edge @@ -205,14 +204,14 @@ subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, h_neglect, h_neglect_ed hNeglect = 1.0e-30 ; if (present(h_neglect)) hNeglect = h_neglect hNeglect_edge = 1.0e-10 ; if (present(h_neglect_edge)) hNeglect_edge = h_neglect_edge - call build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefficients, ppoly_r_E, ppoly_r_S, iMethod, & + call build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, ppoly_r_E, ppoly_r_S, iMethod, & hNeglect, hNeglect_edge ) if (CS%check_reconstruction) call check_reconstructions_1d(n0, h0, u0, CS%degree, & - CS%boundary_extrapolation, ppoly_r_coefficients, ppoly_r_E, ppoly_r_S) + CS%boundary_extrapolation, ppoly_r_coefs, ppoly_r_E, ppoly_r_S) - call remap_via_sub_cells( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients, n1, h1, iMethod, & + call remap_via_sub_cells( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, n1, h1, iMethod, & CS%force_bounds_in_subcell, u1, uh_err ) if (CS%check_remapping) then @@ -224,9 +223,11 @@ subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, h_neglect, h_neglect_ed .or. (u1minu0max) ) then write(0,*) 'iMethod = ',iMethod write(0,*) 'H: h0tot=',h0tot,'h1tot=',h1tot,'dh=',h1tot-h0tot,'h0err=',h0err,'h1err=',h1err - if (abs(h1tot-h0tot)>h0err+h1err) write(0,*) 'H non-conservation difference=',h1tot-h0tot,'allowed err=',h0err+h1err,' <-----!' + if (abs(h1tot-h0tot)>h0err+h1err) & + write(0,*) 'H non-conservation difference=',h1tot-h0tot,'allowed err=',h0err+h1err,' <-----!' write(0,*) 'UH: u0tot=',u0tot,'u1tot=',u1tot,'duh=',u1tot-u0tot,'u0err=',u0err,'u1err=',u1err,'uh_err=',uh_err - if (abs(u1tot-u0tot)>(u0err+u1err)+uh_err) write(0,*) 'U non-conservation difference=',u1tot-u0tot,'allowed err=',u0err+u1err+uh_err,' <-----!' + if (abs(u1tot-u0tot)>(u0err+u1err)+uh_err) & + write(0,*) 'U non-conservation difference=',u1tot-u0tot,'allowed err=',u0err+u1err+uh_err,' <-----!' write(0,*) 'U: u0min=',u0min,'u1min=',u1min if (u1minu0max) ) then write(0,*) 'iMethod = ',iMethod write(0,*) 'H: h0tot=',h0tot,'h1tot=',h1tot,'dh=',h1tot-h0tot,'h0err=',h0err,'h1err=',h1err - if (abs(h1tot-h0tot)>h0err+h1err) write(0,*) 'H non-conservation difference=',h1tot-h0tot,'allowed err=',h0err+h1err,' <-----!' + if (abs(h1tot-h0tot)>h0err+h1err) & + write(0,*) 'H non-conservation difference=',h1tot-h0tot,'allowed err=',h0err+h1err,' <-----!' write(0,*) 'UH: u0tot=',u0tot,'u1tot=',u1tot,'duh=',u1tot-u0tot,'u0err=',u0err,'u1err=',u1err,'uh_err=',uh_err - if (abs(u1tot-u0tot)>(u0err+u1err)+uh_err) write(0,*) 'U non-conservation difference=',u1tot-u0tot,'allowed err=',u0err+u1err+uh_err,' <-----!' + if (abs(u1tot-u0tot)>(u0err+u1err)+uh_err) & + write(0,*) 'U non-conservation difference=',u1tot-u0tot,'allowed err=',u0err+u1err+uh_err,' <-----!' write(0,*) 'U: u0min=',u0min,'u1min=',u1min if (u1min Creates polynomial reconstructions of u0 on the source grid h0. -subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefficients, & +subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & ppoly_r_E, ppoly_r_S, iMethod, h_neglect, & h_neglect_edge ) - type(remapping_CS), intent(in) :: CS + type(remapping_CS), intent(in) :: CS !< Remapping control structure integer, intent(in) :: n0 !< Number of cells on source grid real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid real, dimension(n0,CS%degree+1), & - intent(out) :: ppoly_r_coefficients !< Coefficients of polynomial + intent(out) :: ppoly_r_coefs !< Coefficients of polynomial real, dimension(n0,2), intent(out) :: ppoly_r_E !< Edge value of polynomial real, dimension(n0,2), intent(out) :: ppoly_r_S !< Edge slope of polynomial integer, intent(out) :: iMethod !< Integration method @@ -367,7 +370,7 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefficients, & ! Reset polynomial ppoly_r_E(:,:) = 0.0 ppoly_r_S(:,:) = 0.0 - ppoly_r_coefficients(:,:) = 0.0 + ppoly_r_coefs(:,:) = 0.0 iMethod = -999 local_remapping_scheme = CS%remapping_scheme @@ -380,45 +383,45 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefficients, & endif select case ( local_remapping_scheme ) case ( REMAPPING_PCM ) - call PCM_reconstruction( n0, u0, ppoly_r_E, ppoly_r_coefficients) + call PCM_reconstruction( n0, u0, ppoly_r_E, ppoly_r_coefs) iMethod = INTEGRATION_PCM case ( REMAPPING_PLM ) - call PLM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients, h_neglect ) + call PLM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) if ( CS%boundary_extrapolation ) then - call PLM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients, h_neglect) - end if + call PLM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect) + endif iMethod = INTEGRATION_PLM case ( REMAPPING_PPM_H4 ) call edge_values_explicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge ) - call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients, h_neglect ) + call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) if ( CS%boundary_extrapolation ) then - call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients, h_neglect ) - end if + call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) + endif iMethod = INTEGRATION_PPM case ( REMAPPING_PPM_IH4 ) call edge_values_implicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge ) - call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients, h_neglect ) + call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) if ( CS%boundary_extrapolation ) then - call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients, h_neglect ) - end if + call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) + endif iMethod = INTEGRATION_PPM case ( REMAPPING_PQM_IH4IH3 ) call edge_values_implicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge ) call edge_slopes_implicit_h3( n0, h0, u0, ppoly_r_S, h_neglect ) - call PQM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_S, ppoly_r_coefficients, h_neglect ) + call PQM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_S, ppoly_r_coefs, h_neglect ) if ( CS%boundary_extrapolation ) then call PQM_boundary_extrapolation_v1( n0, h0, u0, ppoly_r_E, ppoly_r_S, & - ppoly_r_coefficients, h_neglect ) - end if + ppoly_r_coefs, h_neglect ) + endif iMethod = INTEGRATION_PQM case ( REMAPPING_PQM_IH6IH5 ) call edge_values_implicit_h6( n0, h0, u0, ppoly_r_E, h_neglect_edge ) call edge_slopes_implicit_h5( n0, h0, u0, ppoly_r_S, h_neglect ) - call PQM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_S, ppoly_r_coefficients, h_neglect ) + call PQM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_S, ppoly_r_coefs, h_neglect ) if ( CS%boundary_extrapolation ) then call PQM_boundary_extrapolation_v1( n0, h0, u0, ppoly_r_E, ppoly_r_S, & - ppoly_r_coefficients, h_neglect ) - end if + ppoly_r_coefs, h_neglect ) + endif iMethod = INTEGRATION_PQM case default call MOM_error( FATAL, 'MOM_remapping, build_reconstructions_1d: '//& @@ -429,13 +432,13 @@ end subroutine build_reconstructions_1d !> Checks that edge values and reconstructions satisfy bounds subroutine check_reconstructions_1d(n0, h0, u0, deg, boundary_extrapolation, & - ppoly_r_coefficients, ppoly_r_E, ppoly_r_S) + ppoly_r_coefs, ppoly_r_E, ppoly_r_S) integer, intent(in) :: n0 !< Number of cells on source grid real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid integer, intent(in) :: deg !< Degree of polynomial reconstruction logical, intent(in) :: boundary_extrapolation !< Extrapolate at boundaries if true - real, dimension(n0,deg+1),intent(out) :: ppoly_r_coefficients !< Coefficients of polynomial + real, dimension(n0,deg+1),intent(out) :: ppoly_r_coefs !< Coefficients of polynomial real, dimension(n0,2), intent(out) :: ppoly_r_E !< Edge value of polynomial real, dimension(n0,2), intent(out) :: ppoly_r_S !< Edge slope of polynomial ! Local variables @@ -486,11 +489,11 @@ subroutine check_reconstructions_1d(n0, h0, u0, deg, boundary_extrapolation, & endif endif if (problem_detected) then - write(0,'(a,1p9e24.16)') 'Polynomial coeffs:',ppoly_r_coefficients(i0,:) + write(0,'(a,1p9e24.16)') 'Polynomial coeffs:',ppoly_r_coefs(i0,:) write(0,'(3(a,1pe24.16,x))') 'u_l=',u_l,'u_c=',u_c,'u_r=',u_r write(0,'(a4,10a24)') 'i0','h0(i0)','u0(i0)','left edge','right edge','Polynomial coefficients' do n = 1, n0 - write(0,'(i4,1p10e24.16)') n,h0(n),u0(n),ppoly_r_E(n,1),ppoly_r_E(n,2),ppoly_r_coefficients(n,:) + write(0,'(i4,1p10e24.16)') n,h0(n),u0(n),ppoly_r_E(n,1),ppoly_r_E(n,2),ppoly_r_coefs(n,:) enddo call MOM_error(FATAL, 'MOM_remapping, check_reconstructions_1d: '// & 'Edge values or polynomial coefficients were inconsistent!') @@ -502,13 +505,13 @@ end subroutine check_reconstructions_1d !> Remaps column of n0 values u0 on grid h0 to grid h1 with n1 cells by calculating !! the n0+n1+1 sub-integrals of the intersection of h0 and h1, and the summing the !! appropriate integrals into the h1*u1 values. h0 and h1 must have the same units. -subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefficients, n1, h1, method, & +subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, method, & force_bounds_in_subcell, u1, uh_err, ah_sub, aisub_src, aiss, aise ) integer, intent(in) :: n0 !< Number of cells in source grid real, intent(in) :: h0(n0) !< Source grid widths (size n0) real, intent(in) :: u0(n0) !< Source cell averages (size n0) real, intent(in) :: ppoly0_E(n0,2) !< Edge value of polynomial - real, intent(in) :: ppoly0_coefficients(:,:) !< Coefficients of polynomial + real, intent(in) :: ppoly0_coefs(:,:) !< Coefficients of polynomial integer, intent(in) :: n1 !< Number of cells in target grid real, intent(in) :: h1(n1) !< Target grid widths (size n1) integer, intent(in) :: method !< Remapping scheme to use @@ -730,7 +733,7 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefficients, n1, h if (h0_eff(i0)>0.) then xb = dh0_eff / h0_eff(i0) ! This expression yields xa <= xb <= 1.0 xb = min(1., xb) ! This is only needed when the total target column is wider than the source column - u_sub(i_sub) = average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefficients, method, i0, xa, xb) + u_sub(i_sub) = average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefs, method, i0, xa, xb) else ! Vanished cell xb = 1. u_sub(i_sub) = u0(i0) @@ -741,7 +744,7 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefficients, n1, h write(0,*) 'xa,xb: ',xa,xb write(0,*) 'Edge values: ',ppoly0_E(i0,:),'mean',u0(i0) write(0,*) 'a_c: ',(u0(i0)-ppoly0_E(i0,1))+(u0(i0)-ppoly0_E(i0,2)) - write(0,*) 'Polynomial coeffs: ',ppoly0_coefficients(i0,:) + write(0,*) 'Polynomial coeffs: ',ppoly0_coefs(i0,:) write(0,*) 'Bounds min=',u0_min(i0),'max=',u0_max(i0) write(0,*) 'Average: ',u_sub(i_sub),'rel to min=',u_sub(i_sub)-u0_min(i0),'rel to max=',u_sub(i_sub)-u0_max(i0) call MOM_error( FATAL, 'MOM_remapping, remap_via_sub_cells: '//& @@ -836,19 +839,26 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefficients, n1, h write(0,*) 'method = ',method write(0,*) 'Source to sub-cells:' write(0,*) 'H: h0tot=',h0tot,'h2tot=',h2tot,'dh=',h2tot-h0tot,'h0err=',h0err,'h2err=',h2err - if (abs(h2tot-h0tot)>h0err+h2err) write(0,*) 'H non-conservation difference=',h2tot-h0tot,'allowed err=',h0err+h2err,' <-----!' - write(0,*) 'UH: u0tot=',u0tot,'u2tot=',u2tot,'duh=',u2tot-u0tot,'u0err=',u0err,'u2err=',u2err,'adjustment err=',u02_err - if (abs(u2tot-u0tot)>u0err+u2err) write(0,*) 'U non-conservation difference=',u2tot-u0tot,'allowed err=',u0err+u2err,' <-----!' + if (abs(h2tot-h0tot)>h0err+h2err) & + write(0,*) 'H non-conservation difference=',h2tot-h0tot,'allowed err=',h0err+h2err,' <-----!' + write(0,*) 'UH: u0tot=',u0tot,'u2tot=',u2tot,'duh=',u2tot-u0tot,'u0err=',u0err,'u2err=',u2err,& + 'adjustment err=',u02_err + if (abs(u2tot-u0tot)>u0err+u2err) & + write(0,*) 'U non-conservation difference=',u2tot-u0tot,'allowed err=',u0err+u2err,' <-----!' write(0,*) 'Sub-cells to target:' write(0,*) 'H: h2tot=',h2tot,'h1tot=',h1tot,'dh=',h1tot-h2tot,'h2err=',h2err,'h1err=',h1err - if (abs(h1tot-h2tot)>h2err+h1err) write(0,*) 'H non-conservation difference=',h1tot-h2tot,'allowed err=',h2err+h1err,' <-----!' + if (abs(h1tot-h2tot)>h2err+h1err) & + write(0,*) 'H non-conservation difference=',h1tot-h2tot,'allowed err=',h2err+h1err,' <-----!' write(0,*) 'UH: u2tot=',u2tot,'u1tot=',u1tot,'duh=',u1tot-u2tot,'u2err=',u2err,'u1err=',u1err,'uh_err=',uh_err - if (abs(u1tot-u2tot)>u2err+u1err) write(0,*) 'U non-conservation difference=',u1tot-u2tot,'allowed err=',u2err+u1err,' <-----!' + if (abs(u1tot-u2tot)>u2err+u1err) & + write(0,*) 'U non-conservation difference=',u1tot-u2tot,'allowed err=',u2err+u1err,' <-----!' write(0,*) 'Source to target:' write(0,*) 'H: h0tot=',h0tot,'h1tot=',h1tot,'dh=',h1tot-h0tot,'h0err=',h0err,'h1err=',h1err - if (abs(h1tot-h0tot)>h0err+h1err) write(0,*) 'H non-conservation difference=',h1tot-h0tot,'allowed err=',h0err+h1err,' <-----!' + if (abs(h1tot-h0tot)>h0err+h1err) & + write(0,*) 'H non-conservation difference=',h1tot-h0tot,'allowed err=',h0err+h1err,' <-----!' write(0,*) 'UH: u0tot=',u0tot,'u1tot=',u1tot,'duh=',u1tot-u0tot,'u0err=',u0err,'u1err=',u1err,'uh_err=',uh_err - if (abs(u1tot-u0tot)>(u0err+u1err)+uh_err) write(0,*) 'U non-conservation difference=',u1tot-u0tot,'allowed err=',u0err+u1err+uh_err,' <-----!' + if (abs(u1tot-u0tot)>(u0err+u1err)+uh_err) & + write(0,*) 'U non-conservation difference=',u1tot-u0tot,'allowed err=',u0err+u1err+uh_err,' <-----!' write(0,*) 'U: u0min=',u0min,'u1min=',u1min,'u2min=',u2min if (u1min Returns the average value of a reconstruction within a single source cell, i0, !! between the non-dimensional positions xa and xb (xa<=xb) with dimensional !! separation dh. -real function average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefficients, method, i0, xa, xb) +real function average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefs, method, i0, xa, xb) integer, intent(in) :: n0 !< Number of cells in source grid real, intent(in) :: u0(:) !< Cell means - real, intent(in) :: ppoly0_E(:,:) !< Edge value of polynomial - real, intent(in) :: ppoly0_coefficients(:,:) !< Coefficients of polynomial + real, intent(in) :: ppoly0_E(:,:) !< Edge value of polynomial + real, intent(in) :: ppoly0_coefs(:,:) !< Coefficients of polynomial integer, intent(in) :: method !< Remapping scheme to use integer, intent(in) :: i0 !< Source cell index real, intent(in) :: xa !< Non-dimensional start position within source cell @@ -927,8 +937,8 @@ real function average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefficients, method u_ave = u0(i0) case ( INTEGRATION_PLM ) u_ave = ( & - ppoly0_coefficients(i0,1) & - + ppoly0_coefficients(i0,2) * 0.5 * ( xb + xa ) ) + ppoly0_coefs(i0,1) & + + ppoly0_coefs(i0,2) * 0.5 * ( xb + xa ) ) case ( INTEGRATION_PPM ) mx = 0.5 * ( xa + xb ) a_L = ppoly0_E(i0, 1) @@ -955,21 +965,21 @@ real function average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefficients, method xa2pxb2 = xa_2 + xb_2 xapxb = xa + xb u_ave = ( & - ppoly0_coefficients(i0,1) & - + ( ppoly0_coefficients(i0,2) * 0.5 * ( xapxb ) & - + ( ppoly0_coefficients(i0,3) * r_3 * ( xa2pxb2 + xa*xb ) & - + ( ppoly0_coefficients(i0,4) * 0.25* ( xa2pxb2 * xapxb ) & - + ppoly0_coefficients(i0,5) * 0.2 * ( ( xb*xb_2 + xa*xa_2 ) * xapxb + xa_2*xb_2 ) ) ) ) ) + ppoly0_coefs(i0,1) & + + ( ppoly0_coefs(i0,2) * 0.5 * ( xapxb ) & + + ( ppoly0_coefs(i0,3) * r_3 * ( xa2pxb2 + xa*xb ) & + + ( ppoly0_coefs(i0,4) * 0.25* ( xa2pxb2 * xapxb ) & + + ppoly0_coefs(i0,5) * 0.2 * ( ( xb*xb_2 + xa*xa_2 ) * xapxb + xa_2*xb_2 ) ) ) ) ) case default call MOM_error( FATAL,'The selected integration method is invalid' ) end select else ! dh == 0. select case ( method ) case ( INTEGRATION_PCM ) - u_ave = ppoly0_coefficients(i0,1) + u_ave = ppoly0_coefs(i0,1) case ( INTEGRATION_PLM ) - !u_ave = ppoly0_coefficients(i0,1) & - ! + xa * ppoly0_coefficients(i0,2) + !u_ave = ppoly0_coefs(i0,1) & + ! + xa * ppoly0_coefs(i0,2) a_L = ppoly0_E(i0, 1) a_R = ppoly0_E(i0, 2) Ya = 1. - xa @@ -979,9 +989,9 @@ real function average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefficients, method u_ave = a_R + Ya * ( a_L - a_R ) endif case ( INTEGRATION_PPM ) - !u_ave = ppoly0_coefficients(i0,1) & - ! + xa * ( ppoly0_coefficients(i0,2) & - ! + xa * ppoly0_coefficients(i0,3) ) + !u_ave = ppoly0_coefs(i0,1) & + ! + xa * ( ppoly0_coefs(i0,2) & + ! + xa * ppoly0_coefs(i0,3) ) a_L = ppoly0_E(i0, 1) a_R = ppoly0_E(i0, 2) u_c = u0(i0) @@ -993,11 +1003,11 @@ real function average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefficients, method u_ave = a_R + Ya * ( ( a_L - a_R ) + a_c * xa ) endif case ( INTEGRATION_PQM ) - u_ave = ppoly0_coefficients(i0,1) & - + xa * ( ppoly0_coefficients(i0,2) & - + xa * ( ppoly0_coefficients(i0,3) & - + xa * ( ppoly0_coefficients(i0,4) & - + xa * ppoly0_coefficients(i0,5) ) ) ) + u_ave = ppoly0_coefs(i0,1) & + + xa * ( ppoly0_coefs(i0,2) & + + xa * ( ppoly0_coefs(i0,3) & + + xa * ( ppoly0_coefs(i0,4) & + + xa * ppoly0_coefs(i0,5) ) ) ) case default call MOM_error( FATAL,'The selected integration method is invalid' ) end select @@ -1075,13 +1085,13 @@ end subroutine measure_output_bounds !> Remaps column of values u0 on grid h0 to grid h1 by integrating !! over the projection of each h1 cell onto the h0 grid. -subroutine remapByProjection( n0, h0, u0, ppoly0_E, ppoly0_coefficients, & +subroutine remapByProjection( n0, h0, u0, ppoly0_E, ppoly0_coefs, & n1, h1, method, u1, h_neglect ) integer, intent(in) :: n0 !< Number of cells in source grid real, intent(in) :: h0(:) !< Source grid widths (size n0) real, intent(in) :: u0(:) !< Source cell averages (size n0) - real, intent(in) :: ppoly0_E(:,:) !< Edge value of polynomial - real, intent(in) :: ppoly0_coefficients(:,:) !< Coefficients of polynomial + real, intent(in) :: ppoly0_E(:,:) !< Edge value of polynomial + real, intent(in) :: ppoly0_coefs(:,:) !< Coefficients of polynomial integer, intent(in) :: n1 !< Number of cells in target grid real, intent(in) :: h1(:) !< Target grid widths (size n1) integer, intent(in) :: method !< Remapping scheme to use @@ -1106,10 +1116,10 @@ subroutine remapByProjection( n0, h0, u0, ppoly0_E, ppoly0_coefficients, & xL = xR xR = xL + h1(iTarget) - call integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefficients, method, & + call integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefs, method, & xL, xR, h1(iTarget), u1(iTarget), jStart, xStart, h_neglect ) - end do ! end iTarget loop on target grid cells + enddo ! end iTarget loop on target grid cells end subroutine remapByProjection @@ -1123,19 +1133,20 @@ end subroutine remapByProjection !! where !! F(k) = dx1(k) qAverage !! and where qAverage is the average qOld in the region zOld(k) to zNew(k). -subroutine remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefficients, n1, dx1, & +subroutine remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, dx1, & method, u1, h1, h_neglect ) - integer, intent(in) :: n0 !< Number of cells in source grid - real, intent(in) :: h0(:) !< Source grid widths (size n0) - real, intent(in) :: u0(:) !< Source cell averages (size n0) - real, intent(in) :: ppoly0_E(:,:) !< Edge value of polynomial - real, intent(in) :: ppoly0_coefficients(:,:) !< Coefficients of polynomial - integer, intent(in) :: n1 !< Number of cells in target grid - real, intent(in) :: dx1(:) !< Target grid edge positions (size n1+1) - integer :: method !< Remapping scheme to use - real, intent(out) :: u1(:) !< Target cell averages (size n1) - real, optional, intent(out) :: h1(:) !< Target grid widths (size n1) - real, optional, intent(in) :: h_neglect !< A negligibly small width for the + integer, intent(in) :: n0 !< Number of cells in source grid + real, dimension(:), intent(in) :: h0 !< Source grid sizes (size n0) + real, dimension(:), intent(in) :: u0 !< Source cell averages (size n0) + real, dimension(:,:), intent(in) :: ppoly0_E !< Edge value of polynomial + real, dimension(:,:), intent(in) :: ppoly0_coefs !< Coefficients of polynomial + integer, intent(in) :: n1 !< Number of cells in target grid + real, dimension(:), intent(in) :: dx1 !< Target grid edge positions (size n1+1) + integer, intent(in) :: method !< Remapping scheme to use + real, dimension(:), intent(out) :: u1 !< Target cell averages (size n1) + real, dimension(:), & + optional, intent(out) :: h1 !< Target grid widths (size n1) + real, optional, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions !! in the same units as h. ! Local variables @@ -1178,7 +1189,7 @@ subroutine remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefficients, n1, dx1, & ! hFlux is the positive width of the remapped volume hFlux = abs(dx1(iTarget+1)) - call integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefficients, method, & + call integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefs, method, & xL, xR, hFlux, uAve, jStart, xStart ) ! uAve is the average value of u, independent of sign of dx1 fluxR = dx1(iTarget+1)*uAve ! Includes sign of dx1 @@ -1195,28 +1206,29 @@ subroutine remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefficients, n1, dx1, & if (present(h1)) h1(iTarget) = hNew endif - end do ! end iTarget loop on target grid cells + enddo ! end iTarget loop on target grid cells end subroutine remapByDeltaZ !> Integrate the reconstructed column profile over a single cell -subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefficients, method, & +subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefs, method, & xL, xR, hC, uAve, jStart, xStart, h_neglect ) - integer, intent(in) :: n0 !< Number of cells in source grid - real, intent(in) :: h0(:) !< Source grid sizes (size n0) - real, intent(in) :: u0(:) !< Source cell averages - real, intent(in) :: ppoly0_E(:,:) !< Edge value of polynomial - real, intent(in) :: ppoly0_coefficients(:,:) !< Coefficients of polynomial - integer, intent(in) :: method !< Remapping scheme to use - real, intent(in) :: xL, xR !< Left/right edges of target cell - real, intent(in) :: hC !< Cell width hC = xR - xL - real, intent(out) :: uAve !< Average value on target cell - integer, intent(inout) :: jStart !< The index of the cell to start searching from + integer, intent(in) :: n0 !< Number of cells in source grid + real, dimension(:), intent(in) :: h0 !< Source grid sizes (size n0) + real, dimension(:), intent(in) :: u0 !< Source cell averages + real, dimension(:,:), intent(in) :: ppoly0_E !< Edge value of polynomial + real, dimension(:,:), intent(in) :: ppoly0_coefs !< Coefficients of polynomial + integer, intent(in) :: method !< Remapping scheme to use + real, intent(in) :: xL !< Left edges of target cell + real, intent(in) :: xR !< Right edges of target cell + real, intent(in) :: hC !< Cell width hC = xR - xL + real, intent(out) :: uAve !< Average value on target cell + integer, intent(inout) :: jStart !< The index of the cell to start searching from !< On exit, contains index of last cell used - real, intent(inout) :: xStart !< The left edge position of cell jStart + real, intent(inout) :: xStart !< The left edge position of cell jStart !< On first entry should be 0. - real, optional, intent(in) :: h_neglect !< A negligibly small width for the + real, optional, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions !! in the same units as h. ! Local variables @@ -1291,25 +1303,25 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefficients, select case ( method ) case ( INTEGRATION_PCM ) - uAve = ppoly0_coefficients(jL,1) + uAve = ppoly0_coefs(jL,1) case ( INTEGRATION_PLM ) - uAve = ppoly0_coefficients(jL,1) & - + xi0 * ppoly0_coefficients(jL,2) + uAve = ppoly0_coefs(jL,1) & + + xi0 * ppoly0_coefs(jL,2) case ( INTEGRATION_PPM ) - uAve = ppoly0_coefficients(jL,1) & - + xi0 * ( ppoly0_coefficients(jL,2) & - + xi0 * ppoly0_coefficients(jL,3) ) + uAve = ppoly0_coefs(jL,1) & + + xi0 * ( ppoly0_coefs(jL,2) & + + xi0 * ppoly0_coefs(jL,3) ) case ( INTEGRATION_PQM ) - uAve = ppoly0_coefficients(jL,1) & - + xi0 * ( ppoly0_coefficients(jL,2) & - + xi0 * ( ppoly0_coefficients(jL,3) & - + xi0 * ( ppoly0_coefficients(jL,4) & - + xi0 * ppoly0_coefficients(jL,5) ) ) ) + uAve = ppoly0_coefs(jL,1) & + + xi0 * ( ppoly0_coefs(jL,2) & + + xi0 * ( ppoly0_coefs(jL,3) & + + xi0 * ( ppoly0_coefs(jL,4) & + + xi0 * ppoly0_coefs(jL,5) ) ) ) case default call MOM_error( FATAL,'The selected integration method is invalid' ) end select - end if ! end checking whether source cell is vanished + endif ! end checking whether source cell is vanished ! 2. Cell is not vanished else @@ -1360,27 +1372,27 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefficients, ! coordinates, hence: \int_xL^xR p(x) dx = h \int_xi0^xi1 p(xi) dxi select case ( method ) case ( INTEGRATION_PCM ) - q = ( xR - xL ) * ppoly0_coefficients(jL,1) + q = ( xR - xL ) * ppoly0_coefs(jL,1) case ( INTEGRATION_PLM ) - q = ( xR - xL ) * ( & - ppoly0_coefficients(jL,1) & - + ppoly0_coefficients(jL,2) * 0.5 * ( xi1 + xi0 ) ) + q = ( xR - xL ) * ( & + ppoly0_coefs(jL,1) & + + ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) ) case ( INTEGRATION_PPM ) - q = ( xR - xL ) * ( & - ppoly0_coefficients(jL,1) & - + ( ppoly0_coefficients(jL,2) * 0.5 * ( xi1 + xi0 ) & - + ppoly0_coefficients(jL,3) * r_3 * ( ( xi1*xi1 + xi0*xi0 ) + xi0*xi1 ) ) ) + q = ( xR - xL ) * ( & + ppoly0_coefs(jL,1) & + + ( ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) & + + ppoly0_coefs(jL,3) * r_3 * ( ( xi1*xi1 + xi0*xi0 ) + xi0*xi1 ) ) ) case ( INTEGRATION_PQM ) x0_2 = xi0*xi0 x1_2 = xi1*xi1 x02px12 = x0_2 + x1_2 x0px1 = xi1 + xi0 - q = ( xR - xL ) * ( & - ppoly0_coefficients(jL,1) & - + ( ppoly0_coefficients(jL,2) * 0.5 * ( xi1 + xi0 ) & - + ( ppoly0_coefficients(jL,3) * r_3 * ( x02px12 + xi0*xi1 ) & - + ppoly0_coefficients(jL,4) * 0.25* ( x02px12 * x0px1 ) & - + ppoly0_coefficients(jL,5) * 0.2 * ( ( xi1*x1_2 + xi0*x0_2 ) * x0px1 + x0_2*x1_2 ) ) ) ) + q = ( xR - xL ) * ( & + ppoly0_coefs(jL,1) & + + ( ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) & + + ( ppoly0_coefs(jL,3) * r_3 * ( x02px12 + xi0*xi1 ) & + + ppoly0_coefs(jL,4) * 0.25* ( x02px12 * x0px1 ) & + + ppoly0_coefs(jL,5) * 0.2 * ( ( xi1*x1_2 + xi0*x0_2 ) * x0px1 + x0_2*x1_2 ) ) ) ) case default call MOM_error( FATAL,'The selected integration method is invalid' ) end select @@ -1412,27 +1424,27 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefficients, select case ( method ) case ( INTEGRATION_PCM ) - q = q + ( x0jLr - xL ) * ppoly0_coefficients(jL,1) + q = q + ( x0jLr - xL ) * ppoly0_coefs(jL,1) case ( INTEGRATION_PLM ) - q = q + ( x0jLr - xL ) * ( & - ppoly0_coefficients(jL,1) & - + ppoly0_coefficients(jL,2) * 0.5 * ( xi1 + xi0 ) ) + q = q + ( x0jLr - xL ) * ( & + ppoly0_coefs(jL,1) & + + ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) ) case ( INTEGRATION_PPM ) - q = q + ( x0jLr - xL ) * ( & - ppoly0_coefficients(jL,1) & - + ( ppoly0_coefficients(jL,2) * 0.5 * ( xi1 + xi0 ) & - + ppoly0_coefficients(jL,3) * r_3 * ( ( xi1*xi1 + xi0*xi0 ) + xi0*xi1 ) ) ) + q = q + ( x0jLr - xL ) * ( & + ppoly0_coefs(jL,1) & + + ( ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) & + + ppoly0_coefs(jL,3) * r_3 * ( ( xi1*xi1 + xi0*xi0 ) + xi0*xi1 ) ) ) case ( INTEGRATION_PQM ) x0_2 = xi0*xi0 x1_2 = xi1*xi1 x02px12 = x0_2 + x1_2 x0px1 = xi1 + xi0 - q = q + ( x0jLr - xL ) * ( & - ppoly0_coefficients(jL,1) & - + ( ppoly0_coefficients(jL,2) * 0.5 * ( xi1 + xi0 ) & - + ( ppoly0_coefficients(jL,3) * r_3 * ( x02px12 + xi0*xi1 ) & - + ppoly0_coefficients(jL,4) * 0.25* ( x02px12 * x0px1 ) & - + ppoly0_coefficients(jL,5) * 0.2 * ( ( xi1*x1_2 + xi0*x0_2 ) * x0px1 + x0_2*x1_2 ) ) ) ) + q = q + ( x0jLr - xL ) * ( & + ppoly0_coefs(jL,1) & + + ( ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) & + + ( ppoly0_coefs(jL,3) * r_3 * ( x02px12 + xi0*xi1 ) & + + ppoly0_coefs(jL,4) * 0.25* ( x02px12 * x0px1 ) & + + ppoly0_coefs(jL,5) * 0.2 * ( ( xi1*x1_2 + xi0*x0_2 ) * x0px1 + x0_2*x1_2 ) ) ) ) case default call MOM_error( FATAL, 'The selected integration method is invalid' ) end select @@ -1442,8 +1454,8 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefficients, do k = jL+1,jR-1 q = q + h0(k) * u0(k) hAct = hAct + h0(k) - end do - end if + enddo + endif ! Integrate from left boundary of cell jR up to xR xi0 = 0.0 @@ -1457,37 +1469,37 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefficients, select case ( method ) case ( INTEGRATION_PCM ) - q = q + ( xR - x0jRl ) * ppoly0_coefficients(jR,1) + q = q + ( xR - x0jRl ) * ppoly0_coefs(jR,1) case ( INTEGRATION_PLM ) - q = q + ( xR - x0jRl ) * ( & - ppoly0_coefficients(jR,1) & - + ppoly0_coefficients(jR,2) * 0.5 * ( xi1 + xi0 ) ) + q = q + ( xR - x0jRl ) * ( & + ppoly0_coefs(jR,1) & + + ppoly0_coefs(jR,2) * 0.5 * ( xi1 + xi0 ) ) case ( INTEGRATION_PPM ) - q = q + ( xR - x0jRl ) * ( & - ppoly0_coefficients(jR,1) & - + ( ppoly0_coefficients(jR,2) * 0.5 * ( xi1 + xi0 ) & - + ppoly0_coefficients(jR,3) * r_3 * ( ( xi1*xi1 + xi0*xi0 ) + xi0*xi1 ) ) ) + q = q + ( xR - x0jRl ) * ( & + ppoly0_coefs(jR,1) & + + ( ppoly0_coefs(jR,2) * 0.5 * ( xi1 + xi0 ) & + + ppoly0_coefs(jR,3) * r_3 * ( ( xi1*xi1 + xi0*xi0 ) + xi0*xi1 ) ) ) case ( INTEGRATION_PQM ) x0_2 = xi0*xi0 x1_2 = xi1*xi1 x02px12 = x0_2 + x1_2 x0px1 = xi1 + xi0 - q = q + ( xR - x0jRl ) * ( & - ppoly0_coefficients(jR,1) & - + ( ppoly0_coefficients(jR,2) * 0.5 * ( xi1 + xi0 ) & - + ( ppoly0_coefficients(jR,3) * r_3 * ( x02px12 + xi0*xi1 ) & - + ppoly0_coefficients(jR,4) * 0.25* ( x02px12 * x0px1 ) & - + ppoly0_coefficients(jR,5) * 0.2 * ( ( xi1*x1_2 + xi0*x0_2 ) * x0px1 + x0_2*x1_2 ) ) ) ) + q = q + ( xR - x0jRl ) * ( & + ppoly0_coefs(jR,1) & + + ( ppoly0_coefs(jR,2) * 0.5 * ( xi1 + xi0 ) & + + ( ppoly0_coefs(jR,3) * r_3 * ( x02px12 + xi0*xi1 ) & + + ppoly0_coefs(jR,4) * 0.25* ( x02px12 * x0px1 ) & + + ppoly0_coefs(jR,5) * 0.2 * ( ( xi1*x1_2 + xi0*x0_2 ) * x0px1 + x0_2*x1_2 ) ) ) ) case default call MOM_error( FATAL,'The selected integration method is invalid' ) end select - end if ! end integration for non-vanished cells + endif ! end integration for non-vanished cells ! The cell average is the integrated value divided by the cell width #ifdef __USE_ROUNDOFF_SAFE_ADJUSTMENTS__ if (hAct==0.) then - uAve = ppoly0_coefficients(jL,1) + uAve = ppoly0_coefs(jL,1) else uAve = q / hAct endif @@ -1495,7 +1507,7 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefficients, uAve = q / hC #endif - end if ! end if clause to check if cell is vanished + endif ! endif clause to check if cell is vanished end subroutine integrateReconOnInterval @@ -1602,7 +1614,7 @@ logical function remapping_unit_tests(verbose) data h1 /3*1./ ! 3 uniform layers with total depth of 3 data h2 /6*0.5/ ! 6 uniform layers with total depth of 3 type(remapping_CS) :: CS !< Remapping control structure - real, allocatable, dimension(:,:) :: ppoly0_E, ppoly0_S, ppoly0_coefficients + real, allocatable, dimension(:,:) :: ppoly0_E, ppoly0_S, ppoly0_coefs integer :: i real :: err, h_neglect, h_neglect_edge logical :: thisTest, v @@ -1649,17 +1661,17 @@ logical function remapping_unit_tests(verbose) thisTest = .false. allocate(ppoly0_E(n0,2)) allocate(ppoly0_S(n0,2)) - allocate(ppoly0_coefficients(n0,CS%degree+1)) + allocate(ppoly0_coefs(n0,CS%degree+1)) ppoly0_E(:,:) = 0.0 ppoly0_S(:,:) = 0.0 - ppoly0_coefficients(:,:) = 0.0 + ppoly0_coefs(:,:) = 0.0 call edge_values_explicit_h4( n0, h0, u0, ppoly0_E, h_neglect=1e-10 ) - call PPM_reconstruction( n0, h0, u0, ppoly0_E, ppoly0_coefficients, h_neglect ) - call PPM_boundary_extrapolation( n0, h0, u0, ppoly0_E, ppoly0_coefficients, h_neglect ) + call PPM_reconstruction( n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect ) + call PPM_boundary_extrapolation( n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect ) u1(:) = 0. - call remapByProjection( n0, h0, u0, ppoly0_E, ppoly0_coefficients, & + call remapByProjection( n0, h0, u0, ppoly0_E, ppoly0_coefs, & n1, h1, INTEGRATION_PPM, u1, h_neglect ) do i=1,n1 err=u1(i)-8.*(0.5*real(1+n1)-real(i)) @@ -1670,7 +1682,7 @@ logical function remapping_unit_tests(verbose) thisTest = .false. u1(:) = 0. - call remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefficients, & + call remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefs, & n1, x1-x0(1:n1+1), & INTEGRATION_PPM, u1, hn1, h_neglect ) if (verbose) write(*,*) 'h1 (by delta)' @@ -1687,7 +1699,7 @@ logical function remapping_unit_tests(verbose) call buildGridFromH(n2, h2, x2) dx2(1:n0+1) = x2(1:n0+1) - x0 dx2(n0+2:n2+1) = x2(n0+2:n2+1) - x0(n0+1) - call remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefficients, & + call remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefs, & n2, dx2, & INTEGRATION_PPM, u2, hn2, h_neglect ) if (verbose) write(*,*) 'h2' @@ -1704,7 +1716,7 @@ logical function remapping_unit_tests(verbose) if (verbose) write(*,*) 'Via sub-cells' thisTest = .false. - call remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefficients, & + call remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, & n2, h2, INTEGRATION_PPM, .false., u2, err ) if (verbose) call dumpGrid(n2,h2,x2,u2) @@ -1715,11 +1727,11 @@ logical function remapping_unit_tests(verbose) if (thisTest) write(*,*) 'remapping_unit_tests: Failed remap_via_sub_cells() 2' remapping_unit_tests = remapping_unit_tests .or. thisTest - call remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefficients, & + call remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, & 6, (/.125,.125,.125,.125,.125,.125/), INTEGRATION_PPM, .false., u2, err ) if (verbose) call dumpGrid(6,h2,x2,u2) - call remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefficients, & + call remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, & 3, (/2.25,1.5,1./), INTEGRATION_PPM, .false., u2, err ) if (verbose) call dumpGrid(3,h2,x2,u2) @@ -1727,126 +1739,128 @@ logical function remapping_unit_tests(verbose) write(*,*) '===== MOM_remapping: new remapping_unit_tests ==================' - deallocate(ppoly0_E, ppoly0_S, ppoly0_coefficients) - allocate(ppoly0_coefficients(5,6)) + deallocate(ppoly0_E, ppoly0_S, ppoly0_coefs) + allocate(ppoly0_coefs(5,6)) allocate(ppoly0_E(5,2)) allocate(ppoly0_S(5,2)) call PCM_reconstruction(3, (/1.,2.,4./), ppoly0_E(1:3,:), & - ppoly0_coefficients(1:3,:) ) + ppoly0_coefs(1:3,:) ) remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 3, ppoly0_E(:,1), (/1.,2.,4./), 'PCM: left edges') remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 3, ppoly0_E(:,2), (/1.,2.,4./), 'PCM: right edges') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefficients(:,1), (/1.,2.,4./), 'PCM: P0') + test_answer(v, 3, ppoly0_coefs(:,1), (/1.,2.,4./), 'PCM: P0') call PLM_reconstruction(3, (/1.,1.,1./), (/1.,3.,5./), ppoly0_E(1:3,:), & - ppoly0_coefficients(1:3,:), h_neglect ) + ppoly0_coefs(1:3,:), h_neglect ) remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 3, ppoly0_E(:,1), (/1.,2.,5./), 'Unlim PLM: left edges') remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 3, ppoly0_E(:,2), (/1.,4.,5./), 'Unlim PLM: right edges') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefficients(:,1), (/1.,2.,5./), 'Unlim PLM: P0') + test_answer(v, 3, ppoly0_coefs(:,1), (/1.,2.,5./), 'Unlim PLM: P0') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefficients(:,2), (/0.,2.,0./), 'Unlim PLM: P1') + test_answer(v, 3, ppoly0_coefs(:,2), (/0.,2.,0./), 'Unlim PLM: P1') call PLM_reconstruction(3, (/1.,1.,1./), (/1.,2.,7./), ppoly0_E(1:3,:), & - ppoly0_coefficients(1:3,:), h_neglect ) + ppoly0_coefs(1:3,:), h_neglect ) remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 3, ppoly0_E(:,1), (/1.,1.,7./), 'Left lim PLM: left edges') remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 3, ppoly0_E(:,2), (/1.,3.,7./), 'Left lim PLM: right edges') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefficients(:,1), (/1.,1.,7./), 'Left lim PLM: P0') + test_answer(v, 3, ppoly0_coefs(:,1), (/1.,1.,7./), 'Left lim PLM: P0') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefficients(:,2), (/0.,2.,0./), 'Left lim PLM: P1') + test_answer(v, 3, ppoly0_coefs(:,2), (/0.,2.,0./), 'Left lim PLM: P1') call PLM_reconstruction(3, (/1.,1.,1./), (/1.,6.,7./), ppoly0_E(1:3,:), & - ppoly0_coefficients(1:3,:), h_neglect ) + ppoly0_coefs(1:3,:), h_neglect ) remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 3, ppoly0_E(:,1), (/1.,5.,7./), 'Right lim PLM: left edges') remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 3, ppoly0_E(:,2), (/1.,7.,7./), 'Right lim PLM: right edges') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefficients(:,1), (/1.,5.,7./), 'Right lim PLM: P0') + test_answer(v, 3, ppoly0_coefs(:,1), (/1.,5.,7./), 'Right lim PLM: P0') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefficients(:,2), (/0.,2.,0./), 'Right lim PLM: P1') + test_answer(v, 3, ppoly0_coefs(:,2), (/0.,2.,0./), 'Right lim PLM: P1') call PLM_reconstruction(3, (/1.,2.,3./), (/1.,4.,9./), ppoly0_E(1:3,:), & - ppoly0_coefficients(1:3,:), h_neglect ) + ppoly0_coefs(1:3,:), h_neglect ) remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 3, ppoly0_E(:,1), (/1.,2.,9./), 'Non-uniform line PLM: left edges') remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 3, ppoly0_E(:,2), (/1.,6.,9./), 'Non-uniform line PLM: right edges') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefficients(:,1), (/1.,2.,9./), 'Non-uniform line PLM: P0') + test_answer(v, 3, ppoly0_coefs(:,1), (/1.,2.,9./), 'Non-uniform line PLM: P0') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefficients(:,2), (/0.,4.,0./), 'Non-uniform line PLM: P1') + test_answer(v, 3, ppoly0_coefs(:,2), (/0.,4.,0./), 'Non-uniform line PLM: P1') call edge_values_explicit_h4( 5, (/1.,1.,1.,1.,1./), (/1.,3.,5.,7.,9./), ppoly0_E, & h_neglect=1e-10 ) - thisTest = test_answer(v, 5, ppoly0_E(:,1), (/0.,2.,4.,6.,8./), 'Line H4: left edges') ! Currently fails due to roundoff - thisTest = test_answer(v, 5, ppoly0_E(:,2), (/2.,4.,6.,8.,10./), 'Line H4: right edges') ! Currently fails due to roundoff + ! The next two tests currently fail due to roundoff. + thisTest = test_answer(v, 5, ppoly0_E(:,1), (/0.,2.,4.,6.,8./), 'Line H4: left edges') + thisTest = test_answer(v, 5, ppoly0_E(:,2), (/2.,4.,6.,8.,10./), 'Line H4: right edges') ppoly0_E(:,1) = (/0.,2.,4.,6.,8./) ppoly0_E(:,2) = (/2.,4.,6.,8.,10./) call PPM_reconstruction(5, (/1.,1.,1.,1.,1./), (/1.,3.,5.,7.,9./), ppoly0_E(1:5,:), & - ppoly0_coefficients(1:5,:), h_neglect ) + ppoly0_coefs(1:5,:), h_neglect ) remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefficients(:,1), (/1.,2.,4.,6.,9./), 'Line PPM: P0') + test_answer(v, 5, ppoly0_coefs(:,1), (/1.,2.,4.,6.,9./), 'Line PPM: P0') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefficients(:,2), (/0.,2.,2.,2.,0./), 'Line PPM: P1') + test_answer(v, 5, ppoly0_coefs(:,2), (/0.,2.,2.,2.,0./), 'Line PPM: P1') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefficients(:,3), (/0.,0.,0.,0.,0./), 'Line PPM: P2') + test_answer(v, 5, ppoly0_coefs(:,3), (/0.,0.,0.,0.,0./), 'Line PPM: P2') call edge_values_explicit_h4( 5, (/1.,1.,1.,1.,1./), (/1.,1.,7.,19.,37./), ppoly0_E, & h_neglect=1e-10 ) - thisTest = test_answer(v, 5, ppoly0_E(:,1), (/3.,0.,3.,12.,27./), 'Parabola H4: left edges') ! Currently fails due to roundoff - thisTest = test_answer(v, 5, ppoly0_E(:,2), (/0.,3.,12.,27.,48./), 'Parabola H4: right edges') ! Currently fails due to roundoff + ! The next two tests currently fail due to roundoff. + thisTest = test_answer(v, 5, ppoly0_E(:,1), (/3.,0.,3.,12.,27./), 'Parabola H4: left edges') + thisTest = test_answer(v, 5, ppoly0_E(:,2), (/0.,3.,12.,27.,48./), 'Parabola H4: right edges') ppoly0_E(:,1) = (/0.,0.,3.,12.,27./) ppoly0_E(:,2) = (/0.,3.,12.,27.,48./) call PPM_reconstruction(5, (/1.,1.,1.,1.,1./), (/0.,1.,7.,19.,37./), ppoly0_E(1:5,:), & - ppoly0_coefficients(1:5,:), h_neglect ) + ppoly0_coefs(1:5,:), h_neglect ) remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 5, ppoly0_E(:,1), (/0.,0.,3.,12.,37./), 'Parabola PPM: left edges') remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 5, ppoly0_E(:,2), (/0.,3.,12.,27.,37./), 'Parabola PPM: right edges') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefficients(:,1), (/0.,0.,3.,12.,37./), 'Parabola PPM: P0') + test_answer(v, 5, ppoly0_coefs(:,1), (/0.,0.,3.,12.,37./), 'Parabola PPM: P0') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefficients(:,2), (/0.,0.,6.,12.,0./), 'Parabola PPM: P1') + test_answer(v, 5, ppoly0_coefs(:,2), (/0.,0.,6.,12.,0./), 'Parabola PPM: P1') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefficients(:,3), (/0.,3.,3.,3.,0./), 'Parabola PPM: P2') + test_answer(v, 5, ppoly0_coefs(:,3), (/0.,3.,3.,3.,0./), 'Parabola PPM: P2') ppoly0_E(:,1) = (/0.,0.,6.,10.,15./) ppoly0_E(:,2) = (/0.,6.,12.,17.,15./) call PPM_reconstruction(5, (/1.,1.,1.,1.,1./), (/0.,5.,7.,16.,15./), ppoly0_E(1:5,:), & - ppoly0_coefficients(1:5,:), h_neglect ) + ppoly0_coefs(1:5,:), h_neglect ) remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 5, ppoly0_E(:,1), (/0.,3.,6.,16.,15./), 'Limits PPM: left edges') remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 5, ppoly0_E(:,2), (/0.,6.,9.,16.,15./), 'Limits PPM: right edges') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefficients(:,1), (/0.,3.,6.,16.,15./), 'Limits PPM: P0') + test_answer(v, 5, ppoly0_coefs(:,1), (/0.,3.,6.,16.,15./), 'Limits PPM: P0') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefficients(:,2), (/0.,6.,0.,0.,0./), 'Limits PPM: P1') + test_answer(v, 5, ppoly0_coefs(:,2), (/0.,6.,0.,0.,0./), 'Limits PPM: P1') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefficients(:,3), (/0.,-3.,3.,0.,0./), 'Limits PPM: P2') + test_answer(v, 5, ppoly0_coefs(:,3), (/0.,-3.,3.,0.,0./), 'Limits PPM: P2') call PLM_reconstruction(4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), ppoly0_E(1:4,:), & - ppoly0_coefficients(1:4,:), h_neglect ) + ppoly0_coefs(1:4,:), h_neglect ) remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 4, ppoly0_E(1:4,1), (/5.,5.,3.,1./), 'PPM: left edges h=0110') remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 4, ppoly0_E(1:4,2), (/5.,3.,1.,1./), 'PPM: right edges h=0110') call remap_via_sub_cells( 4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), ppoly0_E(1:4,:), & - ppoly0_coefficients(1:4,:), & + ppoly0_coefs(1:4,:), & 2, (/1.,1./), INTEGRATION_PLM, .false., u2, err ) remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 2, u2, (/4.,2./), 'PLM: remapped h=0110->h=11') - deallocate(ppoly0_E, ppoly0_S, ppoly0_coefficients) + deallocate(ppoly0_E, ppoly0_S, ppoly0_coefs) if (.not. remapping_unit_tests) write(*,*) 'Pass' diff --git a/src/ALE/P1M_functions.F90 b/src/ALE/P1M_functions.F90 index a7a7635800..0a0d842581 100644 --- a/src/ALE/P1M_functions.F90 +++ b/src/ALE/P1M_functions.F90 @@ -1,73 +1,40 @@ +!> Linear interpolation functions module P1M_functions ! This file is part of MOM6. See LICENSE.md for the license. -!============================================================================== -! -! Date of creation: 2008.06.09 -! L. White -! -! This module contains p1m (linear) interpolation routines. -! -! p1m interpolation is performed by estimating the edge values and -! linearly interpolating between them. - -! Once the edge values are estimated, the limiting process takes care of -! ensuring that (1) edge values are bounded by neighoring cell averages -! and (2) discontinuous edge values are averaged in order to provide a -! fully continuous interpolant throughout the domain. This last step is -! essential for the regridding problem to yield a unique solution. -! Also, a routine is provided that takes care of linear extrapolation -! within the boundary cells. -! -! The module contains the following routines: -! -! P1M_interpolation (public) -! P1M_boundary_extrapolation (public) -! -!============================================================================== use regrid_edge_values, only : bound_edge_values, average_discontinuous_edge_values implicit none ; private -! ----------------------------------------------------------------------------- ! The following routines are visible to the outside world -! ----------------------------------------------------------------------------- public P1M_interpolation, P1M_boundary_extrapolation contains - -!------------------------------------------------------------------------------ -! p1m interpolation -!------------------------------------------------------------------------------ -subroutine P1M_interpolation( N, h, u, ppoly_E, ppoly_coefficients, h_neglect ) -! ------------------------------------------------------------------------------ -! Linearly interpolate between edge values. -! The resulting piecewise interpolant is stored in 'ppoly'. -! See 'ppoly.F90' for a definition of this structure. -! -! The edge values MUST have been estimated prior to calling this routine. -! -! The estimated edge values must be limited to ensure monotonicity of the -! interpolant. We also make sure that edge values are NOT discontinuous. -! -! It is assumed that the size of the array 'u' is equal to the number of cells -! defining 'grid' and 'ppoly'. No consistency check is performed here. -! ------------------------------------------------------------------------------ - - ! Arguments +!> Linearly interpolate between edge values +!! +!! The resulting piecewise interpolant is stored in 'ppoly'. +!! See 'ppoly.F90' for a definition of this structure. +!! +!! The edge values MUST have been estimated prior to calling this routine. +!! +!! The estimated edge values must be limited to ensure monotonicity of the +!! interpolant. We also make sure that edge values are NOT discontinuous. +!! +!! It is assumed that the size of the array 'u' is equal to the number of cells +!! defining 'grid' and 'ppoly'. No consistency check is performed here. +subroutine P1M_interpolation( N, h, u, ppoly_E, ppoly_coef, h_neglect ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) real, dimension(:), intent(in) :: u !< cell average properties (size N) real, dimension(:,:), intent(inout) :: ppoly_E !< Potentially modified edge values, !! with the same units as u. - real, dimension(:,:), intent(inout) :: ppoly_coefficients !< Potentially modified + real, dimension(:,:), intent(inout) :: ppoly_coef !< Potentially modified !! piecewise polynomial coefficients, mainly !! with the same units as u. real, optional, intent(in) :: h_neglect !< A negligibly small width !! in the same units as h. - ! Local variables integer :: k ! loop index real :: u0_l, u0_r ! edge values (left and right) @@ -85,40 +52,29 @@ subroutine P1M_interpolation( N, h, u, ppoly_E, ppoly_coefficients, h_neglect ) u0_l = ppoly_E(k,1) u0_r = ppoly_E(k,2) - ppoly_coefficients(k,1) = u0_l - ppoly_coefficients(k,2) = u0_r - u0_l + ppoly_coef(k,1) = u0_l + ppoly_coef(k,2) = u0_r - u0_l - end do ! end loop on interior cells + enddo ! end loop on interior cells end subroutine P1M_interpolation - -!------------------------------------------------------------------------------ -! p1m boundary extrapolation -! ----------------------------------------------------------------------------- -subroutine P1M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients ) -!------------------------------------------------------------------------------ -! Interpolation by linear polynomials within boundary cells. -! The left and right edge values in the left and right boundary cells, -! respectively, are estimated using a linear extrapolation within the cells. -! -! N: number of cells in grid -! h: thicknesses of grid cells -! u: cell averages to use in constructing piecewise polynomials -! ppoly_E : edge values of piecewise polynomials -! ppoly_coefficients : coefficients of piecewise polynomials -! -! It is assumed that the size of the array 'u' is equal to the number of cells -! defining 'grid' and 'ppoly'. No consistency check is performed here. -!------------------------------------------------------------------------------ - +!> Interpolation by linear polynomials within boundary cells +!! +!! The left and right edge values in the left and right boundary cells, +!! respectively, are estimated using a linear extrapolation within the cells. +!! +!! It is assumed that the size of the array 'u' is equal to the number of cells +!! defining 'grid' and 'ppoly'. No consistency check is performed here. +subroutine P1M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef ) ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell widths (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: ppoly_E - real, dimension(:,:), intent(inout) :: ppoly_coefficients - + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell averages (size N) + real, dimension(:,:), intent(inout) :: ppoly_E !< edge values of piecewise polynomials, + !! with the same units as u. + real, dimension(:,:), intent(inout) :: ppoly_coef !< coefficients of piecewise polynomials, mainly + !! with the same units as u. ! Local variables real :: u0, u1 ! cell averages real :: h0, h1 ! corresponding cell widths @@ -145,20 +101,20 @@ subroutine P1M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients ) ! by using the edge value in the neighboring cell. u0_r = u0 + 0.5 * slope - if ( (u1 - u0) * (ppoly_E(2,1) - u0_r) .LT. 0.0 ) then + if ( (u1 - u0) * (ppoly_E(2,1) - u0_r) < 0.0 ) then slope = 2.0 * ( ppoly_E(2,1) - u0 ) - end if + endif ! Using the limited slope, the left edge value is reevaluated and ! the interpolant coefficients recomputed - if ( h0 .NE. 0.0 ) then + if ( h0 /= 0.0 ) then ppoly_E(1,1) = u0 - 0.5 * slope else ppoly_E(1,1) = u0 - end if + endif - ppoly_coefficients(1,1) = ppoly_E(1,1) - ppoly_coefficients(1,2) = ppoly_E(1,2) - ppoly_E(1,1) + ppoly_coef(1,1) = ppoly_E(1,1) + ppoly_coef(1,2) = ppoly_E(1,2) - ppoly_E(1,1) ! ------------------------------------------ ! Right edge value in the left boundary cell @@ -173,19 +129,37 @@ subroutine P1M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients ) u0_l = u1 - 0.5 * slope - if ( (u1 - u0) * (u0_l - ppoly_E(N-1,2)) .LT. 0.0 ) then + if ( (u1 - u0) * (u0_l - ppoly_E(N-1,2)) < 0.0 ) then slope = 2.0 * ( u1 - ppoly_E(N-1,2) ) - end if + endif - if ( h1 .NE. 0.0 ) then + if ( h1 /= 0.0 ) then ppoly_E(N,2) = u1 + 0.5 * slope else ppoly_E(N,2) = u1 - end if + endif - ppoly_coefficients(N,1) = ppoly_E(N,1) - ppoly_coefficients(N,2) = ppoly_E(N,2) - ppoly_E(N,1) + ppoly_coef(N,1) = ppoly_E(N,1) + ppoly_coef(N,2) = ppoly_E(N,2) - ppoly_E(N,1) end subroutine P1M_boundary_extrapolation +!> \namespace p1m_functions +!! +!! Date of creation: 2008.06.09 +!! L. White +!! +!! This module contains p1m (linear) interpolation routines. +!! +!! p1m interpolation is performed by estimating the edge values and +!! linearly interpolating between them. +! +!! Once the edge values are estimated, the limiting process takes care of +!! ensuring that (1) edge values are bounded by neighoring cell averages +!! and (2) discontinuous edge values are averaged in order to provide a +!! fully continuous interpolant throughout the domain. This last step is +!! essential for the regridding problem to yield a unique solution. +!! Also, a routine is provided that takes care of linear extrapolation +!! within the boundary cells. + end module P1M_functions diff --git a/src/ALE/P3M_functions.F90 b/src/ALE/P3M_functions.F90 index ecc7136ead..1964cd25dd 100644 --- a/src/ALE/P3M_functions.F90 +++ b/src/ALE/P3M_functions.F90 @@ -1,20 +1,8 @@ +!> Cubic interpolation functions module P3M_functions ! This file is part of MOM6. See LICENSE.md for the license. -!============================================================================== -! -! Date of creation: 2008.06.09 -! L. White -! -! This module contains p3m interpolation routines. -! -! p3m interpolation is performed by estimating the edge values and slopes -! and constructing a cubic polynomial. We then make sure that the edge values -! are bounded and continuous and we then modify the slopes to get a monotonic -! cubic curve. -! -!============================================================================== use regrid_edge_values, only : bound_edge_values, average_discontinuous_edge_values implicit none ; private @@ -22,33 +10,32 @@ module P3M_functions public P3M_interpolation public P3M_boundary_extrapolation -real, parameter :: hNeglect_dflt = 1.E-30 -real, parameter :: hNeglect_edge_dflt = 1.E-10 +real, parameter :: hNeglect_dflt = 1.E-30 !< Default value of a negligible cell thickness +real, parameter :: hNeglect_edge_dflt = 1.E-10 !< Default value of a negligible edge thickness contains -!------------------------------------------------------------------------------ -! p3m interpolation -! ----------------------------------------------------------------------------- -subroutine P3M_interpolation( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, & +!> Set up a piecewise cubic interpolation from cell averages and estimated +!! edge slopes and values +!! +!! Cubic interpolation between edges. +!! +!! The edge values and slopes MUST have been estimated prior to calling +!! this routine. +!! +!! It is assumed that the size of the array 'u' is equal to the number of cells +!! defining 'grid' and 'ppoly'. No consistency check is performed here. +subroutine P3M_interpolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & h_neglect ) -!------------------------------------------------------------------------------ -! Cubic interpolation between edges. -! -! The edge values and slopes MUST have been estimated prior to calling -! this routine. -! -! It is assumed that the size of the array 'u' is equal to the number of cells -! defining 'grid' and 'ppoly'. No consistency check is performed here. -!------------------------------------------------------------------------------ - - ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell widths (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: ppoly_E !Edge value of polynomial - real, dimension(:,:), intent(inout) :: ppoly_S !Edge slope of polynomial - real, dimension(:,:), intent(inout) :: ppoly_coefficients !Coefficients of polynomial + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell averages (size N) + real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial, + !! with the same units as u. + real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial, + !! in the units of u over the units of h. + real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, mainly + !! with the same units as u. real, optional, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions !! in the same units as h. @@ -58,40 +45,35 @@ subroutine P3M_interpolation( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, & ! This routine could be called directly instead of having to call ! 'P3M_interpolation' first but we do that to provide an homogeneous ! interface. - - call P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, h_neglect ) + call P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect ) end subroutine P3M_interpolation - -!------------------------------------------------------------------------------ -! p3m limiter -! ----------------------------------------------------------------------------- -subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, h_neglect ) -!------------------------------------------------------------------------------ -! The p3m limiter operates as follows: -! -! (1) Edge values are bounded -! (2) Discontinuous edge values are systematically averaged -! (3) Loop on cells and do the following -! (a) Build cubic curve -! (b) Check if cubic curve is monotonic -! (c) If not, monotonize cubic curve and rebuild it -! -! Step (3) of the monotonization process leaves all edge values unchanged. -!------------------------------------------------------------------------------ - - ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell widths (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: ppoly_E !Edge value of polynomial - real, dimension(:,:), intent(inout) :: ppoly_S !Edge slope of polynomial - real, dimension(:,:), intent(inout) :: ppoly_coefficients !Coefficients of polynomial +!> Adust a piecewise cubic reconstruction with a limiter that adjusts the edge +!! values and slopes +!! +!! The p3m limiter operates as follows: +!! +!! 1. Edge values are bounded +!! 2. Discontinuous edge values are systematically averaged +!! 3. Loop on cells and do the following +!! a. Build cubic curve +!! b. Check if cubic curve is monotonic +!! c. If not, monotonize cubic curve and rebuild it +!! +!! Step 3 of the monotonization process leaves all edge values unchanged. +subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect ) + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell averages (size N) + real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial, + !! with the same units as u. + real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial, + !! in the units of u over the units of h. + real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial real, optional, intent(in) :: h_neglect !< A negligibly small width for !! the purpose of cell reconstructions !! in the same units as h. - ! Local variables integer :: k ! loop index integer :: monotonic ! boolean indicating whether the cubic is monotonic @@ -133,111 +115,109 @@ subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, h_neglect u_c = u(k) h_c = h(k) - if ( k .EQ. 1 ) then + if ( k == 1 ) then h_l = h(k) u_l = u(k) else h_l = h(k-1) u_l = u(k-1) - end if + endif - if ( k .EQ. N ) then + if ( k == N ) then h_r = h(k) u_r = u(k) else h_r = h(k+1) u_r = u(k+1) - end if + endif ! Compute limited slope sigma_l = 2.0 * ( u_c - u_l ) / ( h_c + hNeglect ) sigma_c = 2.0 * ( u_r - u_l ) / ( h_l + 2.0*h_c + h_r + hNeglect ) sigma_r = 2.0 * ( u_r - u_c ) / ( h_c + hNeglect ) - if ( (sigma_l * sigma_r) .GT. 0.0 ) then + if ( (sigma_l * sigma_r) > 0.0 ) then slope = sign( min(abs(sigma_l),abs(sigma_c),abs(sigma_r)), sigma_c ) else slope = 0.0 - end if + endif ! If the slopes are close to zero in machine precision and in absolute ! value, we set the slope to zero. This prevents asymmetric representation ! near extrema. These expressions are both nondimensional. if ( abs(u1_l*h_c) < eps ) then u1_l = 0.0 - end if + endif if ( abs(u1_r*h_c) < eps ) then u1_r = 0.0 - end if + endif ! The edge slopes are limited from above by the respective ! one-sided slopes - if ( abs(u1_l) .GT. abs(sigma_l) ) then + if ( abs(u1_l) > abs(sigma_l) ) then u1_l = sigma_l - end if + endif - if ( abs(u1_r) .GT. abs(sigma_r) ) then + if ( abs(u1_r) > abs(sigma_r) ) then u1_r = sigma_r - end if + endif ! Build cubic interpolant (compute the coefficients) - call build_cubic_interpolant( h, k, ppoly_E, ppoly_S, ppoly_coefficients ) + call build_cubic_interpolant( h, k, ppoly_E, ppoly_S, ppoly_coef ) ! Check whether cubic is monotonic - monotonic = is_cubic_monotonic( ppoly_coefficients, k ) + monotonic = is_cubic_monotonic( ppoly_coef, k ) ! If cubic is not monotonic, monotonize it by modifiying the ! edge slopes, store the new edge slopes and recompute the ! cubic coefficients - if ( monotonic .EQ. 0 ) then + if ( monotonic == 0 ) then call monotonize_cubic( h_c, u0_l, u0_r, sigma_l, sigma_r, slope, u1_l, u1_r ) - end if + endif ! Store edge slopes ppoly_S(k,1) = u1_l ppoly_S(k,2) = u1_r ! Recompute coefficients of cubic - call build_cubic_interpolant( h, k, ppoly_E, ppoly_S, ppoly_coefficients ) + call build_cubic_interpolant( h, k, ppoly_E, ppoly_S, ppoly_coef ) - end do ! loop on cells + enddo ! loop on cells end subroutine P3M_limiter -!------------------------------------------------------------------------------ -! p3m boundary extrapolation -! ----------------------------------------------------------------------------- -subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, & +!> Calculate the edge values and slopes at boundary cells as part of building a +!! piecewise cubic sub-grid scale profiles +!! +!! The following explanations apply to the left boundary cell. The same +!! reasoning holds for the right boundary cell. +!! +!! A cubic needs to be built in the cell and requires four degrees of freedom, +!! which are the edge values and slopes. The right edge values and slopes are +!! taken to be that of the neighboring cell (i.e., the left edge value and slope +!! of the neighboring cell). The left edge value and slope are determined by +!! computing the parabola based on the cell average and the right edge value +!! and slope. The resulting cubic is not necessarily monotonic and the slopes +!! are subsequently modified to yield a monotonic cubic. +subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & h_neglect, h_neglect_edge ) -!------------------------------------------------------------------------------ -! The following explanations apply to the left boundary cell. The same -! reasoning holds for the right boundary cell. -! -! A cubic needs to be built in the cell and requires four degrees of freedom, -! which are the edge values and slopes. The right edge values and slopes are -! taken to be that of the neighboring cell (i.e., the left edge value and slope -! of the neighboring cell). The left edge value and slope are determined by -! computing the parabola based on the cell average and the right edge value -! and slope. The resulting cubic is not necessarily monotonic and the slopes -! are subsequently modified to yield a monotonic cubic. -!------------------------------------------------------------------------------ - - ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell widths (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: ppoly_E !Edge value of polynomial - real, dimension(:,:), intent(inout) :: ppoly_S !Edge slope of polynomial - real, dimension(:,:), intent(inout) :: ppoly_coefficients !Coefficients of polynomial + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell averages (size N) + real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial, + !! with the same units as u. + real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial, + !! in the units of u over the units of h. + real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, mainly + !! with the same units as u. real, optional, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions !! in the same units as h. real, optional, intent(in) :: h_neglect_edge !< A negligibly small width !! for the purpose of finding edge values !! in the same units as h. - ! Local variables integer :: i0, i1 integer :: monotonic @@ -263,14 +243,14 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coeffici ! Compute the left edge slope in neighboring cell and express it in ! the global coordinate system - b = ppoly_coefficients(i1,2) + b = ppoly_coef(i1,2) u1_r = b / h1 ! derivative evaluated at xi = 0.0, expressed w.r.t. x ! Limit the right slope by the PLM limited slope slope = 2.0 * ( u1 - u0 ) / ( h0 + hNeglect ) - if ( abs(u1_r) .GT. abs(slope) ) then + if ( abs(u1_r) > abs(slope) ) then u1_r = slope - end if + endif ! The right edge value in the boundary cell is taken to be the left ! edge value in the neighboring cell @@ -285,11 +265,11 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coeffici ! Check whether the edge values are monotonic. For example, if the left edge ! value is larger than the right edge value while the slope is positive, the ! edge values are inconsistent and we need to modify the left edge value - if ( (u0_r-u0_l) * slope .LT. 0.0 ) then + if ( (u0_r-u0_l) * slope < 0.0 ) then u0_l = u0_r u1_l = 0.0 u1_r = 0.0 - end if + endif ! Store edge values and slope, build cubic and check monotonicity ppoly_E(i0,1) = u0_l @@ -298,18 +278,18 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coeffici ppoly_S(i0,2) = u1_r ! Store edge values and slope, build cubic and check monotonicity - call build_cubic_interpolant( h, i0, ppoly_E, ppoly_S, ppoly_coefficients ) - monotonic = is_cubic_monotonic( ppoly_coefficients, i0 ) + call build_cubic_interpolant( h, i0, ppoly_E, ppoly_S, ppoly_coef ) + monotonic = is_cubic_monotonic( ppoly_coef, i0 ) - if ( monotonic .EQ. 0 ) then + if ( monotonic == 0 ) then call monotonize_cubic( h0, u0_l, u0_r, 0.0, slope, slope, u1_l, u1_r ) ! Rebuild cubic after monotonization ppoly_S(i0,1) = u1_l ppoly_S(i0,2) = u1_r - call build_cubic_interpolant( h, i0, ppoly_E, ppoly_S, ppoly_coefficients ) + call build_cubic_interpolant( h, i0, ppoly_E, ppoly_S, ppoly_coef ) - end if + endif ! ----- Right boundary ----- i0 = N-1 @@ -321,16 +301,16 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coeffici ! Compute the right edge slope in neighboring cell and express it in ! the global coordinate system - b = ppoly_coefficients(i0,2) - c = ppoly_coefficients(i0,3) - d = ppoly_coefficients(i0,4) + b = ppoly_coef(i0,2) + c = ppoly_coef(i0,3) + d = ppoly_coef(i0,4) u1_l = (b + 2*c + 3*d) / ( h0 + hNeglect ) ! derivative evaluated at xi = 1.0 ! Limit the left slope by the PLM limited slope slope = 2.0 * ( u1 - u0 ) / ( h1 + hNeglect ) - if ( abs(u1_l) .GT. abs(slope) ) then + if ( abs(u1_l) > abs(slope) ) then u1_l = slope - end if + endif ! The left edge value in the boundary cell is taken to be the right ! edge value in the neighboring cell @@ -345,11 +325,11 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coeffici ! Check whether the edge values are monotonic. For example, if the right edge ! value is smaller than the left edge value while the slope is positive, the ! edge values are inconsistent and we need to modify the right edge value - if ( (u0_r-u0_l) * slope .LT. 0.0 ) then + if ( (u0_r-u0_l) * slope < 0.0 ) then u0_r = u0_l u1_l = 0.0 u1_r = 0.0 - end if + endif ! Store edge values and slope, build cubic and check monotonicity ppoly_E(i1,1) = u0_l @@ -357,40 +337,37 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coeffici ppoly_S(i1,1) = u1_l ppoly_S(i1,2) = u1_r - call build_cubic_interpolant( h, i1, ppoly_E, ppoly_S, ppoly_coefficients ) - monotonic = is_cubic_monotonic( ppoly_coefficients, i1 ) + call build_cubic_interpolant( h, i1, ppoly_E, ppoly_S, ppoly_coef ) + monotonic = is_cubic_monotonic( ppoly_coef, i1 ) - if ( monotonic .EQ. 0 ) then + if ( monotonic == 0 ) then call monotonize_cubic( h1, u0_l, u0_r, slope, 0.0, slope, u1_l, u1_r ) ! Rebuild cubic after monotonization ppoly_S(i1,1) = u1_l ppoly_S(i1,2) = u1_r - call build_cubic_interpolant( h, i1, ppoly_E, ppoly_S, ppoly_coefficients ) + call build_cubic_interpolant( h, i1, ppoly_E, ppoly_S, ppoly_coef ) - end if + endif end subroutine P3M_boundary_extrapolation -!------------------------------------------------------------------------------ -! Build cubic interpolant in cell k -! ----------------------------------------------------------------------------- -subroutine build_cubic_interpolant( h, k, ppoly_E, ppoly_S, ppoly_coefficients ) -!------------------------------------------------------------------------------ -! Given edge values and edge slopes, compute coefficients of cubic in cell k. -! -! NOTE: edge values and slopes MUST have been properly calculated prior to -! calling this routine. -!------------------------------------------------------------------------------ - - ! Arguments - real, dimension(:), intent(in) :: h ! cell widths (size N) - integer, intent(in) :: k - real, dimension(:,:), intent(in) :: ppoly_E !Edge value of polynomial - real, dimension(:,:), intent(in) :: ppoly_S !Edge slope of polynomial - real, dimension(:,:), intent(inout) :: ppoly_coefficients !Coefficients of polynomial - +!> Build cubic interpolant in cell k +!! +!! Given edge values and edge slopes, compute coefficients of cubic in cell k. +!! +!! NOTE: edge values and slopes MUST have been properly calculated prior to +!! calling this routine. +subroutine build_cubic_interpolant( h, k, ppoly_E, ppoly_S, ppoly_coef ) + real, dimension(:), intent(in) :: h !< cell widths (size N) + integer, intent(in) :: k !< The index of the cell to work on + real, dimension(:,:), intent(in) :: ppoly_E !< Edge value of polynomial, + !! with the same units as u. + real, dimension(:,:), intent(in) :: ppoly_S !< Edge slope of polynomial, + !! in the units of u over the units of h. + real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, mainly + !! with the same units as u. ! Local variables real :: u0_l, u0_r ! edge values real :: u1_l, u1_r ! edge slopes @@ -410,31 +387,25 @@ subroutine build_cubic_interpolant( h, k, ppoly_E, ppoly_S, ppoly_coefficients ) a2 = 3.0 * ( u0_r - u0_l ) - u1_r - 2.0 * u1_l a3 = u1_r + u1_l + 2.0 * ( u0_l - u0_r ) - ppoly_coefficients(k,1) = a0 - ppoly_coefficients(k,2) = a1 - ppoly_coefficients(k,3) = a2 - ppoly_coefficients(k,4) = a3 + ppoly_coef(k,1) = a0 + ppoly_coef(k,2) = a1 + ppoly_coef(k,3) = a2 + ppoly_coef(k,4) = a3 end subroutine build_cubic_interpolant -!------------------------------------------------------------------------------ -! Check whether cubic is monotonic -! ----------------------------------------------------------------------------- -integer function is_cubic_monotonic( ppoly_coefficients, k ) -!------------------------------------------------------------------------------ -! This function checks whether the cubic curve in cell k is monotonic. -! If so, returns 1. Otherwise, returns 0. -! -! The cubic is monotonic if the first derivative is single-signed in [0,1]. -! Hence, we check whether the roots (if any) lie inside this interval. If there -! is no root or if both roots lie outside this interval, the cubic is monotnic. -!------------------------------------------------------------------------------ - - ! Arguments - real, dimension(:,:), intent(in) :: ppoly_coefficients - integer, intent(in) :: k - +!> Check whether the cubic reconstruction in cell k is monotonic +!! +!! This function checks whether the cubic curve in cell k is monotonic. +!! If so, returns 1. Otherwise, returns 0. +!! +!! The cubic is monotonic if the first derivative is single-signed in [0,1]. +!! Hence, we check whether the roots (if any) lie inside this interval. If there +!! is no root or if both roots lie outside this interval, the cubic is monotonic. +integer function is_cubic_monotonic( ppoly_coef, k ) + real, dimension(:,:), intent(in) :: ppoly_coef !< Coefficients of cubic polynomial + integer, intent(in) :: k !< The index of the cell to work on ! Local variables integer :: monotonic ! boolean indicating if monotonic or not real :: a0, a1, a2, a3 ! cubic coefficients @@ -447,10 +418,10 @@ integer function is_cubic_monotonic( ppoly_coefficients, k ) ! to be equal to 0 or 1, respectively eps = 1e-14 - a0 = ppoly_coefficients(k,1) - a1 = ppoly_coefficients(k,2) - a2 = ppoly_coefficients(k,3) - a3 = ppoly_coefficients(k,4) + a0 = ppoly_coef(k,1) + a1 = ppoly_coef(k,2) + a2 = ppoly_coef(k,3) + a3 = ppoly_coef(k,4) a = a1 b = 2.0 * a2 @@ -461,73 +432,69 @@ integer function is_cubic_monotonic( ppoly_coefficients, k ) rho = b*b - 4.0*a*c - if ( rho .GE. 0.0 ) then - if ( abs(c) .GT. 1e-15 ) then + if ( rho >= 0.0 ) then + if ( abs(c) > 1e-15 ) then xi_0 = 0.5 * ( -b - sqrt( rho ) ) / c xi_1 = 0.5 * ( -b + sqrt( rho ) ) / c - else if ( abs(b) .GT. 1e-15 ) then + elseif ( abs(b) > 1e-15 ) then xi_0 = - a / b xi_1 = - a / b - end if + endif ! If one of the roots of the first derivative lies in (0,1), ! the cubic is not monotonic. - if ( ( (xi_0 .GT. eps) .AND. (xi_0 .LT. 1.0-eps) ) .OR. & - ( (xi_1 .GT. eps) .AND. (xi_1 .LT. 1.0-eps) ) ) then + if ( ( (xi_0 > eps) .AND. (xi_0 < 1.0-eps) ) .OR. & + ( (xi_1 > eps) .AND. (xi_1 < 1.0-eps) ) ) then monotonic = 0 else monotonic = 1 - end if + endif else ! there are no real roots --> cubic is monotonic monotonic = 1 - end if + endif ! Set the return value is_cubic_monotonic = monotonic end function is_cubic_monotonic - -!------------------------------------------------------------------------------ -! Monotonize cubic curve -! ----------------------------------------------------------------------------- -subroutine monotonize_cubic( h, u0_l, u0_r, sigma_l, sigma_r, slope, u1_l, u1_r ) -!------------------------------------------------------------------------------ -! This routine takes care of monotonizing a cubic on [0,1] by modifying the -! edge slopes. The edge values are NOT modified. The cubic is entirely -! determined by the four degrees of freedom u0_l, u0_r, u1_l and u1_r. -! -! u1_l and u1_r are the edge slopes expressed in the GLOBAL coordinate system. -! -! The monotonization occurs as follows. - -! 1. The edge slopes are set to 0 if they are inconsistent with the limited -! PLM slope -! 2. We check whether we can find an inflexion point in [0,1]. At most one -! inflexion point may exist. -! (a) If there is no inflexion point, the cubic is monotonic. -! (b) If there is one inflexion point and it lies outside [0,1], the -! cubic is monotonic. -! (c) If there is one inflexion point and it lies in [0,1] and the slope -! at the location of the inflexion point is consistent, the cubic -! is monotonic. -! (d) If the inflexion point lies in [0,1] but the slope is inconsistent, -! we go to (3) to shift the location of the inflexion point to the left -! or to the right. To the left when the 2nd-order left slope is smaller -! than the 2nd order right slope. -! 3. Edge slopes are modified to shift the inflexion point, either onto the left -! edge or onto the right edge. +!> Monotonize a cubic curve by modifying the edge slopes. +!! +!! This routine takes care of monotonizing a cubic on [0,1] by modifying the +!! edge slopes. The edge values are NOT modified. The cubic is entirely +!! determined by the four degrees of freedom u0_l, u0_r, u1_l and u1_r. +!! +!! u1_l and u1_r are the edge slopes expressed in the GLOBAL coordinate system. +!! +!! The monotonization occurs as follows. ! -!------------------------------------------------------------------------------ - - ! Arguments - real, intent(in) :: h ! cell width - real, intent(in) :: u0_l, u0_r ! edge values - real, intent(in) :: sigma_l, sigma_r ! left and right 2nd-order slopes - real, intent(in) :: slope ! limited PLM slope - real, intent(inout) :: u1_l, u1_r ! edge slopes +!! 1. The edge slopes are set to 0 if they are inconsistent with the limited +!! PLM slope +!! 2. We check whether we can find an inflexion point in [0,1]. At most one +!! inflexion point may exist. +!! a. If there is no inflexion point, the cubic is monotonic. +!! b. If there is one inflexion point and it lies outside [0,1], the +!! cubic is monotonic. +!! c. If there is one inflexion point and it lies in [0,1] and the slope +!! at the location of the inflexion point is consistent, the cubic +!! is monotonic. +!! d. If the inflexion point lies in [0,1] but the slope is inconsistent, +!! we go to (3) to shift the location of the inflexion point to the left +!! or to the right. To the left when the 2nd-order left slope is smaller +!! than the 2nd order right slope. +!! 3. Edge slopes are modified to shift the inflexion point, either onto the left +!! edge or onto the right edge. +subroutine monotonize_cubic( h, u0_l, u0_r, sigma_l, sigma_r, slope, u1_l, u1_r ) + real, intent(in) :: h !< cell width + real, intent(in) :: u0_l !< left edge value + real, intent(in) :: u0_r !< right edge value + real, intent(in) :: sigma_l !< left 2nd-order slopes + real, intent(in) :: sigma_r !< right 2nd-order slopes + real, intent(in) :: slope !< limited PLM slope + real, intent(inout) :: u1_l !< left edge slopes + real, intent(inout) :: u1_r !< right edge slopes ! Local variables integer :: found_ip integer :: inflexion_l ! bool telling if inflex. pt must be on left @@ -547,13 +514,13 @@ subroutine monotonize_cubic( h, u0_l, u0_r, sigma_l, sigma_r, slope, u1_l, u1_r ! If the edge slopes are inconsistent w.r.t. the limited PLM slope, ! set them to zero - if ( u1_l*slope .LE. 0.0 ) then + if ( u1_l*slope <= 0.0 ) then u1_l = 0.0 - end if + endif - if ( u1_r*slope .LE. 0.0 ) then + if ( u1_r*slope <= 0.0 ) then u1_r = 0.0 - end if + endif ! Compute the location of the inflexion point, which is the root ! of the second derivative @@ -564,55 +531,55 @@ subroutine monotonize_cubic( h, u0_l, u0_r, sigma_l, sigma_r, slope, u1_l, u1_r ! There is a possible root (and inflexion point) only if a3 is nonzero. ! When a3 is zero, the second derivative of the cubic is constant (the ! cubic degenerates into a parabola) and no inflexion point exists. - if ( a3 .NE. 0.0 ) then + if ( a3 /= 0.0 ) then ! Location of inflexion point xi_ip = - a2 / (3.0 * a3) ! If the inflexion point lies in [0,1], change boolean value - if ( (xi_ip .GE. 0.0) .AND. (xi_ip .LE. 1.0) ) then + if ( (xi_ip >= 0.0) .AND. (xi_ip <= 1.0) ) then found_ip = 1 - end if - end if + endif + endif ! When there is an inflexion point within [0,1], check the slope ! to see if it is consistent with the limited PLM slope. If not, ! decide on which side we want to collapse the inflexion point. ! If the inflexion point lies on one of the edges, the cubic is ! guaranteed to be monotonic - if ( found_ip .EQ. 1 ) then + if ( found_ip == 1 ) then slope_ip = a1 + 2.0*a2*xi_ip + 3.0*a3*xi_ip*xi_ip ! Check whether slope is consistent - if ( slope_ip*slope .LT. 0.0 ) then - if ( abs(sigma_l) .LT. abs(sigma_r) ) then + if ( slope_ip*slope < 0.0 ) then + if ( abs(sigma_l) < abs(sigma_r) ) then inflexion_l = 1 else inflexion_r = 1 - end if - end if - end if ! found_ip + endif + endif + endif ! found_ip ! At this point, if the cubic is not monotonic, we know where the ! inflexion point should lie. When the cubic is monotonic, both ! 'inflexion_l' and 'inflexion_r' are set to 0 and nothing is to be done. ! Move inflexion point on the left - if ( inflexion_l .EQ. 1 ) then + if ( inflexion_l == 1 ) then u1_l_tmp = 1.5*(u0_r-u0_l)/h - 0.5*u1_r u1_r_tmp = 3.0*(u0_r-u0_l)/h - 2.0*u1_l - if ( (u1_l_tmp*slope .LT. 0.0) .AND. (u1_r_tmp*slope .LT. 0.0) ) then + if ( (u1_l_tmp*slope < 0.0) .AND. (u1_r_tmp*slope < 0.0) ) then u1_l = 0.0 u1_r = 3.0 * (u0_r - u0_l) / h - else if (u1_l_tmp*slope .LT. 0.0) then + elseif (u1_l_tmp*slope < 0.0) then u1_r = u1_r_tmp u1_l = 1.5*(u0_r - u0_l)/h - 0.5*u1_r - else if (u1_r_tmp*slope .LT. 0.0) then + elseif (u1_r_tmp*slope < 0.0) then u1_l = u1_l_tmp u1_r = 3.0*(u0_r - u0_l)/h - 2.0*u1_l @@ -622,27 +589,27 @@ subroutine monotonize_cubic( h, u0_l, u0_r, sigma_l, sigma_r, slope, u1_l, u1_r u1_l = u1_l_tmp u1_r = u1_r_tmp - end if + endif - end if ! end treating case with inflexion point on the left + endif ! end treating case with inflexion point on the left ! Move inflexion point on the right - if ( inflexion_r .EQ. 1 ) then + if ( inflexion_r == 1 ) then u1_l_tmp = 3.0*(u0_r-u0_l)/h - 2.0*u1_r u1_r_tmp = 1.5*(u0_r-u0_l)/h - 0.5*u1_l - if ( (u1_l_tmp*slope .LT. 0.0) .AND. (u1_r_tmp*slope .LT. 0.0) ) then + if ( (u1_l_tmp*slope < 0.0) .AND. (u1_r_tmp*slope < 0.0) ) then u1_l = 3.0 * (u0_r - u0_l) / h u1_r = 0.0 - else if (u1_l_tmp*slope .LT. 0.0) then + elseif (u1_l_tmp*slope < 0.0) then u1_r = u1_r_tmp u1_l = 3.0*(u0_r - u0_l)/h - 2.0*u1_r - else if (u1_r_tmp*slope .LT. 0.0) then + elseif (u1_r_tmp*slope < 0.0) then u1_l = u1_l_tmp u1_r = 1.5*(u0_r - u0_l)/h - 0.5*u1_l @@ -652,18 +619,30 @@ subroutine monotonize_cubic( h, u0_l, u0_r, sigma_l, sigma_r, slope, u1_l, u1_r u1_l = u1_l_tmp u1_r = u1_r_tmp - end if + endif - end if ! end treating case with inflexion point on the right + endif ! end treating case with inflexion point on the right - if ( abs(u1_l*h) .LT. eps ) then + if ( abs(u1_l*h) < eps ) then u1_l = 0.0 - end if + endif - if ( abs(u1_r*h) .LT. eps ) then + if ( abs(u1_r*h) < eps ) then u1_r = 0.0 - end if + endif end subroutine monotonize_cubic +!> \namespace p3m_functions +!! +!! Date of creation: 2008.06.09 +!! L. White +!! +!! This module contains p3m interpolation routines. +!! +!! p3m interpolation is performed by estimating the edge values and slopes +!! and constructing a cubic polynomial. We then make sure that the edge values +!! are bounded and continuous and we then modify the slopes to get a monotonic +!! cubic curve. + end module P3M_functions diff --git a/src/ALE/PCM_functions.F90 b/src/ALE/PCM_functions.F90 index b09f6e080e..135f53a8a1 100644 --- a/src/ALE/PCM_functions.F90 +++ b/src/ALE/PCM_functions.F90 @@ -1,60 +1,48 @@ +!> Piecewise constant reconstruction functions module PCM_functions ! This file is part of MOM6. See LICENSE.md for the license. -!============================================================================== -! -! Date of creation: 2008.06.06 -! L. White -! -! This module contains routines that handle one-dimensionnal finite volume -! reconstruction using the piecewise constant method (PCM). -! -!============================================================================== - implicit none ; private public PCM_reconstruction contains -!------------------------------------------------------------------------------ -! pcm_reconstruction -!------------------------------------------------------------------------------ -subroutine PCM_reconstruction( N, u, ppoly_E, ppoly_coefficients ) -!------------------------------------------------------------------------------ -! Reconstruction by constant polynomials within each cell. There is nothing to -! do but this routine is provided to ensure a homogeneous interface -! throughout the regridding toolbox. -! -! N: number of cells in grid -! h: thicknesses of grid cells -! u: cell averages to use in constructing piecewise polynomials -! ppoly_E : edge values of piecewise polynomials -! ppoly_coefficients : coefficients of piecewise polynomials -! -! It is assumed that the dimension of 'u' is equal to the number of cells -! defining 'grid' and 'ppoly'. No consistency check is performed. -!------------------------------------------------------------------------------ - - ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: u ! cell averages - real, dimension(:,:), intent(inout) :: ppoly_E !Edge value of polynomial - real, dimension(:,:), intent(inout) :: ppoly_coefficients !Coefficients of polynomial +!> Reconstruction by constant polynomials within each cell. There is nothing to +!! do but this routine is provided to ensure a homogeneous interface +!! throughout the regridding toolbox. +!! +!! It is assumed that the dimension of 'u' is equal to the number of cells +!! defining 'grid' and 'ppoly'. No consistency check is performed. +subroutine PCM_reconstruction( N, u, ppoly_E, ppoly_coef ) + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: u !< cell averages + real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial, + !! with the same units as u. + real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, + !! with the same units as u. ! Local variables integer :: k ! The coefficients of the piecewise constant polynomial are simply ! the cell averages. - ppoly_coefficients(:,1) = u(:) + ppoly_coef(:,1) = u(:) ! The edge values are equal to the cell average do k = 1,N ppoly_E(k,:) = u(k) - end do + enddo end subroutine PCM_reconstruction +!> \namespace PCM_functions +!! +!! Date of creation: 2008.06.06 +!! L. White +!! +!! This module contains routines that handle one-dimensionnal finite volume +!! reconstruction using the piecewise constant method (PCM). + end module PCM_functions diff --git a/src/ALE/PLM_functions.F90 b/src/ALE/PLM_functions.F90 index 83eea1518b..ed82ad1e0b 100644 --- a/src/ALE/PLM_functions.F90 +++ b/src/ALE/PLM_functions.F90 @@ -1,51 +1,31 @@ +!> Piecewise linear reconstruction functions module PLM_functions ! This file is part of MOM6. See LICENSE.md for the license. -!============================================================================== -! -! Date of creation: 2008.06.06 -! L. White -! -! This module contains routines that handle one-dimensionnal finite volume -! reconstruction using the piecewise linear method (PLM). -! -!============================================================================== - implicit none ; private public PLM_reconstruction, PLM_boundary_extrapolation -real, parameter :: hNeglect_dflt = 1.E-30 +real, parameter :: hNeglect_dflt = 1.E-30 !< Default negligible cell thickness contains -!------------------------------------------------------------------------------ -! PLM_reconstruction -! ----------------------------------------------------------------------------- -subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coefficients, h_neglect ) -!------------------------------------------------------------------------------ -! Reconstruction by linear polynomials within each cell. -! -! N: number of cells in grid -! h: thicknesses of grid cells -! u: cell averages to use in constructing piecewise polynomials -! ppoly_E : edge values of piecewise polynomials -! ppoly_coefficients : coefficients of piecewise polynomials -! -! It is assumed that the size of the array 'u' is equal to the number of cells -! defining 'grid' and 'ppoly'. No consistency check is performed here. -!------------------------------------------------------------------------------ - - ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell widths (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: ppoly_E - real, dimension(:,:), intent(inout) :: ppoly_coefficients +!> Reconstruction by linear polynomials within each cell +!! +!! It is assumed that the size of the array 'u' is equal to the number of cells +!! defining 'grid' and 'ppoly'. No consistency check is performed here. +subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coef, h_neglect ) + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell averages (size N) + real, dimension(:,:), intent(inout) :: ppoly_E !< edge values of piecewise polynomials, + !! with the same units as u. + real, dimension(:,:), intent(inout) :: ppoly_coef !< coefficients of piecewise polynomials, mainly + !! with the same units as u. real, optional, intent(in) :: h_neglect !< A negligibly small width for - !! the purpose of cell reconstructions - !! in the same units as h + !! the purpose of cell reconstructions + !! in the same units as h ! Local variables integer :: k ! loop index @@ -101,7 +81,7 @@ subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coefficients, h_neglect ) ! Extrema in the mean values require a PCM reconstruction avoid generating ! larger extreme values. slope = 0.0 - end if + endif ! This block tests to see if roundoff causes edge values to be out of bounds u_min = min( u_l, u_c, u_r ) @@ -129,7 +109,7 @@ subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coefficients, h_neglect ) ppoly_E(k,1) = u_c - 0.5 * slope ppoly_E(k,2) = u_c + 0.5 * slope - end do ! end loop on interior cells + enddo ! end loop on interior cells ! Boundary cells use PCM. Extrapolation is handled in a later routine. slp(1) = 0. @@ -171,8 +151,8 @@ subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coefficients, h_neglect ) ! Store and return edge values and polynomial coefficients. ppoly_E(1,1) = u(1) ppoly_E(1,2) = u(1) - ppoly_coefficients(1,1) = u(1) - ppoly_coefficients(1,2) = 0. + ppoly_coef(1,1) = u(1) + ppoly_coef(1,2) = 0. do k = 2, N-1 slope = sign( mslp(k), slp(k) ) u_l = u(k) - 0.5 * slope ! Left edge value of cell k @@ -194,54 +174,45 @@ subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coefficients, h_neglect ) ppoly_E(k,1) = u_l ppoly_E(k,2) = u_r - ppoly_coefficients(k,1) = u_l - ppoly_coefficients(k,2) = ( u_r - u_l ) + ppoly_coef(k,1) = u_l + ppoly_coef(k,2) = ( u_r - u_l ) ! Check to see if this evaluation of the polynomial at x=1 would be ! monotonic w.r.t. the next cell's edge value. If not, scale back! - edge = ppoly_coefficients(k,2) + ppoly_coefficients(k,1) + edge = ppoly_coef(k,2) + ppoly_coef(k,1) e_r = u(k+1) - 0.5 * sign( mslp(k+1), slp(k+1) ) if ( (edge-u(k))*(e_r-edge)<0.) then - ppoly_coefficients(k,2) = ppoly_coefficients(k,2) * almost_one + ppoly_coef(k,2) = ppoly_coef(k,2) * almost_one endif enddo ppoly_E(N,1) = u(N) ppoly_E(N,2) = u(N) - ppoly_coefficients(N,1) = u(N) - ppoly_coefficients(N,2) = 0. + ppoly_coef(N,1) = u(N) + ppoly_coef(N,2) = 0. end subroutine PLM_reconstruction -!------------------------------------------------------------------------------ -! plm boundary extrapolation -! ----------------------------------------------------------------------------- -subroutine PLM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients, h_neglect ) -!------------------------------------------------------------------------------ -! Reconstruction by linear polynomials within boundary cells. -! The left and right edge values in the left and right boundary cells, -! respectively, are estimated using a linear extrapolation within the cells. -! -! This extrapolation is EXACT when the underlying profile is linear. -! -! N: number of cells in grid -! h: thicknesses of grid cells -! u: cell averages to use in constructing piecewise polynomials -! ppoly_E : edge values of piecewise polynomials -! ppoly_coefficients : coefficients of piecewise polynomials -! -! It is assumed that the size of the array 'u' is equal to the number of cells -! defining 'grid' and 'ppoly'. No consistency check is performed here. -!------------------------------------------------------------------------------ - - ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell widths (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: ppoly_E - real, dimension(:,:), intent(inout) :: ppoly_coefficients +!> Reconstruction by linear polynomials within boundary cells +!! +!! The left and right edge values in the left and right boundary cells, +!! respectively, are estimated using a linear extrapolation within the cells. +!! +!! This extrapolation is EXACT when the underlying profile is linear. +!! +!! It is assumed that the size of the array 'u' is equal to the number of cells +!! defining 'grid' and 'ppoly'. No consistency check is performed here. + +subroutine PLM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef, h_neglect ) + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell averages (size N) + real, dimension(:,:), intent(inout) :: ppoly_E !< edge values of piecewise polynomials, + !! with the same units as u. + real, dimension(:,:), intent(inout) :: ppoly_coef !< coefficients of piecewise polynomials, mainly + !! with the same units as u. real, optional, intent(in) :: h_neglect !< A negligibly small width for - !! the purpose of cell reconstructions - !! in the same units as h + !! the purpose of cell reconstructions + !! in the same units as h ! Local variables real :: u0, u1 ! cell averages @@ -270,8 +241,8 @@ subroutine PLM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients, h_n ppoly_E(1,1) = u0 - 0.5 * slope ppoly_E(1,2) = u0 + 0.5 * slope - ppoly_coefficients(1,1) = ppoly_E(1,1) - ppoly_coefficients(1,2) = ppoly_E(1,2) - ppoly_E(1,1) + ppoly_coef(1,1) = ppoly_E(1,1) + ppoly_coef(1,2) = ppoly_E(1,2) - ppoly_E(1,1) ! ------------------------------------------ ! Right edge value in the left boundary cell @@ -292,9 +263,17 @@ subroutine PLM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients, h_n ppoly_E(N,1) = u1 - 0.5 * slope ppoly_E(N,2) = u1 + 0.5 * slope - ppoly_coefficients(N,1) = ppoly_E(N,1) - ppoly_coefficients(N,2) = ppoly_E(N,2) - ppoly_E(N,1) + ppoly_coef(N,1) = ppoly_E(N,1) + ppoly_coef(N,2) = ppoly_E(N,2) - ppoly_E(N,1) end subroutine PLM_boundary_extrapolation +!> \namespace plm_functions +!! +!! Date of creation: 2008.06.06 +!! L. White +!! +!! This module contains routines that handle one-dimensionnal finite volume +!! reconstruction using the piecewise linear method (PLM). + end module PLM_functions diff --git a/src/ALE/PPM_functions.F90 b/src/ALE/PPM_functions.F90 index 4dd6699722..11dabad684 100644 --- a/src/ALE/PPM_functions.F90 +++ b/src/ALE/PPM_functions.F90 @@ -25,12 +25,14 @@ module PPM_functions contains !> Builds quadratic polynomials coefficients from cell mean and edge values. -subroutine PPM_reconstruction( N, h, u, ppoly_E, ppoly_coefficients, h_neglect) +subroutine PPM_reconstruction( N, h, u, ppoly_E, ppoly_coef, h_neglect) integer, intent(in) :: N !< Number of cells real, dimension(N), intent(in) :: h !< Cell widths real, dimension(N), intent(in) :: u !< Cell averages - real, dimension(N,2), intent(inout) :: ppoly_E !< Edge values - real, dimension(N,3), intent(inout) :: ppoly_coefficients !< Polynomial coefficients + real, dimension(N,2), intent(inout) :: ppoly_E !< Edge values, + !! with the same units as u. + real, dimension(N,3), intent(inout) :: ppoly_coef !< Polynomial coefficients, mainly + !! with the same units as u. real, optional, intent(in) :: h_neglect !< A negligibly small width !! in the same units as h. ! Local variables @@ -47,9 +49,9 @@ subroutine PPM_reconstruction( N, h, u, ppoly_E, ppoly_coefficients, h_neglect) edge_r = ppoly_E(k,2) ! Store polynomial coefficients - ppoly_coefficients(k,1) = edge_l - ppoly_coefficients(k,2) = 4.0 * ( u(k) - edge_l ) + 2.0 * ( u(k) - edge_r ) - ppoly_coefficients(k,3) = 3.0 * ( ( edge_r - u(k) ) + ( edge_l - u(k) ) ) + ppoly_coef(k,1) = edge_l + ppoly_coef(k,2) = 4.0 * ( u(k) - edge_l ) + 2.0 * ( u(k) - edge_r ) + ppoly_coef(k,3) = 3.0 * ( ( edge_r - u(k) ) + ( edge_l - u(k) ) ) enddo @@ -127,9 +129,8 @@ end subroutine PPM_limiter_standard !------------------------------------------------------------------------------ -! ppm boundary extrapolation -! ----------------------------------------------------------------------------- -subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients, h_neglect) +!> Reconstruction by parabolas within boundary cells +subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef, h_neglect) !------------------------------------------------------------------------------ ! Reconstruction by parabolas within boundary cells. ! @@ -148,21 +149,23 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients, h_n ! h: thicknesses of grid cells ! u: cell averages to use in constructing piecewise polynomials ! ppoly_E : edge values of piecewise polynomials -! ppoly_coefficients : coefficients of piecewise polynomials +! ppoly_coef : coefficients of piecewise polynomials ! ! It is assumed that the size of the array 'u' is equal to the number of cells ! defining 'grid' and 'ppoly'. No consistency check is performed here. !------------------------------------------------------------------------------ ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell widths (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: ppoly_E - real, dimension(:,:), intent(inout) :: ppoly_coefficients - real, optional, intent(in) :: h_neglect !< A negligibly small width for - !! the purpose of cell reconstructions - !! in the same units as h. + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell averages (size N) + real, dimension(:,:), intent(inout) :: ppoly_E !< edge values of piecewise polynomials, + !! with the same units as u. + real, dimension(:,:), intent(inout) :: ppoly_coef !< coefficients of piecewise polynomials, mainly + !! with the same units as u. + real, optional, intent(in) :: h_neglect !< A negligibly small width for + !! the purpose of cell reconstructions + !! in the same units as h. ! Local variables integer :: i0, i1 @@ -187,15 +190,15 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients, h_n ! Compute the left edge slope in neighboring cell and express it in ! the global coordinate system - b = ppoly_coefficients(i1,2) + b = ppoly_coef(i1,2) u1_r = b *((h0+hNeglect)/(h1+hNeglect)) ! derivative evaluated at xi = 0.0, ! expressed w.r.t. xi (local coord. system) ! Limit the right slope by the PLM limited slope slope = 2.0 * ( u1 - u0 ) - if ( abs(u1_r) .GT. abs(slope) ) then + if ( abs(u1_r) > abs(slope) ) then u1_r = slope - end if + endif ! The right edge value in the boundary cell is taken to be the left ! edge value in the neighboring cell @@ -210,13 +213,13 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients, h_n exp1 = (u0_r - u0_l) * (u0 - 0.5*(u0_l+u0_r)) exp2 = (u0_r - u0_l) * (u0_r - u0_l) / 6.0 - if ( exp1 .GT. exp2 ) then + if ( exp1 > exp2 ) then u0_l = 3.0 * u0 - 2.0 * u0_r - end if + endif - if ( exp1 .LT. -exp2 ) then + if ( exp1 < -exp2 ) then u0_r = 3.0 * u0 - 2.0 * u0_l - end if + endif ppoly_E(i0,1) = u0_l ppoly_E(i0,2) = u0_r @@ -225,9 +228,9 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients, h_n b = 6.0 * u0 - 4.0 * u0_l - 2.0 * u0_r c = 3.0 * ( u0_r + u0_l - 2.0 * u0 ) - ppoly_coefficients(i0,1) = a - ppoly_coefficients(i0,2) = b - ppoly_coefficients(i0,3) = c + ppoly_coef(i0,1) = a + ppoly_coef(i0,2) = b + ppoly_coef(i0,3) = c ! ----- Right boundary ----- i0 = N-1 @@ -239,16 +242,16 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients, h_n ! Compute the right edge slope in neighboring cell and express it in ! the global coordinate system - b = ppoly_coefficients(i0,2) - c = ppoly_coefficients(i0,3) + b = ppoly_coef(i0,2) + c = ppoly_coef(i0,3) u1_l = (b + 2*c) ! derivative evaluated at xi = 1.0 u1_l = u1_l * ((h1+hNeglect)/(h0+hNeglect)) ! Limit the left slope by the PLM limited slope slope = 2.0 * ( u1 - u0 ) - if ( abs(u1_l) .GT. abs(slope) ) then + if ( abs(u1_l) > abs(slope) ) then u1_l = slope - end if + endif ! The left edge value in the boundary cell is taken to be the right ! edge value in the neighboring cell @@ -263,13 +266,13 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients, h_n exp1 = (u0_r - u0_l) * (u1 - 0.5*(u0_l+u0_r)) exp2 = (u0_r - u0_l) * (u0_r - u0_l) / 6.0 - if ( exp1 .GT. exp2 ) then + if ( exp1 > exp2 ) then u0_l = 3.0 * u1 - 2.0 * u0_r - end if + endif - if ( exp1 .LT. -exp2 ) then + if ( exp1 < -exp2 ) then u0_r = 3.0 * u1 - 2.0 * u0_l - end if + endif ppoly_E(i1,1) = u0_l ppoly_E(i1,2) = u0_r @@ -278,9 +281,9 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients, h_n b = 6.0 * u1 - 4.0 * u0_l - 2.0 * u0_r c = 3.0 * ( u0_r + u0_l - 2.0 * u1 ) - ppoly_coefficients(i1,1) = a - ppoly_coefficients(i1,2) = b - ppoly_coefficients(i1,3) = c + ppoly_coef(i1,1) = a + ppoly_coef(i1,2) = b + ppoly_coef(i1,3) = c end subroutine PPM_boundary_extrapolation diff --git a/src/ALE/PQM_functions.F90 b/src/ALE/PQM_functions.F90 index 707cd9f40f..4fed4a0c86 100644 --- a/src/ALE/PQM_functions.F90 +++ b/src/ALE/PQM_functions.F90 @@ -1,51 +1,35 @@ +!> Piecewise quartic reconstruction functions module PQM_functions ! This file is part of MOM6. See LICENSE.md for the license. -!============================================================================== -! -! Date of creation: 2008.06.06 -! L. White -! -! This module contains routines that handle one-dimensionnal finite volume -! reconstruction using the piecewise quartic method (PQM). -! -!============================================================================== use regrid_edge_values, only : bound_edge_values, check_discontinuous_edge_values implicit none ; private public PQM_reconstruction, PQM_boundary_extrapolation, PQM_boundary_extrapolation_v1 -real, parameter :: hNeglect_dflt = 1.E-30 +real, parameter :: hNeglect_dflt = 1.E-30 !< Default negligible cell thickness contains -!------------------------------------------------------------------------------ -! PQM_reconstruction -! ----------------------------------------------------------------------------- -subroutine PQM_reconstruction( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, h_neglect ) -!------------------------------------------------------------------------------ -! Reconstruction by quartic polynomials within each cell. -! -! grid: one-dimensional grid (see grid.F90) -! ppoly: piecewise quartic polynomial to be reconstructed (see ppoly.F90) -! u: cell averages -! -! It is assumed that the dimension of 'u' is equal to the number of cells -! defining 'grid' and 'ppoly'. No consistency check is performed. -!------------------------------------------------------------------------------ - - ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell widths (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: ppoly_E !Edge value of polynomial - real, dimension(:,:), intent(inout) :: ppoly_S !Edge slope of polynomial - real, dimension(:,:), intent(inout) :: ppoly_coefficients !Coefficients of polynomial - real, optional, intent(in) :: h_neglect !< A negligibly small width for - !! the purpose of cell reconstructions - !! in the same units as h +!> Reconstruction by quartic polynomials within each cell. +!! +!! It is assumed that the dimension of 'u' is equal to the number of cells +!! defining 'grid' and 'ppoly'. No consistency check is performed. +subroutine PQM_reconstruction( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect ) + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell averages (size N) + real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial, + !! with the same units as u. + real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial, + !! in the units of u over the units of h. + real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, mainly + !! with the same units as u. + real, optional, intent(in) :: h_neglect !< A negligibly small width for + !! the purpose of cell reconstructions + !! in the same units as h ! Local variables integer :: k ! loop index @@ -75,33 +59,23 @@ subroutine PQM_reconstruction( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, h_ e = 30.0 * u(k) + 2.5*h_c*(u1_r - u1_l) - 15.0*(u0_l + u0_r) ! Store coefficients - ppoly_coefficients(k,1) = a - ppoly_coefficients(k,2) = b - ppoly_coefficients(k,3) = c - ppoly_coefficients(k,4) = d - ppoly_coefficients(k,5) = e + ppoly_coef(k,1) = a + ppoly_coef(k,2) = b + ppoly_coef(k,3) = c + ppoly_coef(k,4) = d + ppoly_coef(k,5) = e - end do ! end loop on cells + enddo ! end loop on cells end subroutine PQM_reconstruction - -!------------------------------------------------------------------------------ -! Limit pqm -! ----------------------------------------------------------------------------- +!> Limit the piecewise quartic method reconstruction +!! +!! Standard PQM limiter (White & Adcroft, JCP 2008). +!! +!! It is assumed that the dimension of 'u' is equal to the number of cells +!! defining 'grid' and 'ppoly'. No consistency check is performed. subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect ) -!------------------------------------------------------------------------------ -! Standard PQM limiter (White & Adcroft, JCP 2008). -! -! grid: one-dimensional grid (see grid.F90) -! ppoly: piecewise quadratic polynomial to be reconstructed (see ppoly.F90) -! u: cell averages -! -! It is assumed that the dimension of 'u' is equal to the number of cells -! defining 'grid' and 'ppoly'. No consistency check is performed. -!------------------------------------------------------------------------------ - - ! Arguments integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) real, dimension(:), intent(in) :: u !< cell average properties (size N) @@ -112,7 +86,6 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect ) real, optional, intent(in) :: h_neglect !< A negligibly small width for !! the purpose of cell reconstructions !! in the same units as h - ! Local variables integer :: k ! loop index integer :: inflexion_l @@ -141,7 +114,7 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect ) ! Loop on interior cells to apply the PQM limiter do k = 2,N-1 - !if ( h(k) .lt. 1.0 ) cycle + !if ( h(k) < 1.0 ) cycle inflexion_l = 0 inflexion_r = 0 @@ -166,32 +139,32 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect ) sigma_c = 2.0 * ( u_r - u_l ) / ( h_l + 2.0*h_c + h_r + hNeglect ) sigma_r = 2.0 * ( u_r - u_c ) / ( h_c + hNeglect ) - if ( (sigma_l * sigma_r) .GT. 0.0 ) then + if ( (sigma_l * sigma_r) > 0.0 ) then slope = sign( min(abs(sigma_l),abs(sigma_c),abs(sigma_r)), sigma_c ) else slope = 0.0 - end if + endif ! If one of the slopes has the wrong sign compared with the ! limited PLM slope, it is set equal to the limited PLM slope - if ( u1_l*slope .le. 0.0 ) u1_l = slope - if ( u1_r*slope .le. 0.0 ) u1_r = slope + if ( u1_l*slope <= 0.0 ) u1_l = slope + if ( u1_r*slope <= 0.0 ) u1_r = slope ! Local extremum --> flatten - if ( (u0_r - u_c) * (u_c - u0_l) .le. 0.0) then + if ( (u0_r - u_c) * (u_c - u0_l) <= 0.0) then u0_l = u_c u0_r = u_c u1_l = 0.0 u1_r = 0.0 inflexion_l = -1 inflexion_r = -1 - end if + endif ! Edge values are bounded and averaged when discontinuous and not ! monotonic, edge slopes are consistent and the cell is not an extremum. ! We now need to check and encorce the monotonicity of the quartic within ! the cell - if ( (inflexion_l .EQ. 0) .AND. (inflexion_r .EQ. 0) ) then + if ( (inflexion_l == 0) .AND. (inflexion_r == 0) ) then a = u0_l b = h_c * u1_l @@ -208,7 +181,7 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect ) rho = alpha2 * alpha2 - 4.0 * alpha1 * alpha3 ! Check whether inflexion points exist - if (( alpha1 .ne. 0.0 ) .and. ( rho .ge. 0.0 )) then + if (( alpha1 /= 0.0 ) .and. ( rho >= 0.0 )) then sqrt_rho = sqrt( rho ) @@ -216,89 +189,89 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect ) x2 = 0.5 * ( - alpha2 + sqrt_rho ) / alpha1 ! Check whether both inflexion points lie in [0,1] - if ( (x1 .GE. 0.0) .AND. (x1 .LE. 1.0) .AND. & - (x2 .GE. 0.0) .AND. (x2 .LE. 1.0) ) then + if ( (x1 >= 0.0) .AND. (x1 <= 1.0) .AND. & + (x2 >= 0.0) .AND. (x2 <= 1.0) ) then gradient1 = 4.0 * e * (x1**3) + 3.0 * d * (x1**2) + 2.0 * c * x1 + b gradient2 = 4.0 * e * (x2**3) + 3.0 * d * (x2**2) + 2.0 * c * x2 + b ! Check whether one of the gradients is inconsistent - if ( (gradient1 * slope .LT. 0.0) .OR. & - (gradient2 * slope .LT. 0.0) ) then + if ( (gradient1 * slope < 0.0) .OR. & + (gradient2 * slope < 0.0) ) then ! Decide where to collapse inflexion points ! (depends on one-sided slopes) - if ( abs(sigma_l) .LT. abs(sigma_r) ) then + if ( abs(sigma_l) < abs(sigma_r) ) then inflexion_l = 1 else inflexion_r = 1 - end if - end if + endif + endif ! If both x1 and x2 do not lie in [0,1], check whether ! only x1 lies in [0,1] - else if ( (x1 .GE. 0.0) .AND. (x1 .LE. 1.0) ) then + elseif ( (x1 >= 0.0) .AND. (x1 <= 1.0) ) then gradient1 = 4.0 * e * (x1**3) + 3.0 * d * (x1**2) + 2.0 * c * x1 + b ! Check whether the gradient is inconsistent - if ( gradient1 * slope .LT. 0.0 ) then + if ( gradient1 * slope < 0.0 ) then ! Decide where to collapse inflexion points ! (depends on one-sided slopes) - if ( abs(sigma_l) .LT. abs(sigma_r) ) then + if ( abs(sigma_l) < abs(sigma_r) ) then inflexion_l = 1 else inflexion_r = 1 - end if - end if + endif + endif ! If x1 does not lie in [0,1], check whether x2 lies in [0,1] - else if ( (x2 .GE. 0.0) .AND. (x2 .LE. 1.0) ) then + elseif ( (x2 >= 0.0) .AND. (x2 <= 1.0) ) then gradient2 = 4.0 * e * (x2**3) + 3.0 * d * (x2**2) + 2.0 * c * x2 + b ! Check whether the gradient is inconsistent - if ( gradient2 * slope .LT. 0.0 ) then + if ( gradient2 * slope < 0.0 ) then ! Decide where to collapse inflexion points ! (depends on one-sided slopes) - if ( abs(sigma_l) .LT. abs(sigma_r) ) then + if ( abs(sigma_l) < abs(sigma_r) ) then inflexion_l = 1 else inflexion_r = 1 - end if - end if + endif + endif - end if ! end checking where the inflexion points lie + endif ! end checking where the inflexion points lie - end if ! end checking if alpha1 != 0 AND rho >= 0 + endif ! end checking if alpha1 != 0 AND rho >= 0 ! If alpha1 is zero, the second derivative of the quartic reduces ! to a straight line - if (( alpha1 .eq. 0.0 ) .and. ( alpha2 .ne. 0.0 )) then + if (( alpha1 == 0.0 ) .and. ( alpha2 /= 0.0 )) then x1 = - alpha3 / alpha2 - if ( (x1 .ge. 0.0) .AND. (x1 .le. 1.0) ) then + if ( (x1 >= 0.0) .AND. (x1 <= 1.0) ) then gradient1 = 4.0 * e * (x1**3) + 3.0 * d * (x1**2) + 2.0 * c * x1 + b ! Check whether the gradient is inconsistent - if ( gradient1 * slope .LT. 0.0 ) then + if ( gradient1 * slope < 0.0 ) then ! Decide where to collapse inflexion points ! (depends on one-sided slopes) - if ( abs(sigma_l) .LT. abs(sigma_r) ) then + if ( abs(sigma_l) < abs(sigma_r) ) then inflexion_l = 1 else inflexion_r = 1 - end if - end if ! check slope consistency + endif + endif ! check slope consistency - end if + endif - end if ! end check whether we can find the root of the straight line + endif ! end check whether we can find the root of the straight line - end if ! end checking whether to shift inflexion points + endif ! end checking whether to shift inflexion points ! At this point, we know onto which edge to shift inflexion points - if ( inflexion_l .EQ. 1 ) then + if ( inflexion_l == 1 ) then ! We modify the edge slopes so that both inflexion points ! collapse onto the left edge @@ -309,21 +282,21 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect ) ! the inconsistent slope is set equal to zero and the opposite edge value ! and edge slope are modified in compliance with the fact that both ! inflexion points must still be located on the left edge - if ( u1_l * slope .LT. 0.0 ) then + if ( u1_l * slope < 0.0 ) then u1_l = 0.0 u0_r = 5.0 * u_c - 4.0 * u0_l u1_r = 20.0 * (u_c - u0_l) / ( h_c + hNeglect ) - else if ( u1_r * slope .LT. 0.0 ) then + elseif ( u1_r * slope < 0.0 ) then u1_r = 0.0 u0_l = (5.0*u_c - 3.0*u0_r) / 2.0 u1_l = 10.0 * (-u_c + u0_r) / (3.0 * h_c + hNeglect) - end if + endif - else if ( inflexion_r .EQ. 1 ) then + elseif ( inflexion_r == 1 ) then ! We modify the edge slopes so that both inflexion points ! collapse onto the right edge @@ -334,21 +307,21 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect ) ! the inconsistent slope is set equal to zero and the opposite edge value ! and edge slope are modified in compliance with the fact that both ! inflexion points must still be located on the right edge - if ( u1_l * slope .LT. 0.0 ) then + if ( u1_l * slope < 0.0 ) then u1_l = 0.0 u0_r = ( 5.0 * u_c - 3.0 * u0_l ) / 2.0 u1_r = 10.0 * (u_c - u0_l) / (3.0 * h_c + hNeglect) - else if ( u1_r * slope .LT. 0.0 ) then + elseif ( u1_r * slope < 0.0 ) then u1_r = 0.0 u0_l = 5.0 * u_c - 4.0 * u0_r u1_l = 20.0 * ( -u_c + u0_r ) / (h_c + hNeglect) - end if + endif - end if ! clause to check where to collapse inflexion points + endif ! clause to check where to collapse inflexion points ! Save edge values and edge slopes for reconstruction ppoly_E(k,1) = u0_l @@ -356,7 +329,7 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect ) ppoly_S(k,1) = u1_l ppoly_S(k,2) = u1_r - end do ! end loop on interior cells + enddo ! end loop on interior cells ! Constant reconstruction within boundary cells ppoly_E(1,:) = u(1) @@ -367,40 +340,29 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect ) end subroutine PQM_limiter - -!------------------------------------------------------------------------------ -! pqm boundary extrapolation -! ----------------------------------------------------------------------------- -subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients ) -!------------------------------------------------------------------------------ -! Reconstruction by parabolas within boundary cells. -! -! The following explanations apply to the left boundary cell. The same -! reasoning holds for the right boundary cell. -! -! A parabola needs to be built in the cell and requires three degrees of -! freedom, which are the right edge value and slope and the cell average. -! The right edge values and slopes are taken to be that of the neighboring -! cell (i.e., the left edge value and slope of the neighboring cell). -! The resulting parabola is not necessarily monotonic and the traditional -! PPM limiter is used to modify one of the edge values in order to yield -! a monotonic parabola. -! -! grid: one-dimensional grid (properly initialized) -! ppoly: piecewise linear polynomial to be reconstructed (properly initialized) -! u: cell averages -! -! It is assumed that the size of the array 'u' is equal to the number of cells -! defining 'grid' and 'ppoly'. No consistency check is performed here. -!------------------------------------------------------------------------------ - - ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell widths (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: ppoly_E !Edge value of polynomial - real, dimension(:,:), intent(inout) :: ppoly_coefficients !Coefficients of polynomial - +!> Reconstruction by parabolas within boundary cells. +!! +!! The following explanations apply to the left boundary cell. The same +!! reasoning holds for the right boundary cell. +!! +!! A parabola needs to be built in the cell and requires three degrees of +!! freedom, which are the right edge value and slope and the cell average. +!! The right edge values and slopes are taken to be that of the neighboring +!! cell (i.e., the left edge value and slope of the neighboring cell). +!! The resulting parabola is not necessarily monotonic and the traditional +!! PPM limiter is used to modify one of the edge values in order to yield +!! a monotonic parabola. +!! +!! It is assumed that the size of the array 'u' is equal to the number of cells +!! defining 'grid' and 'ppoly'. No consistency check is performed here. +subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef ) + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell averages (size N) + real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial, + !! with the same units as u. + real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, mainly + !! with the same units as u. ! Local variables integer :: i0, i1 real :: u0, u1 @@ -421,15 +383,15 @@ subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients ) ! Compute the left edge slope in neighboring cell and express it in ! the global coordinate system - b = ppoly_coefficients(i1,2) + b = ppoly_coef(i1,2) u1_r = b *(h0/h1) ! derivative evaluated at xi = 0.0, ! expressed w.r.t. xi (local coord. system) ! Limit the right slope by the PLM limited slope slope = 2.0 * ( u1 - u0 ) - if ( abs(u1_r) .GT. abs(slope) ) then + if ( abs(u1_r) > abs(slope) ) then u1_r = slope - end if + endif ! The right edge value in the boundary cell is taken to be the left ! edge value in the neighboring cell @@ -444,13 +406,13 @@ subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients ) exp1 = (u0_r - u0_l) * (u0 - 0.5*(u0_l+u0_r)) exp2 = (u0_r - u0_l) * (u0_r - u0_l) / 6.0 - if ( exp1 .GT. exp2 ) then + if ( exp1 > exp2 ) then u0_l = 3.0 * u0 - 2.0 * u0_r - end if + endif - if ( exp1 .LT. -exp2 ) then + if ( exp1 < -exp2 ) then u0_r = 3.0 * u0 - 2.0 * u0_l - end if + endif ppoly_E(i0,1) = u0_l ppoly_E(i0,2) = u0_r @@ -460,11 +422,11 @@ subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients ) c = 3.0 * ( u0_r + u0_l - 2.0 * u0 ) ! The quartic is reduced to a parabola in the boundary cell - ppoly_coefficients(i0,1) = a - ppoly_coefficients(i0,2) = b - ppoly_coefficients(i0,3) = c - ppoly_coefficients(i0,4) = 0.0 - ppoly_coefficients(i0,5) = 0.0 + ppoly_coef(i0,1) = a + ppoly_coef(i0,2) = b + ppoly_coef(i0,3) = c + ppoly_coef(i0,4) = 0.0 + ppoly_coef(i0,5) = 0.0 ! ----- Right boundary ----- i0 = N-1 @@ -476,18 +438,18 @@ subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients ) ! Compute the right edge slope in neighboring cell and express it in ! the global coordinate system - b = ppoly_coefficients(i0,2) - c = ppoly_coefficients(i0,3) - d = ppoly_coefficients(i0,4) - e = ppoly_coefficients(i0,5) + b = ppoly_coef(i0,2) + c = ppoly_coef(i0,3) + d = ppoly_coef(i0,4) + e = ppoly_coef(i0,5) u1_l = (b + 2*c + 3*d + 4*e) ! derivative evaluated at xi = 1.0 u1_l = u1_l * (h1/h0) ! Limit the left slope by the PLM limited slope slope = 2.0 * ( u1 - u0 ) - if ( abs(u1_l) .GT. abs(slope) ) then + if ( abs(u1_l) > abs(slope) ) then u1_l = slope - end if + endif ! The left edge value in the boundary cell is taken to be the right ! edge value in the neighboring cell @@ -502,13 +464,13 @@ subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients ) exp1 = (u0_r - u0_l) * (u1 - 0.5*(u0_l+u0_r)) exp2 = (u0_r - u0_l) * (u0_r - u0_l) / 6.0 - if ( exp1 .GT. exp2 ) then + if ( exp1 > exp2 ) then u0_l = 3.0 * u1 - 2.0 * u0_r - end if + endif - if ( exp1 .LT. -exp2 ) then + if ( exp1 < -exp2 ) then u0_r = 3.0 * u1 - 2.0 * u0_l - end if + endif ppoly_E(i1,1) = u0_l ppoly_E(i1,2) = u0_r @@ -518,52 +480,43 @@ subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients ) c = 3.0 * ( u0_r + u0_l - 2.0 * u1 ) ! The quartic is reduced to a parabola in the boundary cell - ppoly_coefficients(i1,1) = a - ppoly_coefficients(i1,2) = b - ppoly_coefficients(i1,3) = c - ppoly_coefficients(i1,4) = 0.0 - ppoly_coefficients(i1,5) = 0.0 + ppoly_coef(i1,1) = a + ppoly_coef(i1,2) = b + ppoly_coef(i1,3) = c + ppoly_coef(i1,4) = 0.0 + ppoly_coef(i1,5) = 0.0 end subroutine PQM_boundary_extrapolation -!------------------------------------------------------------------------------ -! pqm boundary extrapolation using rational function -! ----------------------------------------------------------------------------- -subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, h_neglect ) -!------------------------------------------------------------------------------ -! Reconstruction by parabolas within boundary cells. -! -! The following explanations apply to the left boundary cell. The same -! reasoning holds for the right boundary cell. -! -! A parabola needs to be built in the cell and requires three degrees of -! freedom, which are the right edge value and slope and the cell average. -! The right edge values and slopes are taken to be that of the neighboring -! cell (i.e., the left edge value and slope of the neighboring cell). -! The resulting parabola is not necessarily monotonic and the traditional -! PPM limiter is used to modify one of the edge values in order to yield -! a monotonic parabola. -! -! grid: one-dimensional grid (properly initialized) -! ppoly: piecewise linear polynomial to be reconstructed (properly initialized) -! u: cell averages -! -! It is assumed that the size of the array 'u' is equal to the number of cells -! defining 'grid' and 'ppoly'. No consistency check is performed here. -!------------------------------------------------------------------------------ - - ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell widths (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: ppoly_E !Edge value of polynomial - real, dimension(:,:), intent(inout) :: ppoly_S !Edge slope of polynomial - real, dimension(:,:), intent(inout) :: ppoly_coefficients !Coefficients of polynomial - real, optional, intent(in) :: h_neglect !< A negligibly small width for - !! the purpose of cell reconstructions - !! in the same units as h. - +!> Reconstruction by parabolas within boundary cells. +!! +!! The following explanations apply to the left boundary cell. The same +!! reasoning holds for the right boundary cell. +!! +!! A parabola needs to be built in the cell and requires three degrees of +!! freedom, which are the right edge value and slope and the cell average. +!! The right edge values and slopes are taken to be that of the neighboring +!! cell (i.e., the left edge value and slope of the neighboring cell). +!! The resulting parabola is not necessarily monotonic and the traditional +!! PPM limiter is used to modify one of the edge values in order to yield +!! a monotonic parabola. +!! +!! It is assumed that the size of the array 'u' is equal to the number of cells +!! defining 'grid' and 'ppoly'. No consistency check is performed here. +subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect ) + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell averages (size N) + real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial, + !! with the same units as u. + real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial, + !! in the units of u over the units of h. + real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, mainly + !! with the same units as u. + real, optional, intent(in) :: h_neglect !< A negligibly small width for + !! the purpose of cell reconstructions + !! in the same units as h. ! Local variables integer :: i0, i1 integer :: inflexion_l @@ -600,15 +553,15 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff ! The right edge value and slope of the boundary cell are taken to be the ! left edge value and slope of the adjacent cell - a = ppoly_coefficients(i1,1) - b = ppoly_coefficients(i1,2) + a = ppoly_coef(i1,1) + b = ppoly_coef(i1,2) u0_r = a ! edge value u1_r = b / (h1 + hNeglect) ! edge slope (w.r.t. global coord.) ! Compute coefficient for rational function based on mean and right ! edge value and slope - if (u1_r.ne.0.) then ! HACK by AJA + if (u1_r /= 0.) then ! HACK by AJA beta = 2.0 * ( u0_r - um ) / ( (h0 + hNeglect)*u1_r) - 1.0 else beta = 0. @@ -626,13 +579,13 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff ! the PLM edge value. If so, keep it and compute left edge slope ! based on the rational function. If not, keep the PLM edge value and ! compute corresponding slope. - if ( abs(um-u0_l) .lt. abs(um-u_plm) ) then + if ( abs(um-u0_l) < abs(um-u_plm) ) then u1_l = 2.0 * ( br - ar*beta) u1_l = u1_l / (h0 + hNeglect) else u0_l = u_plm u1_l = slope / (h0 + hNeglect) - end if + endif ! Monotonize quartic inflexion_l = 0 @@ -651,41 +604,41 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff ! Check whether inflexion points exist. If so, transform the quartic ! so that both inflexion points coalesce on the left edge. - if (( alpha1 .ne. 0.0 ) .and. ( rho .ge. 0.0 )) then + if (( alpha1 /= 0.0 ) .and. ( rho >= 0.0 )) then sqrt_rho = sqrt( rho ) x1 = 0.5 * ( - alpha2 - sqrt_rho ) / alpha1 - if ( (x1 .gt. 0.0) .and. (x1 .lt. 1.0) ) then + if ( (x1 > 0.0) .and. (x1 < 1.0) ) then gradient1 = 4.0 * e * (x1**3) + 3.0 * d * (x1**2) + 2.0 * c * x1 + b - if ( gradient1 * slope .lt. 0.0 ) then + if ( gradient1 * slope < 0.0 ) then inflexion_l = 1 - end if - end if + endif + endif x2 = 0.5 * ( - alpha2 + sqrt_rho ) / alpha1 - if ( (x2 .gt. 0.0) .and. (x2 .lt. 1.0) ) then + if ( (x2 > 0.0) .and. (x2 < 1.0) ) then gradient2 = 4.0 * e * (x2**3) + 3.0 * d * (x2**2) + 2.0 * c * x2 + b - if ( gradient2 * slope .lt. 0.0 ) then + if ( gradient2 * slope < 0.0 ) then inflexion_l = 1 - end if - end if + endif + endif - end if + endif - if (( alpha1 .eq. 0.0 ) .and. ( alpha2 .ne. 0.0 )) then + if (( alpha1 == 0.0 ) .and. ( alpha2 /= 0.0 )) then x1 = - alpha3 / alpha2 - if ( (x1 .ge. 0.0) .and. (x1 .le. 1.0) ) then + if ( (x1 >= 0.0) .and. (x1 <= 1.0) ) then gradient1 = 3.0 * d * (x1**2) + 2.0 * c * x1 + b - if ( gradient1 * slope .lt. 0.0 ) then + if ( gradient1 * slope < 0.0 ) then inflexion_l = 1 - end if - end if + endif + endif - end if + endif - if ( inflexion_l .eq. 1 ) then + if ( inflexion_l == 1 ) then ! We modify the edge slopes so that both inflexion points ! collapse onto the left edge @@ -696,21 +649,21 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff ! the inconsistent slope is set equal to zero and the opposite edge value ! and edge slope are modified in compliance with the fact that both ! inflexion points must still be located on the left edge - if ( u1_l * slope .LT. 0.0 ) then + if ( u1_l * slope < 0.0 ) then u1_l = 0.0 u0_r = 5.0 * um - 4.0 * u0_l u1_r = 20.0 * (um - u0_l) / ( h0 + hNeglect ) - else if ( u1_r * slope .LT. 0.0 ) then + elseif ( u1_r * slope < 0.0 ) then u1_r = 0.0 u0_l = (5.0*um - 3.0*u0_r) / 2.0 u1_l = 10.0 * (-um + u0_r) / (3.0 * h0 + hNeglect ) - end if + endif - end if + endif ! Store edge values, edge slopes and coefficients ppoly_E(i0,1) = u0_l @@ -725,11 +678,11 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff e = 30.0 * um + 2.5*h0*(u1_r - u1_l) - 15.0*(u0_l + u0_r) ! Store coefficients - ppoly_coefficients(i0,1) = a - ppoly_coefficients(i0,2) = b - ppoly_coefficients(i0,3) = c - ppoly_coefficients(i0,4) = d - ppoly_coefficients(i0,5) = e + ppoly_coef(i0,1) = a + ppoly_coef(i0,2) = b + ppoly_coef(i0,3) = c + ppoly_coef(i0,4) = d + ppoly_coef(i0,5) = e ! ----- Right boundary (BOTTOM) ----- i0 = N-1 @@ -747,17 +700,17 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff ! The left edge value and slope of the boundary cell are taken to be the ! right edge value and slope of the adjacent cell - a = ppoly_coefficients(i0,1) - b = ppoly_coefficients(i0,2) - c = ppoly_coefficients(i0,3) - d = ppoly_coefficients(i0,4) - e = ppoly_coefficients(i0,5) + a = ppoly_coef(i0,1) + b = ppoly_coef(i0,2) + c = ppoly_coef(i0,3) + d = ppoly_coef(i0,4) + e = ppoly_coef(i0,5) u0_l = a + b + c + d + e ! edge value u1_l = (b + 2*c + 3*d + 4*e) / h0 ! edge slope (w.r.t. global coord.) ! Compute coefficient for rational function based on mean and left ! edge value and slope - if (um-u0_l.ne.0.) then ! HACK by AJA + if (um-u0_l /= 0.) then ! HACK by AJA beta = 0.5*h1*u1_l / (um-u0_l) - 1.0 else beta = 0. @@ -766,7 +719,7 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff ar = u0_l ! Right edge value estimate based on rational function - if (1+beta.ne.0.) then ! HACK by AJA + if (1+beta /= 0.) then ! HACK by AJA u0_r = (ar + 2*br + beta*br ) / ((1+beta)*(1+beta)) else u0_r = um + 0.5 * slope ! PLM @@ -779,13 +732,13 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff ! the PLM edge value. If so, keep it and compute right edge slope ! based on the rational function. If not, keep the PLM edge value and ! compute corresponding slope. - if ( abs(um-u0_r) .lt. abs(um-u_plm) ) then + if ( abs(um-u0_r) < abs(um-u_plm) ) then u1_r = 2.0 * ( br - ar*beta ) / ( (1+beta)*(1+beta)*(1+beta) ) u1_r = u1_r / h1 else u0_r = u_plm u1_r = slope / h1 - end if + endif ! Monotonize quartic inflexion_r = 0 @@ -804,41 +757,41 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff ! Check whether inflexion points exist. If so, transform the quartic ! so that both inflexion points coalesce on the right edge. - if (( alpha1 .ne. 0.0 ) .and. ( rho .ge. 0.0 )) then + if (( alpha1 /= 0.0 ) .and. ( rho >= 0.0 )) then sqrt_rho = sqrt( rho ) x1 = 0.5 * ( - alpha2 - sqrt_rho ) / alpha1 - if ( (x1 .gt. 0.0) .and. (x1 .lt. 1.0) ) then + if ( (x1 > 0.0) .and. (x1 < 1.0) ) then gradient1 = 4.0 * e * (x1**3) + 3.0 * d * (x1**2) + 2.0 * c * x1 + b - if ( gradient1 * slope .lt. 0.0 ) then + if ( gradient1 * slope < 0.0 ) then inflexion_r = 1 - end if - end if + endif + endif x2 = 0.5 * ( - alpha2 + sqrt_rho ) / alpha1 - if ( (x2 .gt. 0.0) .and. (x2 .lt. 1.0) ) then + if ( (x2 > 0.0) .and. (x2 < 1.0) ) then gradient2 = 4.0 * e * (x2**3) + 3.0 * d * (x2**2) + 2.0 * c * x2 + b - if ( gradient2 * slope .lt. 0.0 ) then + if ( gradient2 * slope < 0.0 ) then inflexion_r = 1 - end if - end if + endif + endif - end if + endif - if (( alpha1 .eq. 0.0 ) .and. ( alpha2 .ne. 0.0 )) then + if (( alpha1 == 0.0 ) .and. ( alpha2 /= 0.0 )) then x1 = - alpha3 / alpha2 - if ( (x1 .ge. 0.0) .and. (x1 .le. 1.0) ) then + if ( (x1 >= 0.0) .and. (x1 <= 1.0) ) then gradient1 = 3.0 * d * (x1**2) + 2.0 * c * x1 + b - if ( gradient1 * slope .lt. 0.0 ) then + if ( gradient1 * slope < 0.0 ) then inflexion_r = 1 - end if - end if + endif + endif - end if + endif - if ( inflexion_r .eq. 1 ) then + if ( inflexion_r == 1 ) then ! We modify the edge slopes so that both inflexion points ! collapse onto the right edge @@ -849,21 +802,21 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff ! the inconsistent slope is set equal to zero and the opposite edge value ! and edge slope are modified in compliance with the fact that both ! inflexion points must still be located on the right edge - if ( u1_l * slope .lt. 0.0 ) then + if ( u1_l * slope < 0.0 ) then u1_l = 0.0 u0_r = ( 5.0 * um - 3.0 * u0_l ) / 2.0 u1_r = 10.0 * (um - u0_l) / (3.0 * h1) - else if ( u1_r * slope .lt. 0.0 ) then + elseif ( u1_r * slope < 0.0 ) then u1_r = 0.0 u0_l = 5.0 * um - 4.0 * u0_r u1_l = 20.0 * ( -um + u0_r ) / h1 - end if + endif - end if + endif ! Store edge values, edge slopes and coefficients ppoly_E(i1,1) = u0_l @@ -877,12 +830,20 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff d = -60.0 * um + h1 *(6.0*u1_l - 4.0*u1_r) + 28.0*u0_r + 32.0*u0_l e = 30.0 * um + 2.5*h1*(u1_r - u1_l) - 15.0*(u0_l + u0_r) - ppoly_coefficients(i1,1) = a - ppoly_coefficients(i1,2) = b - ppoly_coefficients(i1,3) = c - ppoly_coefficients(i1,4) = d - ppoly_coefficients(i1,5) = e + ppoly_coef(i1,1) = a + ppoly_coef(i1,2) = b + ppoly_coef(i1,3) = c + ppoly_coef(i1,4) = d + ppoly_coef(i1,5) = e end subroutine PQM_boundary_extrapolation_v1 +!> \namespace pqm_functions +!! +!! Date of creation: 2008.06.06 +!! L. White +!! +!! This module contains routines that handle one-dimensionnal finite volume +!! reconstruction using the piecewise quartic method (PQM). + end module PQM_functions diff --git a/src/ALE/coord_adapt.F90 b/src/ALE/coord_adapt.F90 index dff0638711..98bbeb7b10 100644 --- a/src/ALE/coord_adapt.F90 +++ b/src/ALE/coord_adapt.F90 @@ -12,32 +12,32 @@ module coord_adapt #include -type, public :: adapt_CS - private +!> Control structure for adaptive coordinates (coord_adapt). +type, public :: adapt_CS ; private !> Number of layers/levels integer :: nk - !> Nominal near-surface resolution + !> Nominal near-surface resolution [H ~> m or kg m-2] real, allocatable, dimension(:) :: coordinateResolution !> Ratio of optimisation and diffusion timescales - real :: adaptTimeRatio = 1e-1 + real :: adaptTimeRatio !> Nondimensional coefficient determining how much optimisation to apply - real :: adaptAlpha = 1.0 + real :: adaptAlpha - !> Near-surface zooming depth - real :: adaptZoom = 200.0 + !> Near-surface zooming depth [H ~> m or kg m-2] + real :: adaptZoom !> Near-surface zooming coefficient - real :: adaptZoomCoeff = 0.0 + real :: adaptZoomCoeff !> Stratification-dependent diffusion coefficient - real :: adaptBuoyCoeff = 0.0 + real :: adaptBuoyCoeff - !> Reference density difference for stratification-dependent diffusion - real :: adaptDrho0 = 0.5 + !> Reference density difference for stratification-dependent diffusion [kg m-3] + real :: adaptDrho0 !> If true, form a HYCOM1-like mixed layet by preventing interfaces !! from becoming shallower than the depths set by coordinateResolution @@ -49,22 +49,37 @@ module coord_adapt contains !> Initialise an adapt_CS with parameters -subroutine init_coord_adapt(CS, nk, coordinateResolution) +subroutine init_coord_adapt(CS, nk, coordinateResolution, m_to_H) type(adapt_CS), pointer :: CS !< Unassociated pointer to hold the control structure - integer, intent(in) :: nk - real, dimension(:), intent(in) :: coordinateResolution + integer, intent(in) :: nk !< Number of layers in the grid + real, dimension(:), intent(in) :: coordinateResolution !< Nominal near-surface resolution [m] or + !! other units specified with m_to_H + real, optional, intent(in) :: m_to_H !< A conversion factor from m to the units of thicknesses + + real :: m_to_H_rescale ! A unit conversion factor. if (associated(CS)) call MOM_error(FATAL, "init_coord_adapt: CS already associated") allocate(CS) allocate(CS%coordinateResolution(nk)) + m_to_H_rescale = 1.0 ; if (present(m_to_H)) m_to_H_rescale = m_to_H + CS%nk = nk CS%coordinateResolution(:) = coordinateResolution(:) + + ! Set real parameter default values + CS%adaptTimeRatio = 1e-1 ! Nondim. + CS%adaptAlpha = 1.0 ! Nondim. + CS%adaptZoom = 200.0 * m_to_H_rescale + CS%adaptZoomCoeff = 0.0 ! Nondim. + CS%adaptBuoyCoeff = 0.0 ! Nondim. + CS%adaptDrho0 = 0.5 ! [kg m-3] + end subroutine init_coord_adapt !> Clean up the coordinate control structure subroutine end_coord_adapt(CS) - type(adapt_CS), pointer :: CS + type(adapt_CS), pointer :: CS !< The control structure for this module ! nothing to do if (.not. associated(CS)) return @@ -72,12 +87,21 @@ subroutine end_coord_adapt(CS) deallocate(CS) end subroutine end_coord_adapt +!> This subtroutine can be used to set the parameters for coord_adapt module subroutine set_adapt_params(CS, adaptTimeRatio, adaptAlpha, adaptZoom, adaptZoomCoeff, & - adaptBuoyCoeff, adaptDrho0, adaptDoMin) - type(adapt_CS), pointer :: CS - real, optional, intent(in) :: adaptTimeRatio, adaptAlpha, adaptZoom, adaptZoomCoeff - real, optional, intent(in) :: adaptBuoyCoeff, adaptDrho0 - logical, optional, intent(in) :: adaptDoMin + adaptBuoyCoeff, adaptDrho0, adaptDoMin) + type(adapt_CS), pointer :: CS !< The control structure for this module + real, optional, intent(in) :: adaptTimeRatio !< Ratio of optimisation and diffusion timescales + real, optional, intent(in) :: adaptAlpha !< Nondimensional coefficient determining + !! how much optimisation to apply + real, optional, intent(in) :: adaptZoom !< Near-surface zooming depth [H ~> m or kg m-2] + real, optional, intent(in) :: adaptZoomCoeff !< Near-surface zooming coefficient + real, optional, intent(in) :: adaptBuoyCoeff !< Stratification-dependent diffusion coefficient + real, optional, intent(in) :: adaptDrho0 !< Reference density difference for + !! stratification-dependent diffusion + logical, optional, intent(in) :: adaptDoMin !< If true, form a HYCOM1-like mixed layer by + !! preventing interfaces from becoming shallower than + !! the depths set by coordinateResolution if (.not. associated(CS)) call MOM_error(FATAL, "set_adapt_params: CS not associated") @@ -91,14 +115,18 @@ subroutine set_adapt_params(CS, adaptTimeRatio, adaptAlpha, adaptZoom, adaptZoom end subroutine set_adapt_params subroutine build_adapt_column(CS, G, GV, tv, i, j, zInt, tInt, sInt, h, zNext) - type(adapt_CS), intent(in) :: CS + type(adapt_CS), intent(in) :: CS !< The control structure for this module 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 pointing to various thermodynamic variables - integer, intent(in) :: i, j - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: zInt, tInt, sInt - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - real, dimension(SZK_(GV)+1), intent(inout) :: zNext ! updated interface positions + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables + integer, intent(in) :: i !< The i-index of the column to work on + integer, intent(in) :: j !< The j-index of the column to work on + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: zInt !< Interface heights [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: tInt !< Interface temperatures [degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: sInt !< Interface salinities [ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZK_(GV)+1), intent(inout) :: zNext !< updated interface positions ! Local variables integer :: k, nz @@ -113,7 +141,7 @@ subroutine build_adapt_column(CS, G, GV, tv, i, j, zInt, tInt, sInt, h, zNext) zNext(nz+1) = zInt(i,j,nz+1) ! local depth for scaling diffusivity - depth = G%bathyT(i,j) * GV%m_to_H + depth = G%bathyT(i,j) * GV%Z_to_H ! initialize del2sigma to zero del2sigma(:) = 0. @@ -213,7 +241,7 @@ subroutine build_adapt_column(CS, G, GV, tv, i, j, zInt, tInt, sInt, h, zNext) ! set vertical grid diffusivity kGrid(k) = (CS%adaptTimeRatio * nz**2 * depth) * & - (CS%adaptZoomCoeff / (CS%adaptZoom * GV%m_to_H + 0.5*(zNext(K) + zNext(K+1))) + & + (CS%adaptZoomCoeff / (CS%adaptZoom + 0.5*(zNext(K) + zNext(K+1))) + & (CS%adaptBuoyCoeff * drdz / CS%adaptDrho0) + & max(1.0 - CS%adaptZoomCoeff - CS%adaptBuoyCoeff, 0.0) / depth) enddo diff --git a/src/ALE/coord_hycom.F90 b/src/ALE/coord_hycom.F90 index 06da6db4b2..6928425e33 100644 --- a/src/ALE/coord_hycom.F90 +++ b/src/ALE/coord_hycom.F90 @@ -10,8 +10,7 @@ module coord_hycom implicit none ; private !> Control structure containing required parameters for the HyCOM coordinate -type, public :: hycom_CS - private +type, public :: hycom_CS ; private !> Number of layers/levels in generated grid integer :: nk @@ -40,8 +39,8 @@ module coord_hycom subroutine init_coord_hycom(CS, nk, coordinateResolution, target_density, interp_CS) type(hycom_CS), pointer :: CS !< Unassociated pointer to hold the control structure integer, intent(in) :: nk !< Number of layers in generated grid - real, dimension(nk), intent(in) :: coordinateResolution !< Z-space thicknesses (m) - real, dimension(nk+1),intent(in) :: target_density !< Interface target densities (kg/m3) + real, dimension(nk), intent(in) :: coordinateResolution !< Nominal near-surface resolution [m] + real, dimension(nk+1),intent(in) :: target_density !< Interface target densities [kg m-3] type(interp_CS_type), intent(in) :: interp_CS !< Controls for interpolation if (associated(CS)) call MOM_error(FATAL, "init_coord_hycom: CS already associated!") @@ -55,8 +54,9 @@ subroutine init_coord_hycom(CS, nk, coordinateResolution, target_density, interp CS%interp_CS = interp_CS end subroutine init_coord_hycom +!> This subroutine deallocates memory in the control structure for the coord_hycom module subroutine end_coord_hycom(CS) - type(hycom_CS), pointer :: CS + type(hycom_CS), pointer :: CS !< Coordinate control structure ! nothing to do if (.not. associated(CS)) return @@ -67,11 +67,12 @@ subroutine end_coord_hycom(CS) deallocate(CS) end subroutine end_coord_hycom +!> This subroutine can be used to set the parameters for the coord_hycom module subroutine set_hycom_params(CS, max_interface_depths, max_layer_thickness, interp_CS) - type(hycom_CS), pointer :: CS - real, optional, dimension(:), intent(in) :: max_interface_depths - real, optional, dimension(:), intent(in) :: max_layer_thickness - type(interp_CS_type), optional, intent(in) :: interp_CS + type(hycom_CS), pointer :: CS !< Coordinate control structure + real, dimension(:), optional, intent(in) :: max_interface_depths !< Maximum depths of interfaces in m + real, dimension(:), optional, intent(in) :: max_layer_thickness !< Maximum thicknesses of layers in m + type(interp_CS_type), optional, intent(in) :: interp_CS !< Controls for interpolation if (.not. associated(CS)) call MOM_error(FATAL, "set_hycom_params: CS not associated") @@ -98,14 +99,14 @@ subroutine build_hycom1_column(CS, eqn_of_state, nz, depth, h, T, S, p_col, & type(hycom_CS), intent(in) :: CS !< Coordinate control structure type(EOS_type), pointer :: eqn_of_state !< Equation of state structure integer, intent(in) :: nz !< Number of levels - real, intent(in) :: depth !< Depth of ocean bottom (positive in H) - real, dimension(nz), intent(in) :: T !< Temperature of column (degC) - real, dimension(nz), intent(in) :: S !< Salinity of column (psu) - real, dimension(nz), intent(in) :: h !< Layer thicknesses, (in m or H) - real, dimension(nz), intent(in) :: p_col !< Layer pressure in Pa - real, dimension(nz+1), intent(in) :: z_col !< Interface positions relative to the surface in H units (m or kg m-2) + real, intent(in) :: depth !< Depth of ocean bottom (positive [H ~> m or kg m-2]) + real, dimension(nz), intent(in) :: T !< Temperature of column [degC] + real, dimension(nz), intent(in) :: S !< Salinity of column [ppt] + real, dimension(nz), intent(in) :: h !< Layer thicknesses, in [m] or [H ~> m or kg m-2] + real, dimension(nz), intent(in) :: p_col !< Layer pressure [Pa] + real, dimension(nz+1), intent(in) :: z_col !< Interface positions relative to the surface [H ~> m or kg m-2] real, dimension(CS%nk+1), intent(inout) :: z_col_new !< Absolute positions of interfaces - real, optional, intent(in) :: zScale !< Scaling factor from the input thicknesses in m + real, optional, intent(in) :: zScale !< Scaling factor from the input thicknesses in [m] !! to desired units for zInterface, perhaps m_to_H. real, optional, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions @@ -120,7 +121,7 @@ subroutine build_hycom1_column(CS, eqn_of_state, nz, depth, h, T, S, p_col, & real, dimension(CS%nk) :: h_col_new ! New layer thicknesses real :: z_scale real :: stretching ! z* stretching, converts z* to z. - real :: nominal_z ! Nominal depth of interface is using z* (m or Pa) + real :: nominal_z ! Nominal depth of interface when using z* [Z ~> m] real :: hNew logical :: maximum_depths_set ! If true, the maximum depths of interface have been set. logical :: maximum_h_set ! If true, the maximum layer thicknesses have been set. diff --git a/src/ALE/coord_rho.F90 b/src/ALE/coord_rho.F90 index bee6832f77..452b3dfa09 100644 --- a/src/ALE/coord_rho.F90 +++ b/src/ALE/coord_rho.F90 @@ -11,23 +11,22 @@ module coord_rho implicit none ; private !> Control structure containing required parameters for the rho coordinate -type, public :: rho_CS - private +type, public :: rho_CS ; private !> Number of layers integer :: nk - !> Minimum thickness allowed for layers + !> Minimum thickness allowed for layers, often in [H ~> m or kg m-2] real :: min_thickness = 0. - !> Reference pressure for density calculations + !> Reference pressure for density calculations [Pa] real :: ref_pressure !> If true, integrate for interface positions from the top downward. !! If false, integrate from the bottom upward, as does the rest of the model. logical :: integrate_downward_for_e = .false. - !> Nominal density of interfaces + !> Nominal density of interfaces [kg m-3] real, allocatable, dimension(:) :: target_density !> Interpolation control structure @@ -46,10 +45,10 @@ module coord_rho !> Initialise a rho_CS with pointers to parameters subroutine init_coord_rho(CS, nk, ref_pressure, target_density, interp_CS) type(rho_CS), pointer :: CS !< Unassociated pointer to hold the control structure - integer, intent(in) :: nk - real, intent(in) :: ref_pressure - real, dimension(:), intent(in) :: target_density - type(interp_CS_type), intent(in) :: interp_CS + integer, intent(in) :: nk !< Number of layers in the grid + real, intent(in) :: ref_pressure !< Coordinate reference pressure [Pa] + real, dimension(:), intent(in) :: target_density !< Nominal density of interfaces [kg m-3] + type(interp_CS_type), intent(in) :: interp_CS !< Controls for interpolation if (associated(CS)) call MOM_error(FATAL, "init_coord_rho: CS already associated!") allocate(CS) @@ -61,8 +60,9 @@ subroutine init_coord_rho(CS, nk, ref_pressure, target_density, interp_CS) CS%interp_CS = interp_CS end subroutine init_coord_rho +!> This subroutine deallocates memory in the control structure for the coord_rho module subroutine end_coord_rho(CS) - type(rho_CS), pointer :: CS + type(rho_CS), pointer :: CS !< Coordinate control structure ! nothing to do if (.not. associated(CS)) return @@ -70,11 +70,15 @@ subroutine end_coord_rho(CS) deallocate(CS) end subroutine end_coord_rho +!> This subroutine can be used to set the parameters for the coord_rho module subroutine set_rho_params(CS, min_thickness, integrate_downward_for_e, interp_CS) - type(rho_CS), pointer :: CS - real, optional, intent(in) :: min_thickness - logical, optional, intent(in) :: integrate_downward_for_e - type(interp_CS_type), optional, intent(in) :: interp_CS + type(rho_CS), pointer :: CS !< Coordinate control structure + real, optional, intent(in) :: min_thickness !< Minimum allowed thickness [H ~> m or kg m-2] + logical, optional, intent(in) :: integrate_downward_for_e !< If true, integrate for interface + !! positions from the top downward. If false, integrate + !! from the bottom upward, as does the rest of the model. + + type(interp_CS_type), optional, intent(in) :: interp_CS !< Controls for interpolation if (.not. associated(CS)) call MOM_error(FATAL, "set_rho_params: CS not associated") @@ -92,7 +96,7 @@ subroutine build_rho_column(CS, nz, depth, h, T, S, eqn_of_state, z_interface, & type(rho_CS), intent(in) :: CS !< coord_rho control structure integer, intent(in) :: nz !< Number of levels on source grid (i.e. length of h, T, S) real, intent(in) :: depth !< Depth of ocean bottom (positive in m) - real, dimension(nz), intent(in) :: h !< Layer thicknesses, in H + real, dimension(nz), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] real, dimension(nz), intent(in) :: T !< T for source column real, dimension(nz), intent(in) :: S !< S for source column type(EOS_type), pointer :: eqn_of_state !< Equation of state structure @@ -119,14 +123,14 @@ subroutine build_rho_column(CS, nz, depth, h, T, S, eqn_of_state, z_interface, & xTmp(1) = 0.0 do k = 1,count_nonzero_layers xTmp(k+1) = xTmp(k) + h_nv(k) - end do + enddo ! Compute densities on source column p(:) = CS%ref_pressure call calculate_density(T, S, p, densities, 1, nz, eqn_of_state) do k = 1,count_nonzero_layers densities(k) = densities(mapping(k)) - end do + enddo ! Based on source column density profile, interpolate to generate a new grid call build_and_interpolate_grid(CS%interp_CS, densities, count_nonzero_layers, & @@ -137,10 +141,10 @@ subroutine build_rho_column(CS, nz, depth, h, T, S, eqn_of_state, z_interface, & call old_inflate_layers_1d(CS%min_thickness, CS%nk, h_new) ! Comment: The following adjustment of h_new, and re-calculation of h_new via x1 needs to be removed - x1(1) = 0.0 ; do k = 1,CS%nk ; x1(k+1) = x1(k) + h_new(k) ; end do + x1(1) = 0.0 ; do k = 1,CS%nk ; x1(k+1) = x1(k) + h_new(k) ; enddo do k = 1,CS%nk h_new(k) = x1(k+1) - x1(k) - end do + enddo else ! count_nonzero_layers <= 1 if (nz == CS%nk) then @@ -168,36 +172,35 @@ subroutine build_rho_column(CS, nz, depth, h, T, S, eqn_of_state, z_interface, & end subroutine build_rho_column +!> Iteratively build a rho coordinate column +!! +!! The algorithm operates as follows within each column: +!! +!! 1. Given T & S within each layer, the layer densities are computed. +!! 2. Based on these layer densities, a global density profile is reconstructed +!! (this profile is monotonically increasing and may be discontinuous) +!! 3. The new grid interfaces are determined based on the target interface +!! densities. +!! 4. T & S are remapped onto the new grid. +!! 5. Return to step 1 until convergence or until the maximum number of +!! iterations is reached, whichever comes first. subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_state, & zInterface, h_neglect, h_neglect_edge) - !< Iteratively build a rho coordinate column - !! - !! The algorithm operates as follows within each column: - !! - !! 1. Given T & S within each layer, the layer densities are computed. - !! 2. Based on these layer densities, a global density profile is reconstructed - !! (this profile is monotonically increasing and may be discontinuous) - !! 3. The new grid interfaces are determined based on the target interface - !! densities. - !! 4. T & S are remapped onto the new grid. - !! 5. Return to step 1 until convergence or until the maximum number of - !! iterations is reached, whichever comes first. - type(rho_CS), intent(in) :: CS !< Regridding control structure type(remapping_CS), intent(in) :: remapCS !< Remapping parameters and options integer, intent(in) :: nz !< Number of levels - real, intent(in) :: depth !< Depth of ocean bottom (positive in m) - real, dimension(nz), intent(in) :: h !< Layer thicknesses, in m - real, dimension(nz), intent(in) :: T, S !< T and S for column + real, intent(in) :: depth !< Depth of ocean bottom [Z ~> m] + real, dimension(nz), intent(in) :: h !< Layer thicknesses in Z coordinates [Z ~> m] + real, dimension(nz), intent(in) :: T !< T for column [degC] + real, dimension(nz), intent(in) :: S !< S for column [ppt] type(EOS_type), pointer :: eqn_of_state !< Equation of state structure real, dimension(nz+1), intent(inout) :: zInterface !< Absolute positions of interfaces real, optional, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions - !! in the same units as h + !! in the same units as h [Z ~> m] real, optional, intent(in) :: h_neglect_edge !< A negligibly small width !! for the purpose of edge value calculations - !! in the same units as h - + !! in the same units as h [Z ~> m] ! Local variables integer :: k, m integer :: count_nonzero_layers @@ -227,12 +230,12 @@ subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_ if ( count_nonzero_layers <= 1 ) then h1(:) = h0(:) exit ! stop iterations here - end if + endif xTmp(1) = 0.0 do k = 1,count_nonzero_layers xTmp(k+1) = xTmp(k) + hTmp(k) - end do + enddo ! Compute densities within current water column call calculate_density( T_tmp, S_tmp, p, densities,& @@ -240,7 +243,7 @@ subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_ do k = 1,count_nonzero_layers densities(k) = densities(mapping(k)) - end do + enddo ! One regridding iteration ! Based on global density profile, interpolate to generate a new grid @@ -248,12 +251,12 @@ subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_ hTmp, xTmp, CS%target_density, nz, h1, x1, h_neglect, h_neglect_edge) call old_inflate_layers_1d( CS%min_thickness, nz, h1 ) - x1(1) = 0.0 ; do k = 1,nz ; x1(k+1) = x1(k) + h1(k) ; end do + x1(1) = 0.0 ; do k = 1,nz ; x1(k+1) = x1(k) + h1(k) ; enddo ! Remap T and S from previous grid to new grid do k = 1,nz h1(k) = x1(k+1) - x1(k) - end do + enddo call remapping_core_h(remapCS, nz, h0, S, nz, h1, Tmp, h_neglect, h_neglect_edge) S_tmp(:) = Tmp(:) @@ -269,7 +272,7 @@ subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_ x0(k) = x0(k-1) + h0(k-1) x1(k) = x1(k-1) + h1(k-1) deviation = deviation + (x0(k)-x1(k))**2 - end do + enddo deviation = sqrt( deviation / (nz-1) ) m = m + 1 @@ -277,7 +280,7 @@ subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_ ! Copy final grid onto start grid for next iteration h0(:) = h1(:) - end do ! end regridding iterations + enddo ! end regridding iterations if (CS%integrate_downward_for_e) then zInterface(1) = 0. @@ -326,12 +329,12 @@ subroutine copy_finite_thicknesses(nk, h_in, threshold, nout, h_out, mapping) if (h_out(nout) > thickest_h_out) then thickest_h_out = h_out(nout) k_thickest = nout - end if + endif else ! Add up mass in vanished layers thickness_in_vanished = thickness_in_vanished + h_in(k) - end if - end do + endif + enddo ! No finite layers if (nout <= 1) return @@ -342,14 +345,13 @@ subroutine copy_finite_thicknesses(nk, h_in, threshold, nout, h_out, mapping) end subroutine copy_finite_thicknesses !------------------------------------------------------------------------------ -! Inflate vanished layers to finite (nonzero) width -!------------------------------------------------------------------------------ -subroutine old_inflate_layers_1d( minThickness, N, h ) +!> Inflate vanished layers to finite (nonzero) width +subroutine old_inflate_layers_1d( min_thickness, nk, h ) ! Argument - real, intent(in) :: minThickness - integer, intent(in) :: N - real, intent(inout) :: h(:) + real, intent(in) :: min_thickness !< Minimum allowed thickness [H ~> m or kg m-2] + integer, intent(in) :: nk !< Number of layers in the grid + real, dimension(:), intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] ! Local variable integer :: k @@ -361,42 +363,42 @@ subroutine old_inflate_layers_1d( minThickness, N, h ) ! Count number of nonzero layers count_nonzero_layers = 0 - do k = 1,N - if ( h(k) > minThickness ) then + do k = 1,nk + if ( h(k) > min_thickness ) then count_nonzero_layers = count_nonzero_layers + 1 - end if - end do + endif + enddo ! If all layer thicknesses are greater than the threshold, exit routine - if ( count_nonzero_layers == N ) return + if ( count_nonzero_layers == nk ) return ! If all thicknesses are zero, inflate them all and exit if ( count_nonzero_layers == 0 ) then - do k = 1,N - h(k) = minThickness - end do + do k = 1,nk + h(k) = min_thickness + enddo return - end if + endif ! Inflate zero layers correction = 0.0 - do k = 1,N - if ( h(k) <= minThickness ) then - delta = minThickness - h(k) + do k = 1,nk + if ( h(k) <= min_thickness ) then + delta = min_thickness - h(k) correction = correction + delta h(k) = h(k) + delta - end if - end do + endif + enddo ! Modify thicknesses of nonzero layers to ensure volume conservation maxThickness = h(1) k_found = 1 - do k = 1,N + do k = 1,nk if ( h(k) > maxThickness ) then maxThickness = h(k) k_found = k - end if - end do + endif + enddo h(k_found) = h(k_found) - correction diff --git a/src/ALE/coord_sigma.F90 b/src/ALE/coord_sigma.F90 index 416ab757e2..3bf666ec52 100644 --- a/src/ALE/coord_sigma.F90 +++ b/src/ALE/coord_sigma.F90 @@ -8,8 +8,7 @@ module coord_sigma implicit none ; private !> Control structure containing required parameters for the sigma coordinate -type, public :: sigma_CS - private +type, public :: sigma_CS ; private !> Number of levels integer :: nk @@ -17,7 +16,7 @@ module coord_sigma !> Minimum thickness allowed for layers real :: min_thickness - !> Target coordinate resolution + !> Target coordinate resolution, nondimensional real, allocatable, dimension(:) :: coordinateResolution end type sigma_CS @@ -28,8 +27,8 @@ module coord_sigma !> Initialise a sigma_CS with pointers to parameters subroutine init_coord_sigma(CS, nk, coordinateResolution) type(sigma_CS), pointer :: CS !< Unassociated pointer to hold the control structure - integer, intent(in) :: nk - real, dimension(:), intent(in) :: coordinateResolution + integer, intent(in) :: nk !< Number of layers in the grid + real, dimension(:), intent(in) :: coordinateResolution !< Nominal coordinate resolution [nondim] if (associated(CS)) call MOM_error(FATAL, "init_coord_sigma: CS already associated!") allocate(CS) @@ -39,8 +38,9 @@ subroutine init_coord_sigma(CS, nk, coordinateResolution) CS%coordinateResolution = coordinateResolution end subroutine init_coord_sigma +!> This subroutine deallocates memory in the control structure for the coord_sigma module subroutine end_coord_sigma(CS) - type(sigma_CS), pointer :: CS + type(sigma_CS), pointer :: CS !< Coordinate control structure ! nothing to do if (.not. associated(CS)) return @@ -48,9 +48,10 @@ subroutine end_coord_sigma(CS) deallocate(CS) end subroutine end_coord_sigma +!> This subroutine can be used to set the parameters for the coord_sigma module subroutine set_sigma_params(CS, min_thickness) - type(sigma_CS), pointer :: CS - real, optional, intent(in) :: min_thickness + type(sigma_CS), pointer :: CS !< Coordinate control structure + real, optional, intent(in) :: min_thickness !< Minimum allowed thickness [H ~> m or kg m-2] if (.not. associated(CS)) call MOM_error(FATAL, "set_sigma_params: CS not associated") @@ -61,9 +62,9 @@ end subroutine set_sigma_params !> Build a sigma coordinate column subroutine build_sigma_column(CS, depth, totalThickness, zInterface) type(sigma_CS), intent(in) :: CS !< Coordinate control structure - real, intent(in) :: depth !< Depth of ocean bottom (positive in m) - real, intent(in) :: totalThickness !< Column thickness (positive in m) - real, dimension(CS%nk+1), intent(inout) :: zInterface !< Absolute positions of interfaces + real, intent(in) :: depth !< Depth of ocean bottom (positive [H ~> m or kg m-2]) + real, intent(in) :: totalThickness !< Column thickness (positive [H ~> m or kg m-2]) + real, dimension(CS%nk+1), intent(inout) :: zInterface !< Absolute positions of interfaces [H ~> m or kg m-2] ! Local variables integer :: k diff --git a/src/ALE/coord_slight.F90 b/src/ALE/coord_slight.F90 index 93f5b9c393..8eb623d664 100644 --- a/src/ALE/coord_slight.F90 +++ b/src/ALE/coord_slight.F90 @@ -12,53 +12,52 @@ module coord_slight implicit none ; private !> Control structure containing required parameters for the SLight coordinate -type, public :: slight_CS - private +type, public :: slight_CS ; private !> Number of layers/levels integer :: nk - !> Minimum thickness allowed when building the new grid through regridding + !> Minimum thickness allowed when building the new grid through regridding [H ~> m or kg m-2] real :: min_thickness - !> Reference pressure for potential density calculations (Pa) + !> Reference pressure for potential density calculations [Pa] real :: ref_pressure !> Fraction (between 0 and 1) of compressibility to add to potential density - !! profiles when interpolating for target grid positions. (nondim) - real :: compressibility_fraction = 0. + !! profiles when interpolating for target grid positions. [nondim] + real :: compressibility_fraction ! The following 4 parameters were introduced for use with the SLight coordinate: - !> Depth over which to average to determine the mixed layer potential density (m) - real :: Rho_ML_avg_depth = 1.0 + !> Depth over which to average to determine the mixed layer potential density [H ~> m or kg m-2] + real :: Rho_ML_avg_depth - !> Number of layers to offset the mixed layer density to find resolved stratification (nondim) - real :: nlay_ml_offset = 2.0 + !> Number of layers to offset the mixed layer density to find resolved stratification [nondim] + real :: nlay_ml_offset - !> The number of fixed-thickess layers at the top of the model + !> The number of fixed-thickness layers at the top of the model integer :: nz_fixed_surface = 2 - !> The fixed resolution in the topmost SLight_nkml_min layers (m) - real :: dz_ml_min = 1.0 + !> The fixed resolution in the topmost SLight_nkml_min layers [H ~> m or kg m-2] + real :: dz_ml_min !> If true, detect regions with much weaker stratification in the coordinate !! than based on in-situ density, and use a stretched coordinate there. logical :: fix_haloclines = .false. !> A length scale over which to filter T & S when looking for spuriously - !! unstable water mass profiles, in m. - real :: halocline_filter_length = 2.0 + !! unstable water mass profiles [H ~> m or kg m-2]. + real :: halocline_filter_length - !> A value of the stratification ratio that defines a problematic halocline region. - real :: halocline_strat_tol = 0.25 + !> A value of the stratification ratio that defines a problematic halocline region [nondim]. + real :: halocline_strat_tol - !> Nominal density of interfaces + !> Nominal density of interfaces [kg m-3]. real, allocatable, dimension(:) :: target_density - !> Maximum depths of interfaces + !> Maximum depths of interfaces [H ~> m or kg m-2]. real, allocatable, dimension(:) :: max_interface_depths - !> Maximum thicknesses of layers + !> Maximum thicknesses of layers [H ~> m or kg m-2]. real, allocatable, dimension(:) :: max_layer_thickness !> Interpolation control structure @@ -70,25 +69,40 @@ module coord_slight contains !> Initialise a slight_CS with pointers to parameters -subroutine init_coord_slight(CS, nk, ref_pressure, target_density, interp_CS) +subroutine init_coord_slight(CS, nk, ref_pressure, target_density, interp_CS, m_to_H) type(slight_CS), pointer :: CS !< Unassociated pointer to hold the control structure - integer, intent(in) :: nk - real, intent(in) :: ref_pressure - real, dimension(:), intent(in) :: target_density - type(interp_CS_type), intent(in) :: interp_CS + integer, intent(in) :: nk !< Number of layers in the grid + real, intent(in) :: ref_pressure !< Coordinate reference pressure [Pa] + real, dimension(:), intent(in) :: target_density !< Nominal density of interfaces [kg m-3] + type(interp_CS_type), intent(in) :: interp_CS !< Controls for interpolation + real, optional, intent(in) :: m_to_H !< A conversion factor from m to the units of thicknesses + + real :: m_to_H_rescale ! A unit conversion factor. if (associated(CS)) call MOM_error(FATAL, "init_coord_slight: CS already associated!") allocate(CS) allocate(CS%target_density(nk+1)) + m_to_H_rescale = 1.0 ; if (present(m_to_H)) m_to_H_rescale = m_to_H + CS%nk = nk CS%ref_pressure = ref_pressure CS%target_density(:) = target_density(:) CS%interp_CS = interp_CS + + ! Set real parameter default values + CS%compressibility_fraction = 0. ! Nondim. + CS%Rho_ML_avg_depth = 1.0 * m_to_H_rescale + CS%nlay_ml_offset = 2.0 ! Nondim. + CS%dz_ml_min = 1.0 * m_to_H_rescale + CS%halocline_filter_length = 2.0 * m_to_H_rescale + CS%halocline_strat_tol = 0.25 ! Nondim. + end subroutine init_coord_slight +!> This subroutine deallocates memory in the control structure for the coord_slight module subroutine end_coord_slight(CS) - type(slight_CS), pointer :: CS + type(slight_CS), pointer :: CS !< Coordinate control structure ! nothing to do if (.not. associated(CS)) return @@ -96,23 +110,37 @@ subroutine end_coord_slight(CS) deallocate(CS) end subroutine end_coord_slight +!> This subroutine can be used to set the parameters for the coord_slight module subroutine set_slight_params(CS, max_interface_depths, max_layer_thickness, & - min_thickness, compressibility_fraction, & - dz_ml_min, nz_fixed_surface, Rho_ML_avg_depth, nlay_ML_offset, fix_haloclines, & - halocline_filter_length, halocline_strat_tol, interp_CS) - type(slight_CS), pointer :: CS - real, optional, dimension(:), intent(in) :: max_interface_depths - real, optional, dimension(:), intent(in) :: max_layer_thickness - real, optional, intent(in) :: min_thickness - real, optional, intent(in) :: compressibility_fraction - real, optional, intent(in) :: dz_ml_min - integer, optional, intent(in) :: nz_fixed_surface - real, optional, intent(in) :: Rho_ML_avg_depth - real, optional, intent(in) :: nlay_ML_offset - logical, optional, intent(in) :: fix_haloclines - real, optional, intent(in) :: halocline_filter_length - real, optional, intent(in) :: halocline_strat_tol - type(interp_CS_type), optional, intent(in) :: interp_CS + min_thickness, compressibility_fraction, dz_ml_min, & + nz_fixed_surface, Rho_ML_avg_depth, nlay_ML_offset, fix_haloclines, & + halocline_filter_length, halocline_strat_tol, interp_CS) + type(slight_CS), pointer :: CS !< Coordinate control structure + real, dimension(:), & + optional, intent(in) :: max_interface_depths !< Maximum depths of interfaces [H ~> m or kg m-2] + real, dimension(:), & + optional, intent(in) :: max_layer_thickness !< Maximum thicknesses of layers [H ~> m or kg m-2] + real, optional, intent(in) :: min_thickness !< Minimum thickness allowed when building the + !! new grid through regridding [H ~> m or kg m-2] + real, optional, intent(in) :: compressibility_fraction !< Fraction (between 0 and 1) of + !! compressibility to add to potential density profiles when + !! interpolating for target grid positions. [nondim] + real, optional, intent(in) :: dz_ml_min !< The fixed resolution in the topmost + !! SLight_nkml_min layers [H ~> m or kg m-2] + integer, optional, intent(in) :: nz_fixed_surface !< The number of fixed-thickness layers at the + !! top of the model + real, optional, intent(in) :: Rho_ML_avg_depth !< Depth over which to average to determine + !! the mixed layer potential density [H ~> m or kg m-2] + real, optional, intent(in) :: nlay_ML_offset !< Number of layers to offset the mixed layer + !! density to find resolved stratification [nondim] + logical, optional, intent(in) :: fix_haloclines !< If true, detect regions with much weaker than + !! based on in-situ density, and use a stretched coordinate there. + real, optional, intent(in) :: halocline_filter_length !< A length scale over which to filter T & S + !! when looking for spuriously unstable water mass profiles [H ~> m or kg m-2]. + real, optional, intent(in) :: halocline_strat_tol !< A value of the stratification ratio that + !! defines a problematic halocline region [nondim]. + type(interp_CS_type), & + optional, intent(in) :: interp_CS !< Controls for interpolation if (.not. associated(CS)) call MOM_error(FATAL, "set_slight_params: CS not associated") @@ -149,28 +177,25 @@ subroutine set_slight_params(CS, max_interface_depths, max_layer_thickness, & end subroutine set_slight_params !> Build a SLight coordinate column -subroutine build_slight_column(CS, eqn_of_state, H_to_Pa, m_to_H, H_subroundoff, & +subroutine build_slight_column(CS, eqn_of_state, H_to_Pa, H_subroundoff, & nz, depth, h_col, T_col, S_col, p_col, z_col, z_col_new, & h_neglect, h_neglect_edge) - type(slight_CS), intent(in) :: CS !< Coordinate control structure + type(slight_CS), intent(in) :: CS !< Coordinate control structure type(EOS_type), pointer :: eqn_of_state !< Equation of state structure real, intent(in) :: H_to_Pa !< GV%H_to_Pa - real, intent(in) :: m_to_H !< GV%m_to_H real, intent(in) :: H_subroundoff !< GV%H_subroundoff - integer, intent(in) :: nz !< Number of levels - real, intent(in) :: depth !< Depth of ocean bottom (positive in m) - real, dimension(nz), intent(in) :: T_col, S_col !< T and S for column - real, dimension(nz), intent(in) :: h_col !< Layer thicknesses, in m + integer, intent(in) :: nz !< Number of levels + real, intent(in) :: depth !< Depth of ocean bottom (positive [H ~> m or kg m-2]) + real, dimension(nz), intent(in) :: T_col !< T for column + real, dimension(nz), intent(in) :: S_col !< S for column + real, dimension(nz), intent(in) :: h_col !< Layer thicknesses [H ~> m or kg m-2] real, dimension(nz), intent(in) :: p_col !< Layer quantities - real, dimension(nz+1), intent(in) :: z_col !< Interface positions relative to the surface in H units (m or kg m-2) - real, dimension(nz+1), intent(inout) :: z_col_new !< Absolute positions of interfaces - real, optional, intent(in) :: h_neglect !< A negligibly small width for the - !! purpose of cell reconstructions - !! in the same units as h_col. - real, optional, intent(in) :: h_neglect_edge !< A negligibly small width - !! for the purpose of edge value calculations - !! in the same units as h_col. - + real, dimension(nz+1), intent(in) :: z_col !< Interface positions relative to the surface [H ~> m or kg m-2] + real, dimension(nz+1), intent(inout) :: z_col_new !< Absolute positions of interfaces [H ~> m or kg m-2] + real, optional, intent(in) :: h_neglect !< A negligibly small width for the purpose of + !! cell reconstructions [H ~> m or kg m-2]. + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width for the purpose + !! of edge value calculations [H ~> m or kg m-2]. ! Local variables real, dimension(nz) :: rho_col ! Layer quantities real, dimension(nz) :: T_f, S_f ! Filtered ayer quantities @@ -183,20 +208,20 @@ subroutine build_slight_column(CS, eqn_of_state, H_to_Pa, m_to_H, H_subroundoff, real :: H_to_cPa real :: drIS, drR, Fn_now, I_HStol, Fn_zero_val real :: z_int_unst - real :: dz ! A uniform layer thickness in very shallow water, in H. - real :: dz_ur ! The total thickness of an unstable region, in H. + real :: dz ! A uniform layer thickness in very shallow water [H ~> m or kg m-2]. + real :: dz_ur ! The total thickness of an unstable region [H ~> m or kg m-2]. real :: wgt, cowgt ! A weight and its complement, nondim. - real :: rho_ml_av ! The average potential density in a near-surface region, in kg m-3. - real :: H_ml_av ! A thickness to try to use in taking the near-surface average, in H. - real :: rho_x_z ! A cumulative integral of a density, in kg m-3 H. - real :: z_wt ! The thickness actually used in taking the near-surface average, in H. + real :: rho_ml_av ! The average potential density in a near-surface region [kg m-3]. + real :: H_ml_av ! A thickness to try to use in taking the near-surface average [H ~> m or kg m-2]. + real :: rho_x_z ! A cumulative integral of a density [kg m-3 H ~> kg m-2 or kg2 m-5]. + real :: z_wt ! The thickness actually used in taking the near-surface average [H ~> m or kg m-2]. real :: k_interior ! The (real) value of k where the interior grid starts. real :: k_int2 ! The (real) value of k where the interior grid starts. - real :: z_interior ! The depth where the interior grid starts, in H. - real :: z_ml_fix ! The depth at which the fixed-thickness near-surface layers end, in H. + real :: z_interior ! The depth where the interior grid starts [H ~> m or kg m-2]. + real :: z_ml_fix ! The depth at which the fixed-thickness near-surface layers end [H ~> m or kg m-2]. real :: dz_dk ! The thickness of layers between the fixed-thickness - ! near-surface layars and the interior, in H. - real :: Lfilt ! A filtering lengthscale, in H. + ! near-surface layars and the interior [H ~> m or kg m-2]. + real :: Lfilt ! A filtering lengthscale [H ~> m or kg m-2]. logical :: maximum_depths_set ! If true, the maximum depths of interface have been set. logical :: maximum_h_set ! If true, the maximum layer thicknesses have been set. real :: k2_used, k2here, dz_sum, z_max @@ -268,7 +293,7 @@ subroutine build_slight_column(CS, eqn_of_state, H_to_Pa, m_to_H, H_subroundoff, ! Determine which interfaces are in the s-space region and the depth extent ! of this region. z_wt = 0.0 ; rho_x_z = 0.0 - H_ml_av = m_to_H*CS%Rho_ml_avg_depth + H_ml_av = CS%Rho_ml_avg_depth do k=1,nz if (z_wt + h_col(k) >= H_ml_av) then rho_x_z = rho_x_z + rho_col(k) * (H_ml_av - z_wt) @@ -309,7 +334,7 @@ subroutine build_slight_column(CS, eqn_of_state, H_to_Pa, m_to_H, H_subroundoff, ! ! z_int_unst and k_interior. if (CS%halocline_filter_length > 0.0) then - Lfilt = CS%halocline_filter_length*m_to_H + Lfilt = CS%halocline_filter_length ! Filter the temperature and salnity with a fixed lengthscale. h_tr = h_col(1) + H_subroundoff @@ -478,7 +503,7 @@ subroutine rho_interfaces_col(rho_col, h_col, z_col, rho_tgt, nz, z_col_new, & real, dimension(nz,DEGREE_MAX+1) :: ppoly_i_coefficients ! Coefficients of polynomial logical, dimension(nz) :: unstable_lay ! If true, this layer is in an unstable region. logical, dimension(nz+1) :: unstable_int ! If true, this interface is in an unstable region. - real :: rt ! The current target density, in kg m-3. + real :: rt ! The current target density [kg m-3]. real :: zf ! The fractional z-position within a layer of the target density. real :: rfn real :: a(5) ! Coefficients of a local polynomial minus the target density. diff --git a/src/ALE/coord_zlike.F90 b/src/ALE/coord_zlike.F90 index ca68aa7b0b..1f4949431d 100644 --- a/src/ALE/coord_zlike.F90 +++ b/src/ALE/coord_zlike.F90 @@ -13,11 +13,11 @@ module coord_zlike !> Number of levels to be generated integer :: nk - !> Minimum thickness allowed for layers, in the same thickness units that will - !! be used in all subsequent calls to build_zstar_column with this structure. + !> Minimum thickness allowed for layers, in the same thickness units (perhaps [H ~> m or kg m-2]) + !! that will be used in all subsequent calls to build_zstar_column with this structure. real :: min_thickness - !> Target coordinate resolution, usually in m + !> Target coordinate resolution, usually in [Z ~> m] real, allocatable, dimension(:) :: coordinateResolution end type zlike_CS @@ -28,8 +28,8 @@ module coord_zlike !> Initialise a zlike_CS with pointers to parameters subroutine init_coord_zlike(CS, nk, coordinateResolution) type(zlike_CS), pointer :: CS !< Unassociated pointer to hold the control structure - integer, intent(in) :: nk - real, dimension(:), intent(in) :: coordinateResolution + integer, intent(in) :: nk !< Number of levels in the grid + real, dimension(:), intent(in) :: coordinateResolution !< Target coordinate resolution [Z ~> m] if (associated(CS)) call MOM_error(FATAL, "init_coord_zlike: CS already associated!") allocate(CS) @@ -52,7 +52,7 @@ end subroutine end_coord_zlike !> Set parameters in the zlike structure subroutine set_zlike_params(CS, min_thickness) type(zlike_CS), pointer :: CS !< Coordinate control structure - real, optional, intent(in) :: min_thickness !< Minimum allowed thickness + real, optional, intent(in) :: min_thickness !< Minimum allowed thickness [H ~> m or kg m-2] if (.not. associated(CS)) call MOM_error(FATAL, "set_zlike_params: CS not associated") @@ -63,13 +63,15 @@ end subroutine set_zlike_params subroutine build_zstar_column(CS, depth, total_thickness, zInterface, & z_rigid_top, eta_orig, zScale) type(zlike_CS), intent(in) :: CS !< Coordinate control structure - real, intent(in) :: depth !< Depth of ocean bottom (positive in m or H) + real, intent(in) :: depth !< Depth of ocean bottom (positive in the output units) real, intent(in) :: total_thickness !< Column thickness (positive in the same units as depth) real, dimension(CS%nk+1), intent(inout) :: zInterface !< Absolute positions of interfaces - real, optional, intent(in) :: z_rigid_top !< The height of a rigid top (negative in the same units as depth) - real, optional, intent(in) :: eta_orig !< The actual original height of the top in the same units as depth + real, optional, intent(in) :: z_rigid_top !< The height of a rigid top (negative in the + !! same units as depth) + real, optional, intent(in) :: eta_orig !< The actual original height of the top in the + !! same units as depth real, optional, intent(in) :: zScale !< Scaling factor from the target coordinate resolution - !! in m to desired units for zInterface, perhaps m_to_H + !! in Z to desired units for zInterface, perhaps Z_to_H ! Local variables real :: eta, stretching, dh, min_thickness, z0_top, z_star, z_scale integer :: k diff --git a/src/ALE/polynomial_functions.F90 b/src/ALE/polynomial_functions.F90 index b0d5d135d5..e5c90fe31d 100644 --- a/src/ALE/polynomial_functions.F90 +++ b/src/ALE/polynomial_functions.F90 @@ -1,135 +1,109 @@ +!> Polynomial functions module polynomial_functions ! This file is part of MOM6. See LICENSE.md for the license. -!============================================================================== -! -! Date of creation: 2008.06.12 -! L. White -! -! This module contains routines that handle polynomials. -! -!============================================================================== - implicit none ; private public :: evaluation_polynomial, integration_polynomial, first_derivative_polynomial -! ----------------------------------------------------------------------------- -! This module contains the following routines -! ----------------------------------------------------------------------------- contains -! ----------------------------------------------------------------------------- -! Pointwise evaluation of a polynomial -! ----------------------------------------------------------------------------- -real function evaluation_polynomial( coefficients, nb_coefficients, x ) -! ----------------------------------------------------------------------------- -! The polynomial is defined by the coefficients contained in the -! array of the same name, as follows: C(1) + C(2)x + C(3)x^2 + C(4)x^3 + ... -! where C refers to the array 'coefficients'. -! The number of coefficients is given by nb_coefficients and x -! is the coordinate where the polynomial is to be evaluated. -! -! The function returns the value of the polynomial at x. -! ----------------------------------------------------------------------------- - - ! Arguments - real, dimension(:), intent(in) :: coefficients - integer, intent(in) :: nb_coefficients - real, intent(in) :: x - +!> Pointwise evaluation of a polynomial at x +!! +!! The polynomial is defined by the coefficients contained in the +!! array of the same name, as follows: C(1) + C(2)x + C(3)x^2 + C(4)x^3 + ... +!! where C refers to the array 'coeff'. +!! The number of coefficients is given by ncoef and x +!! is the coordinate where the polynomial is to be evaluated. +real function evaluation_polynomial( coeff, ncoef, x ) + real, dimension(:), intent(in) :: coeff !< The coefficients of the polynomial + integer, intent(in) :: ncoef !< The number of polynomial coefficients + real, intent(in) :: x !< The position at which to evaluate the polynomial ! Local variables - integer :: k - real :: f ! value of polynomial at x + integer :: k + real :: f ! value of polynomial at x f = 0.0 - do k = 1,nb_coefficients - f = f + coefficients(k) * ( x**(k-1) ) - end do + do k = 1,ncoef + f = f + coeff(k) * ( x**(k-1) ) + enddo evaluation_polynomial = f end function evaluation_polynomial -!> Calculates the first derivative of a polynomial with coefficients as above -!! evaluated at a point x -real function first_derivative_polynomial( coefficients, nb_coefficients, x ) -! ----------------------------------------------------------------------------- -! The polynomial is defined by the coefficients contained in the -! array of the same name, as follows: C(1) + C(2)x + C(3)x^2 + C(4)x^3 + ... -! where C refers to the array 'coefficients'. -! The number of coefficients is given by nb_coefficients and x -! is the coordinate where the polynomial's derivative is to be evaluated. -! -! The function returns the value of the polynomial at x. -! ----------------------------------------------------------------------------- - - ! Arguments - real, dimension(:), intent(in) :: coefficients - integer, intent(in) :: nb_coefficients - real, intent(in) :: x - +!> Calculates the first derivative of a polynomial evaluated at a point x +!! +!! The polynomial is defined by the coefficients contained in the +!! array of the same name, as follows: C(1) + C(2)x + C(3)x^2 + C(4)x^3 + ... +!! where C refers to the array 'coeff'. +!! The number of coefficients is given by ncoef and x +!! is the coordinate where the polynomial's derivative is to be evaluated. +real function first_derivative_polynomial( coeff, ncoef, x ) + real, dimension(:), intent(in) :: coeff !< The coefficients of the polynomial + integer, intent(in) :: ncoef !< The number of polynomial coefficients + real, intent(in) :: x !< The position at which to evaluate the derivative ! Local variables integer :: k real :: f ! value of polynomial at x f = 0.0 - do k = 2,nb_coefficients - f = f + REAL(k-1)*coefficients(k) * ( x**(k-2) ) - end do + do k = 2,ncoef + f = f + REAL(k-1)*coeff(k) * ( x**(k-2) ) + enddo first_derivative_polynomial = f end function first_derivative_polynomial -! ----------------------------------------------------------------------------- -! Exact integration of polynomial of degree n -! ----------------------------------------------------------------------------- -real function integration_polynomial( xi0, xi1, C, n ) -! ----------------------------------------------------------------------------- -! Exact integration of a polynomial of degree n over the interval [xi0,xi1]. -! The array of coefficients (C) must be of size n+1, where n is the degree of -! the polynomial to integrate. -! ----------------------------------------------------------------------------- - - ! Arguments - real, intent(in) :: xi0, xi1 - real, dimension(:), intent(in) :: C - integer, intent(in) :: n - +!> Exact integration of polynomial of degree npoly +!! +!! The array of coefficients (Coeff) must be of size npoly+1. +real function integration_polynomial( xi0, xi1, Coeff, npoly ) + real, intent(in) :: xi0 !< The lower bound of the integral + real, intent(in) :: xi1 !< The lower bound of the integral + real, dimension(:), intent(in) :: Coeff !< The coefficients of the polynomial + integer, intent(in) :: npoly !< The degree of the polynomial ! Local variables integer :: k real :: integral integral = 0.0 - do k = 1,(n+1) - integral = integral + C(k) * (xi1**k - xi0**k) / real(k) - end do + do k = 1,npoly+1 + integral = integral + Coeff(k) * (xi1**k - xi0**k) / real(k) + enddo ! !One non-answer-changing way of unrolling the above is: ! k=1 -! integral = integral + C(k) * (xi1**k - xi0**k) / real(k) -! if (n>=1) then +! integral = integral + Coeff(k) * (xi1**k - xi0**k) / real(k) +! if (npoly>=1) then ! k=2 -! integral = integral + C(k) * (xi1**k - xi0**k) / real(k) +! integral = integral + Coeff(k) * (xi1**k - xi0**k) / real(k) ! endif -! if (n>=2) then +! if (npoly>=2) then ! k=3 -! integral = integral + C(k) * (xi1**k - xi0**k) / real(k) +! integral = integral + Coeff(k) * (xi1**k - xi0**k) / real(k) ! endif -! if (n>=3) then +! if (npoly>=3) then ! k=4 -! integral = integral + C(k) * (xi1**k - xi0**k) / real(k) +! integral = integral + Coeff(k) * (xi1**k - xi0**k) / real(k) ! endif -! if (n>=4) then +! if (npoly>=4) then ! k=5 -! integral = integral + C(k) * (xi1**k - xi0**k) / real(k) +! integral = integral + Coeff(k) * (xi1**k - xi0**k) / real(k) ! endif ! integration_polynomial = integral end function integration_polynomial +!> \namespace polynomial_functions +!! +!! Date of creation: 2008.06.12 +!! L. White +!! +!! This module contains routines that handle polynomials. + end module polynomial_functions diff --git a/src/ALE/regrid_consts.F90 b/src/ALE/regrid_consts.F90 index cf5623c754..7e8edea344 100644 --- a/src/ALE/regrid_consts.F90 +++ b/src/ALE/regrid_consts.F90 @@ -8,20 +8,19 @@ module regrid_consts implicit none ; public -integer, parameter :: REGRIDDING_NUM_TYPES = 2 - ! List of regridding types. These should be consecutive and starting at 1. ! This allows them to be used as array indices. -integer, parameter :: REGRIDDING_LAYER = 1 !< Layer mode -integer, parameter :: REGRIDDING_ZSTAR = 2 !< z* coordinates -integer, parameter :: REGRIDDING_RHO = 3 !< Target interface densities -integer, parameter :: REGRIDDING_SIGMA = 4 !< Sigma coordinates -integer, parameter :: REGRIDDING_ARBITRARY = 5 !< Arbitrary coordinates +integer, parameter :: REGRIDDING_LAYER = 1 !< Layer mode identifier +integer, parameter :: REGRIDDING_ZSTAR = 2 !< z* coordinates identifier +integer, parameter :: REGRIDDING_RHO = 3 !< Density coordinates identifier +integer, parameter :: REGRIDDING_SIGMA = 4 !< Sigma coordinates identifier +integer, parameter :: REGRIDDING_ARBITRARY = 5 !< Arbitrary coordinates identifier integer, parameter :: REGRIDDING_HYCOM1 = 6 !< Simple HyCOM coordinates without BBL -integer, parameter :: REGRIDDING_SLIGHT = 7 !< Stretched coordinates in the -integer, parameter :: REGRIDDING_SIGMA_SHELF_ZSTAR = 8 !< z* coordinates at the bottom, sigma-near the top +integer, parameter :: REGRIDDING_SLIGHT = 7 !< Identifier for stretched coordinates in the !! lightest water, isopycnal below -integer, parameter :: REGRIDDING_ADAPTIVE = 9 +integer, parameter :: REGRIDDING_SIGMA_SHELF_ZSTAR = 8 !< Identifiered for z* coordinates at the bottom, + !! sigma-near the top +integer, parameter :: REGRIDDING_ADAPTIVE = 9 !< Adaptive coordinate mode identifier character(len=*), parameter :: REGRIDDING_LAYER_STRING = "LAYER" !< Layer string character(len=*), parameter :: REGRIDDING_ZSTAR_STRING_OLD = "Z*" !< z* string (legacy name) @@ -32,26 +31,16 @@ module regrid_consts character(len=*), parameter :: REGRIDDING_HYCOM1_STRING = "HYCOM1" !< Hycom string character(len=*), parameter :: REGRIDDING_SLIGHT_STRING = "SLIGHT" !< Hybrid S-rho string character(len=*), parameter :: REGRIDDING_SIGMA_SHELF_ZSTAR_STRING = "SIGMA_SHELF_ZSTAR" !< Hybrid z*/sigma -character(len=*), parameter :: REGRIDDING_ADAPTIVE_STRING = "ADAPTIVE" +character(len=*), parameter :: REGRIDDING_ADAPTIVE_STRING = "ADAPTIVE" !< Adaptive coordinate string character(len=*), parameter :: DEFAULT_COORDINATE_MODE = REGRIDDING_LAYER_STRING !< Default coordinate mode -integer, dimension(REGRIDDING_NUM_TYPES), parameter :: vertical_coords = & - (/ REGRIDDING_LAYER, REGRIDDING_ZSTAR /) - !(/ REGRIDDING_LAYER, REGRIDDING_ZSTAR, REGRIDDING_RHO, & - ! REGRIDDING_SIGMA, REGRIDDING_ARBITRARY, & - ! REGRIDDING_HYCOM1, REGRIDDING_SLIGHT /) - -character(len=*), dimension(REGRIDDING_NUM_TYPES), parameter :: vertical_coord_strings = & - (/ REGRIDDING_LAYER_STRING, REGRIDDING_ZSTAR_STRING /) - !(/ REGRIDDING_LAYER_STRING, REGRIDDING_ZSTAR_STRING, REGRIDDING_RHO_STRING, & - ! REGRIDDING_SIGMA_STRING, REGRIDDING_ARBITRARY_STRING, & - ! REGRIDDING_HYCOM1_STRING, REGRIDDING_SLIGHT_STRING /) - +!> Returns a string with the coordinate units associated with the coordinate mode. interface coordinateUnits module procedure coordinateUnitsI module procedure coordinateUnitsS end interface +!> Returns true if the coordinate is dependent on the state density, returns false otherwise. interface state_dependent module procedure state_dependent_char module procedure state_dependent_int diff --git a/src/ALE/regrid_edge_slopes.F90 b/src/ALE/regrid_edge_slopes.F90 index f8781aa937..c22a524683 100644 --- a/src/ALE/regrid_edge_slopes.F90 +++ b/src/ALE/regrid_edge_slopes.F90 @@ -1,72 +1,58 @@ +!> Routines that estimate edge slopes to be used in +!! high-order reconstruction schemes. module regrid_edge_slopes ! This file is part of MOM6. See LICENSE.md for the license. -!============================================================================== -! -! Date of creation: 2008.06.09 -! L. White -! -! This module contains routines that estimate edge slopes to be used in -! high-order reconstruction schemes. -! -!============================================================================== use regrid_solvers, only : solve_linear_system, solve_tridiagonal_system use polynomial_functions, only : evaluation_polynomial - implicit none ; private -! ----------------------------------------------------------------------------- -! The following routines are visible to the outside world -! ----------------------------------------------------------------------------- public edge_slopes_implicit_h3 public edge_slopes_implicit_h5 -! Specifying a dimensional parameter value, as is done here, is a terrible idea. -real, parameter :: hNeglect_dflt = 1.E-30 +! Specifying a dimensional parameter value, as is done here, is a terrible idea. +real, parameter :: hNeglect_dflt = 1.E-30 !< Default negligible cell thickness contains - !------------------------------------------------------------------------------ !> Compute ih4 edge slopes (implicit third order accurate) +!! in the same units as h. +!! +!! Compute edge slopes based on third-order implicit estimates. Note that +!! the estimates are fourth-order accurate on uniform grids +!! +!! Third-order implicit estimates of edge slopes are based on a two-cell +!! stencil. A tridiagonal system is set up and is based on expressing the +!! edge slopes in terms of neighboring cell averages. The generic +!! relationship is +!! +!! \f[ +!! \alpha u'_{i-1/2} + u'_{i+1/2} + \beta u'_{i+3/2} = +!! a \bar{u}_i + b \bar{u}_{i+1} +!! \f] +!! +!! and the stencil looks like this +!! +!! i i+1 +!! ..--o------o------o--.. +!! i-1/2 i+1/2 i+3/2 +!! +!! In this routine, the coefficients \f$\alpha\f$, \f$\beta\f$, a and b are computed, +!! the tridiagonal system is built, boundary conditions are prescribed and +!! the system is solved to yield edge-slope estimates. +!! +!! There are N+1 unknowns and we are able to write N-1 equations. The +!! boundary conditions close the system. subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect ) -! ----------------------------------------------------------------------------- -! Compute edge slopes based on third-order implicit estimates. Note that -! the estimates are fourth-order accurate on uniform grids -! -! Third-order implicit estimates of edge slopes are based on a two-cell -! stencil. A tridiagonal system is set up and is based on expressing the -! edge slopes in terms of neighboring cell averages. The generic -! relationship is -! -! \alpha u'_{i-1/2} + u'_{i+1/2} + \beta u'_{i+3/2} = -! a \bar{u}_i + b \bar{u}_{i+1} -! -! and the stencil looks like this -! -! i i+1 -! ..--o------o------o--.. -! i-1/2 i+1/2 i+3/2 -! -! In this routine, the coefficients \alpha, \beta, a and b are computed, -! the tridiagonal system is built, boundary conditions are prescribed and -! the system is solved to yield edge-slope estimates. -! -! There are N+1 unknowns and we are able to write N-1 equations. The -! boundary conditions close the system. -! ----------------------------------------------------------------------------- - - ! Arguments integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) real, dimension(:), intent(in) :: u !< cell average properties (size N) real, dimension(:,:), intent(inout) :: edge_slopes !< Returned edge slopes, with the !! same units as u divided by the units of h. real, optional, intent(in) :: h_neglect !< A negligibly small width - !! in the same units as h. - ! Local variables integer :: i, j ! loop indexes real :: h0, h1 ! cell widths @@ -118,23 +104,23 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect ) tri_b(i+1) = a * u(i) + b * u(i+1) - end do ! end loop on cells + enddo ! end loop on cells ! Boundary conditions: left boundary x(1) = 0.0 do i = 2,5 x(i) = x(i-1) + h(i-1) - end do + enddo do i = 1,4 do j = 1,4 Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j - end do + enddo Bsys(i) = u(i) * ( h(i) ) - end do + enddo call solve_linear_system( Asys, Bsys, Csys, 4 ) @@ -150,17 +136,17 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect ) x(1) = 0.0 do i = 2,5 x(i) = x(i-1) + h(N-5+i) - end do + enddo do i = 1,4 do j = 1,4 Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j - end do + enddo Bsys(i) = u(N-4+i) * ( h(N-4+i) ) - end do + enddo call solve_linear_system( Asys, Bsys, Csys, 4 ) @@ -178,7 +164,7 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect ) do i = 2,N edge_slopes(i,1) = tri_x(i) edge_slopes(i-1,2) = tri_x(i) - end do + enddo edge_slopes(1,1) = tri_x(1) edge_slopes(N,2) = tri_x(N+1) @@ -188,6 +174,13 @@ end subroutine edge_slopes_implicit_h3 !------------------------------------------------------------------------------ !> Compute ih5 edge values (implicit fifth order accurate) subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect ) + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell average properties (size N) + real, dimension(:,:), intent(inout) :: edge_slopes !< Returned edge slopes, with the + !! same units as u divided by the units of h. + real, optional, intent(in) :: h_neglect !< A negligibly small width + !! in the same units as h. ! ----------------------------------------------------------------------------- ! Fifth-order implicit estimates of edge values are based on a four-cell, ! three-edge stencil. A tridiagonal system is set up and is based on @@ -221,15 +214,6 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect ) ! on nonuniform meshes turned out to be intractable. ! ----------------------------------------------------------------------------- - ! Arguments - integer, intent(in) :: N !< Number of cells - real, dimension(:), intent(in) :: h !< cell widths (size N) - real, dimension(:), intent(in) :: u !< cell average properties (size N) - real, dimension(:,:), intent(inout) :: edge_slopes !< Returned edge slopes, with the - !! same units as u divided by the units of h. - real, optional, intent(in) :: h_neglect !< A negligibly small width - !! in the same units as h. - ! Local variables integer :: i, j, k ! loop indexes real :: h0, h1, h2, h3 ! cell widths @@ -368,7 +352,7 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect ) tri_u(k+1) = beta tri_b(k+1) = a * u(k-1) + b * u(k) + c * u(k+1) + d * u(k+2) - end do ! end loop on cells + enddo ! end loop on cells ! Use a right-biased stencil for the second row @@ -485,17 +469,17 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect ) x(1) = 0.0 do i = 2,7 x(i) = x(i-1) + h(i-1) - end do + enddo do i = 1,6 do j = 1,6 Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j - end do + enddo Bsys(i) = u(i) * h(i) - end do + enddo call solve_linear_system( Asys, Bsys, Csys, 6 ) @@ -625,17 +609,17 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect ) x(1) = 0.0 do i = 2,7 x(i) = x(i-1) + h(N-7+i) - end do + enddo do i = 1,6 do j = 1,6 Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j - end do + enddo Bsys(i) = u(N-6+i) * h(N-6+i) - end do + enddo call solve_linear_system( Asys, Bsys, Csys, 6 ) @@ -656,7 +640,7 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect ) do i = 2,N edge_slopes(i,1) = tri_x(i) edge_slopes(i-1,2) = tri_x(i) - end do + enddo edge_slopes(1,1) = tri_x(1) edge_slopes(N,2) = tri_x(N+1) diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index fafb873a6c..d27d69153c 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -1,16 +1,8 @@ +!> Edge value estimation for high-order resconstruction module regrid_edge_values ! This file is part of MOM6. See LICENSE.md for the license. -!============================================================================== -! -! Date of creation: 2008.06.09 -! L. White -! -! This module contains routines that estimate edge values to be used in -! high-order reconstruction schemes. -! -!============================================================================== use regrid_solvers, only : solve_linear_system, solve_tridiagonal_system use polynomial_functions, only : evaluation_polynomial @@ -34,38 +26,32 @@ module regrid_edge_values ! to a small enough values such that the eigenvalues of the matrix can not ! be separated. ! Specifying a dimensional parameter value, as is done here, is a terrible idea. -real, parameter :: hNeglect_edge_dflt = 1.e-10 ! The default value for cut-off minimum - ! thickness for sum(h) in edge value inversions -real, parameter :: hNeglect_dflt = 1.e-30 ! The default value for cut-off minimum - ! thickness for sum(h) in other calculations -real, parameter :: hMinFrac = 1.e-5 ! A minimum fraction for min(h)/sum(h) +real, parameter :: hNeglect_edge_dflt = 1.e-10 !< The default value for cut-off minimum + !! thickness for sum(h) in edge value inversions +real, parameter :: hNeglect_dflt = 1.e-30 !< The default value for cut-off minimum + !! thickness for sum(h) in other calculations +real, parameter :: hMinFrac = 1.e-5 !< A minimum fraction for min(h)/sum(h) contains -!------------------------------------------------------------------------------ -! Bound edge values by neighboring cell averages -!------------------------------------------------------------------------------ -subroutine bound_edge_values( N, h, u, edge_values, h_neglect ) -! ------------------------------------------------------------------------------ -! In this routine, we loop on all cells to bound their left and right -! edge values by the cell averages. That is, the left edge value must lie -! between the left cell average and the central cell average. A similar -! reasoning applies to the right edge values. -! -! Both boundary edge values are set equal to the boundary cell averages. -! Any extrapolation scheme is applied after this routine has been called. -! Therefore, boundary cells are treated as if they were local extrama. -! ------------------------------------------------------------------------------ - - ! Arguments +!> Bound edge values by neighboring cell averages +!! +!! In this routine, we loop on all cells to bound their left and right +!! edge values by the cell averages. That is, the left edge value must lie +!! between the left cell average and the central cell average. A similar +!! reasoning applies to the right edge values. +!! +!! Both boundary edge values are set equal to the boundary cell averages. +!! Any extrapolation scheme is applied after this routine has been called. +!! Therefore, boundary cells are treated as if they were local extrama. +subroutine bound_edge_values( N, h, u, edge_val, h_neglect ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) real, dimension(:), intent(in) :: u !< cell average properties (size N) - real, dimension(:,:), intent(inout) :: edge_values !< Potentially modified edge values, + real, dimension(:,:), intent(inout) :: edge_val !< Potentially modified edge values, !! with the same units as u. real, optional, intent(in) :: h_neglect !< A negligibly small width !! in the same units as h. - ! Local variables integer :: k ! loop index integer :: k0, k1, k2 @@ -88,11 +74,11 @@ subroutine bound_edge_values( N, h, u, edge_values, h_neglect ) ! boundary cell and the right neighbor of the right boundary cell ! is assumed to be the same as the right boundary cell. This ! effectively makes boundary cells look like extrema. - if ( k .EQ. 1 ) then + if ( k == 1 ) then k0 = 1 k1 = 1 k2 = 2 - else if ( k .EQ. N ) then + elseif ( k == N ) then k0 = N-1 k1 = N k2 = N @@ -100,7 +86,7 @@ subroutine bound_edge_values( N, h, u, edge_values, h_neglect ) k0 = k-1 k1 = k k2 = k+1 - end if + endif ! All cells can now be treated equally h_l = h(k0) @@ -111,18 +97,18 @@ subroutine bound_edge_values( N, h, u, edge_values, h_neglect ) u_c = u(k1) u_r = u(k2) - u0_l = edge_values(k,1) - u0_r = edge_values(k,2) + u0_l = edge_val(k,1) + u0_r = edge_val(k,2) sigma_l = 2.0 * ( u_c - u_l ) / ( h_c + hNeglect ) sigma_c = 2.0 * ( u_r - u_l ) / ( h_l + 2.0*h_c + h_r + hNeglect ) sigma_r = 2.0 * ( u_r - u_c ) / ( h_c + hNeglect ) - if ( (sigma_l * sigma_r) .GT. 0.0 ) then + if ( (sigma_l * sigma_r) > 0.0 ) then slope = sign( min(abs(sigma_l),abs(sigma_c),abs(sigma_r)), sigma_c ) else slope = 0.0 - end if + endif ! The limiter must be used in the local coordinate system to each cell. ! Hence, we must multiply the slope by h1. The multiplication by 0.5 is @@ -130,40 +116,34 @@ subroutine bound_edge_values( N, h, u, edge_values, h_neglect ) ! JCP 2008 Eqs 19 and 20) slope = slope * h_c * 0.5 - if ( (u_l-u0_l)*(u0_l-u_c) .LT. 0.0 ) then + if ( (u_l-u0_l)*(u0_l-u_c) < 0.0 ) then u0_l = u_c - sign( min( abs(slope), abs(u0_l-u_c) ), slope ) - end if + endif - if ( (u_r-u0_r)*(u0_r-u_c) .LT. 0.0 ) then + if ( (u_r-u0_r)*(u0_r-u_c) < 0.0 ) then u0_r = u_c + sign( min( abs(slope), abs(u0_r-u_c) ), slope ) - end if + endif ! Finally bound by neighboring cell means in case of round off u0_l = max( min( u0_l, max(u_l, u_c) ), min(u_l, u_c) ) u0_r = max( min( u0_r, max(u_r, u_c) ), min(u_r, u_c) ) ! Store edge values - edge_values(k,1) = u0_l - edge_values(k,2) = u0_r + edge_val(k,1) = u0_l + edge_val(k,2) = u0_r - end do ! loop on interior edges + enddo ! loop on interior edges end subroutine bound_edge_values - -!------------------------------------------------------------------------------ -! Average discontinuous edge values (systematically) -!------------------------------------------------------------------------------ -subroutine average_discontinuous_edge_values( N, edge_values ) -! ------------------------------------------------------------------------------ -! For each interior edge, check whether the edge values are discontinuous. -! If so, compute the average and replace the edge values by the average.! -! ------------------------------------------------------------------------------ - - ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:,:), intent(inout) :: edge_values - +!> Replace discontinuous collocated edge values with their average +!! +!! For each interior edge, check whether the edge values are discontinuous. +!! If so, compute the average and replace the edge values by the average. +subroutine average_discontinuous_edge_values( N, edge_val ) + integer, intent(in) :: N !< Number of cells + real, dimension(:,:), intent(inout) :: edge_val !< Edge values that may be modified + !! the second index size is 2. ! Local variables integer :: k ! loop index real :: u0_minus ! left value at given edge @@ -174,36 +154,29 @@ subroutine average_discontinuous_edge_values( N, edge_values ) do k = 1,N-1 ! Edge value on the left of the edge - u0_minus = edge_values(k,2) + u0_minus = edge_val(k,2) ! Edge value on the right of the edge - u0_plus = edge_values(k+1,1) + u0_plus = edge_val(k+1,1) - if ( u0_minus .NE. u0_plus ) then + if ( u0_minus /= u0_plus ) then u0_avg = 0.5 * ( u0_minus + u0_plus ) - edge_values(k,2) = u0_avg - edge_values(k+1,1) = u0_avg - end if + edge_val(k,2) = u0_avg + edge_val(k+1,1) = u0_avg + endif - end do ! end loop on interior edges + enddo ! end loop on interior edges end subroutine average_discontinuous_edge_values - -!------------------------------------------------------------------------------ -! Check discontinuous edge values and take average is not monotonic -!------------------------------------------------------------------------------ -subroutine check_discontinuous_edge_values( N, u, edge_values ) -! ------------------------------------------------------------------------------ -! For each interior edge, check whether the edge values are discontinuous. -! If so and if they are not monotonic, replace each edge value by their average. -! ------------------------------------------------------------------------------ - - ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: edge_values - +!> Check discontinuous edge values and replace them with their average if not monotonic +!! +!! For each interior edge, check whether the edge values are discontinuous. +!! If so and if they are not monotonic, replace each edge value by their average. +subroutine check_discontinuous_edge_values( N, u, edge_val ) + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: u !< cell averages (size N) + real, dimension(:,:), intent(inout) :: edge_val !< Cell edge values with the same units as u. ! Local variables integer :: k ! loop index real :: u0_minus ! left value at given edge @@ -216,10 +189,10 @@ subroutine check_discontinuous_edge_values( N, u, edge_values ) do k = 1,N-1 ! Edge value on the left of the edge - u0_minus = edge_values(k,2) + u0_minus = edge_val(k,2) ! Edge value on the right of the edge - u0_plus = edge_values(k+1,1) + u0_plus = edge_val(k+1,1) ! Left cell average um_minus = u(k) @@ -227,43 +200,38 @@ subroutine check_discontinuous_edge_values( N, u, edge_values ) ! Right cell average um_plus = u(k+1) - if ( (u0_plus - u0_minus)*(um_plus - um_minus) .LT. 0.0 ) then + if ( (u0_plus - u0_minus)*(um_plus - um_minus) < 0.0 ) then u0_avg = 0.5 * ( u0_minus + u0_plus ) u0_avg = max( min( u0_avg, max(um_minus, um_plus) ), min(um_minus, um_plus) ) - edge_values(k,2) = u0_avg - edge_values(k+1,1) = u0_avg - end if + edge_val(k,2) = u0_avg + edge_val(k+1,1) = u0_avg + endif - end do ! end loop on interior edges + enddo ! end loop on interior edges end subroutine check_discontinuous_edge_values -!------------------------------------------------------------------------------ !> Compute h2 edge values (explicit second order accurate) -subroutine edge_values_explicit_h2( N, h, u, edge_values, h_neglect ) -! ------------------------------------------------------------------------------ -! Compute edge values based on second-order explicit estimates. -! These estimates are based on a straight line spanning two cells and evaluated -! at the location of the middle edge. An interpolant spanning cells -! k-1 and k is evaluated at edge k-1/2. The estimate for each edge is unique. -! -! k-1 k -! ..--o------o------o--.. -! k-1/2 +!! in the same units as h. ! -! Boundary edge values are set to be equal to the boundary cell averages. -! ------------------------------------------------------------------------------ - - ! Arguments +!! Compute edge values based on second-order explicit estimates. +!! These estimates are based on a straight line spanning two cells and evaluated +!! at the location of the middle edge. An interpolant spanning cells +!! k-1 and k is evaluated at edge k-1/2. The estimate for each edge is unique. +!! +!! k-1 k +!! ..--o------o------o--.. +!! k-1/2 +!! +!! Boundary edge values are set to be equal to the boundary cell averages. +subroutine edge_values_explicit_h2( N, h, u, edge_val, h_neglect ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) real, dimension(:), intent(in) :: u !< cell average properties (size N) - real, dimension(:,:), intent(inout) :: edge_values !< Returned edge values, with the + real, dimension(:,:), intent(inout) :: edge_val !< Returned edge values, with the !! same units as u; the second index size is 2. real, optional, intent(in) :: h_neglect !< A negligibly small width - !! in the same units as h. - ! Local variables integer :: k ! loop index real :: h0, h1 ! cell widths @@ -288,52 +256,46 @@ subroutine edge_values_explicit_h2( N, h, u, edge_values, h_neglect ) u1 = u(k) ! Compute left edge value - edge_values(k,1) = ( u0*h1 + u1*h0 ) / ( h0 + h1 ) + edge_val(k,1) = ( u0*h1 + u1*h0 ) / ( h0 + h1 ) ! Left edge value of the current cell is equal to right edge ! value of left cell - edge_values(k-1,2) = edge_values(k,1) + edge_val(k-1,2) = edge_val(k,1) - end do ! end loop on interior cells + enddo ! end loop on interior cells ! Boundary edge values are simply equal to the boundary cell averages - edge_values(1,1) = u(1) - edge_values(N,2) = u(N) + edge_val(1,1) = u(1) + edge_val(N,2) = u(N) end subroutine edge_values_explicit_h2 - -!------------------------------------------------------------------------------ !> Compute h4 edge values (explicit fourth order accurate) -subroutine edge_values_explicit_h4( N, h, u, edge_values, h_neglect ) -! ----------------------------------------------------------------------------- -! Compute edge values based on fourth-order explicit estimates. -! These estimates are based on a cubic interpolant spanning four cells -! and evaluated at the location of the middle edge. An interpolant spanning -! cells i-2, i-1, i and i+1 is evaluated at edge i-1/2. The estimate for -! each edge is unique. -! -! i-2 i-1 i i+1 -! ..--o------o------o------o------o--.. -! i-1/2 -! -! The first two edge values are estimated by evaluating the first available -! cubic interpolant, i.e., the interpolant spanning cells 1, 2, 3 and 4. -! Similarly, the last two edge values are estimated by evaluating the last -! available interpolant. -! -! For this fourth-order scheme, at least four cells must exist. -! ----------------------------------------------------------------------------- - - ! Arguments +!! in the same units as h. +!! +!! Compute edge values based on fourth-order explicit estimates. +!! These estimates are based on a cubic interpolant spanning four cells +!! and evaluated at the location of the middle edge. An interpolant spanning +!! cells i-2, i-1, i and i+1 is evaluated at edge i-1/2. The estimate for +!! each edge is unique. +!! +!! i-2 i-1 i i+1 +!! ..--o------o------o------o------o--.. +!! i-1/2 +!! +!! The first two edge values are estimated by evaluating the first available +!! cubic interpolant, i.e., the interpolant spanning cells 1, 2, 3 and 4. +!! Similarly, the last two edge values are estimated by evaluating the last +!! available interpolant. +!! +!! For this fourth-order scheme, at least four cells must exist. +subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) real, dimension(:), intent(in) :: u !< cell average properties (size N) - real, dimension(:,:), intent(inout) :: edge_values !< Returned edge values, with the + real, dimension(:,:), intent(inout) :: edge_val !< Returned edge values, with the !! same units as u; the second index size is 2. real, optional, intent(in) :: h_neglect !< A negligibly small width - !! in the same units as h. - ! Local variables integer :: i, j real :: u0, u1, u2, u3 @@ -387,8 +349,8 @@ subroutine edge_values_explicit_h4( N, h, u, edge_values, h_neglect ) e = e / ( h0 + h1 + h2 + h3) - edge_values(i,1) = e - edge_values(i-1,2) = e + edge_val(i,1) = e + edge_val(i-1,2) = e #ifdef __DO_SAFETY_CHECKS__ if (e /= e) then @@ -400,36 +362,36 @@ subroutine edge_values_explicit_h4( N, h, u, edge_values, h_neglect ) endif #endif - end do ! end loop on interior cells + enddo ! end loop on interior cells ! Determine first two edge values f1 = max( hNeglect, hMinFrac*sum(h(1:4)) ) x(1) = 0.0 do i = 2,5 x(i) = x(i-1) + max(f1, h(i-1)) - end do + enddo do i = 1,4 do j = 1,4 A(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / real(j) - end do + enddo B(i) = u(i) * max(f1, h(i) ) - end do + enddo call solve_linear_system( A, B, C, 4 ) ! First edge value - edge_values(1,1) = evaluation_polynomial( C, 4, x(1) ) + edge_val(1,1) = evaluation_polynomial( C, 4, x(1) ) ! Second edge value - edge_values(1,2) = evaluation_polynomial( C, 4, x(2) ) - edge_values(2,1) = edge_values(1,2) + edge_val(1,2) = evaluation_polynomial( C, 4, x(2) ) + edge_val(2,1) = edge_val(1,2) #ifdef __DO_SAFETY_CHECKS__ - if (edge_values(1,1) /= edge_values(1,1) .or. edge_values(1,2) /= edge_values(1,2)) then + if (edge_val(1,1) /= edge_val(1,1) .or. edge_val(1,2) /= edge_val(1,2)) then write(0,*) 'NaN in explicit_edge_h4 at k=',1 write(0,*) 'A=',A write(0,*) 'B=',B @@ -445,38 +407,38 @@ subroutine edge_values_explicit_h4( N, h, u, edge_values, h_neglect ) x(1) = 0.0 do i = 2,5 x(i) = x(i-1) + max(f1, h(N-5+i)) - end do + enddo do i = 1,4 do j = 1,4 A(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / real(j) - end do + enddo B(i) = u(N-4+i) * max(f1, h(N-4+i) ) - end do + enddo call solve_linear_system( A, B, C, 4 ) ! Last edge value - edge_values(N,2) = evaluation_polynomial( C, 4, x(5) ) + edge_val(N,2) = evaluation_polynomial( C, 4, x(5) ) ! Second to last edge value - edge_values(N,1) = evaluation_polynomial( C, 4, x(4) ) - edge_values(N-1,2) = edge_values(N,1) + edge_val(N,1) = evaluation_polynomial( C, 4, x(4) ) + edge_val(N-1,2) = edge_val(N,1) #ifdef __DO_SAFETY_CHECKS__ - if (edge_values(N,1) /= edge_values(N,1) .or. edge_values(N,2) /= edge_values(N,2)) then + if (edge_val(N,1) /= edge_val(N,1) .or. edge_val(N,2) /= edge_val(N,2)) then write(0,*) 'NaN in explicit_edge_h4 at k=',N write(0,*) 'A=' do i = 1,4 do j = 1,4 A(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / real(j) - end do + enddo write(0,*) A(i,:) B(i) = u(N-4+i) * ( h(N-4+i) ) - end do + enddo write(0,*) 'B=',B write(0,*) 'C=',C write(0,*) 'h(:N)=',h(N-3:N) @@ -487,43 +449,39 @@ subroutine edge_values_explicit_h4( N, h, u, edge_values, h_neglect ) end subroutine edge_values_explicit_h4 - -!------------------------------------------------------------------------------ !> Compute ih4 edge values (implicit fourth order accurate) -subroutine edge_values_implicit_h4( N, h, u, edge_values, h_neglect ) -! ----------------------------------------------------------------------------- -! Compute edge values based on fourth-order implicit estimates. -! -! Fourth-order implicit estimates of edge values are based on a two-cell -! stencil. A tridiagonal system is set up and is based on expressing the -! edge values in terms of neighboring cell averages. The generic -! relationship is -! -! \alpha u_{i-1/2} + u_{i+1/2} + \beta u_{i+3/2} = a \bar{u}_i + b \bar{u}_{i+1} -! -! and the stencil looks like this -! -! i i+1 -! ..--o------o------o--.. -! i-1/2 i+1/2 i+3/2 -! -! In this routine, the coefficients \alpha, \beta, a and b are computed, -! the tridiagonal system is built, boundary conditions are prescribed and -! the system is solved to yield edge-value estimates. -! -! There are N+1 unknowns and we are able to write N-1 equations. The -! boundary conditions close the system. -! ----------------------------------------------------------------------------- - - ! Arguments +!! in the same units as h. +!! +!! Compute edge values based on fourth-order implicit estimates. +!! +!! Fourth-order implicit estimates of edge values are based on a two-cell +!! stencil. A tridiagonal system is set up and is based on expressing the +!! edge values in terms of neighboring cell averages. The generic +!! relationship is +!! +!! \f[ +!! \alpha u_{i-1/2} + u_{i+1/2} + \beta u_{i+3/2} = a \bar{u}_i + b \bar{u}_{i+1} +!! \f] +!! +!! and the stencil looks like this +!! +!! i i+1 +!! ..--o------o------o--.. +!! i-1/2 i+1/2 i+3/2 +!! +!! In this routine, the coefficients \f$\alpha\f$, \f$\beta\f$, \f$a\f$ and \f$b\f$ are +!! computed, the tridiagonal system is built, boundary conditions are prescribed and +!! the system is solved to yield edge-value estimates. +!! +!! There are N+1 unknowns and we are able to write N-1 equations. The +!! boundary conditions close the system. +subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) real, dimension(:), intent(in) :: u !< cell average properties (size N) - real, dimension(:,:), intent(inout) :: edge_values !< Returned edge values, with the + real, dimension(:,:), intent(inout) :: edge_val !< Returned edge values, with the !! same units as u; the second index size is 2. real, optional, intent(in) :: h_neglect !< A negligibly small width - !! in the same units as h. - ! Local variables integer :: i, j ! loop indexes real :: h0, h1 ! cell widths @@ -575,24 +533,24 @@ subroutine edge_values_implicit_h4( N, h, u, edge_values, h_neglect ) tri_b(i+1) = a * u(i) + b * u(i+1) - end do ! end loop on cells + enddo ! end loop on cells ! Boundary conditions: left boundary h0 = max( hNeglect, hMinFrac*sum(h(1:4)) ) x(1) = 0.0 do i = 2,5 x(i) = x(i-1) + max( h0, h(i-1) ) - end do + enddo do i = 1,4 do j = 1,4 Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j - end do + enddo Bsys(i) = u(i) * max( h0, h(i) ) - end do + enddo call solve_linear_system( Asys, Bsys, Csys, 4 ) @@ -605,17 +563,17 @@ subroutine edge_values_implicit_h4( N, h, u, edge_values, h_neglect ) x(1) = 0.0 do i = 2,5 x(i) = x(i-1) + max( h0, h(N-5+i) ) - end do + enddo do i = 1,4 do j = 1,4 Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j - end do + enddo Bsys(i) = u(N-4+i) * max( h0, h(N-4+i) ) - end do + enddo call solve_linear_system( Asys, Bsys, Csys, 4 ) @@ -627,60 +585,56 @@ subroutine edge_values_implicit_h4( N, h, u, edge_values, h_neglect ) call solve_tridiagonal_system( tri_l, tri_d, tri_u, tri_b, tri_x, N+1 ) do i = 2,N - edge_values(i,1) = tri_x(i) - edge_values(i-1,2) = tri_x(i) - end do - edge_values(1,1) = tri_x(1) - edge_values(N,2) = tri_x(N+1) + edge_val(i,1) = tri_x(i) + edge_val(i-1,2) = tri_x(i) + enddo + edge_val(1,1) = tri_x(1) + edge_val(N,2) = tri_x(N+1) end subroutine edge_values_implicit_h4 - -!------------------------------------------------------------------------------ !> Compute ih6 edge values (implicit sixth order accurate) -subroutine edge_values_implicit_h6( N, h, u, edge_values, h_neglect ) -! ----------------------------------------------------------------------------- -! Sixth-order implicit estimates of edge values are based on a four-cell, -! three-edge stencil. A tridiagonal system is set up and is based on -! expressing the edge values in terms of neighboring cell averages. -! -! The generic relationship is -! -! \alpha u_{i-1/2} + u_{i+1/2} + \beta u_{i+3/2} = -! a \bar{u}_{i-1} + b \bar{u}_i + c \bar{u}_{i+1} + d \bar{u}_{i+2} -! -! and the stencil looks like this -! -! i-1 i i+1 i+2 -! ..--o------o------o------o------o--.. -! i-1/2 i+1/2 i+3/2 -! -! In this routine, the coefficients \alpha, \beta, a, b, c and d are -! computed, the tridiagonal system is built, boundary conditions are -! prescribed and the system is solved to yield edge-value estimates. -! -! Note that the centered stencil only applies to edges 3 to N-1 (edges are -! numbered 1 to n+1), which yields N-3 equations for N+1 unknowns. Two other -! equations are written by using a right-biased stencil for edge 2 and a -! left-biased stencil for edge N. The prescription of boundary conditions -! (using sixth-order polynomials) closes the system. -! -! CAUTION: For each edge, in order to determine the coefficients of the -! implicit expression, a 6x6 linear system is solved. This may -! become computationally expensive if regridding is carried out -! often. Figuring out closed-form expressions for these coefficients -! on nonuniform meshes turned out to be intractable. -! ----------------------------------------------------------------------------- - - ! Arguments + !! in the same units as h. +!! +!! Sixth-order implicit estimates of edge values are based on a four-cell, +!! three-edge stencil. A tridiagonal system is set up and is based on +!! expressing the edge values in terms of neighboring cell averages. +!! +!! The generic relationship is +!! +!! \f[ +!! \alpha u_{i-1/2} + u_{i+1/2} + \beta u_{i+3/2} = +!! a \bar{u}_{i-1} + b \bar{u}_i + c \bar{u}_{i+1} + d \bar{u}_{i+2} +!! \f] +!! +!! and the stencil looks like this +!! +!! i-1 i i+1 i+2 +!! ..--o------o------o------o------o--.. +!! i-1/2 i+1/2 i+3/2 +!! +!! In this routine, the coefficients \f$\alpha\f$, \f$\beta\f$, a, b, c and d are +!! computed, the tridiagonal system is built, boundary conditions are +!! prescribed and the system is solved to yield edge-value estimates. +!! +!! Note that the centered stencil only applies to edges 3 to N-1 (edges are +!! numbered 1 to n+1), which yields N-3 equations for N+1 unknowns. Two other +!! equations are written by using a right-biased stencil for edge 2 and a +!! left-biased stencil for edge N. The prescription of boundary conditions +!! (using sixth-order polynomials) closes the system. +!! +!! CAUTION: For each edge, in order to determine the coefficients of the +!! implicit expression, a 6x6 linear system is solved. This may +!! become computationally expensive if regridding is carried out +!! often. Figuring out closed-form expressions for these coefficients +!! on nonuniform meshes turned out to be intractable. +subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) real, dimension(:), intent(in) :: u !< cell average properties (size N) - real, dimension(:,:), intent(inout) :: edge_values !< Returned edge values, with the + real, dimension(:,:), intent(inout) :: edge_val !< Returned edge values, with the !! same units as u; the second index size is 2. real, optional, intent(in) :: h_neglect !< A negligibly small width - !! in the same units as h. - ! Local variables integer :: i, j, k ! loop indexes real :: h0, h1, h2, h3 ! cell widths @@ -828,7 +782,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_values, h_neglect ) tri_u(k+1) = beta tri_b(k+1) = a * u(k-1) + b * u(k) + c * u(k+1) + d * u(k+2) - end do ! end loop on cells + enddo ! end loop on cells ! Use a right-biased stencil for the second row @@ -956,17 +910,17 @@ subroutine edge_values_implicit_h6( N, h, u, edge_values, h_neglect ) x(1) = 0.0 do i = 2,7 x(i) = x(i-1) + max( g, h(i-1) ) - end do + enddo do i = 1,6 do j = 1,6 Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j - end do + enddo Bsys(i) = u(i) * max( g, h(i) ) - end do + enddo call solve_linear_system( Asys, Bsys, Csys, 6 ) @@ -1101,17 +1055,17 @@ subroutine edge_values_implicit_h6( N, h, u, edge_values, h_neglect ) x(1) = 0.0 do i = 2,7 x(i) = x(i-1) + max( g, h(N-7+i) ) - end do + enddo do i = 1,6 do j = 1,6 Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j - end do + enddo Bsys(i) = u(N-6+i) * max( g, h(N-6+i) ) - end do + enddo call solve_linear_system( Asys, Bsys, Csys, 6 ) @@ -1124,13 +1078,12 @@ subroutine edge_values_implicit_h6( N, h, u, edge_values, h_neglect ) call solve_tridiagonal_system( tri_l, tri_d, tri_u, tri_b, tri_x, N+1 ) do i = 2,N - edge_values(i,1) = tri_x(i) - edge_values(i-1,2) = tri_x(i) - end do - edge_values(1,1) = tri_x(1) - edge_values(N,2) = tri_x(N+1) + edge_val(i,1) = tri_x(i) + edge_val(i-1,2) = tri_x(i) + enddo + edge_val(1,1) = tri_x(1) + edge_val(N,2) = tri_x(N+1) end subroutine edge_values_implicit_h6 - end module regrid_edge_values diff --git a/src/ALE/regrid_interp.F90 b/src/ALE/regrid_interp.F90 index 6858e0cded..d2c384c15e 100644 --- a/src/ALE/regrid_interp.F90 +++ b/src/ALE/regrid_interp.F90 @@ -1,3 +1,4 @@ +!> Vertical interpolation for regridding module regrid_interp ! This file is part of MOM6. See LICENSE.md for the license. @@ -18,8 +19,8 @@ module regrid_interp implicit none ; private -type, public :: interp_CS_type - private +!> Control structure for regrid_interp module +type, public :: interp_CS_type ; private !> The following parameter is only relevant when used with the target !! interface densities regridding scheme. It indicates which interpolation @@ -47,9 +48,10 @@ module regrid_interp integer, parameter :: INTERPOLATION_PQM_IH4IH3 = 8 !< O(h^4) integer, parameter :: INTERPOLATION_PQM_IH6IH5 = 9 !< O(h^5) -!> List of interpolant degrees +!>@{ Interpolant degrees integer, parameter :: DEGREE_1 = 1, DEGREE_2 = 2, DEGREE_3 = 3, DEGREE_4 = 4 integer, public, parameter :: DEGREE_MAX = 5 +!!@} !> When the N-R algorithm produces an estimate that lies outside [0,1], the !! estimate is set to be equal to the boundary location, 0 or 1, plus or minus @@ -64,8 +66,8 @@ module regrid_interp contains -!> Given the set of target values and cell densities, this routine -!! builds an interpolated profile for the densities within each grid cell. +!> Builds an interpolated profile for the densities within each grid cell. +!! !! It may happen that, given a high-order interpolator, the number of !! available layers is insufficient (e.g., there are two available layers for !! a third-order PPM ih4 scheme). In these cases, we resort to the simplest @@ -86,7 +88,7 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & real, optional, intent(in) :: h_neglect_edge !< A negligibly small width !! for the purpose of edge value calculations !! in the same units as h0. - + ! Local variables logical :: extrapolate ! Reset piecewise polynomials @@ -105,7 +107,7 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) - end if + endif case ( INTERPOLATION_P1M_H4 ) degree = DEGREE_1 @@ -113,11 +115,11 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & call edge_values_explicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge ) else call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) - end if + endif call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) - end if + endif case ( INTERPOLATION_P1M_IH4 ) degree = DEGREE_1 @@ -125,18 +127,18 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & call edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge ) else call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) - end if + endif call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) - end if + endif case ( INTERPOLATION_PLM ) degree = DEGREE_1 call PLM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then call PLM_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) - end if + endif case ( INTERPOLATION_PPM_H4 ) if ( n0 >= 4 ) then @@ -146,15 +148,15 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & if (extrapolate) then call PPM_boundary_extrapolation( n0, h0, densities, ppoly0_E, & ppoly0_coefs, h_neglect ) - end if + endif else degree = DEGREE_1 call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) - end if - end if + endif + endif case ( INTERPOLATION_PPM_IH4 ) if ( n0 >= 4 ) then @@ -164,15 +166,15 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & if (extrapolate) then call PPM_boundary_extrapolation( n0, h0, densities, ppoly0_E, & ppoly0_coefs, h_neglect ) - end if + endif else degree = DEGREE_1 call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) - end if - end if + endif + endif case ( INTERPOLATION_P3M_IH4IH3 ) if ( n0 >= 4 ) then @@ -184,15 +186,15 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & if (extrapolate) then call P3M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_S, & ppoly0_coefs, h_neglect, h_neglect_edge ) - end if + endif else degree = DEGREE_1 call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) - end if - end if + endif + endif case ( INTERPOLATION_P3M_IH6IH5 ) if ( n0 >= 6 ) then @@ -204,15 +206,15 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & if (extrapolate) then call P3M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_S, & ppoly0_coefs, h_neglect, h_neglect_edge ) - end if + endif else degree = DEGREE_1 call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) - end if - end if + endif + endif case ( INTERPOLATION_PQM_IH4IH3 ) if ( n0 >= 4 ) then @@ -224,15 +226,15 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & if (extrapolate) then call PQM_boundary_extrapolation_v1( n0, h0, densities, ppoly0_E, ppoly0_S, & ppoly0_coefs, h_neglect ) - end if + endif else degree = DEGREE_1 call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) - end if - end if + endif + endif case ( INTERPOLATION_PQM_IH6IH5 ) if ( n0 >= 6 ) then @@ -244,15 +246,15 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & if (extrapolate) then call PQM_boundary_extrapolation_v1( n0, h0, densities, ppoly0_E, ppoly0_S, & ppoly0_coefs, h_neglect ) - end if + endif else degree = DEGREE_1 call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) - end if - end if + endif + endif end select end subroutine regridding_set_ppolys @@ -263,7 +265,6 @@ end subroutine regridding_set_ppolys !! are determined by finding the corresponding target interface densities. subroutine interpolate_grid( n0, h0, x0, ppoly0_E, ppoly0_coefs, & target_values, degree, n1, h1, x1 ) - ! Arguments integer, intent(in) :: n0 !< Number of points on source grid real, dimension(:), intent(in) :: h0 !< Thicknesses of source grid cells real, dimension(:), intent(in) :: x0 !< Source interface positions @@ -274,7 +275,6 @@ subroutine interpolate_grid( n0, h0, x0, ppoly0_E, ppoly0_coefs, & integer, intent(in) :: n1 !< Number of points on target grid real, dimension(:), intent(inout) :: h1 !< Thicknesses of target grid cells real, dimension(:), intent(inout) :: x1 !< Target interface positions - ! Local variables integer :: k ! loop index real :: t ! current interface target density @@ -289,15 +289,16 @@ subroutine interpolate_grid( n0, h0, x0, ppoly0_E, ppoly0_coefs, & t = target_values(k) x1(k) = get_polynomial_coordinate ( n0, h0, x0, ppoly0_E, ppoly0_coefs, t, degree ) h1(k-1) = x1(k) - x1(k-1) - end do + enddo h1(n1) = x1(n1+1) - x1(n1) end subroutine interpolate_grid +!> Build a grid by interpolating for target values subroutine build_and_interpolate_grid(CS, densities, n0, h0, x0, target_values, & n1, h1, x1, h_neglect, h_neglect_edge) type(interp_CS_type), intent(in) :: CS !< A control structure for regrid_interp - real, dimension(:), intent(in) :: densities !< Input cell densities, in kg m-3 + real, dimension(:), intent(in) :: densities !< Input cell densities [kg m-3] real, dimension(:), intent(in) :: target_values !< Target values of interfaces integer, intent(in) :: n0 !< The number of points on the input grid real, dimension(:), intent(in) :: h0 !< Initial cell widths @@ -338,8 +339,8 @@ end subroutine build_and_interpolate_grid !! !! It is assumed that the number of cells defining 'grid' and 'ppoly' are the !! same. -function get_polynomial_coordinate ( N, h, x_g, ppoly_E, ppoly_coefs, & - target_value, degree ) result ( x_tgt ) +function get_polynomial_coordinate( N, h, x_g, ppoly_E, ppoly_coefs, & + target_value, degree ) result ( x_tgt ) ! Arguments integer, intent(in) :: N !< Number of grid cells real, dimension(:), intent(in) :: h !< Grid cell thicknesses @@ -348,9 +349,7 @@ function get_polynomial_coordinate ( N, h, x_g, ppoly_E, ppoly_coefs, & real, dimension(:,:), intent(in) :: ppoly_coefs !< Coefficients of interpolating polynomials real, intent(in) :: target_value !< Target value to find position for integer, intent(in) :: degree !< Degree of the interpolating polynomials - real :: x_tgt !< The position of x_g at which target_value is found. - ! Local variables integer :: i, k ! loop indices integer :: k_found ! index of target cell @@ -374,7 +373,7 @@ function get_polynomial_coordinate ( N, h, x_g, ppoly_E, ppoly_coefs, & if ( target_value <= ppoly_E(1,1) ) then x_tgt = x_g(1) return ! return because there is no need to look further - end if + endif ! Since discontinuous edge values are allowed, we check whether the target ! value lies between two discontinuous edge values at interior interfaces @@ -384,8 +383,8 @@ function get_polynomial_coordinate ( N, h, x_g, ppoly_E, ppoly_coefs, & x_tgt = x_g(k) return ! return because there is no need to look further exit - end if - end do + endif + enddo ! If the target value is outside the range of all values, we ! force the target coordinate to be equal to the lowest or @@ -393,7 +392,7 @@ function get_polynomial_coordinate ( N, h, x_g, ppoly_E, ppoly_coefs, & if ( target_value >= ppoly_E(N,2) ) then x_tgt = x_g(N+1) return ! return because there is no need to look further - end if + endif ! At this point, we know that the target value is bounded and does not ! lie between discontinuous, monotonic edge values. Therefore, @@ -405,8 +404,8 @@ function get_polynomial_coordinate ( N, h, x_g, ppoly_E, ppoly_coefs, & ( target_value < ppoly_E(k,2) ) ) then k_found = k exit - end if - end do + endif + enddo ! At this point, 'k_found' should be strictly positive. If not, this is ! a major failure because it means we could not find any target cell @@ -420,14 +419,14 @@ function get_polynomial_coordinate ( N, h, x_g, ppoly_E, ppoly_coefs, & 'inconsistent interpolant (perhaps not monotonically '//& 'increasing)' call MOM_error( FATAL, 'Aborting execution' ) - end if + endif ! Reset all polynomial coefficients to 0 and copy those pertaining to ! the found cell a(:) = 0.0 do i = 1,degree+1 a(i) = ppoly_coefs(k_found,i) - end do + enddo ! Guess value to start Newton-Raphson iterations (middle of cell) xi0 = 0.5 @@ -440,7 +439,7 @@ function get_polynomial_coordinate ( N, h, x_g, ppoly_E, ppoly_coefs, & if ( ( iter > NR_ITERATIONS ) .OR. & ( abs(delta) < NR_TOLERANCE ) ) then exit - end if + endif numerator = a(1) + a(2)*xi0 + a(3)*xi0*xi0 + a(4)*xi0*xi0*xi0 + & a(5)*xi0*xi0*xi0*xi0 - target_value @@ -460,23 +459,25 @@ function get_polynomial_coordinate ( N, h, x_g, ppoly_E, ppoly_coefs, & xi0 = 0.0 grad = a(2) if ( grad == 0.0 ) xi0 = xi0 + eps - end if + endif if ( xi0 > 1.0 ) then xi0 = 1.0 grad = a(2) + 2*a(3) + 3*a(4) + 4*a(5) if ( grad == 0.0 ) xi0 = xi0 - eps - end if + endif iter = iter + 1 - end do ! end Newton-Raphson iterations + enddo ! end Newton-Raphson iterations x_tgt = x_g(k_found) + xi0 * h(k_found) end function get_polynomial_coordinate !> Numeric value of interpolation_scheme corresponding to scheme name integer function interpolation_scheme(interp_scheme) - character(len=*), intent(in) :: interp_scheme !< Name of interpolation scheme + character(len=*), intent(in) :: interp_scheme !< Name of the interpolation scheme + !! Valid values include "P1M_H2", "P1M_H4", "P1M_IH2", "PLM", "PPM_H4", + !! "PPM_IH4", "P3M_IH4IH3", "P3M_IH6IH5", "PQM_IH4IH3", and "PQM_IH6IH5" select case ( uppercase(trim(interp_scheme)) ) case ("P1M_H2"); interpolation_scheme = INTERPOLATION_P1M_H2 @@ -494,18 +495,23 @@ integer function interpolation_scheme(interp_scheme) end select end function interpolation_scheme +!> Store the interpolation_scheme value in the interp_CS based on the input string. subroutine set_interp_scheme(CS, interp_scheme) - type(interp_CS_type), intent(inout) :: CS - character(len=*), intent(in) :: interp_scheme + type(interp_CS_type), intent(inout) :: CS !< A control structure for regrid_interp + character(len=*), intent(in) :: interp_scheme !< Name of the interpolation scheme + !! Valid values include "P1M_H2", "P1M_H4", "P1M_IH2", "PLM", "PPM_H4", + !! "PPM_IH4", "P3M_IH4IH3", "P3M_IH6IH5", "PQM_IH4IH3", and "PQM_IH6IH5" CS%interpolation_scheme = interpolation_scheme(interp_scheme) end subroutine set_interp_scheme -subroutine set_interp_extrap(CS, extrapolation) - type(interp_CS_type), intent(inout) :: CS - logical, intent(in) :: extrapolation +!> Store the boundary_extrapolation value in the interp_CS +subroutine set_interp_extrap(CS, extrap) + type(interp_CS_type), intent(inout) :: CS !< A control structure for regrid_interp + logical, intent(in) :: extrap !< Indicate whether high-order boundary + !! extrapolation should be used in boundary cells - CS%boundary_extrapolation = extrapolation + CS%boundary_extrapolation = extrap end subroutine set_interp_extrap end module regrid_interp diff --git a/src/ALE/regrid_solvers.F90 b/src/ALE/regrid_solvers.F90 index b9e775b1ce..8ee7ab29b2 100644 --- a/src/ALE/regrid_solvers.F90 +++ b/src/ALE/regrid_solvers.F90 @@ -1,45 +1,26 @@ +!> Solvers of linear systems. module regrid_solvers ! This file is part of MOM6. See LICENSE.md for the license. -!============================================================================== -! -! Date of creation: 2008.06.12 -! L. White -! -! This module contains solvers of linear systems. -! These routines could (should ?) be replaced later by more efficient ones. -! -! -!============================================================================== - use MOM_error_handler, only : MOM_error, FATAL implicit none ; private public :: solve_linear_system, solve_tridiagonal_system -! ----------------------------------------------------------------------------- -! This module contains the following routines -! ----------------------------------------------------------------------------- contains -! ----------------------------------------------------------------------------- -! Solve the linear system AX = B -! ----------------------------------------------------------------------------- +!> Solve the linear system AX = B by Gaussian elimination +!! +!! This routine uses Gauss's algorithm to transform the system's original +!! matrix into an upper triangular matrix. Back substitution yields the answer. +!! The matrix A must be square and its size must be that of the vectors B and X. subroutine solve_linear_system( A, B, X, system_size ) -! ----------------------------------------------------------------------------- -! This routine uses Gauss's algorithm to transform the system's original -! matrix into an upper triangular matrix. Back substitution yields the answer. -! The matrix A must be square and its size must be that of the vectors B and X. -! ----------------------------------------------------------------------------- - - ! Arguments - real, dimension(:,:), intent(inout) :: A - real, dimension(:), intent(inout) :: B - real, dimension(:), intent(inout) :: X - integer :: system_size - + real, dimension(:,:), intent(inout) :: A !< The matrix being inverted + real, dimension(:), intent(inout) :: B !< system right-hand side + real, dimension(:), intent(inout) :: X !< solution vector + integer, intent(in) :: system_size !< The size of the system ! Local variables integer :: i, j, k real, parameter :: eps = 0.0 ! Minimum pivot magnitude allowed @@ -59,43 +40,43 @@ subroutine solve_linear_system( A, B, X, system_size ) ! entries of column i in rows below row i. Once a valid ! pivot is found (say in row k), rows i and k are swaped. k = i - do while ( ( .NOT. found_pivot ) .AND. ( k .LE. system_size ) ) + do while ( ( .NOT. found_pivot ) .AND. ( k <= system_size ) ) - if ( abs( A(k,i) ) .GT. eps ) then ! a valid pivot is found + if ( abs( A(k,i) ) > eps ) then ! a valid pivot is found found_pivot = .true. else ! Go to the next row to see ! if there is a valid pivot there k = k + 1 - end if + endif - end do ! end loop to find pivot + enddo ! end loop to find pivot ! If no pivot could be found, the system is singular and we need ! to end the execution if ( .NOT. found_pivot ) then write(0,*) ' A=',A call MOM_error( FATAL, 'The linear system is singular !' ) - end if + endif ! If the pivot is in a row that is different than row i, that is if ! k is different than i, we need to swap those two rows - if ( k .NE. i ) then + if ( k /= i ) then do j = 1,system_size swap_a = A(i,j) A(i,j) = A(k,j) A(k,j) = swap_a - end do + enddo swap_b = B(i) B(i) = B(k) B(k) = swap_b - end if + endif ! Transform pivot to 1 by dividing the entire row ! (right-hand side included) by the pivot pivot = A(i,i) do j = i,system_size A(i,j) = A(i,j) / pivot - end do + enddo B(i) = B(i) / pivot ! #INV: At this point, A(i,i) is a suitable pivot and it is equal to 1 @@ -106,11 +87,11 @@ subroutine solve_linear_system( A, B, X, system_size ) factor = A(k,i) do j = (i+1),system_size ! j is the column index A(k,j) = A(k,j) - factor * A(i,j) - end do + enddo B(k) = B(k) - factor * B(i) - end do + enddo - end do ! end loop on i + enddo ! end loop on i ! Solve system by back substituting @@ -119,27 +100,23 @@ subroutine solve_linear_system( A, B, X, system_size ) X(i) = B(i) do j = (i+1),system_size X(i) = X(i) - A(i,j) * X(j) - end do + enddo X(i) = X(i) / A(i,i) - end do + enddo end subroutine solve_linear_system - -! ----------------------------------------------------------------------------- -! Solve the tridiagonal system AX = B -! ----------------------------------------------------------------------------- +!> Solve the tridiagonal system AX = B +!! +!! This routine uses Thomas's algorithm to solve the tridiagonal system AX = B. +!! (A is made up of lower, middle and upper diagonals) subroutine solve_tridiagonal_system( Al, Ad, Au, B, X, system_size ) -! ----------------------------------------------------------------------------- -! This routine uses Thomas's algorithm to solve the tridiagonal system AX = B. -! (A is made up of lower, middle and upper diagonals) -! ----------------------------------------------------------------------------- - ! Arguments - real, dimension(:), intent(inout) :: Al, Ad, Au ! lo., mid. and up. diagonals - real, dimension(:), intent(inout) :: B ! system right-hand side - real, dimension(:), intent(inout) :: X ! solution vector - integer, intent(in) :: system_size - + real, dimension(:), intent(inout) :: Ad !< Maxtix center diagonal + real, dimension(:), intent(inout) :: Al !< Matrix lower diagonal + real, dimension(:), intent(inout) :: Au !< Matrix upper diagonal + real, dimension(:), intent(inout) :: B !< system right-hand side + real, dimension(:), intent(inout) :: X !< solution vector + integer, intent(in) :: system_size !< The size of the system ! Local variables integer :: k ! Loop index integer :: N ! system size @@ -150,19 +127,27 @@ subroutine solve_tridiagonal_system( Al, Ad, Au, B, X, system_size ) do k = 1,N-1 Al(k+1) = Al(k+1) / Ad(k) Ad(k+1) = Ad(k+1) - Al(k+1) * Au(k) - end do + enddo ! Forward sweep do k = 2,N B(k) = B(k) - Al(k) * B(k-1) - end do + enddo ! Backward sweep X(N) = B(N) / Ad(N) do k = N-1,1,-1 X(k) = ( B(k) - Au(k)*X(k+1) ) / Ad(k) - end do + enddo end subroutine solve_tridiagonal_system +!> \namespace regrid_solvers +!! +!! Date of creation: 2008.06.12 +!! L. White +!! +!! This module contains solvers of linear systems. +!! These routines could (should ?) be replaced later by more efficient ones. + end module regrid_solvers diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index fe6f7073e6..21ec2e6dc6 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1,15 +1,16 @@ +!> The central module of the MOM6 ocean model module MOM ! This file is part of MOM6. See LICENSE.md for the license. ! Infrastructure modules use MOM_debugging, only : MOM_debugging_init, hchksum, uvchksum +use MOM_debugging, only : check_redundant use MOM_checksum_packages, only : MOM_thermo_chksum, MOM_state_chksum use MOM_checksum_packages, only : MOM_accel_chksum, MOM_surface_chksum use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_COMPONENT, CLOCK_SUBCOMPONENT use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE -use MOM_coord_initialization, only : MOM_initialize_coord use MOM_diag_mediator, only : diag_mediator_init, enable_averaging use MOM_diag_mediator, only : diag_mediator_infrastructure_init use MOM_diag_mediator, only : diag_set_state_ptrs, diag_update_remap_grids @@ -26,11 +27,10 @@ module MOM use MOM_domains, only : To_All, Omit_corners, CGRID_NE, SCALAR_PAIR use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type use MOM_domains, only : start_group_pass, complete_group_pass, Omit_Corners -use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe use MOM_error_handler, only : MOM_set_verbosity, callTree_showQuery use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint use MOM_file_parser, only : read_param, get_param, log_version, param_file_type -use MOM_fixed_initialization, only : MOM_initialize_fixed use MOM_forcing_type, only : forcing, mech_forcing use MOM_forcing_type, only : MOM_forcing_chksum, MOM_mech_forcing_chksum use MOM_get_input, only : Get_MOM_Input, directories @@ -40,8 +40,7 @@ module MOM use MOM_restart, only : register_restart_field, query_initialized, save_restart use MOM_restart, only : restart_init, is_new_run, MOM_restart_CS use MOM_spatial_means, only : global_mass_integral -use MOM_state_initialization, only : MOM_initialize_state -use MOM_time_manager, only : time_type, set_time, time_type_to_real, operator(+) +use MOM_time_manager, only : time_type, real_to_time, time_type_to_real, operator(+) use MOM_time_manager, only : operator(-), operator(>), operator(*), operator(/) use MOM_time_manager, only : operator(>=), increment_date use MOM_unit_tests, only : unit_tests @@ -52,12 +51,14 @@ module MOM use MOM_ALE, only : ALE_getCoordinate, ALE_getCoordinateUnits, ALE_writeCoordinateFile use MOM_ALE, only : ALE_updateVerticalGridType, ALE_remap_init_conds, ALE_register_diags use MOM_boundary_update, only : call_OBC_register, OBC_register_end, update_OBC_CS +use MOM_coord_initialization, only : MOM_initialize_coord use MOM_diabatic_driver, only : diabatic, diabatic_driver_init, diabatic_CS use MOM_diabatic_driver, only : adiabatic, adiabatic_driver_init, diabatic_driver_end +use MOM_diabatic_driver, only : legacy_diabatic use MOM_diagnostics, only : calculate_diagnostic_fields, MOM_diagnostics_init use MOM_diagnostics, only : register_transport_diags, post_transport_diagnostics -use MOM_diagnostics, only : register_surface_diags, post_surface_diagnostics -use MOM_diagnostics, only : write_static_fields +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 @@ -71,10 +72,10 @@ module MOM use MOM_dynamics_unsplit_RK2, only : initialize_dyn_unsplit_RK2, end_dyn_unsplit_RK2 use MOM_dynamics_unsplit_RK2, only : MOM_dyn_unsplit_RK2_CS use MOM_dyn_horgrid, only : dyn_horgrid_type, create_dyn_horgrid, destroy_dyn_horgrid -use MOM_EOS, only : EOS_init, calculate_density -use MOM_debugging, only : check_redundant -use MOM_grid, only : ocean_grid_type, set_first_direction -use MOM_grid, only : MOM_grid_init, MOM_grid_end +use MOM_EOS, only : EOS_init, calculate_density, calculate_TFreeze +use MOM_fixed_initialization, only : MOM_initialize_fixed +use MOM_grid, only : ocean_grid_type, MOM_grid_init, MOM_grid_end +use MOM_grid, only : set_first_direction, rescale_grid_bathymetry use MOM_hor_index, only : hor_index_type, hor_index_init use MOM_interface_heights, only : find_eta use MOM_lateral_mixing_coeffs, only : calc_slope_functions, VarMix_init @@ -90,6 +91,7 @@ module MOM use MOM_set_visc, only : set_viscous_BBL, set_viscous_ML, set_visc_init use MOM_set_visc, only : set_visc_register_restarts, set_visc_CS use MOM_sponge, only : init_sponge_diags, sponge_CS +use MOM_state_initialization, only : MOM_initialize_state use MOM_sum_output, only : write_energy, accumulate_net_input use MOM_sum_output, only : MOM_sum_output_init, sum_output_CS use MOM_ALE_sponge, only : init_ALE_sponge_diags, ALE_sponge_CS @@ -107,10 +109,13 @@ module MOM use MOM_tracer_flow_control, only : tracer_flow_control_init, call_tracer_surface_state use MOM_tracer_flow_control, only : tracer_flow_control_end use MOM_transcribe_grid, only : copy_dyngrid_to_MOM_grid, copy_MOM_grid_to_dyngrid +use MOM_unit_scaling, only : unit_scale_type, unit_scaling_init +use MOM_unit_scaling, only : unit_scaling_end, fix_restart_unit_scaling use MOM_variables, only : surface, allocate_surface_state, deallocate_surface_state use MOM_variables, only : thermo_var_ptrs, vertvisc_type use MOM_variables, only : accel_diag_ptrs, cont_diag_ptrs, ocean_internal_state use MOM_verticalGrid, only : verticalGrid_type, verticalGridInit, verticalGridEnd +use MOM_verticalGrid, only : fix_restart_scaling use MOM_verticalGrid, only : get_thickness_units, get_flux_units, get_tr_flux_units use MOM_wave_interface, only : wave_parameters_CS, waves_end use MOM_wave_interface, only : Update_Stokes_Drift @@ -131,11 +136,16 @@ module MOM #include +! 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. + !> A structure with diagnostic IDs of the state variables type MOM_diag_IDs - ! 3-d state fields - integer :: id_u = -1, id_v = -1, id_h = -1 - ! 2-d state field + !>@{ 3-d state field diagnostic IDs + integer :: id_u = -1, id_v = -1, id_h = -1 !!@} + !> 2-d state field diagnotic ID integer :: id_ssh_inst = -1 end type MOM_diag_IDs @@ -143,73 +153,72 @@ module MOM !! the state of the ocean. type, public :: MOM_control_struct ; private real ALLOCABLE_, dimension(NIMEM_,NJMEM_,NKMEM_) :: & - h, & !< layer thickness (m or kg/m2 (H)) - T, & !< potential temperature (degrees C) - S !< salinity (ppt) + h, & !< layer thickness [H ~> m or kg m-2] + T, & !< potential temperature [degC] + S !< salinity [ppt] real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: & - u, & !< zonal velocity component (m/s) - uh, & !< uh = u * h * dy at u grid points (m3/s or kg/s) - uhtr !< accumulated zonal thickness fluxes to advect tracers (m3 or kg) + u, & !< zonal velocity component [m s-1] + uh, & !< uh = u * h * dy at u grid points [H m2 s-1 ~> m3 s-1 or kg s-1] + uhtr !< accumulated zonal thickness fluxes to advect tracers [H m2 ~> m3 or kg] real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: & - v, & !< meridional velocity (m/s) - vh, & !< vh = v * h * dx at v grid points (m3/s or kg/s) - vhtr !< accumulated meridional thickness fluxes to advect tracers (m3 or kg) - real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: & - ssh_rint, & !< A running time integral of the sea surface height, in s m. - ave_ssh_ibc, & !< time-averaged (over a forcing time step) sea surface height - !! with a correction for the inverse barometer (meter) - eta_av_bc !< free surface height or column mass time averaged over the last - !! baroclinic dynamics time step (m or kg/m2) - real, pointer, dimension(:,:) :: & - Hml => NULL() !< active mixed layer depth, in m + v, & !< meridional velocity [m s-1] + vh, & !< vh = v * h * dx at v grid points [H m2 s-1 ~> m3 s-1 or kg s-1] + vhtr !< accumulated meridional thickness fluxes to advect tracers [H m2 ~> m3 or kg] + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: ssh_rint + !< A running time integral of the sea surface height [s m]. + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: ave_ssh_ibc + !< time-averaged (over a forcing time step) sea surface height + !! with a correction for the inverse barometer [m] + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: eta_av_bc + !< free surface height or column mass time averaged over the last + !! baroclinic dynamics time step [H ~> m or kg m-2] + real, dimension(:,:), pointer :: & + Hml => NULL() !< active mixed layer depth [m] real :: time_in_cycle !< The running time of the current time-stepping cycle !! in calls that step the dynamics, and also the length of - !! the time integral of ssh_rint, in s. + !! the time integral of ssh_rint [s]. real :: time_in_thermo_cycle !< The running time of the current time-stepping - !! cycle in calls that step the thermodynamics, in s. + !! cycle in calls that step the thermodynamics [s]. type(ocean_grid_type) :: G !< structure containing metrics and grid info type(verticalGrid_type), pointer :: & - GV => NULL() !< structure containing vertical grid info - type(thermo_var_ptrs) :: tv !< structure containing pointers to available - !! thermodynamic fields - real :: t_dyn_rel_adv !< The time of the dynamics relative to tracer - !! advection and lateral mixing (in seconds), or - !! equivalently the elapsed time since advectively - !! updating the tracers. t_dyn_rel_adv is invariably - !! positive and may span multiple coupling timesteps. - real :: t_dyn_rel_thermo !< The time of the dynamics relative to diabatic - !! processes and remapping (in seconds). t_dyn_rel_thermo - !! can be negative or positive depending on whether - !! the diabatic processes are applied before or after - !! the dynamics and may span multiple coupling timesteps. - real :: t_dyn_rel_diag !< The time of the diagnostics relative to diabatic - !! processes and remapping (in seconds). t_dyn_rel_diag - !! is always positive, since the diagnostics must lag. - integer :: ndyn_per_adv = 0 !< Number of calls to dynamics since the last call to advection - !! Must be saved if thermo spans coupling? + GV => NULL() !< structure containing vertical grid info + type(unit_scale_type), pointer :: & + US => NULL() !< structure containing various unit conversion factors + type(thermo_var_ptrs) :: tv !< structure containing pointers to available thermodynamic fields + real :: t_dyn_rel_adv !< The time of the dynamics relative to tracer advection and lateral mixing + !! (in seconds), or equivalently the elapsed time since advectively updating the + !! tracers. t_dyn_rel_adv is invariably positive and may span multiple coupling timesteps. + real :: t_dyn_rel_thermo !< The time of the dynamics relative to diabatic processes and remapping + !! (in seconds). t_dyn_rel_thermo can be negative or positive depending on whether + !! the diabatic processes are applied before or after the dynamics and may span + !! multiple coupling timesteps. + real :: t_dyn_rel_diag !< The time of the diagnostics relative to diabatic processes and remapping + !! (in seconds). t_dyn_rel_diag is always positive, since the diagnostics must lag. + integer :: ndyn_per_adv = 0 !< Number of calls to dynamics since the last call to advection. + !### Must be saved if thermo spans coupling? type(diag_ctrl) :: diag !< structure to regulate diagnostic output timing type(vertvisc_type) :: visc !< structure containing vertical viscosities, - !! bottom drag viscosities, and related fields + !! bottom drag viscosities, and related fields type(MEKE_type), pointer :: MEKE => NULL() !< structure containing fields - !! related to the Mesoscale Eddy Kinetic Energy - - logical :: adiabatic !< If true, there are no diapycnal mass fluxes, and no calls - !! to routines to calculate or apply diapycnal fluxes. - logical :: diabatic_first !< If true, apply diabatic and thermodynamic - !! processes before time stepping the dynamics. - logical :: use_ALE_algorithm !< If true, use the ALE algorithm rather than layered - !! isopycnal/stacked shallow water mode. This logical is - !! set by calling the function useRegridding() from the - !! MOM_regridding module. + !! related to the Mesoscale Eddy Kinetic Energy + logical :: adiabatic !< If true, there are no diapycnal mass fluxes, and no calls + !! to routines to calculate or apply diapycnal fluxes. + logical :: use_legacy_diabatic_driver!< If true (default), use the a legacy version of the diabatic + !! subroutine. This is temporary and is needed to avoid change in answers. + logical :: diabatic_first !< If true, apply diabatic and thermodynamic processes before time + !! stepping the dynamics. + logical :: use_ALE_algorithm !< If true, use the ALE algorithm rather than layered + !! isopycnal/stacked shallow water mode. This logical is set by calling the + !! function useRegridding() from the MOM_regridding module. logical :: offline_tracer_mode = .false. - !< If true, step_offline() is called instead of step_MOM(). - !! This is intended for running MOM6 in offline tracer mode + !< If true, step_offline() is called instead of step_MOM(). + !! This is intended for running MOM6 in offline tracer mode - type(time_type), pointer :: Time !< pointer to ocean clock - real :: dt !< (baroclinic) dynamics time step (seconds) - real :: dt_therm !< thermodynamics time step (seconds) + type(time_type), pointer :: Time !< pointer to the ocean clock + real :: dt !< (baroclinic) dynamics time step [s] + real :: dt_therm !< thermodynamics time step [s] logical :: thermo_spans_coupling !< If true, thermodynamic and tracer time !! steps can span multiple coupled time steps. integer :: nstep_tot = 0 !< The total number of dynamic timesteps tcaaken @@ -230,10 +239,9 @@ module MOM logical :: mixedlayer_restrat !< If true, use submesoscale mixed layer restratifying scheme. logical :: useMEKE !< If true, call the MEKE parameterization. logical :: useWaves !< If true, update Stokes drift - real :: dtbt_reset_period !< The time interval in seconds between dynamic - !! recalculation of the barotropic time step. If - !! this is negative, it is never calculated, and - !! if it is 0, it is calculated every step. + real :: dtbt_reset_period !< The time interval between dynamic recalculation of the + !! barotropic time step [s]. If this is negative dtbt is never + !! calculated, and if it is 0, dtbt is calculated every step. type(time_type) :: dtbt_reset_interval !< A time_time representation of dtbt_reset_period. type(time_type) :: dtbt_reset_time !< The next time DTBT should be calculated. @@ -241,17 +249,17 @@ module MOM 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, pointer, dimension(:,:,:) :: & - h_pre_dyn => NULL(), & !< The thickness before the transports, in H. - T_pre_dyn => NULL(), & !< Temperature before the transports, in degC. - S_pre_dyn => NULL() !< Salinity before the transports, in psu. + 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]. + S_pre_dyn => NULL() !< Salinity before the transports [ppt]. type(accel_diag_ptrs) :: ADp !< structure containing pointers to accelerations, !! for derived diagnostics (e.g., energy budgets) type(cont_diag_ptrs) :: CDp !< structure containing pointers to continuity equation !! terms, for derived diagnostics (e.g., energy budgets) - real, pointer, dimension(:,:,:) :: & - u_prev => NULL(), & !< previous value of u stored for diagnostics - v_prev => NULL() !< previous value of v stored for diagnostics + real, dimension(:,:,:), pointer :: & + u_prev => NULL(), & !< previous value of u stored for diagnostics [m s-1] + v_prev => NULL() !< previous value of v stored for diagnostics [m s-1] logical :: interp_p_surf !< If true, linearly interpolate surface pressure !! over the coupling time step, using specified value @@ -259,10 +267,10 @@ module MOM logical :: p_surf_prev_set !< If true, p_surf_prev has been properly set from !! a previous time-step or the ocean restart file. !! This is only valid when interp_p_surf is true. - real, pointer, dimension(:,:) :: & - p_surf_prev => NULL(), & !< surface pressure (Pa) at end previous call to step_MOM - p_surf_begin => NULL(), & !< surface pressure (Pa) at start of step_MOM_dyn_... - p_surf_end => NULL() !< surface pressure (Pa) at end of step_MOM_dyn_... + real, dimension(:,:), pointer :: & + p_surf_prev => NULL(), & !< surface pressure [Pa] at end previous call to step_MOM + p_surf_begin => NULL(), & !< surface pressure [Pa] at start of step_MOM_dyn_... + p_surf_end => NULL() !< surface pressure [Pa] at end of step_MOM_dyn_... ! Variables needed to reach between start and finish phases of initialization logical :: write_IC !< If true, then the initial conditions will be written to file @@ -273,63 +281,88 @@ module MOM ! These elements are used to control the calculation and error checking of the surface state real :: Hmix !< Diagnostic mixed layer thickness over which to - !! average surface tracer properties (in meter) when - !! bulk mixed layer is not used, or a negative value + !! average surface tracer properties when a bulk + !! mixed layer is not used [Z ~> m], or a negative value !! if a bulk mixed layer is being used. + real :: HFrz !< If HFrz > 0, melt potential will be computed. + !! The actual depth over which melt potential is computed will + !! min(HFrz, OBLD), where OBLD is the boundary layer depth. + !! If HFrz <= 0 (default), melt potential will not be computed. real :: Hmix_UV !< Depth scale over which to average surface flow to - !! feedback to the coupler/driver (m) when + !! feedback to the coupler/driver [Z ~> m] when !! bulk mixed layer is not used, or a negative value !! if a bulk mixed layer is being used. logical :: check_bad_sfc_vals !< If true, scan surface state for ridiculous values. - real :: bad_val_ssh_max !< Maximum SSH before triggering bad value message - real :: bad_val_sst_max !< Maximum SST before triggering bad value message - real :: bad_val_sst_min !< Minimum SST before triggering bad value message - real :: bad_val_sss_max !< Maximum SSS before triggering bad value message - real :: bad_vol_col_thick !< Minimum column thickness before triggering bad value message - - ! Structures and handles used for diagnostics. - type(MOM_diag_IDs) :: IDs - type(transport_diag_IDs) :: transport_IDs - type(surface_diag_IDs) :: sfc_IDs - type(diag_grid_storage) :: diag_pre_sync, diag_pre_dyn + real :: bad_val_ssh_max !< Maximum SSH before triggering bad value message [m] + real :: bad_val_sst_max !< Maximum SST before triggering bad value message [degC] + real :: bad_val_sst_min !< Minimum SST before triggering bad value message [degC] + real :: bad_val_sss_max !< Maximum SSS before triggering bad value message [ppt] + real :: bad_val_col_thick !< Minimum column thickness before triggering bad value message [m] + + type(MOM_diag_IDs) :: IDs !< Handles used for diagnostics. + type(transport_diag_IDs) :: transport_IDs !< Handles used for transport diagnostics. + type(surface_diag_IDs) :: sfc_IDs !< Handles used for surface diagnostics. + type(diag_grid_storage) :: diag_pre_sync !< The grid (thicknesses) before remapping + type(diag_grid_storage) :: diag_pre_dyn !< The grid (thicknesses) before dynamics ! The remainder of this type provides pointers to child module control structures. - ! These are used for the dynamics updates - type(MOM_dyn_unsplit_CS), pointer :: dyn_unsplit_CSp => NULL() - type(MOM_dyn_unsplit_RK2_CS), pointer :: dyn_unsplit_RK2_CSp => NULL() - type(MOM_dyn_split_RK2_CS), pointer :: dyn_split_RK2_CSp => NULL() - type(thickness_diffuse_CS), pointer :: thickness_diffuse_CSp => NULL() + type(MOM_dyn_unsplit_CS), pointer :: dyn_unsplit_CSp => NULL() + !< Pointer to the control structure used for the unsplit dynamics + type(MOM_dyn_unsplit_RK2_CS), pointer :: dyn_unsplit_RK2_CSp => NULL() + !< Pointer to the control structure used for the unsplit RK2 dynamics + type(MOM_dyn_split_RK2_CS), pointer :: dyn_split_RK2_CSp => NULL() + !< Pointer to the control structure used for the mode-split RK2 dynamics + type(thickness_diffuse_CS), pointer :: thickness_diffuse_CSp => NULL() + !< Pointer to the control structure used for the isopycnal height diffusive transport. + !! This is also common referred to as Gent-McWilliams diffusion type(mixedlayer_restrat_CS), pointer :: mixedlayer_restrat_CSp => NULL() - - type(set_visc_CS), pointer :: set_visc_CSp => NULL() - type(diabatic_CS), pointer :: diabatic_CSp => NULL() - type(MEKE_CS), pointer :: MEKE_CSp => NULL() - type(VarMix_CS), pointer :: VarMix => NULL() - - ! These are used for tracer advection, diffusion, and remapping - type(tracer_registry_type), pointer :: tracer_Reg => NULL() - type(tracer_advect_CS), pointer :: tracer_adv_CSp => NULL() - type(tracer_hor_diff_CS), pointer :: tracer_diff_CSp => NULL() - type(tracer_flow_control_CS), pointer :: tracer_flow_CSp => NULL() - ! This might not be needed outside of initialization? - type(update_OBC_CS), pointer :: update_OBC_CSp => NULL() - type(ocean_OBC_type), pointer :: OBC => NULL() - type(sponge_CS), pointer :: sponge_CSp => NULL() - type(ALE_sponge_CS), pointer :: ALE_sponge_CSp => NULL() - type(ALE_CS), pointer :: ALE_CSp => NULL() - - type(sum_output_CS), pointer :: sum_output_CSp => NULL() - type(diagnostics_CS), pointer :: diagnostics_CSp => NULL() - type(diag_to_Z_CS), pointer :: diag_to_Z_CSp => NULL() - type(offline_transport_CS), pointer :: offline_CSp => NULL() - - logical :: ensemble_ocean !< if true, this run is part of a - !! larger ensemble for the purpose of data assimilation - !! or statistical analysis. - type(ODA_CS), pointer :: odaCS => NULL() !< a pointer to the control structure for handling - !! ensemble model state vectors and data assimilation - !! increments and priors + !< Pointer to the control structure used for the mixed layer restratification + type(set_visc_CS), pointer :: set_visc_CSp => NULL() + !< Pointer to the control structure used to set viscosities + type(diabatic_CS), pointer :: diabatic_CSp => NULL() + !< Pointer to the control structure for the diabatic driver + type(MEKE_CS), pointer :: MEKE_CSp => NULL() + !< Pointer to the control structure for the MEKE updates + type(VarMix_CS), pointer :: VarMix => NULL() + !< Pointer to the control structure for the variable mixing module + + type(tracer_registry_type), pointer :: tracer_Reg => NULL() + !< Pointer to the MOM tracer registry + type(tracer_advect_CS), pointer :: tracer_adv_CSp => NULL() + !< Pointer to the MOM tracer advection control structure + type(tracer_hor_diff_CS), pointer :: tracer_diff_CSp => NULL() + !< Pointer to the MOM along-isopycnal tracer diffusion control structure + type(tracer_flow_control_CS), pointer :: tracer_flow_CSp => NULL() + !< Pointer to the control structure that orchestrates the calling of tracer packages + !### update_OBC_CS might not be needed outside of initialization? + type(update_OBC_CS), pointer :: update_OBC_CSp => NULL() + !< Pointer to the control structure for updating open boundary condition properties + type(ocean_OBC_type), pointer :: OBC => NULL() + !< Pointer to the MOM open boundary condition type + type(sponge_CS), pointer :: sponge_CSp => NULL() + !< Pointer to the layered-mode sponge control structure + type(ALE_sponge_CS), pointer :: ALE_sponge_CSp => NULL() + !< Pointer to the ALE-mode sponge control structure + type(ALE_CS), pointer :: ALE_CSp => NULL() + !< Pointer to the Arbitrary Lagrangian Eulerian (ALE) vertical coordinate control structure + + ! Pointers to control structures used for diagnostics + type(sum_output_CS), pointer :: sum_output_CSp => NULL() + !< 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 + + logical :: ensemble_ocean !< if true, this run is part of a + !! larger ensemble for the purpose of data assimilation + !! or statistical analysis. + type(ODA_CS), pointer :: odaCS => NULL() !< a pointer to the control structure for handling + !! ensemble model state vectors and data assimilation + !! increments and priors end type MOM_control_struct public initialize_MOM, finish_MOM_initialization, MOM_end @@ -338,6 +371,7 @@ module MOM public get_MOM_state_elements, MOM_state_is_synchronized public allocate_surface_state, deallocate_surface_state +!>@{ CPU time clock IDs integer :: id_clock_ocean integer :: id_clock_dynamics integer :: id_clock_thermo @@ -356,6 +390,7 @@ module MOM integer :: id_clock_ALE integer :: id_clock_other integer :: id_clock_offline_tracer +!!@} contains @@ -368,13 +403,14 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & Waves, do_dynamics, do_thermodynamics, start_cycle, & end_cycle, cycle_length, reset_therm) type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(forcing), intent(inout) :: fluxes !< pointers to forcing fields + type(forcing), intent(inout) :: fluxes !< A structure with pointers to themodynamic, + !! tracer and mass exchange forcing fields type(surface), intent(inout) :: sfc_state !< surface ocean state type(time_type), intent(in) :: Time_start !< starting time of a segment, as a time type - real, intent(in) :: time_interval !< time interval covered by this run segment, in s. + real, intent(in) :: time_interval !< time interval covered by this run segment [s]. type(MOM_control_struct), pointer :: CS !< control structure from initialize_MOM type(Wave_parameters_CS), & - optional, pointer :: Waves !< An optional pointer to a wave proptery CS + optional, pointer :: Waves !< An optional pointer to a wave property CS logical, optional, intent(in) :: do_dynamics !< Present and false, do not do updates due !! to the dynamics. logical, optional, intent(in) :: do_thermodynamics !< Present and false, do not do updates due @@ -386,33 +422,34 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & !! treated as the last call to step_MOM in a !! time-stepping cycle; missing is like true. real, optional, intent(in) :: cycle_length !< The amount of time in a coupled time - !! stepping cycle, in s. + !! stepping cycle [s]. logical, optional, intent(in) :: reset_therm !< This indicates whether the running sums of !! thermodynamic quantities should be reset. !! If missing, this is like start_cycle. - ! local - type(ocean_grid_type), pointer :: G ! pointer to a structure containing - ! metrics and related information - type(verticalGrid_type), pointer :: GV => NULL() - + ! local variables + type(ocean_grid_type), pointer :: G => NULL() ! pointer to a structure containing + ! metrics and related information + type(verticalGrid_type), pointer :: GV => NULL() ! Pointer to the vertical grid structure + type(unit_scale_type), pointer :: US => NULL() ! Pointer to a structure containing + ! various unit conversion factors integer :: ntstep ! time steps between tracer updates or diabatic forcing integer :: n_max ! number of steps to take in this call integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, n integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - real :: dt ! baroclinic time step (sec) - real :: dtth ! time step for thickness diffusion (sec) - real :: dtdia ! time step for diabatic processes (sec) - real :: dt_therm ! a limited and quantized version of CS%dt_therm (sec) - real :: dt_therm_here ! a further limited value of dt_therm (sec) + real :: dt ! baroclinic time step [s] + real :: dtth ! time step for thickness diffusion [s] + real :: dtdia ! time step for diabatic processes [s] + real :: dt_therm ! a limited and quantized version of CS%dt_therm [s] + real :: dt_therm_here ! a further limited value of dt_therm [s] real :: wt_end, wt_beg real :: bbl_time_int ! The amount of time over which the calculated BBL ! properties will apply, for use in diagnostics, or 0 - ! if it is not to be calculated anew (sec). - real :: rel_time = 0.0 ! relative time since start of this call (sec). + ! if it is not to be calculated anew [s]. + real :: rel_time = 0.0 ! relative time since start of this call [s]. logical :: calc_dtbt ! Indicates whether the dynamically adjusted ! barotropic time step needs to be updated. @@ -427,23 +464,23 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & logical :: cycle_end ! If true, do calculations and diagnostics that are only done at ! the end of a stepping cycle (whatever that may mean). logical :: therm_reset ! If true, reset running sums of thermodynamic quantities. - real :: cycle_time ! The length of the coupled time-stepping cycle, in s. + real :: cycle_time ! The length of the coupled time-stepping cycle [s]. real, dimension(SZI_(CS%G),SZJ_(CS%G)) :: & - ssh ! sea surface height, which may be based on eta_av (meter) - - real, pointer, dimension(:,:,:) :: & - u, & ! u : zonal velocity component (m/s) - v, & ! v : meridional velocity component (m/s) - h ! h : layer thickness (meter (Bouss) or kg/m2 (non-Bouss)) - real, pointer, dimension(:,:) :: & - p_surf => NULL() ! A pointer to the ocean surface pressure, in Pa. + ssh ! sea surface height, which may be based on eta_av [m] + + real, dimension(:,:,:), pointer :: & + u => NULL(), & ! u : zonal velocity component [m s-1] + v => NULL(), & ! v : meridional velocity component [m s-1] + h => NULL() ! h : layer thickness [H ~> m or kg m-2] + real, dimension(:,:), pointer :: & + p_surf => NULL() ! A pointer to the ocean surface pressure [Pa]. real :: I_wt_ssh type(time_type) :: Time_local, end_time_thermo, Time_temp type(group_pass_type) :: pass_tau_ustar_psurf logical :: showCallTree - G => CS%G ; GV => CS%GV + G => CS%G ; GV => CS%GV ; US => CS%US is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -515,6 +552,8 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & dt = time_interval / real(n_max) dt_therm = dt ; ntstep = 1 if (associated(fluxes%p_surf)) p_surf => fluxes%p_surf + + if (CS%UseWaves) call pass_var(fluxes%ustar, G%Domain, clock=id_clock_pass) endif if (therm_reset) then @@ -530,9 +569,9 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & do j=js,je ; do i=is,ie ; CS%ssh_rint(i,j) = 0.0 ; enddo ; enddo if (associated(CS%VarMix)) then - call enable_averaging(cycle_time, Time_start+set_time(int(cycle_time)), & + call enable_averaging(cycle_time, Time_start + real_to_time(cycle_time), & CS%diag) - call calc_resoln_function(h, CS%tv, G, GV, CS%VarMix) + call calc_resoln_function(h, CS%tv, G, GV, US, CS%VarMix) call disable_averaging(CS%diag) endif endif @@ -553,13 +592,23 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & else CS%p_surf_end => forces%p_surf endif + + if (CS%UseWaves) then + ! Update wave information, which is presently kept static over each call to step_mom + call enable_averaging(time_interval, Time_start + real_to_time(time_interval), CS%diag) + call Update_Stokes_Drift(G, GV, US, Waves, h, forces%ustar) + call disable_averaging(CS%diag) + endif + else ! not do_dyn. + if (CS%UseWaves) & ! Diagnostics are not enabled in this call. + call Update_Stokes_Drift(G, GV, US, Waves, h, fluxes%ustar) endif if (CS%debug) then if (cycle_start) & call MOM_state_chksum("Before steps ", u, v, h, CS%uh, CS%vh, G, GV) if (cycle_start) call check_redundant("Before steps ", u, v, G) - if (do_dyn) call MOM_mech_forcing_chksum("Before steps", forces, G, haloshift=0) + if (do_dyn) call MOM_mech_forcing_chksum("Before steps", forces, G, US, haloshift=0) if (do_dyn) call check_redundant("Before steps ", forces%taux, forces%tauy, G) endif call cpu_clock_end(id_clock_other) @@ -568,19 +617,9 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & do n=1,n_max rel_time = rel_time + dt ! The relative time at the end of the step. ! Set the universally visible time to the middle of the time step. - CS%Time = Time_start + set_time(int(floor(0.5 + rel_time - 0.5*dt))) + CS%Time = Time_start + real_to_time(rel_time - 0.5*dt) ! Set the local time to the end of the time step. - Time_local = Time_start + set_time(int(floor(rel_time+0.5))) - - !### Update_Stokes_Drift must be behind a do_dyn or a do_thermo test. - if (CS%UseWaves) then - ! Update wave information, which is presently kept static over each call to step_mom - !bgr 3/15/18: Need to enable_averaging here to enable output of Stokes drift from the - ! update_stokes_drift routine. Other options? - call enable_averaging(dt, Time_local, CS%diag) - call Update_Stokes_Drift(G, GV, Waves, h, forces%ustar) - call disable_averaging(CS%diag) - endif + Time_local = Time_start + real_to_time(rel_time) if (showCallTree) call callTree_enter("DT cycles (step_MOM) n=",n) @@ -603,16 +642,18 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & dtdia = dt*min(ntstep,n_max-(n-1)) endif - ! If necessary, temporarily reset CS%Time to the center of the period covered - ! by the call to step_MOM_thermo, noting that they begin at the same time. - if (dtdia > dt) CS%Time = CS%Time + set_time(int(floor(0.5*(dtdia-dt) + 0.5))) - - ! The end-time of the diagnostic interval needs to be set ahead if there - ! are multiple dynamic time steps worth of thermodynamics applied here. - end_time_thermo = Time_local + set_time(int(floor(dtdia-dt+0.5))) + end_time_thermo = Time_local + if (dtdia > dt) then + ! If necessary, temporarily reset CS%Time to the center of the period covered + ! by the call to step_MOM_thermo, noting that they begin at the same time. + CS%Time = CS%Time + real_to_time(0.5*(dtdia-dt)) + ! The end-time of the diagnostic interval needs to be set ahead if there + ! are multiple dynamic time steps worth of thermodynamics applied here. + end_time_thermo = Time_local + real_to_time(dtdia-dt) + endif ! Apply diabatic forcing, do mixing, and regrid. - call step_MOM_thermo(CS, G, GV, u, v, h, CS%tv, fluxes, dtdia, & + call step_MOM_thermo(CS, G, GV, US, u, v, h, CS%tv, fluxes, dtdia, & end_time_thermo, .true., Waves=Waves) CS%time_in_thermo_cycle = CS%time_in_thermo_cycle + dtdia @@ -621,7 +662,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & if (showCallTree) call callTree_waypoint("finished diabatic_first (step_MOM)") if (dtdia > dt) & ! Reset CS%Time to its previous value. - CS%Time = Time_start + set_time(int(floor(0.5 + rel_time - 0.5*dt))) + CS%Time = Time_start + real_to_time(rel_time - 0.5*dt) endif ! end of block "(CS%diabatic_first .and. (CS%t_dyn_rel_adv==0.0))" if (do_dyn) then @@ -693,8 +734,13 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & !=========================================================================== ! This is the second place where the diabatic processes and remapping could occur. - if (CS%t_dyn_rel_adv == 0.0 .and. do_thermo .and. .not.CS%diabatic_first) then + if ((CS%t_dyn_rel_adv==0.0) .and. do_thermo .and. (.not.CS%diabatic_first)) then + dtdia = CS%t_dyn_rel_thermo + ! If the MOM6 dynamic and thermodynamic time stepping is being orchestrated + ! by the coupler, the value of diabatic_first does not matter. + if ((CS%t_dyn_rel_thermo==0.0) .and. .not.do_dyn) dtdia = dt + if (CS%thermo_spans_coupling .and. (CS%dt_therm > 1.5*cycle_time) .and. & (abs(dt_therm - dtdia) > 1e-6*dt_therm)) then call MOM_error(FATAL, "step_MOM: Mismatch between dt_therm and dtdia "//& @@ -703,16 +749,22 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & ! If necessary, temporarily reset CS%Time to the center of the period covered ! by the call to step_MOM_thermo, noting that they end at the same time. - if (dtdia > dt) CS%Time = CS%Time - set_time(int(floor(0.5*(dtdia-dt) + 0.5))) + if (dtdia > dt) CS%Time = CS%Time - real_to_time(0.5*(dtdia-dt)) ! Apply diabatic forcing, do mixing, and regrid. - call step_MOM_thermo(CS, G, GV, u, v, h, CS%tv, fluxes, dtdia, & + call step_MOM_thermo(CS, G, GV, US, u, v, h, CS%tv, fluxes, dtdia, & Time_local, .false., Waves=Waves) CS%time_in_thermo_cycle = CS%time_in_thermo_cycle + dtdia - CS%t_dyn_rel_thermo = 0.0 + + if ((CS%t_dyn_rel_thermo==0.0) .and. .not.do_dyn) then + ! The diabatic processes are now ahead of the dynamics by dtdia. + CS%t_dyn_rel_thermo = -dtdia + else ! The diabatic processes and the dynamics are synchronized. + CS%t_dyn_rel_thermo = 0.0 + endif if (dtdia > dt) & ! Reset CS%Time to its previous value. - CS%Time = Time_start + set_time(int(floor(0.5 + rel_time - 0.5*dt))) + CS%Time = Time_start + real_to_time(rel_time - 0.5*dt) endif if (do_dyn) then @@ -720,7 +772,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & ! Determining the time-average sea surface height is part of the algorithm. ! This may be eta_av if Boussinesq, or need to be diagnosed if not. CS%time_in_cycle = CS%time_in_cycle + dt - call find_eta(h, CS%tv, GV%g_Earth, G, GV, ssh, CS%eta_av_bc) + call find_eta(h, CS%tv, G, GV, US, ssh, CS%eta_av_bc, eta_to_m=1.0) do j=js,je ; do i=is,ie CS%ssh_rint(i,j) = CS%ssh_rint(i,j) + dt*ssh(i,j) enddo ; enddo @@ -738,7 +790,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & call enable_averaging(CS%t_dyn_rel_diag, Time_local, CS%diag) call calculate_diagnostic_fields(u, v, h, CS%uh, CS%vh, CS%tv, CS%ADp, & CS%CDp, p_surf, CS%t_dyn_rel_diag, CS%diag_pre_sync,& - G, GV, CS%diagnostics_CSp) + G, GV, US, CS%diagnostics_CSp) call post_tracer_diagnostics(CS%Tracer_reg, h, CS%diag_pre_sync, CS%diag, G, GV, CS%t_dyn_rel_diag) call diag_copy_diag_to_storage(CS%diag_pre_sync, h, CS%diag) if (showCallTree) call callTree_waypoint("finished calculate_diagnostic_fields (step_MOM)") @@ -746,12 +798,12 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & CS%t_dyn_rel_diag = 0.0 call cpu_clock_begin(id_clock_Z_diag) - if (Time_local + set_time(int(0.5*dt_therm)) > CS%Z_diag_time) then + 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, CS%diag_to_Z_CSp) + 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)") @@ -776,10 +828,10 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & CS%ave_ssh_ibc(i,j) = ssh(i,j) enddo ; enddo if (do_dyn) then - call adjust_ssh_for_p_atm(CS%tv, G, GV, CS%ave_ssh_ibc, forces%p_surf_SSH, & + call adjust_ssh_for_p_atm(CS%tv, G, GV, US, CS%ave_ssh_ibc, forces%p_surf_SSH, & CS%calc_rho_for_sea_lev) elseif (do_thermo) then - call adjust_ssh_for_p_atm(CS%tv, G, GV, CS%ave_ssh_ibc, fluxes%p_surf_SSH, & + call adjust_ssh_for_p_atm(CS%tv, G, GV, US, CS%ave_ssh_ibc, fluxes%p_surf_SSH, & CS%calc_rho_for_sea_lev) endif endif @@ -803,9 +855,15 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & ! Do diagnostics that only occur at the end of a complete forcing step. if (cycle_end) then call cpu_clock_begin(id_clock_diagnostics) - call enable_averaging(CS%time_in_thermo_cycle, Time_local, CS%diag) - call post_surface_diagnostics(CS%sfc_IDs, G, GV, CS%diag, CS%time_in_thermo_cycle, & - sfc_state, CS%tv, ssh, CS%ave_ssh_ibc) + if (CS%time_in_cycle > 0.0) then + call enable_averaging(CS%time_in_cycle, Time_local, CS%diag) + call post_surface_dyn_diags(CS%sfc_IDs, G, CS%diag, sfc_state, ssh) + endif + if (CS%time_in_thermo_cycle > 0.0) then + call enable_averaging(CS%time_in_thermo_cycle, Time_local, CS%diag) + call post_surface_thermo_diags(CS%sfc_IDs, G, GV, US, CS%diag, CS%time_in_thermo_cycle, & + sfc_state, CS%tv, ssh, CS%ave_ssh_ibc) + endif call disable_averaging(CS%diag) call cpu_clock_end(id_clock_diagnostics) endif @@ -817,8 +875,8 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & if (MOM_state_is_synchronized(CS)) & call write_energy(CS%u, CS%v, CS%h, CS%tv, Time_local, CS%nstep_tot, & - G, GV, CS%sum_output_CSp, CS%tracer_flow_CSp, & - dt_forcing=set_time(int(floor(time_interval+0.5))) ) + G, GV, US, CS%sum_output_CSp, CS%tracer_flow_CSp, & + dt_forcing=real_to_time(time_interval) ) call cpu_clock_end(id_clock_other) @@ -827,36 +885,39 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & end subroutine step_MOM +!> Time step the ocean dynamics, including the momentum and continuity equations subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & bbl_time_int, CS, Time_local, Waves) type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces real, dimension(:,:), pointer :: p_surf_begin !< A pointer (perhaps NULL) to the surface !! pressure at the beginning of this dynamic - !! step, intent in, in Pa. + !! step, intent in [Pa]. real, dimension(:,:), pointer :: p_surf_end !< A pointer (perhaps NULL) to the surface !! pressure at the end of this dynamic step, - !! intent in, in Pa. - real, intent(in) :: dt !< time interval covered by this call, in s. + !! intent in [Pa]. + real, intent(in) :: dt !< time interval covered by this call [s]. real, intent(in) :: dt_thermo !< time interval covered by any updates that may - !! span multiple dynamics steps, in s. + !! span multiple dynamics steps [s]. real, intent(in) :: bbl_time_int !< time interval over which updates to the - !! bottom boundary layer properties will apply, - !! in s, or zero not to update the properties. + !! bottom boundary layer properties will apply [s], + !! or zero not to update the properties. type(MOM_control_struct), pointer :: CS !< control structure from initialize_MOM - type(time_type), intent(in) :: Time_local !< Starting time of a segment, as a time type + type(time_type), intent(in) :: Time_local !< End time of a segment, as a time type type(wave_parameters_CS), & optional, pointer :: Waves !< Container for wave related parameters; the - !! fields in Waves are intent(in) here. - - ! local - type(ocean_grid_type), pointer :: G ! pointer to a structure containing - ! metrics and related information - type(verticalGrid_type), pointer :: GV => NULL() + !! fields in Waves are intent in here. + + ! local variables + type(ocean_grid_type), pointer :: G => NULL() ! pointer to a structure containing + ! metrics and related information + type(verticalGrid_type), pointer :: GV => NULL() ! Pointer to the vertical grid structure + type(unit_scale_type), pointer :: US => NULL() ! Pointer to a structure containing + ! various unit conversion factors type(MOM_diag_IDs), pointer :: IDs => NULL() ! A structure with the diagnostic IDs. - real, pointer, dimension(:,:,:) :: & - u, & ! u : zonal velocity component (m/s) - v, & ! v : meridional velocity component (m/s) - h ! h : layer thickness (meter (Bouss) or kg/m2 (non-Bouss)) + real, dimension(:,:,:), pointer :: & + u => NULL(), & ! u : zonal velocity component [m s-1] + v => NULL(), & ! v : meridional velocity component [m s-1] + h => NULL() ! h : layer thickness [H ~> m or kg m-2] logical :: calc_dtbt ! Indicates whether the dynamically adjusted ! barotropic time step needs to be updated. @@ -865,7 +926,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - G => CS%G ; GV => CS%GV ; IDs => CS%IDs + G => CS%G ; GV => CS%GV ; US => CS%US ; IDs => CS%IDs is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -877,11 +938,11 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & if ((CS%t_dyn_rel_adv == 0.0) .and. CS%thickness_diffuse .and. CS%thickness_diffuse_first) then - call enable_averaging(dt_thermo,Time_local+set_time(int(floor(dt_thermo-dt+0.5))), CS%diag) + call enable_averaging(dt_thermo, Time_local+real_to_time(dt_thermo-dt), CS%diag) call cpu_clock_begin(id_clock_thick_diff) if (associated(CS%VarMix)) & - call calc_slope_functions(h, CS%tv, dt, G, GV, CS%VarMix) - call thickness_diffuse(h, CS%uhtr, CS%vhtr, CS%tv, dt_thermo, G, GV, & + call calc_slope_functions(h, CS%tv, dt, G, GV, US, CS%VarMix) + call thickness_diffuse(h, CS%uhtr, CS%vhtr, CS%tv, dt_thermo, G, GV, US, & CS%MEKE, CS%VarMix, CS%CDp, CS%thickness_diffuse_CSp) call cpu_clock_end(id_clock_thick_diff) call pass_var(h, G%Domain, clock=id_clock_pass) !###, halo=max(2,cont_stensil)) @@ -896,10 +957,10 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & ! The bottom boundary layer properties need to be recalculated. if (bbl_time_int > 0.0) then call enable_averaging(bbl_time_int, & - Time_local+set_time(int(bbl_time_int-dt+0.5)), CS%diag) + Time_local + real_to_time(bbl_time_int-dt), CS%diag) ! Calculate the BBL properties and store them inside visc (u,h). call cpu_clock_begin(id_clock_BBL_visc) - call set_viscous_BBL(CS%u, CS%v, CS%h, CS%tv, CS%visc, G, GV, & + call set_viscous_BBL(CS%u, CS%v, CS%h, CS%tv, CS%visc, G, GV, US, & CS%set_visc_CSp, symmetrize=.true.) call cpu_clock_end(id_clock_BBL_visc) if (showCallTree) call callTree_wayPoint("done with set_viscous_BBL (step_MOM)") @@ -913,7 +974,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & calc_dtbt = .false. if (CS%dtbt_reset_period == 0.0) calc_dtbt = .true. if (CS%dtbt_reset_period > 0.0) then - if (Time_local >= CS%dtbt_reset_time) then + if (Time_local >= CS%dtbt_reset_time) then !### Change >= to > here. calc_dtbt = .true. CS%dtbt_reset_time = CS%dtbt_reset_time + CS%dtbt_reset_interval endif @@ -921,7 +982,8 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & call step_MOM_dyn_split_RK2(u, v, h, CS%tv, CS%visc, Time_local, dt, forces, & p_surf_begin, p_surf_end, CS%uh, CS%vh, CS%uhtr, CS%vhtr, & - CS%eta_av_bc, G, GV, CS%dyn_split_RK2_CSp, calc_dtbt, CS%VarMix, CS%MEKE) + CS%eta_av_bc, G, GV, US, CS%dyn_split_RK2_CSp, calc_dtbt, CS%VarMix, CS%MEKE,& + waves=waves) if (showCallTree) call callTree_waypoint("finished step_MOM_dyn_split (step_MOM)") elseif (CS%do_dynamics) then ! ------------------------------------ not SPLIT @@ -935,11 +997,11 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & if (CS%use_RK2) then call step_MOM_dyn_unsplit_RK2(u, v, h, CS%tv, CS%visc, Time_local, dt, forces, & p_surf_begin, p_surf_end, CS%uh, CS%vh, CS%uhtr, CS%vhtr, & - CS%eta_av_bc, G, GV, CS%dyn_unsplit_RK2_CSp, CS%VarMix, CS%MEKE) + CS%eta_av_bc, G, GV, US, CS%dyn_unsplit_RK2_CSp, CS%VarMix, CS%MEKE) else call step_MOM_dyn_unsplit(u, v, h, CS%tv, CS%visc, Time_local, dt, forces, & p_surf_begin, p_surf_end, CS%uh, CS%vh, CS%uhtr, CS%vhtr, & - CS%eta_av_bc, G, GV, CS%dyn_unsplit_CSp, CS%VarMix, CS%MEKE, Waves=Waves) + CS%eta_av_bc, G, GV, US, CS%dyn_unsplit_CSp, CS%VarMix, CS%MEKE, Waves=Waves) endif if (showCallTree) call callTree_waypoint("finished step_MOM_dyn_unsplit (step_MOM)") @@ -951,8 +1013,8 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & if (CS%debug) call hchksum(h,"Pre-thickness_diffuse h", G%HI, haloshift=0, scale=GV%H_to_m) if (associated(CS%VarMix)) & - call calc_slope_functions(h, CS%tv, dt, G, GV, CS%VarMix) - call thickness_diffuse(h, CS%uhtr, CS%vhtr, CS%tv, dt, G, GV, & + call calc_slope_functions(h, CS%tv, dt, G, GV, US, CS%VarMix) + call thickness_diffuse(h, CS%uhtr, CS%vhtr, CS%tv, dt, G, GV, US, & CS%MEKE, CS%VarMix, CS%CDp, CS%thickness_diffuse_CSp) if (CS%debug) call hchksum(h,"Post-thickness_diffuse h", G%HI, haloshift=1, scale=GV%H_to_m) @@ -970,7 +1032,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & endif call cpu_clock_begin(id_clock_ml_restrat) call mixedlayer_restrat(h, CS%uhtr, CS%vhtr, CS%tv, forces, dt, CS%visc%MLD, & - CS%VarMix, G, GV, CS%mixedlayer_restrat_CSp) + CS%VarMix, G, GV, US, CS%mixedlayer_restrat_CSp) call cpu_clock_end(id_clock_ml_restrat) call pass_var(h, G%Domain, clock=id_clock_pass) !###, halo=max(2,cont_stensil)) if (CS%debug) then @@ -985,7 +1047,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & call diag_update_remap_grids(CS%diag) if (CS%useMEKE) call step_forward_MEKE(CS%MEKE, h, CS%VarMix%SN_u, CS%VarMix%SN_v, & - CS%visc, dt, G, GV, CS%MEKE_CSp, CS%uhtr, CS%vhtr) + CS%visc, dt, G, GV, US, CS%MEKE_CSp, CS%uhtr, CS%vhtr) call disable_averaging(CS%diag) ! Advance the dynamics time by dt. @@ -1015,7 +1077,7 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, h, Time_local) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< layer thicknesses after the transports (m or kg/m2) + intent(in) :: h !< layer thicknesses after the transports [H ~> m or kg m-2] type(time_type), intent(in) :: Time_local !< The model time at the end !! of the time step. type(group_pass_type) :: pass_T_S @@ -1077,25 +1139,26 @@ end subroutine step_MOM_tracer_dyn !> MOM_step_thermo orchestrates the thermodynamic time stepping and vertical !! remapping, via calls to diabatic (or adiabatic) and ALE_main. -subroutine step_MOM_thermo(CS, G, GV, u, v, h, tv, fluxes, dtdia, & +subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & Time_end_thermo, update_BBL, Waves) type(MOM_control_struct), intent(inout) :: CS !< Master MOM control structure type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(inout) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & - intent(inout) :: u !< zonal velocity (m/s) + intent(inout) :: u !< zonal velocity [m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & - intent(inout) :: v !< meridional velocity (m/s) + intent(inout) :: v !< meridional velocity [m s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(inout) :: h !< layer thickness (m or kg/m2) + intent(inout) :: h !< layer thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(inout) :: tv !< A structure pointing to various thermodynamic variables type(forcing), intent(inout) :: fluxes !< pointers to forcing fields - real, intent(in) :: dtdia !< The time interval over which to advance, in s + real, intent(in) :: dtdia !< The time interval over which to advance [s] type(time_type), intent(in) :: Time_end_thermo !< End of averaging interval for thermo diags logical, intent(in) :: update_BBL !< If true, calculate the bottom boundary layer properties. type(wave_parameters_CS), & - optional, pointer :: Waves !< Container for wave related parameters; - !! the fields in Waves are intent(in) here. + optional, pointer :: Waves !< Container for wave related parameters + !! the fields in Waves are intent in here. logical :: use_ice_shelf ! Needed for selecting the right ALE interface. logical :: showCallTree @@ -1121,7 +1184,7 @@ subroutine step_MOM_thermo(CS, G, GV, u, v, h, tv, fluxes, dtdia, & ! DIABATIC_FIRST=True. Otherwise diabatic() is called after the dynamics ! and set_viscous_BBL is called as a part of the dynamic stepping. call cpu_clock_begin(id_clock_BBL_visc) - call set_viscous_BBL(u, v, h, tv, CS%visc, G, GV, CS%set_visc_CSp, symmetrize=.true.) + call set_viscous_BBL(u, v, h, tv, CS%visc, G, GV, US, CS%set_visc_CSp, symmetrize=.true.) call cpu_clock_end(id_clock_BBL_visc) if (showCallTree) call callTree_wayPoint("done with set_viscous_BBL (step_MOM_thermo)") endif @@ -1136,12 +1199,18 @@ subroutine step_MOM_thermo(CS, G, GV, u, v, h, tv, fluxes, dtdia, & ! call MOM_state_chksum("Pre-diabatic ",u, v, h, CS%uhtr, CS%vhtr, G, GV) call MOM_thermo_chksum("Pre-diabatic ", tv, G,haloshift=0) call check_redundant("Pre-diabatic ", u, v, G) - call MOM_forcing_chksum("Pre-diabatic", fluxes, G, haloshift=0) + call MOM_forcing_chksum("Pre-diabatic", fluxes, G, US, haloshift=0) endif call cpu_clock_begin(id_clock_diabatic) - call diabatic(u, v, h, tv, CS%Hml, fluxes, CS%visc, CS%ADp, CS%CDp, & - dtdia, Time_end_thermo, G, GV, CS%diabatic_CSp, Waves=Waves) + if (CS%use_legacy_diabatic_driver) then + ! the following subroutine is legacy and will be deleted in the near future. + call legacy_diabatic(u, v, h, tv, CS%Hml, fluxes, CS%visc, CS%ADp, CS%CDp, & + dtdia, Time_end_thermo, G, GV, US, CS%diabatic_CSp, Waves=Waves) + else + call diabatic(u, v, h, tv, CS%Hml, fluxes, CS%visc, CS%ADp, CS%CDp, & + dtdia, Time_end_thermo, G, GV, US, CS%diabatic_CSp, Waves=Waves) + endif fluxes%fluxes_used = .true. call cpu_clock_end(id_clock_diabatic) @@ -1170,10 +1239,10 @@ subroutine step_MOM_thermo(CS, G, GV, u, v, h, tv, fluxes, dtdia, & endif call cpu_clock_begin(id_clock_ALE) if (use_ice_shelf) then - call ALE_main(G, GV, h, u, v, tv, CS%tracer_Reg, CS%ALE_CSp, dtdia, & + call ALE_main(G, GV, US, h, u, v, tv, CS%tracer_Reg, CS%ALE_CSp, dtdia, & fluxes%frac_shelf_h) else - call ALE_main(G, GV, h, u, v, tv, CS%tracer_Reg, CS%ALE_CSp, dtdia) + call ALE_main(G, GV, US, h, u, v, tv, CS%tracer_Reg, CS%ALE_CSp, dtdia) endif if (showCallTree) call callTree_waypoint("finished ALE_main (step_MOM_thermo)") @@ -1265,6 +1334,8 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS ! metrics and related information type(verticalGrid_type), pointer :: GV => NULL() ! Pointer to structure containing information ! about the vertical grid + type(unit_scale_type), pointer :: US => NULL() ! Pointer to a structure containing + ! various unit conversion factors logical :: first_iter !< True if this is the first time step_offline has been called in a given interval logical :: last_iter !< True if this is the last time step_tracer is to be called in an offline interval @@ -1275,23 +1346,22 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS logical :: skip_diffusion integer :: id_eta_diff_end - integer, pointer :: accumulated_time + integer, pointer :: accumulated_time => NULL() integer :: i,j,k integer :: is, ie, js, je, isd, ied, jsd, jed ! 3D pointers - real, dimension(:,:,:), pointer :: & - uhtr, vhtr, & - eatr, ebtr, & - h_end + real, dimension(:,:,:), pointer :: & + uhtr => NULL(), vhtr => NULL(), & + eatr => NULL(), ebtr => NULL(), & + h_end => NULL() ! 2D Array for diagnostics real, dimension(SZI_(CS%G),SZJ_(CS%G)) :: eta_pre, eta_end type(time_type) :: Time_end ! End time of a segment, as a time type ! Grid-related pointer assignments - G => CS%G - GV => CS%GV + G => CS%G ; GV => CS%GV ; US => CS%US is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -1303,7 +1373,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS call enable_averaging(time_interval, Time_end, CS%diag) ! Check to see if this is the first iteration of the offline interval - if(accumulated_time==0) then + if (accumulated_time==0) then first_iter = .true. else ! This is probably unnecessary but is used to guard against unwanted behavior first_iter = .false. @@ -1318,17 +1388,17 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS ! Increment the amount of time elapsed since last read and check if it's time to roll around accumulated_time = mod(accumulated_time + int(time_interval), dt_offline) - if(accumulated_time==0) then + if (accumulated_time==0) then last_iter = .true. else last_iter = .false. endif - if(CS%use_ALE_algorithm) then + if (CS%use_ALE_algorithm) then ! If this is the first iteration in the offline timestep, then we need to read in fields and ! perform the main advection. if (first_iter) then - if(is_root_pe()) print *, "Reading in new offline fields" + call MOM_mesg("Reading in new offline fields") ! Read in new transport and other fields ! call update_transport_from_files(G, GV, CS%offline_CSp, h_end, eatr, ebtr, uhtr, vhtr, & ! CS%tv%T, CS%tv%S, fluxes, CS%use_ALE_algorithm) @@ -1348,9 +1418,9 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS ! Perform offline diffusion if requested if (.not. skip_diffusion) then if (associated(CS%VarMix)) then - call pass_var(CS%h,G%Domain) - call calc_resoln_function(CS%h, CS%tv, G, GV, CS%VarMix) - call calc_slope_functions(CS%h, CS%tv, REAL(dt_offline), G, GV, CS%VarMix) + call pass_var(CS%h, G%Domain) + call calc_resoln_function(CS%h, CS%tv, G, GV, US, CS%VarMix) + call calc_slope_functions(CS%h, CS%tv, REAL(dt_offline), G, GV, US, CS%VarMix) endif call tracer_hordiff(CS%h, REAL(dt_offline), CS%MEKE, CS%VarMix, G, GV, & CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) @@ -1363,7 +1433,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS endif ! Last thing that needs to be done is the final ALE remapping - if(last_iter) then + if (last_iter) then if (CS%diabatic_first) then call offline_advection_ale(fluxes, Time_start, time_interval, CS%offline_CSp, id_clock_ALE, & CS%h, uhtr, vhtr, converged=adv_converged) @@ -1373,16 +1443,16 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS ! Perform offline diffusion if requested if (.not. skip_diffusion) then if (associated(CS%VarMix)) then - call pass_var(CS%h,G%Domain) - call calc_resoln_function(CS%h, CS%tv, G, GV, CS%VarMix) - call calc_slope_functions(CS%h, CS%tv, REAL(dt_offline), G, GV, CS%VarMix) + call pass_var(CS%h, G%Domain) + call calc_resoln_function(CS%h, CS%tv, G, GV, US, CS%VarMix) + call calc_slope_functions(CS%h, CS%tv, REAL(dt_offline), G, GV, US, CS%VarMix) endif call tracer_hordiff(CS%h, REAL(dt_offline), CS%MEKE, CS%VarMix, G, GV, & CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) endif endif - if(is_root_pe()) print *, "Last iteration of offline interval" + call MOM_mesg("Last iteration of offline interval") ! Apply freshwater fluxes out of the ocean call offline_fw_fluxes_out_ocean(G, GV, CS%offline_CSp, fluxes, CS%h) @@ -1403,7 +1473,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS ! Note that for the layer mode case, the calls to tracer sources and sinks is embedded in ! main_offline_advection_layer. Warning: this may not be appropriate for tracers that ! exchange with the atmosphere - if(time_interval .NE. dt_offline) then + if (time_interval /= dt_offline) then call MOM_error(FATAL, & "For offline tracer mode in a non-ALE configuration, dt_offline must equal time_interval") endif @@ -1424,14 +1494,14 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS endif - call adjust_ssh_for_p_atm(CS%tv, G, GV, CS%ave_ssh_ibc, forces%p_surf_SSH, & + call adjust_ssh_for_p_atm(CS%tv, G, GV, US, CS%ave_ssh_ibc, forces%p_surf_SSH, & CS%calc_rho_for_sea_lev) call extract_surface_state(CS, sfc_state) call disable_averaging(CS%diag) - call pass_var(CS%tv%T,G%Domain) - call pass_var(CS%tv%S,G%Domain) - call pass_var(CS%h,G%Domain) + call pass_var(CS%tv%T, G%Domain) + call pass_var(CS%tv%S, G%Domain) + call pass_var(CS%h, G%Domain) fluxes%fluxes_used = .true. @@ -1439,7 +1509,8 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS end subroutine step_offline -!> This subroutine initializes MOM. +!> Initialize MOM, including memory allocation, setting up parameters and diagnostics, +!! initializing the ocean state variables, and initializing subsidiary modules subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & Time_in, offline_tracer_mode, input_restart_file, diag_ptr, & count_calls, tracer_flow_CSp) @@ -1463,32 +1534,29 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & logical, optional, intent(in) :: count_calls !< If true, nstep_tot counts the number of !! calls to step_MOM instead of the number of !! dynamics timesteps. - ! local + ! local variables type(ocean_grid_type), pointer :: G => NULL() ! A pointer to a structure with metrics and related type(hor_index_type) :: HI ! A hor_index_type for array extents type(verticalGrid_type), pointer :: GV => NULL() type(dyn_horgrid_type), pointer :: dG => NULL() - type(diag_ctrl), pointer :: diag - + type(diag_ctrl), pointer :: diag => NULL() + type(unit_scale_type), pointer :: US => NULL() character(len=4), parameter :: vers_num = 'v2.0' -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz integer :: IsdB, IedB, JsdB, JedB - real :: dtbt - real :: Z_diag_int ! minimum interval between calc depth-space diagnostics (sec) - - real, allocatable, dimension(:,:,:) :: e ! interface heights (meter) - real, allocatable, dimension(:,:) :: eta ! free surface height (m) or bottom press (Pa) - real, allocatable, dimension(:,:) :: area_shelf_h ! area occupied by ice shelf - real, dimension(:,:), allocatable, target :: frac_shelf_h ! fraction of total area occupied by ice shelf - real, dimension(:,:), pointer :: shelf_area + real :: dtbt ! The barotropic timestep [s] + real :: Z_diag_int ! minimum interval between calc depth-space diagnosetics [s] + + real, allocatable, dimension(:,:) :: eta ! free surface height or column mass [H ~> m or kg m-2] + real, allocatable, dimension(:,:) :: area_shelf_h ! area occupied by ice shelf [m2] + real, dimension(:,:), allocatable, target :: frac_shelf_h ! fraction of total area occupied by ice shelf [nondim] + real, dimension(:,:), pointer :: shelf_area => NULL() type(MOM_restart_CS), pointer :: restart_CSp_tmp => NULL() type(group_pass_type) :: tmp_pass_uv_T_S_h, pass_uv_T_S_h - ! GMM, the following *is not* used. Should we delete it? - type(group_pass_type) :: tmp_pass_Kv_shear real :: default_val ! default value for a parameter logical :: write_geom_files ! If true, write out the grid geometry files. @@ -1529,7 +1597,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & integer :: nkml, nkbl, verbosity, write_geom integer :: dynamics_stencil ! The computational stencil for the calculations ! in the dynamic core. - real :: conv2watt, conv2salt, H_convert + real :: conv2watt, conv2salt character(len=48) :: flux_units, S_flux_units type(vardesc) :: vd_T, vd_S ! Structures describing temperature and salinity variables. @@ -1578,6 +1646,11 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call unit_tests(verbosity) endif + ! Determining the internal unit scaling factors for this run. + call unit_scaling_init(param_file, CS%US) + + US => CS%US + call get_param(param_file, "MOM", "SPLIT", CS%split, & "Use the split time stepping if true.", default=.true.) if (CS%split) then @@ -1616,6 +1689,10 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "true. This assumes that KD = KDML = 0.0 and that \n"//& "there is no buoyancy forcing, but makes the model \n"//& "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"//& + "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"//& @@ -1704,13 +1781,18 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "If BULKMIXEDLAYER is false, HMIX_SFC_PROP is the depth \n"//& "over which to average to find surface properties like \n"//& "SST and SSS or density (but not surface velocities).", & - units="m", default=1.0) + 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"//& "SSU, SSV. A non-positive value indicates no averaging.", & - units="m", default=0.) + 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"//& + "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"//& @@ -1806,7 +1888,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "The value of SST below which a bad value message is \n"//& "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_vol_col_thick, & + 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"//& "triggered, if CHECK_BAD_SURFACE_VALS is true.", units="m", & default=0.0) @@ -1894,9 +1976,9 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call create_dyn_horgrid(dG, HI, bathymetry_at_vel=bathy_at_vel) call clone_MOM_domain(G%Domain, dG%Domain) - call verticalGridInit( param_file, CS%GV ) + call verticalGridInit( param_file, CS%GV, US ) GV => CS%GV -! dG%g_Earth = GV%g_Earth +! dG%g_Earth = (GV%g_Earth*US%m_to_Z) ! Allocate the auxiliary non-symmetric domain for debugging or I/O purposes. if (CS%debug .or. dG%symmetric) & @@ -1904,12 +1986,12 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call callTree_waypoint("grids initialized (initialize_MOM)") - call MOM_timing_init(CS) ! Allocate initialize time-invariant MOM variables. - call MOM_initialize_fixed(dG, CS%OBC, param_file, write_geom_files, dirs%output_directory) + call MOM_initialize_fixed(dG, US, CS%OBC, param_file, write_geom_files, dirs%output_directory) call callTree_waypoint("returned from MOM_initialize_fixed() (initialize_MOM)") + if (associated(CS%OBC)) call call_OBC_register(param_file, CS%update_OBC_CSp, CS%OBC) call tracer_registry_init(param_file, CS%tracer_Reg) @@ -1920,7 +2002,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & IsdB = dG%IsdB ; IedB = dG%IedB ; JsdB = dG%JsdB ; JedB = dG%JedB ALLOC_(CS%u(IsdB:IedB,jsd:jed,nz)) ; CS%u(:,:,:) = 0.0 ALLOC_(CS%v(isd:ied,JsdB:JedB,nz)) ; CS%v(:,:,:) = 0.0 - ALLOC_(CS%h(isd:ied,jsd:jed,nz)) ; CS%h(:,:,:) = GV%Angstrom + ALLOC_(CS%h(isd:ied,jsd:jed,nz)) ; CS%h(:,:,:) = GV%Angstrom_H ALLOC_(CS%uh(IsdB:IedB,jsd:jed,nz)) ; CS%uh(:,:,:) = 0.0 ALLOC_(CS%vh(isd:ied,JsdB:JedB,nz)) ; CS%vh(:,:,:) = 0.0 if (use_temperature) then @@ -1951,10 +2033,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & conv2watt = GV%H_to_kg_m2 * CS%tv%C_p if (GV%Boussinesq) then conv2salt = GV%H_to_m ! Could change to GV%H_to_kg_m2 * 0.001? - H_convert = GV%H_to_m else conv2salt = GV%H_to_kg_m2 - H_convert = GV%H_to_kg_m2 endif call register_tracer(CS%tv%T, CS%tracer_Reg, param_file, dG%HI, GV, & tr_desc=vd_T, registry_diags=.true., flux_nameroot='T', & @@ -2040,7 +2120,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! Set the fields that are needed for bitwise identical restarting ! the time stepping scheme. call restart_init(param_file, restart_CSp) - call set_restart_fields(GV, param_file, CS, restart_CSp) + call set_restart_fields(GV, US, param_file, CS, restart_CSp) if (CS%split) then call register_restarts_dyn_split_RK2(dG%HI, GV, param_file, & CS%dyn_split_RK2_CSp, restart_CSp, CS%uh, CS%vh) @@ -2054,7 +2134,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! This subroutine calls user-specified tracer registration routines. ! Additional calls can be added to MOM_tracer_flow_control.F90. - call call_tracer_register(dG%HI, GV, param_file, CS%tracer_flow_CSp, & + call call_tracer_register(dG%HI, GV, US, param_file, CS%tracer_flow_CSp, & CS%tracer_Reg, restart_CSp) call MEKE_alloc_register_restart(dG%HI, param_file, CS%MEKE, restart_CSp) @@ -2069,12 +2149,12 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! Initialize dynamically evolving fields, perhaps from restart files. call cpu_clock_begin(id_clock_MOM_init) - call MOM_initialize_coord(GV, param_file, write_geom_files, & + call MOM_initialize_coord(GV, US, param_file, write_geom_files, & dirs%output_directory, CS%tv, dG%max_depth) call callTree_waypoint("returned from MOM_initialize_coord() (initialize_MOM)") if (CS%use_ALE_algorithm) then - call ALE_init(param_file, GV, dG%max_depth, CS%ALE_CSp) + call ALE_init(param_file, GV, US, dG%max_depth, CS%ALE_CSp) call callTree_waypoint("returned from ALE_init() (initialize_MOM)") endif @@ -2089,13 +2169,14 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! Set a few remaining fields that are specific to the ocean grid type. call set_first_direction(G, first_direction) ! Allocate the auxiliary non-symmetric domain for debugging or I/O purposes. - if (CS%debug .or. G%symmetric) & + if (CS%debug .or. G%symmetric) then call clone_MOM_domain(G%Domain, G%Domain_aux, symmetric=.false.) + else ; G%Domain_aux => G%Domain ; endif ! Copy common variables from the vertical grid to the horizontal grid. ! Consider removing this later? - G%ke = GV%ke ; G%g_Earth = GV%g_Earth + G%ke = GV%ke ; G%g_Earth = (GV%g_Earth*US%m_to_Z) - call MOM_initialize_state(CS%u, CS%v, CS%h, CS%tv, Time, G, GV, param_file, & + call MOM_initialize_state(CS%u, CS%v, CS%h, CS%tv, Time, G, GV, US, param_file, & dirs, restart_CSp, CS%ALE_CSp, CS%tracer_Reg, & CS%sponge_CSp, CS%ALE_sponge_CSp, CS%OBC, Time_in) call cpu_clock_end(id_clock_MOM_init) @@ -2119,9 +2200,10 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call MOM_grid_end(G) ; deallocate(G) G => CS%G - if (CS%debug .or. CS%G%symmetric) & + if (CS%debug .or. CS%G%symmetric) then call clone_MOM_domain(CS%G%Domain, CS%G%Domain_aux, symmetric=.false.) - G%ke = GV%ke ; G%g_Earth = GV%g_Earth + else ; CS%G%Domain_aux => CS%G%Domain ;endif + G%ke = GV%ke ; G%g_Earth = (GV%g_Earth*US%m_to_Z) endif @@ -2158,10 +2240,10 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & enddo ; enddo ! pass to the pointer shelf_area => frac_shelf_h - call ALE_main(G, GV, CS%h, CS%u, CS%v, CS%tv, CS%tracer_Reg, CS%ALE_CSp, & + call ALE_main(G, GV, US, CS%h, CS%u, CS%v, CS%tv, CS%tracer_Reg, CS%ALE_CSp, & frac_shelf_h = shelf_area) else - call ALE_main( G, GV, CS%h, CS%u, CS%v, CS%tv, CS%tracer_Reg, CS%ALE_CSp ) + call ALE_main( G, GV, US, CS%h, CS%u, CS%v, CS%tv, CS%tracer_Reg, CS%ALE_CSp ) endif call cpu_clock_begin(id_clock_pass_init) @@ -2183,7 +2265,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & diag => CS%diag ! Initialize the diag mediator. - call diag_mediator_init(G, GV, GV%ke, param_file, diag, doc_file_dir=dirs%output_directory) + call diag_mediator_init(G, GV, US, GV%ke, param_file, diag, doc_file_dir=dirs%output_directory) if (present(diag_ptr)) diag_ptr => CS%diag ! Initialize the diagnostics masks for native arrays. @@ -2197,7 +2279,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! This call sets up the diagnostic axes. These are needed, ! e.g. to generate the target grids below. - call set_axes_info(G, GV, param_file, diag) + call set_axes_info(G, GV, US, param_file, diag) ! Whenever thickness/T/S changes let the diag manager know, target grids ! for vertical remapping may need to be regenerated. @@ -2215,7 +2297,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call set_masks_for_axes(G, diag) ! Diagnose static fields AND associate areas/volumes with axes - call write_static_fields(G, GV, CS%tv, CS%diag) + call write_static_fields(G, GV, US, CS%tv, CS%diag) call callTree_waypoint("static fields written (initialize_MOM)") ! Register the volume cell measure (must be one of first diagnostics) @@ -2230,17 +2312,17 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & CS%useMEKE = MEKE_init(Time, G, param_file, diag, CS%MEKE_CSp, CS%MEKE, restart_CSp) - call VarMix_init(Time, G, param_file, diag, CS%VarMix) - call set_visc_init(Time, G, GV, param_file, diag, CS%visc, CS%set_visc_CSp, CS%OBC) + call VarMix_init(Time, G, GV, US, param_file, diag, CS%VarMix) + call set_visc_init(Time, G, GV, US, param_file, diag, CS%visc, CS%set_visc_CSp, restart_CSp, CS%OBC) if (CS%split) then allocate(eta(SZI_(G),SZJ_(G))) ; eta(:,:) = 0.0 call initialize_dyn_split_RK2(CS%u, CS%v, CS%h, CS%uh, CS%vh, eta, Time, & - G, GV, param_file, diag, CS%dyn_split_RK2_CSp, restart_CSp, & + G, GV, US, param_file, diag, CS%dyn_split_RK2_CSp, restart_CSp, & CS%dt, CS%ADp, CS%CDp, MOM_internal_state, CS%VarMix, CS%MEKE, & CS%OBC, CS%update_OBC_CSp, CS%ALE_CSp, CS%set_visc_CSp, & CS%visc, dirs, CS%ntrunc, calc_dtbt=calc_dtbt) if (CS%dtbt_reset_period > 0.0) then - CS%dtbt_reset_interval = set_time(int(floor(CS%dtbt_reset_period))) + CS%dtbt_reset_interval = real_to_time(CS%dtbt_reset_period) ! Set dtbt_reset_time to be the next even multiple of dtbt_reset_interval. CS%dtbt_reset_time = Time_init + CS%dtbt_reset_interval * & ((Time - Time_init) / CS%dtbt_reset_interval) @@ -2252,21 +2334,21 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & endif endif elseif (CS%use_RK2) then - call initialize_dyn_unsplit_RK2(CS%u, CS%v, CS%h, Time, G, GV, & + call initialize_dyn_unsplit_RK2(CS%u, CS%v, CS%h, Time, G, GV, US, & param_file, diag, CS%dyn_unsplit_RK2_CSp, restart_CSp, & CS%ADp, CS%CDp, MOM_internal_state, CS%OBC, CS%update_OBC_CSp, & CS%ALE_CSp, CS%set_visc_CSp, CS%visc, dirs, CS%ntrunc) else - call initialize_dyn_unsplit(CS%u, CS%v, CS%h, Time, G, GV, & + call initialize_dyn_unsplit(CS%u, CS%v, CS%h, Time, G, GV, US, & param_file, diag, CS%dyn_unsplit_CSp, restart_CSp, & CS%ADp, CS%CDp, MOM_internal_state, CS%OBC, CS%update_OBC_CSp, & CS%ALE_CSp, CS%set_visc_CSp, CS%visc, dirs, CS%ntrunc) endif call callTree_waypoint("dynamics initialized (initialize_MOM)") - call thickness_diffuse_init(Time, G, GV, param_file, diag, CS%CDp, CS%thickness_diffuse_CSp) - CS%mixedlayer_restrat = mixedlayer_restrat_init(Time, G, GV, param_file, diag, & - CS%mixedlayer_restrat_CSp) + call thickness_diffuse_init(Time, G, GV, US, param_file, diag, CS%CDp, CS%thickness_diffuse_CSp) + CS%mixedlayer_restrat = mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, & + CS%mixedlayer_restrat_CSp, restart_CSp) if (CS%mixedlayer_restrat) then if (.not.(bulkmixedlayer .or. CS%use_ALE_algorithm)) & call MOM_error(FATAL, "MOM: MIXEDLAYER_RESTRAT true requires a boundary layer scheme.") @@ -2275,15 +2357,14 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call pass_var(CS%visc%MLD, G%domain, halo=1) endif - call MOM_diagnostics_init(MOM_internal_state, CS%ADp, CS%CDp, Time, G, GV, & + call MOM_diagnostics_init(MOM_internal_state, CS%ADp, CS%CDp, Time, G, GV, US, & 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 = set_time(int((CS%dt_therm) * & - max(1,floor(0.01 + Z_diag_int/(CS%dt_therm))))) - call MOM_diag_to_Z_init(Time, G, GV, param_file, diag, CS%diag_to_Z_CSp) + 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 + set_time(int(CS%dt_therm))) - Start_time) / CS%Z_diag_interval) + ((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) @@ -2295,7 +2376,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call adiabatic_driver_init(Time, G, param_file, diag, CS%diabatic_CSp, & CS%tracer_flow_CSp, CS%diag_to_Z_CSp) else - call diabatic_driver_init(Time, G, GV, param_file, CS%use_ALE_algorithm, diag, & + 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) endif @@ -2314,12 +2395,12 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call register_tracer_diagnostics(CS%tracer_Reg, CS%h, Time, diag, G, GV, & CS%use_ALE_algorithm, CS%diag_to_Z_CSp) if (CS%use_ALE_algorithm) then - call ALE_register_diags(Time, G, GV, diag, CS%ALE_CSp) + call ALE_register_diags(Time, G, GV, US, diag, CS%ALE_CSp) endif ! This subroutine initializes any tracer packages. new_sim = is_new_run(restart_CSp) - call tracer_flow_control_init(.not.new_sim, Time, G, GV, CS%h, param_file, & + 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) if (present(tracer_flow_CSp)) tracer_flow_CSp => CS%tracer_flow_CSp @@ -2353,6 +2434,9 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & if (associated(CS%visc%Kv_shear)) & call pass_var(CS%visc%Kv_shear, G%Domain, To_All+Omit_Corners, halo=1) + if (associated(CS%visc%Kv_slow)) & + call pass_var(CS%visc%Kv_slow, G%Domain, To_All+Omit_Corners, halo=1) + call cpu_clock_end(id_clock_pass_init) call register_obsolete_diagnostics(param_file, CS%diag) @@ -2371,16 +2455,16 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & if (.not.query_initialized(CS%ave_ssh_ibc,"ave_ssh",restart_CSp)) then if (CS%split) then - call find_eta(CS%h, CS%tv, GV%g_Earth, G, GV, CS%ave_ssh_ibc, eta) + call find_eta(CS%h, CS%tv, G, GV, US, CS%ave_ssh_ibc, eta, eta_to_m=1.0) else - call find_eta(CS%h, CS%tv, GV%g_Earth, G, GV, CS%ave_ssh_ibc) + call find_eta(CS%h, CS%tv, G, GV, US, CS%ave_ssh_ibc, eta_to_m=1.0) endif endif if (CS%split) deallocate(eta) CS%nstep_tot = 0 if (present(count_calls)) CS%count_calls = count_calls - call MOM_sum_output_init(G, param_file, dirs%output_directory, & + call MOM_sum_output_init(G, US, param_file, dirs%output_directory, & CS%ntrunc, Time_init, CS%sum_output_CSp) ! Flag whether to save initial conditions in finish_MOM_initialization() or not. @@ -2388,44 +2472,52 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & .not.((dirs%input_filename(1:1) == 'r') .and. & (LEN_TRIM(dirs%input_filename) == 1)) - if (CS%ensemble_ocean) then - call init_oda(Time, G, GV, CS%odaCS) + call init_oda(Time, G, GV, CS%odaCS) endif + !### This could perhaps go here instead of in finish_MOM_initialization? + ! call fix_restart_scaling(GV) + ! call fix_restart_unit_scaling(US) + call callTree_leave("initialize_MOM()") call cpu_clock_end(id_clock_init) end subroutine initialize_MOM -!> This subroutine finishes initializing MOM and writes out the initial conditions. -subroutine finish_MOM_initialization(Time, dirs, CS, fluxes, restart_CSp) +!> Finishes initializing MOM and writes out the initial conditions. +subroutine finish_MOM_initialization(Time, dirs, CS, restart_CSp) type(time_type), intent(in) :: Time !< model time, used in this routine type(directories), intent(in) :: dirs !< structure with directory paths type(MOM_control_struct), pointer :: CS !< pointer to MOM control structure - type(forcing), intent(inout) :: fluxes !< pointers to forcing fields type(MOM_restart_CS), pointer :: restart_CSp !< pointer to the restart control !! structure that will be used for MOM. ! Local variables - type(ocean_grid_type), pointer :: G => NULL() - type(verticalGrid_type), pointer :: GV => NULL() - type(MOM_restart_CS), pointer :: restart_CSp_tmp => NULL() - real, allocatable :: z_interface(:,:,:) ! Interface heights (meter) - real, allocatable :: eta(:,:) ! Interface heights (meter) + type(ocean_grid_type), pointer :: G => NULL() ! pointer to a structure containing + ! metrics and related information + type(verticalGrid_type), pointer :: GV => NULL() ! Pointer to the vertical grid structure + type(unit_scale_type), pointer :: US => NULL() ! Pointer to a structure containing + ! various unit conversion factors + type(MOM_restart_CS), pointer :: restart_CSp_tmp => NULL() + real, allocatable :: z_interface(:,:,:) ! Interface heights [m] type(vardesc) :: vd call cpu_clock_begin(id_clock_init) call callTree_enter("finish_MOM_initialization()") ! Pointers for convenience - G => CS%G ; GV => CS%GV + G => CS%G ; GV => CS%GV ; US => CS%US + + !### Move to initialize_MOM? + call fix_restart_scaling(GV) + call fix_restart_unit_scaling(US) ! Write initial conditions if (CS%write_IC) then allocate(restart_CSp_tmp) restart_CSp_tmp = restart_CSp allocate(z_interface(SZI_(G),SZJ_(G),SZK_(G)+1)) - call find_eta(CS%h, CS%tv, GV%g_Earth, G, GV, z_interface) + call find_eta(CS%h, CS%tv, G, GV, US, z_interface, eta_to_m=1.0) call register_restart_field(z_interface, "eta", .true., restart_CSp_tmp, & "Interface heights", "meter", z_grid='i') @@ -2435,7 +2527,7 @@ subroutine finish_MOM_initialization(Time, dirs, CS, fluxes, restart_CSp) deallocate(restart_CSp_tmp) endif - call write_energy(CS%u, CS%v, CS%h, CS%tv, Time, 0, G, GV, & + call write_energy(CS%u, CS%v, CS%h, CS%tv, Time, 0, G, GV, US, & CS%sum_output_CSp, CS%tracer_flow_CSp) call callTree_leave("finish_MOM_initialization()") @@ -2473,7 +2565,7 @@ subroutine register_diags(Time, G, GV, IDs, diag) Time, 'Instantaneous Sea Surface Height', 'm') end subroutine register_diags -!> This subroutine sets up clock IDs for timing various subroutines. +!> Set up CPU clock IDs for timing various subroutines. subroutine MOM_timing_init(CS) type(MOM_control_struct), intent(in) :: CS !< control structure set up by initialize_MOM. @@ -2512,8 +2604,9 @@ end subroutine MOM_timing_init !! This routine should be altered if there are any changes to the !! time stepping scheme. The CHECK_RESTART facility may be used to !! confirm that all needed restart fields have been included. -subroutine set_restart_fields(GV, param_file, CS, restart_CSp) +subroutine set_restart_fields(GV, US, param_file, CS, restart_CSp) type(verticalGrid_type), intent(inout) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(inout) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< opened file for parsing to get parameters type(MOM_control_struct), intent(in) :: CS !< control structure set up by inialize_MOM type(MOM_restart_CS), pointer :: restart_CSp !< pointer to the restart control @@ -2558,26 +2651,33 @@ subroutine set_restart_fields(GV, param_file, CS, restart_CSp) call get_param(param_file, '', "ICE_SHELF", use_ice_shelf, default=.false., & do_not_log=.true.) if (use_ice_shelf .and. associated(CS%Hml)) then - call register_restart_field(CS%Hml, "hML", .false., restart_CSp, & - "Mixed layer thickness", "meter") + call register_restart_field(CS%Hml, "hML", .false., restart_CSp, & + "Mixed layer thickness", "meter") endif + ! Register scalar unit conversion factors. + call register_restart_field(US%m_to_Z_restart, "m_to_Z", .false., restart_CSp, & + "Height unit conversion factor", "Z meter-1") + call register_restart_field(GV%m_to_H_restart, "m_to_H", .false., restart_CSp, & + "Thickness unit conversion factor", "Z meter-1") + end subroutine set_restart_fields -!> This subroutine applies a correction to the sea surface height to compensate +!> Apply a correction to the sea surface height to compensate !! for the atmospheric pressure (the inverse barometer). -subroutine adjust_ssh_for_p_atm(tv, G, GV, ssh, p_atm, use_EOS) +subroutine adjust_ssh_for_p_atm(tv, G, GV, US, ssh, p_atm, use_EOS) type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables - type(ocean_grid_type), intent(in) :: G !< ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: ssh !< time mean surface height (m) - real, dimension(:,:), optional, pointer :: p_atm !< atmospheric pressure (Pascal) + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: ssh !< time mean surface height [m] + real, dimension(:,:), optional, pointer :: p_atm !< atmospheric pressure [Pa] logical, optional, intent(in) :: use_EOS !< If true, calculate the density for !! the SSH correction using the equation of state. real :: Rho_conv ! The density used to convert surface pressure to - ! a corrected effective SSH, in kg m-3. - real :: IgR0 ! The SSH conversion factor from Pa to m. + ! a corrected effective SSH [kg m-3]. + real :: IgR0 ! The SSH conversion factor from Pa to m [m Pa-1]. logical :: calc_rho integer :: i, j, is, ie, js, je @@ -2594,38 +2694,40 @@ subroutine adjust_ssh_for_p_atm(tv, G, GV, ssh, p_atm, use_EOS) else Rho_conv=GV%Rho0 endif - IgR0 = 1.0 / (Rho_conv * GV%g_Earth) + IgR0 = 1.0 / (Rho_conv * (GV%g_Earth*US%m_to_Z)) ssh(i,j) = ssh(i,j) + p_atm(i,j) * IgR0 enddo ; enddo endif ; endif end subroutine adjust_ssh_for_p_atm -!> This subroutine sets the surface (return) properties of the ocean -!! model by setting the appropriate fields in sfc_state. Unused fields +!> Set the surface (return) properties of the ocean model by +!! setting the appropriate fields in sfc_state. Unused fields !! are set to NULL or are unallocated. subroutine extract_surface_state(CS, sfc_state) type(MOM_control_struct), pointer :: CS !< Master MOM control structure type(surface), intent(inout) :: sfc_state !< transparent ocean surface state - !! structure shared with the calling routine; + !! structure shared with the calling routine !! data in this structure is intent out. ! local - real :: hu, hv - type(ocean_grid_type), pointer :: G => NULL() ! pointer to a structure containing - ! metrics and related information - type(verticalGrid_type), pointer :: GV => NULL() - real, pointer, dimension(:,:,:) :: & - u, & ! u : zonal velocity component (m/s) - v, & ! v : meridional velocity component (m/s) - h ! h : layer thickness (meter (Bouss) or kg/m2 (non-Bouss)) - real :: depth(SZI_(CS%G)) ! distance from the surface (meter) - real :: depth_ml ! depth over which to average to - ! determine mixed layer properties (meter) - real :: dh ! thickness of a layer within mixed layer (meter) - real :: mass ! mass per unit area of a layer (kg/m2) - - logical :: use_temperature ! If true, temp and saln used as state variables. + real :: hu, hv ! Thicknesses interpolated to velocity points [H ~> m or kg m-2] + type(ocean_grid_type), pointer :: G => NULL() !< pointer to a structure containing + !! metrics and related information + type(verticalGrid_type), pointer :: GV => NULL() + real, dimension(:,:,:), pointer :: & + u => NULL(), & !< u : zonal velocity component [m s-1] + v => NULL(), & !< v : meridional velocity component [m s-1] + h => NULL() !< h : layer thickness [H ~> m or kg m-2] + real :: depth(SZI_(CS%G)) !< Distance from the surface in depth units [Z ~> m] + real :: depth_ml !< Depth over which to average to determine mixed + !! layer properties [Z ~> m] + real :: dh !< Thickness of a layer within the mixed layer [Z ~> m] + real :: mass !< Mass per unit area of a layer [kg m-2] + real :: bathy_m !< The depth of bathymetry [m] (not Z), used for error checking. + real :: T_freeze !< freezing temperature [degC] + real :: delT(SZI_(CS%G)) !< T-T_freeze [degC] + logical :: use_temperature !< If true, temp and saln used as state variables. integer :: i, j, k, is, ie, js, je, nz, numberOfErrors integer :: isd, ied, jsd, jed integer :: iscB, iecB, jscB, jecB, isdB, iedB, jsdB, jedB @@ -2659,6 +2761,13 @@ subroutine extract_surface_state(CS, sfc_state) sfc_state%sea_lev(i,j) = CS%ave_ssh_ibc(i,j) enddo ; enddo + ! copy Hml into sfc_state, so that caps can access it + if (associated(CS%Hml)) then + do j=js,je ; do i=is,ie + sfc_state%Hml(i,j) = CS%Hml(i,j) + enddo ; enddo + endif + if (CS%Hmix < 0.0) then ! A bulk mixed layer is in use, so layer 1 has the properties if (use_temperature) then ; do j=js,je ; do i=is,ie sfc_state%SST(i,j) = CS%tv%T(i,j,1) @@ -2671,11 +2780,9 @@ subroutine extract_surface_state(CS, sfc_state) sfc_state%v(i,J) = v(i,J,1) enddo ; enddo - if (associated(CS%Hml)) then ; do j=js,je ; do i=is,ie - sfc_state%Hml(i,j) = CS%Hml(i,j) - enddo ; enddo ; endif else ! (CS%Hmix >= 0.0) - + !### 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 ! Determine the mean tracer properties of the uppermost depth_ml fluid. !$OMP parallel do default(shared) private(depth,dh) @@ -2690,8 +2797,8 @@ subroutine extract_surface_state(CS, sfc_state) enddo do k=1,nz ; do i=is,ie - if (depth(i) + h(i,j,k)*GV%H_to_m < depth_ml) then - dh = h(i,j,k)*GV%H_to_m + if (depth(i) + h(i,j,k)*GV%H_to_Z < depth_ml) then + dh = h(i,j,k)*GV%H_to_Z elseif (depth(i) < depth_ml) then dh = depth_ml - depth(i) else @@ -2707,20 +2814,23 @@ subroutine extract_surface_state(CS, sfc_state) enddo ; enddo ! Calculate the average properties of the mixed layer depth. do i=is,ie - if (depth(i) < GV%H_subroundoff*GV%H_to_m) & - depth(i) = GV%H_subroundoff*GV%H_to_m + if (depth(i) < GV%H_subroundoff*GV%H_to_Z) & + depth(i) = GV%H_subroundoff*GV%H_to_Z if (use_temperature) then sfc_state%SST(i,j) = sfc_state%SST(i,j) / depth(i) sfc_state%SSS(i,j) = sfc_state%SSS(i,j) / depth(i) else sfc_state%sfc_density(i,j) = sfc_state%sfc_density(i,j) / depth(i) endif - sfc_state%Hml(i,j) = depth(i) + !### Verify that this is no longer needed. + ! sfc_state%Hml(i,j) = US%Z_to_m * depth(i) enddo enddo ! end of j loop ! Determine the mean velocities in the uppermost depth_ml fluid. 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 @@ -2729,7 +2839,7 @@ subroutine extract_surface_state(CS, sfc_state) sfc_state%v(i,J) = 0.0 enddo do k=1,nz ; do i=is,ie - hv = 0.5 * (h(i,j,k) + h(i,j+1,k)) * GV%H_to_m + hv = 0.5 * (h(i,j,k) + h(i,j+1,k)) * GV%H_to_Z if (depth(i) + hv < depth_ml) then dh = hv elseif (depth(i) < depth_ml) then @@ -2742,8 +2852,8 @@ subroutine extract_surface_state(CS, sfc_state) enddo ; enddo ! Calculate the average properties of the mixed layer depth. do i=is,ie - if (depth(i) < GV%H_subroundoff*GV%H_to_m) & - depth(i) = GV%H_subroundoff*GV%H_to_m + if (depth(i) < GV%H_subroundoff*GV%H_to_Z) & + depth(i) = GV%H_subroundoff*GV%H_to_Z sfc_state%v(i,J) = sfc_state%v(i,J) / depth(i) enddo enddo ! end of j loop @@ -2755,7 +2865,7 @@ subroutine extract_surface_state(CS, sfc_state) sfc_state%u(I,j) = 0.0 enddo do k=1,nz ; do I=iscB,iecB - hu = 0.5 * (h(i,j,k) + h(i+1,j,k)) * GV%H_to_m + 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 elseif (depth(I) < depth_ml) then @@ -2768,8 +2878,8 @@ subroutine extract_surface_state(CS, sfc_state) enddo ; enddo ! Calculate the average properties of the mixed layer depth. do I=iscB,iecB - if (depth(I) < GV%H_subroundoff*GV%H_to_m) & - depth(I) = GV%H_subroundoff*GV%H_to_m + 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 @@ -2783,6 +2893,43 @@ subroutine extract_surface_state(CS, sfc_state) endif endif ! (CS%Hmix >= 0.0) + + if (allocated(sfc_state%melt_potential)) then + !$OMP parallel do default(shared) + do j=js,je + do i=is,ie + depth(i) = 0.0 + delT(i) = 0.0 + enddo + + do k=1,nz ; do i=is,ie + depth_ml = min(CS%HFrz,CS%visc%MLD(i,j)) + if (depth(i) + h(i,j,k)*GV%H_to_m < depth_ml) then + dh = h(i,j,k)*GV%H_to_m + elseif (depth(i) < depth_ml) then + dh = depth_ml - depth(i) + else + dh = 0.0 + endif + + ! p=0 OK, HFrz ~ 10 to 20m + call calculate_TFreeze(CS%tv%S(i,j,k), 0.0, T_freeze, CS%tv%eqn_of_state) + depth(i) = depth(i) + dh + delT(i) = delT(i) + dh * (CS%tv%T(i,j,k) - T_freeze) + enddo ; enddo + + do i=is,ie + ! set melt_potential to zero to avoid passing previous values + sfc_state%melt_potential(i,j) = 0.0 + + if (G%mask2dT(i,j)>0.) then + ! instantaneous melt_potential [J m-2] + sfc_state%melt_potential(i,j) = CS%tv%C_p * CS%GV%Rho0 * delT(i) + endif + enddo + enddo ! end of j loop + endif ! melt_potential + if (allocated(sfc_state%salt_deficit) .and. associated(CS%tv%salt_deficit)) then !$OMP parallel do default(shared) do j=js,je ; do i=is,ie @@ -2844,10 +2991,11 @@ subroutine extract_surface_state(CS, sfc_state) numberOfErrors=0 ! count number of errors do j=js,je; do i=is,ie if (G%mask2dT(i,j)>0.) then - localError = sfc_state%sea_lev(i,j)<=-G%bathyT(i,j) & + bathy_m = CS%US%Z_to_m * G%bathyT(i,j) + localError = sfc_state%sea_lev(i,j)<=-bathy_m & .or. sfc_state%sea_lev(i,j)>= CS%bad_val_ssh_max & .or. sfc_state%sea_lev(i,j)<=-CS%bad_val_ssh_max & - .or. sfc_state%sea_lev(i,j)+G%bathyT(i,j) < CS%bad_vol_col_thick + .or. sfc_state%sea_lev(i,j) + bathy_m < CS%bad_val_col_thick if (use_temperature) localError = localError & .or. sfc_state%SSS(i,j)<0. & .or. sfc_state%SSS(i,j)>=CS%bad_val_sss_max & @@ -2860,7 +3008,7 @@ subroutine extract_surface_state(CS, sfc_state) write(msg(1:240),'(2(a,i4,x),2(a,f8.3,x),8(a,es11.4,x))') & 'Extreme surface sfc_state detected: i=',i,'j=',j, & 'x=',G%geoLonT(i,j), 'y=',G%geoLatT(i,j), & - 'D=',G%bathyT(i,j), 'SSH=',sfc_state%sea_lev(i,j), & + 'D=',bathy_m, 'SSH=',sfc_state%sea_lev(i,j), & 'SST=',sfc_state%SST(i,j), 'SSS=',sfc_state%SSS(i,j), & 'U-=',sfc_state%u(I-1,j), 'U+=',sfc_state%u(I,j), & 'V-=',sfc_state%v(i,J-1), 'V+=',sfc_state%v(i,J) @@ -2868,7 +3016,7 @@ subroutine extract_surface_state(CS, sfc_state) write(msg(1:240),'(2(a,i4,x),2(a,f8.3,x),6(a,es11.4))') & 'Extreme surface sfc_state detected: i=',i,'j=',j, & 'x=',G%geoLonT(i,j), 'y=',G%geoLatT(i,j), & - 'D=',G%bathyT(i,j), 'SSH=',sfc_state%sea_lev(i,j), & + 'D=',bathy_m, 'SSH=',sfc_state%sea_lev(i,j), & 'U-=',sfc_state%u(I-1,j), 'U+=',sfc_state%u(I,j), & 'V-=',sfc_state%v(i,J-1), 'V+=',sfc_state%v(i,J) endif @@ -2878,7 +3026,7 @@ subroutine extract_surface_state(CS, sfc_state) endif ! numberOfErrors endif ! localError endif ! mask2dT - enddo; enddo + enddo ; enddo call sum_across_PEs(numberOfErrors) if (numberOfErrors>0) then write(msg(1:240),'(3(a,i9,x))') 'There were a total of ',numberOfErrors, & @@ -2914,17 +3062,20 @@ end function MOM_state_is_synchronized !> This subroutine offers access to values or pointers to other types from within !! the MOM_control_struct, allowing the MOM_control_struct to be opaque. -subroutine get_MOM_state_elements(CS, G, GV, C_p, use_temp) +subroutine get_MOM_state_elements(CS, G, GV, US, C_p, use_temp) type(MOM_control_struct), pointer :: CS !< MOM control structure type(ocean_grid_type), & optional, pointer :: G !< structure containing metrics and grid info type(verticalGrid_type), & optional, pointer :: GV !< structure containing vertical grid info + type(unit_scale_type), & + optional, pointer :: US !< A dimensional unit scaling type real, optional, intent(out) :: C_p !< The heat capacity logical, optional, intent(out) :: use_temp !< Indicates whether temperature is a state variable if (present(G)) G => CS%G if (present(GV)) GV => CS%GV + if (present(US)) US => CS%US if (present(C_p)) C_p = CS%tv%C_p if (present(use_temp)) use_temp = associated(CS%tv%T) end subroutine get_MOM_state_elements @@ -2932,9 +3083,9 @@ end subroutine get_MOM_state_elements !> Find the global integrals of various quantities. subroutine get_ocean_stocks(CS, mass, heat, salt, on_PE_only) type(MOM_control_struct), pointer :: CS !< MOM control structure - real, optional, intent(out) :: heat !< The globally integrated integrated ocean heat, in J. - real, optional, intent(out) :: salt !< The globally integrated integrated ocean salt, in kg. - real, optional, intent(out) :: mass !< The globally integrated integrated ocean mass, in kg. + real, optional, intent(out) :: heat !< The globally integrated integrated ocean heat [J]. + real, optional, intent(out) :: salt !< The globally integrated integrated ocean salt [kg]. + real, optional, intent(out) :: mass !< The globally integrated integrated ocean mass [kg]. logical, optional, intent(in) :: on_PE_only !< If present and true, only sum on the local PE. if (present(mass)) & @@ -2946,7 +3097,7 @@ subroutine get_ocean_stocks(CS, mass, heat, salt, on_PE_only) end subroutine get_ocean_stocks -!> End of model +!> End of ocean model, including memory deallocation subroutine MOM_end(CS) type(MOM_control_struct), pointer :: CS !< MOM control structure @@ -2967,8 +3118,7 @@ subroutine MOM_end(CS) call tracer_registry_end(CS%tracer_Reg) call tracer_flow_control_end(CS%tracer_flow_CSp) - ! GMM, the following is commented because it fails on Travis. - !if (associated(CS%diabatic_CSp)) call diabatic_driver_end(CS%diabatic_CSp) + call diabatic_driver_end(CS%diabatic_CSp) if (CS%offline_tracer_mode) call offline_transport_end(CS%offline_CSp) @@ -2984,6 +3134,7 @@ subroutine MOM_end(CS) if (associated(CS%update_OBC_CSp)) call OBC_register_end(CS%update_OBC_CSp) call verticalGridEnd(CS%GV) + call unit_scaling_end(CS%US) call MOM_grid_end(CS%G) deallocate(CS) diff --git a/src/core/MOM_CoriolisAdv.F90 b/src/core/MOM_CoriolisAdv.F90 index b1916d838a..450d71d23e 100644 --- a/src/core/MOM_CoriolisAdv.F90 +++ b/src/core/MOM_CoriolisAdv.F90 @@ -70,11 +70,12 @@ module MOM_CoriolisAdv !! SADOURNY75_ENERGY. type(time_type), pointer :: Time !< A pointer to the ocean model's clock. type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the timing of diagnostic output. + !>@{ Diagnostic IDs integer :: id_rv = -1, id_PV = -1, id_gKEu = -1, id_gKEv = -1 - integer :: id_rvxu = -1, id_rvxv = -1 + integer :: id_rvxu = -1, id_rvxv = -1 !!@} end type CoriolisAdv_CS -! Enumeration values for Coriolis_Scheme +!>@{ Enumeration values for Coriolis_Scheme integer, parameter :: SADOURNY75_ENERGY = 1 integer, parameter :: ARAKAWA_HSU90 = 2 integer, parameter :: ROBUST_ENSTRO = 3 @@ -87,106 +88,108 @@ module MOM_CoriolisAdv character*(20), parameter :: SADOURNY75_ENSTRO_STRING = "SADOURNY75_ENSTRO" character*(20), parameter :: ARAKAWA_LAMB_STRING = "ARAKAWA_LAMB81" character*(20), parameter :: AL_BLEND_STRING = "ARAKAWA_LAMB_BLEND" -! Enumeration values for KE_Scheme +!!@} +!>@{ Enumeration values for KE_Scheme integer, parameter :: KE_ARAKAWA = 10 integer, parameter :: KE_SIMPLE_GUDONOV = 11 integer, parameter :: KE_GUDONOV = 12 character*(20), parameter :: KE_ARAKAWA_STRING = "KE_ARAKAWA" character*(20), parameter :: KE_SIMPLE_GUDONOV_STRING = "KE_SIMPLE_GUDONOV" character*(20), parameter :: KE_GUDONOV_STRING = "KE_GUDONOV" -! Enumeration values for PV_Adv_Scheme +!!@} +!>@{ Enumeration values for PV_Adv_Scheme integer, parameter :: PV_ADV_CENTERED = 21 integer, parameter :: PV_ADV_UPWIND1 = 22 character*(20), parameter :: PV_ADV_CENTERED_STRING = "PV_ADV_CENTERED" character*(20), parameter :: PV_ADV_UPWIND1_STRING = "PV_ADV_UPWIND1" +!!@} contains !> Calculates the Coriolis and momentum advection contributions to the acceleration. subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, CS) - type(ocean_grid_type), intent(in) :: G !< Ocen grid structure + type(ocean_grid_type), intent(in) :: G !< Ocen grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Zonal velocity (m/s) - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< Meridional velocity (m/s) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness (m or kg/m2) - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: uh !< Zonal transport u*h*dy (m3/s or kg/s) - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: vh !< Meridional transport v*h*dx (m3/s or kg/s) + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Zonal velocity [m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< Meridional velocity [m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: uh !< Zonal transport u*h*dy + !! [H m2 s-1 ~> m3 s-1 or kg s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: vh !< Meridional transport v*h*dx + !! [H m2 s-1 ~> m3 s-1 or kg s-1] real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: CAu !< Zonal acceleration due to Coriolis - !! and momentum advection, in m/s2. + !! and momentum advection [m s-2]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: CAv !< Meridional acceleration due to Coriolis - !! and momentum advection, in m/s2. + !! and momentum advection [m s-2]. type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure type(accel_diag_ptrs), intent(inout) :: AD !< Storage for acceleration diagnostics type(CoriolisAdv_CS), pointer :: CS !< Control structure for MOM_CoriolisAdv - ! Local variables + ! Local variables real, dimension(SZIB_(G),SZJB_(G)) :: & - q, & ! Layer potential vorticity, in m-1 s-1. - Ih_q, & ! The inverse of thickness interpolated to q pointes, in - ! units of m-1 or m2 kg-1. - Area_q ! The sum of the ocean areas at the 4 adjacent thickness - ! points, in m2. + q, & ! Layer potential vorticity [m-1 s-1]. + Ih_q, & ! The inverse of thickness interpolated to q points [H-1 ~> m-1 or m2 kg-1]. + Area_q ! The sum of the ocean areas at the 4 adjacent thickness points [m2]. real, dimension(SZIB_(G),SZJ_(G)) :: & a, b, c, d ! a, b, c, & d are combinations of the potential vorticities ! surrounding an h grid point. At small scales, a = q/4, - ! b = q/4, etc. All are in units of m-1 s-1 or m2 kg-1 s-1, + ! b = q/4, etc. All are in [H-1 s-1 ~> m-1 s-1 or m2 kg-1 s-1], ! and use the indexing of the corresponding u point. real, dimension(SZI_(G),SZJ_(G)) :: & - Area_h, & ! The ocean area at h points, in m2. Area_h is used to find the + Area_h, & ! The ocean area at h points [m2]. Area_h is used to find the ! average thickness in the denominator of q. 0 for land points. - KE ! Kinetic energy per unit mass, KE = (u^2 + v^2)/2, in m2 s-2. + KE ! Kinetic energy per unit mass [m2 s-2], KE = (u^2 + v^2)/2. real, dimension(SZIB_(G),SZJ_(G)) :: & hArea_u, & ! The cell area weighted thickness interpolated to u points - ! times the effective areas, in H m2. - KEx, & ! The zonal gradient of Kinetic energy per unit mass, - ! KEx = d/dx KE, in m s-2. - uh_center ! centered u times h at u-points + ! times the effective areas [H m2 ~> m3 or kg]. + KEx, & ! The zonal gradient of Kinetic energy per unit mass [m s-2], + ! KEx = d/dx KE. + uh_center ! Transport based on arithmetic mean h at u-points [H m2 s-1 ~> m3 s-1 or kg s-1] real, dimension(SZI_(G),SZJB_(G)) :: & hArea_v, & ! The cell area weighted thickness interpolated to v points - ! times the effective areas, in H m2. - KEy, & ! The meridonal gradient of Kinetic energy per unit mass, - ! KEy = d/dy KE, in m s-2. - vh_center ! centered v times h at v-points + ! times the effective areas [H m2 ~> m3 or kg]. + KEy, & ! The meridonal gradient of Kinetic energy per unit mass [m s-2], + ! KEy = d/dy KE. + vh_center ! Transport based on arithmetic mean h at v-points [H m2 s-1 ~> m3 s-1 or kg s-1] real, dimension(SZI_(G),SZJ_(G)) :: & uh_min, uh_max, & ! The smallest and largest estimates of the volume - vh_min, vh_max, & ! fluxes through the faces (i.e. u*h*dy & v*h*dx), - ! in m3 s-1 or kg s-1. + vh_min, vh_max, & ! fluxes through the faces (i.e. u*h*dy & v*h*dx) + ! [H m2 s-1 ~> m3 s-1 or kg s-1]. ep_u, ep_v ! Additional pseudo-Coriolis terms in the Arakawa and Lamb - ! discretization, in m-1 s-1 or m2 kg-1 s-1. + ! discretization [H-1 s-1 ~> m-1 s-1 or m2 kg-1 s-1]. real, dimension(SZIB_(G),SZJB_(G)) :: & - dvdx,dudy, &! Contributions to the circulation around q-points (m2 s-1) - abs_vort, & ! Absolute vorticity at q-points, in s-1. - q2, & ! Relative vorticity over thickness. + dvdx,dudy, &! Contributions to the circulation around q-points [m2 s-1] + abs_vort, & ! Absolute vorticity at q-points [s-1]. + q2, & ! Relative vorticity over thickness [H-1 s-1 ~> m-1 s-1 or m2 kg-1 s-1]. max_fvq, & ! The maximum or minimum of the min_fvq, & ! adjacent values of (-u) or v times - max_fuq, & ! the absolute vorticity, in m s-2. + max_fuq, & ! the absolute vorticity [m s-2]. min_fuq ! All are defined at q points. real, dimension(SZIB_(G),SZJB_(G),SZK_(G)) :: & - PV, & ! A diagnostic array of the potential vorticities, in m-1 s-1. - RV ! A diagnostic array of the relative vorticities, in s-1. - real :: fv1, fv2, fu1, fu2 ! (f+rv)*v or (f+rv)*u in m s-2. - real :: max_fv, max_fu ! The maximum or minimum of the neighbor- - real :: min_fv, min_fu ! max(min)_fu(v)q, in m s-2. + PV, & ! A diagnostic array of the potential vorticities [m-1 s-1]. + RV ! A diagnostic array of the relative vorticities [s-1]. + real :: fv1, fv2, fu1, fu2 ! (f+rv)*v or (f+rv)*u [m s-2]. + real :: max_fv, max_fu ! The maximum or minimum of the neighboring Coriolis + real :: min_fv, min_fu ! accelerations [m s-2], i.e. max(min)_fu(v)q. real, parameter :: C1_12=1.0/12.0 ! C1_12 = 1/12 real, parameter :: C1_24=1.0/24.0 ! C1_24 = 1/24 - real :: absolute_vorticity ! Absolute vorticity, in s-1. - real :: relative_vorticity ! Relative vorticity, in s-1. - real :: Ih ! Inverse of thickness, m-1 or m2 kg-1. - real :: max_Ihq, min_Ihq ! The maximum and minimum of the nearby Ihq. + real :: absolute_vorticity ! Absolute vorticity [s-1]. + real :: relative_vorticity ! Relative vorticity [s-1]. + real :: Ih ! Inverse of thickness [H-1 ~> m-1 or m2 kg-1]. + real :: max_Ihq, min_Ihq ! The maximum and minimum of the nearby Ihq [H-1 ~> m-1 or m2 kg-1]. real :: hArea_q ! The sum of area times thickness of the cells - ! surrounding a q point, in m3 or kg. + ! surrounding a q point [H m2 ~> m3 or kg]. real :: h_neglect ! A thickness that is so small it is usually - ! lost in roundoff and can be neglected, in m. - real :: temp1, temp2 ! Temporary variables, in m2 s-2. - real, parameter :: eps_vel=1.0e-10 ! A tiny, positive velocity, in m s-1. + ! lost in roundoff and can be neglected [H ~> m or kg m-2]. + real :: temp1, temp2 ! Temporary variables [m2 s-2]. + real, parameter :: eps_vel=1.0e-10 ! A tiny, positive velocity [m s-1]. - real :: uhc, vhc ! Centered estimates of uh and vh in m3 s-1 or kg s-1. - real :: uhm, vhm ! The input estimates of uh and vh in m3 s-1 or kg s-1. - real :: c1, c2, c3, slope ! Nondimensional parameters for the Coriolis - ! limiter scheme. + real :: uhc, vhc ! Centered estimates of uh and vh [H m2 s-1 ~> m3 s-1 or kg s-1]. + real :: uhm, vhm ! The input estimates of uh and vh [H m2 s-1 ~> m3 s-1 or kg s-1]. + real :: c1, c2, c3, slope ! Nondimensional parameters for the Coriolis limiter scheme. real :: Fe_m2 ! Nondimensional temporary variables asssociated with real :: rat_lin ! the ARAKAWA_LAMB_BLEND scheme. @@ -198,27 +201,24 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, CS) ! the other two with the ARAKAWA_LAMB_BLEND scheme, ! nondimensional between 0 and 1. - real :: Heff1, Heff2 ! Temporary effective H at U or V points in m or kg m-2. - real :: Heff3, Heff4 ! Temporary effective H at U or V points in m or kg m-2. - real :: h_tiny ! A very small thickness, in m or kg m-2. - real :: UHeff, VHeff ! More temporary variables, in m3 s-1 or kg s-1. - real :: QUHeff,QVHeff ! More temporary variables, in m3 s-2 or kg s-2. + real :: Heff1, Heff2 ! Temporary effective H at U or V points [H ~> m or kg m-2]. + real :: Heff3, Heff4 ! Temporary effective H at U or V points [H ~> m or kg m-2]. + real :: h_tiny ! A very small thickness [H ~> m or kg m-2]. + real :: UHeff, VHeff ! More temporary variables [H m2 s-1 ~> m3 s-1 or kg s-1]. + real :: QUHeff,QVHeff ! More temporary variables [H m2 s-1 ~> m3 s-1 or kg s-1]. integer :: i, j, k, n, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz ! To work, the following fields must be set outside of the usual ! is to ie range before this subroutine is called: -! v[is-1,ie+1,ie+2], u[is-1,ie+1], vh[ie+1], uh[is-1], and -! h[is-1,ie+1,ie+2]. -! In the y-direction, the following fields must be set: -! v[js-1,je+1], u[js-1,je+1,je+2], vh[js-1], uh[je+1], and -! h[js-1,je+1,je+2]. +! v(is-1:ie+2,js-1:je+1), u(is-1:ie+1,js-1:je+2), h(is-1:ie+2,js-1:je+2), +! uh(is-1,ie,js:je+1) and vh(is:ie+1,js-1:je). if (.not.associated(CS)) call MOM_error(FATAL, & "MOM_CoriolisAdv: Module must be initialized before it is used.") is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = G%ke h_neglect = GV%H_subroundoff - h_tiny = GV%Angstrom ! Perhaps this should be set to h_neglect instead. + h_tiny = GV%Angstrom_H ! Perhaps this should be set to h_neglect instead. !$OMP parallel do default(private) shared(Isq,Ieq,Jsq,Jeq,G,Area_h) do j=Jsq-1,Jeq+2 ; do I=Isq-1,Ieq+2 @@ -290,6 +290,20 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, CS) if (OBC%freeslip_vorticity) then ; do I=OBC%segment(n)%HI%IsdB,OBC%segment(n)%HI%IedB dudy(I,J) = 0. enddo ; endif + if (OBC%computed_vorticity) then ; do I=OBC%segment(n)%HI%IsdB,OBC%segment(n)%HI%IedB + if (OBC%segment(n)%direction == OBC_DIRECTION_N) then + dudy(I,J) = 2.0*(OBC%segment(n)%tangential_vel(I,J,k) - u(I,j,k))*G%dxCu(I,j) + else ! (OBC%segment(n)%direction == OBC_DIRECTION_S) + dudy(I,J) = 2.0*(u(I,j+1,k) - OBC%segment(n)%tangential_vel(I,J,k))*G%dxCu(I,j+1) + endif + enddo ; endif + if (OBC%specified_vorticity) then ; do I=OBC%segment(n)%HI%IsdB,OBC%segment(n)%HI%IedB + if (OBC%segment(n)%direction == OBC_DIRECTION_N) then + dudy(I,J) = OBC%segment(n)%tangential_grad(I,J,k)*G%dxCu(I,j)*G%dyBu(I,J) + else ! (OBC%segment(n)%direction == OBC_DIRECTION_S) + dudy(I,J) = OBC%segment(n)%tangential_grad(I,J,k)*G%dxCu(I,j+1)*G%dyBu(I,J) + endif + enddo ; endif ! Project thicknesses across OBC points with a no-gradient condition. do i = max(Isq-1,OBC%segment(n)%HI%isd), min(Ieq+2,OBC%segment(n)%HI%ied) @@ -316,6 +330,20 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, CS) if (OBC%freeslip_vorticity) then ; do J=OBC%segment(n)%HI%JsdB,OBC%segment(n)%HI%JedB dvdx(I,J) = 0. enddo ; endif + if (OBC%computed_vorticity) then ; do J=OBC%segment(n)%HI%JsdB,OBC%segment(n)%HI%JedB + if (OBC%segment(n)%direction == OBC_DIRECTION_E) then + dvdx(I,J) = 2.0*(OBC%segment(n)%tangential_vel(I,J,k) - v(i,J,k))*G%dyCv(i,J) + else ! (OBC%segment(n)%direction == OBC_DIRECTION_W) + dvdx(I,J) = 2.0*(v(i+1,J,k) - OBC%segment(n)%tangential_vel(I,J,k))*G%dyCv(i+1,J) + endif + enddo ; endif + if (OBC%specified_vorticity) then ; do J=OBC%segment(n)%HI%JsdB,OBC%segment(n)%HI%JedB + if (OBC%segment(n)%direction == OBC_DIRECTION_E) then + dvdx(I,J) = OBC%segment(n)%tangential_grad(I,J,k)*G%dyCv(i,J)*G%dxBu(I,J) + else ! (OBC%segment(n)%direction == OBC_DIRECTION_W) + dvdx(I,J) = OBC%segment(n)%tangential_grad(I,J,k)*G%dyCv(i+1,J)*G%dxBu(I,J) + endif + enddo ; endif ! Project thicknesses across OBC points with a no-gradient condition. do j = max(Jsq-1,OBC%segment(n)%HI%jsd), min(Jeq+2,OBC%segment(n)%HI%jed) @@ -521,7 +549,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, CS) vhm = 10.0*vhc elseif (abs(vhc) > c1*abs(vhm)) then if (abs(vhc) < c2*abs(vhm)) then ; vhc = (3.0*vhc+(1.0-c2*3.0)*vhm) - else if (abs(vhc) <= c3*abs(vhm)) then ; vhc = vhm + elseif (abs(vhc) <= c3*abs(vhm)) then ; vhc = vhm else ; vhc = slope*vhc+(1.0-c3*slope)*vhm endif endif @@ -810,21 +838,21 @@ end subroutine CorAdCalc !> Calculates the acceleration due to the gradient of kinetic energy. subroutine gradKE(u, v, h, KE, KEx, KEy, k, OBC, G, CS) type(ocean_grid_type), intent(in) :: G !< Ocen grid structure - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Zonal velocity (m/s) - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< Meridional velocity (m/s) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness (m or kg/m2) - real, dimension(SZI_(G) ,SZJ_(G) ), intent(out) :: KE !< Kinetic energy (m2/s2) + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Zonal velocity [m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< Meridional velocity [m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G) ,SZJ_(G) ), intent(out) :: KE !< Kinetic energy [m2 s-2] real, dimension(SZIB_(G),SZJ_(G) ), intent(out) :: KEx !< Zonal acceleration due to kinetic - !! energy gradient (m/s2) + !! energy gradient [m s-2] real, dimension(SZI_(G) ,SZJB_(G)), intent(out) :: KEy !< Meridional acceleration due to kinetic - !! energy gradient (m/s2) + !! energy gradient [m s-2] integer, intent(in) :: k !< Layer number to calculate for type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure type(CoriolisAdv_CS), pointer :: CS !< Control structure for MOM_CoriolisAdv ! Local variables - real :: um, up, vm, vp ! Temporary variables with units of m s-1. - real :: um2, up2, vm2, vp2 ! Temporary variables with units of m2 s-2. - real :: um2a, up2a, vm2a, vp2a ! Temporary variables with units of m4 s-2. + real :: um, up, vm, vp ! Temporary variables [m s-1]. + real :: um2, up2, vm2, vp2 ! Temporary variables [m2 s-2]. + real :: um2a, up2a, vm2a, vp2a ! Temporary variables [m4 s-2]. integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, n is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -832,7 +860,7 @@ subroutine gradKE(u, v, h, KE, KEx, KEy, k, OBC, G, CS) ! Calculate KE (Kinetic energy for use in the -grad(KE) acceleration term). - if (CS%KE_Scheme.eq.KE_ARAKAWA) then + if (CS%KE_Scheme == KE_ARAKAWA) then ! The following calculation of Kinetic energy includes the metric terms ! identified in Arakawa & Lamb 1982 as important for KE conservation. It ! also includes the possibility of partially-blocked tracer cell faces. @@ -843,7 +871,7 @@ subroutine gradKE(u, v, h, KE, KEx, KEy, k, OBC, G, CS) +G%areaCv(i,J-1)*(v(i,J-1,k)*v(i,J-1,k)) ) & )*0.25*G%IareaT(i,j) enddo ; enddo - elseif (CS%KE_Scheme.eq.KE_SIMPLE_GUDONOV) then + elseif (CS%KE_Scheme == KE_SIMPLE_GUDONOV) then ! The following discretization of KE is based on the one-dimensinal Gudonov ! scheme which does not take into account any geometric factors do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 @@ -853,7 +881,7 @@ subroutine gradKE(u, v, h, KE, KEx, KEy, k, OBC, G, CS) vm = 0.5*( v(i, J ,k) - ABS( v(i, J ,k) ) ) ; vm2 = vm*vm KE(i,j) = ( max(up2,um2) + max(vp2,vm2) ) *0.5 enddo ; enddo - elseif (CS%KE_Scheme.eq.KE_GUDONOV) then + elseif (CS%KE_Scheme == KE_GUDONOV) then ! The following discretization of KE is based on the one-dimensinal Gudonov ! scheme but has been adapted to take horizontal grid factors into account do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 diff --git a/src/core/MOM_PressureForce.F90 b/src/core/MOM_PressureForce.F90 index 7f67757d3e..110963789b 100644 --- a/src/core/MOM_PressureForce.F90 +++ b/src/core/MOM_PressureForce.F90 @@ -16,7 +16,8 @@ module MOM_PressureForce use MOM_PressureForce_Mont, only : PressureForce_Mont_Bouss, PressureForce_Mont_nonBouss use MOM_PressureForce_Mont, only : PressureForce_Mont_init, PressureForce_Mont_end use MOM_PressureForce_Mont, only : PressureForce_Mont_CS -use MOM_tidal_forcing, only : calc_tidal_forcing, tidal_forcing_CS +use MOM_tidal_forcing, only : tidal_forcing_CS +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use MOM_ALE, only: ALE_CS @@ -26,7 +27,7 @@ module MOM_PressureForce public PressureForce, PressureForce_init, PressureForce_end -! Pressure force control structure +!> Pressure force control structure type, public :: PressureForce_CS ; private logical :: Analytic_FV_PGF !< If true, use the analytic finite volume form !! (Adcroft et al., Ocean Mod. 2008) of the PGF. @@ -43,42 +44,51 @@ module MOM_PressureForce contains !> A thin layer between the model and the Boussinesq and non-Boussinesq pressure force routines. -subroutine PressureForce(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm, pbce, eta) - 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 !< Layer thicknesses, in H (usually m or kg m-2) - type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: PFu - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: PFv - type(PressureForce_CS), pointer :: CS - type(ALE_CS), pointer :: ALE_CSp - real, dimension(:,:), optional, pointer :: p_atm - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: pbce - real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: eta - +subroutine PressureForce(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, eta) + 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 + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(out) :: PFu !< Zonal pressure force acceleration [m s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(out) :: PFv !< Meridional pressure force acceleration [m s-2] + type(PressureForce_CS), pointer :: CS !< Pressure force control structure + type(ALE_CS), pointer :: ALE_CSp !< ALE control structure + real, dimension(:,:), & + optional, pointer :: p_atm !< The pressure at the ice-ocean or + !! atmosphere-ocean interface [Pa]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + optional, intent(out) :: pbce !< The baroclinic pressure anomaly in each layer + !! due to eta anomalies [m2 s-2 H-1 ~> m s-2 or m4 s-2 kg-1]. + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(out) :: eta !< The bottom mass used to calculate PFu and PFv, + !! [H ~> m or kg m-2], with any tidal contributions. if (CS%Analytic_FV_PGF .and. CS%blocked_AFV) then if (GV%Boussinesq) then - call PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, & + call PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, & CS%PressureForce_blk_AFV_CSp, ALE_CSp, p_atm, pbce, eta) else - call PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, & + call PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, & CS%PressureForce_blk_AFV_CSp, p_atm, pbce, eta) endif elseif (CS%Analytic_FV_PGF) then if (GV%Boussinesq) then - call PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, CS%PressureForce_AFV_CSp, & + call PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS%PressureForce_AFV_CSp, & ALE_CSp, p_atm, pbce, eta) else - call PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, CS%PressureForce_AFV_CSp, & + call PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS%PressureForce_AFV_CSp, & ALE_CSp, p_atm, pbce, eta) endif else if (GV%Boussinesq) then - call PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, CS%PressureForce_Mont_CSp, & + call PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS%PressureForce_Mont_CSp, & p_atm, pbce, eta) else - call PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, CS%PressureForce_Mont_CSp, & + call PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS%PressureForce_Mont_CSp, & p_atm, pbce, eta) endif endif @@ -86,10 +96,11 @@ subroutine PressureForce(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm, pbce, eta) end subroutine Pressureforce !> Initialize the pressure force control structure -subroutine PressureForce_init(Time, G, GV, param_file, diag, CS, tides_CSp) +subroutine PressureForce_init(Time, G, GV, US, param_file, diag, CS, tides_CSp) type(time_type), target, intent(in) :: Time !< Current model time type(ocean_grid_type), intent(in) :: G !< Ocean 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 !< Parameter file handles type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure type(PressureForce_CS), pointer :: CS !< Pressure force control structure @@ -117,13 +128,13 @@ subroutine PressureForce_init(Time, G, GV, param_file, diag, CS, tides_CSp) default=.false., do_not_log=.true., debuggingParam=.true.) if (CS%Analytic_FV_PGF .and. CS%blocked_AFV) then - call PressureForce_blk_AFV_init(Time, G, GV, param_file, diag, & + call PressureForce_blk_AFV_init(Time, G, GV, US, param_file, diag, & CS%PressureForce_blk_AFV_CSp, tides_CSp) elseif (CS%Analytic_FV_PGF) then - call PressureForce_AFV_init(Time, G, GV, param_file, diag, & + call PressureForce_AFV_init(Time, G, GV, US, param_file, diag, & CS%PressureForce_AFV_CSp, tides_CSp) else - call PressureForce_Mont_init(Time, G, GV, param_file, diag, & + call PressureForce_Mont_init(Time, G, GV, US, param_file, diag, & CS%PressureForce_Mont_CSp, tides_CSp) endif diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index 147f264cc3..09d3e64266 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -9,6 +9,7 @@ module MOM_PressureForce_Mont use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type use MOM_tidal_forcing, only : calc_tidal_forcing, tidal_forcing_CS +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use MOM_EOS, only : calculate_density, calculate_density_derivs @@ -21,24 +22,31 @@ module MOM_PressureForce_Mont public PressureForce_Mont_Bouss, PressureForce_Mont_nonBouss, Set_pbce_Bouss public Set_pbce_nonBouss, PressureForce_Mont_init, PressureForce_Mont_end +! 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. + !> Control structure for the Montgomery potential form of pressure gradient type, public :: PressureForce_Mont_CS ; private logical :: tides !< If true, apply tidal momentum forcing. real :: Rho0 !< The density used in the Boussinesq - !! approximation, in kg m-3. - real :: Rho_atm !< The assumed atmospheric density, in kg m-3. + !! approximation [kg m-3]. + real :: Rho_atm !< The assumed atmospheric density [kg m-3]. !! By default, Rho_atm is 0. - real :: GFS_scale !< Ratio between gravity applied to top interface - !! and the gravitational acceleration of the planet. + real :: GFS_scale !< Ratio between gravity applied to top interface and the + !! gravitational acceleration of the planet [nondim]. !! Usually this ratio is 1. - type(time_type), pointer :: Time ! A pointer to the ocean model's clock. - type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the - ! timing of diagnostic output. - real, pointer :: PFu_bc(:,:,:) => NULL() ! Accelerations due to pressure - real, pointer :: PFv_bc(:,:,:) => NULL() ! gradients deriving from density - ! gradients within layers, m s-2. + type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate + !! the timing of diagnostic output. + real, pointer :: PFu_bc(:,:,:) => NULL() !< Accelerations due to pressure + real, pointer :: PFv_bc(:,:,:) => NULL() !< gradients deriving from density + !! gradients within layers [m s-2]. + !>@{ Diagnostic IDs integer :: id_PFu_bc = -1, id_PFv_bc = -1, id_e_tidal = -1 - type(tidal_forcing_CS), pointer :: tides_CSp => NULL() + !!@} + type(tidal_forcing_CS), pointer :: tides_CSp => NULL() !< The tidal forcing control structure end type PressureForce_Mont_CS contains @@ -49,61 +57,63 @@ module MOM_PressureForce_Mont !! non-Boussinesq fluid using the compressibility compensated (if appropriate) !! Montgomery-potential form described in Hallberg (Ocean Mod., 2005). !! -!! To work, the following fields must be set outside of the usual -!! ie to ie, je to je range before this subroutine is called: -!! h[ie+1] and h[je+1] and and (if tv%form_of_EOS is set) T[ie+1], S[ie+1], -!! T[je+1], and S[je+1]. -subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbce, eta) +!! To work, the following fields must be set outside of the usual (is:ie,js:je) +!! range before this subroutine is called: +!! h(isB:ie+1,jsB:je+1), T(isB:ie+1,jsB:je+1), and S(isB:ie+1,jsB:je+1). +subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, eta) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure. type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness, in kg/m2. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness, [H ~> kg m-2]. type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: PFu !< Zonal acceleration due to pressure gradients - !! (equal to -dM/dx) in m/s2. + !! (equal to -dM/dx) [m s-2]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: PFv !< Meridional acceleration due to pressure gradients - !! (equal to -dM/dy) in m/s2. + !! (equal to -dM/dy) [m s-2]. type(PressureForce_Mont_CS), pointer :: CS !< Control structure for Montgomery potential PGF - real, dimension(:,:), optional, pointer :: p_atm !< The pressure at the ice-ocean or - !! atmosphere-ocean in Pa. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: pbce !< The baroclinic pressure anomaly in + real, dimension(:,:), optional, pointer :: p_atm !< The pressure at the ice-ocean or + !! atmosphere-ocean [Pa]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + optional, intent(out) :: pbce !< The baroclinic pressure anomaly in !! each layer due to free surface height anomalies, - !! in m2 s-2 H-1. - real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: eta !< Free surface height, in m. + !! [m2 s-2 H-1 ~> m s-2 or m4 kg-1 s-2]. + real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: eta !< Free surface height [H ~> kg m-1]. + ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & - M, & ! The Montgomery potential, M = (p/rho + gz) , in m2 s-2. - alpha_star, & ! Compression adjusted specific volume, in m3 kg-1. - dz_geo ! The change in geopotential across a layer, in m2 s-2. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: p ! Interface pressure in Pa. + M, & ! The Montgomery potential, M = (p/rho + gz) [m2 s-2]. + alpha_star, & ! Compression adjusted specific volume [m3 kg-1]. + dz_geo ! The change in geopotential across a layer [m2 s-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: p ! Interface pressure [Pa]. ! p may be adjusted (with a nonlinear equation of state) so that ! its derivative compensates for the adiabatic compressibility ! in seawater, but p will still be close to the pressure. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), target :: & T_tmp, & ! Temporary array of temperatures where layers that are lighter - ! than the mixed layer have the mixed layer's properties, in C. + ! than the mixed layer have the mixed layer's properties [degC]. S_tmp ! Temporary array of salinities where layers that are lighter - ! than the mixed layer have the mixed layer's properties, in psu. + ! than the mixed layer have the mixed layer's properties [ppt]. real, dimension(SZI_(G)) :: Rho_cv_BL ! The coordinate potential density in the - ! deepest variable density near-surface layer, in kg m-3. + ! deepest variable density near-surface layer [kg m-3]. real, dimension(SZI_(G),SZJ_(G)) :: & dM, & ! A barotropic correction to the Montgomery potentials to - ! enable the use of a reduced gravity form of the equations, - ! in m2 s-2. - dp_star, & ! Layer thickness after compensation for compressibility, in Pa. + ! enable the use of a reduced gravity form of the equations + ! [m2 s-2]. + dp_star, & ! Layer thickness after compensation for compressibility [Pa]. + SSH, & ! The sea surface height anomaly, in depth units [Z ~> m]. e_tidal, & ! Bottom geopotential anomaly due to tidal forces from - ! astronomical sources and self-attraction and loading, in m. - geopot_bot, & ! Bottom geopotential relative to time-mean sea level, - ! including any tidal contributions, in units of m2 s-2. - SSH ! Sea surface height anomalies, in m. + ! astronomical sources and self-attraction and loading [Z ~> m]. + geopot_bot ! Bottom geopotential relative to time-mean sea level, + ! including any tidal contributions [m2 s-2]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate - ! density, in Pa (usually 2e7 Pa = 2000 dbar). - real :: rho_in_situ(SZI_(G)) !In-situ density of a layer, in kg m-3. + ! density [Pa] (usually 2e7 Pa = 2000 dbar). + real :: rho_in_situ(SZI_(G)) !In-situ density of a layer [kg m-3]. real :: PFu_bc, PFv_bc ! The pressure gradient force due to along-layer - ! compensated density gradients, in m s-2. + ! compensated density gradients [m s-2] real :: dp_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected, in Pa. + ! in roundoff and can be neglected [Pa]. logical :: use_p_atm ! If true, use the atmospheric pressure. logical :: use_EOS ! If true, density is calculated from T & S using ! an equation of state. @@ -112,12 +122,12 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbce, ! barotropic and baroclinic pieces. type(thermo_var_ptrs) :: tv_tmp! A structure of temporary T & S. - real :: I_gEarth - real :: dalpha + real :: I_gEarth ! The inverse of g_Earth [s2 Z m-2 ~> s2 m-1] +! real :: dalpha real :: Pa_to_H ! A factor to convert from Pa to the thicknesss units (H). - real :: alpha_Lay(SZK_(G)) ! The specific volume of each layer, in kg m-3. + real :: alpha_Lay(SZK_(G)) ! The specific volume of each layer [kg m-3]. real :: dalpha_int(SZK_(G)+1) ! The change in specific volume across each - ! interface, in kg m-3. + ! interface [kg m-3]. integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb integer :: i, j, k is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -139,36 +149,30 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbce, I_gEarth = 1.0 / GV%g_Earth dp_neglect = GV%H_to_Pa * GV%H_subroundoff -!$OMP parallel default(none) shared(nz,alpha_Lay,GV,dalpha_int) -!$OMP do do k=1,nz ; alpha_Lay(k) = 1.0 / GV%Rlay(k) ; enddo -!$OMP do do k=2,nz ; dalpha_int(K) = alpha_Lay(k-1) - alpha_Lay(k) ; enddo -!$OMP end parallel -!$OMP parallel default(none) shared(Isq,Ieq,Jsq,Jeq,nz,p,p_atm,GV,h,use_p_atm) if (use_p_atm) then -!$OMP do + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 ; p(i,j,1) = p_atm(i,j) ; enddo ; enddo else -!$OMP do + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 ; p(i,j,1) = 0.0 ; enddo ; enddo endif -!$OMP do + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do k=1,nz ; do i=Isq,Ieq+1 p(i,j,K+1) = p(i,j,K) + GV%H_to_Pa * h(i,j,k) enddo ; enddo ; enddo -!$OMP end parallel if (present(eta)) then Pa_to_H = 1.0 / GV%H_to_Pa if (use_p_atm) then -!$OMP parallel do default(none) shared(Isq,Ieq,Jsq,Jeq,nz,eta,p,p_atm,Pa_to_H) + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 eta(i,j) = (p(i,j,nz+1) - p_atm(i,j))*Pa_to_H ! eta has the same units as h. enddo ; enddo else -!$OMP parallel do default(none) shared(Isq,Ieq,Jsq,Jeq,nz,eta,p,Pa_to_H) + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 eta(i,j) = p(i,j,nz+1)*Pa_to_H ! eta has the same units as h. enddo ; enddo @@ -178,37 +182,34 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbce, if (CS%tides) then ! Determine the sea surface height anomalies, to enable the calculation ! of self-attraction and loading. -!$OMP parallel default(none) shared(Isq,Ieq,Jsq,Jeq,nz,SSH,G,GV,use_EOS,tv,p,dz_geo, & -!$OMP I_gEarth,h,alpha_Lay) -!$OMP do + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 SSH(i,j) = -G%bathyT(i,j) enddo ; enddo if (use_EOS) then -!$OMP do + !$OMP parallel do default(shared) do k=1,nz call int_specific_vol_dp(tv%T(:,:,k), tv%S(:,:,k), p(:,:,k), p(:,:,k+1), & 0.0, G%HI, tv%eqn_of_state, dz_geo(:,:,k), halo_size=1) enddo -!$OMP do + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do k=1,nz; do i=Isq,Ieq+1 SSH(i,j) = SSH(i,j) + I_gEarth * dz_geo(i,j,k) enddo ; enddo ; enddo else -!$OMP do + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do k=1,nz ; do i=Isq,Ieq+1 - SSH(i,j) = SSH(i,j) + GV%H_to_kg_m2*h(i,j,k)*alpha_Lay(k) + SSH(i,j) = SSH(i,j) + (US%m_to_Z*GV%H_to_kg_m2)*h(i,j,k)*alpha_Lay(k) enddo ; enddo ; enddo endif -!$OMP end parallel - call calc_tidal_forcing(CS%Time, SSH, e_tidal, G, CS%tides_CSp) -!$OMP parallel do default(none) shared(Isq,Ieq,Jsq,Jeq,geopot_bot,G,GV,e_tidal) + call calc_tidal_forcing(CS%Time, SSH, e_tidal, G, CS%tides_CSp, m_to_Z=US%m_to_Z) + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 geopot_bot(i,j) = -GV%g_Earth*(e_tidal(i,j) + G%bathyT(i,j)) enddo ; enddo else -!$OMP parallel do default(none) shared(Isq,Ieq,Jsq,Jeq,geopot_bot,G,GV) + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 geopot_bot(i,j) = -GV%g_Earth*G%bathyT(i,j) enddo ; enddo @@ -225,8 +226,7 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbce, tv_tmp%T => T_tmp ; tv_tmp%S => S_tmp tv_tmp%eqn_of_state => tv%eqn_of_state do i=Isq,Ieq+1 ; p_ref(i) = tv%P_Ref ; enddo -!$OMP parallel do default(none) shared(Isq,Ieq,Jsq,Jeq,nz,nkmb,tv_tmp,tv,p_ref,GV) & -!$OMP private(Rho_cv_BL) + !$OMP parallel do default(shared) private(Rho_cv_BL) do j=Jsq,Jeq+1 do k=1,nkmb ; do i=Isq,Ieq+1 tv_tmp%T(i,j,k) = tv%T(i,j,k) ; tv_tmp%S(i,j,k) = tv%S(i,j,k) @@ -246,8 +246,7 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbce, tv_tmp%eqn_of_state => tv%eqn_of_state do i=Isq,Ieq+1 ; p_ref(i) = 0 ; enddo endif -!$OMP parallel do default(none) shared(Isq,Ieq,Jsq,Jeq,nz,tv_tmp,p_ref,tv,alpha_star) & -!$OMP private(rho_in_situ) + !$OMP parallel do default(shared) private(rho_in_situ) do k=1,nz ; do j=Jsq,Jeq+1 call calculate_density(tv_tmp%T(:,j,k),tv_tmp%S(:,j,k),p_ref, & rho_in_situ,Isq,Ieq-Isq+2,tv%eqn_of_state) @@ -256,7 +255,7 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbce, endif ! use_EOS if (use_EOS) then -!$OMP parallel do default(none) shared(Isq,Ieq,Jsq,Jeq,nz,M,geopot_bot,p,alpha_star) + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 do i=Isq,Ieq+1 M(i,j,nz) = geopot_bot(i,j) + p(i,j,nz+1) * alpha_star(i,j,nz) @@ -266,8 +265,7 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbce, enddo ; enddo enddo else ! not use_EOS -!$OMP parallel do default(none) shared(Isq,Ieq,Jsq,Jeq,nz,M,geopot_bot,p,& -!$OMP alpha_Lay,dalpha_int) + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 do i=Isq,Ieq+1 M(i,j,nz) = geopot_bot(i,j) + p(i,j,nz+1) * alpha_Lay(nz) @@ -280,11 +278,11 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbce, if (CS%GFS_scale < 1.0) then ! Adjust the Montgomery potential to make this a reduced gravity model. -!$OMP parallel do default(none) shared(Isq,Ieq,Jsq,Jeq,dM,CS,M) + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 dM(i,j) = (CS%GFS_scale - 1.0) * M(i,j,1) enddo ; enddo -!$OMP parallel do default(none) shared(Isq,Ieq,Jsq,Jeq,nz,dM,M) + !$OMP parallel do default(shared) do k=1,nz ; do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 M(i,j,k) = M(i,j,k) + dM(i,j) enddo ; enddo ; enddo @@ -308,16 +306,13 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbce, ! Note that ddM/dPb = alpha_star(i,j,1) if (present(pbce)) then - call Set_pbce_nonBouss(p, tv_tmp, G, GV, GV%g_Earth, CS%GFS_scale, pbce, & - alpha_star) + call Set_pbce_nonBouss(p, tv_tmp, G, GV, CS%GFS_scale, pbce, alpha_star) endif ! Calculate the pressure force. On a Cartesian grid, ! PFu = - dM/dx and PFv = - dM/dy. if (use_EOS) then -!$OMP parallel do default(none) shared(is,ie,js,je,Isq,Ieq,Jsq,Jeq,nz,p,dp_neglect, & -!$OMP alpha_star,G,PFu,PFv,M,CS) & -!$OMP private(dp_star,PFu_bc,PFv_bc) + !$OMP parallel do default(shared) private(dp_star,PFu_bc,PFv_bc) do k=1,nz do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 dp_star(i,j) = (p(i,j,K+1) - p(i,j,K)) + dp_neglect @@ -339,7 +334,7 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbce, enddo ; enddo enddo ! k-loop else ! .not. use_EOS -!$OMP parallel do default(none) shared(is,ie,js,je,Isq,Ieq,Jsq,Jeq,nz,PFu,PFv,M,G) + !$OMP parallel do default(shared) do k=1,nz do j=js,je ; do I=Isq,Ieq PFu(I,j,k) = -(M(i+1,j,k) - M(i,j,k)) * G%IdxCu(I,j) @@ -360,57 +355,57 @@ end subroutine PressureForce_Mont_nonBouss !! !! Determines the acceleration due to pressure forces. !! -!! To work, the following fields must be set outside of the usual -!! ie to ie, je to je range before this subroutine is called: -!! h[ie+1] and h[je+1] and (if tv%form_of_EOS is set) T[ie+1], S[ie+1], -!! T[je+1], and S[je+1]. -subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbce, eta) +!! To work, the following fields must be set outside of the usual (is:ie,js:je) +!! range before this subroutine is called: +!! h(isB:ie+1,jsB:je+1), T(isB:ie+1,jsB:je+1), and S(isB:ie+1,jsB:je+1). +subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, eta) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure. type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness, in m. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m]. type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: PFu !< Zonal acceleration due to pressure gradients - !! (equal to -dM/dx) in m/s2. + !! (equal to -dM/dx) [m s-2]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: PFv !< Meridional acceleration due to pressure gradients - !! (equal to -dM/dy) in m/s2. + !! (equal to -dM/dy) [m s2]. type(PressureForce_Mont_CS), pointer :: CS !< Control structure for Montgomery potential PGF real, dimension(:,:), optional, pointer :: p_atm !< The pressure at the ice-ocean or - !! atmosphere-ocean in Pa. + !! atmosphere-ocean [Pa]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: pbce !< The baroclinic pressure anomaly in - !! each layer due to free surface height anomalies, - !! in m2 s-2 H-1. - real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: eta !< Free surface height, in m. + !! each layer due to free surface height anomalies + !! [m2 s-2 H-1 ~> m s-2]. + real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: eta !< Free surface height [H ~> m]. ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & - M, & ! The Montgomery potential, M = (p/rho + gz) , in m2 s-2. + M, & ! The Montgomery potential, M = (p/rho + gz) [m2 s-2]. rho_star ! In-situ density divided by the derivative with depth of the - ! corrected e times (G_Earth/Rho0). In units of m s-2. + ! corrected e times (G_Earth/Rho0) [m2 Z-1 s-2 ~> m s-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: e ! Interface height in m. - ! e may be adjusted (with a nonlinearequation of state) so that + ! e may be adjusted (with a nonlinear equation of state) so that ! its derivative compensates for the adiabatic compressibility ! in seawater, but e will still be close to the interface depth. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), target :: & T_tmp, & ! Temporary array of temperatures where layers that are lighter - ! than the mixed layer have the mixed layer's properties, in C. + ! than the mixed layer have the mixed layer's properties [degC]. S_tmp ! Temporary array of salinities where layers that are lighter - ! than the mixed layer have the mixed layer's properties, in psu. + ! than the mixed layer have the mixed layer's properties [ppt]. real :: Rho_cv_BL(SZI_(G)) ! The coordinate potential density in - ! the deepest variable density near-surface layer, in kg m-3. + ! the deepest variable density near-surface layer [kg m-3]. real :: h_star(SZI_(G),SZJ_(G)) ! Layer thickness after compensation - ! for compressibility, in m. + ! for compressibility [Z ~> m]. real :: e_tidal(SZI_(G),SZJ_(G)) ! Bottom geopotential anomaly due to tidal ! forces from astronomical sources and self- - ! attraction and loading, in m. + ! attraction and loading, in depth units [Z ~> m]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate - ! density, in Pa (usually 2e7 Pa = 2000 dbar). - real :: I_Rho0 ! 1/Rho0. - real :: G_Rho0 ! G_Earth / Rho0 in m4 s-2 kg-1. + ! density [Pa] (usually 2e7 Pa = 2000 dbar). + real :: I_Rho0 ! 1/Rho0 [m3 kg-1]. + real :: G_Rho0 ! G_Earth / Rho0 [m5 Z-1 s-2 kg-1 ~> m4 s-2 kg-1]. real :: PFu_bc, PFv_bc ! The pressure gradient force due to along-layer - ! compensated density gradients, in m s-2. - real :: dr ! Temporary variables. + ! compensated density gradients [m s-2] +! real :: dr ! Temporary variables. real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected, in m. + ! in roundoff and can be neglected [Z ~> m]. logical :: use_p_atm ! If true, use the atmospheric pressure. logical :: use_EOS ! If true, density is calculated from T & S using ! an equation of state. @@ -438,7 +433,7 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbce, eta "can no longer be used with a compressible EOS. Use #define ANALYTIC_FV_PGF.") endif - h_neglect = GV%H_subroundoff * GV%H_to_m + h_neglect = GV%H_subroundoff * GV%H_to_Z I_Rho0 = 1.0/CS%Rho0 G_Rho0 = GV%g_Earth/GV%Rho0 @@ -447,36 +442,34 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbce, eta ! and loading. This should really be based on bottom pressure anomalies, ! but that is not yet implemented, and the current form is correct for ! barotropic tides. -!$OMP parallel do default(none) shared(Isq,Ieq,Jsq,Jeq,nz,e,h,G,GV) + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 - do i=Isq,Ieq+1 ; e(i,j,1) = -1.0*G%bathyT(i,j) ; enddo + do i=Isq,Ieq+1 ; e(i,j,1) = -G%bathyT(i,j) ; enddo do k=1,nz ; do i=Isq,Ieq+1 - e(i,j,1) = e(i,j,1) + h(i,j,k)*GV%H_to_m + e(i,j,1) = e(i,j,1) + h(i,j,k)*GV%H_to_Z enddo ; enddo enddo - call calc_tidal_forcing(CS%Time, e(:,:,1), e_tidal, G, CS%tides_CSp) + call calc_tidal_forcing(CS%Time, e(:,:,1), e_tidal, G, CS%tides_CSp, m_to_Z=US%m_to_Z) endif ! Here layer interface heights, e, are calculated. -!$OMP parallel default(none) shared(Isq,Ieq,Jsq,Jeq,nz,e,h,G,GV,e_tidal,CS) if (CS%tides) then -!$OMP do + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - e(i,j,nz+1) = -1.0*G%bathyT(i,j) - e_tidal(i,j) + e(i,j,nz+1) = -(G%bathyT(i,j) + e_tidal(i,j)) enddo ; enddo else -!$OMP do + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - e(i,j,nz+1) = -1.0*G%bathyT(i,j) + e(i,j,nz+1) = -G%bathyT(i,j) enddo ; enddo endif -!$OMP do + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do k=nz,1,-1 ; do i=Isq,Ieq+1 - e(i,j,K) = e(i,j,K+1) + h(i,j,k)*GV%H_to_m + e(i,j,K) = e(i,j,K+1) + h(i,j,k)*GV%H_to_Z enddo ; enddo ; enddo -!$OMP end parallel - if (use_EOS) then + if (use_EOS) then ! Calculate in-situ densities (rho_star). ! With a bulk mixed layer, replace the T & S of any layers that are @@ -489,8 +482,7 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbce, eta tv_tmp%eqn_of_state => tv%eqn_of_state do i=Isq,Ieq+1 ; p_ref(i) = tv%P_Ref ; enddo -!$OMP parallel do default(none) shared(Isq,Ieq,Jsq,Jeq,nz,nkmb,tv_tmp,tv,p_ref,GV) & -!$OMP private(Rho_cv_BL) + !$OMP parallel do default(shared) private(Rho_cv_BL) do j=Jsq,Jeq+1 do k=1,nkmb ; do i=Isq,Ieq+1 tv_tmp%T(i,j,k) = tv%T(i,j,k) ; tv_tmp%S(i,j,k) = tv%S(i,j,k) @@ -514,7 +506,7 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbce, eta ! This no longer includes any pressure dependency, since this routine ! will come down with a fatal error if there is any compressibility. -!$OMP parallel do default(none) shared(Isq,Ieq,Jsq,Jeq,nz,tv_tmp,p_ref,rho_star,tv,G_Rho0) + !$OMP parallel do default(shared) do k=1,nz+1 ; do j=Jsq,Jeq+1 call calculate_density(tv_tmp%T(:,j,k), tv_tmp%S(:,j,k), p_ref, rho_star(:,j,k), & Isq,Ieq-Isq+2,tv%eqn_of_state) @@ -524,8 +516,7 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbce, eta ! Here the layer Montgomery potentials, M, are calculated. if (use_EOS) then -!$OMP parallel do default(none) shared(Isq,Ieq,Jsq,Jeq,nz,M,CS,rho_star,e,use_p_atm, & -!$OMP p_atm,I_Rho0) + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 do i=Isq,Ieq+1 M(i,j,1) = CS%GFS_scale * (rho_star(i,j,1) * e(i,j,1)) @@ -536,7 +527,7 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbce, eta enddo ; enddo enddo else ! not use_EOS -!$OMP parallel do default(none) shared(Isq,Ieq,Jsq,Jeq,nz,M,GV,e,use_p_atm,p_atm,I_Rho0) + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 do i=Isq,Ieq+1 M(i,j,1) = GV%g_prime(1) * e(i,j,1) @@ -549,16 +540,13 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbce, eta endif ! use_EOS if (present(pbce)) then - call Set_pbce_Bouss(e, tv_tmp, G, GV, GV%g_Earth, CS%Rho0, CS%GFS_scale, pbce, & - rho_star) + call Set_pbce_Bouss(e, tv_tmp, G, GV, CS%Rho0, CS%GFS_scale, pbce, rho_star) endif ! Calculate the pressure force. On a Cartesian grid, ! PFu = - dM/dx and PFv = - dM/dy. if (use_EOS) then -!$OMP parallel do default(none) shared(Isq,Ieq,Jsq,Jeq,js,je,is,ie,nz,e,h_neglect, & -!$OMP rho_star,G,PFu,CS,PFv,M) & -!$OMP private(h_star,PFu_bc,PFv_bc) + !$OMP parallel do default(shared) private(h_star,PFu_bc,PFv_bc) do k=1,nz do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 h_star(i,j) = (e(i,j,K) - e(i,j,K+1)) + h_neglect @@ -579,7 +567,7 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbce, eta enddo ; enddo enddo ! k-loop else ! .not. use_EOS -!$OMP parallel do default(none) shared(Isq,Ieq,Jsq,Jeq,is,ie,js,je,nz,PFu,PFv,M,G) + !$OMP parallel do default(shared) do k=1,nz do j=js,je ; do I=Isq,Ieq PFu(I,j,k) = -(M(i+1,j,k) - M(i,j,k)) * G%IdxCu(I,j) @@ -595,14 +583,14 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbce, eta ! eta is the sea surface height relative to a time-invariant geoid, for ! comparison with what is used for eta in btstep. See how e was calculated ! about 200 lines above. -!$OMP parallel do default(none) shared(Isq,Ieq,Jsq,Jeq,eta,e,e_tidal,GV) + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta(i,j) = e(i,j,1)*GV%m_to_H + e_tidal(i,j)*GV%m_to_H + eta(i,j) = e(i,j,1)*GV%Z_to_H + e_tidal(i,j)*GV%Z_to_H enddo ; enddo else -!$OMP parallel do default(none) shared(Isq,Ieq,Jsq,Jeq,eta,e,GV) + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta(i,j) = e(i,j,1)*GV%m_to_H + eta(i,j) = e(i,j,1)*GV%Z_to_H enddo ; enddo endif endif @@ -615,53 +603,53 @@ end subroutine PressureForce_Mont_Bouss !> Determines the partial derivative of the acceleration due !! to pressure forces with the free surface height. -subroutine Set_pbce_Bouss(e, tv, G, GV, g_Earth, Rho0, GFS_scale, pbce, rho_star) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: e !< Interface height, in H. - type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables - real, intent(in) :: g_Earth !< The gravitational acceleration, in m s-2. - real, intent(in) :: Rho0 !< The "Boussinesq" ocean density, in kg m-3. - real, intent(in) :: GFS_scale !< Ratio between gravity applied to top interface - !! and the gravitational acceleration of the planet. - !! Usually this ratio is 1. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: pbce !< The baroclinic pressure anomaly in each layer due - !! to free surface height anomalies, in m2 H-1 s-2. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(in) :: rho_star !< The layer densities (maybe - !! compressibility compensated), times g/rho_0, in m s-2. +subroutine Set_pbce_Bouss(e, tv, G, GV, Rho0, GFS_scale, pbce, rho_star) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: e !< Interface height [Z ~> m]. + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables + real, intent(in) :: Rho0 !< The "Boussinesq" ocean density [kg m-3]. + real, intent(in) :: GFS_scale !< Ratio between gravity applied to top + !! interface and the gravitational acceleration of + !! the planet [nondim]. Usually this ratio is 1. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(out) :: pbce !< The baroclinic pressure anomaly in each layer due + !! to free surface height anomalies + !! [m2 H-1 s-2 ~> m4 kg-2 s-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + optional, intent(in) :: rho_star !< The layer densities (maybe compressibility + !! compensated), times g/rho_0 [m2 Z-1 s-2 ~> m s-2]. + ! Local variables - real :: Ihtot(SZI_(G)) ! The inverse of the sum of the layer - ! thicknesses, in m-1. - real :: press(SZI_(G)) ! Interface pressure, in Pa. - real :: T_int(SZI_(G)) ! Interface temperature in C. - real :: S_int(SZI_(G)) ! Interface salinity in PSU. - real :: dR_dT(SZI_(G)) ! Partial derivatives of density with temperature - real :: dR_dS(SZI_(G)) ! and salinity in kg m-3 K-1 and kg m-3 PSU-1. - real :: rho_in_situ(SZI_(G)) !In-situ density at the top of a layer. - real :: G_Rho0 ! g_Earth / Rho0 in m4 s-2 kg-1. - real :: Rho0xG ! g_Earth * Rho0 in kg s-2 m-2. + real :: Ihtot(SZI_(G)) ! The inverse of the sum of the layer thicknesses [H-1 ~> m-1 or m2 kg-1]. + real :: press(SZI_(G)) ! Interface pressure [Pa]. + real :: T_int(SZI_(G)) ! Interface temperature [degC]. + real :: S_int(SZI_(G)) ! Interface salinity [ppt]. + real :: dR_dT(SZI_(G)) ! Partial derivative of density with temperature [kg m-3 degC-1]. + real :: dR_dS(SZI_(G)) ! Partial derivative of density with salinity [kg m-3 ppt-1]. + real :: rho_in_situ(SZI_(G)) !In-situ density at the top of a layer [kg m-3]. + real :: G_Rho0 ! G_Earth / Rho0 [m5 Z-1 s-2 kg-1 ~> m4 s-2 kg-1] + real :: Rho0xG ! g_Earth * Rho0 [kg s-2 m-1 Z-1 ~> kg s-2 m-2] logical :: use_EOS ! If true, density is calculated from T & S using ! an equation of state. - real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected, in m. + real :: z_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m]. integer :: Isq, Ieq, Jsq, Jeq, nz, i, j, k Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = G%ke - Rho0xG = Rho0*g_Earth - G_Rho0 = g_Earth/Rho0 + Rho0xG = Rho0*GV%g_Earth + G_Rho0 = GV%g_Earth / GV%Rho0 use_EOS = associated(tv%eqn_of_state) - h_neglect = GV%H_subroundoff*GV%H_to_m + z_neglect = GV%H_subroundoff*GV%H_to_Z if (use_EOS) then if (present(rho_star)) then -!$OMP parallel do default(none) shared(Isq,Ieq,Jsq,Jeq,nz,e,h_neglect,pbce,rho_star,& -!$OMP GFS_scale,GV) & -!$OMP private(Ihtot) + !$OMP parallel do default(shared) private(Ihtot) do j=Jsq,Jeq+1 do i=Isq,Ieq+1 - Ihtot(i) = 1.0 / (((e(i,j,1)-e(i,j,nz+1)) + h_neglect) * GV%m_to_H) - pbce(i,j,1) = GFS_scale * rho_star(i,j,1) * GV%H_to_m + Ihtot(i) = GV%H_to_Z / ((e(i,j,1)-e(i,j,nz+1)) + z_neglect) + pbce(i,j,1) = GFS_scale * rho_star(i,j,1) * GV%H_to_Z enddo do k=2,nz ; do i=Isq,Ieq+1 pbce(i,j,k) = pbce(i,j,k-1) + (rho_star(i,j,k)-rho_star(i,j,k-1)) * & @@ -669,18 +657,16 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, g_Earth, Rho0, GFS_scale, pbce, rho_star enddo ; enddo enddo ! end of j loop else -!$OMP parallel do default(none) shared(Isq,Ieq,Jsq,Jeq,nz,e,tv,h_neglect,G_Rho0,Rho0xG,& -!$OMP pbce,GFS_scale,GV) & -!$OMP private(Ihtot,press,rho_in_situ,T_int,S_int,dR_dT,dR_dS) + !$OMP parallel do default(shared) private(Ihtot,press,rho_in_situ,T_int,S_int,dR_dT,dR_dS) do j=Jsq,Jeq+1 do i=Isq,Ieq+1 - Ihtot(i) = 1.0 / (((e(i,j,1)-e(i,j,nz+1)) + h_neglect) * GV%m_to_H) + Ihtot(i) = GV%H_to_Z / ((e(i,j,1)-e(i,j,nz+1)) + z_neglect) press(i) = -Rho0xG*e(i,j,1) enddo call calculate_density(tv%T(:,j,1), tv%S(:,j,1), press, rho_in_situ, & Isq, Ieq-Isq+2, tv%eqn_of_state) do i=Isq,Ieq+1 - pbce(i,j,1) = G_Rho0*(GFS_scale * rho_in_situ(i)) * GV%H_to_m + pbce(i,j,1) = G_Rho0*(GFS_scale * rho_in_situ(i)) * GV%H_to_Z enddo do k=2,nz do i=Isq,Ieq+1 @@ -700,15 +686,15 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, g_Earth, Rho0, GFS_scale, pbce, rho_star enddo ! end of j loop endif else ! not use_EOS -!$OMP parallel do default(none) shared(Isq,Ieq,Jsq,Jeq,nz,e,GV,h_neglect,pbce) private(Ihtot) + !$OMP parallel do default(shared) private(Ihtot) do j=Jsq,Jeq+1 do i=Isq,Ieq+1 - Ihtot(i) = 1.0 / (((e(i,j,1)-e(i,j,nz+1)) + h_neglect) * GV%m_to_H) - pbce(i,j,1) = GV%g_prime(1) * GV%H_to_m + Ihtot(i) = 1.0 / ((e(i,j,1)-e(i,j,nz+1)) + z_neglect) + pbce(i,j,1) = GV%g_prime(1) * GV%H_to_Z enddo do k=2,nz ; do i=Isq,Ieq+1 pbce(i,j,k) = pbce(i,j,k-1) + & - GV%g_prime(K) * ((e(i,j,K) - e(i,j,nz+1)) * Ihtot(i)) + (GV%g_prime(K)*GV%H_to_Z) * ((e(i,j,K) - e(i,j,nz+1)) * Ihtot(i)) enddo ; enddo enddo ! end of j loop endif ! use_EOS @@ -717,36 +703,34 @@ end subroutine Set_pbce_Bouss !> Determines the partial derivative of the acceleration due !! to pressure forces with the column mass. -subroutine Set_pbce_nonBouss(p, tv, G, GV, g_Earth, GFS_scale, pbce, alpha_star) +subroutine Set_pbce_nonBouss(p, tv, G, GV, GFS_scale, pbce, alpha_star) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: p !< Interface pressures, in Pa. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: p !< Interface pressures [Pa]. type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables - real, intent(in) :: g_Earth !< The gravitational acceleration, in m s-2. - real, intent(in) :: GFS_scale !< Ratio between gravity applied to top interface - !! and the gravitational acceleration of the planet. - !! Usually this ratio is 1. + real, intent(in) :: GFS_scale !< Ratio between gravity applied to top + !! interface and the gravitational acceleration of + !! the planet [nondim]. Usually this ratio is 1. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: pbce !< The baroclinic pressure anomaly in each layer due - !! to free surface height anomalies, in m2 H-1 s-2. + !! to free surface height anomalies + !! [m2 H-1 s-2 ~> m4 kg-2 s-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(in) :: alpha_star !< The layer specific volumes - !! (maybe compressibility compensated), in m3 kg-1. + !! (maybe compressibility compensated) [m3 kg-1]. ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & dpbce, & ! A barotropic correction to the pbce to enable the use of - ! a reduced gravity form of the equations, in m4 s-2 kg-1. - C_htot ! dP_dH divided by the total ocean pressure, m2 kg-1. - real :: T_int(SZI_(G)) ! Interface temperature in C. - real :: S_int(SZI_(G)) ! Interface salinity in PSU. - real :: dR_dT(SZI_(G)) ! Partial derivatives of density with temperature - real :: dR_dS(SZI_(G)) ! and salinity in kg m-3 K-1 and kg m-3 PSU-1. - real :: rho_in_situ(SZI_(G)) !In-situ density at an interface, in kg m-3. - real :: alpha_Lay(SZK_(G)) ! The specific volume of each layer, in kg m-3. - real :: dalpha_int(SZK_(G)+1) ! The change in specific volume across each - ! interface, in kg m-3. - real :: dP_dH ! A factor that converts from thickness to pressure, - ! usually in Pa m2 kg-1. + ! a reduced gravity form of the equations [m4 s-2 kg-1]. + C_htot ! dP_dH divided by the total ocean pressure [m2 kg-1]. + real :: T_int(SZI_(G)) ! Interface temperature [degC]. + real :: S_int(SZI_(G)) ! Interface salinity [ppt]. + real :: dR_dT(SZI_(G)) ! Partial derivative of density with temperature [kg m-3 degC-1]. + real :: dR_dS(SZI_(G)) ! Partial derivative of density with salinity [kg m-3 ppt-1]. + real :: rho_in_situ(SZI_(G)) ! In-situ density at an interface [kg m-3]. + real :: alpha_Lay(SZK_(G)) ! The specific volume of each layer [kg m-3]. + real :: dalpha_int(SZK_(G)+1) ! The change in specific volume across each interface [kg m-3]. + real :: dP_dH ! A factor that converts from thickness to pressure [Pa H-1 ~> Pa m2 kg-1]. real :: dp_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected, in Pa. + ! in roundoff and can be neglected [Pa]. logical :: use_EOS ! If true, density is calculated from T & S using ! an equation of state. integer :: Isq, Ieq, Jsq, Jeq, nz, i, j, k @@ -755,7 +739,7 @@ subroutine Set_pbce_nonBouss(p, tv, G, GV, g_Earth, GFS_scale, pbce, alpha_star) use_EOS = associated(tv%eqn_of_state) - dP_dH = g_Earth * GV%H_to_kg_m2 + dP_dH = GV%H_to_Pa dp_neglect = dP_dH * GV%H_subroundoff do k=1,nz ; alpha_Lay(k) = 1.0 / GV%Rlay(k) ; enddo @@ -763,8 +747,7 @@ subroutine Set_pbce_nonBouss(p, tv, G, GV, g_Earth, GFS_scale, pbce, alpha_star) if (use_EOS) then if (present(alpha_star)) then -!$OMP parallel do default(none) shared(Isq,Ieq,Jsq,Jeq,nz,C_htot,dP_dH,p,dp_neglect, & -!$OMP pbce,alpha_star) + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 do i=Isq,Ieq+1 C_htot(i,j) = dP_dH / ((p(i,j,nz+1)-p(i,j,1)) + dp_neglect) @@ -776,9 +759,7 @@ subroutine Set_pbce_nonBouss(p, tv, G, GV, g_Earth, GFS_scale, pbce, alpha_star) enddo ; enddo enddo else -!$OMP parallel do default(none) shared(Isq,Ieq,Jsq,Jeq,nz,tv,p,C_htot, & -!$OMP dP_dH,dp_neglect,pbce) & -!$OMP private(T_int,S_int,dR_dT,dR_dS,rho_in_situ) + !$OMP parallel do default(shared) private(T_int,S_int,dR_dT,dR_dS,rho_in_situ) do j=Jsq,Jeq+1 call calculate_density(tv%T(:,j,nz), tv%S(:,j,nz), p(:,j,nz+1), & rho_in_situ, Isq, Ieq-Isq+2, tv%eqn_of_state) @@ -804,8 +785,7 @@ subroutine Set_pbce_nonBouss(p, tv, G, GV, g_Earth, GFS_scale, pbce, alpha_star) enddo endif else ! not use_EOS -!$OMP parallel do default(none) shared(Isq,Ieq,Jsq,Jeq,nz,C_htot,dP_dH,p,dp_neglect, & -!$OMP pbce,alpha_Lay,dalpha_int) + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 do i=Isq,Ieq+1 C_htot(i,j) = dP_dH / ((p(i,j,nz+1)-p(i,j,1)) + dp_neglect) @@ -820,25 +800,24 @@ subroutine Set_pbce_nonBouss(p, tv, G, GV, g_Earth, GFS_scale, pbce, alpha_star) if (GFS_scale < 1.0) then ! Adjust the Montgomery potential to make this a reduced gravity model. -!$OMP parallel default(none) shared(Isq,Ieq,Jsq,Jeq,dpbce,GFS_scale,pbce,nz) -!$OMP do + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 dpbce(i,j) = (GFS_scale - 1.0) * pbce(i,j,1) enddo ; enddo -!$OMP do + !$OMP parallel do default(shared) do k=1,nz ; do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 pbce(i,j,k) = pbce(i,j,k) + dpbce(i,j) enddo ; enddo ; enddo -!$OMP end parallel endif end subroutine Set_pbce_nonBouss !> Initialize the Montgomery-potential form of PGF control structure -subroutine PressureForce_Mont_init(Time, G, GV, param_file, diag, CS, tides_CSp) +subroutine PressureForce_Mont_init(Time, G, GV, US, param_file, diag, CS, tides_CSp) type(time_type), target, intent(in) :: Time !< Current model time type(ocean_grid_type), intent(in) :: G !< ocean 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 !< Parameter file handles type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure type(PressureForce_Mont_CS), pointer :: CS !< Montgomery PGF control structure @@ -890,7 +869,7 @@ subroutine PressureForce_Mont_init(Time, G, GV, param_file, diag, CS, tides_CSp) if (CS%tides) then CS%id_e_tidal = register_diag_field('ocean_model', 'e_tidal', diag%axesT1, & - Time, 'Tidal Forcing Astronomical and SAL Height Anomaly', 'meter') + Time, 'Tidal Forcing Astronomical and SAL Height Anomaly', 'meter', conversion=US%Z_to_m) endif CS%GFS_scale = 1.0 @@ -902,7 +881,7 @@ end subroutine PressureForce_Mont_init !> Deallocates the Montgomery-potential form of PGF control structure subroutine PressureForce_Mont_end(CS) - type(PressureForce_Mont_CS), pointer :: CS + type(PressureForce_Mont_CS), pointer :: CS !< Control structure for Montgomery potential PGF if (associated(CS)) deallocate(CS) end subroutine PressureForce_Mont_end diff --git a/src/core/MOM_PressureForce_analytic_FV.F90 b/src/core/MOM_PressureForce_analytic_FV.F90 index 3f2ae7528a..a8fcae3596 100644 --- a/src/core/MOM_PressureForce_analytic_FV.F90 +++ b/src/core/MOM_PressureForce_analytic_FV.F90 @@ -10,6 +10,7 @@ module MOM_PressureForce_AFV use MOM_grid, only : ocean_grid_type use MOM_PressureForce_Mont, only : set_pbce_Bouss, set_pbce_nonBouss use MOM_tidal_forcing, only : calc_tidal_forcing, tidal_forcing_CS +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use MOM_EOS, only : calculate_density, calculate_density_derivs @@ -26,13 +27,18 @@ module MOM_PressureForce_AFV public PressureForce_AFV, PressureForce_AFV_init, PressureForce_AFV_end public PressureForce_AFV_Bouss, PressureForce_AFV_nonBouss +! 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. + !> Finite volume pressure gradient control structure type, public :: PressureForce_AFV_CS ; private logical :: tides !< If true, apply tidal momentum forcing. real :: Rho0 !< The density used in the Boussinesq - !! approximation, in kg m-3. + !! approximation [kg m-3]. real :: GFS_scale !< A scaling of the surface pressure gradients to - !! allow the use of a reduced gravity model. + !! allow the use of a reduced gravity model [nondim]. type(time_type), pointer :: Time !< A pointer to the ocean model's clock. type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the !! timing of diagnostic output. @@ -57,28 +63,29 @@ module MOM_PressureForce_AFV !> Thin interface between the model and the Boussinesq and non-Boussinesq !! pressure force routines. -subroutine PressureForce_AFV(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm, pbce, eta) +subroutine PressureForce_AFV(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, eta) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness (m or kg/m2) + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamic variables - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: PFu !< Zonal acceleration (m/s2) - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: PFv !< Meridional acceleration (m/s2) + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: PFu !< Zonal acceleration [m s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: PFv !< Meridional acceleration [m s-2] type(PressureForce_AFV_CS), pointer :: CS !< Finite volume PGF control structure type(ALE_CS), pointer :: ALE_CSp !< ALE control structure real, dimension(:,:), optional, pointer :: p_atm !< The pressure at the ice-ocean - !! or atmosphere-ocean interface in Pa. + !! or atmosphere-ocean interface [Pa]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: pbce !< The baroclinic pressure - !! anomaly in each layer due to eta anomalies, - !! in m2 s-2 H-1. + !! anomaly in each layer due to eta anomalies + !! [m2 s-2 H-1 ~> m s-2 or m4 s-2 kg-1]. real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: eta !< The bottom mass used to - !! calculate PFu and PFv, in H, with any tidal + !! calculate PFu and PFv [H ~> m or kg m-2], with any tidal !! contributions or compressibility compensation. if (GV%Boussinesq) then - call PressureForce_AFV_bouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm, pbce, eta) + call PressureForce_AFV_bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, eta) else - call PressureForce_AFV_nonbouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm, pbce, eta) + call PressureForce_AFV_nonbouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, eta) endif end subroutine PressureForce_AFV @@ -89,83 +96,86 @@ end subroutine PressureForce_AFV !! the analytic finite volume form of the Pressure gradient, and does not !! make the Boussinesq approximation. !! -!! To work, the following fields must be set outside of the usual -!! ie to ie, je to je range before this subroutine is called: -!! h[ie+1] and h[je+1] and (if tv%eqn_of_state is set) T[ie+1], S[ie+1], -!! T[je+1], and S[je+1]. -subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm, pbce, eta) +!! To work, the following fields must be set outside of the usual (is:ie,js:je) +!! range before this subroutine is called: +!! h(isB:ie+1,jsB:je+1), T(isB:ie+1,jsB:je+1), and S(isB:ie+1,jsB:je+1). +subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, eta) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness (kg/m2) + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness [H ~> kg/m2] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: PFu !< Zonal acceleration (m/s2) - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: PFv !< Meridional acceleration (m/s2) + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: PFu !< Zonal acceleration [m s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: PFv !< Meridional acceleration [m s-2] type(PressureForce_AFV_CS), pointer :: CS !< Finite volume PGF control structure type(ALE_CS), pointer :: ALE_CSp !< ALE control structure real, dimension(:,:), optional, pointer :: p_atm !< The pressure at the ice-ocean - !! or atmosphere-ocean interface in Pa. + !! or atmosphere-ocean interface [Pa]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: pbce !< The baroclinic pressure - !! anomaly in each layer due to eta anomalies, - !! in m2 s-2 H-1. + !! anomaly in each layer due to eta anomalies + !! [m2 s-2 H-1 ~> m s-2 or m4 s-2 kg-1]. real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: eta !< The bottom mass used to - !! calculate PFu and PFv, in H, with any tidal + !! calculate PFu and PFv [H ~> m or kg m-2], with any tidal !! contributions or compressibility compensation. ! Local variables - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: p ! Interface pressure in Pa. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: p ! Interface pressure [Pa]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), target :: & T_tmp, & ! Temporary array of temperatures where layers that are lighter - ! than the mixed layer have the mixed layer's properties, in C. + ! than the mixed layer have the mixed layer's properties [degC]. S_tmp ! Temporary array of salinities where layers that are lighter - ! than the mixed layer have the mixed layer's properties, in psu. + ! than the mixed layer have the mixed layer's properties [ppt]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & - S_t, S_b, T_t, T_b ! Top and bottom edge values for linear reconstructions - ! of salinity and temperature within each layer. + S_t, & ! Top and bottom edge values for linear reconstructions + S_b, & ! of salinity within each layer [ppt]. + T_t, & ! Top and bottom edge values for linear reconstructions + T_b ! of temperature within each layer [degC]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & dza, & ! The change in geopotential anomaly between the top and bottom - ! of a layer, in m2 s-2. + ! of a layer [m2 s-2]. intp_dza ! The vertical integral in depth of the pressure anomaly less - ! the pressure anomaly at the top of the layer, in Pa m2 s-2. + ! the pressure anomaly at the top of the layer [Pa m2 s-2]. real, dimension(SZI_(G),SZJ_(G)) :: & - dp, & ! The (positive) change in pressure across a layer, in Pa. - SSH, & ! The sea surface height anomaly, in m. + dp, & ! The (positive) change in pressure across a layer [Pa]. + SSH, & ! The sea surface height anomaly, in depth units [Z ~> m]. e_tidal, & ! The bottom geopotential anomaly due to tidal forces from - ! astronomical sources and self-attraction and loading, in m. + ! astronomical sources and self-attraction and loading [Z ~> m]. dM, & ! The barotropic adjustment to the Montgomery potential to - ! account for a reduced gravity model, in m2 s-2. + ! account for a reduced gravity model [m2 s-2]. za ! The geopotential anomaly (i.e. g*e + alpha_0*pressure) at the - ! interface atop a layer, in m2 s-2. + ! interface atop a layer [m2 s-2]. real, dimension(SZI_(G)) :: Rho_cv_BL ! The coordinate potential density in the deepest variable - ! density near-surface layer, in kg m-3. + ! density near-surface layer [kg m-3]. real, dimension(SZIB_(G),SZJ_(G)) :: & intx_za ! The zonal integral of the geopotential anomaly along the - ! interface below a layer, divided by the grid spacing, m2 s-2. + ! interface below a layer, divided by the grid spacing [m2 s-2]. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: & - intx_dza ! The change in intx_za through a layer, in m2 s-2. + intx_dza ! The change in intx_za through a layer [m2 s-2]. real, dimension(SZI_(G),SZJB_(G)) :: & inty_za ! The meridional integral of the geopotential anomaly along the - ! interface below a layer, divided by the grid spacing, m2 s-2. + ! interface below a layer, divided by the grid spacing [m2 s-2]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: & - inty_dza ! The change in inty_za through a layer, in m2 s-2. + inty_dza ! The change in inty_za through a layer [m2 s-2]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate - ! density, in Pa (usually 2e7 Pa = 2000 dbar). + ! density, [Pa] (usually 2e7 Pa = 2000 dbar). real :: dp_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected, in Pa. + ! in roundoff and can be neglected [Pa]. + real :: g_Earth_z ! A scaled version of g_Earth [m2 Z-1 s-2 ~> m s-2]. + real :: I_gEarth ! The inverse of g_Earth_z [s2 Z m-2 ~> s2 m-1] real :: alpha_anom ! The in-situ specific volume, averaged over a - ! layer, less alpha_ref, in m3 kg-1. + ! layer, less alpha_ref [m3 kg-1]. logical :: use_p_atm ! If true, use the atmospheric pressure. logical :: use_ALE ! If true, use an ALE pressure reconstruction. logical :: use_EOS ! If true, density is calculated from T & S using an ! equation of state. type(thermo_var_ptrs) :: tv_tmp! A structure of temporary T & S. - real :: alpha_ref ! A reference specific volume, in m3 kg-1, that is used + real :: alpha_ref ! A reference specific volume [m3 kg-1], that is used ! to reduce the impact of truncation errors. - real :: rho_in_situ(SZI_(G)) ! The in situ density, in kg m-3. + real :: rho_in_situ(SZI_(G)) ! The in situ density [kg m-3]. real :: Pa_to_H ! A factor to convert from Pa to the thicknesss units (H). -! real :: oneatm = 101325.0 ! 1 atm in Pa (kg/ms2) - real :: I_gEarth +! real :: oneatm = 101325.0 ! 1 atm in [Pa] = [kg m-1 s-2] real, parameter :: C1_6 = 1.0/6.0 integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb integer :: i, j, k @@ -185,6 +195,8 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm dp_neglect = GV%H_to_Pa * GV%H_subroundoff alpha_ref = 1.0/CS%Rho0 + g_Earth_z = GV%g_Earth + I_gEarth = 1.0 / g_Earth_z if (use_p_atm) then !$OMP parallel do default(shared) @@ -202,8 +214,6 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm p(i,j,K) = p(i,j,K-1) + GV%H_to_Pa * h(i,j,k-1) enddo ; enddo ; enddo - I_gEarth = 1.0 / GV%g_Earth - if (use_EOS) then ! With a bulk mixed layer, replace the T & S of any layers that are ! lighter than the the buffer layer with the properties of the buffer @@ -240,9 +250,9 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm ! of freedeom needed to know the linear profile). if ( use_ALE ) then if ( CS%Recon_Scheme == 1 ) then - call pressure_gradient_plm (ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) + call pressure_gradient_plm(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) elseif ( CS%Recon_Scheme == 2) then - call pressure_gradient_ppm (ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) + call pressure_gradient_ppm(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) endif endif @@ -253,7 +263,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm if (use_EOS) then if ( use_ALE ) then if ( CS%Recon_Scheme == 1 ) then - call int_spec_vol_dp_generic_plm ( T_t(:,:,k), T_b(:,:,k), & + call int_spec_vol_dp_generic_plm( T_t(:,:,k), T_b(:,:,k), & S_t(:,:,k), S_b(:,:,k), p(:,:,K), p(:,:,K+1), & alpha_ref, dp_neglect, p(:,:,nz+1), G%HI, & tv%eqn_of_state, dza(:,:,k), intp_dza(:,:,k), & @@ -302,7 +312,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm !$OMP parallel do default(shared) do j=Jsq,Jeq+1 do i=Isq,Ieq+1 - za(i,j) = alpha_ref*p(i,j,nz+1) - GV%g_Earth*G%bathyT(i,j) + za(i,j) = alpha_ref*p(i,j,nz+1) - g_Earth_z*G%bathyT(i,j) enddo do k=nz,1,-1 ; do i=Isq,Ieq+1 za(i,j) = za(i,j) + dza(i,j,k) @@ -315,10 +325,10 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 SSH(i,j) = (za(i,j) - alpha_ref*p(i,j,1)) * I_gEarth enddo ; enddo - call calc_tidal_forcing(CS%Time, SSH, e_tidal, G, CS%tides_CSp) + call calc_tidal_forcing(CS%Time, SSH, e_tidal, G, CS%tides_CSp, m_to_Z=US%m_to_Z) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - za(i,j) = za(i,j) - GV%g_Earth*e_tidal(i,j) + za(i,j) = za(i,j) - g_Earth_z * e_tidal(i,j) enddo ; enddo endif @@ -402,7 +412,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm enddo if (present(pbce)) then - call set_pbce_nonBouss(p, tv_tmp, G, GV, GV%g_Earth, CS%GFS_scale, pbce) + call set_pbce_nonBouss(p, tv_tmp, G, GV, CS%GFS_scale, pbce) endif if (present(eta)) then @@ -429,76 +439,76 @@ end subroutine PressureForce_AFV_nonBouss !! Determines the acceleration due to hydrostatic pressure forces, using !! the finite volume form of the terms and analytic integrals in depth. !! -!! To work, the following fields must be set outside of the usual -!! ie to ie, je to je range before this subroutine is called: -!! h[ie+1] and h[je+1] and (if tv%eqn_of_state is set) T[ie+1], S[ie+1], -!! T[je+1], and S[je+1]. -subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm, pbce, eta) +!! To work, the following fields must be set outside of the usual (is:ie,js:je) +!! range before this subroutine is called: +!! h(isB:ie+1,jsB:je+1), T(isB:ie+1,jsB:je+1), and S(isB:ie+1,jsB:je+1). +subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, eta) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness (kg/m2) + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: PFu !< Zonal acceleration (m/s2) - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: PFv !< Meridional acceleration (m/s2) + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: PFu !< Zonal acceleration [m s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: PFv !< Meridional acceleration [m s-2] type(PressureForce_AFV_CS), pointer :: CS !< Finite volume PGF control structure type(ALE_CS), pointer :: ALE_CSp !< ALE control structure real, dimension(:,:), optional, pointer :: p_atm !< The pressure at the ice-ocean - !! or atmosphere-ocean interface in Pa. + !! or atmosphere-ocean interface [Pa]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: pbce !< The baroclinic pressure - !! anomaly in each layer due to eta anomalies, - !! in m2 s-2 H-1. + !! anomaly in each layer due to eta anomalies + !! [m2 s-2 H-1 ~> m s-2 or m4 s-2 kg-1]. real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: eta !< The bottom mass used to - !! calculate PFu and PFv, in H, with any tidal - !! contributions or compressibility compensation. + !! calculate PFu and PFv [H ~> m or kg m-2], with any + !! tidal contributions or compressibility compensation. ! Local variables - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: e ! Interface height in m. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: e ! Interface height in depth units [Z ~> m]. real, dimension(SZI_(G),SZJ_(G)) :: & e_tidal, & ! The bottom geopotential anomaly due to tidal forces from - ! astronomical sources and self-attraction and loading, in m. + ! astronomical sources and self-attraction and loading [Z ~> m]. dM ! The barotropic adjustment to the Montgomery potential to - ! account for a reduced gravity model, in m2 s-2. + ! account for a reduced gravity model [m2 s-2]. real, dimension(SZI_(G)) :: & Rho_cv_BL ! The coordinate potential density in the deepest variable - ! density near-surface layer, in kg m-3. + ! density near-surface layer [kg m-3]. real, dimension(SZI_(G),SZJ_(G)) :: & - dz, & ! The change in geopotential thickness through a layer, m2 s-2. + dz, & ! The change in geopotential thickness through a layer [m2 s-2]. pa, & ! The pressure anomaly (i.e. pressure + g*RHO_0*e) at the - ! the interface atop a layer, in Pa. + ! the interface atop a layer [Pa]. dpa, & ! The change in pressure anomaly between the top and bottom - ! of a layer, in Pa. - intz_dpa ! The vertical integral in depth of the pressure anomaly less - ! the pressure anomaly at the top of the layer, in H Pa (m Pa). + ! of a layer [Pa]. + intz_dpa ! The vertical integral in depth of the pressure anomaly less the + ! pressure anomaly at the top of the layer [H Pa ~> m Pa or kg m-2 Pa]. real, dimension(SZIB_(G),SZJ_(G)) :: & intx_pa, & ! The zonal integral of the pressure anomaly along the interface - ! atop a layer, divided by the grid spacing, in Pa. - intx_dpa ! The change in intx_pa through a layer, in Pa. + ! atop a layer, divided by the grid spacing [Pa]. + intx_dpa ! The change in intx_pa through a layer [Pa]. real, dimension(SZI_(G),SZJB_(G)) :: & inty_pa, & ! The meridional integral of the pressure anomaly along the - ! interface atop a layer, divided by the grid spacing, in Pa. - inty_dpa ! The change in inty_pa through a layer, in Pa. + ! interface atop a layer, divided by the grid spacing [Pa]. + inty_dpa ! The change in inty_pa through a layer [Pa]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), target :: & T_tmp, & ! Temporary array of temperatures where layers that are lighter - ! than the mixed layer have the mixed layer's properties, in C. + ! than the mixed layer have the mixed layer's properties [degC]. S_tmp ! Temporary array of salinities where layers that are lighter - ! than the mixed layer have the mixed layer's properties, in psu. + ! than the mixed layer have the mixed layer's properties [ppt]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & S_t, S_b, T_t, T_b ! Top and bottom edge values for linear reconstructions ! of salinity and temperature within each layer. - real :: rho_in_situ(SZI_(G)) ! The in situ density, in kg m-3. + real :: rho_in_situ(SZI_(G)) ! The in situ density [kg m-3]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate - ! density, in Pa (usually 2e7 Pa = 2000 dbar). - real :: p0(SZI_(G)) ! An array of zeros to use for pressure in Pa. + ! density, [Pa] (usually 2e7 Pa = 2000 dbar). + real :: p0(SZI_(G)) ! An array of zeros to use for pressure [Pa]. real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected, in m. - real :: I_Rho0 ! 1/Rho0. - real :: G_Rho0 ! G_Earth / Rho0 in m4 s-2 kg-1. - real :: Rho_ref ! The reference density in kg m-3. - real :: dz_neglect ! A minimal thickness in m, like e. + ! in roundoff and can be neglected [H ~> m]. + real :: g_Earth_z ! A scaled version of g_Earth [m2 Z-1 s-2 ~> m s-2]. + real :: I_Rho0 ! 1/Rho0 [m3 kg-1]. + real :: G_Rho0 ! G_Earth / Rho0 in [m5 Z-1 s-2 kg-1 ~> m4 s-2 kg-1]. + real :: Rho_ref ! The reference density [kg m-3]. + real :: dz_neglect ! A minimal thickness [Z ~> m], like e. logical :: use_p_atm ! If true, use the atmospheric pressure. logical :: use_ALE ! If true, use an ALE pressure reconstruction. - logical :: use_EOS ! If true, density is calculated from T & S using an - ! equation of state. + logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. type(thermo_var_ptrs) :: tv_tmp! A structure of temporary T & S. real, parameter :: C1_6 = 1.0/6.0 @@ -520,9 +530,10 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm, p if (associated(ALE_CSp)) use_ALE = CS%reconstruct .and. use_EOS h_neglect = GV%H_subroundoff - dz_neglect = GV%H_subroundoff * GV%H_to_m + dz_neglect = GV%H_subroundoff * GV%H_to_Z I_Rho0 = 1.0/GV%Rho0 - G_Rho0 = GV%g_Earth/GV%Rho0 + g_Earth_z = GV%g_Earth + G_Rho0 = g_Earth_z/GV%Rho0 rho_ref = CS%Rho0 if (CS%tides) then @@ -533,33 +544,32 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm, p !$OMP parallel do default(shared) do j=Jsq,Jeq+1 do i=Isq,Ieq+1 - e(i,j,1) = -1.0*G%bathyT(i,j) + e(i,j,1) = -G%bathyT(i,j) enddo do k=1,nz ; do i=Isq,Ieq+1 - e(i,j,1) = e(i,j,1) + h(i,j,k)*GV%H_to_m + e(i,j,1) = e(i,j,1) + h(i,j,k)*GV%H_to_Z enddo ; enddo enddo - call calc_tidal_forcing(CS%Time, e(:,:,1), e_tidal, G, CS%tides_CSp) + call calc_tidal_forcing(CS%Time, e(:,:,1), e_tidal, G, CS%tides_CSp, m_to_Z=US%m_to_Z) endif ! Here layer interface heights, e, are calculated. if (CS%tides) then !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - e(i,j,nz+1) = -1.0*G%bathyT(i,j) - e_tidal(i,j) + e(i,j,nz+1) = -(G%bathyT(i,j) + e_tidal(i,j)) enddo ; enddo else !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - e(i,j,nz+1) = -1.0*G%bathyT(i,j) + e(i,j,nz+1) = -G%bathyT(i,j) enddo ; enddo endif !$OMP parallel do default(shared) do j=Jsq,Jeq+1; do k=nz,1,-1 ; do i=Isq,Ieq+1 - e(i,j,K) = e(i,j,K+1) + h(i,j,k)*GV%H_to_m + e(i,j,K) = e(i,j,K+1) + h(i,j,k)*GV%H_to_Z enddo ; enddo ; enddo - if (use_EOS) then ! With a bulk mixed layer, replace the T & S of any layers that are ! lighter than the the buffer layer with the properties of the buffer @@ -636,12 +646,12 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm, p if (use_p_atm) then !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - pa(i,j) = (rho_ref*GV%g_Earth)*e(i,j,1) + p_atm(i,j) + pa(i,j) = (rho_ref*g_Earth_z)*e(i,j,1) + p_atm(i,j) enddo ; enddo else !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - pa(i,j) = (rho_ref*GV%g_Earth)*e(i,j,1) + pa(i,j) = (rho_ref*g_Earth_z)*e(i,j,1) enddo ; enddo endif !$OMP parallel do default(shared) @@ -665,34 +675,33 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm, p ! where the layers are located. if ( use_ALE ) then if ( CS%Recon_Scheme == 1 ) then - call int_density_dz_generic_plm ( T_t(:,:,k), T_b(:,:,k), & + call int_density_dz_generic_plm( T_t(:,:,k), T_b(:,:,k), & S_t(:,:,k), S_b(:,:,k), e(:,:,K), e(:,:,K+1), & - rho_ref, CS%Rho0, GV%g_Earth, & + rho_ref, CS%Rho0, g_Earth_z, & dz_neglect, G%bathyT, G%HI, G%HI, & tv%eqn_of_state, dpa, intz_dpa, intx_dpa, inty_dpa, & useMassWghtInterp = CS%useMassWghtInterp) elseif ( CS%Recon_Scheme == 2 ) then - call int_density_dz_generic_ppm ( tv%T(:,:,k), T_t(:,:,k), T_b(:,:,k), & + call int_density_dz_generic_ppm( tv%T(:,:,k), T_t(:,:,k), T_b(:,:,k), & tv%S(:,:,k), S_t(:,:,k), S_b(:,:,k), e(:,:,K), e(:,:,K+1), & - rho_ref, CS%Rho0, GV%g_Earth, & - G%HI, G%HI, tv%eqn_of_state, dpa, intz_dpa, & + rho_ref, CS%Rho0, g_Earth_z, & + G%HI, G%HI, tv%eqn_of_state, dpa, intz_dpa, & intx_dpa, inty_dpa) endif else - call int_density_dz(tv_tmp%T(:,:,k), tv_tmp%S(:,:,k), & - e(:,:,K), e(:,:,K+1), & - rho_ref, CS%Rho0, GV%g_Earth, G%HI, G%HI, tv%eqn_of_state, & + call int_density_dz(tv_tmp%T(:,:,k), tv_tmp%S(:,:,k), e(:,:,K), e(:,:,K+1), & + rho_ref, CS%Rho0, g_Earth_z, G%HI, G%HI, tv%eqn_of_state, & dpa, intz_dpa, intx_dpa, inty_dpa, & G%bathyT, dz_neglect, CS%useMassWghtInterp) endif !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - intz_dpa(i,j) = intz_dpa(i,j)*GV%m_to_H + intz_dpa(i,j) = intz_dpa(i,j)*GV%Z_to_H enddo ; enddo else !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - dz(i,j) = GV%g_Earth*GV%H_to_m*h(i,j,k) + dz(i,j) = g_Earth_z * GV%H_to_Z*h(i,j,k) dpa(i,j) = (GV%Rlay(k) - rho_ref)*dz(i,j) intz_dpa(i,j) = 0.5*(GV%Rlay(k) - rho_ref)*dz(i,j)*h(i,j,k) enddo ; enddo @@ -712,7 +721,7 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm, p PFu(I,j,k) = (((pa(i,j)*h(i,j,k) + intz_dpa(i,j)) - & (pa(i+1,j)*h(i+1,j,k) + intz_dpa(i+1,j))) + & ((h(i+1,j,k) - h(i,j,k)) * intx_pa(I,j) - & - (e(i+1,j,K+1) - e(i,j,K+1)) * intx_dpa(I,j) * GV%m_to_H)) * & + (e(i+1,j,K+1) - e(i,j,K+1)) * intx_dpa(I,j) * GV%Z_to_H)) * & ((2.0*I_Rho0*G%IdxCu(I,j)) / & ((h(i,j,k) + h(i+1,j,k)) + h_neglect)) intx_pa(I,j) = intx_pa(I,j) + intx_dpa(I,j) @@ -723,7 +732,7 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm, p PFv(i,J,k) = (((pa(i,j)*h(i,j,k) + intz_dpa(i,j)) - & (pa(i,j+1)*h(i,j+1,k) + intz_dpa(i,j+1))) + & ((h(i,j+1,k) - h(i,j,k)) * inty_pa(i,J) - & - (e(i,j+1,K+1) - e(i,j,K+1)) * inty_dpa(i,J) * GV%m_to_H)) * & + (e(i,j+1,K+1) - e(i,j,K+1)) * inty_dpa(i,J) * GV%Z_to_H)) * & ((2.0*I_Rho0*G%IdyCv(i,J)) / & ((h(i,j,k) + h(i,j+1,k)) + h_neglect)) inty_pa(i,J) = inty_pa(i,J) + inty_dpa(i,J) @@ -748,7 +757,7 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm, p endif if (present(pbce)) then - call set_pbce_Bouss(e, tv_tmp, G, GV, GV%g_Earth, CS%Rho0, CS%GFS_scale, pbce) + call set_pbce_Bouss(e, tv_tmp, G, GV, CS%Rho0, CS%GFS_scale, pbce) endif if (present(eta)) then @@ -758,12 +767,12 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm, p ! about 200 lines above. !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta(i,j) = e(i,j,1)*GV%m_to_H + e_tidal(i,j)*GV%m_to_H + eta(i,j) = e(i,j,1)*GV%Z_to_H + e_tidal(i,j)*GV%Z_to_H enddo ; enddo else !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta(i,j) = e(i,j,1)*GV%m_to_H + eta(i,j) = e(i,j,1)*GV%Z_to_H enddo ; enddo endif endif @@ -773,10 +782,11 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm, p end subroutine PressureForce_AFV_Bouss !> Initializes the finite volume pressure gradient control structure -subroutine PressureForce_AFV_init(Time, G, GV, param_file, diag, CS, tides_CSp) +subroutine PressureForce_AFV_init(Time, G, GV, US, param_file, diag, CS, tides_CSp) type(time_type), target, intent(in) :: Time !< Current model time type(ocean_grid_type), intent(in) :: G !< Ocean 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 !< Parameter file handles type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure type(PressureForce_AFV_CS), pointer :: CS !< Finite volume PGF control structure @@ -834,7 +844,7 @@ subroutine PressureForce_AFV_init(Time, G, GV, param_file, diag, CS, tides_CSp) if (CS%tides) then CS%id_e_tidal = register_diag_field('ocean_model', 'e_tidal', diag%axesT1, & - Time, 'Tidal Forcing Astronomical and SAL Height Anomaly', 'meter') + Time, 'Tidal Forcing Astronomical and SAL Height Anomaly', 'meter', conversion=US%Z_to_m) endif CS%GFS_scale = 1.0 @@ -846,7 +856,8 @@ end subroutine PressureForce_AFV_init !> Deallocates the finite volume pressure gradient control structure subroutine PressureForce_AFV_end(CS) - type(PressureForce_AFV_CS), pointer :: CS + type(PressureForce_AFV_CS), pointer :: CS !< Finite volume pressure control structure that + !! will be deallocated in this subroutine. if (associated(CS)) deallocate(CS) end subroutine PressureForce_AFV_end diff --git a/src/core/MOM_PressureForce_blocked_AFV.F90 b/src/core/MOM_PressureForce_blocked_AFV.F90 index 563972fcc5..a675eebaf4 100644 --- a/src/core/MOM_PressureForce_blocked_AFV.F90 +++ b/src/core/MOM_PressureForce_blocked_AFV.F90 @@ -10,6 +10,7 @@ module MOM_PressureForce_blk_AFV use MOM_grid, only : ocean_grid_type use MOM_PressureForce_Mont, only : set_pbce_Bouss, set_pbce_nonBouss use MOM_tidal_forcing, only : calc_tidal_forcing, tidal_forcing_CS +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use MOM_EOS, only : calculate_density, calculate_density_derivs @@ -26,13 +27,18 @@ module MOM_PressureForce_blk_AFV public PressureForce_blk_AFV, PressureForce_blk_AFV_init, PressureForce_blk_AFV_end public PressureForce_blk_AFV_Bouss, PressureForce_blk_AFV_nonBouss +! 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. + !> Finite volume pressure gradient control structure type, public :: PressureForce_blk_AFV_CS ; private logical :: tides !< If true, apply tidal momentum forcing. real :: Rho0 !< The density used in the Boussinesq - !! approximation, in kg m-3. + !! approximation [kg m-3]. real :: GFS_scale !< A scaling of the surface pressure gradients to - !! allow the use of a reduced gravity model. + !! allow the use of a reduced gravity model [nondim]. type(time_type), pointer :: Time !< A pointer to the ocean model's clock. type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the !! timing of diagnostic output. @@ -57,28 +63,29 @@ module MOM_PressureForce_blk_AFV !> Thin interface between the model and the Boussinesq and non-Boussinesq !! pressure force routines. -subroutine PressureForce_blk_AFV(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm, pbce, eta) +subroutine PressureForce_blk_AFV(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, eta) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness (m or kg/m2) + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamic variables - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: PFu !< Zonal acceleration (m/s2) - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: PFv !< Meridional acceleration (m/s2) + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: PFu !< Zonal acceleration [m s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: PFv !< Meridional acceleration [m s-2] type(PressureForce_blk_AFV_CS), pointer :: CS !< Finite volume PGF control structure type(ALE_CS), pointer :: ALE_CSp !< ALE control structure real, dimension(:,:), optional, pointer :: p_atm !< The pressure at the ice-ocean - !! or atmosphere-ocean interface in Pa. + !! or atmosphere-ocean interface [Pa]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: pbce !< The baroclinic pressure - !! anomaly in each layer due to eta anomalies, - !! in m2 s-2 H-1. + !! anomaly in each layer due to eta anomalies + !! [m2 s-2 H-1 ~> m s-2 or m4 s-2 kg-1]. real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: eta !< The bottom mass used to - !! calculate PFu and PFv, in H, with any tidal + !! calculate PFu and PFv [H ~> m or kg m-2], with any tidal !! contributions or compressibility compensation. if (GV%Boussinesq) then - call PressureForce_blk_AFV_bouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm, pbce, eta) + call PressureForce_blk_AFV_bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, eta) else - call PressureForce_blk_AFV_nonbouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbce, eta) + call PressureForce_blk_AFV_nonbouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, eta) endif end subroutine PressureForce_blk_AFV @@ -89,82 +96,83 @@ end subroutine PressureForce_blk_AFV !! analytic finite volume form of the Pressure gradient, and does not make the !! Boussinesq approximation. This version uses code-blocking for threads. !! -!! To work, the following fields must be set outside of the usual -!! ie to ie, je to je range before this subroutine is called: -!! h[ie+1] and h[je+1] and (if tv%eqn_of_state is set) T[ie+1], S[ie+1], -!! T[je+1], and S[je+1]. -subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbce, eta) +!! To work, the following fields must be set outside of the usual (is:ie,js:je) +!! range before this subroutine is called: +!! h(isB:ie+1,jsB:je+1), T(isB:ie+1,jsB:je+1), and S(isB:ie+1,jsB:je+1). +subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, eta) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness (kg/m2) + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness [H ~> kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: PFu !< Zonal acceleration (m/s2) - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: PFv !< Meridional acceleration (m/s2) + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: PFu !< Zonal acceleration [m s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: PFv !< Meridional acceleration [m s-2] type(PressureForce_blk_AFV_CS), pointer :: CS !< Finite volume PGF control structure real, dimension(:,:), optional, pointer :: p_atm !< The pressure at the ice-ocean - !! or atmosphere-ocean interface in Pa. + !! or atmosphere-ocean interface [Pa]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: pbce !< The baroclinic pressure - !! anomaly in each layer due to eta anomalies, - !! in m2 s-2 H-1. + !! anomaly in each layer due to eta anomalies + !! [m2 s-2 H-1 ~> m s-2 or m4 s-2 kg-1]. real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: eta !< The bottom mass used to - !! calculate PFu and PFv, in H, with any tidal + !! calculate PFu and PFv [H ~> m or kg m-2], with any tidal !! contributions or compressibility compensation. ! Local variables - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: p ! Interface pressure in Pa. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: p ! Interface pressure [Pa]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), target :: & T_tmp, & ! Temporary array of temperatures where layers that are lighter - ! than the mixed layer have the mixed layer's properties, in C. + ! than the mixed layer have the mixed layer's properties [degC]. S_tmp ! Temporary array of salinities where layers that are lighter - ! than the mixed layer have the mixed layer's properties, in psu. + ! than the mixed layer have the mixed layer's properties [ppt]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & dza, & ! The change in geopotential anomaly between the top and bottom - ! of a layer, in m2 s-2. + ! of a layer [m2 s-2]. intp_dza ! The vertical integral in depth of the pressure anomaly less - ! the pressure anomaly at the top of the layer, in Pa m2 s-2. + ! the pressure anomaly at the top of the layer [Pa m2 s-2]. real, dimension(SZI_(G),SZJ_(G)) :: & - dp, & ! The (positive) change in pressure across a layer, in Pa. - SSH, & ! The sea surface height anomaly, in m. + dp, & ! The (positive) change in pressure across a layer [Pa]. + SSH, & ! The sea surface height anomaly, in depth units [Z ~> m]. e_tidal, & ! The bottom geopotential anomaly due to tidal forces from - ! astronomical sources and self-attraction and loading, in m. + ! astronomical sources and self-attraction and loading [Z ~> m]. dM, & ! The barotropic adjustment to the Montgomery potential to - ! account for a reduced gravity model, in m2 s-2. + ! account for a reduced gravity model [m2 s-2]. za ! The geopotential anomaly (i.e. g*e + alpha_0*pressure) at the - ! interface atop a layer, in m2 s-2. + ! interface atop a layer [m2 s-2]. real, dimension(SZDI_(G%Block(1)),SZDJ_(G%Block(1))) :: & ! on block indices - dp_bk, & ! The (positive) change in pressure across a layer, in Pa. + dp_bk, & ! The (positive) change in pressure across a layer [Pa]. za_bk ! The geopotential anomaly (i.e. g*e + alpha_0*pressure) at the - ! interface atop a layer, in m2 s-2. + ! interface atop a layer [m2 s-2]. real, dimension(SZI_(G)) :: Rho_cv_BL ! The coordinate potential density in the deepest variable - ! density near-surface layer, in kg m-3. + ! density near-surface layer [kg m-3]. real, dimension(SZDIB_(G%Block(1)),SZDJ_(G%Block(1))) :: & ! on block indices intx_za_bk ! The zonal integral of the geopotential anomaly along the - ! interface below a layer, divided by the grid spacing, m2 s-2. + ! interface below a layer, divided by the grid spacing [m2 s-2]. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: & - intx_dza ! The change in intx_za through a layer, in m2 s-2. + intx_dza ! The change in intx_za through a layer [m2 s-2]. real, dimension(SZDI_(G%Block(1)),SZDJB_(G%Block(1))) :: & ! on block indices inty_za_bk ! The meridional integral of the geopotential anomaly along the - ! interface below a layer, divided by the grid spacing, m2 s-2. + ! interface below a layer, divided by the grid spacing [m2 s-2]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: & - inty_dza ! The change in inty_za through a layer, in m2 s-2. - real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate - ! density, in Pa (usually 2e7 Pa = 2000 dbar). - - real :: dp_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected, in Pa. - real :: alpha_anom ! The in-situ specific volume, averaged over a - ! layer, less alpha_ref, in m3 kg-1. - logical :: use_p_atm ! If true, use the atmospheric pressure. + inty_dza ! The change in inty_za through a layer [m2 s-2]. + real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate + ! density [Pa] (usually 2e7 Pa = 2000 dbar). + + real :: dp_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [Pa]. + real :: g_Earth_z ! A scaled version of g_Earth [m2 Z-1 s-2 ~> m s-2]. + real :: I_gEarth ! The inverse of g_Earth_z [s2 Z m-2 ~> s2 m-1] + real :: alpha_anom ! The in-situ specific volume, averaged over a + ! layer, less alpha_ref [m3 kg-1]. + logical :: use_p_atm ! If true, use the atmospheric pressure. logical :: use_EOS ! If true, density is calculated from T & S using an ! equation of state. type(thermo_var_ptrs) :: tv_tmp! A structure of temporary T & S. - real :: alpha_ref ! A reference specific volume, in m3 kg-1, that is used + real :: alpha_ref ! A reference specific volume [m3 kg-1], that is used ! to reduce the impact of truncation errors. - real :: rho_in_situ(SZI_(G)) ! The in situ density, in kg m-3. + real :: rho_in_situ(SZI_(G)) ! The in situ density [kg m-3]. real :: Pa_to_H ! A factor to convert from Pa to the thicknesss units (H). -! real :: oneatm = 101325.0 ! 1 atm in Pa (kg/ms2) - real :: I_gEarth +! real :: oneatm = 101325.0 ! 1 atm in [Pa] = [kg m-1 s-2] real, parameter :: C1_6 = 1.0/6.0 integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb integer :: is_bk, ie_bk, js_bk, je_bk, Isq_bk, Ieq_bk, Jsq_bk, Jeq_bk @@ -183,6 +191,8 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbc dp_neglect = GV%H_to_Pa * GV%H_subroundoff alpha_ref = 1.0/CS%Rho0 + g_Earth_z = GV%g_Earth + I_gEarth = 1.0 / g_Earth_z if (use_p_atm) then !$OMP parallel do default(shared) @@ -200,8 +210,6 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbc p(i,j,K) = p(i,j,K-1) + GV%H_to_Pa * h(i,j,k-1) enddo ; enddo ; enddo - I_gEarth = 1.0 / GV%g_Earth - if (use_EOS) then ! With a bulk mixed layer, replace the T & S of any layers that are ! lighter than the the buffer layer with the properties of the buffer @@ -269,7 +277,7 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbc !$OMP parallel do default(shared) do j=Jsq,Jeq+1 do i=Isq,Ieq+1 - za(i,j) = alpha_ref*p(i,j,nz+1) - GV%g_Earth*G%bathyT(i,j) + za(i,j) = alpha_ref*p(i,j,nz+1) - g_Earth_z*G%bathyT(i,j) enddo do k=nz,1,-1 ; do i=Isq,Ieq+1 za(i,j) = za(i,j) + dza(i,j,k) @@ -282,10 +290,10 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbc do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 SSH(i,j) = (za(i,j) - alpha_ref*p(i,j,1)) * I_gEarth enddo ; enddo - call calc_tidal_forcing(CS%Time, SSH, e_tidal, G, CS%tides_CSp) + call calc_tidal_forcing(CS%Time, SSH, e_tidal, G, CS%tides_CSp, m_to_Z=US%m_to_Z) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - za(i,j) = za(i,j) - GV%g_Earth*e_tidal(i,j) + za(i,j) = za(i,j) - g_Earth_z * e_tidal(i,j) enddo ; enddo endif @@ -384,7 +392,7 @@ subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbc enddo if (present(pbce)) then - call set_pbce_nonBouss(p, tv_tmp, G, GV, GV%g_Earth, CS%GFS_scale, pbce) + call set_pbce_nonBouss(p, tv_tmp, G, GV, CS%GFS_scale, pbce) endif if (present(eta)) then @@ -412,74 +420,75 @@ end subroutine PressureForce_blk_AFV_nonBouss !! the finite volume form of the terms and analytic integrals in depth, making !! the Boussinesq approximation. This version uses code-blocking for threads. !! -!! To work, the following fields must be set outside of the usual -!! ie to ie, je to je range before this subroutine is called: -!! h[ie+1] and h[je+1] and (if tv%eqn_of_state is set) T[ie+1], S[ie+1], -!! T[je+1], and S[je+1]. -subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm, pbce, eta) +!! To work, the following fields must be set outside of the usual (is:ie,js:je) +!! range before this subroutine is called: +!! h(isB:ie+1,jsB:je+1), T(isB:ie+1,jsB:je+1), and S(isB:ie+1,jsB:je+1). +subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, eta) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness (kg/m2) + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + 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 !< Thermodynamic variables - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: PFu !< Zonal acceleration (m/s2) - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: PFv !< Meridional acceleration (m/s2) - type(PressureForce_blk_AFV_CS), pointer :: CS !< Finite volume PGF control structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: PFu !< Zonal acceleration [m s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: PFv !< Meridional acceleration [m s-2] + type(PressureForce_blk_AFV_CS), pointer :: CS !< Finite volume PGF control structure type(ALE_CS), pointer :: ALE_CSp !< ALE control structure real, dimension(:,:), optional, pointer :: p_atm !< The pressure at the ice-ocean - !! or atmosphere-ocean interface in Pa. + !! or atmosphere-ocean interface [Pa]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: pbce !< The baroclinic pressure - !! anomaly in each layer due to eta anomalies, - !! in m2 s-2 H-1. + !! anomaly in each layer due to eta anomalies + !! [m2 s-2 H-1 ~> m s-2 or m4 s-2 kg-1]. real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: eta !< The bottom mass used to - !! calculate PFu and PFv, in H, with any tidal + !! calculate PFu and PFv [H ~> m or kg m-2], with any tidal !! contributions or compressibility compensation. ! Local variables - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: e ! Interface height in m. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: e ! Interface height in depth units [Z ~> m]. real, dimension(SZI_(G),SZJ_(G)) :: & e_tidal, & ! The bottom geopotential anomaly due to tidal forces from - ! astronomical sources and self-attraction and loading, in m. + ! astronomical sources and self-attraction and loading, in depth units [Z ~> m]. dM ! The barotropic adjustment to the Montgomery potential to - ! account for a reduced gravity model, in m2 s-2. + ! account for a reduced gravity model [m2 s-2]. real, dimension(SZI_(G)) :: & Rho_cv_BL ! The coordinate potential density in the deepest variable - ! density near-surface layer, in kg m-3. + ! density near-surface layer [kg m-3]. real, dimension(SZDI_(G%Block(1)),SZDJ_(G%Block(1))) :: & ! on block indices - dz_bk, & ! The change in geopotential thickness through a layer, m2 s-2. + dz_bk, & ! The change in geopotential thickness through a layer [m2 s-2]. pa_bk, & ! The pressure anomaly (i.e. pressure + g*RHO_0*e) at the - ! the interface atop a layer, in Pa. + ! the interface atop a layer [Pa]. dpa_bk, & ! The change in pressure anomaly between the top and bottom - ! of a layer, in Pa. - intz_dpa_bk ! The vertical integral in depth of the pressure anomaly less - ! the pressure anomaly at the top of the layer, in H Pa (m Pa). + ! of a layer [Pa]. + intz_dpa_bk ! The vertical integral in depth of the pressure anomaly less the + ! pressure anomaly at the top of the layer [H Pa ~> m Pa or kg m-2 Pa]. real, dimension(SZDIB_(G%Block(1)),SZDJ_(G%Block(1))) :: & ! on block indices intx_pa_bk, & ! The zonal integral of the pressure anomaly along the interface - ! atop a layer, divided by the grid spacing, in Pa. - intx_dpa_bk ! The change in intx_pa through a layer, in Pa. + ! atop a layer, divided by the grid spacing [Pa]. + intx_dpa_bk ! The change in intx_pa through a layer [Pa]. real, dimension(SZDI_(G%Block(1)),SZDJB_(G%Block(1))) :: & ! on block indices inty_pa_bk, & ! The meridional integral of the pressure anomaly along the - ! interface atop a layer, divided by the grid spacing, in Pa. - inty_dpa_bk ! The change in inty_pa through a layer, in Pa. + ! interface atop a layer, divided by the grid spacing [Pa]. + inty_dpa_bk ! The change in inty_pa through a layer [Pa]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), target :: & T_tmp, & ! Temporary array of temperatures where layers that are lighter - ! than the mixed layer have the mixed layer's properties, in C. + ! than the mixed layer have the mixed layer's properties [degC]. S_tmp ! Temporary array of salinities where layers that are lighter - ! than the mixed layer have the mixed layer's properties, in psu. + ! than the mixed layer have the mixed layer's properties [ppt]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & - S_t, S_b, T_t, T_b ! Top and bottom edge values for linear reconstructions - ! of salinity and temperature within each layer. - real :: rho_in_situ(SZI_(G)) ! The in situ density, in kg m-3. - real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate - ! density, in Pa (usually 2e7 Pa = 2000 dbar). - real :: p0(SZI_(G)) ! An array of zeros to use for pressure in Pa. - real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected, in m. - real :: I_Rho0 ! 1/Rho0. - real :: G_Rho0 ! G_Earth / Rho0 in m4 s-2 kg-1. - real :: Rho_ref ! The reference density in kg m-3. - real :: dz_neglect ! A minimal thickness in m, like e. - logical :: use_p_atm ! If true, use the atmospheric pressure. - logical :: use_ALE ! If true, use an ALE pressure reconstruction. + S_t, S_b, & ! Top and bottom edge salinities for linear reconstructions within each layer [ppt]. + T_t, T_b ! Top and bottom edge temperatures for linear reconstructions within each layer [degC]. + real :: rho_in_situ(SZI_(G)) ! The in situ density [kg m-3]. + real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate + ! density [Pa] (usually 2e7 Pa = 2000 dbar). + real :: p0(SZI_(G)) ! An array of zeros to use for pressure [Pa]. + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: I_Rho0 ! 1/Rho0 [m3 kg-1]. + real :: g_Earth_z ! A scaled version of g_Earth [m2 Z-1 s-2 ~> m s-2]. + real :: G_Rho0 ! G_Earth / Rho0 [m5 Z-1 s-2 kg-1 ~> m4 s-2 kg-1]. + real :: Rho_ref ! The reference density [kg m-3]. + real :: dz_neglect ! A minimal thickness [Z ~> m], like e. + logical :: use_p_atm ! If true, use the atmospheric pressure. + logical :: use_ALE ! If true, use an ALE pressure reconstruction. logical :: use_EOS ! If true, density is calculated from T & S using an ! equation of state. type(thermo_var_ptrs) :: tv_tmp! A structure of temporary T & S. @@ -505,9 +514,10 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_at if (associated(ALE_CSp)) use_ALE = CS%reconstruct .and. use_EOS h_neglect = GV%H_subroundoff - dz_neglect = GV%H_subroundoff * GV%H_to_m + dz_neglect = GV%H_subroundoff * GV%H_to_Z I_Rho0 = 1.0/GV%Rho0 - G_Rho0 = GV%g_Earth/GV%Rho0 + g_Earth_z = GV%g_Earth + G_Rho0 = g_Earth_z / GV%Rho0 rho_ref = CS%Rho0 if (CS%tides) then @@ -518,33 +528,32 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_at !$OMP parallel do default(shared) do j=Jsq,Jeq+1 do i=Isq,Ieq+1 - e(i,j,1) = -1.0*G%bathyT(i,j) + e(i,j,1) = -G%bathyT(i,j) enddo do k=1,nz ; do i=Isq,Ieq+1 - e(i,j,1) = e(i,j,1) + h(i,j,k)*GV%H_to_m + e(i,j,1) = e(i,j,1) + h(i,j,k)*GV%H_to_Z enddo ; enddo enddo - call calc_tidal_forcing(CS%Time, e(:,:,1), e_tidal, G, CS%tides_CSp) + call calc_tidal_forcing(CS%Time, e(:,:,1), e_tidal, G, CS%tides_CSp, m_to_Z=US%m_to_Z) endif ! Here layer interface heights, e, are calculated. if (CS%tides) then !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - e(i,j,nz+1) = -1.0*G%bathyT(i,j) - e_tidal(i,j) + e(i,j,nz+1) = -(G%bathyT(i,j) + e_tidal(i,j)) enddo ; enddo else !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - e(i,j,nz+1) = -1.0*G%bathyT(i,j) + e(i,j,nz+1) = -G%bathyT(i,j) enddo ; enddo endif !$OMP parallel do default(shared) do j=Jsq,Jeq+1; do k=nz,1,-1 ; do i=Isq,Ieq+1 - e(i,j,K) = e(i,j,K+1) + h(i,j,k)*GV%H_to_m + e(i,j,K) = e(i,j,K+1) + h(i,j,k)*GV%H_to_Z enddo ; enddo ; enddo - if (use_EOS) then ! With a bulk mixed layer, replace the T & S of any layers that are ! lighter than the the buffer layer with the properties of the buffer @@ -616,7 +625,7 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_at endif !$OMP parallel do default(none) shared(use_p_atm,rho_ref,G,GV,e,p_atm,nz,use_EOS,& -!$OMP use_ALE,T_t,T_b,S_t,S_b,CS,tv,tv_tmp, & +!$OMP use_ALE,T_t,T_b,S_t,S_b,CS,tv,tv_tmp,g_Earth_z, & !$OMP h,PFu,I_Rho0,h_neglect,dz_neglect,PFv,dM)& !$OMP private(is_bk,ie_bk,js_bk,je_bk,Isq_bk,Ieq_bk,Jsq_bk, & !$OMP Jeq_bk,ioff_bk,joff_bk,pa_bk, & @@ -636,12 +645,12 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_at if (use_p_atm) then do jb=Jsq_bk,Jeq_bk+1 ; do ib=Isq_bk,Ieq_bk+1 i = ib+ioff_bk ; j = jb+joff_bk - pa_bk(ib,jb) = (rho_ref*GV%g_Earth)*e(i,j,1) + p_atm(i,j) + pa_bk(ib,jb) = (rho_ref*g_Earth_z)*e(i,j,1) + p_atm(i,j) enddo ; enddo else do jb=Jsq_bk,Jeq_bk+1 ; do ib=Isq_bk,Ieq_bk+1 i = ib+ioff_bk ; j = jb+joff_bk - pa_bk(ib,jb) = (rho_ref*GV%g_Earth)*e(i,j,1) + pa_bk(ib,jb) = (rho_ref*g_Earth_z)*e(i,j,1) enddo ; enddo endif do jb=js_bk,je_bk ; do Ib=Isq_bk,Ieq_bk @@ -663,33 +672,32 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_at ! where the layers are located. if ( use_ALE ) then if ( CS%Recon_Scheme == 1 ) then - call int_density_dz_generic_plm ( T_t(:,:,k), T_b(:,:,k), & + call int_density_dz_generic_plm( T_t(:,:,k), T_b(:,:,k), & S_t(:,:,k), S_b(:,:,k), e(:,:,K), e(:,:,K+1), & - rho_ref, CS%Rho0, GV%g_Earth, & + rho_ref, CS%Rho0, g_Earth_z, & dz_neglect, G%bathyT, G%HI, G%Block(n), & tv%eqn_of_state, dpa_bk, intz_dpa_bk, intx_dpa_bk, inty_dpa_bk, & useMassWghtInterp = CS%useMassWghtInterp) elseif ( CS%Recon_Scheme == 2 ) then - call int_density_dz_generic_ppm ( tv%T(:,:,k), T_t(:,:,k), T_b(:,:,k), & + call int_density_dz_generic_ppm( tv%T(:,:,k), T_t(:,:,k), T_b(:,:,k), & tv%S(:,:,k), S_t(:,:,k), S_b(:,:,k), e(:,:,K), e(:,:,K+1), & - rho_ref, CS%Rho0, GV%g_Earth, & + rho_ref, CS%Rho0, g_Earth_z, & G%HI, G%Block(n), tv%eqn_of_state, dpa_bk, intz_dpa_bk, & intx_dpa_bk, inty_dpa_bk) endif else - call int_density_dz(tv_tmp%T(:,:,k), tv_tmp%S(:,:,k), & - e(:,:,K), e(:,:,K+1), & - rho_ref, CS%Rho0, GV%g_Earth, G%HI, G%Block(n), tv%eqn_of_state, & + call int_density_dz(tv_tmp%T(:,:,k), tv_tmp%S(:,:,k), e(:,:,K), e(:,:,K+1), & + rho_ref, CS%Rho0, g_Earth_z, G%HI, G%Block(n), tv%eqn_of_state, & dpa_bk, intz_dpa_bk, intx_dpa_bk, inty_dpa_bk, & G%bathyT, dz_neglect, CS%useMassWghtInterp) endif do jb=Jsq_bk,Jeq_bk+1 ; do ib=Isq_bk,Ieq_bk+1 - intz_dpa_bk(ib,jb) = intz_dpa_bk(ib,jb)*GV%m_to_H + intz_dpa_bk(ib,jb) = intz_dpa_bk(ib,jb)*GV%Z_to_H enddo ; enddo else do jb=Jsq_bk,Jeq_bk+1 ; do ib=Isq_bk,Ieq_bk+1 i = ib+ioff_bk ; j = jb+joff_bk - dz_bk(ib,jb) = GV%g_Earth*GV%H_to_m*h(i,j,k) + dz_bk(ib,jb) = g_Earth_z*GV%H_to_Z*h(i,j,k) dpa_bk(ib,jb) = (GV%Rlay(k) - rho_ref)*dz_bk(ib,jb) intz_dpa_bk(ib,jb) = 0.5*(GV%Rlay(k) - rho_ref)*dz_bk(ib,jb)*h(i,j,k) enddo ; enddo @@ -707,7 +715,7 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_at PFu(I,j,k) = (((pa_bk(ib,jb)*h(i,j,k) + intz_dpa_bk(ib,jb)) - & (pa_bk(ib+1,jb)*h(i+1,j,k) + intz_dpa_bk(ib+1,jb))) + & ((h(i+1,j,k) - h(i,j,k)) * intx_pa_bk(Ib,jb) - & - (e(i+1,j,K+1) - e(i,j,K+1)) * intx_dpa_bk(Ib,jb) * GV%m_to_H)) * & + (e(i+1,j,K+1) - e(i,j,K+1)) * intx_dpa_bk(Ib,jb) * GV%Z_to_H)) * & ((2.0*I_Rho0*G%IdxCu(I,j)) / & ((h(i,j,k) + h(i+1,j,k)) + h_neglect)) intx_pa_bk(Ib,jb) = intx_pa_bk(Ib,jb) + intx_dpa_bk(Ib,jb) @@ -718,7 +726,7 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_at PFv(i,J,k) = (((pa_bk(ib,jb)*h(i,j,k) + intz_dpa_bk(ib,jb)) - & (pa_bk(ib,jb+1)*h(i,j+1,k) + intz_dpa_bk(ib,jb+1))) + & ((h(i,j+1,k) - h(i,j,k)) * inty_pa_bk(ib,Jb) - & - (e(i,j+1,K+1) - e(i,j,K+1)) * inty_dpa_bk(ib,Jb) * GV%m_to_H)) * & + (e(i,j+1,K+1) - e(i,j,K+1)) * inty_dpa_bk(ib,Jb) * GV%Z_to_H)) * & ((2.0*I_Rho0*G%IdyCv(i,J)) / & ((h(i,j,k) + h(i,j+1,k)) + h_neglect)) inty_pa_bk(ib,Jb) = inty_pa_bk(ib,Jb) + inty_dpa_bk(ib,Jb) @@ -741,7 +749,7 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_at enddo if (present(pbce)) then - call set_pbce_Bouss(e, tv_tmp, G, GV, GV%g_Earth, CS%Rho0, CS%GFS_scale, pbce) + call set_pbce_Bouss(e, tv_tmp, G, GV, CS%Rho0, CS%GFS_scale, pbce) endif if (present(eta)) then @@ -751,12 +759,12 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_at ! about 200 lines above. !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta(i,j) = e(i,j,1)*GV%m_to_H + e_tidal(i,j)*GV%m_to_H + eta(i,j) = e(i,j,1)*GV%Z_to_H + e_tidal(i,j)*GV%Z_to_H enddo ; enddo else !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta(i,j) = e(i,j,1)*GV%m_to_H + eta(i,j) = e(i,j,1)*GV%Z_to_H enddo ; enddo endif endif @@ -766,10 +774,11 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_at end subroutine PressureForce_blk_AFV_Bouss !> Initializes the finite volume pressure gradient control structure -subroutine PressureForce_blk_AFV_init(Time, G, GV, param_file, diag, CS, tides_CSp) +subroutine PressureForce_blk_AFV_init(Time, G, GV, US, param_file, diag, CS, tides_CSp) type(time_type), target, intent(in) :: Time !< Current model time type(ocean_grid_type), intent(in) :: G !< Ocean 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 !< Parameter file handles type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure type(PressureForce_blk_AFV_CS), pointer :: CS !< Finite volume PGF control structure @@ -827,7 +836,7 @@ subroutine PressureForce_blk_AFV_init(Time, G, GV, param_file, diag, CS, tides_C if (CS%tides) then CS%id_e_tidal = register_diag_field('ocean_model', 'e_tidal', diag%axesT1, & - Time, 'Tidal Forcing Astronomical and SAL Height Anomaly', 'meter') + Time, 'Tidal Forcing Astronomical and SAL Height Anomaly', 'meter', conversion=US%Z_to_m) endif CS%GFS_scale = 1.0 @@ -839,7 +848,8 @@ end subroutine PressureForce_blk_AFV_init !> Deallocates the finite volume pressure gradient control structure subroutine PressureForce_blk_AFV_end(CS) - type(PressureForce_blk_AFV_CS), pointer :: CS + type(PressureForce_blk_AFV_CS), pointer :: CS !< Blocked AFV pressure control structure that + !! will be deallocated in this subroutine. if (associated(CS)) deallocate(CS) end subroutine PressureForce_blk_AFV_end diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 5b5ab92869..cdc5ed0251 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -1,79 +1,8 @@ +!> Baropotric solver module MOM_barotropic ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Robert Hallberg, April 1994 - January 2007 * -!* * -!* This program contains the subroutines that time steps the * -!* linearized barotropic equations. btstep is used to actually * -!* time step the barotropic equations, and contains most of the * -!* substance of this module. * -!* * -!* btstep uses a forwards-backwards based scheme to time step * -!* the barotropic equations, returning the layers' accelerations due * -!* to the barotropic changes in the ocean state, the final free * -!* surface height (or column mass), and the volume (or mass) fluxes * -!* summed through the layers and averaged over the baroclinic time * -!* step. As input, btstep takes the initial 3-D velocities, the * -!* inital free surface height, the 3-D accelerations of the layers, * -!* and the external forcing. Everything in btstep is cast in terms * -!* of anomalies, so if everything is in balance, there is explicitly * -!* no acceleration due to btstep. * -!* * -!* The spatial discretization of the continuity equation is second * -!* order accurate. A flux conservative form is used to guarantee * -!* global conservation of volume. The spatial discretization of the * -!* momentum equation is second order accurate. The Coriolis force * -!* is written in a form which does not contribute to the energy * -!* tendency and which conserves linearized potential vorticity, f/D. * -!* These terms are exactly removed from the baroclinic momentum * -!* equations, so the linearization of vorticity advection will not * -!* degrade the overall solution. * -!* * -!* btcalc calculates the fractional thickness of each layer at the * -!* velocity points, for later use in calculating the barotropic * -!* velocities and the averaged accelerations. Harmonic mean * -!* thicknesses (i.e. 2*h_L*h_R/(h_L + h_R)) are used to avoid overly * -!* strong weighting of overly thin layers. This may later be relaxed * -!* to use thicknesses determined from the continuity equations. * -!* * -!* bt_mass_source determines the real mass sources for the * -!* barotropic solver, along with the corrective pseudo-fluxes that * -!* keep the barotropic and baroclinic estimates of the free surface * -!* height close to each other. Given the layer thicknesses and the * -!* free surface height that correspond to each other, it calculates * -!* a corrective mass source that is added to the barotropic continuity* -!* equation, and optionally adjusts a slowly varying correction rate. * -!* Newer algorithmic changes have deemphasized the need for this, but * -!* it is still here to add net water sources to the barotropic solver.* -!* * -!* barotropic_init allocates and initializes any barotropic arrays * -!* that have not been read from a restart file, reads parameters from * -!* the inputfile, and sets up diagnostic fields. * -!* * -!* barotropic_end deallocates anything allocated in barotropic_init * -!* or register_barotropic_restarts. * -!* * -!* register_barotropic_restarts is used to indicate any fields that * -!* are private to the barotropic solver that need to be included in * -!* the restart files, and to ensure that they are read. * -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q, CoriolisBu * -!* j+1 > o > o > At ^: v_in, vbt, accel_layer_v, vbtav * -!* j x ^ x ^ x At >: u_in, ubt, accel_layer_u, ubtav, amer * -!* j > o > o > At o: eta, h, bathyT, pbce * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 * -!* i i+1 * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** - use MOM_debugging, only : hchksum, uvchksum use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE use MOM_diag_mediator, only : post_data, query_averaging_enabled, register_diag_field @@ -93,7 +22,8 @@ module MOM_barotropic use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_S, OBC_segment_type use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS use MOM_tidal_forcing, only : tidal_forcing_sensitivity, tidal_forcing_CS -use MOM_time_manager, only : time_type, set_time, operator(+), operator(-) +use MOM_time_manager, only : time_type, real_to_time, operator(+), operator(-) +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : BT_cont_type, alloc_bt_cont_type use MOM_verticalGrid, only : verticalGrid_type @@ -128,218 +58,237 @@ module MOM_barotropic public btcalc, bt_mass_source, btstep, barotropic_init, barotropic_end public register_barotropic_restarts, set_dtbt +! 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 barotropic stepping open boundary condition type type, private :: BT_OBC_type - real, dimension(:,:), pointer :: & - Cg_u => NULL(), & ! The external wave speed at u-points, in m s-1. - Cg_v => NULL(), & ! The external wave speed at u-points, in m s-1. - H_u => NULL(), & ! The total thickness at the u-points, in m or kg m-2. - H_v => NULL(), & ! The total thickness at the v-points, in m or kg m-2. - uhbt => NULL(), & ! The zonal and meridional barotropic thickness fluxes - vhbt => NULL(), & ! specified for open boundary conditions (if any), - ! in units of m3 s-1. - ubt_outer => NULL(), & ! The zonal and meridional velocities just outside - vbt_outer => NULL(), & ! the domain, as set by the open boundary conditions, - ! in units of m s-1. - eta_outer_u => NULL(), & ! The surface height outside of the domain at a - eta_outer_v => NULL() ! u- or v- point with an open boundary condition, - ! in units of m or kg m-2. + real, dimension(:,:), pointer :: Cg_u => NULL() !< The external wave speed at u-points [m s-1]. + real, dimension(:,:), pointer :: Cg_v => NULL() !< The external wave speed at u-points [m s-1]. + real, dimension(:,:), pointer :: H_u => NULL() !< The total thickness at the u-points [H ~> m or kg m-2]. + real, dimension(:,:), pointer :: H_v => NULL() !< The total thickness at the v-points [H ~> m or kg m-2]. + real, dimension(:,:), pointer :: uhbt => NULL() !< The zonal barotropic thickness fluxes specified + !! for open boundary conditions (if any) [H m2 s-1 ~> m3 s-1 or kg s-1]. + real, dimension(:,:), pointer :: vhbt => NULL() !< The meridional barotropic thickness fluxes specified + !! for open boundary conditions (if any) [H m2 s-1 ~> m3 s-1 or kg s-1]. + real, dimension(:,:), pointer :: ubt_outer => NULL() !< The zonal velocities just outside the domain, + !! as set by the open boundary conditions [m s-1]. + real, dimension(:,:), pointer :: vbt_outer => NULL() !< The meridional velocities just outside the domain, + !! as set by the open boundary conditions [m s-1]. + real, dimension(:,:), pointer :: eta_outer_u => NULL() !< The surface height outside of the domain + !! at a u-point with an open boundary condition [H ~> m or kg m-2]. + real, dimension(:,:), pointer :: eta_outer_v => NULL() !< The surface height outside of the domain + !! at a v-point with an open boundary condition [H ~> m or kg m-2]. logical :: apply_u_OBCs !< True if this PE has an open boundary at a u-point. logical :: apply_v_OBCs !< True if this PE has an open boundary at a v-point. + !>@{ Index ranges for the open boundary conditions integer :: is_u_obc, ie_u_obc, js_u_obc, je_u_obc integer :: is_v_obc, ie_v_obc, js_v_obc, je_v_obc + !!@} logical :: is_alloced = .false. !< True if BT_OBC is in use and has been allocated - ! for group halo pass - type(group_pass_type) :: pass_uv - type(group_pass_type) :: pass_uhvh - type(group_pass_type) :: pass_h - type(group_pass_type) :: pass_cg - type(group_pass_type) :: pass_eta_outer + + type(group_pass_type) :: pass_uv !< Structure for group halo pass + type(group_pass_type) :: pass_uhvh !< Structure for group halo pass + type(group_pass_type) :: pass_h !< Structure for group halo pass + type(group_pass_type) :: pass_cg !< Structure for group halo pass + type(group_pass_type) :: pass_eta_outer !< Structure for group halo pass end type BT_OBC_type +!> The barotropic stepping control stucture type, public :: barotropic_CS ; private real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: frhatu + !< The fraction of the total column thickness interpolated to u grid points in each layer, nondim. real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: frhatv - ! frhatu and frhatv are the fraction of the total column thickness - ! interpolated to u or v grid points in each layer, nondimensional. - real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: & - IDatu, & ! Inverse of the basin depth at u grid points, in m-1. - lin_drag_u, & ! A spatially varying linear drag coefficient acting - ! on the zonal barotropic flow, in H s-1. - uhbt_IC, & ! The barotropic solver's estimate of the zonal - ! transport as the initial condition for the next call - ! to btstep, in H m2 s-1. - ubt_IC, & ! The barotropic solver's estimate of the zonal velocity - ! that will be the initial condition for the next call - ! to btstep, in m s-1. - ubtav ! The barotropic zonal velocity averaged over the - ! baroclinic time step, m s-1. - real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: & - IDatv, & ! Inverse of the basin depth at v grid points, in m-1. - lin_drag_v, & ! A spatially varying linear drag coefficient acting - ! on the zonal barotropic flow, in H s-1. - vhbt_IC, & ! The barotropic solver's estimate of the zonal - ! transport as the initla condition for the next call - ! to btstep, in H m2 s-1. - vbt_IC, & ! The barotropic solver's estimate of the zonal velocity - ! that will be the initial condition for the next call - ! to btstep, in m s-1. - vbtav ! The barotropic meridional velocity averaged over the - ! baroclinic time step, m s-1. - real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: & - eta_cor, & ! The difference between the free surface height from - ! the barotropic calculation and the sum of the layer - ! thicknesses. This difference is imposed as a forcing - ! term in the barotropic calculation over a baroclinic - ! timestep, in H (m or kg m-2). - eta_cor_bound ! A limit on the rate at which eta_cor can be applied - ! while avoiding instability, in units of H s-1. This - ! is only used if CS%bound_BT_corr is true. - real ALLOCABLE_, dimension(NIMEMW_,NJMEMW_) :: & - ua_polarity, & ! Test vector components for checking grid polarity. - va_polarity, & ! Test vector components for checking grid polarity. - bathyT ! A copy of bathyT (ocean bottom depth) with wide halos. + !< The fraction of the total column thickness interpolated to v grid points in each layer, nondim. + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: IDatu + !< Inverse of the basin depth at u grid points [Z-1 ~> m-1]. + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: lin_drag_u + !< A spatially varying linear drag coefficient acting on the zonal barotropic flow + !! [H s-1 ~> m s-1 or kg m-2 s-1]. + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: uhbt_IC + !< The barotropic solvers estimate of the zonal transport as the initial condition for + !! the next call to btstep [H m2 s-1 ~> m3 s-1 or kg s-1]. + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: ubt_IC + !< The barotropic solvers estimate of the zonal velocity that will be the initial + !! condition for the next call to btstep [m s-1]. + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: ubtav + !< The barotropic zonal velocity averaged over the baroclinic time step [m s-1]. + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: IDatv + !< Inverse of the basin depth at v grid points [Z-1 ~> m-1]. + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: lin_drag_v + !< A spatially varying linear drag coefficient acting on the zonal barotropic flow + !! [H s-1 ~> m s-1 or kg m-2 s-1]. + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: vhbt_IC + !< The barotropic solvers estimate of the zonal transport as the initial condition for + !! the next call to btstep [H m2 s-1 ~> m3 s-1 or kg s-1]. + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: vbt_IC + !< The barotropic solvers estimate of the zonal velocity that will be the initial + !! condition for the next call to btstep [m s-1]. + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: vbtav + !< The barotropic meridional velocity averaged over the baroclinic time step [m s-1]. + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: eta_cor + !< The difference between the free surface height from the barotropic calculation and the sum + !! of the layer thicknesses. This difference is imposed as a forcing term in the barotropic + !! calculation over a baroclinic timestep [H ~> m or kg m-2]. + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: eta_cor_bound + !< A limit on the rate at which eta_cor can be applied while avoiding instability + !! [H s-1 ~> m s-1 or kg m-2 s-1]. This is only used if CS%bound_BT_corr is true. real ALLOCABLE_, dimension(NIMEMW_,NJMEMW_) :: & - IareaT ! This is a copy of G%IareaT with wide halos, but will - ! still utilize the macro IareaT when referenced, m-2. + ua_polarity, & !< Test vector components for checking grid polarity. + va_polarity, & !< Test vector components for checking grid polarity. + bathyT !< A copy of bathyT (ocean bottom depth) with wide halos [Z ~> m] + real ALLOCABLE_, dimension(NIMEMW_,NJMEMW_) :: IareaT + !< This is a copy of G%IareaT with wide halos, but will + !! still utilize the macro IareaT when referenced, m-2. real ALLOCABLE_, dimension(NIMEMBW_,NJMEMW_) :: & - D_u_Cor, & ! A simply averaged depth at u points, in m. - dy_Cu, & ! A copy of G%dy_Cu with wide halos, in m. - IdxCu ! A copy of G%IdxCu with wide halos, in m-1. + D_u_Cor, & !< A simply averaged depth at u points [Z ~> m]. + dy_Cu, & !< A copy of G%dy_Cu with wide halos [m]. + IdxCu !< A copy of G%IdxCu with wide halos [m-1]. real ALLOCABLE_, dimension(NIMEMW_,NJMEMBW_) :: & - D_v_Cor, & ! A simply averaged depth at v points, in m. - dx_Cv, & ! A copy of G%dx_Cv with wide halos, in m. - IdyCv ! A copy of G%IdyCv with wide halos, in m-1. + D_v_Cor, & !< A simply averaged depth at v points [Z ~> m]. + dx_Cv, & !< A copy of G%dx_Cv with wide halos [m]. + IdyCv !< A copy of G%IdyCv with wide halos [m-1]. real ALLOCABLE_, dimension(NIMEMBW_,NJMEMBW_) :: & - q_D ! f / D at PV points, in m-1 s-1. + q_D !< f / D at PV points [Z-1 s-1 ~> m-1 s-1]. - real, pointer, dimension(:,:,:) :: frhatu1 => NULL(), frhatv1 => NULL() ! Predictor values. + real, dimension(:,:,:), pointer :: frhatu1 => NULL() !< Predictor step values of frhatu stored for diagnostics. + real, dimension(:,:,:), pointer :: frhatv1 => NULL() !< Predictor step values of frhatv stored for diagnostics. - type(BT_OBC_type) :: BT_OBC !< A structure with all of this module's fields + type(BT_OBC_type) :: BT_OBC !< A structure with all of this modules fields !! for applying open boundary conditions. - real :: Rho0 ! The density used in the Boussinesq - ! approximation, in kg m-3. - real :: dtbt ! The barotropic time step, in s. - real :: dtbt_fraction ! The fraction of the maximum time-step that - ! should used. The default is 0.98. - real :: dtbt_max ! The maximum stable barotropic time step, in s. - real :: dt_bt_filter ! The time-scale over which the barotropic mode - ! solutions are filtered, in s. This can never - ! be taken to be longer than 2*dt. The default, 0, - ! applies no filtering. - integer :: nstep_last = 0 ! The number of barotropic timesteps per baroclinic - ! time step the last time btstep was called. - real :: bebt ! A nondimensional number, from 0 to 1, that - ! determines the gravity wave time stepping scheme. - ! 0.0 gives a forward-backward scheme, while 1.0 - ! give backward Euler. In practice, bebt should be - ! of order 0.2 or greater. - logical :: split ! If true, use the split time stepping scheme. - logical :: bound_BT_corr ! If true, the magnitude of the fake mass source - ! in the barotropic equation that drives the two - ! estimates of the free surface height toward each - ! other is bounded to avoid driving corrective - ! velocities that exceed MAXCFL_BT_CONT. - logical :: gradual_BT_ICs ! 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. - logical :: Sadourny ! If true, the Coriolis terms are discretized - ! with Sadourny's energy conserving scheme, - ! otherwise the Arakawa & Hsu scheme is used. If - ! the deformation radius is not resolved Sadourny's - ! scheme should probably be used. - logical :: Nonlinear_continuity ! If true, the barotropic continuity equation - ! uses the full ocean thickness for transport. - integer :: Nonlin_cont_update_period ! The number of barotropic time steps - ! between updates to the face area, or 0 only to - ! 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 - ! when calculating the transport. The default - ! (false) is to use a predictor continuity step to - ! find the pressure field, and then do a corrector - ! continuity step using a weighted average of the - ! old and new velocities, with weights of (1-BEBT) - ! and BEBT. - logical :: dynamic_psurf ! If true, add a dynamic pressure due to a viscous - ! ice shelf, for instance. - real :: Dmin_dyn_psurf ! The minimum depth to use in limiting the size - ! of the dynamic surface pressure for stability, - ! in m. - real :: ice_strength_length ! The length scale at which the damping rate - ! due to the ice strength should be the same as if - ! a Laplacian were applied, in m. - real :: const_dyn_psurf ! The constant that scales the dynamic surface - ! pressure, nondim. Stable values are < ~1.0. - ! The default is 0.9. - logical :: tides ! If true, apply tidal momentum forcing. - real :: G_extra ! A nondimensional factor by which gtot is enhanced. - integer :: hvel_scheme ! An integer indicating how the thicknesses at - ! velocity points are calculated. Valid values are - ! given by the parameters defined below: - ! HARMONIC, ARITHMETIC, HYBRID, and FROM_BT_CONT - logical :: strong_drag ! If true, use a stronger estimate of the retarding - ! effects of strong bottom drag. - logical :: linear_wave_drag ! 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. - logical :: linearized_BT_PV ! If true, the PV and interface thicknesses used - ! in the barotropic Coriolis calculation is time - ! invariant and linearized. - logical :: use_wide_halos ! If true, use wide halos and march in during the - ! barotropic time stepping for efficiency. - logical :: clip_velocity ! If true, limit any velocity components that are - ! are large enough for a CFL number to exceed - ! CFL_trunc. This should only be used as a - ! desperate debugging measure. - logical :: debug ! If true, write verbose checksums for debugging purposes. - logical :: debug_bt ! If true, write verbose checksums for debugging purposes. + real :: Rho0 !< The density used in the Boussinesq approximation [kg m-3]. + real :: dtbt !< The barotropic time step [s]. + real :: dtbt_fraction !< The fraction of the maximum time-step that + !! should used. The default is 0.98. + real :: dtbt_max !< The maximum stable barotropic time step [s]. + real :: dt_bt_filter !< The time-scale over which the barotropic mode + !! solutions are filtered [s]. This can never + !! be taken to be longer than 2*dt. The default, 0, + !! applies no filtering. + integer :: nstep_last = 0 !< The number of barotropic timesteps per baroclinic + !! time step the last time btstep was called. + real :: bebt !< A nondimensional number, from 0 to 1, that + !! determines the gravity wave time stepping scheme. + !! 0.0 gives a forward-backward scheme, while 1.0 + !! give backward Euler. In practice, bebt should be + !! of order 0.2 or greater. + logical :: split !< If true, use the split time stepping scheme. + logical :: bound_BT_corr !< If true, the magnitude of the fake mass source + !! in the barotropic equation that drives the two + !! estimates of the free surface height toward each + !! other is bounded to avoid driving corrective + !! velocities that exceed MAXCFL_BT_CONT. + logical :: gradual_BT_ICs !< 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. + logical :: Sadourny !< If true, the Coriolis terms are discretized + !! with Sadourny's energy conserving scheme, + !! otherwise the Arakawa & Hsu scheme is used. If + !! the deformation radius is not resolved Sadourny's + !! scheme should probably be used. + logical :: Nonlinear_continuity !< If true, the barotropic continuity equation + !! uses the full ocean thickness for transport. + integer :: Nonlin_cont_update_period !< The number of barotropic time steps + !! between updates to the face area, or 0 only to + !! 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 + !! when calculating the transport. The default + !! (false) is to use a predictor continuity step to + !! find the pressure field, and then do a corrector + !! continuity step using a weighted average of the + !! old and new velocities, with weights of (1-BEBT) + !! and BEBT. + logical :: dynamic_psurf !< If true, add a dynamic pressure due to a viscous + !! ice shelf, for instance. + real :: Dmin_dyn_psurf !< The minimum depth to use in limiting the size + !! of the dynamic surface pressure for stability [m]. + real :: ice_strength_length !< The length scale at which the damping rate + !! due to the ice strength should be the same as if + !! a Laplacian were applied [m]. + real :: const_dyn_psurf !< The constant that scales the dynamic surface + !! pressure, nondim. Stable values are < ~1.0. + !! The default is 0.9. + logical :: tides !< If true, apply tidal momentum forcing. + real :: G_extra !< A nondimensional factor by which gtot is enhanced. + integer :: hvel_scheme !< An integer indicating how the thicknesses at + !! velocity points are calculated. Valid values are + !! given by the parameters defined below: + !! HARMONIC, ARITHMETIC, HYBRID, and FROM_BT_CONT + logical :: strong_drag !< If true, use a stronger estimate of the retarding + !! effects of strong bottom drag. + logical :: linear_wave_drag !< 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. + logical :: linearized_BT_PV !< If true, the PV and interface thicknesses used + !! in the barotropic Coriolis calculation is time + !! invariant and linearized. + logical :: use_wide_halos !< If true, use wide halos and march in during the + !! barotropic time stepping for efficiency. + logical :: clip_velocity !< If true, limit any velocity components that are + !! are large enough for a CFL number to exceed + !! CFL_trunc. This should only be used as a + !! desperate debugging measure. + logical :: debug !< If true, write verbose checksums for debugging purposes. + logical :: debug_bt !< If true, write verbose checksums for debugging purposes. real :: vel_underflow !< Velocity components smaller than vel_underflow - !! are set to 0, in m s-1. - real :: maxvel ! Velocity components greater than maxvel are - ! truncated to maxvel, in m s-1. - real :: CFL_trunc ! If clip_velocity is true, velocity components will - ! be truncated when they are large enough that the - ! corresponding CFL number exceeds this value, nondim. - real :: maxCFL_BT_cont ! The maximum permitted CFL number associated with the - ! barotropic accelerations from the summed velocities - ! times the time-derivatives of thicknesses. The - ! default is 0.1, and there will probably be real - ! problems if this were set close to 1. - logical :: BT_cont_bounds ! If true, use the BT_cont_type variables to set - ! limits on the magnitude of the corrective mass - ! fluxes. - logical :: visc_rem_u_uh0 ! 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. - logical :: adjust_BT_cont ! 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. + !! are set to 0 [m s-1]. + real :: maxvel !< Velocity components greater than maxvel are + !! truncated to maxvel [m s-1]. + real :: CFL_trunc !< If clip_velocity is true, velocity components will + !! be truncated when they are large enough that the + !! corresponding CFL number exceeds this value, nondim. + real :: maxCFL_BT_cont !< The maximum permitted CFL number associated with the + !! barotropic accelerations from the summed velocities + !! times the time-derivatives of thicknesses. The + !! default is 0.1, and there will probably be real + !! problems if this were set close to 1. + logical :: BT_cont_bounds !< If true, use the BT_cont_type variables to set + !! limits on the magnitude of the corrective mass + !! fluxes. + logical :: visc_rem_u_uh0 !< 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. + logical :: adjust_BT_cont !< 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. logical :: use_old_coriolis_bracket_bug !< If True, use an order of operations !! that is not bitwise rotationally symmetric in the !! meridional Coriolis term of the barotropic solver. - type(time_type), pointer :: Time ! A pointer to the ocean model's clock. - type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the - ! timing of diagnostic output. + type(time_type), pointer :: Time => NULL() !< A pointer to the ocean models clock. + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate + !! the timing of diagnostic output. type(MOM_domain_type), pointer :: BT_Domain => NULL() - type(hor_index_type), pointer :: debug_BT_HI ! debugging copy of horizontal index_type + type(hor_index_type), pointer :: debug_BT_HI => NULL() !< debugging copy of horizontal index_type type(tidal_forcing_CS), pointer :: tides_CSp => NULL() logical :: module_is_initialized = .false. - integer :: isdw, iedw, jsdw, jedw ! The memory limits of the wide halo arrays. - - !--- for group halo pass - type(group_pass_type) :: pass_q_DCor, pass_gtot - type(group_pass_type) :: pass_tmp_uv, pass_eta_bt_rem - type(group_pass_type) :: pass_force_hbt0_Cor_ref, pass_Dat_uv - type(group_pass_type) :: pass_eta_ubt, pass_etaav, pass_ubt_Cor - type(group_pass_type) :: pass_ubta_uhbta, pass_e_anom - + integer :: isdw !< The lower i-memory limit for the wide halo arrays. + integer :: iedw !< The upper i-memory limit for the wide halo arrays. + integer :: jsdw !< The lower j-memory limit for the wide halo arrays. + integer :: jedw !< The upper j-memory limit for the wide halo arrays. + + type(group_pass_type) :: pass_q_DCor !< Handle for a group halo pass + type(group_pass_type) :: pass_gtot !< Handle for a group halo pass + type(group_pass_type) :: pass_tmp_uv !< Handle for a group halo pass + type(group_pass_type) :: pass_eta_bt_rem !< Handle for a group halo pass + type(group_pass_type) :: pass_force_hbt0_Cor_ref !< Handle for a group halo pass + type(group_pass_type) :: pass_Dat_uv !< Handle for a group halo pass + type(group_pass_type) :: pass_eta_ubt !< Handle for a group halo pass + type(group_pass_type) :: pass_etaav !< Handle for a group halo pass + type(group_pass_type) :: pass_ubt_Cor !< Handle for a group halo pass + type(group_pass_type) :: pass_ubta_uhbta !< Handle for a group halo pass + type(group_pass_type) :: pass_e_anom !< Handle for a group halo pass + + !>@{ Diagnostic IDs integer :: id_PFu_bt = -1, id_PFv_bt = -1, id_Coru_bt = -1, id_Corv_bt = -1 integer :: id_ubtforce = -1, id_vbtforce = -1, id_uaccel = -1, id_vaccel = -1 integer :: id_visc_rem_u = -1, id_visc_rem_v = -1, id_eta_cor = -1 @@ -356,31 +305,63 @@ module MOM_barotropic integer :: id_BTC_FA_v_NN = -1, id_BTC_FA_v_N0 = -1, id_BTC_FA_v_S0 = -1, id_BTC_FA_v_SS = -1 integer :: id_BTC_vbt_NN = -1, id_BTC_vbt_SS = -1 integer :: id_uhbt0 = -1, id_vhbt0 = -1 + !!@} end type barotropic_CS +!> A desciption of the functional dependence of transport at a u-point type, private :: local_BT_cont_u_type - real :: FA_u_EE, FA_u_E0, FA_u_W0, FA_u_WW - real :: ubt_EE, ubt_WW - real :: uh_crvE, uh_crvW - real :: uh_EE, uh_WW + real :: FA_u_EE !< The effective open face area for zonal barotropic transport + !! drawing from locations far to the east [H m ~> m2 or kg m-1]. + real :: FA_u_E0 !< The effective open face area for zonal barotropic transport + !! drawing from nearby to the east [H m ~> m2 or kg m-1]. + real :: FA_u_W0 !< The effective open face area for zonal barotropic transport + !! drawing from nearby to the west [H m ~> m2 or kg m-1]. + real :: FA_u_WW !< The effective open face area for zonal barotropic transport + !! drawing from locations far to the west [H m ~> m2 or kg m-1]. + real :: uBT_WW !< uBT_WW is the barotropic velocity [m s-1], beyond which the marginal + !! open face area is FA_u_WW. uBT_WW must be non-negative. + real :: uBT_EE !< uBT_EE is a barotropic velocity [m s-1], beyond which the marginal + !! open face area is FA_u_EE. uBT_EE must be non-positive. + real :: uh_crvW !< The curvature of face area with velocity for flow from the west [H s2 m-1 ~> s2 or kg s2 m-3]. + real :: uh_crvE !< The curvature of face area with velocity for flow from the east [H s2 m-1 ~> s2 or kg s2 m-3]. + real :: uh_WW !< The zonal transport when ubt=ubt_WW [H m2 s-1 ~> m3 s-1 or kg s-1]. + real :: uh_EE !< The zonal transport when ubt=ubt_EE [H m2 s-1 ~> m3 s-1 or kg s-1]. end type local_BT_cont_u_type +!> A desciption of the functional dependence of transport at a v-point type, private :: local_BT_cont_v_type - real :: FA_v_NN, FA_v_N0, FA_v_S0, FA_v_SS - real :: vbt_NN, vbt_SS - real :: vh_crvN, vh_crvS - real :: vh_NN, vh_SS + real :: FA_v_NN !< The effective open face area for meridional barotropic transport + !! drawing from locations far to the north [H m ~> m2 or kg m-1]. + real :: FA_v_N0 !< The effective open face area for meridional barotropic transport + !! drawing from nearby to the north [H m ~> m2 or kg m-1]. + real :: FA_v_S0 !< The effective open face area for meridional barotropic transport + !! drawing from nearby to the south [H m ~> m2 or kg m-1]. + real :: FA_v_SS !< The effective open face area for meridional barotropic transport + !! drawing from locations far to the south [H m ~> m2 or kg m-1]. + real :: vBT_SS !< vBT_SS is the barotropic velocity [m s-1], beyond which the marginal + !! open face area is FA_v_SS. vBT_SS must be non-negative. + real :: vBT_NN !< vBT_NN is the barotropic velocity [m s-1], beyond which the marginal + !! open face area is FA_v_NN. vBT_NN must be non-positive. + real :: vh_crvS !< The curvature of face area with velocity for flow from the south [H s2 m-1 ~> s2 or kg s2 m-3]. + real :: vh_crvn !< The curvature of face area with velocity for flow from the north [H s2 m-1 ~> s2 or kg s2 m-3]. + real :: vh_SS !< The meridional transport when vbt=vbt_SS [H m2 s-1 ~> m3 s-1 or kg s-1]. + real :: vh_NN !< The meridional transport when vbt=vbt_NN [H m2 s-1 ~> m3 s-1 or kg s-1]. end type local_BT_cont_v_type +!> A container for passing around active tracer point memory limits type, private :: memory_size_type + !>@{ Currently active memory limits integer :: isdw, iedw, jsdw, jedw ! The memory limits of the wide halo arrays. + !!@} end type memory_size_type +!>@{ CPU time clock IDs integer :: id_clock_sync=-1, id_clock_calc=-1 integer :: id_clock_calc_pre=-1, id_clock_calc_post=-1 integer :: id_clock_pass_step=-1, id_clock_pass_pre=-1, id_clock_pass_post=-1 +!!@} -! Enumeration values for various schemes +!>@{ Enumeration values for various schemes integer, parameter :: HARMONIC = 1 integer, parameter :: ARITHMETIC = 2 integer, parameter :: HYBRID = 3 @@ -390,6 +371,7 @@ module MOM_barotropic character*(20), parameter :: HARMONIC_STRING = "HARMONIC" character*(20), parameter :: ARITHMETIC_STRING = "ARITHMETIC" character*(20), parameter :: BT_CONT_STRING = "FROM_BT_CONT" +!!@} contains @@ -399,46 +381,48 @@ module MOM_barotropic !! 0.0 and 1.0 determining the scheme. In practice, bebt must be of !! order 0.2 or greater. A forwards-backwards treatment of the !! Coriolis terms is always used. -subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & - forces, pbce, eta_PF_in, U_Cor, V_Cor, & - accel_layer_u, accel_layer_v, eta_out, uhbtav, vhbtav, G, GV, CS, & +subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, & + eta_PF_in, U_Cor, V_Cor, accel_layer_u, accel_layer_v, & + eta_out, uhbtav, vhbtav, G, GV, US, CS, & visc_rem_u, visc_rem_v, etaav, OBC, & BT_cont, eta_PF_start, & taux_bot, tauy_bot, uh0, vh0, u_uh0, v_vh0) 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) :: U_in !< The initial (3-D) zonal velocity, in m s-1. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: V_in !< The initial (3-D) meridional velocity, in m s-1. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: U_in !< The initial (3-D) zonal velocity [m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: V_in !< The initial (3-D) meridional velocity [m s-1]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: eta_in !< The initial barotropic free surface height - !! anomaly or column mass anomaly, in H (m or kg m-2). + !! anomaly or column mass anomaly [H ~> m or kg m-2]. real, intent(in) :: dt !< The time increment to integrate over. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: bc_accel_u !< The zonal baroclinic accelerations, in m s-2. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: bc_accel_u !< The zonal baroclinic accelerations [m s-2]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: bc_accel_v !< The meridional baroclinic accelerations, - !! in m s-2. + !! [m s-2]. type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: pbce !< The baroclinic pressure anomaly in each layer - !! due to free surface height anomalies, in m2 H-1 s-2. + !! due to free surface height anomalies + !! [m2 H-1 s-2 ~> m s-2 or m4 kg-1 s-2]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: eta_PF_in !< The 2-D eta field (either SSH anomaly or !! column mass anomaly) that was used to calculate the input !! pressure gradient accelerations (or its final value if - !! eta_PF_start is provided, in m or kg m-2. + !! eta_PF_start is provided [H ~> m or kg m-2]. !! Note: eta_in, pbce, and eta_PF_in must have up-to-date !! values in the first point of their halos. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: U_Cor !< The (3-D) zonal-velocities used to - !! calculate the Coriolis terms in bc_accel_u, in m s-1. + !! calculate the Coriolis terms in bc_accel_u [m s-1]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: V_Cor !< Ditto for meridonal bc_accel_v. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: accel_layer_u !< The zonal acceleration of each layer due - !! to the barotropic calculation, in m s-2. + !! to the barotropic calculation [m s-2]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: accel_layer_v !< The meridional acceleration of each layer - !! due to the barotropic calculation, in m s-2. + !! due to the barotropic calculation [m s-2]. real, dimension(SZI_(G),SZJ_(G)), intent(out) :: eta_out !< The final barotropic free surface - !! height anomaly or column mass anomaly, in m or kg m-2. + !! height anomaly or column mass anomaly [H ~> m or kg m-2]. real, dimension(SZIB_(G),SZJ_(G)), intent(out) :: uhbtav !< the barotropic zonal volume or mass - !! fluxes averaged through the barotropic steps, in - !! m3 s-1 or kg s-1. + !! fluxes averaged through the barotropic steps + !! [H m2 s-1 ~> m3 or kg s-1]. real, dimension(SZI_(G),SZJB_(G)), intent(out) :: vhbtav !< the barotropic meridional volume or mass - !! fluxes averaged through the barotropic steps, in - !! m3 s-1 or kg s-1. + !! fluxes averaged through the barotropic steps + !! [H m2 s-1 ~> m3 or kg s-1]. type(barotropic_CS), pointer :: CS !< The control structure returned by a !! previous call to barotropic_init. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: visc_rem_u !< Both the fraction of the momentum @@ -447,27 +431,31 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & !! barotropic acceleration that a layer experiences after !! viscosity is applied, in the zonal direction. Nondimensional !! between 0 (at the bottom) and 1 (far above the bottom). - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: visc_rem_v !< Ditto for meridional direction. - real, dimension(SZI_(G),SZJ_(G)), intent(out), optional :: etaav !< The free surface height or column mass - !! averaged over the barotropic integration, in m or kg m-2. - type(ocean_OBC_type), pointer, optional :: OBC !< The open boundary condition structure. - type(BT_cont_type), pointer, optional :: BT_cont !< A structure with elements that describe + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: visc_rem_v !< Ditto for meridional direction [nondim]. + real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: etaav !< The free surface height or column mass + !! averaged over the barotropic integration [H ~> m or kg m-2]. + type(ocean_OBC_type), optional, pointer :: OBC !< The open boundary condition structure. + type(BT_cont_type), optional, pointer :: BT_cont !< A structure with elements that describe !! the effective open face areas as a function of barotropic !! flow. - real, dimension(:,:), pointer, optional :: eta_PF_start !< The eta field consistent with the pressure - !! gradient at the start of the barotropic stepping, in m or - !! kg m-2. - real, dimension(:,:), pointer, optional :: taux_bot !< The zonal bottom frictional stress from - !! ocean to the seafloor, in Pa. - real, dimension(:,:), pointer, optional :: tauy_bot !< The meridional bottom frictional stress - !! from ocean to the seafloor, in Pa. - real, dimension(:,:,:), pointer, optional :: uh0, u_uh0 - real, dimension(:,:,:), pointer, optional :: vh0, v_vh0 + real, dimension(:,:), optional, pointer :: eta_PF_start !< The eta field consistent with the pressure + !! gradient at the start of the barotropic stepping + !! [H ~> m or kg m-2]. + real, dimension(:,:), optional, pointer :: taux_bot !< The zonal bottom frictional stress from + !! ocean to the seafloor [Pa]. + real, dimension(:,:), optional, pointer :: tauy_bot !< The meridional bottom frictional stress + !! from ocean to the seafloor [Pa]. + real, dimension(:,:,:), optional, pointer :: uh0 !< The zonal layer transports at reference + !! velocities [H m s-1 ~> m2 s-1 or kg m-1 s-1]. + real, dimension(:,:,:), optional, pointer :: u_uh0 !< The velocities used to calculate uh0 [m s-1] + real, dimension(:,:,:), optional, pointer :: vh0 !< The zonal layer transports at reference + !! velocities [H m s-1 ~> m2 s-1 or kg m-1 s-1]. + real, dimension(:,:,:), optional, pointer :: v_vh0 !< The velocities used to calculate vh0 [m s-1] ! Local variables real :: ubt_Cor(SZIB_(G),SZJ_(G)) ! The barotropic velocities that had been real :: vbt_Cor(SZI_(G),SZJB_(G)) ! used to calculate the input Coriolis - ! terms, in m s-1. + ! terms [m s-1]. real :: wt_u(SZIB_(G),SZJ_(G),SZK_(G)) ! wt_u and wt_v are the real :: wt_v(SZI_(G),SZJB_(G),SZK_(G)) ! normalized weights to ! be used in calculating barotropic velocities, possibly with @@ -481,102 +469,102 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & real, dimension(SZI_(G),SZJ_(G)) :: & e_anom ! The anomaly in the sea surface height or column mass ! averaged between the beginning and end of the time step, - ! relative to eta_PF, with SAL effects included, in units - ! of H (m or kg m-2, the same as eta and h). + ! relative to eta_PF, with SAL effects included [H ~> m or kg m-2]. ! These are always allocated with symmetric memory and wide halos. - real :: q(SZIBW_(CS),SZJBW_(CS)) ! A pseudo potential vorticity in s-1 m-1. + real :: q(SZIBW_(CS),SZJBW_(CS)) ! A pseudo potential vorticity [s-1 Z-1 ~> s-1 m-1]. real, dimension(SZIBW_(CS),SZJW_(CS)) :: & - ubt, & ! The zonal barotropic velocity in m s-1. + ubt, & ! The zonal barotropic velocity [m s-1]. bt_rem_u, & ! The fraction of the barotropic zonal velocity that remains ! after a time step, the remainder being lost to bottom drag. ! bt_rem_u is a nondimensional number between 0 and 1. BT_force_u, & ! The vertical average of all of the u-accelerations that are - ! not explicitly included in the barotropic equation, m s-2. + ! not explicitly included in the barotropic equation [m s-2]. u_accel_bt, & ! The difference between the zonal acceleration from the - ! barotropic calculation and BT_force_u, in m s-2. - uhbt, & ! The zonal barotropic thickness fluxes, in H m2 s-1. + ! barotropic calculation and BT_force_u [m s-2]. + uhbt, & ! The zonal barotropic thickness fluxes [H m2 s-1 ~> m3 s-1 or kg s-1]. uhbt0, & ! The difference between the sum of the layer zonal thickness ! fluxes and the barotropic thickness flux using the same - ! velocity, in H m2 s-1. - ubt_old, & ! The starting value of ubt in a barotropic step, in m s-1. - ubt_first, & ! The starting value of ubt in a series of barotropic steps, in m s-1. - ubt_sum, & ! The sum of ubt over the time steps, in m s-1. - uhbt_sum, & ! The sum of uhbt over the time steps, in H m2 s-1. - ubt_wtd, & ! A weighted sum used to find the filtered final ubt, in m s-1. - ubt_trans, & ! The latest value of ubt used for a transport, in m s-1. + ! velocity [H m2 s-1 ~> m3 s-1 or kg s-1]. + ubt_old, & ! The starting value of ubt in a barotropic step [m s-1]. + ubt_first, & ! The starting value of ubt in a series of barotropic steps [m s-1]. + ubt_sum, & ! The sum of ubt over the time steps [m s-1]. + uhbt_sum, & ! The sum of uhbt over the time steps [H m2 s-1 ~> m3 s-1 or kg s-1]. + ubt_wtd, & ! A weighted sum used to find the filtered final ubt [m s-1]. + ubt_trans, & ! The latest value of ubt used for a transport [m s-1]. azon, bzon, & ! _zon & _mer are the values of the Coriolis force which czon, dzon, & ! are applied to the neighboring values of vbtav & ubtav, - amer, bmer, & ! respectively to get the barotropic inertial rotation, - cmer, dmer, & ! in units of s-1. - Cor_u, & ! The zonal Coriolis acceleration, in m s-2. + amer, bmer, & ! respectively to get the barotropic inertial rotation + cmer, dmer, & ! [s-1]. + Cor_u, & ! The zonal Coriolis acceleration [m s-2]. Cor_ref_u, & ! The zonal barotropic Coriolis acceleration due - ! to the reference velocities, in m s-2. - PFu, & ! The zonal pressure force acceleration, in m s-2. - Rayleigh_u, & ! A Rayleigh drag timescale operating at u-points, in s-1. - PFu_bt_sum, & ! The summed zonal barotropic pressure gradient force, in m s-2. - Coru_bt_sum, & ! The summed zonal barotropic Coriolis acceleration, in m s-2. - DCor_u, & ! A simply averaged depth at u points, in m. + ! to the reference velocities [m s-2]. + PFu, & ! The zonal pressure force acceleration [m s-2]. + Rayleigh_u, & ! A Rayleigh drag timescale operating at u-points [s-1]. + PFu_bt_sum, & ! The summed zonal barotropic pressure gradient force [m s-2]. + Coru_bt_sum, & ! The summed zonal barotropic Coriolis acceleration [m s-2]. + DCor_u, & ! A simply averaged depth at u points [Z ~> m]. Datu ! Basin depth at u-velocity grid points times the y-grid - ! spacing, in H m. + ! spacing [H m ~> m2 or kg m-1]. real, dimension(SZIW_(CS),SZJBW_(CS)) :: & - vbt, & ! The meridional barotropic velocity in m s-1. + vbt, & ! The meridional barotropic velocity [m s-1]. bt_rem_v, & ! The fraction of the barotropic meridional velocity that ! remains after a time step, the rest being lost to bottom ! drag. bt_rem_v is a nondimensional number between 0 and 1. BT_force_v, & ! The vertical average of all of the v-accelerations that are - ! not explicitly included in the barotropic equation, m s-2. + ! not explicitly included in the barotropic equation [m s-2]. v_accel_bt, & ! The difference between the meridional acceleration from the - ! barotropic calculation and BT_force_v, in m s-2. - vhbt, & ! The meridional barotropic thickness fluxes, in H m2 s-1. + ! barotropic calculation and BT_force_v [m s-2]. + vhbt, & ! The meridional barotropic thickness fluxes [H m2 s-1 ~> m3 s-1 or kg s-1]. vhbt0, & ! The difference between the sum of the layer meridional ! thickness fluxes and the barotropic thickness flux using - ! the same velocities, in H m2 s-1. - vbt_old, & ! The starting value of vbt in a barotropic step, in m s-1. - vbt_first, & ! The starting value of ubt in a series of barotropic steps, in m s-1. - vbt_sum, & ! The sum of vbt over the time steps, in m s-1. - vhbt_sum, & ! The sum of vhbt over the time steps, in H m2 s-1. - vbt_wtd, & ! A weighted sum used to find the filtered final vbt, in m s-1. - vbt_trans, & ! The latest value of vbt used for a transport, in m s-1. - Cor_v, & ! The meridional Coriolis acceleration, in m s-2. + ! the same velocities [H m2 s-1 ~> m3 s-1 or kg s-1]. + vbt_old, & ! The starting value of vbt in a barotropic step [m s-1]. + vbt_first, & ! The starting value of ubt in a series of barotropic steps [m s-1]. + vbt_sum, & ! The sum of vbt over the time steps [m s-1]. + vhbt_sum, & ! The sum of vhbt over the time steps [H m2 s-1 ~> m3 s-1 or kg s-1]. + vbt_wtd, & ! A weighted sum used to find the filtered final vbt [m s-1]. + vbt_trans, & ! The latest value of vbt used for a transport [m s-1]. + Cor_v, & ! The meridional Coriolis acceleration [m s-2]. Cor_ref_v, & ! The meridional barotropic Coriolis acceleration due - ! to the reference velocities, in m s-2. - PFv, & ! The meridional pressure force acceleration, in m s-2. - Rayleigh_v, & ! A Rayleigh drag timescale operating at v-points, in s-1. + ! to the reference velocities [m s-2]. + PFv, & ! The meridional pressure force acceleration [m s-2]. + Rayleigh_v, & ! A Rayleigh drag timescale operating at v-points [s-1]. PFv_bt_sum, & ! The summed meridional barotropic pressure gradient force, - ! in m s-2. + ! [m s-2]. Corv_bt_sum, & ! The summed meridional barotropic Coriolis acceleration, - ! in m s-2. - DCor_v, & ! A simply averaged depth at v points, in m. + ! [m s-2]. + DCor_v, & ! A simply averaged depth at v points [Z ~> m]. Datv ! Basin depth at v-velocity grid points times the x-grid - ! spacing, in H m. + ! spacing [H m ~> m2 or kg m-1]. real, target, dimension(SZIW_(CS),SZJW_(CS)) :: & eta, & ! The barotropic free surface height anomaly or column mass - ! anomaly, in H (m or kg m-2) - eta_pred ! A predictor value of eta, in H (m or kg m-2) like eta. - real, pointer, dimension(:,:) :: & + ! anomaly [H ~> m or kg m-2] + eta_pred ! A predictor value of eta [H ~> m or kg m-2] like eta. + real, dimension(:,:), pointer :: & eta_PF_BT ! A pointer to the eta array (either eta or eta_pred) that - ! determines the barotropic pressure force, in H (m or kg m-2) + ! determines the barotropic pressure force [H ~> m or kg m-2] real, dimension(SZIW_(CS),SZJW_(CS)) :: & - eta_sum, & ! eta summed across the timesteps, in m or kg m-2. - eta_wtd, & ! A weighted estimate used to calculate eta_out, in m or kg m-2. + eta_sum, & ! eta summed across the timesteps [H ~> m or kg m-2]. + eta_wtd, & ! A weighted estimate used to calculate eta_out [H ~> m or kg m-2]. eta_PF, & ! A local copy of the 2-D eta field (either SSH anomaly or ! column mass anomaly) that was used to calculate the input - ! pressure gradient accelerations, in m or kg m-2. + ! pressure gradient accelerations [H ~> m or kg m-2]. eta_PF_1, & ! The initial value of eta_PF, when interp_eta_PF is - ! true, in m or kg m-2. + ! true [H ~> m or kg m-2]. d_eta_PF, & ! The change in eta_PF over the barotropic time stepping when - ! interp_eta_PF is true, in m or kg m-2. + ! interp_eta_PF is true [H ~> m or kg m-2]. gtot_E, & ! gtot_X is the effective total reduced gravity used to relate gtot_W, & ! free surface height deviations to pressure forces (including gtot_N, & ! GFS and baroclinic contributions) in the barotropic momentum - gtot_S, & ! equations half a grid-point in the X-direction (X is N, S, - ! E, or W) from the thickness point. gtot_X has units of m2 H-1 s-2. + gtot_S, & ! equations half a grid-point in the X-direction (X is N, S, E, or W) + ! from the thickness point [m2 H-1 s-2 ~> m s-2 or m4 kg-1 s-2]. ! (See Hallberg, J Comp Phys 1997 for a discussion.) - eta_src, & ! The source of eta per barotropic timestep, in m or kg m-2. + eta_src, & ! The source of eta per barotropic timestep [H ~> m or kg m-2]. dyn_coef_eta, & ! The coefficient relating the changes in eta to the - ! dynamic surface pressure under rigid ice, in m2 s-2 H-1. - p_surf_dyn ! A dynamic surface pressure under rigid ice, in m2 s-2. + ! dynamic surface pressure under rigid ice + ! [m2 s-2 H-1 ~> m s-2 or m4 s-2 kg-1]. + p_surf_dyn ! A dynamic surface pressure under rigid ice [m2 s-2]. type(local_BT_cont_u_type), dimension(SZIBW_(CS),SZJW_(CS)) :: & BTCL_u ! A repackaged version of the u-point information in BT_cont. type(local_BT_cont_v_type), dimension(SZIW_(CS),SZJBW_(CS)) :: & @@ -588,15 +576,15 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & real, dimension(SZIW_(CS),SZJBW_(CS)) :: & vbt_prev, vhbt_prev, vbt_sum_prev, vhbt_sum_prev, vbt_wtd_prev ! for OBC - real :: I_Rho0 ! The inverse of the mean density (Rho0), in m3 kg-1. + real :: mass_to_Z ! The depth unit converison divided by the mean density (Rho0) [m3 kg-1]. real :: visc_rem ! A work variable that may equal visc_rem_[uv]. Nondim. - real :: vel_prev ! The previous velocity in m s-1. - real :: dtbt ! The barotropic time step in s. + real :: vel_prev ! The previous velocity [m s-1]. + real :: dtbt ! The barotropic time step [s]. real :: bebt ! A copy of CS%bebt. real :: be_proj ! The fractional amount by which velocities are projected ! when project_velocity is true. For now be_proj is set ! to equal bebt, as they have similar roles and meanings. - real :: Idt ! The inverse of dt, in s-1. + real :: Idt ! The inverse of dt [s-1]. real :: det_de ! The partial derivative due to self-attraction and loading ! of the reference geopotential with the sea surface height. ! This is typically ~0.09 or less. @@ -606,7 +594,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & ! than physical problem would suggest. real :: Instep ! The inverse of the number of barotropic time steps ! to take. - real :: wt_end ! The weighting of the final value of eta_PF, ND. + real :: wt_end ! The weighting of the final value of eta_PF [nondim] integer :: nstep ! The number of barotropic time steps to take. type(time_type) :: & time_bt_start, & ! The starting time of the barotropic steps. @@ -618,24 +606,25 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & logical :: ice_is_rigid, nonblock_setup, interp_eta_PF logical :: project_velocity, add_uh0 - real :: dyn_coef_max ! The maximum stable value of dyn_coef_eta, in m2 s-2 H-1. - real :: ice_strength = 0.0 ! The effective strength of the ice in m s-2. + real :: dyn_coef_max ! The maximum stable value of dyn_coef_eta + ! [m2 s-2 H-1 ~> m s-2 or m4 s-2 kg-1]. + real :: ice_strength = 0.0 ! The effective strength of the ice [m s-2]. real :: Idt_max2 ! The squared inverse of the local maximum stable - ! barotropic time step, in s-2. + ! barotropic time step [s-2]. real :: H_min_dyn ! The minimum depth to use in limiting the size of the - ! dynamic surface pressure for stability, in H. + ! dynamic surface pressure for stability [H ~> m or kg m-2]. real :: H_eff_dx2 ! The effective total thickness divided by the grid spacing - ! squared, in H m-2. - real :: vel_tmp ! A temporary velocity, in m s-1. - real :: u_max_cor, v_max_cor ! The maximum corrective velocities, in m s-1. - real :: Htot ! The total thickness, in units of H. - real :: eta_cor_max ! The maximum fluid that can be added as a correction to eta, in H. + ! squared [H m-2 ~> m-1 or kg m-4]. + real :: vel_tmp ! A temporary velocity [m s-1]. + real :: u_max_cor, v_max_cor ! The maximum corrective velocities [m s-1]. + real :: Htot ! The total thickness [H ~> m or kg m-2]. + real :: eta_cor_max ! The maximum fluid that can be added as a correction to eta [H ~> m or kg m-2]. real :: accel_underflow ! An acceleration that is so small it should be zeroed out. real, allocatable, dimension(:) :: wt_vel, wt_eta, wt_accel, wt_trans, wt_accel2 real :: sum_wt_vel, sum_wt_eta, sum_wt_accel, sum_wt_trans real :: I_sum_wt_vel, I_sum_wt_eta, I_sum_wt_accel, I_sum_wt_trans - real :: dt_filt ! The half-width of the barotropic filter, in s. + real :: dt_filt ! The half-width of the barotropic filter [s]. real :: trans_wt1, trans_wt2 ! weight used to compute ubt_trans and vbt_trans integer :: nfilter @@ -728,7 +717,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & dtbt = dt * Instep bebt = CS%bebt be_proj = CS%bebt - I_Rho0 = 1.0/GV%Rho0 + mass_to_Z = US%m_to_Z / GV%Rho0 !--- setup the weight when computing vbt_trans and ubt_trans if (project_velocity) then @@ -743,7 +732,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & (CS%id_uhbt_hifreq > 0) .or. (CS%id_vhbt_hifreq > 0)) then do_hifreq_output = query_averaging_enabled(CS%diag, time_int_in, time_end_in) if (do_hifreq_output) & - time_bt_start = time_end_in - set_time(int(floor(dt+0.5))) + time_bt_start = time_end_in - real_to_time(dt) endif !--- begin setup for group halo update @@ -835,7 +824,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & q(I,J) = 0.25 * G%CoriolisBu(I,J) * & ((G%areaT(i,j) + G%areaT(i+1,j+1)) + (G%areaT(i+1,j) + G%areaT(i,j+1))) / & ((G%areaT(i,j) * G%bathyT(i,j) + G%areaT(i+1,j+1) * G%bathyT(i+1,j+1)) + & - (G%areaT(i+1,j) * G%bathyT(i+1,j) + G%areaT(i,j+1) * G%bathyT(i,j+1))) + (G%areaT(i+1,j) * G%bathyT(i+1,j) + G%areaT(i,j+1) * G%bathyT(i,j+1)) ) enddo ; enddo ! With very wide halos, q and D need to be calculated on the available data @@ -992,24 +981,24 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & ! ### IDatu here should be replaced with 1/D+eta(Bous) or 1/eta(non-Bous). ! ### although with BT_cont_types IDatu should be replaced by ! ### CS%dy_Cu(I,j) / (d(uhbt)/du) (with appropriate bounds). - BT_force_u(I,j) = forces%taux(I,j) * I_rho0*CS%IDatu(I,j)*visc_rem_u(I,j,1) + BT_force_u(I,j) = forces%taux(I,j) * mass_to_Z *CS%IDatu(I,j)*visc_rem_u(I,j,1) enddo ; enddo !$OMP parallel do default(shared) do J=js-1,je ; do i=is,ie ! ### IDatv here should be replaced with 1/D+eta(Bous) or 1/eta(non-Bous). ! ### although with BT_cont_types IDatv should be replaced by ! ### CS%dx_Cv(I,j) / (d(vhbt)/dv) (with appropriate bounds). - BT_force_v(i,J) = forces%tauy(i,J) * I_rho0*CS%IDatv(i,J)*visc_rem_v(i,J,1) + BT_force_v(i,J) = forces%tauy(i,J) * mass_to_Z *CS%IDatv(i,J)*visc_rem_v(i,J,1) enddo ; enddo if (present(taux_bot) .and. present(tauy_bot)) then if (associated(taux_bot) .and. associated(tauy_bot)) then !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie - BT_force_u(I,j) = BT_force_u(I,j) - taux_bot(I,j) * I_rho0 * CS%IDatu(I,j) + BT_force_u(I,j) = BT_force_u(I,j) - taux_bot(I,j) * mass_to_Z * CS%IDatu(I,j) enddo ; enddo !$OMP parallel do default(shared) do J=js-1,je ; do i=is,ie - BT_force_v(i,J) = BT_force_v(i,J) - tauy_bot(i,J) * I_rho0 * CS%IDatv(i,J) + BT_force_v(i,J) = BT_force_v(i,J) - tauy_bot(i,J) * mass_to_Z * CS%IDatv(i,J) enddo ; enddo endif endif @@ -1269,7 +1258,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & !$OMP Rayleigh_u, Rayleigh_v, & !$OMP use_BT_Cont,BTCL_u,uhbt0,BTCL_v,vhbt0,eta,Idt) & !$OMP private(u_max_cor,v_max_cor,eta_cor_max,Htot) -!$OMP do + !$OMP do do j=js-1,je+1 ; do I=is-1,ie ; av_rem_u(I,j) = 0.0 ; enddo ; enddo !$OMP do do J=js-1,je ; do i=is-1,ie+1 ; av_rem_v(i,J) = 0.0 ; enddo ; enddo @@ -1311,7 +1300,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & do j=js,je ; do I=is-1,ie ; if (CS%lin_drag_u(I,j) > 0.0) then Htot = 0.5 * (eta(i,j) + eta(i+1,j)) if (GV%Boussinesq) & - Htot = Htot + 0.5*GV%m_to_H * (CS%bathyT(i,j) + CS%bathyT(i+1,j)) + Htot = Htot + 0.5*GV%Z_to_H * (CS%bathyT(i,j) + CS%bathyT(i+1,j)) bt_rem_u(I,j) = bt_rem_u(I,j) * (Htot / (Htot + CS%lin_drag_u(I,j) * dtbt)) Rayleigh_u(I,j) = CS%lin_drag_u(I,j) / Htot @@ -1320,7 +1309,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & do J=js-1,je ; do i=is,ie ; if (CS%lin_drag_v(i,J) > 0.0) then Htot = 0.5 * (eta(i,j) + eta(i,j+1)) if (GV%Boussinesq) & - Htot = Htot + 0.5*GV%m_to_H * (CS%bathyT(i,j) + CS%bathyT(i+1,j+1)) + Htot = Htot + 0.5*GV%Z_to_H * (CS%bathyT(i,j) + CS%bathyT(i+1,j+1)) bt_rem_v(i,J) = bt_rem_v(i,J) * (Htot / (Htot + CS%lin_drag_v(i,J) * dtbt)) Rayleigh_v(i,J) = CS%lin_drag_v(i,J) / Htot @@ -1329,23 +1318,23 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & ! Zero out the arrays for various time-averaged quantities. if (find_etaav) then -!$OMP do + !$OMP do do j=jsvf-1,jevf+1 ; do i=isvf-1,ievf+1 eta_sum(i,j) = 0.0 ; eta_wtd(i,j) = 0.0 enddo ; enddo else -!$OMP do + !$OMP do do j=jsvf-1,jevf+1 ; do i=isvf-1,ievf+1 eta_wtd(i,j) = 0.0 enddo ; enddo endif -!$OMP do + !$OMP do do j=jsvf-1,jevf+1 ; do I=isvf-1,ievf ubt_sum(I,j) = 0.0 ; uhbt_sum(I,j) = 0.0 PFu_bt_sum(I,j) = 0.0 ; Coru_bt_sum(I,j) = 0.0 ubt_wtd(I,j) = 0.0 ; ubt_trans(I,j) = 0.0 enddo ; enddo -!$OMP do + !$OMP do do J=jsvf-1,jevf ; do i=isvf-1,ievf+1 vbt_sum(i,J) = 0.0 ; vhbt_sum(i,J) = 0.0 PFv_bt_sum(i,J) = 0.0 ; Corv_bt_sum(i,J) = 0.0 @@ -1353,7 +1342,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & enddo ; enddo ! Set the mass source, after first initializing the halos to 0. -!$OMP do + !$OMP do do j=jsvf-1,jevf+1; do i=isvf-1,ievf+1 ; eta_src(i,j) = 0.0 ; enddo ; enddo if (CS%bound_BT_corr) then ; if (use_BT_Cont .and. CS%BT_cont_bounds) then do j=js,je ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then @@ -1373,7 +1362,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & ! Limit the sink (inward) correction to the amount of mass that is already ! inside the cell. Htot = eta(i,j) - if (GV%Boussinesq) Htot = CS%bathyT(i,j)*GV%m_to_H + eta(i,j) + if (GV%Boussinesq) Htot = CS%bathyT(i,j)*GV%Z_to_H + eta(i,j) CS%eta_cor(i,j) = max(CS%eta_cor(i,j), -max(0.0,Htot)) endif @@ -1382,7 +1371,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & if (abs(CS%eta_cor(i,j)) > dt*CS%eta_cor_bound(i,j)) & CS%eta_cor(i,j) = sign(dt*CS%eta_cor_bound(i,j),CS%eta_cor(i,j)) enddo ; enddo ; endif ; endif -!$OMP do + !$OMP do do j=js,je ; do i=is,ie eta_src(i,j) = G%mask2dT(i,j) * (Instep * CS%eta_cor(i,j)) enddo ; enddo @@ -1416,13 +1405,13 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & dyn_coef_max = CS%const_dyn_psurf * max(0.0, 1.0 - dtbt**2 * Idt_max2) / & (dtbt**2 * H_eff_dx2) - ! ice_strength has units of m s-2. rigidity_ice_[uv] has units of m3 s-1. + ! ice_strength has units of [m s-2]. rigidity_ice_[uv] has units of [m3 s-1]. ice_strength = ((forces%rigidity_ice_u(I,j) + forces%rigidity_ice_u(I-1,j)) + & (forces%rigidity_ice_v(i,J) + forces%rigidity_ice_v(i,J-1))) / & (CS%ice_strength_length**2 * dtbt) - ! Units of dyn_coef: m2 s-2 H-1 - dyn_coef_eta(I,j) = min(dyn_coef_max, ice_strength * GV%H_to_m) + ! Units of dyn_coef: [m2 s-2 H-1 ~> m s-2 or m4 s-2 kg-1] + dyn_coef_eta(i,j) = min(dyn_coef_max, ice_strength * GV%H_to_m) enddo ; enddo ; endif endif @@ -1479,7 +1468,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & call uvchksum("BT frhat[uv]", CS%frhatu, CS%frhatv, G%HI, 0, .true., .true.) call uvchksum("BT bc_accel_[uv]", bc_accel_u, bc_accel_v, & G%HI, haloshift=0) - call uvchksum("BT IDat[uv]", CS%IDatu, CS%IDatv, G%HI, haloshift=0) + call uvchksum("BT IDat[uv]", CS%IDatu, CS%IDatv, G%HI, haloshift=0, scale=US%m_to_Z) call uvchksum("BT visc_rem_[uv]", visc_rem_u, visc_rem_v, & G%HI, haloshift=1) endif @@ -1627,7 +1616,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & if (CS%dynamic_psurf) then !GOMP do do j=jsv-1,jev+1 ; do i=isv-1,iev+1 - p_surf_dyn(i,j) = dyn_coef_eta(I,j) * (eta_pred(i,j) - eta(i,j)) + p_surf_dyn(i,j) = dyn_coef_eta(i,j) * (eta_pred(i,j) - eta(i,j)) enddo ; enddo endif endif @@ -2028,7 +2017,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & enddo ; enddo if (do_hifreq_output) then - time_step_end = time_bt_start + set_time(int(floor(n*dtbt+0.5))) + time_step_end = time_bt_start + real_to_time(n*dtbt) call enable_averaging(dtbt, time_step_end, CS%diag) if (CS%id_ubt_hifreq > 0) call post_data(CS%id_ubt_hifreq, ubt(IsdB:IedB,jsd:jed), CS%diag) if (CS%id_vbt_hifreq > 0) call post_data(CS%id_vbt_hifreq, vbt(isd:ied,JsdB:JedB), CS%diag) @@ -2276,38 +2265,39 @@ end subroutine btstep !> This subroutine automatically determines an optimal value for dtbt based !! on some state of the ocean. -subroutine set_dtbt(G, GV, CS, eta, pbce, BT_cont, gtot_est, SSH_add) - 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(barotropic_CS), pointer :: CS !< Barotropic control structure. - real, dimension(SZI_(G),SZJ_(G)), intent(in), optional :: eta !< The barotropic free surface height - !! anomaly or column mass anomaly, in H. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in), optional :: pbce !< The baroclinic pressure anomaly in each - !! layer due to free surface height - !! anomalies, in m2 H-1 s-2. - type(BT_cont_type), pointer, optional :: BT_cont !< A structure with elements that describe - !! the effective open face areas as a - !! function of barotropic flow. - real, intent(in), optional :: gtot_est !< An estimate of the total gravitational - !! acceleration, in m s-2. - real, intent(in), optional :: SSH_add !< An additional contribution to SSH to - !! provide a margin of error when - !! calculating the external wave speed, in m. +subroutine set_dtbt(G, GV, US, CS, eta, pbce, BT_cont, gtot_est, SSH_add) + 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 + type(barotropic_CS), pointer :: CS !< Barotropic control structure. + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: eta !< The barotropic free surface + !! height anomaly or column mass anomaly [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(in) :: pbce !< The baroclinic pressure + !! anomaly in each layer due to free surface + !! height anomalies [m2 H-1 s-2 ~> m s-2 or m4 kg-1 s-2]. + type(BT_cont_type), optional, pointer :: BT_cont !< A structure with elements that describe + !! the effective open face areas as a + !! function of barotropic flow. + real, optional, intent(in) :: gtot_est !< An estimate of the total gravitational + !! acceleration [m2 Z-1 s-2 ~> m s-2]. + real, optional, intent(in) :: SSH_add !< An additional contribution to SSH to + !! provide a margin of error when + !! calculating the external wave speed [Z ~> m]. ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & gtot_E, & ! gtot_X is the effective total reduced gravity used to relate gtot_W, & ! free surface height deviations to pressure forces (including gtot_N, & ! GFS and baroclinic contributions) in the barotropic momentum - gtot_S ! equations half a grid-point in the X-direction (X is N, S, - ! E, or W) from the thickness point. gtot_X has units of m2 H-1 s-2. + gtot_S ! equations half a grid-point in the X-direction (X is N, S, E, or W) + ! from the thickness point [m2 H-1 s-2 ~> m s-2 or m4 kg-1 s-2]. ! (See Hallberg, J Comp Phys 1997 for a discussion.) real, dimension(SZIBS_(G),SZJ_(G)) :: & Datu ! Basin depth at u-velocity grid points times the y-grid - ! spacing, in m2. + ! spacing [H m ~> m2 or kg m-1]. real, dimension(SZI_(G),SZJBS_(G)) :: & Datv ! Basin depth at v-velocity grid points times the x-grid - ! spacing, in m2. + ! spacing [H m ~> m2 or kg m-1]. real :: det_de ! The partial derivative due to self-attraction and loading ! of the reference geopotential with the sea surface height. ! This is typically ~0.09 or less. @@ -2316,7 +2306,7 @@ subroutine set_dtbt(G, GV, CS, eta, pbce, BT_cont, gtot_est, SSH_add) ! order 1. For stability, this may be made larger ! than physical problem would suggest. real :: add_SSH ! An additional contribution to SSH to provide a margin of error - ! when calculating the external wave speed, in m. + ! when calculating the external wave speed [Z ~> m]. real :: min_max_dt2, Idt_max2, dtbt_max logical :: use_BT_cont type(memory_size_type) :: MS @@ -2362,8 +2352,8 @@ subroutine set_dtbt(G, GV, CS, eta, pbce, BT_cont, gtot_est, SSH_add) enddo ; enddo ; enddo else do j=js,je ; do i=is,ie - gtot_E(i,j) = gtot_est * GV%H_to_m ; gtot_W(i,j) = gtot_est * GV%H_to_m - gtot_N(i,j) = gtot_est * GV%H_to_m ; gtot_S(i,j) = gtot_est * GV%H_to_m + gtot_E(i,j) = gtot_est * GV%H_to_Z ; gtot_W(i,j) = gtot_est * GV%H_to_Z + gtot_N(i,j) = gtot_est * GV%H_to_Z ; gtot_S(i,j) = gtot_est * GV%H_to_Z enddo ; enddo endif @@ -2398,47 +2388,57 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(memory_size_type), intent(in) :: MS !< A type that describes the memory sizes of !! the argument arrays. - real, dimension(SZIBW_(MS),SZJW_(MS)), intent(inout) :: ubt !< the zonal barotropic velocity, in m s-1. - real, dimension(SZIBW_(MS),SZJW_(MS)), intent(inout) :: uhbt !< the zonal barotropic transport, in H m2 s-1. + real, dimension(SZIBW_(MS),SZJW_(MS)), intent(inout) :: ubt !< the zonal barotropic velocity [m s-1]. + real, dimension(SZIBW_(MS),SZJW_(MS)), intent(inout) :: uhbt !< the zonal barotropic transport + !! [H m2 s-1 ~> m3 s-1 or kg s-1]. real, dimension(SZIBW_(MS),SZJW_(MS)), intent(inout) :: ubt_trans !< the zonal barotropic velocity used in - !! transport, m s-1. - real, dimension(SZIW_(MS),SZJBW_(MS)), intent(inout) :: vbt !< the meridional barotropic velocity, in m s-1. - real, dimension(SZIW_(MS),SZJBW_(MS)), intent(inout) :: vhbt !< the meridional barotropic transport, in H m2 s-1. - real, dimension(SZIW_(MS),SZJBW_(MS)), intent(inout) :: vbt_trans !< the meridional BT velocity used in transports, - !! m s-1. + !! transport [m s-1]. + real, dimension(SZIW_(MS),SZJBW_(MS)), intent(inout) :: vbt !< the meridional barotropic velocity [m s-1]. + real, dimension(SZIW_(MS),SZJBW_(MS)), intent(inout) :: vhbt !< the meridional barotropic transport + !! [H m2 s-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZIW_(MS),SZJBW_(MS)), intent(inout) :: vbt_trans !< the meridional BT velocity used in + !! transports [m s-1]. real, dimension(SZIW_(MS),SZJW_(MS)), intent(in) :: eta !< The barotropic free surface height anomaly or - !! column mass anomaly, in m or kg m-2. - real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: ubt_old !< The starting value of ubt in a barotropic step, - !! m s-1. - real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vbt_old !< The starting value of vbt in a barotropic step, - !! m s-1. + !! column mass anomaly [H ~> m or kg m-2]. + real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: ubt_old !< The starting value of ubt in a barotropic + !! step [m s-1]. + real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vbt_old !< The starting value of vbt in a barotropic + !! step [m s-1]. type(BT_OBC_type), intent(in) :: BT_OBC !< A structure with the private barotropic arrays !! related to the open boundary conditions, !! set by set_up_BT_OBC. integer, intent(in) :: halo !< The extra halo size to use here. - real, intent(in) :: dtbt !< The time step, in s. + real, intent(in) :: dtbt !< The time step [s]. real, intent(in) :: bebt !< The fractional weighting of the future velocity !! in determining the transport. logical, intent(in) :: use_BT_cont !< If true, use the BT_cont_types to calculate !! transports. - real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: Datu !< A fixed estimate of the face areas at u points. - real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: Datv !< A fixed estimate of the face areas at v points. + real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: Datu !< A fixed estimate of the face areas at u points + !! [H m ~> m2 or kg m-1]. + real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: Datv !< A fixed estimate of the face areas at v points + !! [H m ~> m2 or kg m-1]. type(local_BT_cont_u_type), dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: BTCL_u !< Structure of information used !! for a dynamic estimate of the face areas at !! u-points. type(local_BT_cont_v_type), dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: BTCL_v !< Structure of information used !! for a dynamic estimate of the face areas at !! v-points. - real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: uhbt0 - real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vhbt0 + real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: uhbt0 !< A correction to the zonal transport so that + !! the barotropic functions agree with the sum + !! of the layer transports + !! [H m2 s-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vhbt0 !< A correction to the meridional transport so that + !! the barotropic functions agree with the sum + !! of the layer transports + !! [H m2 s-1 ~> m3 s-1 or kg s-1]. ! Local variables - real :: vel_prev ! The previous velocity in m s-1. + real :: vel_prev ! The previous velocity [m s-1]. real :: vel_trans ! The combination of the previous and current velocity - ! that does the mass transport, in m s-1. - real :: H_u ! The total thickness at the u-point, in m or kg m-2. - real :: H_v ! The total thickness at the v-point, in m or kg m-2. - real :: cfl ! The CFL number at the point in question, ND. + ! that does the mass transport [m s-1]. + real :: H_u ! The total thickness at the u-point [H ~> m or kg m-2]. + real :: H_v ! The total thickness at the v-point [H ~> m or kg m-2]. + real :: cfl ! The CFL number at the point in question [nondim] real :: u_inlet real :: v_inlet real :: h_in @@ -2461,40 +2461,12 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, if (OBC%segment(OBC%segnum_u(I,j))%Flather) then cfl = dtbt * BT_OBC%Cg_u(I,j) * G%IdxCu(I,j) ! CFL u_inlet = cfl*ubt_old(I-1,j) + (1.0-cfl)*ubt_old(I,j) ! Valid for cfl<1 - ! h_in = 2.0*cfl*eta(i,j) + (1.0-2.0*cfl)*eta(i+1,j) ! external h_in = eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i-1,j)) ! internal H_u = BT_OBC%H_u(I,j) vel_prev = ubt(I,j) ubt(I,j) = 0.5*((u_inlet + BT_OBC%ubt_outer(I,j)) + & (BT_OBC%Cg_u(I,j)/H_u) * (h_in-BT_OBC%eta_outer_u(I,j))) vel_trans = (1.0-bebt)*vel_prev + bebt*ubt(I,j) - elseif (OBC%segment(OBC%segnum_u(I,j))%oblique) then - grad(I,J) = (ubt_old(I,j+1) - ubt_old(I,j)) * G%mask2dBu(I,J) - grad(I,J-1) = (ubt_old(I,j) - ubt_old(I,j-1)) * G%mask2dBu(I,J-1) - grad(I-1,J) = (ubt(I-1,j+1) - ubt(I-1,j)) * G%mask2dBu(I-1,J) - grad(I-1,J-1) = (ubt(I-1,j) - ubt(I-1,j-1)) * G%mask2dBu(I-1,J-1) - dhdt = ubt_old(I-1,j)-ubt(I-1,j) !old-new - dhdx = ubt(I-1,j)-ubt(I-2,j) !in new time backward sasha for I-1 -! if (OBC%segment(OBC%segnum_u(I,j))%oblique) then - if (dhdt*(grad(I-1,J) + grad(I-1,J-1)) > 0.0) then - dhdy = grad(I-1,J-1) - elseif (dhdt*(grad(I-1,J) + grad(I-1,J-1)) == 0.0) then - dhdy = 0.0 - else - dhdy = grad(I-1,J) - endif -! endif - if (dhdt*dhdx < 0.0) dhdt = 0.0 - Cx = min(dhdt*dhdx,rx_max) ! default to normal flow only -! Cy = 0 - cff = max(dhdx*dhdx, eps) -! if (OBC%segment(OBC%segnum_u(I,j))%oblique) then - cff = max(dhdx*dhdx + dhdy*dhdy, eps) - Cy = min(cff, max(dhdt*dhdy, -cff)) -! endif - ubt(I,j) = ((cff*ubt_old(I,j) + Cx*ubt(I-1,j)) - & - (max(Cy,0.0)*grad(I,J-1) + min(Cy,0.0)*grad(I,J))) / (cff + Cx) - vel_trans = ubt(I,j) elseif (OBC%segment(OBC%segnum_u(I,j))%gradient) then ubt(I,j) = ubt(I-1,j) vel_trans = ubt(I,j) @@ -2503,7 +2475,6 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, if (OBC%segment(OBC%segnum_u(I,j))%Flather) then cfl = dtbt * BT_OBC%Cg_u(I,j) * G%IdxCu(I,j) ! CFL u_inlet = cfl*ubt_old(I+1,j) + (1.0-cfl)*ubt_old(I,j) ! Valid for cfl<1 -! h_in = 2.0*cfl*eta(i+1,j) + (1.0-2.0*cfl)*eta(i,j) ! external h_in = eta(i+1,j) + (0.5-cfl)*(eta(i+1,j)-eta(i+2,j)) ! external H_u = BT_OBC%H_u(I,j) @@ -2512,34 +2483,6 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, (BT_OBC%Cg_u(I,j)/H_u) * (BT_OBC%eta_outer_u(I,j)-h_in)) vel_trans = (1.0-bebt)*vel_prev + bebt*ubt(I,j) - elseif (OBC%segment(OBC%segnum_u(I,j))%oblique) then - grad(I,J) = (ubt_old(I,j+1) - ubt_old(I,j)) * G%mask2dBu(I,J) - grad(I,J-1) = (ubt_old(I,j) - ubt_old(I,j-1)) * G%mask2dBu(I,J-1) - grad(I+1,J) = (ubt(I+1,j+1) - ubt(I+1,j)) * G%mask2dBu(I+1,J) - grad(I+1,J-1) = (ubt(I+1,j) - ubt(I+1,j-1)) * G%mask2dBu(I+1,J-1) - dhdt = ubt_old(I+1,j)-ubt(I+1,j) !old-new - dhdx = ubt(I+1,j)-ubt(I+2,j) !in new time backward sasha for I+1 -! if (OBC%segment(OBC%segnum_u(I,j))%oblique) then - if (dhdt*(grad(I+1,J) + grad(I+1,J-1)) > 0.0) then - dhdy = grad(I+1,J-1) - elseif (dhdt*(grad(I+1,J) + grad(I+1,J-1)) == 0.0) then - dhdy = 0.0 - else - dhdy = grad(I+1,J) - endif -! endif - if (dhdt*dhdx < 0.0) dhdt = 0.0 - Cx = min(dhdt*dhdx,rx_max) ! default to normal flow only -! Cy = 0 - cff = max(dhdx*dhdx, eps) -! if (OBC%segment(OBC%segnum_u(I,j))%oblique) then - cff = max(dhdx*dhdx + dhdy*dhdy, eps) - Cy = min(cff,max(dhdt*dhdy,-cff)) -! endif - ubt(I,j) = ((cff*ubt_old(I,j) + Cx*ubt(I+1,j)) - & - (max(Cy,0.0)*grad(I,J-1) + min(Cy,0.0)*grad(I,J))) / (cff + Cx) -! vel_trans = (1.0-bebt)*vel_prev + bebt*ubt(I,j) - vel_trans = ubt(I,j) elseif (OBC%segment(OBC%segnum_u(I,j))%gradient) then ubt(I,j) = ubt(I+1,j) vel_trans = ubt(I,j) @@ -2568,7 +2511,6 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, if (OBC%segment(OBC%segnum_v(i,J))%Flather) then cfl = dtbt * BT_OBC%Cg_v(i,J) * G%IdyCv(I,j) ! CFL v_inlet = cfl*vbt_old(i,J-1) + (1.0-cfl)*vbt_old(i,J) ! Valid for cfl<1 - ! h_in = 2.0*cfl*eta(i,j) + (1.0-2.0*cfl)*eta(i,j+1) ! external h_in = eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i,j-1)) ! internal H_v = BT_OBC%H_v(i,J) @@ -2577,34 +2519,6 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, (BT_OBC%Cg_v(i,J)/H_v) * (h_in-BT_OBC%eta_outer_v(i,J))) vel_trans = (1.0-bebt)*vel_prev + bebt*vbt(i,J) - elseif (OBC%segment(OBC%segnum_v(i,J))%oblique) then - grad(I,J) = (vbt_old(i+1,J) - vbt_old(i,J)) * G%mask2dBu(I,J) - grad(I-1,J) = (vbt_old(i,J) - vbt_old(i-1,J)) * G%mask2dBu(I-1,J) - grad(I,J-1) = (vbt(i+1,J-1) - vbt(i,J-1)) * G%mask2dBu(I,J-1) - grad(I-1,J-1) = (vbt(i,J-1) - vbt(i-1,J-1)) * G%mask2dBu(I-1,J-1) - dhdt = vbt_old(i,J-1)-vbt(i,J-1) !old-new - dhdy = vbt(i,J-1)-vbt(i,J-2) !in new time backward sasha for J-1 -! if (OBC%segment(OBC%segnum_v(i,J))%oblique) then - if (dhdt*(grad(I,J-1) + grad(I-1,J-1)) > 0.0) then - dhdx = grad(I-1,J-1) - elseif (dhdt*(grad(I,J-1) + grad(I-1,J-1)) == 0.0) then - dhdx = 0.0 - else - dhdx = grad(I,J-1) - endif -! endif - if (dhdt*dhdy < 0.0) dhdt = 0.0 - Cy = min(dhdt*dhdy,rx_max) ! default to normal flow only -! Cx = 0 - cff = max(dhdy*dhdy, eps) -! if (OBC%segment(OBC%segnum_v(i,J))%oblique) then - cff = max(dhdx*dhdx + dhdy*dhdy, eps) - Cx = min(cff,max(dhdt*dhdx,-cff)) -! endif - vbt(i,J) = ((cff*vbt_old(i,J) + Cy*vbt(i,J-1)) - & - (max(Cx,0.0)*grad(I-1,J) + min(Cx,0.0)*grad(I,J))) / (cff + Cy) -! vel_trans = (1.0-bebt)*vel_prev + bebt*vbt(i,J) - vel_trans = vbt(I,j) elseif (OBC%segment(OBC%segnum_v(i,J))%gradient) then vbt(i,J) = vbt(i,J-1) vel_trans = vbt(i,J) @@ -2613,7 +2527,6 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, if (OBC%segment(OBC%segnum_v(i,J))%Flather) then cfl = dtbt * BT_OBC%Cg_v(i,J) * G%IdyCv(I,j) ! CFL v_inlet = cfl*vbt_old(i,J+1) + (1.0-cfl)*vbt_old(i,J) ! Valid for cfl <1 - ! h_in = 2.0*cfl*eta(i,j+1) + (1.0-2.0*cfl)*eta(i,j) ! external h_in = eta(i,j+1) + (0.5-cfl)*(eta(i,j+1)-eta(i,j+2)) ! internal H_v = BT_OBC%H_v(i,J) @@ -2622,34 +2535,6 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, (BT_OBC%Cg_v(i,J)/H_v) * (BT_OBC%eta_outer_v(i,J)-h_in)) vel_trans = (1.0-bebt)*vel_prev + bebt*vbt(i,J) - elseif (OBC%segment(OBC%segnum_v(i,J))%oblique) then - grad(I,J) = (vbt_old(i+1,J) - vbt_old(i,J)) * G%mask2dBu(I,J) - grad(I-1,J) = (vbt_old(i,J) - vbt_old(i-1,J)) * G%mask2dBu(I-1,J) - grad(I,J+1) = (vbt(i+1,J+1) - vbt(i,J+1)) * G%mask2dBu(I,J+1) - grad(I-1,J+1) = (vbt(i,J+1) - vbt(i-1,J+1)) * G%mask2dBu(I-1,J+1) - dhdt = vbt_old(i,J+1)-vbt(i,J+1) !old-new - dhdy = vbt(i,J+1)-vbt(i,J+2) !in new time backward sasha for J+1 -! if (OBC%segment(OBC%segnum_v(i,J))%oblique) then - if (dhdt*(grad(I,J+1) + grad(I-1,J+1)) > 0.0) then - dhdx = grad(I-1,J+1) - elseif (dhdt*(grad(I,J+1) + grad(I-1,J+1)) == 0.0) then - dhdx = 0.0 - else - dhdx = grad(I,J+1) - endif -! endif - if (dhdt*dhdy < 0.0) dhdt = 0.0 - Cy = min(dhdt*dhdy,rx_max) ! default to normal flow only -! Cx = 0 - cff = max(dhdy*dhdy, eps) -! if (OBC%segment(OBC%segnum_v(i,J))%oblique) then - cff = max(dhdx*dhdx + dhdy*dhdy, eps) - Cx = min(cff,max(dhdt*dhdx,-cff)) -! endif - vbt(i,J) = ((cff*vbt_old(i,J) + Cy*vbt(i,J+1)) - & - (max(Cx,0.0)*grad(I-1,J) + min(Cx,0.0)*grad(I,J))) / (cff + Cy) -! vel_trans = (1.0-bebt)*vel_prev + bebt*vbt(i,J) - vel_trans = vbt(i,J) elseif (OBC%segment(OBC%segnum_v(i,J))%gradient) then vbt(i,J) = vbt(i,J+1) vel_trans = vbt(i,J) @@ -2677,18 +2562,20 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, MS, halo, use_BT_co type(memory_size_type), intent(in) :: MS !< A type that describes the memory sizes of the !! argument arrays. real, dimension(SZIW_(MS),SZJW_(MS)), intent(in) :: eta !< The barotropic free surface height anomaly or - !! column mass anomaly, in m or kg m-2. + !! column mass anomaly [H ~> m or kg m-2]. type(BT_OBC_type), intent(inout) :: BT_OBC !< A structure with the private barotropic arrays !! related to the open boundary conditions, !! set by set_up_BT_OBC. - type(MOM_domain_type), intent(inout) :: BT_Domain !< MOM_domain_type associated with wide arrays + type(MOM_domain_type), intent(inout) :: BT_Domain !< MOM_domain_type associated with wide arrays type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. integer, intent(in) :: halo !< The extra halo size to use here. logical, intent(in) :: use_BT_cont !< If true, use the BT_cont_types to calculate !! transports. - real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: Datu !< A fixed estimate of the face areas at u points. - real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: Datv !< A fixed estimate of the face areas at u points. + real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: Datu !< A fixed estimate of the face areas at u points + !! [H m ~> m2 or kg m-1]. + real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: Datv !< A fixed estimate of the face areas at v points + !! [H m ~> m2 or kg m-1]. type(local_BT_cont_u_type), dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: BTCL_u !< Structure of information used !! for a dynamic estimate of the face areas at !! u-points. @@ -2757,22 +2644,21 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, MS, halo, use_BT_co else if (Datu(I,j) > 0.0) BT_OBC%ubt_outer(I,j) = BT_OBC%uhbt(I,j) / Datu(I,j) endif - else ! This is assuming Flather as only other option - BT_OBC%Cg_u(I,j) = SQRT(GV%g_prime(1)*(0.5* & - (G%bathyT(i,j) + G%bathyT(i+1,j)))) + else ! This is assuming Flather as only other option if (GV%Boussinesq) then if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then - BT_OBC%H_u(I,j) = G%bathyT(i,j)*GV%m_to_H + eta(i,j) + BT_OBC%H_u(I,j) = G%bathyT(i,j)*GV%Z_to_H + eta(i,j) elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then - BT_OBC%H_u(I,j) = G%bathyT(i+1,j)*GV%m_to_H + eta(i+1,j) + BT_OBC%H_u(I,j) = G%bathyT(i+1,j)*GV%Z_to_H + eta(i+1,j) endif else if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then - BT_OBC%H_u(i,j) = eta(i,j) + BT_OBC%H_u(I,j) = eta(i,j) elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then - BT_OBC%H_u(i,j) = eta(i+1,j) + BT_OBC%H_u(I,j) = eta(i+1,j) endif endif + BT_OBC%Cg_u(I,j) = SQRT(GV%g_prime(1) * GV%H_to_Z*BT_OBC%H_u(i,j)) endif endif ; enddo ; enddo if (OBC%Flather_u_BCs_exist_globally) then @@ -2810,14 +2696,12 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, MS, halo, use_BT_co else if (Datv(i,J) > 0.0) BT_OBC%vbt_outer(i,J) = BT_OBC%vhbt(i,J) / Datv(i,J) endif - else ! This is assuming Flather as only other option - BT_OBC%Cg_v(i,J) = SQRT(GV%g_prime(1)*(0.5* & - (G%bathyT(i,j) + G%bathyT(i,j+1)))) + else ! This is assuming Flather as only other option if (GV%Boussinesq) then if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then - BT_OBC%H_v(i,J) = G%bathyT(i,j)*GV%m_to_H + eta(i,j) + BT_OBC%H_v(i,J) = G%bathyT(i,j)*GV%Z_to_H + eta(i,j) elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then - BT_OBC%H_v(i,J) = G%bathyT(i,j+1)*GV%m_to_H + eta(i,j+1) + BT_OBC%H_v(i,J) = G%bathyT(i,j+1)*GV%Z_to_H + eta(i,j+1) endif else if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then @@ -2826,6 +2710,7 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, MS, halo, use_BT_co BT_OBC%H_v(i,J) = eta(i,j+1) endif endif + BT_OBC%Cg_v(i,J) = SQRT(GV%g_prime(1) * GV%H_to_Z*BT_OBC%H_v(i,J)) endif endif ; enddo ; enddo if (OBC%Flather_v_BCs_exist_globally) then @@ -2877,43 +2762,42 @@ end subroutine destroy_BT_OBC !! that will drive the barotropic estimate of the free surface height toward the !! baroclinic estimate. subroutine btcalc(h, G, GV, CS, h_u, h_v, may_use_default, OBC) - 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(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2). - type(barotropic_CS), pointer :: CS !< The control structure returned by a previous - !! call to barotropic_init. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in), optional :: h_u !< The specified thicknesses at u-points, - !! in m or kg m-2. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in), optional :: h_v !< The specified thicknesses at v-points, - !! in m or kg m-2. - logical, intent(in), optional :: may_use_default !< An optional logical argument - !! to indicate that the default velocity point - !! thickesses may be used for this particular - !! calculation, even though the setting of - !! CS%hvel_scheme would usually require that h_u - !! and h_v be passed in. - type(ocean_OBC_type), pointer, optional :: OBC !< Open boundary control structure. + 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(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + type(barotropic_CS), pointer :: CS !< The control structure returned by a previous + !! call to barotropic_init. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + optional, intent(in) :: h_u !< The specified thicknesses at u-points [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + optional, intent(in) :: h_v !< The specified thicknesses at v-points [H ~> m or kg m-2]. + logical, optional, intent(in) :: may_use_default !< An optional logical argument + !! to indicate that the default velocity point + !! thicknesses may be used for this particular + !! calculation, even though the setting of + !! CS%hvel_scheme would usually require that h_u + !! and h_v be passed in. + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundary control structure. ! Local variables -! All of these variables are in the same units as h - usually m or kg m-2. - real :: hatutot(SZIB_(G)) ! The sum of the layer thicknesses - real :: hatvtot(SZI_(G)) ! interpolated to the u & v grid points. - real :: Ihatutot(SZIB_(G)) ! Ihatutot and Ihatvtot are the inverses - real :: Ihatvtot(SZI_(G)) ! of hatutot and hatvtot, both in H-1. - real :: h_arith ! The arithmetic mean thickness, in H. - real :: h_harm ! The harmonic mean thicknesses, in H. + real :: hatutot(SZIB_(G)) ! The sum of the layer thicknesses interpolated to u points [H ~> m or kg m-2]. + real :: hatvtot(SZI_(G)) ! The sum of the layer thicknesses interpolated to v points [H ~> m or kg m-2]. + real :: Ihatutot(SZIB_(G)) ! Ihatutot is the inverse of hatutot [H-1 ~> m-1 or m2 kg-1]. + real :: Ihatvtot(SZI_(G)) ! Ihatvtot is the inverse of hatvtot [H-1 ~> m-1 or m2 kg-1]. + real :: h_arith ! The arithmetic mean thickness [H ~> m or kg m-2]. + real :: h_harm ! The harmonic mean thicknesses [H ~> m or kg m-2]. real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected, in H. - real :: wt_arith ! The nondimensional weight for the arithmetic - ! mean thickness. The harmonic mean uses - ! a weight of (1 - wt_arith). + ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: wt_arith ! The nondimensional weight for the arithmetic mean thickness. + ! The harmonic mean uses a weight of (1 - wt_arith). real :: Rh ! A ratio of summed thicknesses, nondim. real :: e_u(SZIB_(G),SZK_(G)+1) ! The interface heights at u-velocity and - real :: e_v(SZI_(G),SZK_(G)+1) ! v-velocity points in H. - real :: D_shallow_u(SZI_(G)) ! The shallower of the adjacent depths in H. - real :: D_shallow_v(SZIB_(G))! The shallower of the adjacent depths in H. - real :: htot ! The sum of the layer thicknesses, in H. - real :: Ihtot ! The inverse of htot, in H-1. + real :: e_v(SZI_(G),SZK_(G)+1) ! v-velocity points [H ~> m or kg m-2]. + real :: D_shallow_u(SZI_(G)) ! The shallower of the adjacent depths [H ~> m or kg m-2]. + real :: D_shallow_v(SZIB_(G))! The shallower of the adjacent depths [H ~> m or kg m-2]. + real :: htot ! The sum of the layer thicknesses [H ~> m or kg m-2]. + real :: Ihtot ! The inverse of htot [H-1 ~> m-1 or m2 kg-1]. logical :: use_default, test_dflt, apply_OBCs integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, i, j, k @@ -2977,8 +2861,8 @@ subroutine btcalc(h, G, GV, CS, h_u, h_v, may_use_default, OBC) enddo ; enddo elseif (CS%hvel_scheme == HYBRID .or. use_default) then do I=is-1,ie - e_u(I,nz+1) = -0.5 * GV%m_to_H * (G%bathyT(i+1,j) + G%bathyT(i,j)) - D_shallow_u(I) = -GV%m_to_H * min(G%bathyT(i+1,j), G%bathyT(i,j)) + e_u(I,nz+1) = -0.5 * GV%Z_to_H * (G%bathyT(i+1,j) + G%bathyT(i,j)) + D_shallow_u(I) = -GV%Z_to_H * min(G%bathyT(i+1,j), G%bathyT(i,j)) hatutot(I) = 0.0 enddo do k=nz,1,-1 ; do I=is-1,ie @@ -3040,8 +2924,8 @@ subroutine btcalc(h, G, GV, CS, h_u, h_v, may_use_default, OBC) enddo ; enddo elseif (CS%hvel_scheme == HYBRID .or. use_default) then do i=is,ie - e_v(i,nz+1) = -0.5 * GV%m_to_H * (G%bathyT(i,j+1) + G%bathyT(i,j)) - D_shallow_v(I) = -GV%m_to_H * min(G%bathyT(i,j+1), G%bathyT(i,j)) + e_v(i,nz+1) = -0.5 * GV%Z_to_H * (G%bathyT(i,j+1) + G%bathyT(i,j)) + D_shallow_v(I) = -GV%Z_to_H * min(G%bathyT(i,j+1), G%bathyT(i,j)) hatvtot(I) = 0.0 enddo do k=nz,1,-1 ; do i=is,ie @@ -3147,8 +3031,11 @@ end subroutine btcalc !> The function find_uhbt determines the zonal transport for a given velocity. function find_uhbt(u, BTC) result(uhbt) - real, intent(in) :: u !< The local zonal velocity, in m s-1 - type(local_BT_cont_u_type), intent(in) :: BTC + real, intent(in) :: u !< The local zonal velocity [m s-1] + type(local_BT_cont_u_type), intent(in) :: BTC !< A structure containing various fields that + !! allow the barotropic transports to be calculated consistently + !! with the layers' continuity equations. + real :: uhbt !< The result if (u == 0.0) then @@ -3168,13 +3055,13 @@ end function find_uhbt !! velocity that is consistent with a given transport. function uhbt_to_ubt(uhbt, BTC, guess) result(ubt) real, intent(in) :: uhbt !< The barotropic zonal transport that should be inverted for, - !! in units of H m2 s-1. + !! [H m2 s-1 ~> m3 s-1 or kg s-1]. type(local_BT_cont_u_type), intent(in) :: BTC !< A structure containing various fields that allow the !! barotropic transports to be calculated consistently with the !! layers' continuity equations. real, optional, intent(in) :: guess !< A guess at what ubt will be. The result is not allowed !! to be dramatically larger than guess. - real :: ubt !< The result - The velocity that gives uhbt transport, in m s-1. + real :: ubt !< The result - The velocity that gives uhbt transport [m s-1]. ! Local variables real :: ubt_min, ubt_max, uhbt_err, derr_du @@ -3258,8 +3145,10 @@ end function uhbt_to_ubt !> The function find_vhbt determines the meridional transport for a given velocity. function find_vhbt(v, BTC) result(vhbt) - real, intent(in) :: v !< The local meridional velocity, in m s-1 - type(local_BT_cont_v_type), intent(in) :: BTC + real, intent(in) :: v !< The local meridional velocity [m s-1] + type(local_BT_cont_v_type), intent(in) :: BTC !< A structure containing various fields that + !! allow the barotropic transports to be calculated consistently + !! with the layers' continuity equations. real :: vhbt !< The result if (v == 0.0) then @@ -3279,13 +3168,13 @@ end function find_vhbt !! velocity that is consistent with a given transport. function vhbt_to_vbt(vhbt, BTC, guess) result(vbt) real, intent(in) :: vhbt !< The barotropic meridional transport that should be - !! inverted for, in units of H m2 s-1. + !! inverted for [H m2 s-1 ~> m3 s-1 or kg s-1]. type(local_BT_cont_v_type), intent(in) :: BTC !< A structure containing various fields that allow the !! barotropic transports to be calculated consistently !! with the layers' continuity equations. real, optional, intent(in) :: guess !< A guess at what vbt will be. The result is not allowed !! to be dramatically larger than guess. - real :: vbt !< The result - The velocity that gives vhbt transport, in m s-1. + real :: vbt !< The result - The velocity that gives vhbt transport [m s-1]. ! Local variables real :: vbt_min, vbt_max, vhbt_err, derr_dv @@ -3502,13 +3391,15 @@ subroutine adjust_local_BT_cont_types(ubt, uhbt, vbt, vhbt, BTCL_u, BTCL_v, & G, MS, halo) type(memory_size_type), intent(in) :: MS !< A type that describes the memory sizes of the argument arrays. real, dimension(SZIBW_(MS),SZJW_(MS)), & - intent(in) :: ubt !< The linearization zonal barotropic velocity in m s-1. + intent(in) :: ubt !< The linearization zonal barotropic velocity [m s-1]. real, dimension(SZIBW_(MS),SZJW_(MS)), & - intent(in) :: uhbt !< The linearization zonal barotropic transport in H m2 s-1. + intent(in) :: uhbt !< The linearization zonal barotropic transport + !! [H m2 s-1 ~> m3 s-1 or kg s-1]. real, dimension(SZIW_(MS),SZJBW_(MS)), & - intent(in) :: vbt !< The linearization meridional barotropic velocity in m s-1. + intent(in) :: vbt !< The linearization meridional barotropic velocity [m s-1]. real, dimension(SZIW_(MS),SZJBW_(MS)), & - intent(in) :: vhbt !< The linearization meridional barotropic transport in H m2 s-1. + intent(in) :: vhbt !< The linearization meridional barotropic transport + !! [H m2 s-1 ~> m3 s-1 or kg s-1]. type(local_BT_cont_u_type), dimension(SZIBW_(MS),SZJW_(MS)), & intent(out) :: BTCL_u !< A structure with the u information from BT_cont. type(local_BT_cont_v_type), dimension(SZIW_(MS),SZJBW_(MS)), & @@ -3592,15 +3483,18 @@ end subroutine adjust_local_BT_cont_types !> This subroutine uses the BTCL types to find typical or maximum face !! areas, which can then be used for finding wave speeds, etc. subroutine BT_cont_to_face_areas(BT_cont, Datu, Datv, G, MS, halo, maximize) - type(BT_cont_type), intent(inout) :: BT_cont !< The BT_cont_type input to the - !! barotropic solver. - type(memory_size_type), intent(in) :: MS !< A type that describes the memory - !! sizes of the argument arrays. - real, dimension(MS%isdw-1:MS%iedw,MS%jsdw:MS%jedw), intent(out) :: Datu - real, dimension(MS%isdw:MS%iedw,MS%jsdw-1:MS%jedw), intent(out) :: Datv - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - integer, optional, intent(in) :: halo !< The extra halo size to use here. - logical, optional, intent(in) :: maximize + type(BT_cont_type), intent(inout) :: BT_cont !< The BT_cont_type input to the + !! barotropic solver. + type(memory_size_type), intent(in) :: MS !< A type that describes the memory + !! sizes of the argument arrays. + real, dimension(MS%isdw-1:MS%iedw,MS%jsdw:MS%jedw), & + intent(out) :: Datu !< The effective zonal face area [H m ~> m2 or kg m-1]. + real, dimension(MS%isdw:MS%iedw,MS%jsdw-1:MS%jedw), & + intent(out) :: Datv !< The effective meridional face area [H m ~> m2 or kg m-1]. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + integer, optional, intent(in) :: halo !< The extra halo size to use here. + logical, optional, intent(in) :: maximize !< If present and true, find the + !! maximum face area for any velocity. ! Local variables logical :: find_max @@ -3629,8 +3523,10 @@ subroutine BT_cont_to_face_areas(BT_cont, Datu, Datv, G, MS, halo, maximize) end subroutine BT_cont_to_face_areas +!> Swap the values of two real variables subroutine swap(a,b) - real, intent(inout) :: a, b + real, intent(inout) :: a !< The first variable to be swapped. + real, intent(inout) :: b !< The second variable to be swapped. real :: tmp tmp = a ; a = b ; b = tmp end subroutine swap @@ -3638,27 +3534,24 @@ end subroutine swap !> This subroutine determines the open face areas of cells for calculating !! the barotropic transport. subroutine find_face_areas(Datu, Datv, G, GV, CS, MS, eta, halo, add_max) - type(memory_size_type), intent(in) :: MS -! (in) MS - A type that describes the memory sizes of the argument arrays. - real, dimension(MS%isdw-1:MS%iedw,MS%jsdw:MS%jedw), intent(out) :: Datu !< The open zonal face area, - !! in H m (m2 or kg m-1). - real, dimension(MS%isdw:MS%iedw,MS%jsdw-1:MS%jedw), intent(out) :: Datv !< The open meridional face area, - !! in H m (m2 or kg m-1). - 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(barotropic_CS), pointer :: CS !< The control structure returned by a previous - !! call to barotropic_init. - real, dimension(MS%isdw:MS%iedw,MS%jsdw:MS%jedw), optional, intent(in) :: eta !< The barotropic free surface - !! height anomaly or column mass - !! anomaly, in H (m or kg m-2). - integer, optional, intent(in) :: halo !< The halo size to use, default = 1. - real, optional, intent(in) :: add_max !< A value to add to the maximum - !! depth (used to overestimate the - !! external wave speed) in m. - + type(memory_size_type), intent(in) :: MS !< A type that describes the memory sizes of the argument arrays. + real, dimension(MS%isdw-1:MS%iedw,MS%jsdw:MS%jedw), & + intent(out) :: Datu !< The open zonal face area [H m ~> m2 or kg m-1]. + real, dimension(MS%isdw:MS%iedw,MS%jsdw-1:MS%jedw), & + intent(out) :: Datv !< The open meridional face area [H m ~> m2 or kg m-1]. + 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(barotropic_CS), pointer :: CS !< The control structure returned by a previous + !! call to barotropic_init. + real, dimension(MS%isdw:MS%iedw,MS%jsdw:MS%jedw), & + optional, intent(in) :: eta !< The barotropic free surface height anomaly + !! or column mass anomaly [H ~> m or kg m-2]. + integer, optional, intent(in) :: halo !< The halo size to use, default = 1. + real, optional, intent(in) :: add_max !< A value to add to the maximum depth (used + !! to overestimate the external wave speed) [Z ~> m]. ! Local variables - real :: H1, H2 ! Temporary total thicknesses, in m or kg m-2. + real :: H1, H2 ! Temporary total thicknesses [H ~> m or kg m-2]. integer :: i, j, is, ie, js, je, hs is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec hs = 1 ; if (present(halo)) hs = max(halo,0) @@ -3670,14 +3563,14 @@ subroutine find_face_areas(Datu, Datv, G, GV, CS, MS, eta, halo, add_max) if (GV%Boussinesq) then !$OMP do do j=js-hs,je+hs ; do I=is-1-hs,ie+hs - H1 = CS%bathyT(i,j)*GV%m_to_H + eta(i,j) ; H2 = CS%bathyT(i+1,j)*GV%m_to_H + eta(i+1,j) + H1 = CS%bathyT(i,j)*GV%Z_to_H + eta(i,j) ; H2 = CS%bathyT(i+1,j)*GV%Z_to_H + eta(i+1,j) Datu(I,j) = 0.0 ; if ((H1 > 0.0) .and. (H2 > 0.0)) & Datu(I,j) = CS%dy_Cu(I,j) * (2.0 * H1 * H2) / (H1 + H2) ! Datu(I,j) = CS%dy_Cu(I,j) * 0.5 * (H1 + H2) enddo ; enddo !$OMP do do J=js-1-hs,je+hs ; do i=is-hs,ie+hs - H1 = CS%bathyT(i,j)*GV%m_to_H + eta(i,j) ; H2 = CS%bathyT(i,j+1)*GV%m_to_H + eta(i,j+1) + H1 = CS%bathyT(i,j)*GV%Z_to_H + eta(i,j) ; H2 = CS%bathyT(i,j+1)*GV%Z_to_H + eta(i,j+1) Datv(i,J) = 0.0 ; if ((H1 > 0.0) .and. (H2 > 0.0)) & Datv(i,J) = CS%dx_Cv(i,J) * (2.0 * H1 * H2) / (H1 + H2) ! Datv(i,J) = CS%dy_v(i,J) * 0.5 * (H1 + H2) @@ -3701,13 +3594,13 @@ subroutine find_face_areas(Datu, Datv, G, GV, CS, MS, eta, halo, add_max) elseif (present(add_max)) then !$OMP do do j=js-hs,je+hs ; do I=is-1-hs,ie+hs - Datu(I,j) = CS%dy_Cu(I,j) * GV%m_to_H * & - (max(CS%bathyT(i+1,j), CS%bathyT(i,j)) + add_max) + Datu(I,j) = CS%dy_Cu(I,j) * GV%Z_to_H * & + (max(CS%bathyT(i+1,j), CS%bathyT(i,j)) + add_max) enddo ; enddo !$OMP do do J=js-1-hs,je+hs ; do i=is-hs,ie+hs - Datv(i,J) = CS%dx_Cv(i,J) * GV%m_to_H * & - (max(CS%bathyT(i,j+1), CS%bathyT(i,j)) + add_max) + Datv(i,J) = CS%dx_Cv(i,J) * GV%Z_to_H * & + (max(CS%bathyT(i,j+1), CS%bathyT(i,j)) + add_max) enddo ; enddo else !$OMP do @@ -3715,7 +3608,7 @@ subroutine find_face_areas(Datu, Datv, G, GV, CS, MS, eta, halo, add_max) Datu(I, j) = 0.0 !Would be "if (G%mask2dCu(I,j)>0.) &" is G was valid on BT domain if (CS%bathyT(i+1,j)+CS%bathyT(i,j)>0.) & - Datu(I,j) = 2.0*CS%dy_Cu(I,j) * GV%m_to_H * & + Datu(I,j) = 2.0*CS%dy_Cu(I,j) * GV%Z_to_H * & (CS%bathyT(i+1,j) * CS%bathyT(i,j)) / & (CS%bathyT(i+1,j) + CS%bathyT(i,j)) enddo ; enddo @@ -3724,7 +3617,7 @@ subroutine find_face_areas(Datu, Datv, G, GV, CS, MS, eta, halo, add_max) Datv(i, J) = 0.0 !Would be "if (G%mask2dCv(i,J)>0.) &" is G was valid on BT domain if (CS%bathyT(i,j+1)+CS%bathyT(i,j)>0.) & - Datv(i,J) = 2.0*CS%dx_Cv(i,J) * GV%m_to_H * & + Datv(i,J) = 2.0*CS%dx_Cv(i,J) * GV%Z_to_H * & (CS%bathyT(i,j+1) * CS%bathyT(i,j)) / & (CS%bathyT(i,j+1) + CS%bathyT(i,j)) enddo ; enddo @@ -3740,8 +3633,9 @@ end subroutine find_face_areas subroutine bt_mass_source(h, eta, set_cor, G, GV, 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. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2). - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: eta !< The free surface height that is to be corrected, in m. + 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) :: eta !< The free surface height that is to be + !! corrected [H ~> m or kg m-2]. logical, intent(in) :: set_cor !< A flag to indicate whether to set the corrective !! fluxes (and update the slowly varying part of eta_cor) !! (.true.) or whether to incrementally update the @@ -3750,13 +3644,13 @@ subroutine bt_mass_source(h, eta, set_cor, G, GV, CS) !! to barotropic_init. ! Local variables - real :: h_tot(SZI_(G)) ! The sum of the layer thicknesses, in H. + real :: h_tot(SZI_(G)) ! The sum of the layer thicknesses [H ~> m or kg m-2]. real :: eta_h(SZI_(G)) ! The free surface height determined from - ! the sum of the layer thicknesses, in H. + ! the sum of the layer thicknesses [H ~> m or kg m-2]. real :: d_eta ! The difference between estimates of the total - ! thicknesses, in H. + ! thicknesses [H ~> m or kg m-2]. real :: limit_dt ! The fractional mass-source limit divided by the - ! thermodynamic time step, in s-1. + ! thermodynamic time step [s-1]. integer :: is, ie, js, je, nz, i, j, k real, parameter :: frac_cor = 0.25 real, parameter :: slow_rate = 0.125 @@ -3771,7 +3665,7 @@ subroutine bt_mass_source(h, eta, set_cor, G, GV, CS) do j=js,je do i=is,ie ; h_tot(i) = h(i,j,1) ; enddo if (GV%Boussinesq) then - do i=is,ie ; eta_h(i) = h(i,j,1) - G%bathyT(i,j)*GV%m_to_H ; enddo + do i=is,ie ; eta_h(i) = h(i,j,1) - G%bathyT(i,j)*GV%Z_to_H ; enddo else do i=is,ie ; eta_h(i) = h(i,j,1) ; enddo endif @@ -3798,19 +3692,20 @@ end subroutine bt_mass_source !> barotropic_init initializes a number of time-invariant fields used in the !! barotropic calculation and initializes any barotropic fields that have not !! already been initialized. -subroutine barotropic_init(u, v, h, eta, Time, G, GV, param_file, diag, CS, & +subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, & restart_CS, calc_dtbt, BT_cont, tides_CSp) 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, in m s-1. + intent(in) :: u !< The zonal velocity [m s-1]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & - intent(in) :: v !< The meridional velocity, in m s-1. + intent(in) :: v !< The meridional velocity [m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2). + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G)), & - intent(in) :: eta !< Free surface height or column mass anomaly, in - !! m or kg m-2. + intent(in) :: eta !< Free surface height or column mass anomaly + !! [Z ~> m] or [H ~> kg m-2]. type(time_type), target, intent(in) :: Time !< The current model time. type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters. type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to regulate diagnostic @@ -3832,10 +3727,11 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, param_file, diag, CS, & #include "version_variable.h" ! Local variables character(len=40) :: mdl = "MOM_barotropic" ! This module's name. - real :: Datu(SZIBS_(G),SZJ_(G)), Datv(SZI_(G),SZJBS_(G)) - real :: gtot_estimate ! Summing GV%g_prime gives an upper-bound estimate for pbce. + real :: Datu(SZIBS_(G),SZJ_(G)) ! Zonal open face area [H m ~> m2 or kg m-1]. + real :: Datv(SZI_(G),SZJBS_(G)) ! Meridional open face area [H m ~> m2 or kg m-1]. + real :: gtot_estimate ! Summed GV%g_prime [m2 Z-1 s-2 ~> m s-2], to give an upper-bound estimate for pbce. real :: SSH_extra ! An estimate of how much higher SSH might get, for use - ! in calculating the safe external wave speed. + ! in calculating the safe external wave speed [Z ~> m]. real :: dtbt_input, dtbt_tmp real :: wave_drag_scale ! A scaling factor for the barotropic linear wave drag ! piston velocities. @@ -3844,6 +3740,8 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, param_file, diag, CS, & ! drag piston velocity. character(len=80) :: wave_drag_var ! The wave drag piston velocity variable ! name in wave_drag_file. + real :: uH_rescale ! A rescaling factor for thickness transports from the representation in + ! a restart file to the internal representation in this run. real, allocatable, dimension(:,:) :: lin_drag_h type(memory_size_type) :: MS type(group_pass_type) :: pass_static_data, pass_q_D_Cor @@ -4070,7 +3968,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, param_file, diag, CS, & "An estimate of how much higher SSH might get, for use \n"//& "in calculating the safe external wave speed. The \n"//& "default is the minimum of 10 m or 5% of MAXIMUM_DEPTH.", & - units="m", default=min(10.0,0.05*G%max_depth)) + units="m", default=min(10.0,0.05*G%max_depth*US%Z_to_m), scale=US%m_to_Z) call get_param(param_file, mdl, "DEBUG", CS%debug, & "If true, write out verbose debugging data.", & @@ -4168,7 +4066,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, param_file, diag, CS, & ! IareaT, IdxCu, and IdyCv need to be allocated with wide halos. ALLOC_(CS%IareaT(CS%isdw:CS%iedw,CS%jsdw:CS%jedw)) ; CS%IareaT(:,:) = 0.0 - ALLOC_(CS%bathyT(CS%isdw:CS%iedw,CS%jsdw:CS%jedw)) ; CS%bathyT(:,:) = GV%Angstrom_z !### Change to 0.0? + ALLOC_(CS%bathyT(CS%isdw:CS%iedw,CS%jsdw:CS%jedw)) ; CS%bathyT(:,:) = GV%Angstrom_m !### Change to 0.0? ALLOC_(CS%IdxCu(CS%isdw-1:CS%iedw,CS%jsdw:CS%jedw)) ; CS%IdxCu(:,:) = 0.0 ALLOC_(CS%IdyCv(CS%isdw:CS%iedw,CS%jsdw-1:CS%jedw)) ; CS%IdyCv(:,:) = 0.0 ALLOC_(CS%dy_Cu(CS%isdw-1:CS%iedw,CS%jsdw:CS%jedw)) ; CS%dy_Cu(:,:) = 0.0 @@ -4177,6 +4075,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, param_file, diag, CS, & CS%IareaT(i,j) = G%IareaT(i,j) CS%bathyT(i,j) = G%bathyT(i,j) enddo ; enddo + ! Note: G%IdxCu & G%IdyCv may be smaller than CS%IdxCu & CS%IdyCv, even without ! wide halos. do j=G%jsd,G%jed ; do I=G%IsdB,G%IedB @@ -4209,7 +4108,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, param_file, diag, CS, & CS%q_D(I,J) = 0.25 * G%CoriolisBu(I,J) * & ((G%areaT(i,j) + G%areaT(i+1,j+1)) + (G%areaT(i+1,j) + G%areaT(i,j+1))) / & ((G%areaT(i,j) * G%bathyT(i,j) + G%areaT(i+1,j+1) * G%bathyT(i+1,j+1)) + & - (G%areaT(i+1,j) * G%bathyT(i+1,j) + G%areaT(i,j+1) * G%bathyT(i,j+1))) + (G%areaT(i+1,j) * G%bathyT(i+1,j) + G%areaT(i,j+1) * G%bathyT(i,j+1)) ) else ! All four h points are masked out so q_D(I,J) will is meaningless CS%q_D(I,J) = 0. endif @@ -4255,7 +4154,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, param_file, diag, CS, & ! Estimate the maximum stable barotropic time step. gtot_estimate = 0.0 do k=1,G%ke ; gtot_estimate = gtot_estimate + GV%g_prime(K) ; enddo - call set_dtbt(G, GV, CS, gtot_est = gtot_estimate, SSH_add = SSH_extra) + call set_dtbt(G, GV, US, CS, gtot_est=gtot_estimate, SSH_add=SSH_extra) if (dtbt_input > 0.0) then CS%dtbt = dtbt_input @@ -4414,7 +4313,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, param_file, diag, CS, & do J=js-1,je ; do i=is,ie if (G%mask2dCv(i,J)>0.) then CS%IDatv(i,J) = G%mask2dCv(i,J) * 2.0 / (G%bathyT(i,j+1) + G%bathyT(i,j)) - else ! Both neighboring H points are masked out so IDatu(I,j) is meaningless + else ! Both neighboring H points are masked out so IDatv(I,j) is meaningless CS%IDatv(i,J) = 0. endif enddo ; enddo @@ -4441,6 +4340,10 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, param_file, diag, CS, & .NOT.query_initialized(CS%vhbt_IC,"vhbt_IC",restart_CS)) then do j=js,je ; do I=is-1,ie ; CS%uhbt_IC(I,j) = CS%ubtav(I,j) * Datu(I,j) ; enddo ; enddo do J=js-1,je ; do i=is,ie ; CS%vhbt_IC(i,J) = CS%vbtav(i,J) * Datv(i,J) ; enddo ; enddo + elseif ((GV%m_to_H_restart /= 0.0) .and. (GV%m_to_H_restart /= GV%m_to_H)) then + uH_rescale = GV%m_to_H / GV%m_to_H_restart + do j=js,je ; do I=is-1,ie ; CS%uhbt_IC(I,j) = uH_rescale * CS%uhbt_IC(I,j) ; enddo ; enddo + do J=js-1,je ; do i=is,ie ; CS%vhbt_IC(i,J) = uH_rescale * CS%vhbt_IC(I,j) ; enddo ; enddo endif call create_group_pass(pass_bt_hbt_btav, CS%ubt_IC, CS%vbt_IC, G%Domain) @@ -4525,7 +4428,7 @@ subroutine register_barotropic_restarts(HI, GV, param_file, CS, restart_CS) call register_restart_field(CS%vbt_IC, vd(3), .false., restart_CS) if (GV%Boussinesq) then - vd(2) = var_desc("uhbt_IC", "m3 s-1", & + vd(2) = var_desc("uhbt_IC", "m3 s-1", & longname="Next initial condition for the barotropic zonal transport", & hor_grid='u', z_grid='1') vd(3) = var_desc("vhbt_IC", "m3 s-1", & @@ -4547,4 +4450,62 @@ subroutine register_barotropic_restarts(HI, GV, param_file, CS, restart_CS) end subroutine register_barotropic_restarts +!> \namespace mom_barotropic +!! +!! By Robert Hallberg, April 1994 - January 2007 +!! +!! This program contains the subroutines that time steps the +!! linearized barotropic equations. btstep is used to actually +!! time step the barotropic equations, and contains most of the +!! substance of this module. +!! +!! btstep uses a forwards-backwards based scheme to time step +!! the barotropic equations, returning the layers' accelerations due +!! to the barotropic changes in the ocean state, the final free +!! surface height (or column mass), and the volume (or mass) fluxes +!! summed through the layers and averaged over the baroclinic time +!! step. As input, btstep takes the initial 3-D velocities, the +!! inital free surface height, the 3-D accelerations of the layers, +!! and the external forcing. Everything in btstep is cast in terms +!! of anomalies, so if everything is in balance, there is explicitly +!! no acceleration due to btstep. +!! +!! The spatial discretization of the continuity equation is second +!! order accurate. A flux conservative form is used to guarantee +!! global conservation of volume. The spatial discretization of the +!! momentum equation is second order accurate. The Coriolis force +!! is written in a form which does not contribute to the energy +!! tendency and which conserves linearized potential vorticity, f/D. +!! These terms are exactly removed from the baroclinic momentum +!! equations, so the linearization of vorticity advection will not +!! degrade the overall solution. +!! +!! btcalc calculates the fractional thickness of each layer at the +!! velocity points, for later use in calculating the barotropic +!! velocities and the averaged accelerations. Harmonic mean +!! thicknesses (i.e. 2*h_L*h_R/(h_L + h_R)) are used to avoid overly +!! strong weighting of overly thin layers. This may later be relaxed +!! to use thicknesses determined from the continuity equations. +!! +!! bt_mass_source determines the real mass sources for the +!! barotropic solver, along with the corrective pseudo-fluxes that +!! keep the barotropic and baroclinic estimates of the free surface +!! height close to each other. Given the layer thicknesses and the +!! free surface height that correspond to each other, it calculates +!! a corrective mass source that is added to the barotropic continuity* +!! equation, and optionally adjusts a slowly varying correction rate. +!! Newer algorithmic changes have deemphasized the need for this, but +!! it is still here to add net water sources to the barotropic solver.* +!! +!! barotropic_init allocates and initializes any barotropic arrays +!! that have not been read from a restart file, reads parameters from +!! the inputfile, and sets up diagnostic fields. +!! +!! barotropic_end deallocates anything allocated in barotropic_init +!! or register_barotropic_restarts. +!! +!! register_barotropic_restarts is used to indicate any fields that +!! are private to the barotropic solver that need to be included in +!! the restart files, and to ensure that they are read. + end module MOM_barotropic diff --git a/src/core/MOM_boundary_update.F90 b/src/core/MOM_boundary_update.F90 index 8d94bc12ea..ae78c6fd0d 100644 --- a/src/core/MOM_boundary_update.F90 +++ b/src/core/MOM_boundary_update.F90 @@ -13,6 +13,7 @@ module MOM_boundary_update use MOM_open_boundary, only : ocean_obc_type, update_OBC_segment_data use MOM_open_boundary, only : OBC_registry_type, file_OBC_CS use MOM_open_boundary, only : register_file_OBC, file_OBC_end +use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type use MOM_tracer_registry, only : tracer_registry_type use MOM_variables, only : thermo_var_ptrs @@ -32,24 +33,25 @@ module MOM_boundary_update public call_OBC_register, OBC_register_end public update_OBC_data +!> The control structure for the MOM_boundary_update module type, public :: update_OBC_CS ; private - logical :: use_files = .false. - logical :: use_Kelvin = .false. - logical :: use_tidal_bay = .false. - logical :: use_shelfwave = .false. - logical :: use_dyed_channel = .false. + logical :: use_files = .false. !< If true, use external files for the open boundary. + logical :: use_Kelvin = .false. !< If true, use the Kelvin wave open boundary. + logical :: use_tidal_bay = .false. !< If true, use the tidal_bay open boundary. + logical :: use_shelfwave = .false. !< If true, use the shelfwave open boundary. + logical :: use_dyed_channel = .false. !< If true, use the dyed channel open boundary. + !>@{ Pointers to the control structures for named OBC specifications type(file_OBC_CS), pointer :: file_OBC_CSp => NULL() type(Kelvin_OBC_CS), pointer :: Kelvin_OBC_CSp => NULL() type(tidal_bay_OBC_CS), pointer :: tidal_bay_OBC_CSp => NULL() type(shelfwave_OBC_CS), pointer :: shelfwave_OBC_CSp => NULL() type(dyed_channel_OBC_CS), pointer :: dyed_channel_OBC_CSp => NULL() + !!@} end type update_OBC_CS -integer :: id_clock_pass +integer :: id_clock_pass !< A CPU time clock ID -character(len=40) :: mdl = "MOM_boundary_update" ! This module's name. -! This include declares and sets the variable "version". -#include "version_variable.h" +! character(len=40) :: mdl = "MOM_boundary_update" ! This module's name. contains @@ -60,8 +62,11 @@ subroutine call_OBC_register(param_file, CS, OBC) type(param_file_type), intent(in) :: param_file !< Parameter file to parse type(update_OBC_CS), pointer :: CS !< Control structure for OBCs type(ocean_OBC_type), pointer :: OBC !< Open boundary structure - character(len=40) :: mdl = "MOM_boundary_update" ! This module's name. + ! Local variables + character(len=40) :: mdl = "MOM_boundary_update" ! This module's name. + ! This include declares and sets the variable "version". +# include "version_variable.h" if (associated(CS)) then call MOM_error(WARNING, "call_OBC_register called with an associated "// & "control structure.") @@ -105,14 +110,16 @@ subroutine call_OBC_register(param_file, CS, OBC) end subroutine call_OBC_register !> Calls appropriate routine to update the open boundary conditions. -subroutine update_OBC_data(OBC, G, GV, tv, h, CS, Time) +subroutine update_OBC_data(OBC, G, GV, US, tv, h, CS, Time) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< layer thickness + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< layer thicknesses [H ~> m or kg m-2] type(ocean_OBC_type), pointer :: OBC !< Open boundary structure type(update_OBC_CS), pointer :: CS !< Control structure for OBCs type(time_type), intent(in) :: Time !< Model time + ! Local variables logical :: read_OBC_eta = .false. logical :: read_OBC_uv = .false. @@ -133,7 +140,7 @@ subroutine update_OBC_data(OBC, G, GV, tv, h, CS, Time) if (CS%use_tidal_bay) & call tidal_bay_set_OBC_data(OBC, CS%tidal_bay_OBC_CSp, G, h, Time) if (CS%use_Kelvin) & - call Kelvin_set_OBC_data(OBC, CS%Kelvin_OBC_CSp, G, h, Time) + call Kelvin_set_OBC_data(OBC, CS%Kelvin_OBC_CSp, G, GV, US, h, Time) if (CS%use_shelfwave) & call shelfwave_set_OBC_data(OBC, CS%shelfwave_OBC_CSp, G, h, Time) if (CS%use_dyed_channel) & diff --git a/src/core/MOM_checksum_packages.F90 b/src/core/MOM_checksum_packages.F90 index f1f0ed9733..a71f4bab48 100644 --- a/src/core/MOM_checksum_packages.F90 +++ b/src/core/MOM_checksum_packages.F90 @@ -1,8 +1,9 @@ +!> Provides routines that do checksums of groups of MOM variables module MOM_checksum_packages ! This file is part of MOM6. See LICENSE.md for the license. -! This module provdes a several routines that do check-sums of groups +! This module provides several routines that do check-sums of groups ! of variables in the various dynamic solver routines. use MOM_debugging, only : hchksum, uvchksum @@ -17,6 +18,7 @@ module MOM_checksum_packages public MOM_state_chksum, MOM_thermo_chksum, MOM_accel_chksum public MOM_state_stats, MOM_surface_chksum +!> Write out checksums of the MOM6 state variables interface MOM_state_chksum module procedure MOM_state_chksum_5arg module procedure MOM_state_chksum_3arg @@ -24,42 +26,39 @@ module MOM_checksum_packages #include -type :: stats - private - real :: minimum = 1.E34, maximum = -1.E34, average = 0. +!> A type for storing statistica about a variable +type :: stats ; private + real :: minimum = 1.E34 !< The minimum value + real :: maximum = -1.E34 !< The maximum value + real :: average = 0. !< The average value end type stats contains ! ============================================================================= +!> Write out chksums for the model's basic state variables, including transports. subroutine MOM_state_chksum_5arg(mesg, u, v, h, uh, vh, G, GV, haloshift, symmetric) character(len=*), & intent(in) :: mesg !< A message that appears on the chksum lines. 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(SZIB_(G),SZJ_(G),SZK_(G)), & - intent(in) :: u !< The zonal velocity, in m s-1. + intent(in) :: u !< The zonal velocity [m s-1]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & - intent(in) :: v !< The meridional velocity, in m s-1. + intent(in) :: v !< The meridional velocity [m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2). + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & - intent(in) :: uh !< Volume flux through zonal faces = u*h*dy, m3 s-1. + intent(in) :: uh !< Volume flux through zonal faces = u*h*dy + !! [H m2 s-1 ~> m3 s-1 or kg s-1]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & - intent(in) :: vh !< Volume flux through meridional - !! faces = v*h*dx, in m3 s-1. - integer, optional, intent(in) :: haloshift - logical, optional, intent(in) :: symmetric -! This subroutine writes out chksums for the model's basic state variables. -! Arguments: mesg - A message that appears on the chksum lines. -! (in) u - Zonal velocity, in m s-1. -! (in) v - Meridional velocity, in m s-1. -! (in) h - Layer thickness, in m. -! (in) uh - Volume flux through zonal faces = u*h*dy, m3 s-1. -! (in) vh - Volume flux through meridional faces = v*h*dx, in m3 s-1. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. + intent(in) :: vh !< Volume flux through meridional faces = v*h*dx + !! [H m2 s-1 ~> m3 s-1 or kg s-1]. + integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0). + logical, optional, intent(in) :: symmetric !< If true, do checksums on the fully symmetric + !! computationoal domain. + integer :: is, ie, js, je, nz, hs logical :: sym is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -77,27 +76,21 @@ end subroutine MOM_state_chksum_5arg ! ============================================================================= +!> Write out chksums for the model's basic state variables. subroutine MOM_state_chksum_3arg(mesg, u, v, h, G, GV, haloshift, symmetric) character(len=*), intent(in) :: mesg !< A message that appears on the chksum lines. 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(SZIB_(G),SZJ_(G),SZK_(G)), & - intent(in) :: u !< Zonal velocity, in m s-1. + intent(in) :: u !< Zonal velocity [m s-1]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & - intent(in) :: v !< Meridional velocity, in m s-1. + intent(in) :: v !< Meridional velocity [m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2). - integer, optional, intent(in) :: haloshift - logical, optional, intent(in) :: symmetric -! This subroutine writes out chksums for the model's basic state variables. -! Arguments: mesg - A message that appears on the chksum lines. -! (in) u - Zonal velocity, in m s-1. -! (in) v - Meridional velocity, in m s-1. -! (in) h - Layer thickness, in m. -! (in) uh - Volume flux through zonal faces = u*h*dy, m3 s-1. -! (in) vh - Volume flux through meridional faces = v*h*dx, in m3 s-1. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0). + logical, optional, intent(in) :: symmetric !< If true, do checksums on the fully symmetric + !! computationoal domain. + integer :: is, ie, js, je, nz, hs logical :: sym is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -113,18 +106,14 @@ end subroutine MOM_state_chksum_3arg ! ============================================================================= +!> Write out chksums for the model's thermodynamic state variables. subroutine MOM_thermo_chksum(mesg, tv, G, haloshift) character(len=*), intent(in) :: mesg !< A message that appears on the chksum lines. type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various !! thermodynamic variables. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - integer, optional, intent(in) :: haloshift -! This subroutine writes out chksums for the model's thermodynamic state -! variables. -! Arguments: mesg - A message that appears on the chksum lines. -! (in) tv - A structure containing pointers to any thermodynamic -! fields that are in use. -! (in) G - The ocean's grid structure. + integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0). + integer :: is, ie, js, je, nz, hs is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke hs=1; if (present(haloshift)) hs=haloshift @@ -138,20 +127,17 @@ end subroutine MOM_thermo_chksum ! ============================================================================= +!> Write out chksums for the ocean surface variables. subroutine MOM_surface_chksum(mesg, sfc, G, haloshift, symmetric) character(len=*), intent(in) :: mesg !< A message that appears on the chksum lines. type(surface), intent(inout) :: sfc !< transparent ocean surface state - !! structure shared with the calling routine; + !! structure shared with the calling routine !! data in this structure is intent out. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - integer, optional, intent(in) :: haloshift - logical, optional, intent(in) :: symmetric -! This subroutine writes out chksums for the model's thermodynamic state -! variables. -! Arguments: mesg - A message that appears on the chksum lines. -! (in) tv - A structure containing pointers to any thermodynamic -! fields that are in use. -! (in) G - The ocean's grid structure. + integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0). + logical, optional, intent(in) :: symmetric !< If true, do checksums on the fully symmetric + !! computationoal domain. + integer :: hs logical :: sym @@ -171,6 +157,7 @@ end subroutine MOM_surface_chksum ! ============================================================================= +!> Write out chksums for the model's accelerations subroutine MOM_accel_chksum(mesg, CAu, CAv, PFu, PFv, diffu, diffv, G, GV, pbce, & u_accel_bt, v_accel_bt, symmetric) character(len=*), intent(in) :: mesg !< A message that appears on the chksum lines. @@ -178,57 +165,35 @@ subroutine MOM_accel_chksum(mesg, CAu, CAv, PFu, PFv, diffu, diffv, G, GV, pbce, type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & intent(in) :: CAu !< Zonal acceleration due to Coriolis - !! and momentum advection terms, in m s-2. + !! and momentum advection terms [m s-2]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & intent(in) :: CAv !< Meridional acceleration due to Coriolis - !! and momentum advection terms, in m s-2. + !! and momentum advection terms [m s-2]. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & intent(in) :: PFu !< Zonal acceleration due to pressure gradients - !! (equal to -dM/dx) in m s-2. + !! (equal to -dM/dx) [m s-2]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & intent(in) :: PFv !< Meridional acceleration due to pressure gradients - !! (equal to -dM/dy) in m s-2. + !! (equal to -dM/dy) [m s-2]. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & intent(in) :: diffu !< Zonal acceleration due to convergence of the - !! along-isopycnal stress tensor, in m s-2. + !! along-isopycnal stress tensor [m s-2]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & intent(in) :: diffv !< Meridional acceleration due to convergence of - !! the along-isopycnal stress tensor, in m s-2. + !! the along-isopycnal stress tensor [m s-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & optional, intent(in) :: pbce !< The baroclinic pressure anomaly in each layer - !! due to free surface height anomalies, in - !! m2 s-2 H-1. !! NULL. + !! due to free surface height anomalies + !! [m2 s-2 H-1 ~> m s-2 or m4 s-2 kg-1]. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & optional, intent(in) :: u_accel_bt !< The zonal acceleration from terms in the - !! barotropic solver,in m s-2. + !! barotropic solver [m s-2]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & optional, intent(in) :: v_accel_bt !< The meridional acceleration from terms in - !! the barotropic solver,in m s-2. - logical, optional, intent(in) :: symmetric - -! This subroutine writes out chksums for the model's accelerations. -! Arguments: mesg - A message that appears on the chksum lines. -! (in) CAu - Zonal acceleration due to Coriolis and momentum -! advection terms, in m s-2. -! (in) CAv - Meridional acceleration due to Coriolis and -! momentum advection terms, in m s-2. -! (in) PFu - Zonal acceleration due to pressure gradients -! (equal to -dM/dx) in m s-2. -! (in) PFv - Meridional acceleration due to pressure -! gradients (equal to -dM/dy) in m s-2. -! (in) diffu - Zonal acceleration due to convergence of the -! along-isopycnal stress tensor, in m s-2. -! (in) diffv - Meridional acceleration due to convergence of -! the along-isopycnal stress tensor, in m s-2. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) pbce - the baroclinic pressure anomaly in each layer -! due to free surface height anomalies, in m2 s-2 H-1. -! pbce points to a space with nz layers or NULL. -! (in) u_accel_bt - The zonal acceleration from terms in the barotropic -! solver, in m s-2. -! (in) v_accel_bt - The meridional acceleration from terms in the -! barotropic solver, in m s-2. + !! the barotropic solver [m s-2]. + logical, optional, intent(in) :: symmetric !< If true, do checksums on the fully symmetric + !! computationoal domain. + integer :: is, ie, js, je, nz logical :: sym @@ -249,35 +214,25 @@ end subroutine MOM_accel_chksum ! ============================================================================= +!> Monitor and write out statistics for the model's state variables. subroutine MOM_state_stats(mesg, u, v, h, Temp, Salt, G, allowChange, permitDiminishing) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. character(len=*), intent(in) :: mesg !< A message that appears on the chksum lines. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & - intent(in) :: u !< The zonal velocity, in m s-1. + intent(in) :: u !< The zonal velocity [m s-1]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & - intent(in) :: v !< The meridional velocity, in m s-1. + intent(in) :: v !< The meridional velocity [m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2). + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. real, pointer, dimension(:,:,:), & - intent(in) :: Temp !< Temperature in degree C. + intent(in) :: Temp !< Temperature [degC]. real, pointer, dimension(:,:,:), & - intent(in) :: Salt !< Salinity, in ppt. - - logical, optional, intent(in) :: allowChange !< do not flag an error - !! if the statistics change. - logical, optional, & - intent(in) :: permitDiminishing !< do not flag error + intent(in) :: Salt !< Salinity [ppt]. + logical, optional, intent(in) :: allowChange !< do not flag an error + !! if the statistics change. + logical, optional, intent(in) :: permitDiminishing !< do not flag error !!if the extrema are diminishing. -! This subroutine monitors statistics for the model's state variables. -! Arguments: mesg - A message that appears on the chksum lines. -! (in) u - Zonal velocity, in m s-1. -! (in) v - Meridional velocity, in m s-1. -! (in) h - Layer thickness, in m. -! (in) T - Temperature, in degree C. -! (in) S - Salinity, in ppt. -! (in) G - The ocean's grid structure. -! (in) allowChange - do not flag an error if the statistics change -! (in) permitDiminishing - do not flag an error if the extrema are diminishing + ! Local variables integer :: is, ie, js, je, nz, i, j, k real :: Vol, dV, Area, h_minimum type(stats) :: T, S, delT, delS diff --git a/src/core/MOM_continuity.F90 b/src/core/MOM_continuity.F90 index f4c3bb6d66..cf4dc09897 100644 --- a/src/core/MOM_continuity.F90 +++ b/src/core/MOM_continuity.F90 @@ -41,44 +41,62 @@ module MOM_continuity subroutine continuity(u, v, hin, h, uh, vh, dt, G, GV, CS, uhbt, vhbt, OBC, & visc_rem_u, visc_rem_v, u_cor, v_cor, & uhbt_aux, vhbt_aux, u_cor_aux, v_cor_aux, BT_cont) - type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure. - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Zonal velocity, in m/s. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< Meridional velocity, in m/s. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: hin !< Initial layer thickness, in m or kg/m2. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Final layer thickness, in m or kg/m2. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: uh !< Volume flux through zonal faces = - !! u*h*dy, in m3/s. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: vh !< Volume flux through meridional faces = - !! v*h*dx, in m3/s. - real, intent(in) :: dt !< Time increment, in s. - type(continuity_CS), pointer :: CS !< Control structure for mom_continuity. - real, dimension(SZIB_(G),SZJ_(G)), intent(in), optional :: uhbt !< The vertically summed volume - !! flux through zonal faces, in m3/s. - real, dimension(SZI_(G),SZJB_(G)), intent(in), optional :: vhbt !< The vertically summed volume - !! flux through meridional faces, in m3/s. - type(ocean_OBC_type), pointer, optional :: OBC !< Open boundaries control structure. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in), optional :: visc_rem_u !< Both the fraction of + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(in) :: u !< Zonal velocity [m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(in) :: v !< Meridional velocity [m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: hin !< Initial layer thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(inout) :: h !< Final layer thickness [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(out) :: uh !< Volume flux through zonal faces = + !! u*h*dy [H m2 s-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(out) :: vh !< Volume flux through meridional faces = + !! v*h*dx [H m2 s-1 ~> m3 s-1 or kg s-1]. + real, intent(in) :: dt !< Time increment [s]. + type(continuity_CS), pointer :: CS !< Control structure for mom_continuity. + real, dimension(SZIB_(G),SZJ_(G)), & + optional, intent(in) :: uhbt !< The vertically summed volume + !! flux through zonal faces [H m2 s-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G),SZJB_(G)), & + optional, intent(in) :: vhbt !< The vertically summed volume + !! flux through meridional faces [H m2 s-1 ~> m3 s-1 or kg s-1]. + type(ocean_OBC_type), & + optional, pointer :: OBC !< Open boundaries control structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + optional, intent(in) :: visc_rem_u !< Both the fraction of !! zonal momentum that remains after a time-step of viscosity, and the fraction of a time-step's !! worth of a barotropic acceleration that a layer experiences after viscosity is applied. !! Non-dimensional between 0 (at the bottom) and 1 (far above the bottom). - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in), optional :: visc_rem_v !< Both the fraction of + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + optional, intent(in) :: visc_rem_v !< Both the fraction of !! meridional momentum that remains after a time-step of viscosity, and the fraction of a time-step's !! worth of a barotropic acceleration that a layer experiences after viscosity is applied. !! Non-dimensional between 0 (at the bottom) and 1 (far above the bottom). - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out), optional :: u_cor !< The zonal velocities that - !! give uhbt as the depth-integrated transport, in m/s. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out), optional :: v_cor !< The meridional velocities that - !! give vhbt as the depth-integrated transport, in m/s. - real, dimension(SZIB_(G),SZJ_(G)), intent(in), optional :: uhbt_aux !< A second summed zonal - !! volume flux in m3/s. - real, dimension(SZI_(G),SZJB_(G)), intent(in), optional :: vhbt_aux !< A second summed meridional - !! volume flux in m3/s. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout), optional :: u_cor_aux !< The zonal velocities - !! that give uhbt_aux as the depth-integrated transport, in m/s. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout), optional :: v_cor_aux !< The meridional velocities - !! that give vhbt_aux as the depth-integrated transport, in m/s. - type(BT_cont_type), pointer, optional :: BT_cont !< A structure with elements + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + optional, intent(out) :: u_cor !< The zonal velocities that + !! give uhbt as the depth-integrated transport [m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + optional, intent(out) :: v_cor !< The meridional velocities that + !! give vhbt as the depth-integrated transport [m s-1]. + real, dimension(SZIB_(G),SZJ_(G)), & + optional, intent(in) :: uhbt_aux !< A second summed zonal + !! volume flux [H m2 s-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G),SZJB_(G)), & + optional, intent(in) :: vhbt_aux !< A second summed meridional + !! volume flux [H m2 s-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + optional, intent(inout) :: u_cor_aux !< The zonal velocities + !! that give uhbt_aux as the depth-integrated transport [m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + optional, intent(inout) :: v_cor_aux !< The meridional velocities + !! that give vhbt_aux as the depth-integrated transport [m s-1]. + type(BT_cont_type), & + optional, pointer :: BT_cont !< A structure with elements !! that describe the effective open face areas as a function of barotropic flow. if (present(visc_rem_u) .neqv. present(visc_rem_v)) call MOM_error(FATAL, & diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index cfab905b28..3f6b699b20 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -19,7 +19,9 @@ module MOM_continuity_PPM public continuity_PPM, continuity_PPM_init, continuity_PPM_end, continuity_PPM_stencil +!>@{ CPU time clock IDs integer :: id_clock_update, id_clock_correct +!!@} !> Control structure for mom_continuity_ppm type, public :: continuity_PPM_CS ; private @@ -33,15 +35,15 @@ module MOM_continuity_PPM !! of the higher order interpolation. real :: tol_eta !< The tolerance for free-surface height !! discrepancies between the barotropic solution and - !! the sum of the layer thicknesses, in m. + !! the sum of the layer thicknesses [H ~> m or kg m-2]. real :: tol_vel !< The tolerance for barotropic velocity !! discrepancies between the barotropic solution and - !! the sum of the layer thicknesses, in m s-1. + !! the sum of the layer thicknesses [m s-1]. real :: tol_eta_aux !< The tolerance for free-surface height !! discrepancies between the barotropic solution and !! the sum of the layer thicknesses when calculating - !! the auxiliary corrected velocities, in m. - real :: CFL_limit_adjust !< The maximum CFL of the adjusted velocities, ND. + !! the auxiliary corrected velocities [H ~> m or kg m-2]. + real :: CFL_limit_adjust !< The maximum CFL of the adjusted velocities [nondim] logical :: aggress_adjust !< If true, allow the adjusted velocities to have a !! relative CFL change up to 0.5. False by default. logical :: vol_CFL !< If true, use the ratio of the open face lengths @@ -61,10 +63,9 @@ module MOM_continuity_PPM !> A container for loop bounds type :: loop_bounds_type ; private - !>@{ - !! Loop bounds + !>@{ Loop bounds integer :: ish, ieh, jsh, jeh - !>@} + !!@} end type loop_bounds_type contains @@ -74,51 +75,71 @@ module MOM_continuity_PPM subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, CS, uhbt, vhbt, OBC, & visc_rem_u, visc_rem_v, u_cor, v_cor, & uhbt_aux, vhbt_aux, u_cor_aux, v_cor_aux, BT_cont) - ! In the following documentation, H is used for the units of thickness (usually m or kg m-2.) - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. - type(continuity_PPM_CS), pointer :: CS !< Module's control structure. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Zonal velocity, in m s-1. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< Meridional velocity, in m s-1. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: hin !< Initial layer thickness, in H. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Final layer thickness, in H. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: uh !< Zonal volume flux, - !! u*h*dy, H m2 s-1. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: vh !< Meridional volume flux, - !! v*h*dx, H m2 s-1. - real, intent(in) :: dt !< Time increment in s. - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. - real, dimension(SZIB_(G),SZJ_(G)), intent(in), optional :: uhbt - !< The summed volume flux through zonal faces, H m2 s-1. - real, dimension(SZI_(G),SZJB_(G)), intent(in), optional :: vhbt - !< The summed volume flux through meridional faces, H m2 s-1. - type(ocean_OBC_type), pointer, optional :: OBC !< Open boundaries control structure. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in), optional :: visc_rem_u - !< The fraction of zonal momentum originally in a layer that remains after a time-step - !! of viscosity, and the fraction of a time-step's worth of a barotropic acceleration that - !! a layer experiences after viscosity is applied. - !! Non-dimensional between 0 (at the bottom) and 1 (far above the bottom). - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in), optional :: visc_rem_v - !< The fraction of meridional momentum originally in a layer that remains after a time-step - !! of viscosity, and the fraction of a time-step's worth of a barotropic acceleration that - !! a layer experiences after viscosity is applied. - !! Non-dimensional between 0 (at the bottom) and 1 (far above the bottom). - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out), optional :: u_cor - !< The zonal velocities that give uhbt as the depth-integrated transport, in m s-1. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out), optional :: v_cor - !< The meridional velocities that give vhbt as the depth-integrated transport, in m s-1. - real, dimension(SZIB_(G),SZJ_(G)), intent(in), optional :: uhbt_aux - !< A second set of summed volume fluxes through zonal faces, in H m2 s-1. - real, dimension(SZI_(G),SZJB_(G)), intent(in), optional :: vhbt_aux - !< A second set of summed volume fluxes through meridional faces, in H m2 s-1. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out), optional :: u_cor_aux - !< The zonal velocities that give uhbt_aux as the depth-integrated transports, in m s-1. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out), optional :: v_cor_aux - !< The meridional velocities that give vhbt_aux as the depth-integrated transports, in m s-1. - type(BT_cont_type), pointer, optional :: BT_cont !< A structure with - !! elements that describe the effective open face areas as a function of barotropic flow. + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(continuity_PPM_CS), pointer :: CS !< Module's control structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(in) :: u !< Zonal velocity [m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(in) :: v !< Meridional velocity [m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: hin !< Initial layer thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(inout) :: h !< Final layer thickness [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(out) :: uh !< Zonal volume flux, u*h*dy [H m2 s-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(out) :: vh !< Meridional volume flux, v*h*dx [H m2 s-1 ~> m3 s-1 or kg s-1]. + real, intent(in) :: dt !< Time increment [s]. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. + real, dimension(SZIB_(G),SZJ_(G)), & + optional, intent(in) :: uhbt !< The summed volume flux through zonal faces + !! [H m2 s-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G),SZJB_(G)), & + optional, intent(in) :: vhbt !< The summed volume flux through meridional faces + !! [H m2 s-1 ~> m3 s-1 or kg s-1]. + type(ocean_OBC_type), & + optional, pointer :: OBC !< Open boundaries control structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + optional, intent(in) :: visc_rem_u + !< The fraction of zonal momentum originally + !! in a layer that remains after a time-step of viscosity, and the + !! fraction of a time-step's worth of a barotropic acceleration that + !! a layer experiences after viscosity is applied. + !! Non-dimensional between 0 (at the bottom) and 1 (far above the bottom). + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + optional, intent(in) :: visc_rem_v + !< The fraction of meridional momentum originally + !! in a layer that remains after a time-step of viscosity, and the + !! fraction of a time-step's worth of a barotropic acceleration that + !! a layer experiences after viscosity is applied. + !! Non-dimensional between 0 (at the bottom) and 1 (far above the bottom). + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + optional, intent(out) :: u_cor + !< The zonal velocities that give uhbt as the depth-integrated transport [m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + optional, intent(out) :: v_cor + !< The meridional velocities that give vhbt as the depth-integrated transport [m s-1]. + real, dimension(SZIB_(G),SZJ_(G)), & + optional, intent(in) :: uhbt_aux + !< A second set of summed volume fluxes through zonal faces + !! [H m2 s-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G),SZJB_(G)), & + optional, intent(in) :: vhbt_aux + !< A second set of summed volume fluxes through meridional faces + !! [H m2 s-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + optional, intent(out) :: u_cor_aux + !< The zonal velocities that give uhbt_aux as the depth-integrated + !! transports [m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + optional, intent(out) :: v_cor_aux + !< The meridional velocities that give vhbt_aux as the depth-integrated + !! transports [m s-1]. + type(BT_cont_type), optional, pointer :: BT_cont !< A structure with elements that describe + !! the effective open face areas as a function of barotropic flow. ! Local variables - real :: h_min ! The minimum layer thickness, in H. h_min could be 0. + real :: h_min ! The minimum layer thickness [H ~> m or kg m-2]. h_min could be 0. type(loop_bounds_type) :: LB integer :: is, ie, js, je, nz, stencil integer :: i, j, k @@ -126,7 +147,7 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, CS, uhbt, vhbt, OBC, logical :: x_first is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke - h_min = GV%Angstrom + h_min = GV%Angstrom_H if (.not.associated(CS)) call MOM_error(FATAL, & "MOM_continuity_PPM: Module must be initialized before it is used.") @@ -207,60 +228,68 @@ end subroutine continuity_PPM !> Calculates the mass or volume fluxes through the zonal faces, and other related quantities. subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, CS, LB, uhbt, OBC, & visc_rem_u, u_cor, uhbt_aux, u_cor_aux, BT_cont) - type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Zonal velocity, in m s-1. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_in !< Layer thickness used to - !! calculate fluxes, in H. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: uh !< Volume flux through zonal - !! faces = u*h*dy, H m2 s-1. - real, intent(in) :: dt !< Time increment in s. - type(continuity_PPM_CS), pointer :: CS !< This module's control structure. - type(loop_bounds_type), intent(in) :: LB !< Loop bounds structure. - type(ocean_OBC_type), pointer, optional :: OBC !< Open boundaries control structure. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in), optional :: visc_rem_u !< - !! The fraction of zonal momentum originally in a layer that remains after a time-step - !! of viscosity, and the fraction of a time-step's worth of a barotropic acceleration that - !! a layer experiences after viscosity is applied. - !! Non-dimensional between 0 (at the bottom) and 1 (far above the bottom). - real, dimension(SZIB_(G),SZJ_(G)), intent(in), optional :: uhbt - !< The summed volume flux through zonal faces, H m2 s-1. - real, dimension(SZIB_(G),SZJ_(G)), intent(in), optional :: uhbt_aux - !< A second set of summed volume fluxes through zonal faces, in H m2 s-1. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out), optional :: u_cor - !< The zonal velocitiess (u with a barotropic correction) - !! that give uhbt as the depth-integrated transport, m s-1. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out), optional :: u_cor_aux - !< The zonal velocities (u with a barotropic correction) - !! that give uhbt_aux as the depth-integrated transports, in m s-1. - type(BT_cont_type), pointer, optional :: BT_cont !< - !< A structure with elements that describe the effective - !! open face areas as a function of barotropic flow. + type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(in) :: u !< Zonal velocity [m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_in !< Layer thickness used to calculate fluxes [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(out) :: uh !< Volume flux through zonal faces = u*h*dy + !! [H m2 s-1 ~> m3 s-1 or kg s-1]. + real, intent(in) :: dt !< Time increment [s]. + type(continuity_PPM_CS), pointer :: CS !< This module's control structure. + type(loop_bounds_type), intent(in) :: LB !< Loop bounds structure. + type(ocean_OBC_type), & + optional, pointer :: OBC !< Open boundaries control structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + optional, intent(in) :: visc_rem_u + !< The fraction of zonal momentum originally in a layer that remains after a + !! time-step of viscosity, and the fraction of a time-step's worth of a barotropic + !! acceleration that a layer experiences after viscosity is applied. + !! Non-dimensional between 0 (at the bottom) and 1 (far above the bottom). + real, dimension(SZIB_(G),SZJ_(G)), & + optional, intent(in) :: uhbt !< The summed volume flux through zonal faces + !! [H m2 s-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZIB_(G),SZJ_(G)), & + optional, intent(in) :: uhbt_aux + !< A second set of summed volume fluxes through zonal faces [H m2 s-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + optional, intent(out) :: u_cor + !< The zonal velocitiess (u with a barotropic correction) + !! that give uhbt as the depth-integrated transport, m s-1. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + optional, intent(out) :: u_cor_aux + !< The zonal velocities (u with a barotropic correction) + !! that give uhbt_aux as the depth-integrated transports [m s-1]. + type(BT_cont_type), optional, pointer :: BT_cont !< A structure with elements that describe the + !! effective open face areas as a function of barotropic flow. + ! Local variables - real, dimension(SZIB_(G),SZK_(G)) :: duhdu ! Partial derivative of uh with u, in H m. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_L, h_R ! Left and right face thicknesses, in H. + real, dimension(SZIB_(G),SZK_(G)) :: duhdu ! Partial derivative of uh with u [H m ~> m2 or kg m-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_L, h_R ! Left and right face thicknesses [H ~> m or kg m-2]. real, dimension(SZIB_(G)) :: & - du, & ! Corrective barotropic change in the velocity, in m s-1. + du, & ! Corrective barotropic change in the velocity [m s-1]. du_min_CFL, & ! Min/max limits on du correction du_max_CFL, & ! to avoid CFL violations - duhdu_tot_0, & ! Summed partial derivative of uh with u, in H m. - uh_tot_0, & ! Summed transport with no barotropic correction in H m2 s-1. + duhdu_tot_0, & ! Summed partial derivative of uh with u [H m ~> m2 or kg m-1]. + uh_tot_0, & ! Summed transport with no barotropic correction [H m2 s-1 ~> m3 s-1 or kg s-1]. visc_rem_max ! The column maximum of visc_rem. logical, dimension(SZIB_(G)) :: do_I real, dimension(SZIB_(G),SZK_(G)) :: & visc_rem ! A 2-D copy of visc_rem_u or an array of 1's. - real, dimension(SZIB_(G)) :: FAuI ! A list of sums of zonal face areas, in H m. - real :: FA_u ! A sum of zonal face areas, in H m. + real, dimension(SZIB_(G)) :: FAuI ! A list of sums of zonal face areas [H m ~> m2 or kg m-1]. + real :: FA_u ! A sum of zonal face areas [H m ~> m2 or kg m-1]. real :: I_vrm ! 1.0 / visc_rem_max, nondim. real :: CFL_dt ! The maximum CFL ratio of the adjusted velocities divided by - ! the time step, in s-1. - real :: I_dt ! 1.0 / dt, in s-1. - real :: du_lim ! The velocity change that give a relative CFL of 1, in m s-1. - real :: dx_E, dx_W ! Effective x-grid spacings to the east and west, in m. + ! the time step [s-1]. + real :: I_dt ! 1.0 / dt [s-1]. + real :: du_lim ! The velocity change that give a relative CFL of 1 [m s-1]. + real :: dx_E, dx_W ! Effective x-grid spacings to the east and west [m]. integer :: i, j, k, ish, ieh, jsh, jeh, n, nz logical :: do_aux, local_specified_BC, use_visc_rem, set_BT_cont, any_simple_OBC logical :: local_Flather_OBC, local_open_BC, is_simple - type(OBC_segment_type), pointer :: segment + type(OBC_segment_type), pointer :: segment => NULL() do_aux = (present(uhbt_aux) .and. present(u_cor_aux)) use_visc_rem = present(visc_rem_u) @@ -269,8 +298,7 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, CS, LB, uhbt, OBC, & if (present(BT_cont)) set_BT_cont = (associated(BT_cont)) if (present(OBC)) then ; if (associated(OBC)) then local_specified_BC = OBC%specified_u_BCs_exist_globally - local_Flather_OBC = OBC%Flather_u_BCs_exist_globally .or. & - OBC%Flather_v_BCs_exist_globally + local_Flather_OBC = OBC%Flather_u_BCs_exist_globally local_open_BC = OBC%open_u_BCs_exist_globally endif ; endif ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh ; nz = G%ke @@ -289,7 +317,7 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, CS, LB, uhbt, OBC, & enddo ; enddo else call PPM_reconstruction_x(h_in(:,:,k), h_L(:,:,k), h_R(:,:,k), G, LB, & - 2.0*GV%Angstrom, CS%monotonic, simple_2nd=CS%simple_2nd, OBC=OBC) + 2.0*GV%Angstrom_H, CS%monotonic, simple_2nd=CS%simple_2nd, OBC=OBC) endif do I=ish-1,ieh ; visc_rem(I,k) = 1.0 ; enddo enddo @@ -496,7 +524,7 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, CS, LB, uhbt, OBC, & endif call cpu_clock_end(id_clock_correct) - if (set_BT_cont) then ; if (associated(BT_cont%h_u)) then + if (set_BT_cont) then ; if (allocated(BT_cont%h_u)) then if (present(u_cor)) then call zonal_face_thickness(u_cor, h_in, h_L, h_R, BT_cont%h_u, dt, G, LB, & CS%vol_CFL, CS%marginal_faces, visc_rem_u, OBC) @@ -512,32 +540,32 @@ end subroutine zonal_mass_flux subroutine zonal_flux_layer(u, h, h_L, h_R, uh, duhdu, visc_rem, dt, G, j, & ish, ieh, do_I, vol_CFL, OBC) type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. - real, dimension(SZIB_(G)), intent(in) :: u !< Zonal velocity, in m s-1. + real, dimension(SZIB_(G)), intent(in) :: u !< Zonal velocity [m s-1]. real, dimension(SZIB_(G)), intent(in) :: visc_rem !< Both the fraction of the - !! momentum originally in a layer that remains after a time-step - !! of viscosity, and the fraction of a time-step's worth of a barotropic - !! acceleration that a layer experiences after viscosity is applied. - !! Non-dimensional between 0 (at the bottom) and 1 (far above the bottom). - real, dimension(SZI_(G)), intent(in) :: h !< Layer thickness, in H. - real, dimension(SZI_(G)), intent(in) :: h_L !< Left thickness, in H. - real, dimension(SZI_(G)), intent(in) :: h_R !< Right thickness, in H. + !! momentum originally in a layer that remains after a time-step + !! of viscosity, and the fraction of a time-step's worth of a barotropic + !! acceleration that a layer experiences after viscosity is applied. + !! Non-dimensional between 0 (at the bottom) and 1 (far above the bottom). + real, dimension(SZI_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G)), intent(in) :: h_L !< Left thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G)), intent(in) :: h_R !< Right thickness [H ~> m or kg m-2]. real, dimension(SZIB_(G)), intent(inout) :: uh !< Zonal mass or volume - !! transport, in H m2 s-1. + !! transport [H m2 s-1 ~> m3 s-1 or kg s-1]. real, dimension(SZIB_(G)), intent(inout) :: duhdu !< Partial derivative of uh - !! with u, in H m. - real, intent(in) :: dt !< Time increment in s. + !! with u [H m ~> m2 or kg m-1]. + real, intent(in) :: dt !< Time increment [s]. integer, intent(in) :: j !< Spatial index. integer, intent(in) :: ish !< Start of index range. integer, intent(in) :: ieh !< End of index range. logical, dimension(SZIB_(G)), intent(in) :: do_I !< Which i values to work on. logical, intent(in) :: vol_CFL !< If true, rescale the !! ratio of face areas to the cell areas when estimating the CFL number. - type(ocean_OBC_type), pointer, optional :: OBC !< Open boundaries control structure. + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. ! Local variables - real :: CFL ! The CFL number based on the local velocity and grid spacing, ND. + real :: CFL ! The CFL number based on the local velocity and grid spacing [nondim] real :: curv_3 ! A measure of the thickness curvature over a grid length, ! with the same units as h_in. - real :: h_marg ! The marginal thickness of a flux, in H. + real :: h_marg ! The marginal thickness of a flux [H ~> m or kg m-2]. integer :: i logical :: local_open_BC @@ -588,38 +616,34 @@ end subroutine zonal_flux_layer subroutine zonal_face_thickness(u, h, h_L, h_R, h_u, dt, G, LB, vol_CFL, & marginal, visc_rem_u, OBC) type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Zonal velocity, in m s-1. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Zonal velocity [m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness used to - !! calculate fluxes, in H. + !! calculate fluxes [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_L !< Left thickness in the - !! reconstruction, in H. + !! reconstruction [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_R !< Right thickness in the - !! reconstruction, in H. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: h_u !< Thickness at zonal faces, - !! in H. - real, intent(in) :: dt !< Time increment in s. + !! reconstruction [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: h_u !< Thickness at zonal faces [H ~> m or kg m-2]. + real, intent(in) :: dt !< Time increment [s]. type(loop_bounds_type), intent(in) :: LB !< Loop bounds structure. - logical, intent(in) :: vol_CFL !< - !! If true, rescale the ratio of face areas to the cell - !! areas when estimating the CFL number. - logical, intent(in) :: marginal !< - !! If true, report the marginal face thicknesses; otherwise - !! report transport-averaged thicknesses. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in), optional :: visc_rem_u !< - !! Both the fraction of the momentum originally in a - !! layer that remains after a time-step of viscosity, - !! and the fraction of a time-step's worth of a - !! barotropic acceleration that a layer experiences - !! after viscosity is applied. Non-dimensional between - !! 0 (at the bottom) and 1 (far above the bottom). - type(ocean_OBC_type), pointer, optional :: OBC !< Open boundaries control structure. + logical, intent(in) :: vol_CFL !< If true, rescale the ratio + !! of face areas to the cell areas when estimating the CFL number. + logical, intent(in) :: marginal !< If true, report the + !! marginal face thicknesses; otherwise report transport-averaged thicknesses. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + optional, intent(in) :: visc_rem_u + !< Both the fraction of the momentum originally in a layer that remains after + !! a time-step of viscosity, and the fraction of a time-step's worth of a + !! barotropic acceleration that a layer experiences after viscosity is applied. + !! Non-dimensional between 0 (at the bottom) and 1 (far above the bottom). + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. ! Local variables - real :: CFL ! The CFL number based on the local velocity and grid spacing, ND. + real :: CFL ! The CFL number based on the local velocity and grid spacing [nondim] real :: curv_3 ! A measure of the thickness curvature over a grid length, ! with the same units as h_in. - real :: h_avg ! The average thickness of a flux, in H. - real :: h_marg ! The marginal thickness of a flux, in H. + real :: h_avg ! The average thickness of a flux [H ~> m or kg m-2]. + real :: h_marg ! The marginal thickness of a flux [H ~> m or kg m-2]. logical :: local_open_BC integer :: i, j, k, ish, ieh, jsh, jeh, nz, n ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh ; nz = G%ke @@ -650,7 +674,7 @@ subroutine zonal_face_thickness(u, h, h_L, h_R, h_u, dt, G, LB, vol_CFL, & if (marginal) then ; h_u(I,j,k) = h_marg else ; h_u(I,j,k) = h_avg ; endif - enddo; enddo ; enddo + enddo ; enddo ; enddo if (present(visc_rem_u)) then !$OMP parallel do default(shared) do k=1,nz ; do j=jsh,jeh ; do I=ish-1,ieh @@ -699,60 +723,59 @@ subroutine zonal_flux_adjust(u, h_in, h_L, h_R, uhbt, uh_tot_0, duhdu_tot_0, & du, du_max_CFL, du_min_CFL, dt, G, CS, visc_rem, & j, ish, ieh, do_I_in, full_precision, uh_3d, OBC) type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Zonal velocity, in m s-1. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Zonal velocity [m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_in !< Layer thickness used to - !! calculate fluxes, in H. + !! calculate fluxes [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_L !< Left thickness in the - !! reconstruction, in H. + !! reconstruction [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_R !< Right thickness in the - !! reconstruction, in H. - real, dimension(SZIB_(G),SZK_(G)), intent(in) :: visc_rem !< - !! Both the fraction of the momentum originally in a - !! layer that remains after a time-step of viscosity, - !! and the fraction of a time-step's worth of a - !! barotropic acceleration that a layer experiences - !! after viscosity is applied. Non-dimensional between - !! 0 (at the bottom) and 1 (far above the bottom). - real, dimension(SZIB_(G)), intent(in), optional :: uhbt !< - !! The summed volume flux through zonal faces, H m2 s-1. + !! reconstruction [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZK_(G)), intent(in) :: visc_rem !< Both the fraction of the + !! momentum originally in a layer that remains after a time-step of viscosity, and + !! the fraction of a time-step's worth of a barotropic acceleration that a layer + !! experiences after viscosity is applied. + !! Non-dimensional between 0 (at the bottom) and 1 (far above the bottom). + real, dimension(SZIB_(G)), optional, intent(in) :: uhbt !< The summed volume flux + !! through zonal faces [H m2 s-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZIB_(G)), intent(in) :: du_max_CFL !< Maximum acceptable - !! value of du, in m s-1. + !! value of du [m s-1]. real, dimension(SZIB_(G)), intent(in) :: du_min_CFL !< Minimum acceptable - !! value of du, in m s-1. - real, dimension(SZIB_(G)), intent(in) :: uh_tot_0 !< - !! The summed transport with 0 adjustment, in H m2 s-1. - real, dimension(SZIB_(G)), intent(in) :: duhdu_tot_0 !< - !! The partial derivative of du_err with du at 0 adjustment, in H m. + !! value of du [m s-1]. + real, dimension(SZIB_(G)), intent(in) :: uh_tot_0 !< The summed transport + !! with 0 adjustment [H m2 s-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZIB_(G)), intent(in) :: duhdu_tot_0 !< The partial derivative + !! of du_err with du at 0 adjustment [H m ~> m2 or kg m-1]. real, dimension(SZIB_(G)), intent(out) :: du !< - !! The barotropic velocity adjustment, in m s-1. - real, intent(in) :: dt !< Time increment in s. + !! The barotropic velocity adjustment [m s-1]. + real, intent(in) :: dt !< Time increment [s]. type(continuity_PPM_CS), pointer :: CS !< This module's control structure. integer, intent(in) :: j !< Spatial index. integer, intent(in) :: ish !< Start of index range. integer, intent(in) :: ieh !< End of index range. logical, dimension(SZIB_(G)), intent(in) :: do_I_in !< !! A logical flag indicating which I values to work on. - logical, intent(in), optional :: full_precision !< + logical, optional, intent(in) :: full_precision !< !! A flag indicating how carefully to iterate. The !! default is .true. (more accurate). - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout), optional :: uh_3d !< - !! Volume flux through zonal faces = u*h*dy, H m2 s-1. - type(ocean_OBC_type), pointer, optional :: OBC !< Open boundaries control structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), optional, intent(inout) :: uh_3d !< + !! Volume flux through zonal faces = u*h*dy [H m2 s-1 ~> m3 s-1 or kg s-1]. + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. ! Local variables real, dimension(SZIB_(G),SZK_(G)) :: & - uh_aux, & ! An auxiliary zonal volume flux, in H m s-1. - duhdu ! Partial derivative of uh with u, in H m. + uh_aux, & ! An auxiliary zonal volume flux [H m s-1 ~> m2 s-1 or kg m-1 s-1]. + duhdu ! Partial derivative of uh with u [H m ~> m2 or kg m-1]. real, dimension(SZIB_(G)) :: & - uh_err, & ! Difference between uhbt and the summed uh, in H m2 s-1. - uh_err_best, & ! The smallest value of uh_err found so far, in H m2 s-1. - u_new, & ! The velocity with the correction added, in m s-1. - duhdu_tot,&! Summed partial derivative of uh with u, in H m. + uh_err, & ! Difference between uhbt and the summed uh [H m2 s-1 ~> m3 s-1 or kg s-1]. + uh_err_best, & ! The smallest value of uh_err found so far [H m2 s-1 ~> m3 s-1 or kg s-1]. + u_new, & ! The velocity with the correction added [m s-1]. + duhdu_tot,&! Summed partial derivative of uh with u [H m ~> m2 or kg m-1]. du_min, & ! Min/max limits on du correction based on CFL limits - du_max ! and previous iterations, in m s-1. - real :: du_prev ! The previous value of du, in m s-1. - real :: ddu ! The change in du from the previous iteration, in m s-1. - real :: tol_eta ! The tolerance for the current iteration, in m. - real :: tol_vel ! The tolerance for velocity in the current iteration, m s-1. + du_max ! and previous iterations [m s-1]. + real :: du_prev ! The previous value of du [m s-1]. + real :: ddu ! The change in du from the previous iteration [m s-1]. + real :: tol_eta ! The tolerance for the current iteration [H ~> m or kg m-2]. + real :: tol_vel ! The tolerance for velocity in the current iteration [m s-1]. integer :: i, k, nz, itt, max_itts = 20 logical :: full_prec, domore, do_I(SZIB_(G)) @@ -863,61 +886,58 @@ subroutine set_zonal_BT_cont(u, h_in, h_L, h_R, BT_cont, uh_tot_0, duhdu_tot_0, du_max_CFL, du_min_CFL, dt, G, CS, visc_rem, & visc_rem_max, j, ish, ieh, do_I) type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Zonal velocity, in m s-1. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Zonal velocity [m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_in !< Layer thickness used to - !! calculate fluxes, in H. + !! calculate fluxes [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_L !< Left thickness in the - !! reconstruction, in H. + !! reconstruction [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_R !< Right thickness in the - !! reconstruction, in H. - type(BT_cont_type), intent(inout) :: BT_cont !< - !! A structure with elements that describe the effective - !! open face areas as a function of barotropic flow. - real, dimension(SZIB_(G)), intent(in) :: uh_tot_0 !< - !! The summed transport with 0 adjustment, in H m2 s-1. - real, dimension(SZIB_(G)), intent(in) :: duhdu_tot_0 !< - !! The partial derivative of du_err with du at 0 adjustment, in H m. + !! reconstruction [H ~> m or kg m-2]. + type(BT_cont_type), intent(inout) :: BT_cont !< A structure with elements + !! that describe the effective open face areas as a function of barotropic flow. + real, dimension(SZIB_(G)), intent(in) :: uh_tot_0 !< The summed transport + !! with 0 adjustment [H m2 s-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZIB_(G)), intent(in) :: duhdu_tot_0 !< The partial derivative + !! of du_err with du at 0 adjustment [H m ~> m2 or kg m-1]. real, dimension(SZIB_(G)), intent(in) :: du_max_CFL !< Maximum acceptable - !! value of du, in m s-1. + !! value of du [m s-1]. real, dimension(SZIB_(G)), intent(in) :: du_min_CFL !< Minimum acceptable - !! value of du, in m s-1. - real, intent(in) :: dt !< Time increment in s. + !! value of du [m s-1]. + real, intent(in) :: dt !< Time increment [s]. type(continuity_PPM_CS), pointer :: CS !< This module's control structure. - real, dimension(SZIB_(G),SZK_(G)), intent(in) :: visc_rem !< - !! Both the fraction of the momentum originally in a - !! layer that remains after a time-step of viscosity, - !! and the fraction of a time-step's worth of a - !! barotropic acceleration that a layer experiences - !! after viscosity is applied. Non-dimensional between - !! 0 (at the bottom) and 1 (far above the bottom). + real, dimension(SZIB_(G),SZK_(G)), intent(in) :: visc_rem !< Both the fraction of the + !! momentum originally in a layer that remains after a time-step of viscosity, and + !! the fraction of a time-step's worth of a barotropic acceleration that a layer + !! experiences after viscosity is applied. + !! Non-dimensional between 0 (at the bottom) and 1 (far above the bottom). real, dimension(SZIB_(G)), intent(in) :: visc_rem_max !< Maximum allowable visc_rem. integer, intent(in) :: j !< Spatial index. integer, intent(in) :: ish !< Start of index range. integer, intent(in) :: ieh !< End of index range. - logical, dimension(SZIB_(G)), intent(in) :: do_I !< - !! A logical flag indicating which I values to work on. + logical, dimension(SZIB_(G)), intent(in) :: do_I !< A logical flag indicating + !! which I values to work on. ! Local variables real, dimension(SZIB_(G)) :: & - du0, & ! The barotropic velocity increment that gives 0 transport, m s-1. + du0, & ! The barotropic velocity increment that gives 0 transport [m s-1]. duL, duR, & ! The barotropic velocity increments that give the westerly ! (duL) and easterly (duR) test velocities. zeros, & ! An array of full of 0's. - du_CFL, & ! The velocity increment that corresponds to CFL_min, in m s-1. + du_CFL, & ! The velocity increment that corresponds to CFL_min [m s-1]. u_L, u_R, & ! The westerly (u_L), easterly (u_R), and zero-barotropic - u_0, & ! transport (u_0) layer test velocities, in m s-1. + u_0, & ! transport (u_0) layer test velocities [m s-1]. FA_marg_L, & ! The effective layer marginal face areas with the westerly FA_marg_R, & ! (_L), easterly (_R), and zero-barotropic (_0) test - FA_marg_0, & ! velocities, in H m. + FA_marg_0, & ! velocities [H m ~> m2 or kg m-1]. uh_L, uh_R, & ! The layer transports with the westerly (_L), easterly (_R), - uh_0, & ! and zero-barotropic (_0) test velocities, in H m2 s-1. + uh_0, & ! and zero-barotropic (_0) test velocities [H m2 s-1 ~> m3 s-1 or kg s-1]. FAmt_L, FAmt_R, & ! The summed effective marginal face areas for the 3 - FAmt_0, & ! test velocities, in H m. + FAmt_0, & ! test velocities [H m ~> m2 or kg m-1]. uhtot_L, & ! The summed transport with the westerly (uhtot_L) and - uhtot_R ! and easterly (uhtot_R) test velocities, in H m2 s-1. - real :: FA_0 ! The effective face area with 0 barotropic transport, in m H. - real :: FA_avg ! The average effective face area, in m H, nominally given by + uhtot_R ! and easterly (uhtot_R) test velocities [H m2 s-1 ~> m3 s-1 or kg s-1]. + real :: FA_0 ! The effective face area with 0 barotropic transport [m H ~> m2 or kg m]. + real :: FA_avg ! The average effective face area [m H ~> m2 or kg m], nominally given by ! the realized transport divided by the barotropic velocity. - real :: visc_rem_lim ! The larger of visc_rem and min_visc_rem, ND. This + real :: visc_rem_lim ! The larger of visc_rem and min_visc_rem [nondim] This ! limiting is necessary to keep the inverse of visc_rem ! from leading to large CFL numbers. real :: min_visc_rem ! The smallest permitted value for visc_rem that is used @@ -925,8 +945,8 @@ subroutine set_zonal_BT_cont(u, h_in, h_L, h_R, BT_cont, uh_tot_0, duhdu_tot_0, ! flow direction. This is necessary to keep the inverse ! of visc_rem from leading to large CFL numbers. real :: CFL_min ! A minimal increment in the CFL to try to ensure that the - ! flow is truly upwind, ND. - real :: Idt ! The inverse of the time step, in s-1. + ! flow is truly upwind [nondim] + real :: Idt ! The inverse of the time step [s-1]. logical :: domore integer :: i, k, nz @@ -1031,64 +1051,63 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, CS, LB, vhbt, OBC, & visc_rem_v, v_cor, vhbt_aux, v_cor_aux, BT_cont) type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< Meridional velocity, in m s-1. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< Meridional velocity [m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_in !< Layer thickness used to - !! calculate fluxes, in H. + !! calculate fluxes [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: vh !< Volume flux through meridional - !! faces = v*h*dx, H m2 s-1. - real, intent(in) :: dt !< Time increment in s. + !! faces = v*h*dx [H m2 s-1 ~> m3 s-1 or kg s-1]. + real, intent(in) :: dt !< Time increment [s]. type(continuity_PPM_CS), pointer :: CS !< This module's control structure. type(loop_bounds_type), intent(in) :: LB !< Loop bounds structure. - type(ocean_OBC_type), pointer, optional :: OBC !< - !! This open boundary condition type specifies whether, where, - !! and what open boundary conditions are used. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in), optional :: visc_rem_v !< - !! Both the fraction of the momentum originally in a - !! layer that remains after a time-step of viscosity, - !! and the fraction of a time-step's worth of a - !! barotropic acceleration that a layer experiences - !! after viscosity is applied. Nondimensional between - !! 0 (at the bottom) and 1 (far above the bottom). - real, dimension(SZI_(G),SZJB_(G)), intent(in), optional :: vhbt !< - !! The summed volume flux through meridional faces, H m2 s-1. - real, dimension(SZI_(G),SZJB_(G)), intent(in), optional :: vhbt_aux !< - !! A second set of summed volume fluxes through meridional - !! faces, in H m2 s-1. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out), optional :: v_cor !< - !! The meridional velocitiess (v with a barotropic correction) - !! that give vhbt as the depth-integrated transport, m s-1. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out), optional :: v_cor_aux !< - !! The meridional velocities (v with a barotropic correction) - !! that give vhbt_aux as the depth-integrated transports, in m s-1. - type(BT_cont_type), pointer, optional :: BT_cont !< - !! A structure with elements that describe the effective + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundary condition type + !! specifies whether, where, and what open boundary conditions are used. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + optional, intent(in) :: visc_rem_v !< Both the fraction of the momentum + !! originally in a layer that remains after a time-step of viscosity, + !! and the fraction of a time-step's worth of a barotropic acceleration + !! that a layer experiences after viscosity is applied. Nondimensional between + !! 0 (at the bottom) and 1 (far above the bottom). + real, dimension(SZI_(G),SZJB_(G)), optional, intent(in) :: vhbt !< The summed volume flux through + !< meridional faces [H m2 s-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G),SZJB_(G)), optional, intent(in) :: vhbt_aux !< A second set of summed volume fluxes + !! through meridional faces [H m2 s-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + optional, intent(out) :: v_cor + !< The meridional velocitiess (v with a barotropic correction) + !! that give vhbt as the depth-integrated transport [m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + optional, intent(out) :: v_cor_aux + !< The meridional velocities (v with a barotropic correction) + !! that give vhbt_aux as the depth-integrated transports [m s-1]. + type(BT_cont_type), optional, pointer :: BT_cont !< A structure with elements that describe + !! the effective open face areas as a function of barotropic flow. ! Local variables real, dimension(SZI_(G),SZK_(G)) :: & - dvhdv ! Partial derivative of vh with v, in m2. + dvhdv ! Partial derivative of vh with v [H m ~> m2 or kg m-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & - h_L, h_R ! Left and right face thicknesses, in m. + h_L, h_R ! Left and right face thicknesses [H ~> m or kg m-2]. real, dimension(SZI_(G)) :: & - dv, & ! Corrective barotropic change in the velocity, in m s-1. + dv, & ! Corrective barotropic change in the velocity [m s-1]. dv_min_CFL, & ! Min/max limits on dv correction dv_max_CFL, & ! to avoid CFL violations - dvhdv_tot_0, & ! Summed partial derivative of vh with v, in H m. - vh_tot_0, & ! Summed transport with no barotropic correction in H m2 s-1. + dvhdv_tot_0, & ! Summed partial derivative of vh with v [H m ~> m2 or kg m-1]. + vh_tot_0, & ! Summed transport with no barotropic correction [H m2 s-1 ~> m3 s-1 or kg s-1]. visc_rem_max ! The column maximum of visc_rem. logical, dimension(SZI_(G)) :: do_I - real, dimension(SZI_(G)) :: FAvi ! A list of sums of meridional face areas, in H m. - real :: FA_v ! A sum of meridional face areas, in H m. + real, dimension(SZI_(G)) :: FAvi ! A list of sums of meridional face areas [H m ~> m2 or kg m-1]. + real :: FA_v ! A sum of meridional face areas [H m ~> m2 or kg m-1]. real, dimension(SZI_(G),SZK_(G)) :: & visc_rem ! A 2-D copy of visc_rem_v or an array of 1's. real :: I_vrm ! 1.0 / visc_rem_max, nondim. real :: CFL_dt ! The maximum CFL ratio of the adjusted velocities divided by - ! the time step, in s-1. - real :: I_dt ! 1.0 / dt, in s-1. - real :: dv_lim ! The velocity change that give a relative CFL of 1, in m s-1. - real :: dy_N, dy_S ! Effective y-grid spacings to the north and south, in m. + ! the time step [s-1]. + real :: I_dt ! 1.0 / dt [s-1]. + real :: dv_lim ! The velocity change that give a relative CFL of 1 [m s-1]. + real :: dy_N, dy_S ! Effective y-grid spacings to the north and south [m]. integer :: i, j, k, ish, ieh, jsh, jeh, n, nz logical :: do_aux, local_specified_BC, use_visc_rem, set_BT_cont, any_simple_OBC logical :: local_Flather_OBC, is_simple, local_open_BC - type(OBC_segment_type), pointer :: segment + type(OBC_segment_type), pointer :: segment => NULL() do_aux = (present(vhbt_aux) .and. present(v_cor_aux)) use_visc_rem = present(visc_rem_v) @@ -1097,8 +1116,7 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, CS, LB, vhbt, OBC, & if (present(BT_cont)) set_BT_cont = (associated(BT_cont)) if (present(OBC)) then ; if (associated(OBC)) then ; if (OBC%OBC_pe) then local_specified_BC = OBC%specified_v_BCs_exist_globally - local_Flather_OBC = OBC%Flather_u_BCs_exist_globally .or. & - OBC%Flather_v_BCs_exist_globally + local_Flather_OBC = OBC%Flather_v_BCs_exist_globally local_open_BC = OBC%open_v_BCs_exist_globally endif ; endif ; endif ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh ; nz = G%ke @@ -1117,7 +1135,7 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, CS, LB, vhbt, OBC, & enddo ; enddo else call PPM_reconstruction_y(h_in(:,:,k), h_L(:,:,k), h_R(:,:,k), G, LB, & - 2.0*GV%Angstrom, CS%monotonic, simple_2nd=CS%simple_2nd, OBC=OBC) + 2.0*GV%Angstrom_H, CS%monotonic, simple_2nd=CS%simple_2nd, OBC=OBC) endif do i=ish,ieh ; visc_rem(i,k) = 1.0 ; enddo enddo @@ -1323,7 +1341,7 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, CS, LB, vhbt, OBC, & endif call cpu_clock_end(id_clock_correct) - if (set_BT_cont) then ; if (associated(BT_cont%h_v)) then + if (set_BT_cont) then ; if (allocated(BT_cont%h_v)) then if (present(v_cor)) then call merid_face_thickness(v_cor, h_in, h_L, h_R, BT_cont%h_v, dt, G, LB, & CS%vol_CFL, CS%marginal_faces, visc_rem_v, OBC) @@ -1339,35 +1357,35 @@ end subroutine meridional_mass_flux subroutine merid_flux_layer(v, h, h_L, h_R, vh, dvhdv, visc_rem, dt, G, J, & ish, ieh, do_I, vol_CFL, OBC) type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. - real, dimension(SZI_(G)), intent(in) :: v !< Meridional velocity, in m s-1. + real, dimension(SZI_(G)), intent(in) :: v !< Meridional velocity [m s-1]. real, dimension(SZI_(G)), intent(in) :: visc_rem !< Both the fraction of the !! momentum originally in a layer that remains after a time-step !! of viscosity, and the fraction of a time-step's worth of a barotropic !! acceleration that a layer experiences after viscosity is applied. !! Non-dimensional between 0 (at the bottom) and 1 (far above the bottom). - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h !< Layer thickness used to - !! calculate fluxes, in H. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_L !< Left thickness in the - !! reconstruction, in H. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_R !< Right thickness in the - !! reconstruction, in H. - real, dimension(SZI_(G)), intent(inout) :: vh !< Meridional mass or volume - !! transport, in H m2 s-1. - real, dimension(SZI_(G)), intent(inout) :: dvhdv !< Partial derivative of vh - !! with v, in H m. - real, intent(in) :: dt !< Time increment in s. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h !< Layer thickness used to calculate fluxes, + !! [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_L !< Left thickness in the reconstruction + !! [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_R !< Right thickness in the reconstruction + !! [H ~> m or kg m-2]. + real, dimension(SZI_(G)), intent(inout) :: vh !< Meridional mass or volume transport + !! [H m2 s-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G)), intent(inout) :: dvhdv !< Partial derivative of vh with v + !! [H m ~> m2 or kg m-1]. + real, intent(in) :: dt !< Time increment [s]. integer, intent(in) :: j !< Spatial index. integer, intent(in) :: ish !< Start of index range. integer, intent(in) :: ieh !< End of index range. logical, dimension(SZI_(G)), intent(in) :: do_I !< Which i values to work on. logical, intent(in) :: vol_CFL !< If true, rescale the !! ratio of face areas to the cell areas when estimating the CFL number. - type(ocean_OBC_type), pointer, optional :: OBC !< Open boundaries control structure. + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. ! Local variables - real :: CFL ! The CFL number based on the local velocity and grid spacing, ND. + real :: CFL ! The CFL number based on the local velocity and grid spacing [nondim] real :: curv_3 ! A measure of the thickness curvature over a grid length, - ! with the same units as h_in. - real :: h_marg ! The marginal thickness of a flux, in m. + ! with the same units as h, i.e. [H ~> m or kg m-2]. + real :: h_marg ! The marginal thickness of a flux [H ~> m or kg m-2]. integer :: i logical :: local_open_BC @@ -1419,38 +1437,34 @@ end subroutine merid_flux_layer subroutine merid_face_thickness(v, h, h_L, h_R, h_v, dt, G, LB, vol_CFL, & marginal, visc_rem_v, OBC) type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< Meridional velocity, in m s-1. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness used to - !! calculate fluxes, in H. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_L !< Left thickness in the - !! reconstruction, in H. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_R !< Right thickness in the - !! reconstruction, in H. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< Meridional velocity [m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness used to calculate fluxes, + !! [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_L !< Left thickness in the reconstruction, + !! [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_R !< Right thickness in the reconstruction, + !! [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: h_v !< Thickness at meridional faces, - !! in H. - real, intent(in) :: dt !< Time increment in s. + !! [H ~> m or kg m-2]. + real, intent(in) :: dt !< Time increment [s]. type(loop_bounds_type), intent(in) :: LB !< Loop bounds structure. - logical, intent(in) :: vol_CFL !< - !! If true, rescale the ratio of face areas to the cell - !! areas when estimating the CFL number. - logical, intent(in) :: marginal !< - !! If true, report the marginal face thicknesses; otherwise - !! report transport-averaged thicknesses. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in), optional :: visc_rem_v !< - !! Both the fraction of the momentum originally in a - !! layer that remains after a time-step of viscosity, - !! and the fraction of a time-step's worth of a - !! barotropic acceleration that a layer experiences - !! after viscosity is applied. Non-dimensional between - !! 0 (at the bottom) and 1 (far above the bottom). - type(ocean_OBC_type), pointer, optional :: OBC !< Open boundaries control structure. + logical, intent(in) :: vol_CFL !< If true, rescale the ratio + !! of face areas to the cell areas when estimating the CFL number. + logical, intent(in) :: marginal !< If true, report the marginal + !! face thicknesses; otherwise report transport-averaged thicknesses. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), optional, intent(in) :: visc_rem_v !< Both the fraction + !! of the momentum originally in a layer that remains after a time-step of + !! viscosity, and the fraction of a time-step's worth of a barotropic + !! acceleration that a layer experiences after viscosity is applied. + !! Non-dimensional between 0 (at the bottom) and 1 (far above the bottom). + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. ! Local variables - real :: CFL ! The CFL number based on the local velocity and grid spacing, ND. + real :: CFL ! The CFL number based on the local velocity and grid spacing [nondim] real :: curv_3 ! A measure of the thickness curvature over a grid length, ! with the same units as h_in. - real :: h_avg ! The average thickness of a flux, in H. - real :: h_marg ! The marginal thickness of a flux, in H. + real :: h_avg ! The average thickness of a flux [H ~> m or kg m-2]. + real :: h_marg ! The marginal thickness of a flux [H ~> m or kg m-2]. logical :: local_open_BC integer :: i, j, k, ish, ieh, jsh, jeh, n, nz ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh ; nz = G%ke @@ -1530,61 +1544,59 @@ end subroutine merid_face_thickness subroutine meridional_flux_adjust(v, h_in, h_L, h_R, vhbt, vh_tot_0, dvhdv_tot_0, & dv, dv_max_CFL, dv_min_CFL, dt, G, CS, visc_rem, & j, ish, ieh, do_I_in, full_precision, vh_3d, OBC) - type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< Meridional velocity, in m s-1. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_in !< Layer thickness used to - !! calculate fluxes, in H. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_L !< Left thickness in the - !! reconstruction, in H. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_R !< Right thickness in the - !! reconstruction, in H. - real, dimension(SZI_(G),SZK_(G)), intent(in) :: visc_rem !< - !! Both the fraction of the momentum originally in a - !! layer that remains after a time-step of viscosity, - !! and the fraction of a time-step's worth of a - !! barotropic acceleration that a layer experiences - !! after viscosity is applied. Non-dimensional between - !! 0 (at the bottom) and 1 (far above the bottom). - real, dimension(SZI_(G)), intent(in), optional :: vhbt !< - !! The summed volume flux through meridional faces, H m2 s-1. - real, dimension(SZI_(G)), intent(in) :: dv_max_CFL !< Maximum acceptable value - !! of dv, in m s-1. - real, dimension(SZI_(G)), intent(in) :: dv_min_CFL !< Minimum acceptable value - !! of dv, in m s-1. - real, dimension(SZI_(G)), intent(in) :: vh_tot_0 !< - !! The summed transport with 0 adjustment, in H m2 s-1. - real, dimension(SZI_(G)), intent(in) :: dvhdv_tot_0 !< - !! The partial derivative of dv_err with dv at 0 adjustment, in H m. - real, dimension(SZI_(G)), intent(out) :: dv !< - !! The barotropic velocity adjustment, in m s-1. - real, intent(in) :: dt !< Time increment in s. - type(continuity_PPM_CS), pointer :: CS !< This module's control structure. - integer, intent(in) :: j !< Spatial index. - integer, intent(in) :: ish !< Start of index range. - integer, intent(in) :: ieh !< End of index range. - logical, dimension(SZI_(G)), intent(in) :: do_I_in !< - !! A logical flag indicating which I values to work on. - logical, intent(in), optional :: full_precision !< - !! full_precision - A flag indicating how carefully to iterate. The - !! default is .true. (more accurate). - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout), optional :: vh_3d !< - !! Volume flux through meridional faces = v*h*dx, H m2 s-1. - type(ocean_OBC_type), pointer, optional :: OBC !< Open boundaries control structure. + type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(in) :: v !< Meridional velocity [m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_in !< Layer thickness used to calculate fluxes [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)),& + intent(in) :: h_L !< Left thickness in the reconstruction [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_R !< Right thickness in the reconstruction [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZK_(G)), intent(in) :: visc_rem + !< Both the fraction of the momentum originally + !! in a layer that remains after a time-step of viscosity, and the + !! fraction of a time-step's worth of a barotropic acceleration that + !! a layer experiences after viscosity is applied. Non-dimensional + !! between 0 (at the bottom) and 1 (far above the bottom). + real, dimension(SZI_(G)), & + optional, intent(in) :: vhbt !< The summed volume flux through meridional faces + !! [H m2 s-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G)), intent(in) :: dv_max_CFL !< Maximum acceptable value of dv [m s-1]. + real, dimension(SZI_(G)), intent(in) :: dv_min_CFL !< Minimum acceptable value of dv [m s-1]. + real, dimension(SZI_(G)), intent(in) :: vh_tot_0 !< The summed transport with 0 adjustment + !! [H m2 s-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G)), intent(in) :: dvhdv_tot_0 !< The partial derivative of dv_err with + !! dv at 0 adjustment [H m ~> m2 or kg m-1]. + real, dimension(SZI_(G)), intent(out) :: dv !< The barotropic velocity adjustment [m s-1]. + real, intent(in) :: dt !< Time increment [s]. + type(continuity_PPM_CS), pointer :: CS !< This module's control structure. + integer, intent(in) :: j !< Spatial index. + integer, intent(in) :: ish !< Start of index range. + integer, intent(in) :: ieh !< End of index range. + logical, dimension(SZI_(G)), & + intent(in) :: do_I_in !< A flag indicating which I values to work on. + logical, optional, intent(in) :: full_precision !< A flag indicating how carefully to + !! iterate. The default is .true. (more accurate). + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + optional, intent(inout) :: vh_3d !< Volume flux through meridional + !! faces = v*h*dx [H m2 s-1 ~> m3 s-1 or kg s-1]. + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. ! Local variables real, dimension(SZI_(G),SZK_(G)) :: & - vh_aux, & ! An auxiliary meridional volume flux, in H m s-1. - dvhdv ! Partial derivative of vh with v, in H m. + vh_aux, & ! An auxiliary meridional volume flux [H m s-1 ~> m2 s-1 or kg m-1 s-1]. + dvhdv ! Partial derivative of vh with v [H m ~> m2 or kg m-1]. real, dimension(SZI_(G)) :: & - vh_err, & ! Difference between vhbt and the summed vh, in H m2 s-1. - vh_err_best, & ! The smallest value of vh_err found so far, in H m2 s-1. - v_new, & ! The velocity with the correction added, in m s-1. - dvhdv_tot,&! Summed partial derivative of vh with u, in H m. + vh_err, & ! Difference between vhbt and the summed vh [H m2 s-1 ~> m3 s-1 or kg s-1]. + vh_err_best, & ! The smallest value of vh_err found so far [H m2 s-1 ~> m3 s-1 or kg s-1]. + v_new, & ! The velocity with the correction added [m s-1]. + dvhdv_tot,&! Summed partial derivative of vh with u [H m ~> m2 or kg m-1]. dv_min, & ! Min/max limits on dv correction based on CFL limits - dv_max ! and previous iterations, in m s-1. - real :: dv_prev ! The previous value of dv, in m s-1. - real :: ddv ! The change in dv from the previous iteration, in m s-1. - real :: tol_eta ! The tolerance for the current iteration, in m. - real :: tol_vel ! The tolerance for velocity in the current iteration, m s-1. + dv_max ! and previous iterations [m s-1]. + real :: dv_prev ! The previous value of dv [m s-1]. + real :: ddv ! The change in dv from the previous iteration [m s-1]. + real :: tol_eta ! The tolerance for the current iteration [H ~> m or kg m-2]. + real :: tol_vel ! The tolerance for velocity in the current iteration [m s-1]. integer :: i, k, nz, itt, max_itts = 20 logical :: full_prec, domore, do_I(SZI_(G)) @@ -1695,61 +1707,56 @@ subroutine set_merid_BT_cont(v, h_in, h_L, h_R, BT_cont, vh_tot_0, dvhdv_tot_0, dv_max_CFL, dv_min_CFL, dt, G, CS, visc_rem, & visc_rem_max, j, ish, ieh, do_I) type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< Meridional velocity, in m s-1. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_in !< Layer thickness used to - !! calculate fluxes, in H. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_L !< Left thickness in the - !! reconstruction, in H. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_R !< Right thickness in the - !! reconstruction, in H. - type(BT_cont_type), intent(inout) :: BT_cont !< - !! A structure with elements that describe the effective - !! open face areas as a function of barotropic flow. - real, dimension(SZI_(G)), intent(in) :: vh_tot_0 !< - !! The summed transport with 0 adjustment, in H m2 s-1. - real, dimension(SZI_(G)), intent(in) :: dvhdv_tot_0 !< - !! The partial derivative of du_err with dv at 0 adjustment, in H m. - real, dimension(SZI_(G)), intent(in) :: dv_max_CFL !< Maximum acceptable value - !! of dv, in m s-1. - real, dimension(SZI_(G)), intent(in) :: dv_min_CFL !< Minimum acceptable value - !! of dv, in m s-1. - real, intent(in) :: dt !< Time increment in s. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< Meridional velocity [m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_in !< Layer thickness used to calculate fluxes, + !! [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_L !< Left thickness in the reconstruction, + !! [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_R !< Right thickness in the reconstruction, + !! [H ~> m or kg m-2]. + type(BT_cont_type), intent(inout) :: BT_cont !< A structure with elements + !! that describe the effective open face areas as a function of barotropic flow. + real, dimension(SZI_(G)), intent(in) :: vh_tot_0 !< The summed transport + !! with 0 adjustment [H m2 s-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G)), intent(in) :: dvhdv_tot_0 !< The partial derivative + !! of du_err with dv at 0 adjustment [H m ~> m2 or kg m-1]. + real, dimension(SZI_(G)), intent(in) :: dv_max_CFL !< Maximum acceptable value of dv [m s-1]. + real, dimension(SZI_(G)), intent(in) :: dv_min_CFL !< Minimum acceptable value of dv [m s-1]. + real, intent(in) :: dt !< Time increment [s]. type(continuity_PPM_CS), pointer :: CS !< This module's control structure. - real, dimension(SZI_(G),SZK_(G)), intent(in) :: visc_rem !< - !! Both the fraction of the momentum originally in a - !! layer that remains after a time-step of viscosity, - !! and the fraction of a time-step's worth of a - !! barotropic acceleration that a layer experiences - !! after viscosity is applied. Non-dimensional between - !! 0 (at the bottom) and 1 (far above the bottom). + real, dimension(SZI_(G),SZK_(G)), intent(in) :: visc_rem !< Both the fraction of the + !! momentum originally in a layer that remains after a time-step + !! of viscosity, and the fraction of a time-step's worth of a barotropic + !! acceleration that a layer experiences after viscosity is applied. + !! Non-dimensional between 0 (at the bottom) and 1 (far above the bottom). real, dimension(SZI_(G)), intent(in) :: visc_rem_max !< Maximum allowable visc_rem. integer, intent(in) :: j !< Spatial index. integer, intent(in) :: ish !< Start of index range. integer, intent(in) :: ieh !< End of index range. - logical, dimension(SZI_(G)), intent(in) :: do_I !< - !! A logical flag indicating which I values to work on. + logical, dimension(SZI_(G)), intent(in) :: do_I !< A logical flag indicating + !! which I values to work on. ! Local variables real, dimension(SZI_(G)) :: & - dv0, & ! The barotropic velocity increment that gives 0 transport, m s-1. + dv0, & ! The barotropic velocity increment that gives 0 transport [m s-1]. dvL, dvR, & ! The barotropic velocity increments that give the southerly ! (dvL) and northerly (dvR) test velocities. zeros, & ! An array of full of 0's. - dv_CFL, & ! The velocity increment that corresponds to CFL_min, in m s-1. + dv_CFL, & ! The velocity increment that corresponds to CFL_min [m s-1]. v_L, v_R, & ! The southerly (v_L), northerly (v_R), and zero-barotropic - v_0, & ! transport (v_0) layer test velocities, in m s-1. + v_0, & ! transport (v_0) layer test velocities [m s-1]. FA_marg_L, & ! The effective layer marginal face areas with the southerly FA_marg_R, & ! (_L), northerly (_R), and zero-barotropic (_0) test - FA_marg_0, & ! velocities, in H m. + FA_marg_0, & ! velocities [H m ~> m2 or kg m-1]. vh_L, vh_R, & ! The layer transports with the southerly (_L), northerly (_R) - vh_0, & ! and zero-barotropic (_0) test velocities, in H m2 s-1. + vh_0, & ! and zero-barotropic (_0) test velocities [H m2 s-1 ~> m3 s-1 or kg s-1]. FAmt_L, FAmt_R, & ! The summed effective marginal face areas for the 3 - FAmt_0, & ! test velocities, in H m. + FAmt_0, & ! test velocities [H m ~> m2 or kg m-1]. vhtot_L, & ! The summed transport with the southerly (vhtot_L) and - vhtot_R ! and northerly (vhtot_R) test velocities, in H m2 s-1. - real :: FA_0 ! The effective face area with 0 barotropic transport, in m H. - real :: FA_avg ! The average effective face area, in m H, nominally given by + vhtot_R ! and northerly (vhtot_R) test velocities [H m2 s-1 ~> m3 s-1 or kg s-1]. + real :: FA_0 ! The effective face area with 0 barotropic transport [H m ~> m2 or kg m-1]. + real :: FA_avg ! The average effective face area [H m ~> m2 or kg m-1], nominally given by ! the realized transport divided by the barotropic velocity. - real :: visc_rem_lim ! The larger of visc_rem and min_visc_rem, ND. This + real :: visc_rem_lim ! The larger of visc_rem and min_visc_rem [nondim] This ! limiting is necessary to keep the inverse of visc_rem ! from leading to large CFL numbers. real :: min_visc_rem ! The smallest permitted value for visc_rem that is used @@ -1757,8 +1764,8 @@ subroutine set_merid_BT_cont(v, h_in, h_L, h_R, BT_cont, vh_tot_0, dvhdv_tot_0, ! flow direction. This is necessary to keep the inverse ! of visc_rem from leading to large CFL numbers. real :: CFL_min ! A minimal increment in the CFL to try to ensure that the - ! flow is truly upwind, ND. - real :: Idt ! The inverse of the time step, in s-1. + ! flow is truly upwind [nondim] + real :: Idt ! The inverse of the time step [s-1]. logical :: domore integer :: i, k, nz @@ -1859,11 +1866,11 @@ end subroutine set_merid_BT_cont !> Calculates left/right edge values for PPM reconstruction. subroutine PPM_reconstruction_x(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_2nd, OBC) type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Layer thickness, in H. - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_L !< Left thickness in the - !! reconstruction, in H. - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_R !< Right thickness in the - !! reconstruction, in H. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Layer thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_L !< Left thickness in the reconstruction, + !! [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_R !< Right thickness in the reconstruction, + !! [H ~> m or kg m-2]. type(loop_bounds_type), intent(in) :: LB !< Active loop bounds structure. real, intent(in) :: h_min !< The minimum thickness !! that can be obtained by a concave parabolic fit. @@ -1873,7 +1880,7 @@ subroutine PPM_reconstruction_x(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ logical, optional, intent(in) :: simple_2nd !< If true, use the !! arithmetic mean thicknesses as the default edge values !! for a simple 2nd order scheme. - type(ocean_OBC_type), pointer, optional :: OBC !< Open boundaries control structure. + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. ! Local variables with useful mnemonic names. real, dimension(SZI_(G),SZJ_(G)) :: slp ! The slopes. @@ -1884,7 +1891,7 @@ subroutine PPM_reconstruction_x(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ character(len=256) :: mesg integer :: i, j, isl, iel, jsl, jel, n, stencil logical :: local_open_BC - type(OBC_segment_type), pointer :: segment + type(OBC_segment_type), pointer :: segment => NULL() use_CW84 = .false. ; if (present(monotonic)) use_CW84 = monotonic use_2nd = .false. ; if (present(simple_2nd)) use_2nd = simple_2nd @@ -1932,7 +1939,7 @@ subroutine PPM_reconstruction_x(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ slp(i,j) = sign(1.,slp(i,j)) * min(abs(slp(i,j)), 2. * min(dMx, dMn)) ! * (G%mask2dT(i-1,j) * G%mask2dT(i,j) * G%mask2dT(i+1,j)) endif - enddo; enddo + enddo ; enddo if (local_open_BC) then do n=1, OBC%number_of_segments @@ -1959,7 +1966,7 @@ subroutine PPM_reconstruction_x(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ ! Left/right values following Eq. B2 in Lin 1994, MWR (132) h_L(i,j) = 0.5*( h_im1 + h_in(i,j) ) + oneSixth*( slp(i-1,j) - slp(i,j) ) h_R(i,j) = 0.5*( h_ip1 + h_in(i,j) ) + oneSixth*( slp(i,j) - slp(i+1,j) ) - enddo; enddo + enddo ; enddo endif if (local_open_BC) then @@ -1998,11 +2005,11 @@ end subroutine PPM_reconstruction_x !> Calculates left/right edge values for PPM reconstruction. subroutine PPM_reconstruction_y(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_2nd, OBC) type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Layer thickness, in H. - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_L !< Left thickness in the - !! reconstruction, in H. - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_R !< Right thickness in the - !! reconstruction, in H. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Layer thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_L !< Left thickness in the reconstruction, + !! [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_R !< Right thickness in the reconstruction, + !! [H ~> m or kg m-2]. type(loop_bounds_type), intent(in) :: LB !< Active loop bounds structure. real, intent(in) :: h_min !< The minimum thickness !! that can be obtained by a concave parabolic fit. @@ -2012,7 +2019,7 @@ subroutine PPM_reconstruction_y(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ logical, optional, intent(in) :: simple_2nd !< If true, use the !! arithmetic mean thicknesses as the default edge values !! for a simple 2nd order scheme. - type(ocean_OBC_type), pointer, optional :: OBC !< Open boundaries control structure. + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. ! Local variables with useful mnemonic names. real, dimension(SZI_(G),SZJ_(G)) :: slp ! The slopes. @@ -2023,7 +2030,7 @@ subroutine PPM_reconstruction_y(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ character(len=256) :: mesg integer :: i, j, isl, iel, jsl, jel, n, stencil logical :: local_open_BC - type(OBC_segment_type), pointer :: segment + type(OBC_segment_type), pointer :: segment => NULL() use_CW84 = .false. ; if (present(monotonic)) use_CW84 = monotonic use_2nd = .false. ; if (present(simple_2nd)) use_2nd = simple_2nd @@ -2138,11 +2145,9 @@ end subroutine PPM_reconstruction_y !! than h_min, with a minimum of h_min otherwise. subroutine PPM_limit_pos(h_in, h_L, h_R, h_min, G, iis, iie, jis, jie) type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Layer thickness, in H. - real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_L !< Left thickness in the - !! reconstruction, in H. - real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_R !< Right thickness in the - !! reconstruction, in H. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Layer thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_L !< Left thickness in the reconstruction [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_R !< Right thickness in the reconstruction [H ~> m or kg m-2]. real, intent(in) :: h_min !< The minimum thickness !! that can be obtained by a concave parabolic fit. integer, intent(in) :: iis !< Start of i index range. @@ -2181,11 +2186,11 @@ end subroutine PPM_limit_pos !! according to the monotonic prescription of Colella and Woodward, 1984. subroutine PPM_limit_CW84(h_in, h_L, h_R, G, iis, iie, jis, jie) type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Layer thickness, in H. - real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_L !< Left thickness in the - !! reconstruction, in H. - real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_R !< Right thickness in the - !! reconstruction, in H. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Layer thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_L !< Left thickness in the reconstruction, + !! [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_R !< Right thickness in the reconstruction, + !! [H ~> m or kg m-2]. integer, intent(in) :: iis !< Start of i index range. integer, intent(in) :: iie !< End of i index range. integer, intent(in) :: jis !< Start of j index range. @@ -2231,7 +2236,7 @@ end function ratio_max !> Initializes continuity_ppm_cs subroutine continuity_PPM_init(Time, G, GV, param_file, diag, CS) - type(time_type), target, intent(in) :: Time !< Time increment in s. + type(time_type), target, intent(in) :: Time !< Time increment [s]. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. type(param_file_type), intent(in) :: param_file !< A structure indicating @@ -2241,6 +2246,7 @@ subroutine continuity_PPM_init(Time, G, GV, param_file, diag, CS) type(continuity_PPM_CS), pointer :: CS !< Module's control structure. !> This include declares and sets the variable "version". #include "version_variable.h" + real :: tol_eta_m ! An unscaled version of tol_eta [m]. character(len=40) :: mdl = "MOM_continuity_PPM" ! This module's name. if (associated(CS)) then @@ -2274,8 +2280,8 @@ subroutine continuity_PPM_init(Time, G, GV, param_file, diag, CS) "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"//& - "than about 10^-15*MAXIMUM_DEPTH.", units="m", & - default=0.5*G%ke*GV%Angstrom_z) + "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"//& @@ -2283,7 +2289,7 @@ subroutine continuity_PPM_init(Time, G, GV, param_file, diag, CS) "layer thicknesses when calculating the auxiliary \n"//& "corrected velocities. By default, this is the same as \n"//& "ETA_TOLERANCE, but can be made larger for efficiency.", & - units="m", default=CS%tol_eta) + 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"//& @@ -2319,9 +2325,6 @@ subroutine continuity_PPM_init(Time, G, GV, param_file, diag, CS) id_clock_update = cpu_clock_id('(Ocean continuity update)', grain=CLOCK_ROUTINE) id_clock_correct = cpu_clock_id('(Ocean continuity correction)', grain=CLOCK_ROUTINE) - CS%tol_eta = CS%tol_eta * GV%m_to_H - CS%tol_eta_aux = CS%tol_eta_aux * GV%m_to_H - end subroutine continuity_PPM_init !> continuity_PPM_stencil returns the continuity solver stencil size diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 6735e35063..2a4eeaf21a 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -30,7 +30,7 @@ module MOM_dynamics_split_RK2 use MOM_io, only : MOM_io_init, vardesc, var_desc use MOM_restart, only : register_restart_field, query_initialized, save_restart use MOM_restart, only : restart_init, is_new_run, MOM_restart_CS -use MOM_time_manager, only : time_type, set_time, time_type_to_real, operator(+) +use MOM_time_manager, only : time_type, time_type_to_real, operator(+) use MOM_time_manager, only : operator(-), operator(>), operator(*), operator(/) use MOM_ALE, only : ALE_CS @@ -53,67 +53,80 @@ module MOM_dynamics_split_RK2 use MOM_PressureForce, only : PressureForce, PressureForce_init, PressureForce_CS use MOM_set_visc, only : set_viscous_ML, set_visc_CS use MOM_tidal_forcing, only : tidal_forcing_init, tidal_forcing_CS +use MOM_unit_scaling, only : unit_scale_type use MOM_vert_friction, only : vertvisc, vertvisc_coef, vertvisc_remnant use MOM_vert_friction, only : vertvisc_limit_vel, vertvisc_init, vertvisc_CS use MOM_vert_friction, only : updateCFLtruncationValue use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units use MOM_verticalGrid, only : get_flux_units, get_tr_flux_units +use MOM_wave_interface, only: wave_parameters_CS implicit none ; private #include -!> Module control structure +!> MOM_dynamics_split_RK2 module control structure type, public :: MOM_dyn_split_RK2_CS ; private real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: & - CAu, & !< CAu = f*v - u.grad(u) in m s-2. - PFu, & !< PFu = -dM/dx, in m s-2. - diffu, & !< Zonal acceleration due to convergence of the along-isopycnal - !! stress tensor, in m s-2. - visc_rem_u, & !< Both the fraction of the zonal momentum originally in a - !! layer that remains after a time-step of viscosity, and the - !! fraction of a time-step's worth of a barotropic acceleration - !! that a layer experiences after viscosity is applied. - !! Nondimensional between 0 (at the bottom) and 1 (far above). - u_accel_bt !< The layers' zonal accelerations due to the difference between - !! the barotropic accelerations and the baroclinic accelerations - !! that were fed into the barotopic calculation, in m s-2. + CAu, & !< CAu = f*v - u.grad(u) [m s-2] + PFu, & !< PFu = -dM/dx [m s-2] + diffu !< Zonal acceleration due to convergence of the along-isopycnal stress tensor [m s-2] + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: & - CAv, & !< CAv = -f*u - u.grad(v) in m s-2. - PFv, & !< PFv = -dM/dy, in m s-2. - diffv, & !< Meridional acceleration due to convergence of the - !! along-isopycnal stress tensor, in m s-2. - visc_rem_v, & !< Both the fraction of the meridional momentum originally in - !! a layer that remains after a time-step of viscosity, and the - !! fraction of a time-step's worth of a barotropic acceleration - !! that a layer experiences after viscosity is applied. - !! Nondimensional between 0 (at the bottom) and 1 (far above). - v_accel_bt !< The layers' meridional accelerations due to the difference between - !! the barotropic accelerations and the baroclinic accelerations - !! that were fed into the barotopic calculation, in m s-2. + CAv, & !< CAv = -f*u - u.grad(v) [m s-2] + PFv, & !< PFv = -dM/dy [m s-2] + diffv !< Meridional acceleration due to convergence of the along-isopycnal stress tensor [m s-2] + + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: visc_rem_u + !< Both the fraction of the zonal momentum originally in a + !! layer that remains after a time-step of viscosity, and the + !! fraction of a time-step worth of a barotropic acceleration + !! that a layer experiences after viscosity is applied. + !! Nondimensional between 0 (at the bottom) and 1 (far above). + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: u_accel_bt + !< The zonal layer accelerations due to the difference between + !! the barotropic accelerations and the baroclinic accelerations + !! that were fed into the barotopic calculation [m s-2] + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: visc_rem_v + !< Both the fraction of the meridional momentum originally in + !! a layer that remains after a time-step of viscosity, and the + !! fraction of a time-step worth of a barotropic acceleration + !! that a layer experiences after viscosity is applied. + !! Nondimensional between 0 (at the bottom) and 1 (far above). + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: v_accel_bt + !< The meridional layer accelerations due to the difference between + !! the barotropic accelerations and the baroclinic accelerations + !! that were fed into the barotopic calculation [m s-2] ! The following variables are only used with the split time stepping scheme. - real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: eta !< Instantaneous free surface height (in Boussinesq mode) - !! or column mass anomaly (in non-Boussinesq mode), - !! in units of H (m or kg m-2) - real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: u_av !< layer x-velocity with vertical mean replaced by - !! time-mean barotropic velocity over a baroclinic timestep (m s-1) - real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: v_av !< layer y-velocity with vertical mean replaced by - !! time-mean barotropic velocity over a baroclinic timestep (m s-1) - real ALLOCABLE_, dimension(NIMEM_,NJMEM_,NKMEM_) :: h_av !< arithmetic mean of two successive layer thicknesses (m or kg m-2) - real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: eta_PF !< instantaneous SSH used in calculating PFu and PFv (meter) - real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: uhbt !< average x-volume or mass flux determined by barotropic solver - !! (m3 s-1 or kg s-1). uhbt should (roughly?) equal to vertical sum of uh. - real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: vhbt !< average y-volume or mass flux determined by barotropic solver - !! (m3 s-1 or kg s-1). vhbt should (roughly?) equal to vertical sum of vh. - real ALLOCABLE_, dimension(NIMEM_,NJMEM_,NKMEM_) :: pbce !< pbce times eta gives the baroclinic pressure anomaly in each layer due - !! to free surface height anomalies. pbce has units of m2 H-1 s-2. - - real, pointer, dimension(:,:) :: taux_bot => NULL() !< frictional x-bottom stress from the ocean to the seafloor (Pa) - real, pointer, dimension(:,:) :: tauy_bot => NULL() !< frictional y-bottom stress from the ocean to the seafloor (Pa) - type(BT_cont_type), pointer :: BT_cont => NULL() !< A structure with elements that describe the - !! effective summed open face areas as a function - !! of barotropic flow. + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: eta !< Instantaneous free surface height (in Boussinesq + !! mode) or column mass anomaly (in non-Boussinesq + !! mode) [H ~> m or kg m-2] + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: u_av !< layer x-velocity with vertical mean replaced by + !! time-mean barotropic velocity over a baroclinic + !! timestep [m s-1] + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: v_av !< layer y-velocity with vertical mean replaced by + !! time-mean barotropic velocity over a baroclinic + !! timestep [m s-1] + real ALLOCABLE_, dimension(NIMEM_,NJMEM_,NKMEM_) :: h_av !< arithmetic mean of two successive layer + !! thicknesses [H ~> m or kg m-2] + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: eta_PF !< instantaneous SSH used in calculating PFu and + !! PFv [H ~> m or kg m-2] + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: uhbt !< average x-volume or mass flux determined by the + !! barotropic solver [H m2 s-1 ~> m3 s-1 or kg s-1]. + !! uhbt is roughly equal to the vertical sum of uh. + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: vhbt !< average y-volume or mass flux determined by the + !! barotropic solver [H m2 s-1 ~> m3 s-1 or kg s-1]. + !! vhbt is roughly equal to vertical sum of vh. + real ALLOCABLE_, dimension(NIMEM_,NJMEM_,NKMEM_) :: pbce !< pbce times eta gives the baroclinic pressure + !! anomaly in each layer due to free surface height + !! anomalies [m2 H-1 s-2 ~> m s-2 or m4 kg-1 s-2]. + + real, pointer, dimension(:,:) :: taux_bot => NULL() !< frictional x-bottom stress from the ocean to the seafloor [Pa] + real, pointer, dimension(:,:) :: tauy_bot => NULL() !< frictional y-bottom stress from the ocean to the seafloor [Pa] + type(BT_cont_type), pointer :: BT_cont => NULL() !< A structure with elements that describe the + !! effective summed open face areas as a function + !! of barotropic flow. ! This is to allow the previous, velocity-based coupling with between the ! baroclinic and barotropic modes. @@ -135,8 +148,9 @@ module MOM_dynamics_split_RK2 logical :: debug !< If true, write verbose checksums for debugging purposes. logical :: debug_OBC !< If true, do debugging calls for open boundary conditions. - logical :: module_is_initialized = .false. + logical :: module_is_initialized = .false. !< Record whether this mouled has been initialzed. + !>@{ Diagnostic IDs integer :: id_uh = -1, id_vh = -1 integer :: id_umo = -1, id_vmo = -1 integer :: id_umo_2d = -1, id_vmo_2d = -1 @@ -146,6 +160,7 @@ module MOM_dynamics_split_RK2 ! Split scheme only. integer :: id_uav = -1, id_vav = -1 integer :: id_u_BT_accel = -1, id_v_BT_accel = -1 + !!@} type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the !! timing of diagnostic output. @@ -158,31 +173,40 @@ module MOM_dynamics_split_RK2 !! which can later be used to calculate !! derived diagnostics like energy budgets. - ! Remainder of the structure points to child subroutines' control strings. + ! The remainder of the structure points to child subroutines' control structures. + !> A pointer to the horizontal viscosity control structure type(hor_visc_CS), pointer :: hor_visc_CSp => NULL() + !> A pointer to the continuity control structure type(continuity_CS), pointer :: continuity_CSp => NULL() + !> A pointer to the CoriolisAdv control structure type(CoriolisAdv_CS), pointer :: CoriolisAdv_CSp => NULL() + !> A pointer to the PressureForce control structure type(PressureForce_CS), pointer :: PressureForce_CSp => NULL() + !> A pointer to the barotropic stepping control structure type(barotropic_CS), pointer :: barotropic_CSp => NULL() + !> A pointer to the vertical viscosity control structure type(vertvisc_CS), pointer :: vertvisc_CSp => NULL() + !> A pointer to the set_visc control structure type(set_visc_CS), pointer :: set_visc_CSp => NULL() + !> A pointer to the tidal forcing control structure type(tidal_forcing_CS), pointer :: tides_CSp => NULL() + !> A pointer to the ALE control structure. + type(ALE_CS), pointer :: ALE_CSp => NULL() type(ocean_OBC_type), pointer :: OBC => NULL() !< A pointer to an open boundary !! condition type that specifies whether, where, and what open boundary !! conditions are used. If no open BCs are used, this pointer stays !! nullified. Flather OBCs use open boundary_CS as well. + !> A pointer to the update_OBC control structure type(update_OBC_CS), pointer :: update_OBC_CSp => NULL() - ! This is a copy of the pointer in the top-level control structure. - type(ALE_CS), pointer :: ALE_CSp => NULL() - - ! for group halo pass - type(group_pass_type) :: pass_eta - type(group_pass_type) :: pass_visc_rem, pass_uvp - type(group_pass_type) :: pass_hp_uv - type(group_pass_type) :: pass_uv - type(group_pass_type) :: pass_h, pass_av_uvh + type(group_pass_type) :: pass_eta !< Structure for group halo pass + type(group_pass_type) :: pass_visc_rem !< Structure for group halo pass + type(group_pass_type) :: pass_uvp !< Structure for group halo pass + type(group_pass_type) :: pass_hp_uv !< Structure for group halo pass + type(group_pass_type) :: pass_uv !< Structure for group halo pass + type(group_pass_type) :: pass_h !< Structure for group halo pass + type(group_pass_type) :: pass_av_uvh !< Structure for group halo pass end type MOM_dyn_split_RK2_CS @@ -192,11 +216,13 @@ module MOM_dynamics_split_RK2 public initialize_dyn_split_RK2 public end_dyn_split_RK2 +!>@{ CPU time clock IDs integer :: id_clock_Cor, id_clock_pres, id_clock_vertvisc integer :: id_clock_horvisc, id_clock_mom_update integer :: id_clock_continuity, id_clock_thick_diff integer :: id_clock_btstep, id_clock_btcalc, id_clock_btforce integer :: id_clock_pass, id_clock_pass_init +!!@} contains @@ -204,64 +230,80 @@ module MOM_dynamics_split_RK2 subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & Time_local, dt, forces, p_surf_begin, p_surf_end, & uh, vh, uhtr, vhtr, eta_av, & - G, GV, CS, calc_dtbt, VarMix, MEKE) - 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)), target, intent(inout) :: u !< zonal velocity (m/s) - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), target, intent(inout) :: v !< merid velocity (m/s) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< layer thickness (m or kg/m2) - type(thermo_var_ptrs), intent(in) :: tv !< thermodynamic type - type(vertvisc_type), intent(inout) :: visc !< vertical visc, bottom drag, and related - type(time_type), intent(in) :: Time_local !< model time at end of time step - real, intent(in) :: dt !< time step (sec) - type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces - real, dimension(:,:), pointer :: p_surf_begin !< surf pressure at start of this dynamic time step (Pa) - real, dimension(:,:), pointer :: p_surf_end !< surf pressure at end of this dynamic time step (Pa) - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), target, intent(inout) :: uh !< zonal volume/mass transport (m3/s or kg/s) - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), target, intent(inout) :: vh !< merid volume/mass transport (m3/s or kg/s) - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: uhtr !< accumulatated zonal volume/mass transport since last tracer advection (m3 or kg) - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: vhtr !< accumulatated merid volume/mass transport since last tracer advection (m3 or kg) - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: eta_av !< free surface height or column mass time averaged over time step (m or kg/m2) - type(MOM_dyn_split_RK2_CS), pointer :: CS !< module control structure - logical, intent(in) :: calc_dtbt !< if true, recalculate barotropic time step - type(VarMix_CS), pointer :: VarMix !< specify the spatially varying viscosities - type(MEKE_type), pointer :: MEKE !< related to mesoscale eddy kinetic energy param - + G, GV, US, CS, calc_dtbt, VarMix, MEKE, Waves) + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + 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),SZK_(G)), & + target, intent(inout) :: u !< zonal velocity [m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + target, intent(inout) :: v !< merid velocity [m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(inout) :: h !< layer thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< thermodynamic type + type(vertvisc_type), intent(inout) :: visc !< vertical visc, bottom drag, and related + type(time_type), intent(in) :: Time_local !< model time at end of time step + real, intent(in) :: dt !< time step [s] + type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces + real, dimension(:,:), pointer :: p_surf_begin !< surf pressure at start of this dynamic + !! time step [Pa] + real, dimension(:,:), pointer :: p_surf_end !< surf pressure at end of this dynamic + !! time step [Pa] + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + target, intent(inout) :: uh !< zonal volume/mass transport + !! [H m2 s-1 ~> m3 s-1 or kg s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + target, intent(inout) :: vh !< merid volume/mass transport + !! [H m2 s-1 ~> m3 s-1 or kg s-1] + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(inout) :: uhtr !< accumulatated zonal volume/mass transport + !! since last tracer advection [H m2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(inout) :: vhtr !< accumulatated merid volume/mass transport + !! since last tracer advection [H m2 ~> m3 or kg] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: eta_av !< free surface height or column mass time + !! averaged over time step [H ~> m or kg m-2] + type(MOM_dyn_split_RK2_CS), pointer :: CS !< module control structure + logical, intent(in) :: calc_dtbt !< if true, recalculate barotropic time step + type(VarMix_CS), pointer :: VarMix !< specify the spatially varying viscosities + type(MEKE_type), pointer :: MEKE !< related to mesoscale eddy kinetic energy param + type(wave_parameters_CS), optional, pointer :: Waves !< A pointer to a structure containing + !! fields related to the surface wave conditions real :: dt_pred ! The time step for the predictor part of the baroclinic time stepping. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: up ! Predicted zonal velocity in m s-1. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: vp ! Predicted meridional velocity in m s-1. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: hp ! Predicted thickness in m or kg m-2 (H). + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: up ! Predicted zonal velocity [m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: vp ! Predicted meridional velocity [m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: hp ! Predicted thickness [H ~> m or kg m-2]. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: u_bc_accel real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: v_bc_accel ! u_bc_accel and v_bc_accel are the summed baroclinic accelerations of each - ! layer calculated by the non-barotropic part of the model, both in m s-2. + ! layer calculated by the non-barotropic part of the model [m s-2]. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), target :: uh_in real, dimension(SZI_(G),SZJB_(G),SZK_(G)), target :: vh_in ! uh_in and vh_in are the zonal or meridional mass transports that would be - ! obtained using the initial velocities, both in m3 s-1 or kg s-1. + ! obtained using the initial velocities [H m2 s-1 ~> m3 s-1 or kg s-1]. real, dimension(SZIB_(G),SZJ_(G)) :: uhbt_out real, dimension(SZI_(G),SZJB_(G)) :: vhbt_out ! uhbt_out and vhbt_out are the vertically summed transports from the - ! barotropic solver based on its final velocities, both in m3 s-1 or kg s-1. + ! barotropic solver based on its final velocities [H m2 s-1 ~> m3 s-1 or kg s-1]. real, dimension(SZI_(G),SZJ_(G)) :: eta_pred ! eta_pred is the predictor value of the free surface height or column mass, - ! in m or kg m-2. + ! [H ~> m or kg m-2]. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), target :: u_adj real, dimension(SZI_(G),SZJB_(G),SZK_(G)), target :: v_adj ! u_adj and v_adj are the zonal or meridional velocities after u and v ! have been barotropically adjusted so the resulting transports match - ! uhbt_out and vhbt_out, both in m s-1. + ! uhbt_out and vhbt_out [m s-1]. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: u_old_rad_OBC real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: v_old_rad_OBC ! u_old_rad_OBC and v_old_rad_OBC are the starting velocities, which are - ! saved for use in the Flather open boundary condition code, both in m s-1. + ! saved for use in the Flather open boundary condition code [m s-1]. real :: Pa_to_eta ! A factor that converts pressures to the units of eta. real, pointer, dimension(:,:) :: & @@ -272,10 +314,9 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & real, pointer, dimension(:,:,:) :: & uh_ptr => NULL(), u_ptr => NULL(), vh_ptr => NULL(), v_ptr => NULL(), & u_init => NULL(), v_init => NULL(), & ! Pointers to u and v or u_adj and v_adj. - u_av, & ! The zonal velocity time-averaged over a time step, in m s-1. - v_av, & ! The meridional velocity time-averaged over a time step, in m s-1. - h_av ! The layer thickness time-averaged over a time step, in m or - ! kg m-2. + u_av, & ! The zonal velocity time-averaged over a time step [m s-1]. + v_av, & ! The meridional velocity time-averaged over a time step [m s-1]. + h_av ! The layer thickness time-averaged over a time step [H ~> m or kg m-2]. real :: Idt logical :: dyn_p_surf logical :: BT_cont_BT_thick ! If true, use the BT_cont_type to estimate the @@ -334,7 +375,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & BT_cont_BT_thick = .false. if (associated(CS%BT_cont)) BT_cont_BT_thick = & - (associated(CS%BT_cont%h_u) .and. associated(CS%BT_cont%h_v)) + (allocated(CS%BT_cont%h_u) .and. allocated(CS%BT_cont%h_v)) if (CS%split_bottom_stress) then taux_bot => CS%taux_bot ; tauy_bot => CS%tauy_bot @@ -366,7 +407,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & ! pbce = dM/deta if (CS%begw == 0.0) call enable_averaging(dt, Time_local, CS%diag) call cpu_clock_begin(id_clock_pres) - call PressureForce(h, tv, CS%PFu, CS%PFv, G, GV, CS%PressureForce_CSp, & + call PressureForce(h, tv, CS%PFu, CS%PFv, G, GV, US, CS%PressureForce_CSp, & CS%ALE_CSp, p_surf, CS%pbce, CS%eta_PF) if (dyn_p_surf) then Pa_to_eta = 1.0 / GV%H_to_Pa @@ -381,7 +422,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & if (showCallTree) call callTree_wayPoint("done with PressureForce (step_MOM_dyn_split_RK2)") if (associated(CS%OBC)) then; if (CS%OBC%update_OBC) then - call update_OBC_data(CS%OBC, G, GV, tv, h, CS%update_OBC_CSp, Time_local) + call update_OBC_data(CS%OBC, G, GV, US, tv, h, CS%update_OBC_CSp, Time_local) endif; endif if (associated(CS%OBC) .and. CS%debug_OBC) & call open_boundary_zero_normal_flow(CS%OBC, G, CS%PFu, CS%PFv) @@ -434,14 +475,14 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & enddo call enable_averaging(dt, Time_local, CS%diag) - call set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, & + call set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, & CS%set_visc_CSp) call disable_averaging(CS%diag) if (CS%debug) then call uvchksum("before vertvisc: up", up, vp, G%HI, haloshift=0, symmetric=sym) endif - call vertvisc_coef(up, vp, h, forces, visc, dt, G, GV, CS%vertvisc_CSp, CS%OBC) + call vertvisc_coef(up, vp, h, forces, visc, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC) call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt, G, GV, CS%vertvisc_CSp) call cpu_clock_end(id_clock_vertvisc) if (showCallTree) call callTree_wayPoint("done with vertvisc_coef (step_MOM_dyn_split_RK2)") @@ -487,14 +528,13 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & u_init => u ; v_init => v call cpu_clock_begin(id_clock_btstep) - if (calc_dtbt) call set_dtbt(G, GV, CS%barotropic_CSp, eta, CS%pbce) + if (calc_dtbt) call set_dtbt(G, GV, US, CS%barotropic_CSp, eta, CS%pbce) if (showCallTree) call callTree_enter("btstep(), MOM_barotropic.F90") ! This is the predictor step call to btstep. - call btstep(u, v, eta, dt, u_bc_accel, v_bc_accel, & - forces, CS%pbce, CS%eta_PF, u_av, v_av, CS%u_accel_bt, & - CS%v_accel_bt, eta_pred, CS%uhbt, CS%vhbt, G, GV, CS%barotropic_CSp,& - CS%visc_rem_u, CS%visc_rem_v, OBC=CS%OBC, & - BT_cont = CS%BT_cont, eta_PF_start=eta_PF_start, & + call btstep(u, v, eta, dt, u_bc_accel, v_bc_accel, forces, CS%pbce, CS%eta_PF, & + u_av, v_av, CS%u_accel_bt, CS%v_accel_bt, eta_pred, CS%uhbt, CS%vhbt, & + G, GV, US, CS%barotropic_CSp, CS%visc_rem_u, CS%visc_rem_v, & + OBC=CS%OBC, BT_cont=CS%BT_cont, eta_PF_start=eta_PF_start, & taux_bot=taux_bot, tauy_bot=tauy_bot, & uh0=uh_ptr, vh0=vh_ptr, u_uh0=u_ptr, v_vh0=v_ptr) if (showCallTree) call callTree_leave("btstep()") @@ -537,10 +577,10 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & if (CS%debug) then call uvchksum("0 before vertvisc: [uv]p", up, vp, G%HI,haloshift=0, symmetric=sym) endif - call vertvisc_coef(up, vp, h, forces, visc, dt_pred, G, GV, CS%vertvisc_CSp, & + call vertvisc_coef(up, vp, h, forces, visc, dt_pred, G, GV, US, CS%vertvisc_CSp, & CS%OBC) call vertvisc(up, vp, h, forces, visc, dt_pred, CS%OBC, CS%ADp, CS%CDp, G, & - GV, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot) + GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves) if (showCallTree) call callTree_wayPoint("done with vertvisc (step_MOM_dyn_split_RK2)") if (G%nonblocking_updates) then call cpu_clock_end(id_clock_vertvisc) @@ -615,9 +655,8 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & ! PFu = d/dx M(hp,T,S) ! pbce = dM/deta call cpu_clock_begin(id_clock_pres) - call PressureForce(hp, tv, CS%PFu, CS%PFv, G, GV, & - CS%PressureForce_CSp, CS%ALE_CSp, & - p_surf, CS%pbce, CS%eta_PF) + call PressureForce(hp, tv, CS%PFu, CS%PFv, G, GV, US, CS%PressureForce_CSp, & + CS%ALE_CSp, p_surf, CS%pbce, CS%eta_PF) call cpu_clock_end(id_clock_pres) if (showCallTree) call callTree_wayPoint("done with PressureForce[hp=(1-b).h+b.h] (step_MOM_dyn_split_RK2)") endif @@ -691,11 +730,10 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & if (showCallTree) call callTree_enter("btstep(), MOM_barotropic.F90") ! This is the corrector step call to btstep. - call btstep(u, v, eta, dt, u_bc_accel, v_bc_accel, & - forces, CS%pbce, CS%eta_PF, u_av, v_av, CS%u_accel_bt, & - CS%v_accel_bt, eta_pred, CS%uhbt, CS%vhbt, G, GV, & - CS%barotropic_CSp, CS%visc_rem_u, CS%visc_rem_v, & - etaav=eta_av, OBC=CS%OBC, & + call btstep(u, v, eta, dt, u_bc_accel, v_bc_accel, forces, CS%pbce, & + CS%eta_PF, u_av, v_av, CS%u_accel_bt, CS%v_accel_bt, & + eta_pred, CS%uhbt, CS%vhbt, G, GV, US, CS%barotropic_CSp, & + CS%visc_rem_u, CS%visc_rem_v, etaav=eta_av, OBC=CS%OBC, & BT_cont = CS%BT_cont, eta_PF_start=eta_PF_start, & taux_bot=taux_bot, tauy_bot=tauy_bot, & uh0=uh_ptr, vh0=vh_ptr, u_uh0=u_ptr, v_vh0=v_ptr) @@ -736,9 +774,9 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & ! u <- u + dt d/dz visc d/dz u ! u_av <- u_av + dt d/dz visc d/dz u_av call cpu_clock_begin(id_clock_vertvisc) - call vertvisc_coef(u, v, h, forces, visc, dt, G, GV, CS%vertvisc_CSp, CS%OBC) - call vertvisc(u, v, h, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, G, GV, & - CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot) + call vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC) + call vertvisc(u, v, h, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, G, GV, US, & + CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot,waves=waves) if (G%nonblocking_updates) then call cpu_clock_end(id_clock_vertvisc) call start_group_pass(CS%pass_uv, G%Domain, clock=id_clock_pass) @@ -842,8 +880,10 @@ subroutine register_restarts_dyn_split_RK2(HI, GV, param_file, CS, restart_CS, u type(param_file_type), intent(in) :: param_file !< parameter file type(MOM_dyn_split_RK2_CS), pointer :: CS !< module control structure type(MOM_restart_CS), pointer :: restart_CS !< restart control structure - real, dimension(SZIB_(HI),SZJ_(HI),SZK_(GV)), target, intent(inout) :: uh !< zonal volume/mass transport (m3/s or kg/s) - real, dimension(SZI_(HI),SZJB_(HI),SZK_(GV)), target, intent(inout) :: vh !< merid volume/mass transport (m3/s or kg/s) + real, dimension(SZIB_(HI),SZJ_(HI),SZK_(GV)), & + target, intent(inout) :: uh !< zonal volume/mass transport [H m2 s-1 ~> m3 s-1 or kg s-1] + real, dimension(SZI_(HI),SZJB_(HI),SZK_(GV)), & + target, intent(inout) :: vh !< merid volume/mass transport [H m2 s-1 ~> m3 s-1 or kg s-1] type(vardesc) :: vd character(len=40) :: mdl = "MOM_dynamics_split_RK2" ! This module's name. @@ -871,7 +911,7 @@ subroutine register_restarts_dyn_split_RK2(HI, GV, param_file, CS, restart_CS, u ALLOC_(CS%eta(isd:ied,jsd:jed)) ; CS%eta(:,:) = 0.0 ALLOC_(CS%u_av(IsdB:IedB,jsd:jed,nz)) ; CS%u_av(:,:,:) = 0.0 ALLOC_(CS%v_av(isd:ied,JsdB:JedB,nz)) ; CS%v_av(:,:,:) = 0.0 - ALLOC_(CS%h_av(isd:ied,jsd:jed,nz)) ; CS%h_av(:,:,:) = GV%Angstrom + ALLOC_(CS%h_av(isd:ied,jsd:jed,nz)) ; CS%h_av(:,:,:) = GV%Angstrom_H thickness_units = get_thickness_units(GV) flux_units = get_flux_units(GV) @@ -911,42 +951,54 @@ end subroutine register_restarts_dyn_split_RK2 !> This subroutine initializes all of the variables that are used by this !! dynamic core, including diagnostics and the cpu clocks. -subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, param_file, & +subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param_file, & diag, CS, restart_CS, dt, Accel_diag, Cont_diag, MIS, & VarMix, MEKE, OBC, update_OBC_CSp, ALE_CSp, setVisc_CSp, & visc, dirs, ntrunc, calc_dtbt) - 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(inout) :: u !< zonal velocity (m/s) - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: v !< merid velocity (m/s) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) , intent(inout) :: h !< layer thickness (m or kg/m2) - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), target, intent(inout) :: uh !< zonal volume/mass transport (m3 s-1 or kg s-1) - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), target, intent(inout) :: vh !< merid volume/mass transport (m3 s-1 or kg s-1) - real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: eta !< free surface height or column mass (m or kg m-2) - type(time_type), target, intent(in) :: Time !< current model time - type(param_file_type), intent(in) :: param_file !< parameter file for parsing - type(diag_ctrl), target, intent(inout) :: diag !< to control diagnostics - type(MOM_dyn_split_RK2_CS), pointer :: CS !< module control structure - type(MOM_restart_CS), pointer :: restart_CS !< restart control structure - real, intent(in) :: dt !< time step (sec) - type(accel_diag_ptrs), target, intent(inout) :: Accel_diag !< points to momentum equation terms for budget analysis - type(cont_diag_ptrs), target, intent(inout) :: Cont_diag !< points to terms in continuity equation - type(ocean_internal_state), intent(inout) :: MIS !< "MOM6 internal state" used to pass diagnostic pointers - type(VarMix_CS), pointer :: VarMix !< points to spatially variable viscosities - type(MEKE_type), pointer :: MEKE !< points to mesoscale eddy kinetic energy fields - type(ocean_OBC_type), pointer :: OBC !< points to OBC related fields - type(update_OBC_CS), pointer :: update_OBC_CSp !< points to OBC update related fields - type(ALE_CS), pointer :: ALE_CSp !< points to ALE control structure - type(set_visc_CS), pointer :: setVisc_CSp !< points to the set_visc control structure. - type(vertvisc_type), intent(inout) :: visc !< vertical viscosities, bottom drag, and related - type(directories), intent(in) :: dirs !< contains directory paths - integer, target, intent(inout) :: ntrunc !< A target for the variable that records the number of times - !! the velocity is truncated (this should be 0). - logical, intent(out) :: calc_dtbt !< If true, recalculate the barotropic time step + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + 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),SZK_(G)), & + intent(inout) :: u !< zonal velocity [m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(inout) :: v !< merid velocity [m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) , intent(inout) :: h !< layer thickness [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + target, intent(inout) :: uh !< zonal volume/mass transport [H m2 s-1 ~> m3 s-1 or kg s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + target, intent(inout) :: vh !< merid volume/mass transport [H m2 s-1 ~> m3 s-1 or kg s-1] + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: eta !< free surface height or column mass [H ~> m or kg m-2] + type(time_type), target, intent(in) :: Time !< current model time + type(param_file_type), intent(in) :: param_file !< parameter file for parsing + type(diag_ctrl), target, intent(inout) :: diag !< to control diagnostics + type(MOM_dyn_split_RK2_CS), pointer :: CS !< module control structure + type(MOM_restart_CS), pointer :: restart_CS !< restart control structure + real, intent(in) :: dt !< time step [s] + type(accel_diag_ptrs), target, intent(inout) :: Accel_diag !< points to momentum equation terms for + !! budget analysis + type(cont_diag_ptrs), target, intent(inout) :: Cont_diag !< points to terms in continuity equation + type(ocean_internal_state), intent(inout) :: MIS !< "MOM6 internal state" used to pass + !! diagnostic pointers + type(VarMix_CS), pointer :: VarMix !< points to spatially variable viscosities + type(MEKE_type), pointer :: MEKE !< points to mesoscale eddy kinetic energy fields + type(ocean_OBC_type), pointer :: OBC !< points to OBC related fields + type(update_OBC_CS), pointer :: update_OBC_CSp !< points to OBC update related fields + type(ALE_CS), pointer :: ALE_CSp !< points to ALE control structure + type(set_visc_CS), pointer :: setVisc_CSp !< points to the set_visc control structure. + type(vertvisc_type), intent(inout) :: visc !< vertical viscosities, bottom drag, and related + type(directories), intent(in) :: dirs !< contains directory paths + integer, target, intent(inout) :: ntrunc !< A target for the variable that records + !! the number of times the velocity is + !! truncated (this should be 0). + logical, intent(out) :: calc_dtbt !< If true, recalculate the barotropic time step real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_tmp character(len=40) :: mdl = "MOM_dynamics_split_RK2" ! This module's name. character(len=48) :: thickness_units, flux_units, eta_rest_name + real :: H_rescale ! A rescaling factor for thicknesses from the representation in + ! a restart file to the internal representation in this run. + real :: uH_rescale ! A rescaling factor for thickness transports from the representation in + ! a restart file to the internal representation in this run. real :: H_convert type(group_pass_type) :: pass_av_h_uvh logical :: use_tides, debug_truncations @@ -1042,10 +1094,10 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, param_fil call continuity_init(Time, G, GV, param_file, diag, CS%continuity_CSp) call CoriolisAdv_init(Time, G, param_file, diag, CS%ADp, CS%CoriolisAdv_CSp) if (use_tides) call tidal_forcing_init(Time, G, param_file, CS%tides_CSp) - call PressureForce_init(Time, G, GV, param_file, diag, CS%PressureForce_CSp, & + call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, & CS%tides_CSp) call hor_visc_init(Time, G, param_file, diag, CS%hor_visc_CSp) - call vertvisc_init(MIS, Time, G, GV, param_file, diag, CS%ADp, dirs, & + call vertvisc_init(MIS, Time, G, GV, US, param_file, diag, CS%ADp, dirs, & ntrunc, CS%vertvisc_CSp) if (.not.associated(setVisc_CSp)) call MOM_error(FATAL, & "initialize_dyn_split_RK2 called with setVisc_CSp unassociated.") @@ -1065,16 +1117,19 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, param_fil ! dimensions as h, either m or kg m-3. ! CS%eta(:,:) = 0.0 already from initialization. if (GV%Boussinesq) then - do j=js,je ; do i=is,ie ; CS%eta(i,j) = -G%bathyT(i,j) * GV%m_to_H ; enddo ; enddo + do j=js,je ; do i=is,ie ; CS%eta(i,j) = -GV%Z_to_H * G%bathyT(i,j) ; enddo ; enddo endif do k=1,nz ; do j=js,je ; do i=is,ie CS%eta(i,j) = CS%eta(i,j) + h(i,j,k) enddo ; enddo ; enddo + elseif ((GV%m_to_H_restart /= 0.0) .and. (GV%m_to_H_restart /= GV%m_to_H)) then + H_rescale = GV%m_to_H / GV%m_to_H_restart + do j=js,je ; do i=is,ie ; CS%eta(i,j) = H_rescale * CS%eta(i,j) ; enddo ; enddo endif ! Copy eta into an output array. do j=js,je ; do i=is,ie ; eta(i,j) = CS%eta(i,j) ; enddo ; enddo - call barotropic_init(u, v, h, CS%eta, Time, G, GV, param_file, diag, & + call barotropic_init(u, v, h, CS%eta, Time, G, GV, US, param_file, diag, & CS%barotropic_CSp, restart_CS, calc_dtbt, CS%BT_cont, & CS%tides_CSp) @@ -1096,8 +1151,17 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, param_fil call pass_var(h_tmp, G%Domain, clock=id_clock_pass_init) CS%h_av(:,:,:) = 0.5*(h(:,:,:) + h_tmp(:,:,:)) else - if (.not. query_initialized(CS%h_av,"h2",restart_CS)) & + if (.not. query_initialized(CS%h_av,"h2",restart_CS)) then CS%h_av(:,:,:) = h(:,:,:) + elseif ((GV%m_to_H_restart /= 0.0) .and. (GV%m_to_H_restart /= GV%m_to_H)) then + H_rescale = GV%m_to_H / GV%m_to_H_restart + do k=1,nz ; do j=js,je ; do i=is,ie ; CS%h_av(i,j,k) = H_rescale * CS%h_av(i,j,k) ; enddo ; enddo ; enddo + endif + if ((GV%m_to_H_restart /= 0.0) .and. (GV%m_to_H_restart /= GV%m_to_H)) then + uH_rescale = GV%m_to_H / GV%m_to_H_restart + do k=1,nz ; do j=js,je ; do I=G%IscB,G%IecB ; uh(I,j,k) = uH_rescale * uh(I,j,k) ; enddo ; enddo ; enddo + do k=1,nz ; do J=G%JscB,G%JecB ; do i=is,ie ; vh(i,J,k) = uH_rescale * vh(i,J,k) ; enddo ; enddo ; enddo + endif endif call cpu_clock_begin(id_clock_pass_init) diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index d4e64ef019..887a6c4f54 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -1,3 +1,4 @@ +!> Time steps the ocean dynamics with an unsplit quasi 3rd order scheme module MOM_dynamics_unsplit ! This file is part of MOM6. See LICENSE.md for the license. @@ -71,7 +72,7 @@ module MOM_dynamics_unsplit use MOM_io, only : MOM_io_init use MOM_restart, only : register_restart_field, query_initialized, save_restart use MOM_restart, only : restart_init, MOM_restart_CS -use MOM_time_manager, only : time_type, set_time, time_type_to_real, operator(+) +use MOM_time_manager, only : time_type, real_to_time, operator(+) use MOM_time_manager, only : operator(-), operator(>), operator(*), operator(/) use MOM_ALE, only : ALE_CS @@ -91,6 +92,7 @@ module MOM_dynamics_unsplit use MOM_PressureForce, only : PressureForce, PressureForce_init, PressureForce_CS use MOM_set_visc, only : set_viscous_ML, set_visc_CS use MOM_tidal_forcing, only : tidal_forcing_init, tidal_forcing_CS +use MOM_unit_scaling, only : unit_scale_type use MOM_vert_friction, only : vertvisc, vertvisc_coef use MOM_vert_friction, only : vertvisc_limit_vel, vertvisc_init, vertvisc_CS use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units @@ -100,151 +102,129 @@ module MOM_dynamics_unsplit implicit none ; private #include + +!> MOM_dynamics_unsplit module control structure type, public :: MOM_dyn_unsplit_CS ; private real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: & - CAu, & ! CAu = f*v - u.grad(u) in m s-2. - PFu, & ! PFu = -dM/dx, in m s-2. - diffu ! Zonal acceleration due to convergence of the along-isopycnal - ! stress tensor, in m s-2. + CAu, & !< CAu = f*v - u.grad(u) [m s-2]. + PFu, & !< PFu = -dM/dx [m s-2]. + diffu !< Zonal acceleration due to convergence of the along-isopycnal stress tensor [m s-2]. real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: & - CAv, & ! CAv = -f*u - u.grad(v) in m s-2. - PFv, & ! PFv = -dM/dy, in m s-2. - diffv ! Meridional acceleration due to convergence of the - ! along-isopycnal stress tensor, in m s-2. + CAv, & !< CAv = -f*u - u.grad(v) [m s-2]. + PFv, & !< PFv = -dM/dy [m s-2]. + diffv !< Meridional acceleration due to convergence of the along-isopycnal stress tensor [m s-2]. - real, pointer, dimension(:,:) :: taux_bot => NULL(), tauy_bot => NULL() - ! The frictional bottom stresses from the ocean to the seafloor, in Pa. + real, pointer, dimension(:,:) :: taux_bot => NULL() !< frictional x-bottom stress from the ocean to the seafloor (Pa) + real, pointer, dimension(:,:) :: tauy_bot => NULL() !< frictional y-bottom stress from the ocean to the seafloor (Pa) - logical :: debug ! If true, write verbose checksums for debugging purposes. + logical :: debug !< If true, write verbose checksums for debugging purposes. - logical :: module_is_initialized = .false. + logical :: module_is_initialized = .false. !< Record whether this mouled has been initialzed. + !>@{ Diagnostic IDs integer :: id_uh = -1, id_vh = -1 integer :: id_PFu = -1, id_PFv = -1, id_CAu = -1, id_CAv = -1 - - type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the - ! timing of diagnostic output. - type(accel_diag_ptrs), pointer :: ADp ! A structure pointing to the various - ! accelerations in the momentum equations, - ! which can later be used to calculate - ! derived diagnostics like energy budgets. - type(cont_diag_ptrs), pointer :: CDp ! A structure with pointers to various - ! terms in the continuity equations, - ! which can later be used to calculate - ! derived diagnostics like energy budgets. -! The remainder of the structure is pointers to child subroutines' control strings. + !!@} + + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + type(accel_diag_ptrs), pointer :: ADp => NULL() !< A structure pointing to the + !! accelerations in the momentum equations, + !! which can later be used to calculate + !! derived diagnostics like energy budgets. + type(cont_diag_ptrs), pointer :: CDp => NULL() !< A structure with pointers to + !! various terms in the continuity equations, + !! which can later be used to calculate + !! derived diagnostics like energy budgets. + + ! The remainder of the structure points to child subroutines' control structures. + !> A pointer to the horizontal viscosity control structure type(hor_visc_CS), pointer :: hor_visc_CSp => NULL() + !> A pointer to the continuity control structure type(continuity_CS), pointer :: continuity_CSp => NULL() + !> A pointer to the CoriolisAdv control structure type(CoriolisAdv_CS), pointer :: CoriolisAdv_CSp => NULL() + !> A pointer to the PressureForce control structure type(PressureForce_CS), pointer :: PressureForce_CSp => NULL() + !> A pointer to the vertvisc control structure type(vertvisc_CS), pointer :: vertvisc_CSp => NULL() + !> A pointer to the set_visc control structure type(set_visc_CS), pointer :: set_visc_CSp => NULL() - type(ocean_OBC_type), pointer :: OBC => NULL() ! A pointer to an open boundary + !> A pointer to the tidal forcing control structure + type(tidal_forcing_CS), pointer :: tides_CSp => NULL() + !> A pointer to the ALE control structure. + type(ALE_CS), pointer :: ALE_CSp => NULL() + + type(ocean_OBC_type), pointer :: OBC => NULL() !< A pointer to an open boundary ! condition type that specifies whether, where, and what open boundary ! conditions are used. If no open BCs are used, this pointer stays ! nullified. Flather OBCs use open boundary_CS as well. + !> A pointer to the update_OBC control structure type(update_OBC_CS), pointer :: update_OBC_CSp => NULL() - type(tidal_forcing_CS), pointer :: tides_CSp => NULL() - -! This is a copy of the pointer in the top-level control structure. - type(ALE_CS), pointer :: ALE_CSp => NULL() end type MOM_dyn_unsplit_CS public step_MOM_dyn_unsplit, register_restarts_dyn_unsplit public initialize_dyn_unsplit, end_dyn_unsplit +!>@{ CPU time clock IDs integer :: id_clock_Cor, id_clock_pres, id_clock_vertvisc integer :: id_clock_continuity, id_clock_horvisc, id_clock_mom_update integer :: id_clock_pass, id_clock_pass_init +!!@} contains ! ============================================================================= +!> Step the MOM6 dynamics using an unsplit mixed 2nd order (for continuity) and +!! 3rd order (for the inviscid momentum equations) order scheme subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & - p_surf_begin, p_surf_end, uh, vh, uhtr, vhtr, eta_av, G, GV, CS, & + p_surf_begin, p_surf_end, uh, vh, uhtr, vhtr, eta_av, G, GV, US, CS, & VarMix, MEKE, Waves) - 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(inout) :: u !< The zonal velocity, in m s-1. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & - intent(inout) :: v !< The meridional velocity, in m s-1. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(inout) :: h !< Layer thicknesses, in H. - !! (usually m or kg m-2). - type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various - !! thermodynamic variables. - type(vertvisc_type), intent(inout) :: visc !< A structure containing vertical + 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(inout) :: u !< The zonal velocity [m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: v !< The meridional velocity [m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2]. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables. + type(vertvisc_type), intent(inout) :: visc !< A structure containing vertical !! viscosities, bottom drag viscosities, and related fields. - type(time_type), intent(in) :: Time_local !< The model time at the end - !! of the time step. - real, intent(in) :: dt !< The dynamics time step, in s. - type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces - real, dimension(:,:), pointer :: p_surf_begin !< A pointer (perhaps NULL) to the - !! surface pressure at the beginning of this dynamic step, in Pa. - real, dimension(:,:), pointer :: p_surf_end !< A pointer (perhaps NULL) to the - !! surface pressure at the end of this dynamic step, in Pa. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & - intent(inout) :: uh !< The zonal volume or mass transport, - !! in m3 s-1 or kg s-1. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & - intent(inout) :: vh !< The meridional volume or mass - !! transport, in m3 s-1 or kg s-1. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & - intent(inout) :: uhtr !< he accumulated zonal volume or mass - !! transport since the last tracer advection, in m3 or kg. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & - intent(inout) :: vhtr !< The accumulated meridional volume or - !! mass transport since the last tracer advection, in m3 or kg. - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: eta_av !< The time-mean free surface height or - !! column mass, in m or kg m-2. - type(MOM_dyn_unsplit_CS), pointer :: CS !< The control structure set up by - !! initialize_dyn_unsplit. - type(VarMix_CS), pointer :: VarMix !< A pointer to a structure with fields - !! that specify the spatially variable viscosities. - type(MEKE_type), pointer :: MEKE !< A pointer to a structure containing - !! fields related to the Mesoscale Eddy Kinetic Energy. - type(wave_parameters_CS), pointer, optional :: Waves !< A pointer to a structure containing - !! fields related to the surface wave conditions - -! Arguments: u - The input and output zonal velocity, in m s-1. -! (inout) v - The input and output meridional velocity, in m s-1. -! (inout) h - The input and output layer thicknesses, in m or kg m-2, -! depending on whether the Boussinesq approximation is made. -! (in) tv - a structure pointing to various thermodynamic variables. -! (inout) visc - A structure containing vertical viscosities, bottom drag -! viscosities, and related fields. -! (in) Time_local - The model time at the end of the time step. -! (in) dt - The time step in s. -! (in) fluxes - A structure containing pointers to any possible -! forcing fields. Unused fields have NULL ptrs. -! (in) p_surf_begin - A pointer (perhaps NULL) to the surface pressure -! at the beginning of this dynamic step, in Pa. -! (in) p_surf_end - A pointer (perhaps NULL) to the surface pressure -! at the end of this dynamic step, in Pa. -! (inout) uh - The zonal volume or mass transport, in m3 s-1 or kg s-1. -! (inout) vh - The meridional volume or mass transport, in m3 s-1 or kg s-1. -! (inout) uhtr - The accumulated zonal volume or mass transport since the last -! tracer advection, in m3 or kg. -! (inout) vhtr - The accumulated meridional volume or mass transport since the last -! tracer advection, in m3 or kg. -! (out) eta_av - The time-mean free surface height or column mass, in m or -! kg m-2. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - The control structure set up by initialize_dyn_unsplit. -! (in) VarMix - A pointer to a structure with fields that specify the -! spatially variable viscosities. -! (inout) MEKE - A pointer to a structure containing fields related to -! the Mesoscale Eddy Kinetic Energy. - + type(time_type), intent(in) :: Time_local !< The model time at the end + !! of the time step. + real, intent(in) :: dt !< The dynamics time step [s]. + type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces + real, dimension(:,:), pointer :: p_surf_begin !< A pointer (perhaps NULL) to the surface + !! pressure at the start of this dynamic step [Pa]. + real, dimension(:,:), pointer :: p_surf_end !< A pointer (perhaps NULL) to the surface + !! pressure at the end of this dynamic step [Pa]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: uh !< The zonal volume or mass transport + !! [H m2 s-1 ~> m3 or kg s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: vh !< The meridional volume or mass + !! transport [H m2 s-1 ~> m3 or kg s-1]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: uhtr !< The accumulated zonal volume or mass + !! transport since the last tracer advection [H m2 ~> m3 or kg]. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: vhtr !< The accumulated meridional volume or mass + !! transport since the last tracer advection [H m2 ~> m3 or kg]. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: eta_av !< The time-mean free surface height or + !! column mass [H ~> m or kg m-2]. + type(MOM_dyn_unsplit_CS), pointer :: CS !< The control structure set up by + !! initialize_dyn_unsplit. + type(VarMix_CS), pointer :: VarMix !< A pointer to a structure with fields + !! that specify the spatially variable viscosities. + type(MEKE_type), pointer :: MEKE !< A pointer to a structure containing + !! fields related to the Mesoscale Eddy Kinetic Energy. + type(wave_parameters_CS), optional, pointer :: Waves !< A pointer to a structure containing + !! fields related to the surface wave conditions + + ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_av, hp real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: up, upp real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: vp, vpp - real, dimension(:,:), pointer :: p_surf + real, dimension(:,:), pointer :: p_surf => NULL() real :: dt_pred ! The time step for the predictor part of the baroclinic ! time stepping. logical :: dyn_p_surf @@ -288,7 +268,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & call pass_var(hp, G%Domain, clock=id_clock_pass) call pass_vector(uh, vh, G%Domain, clock=id_clock_pass) - call enable_averaging(0.5*dt,Time_local-set_time(int(0.5*dt)), CS%diag) + call enable_averaging(0.5*dt,Time_local-real_to_time(0.5*dt), CS%diag) ! Here the first half of the thickness fluxes are offered for averaging. if (CS%id_uh > 0) call post_data(CS%id_uh, uh, CS%diag) if (CS%id_vh > 0) call post_data(CS%id_vh, vh, CS%diag) @@ -328,12 +308,12 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & if (dyn_p_surf) then ; do j=js-2,je+2 ; do i=is-2,ie+2 p_surf(i,j) = 0.75*p_surf_begin(i,j) + 0.25*p_surf_end(i,j) enddo ; enddo ; endif - call PressureForce(h_av, tv, CS%PFu, CS%PFv, G, GV, & + call PressureForce(h_av, tv, CS%PFu, CS%PFv, G, GV, US, & CS%PressureForce_CSp, CS%ALE_CSp, p_surf) call cpu_clock_end(id_clock_pres) if (associated(CS%OBC)) then; if (CS%OBC%update_OBC) then - call update_OBC_data(CS%OBC, G, GV, tv, h, CS%update_OBC_CSp, Time_local) + call update_OBC_data(CS%OBC, G, GV, US, tv, h, CS%update_OBC_CSp, Time_local) endif; endif if (associated(CS%OBC)) then call open_boundary_zero_normal_flow(CS%OBC, G, CS%PFu, CS%PFv) @@ -361,13 +341,13 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! up <- up + dt/2 d/dz visc d/dz up call cpu_clock_begin(id_clock_vertvisc) call enable_averaging(dt, Time_local, CS%diag) - call set_viscous_ML(u, v, h_av, tv, forces, visc, dt*0.5, G, GV, & + call set_viscous_ML(u, v, h_av, tv, forces, visc, dt*0.5, G, GV, US, & CS%set_visc_CSp) call disable_averaging(CS%diag) - call vertvisc_coef(up, vp, h_av, forces, visc, dt*0.5, G, GV, & + call vertvisc_coef(up, vp, h_av, forces, visc, dt*0.5, G, GV, US, & CS%vertvisc_CSp, CS%OBC) call vertvisc(up, vp, h_av, forces, visc, dt*0.5, CS%OBC, CS%ADp, CS%CDp, & - G, GV, CS%vertvisc_CSp, Waves=Waves) + G, GV, US, CS%vertvisc_CSp, Waves=Waves) call cpu_clock_end(id_clock_vertvisc) call pass_vector(up, vp, G%Domain, clock=id_clock_pass) @@ -396,12 +376,12 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & if (dyn_p_surf) then ; do j=js-2,je+2 ; do i=is-2,ie+2 p_surf(i,j) = 0.25*p_surf_begin(i,j) + 0.75*p_surf_end(i,j) enddo ; enddo ; endif - call PressureForce(h_av, tv, CS%PFu, CS%PFv, G, GV, & + call PressureForce(h_av, tv, CS%PFu, CS%PFv, G, GV, US, & CS%PressureForce_CSp, CS%ALE_CSp, p_surf) call cpu_clock_end(id_clock_pres) if (associated(CS%OBC)) then; if (CS%OBC%update_OBC) then - call update_OBC_data(CS%OBC, G, GV, tv, h, CS%update_OBC_CSp, Time_local) + call update_OBC_data(CS%OBC, G, GV, US, tv, h, CS%update_OBC_CSp, Time_local) endif; endif if (associated(CS%OBC)) then call open_boundary_zero_normal_flow(CS%OBC, G, CS%PFu, CS%PFv) @@ -428,10 +408,10 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! upp <- upp + dt/2 d/dz visc d/dz upp call cpu_clock_begin(id_clock_vertvisc) - call vertvisc_coef(upp, vpp, hp, forces, visc, dt*0.5, G, GV, & + call vertvisc_coef(upp, vpp, hp, forces, visc, dt*0.5, G, GV, US, & CS%vertvisc_CSp, CS%OBC) call vertvisc(upp, vpp, hp, forces, visc, dt*0.5, CS%OBC, CS%ADp, CS%CDp, & - G, GV, CS%vertvisc_CSp, Waves=Waves) + G, GV, US, CS%vertvisc_CSp, Waves=Waves) call cpu_clock_end(id_clock_vertvisc) call pass_vector(upp, vpp, G%Domain, clock=id_clock_pass) @@ -475,12 +455,12 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! PFu = d/dx M(h_av,T,S) call cpu_clock_begin(id_clock_pres) - call PressureForce(h_av, tv, CS%PFu, CS%PFv, G, GV, & + call PressureForce(h_av, tv, CS%PFu, CS%PFv, G, GV, US, & CS%PressureForce_CSp, CS%ALE_CSp, p_surf) call cpu_clock_end(id_clock_pres) if (associated(CS%OBC)) then; if (CS%OBC%update_OBC) then - call update_OBC_data(CS%OBC, G, GV, tv, h, CS%update_OBC_CSp, Time_local) + call update_OBC_data(CS%OBC, G, GV, US, tv, h, CS%update_OBC_CSp, Time_local) endif; endif ! u = u + dt * ( PFu + CAu ) @@ -499,9 +479,9 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! u <- u + dt d/dz visc d/dz u call cpu_clock_begin(id_clock_vertvisc) - call vertvisc_coef(u, v, h_av, forces, visc, dt, G, GV, CS%vertvisc_CSp, CS%OBC) + call vertvisc_coef(u, v, h_av, forces, visc, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC) call vertvisc(u, v, h_av, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, & - G, GV, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, Waves=Waves) + G, GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, Waves=Waves) call cpu_clock_end(id_clock_vertvisc) call pass_vector(u, v, G%Domain, clock=id_clock_pass) @@ -512,7 +492,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & endif if (GV%Boussinesq) then - do j=js,je ; do i=is,ie ; eta_av(i,j) = -G%bathyT(i,j) ; enddo ; enddo + do j=js,je ; do i=is,ie ; eta_av(i,j) = -GV%Z_to_H*G%bathyT(i,j) ; enddo ; enddo else do j=js,je ; do i=is,ie ; eta_av(i,j) = 0.0 ; enddo ; enddo endif @@ -533,6 +513,11 @@ end subroutine step_MOM_dyn_unsplit ! ============================================================================= +!> Allocate the control structure for this module, allocates memory in it, and registers +!! any auxiliary restart variables that are specific to the unsplit time stepping scheme. +!! +!! All variables registered here should have the ability to be recreated if they are not present +!! in a restart file. subroutine register_restarts_dyn_unsplit(HI, GV, param_file, CS, 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. @@ -542,24 +527,14 @@ subroutine register_restarts_dyn_unsplit(HI, GV, param_file, CS, restart_CS) !! initialize_dyn_unsplit. type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure. -! This subroutine sets up any auxiliary restart variables that are specific -! to the unsplit time stepping scheme. All variables registered here should -! have the ability to be recreated if they are not present in a restart file. - -! Arguments: HI - A horizontal index type structure. -! (in) GV - The ocean's vertical grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (inout) CS - The control structure set up by initialize_dyn_unsplit. -! (inout) restart_CS - A pointer to the restart control structure. - + ! Local arguments character(len=40) :: mdl = "MOM_dynamics_unsplit" ! This module's name. character(len=48) :: thickness_units, flux_units integer :: isd, ied, jsd, jed, nz, IsdB, IedB, JsdB, JedB isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke IsdB = HI%IsdB ; IedB = HI%IedB ; JsdB = HI%JsdB ; JedB = HI%JedB -! This is where a control structure that is specific to this module would be allocated. + ! This is where a control structure that is specific to this module is allocated. if (associated(CS)) then call MOM_error(WARNING, "register_restarts_dyn_unsplit called with an associated "// & "control structure.") @@ -581,20 +556,20 @@ subroutine register_restarts_dyn_unsplit(HI, GV, param_file, CS, restart_CS) end subroutine register_restarts_dyn_unsplit -subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, param_file, diag, CS, & +!> Initialize parameters and allocate memory associated with the unsplit dynamics module. +subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS, & restart_CS, Accel_diag, Cont_diag, MIS, & OBC, update_OBC_CSp, ALE_CSp, setVisc_CSp, & visc, dirs, ntrunc) 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(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(inout) :: u !< The zonal velocity, in m s-1. + intent(inout) :: u !< The zonal velocity [m s-1]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & - intent(inout) :: v !< The meridional velocity, in m s-1. + intent(inout) :: 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] type(time_type), target, intent(in) :: Time !< The current model time. type(param_file_type), intent(in) :: param_file !< A structure to parse !! for run-time parameters. @@ -632,39 +607,10 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, param_file, diag, CS, & !! records the number of times the velocity !! is truncated (this should be 0). -! Arguments: u - The zonal velocity, in m s-1. -! (inout) v - The meridional velocity, in m s-1. -! (inout) h - The layer thicknesses, in m or kg m-2, depending on whether -! the Boussinesq approximation is made. -! (in) Time - The current model time. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in) diag - A structure that is used to regulate diagnostic output. -! (inout) CS - The control structure set up by initialize_dyn_unsplit. -! (in) restart_CS - A pointer to the restart control structure. -! (inout) Accel_diag - A set of pointers to the various accelerations in -! the momentum equations, which can be used for later derived -! diagnostics, like energy budgets. -! (inout) Cont_diag - A structure with pointers to various terms in the -! continuity equations. -! (inout) MIS - The "MOM6 Internal State" structure, used to pass around -! pointers to various arrays for diagnostic purposes. -! (in) OBC - If open boundary conditions are used, this points to the -! ocean_OBC_type that was set up in MOM_initialization. -! (in) update_OBC_CSp - If open boundary condition updates are used, -! this points to the appropriate control structure. -! (in) ALE_CS - This points to the ALE control structure. -! (in) setVisc_CSp - This points to the set_visc control structure. -! (inout) visc - A structure containing vertical viscosities, bottom drag -! viscosities, and related fields. -! (in) dirs - A structure containing several relevant directory paths. -! (in) ntrunc - A target for the variable that records the number of times -! the velocity is truncated (this should be 0). - ! This subroutine initializes all of the variables that are used by this ! dynamic core, including diagnostics and the cpu clocks. + + ! Local variables character(len=40) :: mdl = "MOM_dynamics_unsplit" ! This module's name. character(len=48) :: thickness_units, flux_units real :: H_convert @@ -705,10 +651,10 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, param_file, diag, CS, & call continuity_init(Time, G, GV, param_file, diag, CS%continuity_CSp) call CoriolisAdv_init(Time, G, param_file, diag, CS%ADp, CS%CoriolisAdv_CSp) if (use_tides) call tidal_forcing_init(Time, G, param_file, CS%tides_CSp) - call PressureForce_init(Time, G, GV, param_file, diag, CS%PressureForce_CSp, & + call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, & CS%tides_CSp) call hor_visc_init(Time, G, param_file, diag, CS%hor_visc_CSp) - call vertvisc_init(MIS, Time, G, GV, param_file, diag, CS%ADp, dirs, & + call vertvisc_init(MIS, Time, G, GV, US, param_file, diag, CS%ADp, dirs, & ntrunc, CS%vertvisc_CSp) if (.not.associated(setVisc_CSp)) call MOM_error(FATAL, & "initialize_dyn_unsplit called with setVisc_CSp unassociated.") @@ -746,9 +692,10 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, param_file, diag, CS, & end subroutine initialize_dyn_unsplit +!> Clean up and deallocate memory associated with the unsplit dynamics module. subroutine end_dyn_unsplit(CS) - type(MOM_dyn_unsplit_CS), pointer :: CS -! (inout) CS - The control structure set up by initialize_dyn_unsplit. + type(MOM_dyn_unsplit_CS), pointer :: CS !< unsplit dynamics control structure that + !! will be deallocated in this subroutine. DEALLOC_(CS%diffu) ; DEALLOC_(CS%diffv) DEALLOC_(CS%CAu) ; DEALLOC_(CS%CAv) diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index 87759b0575..e3625dd6a3 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -1,3 +1,4 @@ +!> Time steps the ocean dynamics with an unsplit quasi 2nd order Runge-Kutta scheme module MOM_dynamics_unsplit_RK2 ! This file is part of MOM6. See LICENSE.md for the license. @@ -69,7 +70,7 @@ module MOM_dynamics_unsplit_RK2 use MOM_io, only : MOM_io_init use MOM_restart, only : register_restart_field, query_initialized, save_restart use MOM_restart, only : restart_init, MOM_restart_CS -use MOM_time_manager, only : time_type, set_time, time_type_to_real, operator(+) +use MOM_time_manager, only : time_type, time_type_to_real, operator(+) use MOM_time_manager, only : operator(-), operator(>), operator(*), operator(/) use MOM_ALE, only : ALE_CS @@ -88,6 +89,7 @@ module MOM_dynamics_unsplit_RK2 use MOM_PressureForce, only : PressureForce, PressureForce_init, PressureForce_CS use MOM_set_visc, only : set_viscous_ML, set_visc_CS use MOM_tidal_forcing, only : tidal_forcing_init, tidal_forcing_CS +use MOM_unit_scaling, only : unit_scale_type use MOM_vert_friction, only : vertvisc, vertvisc_coef use MOM_vert_friction, only : vertvisc_limit_vel, vertvisc_init, vertvisc_CS use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units @@ -97,93 +99,102 @@ module MOM_dynamics_unsplit_RK2 #include +!> MOM_dynamics_unsplit_RK2 module control structure type, public :: MOM_dyn_unsplit_RK2_CS ; private real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: & - CAu, & ! CAu = f*v - u.grad(u) in m s-2. - PFu, & ! PFu = -dM/dx, in m s-2. - diffu ! Zonal acceleration due to convergence of the along-isopycnal - ! stress tensor, in m s-2. - real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: & - CAv, & ! CAv = -f*u - u.grad(v) in m s-2. - PFv, & ! PFv = -dM/dy, in m s-2. - diffv ! Meridional acceleration due to convergence of the - ! along-isopycnal stress tensor, in m s-2. + CAu, & !< CAu = f*v - u.grad(u) [m s-2]. + PFu, & !< PFu = -dM/dx [m s-2]. + diffu !< Zonal acceleration due to convergence of the along-isopycnal stress tensor [m s-2]. + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: & + CAv, & !< CAv = -f*u - u.grad(v) [m s-2]. + PFv, & !< PFv = -dM/dy [m s-2]. + diffv !< Meridional acceleration due to convergence of the along-isopycnal stress tensor [m s-2]. - real, pointer, dimension(:,:) :: taux_bot => NULL(), tauy_bot => NULL() - ! The frictional bottom stresses from the ocean to the seafloor, in Pa. + real, pointer, dimension(:,:) :: taux_bot => NULL() !< frictional x-bottom stress from the ocean to the seafloor (Pa) + real, pointer, dimension(:,:) :: tauy_bot => NULL() !< frictional y-bottom stress from the ocean to the seafloor (Pa) - real :: be ! A nondimensional number from 0.5 to 1 that controls - ! the backward weighting of the time stepping scheme. - real :: begw ! A nondimensional 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. - logical :: debug ! If true, write verbose checksums for debugging purposes. + real :: be !< A nondimensional number from 0.5 to 1 that controls + !! the backward weighting of the time stepping scheme. + real :: begw !< A nondimensional 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. + logical :: debug !< If true, write verbose checksums for debugging purposes. - logical :: module_is_initialized = .false. + logical :: module_is_initialized = .false. !< Record whether this mouled has been initialzed. + !>@{ Diagnostic IDs integer :: id_uh = -1, id_vh = -1 integer :: id_PFu = -1, id_PFv = -1, id_CAu = -1, id_CAv = -1 - - type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the - ! timing of diagnostic output. - type(accel_diag_ptrs), pointer :: ADp ! A structure pointing to the various - ! accelerations in the momentum equations, - ! which can later be used to calculate - ! derived diagnostics like energy budgets. - type(cont_diag_ptrs), pointer :: CDp ! A structure with pointers to various - ! terms in the continuity equations, - ! which can later be used to calculate - ! derived diagnostics like energy budgets. - -! The remainder of the structure is pointers to child subroutines' control strings. + !!@} + + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + type(accel_diag_ptrs), pointer :: ADp => NULL() !< A structure pointing to the + !! accelerations in the momentum equations, + !! which can later be used to calculate + !! derived diagnostics like energy budgets. + type(cont_diag_ptrs), pointer :: CDp => NULL() !< A structure with pointers to + !! various terms in the continuity equations, + !! which can later be used to calculate + !! derived diagnostics like energy budgets. + + ! The remainder of the structure points to child subroutines' control structures. + !> A pointer to the horizontal viscosity control structure type(hor_visc_CS), pointer :: hor_visc_CSp => NULL() + !> A pointer to the continuity control structure type(continuity_CS), pointer :: continuity_CSp => NULL() + !> A pointer to the CoriolisAdv control structure type(CoriolisAdv_CS), pointer :: CoriolisAdv_CSp => NULL() + !> A pointer to the PressureForce control structure type(PressureForce_CS), pointer :: PressureForce_CSp => NULL() + !> A pointer to the vertvisc control structure type(vertvisc_CS), pointer :: vertvisc_CSp => NULL() + !> A pointer to the set_visc control structure type(set_visc_CS), pointer :: set_visc_CSp => NULL() - type(ocean_OBC_type), pointer :: OBC => NULL() ! A pointer to an open boundary - ! condition type that specifies whether, where, and what open boundary - ! conditions are used. If no open BCs are used, this pointer stays - ! nullified. Flather OBCs use open boundary_CS as well. + !> A pointer to the tidal forcing control structure type(tidal_forcing_CS), pointer :: tides_CSp => NULL() - type(update_OBC_CS), pointer :: update_OBC_CSp => NULL() - -! This is a copy of the pointer in the top-level control structure. + !> A pointer to the ALE control structure. type(ALE_CS), pointer :: ALE_CSp => NULL() + type(ocean_OBC_type), pointer :: OBC => NULL() !< A pointer to an open boundary + !! condition type that specifies whether, where, and what open boundary + !! conditions are used. If no open BCs are used, this pointer stays + !! nullified. Flather OBCs use open boundary_CS as well. + !> A pointer to the update_OBC control structure + type(update_OBC_CS), pointer :: update_OBC_CSp => NULL() + end type MOM_dyn_unsplit_RK2_CS public step_MOM_dyn_unsplit_RK2, register_restarts_dyn_unsplit_RK2 public initialize_dyn_unsplit_RK2, end_dyn_unsplit_RK2 +!>@{ CPU time clock IDs integer :: id_clock_Cor, id_clock_pres, id_clock_vertvisc integer :: id_clock_horvisc, id_clock_continuity, id_clock_mom_update integer :: id_clock_pass, id_clock_pass_init +!!@} contains ! ============================================================================= +!> Step the MOM6 dynamics using an unsplit quasi-2nd order Runge-Kutta scheme subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, forces, & - p_surf_begin, p_surf_end, uh, vh, uhtr, vhtr, eta_av, G, GV, CS, & + p_surf_begin, p_surf_end, uh, vh, uhtr, vhtr, eta_av, G, GV, US, CS, & VarMix, MEKE) 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(inout) :: u_in !< The input and output zonal - !! velocity, in m s-1. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & - intent(inout) :: v_in !< The input and output meridional - !! velocity, in m s-1. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(inout) :: h_in !< The input and output layer - !! thicknesses, in m or kg m-2, depending on - !! whether the Boussinesq approximation is made. + 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(inout) :: u_in !< The input and output zonal + !! velocity [m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: v_in !< The input and output meridional + !! velocity [m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h_in !< The input and output layer thicknesses, + !! [H ~> m or kg m-2], depending on whether + !! the Boussinesq approximation is made. type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various !! thermodynamic variables. type(vertvisc_type), intent(inout) :: visc !< A structure containing vertical @@ -191,31 +202,26 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, !! viscosities, and related fields. type(time_type), intent(in) :: Time_local !< The model time at the end of !! the time step. - real, intent(in) :: dt !< The baroclinic dynamics time step, - !! in s. + real, intent(in) :: dt !< The baroclinic dynamics time step [s]. type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces real, dimension(:,:), pointer :: p_surf_begin !< A pointer (perhaps NULL) to - !! the surface pressure at the beginning - !! of this dynamic step, in Pa. + !! the surface pressure at the beginning + !! of this dynamic step [Pa]. real, dimension(:,:), pointer :: p_surf_end !< A pointer (perhaps NULL) to !! the surface pressure at the end of - !! this dynamic step, in Pa. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & - intent(inout) :: uh !< The zonal volume or mass transport, - !! in m3 s-1 or kg s-1. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & - intent(inout) :: vh !< The meridional volume or mass - !! transport, in m3 s-1 or kg s-1. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & - intent(inout) :: uhtr !< The accumulated zonal volume or + !! this dynamic step [Pa]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: uh !< The zonal volume or mass transport + !! [H m2 s-1 ~> m3 or kg s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: vh !< The meridional volume or mass + !! transport [H m2 s-1 ~> m3 or kg s-1]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: uhtr !< The accumulated zonal volume or !! mass transport since the last - !! tracer advection, in m3 or kg. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & - intent(inout) :: vhtr !< The accumulated meridional volume + !! tracer advection [H m2 ~> m3 or kg]. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: vhtr !< The accumulated meridional volume !! or mass transport since the last - !! tracer advection, in m3 or kg. + !! tracer advection [H m2 ~> m3 or kg]. real, dimension(SZI_(G),SZJ_(G)), intent(out) :: eta_av !< The time-mean free surface height - !! or column mass, in m or kg m-2. + !! or column mass [H ~> m or kg m-2]. type(MOM_dyn_unsplit_RK2_CS), pointer :: CS !< The control structure set up by !! initialize_dyn_unsplit_RK2. type(VarMix_CS), pointer :: VarMix !< A pointer to a structure with @@ -224,41 +230,12 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, type(MEKE_type), pointer :: MEKE !< A pointer to a structure containing !! fields related to the Mesoscale !! Eddy Kinetic Energy. -! Arguments: u_in - The input and output zonal velocity, in m s-1. -! (inout) v_in - The input and output meridional velocity, in m s-1. -! (inout) h_in - The input and output layer thicknesses, in m or kg m-2, -! depending on whether the Boussinesq approximation is made. -! (in) tv - a structure pointing to various thermodynamic variables. -! (inout) visc - A structure containing vertical viscosities, bottom drag -! viscosities, and related fields. -! (in) Time_local - The model time at the end of the time step. -! (in) dt - The time step in s. -! (in) fluxes - A structure containing pointers to any possible -! forcing fields. Unused fields have NULL ptrs. -! (in) p_surf_begin - A pointer (perhaps NULL) to the surface pressure -! at the beginning of this dynamic step, in Pa. -! (in) p_surf_end - A pointer (perhaps NULL) to the surface pressure -! at the end of this dynamic step, in Pa. -! (inout) uh - The zonal volume or mass transport, in m3 s-1 or kg s-1. -! (inout) vh - The meridional volume or mass transport, in m3 s-1 or kg s-1. -! (inout) uhtr - The accumulated zonal volume or mass transport since the last -! tracer advection, in m3 or kg. -! (inout) vhtr - The accumulated meridional volume or mass transport since the last -! tracer advection, in m3 or kg. -! (out) eta_av - The time-mean free surface height or column mass, in m or -! kg m-2. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - The control structure set up by initialize_dyn_unsplit_RK2. -! (in) VarMix - A pointer to a structure with fields that specify the -! spatially variable viscosities. -! (inout) MEKE - A pointer to a structure containing fields related to -! the Mesoscale Eddy Kinetic Energy. + ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_av, hp real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: up real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: vp - real, dimension(:,:), pointer :: p_surf + real, dimension(:,:), pointer :: p_surf => NULL() real :: dt_pred ! The time step for the predictor part of the baroclinic ! time stepping. logical :: dyn_p_surf @@ -326,14 +303,14 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, if (dyn_p_surf) then ; do j=js-2,je+2 ; do i=is-2,ie+2 p_surf(i,j) = 0.5*p_surf_begin(i,j) + 0.5*p_surf_end(i,j) enddo ; enddo ; endif - call PressureForce(h_in, tv, CS%PFu, CS%PFv, G, GV, & + call PressureForce(h_in, tv, CS%PFu, CS%PFv, G, GV, US, & CS%PressureForce_CSp, CS%ALE_CSp, p_surf) call cpu_clock_end(id_clock_pres) call pass_vector(CS%PFu, CS%PFv, G%Domain, clock=id_clock_pass) call pass_vector(CS%CAu, CS%CAv, G%Domain, clock=id_clock_pass) if (associated(CS%OBC)) then; if (CS%OBC%update_OBC) then - call update_OBC_data(CS%OBC, G, GV, tv, h_in, CS%update_OBC_CSp, Time_local) + call update_OBC_data(CS%OBC, G, GV, US, tv, h_in, CS%update_OBC_CSp, Time_local) endif; endif if (associated(CS%OBC)) then call open_boundary_zero_normal_flow(CS%OBC, G, CS%PFu, CS%PFv) @@ -360,13 +337,13 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, ! up[n-1/2] <- up*[n-1/2] + dt/2 d/dz visc d/dz up[n-1/2] call cpu_clock_begin(id_clock_vertvisc) call enable_averaging(dt, Time_local, CS%diag) - call set_viscous_ML(up, vp, h_av, tv, forces, visc, dt_pred, G, GV, & + call set_viscous_ML(up, vp, h_av, tv, forces, visc, dt_pred, G, GV, US, & CS%set_visc_CSp) call disable_averaging(CS%diag) - call vertvisc_coef(up, vp, h_av, forces, visc, dt_pred, G, GV, & + call vertvisc_coef(up, vp, h_av, forces, visc, dt_pred, G, GV, US, & CS%vertvisc_CSp, CS%OBC) call vertvisc(up, vp, h_av, forces, visc, dt_pred, CS%OBC, CS%ADp, CS%CDp, & - G, GV, CS%vertvisc_CSp) + G, GV, US, CS%vertvisc_CSp) call cpu_clock_end(id_clock_vertvisc) call pass_vector(up, vp, G%Domain, clock=id_clock_pass) @@ -416,14 +393,14 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, ! up[n] <- up* + dt d/dz visc d/dz up ! u[n] <- u*[n] + dt d/dz visc d/dz u[n] call cpu_clock_begin(id_clock_vertvisc) - call vertvisc_coef(up, vp, h_av, forces, visc, dt, G, GV, & + call vertvisc_coef(up, vp, h_av, forces, visc, dt, G, GV, US, & CS%vertvisc_CSp, CS%OBC) call vertvisc(up, vp, h_av, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, & - G, GV, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot) - call vertvisc_coef(u_in, v_in, h_av, forces, visc, dt, G, GV, & + G, GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot) + call vertvisc_coef(u_in, v_in, h_av, forces, visc, dt, G, GV, US, & CS%vertvisc_CSp, CS%OBC) call vertvisc(u_in, v_in, h_av, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp,& - G, GV, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot) + G, GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot) call cpu_clock_end(id_clock_vertvisc) call pass_vector(up, vp, G%Domain, clock=id_clock_pass) call pass_vector(u_in, v_in, G%Domain, clock=id_clock_pass) @@ -454,7 +431,7 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, endif if (GV%Boussinesq) then - do j=js,je ; do i=is,ie ; eta_av(i,j) = -G%bathyT(i,j) ; enddo ; enddo + do j=js,je ; do i=is,ie ; eta_av(i,j) = -GV%Z_to_H*G%bathyT(i,j) ; enddo ; enddo else do j=js,je ; do i=is,ie ; eta_av(i,j) = 0.0 ; enddo ; enddo endif @@ -479,6 +456,11 @@ end subroutine step_MOM_dyn_unsplit_RK2 ! ============================================================================= +!> Allocate the control structure for this module, allocates memory in it, and registers +!! any auxiliary restart variables that are specific to the unsplit RK2 time stepping scheme. +!! +!! All variables registered here should have the ability to be recreated if they are not present +!! in a restart file. subroutine register_restarts_dyn_unsplit_RK2(HI, GV, param_file, CS, 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. @@ -492,13 +474,7 @@ subroutine register_restarts_dyn_unsplit_RK2(HI, GV, param_file, CS, restart_CS) ! to the unsplit time stepping scheme. All variables registered here should ! have the ability to be recreated if they are not present in a restart file. -! Arguments: HI - A horizontal index type structure. -! (in) GV - The ocean's vertical grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (inout) CS - The control structure set up by initialize_dyn_unsplit_RK2. -! (inout) restart_CS - A pointer to the restart control structure. - + ! Local variables character(len=48) :: thickness_units, flux_units integer :: isd, ied, jsd, jed, nz, IsdB, IedB, JsdB, JedB isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke @@ -526,18 +502,17 @@ subroutine register_restarts_dyn_unsplit_RK2(HI, GV, param_file, CS, restart_CS) end subroutine register_restarts_dyn_unsplit_RK2 -subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, param_file, diag, CS, & +!> Initialize parameters and allocate memory associated with the unsplit RK2 dynamics module. +subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag, CS, & restart_CS, Accel_diag, Cont_diag, MIS, & OBC, update_OBC_CSp, ALE_CSp, setVisc_CSp, & visc, dirs, ntrunc) 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(inout) :: u !< The zonal velocity, in m s-1. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: v !< The meridional velocity, - !! in m s-1. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) , intent(inout) :: h !< Layer thicknesses, in H - !! (usually m or kg m-2). + 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(inout) :: u !< The zonal velocity [m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: v !< The meridional velocity [m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) , intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] type(time_type), target, intent(in) :: Time !< The current model time. type(param_file_type), intent(in) :: param_file !< A structure to parse !! for run-time parameters. @@ -550,7 +525,7 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, param_file, diag, CS type(accel_diag_ptrs), target, intent(inout) :: Accel_diag !< A set of pointers to the !! various accelerations in the momentum equations, which can !! be used for later derived diagnostics, like energy budgets. - type(cont_diag_ptrs), target, intent(inout) :: Cont_diag ! Clean up and deallocate memory associated with the dyn_unsplit_RK2 module. subroutine end_dyn_unsplit_RK2(CS) - type(MOM_dyn_unsplit_RK2_CS), pointer :: CS -! (inout) CS - The control structure set up by initialize_dyn_unsplit_RK2. + type(MOM_dyn_unsplit_RK2_CS), pointer :: CS !< dyn_unsplit_RK2 control structure that + !! will be deallocated in this subroutine. DEALLOC_(CS%diffu) ; DEALLOC_(CS%diffv) DEALLOC_(CS%CAu) ; DEALLOC_(CS%CAv) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 2d94984d4e..465cdf2c28 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -13,6 +13,7 @@ module MOM_forcing_type use MOM_grid, only : ocean_grid_type use MOM_shortwave_abs, only : sumSWoverBands, optics_type use MOM_spatial_means, only : global_area_integral, global_area_mean +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface, thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type @@ -26,136 +27,143 @@ module MOM_forcing_type public extractFluxes1d, extractFluxes2d, optics_type public MOM_forcing_chksum, MOM_mech_forcing_chksum -public calculateBuoyancyFlux1d, calculateBuoyancyFlux2d, forcing_accumulate +public calculateBuoyancyFlux1d, calculateBuoyancyFlux2d +public forcing_accumulate, fluxes_accumulate public forcing_SinglePointPrint, mech_forcing_diags, forcing_diagnostics public register_forcing_type_diags, allocate_forcing_type, deallocate_forcing_type public copy_common_forcing_fields, allocate_mech_forcing, deallocate_mech_forcing -public set_derived_forcing_fields, copy_back_forcing_fields, set_net_mass_forcing +public set_derived_forcing_fields, copy_back_forcing_fields +public set_net_mass_forcing, get_net_mass_forcing -!> Structure that contains pointers to the boundary forcing -!! used to drive the liquid ocean simulated by MOM. -!! Data in this type is allocated in the module -!! MOM_surface_forcing.F90, of which there are three: -!! solo, coupled, and ice-shelf. Alternatively, they are -!! allocated in MESO_surface_forcing.F90, which is a -!! special case of solo_driver/MOM_surface_forcing.F90. -type, public :: forcing +! 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. - ! Pointers in this module should be initialized to NULL. +!> Structure that contains pointers to the boundary forcing used to drive the +!! liquid ocean simulated by MOM. +!! +!! Data in this type is allocated in the module MOM_surface_forcing.F90, of which there +!! are three: solo, coupled, and ice-shelf. Alternatively, they are allocated in +!! MESO_surface_forcing.F90, which is a special case of solo_driver/MOM_surface_forcing.F90. +type, public :: forcing ! surface stress components and turbulent velocity scale real, pointer, dimension(:,:) :: & - ustar => NULL(), & !< surface friction velocity scale (m/s) + ustar => NULL(), & !< surface friction velocity scale [Z s-1 ~> m s-1]. ustar_gustless => NULL() !< surface friction velocity scale without any - !! any augmentation for gustiness (m/s) + !! any augmentation for gustiness [Z s-1 ~> m s-1]. ! surface buoyancy force, used when temperature is not a state variable real, pointer, dimension(:,:) :: & - buoy => NULL() !< buoyancy flux (m^2/s^3) + buoy => NULL() !< buoyancy flux [m2 s-3] - ! radiative heat fluxes into the ocean (W/m^2) + ! radiative heat fluxes into the ocean [W m-2] real, pointer, dimension(:,:) :: & - sw => NULL(), & !< shortwave (W/m^2) - sw_vis_dir => NULL(), & !< visible, direct shortwave (W/m^2) - sw_vis_dif => NULL(), & !< visible, diffuse shortwave (W/m^2) - sw_nir_dir => NULL(), & !< near-IR, direct shortwave (W/m^2) - sw_nir_dif => NULL(), & !< near-IR, diffuse shortwave (W/m^2) - lw => NULL() !< longwave (W/m^2) (typically negative) - - ! turbulent heat fluxes into the ocean (W/m^2) + sw => NULL(), & !< shortwave [W m-2] + sw_vis_dir => NULL(), & !< visible, direct shortwave [W m-2] + sw_vis_dif => NULL(), & !< visible, diffuse shortwave [W m-2] + sw_nir_dir => NULL(), & !< near-IR, direct shortwave [W m-2] + sw_nir_dif => NULL(), & !< near-IR, diffuse shortwave [W m-2] + lw => NULL() !< longwave [W m-2] (typically negative) + + ! turbulent heat fluxes into the ocean [W m-2] real, pointer, dimension(:,:) :: & - latent => NULL(), & !< latent (W/m^2) (typically < 0) - sens => NULL(), & !< sensible (W/m^2) (typically negative) - heat_added => NULL() !< additional heat flux from SST restoring or flux adjustments (W/m^2) + latent => NULL(), & !< latent [W m-2] (typically < 0) + sens => NULL(), & !< sensible [W m-2] (typically negative) + seaice_melt_heat => NULL(), & !< sea ice and snow melt or formation [W m-2] (typically negative) + heat_added => NULL() !< additional heat flux from SST restoring or flux adjustments [W m-2] ! components of latent heat fluxes used for diagnostic purposes real, pointer, dimension(:,:) :: & - latent_evap_diag => NULL(), & !< latent (W/m^2) from evaporating liquid water (typically < 0) - latent_fprec_diag => NULL(), & !< latent (W/m^2) from melting fprec (typically < 0) - latent_frunoff_diag => NULL() !< latent (W/m^2) from melting frunoff (calving) (typically < 0) + latent_evap_diag => NULL(), & !< latent [W m-2] from evaporating liquid water (typically < 0) + latent_fprec_diag => NULL(), & !< latent [W m-2] from melting fprec (typically < 0) + latent_frunoff_diag => NULL() !< latent [W m-2] from melting frunoff (calving) (typically < 0) - ! water mass fluxes into the ocean ( kg/(m^2 s) ); these fluxes impact the ocean mass + ! water mass fluxes into the ocean [kg m-2 s-1]; these fluxes impact the ocean mass real, pointer, dimension(:,:) :: & - evap => NULL(), & !< (-1)*fresh water flux evaporated out of the ocean ( kg/(m^2 s) ) - lprec => NULL(), & !< precipitating liquid water into the ocean ( kg/(m^2 s) ) - fprec => NULL(), & !< precipitating frozen water into the ocean ( kg/(m^2 s) ) - vprec => NULL(), & !< virtual liquid precip associated w/ SSS restoring ( kg/(m^2 s) ) - lrunoff => NULL(), & !< liquid river runoff entering ocean ( kg/(m^2 s) ) - frunoff => NULL(), & !< frozen river runoff (calving) entering ocean ( kg/(m^2 s) ) - seaice_melt => NULL(), & !< seaice melt (positive) or formation (negative) ( kg/(m^2 s) ) - netMassIn => NULL(), & !< Sum of water mass flux out of the ocean ( kg/(m^2 s) ) - netMassOut => NULL(), & !< Net water mass flux into of the ocean ( kg/(m^2 s) ) - netSalt => NULL() !< Net salt entering the ocean + evap => NULL(), & !< (-1)*fresh water flux evaporated out of the ocean [kg m-2 s-1] + lprec => NULL(), & !< precipitating liquid water into the ocean [kg m-2 s-1] + fprec => NULL(), & !< precipitating frozen water into the ocean [kg m-2 s-1] + vprec => NULL(), & !< virtual liquid precip associated w/ SSS restoring [kg m-2 s-1] + lrunoff => NULL(), & !< liquid river runoff entering ocean [kg m-2 s-1] + frunoff => NULL(), & !< frozen river runoff (calving) entering ocean [kg m-2 s-1] + seaice_melt => NULL(), & !< snow/seaice melt (positive) or formation (negative) [kg m-2 s-1] + netMassIn => NULL(), & !< Sum of water mass flux out of the ocean [kg m-2 s-1] + netMassOut => NULL(), & !< Net water mass flux into of the ocean [kg m-2 s-1] + netSalt => NULL() !< Net salt entering the ocean [kgSalt m-2 s-1] ! heat associated with water crossing ocean surface real, pointer, dimension(:,:) :: & - heat_content_cond => NULL(), & !< heat content associated with condensating water (W/m^2) - heat_content_lprec => NULL(), & !< heat content associated with liquid >0 precip (W/m^2) (diagnostic) - heat_content_fprec => NULL(), & !< heat content associated with frozen precip (W/m^2) - heat_content_vprec => NULL(), & !< heat content associated with virtual >0 precip (W/m^2) - heat_content_lrunoff => NULL(), & !< heat content associated with liquid runoff (W/m^2) - heat_content_frunoff => NULL(), & !< heat content associated with frozen runoff (W/m^2) - heat_content_icemelt => NULL(), & !< heat content associated with liquid sea ice (W/m^2) - heat_content_massout => NULL(), & !< heat content associated with mass leaving ocean (W/m^2) - heat_content_massin => NULL() !< heat content associated with mass entering ocean (W/m^2) + heat_content_cond => NULL(), & !< heat content associated with condensating water [W m-2] + heat_content_lprec => NULL(), & !< heat content associated with liquid >0 precip [W m-2] (diagnostic) + heat_content_icemelt => NULL(), & !< heat content associated with snow/seaice melt/formation [W/m^2] + heat_content_fprec => NULL(), & !< heat content associated with frozen precip [W m-2] + heat_content_vprec => NULL(), & !< heat content associated with virtual >0 precip [W m-2] + heat_content_lrunoff => NULL(), & !< heat content associated with liquid runoff [W m-2] + heat_content_frunoff => NULL(), & !< heat content associated with frozen runoff [W m-2] + heat_content_massout => NULL(), & !< heat content associated with mass leaving ocean [W m-2] + heat_content_massin => NULL() !< heat content associated with mass entering ocean [W m-2] ! salt mass flux (contributes to ocean mass only if non-Bouss ) real, pointer, dimension(:,:) :: & - salt_flux => NULL(), & !< net salt flux into the ocean ( kg salt/(m^2 s) ) - salt_flux_in => NULL(), & !< salt flux provided to the ocean from coupler ( kg salt/(m^2 s) ) + salt_flux => NULL(), & !< net salt flux into the ocean [kgSalt m-2 s-1] + salt_flux_in => NULL(), & !< salt flux provided to the ocean from coupler [kgSalt m-2 s-1] salt_flux_added => NULL() !< additional salt flux from restoring or flux adjustment before adjustment - !! to net zero ( kg salt/(m^2 s) ) + !! to net zero [kgSalt m-2 s-1] ! applied surface pressure from other component models (e.g., atmos, sea ice, land ice) - real, pointer, dimension(:,:) :: & - p_surf_full => NULL(), & !< Pressure at the top ocean interface (Pa). - !! if there is sea-ice, then p_surf_flux is at ice-ocean interface - p_surf => NULL(), & !< Pressure at the top ocean interface (Pa) as used - !! to drive the ocean model. If p_surf is limited, - !! p_surf may be smaller than p_surf_full, - !! otherwise they are the same. - p_surf_SSH => NULL() !< Pressure at the top ocean interface that is used - !! in corrections to the sea surface height field - !! that is passed back to the calling routines. - !! This may point to p_surf or to p_surf_full. + real, pointer, dimension(:,:) :: p_surf_full => NULL() + !< Pressure at the top ocean interface [Pa]. + !! if there is sea-ice, then p_surf_flux is at ice-ocean interface + real, pointer, dimension(:,:) :: p_surf => NULL() + !< Pressure at the top ocean interface [Pa] as used to drive the ocean model. + !! If p_surf is limited, p_surf may be smaller than p_surf_full, otherwise they are the same. + real, pointer, dimension(:,:) :: p_surf_SSH => NULL() + !< Pressure at the top ocean interface [Pa] that is used in corrections to the sea surface + !! height field that is passed back to the calling routines. + !! p_surf_SSH may point to p_surf or to p_surf_full. + logical :: accumulate_p_surf = .false. !< If true, the surface pressure due to the atmosphere + !! and various types of ice needs to be accumulated, and the + !! surface pressure explicitly reset to zero at the driver level + !! when appropriate. ! tide related inputs real, pointer, dimension(:,:) :: & - TKE_tidal => NULL(), & !< tidal energy source driving mixing in bottom boundary layer (W/m^2) - ustar_tidal => NULL() !< tidal contribution to bottom ustar (m/s) + TKE_tidal => NULL(), & !< tidal energy source driving mixing in bottom boundary layer [W m-2] + ustar_tidal => NULL() !< tidal contribution to bottom ustar [m s-1] ! iceberg related inputs real, pointer, dimension(:,:) :: & - ustar_berg => NULL(), & !< iceberg contribution to top ustar (m/s) - area_berg => NULL(), & !< area of ocean surface covered by icebergs (m2/m2) - mass_berg => NULL() !< mass of icebergs (kg/m2) + ustar_berg => NULL(), & !< iceberg contribution to top ustar [Z s-1 ~> m s-1]. + area_berg => NULL(), & !< area of ocean surface covered by icebergs [m2 m-2] + mass_berg => NULL() !< mass of icebergs [kg m-2] ! land ice-shelf related inputs - real, pointer, dimension(:,:) :: & - ustar_shelf => NULL(), & !< friction velocity under ice-shelves (m/s) + real, pointer, dimension(:,:) :: ustar_shelf => NULL() !< Friction velocity under ice-shelves [Z s-1 ~> m s-1]. !! as computed by the ocean at the previous time step. - frac_shelf_h => NULL(), & !! Fractional ice shelf coverage of h-cells, nondimensional - !! cells, nondimensional from 0 to 1. This is only + real, pointer, dimension(:,:) :: frac_shelf_h => NULL() !< Fractional ice shelf coverage of + !! h-cells, nondimensional from 0 to 1. This is only !! associated if ice shelves are enabled, and are !! exactly 0 away from shelves or on land. - iceshelf_melt => NULL() !< ice shelf melt rate (positive) or freezing (negative) ( m/year ) + real, pointer, dimension(:,:) :: iceshelf_melt => NULL() !< Ice shelf melt rate (positive) + !! or freezing (negative) [m year-1] ! Scalars set by surface forcing modules - real :: vPrecGlobalAdj !< adjustment to restoring vprec to zero out global net ( kg/(m^2 s) ) - real :: saltFluxGlobalAdj !< adjustment to restoring salt flux to zero out global net ( kg salt/(m^2 s) ) - real :: netFWGlobalAdj !< adjustment to net fresh water to zero out global net ( kg/(m^2 s) ) - real :: vPrecGlobalScl !< scaling of restoring vprec to zero out global net ( -1..1 ) - real :: saltFluxGlobalScl !< scaling of restoring salt flux to zero out global net ( -1..1 ) - real :: netFWGlobalScl !< scaling of net fresh water to zero out global net ( -1..1 ) + real :: vPrecGlobalAdj !< adjustment to restoring vprec to zero out global net [kg m-2 s-1] + real :: saltFluxGlobalAdj !< adjustment to restoring salt flux to zero out global net [kgSalt m-2 s-1] + real :: netFWGlobalAdj !< adjustment to net fresh water to zero out global net [kg m-2 s-1] + real :: vPrecGlobalScl !< scaling of restoring vprec to zero out global net ( -1..1 ) [nondim] + real :: saltFluxGlobalScl !< scaling of restoring salt flux to zero out global net ( -1..1 ) [nondim] + real :: netFWGlobalScl !< scaling of net fresh water to zero out global net ( -1..1 ) [nondim] logical :: fluxes_used = .true. !< If true, all of the heat, salt, and mass !! fluxes have been applied to the ocean. - real :: dt_buoy_accum = -1.0 !< The amount of time over which the buoyancy fluxes - !! should be applied, in s. If negative, this forcing + real :: dt_buoy_accum = -1.0 !< The amount of time over which the buoyancy fluxes + !! should be applied [s]. If negative, this forcing !! type variable has not yet been inialized. - ! heat capacity - real :: C_p !< heat capacity of seawater ( J/(K kg) ). + real :: C_p !< heat capacity of seawater [J kg-1 degC-1]. !! C_p is is the same value as in thermovar_ptrs_type. ! passive tracer surface fluxes @@ -165,7 +173,7 @@ module MOM_forcing_type !! This is not a convenient convention, but imposed on MOM6 by the coupler. ! For internal error tracking - integer :: num_msg = 0 !< Number of messages issues about excessive SW penetration + integer :: num_msg = 0 !< Number of messages issued about excessive SW penetration integer :: max_msg = 2 !< Maximum number of messages to issue about excessive SW penetration end type forcing @@ -177,37 +185,56 @@ module MOM_forcing_type type, public :: mech_forcing ! surface stress components and turbulent velocity scale real, pointer, dimension(:,:) :: & - taux => NULL(), & !< zonal wind stress (Pa) - tauy => NULL(), & !< meridional wind stress (Pa) - ustar => NULL(), & !< surface friction velocity scale (m/s) + taux => NULL(), & !< zonal wind stress [Pa] + tauy => NULL(), & !< meridional wind stress [Pa] + ustar => NULL(), & !< surface friction velocity scale [Z s-1 ~> m s-1]. + net_mass_src => NULL() !< The net mass source to the ocean [kg m-2 s-1]. ! applied surface pressure from other component models (e.g., atmos, sea ice, land ice) - p_surf_full => NULL(), & !< Pressure at the top ocean interface (Pa). - !! if there is sea-ice, then p_surf_flux is at ice-ocean interface - p_surf => NULL(), & !< Pressure at the top ocean interface (Pa) as used - !! to drive the ocean model. If p_surf is limited, - !! p_surf may be smaller than p_surf_full, - !! otherwise they are the same. - p_surf_SSH => NULL(), & !< Pressure at the top ocean interface that is used - !! in corrections to the sea surface height field - !! that is passed back to the calling routines. - !! This may point to p_surf or to p_surf_full. - net_mass_src => NULL(), & !< The net mass source to the ocean, in kg m-2 s-1. + real, pointer, dimension(:,:) :: p_surf_full => NULL() + !< Pressure at the top ocean interface [Pa]. + !! if there is sea-ice, then p_surf_flux is at ice-ocean interface + real, pointer, dimension(:,:) :: p_surf => NULL() + !< Pressure at the top ocean interface [Pa] as used to drive the ocean model. + !! If p_surf is limited, p_surf may be smaller than p_surf_full, otherwise they are the same. + real, pointer, dimension(:,:) :: p_surf_SSH => NULL() + !< Pressure at the top ocean interface that is used in corrections to the sea surface + !! height field that is passed back to the calling routines. + !! p_surf_SSH may point to p_surf or to p_surf_full. + + ! iceberg related inputs + real, pointer, dimension(:,:) :: & + area_berg => NULL(), & !< fractional area of ocean surface covered by icebergs [m2 m-2] + mass_berg => NULL() !< mass of icebergs per unit ocean area [kg m-2] ! land ice-shelf related inputs - frac_shelf_u => NULL(), & !< Fractional ice shelf coverage of u-cells, nondimensional - !! from 0 to 1. This is only associated if ice shelves are - !< enabled, and is exactly 0 away from shelves or on land. - frac_shelf_v => NULL(), & !< Fractional ice shelf coverage of v-cells, nondimensional - !! from 0 to 1. This is only associated if ice shelves are - !< enabled, and is exactly 0 away from shelves or on land. - rigidity_ice_u => NULL(), & !< Depth-integrated lateral viscosity of ice - rigidity_ice_v => NULL() !< shelves or sea ice at u- or v-points (m3/s) + real, pointer, dimension(:,:) :: frac_shelf_u => NULL() !< Fractional ice shelf coverage of u-cells, + !! nondimensional from 0 to 1 [nondim]. This is only associated if ice shelves are enabled, + !! and is exactly 0 away from shelves or on land. + real, pointer, dimension(:,:) :: frac_shelf_v => NULL() !< Fractional ice shelf coverage of v-cells, + !! nondimensional from 0 to 1 [nondim]. This is only associated if ice shelves are enabled, + !! and is exactly 0 away from shelves or on land. + real, pointer, dimension(:,:) :: & + rigidity_ice_u => NULL(), & !< Depth-integrated lateral viscosity of ice shelves or sea ice at u-points [m3 s-1] + rigidity_ice_v => NULL() !< Depth-integrated lateral viscosity of ice shelves or sea ice at v-points [m3 s-1] + real :: dt_force_accum = -1.0 !< The amount of time over which the mechanical forcing fluxes + !! have been averaged [s]. + logical :: net_mass_src_set = .false. !< If true, an estimate of net_mass_src has been provided. + logical :: accumulate_p_surf = .false. !< If true, the surface pressure due to the atmosphere + !! and various types of ice needs to be accumulated, and the + !! surface pressure explicitly reset to zero at the driver level + !! when appropriate. + logical :: accumulate_rigidity = .false. !< If true, the rigidity due to various types of + !! ice needs to be accumulated, and the rigidity explicitly + !! reset to zero at the driver level when appropriate. + + logical :: initialized = .false. !< This indicates whether the appropriate arrays have been initialized. end type mech_forcing !> Structure that defines the id handles for the forcing type type, public :: forcing_diags + !>@{ Forcing diagnostic handles ! mass flux diagnostic handles integer :: id_prcme = -1, id_evap = -1 integer :: id_precip = -1, id_vprec = -1 @@ -243,7 +270,7 @@ module MOM_forcing_type integer :: id_heat_content_vprec = -1, id_heat_content_massout = -1 integer :: id_heat_added = -1, id_heat_content_massin = -1 integer :: id_hfrainds = -1, id_hfrunoffds = -1 - + integer :: id_seaice_melt_heat = -1, id_heat_content_icemelt = -1 ! global area integrated heat flux diagnostic handles integer :: id_total_net_heat_coupler = -1, id_total_net_heat_surface = -1 @@ -256,6 +283,7 @@ module MOM_forcing_type integer :: id_total_heat_content_cond = -1, id_total_heat_content_surfwater= -1 integer :: id_total_heat_content_vprec = -1, id_total_heat_content_massout = -1 integer :: id_total_heat_added = -1, id_total_heat_content_massin = -1 + integer :: id_total_seaice_melt_heat = -1, id_total_heat_content_icemelt = -1 ! global area averaged heat flux diagnostic handles integer :: id_net_heat_coupler_ga = -1, id_net_heat_surface_ga = -1 @@ -279,7 +307,7 @@ module MOM_forcing_type integer :: id_netFWGlobalAdj = -1 integer :: id_netFWGlobalScl = -1 - ! momentum flux diagnostic handls + ! momentum flux and forcing diagnostic handles integer :: id_taux = -1 integer :: id_tauy = -1 integer :: id_ustar = -1 @@ -288,17 +316,17 @@ module MOM_forcing_type integer :: id_TKE_tidal = -1 integer :: id_buoy = -1 - ! clock id handle - integer :: id_clock_forcing - - ! iceberg id handle + ! iceberg diagnostic handles integer :: id_ustar_berg = -1 integer :: id_area_berg = -1 integer :: id_mass_berg = -1 - !Iceberg + Ice shelf + ! Iceberg + Ice shelf diagnostic handles integer :: id_ustar_ice_cover = -1 integer :: id_frac_ice_cover = -1 + !!@} + + integer :: id_clock_forcing = -1 !< CPU clock id end type forcing_diags @@ -309,70 +337,81 @@ module MOM_forcing_type !! This routine multiplies fluxes by dt, so that the result is an accumulation of fluxes !! over a time step. subroutine extractFluxes1d(G, GV, fluxes, optics, nsw, j, dt, & - DepthBeforeScalingFluxes, useRiverHeatContent, useCalvingHeatContent, & + FluxRescaleDepth, useRiverHeatContent, useCalvingHeatContent, & h, T, netMassInOut, netMassOut, net_heat, net_salt, pen_SW_bnd, tv, & - aggregate_FW_forcing, nonpenSW, netmassInOut_rate,net_Heat_Rate, & + aggregate_FW, nonpenSW, netmassInOut_rate,net_Heat_Rate, & net_salt_rate, pen_sw_bnd_Rate, skip_diags) - type(ocean_grid_type), intent(in) :: G !< ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(forcing), intent(inout) :: fluxes !< structure containing pointers to possible - !! forcing fields. NULL unused fields. - type(optics_type), pointer :: optics !< pointer to optics - integer, intent(in) :: nsw !< number of bands of penetrating SW - integer, intent(in) :: j !< j-index to work on - real, intent(in) :: dt !< time step in seconds - real, intent(in) :: DepthBeforeScalingFluxes !< min ocean depth before scale away fluxes (H) - logical, intent(in) :: useRiverHeatContent !< logical for river heat content - logical, intent(in) :: useCalvingHeatContent !< logical for calving heat content + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(forcing), intent(inout) :: fluxes !< structure containing pointers to possible + !! forcing fields. NULL unused fields. + type(optics_type), pointer :: optics !< pointer to optics + integer, intent(in) :: nsw !< number of bands of penetrating SW + integer, intent(in) :: j !< j-index to work on + real, intent(in) :: dt !< time step [s] + real, intent(in) :: FluxRescaleDepth !< min ocean depth before fluxes + !! are scaled away [H ~> m or kg m-2] + logical, intent(in) :: useRiverHeatContent !< logical for river heat content + logical, intent(in) :: useCalvingHeatContent !< logical for calving heat content real, dimension(SZI_(G),SZK_(G)), & - intent(in) :: h !< layer thickness (in H units) + intent(in) :: h !< layer thickness [H ~> m or kg m-2] real, dimension(SZI_(G),SZK_(G)), & - intent(in) :: T !< layer temperatures (deg C) - real, dimension(SZI_(G)), intent(out) :: netMassInOut !< net mass flux (non-Bouss) or volume flux - !! (if Bouss) of water in/out of ocean over - !! a time step (H units) - real, dimension(SZI_(G)), intent(out) :: netMassOut !< net mass flux (non-Bouss) or volume flux - !! (if Bouss) of water leaving ocean surface - !! over a time step (H units). - !! netMassOut < 0 means mass leaves ocean. - real, dimension(SZI_(G)), intent(out) :: net_heat !< net heat at the surface accumulated over a - !! time step for coupler + restoring. - !! Exclude two terms from net_heat: - !! (1) downwelling (penetrative) SW, - !! (2) evaporation heat content, - !! (since do not yet know evap temperature). - !! Units of net_heat are (K * H). - real, dimension(SZI_(G)), intent(out) :: net_salt !< surface salt flux into the ocean accumulated - !! over a time step (ppt * H) - real, dimension(:,:), intent(out) :: pen_SW_bnd !< penetrating SW flux, split into bands. - !! Units are (deg K * H) and array size - !! nsw x SZI_(G), where nsw=number of SW bands - !! in pen_SW_bnd. This heat flux is not part - !! of net_heat. - type(thermo_var_ptrs), intent(inout) :: tv !< structure containing pointers to available - !! thermodynamic fields. Used to keep - !! track of the heat flux associated with net - !! mass fluxes into the ocean. - logical, intent(in) :: aggregate_FW_forcing !< For determining how to aggregate forcing. - real, dimension(SZI_(G)), optional, intent(out) :: nonpenSW !< non-downwelling SW; use in net_heat. - !! Sum over SW bands when diagnosing nonpenSW. - !! Units are (K * H). - real, dimension(SZI_(G)), optional, intent(out) :: net_Heat_rate !< Rate of net surface heating in H K s-1. - real, dimension(SZI_(G)), optional, intent(out) :: net_salt_rate !< Surface salt flux into the ocean in ppt H s-1. - real, dimension(SZI_(G)), optional, intent(out) :: netmassInOut_rate !< Rate of net mass flux into the ocean in H s-1. - real, dimension(:,:), optional, intent(out) :: pen_sw_bnd_rate !< Rate of penetrative shortwave heating in degC H s-1. - logical, optional, intent(in) :: skip_diags !< If present and true, skip calculating diagnostics + intent(in) :: T !< layer temperatures [degC] + real, dimension(SZI_(G)), intent(out) :: netMassInOut !< net mass flux (non-Bouss) or volume flux + !! (if Bouss) of water in/out of ocean over + !! a time step [H ~> m or kg m-2] + real, dimension(SZI_(G)), intent(out) :: netMassOut !< net mass flux (non-Bouss) or volume flux + !! (if Bouss) of water leaving ocean surface + !! over a time step [H ~> m or kg m-2]. + !! netMassOut < 0 means mass leaves ocean. + real, dimension(SZI_(G)), intent(out) :: net_heat !< net heat at the surface accumulated over a + !! time step for coupler + restoring. + !! Exclude two terms from net_heat: + !! (1) downwelling (penetrative) SW, + !! (2) evaporation heat content, + !! (since do not yet know evap temperature). + !! [degC H ~> degC m or degC kg m-2]. + real, dimension(SZI_(G)), intent(out) :: net_salt !< surface salt flux into the ocean + !! accumulated over a time step + !! [ppt H ~> ppt m or ppt kg m-2]. + real, dimension(:,:), intent(out) :: pen_SW_bnd !< penetrating SW flux, split into bands. + !! [degC H ~> degC m or degC kg m-2] + !! and array size nsw x SZI_(G), where + !! nsw=number of SW bands in pen_SW_bnd. + !! This heat flux is not part of net_heat. + type(thermo_var_ptrs), intent(inout) :: tv !< structure containing pointers to available + !! thermodynamic fields. Used to keep + !! track of the heat flux associated with net + !! mass fluxes into the ocean. + logical, intent(in) :: aggregate_FW !< For determining how to aggregate forcing. + real, dimension(SZI_(G)), & + optional, intent(out) :: nonpenSW !< Non-penetrating SW used in net_heat + !! [degC H ~> degC m or degC kg m-2]. + !! Summed over SW bands when diagnosing nonpenSW. + real, dimension(SZI_(G)), & + optional, intent(out) :: net_Heat_rate !< Rate of net surface heating + !! [degC H s-1 ~> degC m s-1 or degC kg m-2 s-1]. + real, dimension(SZI_(G)), & + optional, intent(out) :: net_salt_rate !< Surface salt flux into the ocean + !! [ppt H s-1 ~> ppt m s-1 or ppt kg m-2 s-1]. + real, dimension(SZI_(G)), & + optional, intent(out) :: netmassInOut_rate !< Rate of net mass flux into the ocean + !! [H s-1 ~> m s-1 or kg m-2 s-1]. + real, dimension(:,:), & + optional, intent(out) :: pen_sw_bnd_rate !< Rate of penetrative shortwave heating + !! [degC H s-1 ~> degC m s-1 or degC kg m-2 s-1]. + logical, optional, intent(in) :: skip_diags !< If present and true, skip calculating diagnostics ! local - real :: htot(SZI_(G)) ! total ocean depth (m for Bouss or kg/m^2 for non-Bouss) - real :: Pen_sw_tot(SZI_(G)) ! sum across all bands of Pen_SW (K * H) + real :: htot(SZI_(G)) ! total ocean depth [H ~> m or kg m-2] + real :: Pen_sw_tot(SZI_(G)) ! sum across all bands of Pen_SW [degC H ~> degC m or degC kg m-2]. real :: pen_sw_tot_rate(SZI_(G)) ! Similar but sum but as a rate (no dt in calculation) - real :: Ih_limit ! inverse depth at which surface fluxes start to be limited (1/H) - real :: scale ! scale scales away fluxes if depth < DepthBeforeScalingFluxes + real :: Ih_limit ! inverse depth at which surface fluxes start to be limited [H-1 ~> m-1 or m2 kg-1] + real :: scale ! scale scales away fluxes if depth < FluxRescaleDepth real :: J_m2_to_H ! converts J/m^2 to H units (m for Bouss and kg/m^2 for non-Bouss) - real :: Irho0 ! 1.0 / Rho0 - real :: I_Cp ! 1.0 / C_p + real :: Irho0 ! 1.0 / Rho0 [m3 kg-1] + real :: I_Cp ! 1.0 / C_p [kg decC J-1] logical :: calculate_diags ! Indicate to calculate/update diagnostic arrays character(len=200) :: mesg integer :: is, ie, nz, i, k, n @@ -393,7 +432,7 @@ subroutine extractFluxes1d(G, GV, fluxes, optics, nsw, j, dt, if (present(pen_sw_bnd_rate)) do_PSWBR = .true. !}BGR - Ih_limit = 1.0 / DepthBeforeScalingFluxes + Ih_limit = 1.0 / FluxRescaleDepth Irho0 = 1.0 / GV%Rho0 I_Cp = 1.0 / fluxes%C_p J_m2_to_H = 1.0 / (GV%H_to_kg_m2 * fluxes%C_p) @@ -465,20 +504,22 @@ subroutine extractFluxes1d(G, GV, fluxes, optics, nsw, j, dt, endif ! net volume/mass of liquid and solid passing through surface boundary fluxes - netMassInOut(i) = dt * (scale * ((((( fluxes%lprec(i,j) & - + fluxes%fprec(i,j) ) & - + fluxes%evap(i,j) ) & - + fluxes%lrunoff(i,j) ) & - + fluxes%vprec(i,j) ) & - + fluxes%frunoff(i,j) ) ) + netMassInOut(i) = dt * (scale * (((((( fluxes%lprec(i,j) & + + fluxes%fprec(i,j) ) & + + fluxes%evap(i,j) ) & + + fluxes%lrunoff(i,j) ) & + + fluxes%vprec(i,j) ) & + + fluxes%seaice_melt(i,j)) & + + fluxes%frunoff(i,j) )) if (do_NMIOr) then ! Repeat the above code w/ dt=1s for legacy reasons - netMassInOut_rate(i) = (scale * ((((( fluxes%lprec(i,j) & - + fluxes%fprec(i,j) ) & - + fluxes%evap(i,j) ) & - + fluxes%lrunoff(i,j) ) & - + fluxes%vprec(i,j) ) & - + fluxes%frunoff(i,j) ) ) + netMassInOut_rate(i) = (scale * (((((( fluxes%lprec(i,j) & + + fluxes%fprec(i,j) ) & + + fluxes%evap(i,j) ) & + + fluxes%lrunoff(i,j) ) & + + fluxes%vprec(i,j) ) & + + fluxes%seaice_melt(i,j)) & + + fluxes%frunoff(i,j) )) endif ! smg: @@ -498,20 +539,25 @@ subroutine extractFluxes1d(G, GV, fluxes, optics, nsw, j, dt, ! evap > 0 means condensating water is added into ocean. ! evap < 0 means evaporation of water from the ocean, in ! which case heat_content_evap is computed in MOM_diabatic_driver.F90 - if(fluxes%evap(i,j) < 0.0) then + if (fluxes%evap(i,j) < 0.0) then netMassOut(i) = netMassOut(i) + fluxes%evap(i,j) - ! if(associated(fluxes%heat_content_cond)) fluxes%heat_content_cond(i,j) = 0.0 !??? --AJA + ! if (associated(fluxes%heat_content_cond)) fluxes%heat_content_cond(i,j) = 0.0 !??? --AJA endif ! lprec < 0 means sea ice formation taking water from the ocean. ! smg: we should split the ice melt/formation from the lprec - if(fluxes%lprec(i,j) < 0.0) then + if (fluxes%lprec(i,j) < 0.0) then netMassOut(i) = netMassOut(i) + fluxes%lprec(i,j) endif + ! seaice_melt < 0 means sea ice formation taking water from the ocean. + if (fluxes%seaice_melt(i,j) < 0.0) then + netMassOut(i) = netMassOut(i) + fluxes%seaice_melt(i,j) + endif + ! vprec < 0 means virtual evaporation arising from surface salinity restoring, ! in which case heat_content_vprec is computed in MOM_diabatic_driver.F90. - if(fluxes%vprec(i,j) < 0.0) then + if (fluxes%vprec(i,j) < 0.0) then netMassOut(i) = netMassOut(i) + fluxes%vprec(i,j) endif netMassOut(i) = dt * scale * netMassOut(i) @@ -523,11 +569,24 @@ subroutine extractFluxes1d(G, GV, fluxes, optics, nsw, j, dt, ! surface heat fluxes from radiation and turbulent fluxes (K * H) ! (H=m for Bouss, H=kg/m2 for non-Bouss) - net_heat(i) = scale * dt * J_m2_to_H * & - ( fluxes%sw(i,j) + ((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) ) - !Repeats above code w/ dt=1. for legacy reason - if (do_NHR) net_heat_rate(i) = scale * J_m2_to_H * & - ( fluxes%sw(i,j) + ((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) ) + + ! CIME provides heat flux from snow&ice melt (seaice_melt_heat), so this is added below + if (associated(fluxes%seaice_melt_heat)) then + net_heat(i) = scale * dt * J_m2_to_H * & + ( fluxes%sw(i,j) + ((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j) + & + fluxes%seaice_melt_heat(i,j)) ) + !Repeats above code w/ dt=1. for legacy reason + if (do_NHR) net_heat_rate(i) = scale * J_m2_to_H * & + ( fluxes%sw(i,j) + ((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j) + & + fluxes%seaice_melt_heat(i,j))) + else + net_heat(i) = scale * dt * J_m2_to_H * & + ( fluxes%sw(i,j) + ((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) ) + !Repeats above code w/ dt=1. for legacy reason + if (do_NHR) net_heat_rate(i) = scale * J_m2_to_H * & + ( fluxes%sw(i,j) + ((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) ) + endif + ! Add heat flux from surface damping (restoring) (K * H) or flux adjustments. if (associated(fluxes%heat_added)) then net_heat(i) = net_heat(i) + (scale * (dt * J_m2_to_H)) * fluxes%heat_added(i,j) @@ -630,11 +689,12 @@ subroutine extractFluxes1d(G, GV, fluxes, optics, nsw, j, dt, ! Initialize heat_content_massin that is diagnosed in mixedlayer_convection or ! applyBoundaryFluxes such that the meaning is as the sum of all incoming components. if (associated(fluxes%heat_content_massin)) then - if (aggregate_FW_forcing) then + if (aggregate_FW) then if (netMassInOut(i) > 0.0) then ! net is "in" fluxes%heat_content_massin(i,j) = -fluxes%C_p * netMassOut(i) * T(i,1) * GV%H_to_kg_m2 / dt else ! net is "out" - fluxes%heat_content_massin(i,j) = fluxes%C_p * ( netMassInout(i) - netMassOut(i) ) * T(i,1) * GV%H_to_kg_m2 / dt + fluxes%heat_content_massin(i,j) = fluxes%C_p * ( netMassInout(i) - netMassOut(i) ) * & + T(i,1) * GV%H_to_kg_m2 / dt endif else fluxes%heat_content_massin(i,j) = 0. @@ -644,11 +704,12 @@ subroutine extractFluxes1d(G, GV, fluxes, optics, nsw, j, dt, ! Initialize heat_content_massout that is diagnosed in mixedlayer_convection or ! applyBoundaryFluxes such that the meaning is as the sum of all outgoing components. if (associated(fluxes%heat_content_massout)) then - if (aggregate_FW_forcing) then + if (aggregate_FW) then if (netMassInOut(i) > 0.0) then ! net is "in" fluxes%heat_content_massout(i,j) = fluxes%C_p * netMassOut(i) * T(i,1) * GV%H_to_kg_m2 / dt else ! net is "out" - fluxes%heat_content_massout(i,j) = -fluxes%C_p * ( netMassInout(i) - netMassOut(i) ) * T(i,1) * GV%H_to_kg_m2 / dt + fluxes%heat_content_massout(i,j) = -fluxes%C_p * ( netMassInout(i) - netMassOut(i) ) * & + T(i,1) * GV%H_to_kg_m2 / dt endif else fluxes%heat_content_massout(i,j) = 0.0 @@ -681,6 +742,15 @@ subroutine extractFluxes1d(G, GV, fluxes, optics, nsw, j, dt, endif endif + ! Following lprec and fprec, water flux due to sea ice melt (seaice_melt) enters at SST - GMM + if (associated(fluxes%heat_content_icemelt)) then + if (fluxes%seaice_melt(i,j) > 0.0) then + fluxes%heat_content_icemelt(i,j) = fluxes%C_p*fluxes%seaice_melt(i,j)*T(i,1) + else + fluxes%heat_content_icemelt(i,j) = 0.0 + endif + endif + ! virtual precip associated with salinity restoring ! vprec > 0 means add water to ocean, assumed to be at SST ! vprec < 0 means remove water from ocean; set heat_content_vprec in MOM_diabatic_driver.F90 @@ -730,58 +800,60 @@ end subroutine extractFluxes1d !> 2d wrapper for 1d extract fluxes from surface fluxes type. !! This subroutine extracts fluxes from the surface fluxes type. It multiplies the !! fluxes by dt, so that the result is an accumulation of the fluxes over a time step. -subroutine extractFluxes2d(G, GV, fluxes, optics, nsw, dt, & - DepthBeforeScalingFluxes, useRiverHeatContent, useCalvingHeatContent, & - h, T, netMassInOut, netMassOut, net_heat, Net_salt, Pen_SW_bnd, tv, & - aggregate_FW_forcing) - - type(ocean_grid_type), intent(in) :: G !< ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(forcing), intent(inout) :: fluxes !< structure containing pointers to forcing. - type(optics_type), pointer :: optics !< pointer to optics - integer, intent(in) :: nsw !< number of bands of penetrating SW - real, intent(in) :: dt !< time step in seconds - real, intent(in) :: DepthBeforeScalingFluxes !< min ocean depth before scale away fluxes (H) - logical, intent(in) :: useRiverHeatContent !< logical for river heat content - logical, intent(in) :: useCalvingHeatContent !< logical for calving heat content - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< layer thickness (in H units) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: T !< layer temperatures (deg C) - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: netMassInOut !< net mass flux (non-Bouss) or volume flux - !! (if Bouss) of water in/out of ocean over - !! a time step (H units) - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: netMassOut !< net mass flux (non-Bouss) or volume flux - !! (if Bouss) of water leaving ocean surface - !! over a time step (H units). - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: net_heat !< net heat at the surface accumulated over a - !! time step associated with coupler + restore. - !! Exclude two terms from net_heat: - !! (1) downwelling (penetrative) SW, - !! (2) evaporation heat content, - !! (since do not yet know temperature of evap). - !! Units of net_heat are (K * H). - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: net_salt !< surface salt flux into the ocean accumulated - !! over a time step (ppt * H) - real, dimension(:,:,:), intent(out) :: pen_SW_bnd !< penetrating shortwave flux, split into bands. - !! Units (deg K * H) & array size nsw x SZI_(G), - !! where nsw=number of SW bands in pen_SW_bnd. - !! This heat flux is not in net_heat. - type(thermo_var_ptrs), intent(inout) :: tv !< structure containing pointers to available - !! thermodynamic fields. Here it is used to keep - !! track of the heat flux associated with net - !! mass fluxes into the ocean. - logical, intent(in) :: aggregate_FW_forcing !< For determining how to aggregate the forcing. - +subroutine extractFluxes2d(G, GV, fluxes, optics, nsw, dt, FluxRescaleDepth, & + useRiverHeatContent, useCalvingHeatContent, h, T, & + netMassInOut, netMassOut, net_heat, Net_salt, Pen_SW_bnd, tv, & + aggregate_FW) + + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(forcing), intent(inout) :: fluxes !< structure containing pointers to forcing. + type(optics_type), pointer :: optics !< pointer to optics + integer, intent(in) :: nsw !< number of bands of penetrating SW + real, intent(in) :: dt !< time step [s] + real, intent(in) :: FluxRescaleDepth !< min ocean depth before fluxes + !! are scaled away [H ~> m or kg m-2] + logical, intent(in) :: useRiverHeatContent !< logical for river heat content + logical, intent(in) :: useCalvingHeatContent !< logical for calving heat content + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: T !< layer temperatures [degC] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: netMassInOut !< net mass flux (non-Bouss) or volume flux + !! (if Bouss) of water in/out of ocean over + !! a time step [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: netMassOut !< net mass flux (non-Bouss) or volume flux + !! (if Bouss) of water leaving ocean surface + !! over a time step [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: net_heat !< net heat at the surface accumulated over a + !! time step associated with coupler + restore. + !! Exclude two terms from net_heat: + !! (1) downwelling (penetrative) SW, + !! (2) evaporation heat content, + !! (since do not yet know temperature of evap). + !! [degC H ~> degC m or degC kg m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: net_salt !< surface salt flux into the ocean accumulated + !! over a time step [ppt H ~> ppt m or ppt kg m-2] + real, dimension(:,:,:), intent(out) :: pen_SW_bnd !< penetrating shortwave flux, split into bands. + !! [degC H ~> degC m or degC kg m-2] array size + !! nsw x SZI_(G), where nsw=number of SW bands in + !! pen_SW_bnd. This heat flux is not in net_heat. + type(thermo_var_ptrs), intent(inout) :: tv !< structure containing pointers to available + !! thermodynamic fields. Here it is used to keep + !! track of the heat flux associated with net + !! mass fluxes into the ocean. + logical, intent(in) :: aggregate_FW !< For determining how to aggregate the forcing. integer :: j -!$OMP parallel do default(none) shared(G, GV, fluxes, optics, nsw,dt,DepthBeforeScalingFluxes, & +!$OMP parallel do default(none) shared(G, GV, fluxes, optics, nsw,dt,FluxRescaleDepth, & !$OMP useRiverHeatContent, useCalvingHeatContent, & !$OMP h,T,netMassInOut,netMassOut,Net_heat,Net_salt,Pen_SW_bnd,tv, & -!$OMP aggregate_FW_forcing) +!$OMP aggregate_FW) do j=G%jsc, G%jec call extractFluxes1d(G, GV, fluxes, optics, nsw, j, dt, & - DepthBeforeScalingFluxes, useRiverHeatContent, useCalvingHeatContent,& + FluxRescaleDepth, useRiverHeatContent, useCalvingHeatContent,& h(:,j,:), T(:,j,:), netMassInOut(:,j), netMassOut(:,j), & - net_heat(:,j), net_salt(:,j), pen_SW_bnd(:,:,j), tv, aggregate_FW_forcing) + net_heat(:,j), net_salt(:,j), pen_SW_bnd(:,:,j), tv, aggregate_FW) enddo end subroutine extractFluxes2d @@ -791,32 +863,36 @@ end subroutine extractFluxes2d !! These are actual fluxes, with units of stuff per time. Setting dt=1 in the call to !! extractFluxes routine allows us to get "stuf per time" rather than the time integrated !! fluxes needed in other routines that call extractFluxes. -subroutine calculateBuoyancyFlux1d(G, GV, fluxes, optics, h, Temp, Salt, tv, j, & +subroutine calculateBuoyancyFlux1d(G, GV, US, fluxes, optics, h, Temp, Salt, tv, j, & buoyancyFlux, netHeatMinusSW, netSalt, skip_diags) type(ocean_grid_type), intent(in) :: 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 type(forcing), intent(inout) :: fluxes !< surface fluxes type(optics_type), pointer :: optics !< penetrating SW optics - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< layer thickness (H) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: Temp !< prognostic temp(deg C) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: Salt !< salinity (ppt) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: Temp !< prognostic temp [degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: Salt !< salinity [ppt] type(thermo_var_ptrs), intent(inout) :: tv !< thermodynamics type integer, intent(in) :: j !< j-row to work on - real, dimension(SZI_(G),SZK_(G)+1), intent(inout) :: buoyancyFlux !< buoyancy flux (m^2/s^3) - real, dimension(SZI_(G)), intent(inout) :: netHeatMinusSW !< surf Heat flux (K H/s) - real, dimension(SZI_(G)), intent(inout) :: netSalt !< surf salt flux (ppt H/s) - logical, optional, intent(in) :: skip_diags !< If present and true, skip calculating - !! diagnostics inside extractFluxes1d() + real, dimension(SZI_(G),SZK_(G)+1), intent(inout) :: buoyancyFlux !< buoyancy flux [m2 s-3] + real, dimension(SZI_(G)), intent(inout) :: netHeatMinusSW !< surf Heat flux + !! [degC H s-1 ~> degC m s-1 or degC kg m-2 s-1] + real, dimension(SZI_(G)), intent(inout) :: netSalt !< surf salt flux + !! [ppt H s-1 ~> ppt m s-1 or ppt kg m-2 s-1] + logical, optional, intent(in) :: skip_diags !< If present and true, skip calculating + !! diagnostics inside extractFluxes1d() ! local variables integer :: nsw, start, npts, k real, parameter :: dt = 1. ! to return a rate from extractFluxes1d - real, dimension( SZI_(G) ) :: netH ! net FW flux (m/s for Bouss) - real, dimension( SZI_(G) ) :: netEvap ! net FW flux leaving ocean via evaporation (m/s for Bouss) - real, dimension( SZI_(G) ) :: netHeat ! net temp flux (K m/s) + real, dimension( SZI_(G) ) :: netH ! net FW flux [H s-1 ~> m s-1 or kg m-2 s-1] + real, dimension( SZI_(G) ) :: netEvap ! net FW flux leaving ocean via evaporation + ! [H s-1 ~> m s-1 or kg m-2 s-1] + real, dimension( SZI_(G) ) :: netHeat ! net temp flux [degC H s-1 ~> degC m s-2 or degC kg m-2 s-1] real, dimension( optics%nbands, SZI_(G) ) :: penSWbnd ! SW penetration bands - real, dimension( SZI_(G) ) :: pressure ! pressurea the surface (Pa) - real, dimension( SZI_(G) ) :: dRhodT ! density partial derivative wrt temp - real, dimension( SZI_(G) ) :: dRhodS ! density partial derivative wrt saln + real, dimension( SZI_(G) ) :: pressure ! pressurea the surface [Pa] + real, dimension( SZI_(G) ) :: dRhodT ! density partial derivative wrt temp [kg m-3 degC-1] + real, dimension( SZI_(G) ) :: dRhodS ! density partial derivative wrt saln [kg m-3 ppt-1] real, dimension(SZI_(G),SZK_(G)+1) :: netPen logical :: useRiverHeatContent @@ -830,9 +906,9 @@ subroutine calculateBuoyancyFlux1d(G, GV, fluxes, optics, h, Temp, Salt, tv, j, useRiverHeatContent = .False. useCalvingHeatContent = .False. - depthBeforeScalingFluxes = max( GV%Angstrom, 1.e-30*GV%m_to_H ) + depthBeforeScalingFluxes = max( GV%Angstrom_H, 1.e-30*GV%m_to_H ) pressure(:) = 0. ! Ignore atmospheric pressure - GoRho = GV%g_Earth / GV%Rho0 + GoRho = (GV%g_Earth*US%m_to_Z) / GV%Rho0 start = 1 + G%isc - G%isd npts = 1 + G%iec - G%isc @@ -840,9 +916,9 @@ subroutine calculateBuoyancyFlux1d(G, GV, fluxes, optics, h, Temp, Salt, tv, j, ! The surface forcing is contained in the fluxes type. ! We aggregate the thermodynamic forcing for a time step into the following: - ! netH = water (H units/s) added/removed via surface fluxes - ! netHeat = heat (degC * H/s) via surface fluxes - ! netSalt = salt ( g(salt)/m2 for non-Bouss and ppt*m for Bouss /s) via surface fluxes + ! netH = water added/removed via surface fluxes [H s-1 ~> m s-1 or kg m-2 s-1] + ! netHeat = heat via surface fluxes [degC H s-1 ~> degC m s-1 or degC kg m-2 s-1] + ! netSalt = salt via surface fluxes [ppt H s-1 ~> ppt m s-1 or gSalt m-2 s-1] ! Note that unlike other calls to extractFLuxes1d() that return the time-integrated flux ! this call returns the rate because dt=1 call extractFluxes1d(G, GV, fluxes, optics, nsw, j, dt, & @@ -880,46 +956,48 @@ end subroutine calculateBuoyancyFlux1d !> Calculates surface buoyancy flux by adding up the heat, FW and salt fluxes, !! for 2d arrays. This is a wrapper for calculateBuoyancyFlux1d. -subroutine calculateBuoyancyFlux2d(G, GV, fluxes, optics, h, Temp, Salt, tv, & +subroutine calculateBuoyancyFlux2d(G, GV, US, fluxes, optics, h, Temp, Salt, tv, & buoyancyFlux, netHeatMinusSW, netSalt, skip_diags) - type(ocean_grid_type), intent(in) :: G !< ocean grid - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(forcing), intent(inout) :: fluxes !< surface fluxes - type(optics_type), pointer :: optics !< SW ocean optics - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< layer thickness (H) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: Temp !< temperature (deg C) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: Salt !< salinity (ppt) - type(thermo_var_ptrs), intent(inout) :: tv !< thermodynamics type - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: buoyancyFlux !< buoy flux (m^2/s^3) - real, dimension(SZI_(G),SZJ_(G)), optional, intent(inout) :: netHeatMinusSW !< surf temp flux (K H) - real, dimension(SZI_(G),SZJ_(G)), optional, intent(inout) :: netSalt !< surf salt flux (ppt H) - logical, optional, intent(in) :: skip_diags !< If present and true, skip calculating + type(ocean_grid_type), intent(in) :: 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 + type(forcing), intent(inout) :: fluxes !< surface fluxes + type(optics_type), pointer :: optics !< SW ocean optics + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: Temp !< temperature [degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: Salt !< salinity [ppt] + type(thermo_var_ptrs), intent(inout) :: tv !< thermodynamics type + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: buoyancyFlux !< buoy flux [m2 s-3] + real, dimension(SZI_(G),SZJ_(G)), optional, intent(inout) :: netHeatMinusSW !< surf temp flux + !! [degC H ~> degC m or degC kg m-2] + real, dimension(SZI_(G),SZJ_(G)), optional, intent(inout) :: netSalt !< surf salt flux + !! [ppt H ~> ppt m or ppt kg m-2] + logical, optional, intent(in) :: skip_diags !< If present and true, skip calculating !! diagnostics inside extractFluxes1d() ! local variables - real, dimension( SZI_(G) ) :: netT ! net temperature flux (K m/s) - real, dimension( SZI_(G) ) :: netS ! net saln flux (ppt m/s) + real, dimension( SZI_(G) ) :: netT ! net temperature flux [degC H s-1 ~> degC m s-2 or degC kg m-2 s-1] + real, dimension( SZI_(G) ) :: netS ! net saln flux !! [ppt H s-1 ~> ppt m s-1 or ppt kg m-2 s-1] integer :: j netT(G%isc:G%iec) = 0. ; netS(G%isc:G%iec) = 0. -!$OMP parallel do default(none) shared(G,GV,fluxes,optics,h,Temp,Salt,tv,buoyancyFlux,& -!$OMP netHeatMinusSW,netSalt,skip_diags) & -!$OMP firstprivate(netT,netS) - do j = G%jsc, G%jec - call calculateBuoyancyFlux1d(G, GV, fluxes, optics, h, Temp, Salt, tv, j, buoyancyFlux(:,j,:), & + !$OMP parallel do default(shared) firstprivate(netT,netS) + do j=G%jsc,G%jec + call calculateBuoyancyFlux1d(G, GV, US, fluxes, optics, h, Temp, Salt, tv, j, buoyancyFlux(:,j,:), & netT, netS, skip_diags=skip_diags) if (present(netHeatMinusSW)) netHeatMinusSW(G%isc:G%iec,j) = netT(G%isc:G%iec) if (present(netSalt)) netSalt(G%isc:G%iec,j) = netS(G%isc:G%iec) - enddo ! j + enddo end subroutine calculateBuoyancyFlux2d !> Write out chksums for thermodynamic fluxes. -subroutine MOM_forcing_chksum(mesg, fluxes, G, haloshift) +subroutine MOM_forcing_chksum(mesg, fluxes, G, US, haloshift) character(len=*), intent(in) :: mesg !< message type(forcing), intent(in) :: fluxes !< A structure containing thermodynamic forcing fields type(ocean_grid_type), intent(in) :: G !< grid type + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, optional, intent(in) :: haloshift !< shift in halo integer :: is, ie, js, je, nz, hshift @@ -931,7 +1009,7 @@ subroutine MOM_forcing_chksum(mesg, fluxes, G, haloshift) ! counts, there must be no redundant points, so all variables use is..ie ! and js...je as their extent. if (associated(fluxes%ustar)) & - call hchksum(fluxes%ustar, mesg//" fluxes%ustar",G%HI,haloshift=hshift) + call hchksum(fluxes%ustar, mesg//" fluxes%ustar",G%HI, haloshift=hshift, scale=US%Z_to_m) if (associated(fluxes%buoy)) & call hchksum(fluxes%buoy, mesg//" fluxes%buoy ",G%HI,haloshift=hshift) if (associated(fluxes%sw)) & @@ -966,6 +1044,8 @@ subroutine MOM_forcing_chksum(mesg, fluxes, G, haloshift) call hchksum(fluxes%vprec, mesg//" fluxes%vprec",G%HI,haloshift=hshift) if (associated(fluxes%seaice_melt)) & call hchksum(fluxes%seaice_melt, mesg//" fluxes%seaice_melt",G%HI,haloshift=hshift) + if (associated(fluxes%seaice_melt_heat)) & + call hchksum(fluxes%seaice_melt_heat, mesg//" fluxes%seaice_melt_heat",G%HI,haloshift=hshift) if (associated(fluxes%p_surf)) & call hchksum(fluxes%p_surf, mesg//" fluxes%p_surf",G%HI,haloshift=hshift) if (associated(fluxes%salt_flux)) & @@ -986,6 +1066,8 @@ subroutine MOM_forcing_chksum(mesg, fluxes, G, haloshift) call hchksum(fluxes%heat_content_lprec, mesg//" fluxes%heat_content_lprec",G%HI,haloshift=hshift) if (associated(fluxes%heat_content_fprec)) & call hchksum(fluxes%heat_content_fprec, mesg//" fluxes%heat_content_fprec",G%HI,haloshift=hshift) + if (associated(fluxes%heat_content_icemelt)) & + call hchksum(fluxes%heat_content_icemelt, mesg//" fluxes%heat_content_icemelt",G%HI,haloshift=hshift) if (associated(fluxes%heat_content_cond)) & call hchksum(fluxes%heat_content_cond, mesg//" fluxes%heat_content_cond",G%HI,haloshift=hshift) if (associated(fluxes%heat_content_massout)) & @@ -993,10 +1075,11 @@ subroutine MOM_forcing_chksum(mesg, fluxes, G, haloshift) end subroutine MOM_forcing_chksum !> Write out chksums for the driving mechanical forces. -subroutine MOM_mech_forcing_chksum(mesg, forces, G, haloshift) +subroutine MOM_mech_forcing_chksum(mesg, forces, G, US, haloshift) character(len=*), intent(in) :: mesg !< message type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces type(ocean_grid_type), intent(in) :: G !< grid type + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, optional, intent(in) :: haloshift !< shift in halo integer :: is, ie, js, je, nz, hshift @@ -1012,12 +1095,17 @@ subroutine MOM_mech_forcing_chksum(mesg, forces, G, haloshift) haloshift=hshift, symmetric=.true.) if (associated(forces%p_surf)) & call hchksum(forces%p_surf, mesg//" forces%p_surf",G%HI,haloshift=hshift) + if (associated(forces%ustar)) & + call hchksum(forces%ustar, mesg//" forces%ustar",G%HI,haloshift=hshift, scale=US%Z_to_m) + if (associated(forces%rigidity_ice_u) .and. associated(forces%rigidity_ice_v)) & + call uvchksum(mesg//" forces%rigidity_ice_[uv]", forces%rigidity_ice_u, & + forces%rigidity_ice_v, G%HI, haloshift=hshift, symmetric=.true.) end subroutine MOM_mech_forcing_chksum !> Write out values of the mechanical forcing arrays at the i,j location. This is a debugging tool. subroutine mech_forcing_SinglePointPrint(forces, G, i, j, mesg) - type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces + type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces type(ocean_grid_type), intent(in) :: G !< Grid type character(len=*), intent(in) :: mesg !< Message integer, intent(in) :: i !< i-index @@ -1071,6 +1159,7 @@ subroutine forcing_SinglePointPrint(fluxes, G, i, j, mesg) call locMsg(fluxes%fprec,'fprec') call locMsg(fluxes%vprec,'vprec') call locMsg(fluxes%seaice_melt,'seaice_melt') + call locMsg(fluxes%seaice_melt_heat,'seaice_melt_heat') call locMsg(fluxes%p_surf,'p_surf') call locMsg(fluxes%salt_flux,'salt_flux') call locMsg(fluxes%TKE_tidal,'TKE_tidal') @@ -1081,6 +1170,7 @@ subroutine forcing_SinglePointPrint(fluxes, G, i, j, mesg) call locMsg(fluxes%heat_content_frunoff,'heat_content_frunoff') call locMsg(fluxes%heat_content_lprec,'heat_content_lprec') call locMsg(fluxes%heat_content_fprec,'heat_content_fprec') + call locMsg(fluxes%heat_content_icemelt,'heat_content_icemelt') call locMsg(fluxes%heat_content_vprec,'heat_content_vprec') call locMsg(fluxes%heat_content_cond,'heat_content_cond') call locMsg(fluxes%heat_content_cond,'heat_content_massout') @@ -1102,9 +1192,10 @@ end subroutine forcing_SinglePointPrint !> Register members of the forcing type for diagnostics -subroutine register_forcing_type_diags(Time, diag, use_temperature, handles, use_berg_fluxes) +subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, use_berg_fluxes) type(time_type), intent(in) :: Time !< time type type(diag_ctrl), intent(inout) :: diag !< diagnostic control type + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type logical, intent(in) :: use_temperature !< True if T/S are in use type(forcing_diags), intent(inout) :: handles !< handles for diagnostics logical, optional, intent(in) :: use_berg_fluxes !< If true, allow iceberg flux diagnostics @@ -1126,12 +1217,13 @@ subroutine register_forcing_type_diags(Time, diag, use_temperature, handles, use cmor_standard_name='surface_downward_y_stress') handles%id_ustar = register_diag_field('ocean_model', 'ustar', diag%axesT1, Time, & - 'Surface friction velocity = [(gustiness + tau_magnitude)/rho0]^(1/2)', 'm s-1') + 'Surface friction velocity = [(gustiness + tau_magnitude)/rho0]^(1/2)', & + 'm s-1', conversion=US%Z_to_m) if (present(use_berg_fluxes)) then if (use_berg_fluxes) then handles%id_ustar_berg = register_diag_field('ocean_model', 'ustar_berg', diag%axesT1, Time, & - 'Friction velocity below iceberg ', 'm s-1') + 'Friction velocity below iceberg ', 'm s-1', conversion=US%Z_to_m) handles%id_area_berg = register_diag_field('ocean_model', 'area_berg', diag%axesT1, Time, & 'Area of grid cell covered by iceberg ', 'm2 m-2') @@ -1140,7 +1232,7 @@ subroutine register_forcing_type_diags(Time, diag, use_temperature, handles, use 'Mass of icebergs ', 'kg m-2') handles%id_ustar_ice_cover = register_diag_field('ocean_model', 'ustar_ice_cover', diag%axesT1, Time, & - 'Friction velocity below iceberg and ice shelf together', 'm s-1') + 'Friction velocity below iceberg and ice shelf together', 'm s-1', conversion=US%Z_to_m) handles%id_frac_ice_cover = register_diag_field('ocean_model', 'frac_ice_cover', diag%axesT1, Time, & 'Area of grid cell below iceberg and ice shelf together ', 'm2 m-2') @@ -1177,13 +1269,13 @@ subroutine register_forcing_type_diags(Time, diag, use_temperature, handles, use cmor_long_name='Water Evaporation Flux Where Ice Free Ocean over Sea') ! smg: seaice_melt field requires updates to the sea ice model - !handles%id_seaice_melt = register_diag_field('ocean_model', 'seaice_melt', & - ! diag%axesT1, Time, 'water flux to ocean from sea ice melt(> 0) or form(< 0)', & - ! 'kg m-2 s-1', & - ! standard_name='water_flux_into_sea_water_due_to_sea_ice_thermodynamics', & - ! cmor_field_name='fsitherm', & - ! cmor_standard_name='water_flux_into_sea_water_due_to_sea_ice_thermodynamics',& - ! cmor_long_name='water flux to ocean from sea ice melt(> 0) or form(< 0)') + handles%id_seaice_melt = register_diag_field('ocean_model', 'seaice_melt', & + diag%axesT1, Time, 'water flux to ocean from snow/sea ice melting(> 0) or formation(< 0)', & + 'kg m-2 s-1', & + standard_name='water_flux_into_sea_water_due_to_sea_ice_thermodynamics', & + cmor_field_name='fsitherm', & + cmor_standard_name='water_flux_into_sea_water_due_to_sea_ice_thermodynamics',& + cmor_long_name='water flux to ocean from sea ice melt(> 0) or form(< 0)') handles%id_precip = register_diag_field('ocean_model', 'precip', diag%axesT1, Time, & 'Liquid + frozen precipitation into ocean', 'kg m-2 s-1') @@ -1245,12 +1337,12 @@ subroutine register_forcing_type_diags(Time, diag, use_temperature, handles, use cmor_long_name='Evaporation Where Ice Free Ocean over Sea Area Integrated') ! seaice_melt field requires updates to the sea ice model - !handles%id_total_seaice_melt = register_scalar_field('ocean_model', 'total_seaice_melt', Time, diag, & - ! long_name='Area integrated sea ice melt (>0) or form (<0)', units='kg s-1', & - ! standard_name='water_flux_into_sea_water_due_to_sea_ice_thermodynamics_area_integrated', & - ! cmor_field_name='total_fsitherm', & - ! cmor_standard_name='water_flux_into_sea_water_due_to_sea_ice_thermodynamics_area_integrated', & - ! cmor_long_name='Water Melt/Form from Sea Ice Area Integrated') + handles%id_total_seaice_melt = register_scalar_field('ocean_model', 'total_icemelt', Time, diag, & + long_name='Area integrated sea ice melt (>0) or form (<0)', units='kg s-1', & + standard_name='water_flux_into_sea_water_due_to_sea_ice_thermodynamics_area_integrated', & + cmor_field_name='total_fsitherm', & + cmor_standard_name='water_flux_into_sea_water_due_to_sea_ice_thermodynamics_area_integrated', & + cmor_long_name='Water Melt/Form from Sea Ice Area Integrated') handles%id_total_precip = register_scalar_field('ocean_model', 'total_precip', Time, diag, & long_name='Area integrated liquid+frozen precip into ocean', units='kg s-1') @@ -1350,6 +1442,10 @@ subroutine register_forcing_type_diags(Time, diag, use_temperature, handles, use diag%axesT1,Time,'Heat content (relative to 0degC) of frozen prec entering ocean',& 'W m-2') + handles%id_heat_content_icemelt = register_diag_field('ocean_model', 'heat_content_icemelt',& + diag%axesT1,Time,'Heat content (relative to 0degC) of water flux due to sea ice melting/freezing',& + 'W m-2') + handles%id_heat_content_vprec = register_diag_field('ocean_model', 'heat_content_vprec', & diag%axesT1,Time,'Heat content (relative to 0degC) of virtual precip entering ocean',& 'W m-2') @@ -1380,14 +1476,16 @@ subroutine register_forcing_type_diags(Time, diag, use_temperature, handles, use 'W m-2') handles%id_net_heat_coupler = register_diag_field('ocean_model', 'net_heat_coupler', & - diag%axesT1,Time,'Surface ocean heat flux from SW+LW+latent+sensible (via the coupler)',& + diag%axesT1,Time,'Surface ocean heat flux from SW+LW+latent+sensible+seaice_melt_heat (via the coupler)',& 'W m-2') - handles%id_net_heat_surface = register_diag_field('ocean_model', 'net_heat_surface',diag%axesT1, & - Time,'Surface ocean heat flux from SW+LW+lat+sens+mass transfer+frazil+restore or flux adjustments', 'W m-2',& + handles%id_net_heat_surface = register_diag_field('ocean_model', 'net_heat_surface',diag%axesT1, Time, & + 'Surface ocean heat flux from SW+LW+lat+sens+mass transfer+frazil+restore+seaice_melt_heat or '// & + 'flux adjustments',& + 'W m-2',& standard_name='surface_downward_heat_flux_in_sea_water', cmor_field_name='hfds', & cmor_standard_name='surface_downward_heat_flux_in_sea_water', & - cmor_long_name='Surface ocean heat flux from SW+LW+latent+sensible+masstransfer+frazil') + cmor_long_name='Surface ocean heat flux from SW+LW+latent+sensible+masstransfer+frazil+seaice_melt_heat') handles%id_sw = register_diag_field('ocean_model', 'SW', diag%axesT1, Time, & 'Shortwave radiation flux into ocean', 'W m-2', & @@ -1440,6 +1538,13 @@ subroutine register_forcing_type_diags(Time, diag, use_temperature, handles, use cmor_standard_name='surface_downward_sensible_heat_flux', & cmor_long_name='Surface Downward Sensible Heat Flux') + handles%id_seaice_melt_heat = register_diag_field('ocean_model', 'seaice_melt_heat', diag%axesT1, Time,& + 'Heat flux into ocean due to snow and sea ice melt/freeze', 'W m-2', & + standard_name='snow_ice_melt_heat_flux', & + !GMM TODO cmor_field_name='hfsso', & + cmor_standard_name='snow_ice_melt_heat_flux', & + cmor_long_name='Heat flux into ocean from snow and sea ice melt') + handles%id_heat_added = register_diag_field('ocean_model', 'heat_added', diag%axesT1, Time, & 'Flux Adjustment or restoring surface heat flux into ocean', 'W m-2') @@ -1479,6 +1584,11 @@ subroutine register_forcing_type_diags(Time, diag, use_temperature, handles, use long_name='Area integrated heat content (relative to 0C) of frozen precip',& units='W') + handles%id_total_heat_content_icemelt = register_scalar_field('ocean_model', & + 'total_heat_content_icemelt', Time, diag,long_name= & + 'Area integrated heat content (relative to 0C) of water flux due sea ice melting/freezing', & + units='W') + handles%id_total_heat_content_vprec = register_scalar_field('ocean_model', & 'total_heat_content_vprec', Time, diag, & long_name='Area integrated heat content (relative to 0C) of virtual precip',& @@ -1510,12 +1620,12 @@ subroutine register_forcing_type_diags(Time, diag, use_temperature, handles, use handles%id_total_net_heat_coupler = register_scalar_field('ocean_model', & 'total_net_heat_coupler', Time, diag, & - long_name='Area integrated surface heat flux from SW+LW+latent+sensible (via the coupler)',& + long_name='Area integrated surface heat flux from SW+LW+latent+sensible+seaice_melt_heat (via the coupler)',& units='W') handles%id_total_net_heat_surface = register_scalar_field('ocean_model', & 'total_net_heat_surface', Time, diag, & - long_name='Area integrated surface heat flux from SW+LW+lat+sens+mass+frazil+restore or flux adjustments', & + long_name='Area integrated surface heat flux from SW+LW+lat+sens+mass+frazil+restore or flux adjustments', & units='W', & cmor_field_name='total_hfds', & cmor_standard_name='surface_downward_heat_flux_in_sea_water_area_integrated', & @@ -1591,18 +1701,22 @@ subroutine register_forcing_type_diags(Time, diag, use_temperature, handles, use long_name='Area integrated surface heat flux from restoring and/or flux adjustment', & units='W') + handles%id_total_seaice_melt_heat = register_scalar_field('ocean_model',& + 'total_seaice_melt_heat', Time, diag, & + long_name='Area integrated surface heat flux from snow and sea ice melt', & + units='W') !=============================================================== ! area averaged surface heat fluxes handles%id_net_heat_coupler_ga = register_scalar_field('ocean_model', & 'net_heat_coupler_ga', Time, diag, & - long_name='Area averaged surface heat flux from SW+LW+latent+sensible (via the coupler)',& + long_name='Area averaged surface heat flux from SW+LW+latent+sensible+seaice_melt_heat (via the coupler)',& units='W m-2') handles%id_net_heat_surface_ga = register_scalar_field('ocean_model', & - 'net_heat_surface_ga', Time, diag, & - long_name='Area averaged surface heat flux from SW+LW+lat+sens+mass+frazil+restore or flux adjustments', & + 'net_heat_surface_ga', Time, diag, long_name= & + 'Area averaged surface heat flux from SW+LW+lat+sens+mass+frazil+restore+seaice_melt_heat or flux adjustments', & units='W m-2', & cmor_field_name='ave_hfds', & cmor_standard_name='surface_downward_heat_flux_in_sea_water_area_averaged', & @@ -1717,14 +1831,37 @@ subroutine register_forcing_type_diags(Time, diag, use_temperature, handles, use end subroutine register_forcing_type_diags -!> Accumulate the forcing over time steps +!> Accumulate the forcing over time steps, taking input from a mechanical forcing type +!! and a temporary forcing-flux type. subroutine forcing_accumulate(flux_tmp, forces, fluxes, dt, G, wt2) - type(forcing), intent(in) :: flux_tmp + type(forcing), intent(in) :: flux_tmp !< A temporary structure with current + !!thermodynamic forcing fields type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces - type(forcing), intent(inout) :: fluxes - real, intent(in) :: dt !< The elapsed time since the last call to this subroutine, in s + type(forcing), intent(inout) :: fluxes !< A structure containing time-averaged + !! thermodynamic forcing fields + real, intent(in) :: dt !< The elapsed time since the last call to this subroutine [s] type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, intent(out) :: wt2 + real, intent(out) :: wt2 !< The relative weight of the new fluxes + + ! This subroutine copies mechancal forcing from flux_tmp to fluxes and + ! stores the time-weighted averages of the various buoyancy fluxes in fluxes, + ! and increments the amount of time over which the buoyancy forcing should be + ! applied, all via a call to fluxes accumulate. + + call fluxes_accumulate(flux_tmp, fluxes, dt, G, wt2, forces) + +end subroutine forcing_accumulate + +!> Accumulate the thermodynamic fluxes over time steps +subroutine fluxes_accumulate(flux_tmp, fluxes, dt, G, wt2, forces) + type(forcing), intent(in) :: flux_tmp !< A temporary structure with current + !! thermodynamic forcing fields + type(forcing), intent(inout) :: fluxes !< A structure containing time-averaged + !! thermodynamic forcing fields + real, intent(in) :: dt !< The elapsed time since the last call to this subroutine [s] + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, intent(out) :: wt2 !< The relative weight of the new fluxes + type(mech_forcing), optional, intent(in) :: forces !< A structure with the driving mechanical forces ! This subroutine copies mechancal forcing from flux_tmp to fluxes and ! stores the time-weighted averages of the various buoyancy fluxes in fluxes, @@ -1748,15 +1885,29 @@ subroutine forcing_accumulate(flux_tmp, forces, fluxes, dt, G, wt2) wt2 = 1.0 - wt1 ! = dt / (fluxes%dt_buoy_accum + dt) fluxes%dt_buoy_accum = fluxes%dt_buoy_accum + dt - ! Copy over the pressure fields. - do j=js,je ; do i=is,ie - fluxes%p_surf(i,j) = forces%p_surf(i,j) - fluxes%p_surf_full(i,j) = forces%p_surf_full(i,j) - enddo ; enddo + ! Copy over the pressure fields and accumulate averages of ustar, either from the forcing + ! type or from the temporary fluxes type. + if (present(forces)) then + do j=js,je ; do i=is,ie + fluxes%p_surf(i,j) = forces%p_surf(i,j) + fluxes%p_surf_full(i,j) = forces%p_surf_full(i,j) + + fluxes%ustar(i,j) = wt1*fluxes%ustar(i,j) + wt2*forces%ustar(i,j) + enddo ; enddo + else + do j=js,je ; do i=is,ie + fluxes%p_surf(i,j) = flux_tmp%p_surf(i,j) + fluxes%p_surf_full(i,j) = flux_tmp%p_surf_full(i,j) + + fluxes%ustar(i,j) = wt1*fluxes%ustar(i,j) + wt2*flux_tmp%ustar(i,j) + enddo ; enddo + endif ! Average the water, heat, and salt fluxes, and ustar. do j=js,je ; do i=is,ie - fluxes%ustar(i,j) = wt1*fluxes%ustar(i,j) + wt2*forces%ustar(i,j) +!### Replace the expression for ustar_gustless with this one... +! fluxes%ustar_gustless(i,j) = wt1*fluxes%ustar_gustless(i,j) + wt2*flux_tmp%ustar_gustless(i,j) + fluxes%ustar_gustless(i,j) = flux_tmp%ustar_gustless(i,j) fluxes%evap(i,j) = wt1*fluxes%evap(i,j) + wt2*flux_tmp%evap(i,j) fluxes%lprec(i,j) = wt1*fluxes%lprec(i,j) + wt2*flux_tmp%lprec(i,j) @@ -1764,8 +1915,7 @@ subroutine forcing_accumulate(flux_tmp, forces, fluxes, dt, G, wt2) fluxes%vprec(i,j) = wt1*fluxes%vprec(i,j) + wt2*flux_tmp%vprec(i,j) fluxes%lrunoff(i,j) = wt1*fluxes%lrunoff(i,j) + wt2*flux_tmp%lrunoff(i,j) fluxes%frunoff(i,j) = wt1*fluxes%frunoff(i,j) + wt2*flux_tmp%frunoff(i,j) - ! ### ADD LATER fluxes%seaice_melt(i,j) = wt1*fluxes%seaice_melt(i,j) + wt2*flux_tmp%seaice_melt(i,j) - + fluxes%seaice_melt(i,j) = wt1*fluxes%seaice_melt(i,j) + wt2*flux_tmp%seaice_melt(i,j) fluxes%sw(i,j) = wt1*fluxes%sw(i,j) + wt2*flux_tmp%sw(i,j) fluxes%sw_vis_dir(i,j) = wt1*fluxes%sw_vis_dir(i,j) + wt2*flux_tmp%sw_vis_dir(i,j) fluxes%sw_vis_dif(i,j) = wt1*fluxes%sw_vis_dif(i,j) + wt2*flux_tmp%sw_vis_dif(i,j) @@ -1798,6 +1948,11 @@ subroutine forcing_accumulate(flux_tmp, forces, fluxes, dt, G, wt2) fluxes%heat_content_fprec(i,j) = wt1*fluxes%heat_content_fprec(i,j) + wt2*flux_tmp%heat_content_fprec(i,j) enddo ; enddo endif + if (associated(fluxes%heat_content_icemelt) .and. associated(flux_tmp%heat_content_icemelt)) then + do j=js,je ; do i=is,ie + fluxes%heat_content_icemelt(i,j) = wt1*fluxes%heat_content_icemelt(i,j) + wt2*flux_tmp%heat_content_icemelt(i,j) + enddo ; enddo + endif if (associated(fluxes%heat_content_vprec) .and. associated(flux_tmp%heat_content_vprec)) then do j=js,je ; do i=is,ie fluxes%heat_content_vprec(i,j) = wt1*fluxes%heat_content_vprec(i,j) + wt2*flux_tmp%heat_content_vprec(i,j) @@ -1840,41 +1995,47 @@ subroutine forcing_accumulate(flux_tmp, forces, fluxes, dt, G, wt2) call coupler_type_increment_data(flux_tmp%tr_fluxes, fluxes%tr_fluxes, & scale_factor=wt2, scale_prev=wt1) -end subroutine forcing_accumulate +end subroutine fluxes_accumulate !> This subroutine copies the computational domains of common forcing fields !! from a mech_forcing type to a (thermodynamic) forcing type. -subroutine copy_common_forcing_fields(forces, fluxes, G) +subroutine copy_common_forcing_fields(forces, fluxes, G, skip_pres) type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields type(ocean_grid_type), intent(in) :: G !< grid type + logical, optional, intent(in) :: skip_pres !< If present and true, do not copy pressure fields. - real :: taux2, tauy2 ! Squared wind stress components, in Pa^2. + real :: taux2, tauy2 ! Squared wind stress components [Pa2]. + logical :: do_pres integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + do_pres = .true. ; if (present(skip_pres)) do_pres = .not.skip_pres + if (associated(forces%ustar) .and. associated(fluxes%ustar)) then do j=js,je ; do i=is,ie fluxes%ustar(i,j) = forces%ustar(i,j) enddo ; enddo endif - if (associated(forces%p_surf) .and. associated(fluxes%p_surf)) then - do j=js,je ; do i=is,ie - fluxes%p_surf(i,j) = forces%p_surf(i,j) - enddo ; enddo - endif + if (do_pres) then + if (associated(forces%p_surf) .and. associated(fluxes%p_surf)) then + do j=js,je ; do i=is,ie + fluxes%p_surf(i,j) = forces%p_surf(i,j) + enddo ; enddo + endif - if (associated(forces%p_surf_full) .and. associated(fluxes%p_surf_full)) then - do j=js,je ; do i=is,ie - fluxes%p_surf_full(i,j) = forces%p_surf_full(i,j) - enddo ; enddo - endif + if (associated(forces%p_surf_full) .and. associated(fluxes%p_surf_full)) then + do j=js,je ; do i=is,ie + fluxes%p_surf_full(i,j) = forces%p_surf_full(i,j) + enddo ; enddo + endif - if (associated(forces%p_surf_SSH, forces%p_surf_full)) then - fluxes%p_surf_SSH => fluxes%p_surf_full - elseif (associated(forces%p_surf_SSH, forces%p_surf)) then - fluxes%p_surf_SSH => fluxes%p_surf + if (associated(forces%p_surf_SSH, forces%p_surf_full)) then + fluxes%p_surf_SSH => fluxes%p_surf_full + elseif (associated(forces%p_surf_SSH, forces%p_surf)) then + fluxes%p_surf_SSH => fluxes%p_surf + endif endif end subroutine copy_common_forcing_fields @@ -1882,17 +2043,21 @@ end subroutine copy_common_forcing_fields !> This subroutine calculates certain derived forcing fields based on information !! from a mech_forcing type and stores them in a (thermodynamic) forcing type. -subroutine set_derived_forcing_fields(forces, fluxes, G, Rho0) +subroutine set_derived_forcing_fields(forces, fluxes, G, US, Rho0) type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields type(ocean_grid_type), intent(in) :: G !< grid type - real, intent(in) :: Rho0 !< A reference density of seawater, in kg m-3, + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(in) :: Rho0 !< A reference density of seawater [kg m-3], !! as used to calculate ustar. - real :: taux2, tauy2 ! Squared wind stress components, in Pa^2. + real :: taux2, tauy2 ! Squared wind stress components [Pa2]. + real :: Irho0 ! Inverse of the mean density rescaled to [Z2 m / kg ~> m3 kg-1] integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Irho0 = US%m_to_Z**2 / Rho0 + if (associated(forces%taux) .and. associated(forces%tauy) .and. & associated(fluxes%ustar_gustless)) then do j=js,je ; do i=is,ie @@ -1907,46 +2072,62 @@ subroutine set_derived_forcing_fields(forces, fluxes, G, Rho0) G%mask2dCv(i,J) * forces%tauy(i,J)**2) / & (G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) - fluxes%ustar_gustless(i,j) = sqrt(sqrt(taux2 + tauy2) / Rho0) + fluxes%ustar_gustless(i,j) = US%m_to_Z * sqrt(sqrt(taux2 + tauy2) / Rho0) +!### Change to: +! fluxes%ustar_gustless(i,j) = sqrt(sqrt(taux2 + tauy2) * Irho0) enddo ; enddo endif end subroutine set_derived_forcing_fields -!> This subroutine calculates determines the net mass source to th eocean from +!> This subroutine determines the net mass source to the ocean from !! a (thermodynamic) forcing type and stores it in a mech_forcing type. subroutine set_net_mass_forcing(fluxes, forces, G) type(forcing), intent(in) :: fluxes !< A structure containing thermodynamic forcing fields type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(ocean_grid_type), intent(in) :: G !< grid type + type(ocean_grid_type), intent(in) :: G !< The ocean grid type + + if (associated(forces%net_mass_src)) & + call get_net_mass_forcing(fluxes, G, forces%net_mass_src) + +end subroutine set_net_mass_forcing + +!> This subroutine calculates determines the net mass source to the ocean from +!! a (thermodynamic) forcing type and stores it in a provided array. +subroutine get_net_mass_forcing(fluxes, G, net_mass_src) + type(forcing), intent(in) :: fluxes !< A structure containing thermodynamic forcing fields + type(ocean_grid_type), intent(in) :: G !< The ocean grid type + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: net_mass_src !< The net mass flux of water into the ocean + !! [kg m-2 s-1]. integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - if (associated(forces%net_mass_src)) then - forces%net_mass_src(:,:) = 0.0 - if (associated(fluxes%lprec)) then ; do j=js,je ; do i=is,ie - forces%net_mass_src(i,j) = forces%net_mass_src(i,j) + fluxes%lprec(i,j) - enddo ; enddo ; endif - if (associated(fluxes%fprec)) then ; do j=js,je ; do i=is,ie - forces%net_mass_src(i,j) = forces%net_mass_src(i,j) + fluxes%fprec(i,j) - enddo ; enddo ; endif - if (associated(fluxes%vprec)) then ; do j=js,je ; do i=is,ie - forces%net_mass_src(i,j) = forces%net_mass_src(i,j) + fluxes%vprec(i,j) - enddo ; enddo ; endif - if (associated(fluxes%lrunoff)) then ; do j=js,je ; do i=is,ie - forces%net_mass_src(i,j) = forces%net_mass_src(i,j) + fluxes%lrunoff(i,j) - enddo ; enddo ; endif - if (associated(fluxes%frunoff)) then ; do j=js,je ; do i=is,ie - forces%net_mass_src(i,j) = forces%net_mass_src(i,j) + fluxes%frunoff(i,j) - enddo ; enddo ; endif - if (associated(fluxes%evap)) then ; do j=js,je ; do i=is,ie - forces%net_mass_src(i,j) = forces%net_mass_src(i,j) + fluxes%evap(i,j) - enddo ; enddo ; endif - endif - -end subroutine set_net_mass_forcing + net_mass_src(:,:) = 0.0 + if (associated(fluxes%lprec)) then ; do j=js,je ; do i=is,ie + net_mass_src(i,j) = net_mass_src(i,j) + fluxes%lprec(i,j) + enddo ; enddo ; endif + if (associated(fluxes%fprec)) then ; do j=js,je ; do i=is,ie + net_mass_src(i,j) = net_mass_src(i,j) + fluxes%fprec(i,j) + enddo ; enddo ; endif + if (associated(fluxes%vprec)) then ; do j=js,je ; do i=is,ie + net_mass_src(i,j) = net_mass_src(i,j) + fluxes%vprec(i,j) + enddo ; enddo ; endif + if (associated(fluxes%lrunoff)) then ; do j=js,je ; do i=is,ie + net_mass_src(i,j) = net_mass_src(i,j) + fluxes%lrunoff(i,j) + enddo ; enddo ; endif + if (associated(fluxes%frunoff)) then ; do j=js,je ; do i=is,ie + net_mass_src(i,j) = net_mass_src(i,j) + fluxes%frunoff(i,j) + enddo ; enddo ; endif + if (associated(fluxes%evap)) then ; do j=js,je ; do i=is,ie + net_mass_src(i,j) = net_mass_src(i,j) + fluxes%evap(i,j) + enddo ; enddo ; endif + if (associated(fluxes%seaice_melt)) then ; do j=js,je ; do i=is,ie + net_mass_src(i,j) = net_mass_src(i,j) + fluxes%seaice_melt(i,j) + enddo ; enddo ; endif + +end subroutine get_net_mass_forcing !> This subroutine copies the computational domains of common forcing fields !! from a mech_forcing type to a (thermodynamic) forcing type. @@ -1955,7 +2136,7 @@ subroutine copy_back_forcing_fields(fluxes, forces, G) type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces type(ocean_grid_type), intent(in) :: G !< grid type - real :: taux2, tauy2 ! Squared wind stress components, in Pa^2. + real :: taux2, tauy2 ! Squared wind stress components [Pa2]. integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -1969,9 +2150,8 @@ end subroutine copy_back_forcing_fields !> Offer mechanical forcing fields for diagnostics for those !! fields registered as part of register_forcing_type_diags. -subroutine mech_forcing_diags(forces, fluxes, dt, G, diag, handles) +subroutine mech_forcing_diags(forces, dt, G, diag, handles) type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces - type(forcing), intent(in) :: fluxes !< A structure containing thermodynamic forcing fields real, intent(in) :: dt !< time step type(ocean_grid_type), intent(in) :: G !< grid type type(diag_ctrl), intent(in) :: diag !< diagnostic type @@ -1986,20 +2166,15 @@ subroutine mech_forcing_diags(forces, fluxes, dt, G, diag, handles) if ((handles%id_taux > 0) .and. associated(forces%taux)) & call post_data(handles%id_taux, forces%taux, diag) + if ((handles%id_tauy > 0) .and. associated(forces%tauy)) & call post_data(handles%id_tauy, forces%tauy, diag) - if ((handles%id_ustar > 0) .and. associated(fluxes%ustar)) & - call post_data(handles%id_ustar, fluxes%ustar, diag) - if (handles%id_ustar_berg > 0) & - call post_data(handles%id_ustar_berg, fluxes%ustar_berg, diag) - if (handles%id_area_berg > 0) & - call post_data(handles%id_area_berg, fluxes%area_berg, diag) - if (handles%id_mass_berg > 0) & - call post_data(handles%id_mass_berg, fluxes%mass_berg, diag) - if (handles%id_frac_ice_cover > 0) & - call post_data(handles%id_frac_ice_cover, fluxes%frac_shelf_h, diag) - if (handles%id_ustar_ice_cover > 0) & - call post_data(handles%id_ustar_ice_cover, fluxes%ustar_shelf, diag) + + if ((handles%id_mass_berg > 0) .and. associated(forces%mass_berg)) & + call post_data(handles%id_mass_berg, forces%mass_berg, diag) + + if ((handles%id_area_berg > 0) .and. associated(forces%area_berg)) & + call post_data(handles%id_area_berg, forces%area_berg, diag) endif @@ -2010,7 +2185,7 @@ end subroutine mech_forcing_diags !> Offer buoyancy forcing fields for diagnostics for those !! fields registered as part of register_forcing_type_diags. subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) - type(forcing), intent(in) :: fluxes !< flux type + type(forcing), intent(in) :: fluxes !< A structure containing thermodynamic forcing fields type(surface), intent(in) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. real, intent(in) :: dt !< time step @@ -2048,50 +2223,53 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) 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%vprec)) res(i,j) = res(i,j)+fluxes%vprec(i,j) + if (associated(fluxes%seaice_melt)) res(i,j) = res(i,j)+fluxes%seaice_melt(i,j) enddo ; enddo - call post_data(handles%id_prcme, res, diag) - if(handles%id_total_prcme > 0) then + if (handles%id_prcme > 0) call post_data(handles%id_prcme, res, diag) + if (handles%id_total_prcme > 0) then total_transport = global_area_integral(res,G) call post_data(handles%id_total_prcme, total_transport, diag) endif - if(handles%id_prcme_ga > 0) then + if (handles%id_prcme_ga > 0) then ave_flux = global_area_mean(res,G) call post_data(handles%id_prcme_ga, ave_flux, diag) endif endif - if(handles%id_net_massout > 0 .or. handles%id_total_net_massout > 0) then + 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%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) enddo ; enddo - call post_data(handles%id_net_massout, res, diag) - if(handles%id_total_net_massout > 0) then + if (handles%id_net_massout > 0) call post_data(handles%id_net_massout, res, diag) + if (handles%id_total_net_massout > 0) then total_transport = global_area_integral(res,G) call post_data(handles%id_total_net_massout, total_transport, diag) endif endif - if(handles%id_massout_flux > 0) call post_data(handles%id_massout_flux,fluxes%netMassOut,diag) + if (handles%id_massout_flux > 0) call post_data(handles%id_massout_flux,fluxes%netMassOut,diag) - if(handles%id_net_massin > 0 .or. handles%id_total_net_massin > 0) then + 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) + 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) ! 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%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) enddo ; enddo - call post_data(handles%id_net_massin, res, diag) - if(handles%id_total_net_massin > 0) then + if (handles%id_net_massin > 0) call post_data(handles%id_net_massin, res, diag) + if (handles%id_total_net_massin > 0) then total_transport = global_area_integral(res,G) call post_data(handles%id_total_net_massin, total_transport, diag) endif endif - if(handles%id_massin_flux > 0) call post_data(handles%id_massin_flux,fluxes%netMassIn,diag) + if (handles%id_massin_flux > 0) 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) @@ -2171,6 +2349,14 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) endif endif + if (associated(fluxes%seaice_melt)) then + if (handles%id_seaice_melt > 0) call post_data(handles%id_seaice_melt, fluxes%seaice_melt, diag) + if (handles%id_total_seaice_melt > 0) then + total_transport = global_area_integral(fluxes%seaice_melt,G) + call post_data(handles%id_total_seaice_melt, total_transport, diag) + endif + endif + ! post diagnostics for boundary heat fluxes ==================================== if ((handles%id_heat_content_lrunoff > 0) .and. associated(fluxes%heat_content_lrunoff)) & @@ -2201,6 +2387,13 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) call post_data(handles%id_total_heat_content_fprec, total_transport, diag) endif + if ((handles%id_heat_content_icemelt > 0) .and. associated(fluxes%heat_content_icemelt)) & + call post_data(handles%id_heat_content_icemelt, fluxes%heat_content_icemelt, diag) + if ((handles%id_total_heat_content_icemelt > 0) .and. associated(fluxes%heat_content_icemelt)) then + total_transport = global_area_integral(fluxes%heat_content_icemelt,G) + call post_data(handles%id_total_heat_content_icemelt, total_transport, diag) + endif + if ((handles%id_heat_content_vprec > 0) .and. associated(fluxes%heat_content_vprec)) & call post_data(handles%id_heat_content_vprec, fluxes%heat_content_vprec, diag) if ((handles%id_total_heat_content_vprec > 0) .and. associated(fluxes%heat_content_vprec)) then @@ -2229,53 +2422,58 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) call post_data(handles%id_total_heat_content_massin, total_transport, diag) endif - if (handles%id_net_heat_coupler > 0 .or. handles%id_total_net_heat_coupler > 0 .or. handles%id_net_heat_coupler_ga > 0. ) then + if (handles%id_net_heat_coupler > 0 .or. handles%id_total_net_heat_coupler > 0 .or. & + handles%id_net_heat_coupler_ga > 0. ) then do j=js,je ; do i=is,ie res(i,j) = 0.0 - if (associated(fluxes%LW)) res(i,j) = res(i,j) + fluxes%LW(i,j) - if (associated(fluxes%latent)) res(i,j) = res(i,j) + fluxes%latent(i,j) - if (associated(fluxes%sens)) res(i,j) = res(i,j) + fluxes%sens(i,j) - if (associated(fluxes%SW)) res(i,j) = res(i,j) + fluxes%SW(i,j) + if (associated(fluxes%LW)) res(i,j) = res(i,j) + fluxes%LW(i,j) + if (associated(fluxes%latent)) res(i,j) = res(i,j) + fluxes%latent(i,j) + if (associated(fluxes%sens)) res(i,j) = res(i,j) + fluxes%sens(i,j) + if (associated(fluxes%SW)) res(i,j) = res(i,j) + fluxes%SW(i,j) + if (associated(fluxes%seaice_melt_heat)) res(i,j) = res(i,j) + fluxes%seaice_melt_heat(i,j) enddo ; enddo - call post_data(handles%id_net_heat_coupler, res, diag) - if(handles%id_total_net_heat_coupler > 0) then + if (handles%id_net_heat_coupler > 0) call post_data(handles%id_net_heat_coupler, res, diag) + if (handles%id_total_net_heat_coupler > 0) then total_transport = global_area_integral(res,G) call post_data(handles%id_total_net_heat_coupler, total_transport, diag) endif - if(handles%id_net_heat_coupler_ga > 0) then + if (handles%id_net_heat_coupler_ga > 0) then ave_flux = global_area_mean(res,G) call post_data(handles%id_net_heat_coupler_ga, ave_flux, diag) endif endif - if (handles%id_net_heat_surface > 0 .or. handles%id_total_net_heat_surface > 0 .or. handles%id_net_heat_surface_ga > 0. ) then + if (handles%id_net_heat_surface > 0 .or. handles%id_total_net_heat_surface > 0 .or. & + handles%id_net_heat_surface_ga > 0. ) then do j=js,je ; do i=is,ie res(i,j) = 0.0 if (associated(fluxes%LW)) res(i,j) = res(i,j) + fluxes%LW(i,j) if (associated(fluxes%latent)) res(i,j) = res(i,j) + fluxes%latent(i,j) if (associated(fluxes%sens)) res(i,j) = res(i,j) + fluxes%sens(i,j) if (associated(fluxes%SW)) res(i,j) = res(i,j) + fluxes%SW(i,j) + if (associated(fluxes%seaice_melt_heat)) res(i,j) = res(i,j) + fluxes%seaice_melt_heat(i,j) if (associated(sfc_state%frazil)) res(i,j) = res(i,j) + sfc_state%frazil(i,j) * I_dt - ! if (associated(sfc_state%TempXpme)) then - ! res(i,j) = res(i,j) + sfc_state%TempXpme(i,j) * fluxes%C_p * I_dt - ! else - if (associated(fluxes%heat_content_lrunoff)) res(i,j) = res(i,j) + fluxes%heat_content_lrunoff(i,j) - if (associated(fluxes%heat_content_frunoff)) res(i,j) = res(i,j) + fluxes%heat_content_frunoff(i,j) - if (associated(fluxes%heat_content_lprec)) res(i,j) = res(i,j) + fluxes%heat_content_lprec(i,j) - if (associated(fluxes%heat_content_fprec)) res(i,j) = res(i,j) + fluxes%heat_content_fprec(i,j) - if (associated(fluxes%heat_content_vprec)) res(i,j) = res(i,j) + fluxes%heat_content_vprec(i,j) - if (associated(fluxes%heat_content_cond)) res(i,j) = res(i,j) + fluxes%heat_content_cond(i,j) - if (associated(fluxes%heat_content_massout)) res(i,j) = res(i,j) + fluxes%heat_content_massout(i,j) - ! endif + !if (associated(sfc_state%TempXpme)) then + ! res(i,j) = res(i,j) + sfc_state%TempXpme(i,j) * fluxes%C_p * I_dt + !else + if (associated(fluxes%heat_content_lrunoff)) res(i,j) = res(i,j) + fluxes%heat_content_lrunoff(i,j) + if (associated(fluxes%heat_content_frunoff)) res(i,j) = res(i,j) + fluxes%heat_content_frunoff(i,j) + if (associated(fluxes%heat_content_lprec)) res(i,j) = res(i,j) + fluxes%heat_content_lprec(i,j) + if (associated(fluxes%heat_content_fprec)) res(i,j) = res(i,j) + fluxes%heat_content_fprec(i,j) + if (associated(fluxes%heat_content_icemelt)) res(i,j) = res(i,j) + fluxes%heat_content_icemelt(i,j) + if (associated(fluxes%heat_content_vprec)) res(i,j) = res(i,j) + fluxes%heat_content_vprec(i,j) + if (associated(fluxes%heat_content_cond)) res(i,j) = res(i,j) + fluxes%heat_content_cond(i,j) + if (associated(fluxes%heat_content_massout)) res(i,j) = res(i,j) + fluxes%heat_content_massout(i,j) + !endif if (associated(fluxes%heat_added)) res(i,j) = res(i,j) + fluxes%heat_added(i,j) enddo ; enddo - call post_data(handles%id_net_heat_surface, res, diag) + if (handles%id_net_heat_surface > 0) call post_data(handles%id_net_heat_surface, res, diag) - if(handles%id_total_net_heat_surface > 0) then + if (handles%id_total_net_heat_surface > 0) then total_transport = global_area_integral(res,G) call post_data(handles%id_total_net_heat_surface, total_transport, diag) endif - if(handles%id_net_heat_surface_ga > 0) then + if (handles%id_net_heat_surface_ga > 0) then ave_flux = global_area_mean(res,G) call post_data(handles%id_net_heat_surface_ga, ave_flux, diag) endif @@ -2290,14 +2488,15 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) if (associated(fluxes%heat_content_lrunoff)) res(i,j) = res(i,j) + fluxes%heat_content_lrunoff(i,j) if (associated(fluxes%heat_content_frunoff)) res(i,j) = res(i,j) + fluxes%heat_content_frunoff(i,j) if (associated(fluxes%heat_content_lprec)) res(i,j) = res(i,j) + fluxes%heat_content_lprec(i,j) + if (associated(fluxes%heat_content_icemelt)) res(i,j) = res(i,j) + fluxes%heat_content_icemelt(i,j) if (associated(fluxes%heat_content_fprec)) res(i,j) = res(i,j) + fluxes%heat_content_fprec(i,j) if (associated(fluxes%heat_content_vprec)) res(i,j) = res(i,j) + fluxes%heat_content_vprec(i,j) if (associated(fluxes%heat_content_cond)) res(i,j) = res(i,j) + fluxes%heat_content_cond(i,j) if (associated(fluxes%heat_content_massout)) res(i,j) = res(i,j) + fluxes%heat_content_massout(i,j) ! endif enddo ; enddo - call post_data(handles%id_heat_content_surfwater, res, diag) - if(handles%id_total_heat_content_surfwater > 0) then + if (handles%id_heat_content_surfwater > 0) call post_data(handles%id_heat_content_surfwater, res, diag) + if (handles%id_total_heat_content_surfwater > 0) then total_transport = global_area_integral(res,G) call post_data(handles%id_total_heat_content_surfwater, total_transport, diag) endif @@ -2307,8 +2506,8 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) if (handles%id_hfrunoffds > 0) then do j=js,je ; do i=is,ie res(i,j) = 0.0 - if(associated(fluxes%heat_content_lrunoff)) res(i,j) = res(i,j) + fluxes%heat_content_lrunoff(i,j) - if(associated(fluxes%heat_content_frunoff)) res(i,j) = res(i,j) + fluxes%heat_content_frunoff(i,j) + if (associated(fluxes%heat_content_lrunoff)) res(i,j) = res(i,j) + fluxes%heat_content_lrunoff(i,j) + if (associated(fluxes%heat_content_frunoff)) res(i,j) = res(i,j) + fluxes%heat_content_frunoff(i,j) enddo ; enddo call post_data(handles%id_hfrunoffds, res, diag) endif @@ -2317,9 +2516,9 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) if (handles%id_hfrainds > 0) then do j=js,je ; do i=is,ie res(i,j) = 0.0 - if(associated(fluxes%heat_content_lprec)) res(i,j) = res(i,j) + fluxes%heat_content_lprec(i,j) - if(associated(fluxes%heat_content_fprec)) res(i,j) = res(i,j) + fluxes%heat_content_fprec(i,j) - if(associated(fluxes%heat_content_cond)) res(i,j) = res(i,j) + fluxes%heat_content_cond(i,j) + if (associated(fluxes%heat_content_lprec)) res(i,j) = res(i,j) + fluxes%heat_content_lprec(i,j) + if (associated(fluxes%heat_content_fprec)) res(i,j) = res(i,j) + fluxes%heat_content_fprec(i,j) + if (associated(fluxes%heat_content_cond)) res(i,j) = res(i,j) + fluxes%heat_content_cond(i,j) enddo ; enddo call post_data(handles%id_hfrainds, res, diag) endif @@ -2413,7 +2612,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) if ((handles%id_lat_frunoff > 0) .and. associated(fluxes%latent_frunoff_diag)) then call post_data(handles%id_lat_frunoff, fluxes%latent_frunoff_diag, diag) endif - if(handles%id_total_lat_frunoff > 0 .and. associated(fluxes%latent_frunoff_diag)) then + if (handles%id_total_lat_frunoff > 0 .and. associated(fluxes%latent_frunoff_diag)) then total_transport = global_area_integral(fluxes%latent_frunoff_diag,G) call post_data(handles%id_total_lat_frunoff, total_transport, diag) endif @@ -2421,6 +2620,16 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) if ((handles%id_sens > 0) .and. associated(fluxes%sens)) then call post_data(handles%id_sens, fluxes%sens, diag) endif + + if ((handles%id_seaice_melt_heat > 0) .and. associated(fluxes%seaice_melt_heat)) then + call post_data(handles%id_seaice_melt_heat, fluxes%seaice_melt_heat, diag) + endif + + if ((handles%id_total_seaice_melt_heat > 0) .and. associated(fluxes%seaice_melt_heat)) then + total_transport = global_area_integral(fluxes%seaice_melt_heat,G) + call post_data(handles%id_total_seaice_melt_heat, total_transport, diag) + endif + if ((handles%id_total_sens > 0) .and. associated(fluxes%sens)) then total_transport = global_area_integral(fluxes%sens,G) call post_data(handles%id_total_sens, total_transport, diag) @@ -2488,8 +2697,19 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) if ((handles%id_buoy > 0) .and. associated(fluxes%buoy)) & call post_data(handles%id_buoy, fluxes%buoy, diag) + if ((handles%id_ustar > 0) .and. associated(fluxes%ustar)) & + call post_data(handles%id_ustar, fluxes%ustar, diag) - endif + if ((handles%id_ustar_berg > 0) .and. associated(fluxes%ustar_berg)) & + call post_data(handles%id_ustar_berg, fluxes%ustar_berg, diag) + + if ((handles%id_frac_ice_cover > 0) .and. associated(fluxes%frac_shelf_h)) & + call post_data(handles%id_frac_ice_cover, fluxes%frac_shelf_h, diag) + + if ((handles%id_ustar_ice_cover > 0) .and. associated(fluxes%ustar_shelf)) & + call post_data(handles%id_ustar_ice_cover, fluxes%ustar_shelf, diag) + + endif ! query_averaging_enabled call cpu_clock_end(handles%id_clock_forcing) end subroutine forcing_diagnostics @@ -2498,7 +2718,7 @@ end subroutine forcing_diagnostics !> Conditionally allocate fields within the forcing type subroutine allocate_forcing_type(G, fluxes, water, heat, ustar, press, shelf, iceberg, salt) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(forcing), intent(inout) :: fluxes !< Forcing fields structure + type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields logical, optional, intent(in) :: water !< If present and true, allocate water fluxes logical, optional, intent(in) :: heat !< If present and true, allocate heat fluxes logical, optional, intent(in) :: ustar !< If present and true, allocate ustar and related fields @@ -2527,7 +2747,7 @@ subroutine allocate_forcing_type(G, fluxes, water, heat, ustar, press, shelf, ic call myAlloc(fluxes%netMassOut,isd,ied,jsd,jed, water) call myAlloc(fluxes%netMassIn,isd,ied,jsd,jed, water) call myAlloc(fluxes%netSalt,isd,ied,jsd,jed, water) - + call myAlloc(fluxes%seaice_melt_heat,isd,ied,jsd,jed, heat) call myAlloc(fluxes%sw,isd,ied,jsd,jed, heat) call myAlloc(fluxes%lw,isd,ied,jsd,jed, heat) call myAlloc(fluxes%latent,isd,ied,jsd,jed, heat) @@ -2540,6 +2760,7 @@ subroutine allocate_forcing_type(G, fluxes, water, heat, ustar, press, shelf, ic if (present(heat) .and. present(water)) then ; if (heat .and. water) then call myAlloc(fluxes%heat_content_cond,isd,ied,jsd,jed, .true.) + call myAlloc(fluxes%heat_content_icemelt,isd,ied,jsd,jed, .true.) call myAlloc(fluxes%heat_content_lprec,isd,ied,jsd,jed, .true.) call myAlloc(fluxes%heat_content_fprec,isd,ied,jsd,jed, .true.) call myAlloc(fluxes%heat_content_vprec,isd,ied,jsd,jed, .true.) @@ -2594,6 +2815,10 @@ subroutine allocate_mech_forcing(G, forces, stress, ustar, shelf, press, iceberg call myAlloc(forces%frac_shelf_u,IsdB,IedB,jsd,jed, shelf) call myAlloc(forces%frac_shelf_v,isd,ied,JsdB,JedB, shelf) + !These fields should only on allocated when iceberg area is being passed through the coupler. + call myAlloc(forces%area_berg,isd,ied,jsd,jed, iceberg) + call myAlloc(forces%mass_berg,isd,ied,jsd,jed, iceberg) + end subroutine allocate_mech_forcing !> Allocates and zeroes-out array. @@ -2618,6 +2843,7 @@ subroutine deallocate_forcing_type(fluxes) if (associated(fluxes%ustar_gustless)) deallocate(fluxes%ustar_gustless) if (associated(fluxes%buoy)) deallocate(fluxes%buoy) if (associated(fluxes%sw)) deallocate(fluxes%sw) + if (associated(fluxes%seaice_melt_heat)) deallocate(fluxes%seaice_melt_heat) if (associated(fluxes%sw_vis_dir)) deallocate(fluxes%sw_vis_dir) if (associated(fluxes%sw_vis_dif)) deallocate(fluxes%sw_vis_dif) if (associated(fluxes%sw_nir_dir)) deallocate(fluxes%sw_nir_dir) @@ -2631,6 +2857,7 @@ subroutine deallocate_forcing_type(fluxes) if (associated(fluxes%heat_added)) deallocate(fluxes%heat_added) if (associated(fluxes%heat_content_lrunoff)) deallocate(fluxes%heat_content_lrunoff) if (associated(fluxes%heat_content_frunoff)) deallocate(fluxes%heat_content_frunoff) + if (associated(fluxes%heat_content_icemelt)) deallocate(fluxes%heat_content_icemelt) if (associated(fluxes%heat_content_lprec)) deallocate(fluxes%heat_content_lprec) if (associated(fluxes%heat_content_fprec)) deallocate(fluxes%heat_content_fprec) if (associated(fluxes%heat_content_cond)) deallocate(fluxes%heat_content_cond) @@ -2667,13 +2894,15 @@ subroutine deallocate_mech_forcing(forces) if (associated(forces%taux)) deallocate(forces%taux) if (associated(forces%tauy)) deallocate(forces%tauy) if (associated(forces%ustar)) deallocate(forces%ustar) - if (associated(forces%p_surf)) deallocate(forces%p_surf) - if (associated(forces%p_surf_full)) deallocate(forces%p_surf_full) + if (associated(forces%p_surf)) deallocate(forces%p_surf) + if (associated(forces%p_surf_full)) deallocate(forces%p_surf_full) if (associated(forces%net_mass_src)) deallocate(forces%net_mass_src) if (associated(forces%rigidity_ice_u)) deallocate(forces%rigidity_ice_u) if (associated(forces%rigidity_ice_v)) deallocate(forces%rigidity_ice_v) if (associated(forces%frac_shelf_u)) deallocate(forces%frac_shelf_u) if (associated(forces%frac_shelf_v)) deallocate(forces%frac_shelf_v) + if (associated(forces%area_berg)) deallocate(forces%area_berg) + if (associated(forces%mass_berg)) deallocate(forces%mass_berg) end subroutine deallocate_mech_forcing @@ -2778,7 +3007,7 @@ end subroutine deallocate_mech_forcing !! * non-penetrative = non-downwelling shortwave; portion of SW !! totally absorbed in the k=1 cell. !! The non-penetrative SW is combined with -!! LW+LAT+SENS in net_heat inside routine +!! LW+LAT+SENS+seaice_melt_heat in net_heat inside routine !! extractFluxes1d. Notably, for many cases, !! non-penetrative SW = 0. !! * penetrative = that portion of shortwave penetrating below diff --git a/src/core/MOM_grid.F90 b/src/core/MOM_grid.F90 index 86aa5bddb7..25cd31f96b 100644 --- a/src/core/MOM_grid.F90 +++ b/src/core/MOM_grid.F90 @@ -5,7 +5,7 @@ module MOM_grid use MOM_hor_index, only : hor_index_type, hor_index_init use MOM_domains, only : MOM_domain_type, get_domain_extent, compute_block_extent -use MOM_domains, only : get_global_shape +use MOM_domains, only : get_global_shape, get_domain_extent_dsamp2 use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL use MOM_file_parser, only : get_param, log_param, log_version, param_file_type @@ -14,13 +14,19 @@ module MOM_grid #include public MOM_grid_init, MOM_grid_end, set_derived_metrics, set_first_direction -public isPointInCell, hor_index_type, get_global_grid_size +public isPointInCell, hor_index_type, get_global_grid_size, rescale_grid_bathymetry + +! 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. !> Ocean grid type. See mom_grid for details. type, public :: ocean_grid_type type(MOM_domain_type), pointer :: Domain => NULL() !< Ocean model domain type(MOM_domain_type), pointer :: Domain_aux => NULL() !< A non-symmetric auxiliary domain type. type(hor_index_type) :: HI !< Horizontal index ranges + type(hor_index_type) :: HId2 !< Horizontal index ranges for level-2-downsampling integer :: isc !< The start i-index of cell centers within the computational domain integer :: iec !< The end i-index of cell centers within the computational domain @@ -70,12 +76,12 @@ module MOM_grid mask2dT, & !< 0 for land points and 1 for ocean points on the h-grid. Nd. geoLatT, & !< The geographic latitude at q points in degrees of latitude or m. geoLonT, & !< The geographic longitude at q points in degrees of longitude or m. - dxT, & !< dxT is delta x at h points, in m. - IdxT, & !< 1/dxT in m-1. - dyT, & !< dyT is delta y at h points, in m, and IdyT is 1/dyT in m-1. - IdyT, & !< dyT is delta y at h points, in m, and IdyT is 1/dyT in m-1. - areaT, & !< The area of an h-cell, in m2. - IareaT, & !< 1/areaT, in m-2. + dxT, & !< dxT is delta x at h points [m]. + IdxT, & !< 1/dxT [m-1]. + dyT, & !< dyT is delta y at h points [m]. + IdyT, & !< IdyT is 1/dyT [m-1]. + areaT, & !< The area of an h-cell [m2]. + IareaT, & !< 1/areaT [m-2]. sin_rot, & !< The sine of the angular rotation between the local model grid's northward !! and the true northward directions. cos_rot !< The cosine of the angular rotation between the local model grid's northward @@ -85,36 +91,36 @@ module MOM_grid mask2dCu, & !< 0 for boundary points and 1 for ocean points on the u grid. Nondim. geoLatCu, & !< The geographic latitude at u points in degrees of latitude or m. geoLonCu, & !< The geographic longitude at u points in degrees of longitude or m. - dxCu, & !< dxCu is delta x at u points, in m. - IdxCu, & !< 1/dxCu in m-1. - dyCu, & !< dyCu is delta y at u points, in m. - IdyCu, & !< 1/dyCu in m-1. - dy_Cu, & !< The unblocked lengths of the u-faces of the h-cell in m. - IareaCu, & !< The masked inverse areas of u-grid cells in m2. - areaCu !< The areas of the u-grid cells in m2. + dxCu, & !< dxCu is delta x at u points [m]. + IdxCu, & !< 1/dxCu [m-1]. + dyCu, & !< dyCu is delta y at u points [m]. + IdyCu, & !< 1/dyCu [m-1]. + dy_Cu, & !< The unblocked lengths of the u-faces of the h-cell [m]. + IareaCu, & !< The masked inverse areas of u-grid cells [m2]. + areaCu !< The areas of the u-grid cells [m2]. real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: & mask2dCv, & !< 0 for boundary points and 1 for ocean points on the v grid. Nondim. geoLatCv, & !< The geographic latitude at v points in degrees of latitude or m. geoLonCv, & !< The geographic longitude at v points in degrees of longitude or m. - dxCv, & !< dxCv is delta x at v points, in m. - IdxCv, & !< 1/dxCv in m-1. - dyCv, & !< dyCv is delta y at v points, in m. - IdyCv, & !< 1/dyCv in m-1. - dx_Cv, & !< The unblocked lengths of the v-faces of the h-cell in m. - IareaCv, & !< The masked inverse areas of v-grid cells in m2. - areaCv !< The areas of the v-grid cells in m2. + dxCv, & !< dxCv is delta x at v points [m]. + IdxCv, & !< 1/dxCv [m-1]. + dyCv, & !< dyCv is delta y at v points [m]. + IdyCv, & !< 1/dyCv [m-1]. + dx_Cv, & !< The unblocked lengths of the v-faces of the h-cell [m]. + IareaCv, & !< The masked inverse areas of v-grid cells [m2]. + areaCv !< The areas of the v-grid cells [m2]. real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: & mask2dBu, & !< 0 for boundary points and 1 for ocean points on the q grid. Nondim. geoLatBu, & !< The geographic latitude at q points in degrees of latitude or m. geoLonBu, & !< The geographic longitude at q points in degrees of longitude or m. - dxBu, & !< dxBu is delta x at q points, in m. - IdxBu, & !< 1/dxBu in m-1. - dyBu, & !< dyBu is delta y at q points, in m. - IdyBu, & !< 1/dyBu in m-1. - areaBu, & !< areaBu is the area of a q-cell, in m2 - IareaBu !< IareaBu = 1/areaBu in m-2. + dxBu, & !< dxBu is delta x at q points [m]. + IdxBu, & !< 1/dxBu [m-1]. + dyBu, & !< dyBu is delta y at q points [m]. + IdyBu, & !< 1/dyBu [m-1]. + areaBu, & !< areaBu is the area of a q-cell [m2] + IareaBu !< IareaBu = 1/areaBu [m-2]. real, pointer, dimension(:) :: & gridLatT => NULL(), & !< The latitude of T points for the purpose of labeling the output axes. @@ -131,31 +137,31 @@ module MOM_grid y_axis_units !< The units that are used in labeling the y coordinate axes. real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: & - bathyT !< Ocean bottom depth at tracer points, in m. + bathyT !< Ocean bottom depth at tracer points, in depth units [Z ~> m]. logical :: bathymetry_at_vel !< If true, there are separate values for the !! basin depths at velocity points. Otherwise the effects of !! of topography are entirely determined from thickness points. real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: & - Dblock_u, & !< Topographic depths at u-points at which the flow is blocked, in m. - Dopen_u !< Topographic depths at u-points at which the flow is open at width dy_Cu, in m. + Dblock_u, & !< Topographic depths at u-points at which the flow is blocked [Z ~> m]. + Dopen_u !< Topographic depths at u-points at which the flow is open at width dy_Cu [Z ~> m]. real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: & - Dblock_v, & !< Topographic depths at v-points at which the flow is blocked, in m. - Dopen_v !< Topographic depths at v-points at which the flow is open at width dx_Cv, in m. + Dblock_v, & !< Topographic depths at v-points at which the flow is blocked [Z ~> m]. + Dopen_v !< Topographic depths at v-points at which the flow is open at width dx_Cv [Z ~> m]. real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: & - CoriolisBu !< The Coriolis parameter at corner points, in s-1. + CoriolisBu !< The Coriolis parameter at corner points [s-1]. real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: & - dF_dx, & !< Derivative d/dx f (Coriolis parameter) at h-points, in s-1 m-1. - dF_dy !< Derivative d/dy f (Coriolis parameter) at h-points, in s-1 m-1. - real :: g_Earth !< The gravitational acceleration in m s-2. + df_dx, & !< Derivative d/dx f (Coriolis parameter) at h-points [s-1 m-1]. + df_dy !< Derivative d/dy f (Coriolis parameter) at h-points [s-1 m-1]. + real :: g_Earth !< The gravitational acceleration [m s-2]. ! These variables are global sums that are useful for 1-d diagnostics - real :: areaT_global !< Global sum of h-cell area in m2 - real :: IareaT_global !< Global sum of inverse h-cell area (1/areaT_global) in m2. + real :: areaT_global !< Global sum of h-cell area [m2] + real :: IareaT_global !< Global sum of inverse h-cell area (1/areaT_global) [m2]. ! These variables are for block structures. - integer :: nblocks - type(hor_index_type), pointer :: Block(:) => NULL() ! store indices for each block + integer :: nblocks !< The number of sub-PE blocks on this PE + type(hor_index_type), pointer :: Block(:) => NULL() !< Index ranges for each block ! These parameters are run-time parameters that are used during some ! initialization routines (but not all) @@ -163,8 +169,8 @@ module MOM_grid real :: west_lon !< The longitude (or x-coordinate) of the first u-line real :: len_lat = 0. !< The latitudinal (or y-coord) extent of physical domain real :: len_lon = 0. !< The longitudinal (or x-coord) extent of physical domain - real :: Rad_Earth = 6.378e6 !< The radius of the planet in meters. - real :: max_depth !< The maximum depth of the ocean in meters. + real :: Rad_Earth = 6.378e6 !< The radius of the planet [m]. + real :: max_depth !< The maximum depth of the ocean in depth units [Z ~> m]. end type ocean_grid_type contains @@ -343,8 +349,57 @@ subroutine MOM_grid_init(G, param_file, HI, global_indexing, bathymetry_at_vel) if ( G%block(nblocks)%jed+G%block(nblocks)%jdg_offset > G%HI%jed + G%HI%jdg_offset ) & call MOM_error(FATAL, "MOM_grid_init: G%jed_bk > G%jed") + call get_domain_extent_dsamp2(G%Domain, G%HId2%isc, G%HId2%iec, G%HId2%jsc, G%HId2%jec,& + G%HId2%isd, G%HId2%ied, G%HId2%jsd, G%HId2%jed,& + G%HId2%isg, G%HId2%ieg, G%HId2%jsg, G%HId2%jeg) + + ! Set array sizes for fields that are discretized at tracer cell boundaries. + G%HId2%IscB = G%HId2%isc ; G%HId2%JscB = G%HId2%jsc + G%HId2%IsdB = G%HId2%isd ; G%HId2%JsdB = G%HId2%jsd + G%HId2%IsgB = G%HId2%isg ; G%HId2%JsgB = G%HId2%jsg + if (G%symmetric) then + G%HId2%IscB = G%HId2%isc-1 ; G%HId2%JscB = G%HId2%jsc-1 + G%HId2%IsdB = G%HId2%isd-1 ; G%HId2%JsdB = G%HId2%jsd-1 + G%HId2%IsgB = G%HId2%isg-1 ; G%HId2%JsgB = G%HId2%jsg-1 + endif + G%HId2%IecB = G%HId2%iec ; G%HId2%JecB = G%HId2%jec + G%HId2%IedB = G%HId2%ied ; G%HId2%JedB = G%HId2%jed + G%HId2%IegB = G%HId2%ieg ; G%HId2%JegB = G%HId2%jeg + end subroutine MOM_grid_init +!> rescale_grid_bathymetry permits a change in the internal units for the bathymetry on the grid, +!! both rescaling the depths and recording the new internal units. +subroutine rescale_grid_bathymetry(G, m_in_new_units) + type(ocean_grid_type), intent(inout) :: G !< The horizontal grid structure + real, intent(in) :: m_in_new_units !< The new internal representation of 1 m depth. + + ! Local variables + real :: rescale + integer :: i, j, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + if (m_in_new_units == 1.0) return + if (m_in_new_units < 0.0) & + call MOM_error(FATAL, "rescale_grid_bathymetry: Negative depth units are not permitted.") + if (m_in_new_units == 0.0) & + call MOM_error(FATAL, "rescale_grid_bathymetry: Zero depth units are not permitted.") + + rescale = 1.0 / m_in_new_units + do j=jsd,jed ; do i=isd,ied + G%bathyT(i,j) = rescale*G%bathyT(i,j) + enddo ; enddo + if (G%bathymetry_at_vel) then ; do j=jsd,jed ; do I=IsdB,IedB + G%Dblock_u(I,j) = rescale*G%Dblock_u(I,j) ; G%Dopen_u(I,j) = rescale*G%Dopen_u(I,j) + enddo ; enddo ; endif + if (G%bathymetry_at_vel) then ; do J=JsdB,JedB ; do i=isd,ied + G%Dblock_v(i,J) = rescale*G%Dblock_v(i,J) ; G%Dopen_v(i,J) = rescale*G%Dopen_v(i,J) + enddo ; enddo ; endif + G%max_depth = rescale*G%max_depth + +end subroutine rescale_grid_bathymetry !> set_derived_metrics calculates metric terms that are derived from other metrics. subroutine set_derived_metrics(G) @@ -434,9 +489,10 @@ logical function isPointInCell(G, i, j, x, y) endif end function isPointInCell +!> Store an integer indicating which direction to work on first. subroutine set_first_direction(G, y_first) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - integer, intent(in) :: y_first + integer, intent(in) :: y_first !< The first direction to store G%first_direction = y_first end subroutine set_first_direction @@ -568,18 +624,21 @@ end subroutine MOM_grid_end !! !! Grid metrics and their inverses are labelled according to their staggered location on a Arakawa C (or B) grid. !! - Metrics centered on h- or T-points are labelled T, e.g. dxT is the distance across the cell in the x-direction. -!! - Metrics centered on u-points are labelled Cu (C-grid u location). e.g. dyCu is the y-distance between two corners of a T-cell. +!! - Metrics centered on u-points are labelled Cu (C-grid u location). e.g. dyCu is the y-distance between +!! two corners of a T-cell. !! - Metrics centered on v-points are labelled Cv (C-grid v location). e.g. dyCv is the y-distance between two -points. !! - Metrics centered on q-points are labelled Bu (B-grid u,v location). e.g. areaBu is the area centered on a q-point. !! -!! \image html Grid_metrics.png "The labelling of distances (grid metrics) at various staggered location on an T-cell and around a q-point. +!! \image html Grid_metrics.png "The labelling of distances (grid metrics) at various staggered +!! location on an T-cell and around a q-point." !! !! Areas centered at T-, u-, v- and q- points are `areaT`, `areaCu`, `areaCv` and `areaBu` respectively. !! !! The reciprocal of metrics are pre-calculated and also stored in the ocean_grid_type with a I prepended to the name. !! For example, `1./areaT` is called `IareaT`, and `1./dyCv` is `IdyCv`. !! -!! Geographic latitude and longitude (or model coordinates if not on a sphere) are stored in `geoLatT`, `geoLonT` for T-points. +!! Geographic latitude and longitude (or model coordinates if not on a sphere) are stored in +!! `geoLatT`, `geoLonT` for T-points. !! u-, v- and q- point coordinates are follow same pattern of replacing T with Cu, Cv and Bu respectively. !! !! Each location also has a 2D mask indicating whether the entire column is land or ocean. diff --git a/src/core/MOM_interface_heights.F90 b/src/core/MOM_interface_heights.F90 index f30bcda8cb..de0064932d 100644 --- a/src/core/MOM_interface_heights.F90 +++ b/src/core/MOM_interface_heights.F90 @@ -6,6 +6,7 @@ module MOM_interface_heights use MOM_error_handler, only : MOM_error, FATAL use MOM_file_parser, only : log_version use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use MOM_EOS, only : int_specific_vol_dp @@ -27,33 +28,32 @@ module MOM_interface_heights !! form for consistency with the calculation of the pressure gradient forces. !! Additionally, these height may be dilated for consistency with the !! corresponding time-average quantity from the barotropic calculation. -subroutine find_eta_3d(h, tv, G_Earth, G, GV, eta, eta_bt, halo_size) - 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 !< Layer thicknesses, in H - !! (usually m or kg m-2). - type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to - !! various thermodynamic - !! variables. - real, intent(in) :: G_Earth !< Earth gravitational - !! acceleration (m/s2). - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(out) :: eta !< layer interface heights - !! (meter). - real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: eta_bt !< optional barotropic +subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m) + 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 + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(out) :: eta !< layer interface heights + !! [Z ~> m] or 1/eta_to_m m). + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: eta_bt !< optional barotropic !! variable that gives the "correct" free surface height (Boussinesq) or total water !! column mass per unit area (non-Boussinesq). This is used to dilate the layer. - !! thicknesses when calculating interfaceheights, in H (m or kg m-2). + !! thicknesses when calculating interfaceheights [H ~> m or kg m-2]. integer, optional, intent(in) :: halo_size !< width of halo points on - !! which to calculate eta. + !! which to calculate eta. + real, optional, intent(in) :: eta_to_m !< The conversion factor from + !! the units of eta to m; by default this is US%Z_to_m. + ! Local variables real :: p(SZI_(G),SZJ_(G),SZK_(G)+1) real :: dz_geo(SZI_(G),SZJ_(G),SZK_(G)) ! The change in geopotential height - ! across a layer, in m2 s-2. + ! across a layer [m2 s-2]. real :: dilate(SZI_(G)) ! non-dimensional dilation factor real :: htot(SZI_(G)) ! total thickness H real :: I_gEarth + real :: Z_to_eta, H_to_eta, H_to_rho_eta ! Unit conversion factors with obvious names. integer i, j, k, isv, iev, jsv, jev, nz, halo halo = 0 ; if (present(halo_size)) halo = max(0,halo_size) @@ -64,18 +64,19 @@ subroutine find_eta_3d(h, tv, G_Earth, G, GV, eta, eta_bt, halo_size) if ((isvG%ied) .or. (jsvG%jed)) & call MOM_error(FATAL,"find_eta called with an overly large halo_size.") - I_gEarth = 1.0 / G_Earth + Z_to_eta = 1.0 ; if (present(eta_to_m)) Z_to_eta = US%Z_to_m / eta_to_m + H_to_eta = GV%H_to_Z * Z_to_eta + H_to_rho_eta = GV%H_to_kg_m2 * (US%m_to_Z * Z_to_eta) + I_gEarth = Z_to_eta / GV%g_Earth -!$OMP parallel default(none) shared(isv,iev,jsv,jev,nz,eta,G,GV,h,eta_bt,tv,p, & -!$OMP G_Earth,dz_geo,halo,I_gEarth) & -!$OMP private(dilate,htot) +!$OMP parallel default(shared) private(dilate,htot) !$OMP do - do j=jsv,jev ; do i=isv,iev ; eta(i,j,nz+1) = -G%bathyT(i,j) ; enddo ; enddo + do j=jsv,jev ; do i=isv,iev ; eta(i,j,nz+1) = -Z_to_eta*G%bathyT(i,j) ; enddo ; enddo if (GV%Boussinesq) then !$OMP do do j=jsv,jev ; do k=nz,1,-1; do i=isv,iev - eta(i,j,K) = eta(i,j,K+1) + h(i,j,k)*GV%H_to_m + eta(i,j,K) = eta(i,j,K+1) + h(i,j,k)*H_to_eta enddo ; enddo ; enddo if (present(eta_bt)) then ! Dilate the water column to agree with the free surface height @@ -83,22 +84,22 @@ subroutine find_eta_3d(h, tv, G_Earth, G, GV, eta, eta_bt, halo_size) !$OMP do do j=jsv,jev do i=isv,iev - dilate(i) = (eta_bt(i,j)*GV%H_to_m + G%bathyT(i,j)) / & - (eta(i,j,1) + G%bathyT(i,j)) + dilate(i) = (eta_bt(i,j)*H_to_eta + Z_to_eta*G%bathyT(i,j)) / & + (eta(i,j,1) + Z_to_eta*G%bathyT(i,j)) enddo do k=1,nz ; do i=isv,iev - eta(i,j,K) = dilate(i) * (eta(i,j,K) + G%bathyT(i,j)) - G%bathyT(i,j) + eta(i,j,K) = dilate(i) * (eta(i,j,K) + Z_to_eta*G%bathyT(i,j)) - Z_to_eta*G%bathyT(i,j) enddo ; enddo enddo endif else if (associated(tv%eqn_of_state)) then - ! ### THIS SHOULD BE P_SURF, IF AVAILABLE. !$OMP do do j=jsv,jev + ! ### THIS SHOULD BE P_SURF, IF AVAILABLE. do i=isv,iev ; p(i,j,1) = 0.0 ; enddo do k=1,nz ; do i=isv,iev - p(i,j,K+1) = p(i,j,K) + G_Earth*GV%H_to_kg_m2*h(i,j,k) + p(i,j,K+1) = p(i,j,K) + GV%H_to_Pa*h(i,j,k) enddo ; enddo enddo !$OMP do @@ -115,7 +116,7 @@ subroutine find_eta_3d(h, tv, G_Earth, G, GV, eta, eta_bt, halo_size) else !$OMP do do j=jsv,jev ; do k=nz,1,-1; do i=isv,iev - eta(i,j,K) = eta(i,j,K+1) + GV%H_to_kg_m2*h(i,j,k)/GV%Rlay(k) + eta(i,j,K) = eta(i,j,K+1) + H_to_rho_eta*h(i,j,k)/GV%Rlay(k) enddo ; enddo ; enddo endif if (present(eta_bt)) then @@ -127,7 +128,7 @@ subroutine find_eta_3d(h, tv, G_Earth, G, GV, eta, eta_bt, halo_size) do k=1,nz ; do i=isv,iev ; htot(i) = htot(i) + h(i,j,k) ; enddo ; enddo do i=isv,iev ; dilate(i) = eta_bt(i,j) / htot(i) ; enddo do k=1,nz ; do i=isv,iev - eta(i,j,K) = dilate(i) * (eta(i,j,K) + G%bathyT(i,j)) - G%bathyT(i,j) + eta(i,j,K) = dilate(i) * (eta(i,j,K) + Z_to_eta*G%bathyT(i,j)) - Z_to_eta*G%bathyT(i,j) enddo ; enddo enddo endif @@ -140,56 +141,55 @@ end subroutine find_eta_3d !! with the calculation of the pressure gradient forces. Additionally, the sea !! surface height may be adjusted for consistency with the corresponding !! time-average quantity from the barotropic calculation. -subroutine find_eta_2d(h, tv, G_Earth, G, GV, eta, eta_bt, halo_size) - 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 !< Layer thicknesses, in H - !! (usually m or kg m-2). - type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to - !! various thermodynamic - !! variables. - real, intent(in) :: G_Earth !< Earth gravitational - !! acceleration (m/s2). - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: eta !< free surface height - !! relative to mean sea - !! level (z=0) (m). - real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: eta_bt !< optional barotropic +subroutine find_eta_2d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m) + 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 + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: eta !< free surface height relative to + !! mean sea level (z=0) often [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: eta_bt !< optional barotropic !! variable that gives the "correct" free surface height (Boussinesq) or total - !! water column mass per unit area (non-Boussinesq), in H (m or kg m-2). + !! water column mass per unit area (non-Boussinesq) [H ~> m or kg m-2]. integer, optional, intent(in) :: halo_size !< width of halo points on - !! which to calculate eta. + !! which to calculate eta. + real, optional, intent(in) :: eta_to_m !< The conversion factor from + !! the units of eta to m; by default this is US%Z_to_m. ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: & - p ! The pressure in Pa. + p ! The pressure at interfaces [Pa]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & - dz_geo ! The change in geopotential height across a layer, in m2 s-2. - real :: htot(SZI_(G)) ! The sum of all layers' thicknesses, in kg m-2 or m. + dz_geo ! The change in geopotential height across a layer [m2 s-2]. + real :: htot(SZI_(G)) ! The sum of all layers' thicknesses [H ~> m or kg m-2]. real :: I_gEarth + real :: Z_to_eta, H_to_eta, H_to_rho_eta ! Unit conversion factors with obvious names. integer i, j, k, is, ie, js, je, nz, halo halo = 0 ; if (present(halo_size)) halo = max(0,halo_size) is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo nz = G%ke - I_gEarth = 1.0 / G_Earth + Z_to_eta = 1.0 ; if (present(eta_to_m)) Z_to_eta = US%Z_to_m / eta_to_m + H_to_eta = GV%H_to_Z * Z_to_eta + H_to_rho_eta = GV%H_to_kg_m2 * (US%m_to_Z * Z_to_eta) + I_gEarth = Z_to_eta / GV%g_Earth -!$OMP parallel default(none) shared(is,ie,js,je,nz,eta,G,GV,eta_bt,h,tv,p, & -!$OMP G_Earth,dz_geo,halo,I_gEarth) & -!$OMP private(htot) +!$OMP parallel default(shared) private(htot) !$OMP do - do j=js,je ; do i=is,ie ; eta(i,j) = -G%bathyT(i,j) ; enddo ; enddo + do j=js,je ; do i=is,ie ; eta(i,j) = -Z_to_eta*G%bathyT(i,j) ; enddo ; enddo if (GV%Boussinesq) then if (present(eta_bt)) then !$OMP do do j=js,je ; do i=is,ie - eta(i,j) = GV%H_to_m*eta_bt(i,j) + eta(i,j) = H_to_eta*eta_bt(i,j) enddo ; enddo else !$OMP do do j=js,je ; do k=1,nz ; do i=is,ie - eta(i,j) = eta(i,j) + h(i,j,k)*GV%H_to_m + eta(i,j) = eta(i,j) + h(i,j,k)*H_to_eta enddo ; enddo ; enddo endif else @@ -199,7 +199,7 @@ subroutine find_eta_2d(h, tv, G_Earth, G, GV, eta, eta_bt, halo_size) do i=is,ie ; p(i,j,1) = 0.0 ; enddo do k=1,nz ; do i=is,ie - p(i,j,k+1) = p(i,j,k) + G_Earth*GV%H_to_kg_m2*h(i,j,k) + p(i,j,k+1) = p(i,j,k) + GV%H_to_Pa*h(i,j,k) enddo ; enddo enddo !$OMP do @@ -214,7 +214,7 @@ subroutine find_eta_2d(h, tv, G_Earth, G, GV, eta, eta_bt, halo_size) else !$OMP do do j=js,je ; do k=1,nz ; do i=is,ie - eta(i,j) = eta(i,j) + GV%H_to_kg_m2*h(i,j,k)/GV%Rlay(k) + eta(i,j) = eta(i,j) + H_to_rho_eta*h(i,j,k)/GV%Rlay(k) enddo ; enddo ; enddo endif if (present(eta_bt)) then @@ -225,8 +225,8 @@ subroutine find_eta_2d(h, tv, G_Earth, G, GV, eta, eta_bt, halo_size) do i=is,ie ; htot(i) = GV%H_subroundoff ; enddo do k=1,nz ; do i=is,ie ; htot(i) = htot(i) + h(i,j,k) ; enddo ; enddo do i=is,ie - eta(i,j) = (eta_bt(i,j) / htot(i)) * (eta(i,j) + G%bathyT(i,j)) - & - G%bathyT(i,j) + eta(i,j) = (eta_bt(i,j) / htot(i)) * (eta(i,j) + Z_to_eta*G%bathyT(i,j)) - & + Z_to_eta*G%bathyT(i,j) enddo enddo endif diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index bb96f82fe4..11975aa5dc 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -4,6 +4,7 @@ module MOM_isopycnal_slopes ! This file is part of MOM6. See LICENSE.md for the license. use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use MOM_EOS, only : int_specific_vol_dp, calculate_density_derivs @@ -14,68 +15,89 @@ module MOM_isopycnal_slopes public calc_isoneutral_slopes +! 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. + contains !> Calculate isopycnal slopes, and optionally return N2 used in calculation. -subroutine calc_isoneutral_slopes(G, GV, h, e, tv, dt_kappa_smooth, & - slope_x, slope_y, N2_u, N2_v, halo) +subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & + slope_x, slope_y, N2_u, N2_v, halo) !, eta_to_m) 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 !< Layer thicknesses, in H (usually m or kg m-2) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: e !< Interface heights (m) - type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables - real, intent(in) :: dt_kappa_smooth - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: slope_x !< Isopycnal slope in i-direction (nondim) - real, dimension(SZI_(G),SZJB_(G),SZK_(G)+1), intent(inout) :: slope_y !< Isopycnal slope in j-direction (nondim) - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: N2_u !< Brunt-Vaisala frequency squared at u-points (s-2) - real, dimension(SZI_(G),SZJB_(G),SZK_(G)+1), intent(inout) :: N2_v !< Brunt-Vaisala frequency squared at u-points (s-2) - optional :: N2_u, N2_v - integer, optional, intent(in) :: halo !< Halo width over which to compute + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + 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)+1), intent(in) :: e !< Interface heights [Z ~> m] or units + !! given by 1/eta_to_m) + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables + real, intent(in) :: dt_kappa_smooth !< A smoothing vertical diffusivity + !! times a smoothing timescale [Z2 ~> m2]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: slope_x !< Isopycnal slope in i-direction [nondim] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)+1), intent(inout) :: slope_y !< Isopycnal slope in j-direction [nondim] + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)+1), & + optional, intent(inout) :: N2_u !< Brunt-Vaisala frequency squared at + !! interfaces between u-points [s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)+1), & + optional, intent(inout) :: N2_v !< Brunt-Vaisala frequency squared at + !! interfaces between u-points [s-2] + integer, optional, intent(in) :: halo !< Halo width over which to compute + + ! real, optional, intent(in) :: eta_to_m !< The conversion factor from the units + ! (This argument has been tested but for now serves no purpose.) !! of eta to m; US%Z_to_m by default. ! Local variables real, dimension(SZI_(G), SZJ_(G), SZK_(G)) :: & - T, & ! The temperature (or density) in C, with the values in + T, & ! The temperature [degC], with the values in ! in massless layers filled vertically by diffusion. - S, & ! The filled salinity, in PSU, with the values in + S, & ! The filled salinity [ppt], with the values in ! in massless layers filled vertically by diffusion. - Rho ! Density itself, when a nonlinear equation of state is - ! not in use. + Rho ! Density itself, when a nonlinear equation of state is not in use [kg m-3]. real, dimension(SZI_(G), SZJ_(G), SZK_(G)+1) :: & - pres ! The pressure at an interface, in Pa. + pres ! The pressure at an interface [Pa]. real, dimension(SZIB_(G)) :: & - drho_dT_u, & ! The derivatives of density with temperature and - drho_dS_u ! salinity at u points, in kg m-3 K-1 and kg m-3 psu-1. + drho_dT_u, & ! The derivative of density with temperature at u points [kg m-3 degC-1]. + drho_dS_u ! The derivative of density with salinity at u points [kg m-3 ppt-1]. real, dimension(SZI_(G)) :: & - drho_dT_v, & ! The derivatives of density with temperature and - drho_dS_v ! salinity at v points, in kg m-3 K-1 and kg m-3 psu-1. + drho_dT_v, & ! The derivative of density with temperature at v points [kg m-3 degC-1]. + drho_dS_v ! The derivative of density with salinity at v points [kg m-3 ppt-1]. real, dimension(SZIB_(G)) :: & - T_u, S_u, & ! Temperature, salinity, and pressure on the interface at - pres_u ! the u-point in the horizontal. + T_u, & ! Temperature on the interface at the u-point [degC]. + S_u, & ! Salinity on the interface at the u-point [ppt]. + pres_u ! Pressure on the interface at the u-point [Pa]. real, dimension(SZI_(G)) :: & - T_v, S_v, & ! Temperature, salinity, and pressure on the interface at - pres_v ! the v-point in the horizontal. + T_v, & ! Temperature on the interface at the v-point [degC]. + S_v, & ! Salinity on the interface at the v-point [ppt]. + pres_v ! Pressure on the interface at the v-point [Pa]. real :: drdiA, drdiB ! Along layer zonal- and meridional- potential density real :: drdjA, drdjB ! gradients in the layers above (A) and below(B) the - ! interface times the grid spacing, in kg m-3. - real :: drdkL, drdkR ! Vertical density differences across an interface, - ! in kg m-3. - real :: hg2A, hg2B, hg2L, hg2R - real :: haA, haB, haL, haR - real :: dzaL, dzaR - real :: wtA, wtB, wtL, wtR - real :: drdx, drdy, drdz ! Zonal, meridional, and vertical density gradients, - ! in units of kg m-4. + ! interface times the grid spacing [kg m-3]. + real :: drdkL, drdkR ! Vertical density differences across an interface [kg m-3]. + real :: hg2A, hg2B ! Squares of geometric mean thicknesses [H2 ~> m2 or kg2 m-4]. + real :: hg2L, hg2R ! Squares of geometric mean thicknesses [H2 ~> m2 or kg2 m-4]. + real :: haA, haB, haL, haR ! Arithmetic mean thicknesses [H ~> m or kg m-2]. + real :: dzaL, dzaR ! Temporary thicknesses in eta units [Z ~> m]. + real :: wtA, wtB, wtL, wtR ! Unscaled weights, with various units. + real :: drdx, drdy ! Zonal and meridional density gradients [kg m-4]. + real :: drdz ! Vertical density gradient [kg m-3 Z-1 ~> kg m-4]. real :: Slope ! The slope of density surfaces, calculated in a way ! that is always between -1 and 1. - real :: mag_grad2 ! The squared magnitude of the 3-d density gradient, in kg2 m-8. + real :: mag_grad2 ! The squared magnitude of the 3-d density gradient [kg2 m-8]. real :: slope2_Ratio ! The ratio of the slope squared to slope_max squared. real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected, in H. - real :: h_neglect2 ! h_neglect^2, in H2. - real :: dz_neglect ! A thickness in m that is so small it is usually lost - ! in roundoff and can be neglected, in m. + ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: h_neglect2 ! h_neglect^2 [H2 ~> m2 or kg2 m-4]. + real :: dz_neglect ! A change in interface heighs that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m]. logical :: use_EOS ! If true, density is calculated from T & S using an ! equation of state. real :: G_Rho0, N2, dzN2, H_x(SZIB_(G)), H_y(SZI_(G)) + real :: Z_to_L ! A conversion factor between from units for e to the + ! units for lateral distances. + real :: L_to_Z ! A conversion factor between from units for lateral distances + ! to the units for e. + real :: H_to_Z ! A conversion factor from thickness units to the units of e. logical :: present_N2_u, present_N2_v integer :: is, ie, js, je, nz, IsdB @@ -89,13 +111,18 @@ subroutine calc_isoneutral_slopes(G, GV, h, e, tv, dt_kappa_smooth, & nz = G%ke ; IsdB = G%IsdB h_neglect = GV%H_subroundoff ; h_neglect2 = h_neglect**2 - dz_neglect = GV%H_subroundoff*GV%H_to_m + Z_to_L = US%Z_to_m ; H_to_Z = GV%H_to_Z + ! if (present(eta_to_m)) then + ! Z_to_L = eta_to_m ; H_to_Z = GV%H_to_m / eta_to_m + ! endif + L_to_Z = 1.0 / Z_to_L + dz_neglect = GV%H_subroundoff * H_to_Z use_EOS = associated(tv%eqn_of_state) present_N2_u = PRESENT(N2_u) present_N2_v = PRESENT(N2_v) - G_Rho0 = GV%g_Earth / GV%Rho0 + G_Rho0 = (GV%g_Earth*L_to_Z*US%m_to_Z) / GV%Rho0 if (present_N2_u) then do j=js,je ; do I=is-1,ie N2_u(I,j,1) = 0. @@ -111,34 +138,32 @@ subroutine calc_isoneutral_slopes(G, GV, h, e, tv, dt_kappa_smooth, & if (use_EOS) then if (present(halo)) then - call vert_fill_TS(h, tv%T, tv%S, dt_kappa_smooth, 1.0, T, S, G, GV, halo+1) + call vert_fill_TS(h, tv%T, tv%S, dt_kappa_smooth, T, S, G, GV, halo+1) else - call vert_fill_TS(h, tv%T, tv%S, dt_kappa_smooth, 1.0, T, S, G, GV, 1) + call vert_fill_TS(h, tv%T, tv%S, dt_kappa_smooth, T, S, G, GV, 1) endif endif ! Find the maximum and minimum permitted streamfunction. -!$OMP parallel default(none) shared(is,ie,js,je,pres,GV,h,nz) -!$OMP do + !$OMP parallel do default(shared) do j=js-1,je+1 ; do i=is-1,ie+1 pres(i,j,1) = 0.0 ! ### This should be atmospheric pressure. pres(i,j,2) = pres(i,j,1) + GV%H_to_Pa*h(i,j,1) enddo ; enddo -!$OMP do + !$OMP parallel do default(shared) do j=js-1,je+1 do k=2,nz ; do i=is-1,ie+1 pres(i,j,K+1) = pres(i,j,K) + GV%H_to_Pa*h(i,j,k) enddo ; enddo enddo -!$OMP end parallel - -!$OMP parallel do default(none) shared(nz,is,ie,js,je,use_EOS,G,GV,pres,T,S, & -!$OMP IsdB,tv,h,h_neglect,e,dz_neglect, & -!$OMP h_neglect2,present_N2_u,G_Rho0,N2_u,slope_x) & -!$OMP private(drdiA,drdiB,drdkL,drdkR,pres_u,T_u,S_u, & -!$OMP drho_dT_u,drho_dS_u,hg2A,hg2B,hg2L,hg2R,haA, & -!$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & -!$OMP drdx,mag_grad2,Slope,slope2_Ratio) + + !$OMP parallel do default(none) shared(nz,is,ie,js,je,IsdB,use_EOS,G,GV,pres,T,S,tv, & + !$OMP h,h_neglect,e,dz_neglect,Z_to_L,L_to_Z,H_to_Z, & + !$OMP h_neglect2,present_N2_u,G_Rho0,N2_u,slope_x) & + !$OMP private(drdiA,drdiB,drdkL,drdkR,pres_u,T_u,S_u, & + !$OMP drho_dT_u,drho_dS_u,hg2A,hg2B,hg2L,hg2R,haA, & + !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & + !$OMP drdx,mag_grad2,Slope,slope2_Ratio) do j=js,je ; do K=nz,2,-1 if (.not.(use_EOS)) then drdiA = 0.0 ; drdiB = 0.0 @@ -182,7 +207,7 @@ subroutine calc_isoneutral_slopes(G, GV, h, e, tv, dt_kappa_smooth, & haL = 0.5*(h(i,j,k-1) + h(i,j,k)) + h_neglect haR = 0.5*(h(i+1,j,k-1) + h(i+1,j,k)) + h_neglect if (GV%Boussinesq) then - dzaL = haL * GV%H_to_m ; dzaR = haR * GV%H_to_m + dzaL = haL * H_to_Z ; dzaR = haR * H_to_Z else dzaL = 0.5*(e(i,j,K-1) - e(i,j,K+1)) + dz_neglect dzaR = 0.5*(e(i+1,j,K-1) - e(i+1,j,K+1)) + dz_neglect @@ -202,30 +227,30 @@ subroutine calc_isoneutral_slopes(G, GV, h, e, tv, dt_kappa_smooth, & ! This estimate of slope is accurate for small slopes, but bounded ! to be between -1 and 1. - mag_grad2 = drdx**2 + drdz**2 + mag_grad2 = drdx**2 + (L_to_Z*drdz)**2 if (mag_grad2 > 0.0) then slope_x(I,j,K) = drdx / sqrt(mag_grad2) else ! Just in case mag_grad2 = 0 ever. slope_x(I,j,K) = 0.0 endif - if (present_N2_u) N2_u(I,j,k) = G_Rho0 * drdz * G%mask2dCu(I,j) ! Square of Brunt-Vaisala frequency (s-2) + if (present_N2_u) N2_u(I,j,k) = G_Rho0 * drdz * G%mask2dCu(I,j) ! Square of Brunt-Vaisala frequency [s-2] else ! With .not.use_EOS, the layers are constant density. - slope_x(I,j,K) = ((e(i,j,K)-e(i+1,j,K))*G%IdxCu(I,j)) + slope_x(I,j,K) = (Z_to_L*(e(i,j,K)-e(i+1,j,K))) * G%IdxCu(I,j) endif enddo ! I enddo ; enddo ! end of j-loop - ! Calculate the meridional isopycnal slope. -!$OMP parallel do default(none) shared(nz,is,ie,js,je,use_EOS,G,GV,pres,T,S, & -!$OMP IsdB,tv,h,h_neglect,e,dz_neglect, & -!$OMP h_neglect2,present_N2_v,G_Rho0,N2_v,slope_y) & -!$OMP private(drdjA,drdjB,drdkL,drdkR,pres_v,T_v,S_v, & -!$OMP drho_dT_v,drho_dS_v,hg2A,hg2B,hg2L,hg2R,haA, & -!$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & -!$OMP drdy,mag_grad2,Slope,slope2_Ratio) + ! Calculate the meridional isopycnal slope. + !$OMP parallel do default(none) shared(nz,is,ie,js,je,IsdB,use_EOS,G,GV,pres,T,S,tv, & + !$OMP h,h_neglect,e,dz_neglect,Z_to_L,L_to_Z,H_to_Z, & + !$OMP h_neglect2,present_N2_v,G_Rho0,N2_v,slope_y) & + !$OMP private(drdjA,drdjB,drdkL,drdkR,pres_v,T_v,S_v, & + !$OMP drho_dT_v,drho_dS_v,hg2A,hg2B,hg2L,hg2R,haA, & + !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & + !$OMP drdy,mag_grad2,Slope,slope2_Ratio) do j=js-1,je ; do K=nz,2,-1 if (.not.(use_EOS)) then drdjA = 0.0 ; drdjB = 0.0 @@ -266,7 +291,7 @@ subroutine calc_isoneutral_slopes(G, GV, h, e, tv, dt_kappa_smooth, & haL = 0.5*(h(i,j,k-1) + h(i,j,k)) + h_neglect haR = 0.5*(h(i,j+1,k-1) + h(i,j+1,k)) + h_neglect if (GV%Boussinesq) then - dzaL = haL * GV%H_to_m ; dzaR = haR * GV%H_to_m + dzaL = haL * H_to_Z ; dzaR = haR * H_to_Z else dzaL = 0.5*(e(i,j,K-1) - e(i,j,K+1)) + dz_neglect dzaR = 0.5*(e(i,j+1,K-1) - e(i,j+1,K+1)) + dz_neglect @@ -286,17 +311,17 @@ subroutine calc_isoneutral_slopes(G, GV, h, e, tv, dt_kappa_smooth, & ! This estimate of slope is accurate for small slopes, but bounded ! to be between -1 and 1. - mag_grad2 = drdy**2 + drdz**2 + mag_grad2 = drdy**2 + (L_to_Z*drdz)**2 if (mag_grad2 > 0.0) then slope_y(i,J,K) = drdy / sqrt(mag_grad2) else ! Just in case mag_grad2 = 0 ever. slope_y(i,J,K) = 0.0 endif - if (present_N2_v) N2_v(i,J,k) = G_Rho0 * drdz * G%mask2dCv(i,J) ! Square of Brunt-Vaisala frequency (s-2) + if (present_N2_v) N2_v(i,J,k) = G_Rho0 * drdz * G%mask2dCv(i,J) ! Square of Brunt-Vaisala frequency [s-2] else ! With .not.use_EOS, the layers are constant density. - slope_y(i,J,K) = ((e(i,j,K)-e(i,j+1,K))*G%IdyCv(i,J)) + slope_y(i,J,K) = (Z_to_L*(e(i,j,K)-e(i,j+1,K))) * G%IdyCv(i,J) endif enddo ! i @@ -306,25 +331,25 @@ end subroutine calc_isoneutral_slopes !> Returns tracer arrays (nominally T and S) with massless layers filled with !! sensible values, by diffusing vertically with a small but constant diffusivity. -subroutine vert_fill_TS(h, T_in, S_in, kappa, dt, T_f, S_f, G, GV, halo_here) - 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 !< Layer thicknesses, in H (usually m or kg m-2) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: T_in !< Temperature (deg C) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: S_in !< Salinity (psu) - real, intent(in) :: kappa !< A vertical diffusivity to use for smoothing (m2 s-1) - real, intent(in) :: dt !< The time increment, in s. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: T_f !< Filled temperature (deg C) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: S_f !< Filed salinity (psu) - integer, optional, intent(in) :: halo_here !< Halo width over which to compute +subroutine vert_fill_TS(h, T_in, S_in, kappa_dt, T_f, S_f, G, GV, halo_here) + 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 !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: T_in !< Temperature [degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: S_in !< Salinity [ppt] + real, intent(in) :: kappa_dt !< A vertical diffusivity to use for smoothing + !! times a smoothing timescale [Z2 ~> m2]. + 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 !< Filed salinity [ppt] + integer, optional, intent(in) :: halo_here !< Halo width over which to compute ! Local variables real :: ent(SZI_(G),SZK_(G)+1) ! The diffusive entrainment (kappa*dt)/dz - ! between layers in a timestep in m or kg m-2. + ! between layers in a timestep [H ~> m or kg m-2]. real :: b1(SZI_(G)), d1(SZI_(G)) ! b1, c1, and d1 are variables used by the real :: c1(SZI_(G),SZK_(G)) ! tridiagonal solver. real :: kap_dt_x2 ! The product of 2*kappa*dt, converted to - ! the same units as h, in m2 or kg2 m-4. - real :: h_neglect ! A negligible thickness, in m or kg m-2, to + ! the same units as h squared, [H2 ~> m2 or kg2 m-4]. + real :: h_neglect ! A negligible thickness [H ~> m or kg m-2], to ! allow for zero thicknesses. integer :: i, j, k, is, ie, js, je, nz, halo @@ -333,7 +358,7 @@ subroutine vert_fill_TS(h, T_in, S_in, kappa, dt, T_f, S_f, G, GV, halo_here) is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo nz = G%ke - kap_dt_x2 = (2.0*kappa*dt)*GV%m_to_H**2 + kap_dt_x2 = (2.0*kappa_dt)*GV%Z_to_H**2 h_neglect = GV%H_subroundoff if (kap_dt_x2 <= 0.0) then diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 6b59addd0b..c59eafc4c2 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -19,12 +19,13 @@ module MOM_open_boundary use MOM_obsolete_params, only : obsolete_logical, obsolete_int, obsolete_real, obsolete_char use MOM_string_functions, only : extract_word, remove_spaces use MOM_tracer_registry, only : tracer_type, tracer_registry_type, tracer_name_lookup -use MOM_variables, only : thermo_var_ptrs use time_interp_external_mod, only : init_external_field, time_interp_external use time_interp_external_mod, only : time_interp_external_init use MOM_remapping, only : remappingSchemesDoc, remappingDefaultScheme, remapping_CS use MOM_remapping, only : initialize_remapping, remapping_core_h, end_remapping use MOM_regridding, only : regridding_CS +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -53,9 +54,11 @@ module MOM_open_boundary public fill_temp_salt_segments public open_boundary_register_restarts -integer, parameter, public :: OBC_NONE = 0, OBC_SIMPLE = 1, OBC_WALL = 2 -integer, parameter, public :: OBC_FLATHER = 3 -integer, parameter, public :: OBC_RADIATION = 4 +integer, parameter, public :: OBC_NONE = 0 !< Indicates the use of no open boundary +integer, parameter, public :: OBC_SIMPLE = 1 !< Indicates the use of a simple inflow open boundary +integer, parameter, public :: OBC_WALL = 2 !< Indicates the use of a closed sall +integer, parameter, public :: OBC_FLATHER = 3 !< Indicates the use of a Flather open boundary +integer, parameter, public :: OBC_RADIATION = 4 !< Indicates the use of a radiation open boundary integer, parameter, public :: OBC_DIRECTION_N = 100 !< Indicates the boundary is an effective northern boundary integer, parameter, public :: OBC_DIRECTION_S = 200 !< Indicates the boundary is an effective southern boundary integer, parameter, public :: OBC_DIRECTION_E = 300 !< Indicates the boundary is an effective eastern boundary @@ -70,9 +73,9 @@ module MOM_open_boundary real, pointer, dimension(:,:,:) :: buffer_src=>NULL() !< buffer for segment data located at cell faces !! and on the original vertical grid integer :: nk_src !< Number of vertical levels in the source data - real, dimension(:,:,:), pointer :: dz_src=>NULL() !< vertical grid cell spacing of the incoming segment data (m) + real, dimension(:,:,:), pointer :: dz_src=>NULL() !< vertical grid cell spacing of the incoming segment data [m] real, dimension(:,:,:), pointer :: buffer_dst=>NULL() !< buffer src data remapped to the target vertical grid - real, dimension(:,:), pointer :: bt_vel=>NULL() !< barotropic velocity (m s-1) + real, dimension(:,:), pointer :: bt_vel=>NULL() !< barotropic velocity [m s-1] real :: value !< constant value if fid is equal to -1 end type OBC_segment_data_type @@ -105,9 +108,20 @@ module MOM_open_boundary logical :: Flather !< If true, applies Flather + Chapman radiation of barotropic gravity waves. logical :: radiation !< If true, 1D Orlanksi radiation boundary conditions are applied. !! If False, a gradient condition is applied. + logical :: radiation_tan !< If true, 1D Orlanksi radiation boundary conditions are applied to + !! tangential flows. + logical :: radiation_grad !< If true, 1D Orlanksi radiation boundary conditions are applied to + !! dudv and dvdx. logical :: oblique !< Oblique waves supported at radiation boundary. + logical :: oblique_tan !< If true, 2D radiation boundary conditions are applied to + !! tangential flows. + logical :: oblique_grad !< If true, 2D radiation boundary conditions are applied to + !! dudv and dvdx. logical :: nudged !< Optional supplement to radiation boundary. - logical :: specified !< Boundary fixed to external value. + logical :: nudged_tan !< Optional supplement to nudge tangential velocity. + logical :: nudged_grad !< Optional supplement to nudge normal gradient of tangential velocity. + logical :: specified !< Boundary normal velocity fixed to external value. + logical :: specified_tan !< Boundary tangential velocity fixed to external value. logical :: open !< Boundary is open for continuity solver. logical :: gradient !< Zero gradient at boundary. logical :: values_needed !< Whether or not external OBC fields are needed. @@ -121,35 +135,47 @@ module MOM_open_boundary integer :: Ie_obc !< i-indices of boundary segment. integer :: Js_obc !< j-indices of boundary segment. integer :: Je_obc !< j-indices of boundary segment. - real :: Velocity_nudging_timescale_in !< Nudging timescale on inflow (s). - real :: Velocity_nudging_timescale_out !< Nudging timescale on outflow (s). + real :: Velocity_nudging_timescale_in !< Nudging timescale on inflow [s]. + real :: Velocity_nudging_timescale_out !< Nudging timescale on outflow [s]. logical :: on_pe !< true if segment is located in the computational domain logical :: temp_segment_data_exists !< true if temperature data arrays are present logical :: salt_segment_data_exists !< true if salinity data arrays are present - real, pointer, dimension(:,:) :: Cg=>NULL() !< The external gravity - !! wave speed (m -s) at OBC-points. - real, pointer, dimension(:,:) :: Htot=>NULL() !< The total column thickness (m) at OBC-points. - real, pointer, dimension(:,:,:) :: h=>NULL() !< The cell thickness (m) at OBC-points. + real, pointer, dimension(:,:) :: Cg=>NULL() !< The external gravity wave speed [m s-1] + !! at OBC-points. + real, pointer, dimension(:,:) :: Htot=>NULL() !< The total column thickness [m] at OBC-points. + real, pointer, dimension(:,:,:) :: h=>NULL() !< The cell thickness [m] at OBC-points. real, pointer, dimension(:,:,:) :: normal_vel=>NULL() !< The layer velocity normal to the OB - !! segment (m s-1). + !! segment [m s-1]. + real, pointer, dimension(:,:,:) :: tangential_vel=>NULL() !< The layer velocity tangential to the + !! OB segment [m s-1]. + real, pointer, dimension(:,:,:) :: tangential_grad=>NULL() !< The gradient of the velocity tangential + !! to the OB segment [m s-1]. real, pointer, dimension(:,:,:) :: normal_trans=>NULL() !< The layer transport normal to the OB - !! segment (m3 s-1). + !! segment [m3 s-1]. real, pointer, dimension(:,:) :: normal_vel_bt=>NULL() !< The barotropic velocity normal to - !! the OB segment (m s-1). - real, pointer, dimension(:,:) :: normal_trans_bt=>NULL()!< The barotropic transport normal to - !! the OB segment (m3 s-1). - real, pointer, dimension(:,:) :: eta=>NULL() !< The sea-surface elevation along the segment (m). + !! the OB segment [m s-1]. + real, pointer, dimension(:,:) :: eta=>NULL() !< The sea-surface elevation along the segment [m]. real, pointer, dimension(:,:,:) :: grad_normal=>NULL() !< The gradient of the normal flow along the - !! segment (m s-1) + !! segment [s-1] + real, pointer, dimension(:,:,:) :: grad_tan=>NULL() !< The gradient of the tangential flow along the + !! segment [s-1] + real, pointer, dimension(:,:,:) :: grad_gradient=>NULL() !< The gradient of the gradient of tangential flow along the + !! segment [m-1 s-1] real, pointer, dimension(:,:,:) :: rx_normal=>NULL() !< The rx_old_u value for radiation coeff !! for normal velocity + real, pointer, dimension(:,:,:) :: ry_normal=>NULL() !< The tangential value for radiation coeff + !! for normal velocity + real, pointer, dimension(:,:,:) :: cff_normal=>NULL() !< The denominator for oblique radiation + !! for normal velocity real, pointer, dimension(:,:,:) :: nudged_normal_vel=>NULL() !< The layer velocity normal to the OB segment - !! that values should be nudged towards (m s-1). + !! that values should be nudged towards [m s-1]. real, pointer, dimension(:,:,:) :: nudged_tangential_vel=>NULL() !< The layer velocity tangential to the OB segment - !! that values should be nudged towards (m s-1). + !! that values should be nudged towards [m s-1]. + real, pointer, dimension(:,:,:) :: nudged_tangential_grad=>NULL() !< The layer dvdx or dudy towards which nudging + !! can occur [s-1]. type(segment_tracer_registry_type), pointer :: tr_Reg=> NULL()!< A pointer to the tracer registry for the segment. type(hor_index_type) :: HI !< Horizontal index ranges - real :: Tr_InvLscale3_out !< An effective inverse length scale cubed (m-3) + real :: Tr_InvLscale3_out !< An effective inverse length scale cubed [m-3] real :: Tr_InvLscale3_in !< for restoring the tracer concentration in a !! ficticious reservior towards interior values !! when flow is exiting the domain, or towards @@ -186,13 +212,21 @@ module MOM_open_boundary logical :: zero_vorticity = .false. !< If True, sets relative vorticity to zero on open boundaries. logical :: freeslip_vorticity = .false. !< If True, sets normal gradient of tangential velocity to zero !! in the relative vorticity on open boundaries. + logical :: computed_vorticity = .false. !< If True, uses external data for tangential velocity + !! in the relative vorticity on open boundaries. + logical :: specified_vorticity = .false. !< If True, uses external data for tangential velocity + !! gradients in the relative vorticity on open boundaries. logical :: zero_strain = .false. !< If True, sets strain to zero on open boundaries. logical :: freeslip_strain = .false. !< If True, sets normal gradient of tangential velocity to zero !! in the strain on open boundaries. + logical :: computed_strain = .false. !< If True, uses external data for tangential velocity to compute + !! normal gradient in the strain on open boundaries. + logical :: specified_strain = .false. !< If True, uses external data for tangential velocity gradients + !! to compute strain on open boundaries. logical :: zero_biharmonic = .false. !< If True, zeros the Laplacian of flow on open boundaries for !! use in the biharmonic viscosity term. logical :: brushcutter_mode = .false. !< If True, read data on supergrid. - real :: g_Earth + real :: g_Earth !< The gravitational acceleration [m s-2]. ! Properties of the segments used. type(OBC_segment_type), pointer, dimension(:) :: & segment => NULL() !< List of segment objects. @@ -206,24 +240,21 @@ module MOM_open_boundary !! 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, with a default of 0.3. - real :: gamma_h !< The relative weighting for the baroclinic radiation - !! velocities (or speed of characteristics) at the - !! new time level (1) or the running mean (0) for thicknesses. - !! Valid values range from 0 to 1, with a default of 0.2. real :: rx_max !< The maximum magnitude of the baroclinic radiation - !! velocity (or speed of characteristics), in m s-1. The + !! velocity (or speed of characteristics) [m s-1]. The !! default value is 10 m s-1. logical :: OBC_pe !< Is there an open boundary on this tile? type(remapping_CS), pointer :: remap_CS !< ALE remapping control structure for segments only type(OBC_registry_type), pointer :: OBC_Reg => NULL() !< Registry type for boundaries real, pointer, dimension(:,:,:) :: rx_normal => NULL() !< Array storage for restarts real, pointer, dimension(:,:,:) :: ry_normal => NULL() !< Array storage for restarts + real, pointer, dimension(:,:,:) :: cff_normal => NULL() !< Array storage for restarts real :: silly_h !< A silly value of thickness outside of the domain that !! can be used to test the independence of the OBCs to - !! this external data, in m. + !! this external data [H ~> m or kg m-2]. real :: silly_u !< A silly value of velocity outside of the domain that !! can be used to test the independence of the OBCs to - !! this external data, in m/s. + !! this external data [m s-1]. end type ocean_OBC_type !> Control structure for open boundaries that read from files. @@ -245,9 +276,9 @@ module MOM_open_boundary !! When locked=.true.,no more boundaries can be registered. end type OBC_registry_type -integer :: id_clock_pass +integer :: id_clock_pass !< A CPU time clock -character(len=40) :: mdl = "MOM_open_boundary" ! This module's name. +character(len=40) :: mdl = "MOM_open_boundary" !< This module's name. ! This include declares and sets the variable "version". #include "version_variable.h" @@ -260,13 +291,14 @@ module MOM_open_boundary !> here. The remainder of the segment data are initialized in a !> later call to update_open_boundary_data -subroutine open_boundary_config(G, param_file, OBC) +subroutine open_boundary_config(G, US, param_file, OBC) type(dyn_horgrid_type), intent(inout) :: G !< Ocean grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< Parameter file handle type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure ! Local variables integer :: l ! For looping over segments - logical :: debug_OBC, debug, mask_outside + logical :: debug_OBC, debug, mask_outside, reentrant_x, reentrant_y character(len=15) :: segment_param_str ! The run-time parameter name for each segment character(len=100) :: segment_str ! The contents (rhs) for parameter "segment_param_str" character(len=200) :: config1 ! String for OBC_USER_CONFIG @@ -287,7 +319,7 @@ subroutine open_boundary_config(G, param_file, OBC) call get_param(param_file, mdl, "NK", OBC%ke, & "The number of model layers", default=0, do_not_log=.true.) - if (config1 .ne. "none") OBC%user_BCs_set_globally = .true. + if (config1 /= "none") OBC%user_BCs_set_globally = .true. if (OBC%number_of_segments > 0) then call get_param(param_file, mdl, "OBC_ZERO_VORTICITY", OBC%zero_vorticity, & @@ -296,20 +328,48 @@ subroutine open_boundary_config(G, param_file, OBC) 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"// & - "be true if OBC_ZERO_VORTICITY is True.", default=.false.) - if (OBC%zero_vorticity .and. OBC%freeslip_vorticity) call MOM_error(FATAL, & - "MOM_open_boundary.F90, open_boundary_config: "//& - "Only one of OBC_ZERO_VORTICITY and OBC_FREESLIP_VORTICITY can be True at once.") + "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"// & + "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"// & + "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. & + (OBC%zero_vorticity .and. OBC%specified_vorticity) .or. & + (OBC%freeslip_vorticity .and. OBC%computed_vorticity) .or. & + (OBC%freeslip_vorticity .and. OBC%specified_vorticity) .or. & + (OBC%computed_vorticity .and. OBC%specified_vorticity)) & + call MOM_error(FATAL, "MOM_open_boundary.F90, open_boundary_config:\n"//& + "Only one of OBC_ZERO_VORTICITY, OBC_FREESLIP_VORTICITY, OBC_COMPUTED_VORTICITY\n"//& + "and OBC_IMPORTED_VORTICITY can be True at once.") call get_param(param_file, mdl, "OBC_ZERO_STRAIN", OBC%zero_strain, & "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"// & - "be true if OBC_ZERO_STRAIN is True.", default=.false.) - if (OBC%zero_strain .and. OBC%freeslip_strain) call MOM_error(FATAL, & - "MOM_open_boundary.F90, open_boundary_config: "//& - "Only one of OBC_ZERO_STRAIN and OBC_FREESLIP_STRAIN can be True at once.") + "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"// & + "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"// & + "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. & + (OBC%zero_strain .and. OBC%specified_strain) .or. & + (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"//& + "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"//& "viscosity term.", default=.false.) @@ -333,6 +393,10 @@ subroutine open_boundary_config(G, param_file, OBC) "A silly value of velocities used outside of open boundary \n"//& "conditions for debugging.", units="m/s", default=0.0, & do_not_log=.not.debug_OBC, debuggingParam=.true.) + reentrant_x = .false. + call get_param(param_file, mdl, "REENTRANT_X", reentrant_x, default=.true.) + reentrant_y = .false. + call get_param(param_file, mdl, "REENTRANT_Y", reentrant_y, default=.false.) ! Allocate everything ! Note the 0-segment is needed when %segnum_u/v(:,:) = 0 @@ -340,9 +404,16 @@ subroutine open_boundary_config(G, param_file, OBC) do l=0,OBC%number_of_segments OBC%segment(l)%Flather = .false. OBC%segment(l)%radiation = .false. + OBC%segment(l)%radiation_tan = .false. + OBC%segment(l)%radiation_grad = .false. OBC%segment(l)%oblique = .false. + OBC%segment(l)%oblique_tan = .false. + OBC%segment(l)%oblique_grad = .false. OBC%segment(l)%nudged = .false. + OBC%segment(l)%nudged_tan = .false. + OBC%segment(l)%nudged_grad = .false. OBC%segment(l)%specified = .false. + OBC%segment(l)%specified_tan = .false. OBC%segment(l)%open = .false. OBC%segment(l)%gradient = .false. OBC%segment(l)%values_needed = .false. @@ -363,9 +434,9 @@ subroutine open_boundary_config(G, param_file, OBC) fail_if_missing=.true.) segment_str = remove_spaces(segment_str) if (segment_str(1:2) == 'I=') then - call setup_u_point_obc(OBC, G, segment_str, l, param_file) + call setup_u_point_obc(OBC, G, segment_str, l, param_file, reentrant_y) elseif (segment_str(1:2) == 'J=') then - call setup_v_point_obc(OBC, G, segment_str, l, param_file) + call setup_v_point_obc(OBC, G, segment_str, l, param_file, reentrant_x) else call MOM_error(FATAL, "MOM_open_boundary.F90, open_boundary_config: "//& "Unable to interpret "//segment_param_str//" = "//trim(segment_str)) @@ -375,7 +446,7 @@ subroutine open_boundary_config(G, param_file, OBC) ! if (open_boundary_query(OBC, needs_ext_seg_data=.true.)) & call initialize_segment_data(G, OBC, param_file) - if ( OBC%Flather_u_BCs_exist_globally .or. OBC%Flather_v_BCs_exist_globally ) then + 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"//& @@ -388,13 +459,11 @@ subroutine open_boundary_config(G, param_file, OBC) "Valid values range from 0 to 1. This is only used if \n"//& "one of the open boundary segments is using Orlanski.", & units="nondim", default=0.3) - call get_param(param_file, mdl, "OBC_RAD_THICK_WT", OBC%gamma_h, & - "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 thicknesses. \n"//& - "Valid values range from 0 to 1. This is only used if \n"//& - "one of the open boundary segments is using Orlanski.", & - units="nondim", default=0.2) + endif + + Lscale_in = 0. + 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"//& @@ -404,20 +473,21 @@ subroutine open_boundary_config(G, param_file, OBC) "An effective length scale for restoring the tracer concentration \n"//& "at the boundaries to values from the interior when the flow \n"//& "is entering the domain.", units="m", default=0.0) - endif - if (mask_outside) call mask_outside_OBCs(G, param_file, OBC) - endif - ! All tracers are using the same restoring length scale for now, but we may want to make this - ! tracer-specific in the future for example, in cases where certain tracers are poorly constrained - ! by data while others are well constrained - MJH. - do l = 1, OBC%number_of_segments - OBC%segment(l)%Tr_InvLscale3_in=0.0 - if (Lscale_in>0.) OBC%segment(l)%Tr_InvLscale3_in = 1.0/(Lscale_in*Lscale_in*Lscale_in) - OBC%segment(l)%Tr_InvLscale3_out=0.0 - if (Lscale_out>0.) OBC%segment(l)%Tr_InvLscale3_out = 1.0/(Lscale_out*Lscale_out*Lscale_out) - enddo + if (mask_outside) call mask_outside_OBCs(G, US, param_file, OBC) + + ! All tracers are using the same restoring length scale for now, but we may want to make this + ! tracer-specific in the future for example, in cases where certain tracers are poorly constrained + ! by data while others are well constrained - MJH. + do l = 1, OBC%number_of_segments + OBC%segment(l)%Tr_InvLscale3_in=0.0 + if (Lscale_in>0.) OBC%segment(l)%Tr_InvLscale3_in = 1.0/(Lscale_in*Lscale_in*Lscale_in) + OBC%segment(l)%Tr_InvLscale3_out=0.0 + if (Lscale_out>0.) OBC%segment(l)%Tr_InvLscale3_out = 1.0/(Lscale_out*Lscale_out*Lscale_out) + enddo + + endif ! OBC%number_of_segments > 0 ! Safety check if ((OBC%open_u_BCs_exist_globally .or. OBC%open_v_BCs_exist_globally) .and. & @@ -436,12 +506,14 @@ subroutine open_boundary_config(G, param_file, OBC) end subroutine open_boundary_config +!> Allocate space for reading OBC data from files. It sets up the required vertical +!! remapping. In the process, it does funky stuff with the MPI processes. subroutine initialize_segment_data(G, OBC, PF) use mpp_mod, only : mpp_pe, mpp_set_current_pelist, mpp_get_current_pelist,mpp_npes - type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure - type(ocean_OBC_type), intent(inout) :: OBC !< Open boundary control structure - type(param_file_type), intent(in) :: PF !< Parameter file handle + type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure + type(ocean_OBC_type), intent(inout) :: OBC !< Open boundary control structure + type(param_file_type), intent(in) :: PF !< Parameter file handle integer :: n,m,num_fields character(len=256) :: segstr, filename @@ -451,7 +523,7 @@ subroutine initialize_segment_data(G, OBC, PF) integer :: orient character(len=32), dimension(MAX_OBC_FIELDS) :: fields ! segment field names character(len=128) :: inputdir - type(OBC_segment_type), pointer :: segment ! pointer to segment type list + type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list character(len=32) :: remappingScheme logical :: check_reconstruction, check_remapping, force_bounds_in_subcell integer, dimension(4) :: siz,siz2 @@ -501,6 +573,13 @@ subroutine initialize_segment_data(G, OBC, PF) if (OBC%user_BCs_set_globally) return + ! Try this here just for the documentation. It is repeated below. + do n=1, OBC%number_of_segments + segment => OBC%segment(n) + write(segnam,"('OBC_SEGMENT_',i3.3,'_DATA')") n + call get_param(PF, mdl, segnam, segstr, 'OBC segment docs') + enddo + !< temporarily disable communication in order to read segment data independently allocate(saved_pelist(0:mpp_npes()-1)) @@ -521,7 +600,8 @@ subroutine initialize_segment_data(G, OBC, PF) call parse_segment_data_str(trim(segstr), fields=fields, num_fields=num_fields) if (num_fields == 0) then - print *,'num_fields = 0';cycle ! cycle to next segment + call MOM_mesg('initialize_segment_data: num_fields = 0') + cycle ! cycle to next segment endif allocate(segment%field(num_fields)) @@ -583,13 +663,13 @@ subroutine initialize_segment_data(G, OBC, PF) siz2(3)=siz(3) if (segment%is_E_or_W) then - if (segment%field(m)%name == 'V') then + if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX') then allocate(segment%field(m)%buffer_src(IsdB:IedB,JsdB:JedB,siz2(3))) else allocate(segment%field(m)%buffer_src(IsdB:IedB,jsd:jed,siz2(3))) endif else - if (segment%field(m)%name == 'U') then + if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY') then allocate(segment%field(m)%buffer_src(IsdB:IedB,JsdB:JedB,siz2(3))) else allocate(segment%field(m)%buffer_src(isd:ied,JsdB:JedB,siz2(3))) @@ -602,13 +682,13 @@ subroutine initialize_segment_data(G, OBC, PF) fieldname = 'dz_'//trim(fieldname) call field_size(filename,fieldname,siz,no_domain=.true.) if (segment%is_E_or_W) then - if (segment%field(m)%name == 'V') then + if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX') then allocate(segment%field(m)%dz_src(IsdB:IedB,JsdB:JedB,siz(3))) else allocate(segment%field(m)%dz_src(IsdB:IedB,jsd:jed,siz(3))) endif else - if (segment%field(m)%name == 'U') then + if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY') then allocate(segment%field(m)%dz_src(IsdB:IedB,JsdB:JedB,siz(3))) else allocate(segment%field(m)%dz_src(isd:ied,JsdB:JedB,siz(3))) @@ -694,20 +774,21 @@ subroutine setup_segment_indices(G, seg, Is_obc, Ie_obc, Js_obc, Je_obc) end subroutine setup_segment_indices !> Parse an OBC_SEGMENT_%%% string starting with "I=" and configure placement and type of OBC accordingly -subroutine setup_u_point_obc(OBC, G, segment_str, l_seg, PF) +subroutine setup_u_point_obc(OBC, G, segment_str, l_seg, PF, reentrant_y) type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure character(len=*), intent(in) :: segment_str !< A string in form of "I=%,J=%:%,string" integer, intent(in) :: l_seg !< which segment is this? - type(param_file_type), intent(in) :: PF + type(param_file_type), intent(in) :: PF !< Parameter file handle + logical, intent(in) :: reentrant_y !< is the domain reentrant in y? ! Local variables integer :: I_obc, Js_obc, Je_obc ! Position of segment in global index space integer :: j, a_loop - character(len=32) :: action_str(5) + character(len=32) :: action_str(8) character(len=128) :: segment_param_str real, allocatable, dimension(:) :: tnudge ! This returns the global indices for the segment - call parse_segment_str(G%ieg, G%jeg, segment_str, I_obc, Js_obc, Je_obc, action_str ) + call parse_segment_str(G%ieg, G%jeg, segment_str, I_obc, Js_obc, Je_obc, action_str, reentrant_y) call setup_segment_indices(G, OBC%segment(l_seg),I_obc,I_obc,Js_obc,Je_obc) @@ -717,14 +798,14 @@ subroutine setup_u_point_obc(OBC, G, segment_str, l_seg, PF) if (Je_obc>Js_obc) then OBC%segment(l_seg)%direction = OBC_DIRECTION_E - else if (Je_obc Parse an OBC_SEGMENT_%%% string starting with "J=" and configure placement and type of OBC accordingly -subroutine setup_v_point_obc(OBC, G, segment_str, l_seg, PF) +subroutine setup_v_point_obc(OBC, G, segment_str, l_seg, PF, reentrant_x) type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure character(len=*), intent(in) :: segment_str !< A string in form of "J=%,I=%:%,string" integer, intent(in) :: l_seg !< which segment is this? - type(param_file_type), intent(in) :: PF + type(param_file_type), intent(in) :: PF !< Parameter file handle + logical, intent(in) :: reentrant_x !< is the domain reentrant in x? ! Local variables integer :: J_obc, Is_obc, Ie_obc ! Position of segment in global index space integer :: i, a_loop - character(len=32) :: action_str(5) + character(len=32) :: action_str(8) character(len=128) :: segment_param_str real, allocatable, dimension(:) :: tnudge ! This returns the global indices for the segment - call parse_segment_str(G%ieg, G%jeg, segment_str, J_obc, Is_obc, Ie_obc, action_str ) + call parse_segment_str(G%ieg, G%jeg, segment_str, J_obc, Is_obc, Ie_obc, action_str, reentrant_x) call setup_segment_indices(G, OBC%segment(l_seg),Is_obc,Ie_obc,J_obc,J_obc) @@ -819,14 +922,14 @@ subroutine setup_v_point_obc(OBC, G, segment_str, l_seg, PF) if (Ie_obc>Is_obc) then OBC%segment(l_seg)%direction = OBC_DIRECTION_S - else if (Ie_obc Parse an OBC_SEGMENT_%%% string -subroutine parse_segment_str(ni_global, nj_global, segment_str, l, m, n, action_str ) +subroutine parse_segment_str(ni_global, nj_global, segment_str, l, m, n, action_str, reentrant) integer, intent(in) :: ni_global !< Number of h-points in zonal direction integer, intent(in) :: nj_global !< Number of h-points in meridional direction character(len=*), intent(in) :: segment_str !< A string in form of "I=l,J=m:n,string" or "J=l,I=m,n,string" @@ -904,11 +1029,14 @@ subroutine parse_segment_str(ni_global, nj_global, segment_str, l, m, n, action_ integer, intent(out) :: m !< The value of J=m, if segment_str begins with I=, or the value of I=m integer, intent(out) :: n !< The value of J=n, if segment_str begins with I=, or the value of I=n character(len=*), intent(out) :: action_str(:) !< The "string" part of segment_str + logical, intent(in) :: reentrant !< is domain reentrant in relevant direction? ! Local variables - character(len=24) :: word1, word2, m_word, n_word !< Words delineated by commas in a string in form of "I=%,J=%:%,string" + character(len=24) :: word1, word2, m_word, n_word !< Words delineated by commas in a string in form of + !! "I=%,J=%:%,string" integer :: l_max !< Either ni_global or nj_global, depending on whether segment_str begins with "I=" or "J=" integer :: mn_max !< Either nj_global or ni_global, depending on whether segment_str begins with "I=" or "J=" integer :: j + integer, parameter :: halo = 10 ! Process first word which will started with either 'I=' or 'J=' word1 = extract_word(segment_str,',',1) @@ -938,17 +1066,31 @@ subroutine parse_segment_str(ni_global, nj_global, segment_str, l, m, n, action_ ! Read m m_word = extract_word(word2(3:24),':',1) m = interpret_int_expr( m_word, mn_max ) - if (m<-1 .or. m>mn_max+1) then - call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str: "//& - "Beginning of range in string '"//trim(segment_str)//"' is outside of the physical domain.") + if (reentrant) then + if (m<-halo .or. m>mn_max+halo) then + call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str: "//& + "Beginning of range in string '"//trim(segment_str)//"' is outside of the physical domain.") + endif + else + if (m<-1 .or. m>mn_max+1) then + call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str: "//& + "Beginning of range in string '"//trim(segment_str)//"' is outside of the physical domain.") + endif endif - ! Read m + ! Read n n_word = extract_word(word2(3:24),':',2) n = interpret_int_expr( n_word, mn_max ) - if (n<-1 .or. n>mn_max+1) then - call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str: "//& - "End of range in string '"//trim(segment_str)//"' is outside of the physical domain.") + if (reentrant) then + if (n<-halo .or. n>mn_max+halo) then + call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str: "//& + "End of range in string '"//trim(segment_str)//"' is outside of the physical domain.") + endif + else + if (n<-1 .or. n>mn_max+1) then + call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str: "//& + "End of range in string '"//trim(segment_str)//"' is outside of the physical domain.") + endif endif if (abs(n-m)==0) then @@ -963,7 +1105,7 @@ subroutine parse_segment_str(ni_global, nj_global, segment_str, l, m, n, action_ contains - ! Returns integer value interpreted from string in form of %I, N or N-%I + ! Returns integer value interpreted from string in form of %I, N or N+-%I integer function interpret_int_expr(string, imax) character(len=*), intent(in) :: string !< Integer in form or %I, N or N-%I integer, intent(in) :: imax !< Value to replace 'N' with @@ -976,8 +1118,13 @@ integer function interpret_int_expr(string, imax) if (len_trim(string)==1 .and. string(1:1)=='N') then interpret_int_expr = imax elseif (string(1:1)=='N') then - read(string(2:slen),*,err=911) interpret_int_expr - interpret_int_expr = imax - interpret_int_expr + if (string(2:2)=='+') then + read(string(3:slen),*,err=911) interpret_int_expr + interpret_int_expr = imax + interpret_int_expr + elseif (string(2:2)=='-') then + read(string(3:slen),*,err=911) interpret_int_expr + interpret_int_expr = imax - interpret_int_expr + endif else read(string(1:slen),*,err=911) interpret_int_expr endif @@ -989,14 +1136,17 @@ end subroutine parse_segment_str !> Parse an OBC_SEGMENT_%%%_DATA string subroutine parse_segment_data_str(segment_str, var, value, filenam, fieldnam, fields, num_fields, debug ) - character(len=*), intent(in) :: segment_str !< A string in form of "VAR1=file:foo1.nc(varnam1),VAR2=file:foo2.nc(varnam2),..." - character(len=*), intent(in), optional :: var !< The name of the variable for which parameters are needed - character(len=*), intent(out), optional :: filenam !< The name of the input file if using "file" method - character(len=*), intent(out), optional :: fieldnam !< The name of the variable in the input file if using "file" method - real, intent(out), optional :: value !< A constant value if using the "value" method - character(len=*), dimension(MAX_OBC_FIELDS), intent(out), optional :: fields !< List of fieldnames for each segment - integer, intent(out), optional :: num_fields - logical, intent(in), optional :: debug + character(len=*), intent(in) :: segment_str !< A string in form of + !! "VAR1=file:foo1.nc(varnam1),VAR2=file:foo2.nc(varnam2),..." + character(len=*), optional, intent(in) :: var !< The name of the variable for which parameters are needed + character(len=*), optional, intent(out) :: filenam !< The name of the input file if using "file" method + character(len=*), optional, intent(out) :: fieldnam !< The name of the variable in the input file if using + !! "file" method + real, optional, intent(out) :: value !< A constant value if using the "value" method + character(len=*), dimension(MAX_OBC_FIELDS), & + optional, intent(out) :: fields !< List of fieldnames for each segment + integer, optional, intent(out) :: num_fields !< The number of fields in the segment data + logical, optional, intent(in) :: debug !< If present and true, write verbose debugging messages ! Local variables character(len=128) :: word1, word2, word3, method integer :: lword, nfields, n, m, orient @@ -1074,10 +1224,11 @@ end subroutine parse_segment_data_str !> Parse an OBC_SEGMENT_%%%_PARAMS string subroutine parse_segment_param_real(segment_str, var, param_value, debug ) - character(len=*), intent(in) :: segment_str !< A string in form of "VAR1=file:foo1.nc(varnam1),VAR2=file:foo2.nc(varnam2),..." - character(len=*), intent(in) :: var !< The name of the variable for which parameters are needed - real, intent(out) :: param_value !< The value of the parameter - logical, intent(in), optional :: debug + character(len=*), intent(in) :: segment_str !< A string in form of + !! "VAR1=file:foo1.nc(varnam1),VAR2=file:foo2.nc(varnam2),..." + character(len=*), intent(in) :: var !< The name of the variable for which parameters are needed + real, intent(out) :: param_value !< The value of the parameter + logical, optional, intent(in) :: debug !< If present and true, write verbose debugging messages ! Local variables character(len=128) :: word1, word2, word3, method integer :: lword, nfields, n, m, orient @@ -1120,7 +1271,6 @@ subroutine parse_segment_param_real(segment_str, var, param_value, debug ) call abort() endif - print *,'00001x' ! Process first word which will start with the fieldname word3 = extract_word(segment_str,',',m) ! word1 = extract_word(word3,':',1) @@ -1130,7 +1280,6 @@ subroutine parse_segment_param_real(segment_str, var, param_value, debug ) method=trim(extract_word(word1,'=',2)) lword=len_trim(method) read(method(1:lword),*,err=987) param_value - print *,'00002x' ! if (method(lword-3:lword) == 'file') then ! ! raise an error id filename/fieldname not in argument list ! word1 = extract_word(word3,':',2) @@ -1168,13 +1317,14 @@ subroutine open_boundary_init(G, param_file, OBC) end subroutine open_boundary_init -logical function open_boundary_query(OBC, apply_open_OBC, apply_specified_OBC, apply_Flather_OBC, apply_nudged_OBC, needs_ext_seg_data) - type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure - logical, optional, intent(in) :: apply_open_OBC !< If present, returns True if specified_*_BCs_exist_globally is true - logical, optional, intent(in) :: apply_specified_OBC !< If present, returns True if specified_*_BCs_exist_globally is true - logical, optional, intent(in) :: apply_Flather_OBC !< If present, returns True if Flather_*_BCs_exist_globally is true - logical, optional, intent(in) :: apply_nudged_OBC !< If present, returns True if nudged_*_BCs_exist_globally is true - logical, optional, intent(in) :: needs_ext_seg_data !< If present, returns True if external segment data needed +logical function open_boundary_query(OBC, apply_open_OBC, apply_specified_OBC, apply_Flather_OBC, & + apply_nudged_OBC, needs_ext_seg_data) + type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure + logical, optional, intent(in) :: apply_open_OBC !< Returns True if open_*_BCs_exist_globally is true + logical, optional, intent(in) :: apply_specified_OBC !< Returns True if specified_*_BCs_exist_globally is true + logical, optional, intent(in) :: apply_Flather_OBC !< Returns True if Flather_*_BCs_exist_globally is true + logical, optional, intent(in) :: apply_nudged_OBC !< Returns True if nudged_*_BCs_exist_globally is true + logical, optional, intent(in) :: needs_ext_seg_data !< Returns True if external segment data needed open_boundary_query = .false. if (.not. associated(OBC)) return if (present(apply_open_OBC)) open_boundary_query = OBC%open_u_BCs_exist_globally .or. & @@ -1192,7 +1342,7 @@ end function open_boundary_query !> Deallocate open boundary data subroutine open_boundary_dealloc(OBC) type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure - type(OBC_segment_type), pointer :: segment + type(OBC_segment_type), pointer :: segment => NULL() integer :: n if (.not. associated(OBC)) return @@ -1220,7 +1370,7 @@ subroutine open_boundary_impose_normal_slope(OBC, G, depth) real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: depth !< Bathymetry at h-points ! Local variables integer :: i, j, n - type(OBC_segment_type), pointer :: segment + type(OBC_segment_type), pointer :: segment => NULL() if (.not.associated(OBC)) return @@ -1257,15 +1407,16 @@ subroutine open_boundary_impose_normal_slope(OBC, G, depth) end subroutine open_boundary_impose_normal_slope !> Reconcile masks and open boundaries, deallocate OBC on PEs where it is not needed. -!! Also adjust u- and v-point cell area on specified open boundaries. +!! Also adjust u- and v-point cell area on specified open boundaries and mask all +!! points outside open boundaries. subroutine open_boundary_impose_land_mask(OBC, G, areaCu, areaCv) type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure type(dyn_horgrid_type), intent(inout) :: G !< Ocean grid structure - real, dimension(SZIB_(G),SZJ_(G)), intent(inout) :: areaCu !< Area of a u-cell (m2) - real, dimension(SZI_(G),SZJB_(G)), intent(inout) :: areaCv !< Area of a u-cell (m2) + real, dimension(SZIB_(G),SZJ_(G)), intent(inout) :: areaCu !< Area of a u-cell [m2] + real, dimension(SZI_(G),SZJB_(G)), intent(inout) :: areaCv !< Area of a u-cell [m2] ! Local variables integer :: i, j, n - type(OBC_segment_type), pointer :: segment + type(OBC_segment_type), pointer :: segment => NULL() logical :: any_U, any_V if (.not.associated(OBC)) return @@ -1275,6 +1426,7 @@ subroutine open_boundary_impose_land_mask(OBC, G, areaCu, areaCv) if (.not. segment%on_pe) cycle if (segment%is_E_or_W) then ! Sweep along u-segments and delete the OBC for blocked points. + ! Also, mask all points outside. I=segment%HI%IsdB do j=segment%HI%jsd,segment%HI%jed if (G%mask2dCu(I,j) == 0) OBC%segnum_u(I,j) = OBC_NONE @@ -1379,14 +1531,20 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v_old !< Original unadjusted v real, intent(in) :: dt !< Appropriate timestep ! Local variables - real :: dhdt, dhdx, dhdy, gamma_u, gamma_h, gamma_v, gamma_2 + real :: dhdt, dhdx, dhdy, gamma_u, gamma_v, gamma_2 real :: cff, Cx, Cy, tau real :: rx_max, ry_max ! coefficients for radiation real :: rx_new, rx_avg ! coefficients for radiation real :: ry_new, ry_avg ! coefficients for radiation + real :: cff_new, cff_avg ! denominator in oblique + real, pointer, dimension(:,:,:) :: rx_tangential=>NULL() + real, pointer, dimension(:,:,:) :: ry_tangential=>NULL() + real, pointer, dimension(:,:,:) :: cff_tangential=>NULL() real, parameter :: eps = 1.0e-20 - type(OBC_segment_type), pointer :: segment + type(OBC_segment_type), pointer :: segment => NULL() integer :: i, j, k, is, ie, js, je, nz, n + integer :: is_obc, ie_obc, js_obc, je_obc + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke if (.not.associated(OBC)) return @@ -1411,13 +1569,32 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) do k=1,G%ke J=segment%HI%JsdB do i=segment%HI%isd,segment%HI%ied - segment%rx_normal(i,J,k) = OBC%ry_normal(i,J,k) + segment%ry_normal(i,J,k) = OBC%ry_normal(i,J,k) + enddo + enddo + endif + if (segment%is_E_or_W .and. segment%oblique) then + do k=1,G%ke + I=segment%HI%IsdB + do j=segment%HI%jsd,segment%HI%jed + segment%rx_normal(I,j,k) = OBC%rx_normal(I,j,k) + segment%ry_normal(I,j,k) = OBC%ry_normal(I,j,k) + segment%cff_normal(I,j,k) = OBC%cff_normal(I,j,k) + enddo + enddo + elseif (segment%is_N_or_S .and. segment%oblique) then + do k=1,G%ke + J=segment%HI%JsdB + do i=segment%HI%isd,segment%HI%ied + segment%rx_normal(i,J,k) = OBC%rx_normal(i,J,k) + segment%ry_normal(i,J,k) = OBC%ry_normal(i,J,k) + segment%cff_normal(i,J,k) = OBC%cff_normal(i,J,k) enddo enddo endif enddo - gamma_u = OBC%gamma_uv ; gamma_v = OBC%gamma_uv ; gamma_h = OBC%gamma_h + gamma_u = OBC%gamma_uv ; gamma_v = OBC%gamma_uv rx_max = OBC%rx_max ; ry_max = OBC%rx_max do n=1,OBC%number_of_segments segment=>OBC%segment(n) @@ -1444,39 +1621,185 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) elseif (segment%oblique) then dhdt = u_old(I-1,j,k)-u_new(I-1,j,k) !old-new dhdx = u_new(I-1,j,k)-u_new(I-2,j,k) !in new time backward sasha for I-1 - if (dhdt*(segment%grad_normal(J,1,k) + segment%grad_normal(J-1,1,k)) > 0.0) then - dhdy = segment%grad_normal(J-1,1,k) - elseif (dhdt*(segment%grad_normal(J,1,k) + segment%grad_normal(J-1,1,k)) == 0.0) then - dhdy = 0.0 - else - dhdy = segment%grad_normal(J,1,k) - endif + if (dhdt*(segment%grad_normal(J,1,k) + segment%grad_normal(J-1,1,k)) > 0.0) then + dhdy = segment%grad_normal(J-1,1,k) + elseif (dhdt*(segment%grad_normal(J,1,k) + segment%grad_normal(J-1,1,k)) == 0.0) then + dhdy = 0.0 + else + dhdy = segment%grad_normal(J,1,k) + endif if (dhdt*dhdx < 0.0) dhdt = 0.0 - Cx = min(dhdt*dhdx,rx_max) ! default to normal radiation - cff = max(dhdx*dhdx + dhdy*dhdy, eps) - Cy = min(cff,max(dhdt*dhdy,-cff)) - segment%normal_vel(I,j,k) = ((cff*u_new(I,j,k) + Cx*u_new(I-1,j,k)) - & - (max(Cy,0.0)*segment%grad_normal(J-1,2,k) + min(Cy,0.0)*segment%grad_normal(J,2,k))) / (cff + Cx) + rx_new = dhdt*dhdx + cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + ry_new = min(cff,max(dhdt*dhdy,-cff)) + rx_avg = (1.0-gamma_u)*segment%rx_normal(I,j,k) + gamma_u*rx_new + ry_avg = (1.0-gamma_u)*segment%ry_normal(i,J,k) + gamma_u*ry_new + cff_avg = (1.0-gamma_u)*segment%cff_normal(i,J,k) + gamma_u*cff_new + segment%rx_normal(I,j,k) = rx_avg + segment%ry_normal(i,J,k) = ry_avg + segment%cff_normal(i,J,k) = cff_avg + segment%normal_vel(I,j,k) = ((cff_avg*u_new(I,j,k) + rx_avg*u_new(I-1,j,k)) - & + (max(ry_avg,0.0)*segment%grad_normal(J-1,2,k) + min(ry_avg,0.0)*segment%grad_normal(J,2,k))) / & + (cff_avg + rx_avg) + ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues + ! implemented as a work-around to limitations in restart capability + OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) + OBC%ry_normal(i,J,k) = segment%ry_normal(i,J,k) + OBC%cff_normal(I,j,k) = segment%cff_normal(I,j,k) elseif (segment%gradient) then segment%normal_vel(I,j,k) = u_new(I-1,j,k) endif if ((segment%radiation .or. segment%oblique) .and. segment%nudged) then - if (dhdt*dhdx < 0.0) then + ! dhdt gets set to 0 on inflow in oblique case + if (dhdt*dhdx <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%normal_vel(I,j,k) = (1 - gamma_2) * u_new(I,j,k) + & + segment%normal_vel(I,j,k) = (1 - gamma_2) * segment%normal_vel(I,j,k) + & gamma_2 * segment%nudged_normal_vel(I,j,k) endif - enddo; enddo + enddo ; enddo + if (segment%radiation_tan .or. segment%radiation_grad) then + I=segment%HI%IsdB + allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + do k=1,nz + rx_tangential(I,segment%HI%JsdB,k) = segment%rx_normal(I,segment%HI%jsd,k) + rx_tangential(I,segment%HI%JedB,k) = segment%rx_normal(I,segment%HI%jed,k) + do J=segment%HI%JsdB+1,segment%HI%JedB-1 + rx_tangential(I,J,k) = 0.5*(segment%rx_normal(I,j,k) + segment%rx_normal(I,j+1,k)) + enddo + enddo + if (segment%radiation_tan) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + rx_avg = rx_tangential(I,J,k) + segment%tangential_vel(I,J,k) = (v_new(I,J,k) + rx_avg*v_new(I-1,J,k)) / (1.0+rx_avg) + enddo ; enddo + endif + if (segment%nudged_tan) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + ! dhdt gets set to 0 on inflow in oblique case + if (rx_tangential(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_vel(I,J,k) = (1 - gamma_2) * segment%tangential_vel(I,J,k) + & + gamma_2 * segment%nudged_tangential_vel(I,J,k) + enddo ; enddo + endif + if (segment%radiation_grad) then + Js_obc = max(segment%HI%JsdB,G%jsd+1) + Je_obc = min(segment%HI%JedB,G%jed-1) + do k=1,nz ; do J=Js_obc,Je_obc + rx_avg = rx_tangential(I,J,k) +! if (G%mask2dCu(I-1,j) > 0.0 .and. G%mask2dCu(I-1,j+1) > 0.0) then +! rx_avg = 0.5*(u_new(I-1,j,k) + u_new(I-1,j+1,k))*dt*G%IdxBu(I-1,J) +! elseif (G%mask2dCu(I-1,j) > 0.0) then +! rx_avg = u_new(I-1,j,k)*dt*G%IdxBu(I-1,J) +! elseif (G%mask2dCu(I-1,j+1) > 0.0) then +! rx_avg = u_new(I-1,j+1,k)*dt*G%IdxBu(I-1,J) +! else +! rx_avg = 0.0 +! endif + segment%tangential_grad(I,J,k) = ((v_new(i,J,k) - v_new(i-1,J,k))*G%IdxBu(I-1,J) + & + rx_avg*(v_new(i-1,J,k) - v_new(i-2,J,k))*G%IdxBu(I-2,J)) / (1.0+rx_avg) + enddo ; enddo + endif + if (segment%nudged_grad) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + ! dhdt gets set to 0 on inflow in oblique case + if (rx_tangential(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_grad(I,J,k) = (1 - gamma_2) * segment%tangential_grad(I,J,k) + & + gamma_2 * segment%nudged_tangential_grad(I,J,k) + enddo ; enddo + endif + deallocate(rx_tangential) + endif + if (segment%oblique_tan .or. segment%oblique_grad) then + I=segment%HI%IsdB + allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(ry_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + do k=1,nz + rx_tangential(I,segment%HI%JsdB,k) = segment%rx_normal(I,segment%HI%jsd,k) + rx_tangential(I,segment%HI%JedB,k) = segment%rx_normal(I,segment%HI%jed,k) + ry_tangential(I,segment%HI%JsdB,k) = segment%ry_normal(I,segment%HI%jsd,k) + ry_tangential(I,segment%HI%JedB,k) = segment%ry_normal(I,segment%HI%jed,k) + cff_tangential(I,segment%HI%JsdB,k) = segment%cff_normal(I,segment%HI%jsd,k) + cff_tangential(I,segment%HI%JedB,k) = segment%cff_normal(I,segment%HI%jed,k) + do J=segment%HI%JsdB+1,segment%HI%JedB-1 + rx_tangential(I,J,k) = 0.5*(segment%rx_normal(I,j,k) + segment%rx_normal(I,j+1,k)) + ry_tangential(I,J,k) = 0.5*(segment%ry_normal(I,j,k) + segment%ry_normal(I,j+1,k)) + cff_tangential(I,J,k) = 0.5*(segment%cff_normal(I,j,k) + segment%cff_normal(I,j+1,k)) + enddo + enddo + if (segment%oblique_tan) then + do k=1,nz ; do J=segment%HI%JsdB+1,segment%HI%JedB-1 + rx_avg = rx_tangential(I,J,k) + ry_avg = ry_tangential(I,J,k) + cff_avg = cff_tangential(I,J,k) + segment%tangential_vel(I,J,k) = ((cff_avg*v_new(i,J,k) + rx_avg*v_new(i-1,J,k)) - & + (max(ry_avg,0.0)*segment%grad_tan(j,2,k) + min(ry_avg,0.0)*segment%grad_tan(j+1,2,k))) / & + (cff_avg + rx_avg) + enddo ; enddo + endif + if (segment%nudged_tan) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + ! dhdt gets set to 0 on inflow in oblique case + if (rx_tangential(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_vel(I,J,k) = (1 - gamma_2) * segment%tangential_vel(I,J,k) + & + gamma_2 * segment%nudged_tangential_vel(I,J,k) + enddo ; enddo + endif + if (segment%oblique_grad) then + Js_obc = max(segment%HI%JsdB,G%jsd+1) + Je_obc = min(segment%HI%JedB,G%jed-1) + do k=1,nz ; do J=segment%HI%JsdB+1,segment%HI%JedB-1 + rx_avg = rx_tangential(I,J,k) + ry_avg = ry_tangential(I,J,k) + cff_avg = cff_tangential(I,J,k) + segment%tangential_grad(I,J,k) = ((cff_avg*(v_new(i,J,k) - v_new(i-1,J,k))*G%IdxBu(I-1,J) & + + rx_avg*(v_new(i-1,J,k) - v_new(i-2,J,k))*G%IdxBu(I-2,J)) - & + (max(ry_avg,0.0)*segment%grad_gradient(J,2,k) + min(ry_avg,0.0)*segment%grad_gradient(J+1,2,k))) / & + (cff_avg + rx_avg) + enddo ; enddo + endif + if (segment%nudged_grad) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + ! dhdt gets set to 0 on inflow in oblique case + if (rx_tangential(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_grad(I,J,k) = (1 - gamma_2) * segment%tangential_grad(I,J,k) + & + gamma_2 * segment%nudged_tangential_grad(I,J,k) + enddo ; enddo + endif + deallocate(rx_tangential) + deallocate(ry_tangential) + deallocate(cff_tangential) + endif endif if (segment%direction == OBC_DIRECTION_W) then I=segment%HI%IsdB if (I>G%HI%IecB) cycle - do k=1,nz ; do j=segment%HI%jsd,segment%HI%jed + do k=1,nz ; do j=segment%HI%jsd,segment%HI%jed if (segment%radiation) then dhdt = u_old(I+1,j,k)-u_new(I+1,j,k) !old-new dhdx = u_new(I+1,j,k)-u_new(I+2,j,k) !in new time forward sasha for I+1 @@ -1494,39 +1817,179 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) elseif (segment%oblique) then dhdt = u_old(I+1,j,k)-u_new(I+1,j,k) !old-new dhdx = u_new(I+1,j,k)-u_new(I+2,j,k) !in new time forward sasha for I+1 -! if (segment%oblique) then - if (dhdt*(segment%grad_normal(J,1,k) + segment%grad_normal(J-1,1,k)) > 0.0) then - dhdy = segment%grad_normal(J-1,1,k) - elseif (dhdt*(segment%grad_normal(J,1,k) + segment%grad_normal(J-1,1,k)) == 0.0) then - dhdy = 0.0 - else - dhdy = segment%grad_normal(J,1,k) - endif -! endif + if (dhdt*(segment%grad_normal(J,1,k) + segment%grad_normal(J-1,1,k)) > 0.0) then + dhdy = segment%grad_normal(J-1,1,k) + elseif (dhdt*(segment%grad_normal(J,1,k) + segment%grad_normal(J-1,1,k)) == 0.0) then + dhdy = 0.0 + else + dhdy = segment%grad_normal(J,1,k) + endif if (dhdt*dhdx < 0.0) dhdt = 0.0 - Cx = min(dhdt*dhdx,rx_max) ! default to normal flow only -! Cy = 0. - cff = max(dhdx*dhdx, eps) -! if (segment%oblique) then - cff = max(dhdx*dhdx + dhdy*dhdy, eps) - Cy = min(cff,max(dhdt*dhdy,-cff)) -! endif - segment%normal_vel(I,j,k) = ((cff*u_new(I,j,k) + Cx*u_new(I+1,j,k)) - & - (max(Cy,0.0)*segment%grad_normal(J-1,2,k) + min(Cy,0.0)*segment%grad_normal(J,2,k))) / (cff + Cx) + rx_new = dhdt*dhdx + cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + ry_new = min(cff,max(dhdt*dhdy,-cff)) + rx_avg = (1.0-gamma_u)*segment%rx_normal(I,j,k) + gamma_u*rx_new + ry_avg = (1.0-gamma_u)*segment%ry_normal(i,J,k) + gamma_u*ry_new + cff_avg = (1.0-gamma_u)*segment%cff_normal(I,j,k) + gamma_u*cff_new + segment%rx_normal(I,j,k) = rx_avg + segment%ry_normal(i,J,k) = ry_avg + segment%cff_normal(i,J,k) = cff_avg + segment%normal_vel(I,j,k) = ((cff_avg*u_new(I,j,k) + rx_avg*u_new(I+1,j,k)) - & + (max(ry_avg,0.0)*segment%grad_normal(J-1,2,k) + min(ry_avg,0.0)*segment%grad_normal(J,2,k))) / & + (cff_avg + rx_avg) + ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues + ! implemented as a work-around to limitations in restart capability + OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) + OBC%ry_normal(i,J,k) = segment%ry_normal(i,J,k) + OBC%cff_normal(I,j,k) = segment%cff_normal(I,j,k) elseif (segment%gradient) then segment%normal_vel(I,j,k) = u_new(I+1,j,k) endif if ((segment%radiation .or. segment%oblique) .and. segment%nudged) then - if (dhdt*dhdx < 0.0) then + ! dhdt gets set to 0. on inflow in oblique case + if (dhdt*dhdx <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%normal_vel(I,j,k) = (1 - gamma_2) * u_new(I,j,k) + & + segment%normal_vel(I,j,k) = (1 - gamma_2) * segment%normal_vel(I,j,k) + & gamma_2 * segment%nudged_normal_vel(I,j,k) endif - enddo; enddo + enddo ; enddo + if (segment%radiation_tan .or. segment%radiation_grad) then + I=segment%HI%IsdB + allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + do k=1,nz + rx_tangential(I,segment%HI%JsdB,k) = segment%rx_normal(I,segment%HI%jsd,k) + rx_tangential(I,segment%HI%JedB,k) = segment%rx_normal(I,segment%HI%jed,k) + do J=segment%HI%JsdB+1,segment%HI%JedB-1 + rx_tangential(I,J,k) = 0.5*(segment%rx_normal(I,j,k) + segment%rx_normal(I,j+1,k)) + enddo + enddo + if (segment%radiation_tan) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + rx_avg = rx_tangential(I,J,k) + segment%tangential_vel(I,J,k) = (v_new(i+1,J,k) + rx_avg*v_new(i+2,J,k)) / (1.0+rx_avg) + enddo ; enddo + endif + if (segment%nudged_tan) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + ! dhdt gets set to 0 on inflow in oblique case + if (rx_tangential(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_vel(I,J,k) = (1 - gamma_2) * segment%tangential_vel(I,J,k) + & + gamma_2 * segment%nudged_tangential_vel(I,J,k) + enddo ; enddo + endif + if (segment%radiation_grad) then + Js_obc = max(segment%HI%JsdB,G%jsd+1) + Je_obc = min(segment%HI%JedB,G%jed-1) + do k=1,nz ; do J=Js_obc,Je_obc + rx_avg = rx_tangential(I,J,k) +! if (G%mask2dCu(I+1,j) > 0.0 .and. G%mask2dCu(I+1,j+1) > 0.0) then +! rx_avg = 0.5*(u_new(I+1,j,k) + u_new(I+1,j+1,k))*dt*G%IdxBu(I+1,J) +! elseif (G%mask2dCu(I+1,j) > 0.0) then +! rx_avg = u_new(I+1,j,k)*dt*G%IdxBu(I+1,J) +! elseif (G%mask2dCu(I+1,j+1) > 0.0) then +! rx_avg = u_new(I+1,j+1,k)*dt*G%IdxBu(I+1,J) +! else +! rx_avg = 0.0 +! endif + segment%tangential_grad(I,J,k) = ((v_new(i+2,J,k) - v_new(i+1,J,k))*G%IdxBu(I+1,J) + & + rx_avg*(v_new(i+3,J,k) - v_new(i+2,J,k))*G%IdxBu(I+2,J)) / (1.0+rx_avg) + enddo ; enddo + endif + if (segment%nudged_grad) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + ! dhdt gets set to 0 on inflow in oblique case + if (rx_tangential(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_grad(I,J,k) = (1 - gamma_2) * segment%tangential_grad(I,J,k) + & + gamma_2 * segment%nudged_tangential_grad(I,J,k) + enddo ; enddo + endif + deallocate(rx_tangential) + endif + if (segment%oblique_tan .or. segment%oblique_grad) then + I=segment%HI%IsdB + allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(ry_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + do k=1,nz + rx_tangential(I,segment%HI%JsdB,k) = segment%rx_normal(I,segment%HI%jsd,k) + rx_tangential(I,segment%HI%JedB,k) = segment%rx_normal(I,segment%HI%jed,k) + ry_tangential(I,segment%HI%JsdB,k) = segment%ry_normal(I,segment%HI%jsd,k) + ry_tangential(I,segment%HI%JedB,k) = segment%ry_normal(I,segment%HI%jed,k) + cff_tangential(I,segment%HI%JsdB,k) = segment%cff_normal(I,segment%HI%jsd,k) + cff_tangential(I,segment%HI%JedB,k) = segment%cff_normal(I,segment%HI%jed,k) + do J=segment%HI%JsdB+1,segment%HI%JedB-1 + rx_tangential(I,J,k) = 0.5*(segment%rx_normal(I,j,k) + segment%rx_normal(I,j+1,k)) + ry_tangential(I,J,k) = 0.5*(segment%ry_normal(I,j,k) + segment%ry_normal(I,j+1,k)) + cff_tangential(I,J,k) = 0.5*(segment%cff_normal(I,j,k) + segment%cff_normal(I,j+1,k)) + enddo + enddo + if (segment%oblique_tan) then + do k=1,nz ; do J=segment%HI%JsdB+1,segment%HI%JedB-1 + rx_avg = rx_tangential(I,J,k) + ry_avg = ry_tangential(I,J,k) + cff_avg = cff_tangential(I,J,k) + segment%tangential_vel(I,J,k) = ((cff_avg*v_new(i+1,J,k) + rx_avg*v_new(i+2,J,k)) - & + (max(ry_avg,0.0)*segment%grad_tan(j,2,k) + min(ry_avg,0.0)*segment%grad_tan(j+1,2,k))) / & + (cff_avg + rx_avg) + enddo ; enddo + endif + if (segment%nudged_tan) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + ! dhdt gets set to 0 on inflow in oblique case + if (rx_tangential(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_vel(I,J,k) = (1 - gamma_2) * segment%tangential_vel(I,J,k) + & + gamma_2 * segment%nudged_tangential_vel(I,J,k) + enddo ; enddo + endif + if (segment%oblique_grad) then + Js_obc = max(segment%HI%JsdB,G%jsd+1) + Je_obc = min(segment%HI%JedB,G%jed-1) + do k=1,nz ; do J=segment%HI%JsdB+1,segment%HI%JedB-1 + rx_avg = rx_tangential(I,J,k) + ry_avg = ry_tangential(I,J,k) + cff_avg = cff_tangential(I,J,k) + segment%tangential_grad(I,J,k) = ((cff_avg*(v_new(i+2,J,k) - v_new(i+1,J,k))*G%IdxBu(I+1,J) & + + rx_avg*(v_new(i+3,J,k) - v_new(i+2,J,k))*G%IdxBu(I+2,J)) - & + (max(ry_avg,0.0)*segment%grad_gradient(J,2,k) + min(ry_avg,0.0)*segment%grad_gradient(J+1,2,k))) / & + (cff_avg + rx_avg) + enddo ; enddo + endif + if (segment%nudged_grad) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + ! dhdt gets set to 0 on inflow in oblique case + if (rx_tangential(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_grad(I,J,k) = (1 - gamma_2) * segment%tangential_grad(I,J,k) + & + gamma_2 * segment%nudged_tangential_grad(I,J,k) + enddo ; enddo + endif + deallocate(rx_tangential) + deallocate(ry_tangential) + deallocate(cff_tangential) + endif endif if (segment%direction == OBC_DIRECTION_N) then @@ -1538,54 +2001,194 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) dhdy = v_new(i,J-1,k)-v_new(i,J-2,k) !in new time backward sasha for J-1 ry_new = 0.0 if (dhdt*dhdy > 0.0) ry_new = min( (dhdt/dhdy), ry_max) - ry_avg = (1.0-gamma_v)*segment%rx_normal(I,j,k) + gamma_v*ry_new - segment%rx_normal(i,J,k) = ry_avg + ry_avg = (1.0-gamma_v)*segment%ry_normal(I,j,k) + gamma_v*ry_new + segment%ry_normal(i,J,k) = ry_avg ! The new boundary value is interpolated between future interior ! value, v_new(J-1) and past boundary value but with barotropic ! accelerations, v_new(J). segment%normal_vel(i,J,k) = (v_new(i,J,k) + ry_avg*v_new(i,J-1,k)) / (1.0+ry_avg) ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues ! implemented as a work-around to limitations in restart capability - OBC%ry_normal(i,J,k) = segment%rx_normal(i,J,k) + OBC%ry_normal(i,J,k) = segment%ry_normal(i,J,k) elseif (segment%oblique) then dhdt = v_old(i,J-1,k)-v_new(i,J-1,k) !old-new dhdy = v_new(i,J-1,k)-v_new(i,J-2,k) !in new time backward sasha for J-1 -! if (segment%oblique) then - if (dhdt*(segment%grad_normal(I,1,k) + segment%grad_normal(I-1,1,k)) > 0.0) then - dhdx = segment%grad_normal(I-1,1,k) - elseif (dhdt*(segment%grad_normal(I,1,k) + segment%grad_normal(I-1,1,k)) == 0.0) then - dhdx = 0.0 - else - dhdx = segment%grad_normal(I,1,k) - endif -! endif + segment%ry_normal(i,J,k) = ry_avg + if (dhdt*(segment%grad_normal(I,1,k) + segment%grad_normal(I-1,1,k)) > 0.0) then + dhdx = segment%grad_normal(I-1,1,k) + elseif (dhdt*(segment%grad_normal(I,1,k) + segment%grad_normal(I-1,1,k)) == 0.0) then + dhdx = 0.0 + else + dhdx = segment%grad_normal(I,1,k) + endif if (dhdt*dhdy < 0.0) dhdt = 0.0 - Cy = min(dhdt*dhdy,rx_max) ! default to normal flow only -! Cx = 0 - cff = max(dhdy*dhdy, eps) -! if (segment%oblique) then - cff = max(dhdx*dhdx + dhdy*dhdy, eps) - Cx = min(cff,max(dhdt*dhdx,-cff)) -! endif - segment%normal_vel(i,J,k) = ((cff*v_new(i,J,k) + Cy*v_new(i,J-1,k)) - & - (max(Cx,0.0)*segment%grad_normal(I-1,2,k) + min(Cx,0.0)*segment%grad_normal(I,2,k))) / (cff + Cy) + ry_new = dhdt*dhdy + cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + rx_new = min(cff,max(dhdt*dhdx,-cff)) + rx_avg = (1.0-gamma_u)*segment%rx_normal(I,j,k) + gamma_u*rx_new + ry_avg = (1.0-gamma_u)*segment%ry_normal(i,J,k) + gamma_u*ry_new + cff_avg = (1.0-gamma_u)*segment%cff_normal(i,J,k) + gamma_u*cff_new + segment%rx_normal(I,j,k) = rx_avg + segment%ry_normal(i,J,k) = ry_avg + segment%cff_normal(i,J,k) = cff_avg + segment%normal_vel(i,J,k) = ((cff_avg*v_new(i,J,k) + ry_avg*v_new(i,J-1,k)) - & + (max(rx_avg,0.0)*segment%grad_normal(I-1,2,k) + min(rx_avg,0.0)*segment%grad_normal(I,2,k))) / & + (cff_avg + ry_avg) + ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues + ! implemented as a work-around to limitations in restart capability + OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) + OBC%ry_normal(i,J,k) = segment%ry_normal(i,J,k) + OBC%cff_normal(i,J,k) = segment%cff_normal(i,J,k) elseif (segment%gradient) then segment%normal_vel(i,J,k) = v_new(i,J-1,k) endif if ((segment%radiation .or. segment%oblique) .and. segment%nudged) then - if (dhdt*dhdy < 0.0) then + ! dhdt gets set to 0 on inflow in oblique case + if (dhdt*dhdy <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%normal_vel(i,J,k) = (1 - gamma_2) * v_new(i,J,k) + & + segment%normal_vel(i,J,k) = (1 - gamma_2) * segment%normal_vel(i,J,k) + & gamma_2 * segment%nudged_normal_vel(i,J,k) endif - enddo; enddo + enddo ; enddo + if (segment%radiation_tan .or. segment%radiation_grad) then + J=segment%HI%JsdB + allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + do k=1,nz + rx_tangential(segment%HI%IsdB,J,k) = segment%ry_normal(segment%HI%isd,J,k) + rx_tangential(segment%HI%IedB,J,k) = segment%ry_normal(segment%HI%ied,J,k) + do I=segment%HI%IsdB+1,segment%HI%IedB-1 + rx_tangential(I,J,k) = 0.5*(segment%ry_normal(i,J,k) + segment%ry_normal(i+1,J,k)) + enddo + enddo + if (segment%radiation_tan) then + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + rx_avg = rx_tangential(I,J,k) + segment%tangential_vel(I,J,k) = (u_new(I,j,k) + rx_avg*u_new(I,j-1,k)) / (1.0+rx_avg) + enddo ; enddo + endif + if (segment%nudged_tan) then + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + ! dhdt gets set to 0 on inflow in oblique case + if (rx_tangential(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_vel(I,J,k) = (1 - gamma_2) * segment%tangential_vel(I,J,k) + & + gamma_2 * segment%nudged_tangential_vel(I,J,k) + enddo ; enddo + endif + if (segment%radiation_grad) then + Is_obc = max(segment%HI%IsdB,G%isd+1) + Ie_obc = min(segment%HI%IedB,G%ied-1) + do k=1,nz ; do I=Is_obc,Ie_obc + rx_avg = rx_tangential(I,J,k) +! if (G%mask2dCv(i,J-1) > 0.0 .and. G%mask2dCv(i+1,J-1) > 0.0) then +! rx_avg = 0.5*(v_new(i,J-1,k) + v_new(i+1,J-1,k)*dt*G%IdyBu(I,J-1)) +! elseif (G%mask2dCv(i,J-1) > 0.0) then +! rx_avg = v_new(i,J-1,k)*dt*G%IdyBu(I,J-1) +! elseif (G%mask2dCv(i+1,J-1) > 0.0) then +! rx_avg = v_new(i+1,J-1,k)*dt*G%IdyBu(I,J-1) +! else +! rx_avg = 0.0 +! endif + segment%tangential_grad(I,J,k) = ((u_new(I,j,k) - u_new(I,j-1,k))*G%IdyBu(I,J-1) + & + rx_avg*(u_new(I,j-1,k) - u_new(I,j-2,k))*G%IdyBu(I,J-2)) / (1.0+rx_avg) + enddo ; enddo + endif + if (segment%nudged_grad) then + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + ! dhdt gets set to 0 on inflow in oblique case + if (ry_tangential(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_grad(I,J,k) = (1 - gamma_2) * segment%tangential_grad(I,J,k) + & + gamma_2 * segment%nudged_tangential_grad(I,J,k) + enddo ; enddo + endif + deallocate(rx_tangential) + endif + if (segment%oblique_tan .or. segment%oblique_grad) then + J=segment%HI%JsdB + allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(ry_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + do k=1,nz + rx_tangential(segment%HI%IsdB,J,k) = segment%ry_normal(segment%HI%isd,J,k) + rx_tangential(segment%HI%IedB,J,k) = segment%ry_normal(segment%HI%ied,J,k) + ry_tangential(segment%HI%IsdB,J,k) = segment%rx_normal(segment%HI%isd,J,k) + ry_tangential(segment%HI%IedB,J,k) = segment%rx_normal(segment%HI%ied,J,k) + cff_tangential(segment%HI%IsdB,J,k) = segment%cff_normal(segment%HI%isd,J,k) + cff_tangential(segment%HI%IedB,J,k) = segment%cff_normal(segment%HI%ied,J,k) + do I=segment%HI%IsdB+1,segment%HI%IedB-1 + rx_tangential(I,J,k) = 0.5*(segment%ry_normal(i,J,k) + segment%ry_normal(i+1,J,k)) + ry_tangential(I,J,k) = 0.5*(segment%rx_normal(i,J,k) + segment%rx_normal(i+1,J,k)) + cff_tangential(I,J,k) = 0.5*(segment%cff_normal(i,J,k) + segment%cff_normal(i+1,J,k)) + enddo + enddo + if (segment%oblique_tan) then + do k=1,nz ; do I=segment%HI%IsdB+1,segment%HI%IedB-1 + rx_avg = rx_tangential(I,J,k) + ry_avg = ry_tangential(I,J,k) + cff_avg = cff_tangential(I,J,k) + segment%tangential_vel(I,J,k) = ((cff_avg*u_new(I,j,k) + rx_avg*u_new(I,j-1,k)) - & + (max(ry_avg,0.0)*segment%grad_tan(i,2,k) + min(ry_avg,0.0)*segment%grad_tan(i+1,2,k))) / & + (cff_avg + rx_avg) + enddo ; enddo + endif + if (segment%nudged_tan) then + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + ! dhdt gets set to 0 on inflow in oblique case + if (ry_tangential(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_vel(I,J,k) = (1 - gamma_2) * segment%tangential_vel(I,J,k) + & + gamma_2 * segment%nudged_tangential_vel(I,J,k) + enddo ; enddo + endif + if (segment%oblique_grad) then + Is_obc = max(segment%HI%IsdB,G%isd+1) + Ie_obc = min(segment%HI%IedB,G%ied-1) + do k=1,nz ; do I=segment%HI%IsdB+1,segment%HI%IedB-1 + rx_avg = rx_tangential(I,J,k) + ry_avg = ry_tangential(I,J,k) + cff_avg = cff_tangential(I,J,k) + segment%tangential_grad(I,J,k) = ((cff_avg*(u_new(I,j,k) - u_new(I,j-1,k))*G%IdyBu(I,J-1) & + + rx_avg*(u_new(I,j-1,k) - u_new(I,j-2,k))*G%IdyBu(I,J-2)) - & + (max(ry_avg,0.0)*segment%grad_gradient(I,2,k) + min(ry_avg,0.0)*segment%grad_gradient(I+1,2,k))) / & + (cff_avg + rx_avg) + enddo ; enddo + endif + if (segment%nudged_grad) then + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + ! dhdt gets set to 0 on inflow in oblique case + if (ry_tangential(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_grad(I,J,k) = (1 - gamma_2) * segment%tangential_grad(I,J,k) + & + gamma_2 * segment%nudged_tangential_grad(I,J,k) + enddo ; enddo + endif + deallocate(rx_tangential) + deallocate(ry_tangential) + deallocate(cff_tangential) + endif endif - if (segment%direction == OBC_DIRECTION_S) then J=segment%HI%JsdB if (J>G%HI%JecB) cycle @@ -1595,52 +2198,192 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) dhdy = v_new(i,J+1,k)-v_new(i,J+2,k) !in new time backward sasha for J-1 ry_new = 0.0 if (dhdt*dhdy > 0.0) ry_new = min( (dhdt/dhdy), ry_max) - ry_avg = (1.0-gamma_v)*segment%rx_normal(I,j,k) + gamma_v*ry_new - segment%rx_normal(i,J,k) = ry_avg + ry_avg = (1.0-gamma_v)*segment%ry_normal(I,j,k) + gamma_v*ry_new + segment%ry_normal(i,J,k) = ry_avg ! The new boundary value is interpolated between future interior ! value, v_new(J+1) and past boundary value but with barotropic ! accelerations, v_new(J). segment%normal_vel(i,J,k) = (v_new(i,J,k) + ry_avg*v_new(i,J+1,k)) / (1.0+ry_avg) ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues ! implemented as a work-around to limitations in restart capability - OBC%ry_normal(i,J,k) = segment%rx_normal(i,J,k) + OBC%ry_normal(i,J,k) = segment%ry_normal(i,J,k) elseif (segment%oblique) then dhdt = v_old(i,J+1,k)-v_new(i,J+1,k) !old-new dhdy = v_new(i,J+1,k)-v_new(i,J+2,k) !in new time backward sasha for J-1 -! if (segment%oblique) then - if (dhdt*(segment%grad_normal(I,1,k) + segment%grad_normal(I-1,1,k)) > 0.0) then - dhdx = segment%grad_normal(I-1,1,k) - elseif (dhdt*(segment%grad_normal(I,1,k) + segment%grad_normal(I-1,1,k)) == 0.0) then - dhdx = 0.0 - else - dhdx = segment%grad_normal(I,1,k) - endif -! endif + if (dhdt*(segment%grad_normal(I,1,k) + segment%grad_normal(I-1,1,k)) > 0.0) then + dhdx = segment%grad_normal(I-1,1,k) + elseif (dhdt*(segment%grad_normal(I,1,k) + segment%grad_normal(I-1,1,k)) == 0.0) then + dhdx = 0.0 + else + dhdx = segment%grad_normal(I,1,k) + endif if (dhdt*dhdy < 0.0) dhdt = 0.0 - Cy = min(dhdt*dhdy,rx_max) ! default to normal flow only -! Cx = 0 - cff = max(dhdy*dhdy, eps) -! if (segment%oblique) then - cff = max(dhdx*dhdx + dhdy*dhdy, eps) - Cx = min(cff,max(dhdt*dhdx,-cff)) -! endif - segment%normal_vel(i,J,k) = ((cff*v_new(i,J,k) + Cy*v_new(i,J+1,k)) - & - (max(Cx,0.0)*segment%grad_normal(I-1,2,k) + min(Cx,0.0)*segment%grad_normal(I,2,k))) / (cff + Cy) + ry_new = dhdt*dhdy + cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + rx_new = min(cff,max(dhdt*dhdx,-cff)) + rx_avg = (1.0-gamma_u)*segment%rx_normal(I,j,k) + gamma_u*rx_new + ry_avg = (1.0-gamma_u)*segment%ry_normal(i,J,k) + gamma_u*ry_new + cff_avg = (1.0-gamma_u)*segment%cff_normal(i,J,k) + gamma_u*cff_new + segment%rx_normal(I,j,k) = rx_avg + segment%ry_normal(i,J,k) = ry_avg + segment%cff_normal(i,J,k) = cff_avg + segment%normal_vel(i,J,k) = ((cff_avg*v_new(i,J,k) + ry_avg*v_new(i,J+1,k)) - & + (max(rx_avg,0.0)*segment%grad_normal(I-1,2,k) + min(rx_avg,0.0)*segment%grad_normal(I,2,k))) / & + (cff_avg + ry_avg) + ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues + ! implemented as a work-around to limitations in restart capability + OBC%rx_normal(I,j,k) = segment%rx_normal(I,j,k) + OBC%ry_normal(i,J,k) = segment%ry_normal(i,J,k) + OBC%cff_normal(i,J,k) = segment%cff_normal(i,J,k) elseif (segment%gradient) then segment%normal_vel(i,J,k) = v_new(i,J+1,k) endif if ((segment%radiation .or. segment%oblique) .and. segment%nudged) then - if (dhdt*dhdy < 0.0) then + ! dhdt gets set to 0 on inflow in oblique case + if (dhdt*dhdy <= 0.0) then tau = segment%Velocity_nudging_timescale_in else tau = segment%Velocity_nudging_timescale_out endif gamma_2 = dt / (tau + dt) - segment%normal_vel(i,J,k) = (1 - gamma_2) * v_new(i,J,k) + & + segment%normal_vel(i,J,k) = (1 - gamma_2) * segment%normal_vel(i,J,k) + & gamma_2 * segment%nudged_normal_vel(i,J,k) endif - enddo; enddo - end if + enddo ; enddo + if (segment%radiation_tan .or. segment%radiation_grad) then + J=segment%HI%JsdB + allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + do k=1,nz + rx_tangential(segment%HI%IsdB,J,k) = segment%ry_normal(segment%HI%isd,J,k) + rx_tangential(segment%HI%IedB,J,k) = segment%ry_normal(segment%HI%ied,J,k) + do I=segment%HI%IsdB+1,segment%HI%IedB-1 + rx_tangential(I,J,k) = 0.5*(segment%ry_normal(i,J,k) + segment%ry_normal(i+1,J,k)) + enddo + enddo + if (segment%radiation_tan) then + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + rx_avg = rx_tangential(I,J,k) + segment%tangential_vel(I,J,k) = (u_new(I,j+1,k) + rx_avg*u_new(I,j+2,k)) / (1.0+rx_avg) + enddo ; enddo + endif + if (segment%nudged_tan) then + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + ! dhdt gets set to 0 on inflow in oblique case + if (rx_tangential(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_vel(I,J,k) = (1 - gamma_2) * segment%tangential_vel(I,J,k) + & + gamma_2 * segment%nudged_tangential_vel(I,J,k) + enddo ; enddo + endif + if (segment%radiation_grad) then + Is_obc = max(segment%HI%IsdB,G%isd+1) + Ie_obc = min(segment%HI%IedB,G%ied-1) + do k=1,nz ; do I=Is_obc,Ie_obc + rx_avg = rx_tangential(I,J,k) +! if (G%mask2dCv(i,J+1) > 0.0 .and. G%mask2dCv(i+1,J+1) > 0.0) then +! rx_avg = 0.5*(v_new(i,J+1,k) + v_new(i+1,J+1,k))*dt*G%IdyBu(I,J+1) +! elseif (G%mask2dCv(i,J+1) > 0.0) then +! rx_avg = v_new(i,J+1,k)*dt*G%IdyBu(I,J+1) +! elseif (G%mask2dCv(i+1,J+1) > 0.0) then +! rx_avg = v_new(i+1,J+1,k)*dt*G%IdyBu(I,J+1) +! else +! rx_avg = 0.0 +! endif + segment%tangential_grad(I,J,k) = ((u_new(I,j+2,k) - u_new(I,j+1,k))*G%IdyBu(I,J+1) + & + rx_avg*(u_new(I,j+3,k) - u_new(I,j+2,k))*G%IdyBu(I,J+2)) / (1.0+rx_avg) + enddo ; enddo + endif + if (segment%nudged_grad) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + ! dhdt gets set to 0 on inflow in oblique case + if (ry_tangential(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_grad(I,J,k) = (1 - gamma_2) * segment%tangential_grad(I,J,k) + & + gamma_2 * segment%nudged_tangential_grad(I,J,k) + enddo ; enddo + endif + deallocate(rx_tangential) + endif + if (segment%oblique_tan .or. segment%oblique_grad) then + J=segment%HI%JsdB + allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(ry_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + allocate(cff_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + do k=1,nz + rx_tangential(segment%HI%IsdB,J,k) = segment%ry_normal(segment%HI%isd,J,k) + rx_tangential(segment%HI%IedB,J,k) = segment%ry_normal(segment%HI%ied,J,k) + ry_tangential(segment%HI%IsdB,J,k) = segment%rx_normal(segment%HI%isd,J,k) + ry_tangential(segment%HI%IedB,J,k) = segment%rx_normal(segment%HI%ied,J,k) + cff_tangential(segment%HI%IsdB,J,k) = segment%cff_normal(segment%HI%isd,J,k) + cff_tangential(segment%HI%IedB,J,k) = segment%cff_normal(segment%HI%ied,J,k) + do I=segment%HI%IsdB+1,segment%HI%IedB-1 + rx_tangential(I,J,k) = 0.5*(segment%ry_normal(i,J,k) + segment%ry_normal(i+1,J,k)) + ry_tangential(I,J,k) = 0.5*(segment%rx_normal(i,J,k) + segment%rx_normal(i+1,J,k)) + cff_tangential(I,J,k) = 0.5*(segment%cff_normal(i,J,k) + segment%cff_normal(i+1,J,k)) + enddo + enddo + if (segment%oblique_tan) then + do k=1,nz ; do I=segment%HI%IsdB+1,segment%HI%IedB-1 + rx_avg = rx_tangential(I,J,k) + ry_avg = ry_tangential(I,J,k) + cff_avg = cff_tangential(I,J,k) + segment%tangential_vel(I,J,k) = ((cff_avg*u_new(I,j+1,k) + rx_avg*u_new(I,j+2,k)) - & + (max(ry_avg,0.0)*segment%grad_tan(i,2,k) + min(ry_avg,0.0)*segment%grad_tan(i+1,2,k))) / & + (cff_avg + rx_avg) + enddo ; enddo + endif + if (segment%nudged_tan) then + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + ! dhdt gets set to 0 on inflow in oblique case + if (ry_tangential(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_vel(I,J,k) = (1 - gamma_2) * segment%tangential_vel(I,J,k) + & + gamma_2 * segment%nudged_tangential_vel(I,J,k) + enddo ; enddo + endif + if (segment%oblique_grad) then + Is_obc = max(segment%HI%IsdB,G%isd+1) + Ie_obc = min(segment%HI%IedB,G%ied-1) + do k=1,nz ; do I=segment%HI%IsdB+1,segment%HI%IedB-1 + rx_avg = rx_tangential(I,J,k) + ry_avg = ry_tangential(I,J,k) + cff_avg = cff_tangential(I,J,k) + segment%tangential_grad(I,J,k) = ((cff_avg*(u_new(I,j+2,k) - u_new(I,j+1,k))*G%IdyBu(I,J+1) & + + rx_avg*(u_new(I,j+3,k) - u_new(I,j+2,k))*G%IdyBu(I,J+2)) - & + (max(ry_avg,0.0)*segment%grad_gradient(i,2,k) + min(ry_avg,0.0)*segment%grad_gradient(i+1,2,k))) / & + (cff_avg + rx_avg) + enddo ; enddo + endif + if (segment%nudged_grad) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + ! dhdt gets set to 0 on inflow in oblique case + if (ry_tangential(I,J,k) <= 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_grad(I,J,k) = (1 - gamma_2) * segment%tangential_grad(I,J,k) + & + gamma_2 * segment%nudged_tangential_grad(I,J,k) + enddo ; enddo + endif + deallocate(rx_tangential) + deallocate(ry_tangential) + deallocate(cff_tangential) + endif + endif enddo ! Actually update u_new, v_new @@ -1659,7 +2402,7 @@ subroutine open_boundary_apply_normal_flow(OBC, G, u, v) real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: v !< v field to update on open boundaries ! Local variables integer :: i, j, k, n - type(OBC_segment_type), pointer :: segment + type(OBC_segment_type), pointer :: segment => NULL() if (.not.associated(OBC)) return ! Bail out if OBC is not available @@ -1672,12 +2415,12 @@ subroutine open_boundary_apply_normal_flow(OBC, G, u, v) I=segment%HI%IsdB do k=1,G%ke ; do j=segment%HI%jsd,segment%HI%jed u(I,j,k) = segment%normal_vel(I,j,k) - enddo; enddo + enddo ; enddo elseif (segment%is_N_or_S) then J=segment%HI%JsdB do k=1,G%ke ; do i=segment%HI%isd,segment%HI%ied v(i,J,k) = segment%normal_vel(i,J,k) - enddo; enddo + enddo ; enddo endif endif enddo @@ -1693,7 +2436,7 @@ subroutine open_boundary_zero_normal_flow(OBC, G, u, v) real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: v !< v field to update on open boundaries ! Local variables integer :: i, j, k, n - type(OBC_segment_type), pointer :: segment + type(OBC_segment_type), pointer :: segment => NULL() if (.not.associated(OBC)) return ! Bail out if OBC is not available @@ -1705,19 +2448,19 @@ subroutine open_boundary_zero_normal_flow(OBC, G, u, v) I=segment%HI%IsdB do k=1,G%ke ; do j=segment%HI%jsd,segment%HI%jed u(I,j,k) = 0. - enddo; enddo + enddo ; enddo elseif (segment%is_N_or_S) then J=segment%HI%JsdB do k=1,G%ke ; do i=segment%HI%isd,segment%HI%ied v(i,J,k) = 0. - enddo; enddo + enddo ; enddo endif enddo end subroutine open_boundary_zero_normal_flow !> Calculate the tangential gradient of the normal flow at the boundary q-points. -subroutine gradient_at_q_points(G,segment,uvel,vvel) +subroutine gradient_at_q_points(G, segment, uvel, vvel) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(OBC_segment_type), pointer :: segment !< OBC segment structure real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: uvel !< zonal velocity @@ -1735,6 +2478,24 @@ subroutine gradient_at_q_points(G,segment,uvel,vvel) segment%grad_normal(J,2,k) = (uvel(I,j+1,k)-uvel(I,j,k)) * G%mask2dBu(I,J) enddo enddo + if (segment%oblique_tan) then + do k=1,G%ke + do J=max(segment%HI%jsd, G%HI%jsd+1),min(segment%HI%jed, G%HI%jed-1) + segment%grad_tan(j,1,k) = (vvel(i-1,J,k)-vvel(i-1,J-1,k)) * G%mask2dT(i-1,j) + segment%grad_tan(j,2,k) = (vvel(i,J,k)-vvel(i,J-1,k)) * G%mask2dT(i,j) + enddo + enddo + endif + if (segment%oblique_grad) then + do k=1,G%ke + do J=max(segment%HI%jsd, G%HI%jsd+1),min(segment%HI%jed, G%HI%jed-1) + segment%grad_gradient(j,1,k) = (((vvel(i-1,J,k) - vvel(i-2,J,k))*G%IdxBu(I-2,J)) - & + (vvel(i-1,J-1,k) - vvel(i-2,J-1,k))*G%IdxBu(I-2,J-1)) * G%mask2dCu(I-1,j) + segment%grad_gradient(j,2,k) = (((vvel(i,J,k) - vvel(i-1,J,k))*G%IdxBu(I-1,J)) - & + (vvel(i,J-1,k) - vvel(i-1,J-1,k))*G%IdxBu(I-1,J-1)) * G%mask2dCu(I,j) + enddo + enddo + endif else ! western segment I=segment%HI%isdB do k=1,G%ke @@ -1743,8 +2504,26 @@ subroutine gradient_at_q_points(G,segment,uvel,vvel) segment%grad_normal(J,2,k) = (uvel(I,j+1,k)-uvel(I,j,k)) * G%mask2dBu(I,J) enddo enddo + if (segment%oblique_tan) then + do k=1,G%ke + do J=max(segment%HI%jsd, G%HI%jsd+1),min(segment%HI%jed, G%HI%jed-1) + segment%grad_tan(j,1,k) = (vvel(i+2,J,k)-vvel(i+2,J-1,k)) * G%mask2dT(i+2,j) + segment%grad_tan(j,2,k) = (vvel(i+1,J,k)-vvel(i+1,J-1,k)) * G%mask2dT(i+1,j) + enddo + enddo + endif + if (segment%oblique_grad) then + do k=1,G%ke + do J=max(segment%HI%jsd, G%HI%jsd+1),min(segment%HI%jed, G%HI%jed-1) + segment%grad_gradient(j,1,k) = (((vvel(i+3,J,k) - vvel(i+2,J,k))*G%IdxBu(I+2,J)) - & + (vvel(i+3,J-1,k) - vvel(i+2,J-1,k))*G%IdxBu(I+2,J-1)) * G%mask2dCu(I+2,j) + segment%grad_gradient(j,2,k) = (((vvel(i+2,J,k) - vvel(i+1,J,k))*G%IdxBu(I+1,J)) - & + (vvel(i+2,J-1,k) - vvel(i+1,J-1,k))*G%IdxBu(I+1,J-1)) * G%mask2dCu(I+1,j) + enddo + enddo + endif endif - else if (segment%is_N_or_S) then + elseif (segment%is_N_or_S) then if (segment%direction == OBC_DIRECTION_N) then J=segment%HI%jsdB do k=1,G%ke @@ -1753,6 +2532,24 @@ subroutine gradient_at_q_points(G,segment,uvel,vvel) segment%grad_normal(I,2,k) = (vvel(i+1,J,k)-vvel(i,J,k)) * G%mask2dBu(I,J) enddo enddo + if (segment%oblique_tan) then + do k=1,G%ke + do I=max(segment%HI%isd, G%HI%isd+1),min(segment%HI%ied, G%HI%ied-1) + segment%grad_tan(i,1,k) = (uvel(I,j-1,k)-uvel(I-1,j-1,k)) * G%mask2dT(i,j-1) + segment%grad_tan(i,2,k) = (uvel(I,j,k)-uvel(I-1,j,k)) * G%mask2dT(i,j) + enddo + enddo + endif + if (segment%oblique_grad) then + do k=1,G%ke + do I=max(segment%HI%isd, G%HI%isd+1),min(segment%HI%ied, G%HI%ied-1) + segment%grad_gradient(i,1,k) = (((uvel(I,j-1,k) - uvel(I,j-2,k))*G%IdxBu(I,J-2)) - & + (uvel(I-1,j-1,k) - uvel(I-1,j-2,k))*G%IdxBu(I-1,J-2)) * G%mask2dCv(I,j-1) + segment%grad_gradient(i,2,k) = (((uvel(I,j,k) - uvel(I,j-1,k))*G%IdyBu(I,J-1)) - & + (uvel(I-1,j,k) - uvel(I-1,j-1,k))*G%IdyBu(I-1,J-1)) * G%mask2dCv(i,J) + enddo + enddo + endif else ! south segment J=segment%HI%jsdB do k=1,G%ke @@ -1761,6 +2558,24 @@ subroutine gradient_at_q_points(G,segment,uvel,vvel) segment%grad_normal(I,2,k) = (vvel(i+1,J,k)-vvel(i,J,k)) * G%mask2dBu(I,J) enddo enddo + if (segment%oblique_tan) then + do k=1,G%ke + do I=max(segment%HI%isd, G%HI%isd+1),min(segment%HI%ied, G%HI%ied-1) + segment%grad_tan(i,1,k) = (uvel(I,j+2,k)-uvel(I-1,j+2,k)) * G%mask2dT(i,j+2) + segment%grad_tan(i,2,k) = (uvel(I,j+1,k)-uvel(I-1,j+1,k)) * G%mask2dT(i,j+1) + enddo + enddo + endif + if (segment%oblique_grad) then + do k=1,G%ke + do I=max(segment%HI%isd, G%HI%isd+1),min(segment%HI%ied, G%HI%ied-1) + segment%grad_gradient(i,1,k) = (((uvel(I,j+3,k) - uvel(I,j+2,k))*G%IdxBu(I,J+2)) - & + (uvel(I-1,j+3,k) - uvel(I-1,j+2,k))*G%IdyBu(I-1,J+2)) * G%mask2dCv(i,J+2) + segment%grad_gradient(i,2,k) = (((uvel(I,j+2,k) - uvel(I,j+1,k))*G%IdxBu(I,J+1)) - & + (uvel(I-1,j+2,k) - uvel(I-1,j+1,k))*G%IdyBu(I-1,J+1)) * G%mask2dCv(i,J+1) + enddo + enddo + endif endif endif @@ -1780,7 +2595,7 @@ subroutine set_tracer_data(OBC, tv, h, G, PF, tracer_Reg) integer :: i, j, k, itt, is, ie, js, je, isd, ied, jsd, jed, nz, n integer :: isd_off, jsd_off integer :: IsdB, IedB, JsdB, JedB - type(OBC_segment_type), pointer :: segment ! pointer to segment type list + type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list character(len=40) :: mdl = "set_tracer_data" ! This subroutine's name. character(len=200) :: filename, OBC_file, inputdir ! Strings for file/path @@ -1808,22 +2623,22 @@ subroutine set_tracer_data(OBC, tv, h, G, PF, tracer_Reg) I=segment%HI%IsdB do k=1,G%ke ; do j=segment%HI%jsd,segment%HI%jed tv%T(i+1,j,k) = tv%T(i,j,k) ; tv%S(i+1,j,k) = tv%S(i,j,k) - enddo; enddo + enddo ; enddo elseif (segment%direction == OBC_DIRECTION_W) then I=segment%HI%IsdB do k=1,G%ke ; do j=segment%HI%jsd,segment%HI%jed tv%T(i,j,k) = tv%T(i+1,j,k) ; tv%S(i,j,k) = tv%S(i+1,j,k) - enddo; enddo + enddo ; enddo elseif (segment%direction == OBC_DIRECTION_N) then J=segment%HI%JsdB do k=1,G%ke ; do i=segment%HI%isd,segment%HI%ied tv%T(i,j+1,k) = tv%T(i,j,k) ; tv%S(i,j+1,k) = tv%S(i,j,k) - enddo; enddo + enddo ; enddo elseif (segment%direction == OBC_DIRECTION_S) then J=segment%HI%JsdB do k=1,G%ke ; do i=segment%HI%isd,segment%HI%ied tv%T(i,j,k) = tv%T(i,j+1,k) ; tv%S(i,j,k) = tv%S(i,j+1,k) - enddo; enddo + enddo ; enddo endif enddo endif @@ -1836,22 +2651,22 @@ subroutine set_tracer_data(OBC, tv, h, G, PF, tracer_Reg) ! I=segment%HI%IsdB ! do k=1,G%ke ; do j=segment%HI%jsd,segment%HI%jed ! h(i+1,j,k) = h(i,j,k) -! enddo; enddo +! enddo ; enddo ! elseif (segment%direction == OBC_DIRECTION_W) then ! I=segment%HI%IsdB ! do k=1,G%ke ; do j=segment%HI%jsd,segment%HI%jed ! h(i,j,k) = h(i+1,j,k) -! enddo; enddo +! enddo ; enddo ! elseif (segment%direction == OBC_DIRECTION_N) then ! J=segment%HI%JsdB ! do k=1,G%ke ; do i=segment%HI%isd,segment%HI%ied ! h(i,j+1,k) = h(i,j,k) -! enddo; enddo +! enddo ; enddo ! elseif (segment%direction == OBC_DIRECTION_S) then ! J=segment%HI%JsdB ! do k=1,G%ke ; do i=segment%HI%isd,segment%HI%ied ! h(i,j,k) = h(i,j+1,k) -! enddo; enddo +! enddo ; enddo ! endif ! enddo @@ -1901,19 +2716,40 @@ subroutine allocate_OBC_segment_data(OBC, segment) allocate(segment%Htot(IsdB:IedB,jsd:jed)); segment%Htot(:,:)=0.0 allocate(segment%h(IsdB:IedB,jsd:jed,OBC%ke)); segment%h(:,:,:)=0.0 allocate(segment%eta(IsdB:IedB,jsd:jed)); segment%eta(:,:)=0.0 - allocate(segment%normal_trans_bt(IsdB:IedB,jsd:jed)); segment%normal_trans_bt(:,:)=0.0 if (segment%radiation) then - allocate(segment%rx_normal(IsdB:IedB,jsd:jed,OBC%ke)); segment%rx_normal(:,:,:)=0.0 + allocate(segment%rx_normal(IsdB:IedB,jsd:jed,OBC%ke)); segment%rx_normal(:,:,:)=0.0 endif allocate(segment%normal_vel(IsdB:IedB,jsd:jed,OBC%ke)); segment%normal_vel(:,:,:)=0.0 allocate(segment%normal_vel_bt(IsdB:IedB,jsd:jed)); segment%normal_vel_bt(:,:)=0.0 allocate(segment%normal_trans(IsdB:IedB,jsd:jed,OBC%ke)); segment%normal_trans(:,:,:)=0.0 if (segment%nudged) then allocate(segment%nudged_normal_vel(IsdB:IedB,jsd:jed,OBC%ke)); segment%nudged_normal_vel(:,:,:)=0.0 + endif + if (segment%radiation_tan .or. segment%nudged_tan .or. segment%specified_tan .or. & + OBC%computed_vorticity .or. OBC%computed_strain) then + allocate(segment%tangential_vel(IsdB:IedB,JsdB:JedB,OBC%ke)); segment%tangential_vel(:,:,:)=0.0 + endif + if (segment%nudged_tan) then allocate(segment%nudged_tangential_vel(IsdB:IedB,JsdB:JedB,OBC%ke)); segment%nudged_tangential_vel(:,:,:)=0.0 endif + if (segment%nudged_grad) then + allocate(segment%nudged_tangential_grad(IsdB:IedB,JsdB:JedB,OBC%ke)); segment%nudged_tangential_grad(:,:,:)=0.0 + endif + if (OBC%specified_vorticity .or. OBC%specified_strain .or. segment%radiation_grad .or. & + segment%oblique_grad) then + allocate(segment%tangential_grad(IsdB:IedB,JsdB:JedB,OBC%ke)); segment%tangential_grad(:,:,:)=0.0 + endif if (segment%oblique) then - allocate(segment%grad_normal(JsdB:JedB,2,OBC%ke)); segment%grad_normal(:,:,:) = 0.0 + allocate(segment%grad_normal(JsdB:JedB,2,OBC%ke)); segment%grad_normal(:,:,:) = 0.0 + allocate(segment%rx_normal(IsdB:IedB,jsd:jed,OBC%ke)); segment%rx_normal(:,:,:)=0.0 + allocate(segment%ry_normal(IsdB:IedB,jsd:jed,OBC%ke)); segment%ry_normal(:,:,:)=0.0 + allocate(segment%cff_normal(IsdB:IedB,jsd:jed,OBC%ke)); segment%cff_normal(:,:,:)=0.0 + endif + if (segment%oblique_tan) then + allocate(segment%grad_tan(jsd:jed,2,OBC%ke)); segment%grad_tan(:,:,:) = 0.0 + endif + if (segment%oblique_grad) then + allocate(segment%grad_gradient(jsd:jed,2,OBC%ke)); segment%grad_gradient(:,:,:) = 0.0 endif endif @@ -1923,19 +2759,40 @@ subroutine allocate_OBC_segment_data(OBC, segment) allocate(segment%Htot(isd:ied,JsdB:JedB)); segment%Htot(:,:)=0.0 allocate(segment%h(isd:ied,JsdB:JedB,OBC%ke)); segment%h(:,:,:)=0.0 allocate(segment%eta(isd:ied,JsdB:JedB)); segment%eta(:,:)=0.0 - allocate(segment%normal_trans_bt(isd:ied,JsdB:JedB)); segment%normal_trans_bt(:,:)=0.0 if (segment%radiation) then - allocate(segment%rx_normal(isd:ied,JsdB:JedB,OBC%ke)); segment%rx_normal(:,:,:)=0.0 + allocate(segment%ry_normal(isd:ied,JsdB:JedB,OBC%ke)); segment%ry_normal(:,:,:)=0.0 endif allocate(segment%normal_vel(isd:ied,JsdB:JedB,OBC%ke)); segment%normal_vel(:,:,:)=0.0 allocate(segment%normal_vel_bt(isd:ied,JsdB:JedB)); segment%normal_vel_bt(:,:)=0.0 allocate(segment%normal_trans(isd:ied,JsdB:JedB,OBC%ke)); segment%normal_trans(:,:,:)=0.0 if (segment%nudged) then allocate(segment%nudged_normal_vel(isd:ied,JsdB:JedB,OBC%ke)); segment%nudged_normal_vel(:,:,:)=0.0 + endif + if (segment%radiation_tan .or. segment%nudged_tan .or. segment%specified_tan .or. & + OBC%computed_vorticity .or. OBC%computed_strain) then + allocate(segment%tangential_vel(IsdB:IedB,JsdB:JedB,OBC%ke)); segment%tangential_vel(:,:,:)=0.0 + endif + if (segment%nudged_tan) then allocate(segment%nudged_tangential_vel(IsdB:IedB,JsdB:JedB,OBC%ke)); segment%nudged_tangential_vel(:,:,:)=0.0 endif + if (segment%nudged_grad) then + allocate(segment%nudged_tangential_grad(IsdB:IedB,JsdB:JedB,OBC%ke)); segment%nudged_tangential_grad(:,:,:)=0.0 + endif + if (OBC%specified_vorticity .or. OBC%specified_strain .or. segment%radiation_grad .or. & + segment%oblique_grad) then + allocate(segment%tangential_grad(IsdB:IedB,JsdB:JedB,OBC%ke)); segment%tangential_grad(:,:,:)=0.0 + endif if (segment%oblique) then - allocate(segment%grad_normal(IsdB:IedB,2,OBC%ke)); segment%grad_normal(:,:,:) = 0.0 + allocate(segment%grad_normal(IsdB:IedB,2,OBC%ke)); segment%grad_normal(:,:,:) = 0.0 + allocate(segment%rx_normal(isd:ied,JsdB:JedB,OBC%ke)); segment%rx_normal(:,:,:)=0.0 + allocate(segment%ry_normal(isd:ied,JsdB:JedB,OBC%ke)); segment%ry_normal(:,:,:)=0.0 + allocate(segment%cff_normal(isd:ied,JsdB:JedB,OBC%ke)); segment%cff_normal(:,:,:)=0.0 + endif + if (segment%oblique_tan) then + allocate(segment%grad_tan(isd:ied,2,OBC%ke)); segment%grad_tan(:,:,:) = 0.0 + endif + if (segment%oblique_grad) then + allocate(segment%grad_gradient(isd:ied,2,OBC%ke)); segment%grad_gradient(:,:,:) = 0.0 endif endif @@ -1954,13 +2811,20 @@ subroutine deallocate_OBC_segment_data(OBC, segment) if (associated (segment%Htot)) deallocate(segment%Htot) if (associated (segment%h)) deallocate(segment%h) if (associated (segment%eta)) deallocate(segment%eta) - if (associated (segment%normal_trans_bt)) deallocate(segment%normal_trans_bt) if (associated (segment%rx_normal)) deallocate(segment%rx_normal) + if (associated (segment%ry_normal)) deallocate(segment%ry_normal) + if (associated (segment%cff_normal)) deallocate(segment%cff_normal) + if (associated (segment%grad_normal)) deallocate(segment%grad_normal) + if (associated (segment%grad_tan)) deallocate(segment%grad_tan) + if (associated (segment%grad_gradient)) deallocate(segment%grad_gradient) if (associated (segment%normal_vel)) deallocate(segment%normal_vel) if (associated (segment%normal_vel_bt)) deallocate(segment%normal_vel_bt) if (associated (segment%normal_trans)) deallocate(segment%normal_trans) if (associated (segment%nudged_normal_vel)) deallocate(segment%nudged_normal_vel) + if (associated (segment%tangential_vel)) deallocate(segment%tangential_vel) if (associated (segment%nudged_tangential_vel)) deallocate(segment%nudged_tangential_vel) + if (associated (segment%nudged_tangential_grad)) deallocate(segment%nudged_tangential_grad) + if (associated (segment%tangential_grad)) deallocate(segment%tangential_grad) if (associated (segment%tr_Reg)) call segment_tracer_registry_end(segment%tr_Reg) @@ -1972,8 +2836,8 @@ end subroutine deallocate_OBC_segment_data subroutine open_boundary_test_extern_uv(G, OBC, u, v) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(ocean_OBC_type), pointer :: OBC !< Open boundary structure - real, dimension(SZIB_(G),SZJ_(G), SZK_(G)),intent(inout) :: u !< Zonal velocity (m/s) - real, dimension(SZI_(G),SZJB_(G), SZK_(G)),intent(inout) :: v !< Meridional velocity (m/s) + real, dimension(SZIB_(G),SZJ_(G), SZK_(G)),intent(inout) :: u !< Zonal velocity [m s-1] + real, dimension(SZI_(G),SZJB_(G), SZK_(G)),intent(inout) :: v !< Meridional velocity [m s-1] ! Local variables integer :: i, j, k, n @@ -2015,7 +2879,7 @@ end subroutine open_boundary_test_extern_uv subroutine open_boundary_test_extern_h(G, OBC, h) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(ocean_OBC_type), pointer :: OBC !< Open boundary structure - real, dimension(SZI_(G),SZJ_(G), SZK_(G)),intent(inout) :: h !< Layer thickness (m or kg/m2) + real, dimension(SZI_(G),SZJ_(G), SZK_(G)),intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] ! Local variables integer :: i, j, k, n @@ -2057,19 +2921,16 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(ocean_OBC_type), pointer :: OBC !< Open boundary structure type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(inout) :: h !< Thickness -! real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(inout) :: e !< Layer interface height -! real, dimension(SZI_(G),SZJ_(G)) , intent(inout) :: eta !< Thickness - type(time_type), intent(in) :: Time !< Time + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(inout) :: h !< Thickness [m] + type(time_type), intent(in) :: Time !< Model time ! Local variables - integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed integer :: IsdB, IedB, JsdB, JedB, n, m, nz character(len=40) :: mdl = "set_OBC_segment_data" ! This subroutine's name. character(len=200) :: filename, OBC_file, inputdir ! Strings for file/path - type(OBC_segment_type), pointer :: segment + type(OBC_segment_type), pointer :: segment => NULL() integer, dimension(4) :: siz,siz2 - real :: sumh ! column sum of thicknesses (m) + real :: sumh ! column sum of thicknesses [m] integer :: ni_seg, nj_seg ! number of src gridpoints along the segments integer :: i2, j2 ! indices for referencing local domain array integer :: is_obc, ie_obc, js_obc, je_obc ! segment indices within local domain @@ -2079,6 +2940,8 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) real, dimension(:,:,:), allocatable :: tmp_buffer real, dimension(:), allocatable :: h_stack integer :: is_obc2, js_obc2 + real :: net_H_src, net_H_int, scl_fac + real, pointer, dimension(:,:) :: normal_trans_bt=>NULL() ! barotropic transport is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -2111,34 +2974,29 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) ! calculate auxiliary fields at staggered locations ishift=0;jshift=0 if (segment%is_E_or_W) then + allocate(normal_trans_bt(segment%HI%IsdB:segment%HI%IedB,segment%HI%jsd:segment%HI%jed)) + normal_trans_bt(:,:)=0.0 if (segment%direction == OBC_DIRECTION_W) ishift=1 I=segment%HI%IsdB do j=segment%HI%jsd,segment%HI%jed segment%Cg(I,j) = sqrt(GV%g_prime(1)*G%bathyT(i+ishift,j)) - ! if (GV%Boussinesq) then - segment%Htot(I,j) = G%bathyT(i+ishift,j)*GV%m_to_H! + eta(i+ishift,j) - ! else - ! segment%Htot(I,j) = eta(i+ishift,j) - ! endif + segment%Htot(I,j)=0.0 do k=1,G%ke segment%h(I,j,k) = h(i+ishift,j,k) + segment%Htot(I,j)=segment%Htot(I,j)+segment%h(I,j,k) enddo enddo - - else! (segment%direction == OBC_DIRECTION_N .or. segment%direction == OBC_DIRECTION_S) + allocate(normal_trans_bt(segment%HI%isd:segment%HI%ied,segment%HI%JsdB:segment%HI%JedB)) + normal_trans_bt(:,:)=0.0 if (segment%direction == OBC_DIRECTION_S) jshift=1 J=segment%HI%JsdB do i=segment%HI%isd,segment%HI%ied segment%Cg(i,J) = sqrt(GV%g_prime(1)*G%bathyT(i,j+jshift)) -! if (GV%Boussinesq) then - segment%Htot(i,J) = G%bathyT(i,j+jshift)*GV%m_to_H! + eta(i,j+jshift) -! else -! segment%Htot(i,J) = eta(i,j+jshift) -! endif + segment%Htot(i,J)=0.0 do k=1,G%ke segment%h(i,J,k) = h(i,j+jshift,k) -! segment%e(i,J,k) = e(i,j+jshift,k) + segment%Htot(i,J)=segment%Htot(i,J)+segment%h(i,J,k) enddo enddo endif @@ -2154,7 +3012,7 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) if (siz(3) /= segment%field(m)%nk_src) call MOM_error(FATAL,'nk_src inconsistency') if (segment%field(m)%nk_src > 1) then if (segment%is_E_or_W) then - if (segment%field(m)%name == 'V') then + if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX') then allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,G%ke)) else allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,G%ke)) @@ -2164,7 +3022,7 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) segment%field(m)%bt_vel(:,:)=0.0 endif else - if (segment%field(m)%name == 'U') then + if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY') then allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,G%ke)) else allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,G%ke)) @@ -2176,7 +3034,7 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) endif else if (segment%is_E_or_W) then - if (segment%field(m)%name == 'V') then + if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX') then allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,1)) else allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,1)) @@ -2186,7 +3044,7 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) segment%field(m)%bt_vel(:,:)=0.0 endif else - if (segment%field(m)%name == 'U') then + if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY') then allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,1)) else allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,1)) @@ -2217,27 +3075,31 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) call time_interp_external(segment%field(m)%fid,Time, tmp_buffer) if (OBC%brushcutter_mode) then if (segment%is_E_or_W) then - if (segment%field(m)%name == 'V') then - segment%field(m)%buffer_src(is_obc,:,:)=tmp_buffer(1,2*(js_obc+G%jdg_offset)+1:2*(je_obc+G%jdg_offset)+1:2,:) + if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX') then + segment%field(m)%buffer_src(is_obc,:,:) = & + tmp_buffer(1,2*(js_obc+G%jdg_offset)+1:2*(je_obc+G%jdg_offset)+1:2,:) else - segment%field(m)%buffer_src(is_obc,:,:)=tmp_buffer(1,2*(js_obc+G%jdg_offset)+1:2*(je_obc+G%jdg_offset):2,:) + segment%field(m)%buffer_src(is_obc,:,:) = & + tmp_buffer(1,2*(js_obc+G%jdg_offset)+1:2*(je_obc+G%jdg_offset):2,:) endif else - if (segment%field(m)%name == 'U') then - segment%field(m)%buffer_src(:,js_obc,:)=tmp_buffer(2*(is_obc+G%idg_offset)+1:2*(ie_obc+G%idg_offset)+1:2,1,:) + if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY') then + segment%field(m)%buffer_src(:,js_obc,:) = & + tmp_buffer(2*(is_obc+G%idg_offset)+1:2*(ie_obc+G%idg_offset)+1:2,1,:) else - segment%field(m)%buffer_src(:,js_obc,:)=tmp_buffer(2*(is_obc+G%idg_offset)+1:2*(ie_obc+G%idg_offset):2,1,:) + segment%field(m)%buffer_src(:,js_obc,:) = & + tmp_buffer(2*(is_obc+G%idg_offset)+1:2*(ie_obc+G%idg_offset):2,1,:) endif endif else if (segment%is_E_or_W) then - if (segment%field(m)%name == 'V') then + if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX') then segment%field(m)%buffer_src(is_obc,:,:)=tmp_buffer(1,js_obc+G%jdg_offset+1:je_obc+G%jdg_offset+1,:) else segment%field(m)%buffer_src(is_obc,:,:)=tmp_buffer(1,js_obc+G%jdg_offset+1:je_obc+G%jdg_offset,:) endif else - if (segment%field(m)%name == 'U') then + if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY') then segment%field(m)%buffer_src(:,js_obc,:)=tmp_buffer(is_obc+G%idg_offset+1:ie_obc+G%idg_offset+1,1,:) else segment%field(m)%buffer_src(:,js_obc,:)=tmp_buffer(is_obc+G%idg_offset+1:ie_obc+G%idg_offset,1,:) @@ -2248,27 +3110,31 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) call time_interp_external(segment%field(m)%fid_dz,Time, tmp_buffer) if (OBC%brushcutter_mode) then if (segment%is_E_or_W) then - if (segment%field(m)%name == 'V') then - segment%field(m)%dz_src(is_obc,:,:)=tmp_buffer(1,2*(js_obc+G%jdg_offset)+1:2*(je_obc+G%jdg_offset)+1:2,:) + if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX') then + segment%field(m)%dz_src(is_obc,:,:) = & + tmp_buffer(1,2*(js_obc+G%jdg_offset)+1:2*(je_obc+G%jdg_offset)+1:2,:) else - segment%field(m)%dz_src(is_obc,:,:)=tmp_buffer(1,2*(js_obc+G%jdg_offset)+1:2*(je_obc+G%jdg_offset):2,:) + segment%field(m)%dz_src(is_obc,:,:) = & + tmp_buffer(1,2*(js_obc+G%jdg_offset)+1:2*(je_obc+G%jdg_offset):2,:) endif else - if (segment%field(m)%name == 'U') then - segment%field(m)%dz_src(:,js_obc,:)=tmp_buffer(2*(is_obc+G%idg_offset)+1:2*(ie_obc+G%idg_offset)+1:2,1,:) + if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY') then + segment%field(m)%dz_src(:,js_obc,:) = & + tmp_buffer(2*(is_obc+G%idg_offset)+1:2*(ie_obc+G%idg_offset)+1:2,1,:) else - segment%field(m)%dz_src(:,js_obc,:)=tmp_buffer(2*(is_obc+G%idg_offset)+1:2*(ie_obc+G%idg_offset):2,1,:) + segment%field(m)%dz_src(:,js_obc,:) = & + tmp_buffer(2*(is_obc+G%idg_offset)+1:2*(ie_obc+G%idg_offset):2,1,:) endif endif else if (segment%is_E_or_W) then - if (segment%field(m)%name == 'V') then + if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX') then segment%field(m)%dz_src(is_obc,:,:)=tmp_buffer(1,js_obc+G%jdg_offset+1:je_obc+G%jdg_offset+1,:) else segment%field(m)%dz_src(is_obc,:,:)=tmp_buffer(1,js_obc+G%jdg_offset+1:je_obc+G%jdg_offset,:) endif else - if (segment%field(m)%name == 'U') then + if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY') then segment%field(m)%dz_src(:,js_obc,:)=tmp_buffer(is_obc+G%idg_offset+1:ie_obc+G%idg_offset+1,1,:) else segment%field(m)%dz_src(:,js_obc,:)=tmp_buffer(is_obc+G%idg_offset+1:ie_obc+G%idg_offset,1,:) @@ -2280,9 +3146,9 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) ishift=1 if (segment%direction == OBC_DIRECTION_E) ishift=0 I=is_obc - if (segment%field(m)%name == 'V') then - ! Only do q points within the segment - do J=js_obc+1,je_obc-1 + if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX') then + ! Do q points for the whole segment + do J=max(js_obc,jsd),min(je_obc,jed-1) ! Using the h remapping approach ! Pretty sure we need to check for source/target grid consistency here segment%field(m)%buffer_dst(I,J,:)=0.0 ! initialize remap destination buffer @@ -2292,13 +3158,13 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) segment%field(m)%nk_src,segment%field(m)%dz_src(I,J,:), & segment%field(m)%buffer_src(I,J,:), & G%ke, h_stack, segment%field(m)%buffer_dst(I,J,:)) - else if (G%mask2dCu(I,j)>0.) then + elseif (G%mask2dCu(I,j)>0.) then h_stack(:) = h(i+ishift,j,:) call remapping_core_h(OBC%remap_CS, & segment%field(m)%nk_src,segment%field(m)%dz_src(I,J,:), & segment%field(m)%buffer_src(I,J,:), & G%ke, h_stack, segment%field(m)%buffer_dst(I,J,:)) - else if (G%mask2dCu(I,j+1)>0.) then + elseif (G%mask2dCu(I,j+1)>0.) then h_stack(:) = h(i+ishift,j+1,:) call remapping_core_h(OBC%remap_CS, & segment%field(m)%nk_src,segment%field(m)%dz_src(I,j,:), & @@ -2312,8 +3178,11 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) ! Pretty sure we need to check for source/target grid consistency here segment%field(m)%buffer_dst(I,j,:)=0.0 ! initialize remap destination buffer if (G%mask2dCu(I,j)>0.) then + net_H_src = sum( segment%field(m)%dz_src(I,j,:) ) + net_H_int = sum( h(i+ishift,j,:) ) + scl_fac = net_H_int / net_H_src call remapping_core_h(OBC%remap_CS, & - segment%field(m)%nk_src,segment%field(m)%dz_src(I,j,:), & + segment%field(m)%nk_src, scl_fac*segment%field(m)%dz_src(I,j,:), & segment%field(m)%buffer_src(I,j,:), & G%ke, h(i+ishift,j,:), segment%field(m)%buffer_dst(I,j,:)) endif @@ -2323,9 +3192,9 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) jshift=1 if (segment%direction == OBC_DIRECTION_N) jshift=0 J=js_obc - if (segment%field(m)%name == 'U') then - ! Only do q points within the segment - do I=is_obc+1,ie_obc-1 + if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY') then + ! Do q points for the whole segment + do I=max(is_obc,isd),min(ie_obc,ied-1) segment%field(m)%buffer_dst(I,J,:)=0.0 ! initialize remap destination buffer if (G%mask2dCv(i,J)>0. .and. G%mask2dCv(i+1,J)>0.) then ! Using the h remapping approach @@ -2335,13 +3204,13 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) segment%field(m)%nk_src,segment%field(m)%dz_src(I,J,:), & segment%field(m)%buffer_src(I,J,:), & G%ke, h_stack, segment%field(m)%buffer_dst(I,J,:)) - else if (G%mask2dCv(i,J)>0.) then + elseif (G%mask2dCv(i,J)>0.) then h_stack(:) = h(i,j+jshift,:) call remapping_core_h(OBC%remap_CS, & segment%field(m)%nk_src,segment%field(m)%dz_src(I,J,:), & segment%field(m)%buffer_src(I,J,:), & G%ke, h_stack, segment%field(m)%buffer_dst(I,J,:)) - else if (G%mask2dCv(i+1,J)>0.) then + elseif (G%mask2dCv(i+1,J)>0.) then h_stack(:) = h(i+1,j+jshift,:) call remapping_core_h(OBC%remap_CS, & segment%field(m)%nk_src,segment%field(m)%dz_src(I,J,:), & @@ -2355,6 +3224,9 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) ! Pretty sure we need to check for source/target grid consistency here segment%field(m)%buffer_dst(i,J,:)=0.0 ! initialize remap destination buffer if (G%mask2dCv(i,J)>0.) then + net_H_src = sum( segment%field(m)%dz_src(i,J,:) ) + net_H_int = sum( h(i,j+jshift,:) ) + scl_fac = net_H_int / net_H_src call remapping_core_h(OBC%remap_CS, & segment%field(m)%nk_src,segment%field(m)%dz_src(i,J,:), & segment%field(m)%buffer_src(i,J,:), & @@ -2373,9 +3245,11 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) if (segment%field(m)%name == 'V') then allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,G%ke)) allocate(segment%field(m)%bt_vel(is_obc:ie_obc,js_obc:je_obc)) - else if (segment%field(m)%name == 'U') then + elseif (segment%field(m)%name == 'U') then allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,G%ke)) allocate(segment%field(m)%bt_vel(is_obc:ie_obc,js_obc+1:je_obc)) + elseif (segment%field(m)%name == 'DVDX') then + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,G%ke)) else allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,G%ke)) endif @@ -2383,9 +3257,11 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) if (segment%field(m)%name == 'U') then allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,G%ke)) allocate(segment%field(m)%bt_vel(is_obc:ie_obc,js_obc:je_obc)) - else if (segment%field(m)%name == 'V') then + elseif (segment%field(m)%name == 'V') then allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,G%ke)) allocate(segment%field(m)%bt_vel(is_obc+1:ie_obc,js_obc:je_obc)) + elseif (segment%field(m)%name == 'DUDY') then + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,G%ke)) else allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,G%ke)) endif @@ -2402,31 +3278,67 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) if (trim(segment%field(m)%name) == 'U' .and. segment%is_E_or_W) then I=is_obc do j=js_obc+1,je_obc - segment%normal_trans_bt(I,j) = 0.0 + normal_trans_bt(I,j) = 0.0 do k=1,G%ke segment%normal_vel(I,j,k) = segment%field(m)%buffer_dst(I,j,k) segment%normal_trans(I,j,k) = segment%field(m)%buffer_dst(I,j,k)*segment%h(I,j,k) * & G%dyCu(I,j) - segment%normal_trans_bt(I,j)= segment%normal_trans_bt(I,j)+segment%normal_trans(I,j,k) + normal_trans_bt(I,j) = normal_trans_bt(I,j)+segment%normal_trans(I,j,k) enddo - segment%normal_vel_bt(I,j) = segment%normal_trans_bt(I,j)/(max(segment%Htot(I,j),1.e-12) * & + segment%normal_vel_bt(I,j) = normal_trans_bt(I,j)/(max(segment%Htot(I,j),1.e-12) * & G%dyCu(I,j)) if (associated(segment%nudged_normal_vel)) segment%nudged_normal_vel(I,j,:) = segment%normal_vel(I,j,:) enddo elseif (trim(segment%field(m)%name) == 'V' .and. segment%is_N_or_S) then J=js_obc do i=is_obc+1,ie_obc - segment%normal_trans_bt(i,J) = 0.0 + normal_trans_bt(i,J) = 0.0 do k=1,G%ke segment%normal_vel(i,J,k) = segment%field(m)%buffer_dst(i,J,k) segment%normal_trans(i,J,k) = segment%field(m)%buffer_dst(i,J,k)*segment%h(i,J,k) * & G%dxCv(i,J) - segment%normal_trans_bt(i,J)= segment%normal_trans_bt(i,J)+segment%normal_trans(i,J,k) + normal_trans_bt(i,J) = normal_trans_bt(i,J)+segment%normal_trans(i,J,k) enddo - segment%normal_vel_bt(i,J) = segment%normal_trans_bt(i,J)/(max(segment%Htot(i,J),1.e-12) * & + segment%normal_vel_bt(i,J) = normal_trans_bt(i,J)/(max(segment%Htot(i,J),1.e-12) * & G%dxCv(i,J)) if (associated(segment%nudged_normal_vel)) segment%nudged_normal_vel(i,J,:) = segment%normal_vel(i,J,:) enddo + elseif (trim(segment%field(m)%name) == 'V' .and. segment%is_E_or_W .and. & + associated(segment%tangential_vel)) then + I=is_obc + do J=js_obc,je_obc + do k=1,G%ke + segment%tangential_vel(I,J,k) = segment%field(m)%buffer_dst(I,J,k) + enddo + if (associated(segment%nudged_tangential_vel)) & + segment%nudged_tangential_vel(I,J,:) = segment%tangential_vel(I,J,:) + enddo + elseif (trim(segment%field(m)%name) == 'U' .and. segment%is_N_or_S .and. & + associated(segment%tangential_vel)) then + J=js_obc + do I=is_obc,ie_obc + do k=1,G%ke + segment%tangential_vel(I,J,k) = segment%field(m)%buffer_dst(I,J,k) + enddo + if (associated(segment%nudged_tangential_vel)) & + segment%nudged_tangential_vel(I,J,:) = segment%tangential_vel(I,J,:) + enddo + elseif (trim(segment%field(m)%name) == 'DVDX' .and. segment%is_E_or_W .and. & + associated(segment%tangential_grad)) then + I=is_obc + do J=js_obc,je_obc + do k=1,G%ke + segment%tangential_grad(I,J,k) = segment%field(m)%buffer_dst(I,J,k) + enddo + enddo + elseif (trim(segment%field(m)%name) == 'DUDY' .and. segment%is_N_or_S .and. & + associated(segment%tangential_grad)) then + J=js_obc + do I=is_obc,ie_obc + do k=1,G%ke + segment%tangential_grad(I,J,k) = segment%field(m)%buffer_dst(I,J,k) + enddo + enddo endif endif endif @@ -2460,12 +3372,12 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) if (associated(segment%field(m)%buffer_dst)) then do k=1,nz; do j=js_obc2, je_obc; do i=is_obc2,ie_obc segment%tr_Reg%Tr(1)%t(i,j,k) = segment%field(m)%buffer_dst(i,j,k) - enddo; enddo; enddo + enddo ; enddo ; enddo if (.not. segment%tr_Reg%Tr(1)%is_initialized) then ! if the tracer reservoir has not yet been initialized, then set to external value. do k=1,nz; do j=js_obc2, je_obc; do i=is_obc2,ie_obc segment%tr_Reg%Tr(1)%tres(i,j,k) = segment%tr_Reg%Tr(1)%t(i,j,k) - enddo; enddo; enddo + enddo ; enddo ; enddo segment%tr_Reg%Tr(1)%is_initialized=.true. endif else @@ -2475,12 +3387,12 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) if (associated(segment%field(m)%buffer_dst)) then do k=1,nz; do j=js_obc2, je_obc; do i=is_obc2,ie_obc segment%tr_Reg%Tr(2)%t(i,j,k) = segment%field(m)%buffer_dst(i,j,k) - enddo; enddo; enddo + enddo ; enddo ; enddo if (.not. segment%tr_Reg%Tr(1)%is_initialized) then !if the tracer reservoir has not yet been initialized, then set to external value. do k=1,nz; do j=js_obc2, je_obc; do i=is_obc2,ie_obc segment%tr_Reg%Tr(2)%tres(i,j,k) = segment%tr_Reg%Tr(2)%t(i,j,k) - enddo; enddo; enddo + enddo ; enddo ; enddo segment%tr_Reg%Tr(1)%is_initialized=.true. endif else @@ -2490,6 +3402,7 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) enddo ! end field loop deallocate(h_stack) + deallocate(normal_trans_bt) enddo ! end segment loop @@ -2621,9 +3534,9 @@ subroutine register_segment_tracer(tr_ptr, param_file, GV, segment, & !! available subsequently to the tracer registry. type(param_file_type), intent(in) :: param_file !< file to parse for model parameter values type(OBC_segment_type), intent(inout) :: segment !< current segment data structure - real, optional :: OBC_scalar !< If present, use scalar value for segment tracer + real, optional, intent(in) :: OBC_scalar !< If present, use scalar value for segment tracer !! inflow concentration. - logical, optional :: OBC_array !< If true, use array values for segment tracer + logical, optional, intent(in) :: OBC_array !< If true, use array values for segment tracer !! inflow concentration. @@ -2696,7 +3609,7 @@ subroutine register_temp_salt_segments(GV, OBC, tr_Reg, param_file) integer :: i, j, k, n character(len=32) :: name type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list - type(tracer_type), pointer :: tr_ptr + type(tracer_type), pointer :: tr_ptr => NULL() if (.not. associated(OBC)) return @@ -2727,7 +3640,7 @@ subroutine fill_temp_salt_segments(G, OBC, tv) ! Local variables integer :: isd, ied, IsdB, IedB, jsd, jed, JsdB, JedB, n, nz integer :: i, j, k - type(OBC_segment_type), pointer :: segment ! pointer to segment type list + type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list if (.not. associated(OBC)) return if (.not. associated(tv%T) .and. associated(tv%S)) return @@ -2779,24 +3692,27 @@ end subroutine fill_temp_salt_segments !> Find the region outside of all open boundary segments and !! make sure it is set to land mask. Gonna need to know global land !! mask as well to get it right... -subroutine mask_outside_OBCs(G, param_file, OBC) - type(dyn_horgrid_type), intent(inout) :: G !< Ocean grid structure - type(param_file_type), intent(in) :: param_file !< Parameter file handle - type(ocean_OBC_type), pointer :: OBC !< Open boundary structure +subroutine mask_outside_OBCs(G, US, param_file, OBC) + type(dyn_horgrid_type), intent(inout) :: G !< Ocean grid structure + type(param_file_type), intent(in) :: param_file !< Parameter file handle + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type -! Local variables + ! Local variables integer :: isd, ied, IsdB, IedB, jsd, jed, JsdB, JedB, n integer :: i, j + logical :: fatal_error = .False. real :: min_depth - integer, parameter :: cin = 3, cout = 4, cland = -1, cedge = -2 - type(OBC_segment_type), pointer :: segment ! pointer to segment type list + integer, parameter :: cin = 3, cout = 4, cland = -1, cedge = -2 + character(len=256) :: mesg ! Message for error messages. + type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list real, allocatable, dimension(:,:) :: color, color2 ! For sorting inside from outside, ! two different ways if (.not. associated(OBC)) return call get_param(param_file, mdl, "MINIMUM_DEPTH", min_depth, & - default=0.0, do_not_log=.true.) + units="m", default=0.0, scale=US%m_to_Z, do_not_log=.true.) allocate(color(G%isd:G%ied, G%jsd:G%jed)) ; color = 0 allocate(color2(G%isd:G%ied, G%jsd:G%jed)) ; color2 = 0 @@ -2869,10 +3785,16 @@ subroutine mask_outside_OBCs(G, param_file, OBC) ! Use the color to set outside to min_depth on this process. do j=G%jsd,G%jed ; do i=G%isd,G%ied - if (color(i,j) /= color2(i,j)) call MOM_error(FATAL, & - "MOM_open_boundary: inconsistent OBC segments.") + if (color(i,j) /= color2(i,j)) then + fatal_error = .True. + write(mesg,'("MOM_open_boundary: problem with OBC segments specification at ",I5,",",I5," during\n", & + "the masking of the outside grid points.")') i, j + call MOM_error(WARNING,"MOM register_tracer: "//mesg, all_print=.true.) + endif if (color(i,j) == cout) G%bathyT(i,j) = min_depth enddo ; enddo + if (fatal_error) call MOM_error(FATAL, & + "MOM_open_boundary: inconsistent OBC segments.") deallocate(color) deallocate(color2) @@ -3019,7 +3941,7 @@ subroutine open_boundary_register_restarts(HI, GV, OBC_CS,restart_CSp) ! This implementation uses 3D arrays solely for restarts. We need ! to be able to add 2D ( x,z or y,z ) data to restarts to avoid using ! so much memory and disk space. *** - if (OBC_CS%radiation_BCs_exist_globally) then + if (OBC_CS%radiation_BCs_exist_globally .or. OBC_CS%oblique_BCs_exist_globally) then allocate(OBC_CS%rx_normal(HI%isdB:HI%iedB,HI%jsd:HI%jed,GV%ke)) OBC_CS%rx_normal(:,:,:) = 0.0 vd = var_desc("rx_normal","m s-1", "Normal Phase Speed for EW OBCs",'u','L') @@ -3029,6 +3951,12 @@ subroutine open_boundary_register_restarts(HI, GV, OBC_CS,restart_CSp) vd = var_desc("ry_normal","m s-1", "Normal Phase Speed for NS OBCs",'v','L') call register_restart_field(OBC_CS%ry_normal, vd, .true., restart_CSp) endif + if (OBC_CS%oblique_BCs_exist_globally) then + allocate(OBC_CS%cff_normal(HI%IsdB:HI%IedB,HI%jsdB:HI%jedB,GV%ke)) + OBC_CS%cff_normal(:,:,:) = 0.0 + vd = var_desc("cff_normal","m s-1", "denominator for oblique OBCs",'q','L') + call register_restart_field(OBC_CS%cff_normal, vd, .true., restart_CSp) + endif end subroutine open_boundary_register_restarts diff --git a/src/core/MOM_transcribe_grid.F90 b/src/core/MOM_transcribe_grid.F90 index 75892d19f3..62ac6e1ea4 100644 --- a/src/core/MOM_transcribe_grid.F90 +++ b/src/core/MOM_transcribe_grid.F90 @@ -1,3 +1,5 @@ +!> Module with routines for copying information from a shared dynamic horizontal +!! grid to an ocean-specific horizontal grid and the reverse. module MOM_transcribe_grid ! This file is part of MOM6. See LICENSE.md for the license. @@ -141,7 +143,7 @@ subroutine copy_dyngrid_to_MOM_grid(dG, oG) call pass_vector(oG%geoLatCu, oG%geoLatCv, oG%Domain, To_All+Scalar_Pair, CGRID_NE) call pass_var(oG%areaBu, oG%Domain, position=CORNER) - call pass_var(oG%geoLonBu, oG%Domain, position=CORNER) + call pass_var(oG%geoLonBu, oG%Domain, position=CORNER, inner_halo=oG%isc-isd) call pass_var(oG%geoLatBu, oG%Domain, position=CORNER) call pass_vector(oG%dxBu, oG%dyBu, oG%Domain, To_All+Scalar_Pair, BGRID_NE) call pass_var(oG%CoriolisBu, oG%Domain, position=CORNER) @@ -285,7 +287,7 @@ subroutine copy_MOM_grid_to_dyngrid(oG, dG) call pass_vector(dG%geoLatCu, dG%geoLatCv, dG%Domain, To_All+Scalar_Pair, CGRID_NE) call pass_var(dG%areaBu, dG%Domain, position=CORNER) - call pass_var(dG%geoLonBu, dG%Domain, position=CORNER) + call pass_var(dG%geoLonBu, dG%Domain, position=CORNER, inner_halo=dG%isc-isd) call pass_var(dG%geoLatBu, dG%Domain, position=CORNER) call pass_vector(dG%dxBu, dG%dyBu, dG%Domain, To_All+Scalar_Pair, BGRID_NE) call pass_var(dG%CoriolisBu, dG%Domain, position=CORNER) diff --git a/src/core/MOM_unit_tests.F90 b/src/core/MOM_unit_tests.F90 index f3bd5fb76d..ff5a93a62c 100644 --- a/src/core/MOM_unit_tests.F90 +++ b/src/core/MOM_unit_tests.F90 @@ -10,6 +10,10 @@ module MOM_unit_tests use MOM_neutral_diffusion, only : neutral_diffusion_unit_tests use MOM_diag_vkernels, only : diag_vkernels_unit_tests +implicit none ; private + +public unit_tests + contains !> Calls unit tests for other modules. diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index f7fa45f12c..c623848c15 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -1,3 +1,4 @@ +!> Provides transparent structures with groups of MOM6 variables and supporting routines module MOM_variables ! This file is part of MOM6. See LICENSE.md for the license. @@ -18,278 +19,299 @@ module MOM_variables public allocate_surface_state, deallocate_surface_state, MOM_thermovar_chksum public ocean_grid_type, alloc_BT_cont_type, dealloc_BT_cont_type +! 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. + +!> A structure for creating arrays of pointers to 3D arrays type, public :: p3d - real, dimension(:,:,:), pointer :: p => NULL() + real, dimension(:,:,:), pointer :: p => NULL() !< A pointer to a 3D array end type p3d +!> A structure for creating arrays of pointers to 2D arrays type, public :: p2d - real, dimension(:,:), pointer :: p => NULL() + real, dimension(:,:), pointer :: p => NULL() !< A pointer to a 2D array end type p2d -!> The following structure contains pointers to various fields -!! which may be used describe the surface state of MOM, and which +!> Pointers to various fields which may be used describe the surface state of MOM, and which !! will be returned to a the calling program type, public :: surface real, allocatable, dimension(:,:) :: & - SST, & !< The sea surface temperature in C. - SSS, & !< The sea surface salinity in psu. - sfc_density, & !< The mixed layer density in kg m-3. - Hml, & !< The mixed layer depth in m. - u, & !< The mixed layer zonal velocity in m s-1. - v, & !< The mixed layer meridional velocity in m s-1. - sea_lev, & !< The sea level in m. If a reduced surface gravity is + SST, & !< The sea surface temperature [degC]. + SSS, & !< The sea surface salinity [ppt ~> psu or gSalt/kg]. + sfc_density, & !< The mixed layer density [kg m-3]. + Hml, & !< The mixed layer depth [m]. + u, & !< The mixed layer zonal velocity [m s-1]. + v, & !< The mixed layer meridional velocity [m s-1]. + sea_lev, & !< The sea level [m]. If a reduced surface gravity is !! used, that is compensated for in sea_lev. - ocean_mass, & !< The total mass of the ocean in kg m-2. - ocean_heat, & !< The total heat content of the ocean in C kg m-2. - ocean_salt, & !< The total salt content of the ocean in kgSalt m-2. + melt_potential, & !< Instantaneous amount of heat that can be used to melt sea ice [J m-2]. + !! This is computed w.r.t. surface freezing temperature. + ocean_mass, & !< The total mass of the ocean [kg m-2]. + ocean_heat, & !< The total heat content of the ocean in [degC kg m-2]. + ocean_salt, & !< The total salt content of the ocean in [kgSalt m-2]. salt_deficit !< The salt needed to maintain the ocean column at a minimum - !! salinity of 0.01 PSU over the call to step_MOM, in kgSalt m-2. - logical :: T_is_conT = .false. !< If true, the temperature variable SST is - !! actually the conservative temperature, in degC. - logical :: S_is_absS = .false. !< If true, the salinity variable SSS is - !! actually the absolute salinity, in g/kg. + !! salinity of 0.01 PSU over the call to step_MOM [kgSalt m-2]. + logical :: T_is_conT = .false. !< If true, the temperature variable SST is actually the + !! conservative temperature in [degC]. + logical :: S_is_absS = .false. !< If true, the salinity variable SSS is actually the + !! absolute salinity in [g/kg]. real, pointer, dimension(:,:) :: & - taux_shelf => NULL(), & !< The zonal and meridional stresses on the ocean - tauy_shelf => NULL(), & !< under shelves, in Pa. - frazil => NULL(), & !< The energy needed to heat the ocean column to the - !! freezing point over the call to step_MOM, in J m-2. - TempxPmE => NULL(), & !< The net inflow of water into the ocean times - !! the temperature at which this inflow occurs during - !! the call to step_MOM, in deg C kg m-2. - !! This should be prescribed in the forcing fields, - !! but as it often is not, this is a useful heat budget - !! diagnostic. - internal_heat => NULL() !< Any internal or geothermal heat sources that - !! are applied to the ocean integrated over the call - !! to step_MOM, in deg C kg m-2. - type(coupler_2d_bc_type) :: & - tr_fields !< A structure that may contain an array of named - !! fields describing tracer-related quantities. - !!! NOTE: ALL OF THE ARRAYS IN TR_FIELDS USE THE COUPLER'S INDEXING - !!! CONVENTION AND HAVE NO HALOS! THIS IS DONE TO CONFORM TO - !!! THE TREATMENT IN MOM4, BUT I DON'T LIKE IT! - logical :: arrays_allocated = .false. !< A flag that indicates whether - !! the surface type has had its memory allocated. + taux_shelf => NULL(), & !< The zonal stresses on the ocean under shelves [Pa]. + tauy_shelf => NULL() !< The meridional stresses on the ocean under shelves [Pa]. + real, pointer, dimension(:,:) :: frazil => NULL() + !< The energy needed to heat the ocean column to the freezing point during the call + !! to step_MOM [J m-2]. + real, pointer, dimension(:,:) :: TempxPmE => NULL() + !< The net inflow of water into the ocean times the temperature at which this inflow + !! occurs during the call to step_MOM [degC kg m-2]. This should be prescribed in the + !! forcing fields, but as it often is not, this is a useful heat budget diagnostic. + real, pointer, dimension(:,:) :: internal_heat => NULL() + !< Any internal or geothermal heat sources that are applied to the ocean integrated + !! over the call to step_MOM [degC kg m-2]. + type(coupler_2d_bc_type) :: tr_fields !< A structure that may contain an + !! array of named fields describing tracer-related quantities. + !### NOTE: ALL OF THE ARRAYS IN TR_FIELDS USE THE COUPLER'S INDEXING CONVENTION AND HAVE NO + !### HALOS! THIS IS DONE TO CONFORM TO THE TREATMENT IN MOM4, BUT I DON'T LIKE IT! -RWH + logical :: arrays_allocated = .false. !< A flag that indicates whether the surface type + !! has had its memory allocated. end type surface -!> The thermo_var_ptrs structure contains pointers to an assortment of -!! thermodynamic fields that may be available, including potential temperature, -!! salinity, heat capacity, and the equation of state control structure. +!> 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. - real, pointer :: T(:,:,:) => NULL() !< Potential temperature in C. - real, pointer :: S(:,:,:) => NULL() !< Salnity in psu or ppt. + 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 - !! equation of state to use. - real :: P_Ref !< The coordinate-density reference pressure in Pa. + !! equation of state to use. + real :: P_Ref !< The coordinate-density reference pressure [Pa]. !! This is the pressure used to calculate Rml from !! T and S when eqn_of_state is associated. - real :: C_p !< The heat capacity of seawater, in J K-1 kg-1. + real :: C_p !< The heat capacity of seawater [J degC-1 kg-1]. !! When conservative temperature is used, this is - !! constant and exactly 3991.86795711963 J K kg-1. + !! constant and exactly 3991.86795711963 J degC-1 kg-1. logical :: T_is_conT = .false. !< If true, the temperature variable tv%T is - !! actually the conservative temperature, in degC. + !! actually the conservative temperature [degC]. logical :: S_is_absS = .false. !< If true, the salinity variable tv%S is - !! actually the absolute salinity, in g/kg. - real, pointer, dimension(:,:) :: & + !! actually the absolute salinity in units of [gSalt/kg]. ! These arrays are accumulated fluxes for communication with other components. - frazil => NULL(), & !< The energy needed to heat the ocean column to the - !! freezing point since calculate_surface_state was - !! last called, in units of J m-2. - salt_deficit => NULL(), & !< The salt needed to maintain the ocean column + 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 - !! that calculate_surface_state was called, in units - !! of gSalt m-2. - TempxPmE => NULL(), & !< The net inflow of water into the ocean times the + !! that calculate_surface_state was called, [gSalt m-2]. + real, dimension(:,:), pointer :: TempxPmE => NULL() + !< The net inflow of water into the ocean times the !! temperature at which this inflow occurs since the - !! last call to calculate_surface_state, in units of - !! deg C kg m-2. This should be prescribed in the - !! forcing fields, but as it often is not, this is a - !! useful heat budget diagnostic. - internal_heat => NULL() !< Any internal or geothermal heat sources that + !! last call to calculate_surface_state [degC kg m-2]. + !! This should be prescribed in the forcing fields, but + !! as it often is not, this is a useful heat budget diagnostic. + real, dimension(:,:), pointer :: internal_heat => NULL() + !< Any internal or geothermal heat sources that !! have been applied to the ocean since the last call to - !! calculate_surface_state, in units of deg C kg m-2. + !! calculate_surface_state [degC kg m-2]. end type thermo_var_ptrs -!> The ocean_internal_state structure contains pointers to all of the prognostic -!! variables allocated in MOM_variables.F90 and MOM.F90. It is useful for -!! sending these variables for diagnostics, and in preparation for ensembles +!> Pointers to all of the prognostic variables allocated in MOM_variables.F90 and MOM.F90. +!! +!! It is useful for sending these variables for diagnostics, and in preparation for ensembles !! later on. All variables have the same names as the local (public) variables !! they refer to in MOM.F90. type, public :: ocean_internal_state real, pointer, dimension(:,:,:) :: & - u => NULL(), v => NULL(), h => NULL() + T => NULL(), & !< Pointer to the temperature state variable [degC] + S => NULL(), & !< Pointer to the salinity state variable [ppt ~> PSU or g/kg] + u => NULL(), & !< Pointer to the zonal velocity [m s-1] + v => NULL(), & !< Pointer to the meridional velocity [m s-1] + h => NULL() !< Pointer to the layer thicknesses [H ~> m or kg m-2] + real, pointer, dimension(:,:,:) :: & + uh => NULL(), & !< Pointer to zonal transports [H m2 s-1 ~> m3 s-1 or kg s-1] + vh => NULL() !< Pointer to meridional transports [H m2 s-1 ~> m3 s-1 or kg s-1] + real, pointer, dimension(:,:,:) :: & + CAu => NULL(), & !< Pointer to the zonal Coriolis and Advective acceleration [m s-2] + CAv => NULL(), & !< Pointer to the meridional Coriolis and Advective acceleration [m s-2] + PFu => NULL(), & !< Pointer to the zonal Pressure force acceleration [m s-2] + PFv => NULL(), & !< Pointer to the meridional Pressure force acceleration [m s-2] + diffu => NULL(), & !< Pointer to the zonal acceleration due to lateral viscosity [m s-2] + diffv => NULL(), & !< Pointer to the meridional acceleration due to lateral viscosity [m s-2] + pbce => NULL(), & !< Pointer to the baroclinic pressure force dependency on free surface movement + !! [m2 s-2 H-1 ~> m s-2 or m4 kg-1 s-2] + u_accel_bt => NULL(), & !< Pointer to the zonal barotropic-solver acceleration [m s-2] + v_accel_bt => NULL() !< Pointer to the meridional barotropic-solver acceleration [m s-2] real, pointer, dimension(:,:,:) :: & - uh => NULL(), vh => NULL(), & - CAu => NULL(), CAv => NULL(), & - PFu => NULL(), PFv => NULL(), diffu => NULL(), diffv => NULL(), & - T => NULL(), S => NULL(), & - pbce => NULL(), u_accel_bt => NULL(), v_accel_bt => NULL(), & - u_av => NULL(), v_av => NULL(), u_prev => NULL(), v_prev => NULL() + u_av => NULL(), & !< Pointer to zonal velocity averaged over the timestep [m s-1] + v_av => NULL(), & !< Pointer to meridional velocity averaged over the timestep [m s-1] + u_prev => NULL(), & !< Pointer to zonal velocity at the end of the last timestep [m s-1] + v_prev => NULL() !< Pointer to meridional velocity at the end of the last timestep [m s-1] end type ocean_internal_state -!> The accel_diag_ptrs structure contains pointers to arrays with accelerations, -!! which can later be used for derived diagnostics, like energy balances. +!> Pointers to arrays with accelerations, which can later be used for derived diagnostics, like energy balances. type, public :: accel_diag_ptrs -! Each of the following fields has nz layers. - real, pointer :: diffu(:,:,:) => NULL() ! Accelerations due to along iso- - real, pointer :: diffv(:,:,:) => NULL() ! pycnal viscosity, in m s-2. - real, pointer :: CAu(:,:,:) => NULL() ! Coriolis and momentum advection - real, pointer :: CAv(:,:,:) => NULL() ! accelerations, in m s-2. - real, pointer :: PFu(:,:,:) => NULL() ! Accelerations due to pressure - real, pointer :: PFv(:,:,:) => NULL() ! forces, in m s-2. - real, pointer :: du_dt_visc(:,:,:) => NULL()! Accelerations due to vertical - real, pointer :: dv_dt_visc(:,:,:) => NULL()! viscosity, in m s-2. - real, pointer :: du_dt_dia(:,:,:) => NULL()! Accelerations due to diapycnal - real, pointer :: dv_dt_dia(:,:,:) => NULL()! mixing, in m s-2. - real, pointer :: du_other(:,:,:) => NULL() ! Velocity changes due to any other - real, pointer :: dv_other(:,:,:) => NULL() ! processes that are not due to any - ! explicit accelerations, in m s-1. + ! Each of the following fields has nz layers. + real, pointer, dimension(:,:,:) :: & + diffu => NULL(), & !< Zonal acceleration due to along isopycnal viscosity [m s-2] + diffv => NULL(), & !< Meridional acceleration due to along isopycnal viscosity [m s-2] + CAu => NULL(), & !< Zonal Coriolis and momentum advection accelerations [m s-2] + CAv => NULL(), & !< Meridional Coriolis and momentum advection accelerations [m s-2] + PFu => NULL(), & !< Zonal acceleration due to pressure forces [m s-2] + PFv => NULL(), & !< Meridional acceleration due to pressure forces [m s-2] + du_dt_visc => NULL(), &!< Zonal acceleration due to vertical viscosity [m s-2] + dv_dt_visc => NULL(), &!< Meridional acceleration due to vertical viscosity [m s-2] + du_dt_dia => NULL(), & !< Zonal acceleration due to diapycnal mixing [m s-2] + dv_dt_dia => NULL() !< Meridional acceleration due to diapycnal mixing [m s-2] + real, pointer, dimension(:,:,:) :: du_other => NULL() + !< Zonal velocity changes due to any other processes that are + !! not due to any explicit accelerations [m s-1]. + real, pointer, dimension(:,:,:) :: dv_other => NULL() + !< Meridional velocity changes due to any other processes that are + !! not due to any explicit accelerations [m s-1]. ! These accelerations are sub-terms included in the accelerations above. - real, pointer :: gradKEu(:,:,:) => NULL() ! gradKEu = - d/dx(u2), in m s-2. - real, pointer :: gradKEv(:,:,:) => NULL() ! gradKEv = - d/dy(u2), in m s-2. - real, pointer :: rv_x_v(:,:,:) => NULL() ! rv_x_v = rv * v at u, in m s-2. - real, pointer :: rv_x_u(:,:,:) => NULL() ! rv_x_u = rv * u at v, in m s-2. + real, pointer :: gradKEu(:,:,:) => NULL() !< gradKEu = - d/dx(u2) [m s-2] + real, pointer :: gradKEv(:,:,:) => NULL() !< gradKEv = - d/dy(u2) [m s-2] + real, pointer :: rv_x_v(:,:,:) => NULL() !< rv_x_v = rv * v at u [m s-2] + real, pointer :: rv_x_u(:,:,:) => NULL() !< rv_x_u = rv * u at v [m s-2] end type accel_diag_ptrs -!> The cont_diag_ptrs structure contains pointers to arrays with transports, -!! which can later be used for derived diagnostics, like energy balances. +!> Pointers to arrays with transports, which can later be used for derived diagnostics, like energy balances. type, public :: cont_diag_ptrs ! Each of the following fields has nz layers. - real, pointer :: uh(:,:,:) => NULL() ! Resolved layer thickness fluxes, - real, pointer :: vh(:,:,:) => NULL() ! in m3 s-1 or kg s-1. - real, pointer :: uhGM(:,:,:) => NULL() ! Thickness diffusion induced - real, pointer :: vhGM(:,:,:) => NULL() ! volume fluxes in m3 s-1. + real, pointer, dimension(:,:,:) :: & + uh => NULL(), & !< Resolved zonal layer thickness fluxes, [H m2 s-1 ~> m3 s-1 or kg s-1] + vh => NULL(), & !< Resolved meridional layer thickness fluxes, [H m2 s-1 ~> m3 s-1 or kg s-1] + uhGM => NULL(), & !< Isopycnal height diffusion induced zonal volume fluxes [H m2 s-1 ~> m3 s-1 or kg s-1] + vhGM => NULL() !< Isopycnal height diffusion induced meridional volume fluxes [H m2 s-1 ~> m3 s-1 or kg s-1] ! Each of the following fields is found at nz+1 interfaces. - real, pointer :: diapyc_vel(:,:,:) => NULL()! The net diapycnal velocity, + real, pointer :: diapyc_vel(:,:,:) => NULL() !< The net diapycnal velocity [H s-1 ~> m s-1 or kg m-2 s-1] end type cont_diag_ptrs -!> The vertvisc_type structure contains vertical viscosities, drag -!! coefficients, and related fields. +!> Vertical viscosities, drag coefficients, and related fields. type, public :: vertvisc_type real :: Prandtl_turb !< The Prandtl number for the turbulent diffusion - !! that is captured in Kd_shear. + !! that is captured in Kd_shear [nondim]. + real, pointer, dimension(:,:) :: & + bbl_thick_u => NULL(), & !< The bottom boundary layer thickness at the u-points [Z ~> m]. + bbl_thick_v => NULL(), & !< The bottom boundary layer thickness at the v-points [Z ~> m]. + kv_bbl_u => NULL(), & !< The bottom boundary layer viscosity at the u-points [Z2 s-1 ~> m2 s-1]. + kv_bbl_v => NULL(), & !< The bottom boundary layer viscosity at the v-points [Z2 s-1 ~> m2 s-1]. + 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]. real, pointer, dimension(:,:) :: & - bbl_thick_u => NULL(), & !< The bottom boundary layer thickness at the - !! u-points, in m. - bbl_thick_v => NULL(), & !< The bottom boundary layer thickness at the - !! v-points, in m. - kv_bbl_u => NULL(), & !< The bottom boundary layer viscosity at the - !! u-points, in m2 s-1. - kv_bbl_v => NULL(), & !< The bottom boundary layer viscosity at the - !! v-points, in m2 s-1. - ustar_BBL => NULL(), & !< The turbulence velocity in the bottom boundary - !! layer at h points, in m s-1. - TKE_BBL => NULL(), & !< A term related to the bottom boundary layer - !! source of turbulent kinetic energy, currently - !! in units of m3 s-3, but will later be changed - !! to W m-2. - taux_shelf => NULL(), & !< The zonal stresses on the ocean under shelves, in Pa. - tauy_shelf => NULL(), & !< The meridional stresses on the ocean under shelves, in Pa. - tbl_thick_shelf_u => NULL(), & !< Thickness of the viscous top boundary - !< layer under ice shelves at u-points, in m. - tbl_thick_shelf_v => NULL(), & !< Thickness of the viscous top boundary - !< layer under ice shelves at v-points, in m. - kv_tbl_shelf_u => NULL(), & !< Viscosity in the viscous top boundary layer - !! under ice shelves at u-points, in m2 s-1. - kv_tbl_shelf_v => NULL(), & !< Viscosity in the viscous top boundary layer - !! under ice shelves at u-points, in m2 s-1. - nkml_visc_u => NULL(), & !< The number of layers in the viscous surface - !! mixed layer at u-points (nondimensional). This - !! is not an integer because there may be - !! fractional layers, and it is stored - !! in terms of layers, not depth, to facilitate - !! the movement of the viscous boundary layer with - !! the flow. - nkml_visc_v => NULL(), & !< The number of layers in the viscous surface - !! mixed layer at v-points (nondimensional). - MLD => NULL() !< Instantaneous active mixing layer depth (H units). + taux_shelf => NULL(), & !< The zonal stresses on the ocean under shelves [Pa]. + tauy_shelf => NULL() !< The meridional stresses on the ocean under shelves [Pa]. + real, pointer, dimension(:,:) :: tbl_thick_shelf_u => NULL() + !< Thickness of the viscous top boundary layer under ice shelves at u-points [Z ~> m]. + real, pointer, dimension(:,:) :: tbl_thick_shelf_v => NULL() + !< Thickness of the viscous top boundary layer under ice shelves at v-points [Z ~> m]. + real, pointer, dimension(:,:) :: kv_tbl_shelf_u => NULL() + !< Viscosity in the viscous top boundary layer under ice shelves at u-points [Z2 s-1 ~> m2 s-1]. + real, pointer, dimension(:,:) :: kv_tbl_shelf_v => NULL() + !< Viscosity in the viscous top boundary layer under ice shelves at v-points [Z2 s-1 ~> m2 s-1]. + real, pointer, dimension(:,:) :: nkml_visc_u => NULL() + !< The number of layers in the viscous surface mixed layer at u-points [nondim]. + !! This is not an integer because there may be fractional layers, and it is stored in + !! terms of layers, not depth, to facilitate the movement of the viscous boundary layer + !! with the flow. + real, pointer, dimension(:,:) :: nkml_visc_v => NULL() + !< The number of layers in the viscous surface mixed layer at v-points [nondim]. + real, pointer, dimension(:,:) :: & + MLD => NULL() !< Instantaneous active mixing layer depth [H ~> m or kg m-2]. real, pointer, dimension(:,:,:) :: & - Ray_u => NULL(), & !< The Rayleigh drag velocity to be applied to each layer - !! at u-points, in m s-1. - Ray_v => NULL(), & !< The Rayleigh drag velocity to be applied to each layer - !! at v-points, in m s-1. - Kd_extra_T => NULL(), & !< The extra diffusivity of temperature due to - !! double diffusion relative to the diffusivity of - !! density, in m2 s-1. - Kd_extra_S => NULL(), & !< The extra diffusivity of salinity due to - !! double diffusion relative to the diffusivity of - !! density, in m2 s-1. - ! One of Kd_extra_T and Kd_extra_S is always 0. - ! Kd_extra_S is positive for salt fingering; Kd_extra_T - ! is positive for double diffusive convection. These - ! are only allocated if DOUBLE_DIFFUSION is true. - Kd_shear => NULL(), &!< The shear-driven turbulent diapycnal diffusivity - !! at the interfaces between each layer, in m2 s-1. - Kv_shear => NULL(), &!< The shear-driven turbulent vertical viscosity - !! at the interfaces between each layer, in m2 s-1. - Kv_slow => NULL(), &!< The turbulent vertical viscosity component due to - !! "slow" processes (e.g., tidal, background, - !! convection etc). - TKE_turb => NULL() !< The turbulent kinetic energy per unit mass defined - !! at the interfaces between each layer, in m2 s-2. + Ray_u => NULL(), & !< The Rayleigh drag velocity to be applied to each layer at u-points [Z s-1 ~> m s-1]. + Ray_v => NULL() !< The Rayleigh drag velocity to be applied to each layer at v-points [Z s-1 ~> m s-1]. + real, pointer, dimension(:,:,:) :: Kd_extra_T => NULL() + !< The extra diffusivity of temperature due to double diffusion relative to the + !! diffusivity of density [Z2 s-1 ~> m2 s-1]. + real, pointer, dimension(:,:,:) :: Kd_extra_S => NULL() + !< The extra diffusivity of salinity due to double diffusion relative to the + !! diffusivity of density [Z2 s-1 ~> m2 s-1]. + ! One of Kd_extra_T and Kd_extra_S is always 0. Kd_extra_S is positive for salt fingering; + ! Kd_extra_T is positive for double diffusive convection. They are only allocated if + ! DOUBLE_DIFFUSION is true. + real, pointer, dimension(:,:,:) :: Kd_shear => NULL() + !< The shear-driven turbulent diapycnal diffusivity at the interfaces between layers + !! in tracer columns [Z2 s-1 ~> m2 s-1]. + real, pointer, dimension(:,:,:) :: Kv_shear => NULL() + !< The shear-driven turbulent vertical viscosity at the interfaces between layers + !! in tracer columns [Z2 s-1 ~> m2 s-1]. + real, pointer, dimension(:,:,:) :: Kv_shear_Bu => NULL() + !< The shear-driven turbulent vertical viscosity at the interfaces between layers in + !! corner columns [Z2 s-1 ~> m2 s-1]. + real, pointer, dimension(:,:,:) :: Kv_slow => NULL() + !< The turbulent vertical viscosity component due to "slow" processes (e.g., tidal, + !! background, convection etc) [Z2 s-1 ~> m2 s-1]. + real, pointer, dimension(:,:,:) :: TKE_turb => NULL() + !< The turbulent kinetic energy per unit mass at the interfaces [m2 s-2]. + !! This may be at the tracer or corner points + logical :: add_Kv_slow !< If True, add Kv_slow when calculating the 'coupling coefficient' (a_cpl) + !! at the interfaces in find_coupling_coef. end type vertvisc_type -!> The BT_cont_type structure contains information about the summed layer -!! transports and how they will vary as the barotropic velocity is changed. +!> Container for information about the summed layer transports +!! and how they will vary as the barotropic velocity is changed. type, public :: BT_cont_type - real, pointer, dimension(:,:) :: & - FA_u_EE => NULL(), & ! The FA_u_XX variables are the effective open face - FA_u_E0 => NULL(), & ! areas for barotropic transport through the zonal - FA_u_W0 => NULL(), & ! faces, all in H m, with the XX indicating where - FA_u_WW => NULL(), & ! the transport is from, with _EE drawing from points - ! far to the east, _E0 from points nearby from the - ! east, _W0 nearby from the west, and _WW from far to - ! the west. - uBT_WW => NULL(), & ! uBT_WW is the barotropic velocity, in m s-1, beyond - ! which the marginal open face area is FA_u_WW. - ! uBT_EE must be non-negative. - uBT_EE => NULL(), & ! uBT_EE is the barotropic velocity, in m s-1, beyond - ! which the marginal open face area is FA_u_EE. - ! uBT_EE must be non-positive. - FA_v_NN => NULL(), & ! The FA_v_XX variables are the effective open face - FA_v_N0 => NULL(), & ! areas for barotropic transport through the meridional - FA_v_S0 => NULL(), & ! faces, all in H m, with the XX indicating where - FA_v_SS => NULL(), & ! the transport is from, with _NN drawing from points - ! far to the north, _N0 from points nearby from the - ! north, _S0 nearby from the south, and _SS from far - ! to the south. - vBT_SS => NULL(), & ! vBT_SS is the barotropic velocity, in m s-1, beyond - ! which the marginal open face area is FA_v_SS. - ! vBT_SS must be non-negative. - vBT_NN => NULL() ! vBT_NN is the barotropic velocity, in m s-1, beyond - ! which the marginal open face area is FA_v_NN. - ! vBT_NN must be non-positive. - real, pointer, dimension(:,:,:) :: & - h_u => NULL(), & ! An effective thickness at zonal faces, in H. - h_v => NULL() ! An effective thickness at meridional faces, in H. - type(group_pass_type) :: pass_polarity_BT, pass_FA_uv ! For group halo updates + real, allocatable :: FA_u_EE(:,:) !< The effective open face area for zonal barotropic transport + !! drawing from locations far to the east [H m ~> m2 or kg m-1]. + real, allocatable :: FA_u_E0(:,:) !< The effective open face area for zonal barotropic transport + !! drawing from nearby to the east [H m ~> m2 or kg m-1]. + real, allocatable :: FA_u_W0(:,:) !< The effective open face area for zonal barotropic transport + !! drawing from nearby to the west [H m ~> m2 or kg m-1]. + real, allocatable :: FA_u_WW(:,:) !< The effective open face area for zonal barotropic transport + !! drawing from locations far to the west [H m ~> m2 or kg m-1]. + real, allocatable :: uBT_WW(:,:) !< uBT_WW is the barotropic velocity [m s-1], beyond which the marginal + !! open face area is FA_u_WW. uBT_WW must be non-negative. + real, allocatable :: uBT_EE(:,:) !< uBT_EE is a barotropic velocity [m s-1], beyond which the marginal + !! open face area is FA_u_EE. uBT_EE must be non-positive. + real, allocatable :: FA_v_NN(:,:) !< The effective open face area for meridional barotropic transport + !! drawing from locations far to the north [H m ~> m2 or kg m-1]. + real, allocatable :: FA_v_N0(:,:) !< The effective open face area for meridional barotropic transport + !! drawing from nearby to the north [H m ~> m2 or kg m-1]. + real, allocatable :: FA_v_S0(:,:) !< The effective open face area for meridional barotropic transport + !! drawing from nearby to the south [H m ~> m2 or kg m-1]. + real, allocatable :: FA_v_SS(:,:) !< The effective open face area for meridional barotropic transport + !! drawing from locations far to the south [H m ~> m2 or kg m-1]. + real, allocatable :: vBT_SS(:,:) !< vBT_SS is the barotropic velocity, [m s-1], beyond which the marginal + !! open face area is FA_v_SS. vBT_SS must be non-negative. + real, allocatable :: vBT_NN(:,:) !< vBT_NN is the barotropic velocity, [m s-1], beyond which the marginal + !! open face area is FA_v_NN. vBT_NN must be non-positive. + real, allocatable :: h_u(:,:,:) !< An effective thickness at zonal faces [H ~> m or kg m-2]. + real, allocatable :: h_v(:,:,:) !< An effective thickness at meridional faces [H ~> m or kg m-2]. + type(group_pass_type) :: pass_polarity_BT !< Structure for polarity group halo updates + type(group_pass_type) :: pass_FA_uv !< Structure for face area group halo updates end type BT_cont_type contains - -!> This subroutine allocates the fields for the surface (return) properties of -!! the ocean model. Unused fields are unallocated. +!> Allocates the fields for the surface (return) properties of +!! the ocean model. Unused fields are unallocated. subroutine allocate_surface_state(sfc_state, G, use_temperature, do_integrals, & - gas_fields_ocn) + gas_fields_ocn, use_meltpot) type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(surface), intent(inout) :: sfc_state !< ocean surface state type to be allocated. logical, optional, intent(in) :: use_temperature !< If true, allocate the space for thermodynamic variables. - logical, optional, intent(in) :: do_integrals !< If true, allocate the space for vertically integrated fields. + logical, optional, intent(in) :: do_integrals !< If true, allocate the space for vertically + !! integrated fields. type(coupler_1d_bc_type), & - optional, intent(in) :: gas_fields_ocn !< If present, this type describes the ocean + optional, intent(in) :: gas_fields_ocn !< If present, this type describes the ocean !! ocean and surface-ice fields that will participate !! in the calculation of additional gas or other !! tracer fluxes, and can be used to spawn related !! internal variables in the ice model. + logical, optional, intent(in) :: use_meltpot !< If true, allocate the space for melt potential - logical :: use_temp, alloc_integ + ! local variables + logical :: use_temp, alloc_integ, use_melt_potential integer :: is, ie, js, je, isd, ied, jsd, jed integer :: isdB, iedB, jsdB, jedB @@ -299,6 +321,7 @@ subroutine allocate_surface_state(sfc_state, G, use_temperature, do_integrals, & use_temp = .true. ; if (present(use_temperature)) use_temp = use_temperature alloc_integ = .true. ; if (present(do_integrals)) alloc_integ = do_integrals + use_melt_potential = .false. ; if (present(use_meltpot)) use_melt_potential = use_meltpot if (sfc_state%arrays_allocated) return @@ -313,9 +336,12 @@ subroutine allocate_surface_state(sfc_state, G, use_temperature, do_integrals, & allocate(sfc_state%u(IsdB:IedB,jsd:jed)) ; sfc_state%u(:,:) = 0.0 allocate(sfc_state%v(isd:ied,JsdB:JedB)) ; sfc_state%v(:,:) = 0.0 + if (use_melt_potential) then + allocate(sfc_state%melt_potential(isd:ied,jsd:jed)) ; sfc_state%melt_potential(:,:) = 0.0 + endif + if (alloc_integ) then - ! Allocate structures for the vertically integrated ocean_mass, ocean_heat, - ! and ocean_salt. + ! Allocate structures for the vertically integrated ocean_mass, ocean_heat, and ocean_salt. allocate(sfc_state%ocean_mass(isd:ied,jsd:jed)) ; sfc_state%ocean_mass(:,:) = 0.0 if (use_temp) then allocate(sfc_state%ocean_heat(isd:ied,jsd:jed)) ; sfc_state%ocean_heat(:,:) = 0.0 @@ -326,18 +352,19 @@ subroutine allocate_surface_state(sfc_state, G, use_temperature, do_integrals, & if (present(gas_fields_ocn)) & call coupler_type_spawn(gas_fields_ocn, sfc_state%tr_fields, & - (/isd,is,ie,ied/), (/jsd,js,je,jed/), as_needed=.true.) + (/is,is,ie,ie/), (/js,js,je,je/), as_needed=.true.) sfc_state%arrays_allocated = .true. end subroutine allocate_surface_state -!> This subroutine deallocates the elements of a surface state type. +!> Deallocates the elements of a surface state type. subroutine deallocate_surface_state(sfc_state) - type(surface), intent(inout) :: sfc_state !< ocean surface state type to be deallocated. + type(surface), intent(inout) :: sfc_state !< ocean surface state type to be deallocated here. if (.not.sfc_state%arrays_allocated) return + if (allocated(sfc_state%melt_potential)) deallocate(sfc_state%melt_potential) if (allocated(sfc_state%SST)) deallocate(sfc_state%SST) if (allocated(sfc_state%SSS)) deallocate(sfc_state%SSS) if (allocated(sfc_state%sfc_density)) deallocate(sfc_state%sfc_density) @@ -356,12 +383,12 @@ subroutine deallocate_surface_state(sfc_state) end subroutine deallocate_surface_state -!> alloc_BT_cont_type allocates the arrays contained within a BT_cont_type and -!! initializes them to 0. +!> Allocates the arrays contained within a BT_cont_type and initializes them to 0. subroutine alloc_BT_cont_type(BT_cont, G, alloc_faces) - type(BT_cont_type), pointer :: BT_cont + type(BT_cont_type), pointer :: BT_cont !< The BT_cont_type whose elements will be allocated type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - logical, optional, intent(in) :: alloc_faces + logical, optional, intent(in) :: alloc_faces !< If present and true, allocate + !! memory for effective face thicknesses. integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -392,9 +419,9 @@ subroutine alloc_BT_cont_type(BT_cont, G, alloc_faces) end subroutine alloc_BT_cont_type -!> dealloc_BT_cont_type deallocates the arrays contained within a BT_cont_type. +!> Deallocates the arrays contained within a BT_cont_type. subroutine dealloc_BT_cont_type(BT_cont) - type(BT_cont_type), pointer :: BT_cont + type(BT_cont_type), pointer :: BT_cont !< The BT_cont_type whose elements will be deallocated. if (.not.associated(BT_cont)) return @@ -406,43 +433,32 @@ subroutine dealloc_BT_cont_type(BT_cont) deallocate(BT_cont%FA_v_N0) ; deallocate(BT_cont%FA_v_NN) deallocate(BT_cont%vBT_SS) ; deallocate(BT_cont%vBT_NN) - if (associated(BT_cont%h_u)) deallocate(BT_cont%h_u) - if (associated(BT_cont%h_v)) deallocate(BT_cont%h_v) + if (allocated(BT_cont%h_u)) deallocate(BT_cont%h_u) + if (allocated(BT_cont%h_v)) deallocate(BT_cont%h_v) deallocate(BT_cont) end subroutine dealloc_BT_cont_type -!> MOM_thermovar_chksum does diagnostic checksums on various elements of a -!! thermo_var_ptrs type for debugging. +!> Diagnostic checksums on various elements of a thermo_var_ptrs type for debugging. subroutine MOM_thermovar_chksum(mesg, tv, G) - character(len=*), intent(in) :: mesg - type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure -! This subroutine writes out chksums for the model's basic state variables. -! Arguments: mesg - A message that appears on the chksum lines. -! (in) u - Zonal velocity, in m s-1. -! (in) v - Meridional velocity, in m s-1. -! (in) h - Layer thickness, in m. -! (in) uh - Volume flux through zonal faces = u*h*dy, m3 s-1. -! (in) vh - Volume flux through meridional faces = v*h*dx, in m3 s-1. -! (in) G - The ocean's grid structure. - integer :: is, ie, js, je, nz - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + character(len=*), intent(in) :: mesg !< A message that appears in the checksum lines + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure ! Note that for the chksum calls to be useful for reproducing across PE ! counts, there must be no redundant points, so all variables use is..ie ! and js...je as their extent. if (associated(tv%T)) & - call hchksum(tv%T, mesg//" tv%T",G%HI) + call hchksum(tv%T, mesg//" tv%T", G%HI) if (associated(tv%S)) & - call hchksum(tv%S, mesg//" tv%S",G%HI) + call hchksum(tv%S, mesg//" tv%S", G%HI) if (associated(tv%frazil)) & - call hchksum(tv%frazil, mesg//" tv%frazil",G%HI) + call hchksum(tv%frazil, mesg//" tv%frazil", G%HI) if (associated(tv%salt_deficit)) & - call hchksum(tv%salt_deficit, mesg//" tv%salt_deficit",G%HI) + call hchksum(tv%salt_deficit, mesg//" tv%salt_deficit", G%HI) if (associated(tv%TempxPmE)) & - call hchksum(tv%TempxPmE, mesg//" tv%TempxPmE",G%HI) + call hchksum(tv%TempxPmE, mesg//" tv%TempxPmE", G%HI) end subroutine MOM_thermovar_chksum end module MOM_variables diff --git a/src/core/MOM_verticalGrid.F90 b/src/core/MOM_verticalGrid.F90 index a57bd1f61f..a824553a84 100644 --- a/src/core/MOM_verticalGrid.F90 +++ b/src/core/MOM_verticalGrid.F90 @@ -1,79 +1,84 @@ +!> Provides a transparent vertical ocean grid type and supporting routines module MOM_verticalGrid ! This file is part of MOM6. See LICENSE.md for the license. use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_unit_scaling, only : unit_scale_type implicit none ; private #include public verticalGridInit, verticalGridEnd -public setVerticalGridAxes +public setVerticalGridAxes, fix_restart_scaling public get_flux_units, get_thickness_units, get_tr_flux_units +! 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. + +!> Describes the vertical ocean grid, including unit conversion factors type, public :: verticalGrid_type ! Commonly used parameters - integer :: ke ! The number of layers/levels in the vertical - real :: max_depth ! The maximum depth of the ocean in meters. - real :: g_Earth ! The gravitational acceleration in m s-2. - real :: Rho0 ! The density used in the Boussinesq approximation or - ! nominal density used to convert depths into mass - ! units, in kg m-3. + integer :: ke !< The number of layers/levels in the vertical + real :: max_depth !< The maximum depth of the ocean [Z ~> m]. + real :: g_Earth !< The gravitational acceleration [m2 Z-1 s-2 ~> m s-2]. + real :: Rho0 !< The density used in the Boussinesq approximation or nominal + !! density used to convert depths into mass units [kg m-3]. ! Vertical coordinate descriptions for diagnostics and I/O - character(len=40) :: & - zAxisUnits, & ! The units that vertical coordinates are written in - zAxisLongName ! Coordinate name to appear in files, - ! e.g. "Target Potential Density" or "Height" - real ALLOCABLE_, dimension(NKMEM_) :: sLayer ! Coordinate values of layer centers - real ALLOCABLE_, dimension(NK_INTERFACE_) :: sInterface ! Coordinate values on interfaces - integer :: direction = 1 ! Direction defaults to 1, positive up. + character(len=40) :: zAxisUnits !< The units that vertical coordinates are written in + character(len=40) :: zAxisLongName !< Coordinate name to appear in files, + !! e.g. "Target Potential Density" or "Height" + real, allocatable, dimension(:) :: sLayer !< Coordinate values of layer centers + real, allocatable, dimension(:) :: sInterface !< Coordinate values on interfaces + integer :: direction = 1 !< Direction defaults to 1, positive up. ! The following variables give information about the vertical grid. - logical :: Boussinesq ! If true, make the Boussinesq approximation. - real :: Angstrom ! A one-Angstrom thickness in the model's thickness - ! units. (This replaces the old macro EPSILON.) - real :: Angstrom_z ! A one-Angstrom thickness in m. - real :: H_subroundoff ! A thickness that is so small that it can be added to - ! a thickness of Angstrom or larger without changing it - ! at the bit level, in thickness units. If Angstrom is - ! 0 or exceedingly small, this is negligible compared to - ! a thickness of 1e-17 m. - real ALLOCABLE_, dimension(NK_INTERFACE_) :: & - g_prime, & ! The reduced gravity at each interface, in m s-2. - Rlay ! The target coordinate value (potential density) in - ! in each layer in kg m-3. - integer :: nkml = 0 ! The number of layers at the top that should be treated - ! as parts of a homogenous 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. - real :: kg_m2_to_H ! A constant that translates thicknesses from kg m-2 to - ! the units of thickness. - real :: m_to_H ! A constant that translates distances in m to the - ! units of thickness. - real :: H_to_m ! A constant that translates distances in the units of - ! thickness to m. - real :: H_to_Pa ! A constant that translates the units of thickness to - ! to pressure in Pa. + logical :: Boussinesq !< If true, make the Boussinesq approximation. + real :: Angstrom_H !< A one-Angstrom thickness in the model thickness units [H ~> m or kg m-2]. + real :: Angstrom_Z !< A one-Angstrom thickness in the model depth units [Z ~> m]. + real :: Angstrom_m !< A one-Angstrom thickness [m]. + real :: H_subroundoff !< A thickness that is so small that it can be added to a thickness of + !! Angstrom or larger without changing it at the bit level [H ~> m or kg m-2]. + !! If Angstrom is 0 or exceedingly small, this is negligible compared to 1e-17 m. + real, allocatable, dimension(:) :: & + 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. + 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. + real :: kg_m2_to_H !< A constant that translates thicknesses from kg m-2 to the units of thickness. + real :: m_to_H !< A constant that translates distances in m to the units of thickness. + real :: H_to_m !< A constant that translates distances in the units of thickness to m. + real :: H_to_Pa !< A constant that translates the units of thickness to pressure [Pa]. + real :: H_to_Z !< A constant that translates thickness units to the units of depth. + real :: Z_to_H !< A constant that translates depth units to thickness units. + + real :: m_to_H_restart = 0.0 !< A copy of the m_to_H that is used in restart files. end type verticalGrid_type contains -!> Allocates and initializes the model's vertical grid structure. -subroutine verticalGridInit( param_file, GV ) -! This routine initializes the verticalGrid_type structure (GV). -! All memory is allocated but not necessarily set to meaningful values until later. - type(param_file_type), intent(in) :: param_file ! Parameter file handle/type - type(verticalGrid_type), pointer :: GV ! The container for vertical grid data -! This include declares and sets the variable "version". -#include "version_variable.h" +!> Allocates and initializes the ocean model vertical grid structure. +subroutine verticalGridInit( param_file, GV, US ) + type(param_file_type), intent(in) :: param_file !< Parameter file handle/type + type(verticalGrid_type), pointer :: GV !< The container for vertical grid data + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + ! This routine initializes the verticalGrid_type structure (GV). + ! All memory is allocated but not necessarily set to meaningful values until later. + + ! Local variables integer :: nk, H_power - real :: rescale_factor + real :: H_rescale_factor + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=16) :: mdl = 'MOM_verticalGrid' if (associated(GV)) call MOM_error(FATAL, & @@ -94,7 +99,7 @@ subroutine verticalGridInit( param_file, GV ) 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_z, & + call get_param(param_file, mdl, "ANGSTROM", GV%Angstrom_m, & "The minumum layer thickness, usually one-Angstrom.", & units="m", default=1.0e-10) call get_param(param_file, mdl, "H_RESCALE_POWER", H_power, & @@ -103,20 +108,21 @@ subroutine verticalGridInit( param_file, GV ) units="nondim", default=0, debuggingParam=.true.) if (abs(H_power) > 300) call MOM_error(FATAL, "verticalGridInit: "//& "H_RESCALE_POWER is outside of the valid range of -300 to 300.") - rescale_factor = 1.0 - if (H_power /= 0) rescale_factor = 2.0**H_power + H_rescale_factor = 1.0 + 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"//& "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 * rescale_factor + 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"//& "units of thickness into m.", units="m H-1", default=1.0) - GV%H_to_m = GV%H_to_m * rescale_factor + GV%H_to_m = GV%H_to_m * H_rescale_factor endif + GV%g_Earth = GV%g_Earth * US%Z_to_m #ifdef STATIC_MEMORY_ ! Here NK_ is a macro, while nk is a variable. call get_param(param_file, mdl, "NK", nk, & @@ -135,39 +141,47 @@ subroutine verticalGridInit( param_file, GV ) GV%H_to_kg_m2 = GV%Rho0 * GV%H_to_m GV%kg_m2_to_H = 1.0 / GV%H_to_kg_m2 GV%m_to_H = 1.0 / GV%H_to_m - GV%Angstrom = GV%m_to_H * GV%Angstrom_z + GV%Angstrom_H = GV%m_to_H * GV%Angstrom_m else GV%kg_m2_to_H = 1.0 / GV%H_to_kg_m2 GV%m_to_H = GV%Rho0 * GV%kg_m2_to_H GV%H_to_m = GV%H_to_kg_m2 / GV%Rho0 - GV%Angstrom = GV%Angstrom_z*1000.0*GV%kg_m2_to_H + GV%Angstrom_H = GV%Angstrom_m*1000.0*GV%kg_m2_to_H endif - GV%H_subroundoff = 1e-20 * max(GV%Angstrom,GV%m_to_H*1e-17) - GV%H_to_Pa = GV%g_Earth * GV%H_to_kg_m2 + GV%H_subroundoff = 1e-20 * max(GV%Angstrom_H,GV%m_to_H*1e-17) + GV%H_to_Pa = (GV%g_Earth*US%m_to_Z) * GV%H_to_kg_m2 + + GV%H_to_Z = GV%H_to_m * US%m_to_Z + GV%Z_to_H = US%Z_to_m * GV%m_to_H + GV%Angstrom_Z = US%m_to_Z * GV%Angstrom_m ! Log derivative values. - call log_param(param_file, mdl, "M to THICKNESS", GV%m_to_H*rescale_factor) + call log_param(param_file, mdl, "M to THICKNESS", GV%m_to_H*H_rescale_factor) call log_param(param_file, mdl, "M to THICKNESS rescaled by 2^-n", GV%m_to_H) call log_param(param_file, mdl, "THICKNESS to M rescaled by 2^n", GV%H_to_m) - ALLOC_( GV%sInterface(nk+1) ) - ALLOC_( GV%sLayer(nk) ) - ALLOC_( GV%g_prime(nk+1) ) ; GV%g_prime(:) = 0.0 + allocate( GV%sInterface(nk+1) ) + allocate( GV%sLayer(nk) ) + allocate( GV%g_prime(nk+1) ) ; GV%g_prime(:) = 0.0 ! The extent of Rlay should be changed to nk? - ALLOC_( GV%Rlay(nk+1) ) ; GV%Rlay(:) = 0.0 + allocate( GV%Rlay(nk+1) ) ; GV%Rlay(:) = 0.0 end subroutine verticalGridInit +!> Set the scaling factors for restart files to the scaling factors for this run. +subroutine fix_restart_scaling(GV) + type(verticalGrid_type), intent(inout) :: GV !< The ocean's vertical grid structure + + GV%m_to_H_restart = GV%m_to_H +end subroutine fix_restart_scaling + !> Returns the model's thickness units, usually m or kg/m^2. function get_thickness_units(GV) - character(len=48) :: get_thickness_units + character(len=48) :: get_thickness_units !< The vertical thickness units type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure -! This subroutine returns the appropriate units for thicknesses, -! depending on whether the model is Boussinesq or not and the scaling for -! the vertical thickness. - -! Arguments: G - The ocean's grid structure. -! (ret) get_thickness_units - The model's vertical thickness units. + ! This subroutine returns the appropriate units for thicknesses, + ! depending on whether the model is Boussinesq or not and the scaling for + ! the vertical thickness. if (GV%Boussinesq) then get_thickness_units = "m" @@ -178,14 +192,11 @@ end function get_thickness_units !> Returns the model's thickness flux units, usually m^3/s or kg/s. function get_flux_units(GV) - character(len=48) :: get_flux_units + character(len=48) :: get_flux_units !< The thickness flux units type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure -! This subroutine returns the appropriate units for thickness fluxes, -! depending on whether the model is Boussinesq or not and the scaling for -! the vertical thickness. - -! Arguments: G - The ocean's grid structure. -! (ret) get_flux_units - The model's thickness flux units. + ! This subroutine returns the appropriate units for thickness fluxes, + ! depending on whether the model is Boussinesq or not and the scaling for + ! the vertical thickness. if (GV%Boussinesq) then get_flux_units = "m3 s-1" @@ -203,7 +214,7 @@ function get_tr_flux_units(GV, tr_units, tr_vol_conc_units, tr_mass_conc_units) character(len=*), optional, intent(in) :: tr_units !< Units for a tracer, for example !! Celsius or PSU. character(len=*), optional, intent(in) :: tr_vol_conc_units !< The concentration units per unit - !! volume, forexample if the units are + !! volume, for example if the units are !! umol m-3, tr_vol_conc_units would !! be umol. character(len=*), optional, intent(in) :: tr_mass_conc_units !< The concentration units per unit @@ -211,20 +222,9 @@ function get_tr_flux_units(GV, tr_units, tr_vol_conc_units, tr_mass_conc_units) !! the units are mol kg-1, !! tr_vol_conc_units would be mol. -! This subroutine returns the appropriate units for thicknesses and fluxes, -! depending on whether the model is Boussinesq or not and the scaling for -! the vertical thickness. - -! Arguments: G - The ocean's grid structure. -! One of the following three arguments must be present. -! (in,opt) tr_units - Units for a tracer, for example Celsius or PSU. -! (in,opt) tr_vol_conc_units - The concentration units per unit volume, for -! example if the units are umol m-3, -! tr_vol_conc_units would be umol. -! (in,opt) tr_mass_conc_units - The concentration units per unit mass of sea -! water, for example if the units are mol kg-1, -! tr_vol_conc_units would be mol. -! (ret) get_tr_flux_units - The model's flux units for a tracer. + ! This subroutine returns the appropriate units for thicknesses and fluxes, + ! depending on whether the model is Boussinesq or not and the scaling for + ! the vertical thickness. integer :: cnt cnt = 0 @@ -263,7 +263,6 @@ end function get_tr_flux_units !> This sets the coordinate data for the "layer mode" of the isopycnal model. subroutine setVerticalGridAxes( Rlay, GV ) - ! Arguments type(verticalGrid_type), intent(inout) :: GV !< The container for vertical grid data real, dimension(GV%ke), intent(in) :: Rlay !< The layer target density ! Local variables @@ -286,12 +285,10 @@ end subroutine setVerticalGridAxes !> Deallocates the model's vertical grid structure. subroutine verticalGridEnd( GV ) -! Arguments: G - The ocean's grid structure. - type(verticalGrid_type), pointer :: GV !< The ocean's vertical grid structure + type(verticalGrid_type), pointer :: GV !< The ocean's vertical grid structure - DEALLOC_(GV%g_prime) ; DEALLOC_(GV%Rlay) - DEALLOC_( GV%sInterface ) - DEALLOC_( GV%sLayer ) + deallocate( GV%g_prime, GV%Rlay ) + deallocate( GV%sInterface , GV%sLayer ) deallocate( GV ) end subroutine verticalGridEnd diff --git a/src/diagnostics/MOM_PointAccel.F90 b/src/diagnostics/MOM_PointAccel.F90 index 37d3433330..a642cd0205 100644 --- a/src/diagnostics/MOM_PointAccel.F90 +++ b/src/diagnostics/MOM_PointAccel.F90 @@ -1,31 +1,14 @@ +!> Debug accelerations at a given point +!! +!! The two subroutines in this file write out all of the terms +!! in the u- or v-momentum balance at a given point. Usually +!! these subroutines are called after the velocities exceed some +!! threshold, in order to determine which term is culpable. +!! often this is done for debugging purposes. module MOM_PointAccel ! This file is part of MOM6. See LICENSE.md for the license. -!*********************************************************************** -!* * -!* The two subroutines in this file write out all of the terms * -!* in the u- or v-momentum balance at a given point. Usually * -!* these subroutines are called after the velocities exceed some * -!* threshold, in order to determine which term is culpable. * -!* often this is done for debugging purposes. * -!* * -!* Macros written all in capital letters are defined in MOM_memory.h * -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q, CoriolisBu * -!* j+1 > o > o > At ^: v, PFv, CAv, vh, diffv, vbt, vhtr * -!* j x ^ x ^ x At >: u, PFu, CAu, uh, diffu, ubt, uhtr * -!* j > o > o > At o: h, bathyT, tr, T, S * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** - use MOM_diag_mediator, only : diag_ctrl use MOM_domains, only : pe_here use MOM_error_handler, only : MOM_error, NOTE @@ -35,6 +18,7 @@ module MOM_PointAccel use MOM_io, only : open_file use MOM_io, only : APPEND_FILE, ASCII_FILE, MULTIPLE, SINGLE_FILE use MOM_time_manager, only : time_type, get_time, get_date, set_date, operator(-) +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : ocean_internal_state, accel_diag_ptrs, cont_diag_ptrs use MOM_verticalGrid, only : verticalGrid_type @@ -44,32 +28,36 @@ module MOM_PointAccel public write_u_accel, write_v_accel, PointAccel_init +!> The control structure for the MOM_PointAccel module type, public :: PointAccel_CS ; private - character(len=200) :: u_trunc_file ! The complete path to files in which a - character(len=200) :: v_trunc_file ! column's worth of accelerations are - ! written if velocity truncations occur. - integer :: u_file, v_file ! The unit numbers for opened u- or v- truncation - ! files, or -1 if they have not yet been opened. - integer :: cols_written ! The number of columns whose output has been - ! written by this PE during the current run. - integer :: max_writes ! The maximum number of times any PE can write out - ! a column's worth of accelerations during a run. - type(time_type), pointer :: Time ! A pointer to the ocean model's clock. - type(diag_ctrl), pointer :: diag ! A pointer to a structure of shareable - ! ocean diagnostic fields. + character(len=200) :: u_trunc_file !< The complete path to the file in which a column's worth of + !! u-accelerations are written if u-velocity truncations occur. + character(len=200) :: v_trunc_file !< The complete path to the file in which a column's worth of + !! v-accelerations are written if v-velocity truncations occur. + integer :: u_file !< The unit number for an opened u-truncation files, or -1 if it has not yet been opened. + integer :: v_file !< The unit number for an opened v-truncation files, or -1 if it has not yet been opened. + integer :: cols_written !< The number of columns whose output has been + !! written by this PE during the current run. + integer :: max_writes !< The maximum number of times any PE can write out + !! a column's worth of accelerations during a run. + type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. ! The following are pointers to many of the state variables and accelerations ! that are used to step the physical model forward. They all use the same ! names as the variables they point to in MOM.F90 real, pointer, dimension(:,:,:) :: & - u_av => NULL(), v_av => NULL(), & ! Time average velocities in m s-1. - u_prev => NULL(), v_prev => NULL(), & ! Previous velocities in m s-1. - T => NULL(), S => NULL(), & ! Temperature and salinity in C and psu. - pbce => NULL(), & ! pbce times eta gives the baroclinic - ! pressure anomaly in each layer due to - ! free surface height anomalies. - ! pbce has units of m s-2. - u_accel_bt => NULL(), & ! Barotropic acclerations in m s-2. - v_accel_bt => NULL() + u_av => NULL(), & !< Time average u-velocity [m s-1]. + v_av => NULL(), & !< Time average velocity [m s-1]. + u_prev => NULL(), & !< Previous u-velocity [m s-1]. + v_prev => NULL(), & !< Previous v-velocity [m s-1]. + T => NULL(), & !< Temperature [degC]. + S => NULL(), & !< Salinity [ppt]. + u_accel_bt => NULL(), & !< Barotropic u-acclerations [m s-2] + v_accel_bt => NULL() !< Barotropic v-acclerations [m s-2] + real, pointer, dimension(:,:,:) :: pbce => NULL() !< pbce times eta gives the baroclinic + !! pressure anomaly in each layer due to free surface height anomalies + !! [m2 s-2 H-1 ~> m s-2 or m4 kg-1 s-2]. end type PointAccel_CS @@ -78,62 +66,38 @@ module MOM_PointAccel !> This subroutine writes to an output file all of the accelerations !! that have been applied to a column of zonal velocities over the !! previous timestep. This subroutine is called from vertvisc. -subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, CS, & - maxvel, minvel, str, a, hv) +subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, str, a, hv) integer, intent(in) :: I !< The zonal index of the column to be documented. - integer, intent(in) :: j !< The meridional index of the column to be - !! documented. + integer, intent(in) :: j !< The meridional index of the column to be documented. 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 real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & - intent(in) :: um !< The new zonal velocity, in m s-1. + intent(in) :: um !< The new zonal velocity [m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: hin !< The layer thickness, in m. + intent(in) :: hin !< The layer thickness [H ~> m or kg m-2]. type(accel_diag_ptrs), intent(in) :: ADp !< A structure pointing to the various !! accelerations in the momentum equations. type(cont_diag_ptrs), intent(in) :: CDp !< A structure with pointers to various terms !! in the continuity equations. - real, intent(in) :: dt !< The ocean dynamics time step, in s. + real, intent(in) :: dt !< The ocean dynamics time step [s]. type(PointAccel_CS), pointer :: CS !< The control structure returned by a previous !! call to PointAccel_init. - real, intent(in) :: maxvel, minvel + real, intent(in) :: vel_rpt !< The velocity magnitude that triggers a report [m s-1]. real, optional, intent(in) :: str !< The surface wind stress integrated over a time - !! step, in m2 s-1. - real, dimension(SZIB_(G),SZK_(G)), & - optional, intent(in) :: a !< The layer coupling coefficients from - !! vertvisc, m. - real, dimension(SZIB_(G),SZK_(G)), & + !! step divided by the Boussinesq density [m2 s-1]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + optional, intent(in) :: a !< The layer coupling coefficients from vertvisc [Z s-1 ~> m s-1]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & optional, intent(in) :: hv !< The layer thicknesses at velocity grid points, - !! from vertvisc, in m. - -! This subroutine writes to an output file all of the accelerations -! that have been applied to a column of zonal velocities over the -! previous timestep. This subroutine is called from vertvisc. - -! Arguments: I - The zonal index of the column to be documented. -! (in) j - The meridional index of the column to be documented. -! (in) um - The new zonal velocity, in m s-1. -! (in) hin - The layer thickness, in m. -! (in) ADp - A structure pointing to the various accelerations in -! the momentum equations. -! (in) CDp - A structure with pointers to various terms in the continuity -! equations. -! (in) dt - The model's dynamics time step. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - The control structure returned by a previous call to -! PointAccel_init. -! (in) str - The surface wind stress integrated over a time -! step, in m2 s-1. -! (in) a - The layer coupling coefficients from vertvisc, m. -! (in) hv - The layer thicknesses at velocity grid points, from -! vertvisc, in m. - + !! from vertvisc [H ~> m or kg m-2]. + ! Local variables real :: f_eff, CFL real :: Angstrom real :: truncvel, du real :: Inorm(SZK_(G)) real :: e(SZK_(G)+1) + real :: h_scale, uh_scale integer :: yr, mo, day, hr, minute, sec, yearday integer :: k, ks, ke integer :: nz @@ -141,7 +105,8 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, CS, & logical :: prev_avail integer :: file - Angstrom = GV%Angstrom + GV%H_subroundoff + Angstrom = GV%Angstrom_H + GV%H_subroundoff + h_scale = GV%H_to_m ; uh_scale = GV%H_to_m ! if (.not.associated(CS)) return nz = G%ke @@ -167,14 +132,14 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, CS, & ! Determine which layers to write out accelerations for. do k=1,nz - if (((max(CS%u_av(I,j,k),um(I,j,k)) >= maxvel) .or. & - (min(CS%u_av(I,j,k),um(I,j,k)) <= minvel)) .and. & + if (((max(CS%u_av(I,j,k),um(I,j,k)) >= vel_rpt) .or. & + (min(CS%u_av(I,j,k),um(I,j,k)) <= -vel_rpt)) .and. & ((hin(i,j,k) + hin(i+1,j,k)) > 3.0*Angstrom)) exit enddo ks = k do k=nz,1,-1 - if (((max(CS%u_av(I,j,k), um(I,j,k)) >= maxvel) .or. & - (min(CS%u_av(I,j,k), um(I,j,k)) <= minvel)) .and. & + if (((max(CS%u_av(I,j,k), um(I,j,k)) >= vel_rpt) .or. & + (min(CS%u_av(I,j,k), um(I,j,k)) <= -vel_rpt)) .and. & ((hin(i,j,k) + hin(i+1,j,k)) > 3.0*Angstrom)) exit enddo ke = k @@ -254,11 +219,11 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, CS, & endif if (present(a)) then write(file,'(/,"a: ",$)') - do k=ks,ke+1 ; if (do_k(k)) write(file,'(ES10.3," ",$)') a(I,k); enddo + do k=ks,ke+1 ; if (do_k(k)) write(file,'(ES10.3," ",$)') a(I,j,k)*US%Z_to_m*dt; enddo endif if (present(hv)) then write(file,'(/,"hvel: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') hv(I,k); enddo + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') hv(I,j,k); enddo endif write(file,'(/,"Stress: ",ES10.3)') str @@ -270,27 +235,27 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, CS, & endif write(file,'(/,"h--: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (hin(i,j-1,k)); enddo + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (h_scale*hin(i,j-1,k)); enddo write(file,'(/,"h+-: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (hin(i+1,j-1,k)); enddo + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (h_scale*hin(i+1,j-1,k)); enddo write(file,'(/,"h-0: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (hin(i,j,k)); enddo + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (h_scale*hin(i,j,k)); enddo write(file,'(/,"h+0: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (hin(i+1,j,k)); enddo + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (h_scale*hin(i+1,j,k)); enddo write(file,'(/,"h-+: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (hin(i,j+1,k)); enddo + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (h_scale*hin(i,j+1,k)); enddo write(file,'(/,"h++: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (hin(i+1,j+1,k)); enddo + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (h_scale*hin(i+1,j+1,k)); enddo - e(nz+1) = -G%bathyT(i,j) - do k=nz,1,-1 ; e(K) = e(K+1) + hin(i,j,k) ; enddo + e(nz+1) = -US%Z_to_m*G%bathyT(i,j) + do k=nz,1,-1 ; e(K) = e(K+1) + h_scale*hin(i,j,k) ; enddo write(file,'(/,"e-: ",$)') write(file,'(ES10.3," ",$)') e(ks) do K=ks+1,ke+1 ; if (do_k(k-1)) write(file,'(ES10.3," ",$)') e(K); enddo - e(nz+1) = -G%bathyT(i+1,j) - do k=nz,1,-1 ; e(K) = e(K+1) + hin(i+1,j,k) ; enddo + e(nz+1) = -US%Z_to_m*G%bathyT(i+1,j) + do k=nz,1,-1 ; e(K) = e(K+1) + h_scale*hin(i+1,j,k) ; enddo write(file,'(/,"e+: ",$)') write(file,'(ES10.3," ",$)') e(ks) do K=ks+1,ke+1 ; if (do_k(k-1)) write(file,'(ES10.3," ",$)') e(K) ; enddo @@ -320,53 +285,53 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, CS, & write(file,'(/,"vh--: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (CDp%vh(i,J-1,k)*G%IdxCv(i,J-1)); enddo + (uh_scale*CDp%vh(i,J-1,k)*G%IdxCv(i,J-1)); enddo write(file,'(/," vhC--:",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (0.5*CS%v_av(i,j-1,k)*(hin(i,j-1,k) + hin(i,j,k))); enddo + (0.5*CS%v_av(i,j-1,k)*h_scale*(hin(i,j-1,k) + hin(i,j,k))); enddo if (prev_avail) then write(file,'(/," vhCp--:",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (0.5*CS%v_prev(i,j-1,k)*(hin(i,j-1,k) + hin(i,j,k))); enddo + (0.5*CS%v_prev(i,j-1,k)*h_scale*(hin(i,j-1,k) + hin(i,j,k))); enddo endif write(file,'(/,"vh-+: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (CDp%vh(i,J,k)*G%IdxCv(i,J)); enddo + (uh_scale*CDp%vh(i,J,k)*G%IdxCv(i,J)); enddo write(file,'(/," vhC-+:",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (0.5*CS%v_av(i,J,k)*(hin(i,j,k) + hin(i,j+1,k))); enddo + (0.5*CS%v_av(i,J,k)*h_scale*(hin(i,j,k) + hin(i,j+1,k))); enddo if (prev_avail) then write(file,'(/," vhCp-+:",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (0.5*CS%v_prev(i,J,k)*(hin(i,j,k) + hin(i,j+1,k))); enddo + (0.5*CS%v_prev(i,J,k)*h_scale*(hin(i,j,k) + hin(i,j+1,k))); enddo endif write(file,'(/,"vh+-: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (CDp%vh(i+1,J-1,k)*G%IdxCv(i+1,J-1)); enddo + (uh_scale*CDp%vh(i+1,J-1,k)*G%IdxCv(i+1,J-1)); enddo write(file,'(/," vhC+-:",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (0.5*CS%v_av(i+1,J-1,k)*(hin(i+1,j-1,k) + hin(i+1,j,k))); enddo + (0.5*CS%v_av(i+1,J-1,k)*h_scale*(hin(i+1,j-1,k) + hin(i+1,j,k))); enddo if (prev_avail) then write(file,'(/," vhCp+-:",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (0.5*CS%v_prev(i+1,J-1,k)*(hin(i+1,j-1,k) + hin(i+1,j,k))); enddo + (0.5*CS%v_prev(i+1,J-1,k)*h_scale*(hin(i+1,j-1,k) + hin(i+1,j,k))); enddo endif write(file,'(/,"vh++: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (CDp%vh(i+1,J,k)*G%IdxCv(i+1,J)); enddo + (uh_scale*CDp%vh(i+1,J,k)*G%IdxCv(i+1,J)); enddo write(file,'(/," vhC++:",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (0.5*CS%v_av(i+1,J,k)*(hin(i+1,j,k) + hin(i+1,j+1,k))); enddo + (0.5*CS%v_av(i+1,J,k)*h_scale*(hin(i+1,j,k) + hin(i+1,j+1,k))); enddo if (prev_avail) then write(file,'(/," vhCp++:",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (0.5*CS%v_av(i+1,J,k)*(hin(i+1,j,k) + hin(i+1,j+1,k))); enddo + (0.5*CS%v_av(i+1,J,k)*h_scale*(hin(i+1,j,k) + hin(i+1,j+1,k))); enddo endif - write(file,'(/,"D: ",2(ES10.3))') G%bathyT(i,j),G%bathyT(i+1,j) + write(file,'(/,"D: ",2(ES10.3))') US%Z_to_m*G%bathyT(i,j),US%Z_to_m*G%bathyT(i+1,j) ! From here on, the normalized accelerations are written. if (prev_avail) then @@ -432,62 +397,38 @@ end subroutine write_u_accel !> This subroutine writes to an output file all of the accelerations !! that have been applied to a column of meridional velocities over !! the previous timestep. This subroutine is called from vertvisc. -subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, CS, & - maxvel, minvel, str, a, hv) +subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, str, a, hv) integer, intent(in) :: i !< The zonal index of the column to be documented. - integer, intent(in) :: J !< The meridional index of the column to be - !! documented. + integer, intent(in) :: J !< The meridional index of the column to be documented. 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 real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & - intent(in) :: vm !< The new meridional velocity, in m s-1. + intent(in) :: vm !< The new meridional velocity [m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: hin !< The layer thickness, in m. + intent(in) :: hin !< The layer thickness [H ~> m or kg m-2]. type(accel_diag_ptrs), intent(in) :: ADp !< A structure pointing to the various !! accelerations in the momentum equations. type(cont_diag_ptrs), intent(in) :: CDp !< A structure with pointers to various terms in !! the continuity equations. - real, intent(in) :: dt !< The ocean dynamics time step, in s. + real, intent(in) :: dt !< The ocean dynamics time step [s]. type(PointAccel_CS), pointer :: CS !< The control structure returned by a previous !! call to PointAccel_init. - real, intent(in) :: maxvel, minvel + real, intent(in) :: vel_rpt !< The velocity magnitude that triggers a report [m s-1]. real, optional, intent(in) :: str !< The surface wind stress integrated over a time - !! step, in m2 s-1. - real, dimension(SZI_(G),SZK_(G)), & - optional, intent(in) :: a !< The layer coupling coefficients from - !! vertvisc, m. - real, dimension(SZI_(G),SZK_(G)), & + !! step divided by the Boussinesq density [m2 s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + optional, intent(in) :: a !< The layer coupling coefficients from vertvisc [Z s-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & optional, intent(in) :: hv !< The layer thicknesses at velocity grid points, - !! from vertvisc, in m. - -! This subroutine writes to an output file all of the accelerations -! that have been applied to a column of meridional velocities over -! the previous timestep. This subroutine is called from vertvisc. - -! Arguments: i - The zonal index of the column to be documented. -! (in) J - The meridional index of the column to be documented. -! (in) vm - The new meridional velocity, in m s-1. -! (in) hin - The layer thickness, in m. -! (in) ADp - A structure pointing to the various accelerations in -! the momentum equations. -! (in) CDp - A structure with pointers to various terms in the continuity -! equations. -! (in) dt - The model's dynamics time step. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - The control structure returned by a previous call to -! PointAccel_init. -! (in) str - The surface wind stress integrated over a time -! step, in m2 s-1. -! (in) a - The layer coupling coefficients from vertvisc, m. -! (in) hv - The layer thicknesses at velocity grid points, from -! vertvisc, in m. - + !! from vertvisc [H ~> m or kg m-2]. + ! Local variables real :: f_eff, CFL real :: Angstrom real :: truncvel, dv real :: Inorm(SZK_(G)) real :: e(SZK_(G)+1) + real :: h_scale, uh_scale integer :: yr, mo, day, hr, minute, sec, yearday integer :: k, ks, ke integer :: nz @@ -495,7 +436,8 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, CS, & logical :: prev_avail integer :: file - Angstrom = GV%Angstrom + GV%H_subroundoff + Angstrom = GV%Angstrom_H + GV%H_subroundoff + h_scale = GV%H_to_m ; uh_scale = GV%H_to_m ! if (.not.associated(CS)) return nz = G%ke @@ -520,14 +462,14 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, CS, & prev_avail = (associated(CS%u_prev) .and. associated(CS%v_prev)) do k=1,nz - if (((max(CS%v_av(i,J,k), vm(i,J,k)) >= maxvel) .or. & - (min(CS%v_av(i,J,k), vm(i,J,k)) <= minvel)) .and. & + if (((max(CS%v_av(i,J,k), vm(i,J,k)) >= vel_rpt) .or. & + (min(CS%v_av(i,J,k), vm(i,J,k)) <= -vel_rpt)) .and. & ((hin(i,j,k) + hin(i,j+1,k)) > 3.0*Angstrom)) exit enddo ks = k do k=nz,1,-1 - if (((max(CS%v_av(i,J,k), vm(i,J,k)) >= maxvel) .or. & - (min(CS%v_av(i,J,k), vm(i,J,k)) <= minvel)) .and. & + if (((max(CS%v_av(i,J,k), vm(i,J,k)) >= vel_rpt) .or. & + (min(CS%v_av(i,J,k), vm(i,J,k)) <= -vel_rpt)) .and. & ((hin(i,j,k) + hin(i,j+1,k)) > 3.0*Angstrom)) exit enddo ke = k @@ -612,11 +554,11 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, CS, & endif if (present(a)) then write(file,'(/,"a: ",$)') - do k=ks,ke+1 ; if (do_k(k)) write(file,'(ES10.3," ",$)') a(i,k); enddo + do k=ks,ke+1 ; if (do_k(k)) write(file,'(ES10.3," ",$)') a(i,j,k)*US%Z_to_m*dt; enddo endif if (present(hv)) then write(file,'(/,"hvel: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') hv(i,k); enddo + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') hv(i,J,k); enddo endif write(file,'(/,"Stress: ",ES10.3)') str @@ -628,26 +570,26 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, CS, & endif write(file,'("h--: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') hin(i-1,j,k); enddo + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') h_scale*hin(i-1,j,k); enddo write(file,'(/,"h0-: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') hin(i,j,k); enddo + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') h_scale*hin(i,j,k); enddo write(file,'(/,"h+-: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') hin(i+1,j,k); enddo + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') h_scale*hin(i+1,j,k); enddo write(file,'(/,"h-+: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') hin(i-1,j+1,k); enddo + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') h_scale*hin(i-1,j+1,k); enddo write(file,'(/,"h0+: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') hin(i,j+1,k); enddo + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') h_scale*hin(i,j+1,k); enddo write(file,'(/,"h++: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') hin(i+1,j+1,k); enddo + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') h_scale*hin(i+1,j+1,k); enddo - e(nz+1) = -G%bathyT(i,j) - do k=nz,1,-1 ; e(K) = e(K+1) + hin(i,j,k); enddo + e(nz+1) = -US%Z_to_m*G%bathyT(i,j) + do k=nz,1,-1 ; e(K) = e(K+1) + h_scale*hin(i,j,k); enddo write(file,'(/,"e-: ",$)') write(file,'(ES10.3," ",$)') e(ks) do K=ks+1,ke+1 ; if (do_k(k-1)) write(file,'(ES10.3," ",$)') e(K); enddo - e(nz+1) = -G%bathyT(i,j+1) - do k=nz,1,-1 ; e(K) = e(K+1) + hin(i,j+1,k) ; enddo + e(nz+1) = -US%Z_to_m*G%bathyT(i,j+1) + do k=nz,1,-1 ; e(K) = e(K+1) + h_scale*hin(i,j+1,k) ; enddo write(file,'(/,"e+: ",$)') write(file,'(ES10.3," ",$)') e(ks) do K=ks+1,ke+1 ; if (do_k(k-1)) write(file,'(ES10.3," ",$)') e(K); enddo @@ -677,53 +619,53 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, CS, & write(file,'(/,"uh--: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (CDp%uh(I-1,j,k)*G%IdyCu(I-1,j)); enddo + (uh_scale*CDp%uh(I-1,j,k)*G%IdyCu(I-1,j)); enddo write(file,'(/," uhC--: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (CS%u_av(I-1,j,k) * 0.5*(hin(i-1,j,k) + hin(i,j,k))); enddo + (CS%u_av(I-1,j,k) * h_scale*0.5*(hin(i-1,j,k) + hin(i,j,k))); enddo if (prev_avail) then write(file,'(/," uhCp--:",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (0.5*CS%u_prev(I-1,j,k)*(hin(i-1,j,k) + hin(i,j,k))); enddo + (CS%u_prev(I-1,j,k) * h_scale*0.5*(hin(i-1,j,k) + hin(i,j,k))); enddo endif write(file,'(/,"uh-+: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (CDp%uh(I-1,j+1,k)*G%IdyCu(I-1,j+1)); enddo + (uh_scale*CDp%uh(I-1,j+1,k)*G%IdyCu(I-1,j+1)); enddo write(file,'(/," uhC-+: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (CS%u_av(I-1,j+1,k) * 0.5*(hin(i-1,j+1,k) + hin(i,j+1,k))); enddo + (CS%u_av(I-1,j+1,k) * h_scale*0.5*(hin(i-1,j+1,k) + hin(i,j+1,k))); enddo if (prev_avail) then write(file,'(/," uhCp-+:",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (0.5*CS%u_prev(I-1,j+1,k)*(hin(i-1,j+1,k) + hin(i,j+1,k))); enddo + (CS%u_prev(I-1,j+1,k) * h_scale*0.5*(hin(i-1,j+1,k) + hin(i,j+1,k))); enddo endif write(file,'(/,"uh+-: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (CDp%uh(I,j,k)*G%IdyCu(I,j)); enddo + (uh_scale*CDp%uh(I,j,k)*G%IdyCu(I,j)); enddo write(file,'(/," uhC+-: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (CS%u_av(I,j,k) * 0.5*(hin(i,j,k) + hin(i+1,j,k))); enddo + (CS%u_av(I,j,k) * h_scale*0.5*(hin(i,j,k) + hin(i+1,j,k))); enddo if (prev_avail) then write(file,'(/," uhCp+-:",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (0.5*CS%u_prev(I,j,k)*(hin(i,j,k) + hin(i+1,j,k))); enddo + (CS%u_prev(I,j,k) * h_scale*0.5*(hin(i,j,k) + hin(i+1,j,k))); enddo endif write(file,'(/,"uh++: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (CDp%uh(I,j+1,k)*G%IdyCu(I,j+1)); enddo + (uh_scale*CDp%uh(I,j+1,k)*G%IdyCu(I,j+1)); enddo write(file,'(/," uhC++: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (CS%u_av(I,j+1,k) * 0.5*(hin(i,j+1,k) + hin(i+1,j+1,k))); enddo + (CS%u_av(I,j+1,k) * 0.5*h_scale*(hin(i,j+1,k) + hin(i+1,j+1,k))); enddo if (prev_avail) then write(file,'(/," uhCp++:",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & - (0.5*CS%u_prev(I,j+1,k)*(hin(i,j+1,k) + hin(i+1,j+1,k))); enddo + (CS%u_prev(I,j+1,k) * h_scale*0.5*(hin(i,j+1,k) + hin(i+1,j+1,k))); enddo endif - write(file,'(/,"D: ",2(ES10.3))') G%bathyT(i,j),G%bathyT(i,j+1) + write(file,'(/,"D: ",2(ES10.3))') US%Z_to_m*G%bathyT(i,j),US%Z_to_m*G%bathyT(i,j+1) ! From here on, the normalized accelerations are written. if (prev_avail) then @@ -782,7 +724,7 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, CS, & end subroutine write_v_accel -! #@# This subroutine needs a doxygen description +!> This subroutine initializes the parameters regulating how truncations are logged. subroutine PointAccel_init(MIS, Time, G, param_file, diag, dirs, CS) type(ocean_internal_state), & target, intent(in) :: MIS !< For "MOM Internal State" a set of pointers @@ -798,17 +740,6 @@ subroutine PointAccel_init(MIS, Time, G, param_file, diag, dirs, CS) !! directory paths. type(PointAccel_CS), pointer :: CS !< A pointer that is set to point to the !! control structure for this module. - -! Arguments: MIS - For "MOM Internal State" a set of pointers to the fields and -! accelerations that make up the ocean's physical state. -! (in) Time - The current model time. -! (in) G - The ocean's grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in) diag - A structure that is used to regulate diagnostic output. -! (in) dirs - A structure containing several relevant directory paths. -! (in/out) CS - A pointer that is set to point to the control structure -! for this module ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "MOM_PointAccel" ! This module's name. @@ -851,4 +782,5 @@ subroutine PointAccel_init(MIS, Time, G, param_file, diag, dirs, CS) CS%u_file = -1 ; CS%v_file = -1 ; CS%cols_written = 0 end subroutine PointAccel_init + end module MOM_PointAccel diff --git a/src/diagnostics/MOM_debugging.F90 b/src/diagnostics/MOM_debugging.F90 index 4301368de9..79a56cae2f 100644 --- a/src/diagnostics/MOM_debugging.F90 +++ b/src/diagnostics/MOM_debugging.F90 @@ -1,14 +1,13 @@ +!> Provides checksumming functions for debugging +!! +!! This module contains subroutines that perform various error checking and +!! debugging functions for MOM6. This routine is similar to it counterpart in +!! the SIS2 code, except for the use of the ocean_grid_type and by keeping them +!! separate we retain the ability to set up MOM6 and SIS2 debugging separately. module MOM_debugging ! This file is part of MOM6. See LICENSE.md for the license. -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! -! This module contains subroutines that perform various error checking and ! -! debugging functions for MOM6. This routine is similar to it counterpart in ! -! the SIS2 code, except for the use of the ocean_grid_type and by keeping them ! -! separate we retain the ability to set up MOM6 and SIS2 debugging separately. ! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! - use MOM_checksums, only : hchksum, Bchksum, qchksum, uvchksum use MOM_checksums, only : is_NaN, chksum, MOM_checksums_init use MOM_coms, only : PE_here, root_PE, num_PEs, sum_across_PEs @@ -28,47 +27,54 @@ module MOM_debugging public :: check_column_integral, check_column_integrals ! These interfaces come from MOM_checksums. -public :: hchksum, Bchksum, qchksum, is_NaN, chksum -public :: uvchksum +public :: hchksum, Bchksum, qchksum, is_NaN, chksum, uvchksum +!> Check for consistency between the duplicated points of a C-grid vector interface check_redundant module procedure check_redundant_vC3d, check_redundant_vC2d end interface check_redundant +!> Check for consistency between the duplicated points of a C-grid vector interface check_redundant_C module procedure check_redundant_vC3d, check_redundant_vC2d end interface check_redundant_C +!> Check for consistency between the duplicated points of a B-grid vector or scalar interface check_redundant_B module procedure check_redundant_vB3d, check_redundant_vB2d module procedure check_redundant_sB3d, check_redundant_sB2d end interface check_redundant_B +!> Check for consistency between the duplicated points of an A-grid vector or scalar interface check_redundant_T module procedure check_redundant_sT3d, check_redundant_sT2d module procedure check_redundant_vT3d, check_redundant_vT2d end interface check_redundant_T +!> Do checksums on the components of a C-grid vector interface vec_chksum module procedure chksum_vec_C3d, chksum_vec_C2d end interface vec_chksum +!> Do checksums on the components of a C-grid vector interface vec_chksum_C module procedure chksum_vec_C3d, chksum_vec_C2d end interface vec_chksum_C +!> Do checksums on the components of a B-grid vector interface vec_chksum_B module procedure chksum_vec_B3d, chksum_vec_B2d end interface vec_chksum_B +!> Do checksums on the components of an A-grid vector interface vec_chksum_A module procedure chksum_vec_A3d, chksum_vec_A2d end interface vec_chksum_A -integer :: max_redundant_prints = 100 -integer :: redundant_prints(3) = 0 -logical :: debug = .false. -logical :: debug_chksums = .true. -logical :: debug_redundant = .true. +! Note: these parameters are module data but ONLY used when debugging and +! so can violate the thread-safe requirement of no module/global data. +integer :: max_redundant_prints = 100 !< Maximum number of times to write redundant messages +integer :: redundant_prints(3) = 0 !< Counters for controlling redundant printing +logical :: debug = .false. !< Write out verbose debugging data +logical :: debug_chksums = .true. !< Perform checksums on arrays +logical :: debug_redundant = .true. !< Check redundant values on PE boundaries contains -! ===================================================================== - !> MOM_debugging_init initializes the MOM_debugging module, and sets !! the parameterts that control which checks are active for MOM6. subroutine MOM_debugging_init(param_file) @@ -94,21 +100,22 @@ subroutine MOM_debugging_init(param_file) end subroutine MOM_debugging_init +!> Check for consistency between the duplicated points of a 3-D C-grid vector subroutine check_redundant_vC3d(mesg, u_comp, v_comp, G, is, ie, js, je, & direction) - character(len=*), intent(in) :: mesg - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%IsdB:,G%jsd:,:), intent(in) :: u_comp - real, dimension(G%isd:,G%JsdB:,:), intent(in) :: v_comp - integer, optional, intent(in) :: is, ie, js, je - integer, optional, intent(in) :: direction -! Arguments: u_comp - The u-component of the vector being checked. -! (in) v_comp - The v-component of the vector being checked. -! (in) mesg - A message indicating what is being checked. -! (in) G - The ocean's grid structure. -! (in/opt) is, ie, js, je - the i- and j- range of indices to check. -! (in/opt) direction - the direction flag to be passed to pass_vector. - + character(len=*), intent(in) :: mesg !< An identifying message + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(G%IsdB:,G%jsd:,:), intent(in) :: u_comp !< The u-component of the vector + !! to be checked for consistency + real, dimension(G%isd:,G%JsdB:,:), intent(in) :: v_comp !< The u-component of the vector + !! to be checked for consistency + integer, optional, intent(in) :: is !< The starting i-index to check + integer, optional, intent(in) :: ie !< The ending i-index to check + integer, optional, intent(in) :: js !< The starting j-index to check + integer, optional, intent(in) :: je !< The ending j-index to check + integer, optional, intent(in) :: direction !< the direction flag to be + !! passed to pass_vector + ! Local variables character(len=24) :: mesg_k integer :: k @@ -123,29 +130,30 @@ subroutine check_redundant_vC3d(mesg, u_comp, v_comp, G, is, ie, js, je, & enddo end subroutine check_redundant_vC3d +!> Check for consistency between the duplicated points of a 2-D C-grid vector subroutine check_redundant_vC2d(mesg, u_comp, v_comp, G, is, ie, js, je, & direction) - character(len=*), intent(in) :: mesg - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%IsdB:,G%jsd:), intent(in) :: u_comp - real, dimension(G%isd:,G%JsdB:), intent(in) :: v_comp - integer, optional, intent(in) :: is, ie, js, je - integer, optional, intent(in) :: direction -! Arguments: u_comp - The u-component of the vector being checked. -! (in) v_comp - The v-component of the vector being checked. -! (in) mesg - A message indicating what is being checked. -! (in) G - The ocean's grid structure. -! (in/opt) is, ie, js, je - the i- and j- range of indices to check. -! (in/opt) direction - the direction flag to be passed to pass_vector. - + character(len=*), intent(in) :: mesg !< An identifying message + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(G%IsdB:,G%jsd:), intent(in) :: u_comp !< The u-component of the vector + !! to be checked for consistency + real, dimension(G%isd:,G%JsdB:), intent(in) :: v_comp !< The u-component of the vector + !! to be checked for consistency + integer, optional, intent(in) :: is !< The starting i-index to check + integer, optional, intent(in) :: ie !< The ending i-index to check + integer, optional, intent(in) :: js !< The starting j-index to check + integer, optional, intent(in) :: je !< The ending j-index to check + integer, optional, intent(in) :: direction !< the direction flag to be + !! passed to pass_vector + ! Local variables real :: u_nonsym(G%isd:G%ied,G%jsd:G%jed) real :: v_nonsym(G%isd:G%ied,G%jsd:G%jed) real :: u_resym(G%IsdB:G%IedB,G%jsd:G%jed) real :: v_resym(G%isd:G%ied,G%JsdB:G%JedB) character(len=128) :: mesg2 - integer :: i, j, is_ch, ie_ch, js_ch, je_ch integer :: Isq, Ieq, Jsq, Jeq, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB @@ -198,16 +206,17 @@ subroutine check_redundant_vC2d(mesg, u_comp, v_comp, G, is, ie, js, je, & end subroutine check_redundant_vC2d +!> Check for consistency between the duplicated points of a 3-D scalar at corner points subroutine check_redundant_sB3d(mesg, array, G, is, ie, js, je) - character(len=*), intent(in) :: mesg - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: array - integer, optional, intent(in) :: is, ie, js, je -! Arguments: array - The array being checked. -! (in) mesg - A message indicating what is being checked. -! (in) G - The ocean's grid structure. -! (in/opt) is, ie, js, je - the i- and j- range of indices to check. + character(len=*), intent(in) :: mesg !< An identifying message + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: array !< The array to be checked for consistency + integer, optional, intent(in) :: is !< The starting i-index to check + integer, optional, intent(in) :: ie !< The ending i-index to check + integer, optional, intent(in) :: js !< The starting j-index to check + integer, optional, intent(in) :: je !< The ending j-index to check + ! Local variables character(len=24) :: mesg_k integer :: k @@ -222,23 +231,22 @@ subroutine check_redundant_sB3d(mesg, array, G, is, ie, js, je) enddo end subroutine check_redundant_sB3d - +!> Check for consistency between the duplicated points of a 2-D scalar at corner points subroutine check_redundant_sB2d(mesg, array, G, is, ie, js, je) - character(len=*), intent(in) :: mesg - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%IsdB:,G%JsdB:), intent(in) :: array - integer, optional, intent(in) :: is, ie, js, je -! Arguments: array - The array being checked. -! (in) mesg - A message indicating what is being checked. -! (in) G - The ocean's grid structure. -! (in/opt) is, ie, js, je - the i- and j- range of indices to check. - + character(len=*), intent(in) :: mesg !< An identifying message + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(G%IsdB:,G%JsdB:), intent(in) :: array !< The array to be checked for consistency + integer, optional, intent(in) :: is !< The starting i-index to check + integer, optional, intent(in) :: ie !< The ending i-index to check + integer, optional, intent(in) :: js !< The starting j-index to check + integer, optional, intent(in) :: je !< The ending j-index to check + ! Local variables real :: a_nonsym(G%isd:G%ied,G%jsd:G%jed) real :: a_resym(G%IsdB:G%IedB,G%JsdB:G%JedB) character(len=128) :: mesg2 - integer :: i, j, is_ch, ie_ch, js_ch, je_ch integer :: Isq, Ieq, Jsq, Jeq, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB @@ -281,22 +289,22 @@ subroutine check_redundant_sB2d(mesg, array, G, is, ie, js, je) end subroutine check_redundant_sB2d - +!> Check for consistency between the duplicated points of a 3-D B-grid vector subroutine check_redundant_vB3d(mesg, u_comp, v_comp, G, is, ie, js, je, & direction) - character(len=*), intent(in) :: mesg - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: u_comp - real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: v_comp - integer, optional, intent(in) :: is, ie, js, je - integer, optional, intent(in) :: direction -! Arguments: u_comp - The u-component of the vector being checked. -! (in) v_comp - The v-component of the vector being checked. -! (in) mesg - A message indicating what is being checked. -! (in) G - The ocean's grid structure. -! (in/opt) is, ie, js, je - the i- and j- range of indices to check. -! (in/opt) direction - the direction flag to be passed to pass_vector. - + character(len=*), intent(in) :: mesg !< An identifying message + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: u_comp !< The u-component of the vector + !! to be checked for consistency + real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: v_comp !< The v-component of the vector + !! to be checked for consistency + integer, optional, intent(in) :: is !< The starting i-index to check + integer, optional, intent(in) :: ie !< The ending i-index to check + integer, optional, intent(in) :: js !< The starting j-index to check + integer, optional, intent(in) :: je !< The ending j-index to check + integer, optional, intent(in) :: direction !< the direction flag to be + !! passed to pass_vector + ! Local variables character(len=24) :: mesg_k integer :: k @@ -311,29 +319,30 @@ subroutine check_redundant_vB3d(mesg, u_comp, v_comp, G, is, ie, js, je, & enddo end subroutine check_redundant_vB3d +!> Check for consistency between the duplicated points of a 2-D B-grid vector subroutine check_redundant_vB2d(mesg, u_comp, v_comp, G, is, ie, js, je, & direction) - character(len=*), intent(in) :: mesg - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%IsdB:,G%JsdB:), intent(in) :: u_comp - real, dimension(G%IsdB:,G%JsdB:), intent(in) :: v_comp - integer, optional, intent(in) :: is, ie, js, je - integer, optional, intent(in) :: direction -! Arguments: u_comp - The u-component of the vector being checked. -! (in) v_comp - The v-component of the vector being checked. -! (in) mesg - A message indicating what is being checked. -! (in) G - The ocean's grid structure. -! (in/opt) is, ie, js, je - the i- and j- range of indices to check. -! (in/opt) direction - the direction flag to be passed to pass_vector. - + character(len=*), intent(in) :: mesg !< An identifying message + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(G%IsdB:,G%JsdB:), intent(in) :: u_comp !< The u-component of the vector + !! to be checked for consistency + real, dimension(G%IsdB:,G%JsdB:), intent(in) :: v_comp !< The v-component of the vector + !! to be checked for consistency + integer, optional, intent(in) :: is !< The starting i-index to check + integer, optional, intent(in) :: ie !< The ending i-index to check + integer, optional, intent(in) :: js !< The starting j-index to check + integer, optional, intent(in) :: je !< The ending j-index to check + integer, optional, intent(in) :: direction !< the direction flag to be + !! passed to pass_vector + ! Local variables real :: u_nonsym(G%isd:G%ied,G%jsd:G%jed) real :: v_nonsym(G%isd:G%ied,G%jsd:G%jed) real :: u_resym(G%IsdB:G%IedB,G%JsdB:G%JedB) real :: v_resym(G%IsdB:G%IedB,G%JsdB:G%JedB) character(len=128) :: mesg2 - integer :: i, j, is_ch, ie_ch, js_ch, je_ch integer :: Isq, Ieq, Jsq, Jeq, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB @@ -387,16 +396,16 @@ subroutine check_redundant_vB2d(mesg, u_comp, v_comp, G, is, ie, js, je, & end subroutine check_redundant_vB2d +!> Check for consistency between the duplicated points of a 3-D scalar at tracer points subroutine check_redundant_sT3d(mesg, array, G, is, ie, js, je) - character(len=*), intent(in) :: mesg - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%isd:,G%jsd:,:), intent(in) :: array - integer, optional, intent(in) :: is, ie, js, je -! Arguments: array - The array being checked. -! (in) mesg - A message indicating what is being checked. -! (in) G - The ocean's grid structure. -! (in/opt) is, ie, js, je - the i- and j- range of indices to check. - + character(len=*), intent(in) :: mesg !< An identifying message + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(G%isd:,G%jsd:,:), intent(in) :: array !< The array to be checked for consistency + integer, optional, intent(in) :: is !< The starting i-index to check + integer, optional, intent(in) :: ie !< The ending i-index to check + integer, optional, intent(in) :: js !< The starting j-index to check + integer, optional, intent(in) :: je !< The ending j-index to check + ! Local variables character(len=24) :: mesg_k integer :: k @@ -412,16 +421,16 @@ subroutine check_redundant_sT3d(mesg, array, G, is, ie, js, je) end subroutine check_redundant_sT3d +!> Check for consistency between the duplicated points of a 2-D scalar at tracer points subroutine check_redundant_sT2d(mesg, array, G, is, ie, js, je) - character(len=*), intent(in) :: mesg - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%isd:,G%jsd:), intent(in) :: array - integer, optional, intent(in) :: is, ie, js, je -! Arguments: array - The array being checked. -! (in) mesg - A message indicating what is being checked. -! (in) G - The ocean's grid structure. -! (in/opt) is, ie, js, je - the i- and j- range of indices to check. - + character(len=*), intent(in) :: mesg !< An identifying message + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(G%isd:,G%jsd:), intent(in) :: array !< The array to be checked for consistency + integer, optional, intent(in) :: is !< The starting i-index to check + integer, optional, intent(in) :: ie !< The ending i-index to check + integer, optional, intent(in) :: js !< The starting j-index to check + integer, optional, intent(in) :: je !< The ending j-index to check + ! Local variables real :: a_nonsym(G%isd:G%ied,G%jsd:G%jed) character(len=128) :: mesg2 @@ -456,22 +465,22 @@ subroutine check_redundant_sT2d(mesg, array, G, is, ie, js, je) end subroutine check_redundant_sT2d - +!> Check for consistency between the duplicated points of a 3-D A-grid vector subroutine check_redundant_vT3d(mesg, u_comp, v_comp, G, is, ie, js, je, & direction) - character(len=*), intent(in) :: mesg - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%isd:,G%jsd:,:), intent(in) :: u_comp - real, dimension(G%isd:,G%jsd:,:), intent(in) :: v_comp - integer, optional, intent(in) :: is, ie, js, je - integer, optional, intent(in) :: direction -! Arguments: u_comp - The u-component of the vector being checked. -! (in) v_comp - The v-component of the vector being checked. -! (in) mesg - A message indicating what is being checked. -! (in) G - The ocean's grid structure. -! (in/opt) is, ie, js, je - the i- and j- range of indices to check. -! (in/opt) direction - the direction flag to be passed to pass_vector. - + character(len=*), intent(in) :: mesg !< An identifying message + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(G%isd:,G%jsd:,:), intent(in) :: u_comp !< The u-component of the vector + !! to be checked for consistency + real, dimension(G%isd:,G%jsd:,:), intent(in) :: v_comp !< The v-component of the vector + !! to be checked for consistency + integer, optional, intent(in) :: is !< The starting i-index to check + integer, optional, intent(in) :: ie !< The ending i-index to check + integer, optional, intent(in) :: js !< The starting j-index to check + integer, optional, intent(in) :: je !< The ending j-index to check + integer, optional, intent(in) :: direction !< the direction flag to be + !! passed to pass_vector + ! Local variables character(len=24) :: mesg_k integer :: k @@ -486,21 +495,22 @@ subroutine check_redundant_vT3d(mesg, u_comp, v_comp, G, is, ie, js, je, & enddo end subroutine check_redundant_vT3d +!> Check for consistency between the duplicated points of a 2-D A-grid vector subroutine check_redundant_vT2d(mesg, u_comp, v_comp, G, is, ie, js, je, & direction) - character(len=*), intent(in) :: mesg - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%isd:,G%jsd:), intent(in) :: u_comp - real, dimension(G%isd:,G%jsd:), intent(in) :: v_comp - integer, optional, intent(in) :: is, ie, js, je - integer, optional, intent(in) :: direction -! Arguments: u_comp - The u-component of the vector being checked. -! (in) v_comp - The v-component of the vector being checked. -! (in) mesg - A message indicating what is being checked. -! (in) G - The ocean's grid structure. -! (in/opt) is, ie, js, je - the i- and j- range of indices to check. -! (in/opt) direction - the direction flag to be passed to pass_vector. - + character(len=*), intent(in) :: mesg !< An identifying message + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(G%isd:,G%jsd:), intent(in) :: u_comp !< The u-component of the vector + !! to be checked for consistency + real, dimension(G%isd:,G%jsd:), intent(in) :: v_comp !< The v-component of the vector + !! to be checked for consistency + integer, optional, intent(in) :: is !< The starting i-index to check + integer, optional, intent(in) :: ie !< The ending i-index to check + integer, optional, intent(in) :: js !< The starting j-index to check + integer, optional, intent(in) :: je !< The ending j-index to check + integer, optional, intent(in) :: direction !< the direction flag to be + !! passed to pass_vector + ! Local variables real :: u_nonsym(G%isd:G%ied,G%jsd:G%jed) real :: v_nonsym(G%isd:G%ied,G%jsd:G%jed) character(len=128) :: mesg2 @@ -549,9 +559,7 @@ subroutine check_redundant_vT2d(mesg, u_comp, v_comp, G, is, ie, js, je, & end subroutine check_redundant_vT2d -! ===================================================================== - -! This function does a checksum and redundant point check on a 3d C-grid vector. +!> Do a checksum and redundant point check on a 3d C-grid vector. subroutine chksum_vec_C3d(mesg, u_comp, v_comp, G, halos, scalars) character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure @@ -559,8 +567,8 @@ subroutine chksum_vec_C3d(mesg, u_comp, v_comp, G, halos, scalars) real, dimension(G%isd:,G%JsdB:,:), intent(in) :: v_comp !< The v-component of the vector integer, optional, intent(in) :: halos !< The width of halos to check (default 0) logical, optional, intent(in) :: scalars !< If true this is a pair of - !! scalars that are being checked. - + !! scalars that are being checked. + ! Local variables logical :: are_scalars are_scalars = .false. ; if (present(scalars)) are_scalars = scalars @@ -577,7 +585,7 @@ subroutine chksum_vec_C3d(mesg, u_comp, v_comp, G, halos, scalars) end subroutine chksum_vec_C3d -! This function does a checksum and redundant point check on a 2d C-grid vector. +!> Do a checksum and redundant point check on a 2d C-grid vector. subroutine chksum_vec_C2d(mesg, u_comp, v_comp, G, halos, scalars) character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure @@ -585,8 +593,8 @@ subroutine chksum_vec_C2d(mesg, u_comp, v_comp, G, halos, scalars) real, dimension(G%isd:,G%JsdB:), intent(in) :: v_comp !< The v-component of the vector integer, optional, intent(in) :: halos !< The width of halos to check (default 0) logical, optional, intent(in) :: scalars !< If true this is a pair of - !! scalars that are being checked. - + !! scalars that are being checked. + ! Local variables logical :: are_scalars are_scalars = .false. ; if (present(scalars)) are_scalars = scalars @@ -603,7 +611,7 @@ subroutine chksum_vec_C2d(mesg, u_comp, v_comp, G, halos, scalars) end subroutine chksum_vec_C2d -! This function does a checksum and redundant point check on a 3d B-grid vector. +!> Do a checksum and redundant point check on a 3d B-grid vector. subroutine chksum_vec_B3d(mesg, u_comp, v_comp, G, halos, scalars) character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure @@ -611,8 +619,8 @@ subroutine chksum_vec_B3d(mesg, u_comp, v_comp, G, halos, scalars) real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: v_comp !< The v-component of the vector integer, optional, intent(in) :: halos !< The width of halos to check (default 0) logical, optional, intent(in) :: scalars !< If true this is a pair of - !! scalars that are being checked. - + !! scalars that are being checked. + ! Local variables logical :: are_scalars are_scalars = .false. ; if (present(scalars)) are_scalars = scalars @@ -630,7 +638,7 @@ subroutine chksum_vec_B3d(mesg, u_comp, v_comp, G, halos, scalars) end subroutine chksum_vec_B3d -! This function does a checksum and redundant point check on a 2d B-grid vector. +! Do a checksum and redundant point check on a 2d B-grid vector. subroutine chksum_vec_B2d(mesg, u_comp, v_comp, G, halos, scalars, symmetric) character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure @@ -638,10 +646,10 @@ subroutine chksum_vec_B2d(mesg, u_comp, v_comp, G, halos, scalars, symmetric) real, dimension(G%IsdB:,G%JsdB:), intent(in) :: v_comp !< The v-component of the vector integer, optional, intent(in) :: halos !< The width of halos to check (default 0) logical, optional, intent(in) :: scalars !< If true this is a pair of - !! scalars that are being checked. + !! scalars that are being checked. logical, optional, intent(in) :: symmetric !< If true, do the checksums on the - !! full symmetric computational domain. - + !! full symmetric computational domain. + ! Local variables logical :: are_scalars are_scalars = .false. ; if (present(scalars)) are_scalars = scalars @@ -659,7 +667,7 @@ subroutine chksum_vec_B2d(mesg, u_comp, v_comp, G, halos, scalars, symmetric) end subroutine chksum_vec_B2d -! This function does a checksum and redundant point check on a 3d C-grid vector. +!> Do a checksum and redundant point check on a 3d C-grid vector. subroutine chksum_vec_A3d(mesg, u_comp, v_comp, G, halos, scalars) character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure @@ -667,8 +675,8 @@ subroutine chksum_vec_A3d(mesg, u_comp, v_comp, G, halos, scalars) real, dimension(G%isd:,G%jsd:,:), intent(in) :: v_comp !< The v-component of the vector integer, optional, intent(in) :: halos !< The width of halos to check (default 0) logical, optional, intent(in) :: scalars !< If true this is a pair of - !! scalars that are being checked. - + !! scalars that are being checked. + ! Local variables logical :: are_scalars are_scalars = .false. ; if (present(scalars)) are_scalars = scalars @@ -686,8 +694,7 @@ subroutine chksum_vec_A3d(mesg, u_comp, v_comp, G, halos, scalars) end subroutine chksum_vec_A3d - -! This function does a checksum and redundant point check on a 2d C-grid vector. +!> Do a checksum and redundant point check on a 2d C-grid vector. subroutine chksum_vec_A2d(mesg, u_comp, v_comp, G, halos, scalars) character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure @@ -695,8 +702,8 @@ subroutine chksum_vec_A2d(mesg, u_comp, v_comp, G, halos, scalars) real, dimension(G%isd:,G%jsd:), intent(in) :: v_comp !< The v-component of the vector integer, optional, intent(in) :: halos !< The width of halos to check (default 0) logical, optional, intent(in) :: scalars !< If true this is a pair of - !! scalars that are being checked. - + !! scalars that are being checked. + ! Local variables logical :: are_scalars are_scalars = .false. ; if (present(scalars)) are_scalars = scalars @@ -714,17 +721,15 @@ subroutine chksum_vec_A2d(mesg, u_comp, v_comp, G, halos, scalars) end subroutine chksum_vec_A2d - -! ===================================================================== - !> This function returns the sum over computational domain of all !! processors of hThick*stuff, where stuff is a 3-d array at tracer points. function totalStuff(HI, hThick, areaT, stuff) type(hor_index_type), intent(in) :: HI !< A horizontal index type real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: hThick !< The array of thicknesses to use as weights - real, dimension(HI%isd:,HI%jsd:), intent(in) :: areaT !< The array of cell areas in m2 + real, dimension(HI%isd:,HI%jsd:), intent(in) :: areaT !< The array of cell areas [m2] real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: stuff !< The array of stuff to be summed - real :: totalStuff + real :: totalStuff !< the globally integrated amoutn of stuff + ! Local variables integer :: i, j, k, nz nz = size(hThick,3) @@ -736,24 +741,19 @@ function totalStuff(HI, hThick, areaT, stuff) end function totalStuff -! ===================================================================== - !> This subroutine display the total thickness, temperature and salinity !! as well as the change since the last call. -!! NOTE: This subroutine uses "save" data which is not thread safe and is purely -!! for extreme debugging without a proper debugger. subroutine totalTandS(HI, hThick, areaT, temperature, salinity, mesg) type(hor_index_type), intent(in) :: HI !< A horizontal index type real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: hThick !< The array of thicknesses to use as weights - real, dimension(HI%isd:,HI%jsd:), intent(in) :: areaT !< The array of cell areas in m2 + real, dimension(HI%isd:,HI%jsd:), intent(in) :: areaT !< The array of cell areas [m2] real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: temperature !< The temperature field to sum real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: salinity !< The salinity field to sum character(len=*), intent(in) :: mesg !< An identifying message - ! NOTE: This subroutine uses "save" data which is not thread safe and is purely for ! extreme debugging without a proper debugger. real, save :: totalH = 0., totalT = 0., totalS = 0. - + ! Local variables logical, save :: firstCall = .true. real :: thisH, thisT, thisS, delH, delT, delS integer :: i, j, k, nz @@ -826,8 +826,6 @@ logical function check_column_integrals(nk_1, field_1, nk_2, field_2, missing_va real, dimension(nk_2), intent(in) :: field_2 !< Second field to be summed real, optional, intent(in) :: missing_value !< If column contains missing values, !! mask them from the sum - - ! Local variables real :: u1_sum, error1, u2_sum, error2, misval integer :: k diff --git a/src/diagnostics/MOM_diag_to_Z.F90 b/src/diagnostics/MOM_diag_to_Z.F90 index 5dd78e8eee..3c50f00061 100644 --- a/src/diagnostics/MOM_diag_to_Z.F90 +++ b/src/diagnostics/MOM_diag_to_Z.F90 @@ -1,40 +1,23 @@ +!> 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. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Robert Hallberg, July 2006 * -!* * -!* This subroutine 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. * -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q, CoriolisBu * -!* j+1 > o > o > At ^: v * -!* j x ^ x ^ x At >: u * -!* j > o > o > At o: h, bathyT * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** -use MOM_domains, only : pass_var use MOM_coms, only : reproducing_sum -use MOM_diag_mediator, only : post_data, post_data_1d_k, register_diag_field, safe_alloc_ptr +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 @@ -55,84 +38,101 @@ module MOM_diag_to_Z 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) - v_z => NULL(), & ! meridional velocity remapped to depth space (m/s) - uh_z => NULL(), & ! zonal transport remapped to depth space (m3/s or kg/s) - vh_z => NULL() ! meridional transport remapped to depth space (m3/s or kg/s) - - 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 - real :: missing_trans = -1.0e34 - real :: missing_value = -1.0e34 - real :: missing_tr(MAX_FIELDS_) = -1.0e34 - - integer :: id_u_z = -1 - integer :: id_v_z = -1 - integer :: id_uh_Z = -1 - integer :: id_vh_Z = -1 - integer :: id_tr(MAX_FIELDS_) = -1 - integer :: id_tr_xyave(MAX_FIELDS_) = -1 - integer :: num_tr_used = 0 - integer :: nk_zspace = -1 - - real, pointer :: Z_int(:) => NULL() ! interface depths of the z-space file (meter) + 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 ! structure to regulate diagnostic output timing + 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 +integer, parameter :: NO_ZSPACE = -1 !< Flag to enable z-space? contains -function global_z_mean(var,G,CS,tracer) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(diag_to_Z_CS), intent(in) :: CS - real, dimension(SZI_(G), SZJ_(G), CS%nk_zspace), intent(in) :: var +!> 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(SZI_(G), SZJ_(G), CS%nk_zspace) :: localVar, valid_point, depth_weight real, dimension(CS%nk_zspace) :: global_z_mean, scalarij, weightij real, dimension(CS%nk_zspace) :: global_temp_scalar, global_weight_scalar - integer :: i, j, k, is, ie, js, je, nz, tracer - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; + 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 - valid_point = 1. ; depth_weight = 0. tmpForSumming(:,:,:) = 0. ; weight(:,:,:) = 0. - ! Local array copy of tracer field pointer - localVar = var - - do k=1, nz ; do j=js,je ; do i=is, ie + do k=1,nz ; do j=js,je ; do i=is,ie + valid_point = 1.0 ! Weight factor for partial bottom cells - depth_weight(i,j,k) = min( max( (-1.*G%bathyT(i,j)), CS%Z_int(k+1) ) - CS%Z_int(k), 0.) + 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(i,j,k) = 0. - if (depth_weight(i,j,k) == 0.) valid_point(i,j,k) = 0. + if (var(i,j,k) == CS%missing_tr(tracer)) valid_point = 0. + if (depth_weight == 0.) valid_point = 0. - ! If the point is flagged, set the variable itsef to zero to avoid NaNs - if (valid_point(i,j,k) == 0.) localVar(i,j,k) = 0. + weight(i,j,k) = US%Z_to_m * depth_weight * ( (valid_point * (G%areaT(i,j) * G%mask2dT(i,j))) ) - weight(i,j,k) = depth_weight(i,j,k) * ( (valid_point(i,j,k) * (G%areaT(i,j) * G%mask2dT(i,j))) ) - tmpForSumming(i,j,k) = localVar(i,j,k) * weight(i,j,k) + ! 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) + 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 @@ -145,57 +145,47 @@ function global_z_mean(var,G,CS,tracer) 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, 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) :: u !< The zonal velocity, in m s-1. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< The meridional velocity, - !! in m s-1. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H - !! (usually m or kg m-2). - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: ssh_in !< Sea surface height - !! (meter or kg/m2). - real, dimension(:,:), pointer :: frac_shelf_h - type(diag_to_Z_CS), pointer :: CS !< Control structure returned by - !! previous call to - !! diagnostics_init. - -! This subroutine maps tracers and velocities into depth space for diagnostics. - -! Arguments: -! (in) u - zonal velocity component (m/s) -! (in) v - meridional velocity component (m/s) -! (in) h - layer thickness (meter or kg/m2) -! (in) ssh_in - sea surface height (meter or kg/m2) -! (in) G - ocean grid structure -! (in) GV - The ocean's vertical grid structure. -! (in) CS - control structure returned by previous call to diagnostics_init - +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 (meter or kg/m2) - real :: e(SZK_(G)+2) ! z-star interface heights (meter or kg/m2) - real :: h_f(SZK_(G)+1,SZI_(G)) ! thicknesses of massive layers (meter or kg/m2) + 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 (meter or kg/m2) - real :: shelf_depth(SZIB_(G)) ! ice shelf depth (meter or kg/m2) - real :: htot ! summed layer thicknesses (meter or kg/m2) + 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) + ! 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) + ! 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, in H. + 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) @@ -209,17 +199,21 @@ subroutine calculate_Z_diag_fields(u, v, h, ssh_in, frac_shelf_h, G, GV, CS) 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 - ssh(:,:) = ssh_in + Angstrom = GV%Angstrom_H linear_velocity_profiles = .true. - ! Update the halos - call pass_var(ssh, G%Domain) + 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 @@ -255,9 +249,9 @@ subroutine calculate_Z_diag_fields(u, v, h, ssh_in, frac_shelf_h, G, GV, CS) 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 when - ! shelf_depth(I) + 1.0E-3 > D_pt(i) - if (ice_shelf .and. shelf_depth(I) + 1.0E-3 > D_pt(i)) nk_valid(I)=0 + ! 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 @@ -265,8 +259,8 @@ subroutine calculate_Z_diag_fields(u, v, h, ssh_in, frac_shelf_h, G, GV, CS) ! 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*GV%H_to_m > 2.0*Angstrom) then - dilate = MAX((D_pt(i) - shelf_depth(i)),Angstrom)/htot + 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 @@ -351,7 +345,7 @@ subroutine calculate_Z_diag_fields(u, v, h, ssh_in, frac_shelf_h, G, GV, CS) ! 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 > D_pt(i)) nk_valid(I)=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 @@ -359,7 +353,7 @@ subroutine calculate_Z_diag_fields(u, v, h, ssh_in, frac_shelf_h, G, GV, CS) 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)),Angstrom)/htot + 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 @@ -436,7 +430,7 @@ subroutine calculate_Z_diag_fields(u, v, h, ssh_in, frac_shelf_h, G, GV, CS) 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 > D_pt(i)) nk_valid(I)=0 + 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 @@ -446,7 +440,7 @@ subroutine calculate_Z_diag_fields(u, v, h, ssh_in, frac_shelf_h, G, GV, CS) 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)),Angstrom)/htot + 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 @@ -497,8 +491,8 @@ subroutine calculate_Z_diag_fields(u, v, h, ssh_in, frac_shelf_h, G, GV, CS) 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,CS,m) - call post_data_1d_k(CS%id_tr_xyave(m), layer_ave, CS%diag) + 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 @@ -511,56 +505,44 @@ subroutine calculate_Z_transport(uh_int, vh_int, h, dt, G, GV, CS) 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 (m3 or kg). + !! transport [H m2 ~> m3 or kg]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: vh_int !< Time integrated meridional - !! transport (m3 or kg). - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H - !! (usually m or kg m-2). + !! 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 - !! diagnostics_init. - -! This subroutine maps horizontal transport into depth space for diagnostic output. - -! Arguments: -! (in) uh_int - time integrated zonal transport (m3 or kg) -! (in) vh_int - time integrated meridional transport (m3 or kg) -! (in) h - layer thickness (meter or kg/m2) -! (in) dt - time difference (sec) since last call to this routine -! (in) G - ocean grid structure -! (in) GV - The ocean's vertical grid structure -! (in) CS - control structure returned by previous call to diagnostics_init - + !! diag_to_Z_init. + ! Local variables real, dimension(SZI_(G), SZJ_(G)) :: & - htot, & ! total layer thickness (meter or kg/m2) - dilate ! nondimensional factor by which to dilate layers to - ! convert them into z* space. (-G%D < z* < 0) + 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 (m3 or kg) + 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 (m3 or kg) + 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 (meter or kg/m2) + ! into depth space [Z ~> m] real :: uh_rem ! integrated zonal transport of a layer that has yet to be - ! mapped into depth space (m3 or kg) + ! 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 (m3 or kg) + ! 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 (meter or kg/m2) + ! current depth level [Z ~> m] real :: h_above ! thickness of a layer that is above the current depth - ! level (meter or kg.m2) + ! level [Z ~> m] real :: uh_here ! zonal transport of a layer that is attributed to the - ! current depth level (m3 or kg) + ! current depth level [H m2 ~> m3 or kg] real :: vh_here ! meridional transport of a layer that is attributed to - ! the current depth level (m3 or kg) - real :: Idt ! inverse of the time step (sec) + ! 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 (meter or kg/m2) + 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 @@ -675,14 +657,14 @@ subroutine calculate_Z_transport(uh_int, vh_int, h, dt, G, GV, CS) end subroutine calculate_Z_transport -!> This subroutine determines the layers bounded by interfaces e that overlap +!> 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 (meter or kg/m2). - real, intent(in) :: Z_top !< Top of range being mapped to (meter or kg/m2). - real, intent(in) :: Z_bot !< Bottom of range being mapped to (meter or kg/m2). + 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 @@ -690,31 +672,13 @@ subroutine find_overlap(e, Z_top, Z_bot, k_max, k_start, k_top, k_bot, wt, z1, z 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, z2 !< Depths of the top and bottom limits of the part of + 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. - -! This subroutine 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. - -! Note that by convention, e decreases with increasing k and Z_top > Z_bot. -! -! Arguments: -! (in) e - column interface heights (meter or kg/m2) -! (in) Z_top - top of range being mapped to (meter or kg/m2) -! (in) Z_bot - bottom of range being mapped to (meter or kg/m2) -! (in) k_max - number of valid layers -! (in) k_start - layer at which to start searching -! (out) k_top, k_bot - indices of top and bottom layers that -! overlap with the depth range -! (out) wt - relative weights of each layer from k_top to k_bot -! (out) z1, z2 - depths of the top and bottom 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. - + !! 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 @@ -726,20 +690,24 @@ subroutine find_overlap(e, Z_top, Z_bot, k_max, k_start, k_top, k_bot, wt, z1, z ! 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 = 1.0 / (e(K)-e(K+1)) + 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. - z1(k) = (0.5*(e(K)+e(K+1)) - MIN(e(K),Z_top)) / (e(K)-e(K+1)) + 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 - z2(k) = (0.5*(e(K)+e(K+1)) - Z_bot) / (e(K)-e(K+1)) + 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 @@ -753,29 +721,20 @@ subroutine find_overlap(e, Z_top, Z_bot, k_max, k_start, k_top, k_bot, wt, z1, z end subroutine find_overlap -!> This subroutine determines a limited slope for val to be advected with +!> 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 (meter or kg/m2). + 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. -! This subroutine determines a limited slope for val to be advected with -! a piecewise limited scheme. - -! Arguments: -! (in) val - a column of values that are being interpolated -! (in) e - column interface heights (meter or kg/m2) -! (in) slope - normalized slope in the intracell distribution of val -! (in) k - layer whose slope is being determined - - real :: d1, d2 - - if ((val(k)-val(k-1)) * (val(k)-val(k+1)) >= 0.0) then + 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 - d1 = 0.5*(e(K-1)-e(K+1)) ; d2 = 0.5*(e(K)-e(K+2)) 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)) @@ -788,25 +747,25 @@ subroutine find_limited_slope(val, e, slope, k) end subroutine find_limited_slope -! #@# This subroutine needs a doxygen description +!> 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, in H - !! (usually m or kg m-2). - type(p3d), dimension(:), intent(in) :: in_ptrs - integer, dimension(:), intent(in) :: ids - integer, intent(in) :: num_diags - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid - !! structure. - type(diag_to_Z_CS), pointer :: 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 (meter or kg/m2) + 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 @@ -826,7 +785,7 @@ subroutine calc_Zint_diags(h, in_ptrs, ids, num_diags, G, GV, CS) 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)*GV%H_to_m > 0.5) dilate(i) = (G%bathyT(i,j) - 0.0) / htot(i) + 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 @@ -889,36 +848,23 @@ 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. + 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 - type(time_type), intent(in) :: Time !< Current model time. - type(diag_to_Z_CS), pointer :: CS !< Control struct returned by previous - !! call to diagnostics_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. - -! This subroutine registers a tracer to be output in depth space. -! Arguments: -! (in) tr_ptr - tracer for translation to Z-space -! (in) name - name for the output tracer -! (in) long_name - long name for the output tracer -! (in) units - units of output tracer -! (in) Time - current model time -! (in) G - ocean grid structure -! (in) CS - control struct returned by previous call to diagnostics_init -! (in,opt) cmor_field_name - cmor name of a field -! (in,opt) cmor_long_name - cmor long name of a field -! (in,opt) cmor_units - cmor units of a field -! (in,opt) cmor_standard_name - cmor standardized name associated with a field - + 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 @@ -960,28 +906,17 @@ 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. + 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 - type(time_type), intent(in) :: Time !< Current model time. - type(diag_to_Z_CS), pointer :: CS !< Control struct returned by previous call to - !! diagnostics_init. - -! This subroutine registers a tracer to be output in depth space. - -! Arguments: -! (in) tr_ptr - tracer for translation to Z-space -! (in) name - name for the output tracer -! (in) long_name - long name for output tracer -! (in) units - units of output tracer -! (in) Time - current model time -! (in) G - ocean grid structure -! (in) CS - control struct returned by previous call to diagnostics_init - + 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 @@ -1024,34 +959,26 @@ subroutine register_Z_tracer_low(tr_ptr, name, long_name, units, standard_name, end subroutine register_Z_tracer_low -! #@# This subroutine needs a doxygen comment. -subroutine MOM_diag_to_Z_init(Time, G, GV, param_file, diag, CS) +!> 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(param_file_type), intent(in) :: param_file !< A structure to parse for run-time - !! parameters. + 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. - -! Arguments: -! (in) Time - current model time -! (in) G - ocean grid structure -! (in) GV - The ocean's vertical grid structure. -! (in) param_file - struct indicating open file to parse for model param values -! (in) diag - struct to regulate diagnostic output -! (in/out) CS - pointer to point to control structure for this module - + !! 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 :: 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 + 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 @@ -1080,6 +1007,7 @@ subroutine MOM_diag_to_Z_init(Time, G, GV, param_file, diag, CS) 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, & @@ -1134,26 +1062,22 @@ end subroutine MOM_diag_to_Z_init !! 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 - character(len=*), intent(in) :: int_depth_name - real, dimension(:), pointer :: int_depth - character(len=*), intent(in) :: cell_depth_name - integer, intent(out) :: z_axis_index - integer, intent(out) :: edge_index - integer, intent(out) :: nk_out - -! 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. - + 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); + 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)//" - "//& @@ -1253,8 +1177,9 @@ subroutine get_Z_depths(depth_file, int_depth_name, int_depth, cell_depth_name, 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 + 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) @@ -1268,23 +1193,15 @@ 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. + 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 diagnostics_init. - integer :: ocean_register_diag_with_z - -! This subroutine registers a tracer to be output in depth space. -! Arguments: -! (in) tr_ptr - tracer for translation to Z-space -! (in) vardesc_tr - variable descriptor -! (in) Time - current model time -! (in) G - ocean grid structure -! (in) CS - control struct returned by a previous call to diagnostics_init - + 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 @@ -1302,7 +1219,7 @@ function ocean_register_diag_with_z(tr_ptr, vardesc_tr, G, Time, CS) ! 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; + ! 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") @@ -1332,18 +1249,20 @@ function ocean_register_diag_with_z(tr_ptr, vardesc_tr, G, Time, CS) 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 - type(vardesc), intent(in) :: var_desc - type(diag_to_Z_CS), pointer :: CS - type(time_type), intent(in) :: day - real, intent(in) :: 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 + 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") @@ -1385,17 +1304,20 @@ function register_Z_diag(var_desc, CS, day, missing) end function register_Z_diag -function register_Zint_diag(var_desc, CS, day) - integer :: register_Zint_diag - type(vardesc), intent(in) :: var_desc - type(diag_to_Z_CS), pointer :: CS - type(time_type), intent(in) :: day - +!> 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 + 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") @@ -1420,10 +1342,10 @@ function register_Zint_diag(var_desc, CS, day) "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) + 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 097a0e13b3..cd3c87b922 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -1,31 +1,12 @@ +!> Calculates any requested diagnostic quantities +!! that are not calculated in the various subroutines. +!! Diagnostic quantities are requested by allocating them memory. module MOM_diagnostics ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Robert Hallberg, February 2001 * -!* * -!* This subroutine calculates any requested diagnostic quantities * -!* that are not calculated in the various subroutines. Diagnostic * -!* quantities are requested by allocating them memory. * -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q, CoriolisBu * -!* j+1 > o > o > At ^: v * -!* j x ^ x ^ x At >: u * -!* j > o > o > At o: h, bathyT * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** - use MOM_coms, only : reproducing_sum -use MOM_diag_mediator, only : post_data, post_data_1d_k, get_diag_time_end +use MOM_diag_mediator, only : post_data, get_diag_time_end use MOM_diag_mediator, only : register_diag_field, register_scalar_field use MOM_diag_mediator, only : register_static_field, diag_register_area_ids use MOM_diag_mediator, only : diag_ctrl, time_type, safe_alloc_ptr @@ -44,6 +25,7 @@ module MOM_diagnostics use MOM_spatial_means, only : global_area_mean, global_layer_mean use MOM_spatial_means, only : global_volume_mean, global_area_integral use MOM_tracer_registry, only : tracer_registry_type, post_tracer_transport_diagnostics +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs, ocean_internal_state, p3d use MOM_variables, only : accel_diag_ptrs, cont_diag_ptrs, surface use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units @@ -56,64 +38,74 @@ module MOM_diagnostics public calculate_diagnostic_fields, register_time_deriv, write_static_fields public find_eta -public MOM_diagnostics_init, MOM_diagnostics_end -public register_surface_diags, post_surface_diagnostics +public register_surface_diags, post_surface_dyn_diags, post_surface_thermo_diags public register_transport_diags, post_transport_diagnostics +public MOM_diagnostics_init, MOM_diagnostics_end +! 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_diagnostics module type, public :: diagnostics_CS ; private real :: mono_N2_column_fraction = 0. !< The lower fraction of water column over which N2 is limited as - !! monotonic for the purposes of calculating the equivalent barotropic wave speed. + !! monotonic for the purposes of calculating the equivalent + !! barotropic wave speed. real :: mono_N2_depth = -1. !< The depth below which N2 is limited as monotonic for the purposes of - !! calculating the equivalent barotropic wave speed. (m) + !! calculating the equivalent barotropic wave speed [m]. - type(diag_ctrl), pointer :: diag ! structure to regulate diagnostics timing + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. ! following arrays store diagnostics calculated here and unavailable outside. ! following fields have nz+1 levels. real, pointer, dimension(:,:,:) :: & - e => NULL(), & ! interface height (metre) - e_D => NULL() ! interface height above bottom (metre) + e => NULL(), & !< interface height [Z ~> m] + e_D => NULL() !< interface height above bottom [Z ~> m] ! following fields have nz layers. real, pointer, dimension(:,:,:) :: & - du_dt => NULL(), & ! net i-acceleration in m/s2 - dv_dt => NULL(), & ! net j-acceleration in m/s2 - dh_dt => NULL(), & ! thickness rate of change in (m/s) or kg/(m2*s) - - h_Rlay => NULL(), & ! layer thicknesses in layered potential density - ! coordinates, in m (Bouss) or kg/m2 (non-Bouss) - uh_Rlay => NULL(), & ! zonal and meridional transports in layered - vh_Rlay => NULL(), & ! potential rho coordinates: m3/s(Bouss) kg/s(non-Bouss) - uhGM_Rlay => NULL(), & ! zonal and meridional Gent-McWilliams transports in layered - vhGM_Rlay => NULL(), & ! potential density coordinates, m3/s (Bouss) kg/s(non-Bouss) - p_ebt => NULL() ! Equivalent barotropic modal structure + du_dt => NULL(), & !< net i-acceleration [m s-2] + dv_dt => NULL(), & !< net j-acceleration [m s-2] + dh_dt => NULL(), & !< thickness rate of change [H s-1 ~> m s-1 or kg m-2 s-1] + p_ebt => NULL() !< Equivalent barotropic modal structure [nondim] + + real, pointer, dimension(:,:,:) :: h_Rlay => NULL() !< Layer thicknesses in potential density + !! coordinates [H ~> m or kg m-2] + real, pointer, dimension(:,:,:) :: uh_Rlay => NULL() !< Zonal transports in potential density + !! coordinates [H m2 s-1 ~> m3 s-1 or kg s-1] + real, pointer, dimension(:,:,:) :: vh_Rlay => NULL() !< Meridional transports in potential density + !! coordinates [H m2 s-1 ~> m3 s-1 or kg s-1] + real, pointer, dimension(:,:,:) :: uhGM_Rlay => NULL() !< Zonal Gent-McWilliams transports in potential density + !! coordinates [H m2 s-1 ~> m3 s-1 or kg s-1] + real, pointer, dimension(:,:,:) :: vhGM_Rlay => NULL() !< Meridional Gent-McWilliams transports in potential density + !! coordinates [H m2 s-1 ~> m3 s-1 or kg s-1] ! following fields are 2-D. real, pointer, dimension(:,:) :: & - cg1 => NULL(), & ! first baroclinic gravity wave speed, in m s-1 - Rd1 => NULL(), & ! first baroclinic deformation radius, in m - cfl_cg1 => NULL(), & ! CFL for first baroclinic gravity wave speed, nondim - cfl_cg1_x => NULL(), & ! i-component of CFL for first baroclinic gravity wave speed, nondim - cfl_cg1_y => NULL() ! j-component of CFL for first baroclinic gravity wave speed, nondim - - ! arrays to hold diagnostics in the layer-integrated energy budget. - ! all except KE have units of m3 s-3 (when Boussinesq). + cg1 => NULL(), & !< First baroclinic gravity wave speed [m s-1] + Rd1 => NULL(), & !< First baroclinic deformation radius [m] + cfl_cg1 => NULL(), & !< CFL for first baroclinic gravity wave speed, nondim + cfl_cg1_x => NULL(), & !< i-component of CFL for first baroclinic gravity wave speed, nondim + cfl_cg1_y => NULL() !< j-component of CFL for first baroclinic gravity wave speed, nondim + + ! The following arrays hold diagnostics in the layer-integrated energy budget. real, pointer, dimension(:,:,:) :: & - KE => NULL(), & ! KE per unit mass, in m2 s-2 - dKE_dt => NULL(), & ! time derivative of the layer KE - PE_to_KE => NULL(), & ! potential energy to KE term - KE_CorAdv => NULL(), & ! KE source from the combined Coriolis and - ! advection terms. The Coriolis source should be - ! zero, but is not due to truncation errors. There - ! should be near-cancellation of the global integral - ! of this spurious Coriolis source. - KE_adv => NULL(),& ! KE source from along-layer advection - KE_visc => NULL(),& ! KE source from vertical viscosity - KE_horvisc => NULL(),& ! KE source from horizontal viscosity - KE_dia => NULL() ! KE source from diapycnal diffusion - - ! diagnostic IDs + KE => NULL(), & !< KE per unit mass [m2 s-2] + dKE_dt => NULL(), & !< time derivative of the layer KE [m3 s-3] + PE_to_KE => NULL(), & !< potential energy to KE term [m3 s-3] + KE_CorAdv => NULL(), & !< KE source from the combined Coriolis and advection terms [m3 s-3]. + !! The Coriolis source should be zero, but is not due to truncation + !! errors. There should be near-cancellation of the global integral + !! of this spurious Coriolis source. + KE_adv => NULL(), & !< KE source from along-layer advection [m3 s-3] + KE_visc => NULL(), & !< KE source from vertical viscosity [m3 s-3] + KE_horvisc => NULL(), & !< KE source from horizontal viscosity [m3 s-3] + KE_dia => NULL() !< KE source from diapycnal diffusion [m3 s-3] + + !>@{ Diagnostic IDs integer :: id_u = -1, id_v = -1, id_h = -1 integer :: id_e = -1, id_e_D = -1 integer :: id_du_dt = -1, id_dv_dt = -1 @@ -142,25 +134,28 @@ module MOM_diagnostics integer :: id_pbo = -1 integer :: id_thkcello = -1, id_rhoinsitu = -1 integer :: id_rhopot0 = -1, id_rhopot2 = -1 - integer :: id_h_pre_sync = -1 + integer :: id_h_pre_sync = -1 !!@} + !> The control structure for calculating wave speed. type(wave_speed_CS), pointer :: wave_speed_CSp => NULL() - ! pointers used in calculation of time derivatives - type(p3d) :: var_ptr(MAX_FIELDS_) - type(p3d) :: deriv(MAX_FIELDS_) - type(p3d) :: prev_val(MAX_FIELDS_) - integer :: nlay(MAX_FIELDS_) - integer :: num_time_deriv = 0 + type(p3d) :: var_ptr(MAX_FIELDS_) !< pointers to variables used in the calculation + !! of time derivatives + type(p3d) :: deriv(MAX_FIELDS_) !< Time derivatives of various fields + type(p3d) :: prev_val(MAX_FIELDS_) !< Previous values of variables used in the calculation + !! of time derivatives + !< previous values of variables used in calculation of time derivatives + integer :: nlay(MAX_FIELDS_) !< The number of layers in each diagnostics + integer :: num_time_deriv = 0 !< The number of time derivative diagnostics - ! for group halo pass - type(group_pass_type) :: pass_KE_uv + type(group_pass_type) :: pass_KE_uv !< A handle used for group halo passes end type diagnostics_CS !> A structure with diagnostic IDs of the surface and integrated variables type, public :: surface_diag_IDs ; private - ! 2-d surface and bottom fields + !>@{ Diagnostic IDs for 2-d surface and bottom flux and state fields + !Diagnostic IDs for 2-d surface and bottom fields integer :: id_zos = -1, id_zossq = -1 integer :: id_volo = -1, id_speed = -1 integer :: id_ssh = -1, id_ssh_ga = -1 @@ -168,53 +163,54 @@ module MOM_diagnostics integer :: id_sss = -1, id_sss_sq = -1, id_sssabs = -1 integer :: id_ssu = -1, id_ssv = -1 - ! heat and salt flux fields + ! Diagnostic IDs for heat and salt flux fields integer :: id_fraz = -1 integer :: id_salt_deficit = -1 integer :: id_Heat_PmE = -1 integer :: id_intern_heat = -1 + !!@} end type surface_diag_IDs !> A structure with diagnostic IDs of mass transport related diagnostics type, public :: transport_diag_IDs ; private - ! Diagnostics for tracer horizontal transport + !>@{ Diagnostics for tracer horizontal transport integer :: id_uhtr = -1, id_umo = -1, id_umo_2d = -1 integer :: id_vhtr = -1, id_vmo = -1, id_vmo_2d = -1 - integer :: id_dynamics_h = -1, id_dynamics_h_tendency = -1 - + integer :: id_dynamics_h = -1, id_dynamics_h_tendency = -1 !!@} end type transport_diag_IDs contains !> Diagnostics not more naturally calculated elsewhere are computed here. subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & - dt, diag_pre_sync, G, GV, CS, eta_bt) + dt, diag_pre_sync, G, GV, US, CS, eta_bt) 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, in m s-1. + intent(in) :: u !< The zonal velocity [m s-1]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & - intent(in) :: v !< The meridional velocity, in m s-1. + intent(in) :: v !< The meridional velocity [m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2). + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & intent(in) :: uh !< Transport through zonal faces = u*h*dy, - !! in H m2 s-1, i.e. m3/s(Bouss) or kg/s(non-Bouss). + !! [H m2 s-1 ~> m3 s-1 or kg s-1]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & intent(in) :: vh !< Transport through meridional faces = v*h*dx, - !! in H m2 s-1, i.e. m3/s(Bouss) or kg/s(non-Bouss). + !! [H m2 s-1 ~> m3 s-1 or kg s-1]. type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various !! thermodynamic variables. type(accel_diag_ptrs), intent(in) :: ADp !< structure with pointers to !! accelerations in momentum equation. type(cont_diag_ptrs), intent(in) :: CDp !< structure with pointers to !! terms in continuity equation. - real, dimension(:,:), pointer :: p_surf !< A pointer to the surface pressure, in Pa. + real, dimension(:,:), pointer :: p_surf !< A pointer to the surface pressure [Pa]. !! If p_surf is not associated, it is the same !! as setting the surface pressure to 0. - real, intent(in) :: dt !< The time difference in s since the last - !! call to this subroutine. + real, intent(in) :: dt !< The time difference since the last + !! call to this subroutine [s]. type(diag_grid_storage), intent(in) :: diag_pre_sync !< Target grids from previous timestep type(diagnostics_CS), intent(inout) :: CS !< Control structure returned by a !! previous call to diagnostics_init. @@ -222,11 +218,11 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & optional, intent(in) :: eta_bt !< An optional barotropic !! variable that gives the "correct" free surface height (Boussinesq) or total water column !! mass per unit area (non-Boussinesq). This is used to dilate the layer thicknesses when - !! calculating interface heights, in m or kg m-2. + !! calculating interface heights [H ~> m or kg m-2]. ! Local variables integer i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb - ! coordinate variable potential density, in kg m-3. + ! coordinate variable potential density [kg m-3]. real :: Rcv(SZI_(G),SZJ_(G),SZK_(G)) ! Two temporary work arrays real :: work_3d(SZI_(G),SZJ_(G),SZK_(G)) @@ -237,13 +233,13 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & real :: pressure_1d(SZI_(G)) ! Temporary array for pressure when calling EOS real :: wt, wt_p - ! squared Coriolis parameter at to h-points (1/s2) + ! squared Coriolis parameter at to h-points [s-2] real :: f2_h - ! magnitude of the gradient of f (1/(m*s)) + ! magnitude of the gradient of f [s-1 m-1] real :: mag_beta - ! frequency squared used to avoid division by 0 (1/s2) + ! frequency squared used to avoid division by 0 [s-2] ! value is roughly (pi / (the age of the universe) )^2. real, parameter :: absurdly_small_freq2 = 1e-34 @@ -294,7 +290,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & if (CS%id_h > 0) call post_data(CS%id_h, h, CS%diag) if (associated(CS%e)) then - call find_eta(h, tv, GV%g_Earth, G, GV, CS%e, eta_bt) + call find_eta(h, tv, G, GV, US, CS%e, eta_bt) if (CS%id_e > 0) call post_data(CS%id_e, CS%e, CS%diag) endif @@ -304,7 +300,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & CS%e_D(i,j,k) = CS%e(i,j,k) + G%bathyT(i,j) enddo ; enddo ; enddo else - call find_eta(h, tv, GV%g_Earth, G, GV, CS%e_D, eta_bt) + call find_eta(h, tv, G, GV, US, CS%e_D, eta_bt) do k=1,nz+1 ; do j=js,je ; do i=is,ie CS%e_D(i,j,k) = CS%e_D(i,j,k) + G%bathyT(i,j) enddo ; enddo ; enddo @@ -331,10 +327,17 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & call post_data(CS%id_masso, masso, CS%diag) endif - ! diagnose thickness/volumes of grid cells (meter) + ! diagnose thickness/volumes of grid cells [m] if (CS%id_thkcello>0 .or. CS%id_volcello>0) then if (GV%Boussinesq) then ! thkcello = h for Boussinesq - if (CS%id_thkcello > 0) call post_data(CS%id_thkcello, GV%H_to_m*h, CS%diag) + if (CS%id_thkcello > 0) then ; if (GV%H_to_m == 1.0) then + call post_data(CS%id_thkcello, h, CS%diag) + else + do k=1,nz; do j=js,je ; do i=is,ie + work_3d(i,j,k) = GV%H_to_m*h(i,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_thkcello, work_3d, CS%diag) + endif ; endif if (CS%id_volcello > 0) then ! volcello = h*area for Boussinesq do k=1,nz; do j=js,je ; do i=is,ie work_3d(i,j,k) = ( GV%H_to_m*h(i,j,k) ) * G%areaT(i,j) @@ -343,7 +346,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & endif else ! thkcello = dp/(rho*g) for non-Boussinesq do j=js,je - if(associated(p_surf)) then ! Pressure loading at top of surface layer (Pa) + if (associated(p_surf)) then ! Pressure loading at top of surface layer [Pa] do i=is,ie pressure_1d(i) = p_surf(i,j) enddo @@ -353,17 +356,17 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & enddo endif do k=1,nz ! Integrate vertically downward for pressure - do i=is,ie ! Pressure for EOS at the layer center (Pa) - pressure_1d(i) = pressure_1d(i) + 0.5*(GV%g_Earth*GV%H_to_kg_m2)*h(i,j,k) + do i=is,ie ! Pressure for EOS at the layer center [Pa] + pressure_1d(i) = pressure_1d(i) + 0.5*GV%H_to_Pa*h(i,j,k) enddo - ! Store in-situ density (kg/m3) in work_3d + ! Store in-situ density [kg m-3] in work_3d call calculate_density(tv%T(:,j,k),tv%S(:,j,k), pressure_1d, & work_3d(:,j,k), is, ie-is+1, tv%eqn_of_state) do i=is,ie ! Cell thickness = dz = dp/(g*rho) (meter); store in work_3d work_3d(i,j,k) = (GV%H_to_kg_m2*h(i,j,k)) / work_3d(i,j,k) enddo - do i=is,ie ! Pressure for EOS at the bottom interface (Pa) - pressure_1d(i) = pressure_1d(i) + 0.5*(GV%g_Earth*GV%H_to_kg_m2)*h(i,j,k) + do i=is,ie ! Pressure for EOS at the bottom interface [Pa] + pressure_1d(i) = pressure_1d(i) + 0.5*GV%H_to_Pa*h(i,j,k) enddo enddo ! k enddo ! j @@ -385,7 +388,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & if ((CS%id_Tpot > 0) .or. (CS%id_tob > 0)) then do k=1,nz ; do j=js,je ; do i=is,ie work_3d(i,j,k) = gsw_pt_from_ct(tv%S(i,j,k),tv%T(i,j,k)) - enddo; enddo ; enddo + enddo ; enddo ; enddo if (CS%id_Tpot > 0) call post_data(CS%id_Tpot, work_3d, CS%diag) if (CS%id_tob > 0) call post_data(CS%id_tob, work_3d(:,:,nz), CS%diag, mask=G%mask2dT) endif @@ -402,7 +405,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & if ((CS%id_Sprac > 0) .or. (CS%id_sob > 0)) then do k=1,nz ; do j=js,je ; do i=is,ie work_3d(i,j,k) = gsw_sp_from_sr(tv%S(i,j,k)) - enddo; enddo ; enddo + enddo ; enddo ; enddo if (CS%id_Sprac > 0) call post_data(CS%id_Sprac, work_3d, CS%diag) if (CS%id_sob > 0) call post_data(CS%id_sob, work_3d(:,:,nz), CS%diag, mask=G%mask2dT) endif @@ -444,16 +447,16 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & ! layer mean potential temperature if (CS%id_temp_layer_ave>0) then temp_layer_ave = global_layer_mean(tv%T, h, G, GV) - call post_data_1d_k(CS%id_temp_layer_ave, temp_layer_ave, CS%diag) + call post_data(CS%id_temp_layer_ave, temp_layer_ave, CS%diag) endif ! layer mean salinity if (CS%id_salt_layer_ave>0) then salt_layer_ave = global_layer_mean(tv%S, h, G, GV) - call post_data_1d_k(CS%id_salt_layer_ave, salt_layer_ave, CS%diag) + call post_data(CS%id_salt_layer_ave, salt_layer_ave, CS%diag) endif - call calculate_vertical_integrals(h, tv, p_surf, G, GV, CS) + call calculate_vertical_integrals(h, tv, p_surf, G, GV, US, CS) if ((CS%id_Rml > 0) .or. (CS%id_Rcv > 0) .or. associated(CS%h_Rlay) .or. & associated(CS%uh_Rlay) .or. associated(CS%vh_Rlay) .or. & @@ -617,7 +620,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & if ((CS%id_cg1>0) .or. (CS%id_Rd1>0) .or. (CS%id_cfl_cg1>0) .or. & (CS%id_cfl_cg1_x>0) .or. (CS%id_cfl_cg1_y>0)) then - call wave_speed(h, tv, G, GV, CS%cg1, CS%wave_speed_CSp) + call wave_speed(h, tv, G, GV, US, CS%cg1, CS%wave_speed_CSp) if (CS%id_cg1>0) call post_data(CS%id_cg1, CS%cg1, CS%diag) if (CS%id_Rd1>0) then !$OMP parallel do default(none) shared(is,ie,js,je,G,CS) & @@ -658,12 +661,12 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & endif if ((CS%id_cg_ebt>0) .or. (CS%id_Rd_ebt>0) .or. (CS%id_p_ebt>0)) then if (CS%id_p_ebt>0) then - call wave_speed(h, tv, G, GV, CS%cg1, CS%wave_speed_CSp, use_ebt_mode=.true., & + call wave_speed(h, tv, G, GV, US, CS%cg1, CS%wave_speed_CSp, use_ebt_mode=.true., & mono_N2_column_fraction=CS%mono_N2_column_fraction, & mono_N2_depth=CS%mono_N2_depth, modal_structure=CS%p_ebt) call post_data(CS%id_p_ebt, CS%p_ebt, CS%diag) else - call wave_speed(h, tv, G, GV, CS%cg1, CS%wave_speed_CSp, use_ebt_mode=.true., & + call wave_speed(h, tv, G, GV, US, CS%cg1, CS%wave_speed_CSp, use_ebt_mode=.true., & mono_N2_column_fraction=CS%mono_N2_column_fraction, & mono_N2_depth=CS%mono_N2_depth) endif @@ -690,15 +693,19 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & end subroutine calculate_diagnostic_fields -!> This subroutine finds location of R_in in an increasing ordered +!> This subroutine finds the location of R_in in an increasing ordered !! list, Rlist, returning as k the element such that !! Rlist(k) <= R_in < Rlist(k+1), and where wt and wt_p are the linear !! weights that should be assigned to elements k and k+1. subroutine find_weights(Rlist, R_in, k, nz, wt, wt_p) - real, intent(in) :: Rlist(:), R_in - integer, intent(inout) :: k - integer, intent(in) :: nz - real, intent(out) :: wt, wt_p + real, dimension(:), & + intent(in) :: Rlist !< The list of target densities [kg m-3] + real, intent(in) :: R_in !< The density being inserted into Rlist [kg m-3] + integer, intent(inout) :: k !< The value of k such that Rlist(k) <= R_in < Rlist(k+1) + !! The input value is a first guess + integer, intent(in) :: nz !< The number of layers in Rlist + real, intent(out) :: wt !< The weight of layer k for interpolation, nondim + real, intent(out) :: wt_p !< The weight of layer k+1 for interpolation, nondim ! This subroutine finds location of R_in in an increasing ordered ! list, Rlist, returning as k the element such that @@ -717,19 +724,19 @@ subroutine find_weights(Rlist, R_in, k, nz, wt, wt_p) if ((k_lower == 1) .or. (R_in >= Rlist(k_lower))) exit k_upper = k_lower inc = inc*2 - end do + enddo else do k_upper = min(k_upper+inc, nz) if ((k_upper == nz) .or. (R_in < Rlist(k_upper))) exit k_lower = k_upper inc = inc*2 - end do + enddo endif if ((k_lower == 1) .and. (R_in <= Rlist(k_lower))) then k = 1 ; wt = 1.0 ; wt_p = 0.0 - else if ((k_upper == nz) .and. (R_in >= Rlist(k_upper))) then + elseif ((k_upper == nz) .and. (R_in >= Rlist(k_upper))) then k = nz-1 ; wt = 0.0 ; wt_p = 1.0 else do @@ -740,7 +747,7 @@ subroutine find_weights(Rlist, R_in, k, nz, wt, wt_p) else k_lower = k_new endif - end do + enddo ! Uncomment this as a code check ! if ((R_in < Rlist(k_lower)) .or. (R_in >= Rlist(k_upper)) .or. (k_upper-k_lower /= 1)) & @@ -757,34 +764,35 @@ end subroutine find_weights !> This subroutine calculates vertical integrals of several tracers, along !! with the mass-weight of these tracers, the total column mass, and the !! carefully calculated column height. -subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, CS) +subroutine calculate_vertical_integrals(h, tv, p_surf, 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(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2). + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various !! thermodynamic variables. - real, dimension(:,:), pointer :: p_surf !< A pointer to the surface pressure, in Pa. + real, dimension(:,:), pointer :: p_surf !< A pointer to the surface pressure [Pa]. !! If p_surf is not associated, it is the same !! as setting the surface pressure to 0. type(diagnostics_CS), intent(inout) :: CS !< Control structure returned by a !! previous call to diagnostics_init. real, dimension(SZI_(G), SZJ_(G)) :: & - z_top, & ! Height of the top of a layer or the ocean, in m. + z_top, & ! Height of the top of a layer or the ocean [Z ~> m]. z_bot, & ! Height of the bottom of a layer (for id_mass) or the - ! (positive) depth of the ocean (for id_col_ht), in m. - mass, & ! integrated mass of the water column, in kg m-2. For - ! non-Boussinesq models this is rho*dz. For Boussiensq + ! (positive) depth of the ocean (for id_col_ht) [Z ~> m]. + mass, & ! integrated mass of the water column [kg m-2]. For + ! non-Boussinesq models this is rho*dz. For Boussinesq ! models, this is either the integral of in-situ density - ! (rho*dz for col_mass) or reference dens (Rho_0*dz for mass_wt). + ! (rho*dz for col_mass) or reference density (Rho_0*dz for mass_wt). btm_pres,&! The pressure at the ocean bottom, or CMIP variable 'pbo'. ! This is the column mass multiplied by gravity plus the pressure - ! at the ocean surface. - dpress, & ! Change in hydrostatic pressure across a layer, in Pa. + ! at the ocean surface [Pa]. + dpress, & ! Change in hydrostatic pressure across a layer [Pa]. tr_int ! vertical integral of a tracer times density, - ! (Rho_0 in a Boussinesq model) in TR kg m-2. - real :: IG_Earth ! Inverse of gravitational acceleration, in s2 m-1. + ! (Rho_0 in a Boussinesq model) [TR kg m-2]. + real :: IG_Earth ! Inverse of gravitational acceleration [s2 m-1]. integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -814,7 +822,7 @@ subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, CS) endif if (CS%id_col_ht > 0) then - call find_eta(h, tv, GV%g_Earth, G, GV, z_top) + call find_eta(h, tv, G, GV, US, z_top) do j=js,je ; do i=is,ie z_bot(i,j) = z_top(i,j) + G%bathyT(i,j) enddo ; enddo @@ -825,16 +833,16 @@ subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, CS) do j=js,je ; do i=is,ie ; mass(i,j) = 0.0 ; enddo ; enddo if (GV%Boussinesq) then if (associated(tv%eqn_of_state)) then - IG_Earth = 1.0 / GV%g_Earth + IG_Earth = 1.0 / (GV%g_Earth*US%m_to_Z) ! do j=js,je ; do i=is,ie ; z_bot(i,j) = -P_SURF(i,j)/GV%H_to_Pa ; enddo ; enddo do j=js,je ; do i=is,ie ; z_bot(i,j) = 0.0 ; enddo ; enddo do k=1,nz do j=js,je ; do i=is,ie z_top(i,j) = z_bot(i,j) - z_bot(i,j) = z_top(i,j) - GV%H_to_m*h(i,j,k) + z_bot(i,j) = z_top(i,j) - GV%H_to_Z*h(i,j,k) enddo ; enddo call int_density_dz(tv%T(:,:,k), tv%S(:,:,k), & - z_top, z_bot, 0.0, GV%H_to_kg_m2, GV%g_Earth, & + z_top, z_bot, 0.0, GV%Rho0, GV%g_Earth, & G%HI, G%HI, tv%eqn_of_state, dpress) do j=js,je ; do i=is,ie mass(i,j) = mass(i,j) + dpress(i,j) * IG_Earth @@ -859,7 +867,7 @@ subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, CS) ! pbo = (mass * g) + p_surf ! where p_surf is the sea water pressure at sea water surface. do j=js,je ; do i=is,ie - btm_pres(i,j) = mass(i,j) * GV%g_Earth + btm_pres(i,j) = mass(i,j) * (GV%g_Earth*US%m_to_Z) if (associated(p_surf)) then btm_pres(i,j) = btm_pres(i,j) + p_surf(i,j) endif @@ -872,42 +880,28 @@ end subroutine calculate_vertical_integrals !> This subroutine calculates terms in the mechanical energy budget. subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, 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) :: u !< The zonal velocity, in m s-1. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< The meridional velocity, - !! in m s-1. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H - !! (usually m or kg m-2). - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: uh !< Transport through zonal - !! faces=u*h*dy: m3/s (Bouss) - !! kg/s(non-Bouss). - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: vh !< Transport through merid - !! faces=v*h*dx: m3/s (Bouss) - !! kg/s(non-Bouss). - type(accel_diag_ptrs), intent(in) :: ADp !< Structure pointing to - !! accelerations in momentum - !! equation. - type(cont_diag_ptrs), intent(in) :: CDp !< Structure pointing to terms - !! in continuity equations. - type(diagnostics_CS), intent(inout) :: CS !< Control structure returned by - !! a previous call to - !! diagnostics_init. + 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) :: 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(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(in) :: uh !< Transport through zonal faces=u*h*dy, + !! [H m2 s-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(in) :: vh !< Transport through merid faces=v*h*dx, + !! [H m2 s-1 ~> m3 s-1 or kg s-1]. + type(accel_diag_ptrs), intent(in) :: ADp !< Structure pointing to accelerations in momentum equation. + type(cont_diag_ptrs), intent(in) :: CDp !< Structure pointing to terms in continuity equations. + type(diagnostics_CS), intent(inout) :: CS !< Control structure returned by a previous call to + !! diagnostics_init. ! This subroutine calculates terms in the mechanical energy budget. -! Arguments: -! (in) u - zonal velocity component (m/s) -! (in) v - meridional velocity componnent (m/s) -! (in) h - layer thickness: metre(Bouss) of kg/m2(non-Bouss) -! (in) uh - transport through zonal faces=u*h*dy: m3/s (Bouss) kg/s(non-Bouss) -! (in) vh - transport through merid faces=v*h*dx: m3/s (Bouss) kg/s(non-Bouss) -! (in) ADp - structure pointing to accelerations in momentum equation -! (in) CDp - structure pointing to terms in continuity equations -! (in) G - ocean grid structure -! (in) CS - control structure returned by a previous call to diagnostics_init - + ! Local variables real :: KE_u(SZIB_(G),SZJ_(G)) real :: KE_v(SZI_(G),SZJB_(G)) real :: KE_h(SZI_(G),SZJ_(G)) @@ -931,8 +925,8 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, CS) if (CS%id_KE > 0) call post_data(CS%id_KE, CS%KE, CS%diag) endif - if(.not.G%symmetric) then - if(associated(CS%dKE_dt) .OR. associated(CS%PE_to_KE) .OR. associated(CS%KE_CorAdv) .OR. & + if (.not.G%symmetric) then + if (associated(CS%dKE_dt) .OR. associated(CS%PE_to_KE) .OR. associated(CS%KE_CorAdv) .OR. & associated(CS%KE_adv) .OR. associated(CS%KE_visc) .OR. associated(CS%KE_horvisc).OR. & associated(CS%KE_dia) ) then call create_group_pass(CS%pass_KE_uv, KE_u, KE_v, G%Domain, To_North+To_East) @@ -1086,16 +1080,11 @@ end subroutine calculate_energy_diagnostics 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 - !! placed. + !! will be placed. type(diagnostics_CS), pointer :: CS !< Control structure returned by previous call to !! diagnostics_init. -! This subroutine registers fields to calculate a diagnostic time derivative. -! Arguments: -! (target) f_ptr - field whose derivative is taken -! (in) deriv_ptr - field in which the calculated time derivatives placed -! (in) num_lay - number of layers in this field -! (in) CS - control structure returned by previous call to diagnostics_init + ! This subroutine registers fields to calculate a diagnostic time derivative. integer :: m @@ -1121,18 +1110,12 @@ end subroutine register_time_deriv !> This subroutine calculates all registered time derivatives. subroutine calculate_derivs(dt, G, CS) - real, intent(in) :: dt !< The time interval over which differences occur, - !! in s. + real, intent(in) :: dt !< The time interval over which differences occur [s]. type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(diagnostics_CS), intent(inout) :: CS !< Control structure returned by previous call to !! diagnostics_init. ! This subroutine calculates all registered time derivatives. -! Arguments: -! (in) dt - time interval in s over which differences occur -! (in) G - ocean grid structure. -! (in) CS - control structure returned by previous call to diagnostics_init - integer i, j, k, m real Idt @@ -1148,28 +1131,64 @@ subroutine calculate_derivs(dt, G, CS) end subroutine calculate_derivs +!> This routine posts diagnostics of various dynamic ocean surface quantities, +!! including velocities, speed and sea surface height, at the time the ocean +!! state is reported back to the caller +subroutine post_surface_dyn_diags(IDs, G, diag, sfc_state, ssh) + type(surface_diag_IDs), intent(in) :: IDs !< A structure with the diagnostic IDs. + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(diag_ctrl), intent(in) :: diag !< regulates diagnostic output + type(surface), intent(in) :: sfc_state !< structure describing the ocean surface state + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: ssh !< Time mean surface height without corrections for ice displacement [m] + + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: work_2d ! A 2-d work array + integer :: i, j, is, ie, js, je + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + if (IDs%id_ssh > 0) & + call post_data(IDs%id_ssh, ssh, diag, mask=G%mask2dT) + + if (IDs%id_ssu > 0) & + call post_data(IDs%id_ssu, sfc_state%u, diag, mask=G%mask2dCu) + + if (IDs%id_ssv > 0) & + call post_data(IDs%id_ssv, sfc_state%v, diag, mask=G%mask2dCv) + + if (IDs%id_speed > 0) then + do j=js,je ; do i=is,ie + work_2d(i,j) = sqrt(0.5*(sfc_state%u(I-1,j)**2 + sfc_state%u(I,j)**2) + & + 0.5*(sfc_state%v(i,J-1)**2 + sfc_state%v(i,J)**2)) + enddo ; enddo + call post_data(IDs%id_speed, work_2d, diag, mask=G%mask2dT) + endif + +end subroutine post_surface_dyn_diags + + !> This routine posts diagnostics of various ocean surface and integrated !! quantities at the time the ocean state is reported back to the caller -subroutine post_surface_diagnostics(IDs, G, GV, diag, dt_int, sfc_state, tv, & +subroutine post_surface_thermo_diags(IDs, G, GV, US, diag, dt_int, sfc_state, tv, & ssh, ssh_ibc) type(surface_diag_IDs), intent(in) :: IDs !< A structure with the diagnostic IDs. type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(diag_ctrl), intent(in) :: diag !< regulates diagnostic output - real, intent(in) :: dt_int !< total time step associated with these diagnostics, in s. + real, intent(in) :: dt_int !< total time step associated with these diagnostics [s]. type(surface), intent(in) :: sfc_state !< structure describing the ocean surface state type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables real, dimension(SZI_(G),SZJ_(G)), & - intent(in) :: ssh !< Time mean surface height without corrections for - !! ice displacement (m) - real, dimension(SZI_(G),SZJ_(G)), & - intent(in) :: ssh_ibc !< Time mean surface height with corrections for - !! ice displacement and the inverse barometer (m) + intent(in) :: ssh !< Time mean surface height without corrections for ice displacement [m] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: ssh_ibc !< Time mean surface height with corrections + !! for ice displacement and the inverse barometer [m] real, dimension(SZI_(G),SZJ_(G)) :: work_2d ! A 2-d work array real, dimension(SZI_(G),SZJ_(G)) :: & - zos ! dynamic sea lev (zero area mean) from inverse-barometer adjusted ssh (meter) - real :: I_time_int ! The inverse of the time interval in s-1. + zos ! dynamic sea lev (zero area mean) from inverse-barometer adjusted ssh [m] + real :: I_time_int ! The inverse of the time interval [s-1]. real :: zos_area_mean, volo, ssh_ga integer :: i, j, is, ie, js, je @@ -1181,10 +1200,6 @@ subroutine post_surface_diagnostics(IDs, G, GV, diag, dt_int, sfc_state, tv, & call post_data(IDs%id_ssh_ga, ssh_ga, diag) endif - I_time_int = 1.0 / dt_int - if (IDs%id_ssh > 0) & - call post_data(IDs%id_ssh, ssh, diag, mask=G%mask2dT) - ! post the dynamic sea level, zos, and zossq. ! zos is ave_ssh with sea ice inverse barometer removed, ! and with zero global area mean. @@ -1209,12 +1224,15 @@ subroutine post_surface_diagnostics(IDs, G, GV, diag, dt_int, sfc_state, tv, & ! post total volume of the liquid ocean if (IDs%id_volo > 0) then do j=js,je ; do i=is,ie - work_2d(i,j) = G%mask2dT(i,j)*(ssh(i,j) + G%bathyT(i,j)) + work_2d(i,j) = G%mask2dT(i,j)*(ssh(i,j) + US%Z_to_m*G%bathyT(i,j)) enddo ; enddo volo = global_area_integral(work_2d, G) call post_data(IDs%id_volo, volo, diag) endif + ! Use Adcroft's rule of reciprocals; it does the right thing here. + I_time_int = 0.0 ; if (dt_int > 0.0) I_time_int = 1.0 / dt_int + ! post time-averaged rate of frazil formation if (associated(tv%frazil) .and. (IDs%id_fraz > 0)) then do j=js,je ; do i=is,ie @@ -1288,51 +1306,41 @@ subroutine post_surface_diagnostics(IDs, G, GV, diag, dt_int, sfc_state, tv, & call post_data(IDs%id_sss_sq, work_2d, diag, mask=G%mask2dT) endif - if (IDs%id_ssu > 0) & - call post_data(IDs%id_ssu, sfc_state%u, diag, mask=G%mask2dCu) - if (IDs%id_ssv > 0) & - call post_data(IDs%id_ssv, sfc_state%v, diag, mask=G%mask2dCv) - - if (IDs%id_speed > 0) then - do j=js,je ; do i=is,ie - work_2d(i,j) = sqrt(0.5*(sfc_state%u(I-1,j)**2 + sfc_state%u(I,j)**2) + & - 0.5*(sfc_state%v(i,J-1)**2 + sfc_state%v(i,J)**2)) - enddo ; enddo - call post_data(IDs%id_speed, work_2d, diag, mask=G%mask2dT) - endif - call coupler_type_send_data(sfc_state%tr_fields, get_diag_time_end(diag)) -end subroutine post_surface_diagnostics +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, & + diag_to_Z_CSp, 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 used - !! to advect tracers (m3 or kg) - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & - intent(in) :: vhtr !< Accumulated meridional thickness fluxes - !! used to advect tracers (m3 or kg) + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: uhtr !< Accumulated zonal thickness fluxes + !! used to advect tracers [H m2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: vhtr !< Accumulated meridional thickness fluxes + !! used to advect tracers [H m2 ~> m3 or kg] real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< The updated layer thicknesses, in H + intent(in) :: h !< The updated layer thicknesses [H ~> m or kg m-2] type(transport_diag_IDs), intent(in) :: IDs !< A structure with the diagnostic IDs. 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, in s. + 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 - real, dimension(SZIB_(G), SZJ_(G)) :: umo2d ! Diagnostics of integrated mass transport, in kg s-1 - real, dimension(SZI_(G), SZJB_(G)) :: vmo2d ! Diagnostics of integrated mass transport, in kg s-1 - real, dimension(SZIB_(G), SZJ_(G), SZK_(G)) :: umo ! Diagnostics of layer mass transport, in kg s-1 - real, dimension(SZI_(G), SZJB_(G), SZK_(G)) :: vmo ! Diagnostics of layer mass transport, in kg s-1 - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_tend ! Change in layer thickness due to dynamics m s-1 - real :: Idt - real :: H_to_kg_m2_dt ! A conversion factor from accumulated transports to fluxes, in kg m-2 H-1 s-1. + ! Local variables + real, dimension(SZIB_(G), SZJ_(G)) :: umo2d ! Diagnostics of integrated mass transport [kg s-1] + real, dimension(SZI_(G), SZJB_(G)) :: vmo2d ! Diagnostics of integrated mass transport [kg s-1] + real, dimension(SZIB_(G), SZJ_(G), SZK_(G)) :: umo ! Diagnostics of layer mass transport [kg s-1] + real, dimension(SZI_(G), SZJB_(G), SZK_(G)) :: vmo ! Diagnostics of layer mass transport [kg s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_tend ! Change in layer thickness due to dynamics + ! [H s-1 ~> m s-1 or kg m-2 s-1]. + real :: Idt ! The inverse of the time interval [s-1] + real :: H_to_kg_m2_dt ! A conversion factor from accumulated transports to fluxes + ! [kg m-2 H-1 s-1 ~> kg m-3 s-1 or s-1]. integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -1352,7 +1360,7 @@ subroutine post_transport_diagnostics(G, GV, uhtr, vhtr, h, IDs, diag_pre_dyn, d call post_data(IDs%id_umo_2d, umo2d, diag) endif if (IDs%id_umo > 0) then - ! Convert to kg/s. Modifying the array for diagnostics is allowed here since it is set to zero immediately below + ! Convert to kg/s. do k=1,nz ; do j=js,je ; do I=is-1,ie umo(I,j,k) = uhtr(I,j,k) * H_to_kg_m2_dt enddo ; enddo ; enddo @@ -1366,7 +1374,7 @@ subroutine post_transport_diagnostics(G, GV, uhtr, vhtr, h, IDs, diag_pre_dyn, d call post_data(IDs%id_vmo_2d, vmo2d, diag) endif if (IDs%id_vmo > 0) then - ! Convert to kg/s. Modifying the array for diagnostics is allowed here since it is set to zero immediately below + ! Convert to kg/s. do k=1,nz ; do J=js-1,je ; do i=is,ie vmo(i,J,k) = vhtr(i,J,k) * H_to_kg_m2_dt enddo ; enddo ; enddo @@ -1375,7 +1383,8 @@ subroutine post_transport_diagnostics(G, GV, uhtr, vhtr, h, IDs, diag_pre_dyn, d if (IDs%id_uhtr > 0) call post_data(IDs%id_uhtr, uhtr, diag, alt_h = diag_pre_dyn%h_state) if (IDs%id_vhtr > 0) call post_data(IDs%id_vhtr, vhtr, diag, alt_h = diag_pre_dyn%h_state) - if (IDs%id_dynamics_h > 0 ) call post_data(IDs%id_dynamics_h, diag_pre_dyn%h_state, diag, alt_h = diag_pre_dyn%h_state) + if (IDs%id_dynamics_h > 0) call post_data(IDs%id_dynamics_h, diag_pre_dyn%h_state, diag, & + alt_h = diag_pre_dyn%h_state) ! Post the change in thicknesses if (IDs%id_dynamics_h_tendency > 0) then h_tend(:,:,:) = 0. @@ -1393,7 +1402,7 @@ end subroutine post_transport_diagnostics !> This subroutine registers various diagnostics and allocates space for fields !! that other diagnostis depend upon. -subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, param_file, diag, CS, tv) +subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag, CS, tv) type(ocean_internal_state), intent(in) :: MIS !< For "MOM Internal State" a set of pointers to !! the fields and accelerations that make up the !! ocean's internal physical state. @@ -1404,6 +1413,7 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, 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 !< Structure to regulate diagnostic output. @@ -1412,25 +1422,11 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, param_file, diag, CS type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various !! thermodynamic variables. -! Arguments -! (in) MIS - For "MOM Internal State" a set of pointers to the fields and -! accelerations that make up the ocean's internal physical -! state. -! (inout) ADp - structure with pointers to momentum equation terms -! (inout) CDp - structure with pointers to continuity equation terms -! (in) Time - current model time -! (in) G - ocean grid structure -! (in) GV - The ocean's vertical grid structure. -! (in) param_file - structure indicating the open file to parse for -! model parameter values -! (in) diag - structure to regulate diagnostic output -! (in/out) CS - pointer set to point to control structure for this module - -! This include declares and sets the variable "version". -#include "version_variable.h" - - character(len=40) :: mdl = "MOM_diagnostics" ! This module's name. + ! Local variables real :: omega, f2_min, convert_H + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "MOM_diagnostics" ! This module's name. character(len=48) :: thickness_units, flux_units logical :: use_temperature integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz, nkml, nkbl @@ -1536,11 +1532,11 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, param_file, diag, CS 'Layer Thickness', thickness_units, v_extensive=.true., conversion=convert_H) CS%id_e = register_diag_field('ocean_model', 'e', diag%axesTi, Time, & - 'Interface Height Relative to Mean Sea Level', 'm') + 'Interface Height Relative to Mean Sea Level', 'm', conversion=US%Z_to_m) if (CS%id_e>0) call safe_alloc_ptr(CS%e,isd,ied,jsd,jed,nz+1) CS%id_e_D = register_diag_field('ocean_model', 'e_D', diag%axesTi, Time, & - 'Interface Height above the Seafloor', 'm') + 'Interface Height above the Seafloor', 'm', conversion=US%Z_to_m) if (CS%id_e_D>0) call safe_alloc_ptr(CS%e_D,isd,ied,jsd,jed,nz+1) CS%id_Rml = register_diag_field('ocean_model', 'Rml', diag%axesTL, Time, & @@ -1692,7 +1688,7 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, param_file, diag, CS 'The column integrated in situ density', 'kg m-2') CS%id_col_ht = register_diag_field('ocean_model', 'col_height', diag%axesT1, Time, & - 'The height of the water column', 'm') + 'The height of the water column', 'm', conversion=US%Z_to_m) CS%id_pbo = register_diag_field('ocean_model', 'pbo', diag%axesT1, Time, & long_name='Sea Water Pressure at Sea Floor', standard_name='sea_water_pressure_at_sea_floor', & units='Pa') @@ -1821,14 +1817,15 @@ subroutine register_transport_diags(Time, G, GV, IDs, diag) end subroutine register_transport_diags !> Offers the static fields in the ocean grid type for output via the diag_manager. -subroutine write_static_fields(G, GV, tv, diag) +subroutine write_static_fields(G, GV, US, tv, diag) type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables type(diag_ctrl), target, intent(inout) :: diag !< regulates diagnostic output + ! Local variables - real :: tmp_h(SZI_(G),SZJ_(G)) - integer :: id, i, j + integer :: id id = register_static_field('ocean_model', 'geolat', diag%axesT1, & 'Latitude of tracer (T) points', 'degrees_north') @@ -1877,35 +1874,29 @@ subroutine write_static_fields(G, GV, tv, diag) cmor_field_name='areacello_cu', cmor_standard_name='cell_area', & cmor_long_name='Ocean Grid-Cell Area', & x_cell_method='sum', y_cell_method='sum', area_cell_method='sum') - if (id > 0) then - call post_data(id, G%areaCu, diag, .true.) - endif + if (id > 0) call post_data(id, G%areaCu, diag, .true.) id = register_static_field('ocean_model', 'area_v', diag%axesCv1, & 'Surface area of y-direction flow (V) cells', 'm2', & cmor_field_name='areacello_cv', cmor_standard_name='cell_area', & cmor_long_name='Ocean Grid-Cell Area', & x_cell_method='sum', y_cell_method='sum', area_cell_method='sum') - if (id > 0) then - call post_data(id, G%areaCv, diag, .true.) - endif + if (id > 0) call post_data(id, G%areaCv, diag, .true.) id = register_static_field('ocean_model', 'area_q', diag%axesB1, & 'Surface area of B-grid flow (Q) cells', 'm2', & cmor_field_name='areacello_bu', cmor_standard_name='cell_area', & cmor_long_name='Ocean Grid-Cell Area', & x_cell_method='sum', y_cell_method='sum', area_cell_method='sum') - if (id > 0) then - call post_data(id, G%areaBu, diag, .true.) - endif + if (id > 0) call post_data(id, G%areaBu, diag, .true.) id = register_static_field('ocean_model', 'depth_ocean', diag%axesT1, & 'Depth of the ocean at tracer points', 'm', & standard_name='sea_floor_depth_below_geoid', & cmor_field_name='deptho', cmor_long_name='Sea Floor Depth', & - cmor_standard_name='sea_floor_depth_below_geoid',& - area=diag%axesT1%id_area, & - x_cell_method='mean', y_cell_method='mean', area_cell_method='mean') + cmor_standard_name='sea_floor_depth_below_geoid', area=diag%axesT1%id_area, & + x_cell_method='mean', y_cell_method='mean', area_cell_method='mean', & + conversion=US%Z_to_m) if (id > 0) call post_data(id, G%bathyT, diag, .true., mask=G%mask2dT) id = register_static_field('ocean_model', 'wet', diag%axesT1, & @@ -1960,6 +1951,14 @@ subroutine write_static_fields(G, GV, tv, diag) 'Open zonal grid spacing at v points (meter)', 'm', interp_method='none') if (id > 0) call post_data(id, G%dx_Cv, diag, .true.) + id = register_static_field('ocean_model', 'sin_rot', diag%axesT1, & + 'sine of the clockwise angle of the ocean grid north to true north', 'none') + if (id > 0) call post_data(id, G%sin_rot, diag, .true.) + + id = register_static_field('ocean_model', 'cos_rot', diag%axesT1, & + 'cosine of the clockwise angle of the ocean grid north to true north', 'none') + if (id > 0) call post_data(id, G%cos_rot, diag, .true.) + ! This static diagnostic is from CF 1.8, and is the fraction of a cell ! covered by ocean, given as a percentage (poorly named). @@ -1967,12 +1966,10 @@ subroutine write_static_fields(G, GV, tv, diag) 'Percentage of cell area covered by ocean', '%', & cmor_field_name='sftof', cmor_standard_name='SeaAreaFraction', & cmor_long_name='Sea Area Fraction', & - x_cell_method='mean', y_cell_method='mean', area_cell_method='mean') - if (id > 0) then - tmp_h(:,:) = 0. - tmp_h(G%isc:G%iec,G%jsc:G%jec) = 100. * G%mask2dT(G%isc:G%iec,G%jsc:G%jec) - call post_data(id, tmp_h, diag, .true.) - endif + x_cell_method='mean', y_cell_method='mean', area_cell_method='mean', & + conversion=100.0) + if (id > 0) call post_data(id, G%mask2dT, diag, .true.) + id = register_static_field('ocean_model','Rho_0', diag%axesNull, & 'mean ocean density used with the Boussinesq approximation', & @@ -2004,14 +2001,6 @@ subroutine set_dependent_diagnostics(MIS, ADp, CDp, G, CS) !! module. ! This subroutine sets up diagnostics upon which other diagnostics depend. -! Arguments: -! (in) MIS - For "MOM Internal State" a set of pointers to the fields and -! accelerations making up ocean internal physical state. -! (inout) ADp - structure pointing to accelerations in momentum equation -! (inout) CDp - structure pointing to terms in continuity equation -! (in) G - ocean grid structure -! (in) CS - pointer to the control structure for this module - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = G%ke IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB @@ -2057,9 +2046,12 @@ subroutine set_dependent_diagnostics(MIS, ADp, CDp, G, CS) end subroutine set_dependent_diagnostics +!> Deallocate memory associated with the diagnostics module subroutine MOM_diagnostics_end(CS, ADp) - type(diagnostics_CS), pointer :: CS - type(accel_diag_ptrs), intent(inout) :: ADp + type(diagnostics_CS), pointer :: CS !< Control structure returned by a + !! previous call to diagnostics_init. + type(accel_diag_ptrs), intent(inout) :: ADp !< structure with pointers to + !! accelerations in momentum equation. integer :: m if (associated(CS%e)) deallocate(CS%e) diff --git a/src/diagnostics/MOM_obsolete_diagnostics.F90 b/src/diagnostics/MOM_obsolete_diagnostics.F90 index 4cf55bad3b..4bd5b61255 100644 --- a/src/diagnostics/MOM_obsolete_diagnostics.F90 +++ b/src/diagnostics/MOM_obsolete_diagnostics.F90 @@ -64,9 +64,9 @@ end subroutine register_obsolete_diagnostics !> Fakes a register of a diagnostic to find out if an obsolete !! parameter appears in the diag_table. logical function found_in_diagtable(diag, varName, newVarName) - type(diag_ctrl), intent(in) :: diag - character(len=*), intent(in) :: varName - character(len=*), optional, intent(in) :: newVarName + type(diag_ctrl), intent(in) :: diag !< A structure used to control diagnostics. + character(len=*), intent(in) :: varName !< The obsolete diagnostic name + character(len=*), optional, intent(in) :: newVarName !< The valid name of this diagnostic ! Local integer :: handle ! Integer handle returned from diag_manager diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index 18de7c2902..cfc74b47fc 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -1,52 +1,18 @@ +!> Reports integrated quantities for monitoring the model state module MOM_sum_output ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Robert Hallberg, April 1994 - June 2002 * -!* * -!* This file contains the subroutine (write_energy) that writes * -!* horizontally integrated quantities, such as energies and layer * -!* volumes, and other summary information to an output file. Some * -!* of these quantities (APE or resting interface height) are defined * -!* relative to the global histogram of topography. The subroutine * -!* that compiles that histogram (depth_list_setup) is also included * -!* in this file. * -!* * -!* In addition, if the number of velocity truncations since the * -!* previous call to write_energy exceeds maxtrunc or the total energy * -!* exceeds a very large threshold, a fatal termination is triggered. * -!* * -!* This file also contains a few miscelaneous initialization * -!* calls to FMS-related modules. * -!* * -!* Macros written all in capital letters are defined in MOM_memory.h. * -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q * -!* j+1 > o > o > At ^: v * -!* j x ^ x ^ x At >: u * -!* j > o > o > At o: h, bathyT * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** - use MOM_coms, only : sum_across_PEs, PE_here, root_PE, num_PEs, max_across_PEs -use MOM_coms, only : reproducing_sum -use MOM_coms, only : EFP_type, operator(+), operator(-), assignment(=), EFP_to_real, real_to_EFP +use MOM_coms, only : reproducing_sum, EFP_to_real, real_to_EFP +use MOM_coms, only : EFP_type, operator(+), operator(-), assignment(=) use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe, MOM_mesg use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing use MOM_grid, only : ocean_grid_type use MOM_interface_heights, only : find_eta -use MOM_io, only : create_file, fieldtype, flush_file, open_file, reopen_file, get_filename_appendix -use MOM_io, only : file_exists, slasher, vardesc, var_desc, write_field +use MOM_io, only : create_file, fieldtype, flush_file, open_file, reopen_file +use MOM_io, only : file_exists, slasher, vardesc, var_desc, write_field, get_filename_appendix use MOM_io, only : APPEND_FILE, ASCII_FILE, SINGLE_FILE, WRITEONLY_FILE use MOM_open_boundary, only : ocean_OBC_type, OBC_segment_type use MOM_open_boundary, only : OBC_DIRECTION_E, OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S @@ -55,6 +21,7 @@ module MOM_sum_output use MOM_time_manager, only : operator(/=), operator(<=), operator(>=), operator(<) use MOM_time_manager, only : get_calendar_type, time_type_to_real, NO_CALENDAR use MOM_tracer_flow_control, only : tracer_flow_control_CS, call_tracer_stocks +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface, thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type @@ -66,55 +33,57 @@ module MOM_sum_output public write_energy, accumulate_net_input, MOM_sum_output_init -!----------------------------------------------------------------------- +! 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. -integer, parameter :: NUM_FIELDS = 17 +integer, parameter :: NUM_FIELDS = 17 !< Number of diagnostic fields +!> A list of depths and corresponding globally integrated ocean area at each +!! depth and the ocean volume below each depth. type :: Depth_List - real :: depth ! A depth, in m. - real :: area ! The cross-sectional area of the ocean at that depth, in m2. - real :: vol_below ! The ocean volume below that depth, in m3. + real :: depth !< A depth [m]. + real :: area !< The cross-sectional area of the ocean at that depth [m2]. + real :: vol_below !< The ocean volume below that depth [m3]. end type Depth_List +!> The control structure for the MOM_sum_output module type, public :: sum_output_CS ; private - type(Depth_List), pointer, dimension(:) :: DL => NULL() ! The sorted depth list. - integer :: list_size ! =niglobal*njglobal length of sorting vector - - integer ALLOCABLE_, dimension(NKMEM_) :: lH - ! This saves the entry in DL with a volume just - ! less than the volume of fluid below the - ! interface. - logical :: do_APE_calc ! If true, calculate the available potential - ! energy of the interfaces. Disabling this - ! reduces the memory footprint of high-PE-count - ! models dramatically. - logical :: read_depth_list ! Read the depth list from a file if it exists - ! and write it if it doesn't. - character(len=200) :: depth_list_file ! The name of the depth list file. - real :: D_list_min_inc ! The minimum increment, in m, between the - ! depths of the entries in the depth-list file, - ! 0 by default. - 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 - real :: mass_prev ! The total ocean mass the last time that - ! write_energy was called, in kg. - real :: salt_prev ! The total amount of salt in the ocean the last - ! time that write_energy was called, in PSU kg. - real :: net_salt_input ! The total salt added by surface fluxes since - ! the last time that write_energy was called, - ! in PSU kg. - real :: heat_prev ! The total amount of heat in the ocean the last - ! time that write_energy was called, in Joules. - real :: net_heat_input ! The total heat added by surface fluxes since - ! the last time that write_energy was called, - ! in Joules. - type(EFP_type) :: & - fresh_water_in_EFP, & ! These are extended fixed point versions of the - net_salt_in_EFP, & ! correspondingly named variables above. - net_heat_in_EFP, heat_prev_EFP, salt_prev_EFP, mass_prev_EFP - real :: dt ! The baroclinic dynamics time step, in s. + type(Depth_List), pointer, dimension(:) :: DL => NULL() !< The sorted depth list. + integer :: list_size !< length of sorting vector <= niglobal*njglobal + + integer, allocatable, dimension(:) :: lH + !< This saves the entry in DL with a volume just + !! less than the volume of fluid below the interface. + logical :: do_APE_calc !< If true, calculate the available potential energy of the + !! interfaces. Disabling this reduces the memory footprint of + !! high-PE-count models dramatically. + logical :: read_depth_list !< Read the depth list from a file if it exists + !! and write it if it doesn't. + 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 :: 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]. + real :: mass_prev !< The total ocean mass the last time that + !! write_energy was called [kg]. + real :: salt_prev !< The total amount of salt in the ocean the last + !! time that write_energy was called [ppt kg]. + real :: net_salt_input !< The total salt added by surface fluxes since the last + !! time that write_energy was called [ppt kg]. + real :: heat_prev !< The total amount of heat in the ocean the last + !! time that write_energy was called [J]. + real :: net_heat_input !< The total heat added by surface fluxes since the last + !! the last time that write_energy was called [J]. + type(EFP_type) :: fresh_water_in_EFP !< An extended fixed point version of fresh_water_input + type(EFP_type) :: net_salt_in_EFP !< An extended fixed point version of net_salt_input + type(EFP_type) :: net_heat_in_EFP !< An extended fixed point version of net_heat_input + type(EFP_type) :: heat_prev_EFP !< An extended fixed point version of heat_prev + type(EFP_type) :: salt_prev_EFP !< An extended fixed point version of salt_prev + type(EFP_type) :: mass_prev_EFP !< An extended fixed point version of mass_prev + real :: dt !< The baroclinic dynamics time step [s]. type(time_type) :: energysavedays !< The interval between writing the energies !! and other integral quantities of the run. @@ -129,35 +98,34 @@ module MOM_sum_output !! of calls to write_energy and revert to the standard !! energysavedays interval - real :: timeunit ! The length of the units for the time - ! axis, in s. - logical :: date_stamped_output ! If true, use dates (not times) in messages to stdout. - type(time_type) :: Start_time ! The start time of the simulation. + real :: timeunit !< The length of the units for the time axis [s]. + logical :: date_stamped_output !< If true, use dates (not times) in messages to stdout. + type(time_type) :: Start_time !< The start time of the simulation. ! Start_time is set in MOM_initialization.F90 - integer, pointer :: ntrunc ! The number of times the velocity has been - ! truncated since the last call to write_energy. - real :: max_Energy ! The maximum permitted energy per unit mass; - ! If there is more energy than this, the model - ! should stop, in m2 s-2. - integer :: maxtrunc ! The number of truncations per energy save - ! interval at which the run is stopped. - logical :: write_stocks ! If true, write the integrated tracer amounts - ! to stdout when the energy files are written. - integer :: previous_calls = 0 ! The number of times write_energy has been called. - integer :: prev_n = 0 ! The value of n from the last call. - integer :: fileenergy_nc ! NetCDF id of the energy file. - integer :: fileenergy_ascii ! The unit number of the ascii version of the energy file. + integer, pointer :: ntrunc => NULL() !< The number of times the velocity has been + !! truncated since the last call to write_energy. + real :: max_Energy !< The maximum permitted energy per unit mass. If there is + !! more energy than this, the model should stop [m2 s-2]. + integer :: maxtrunc !< The number of truncations per energy save + !! interval at which the run is stopped. + logical :: write_stocks !< If true, write the integrated tracer amounts + !! to stdout when the energy files are written. + integer :: previous_calls = 0 !< The number of times write_energy has been called. + integer :: prev_n = 0 !< The value of n from the last call. + integer :: fileenergy_nc !< NetCDF id of the energy file. + integer :: fileenergy_ascii !< The unit number of the ascii version of the energy file. type(fieldtype), dimension(NUM_FIELDS+MAX_FIELDS_) :: & - fields ! fieldtype variables for the output fields. - character(len=200) :: energyfile ! The name of the energy file with path. + fields !< fieldtype variables for the output fields. + character(len=200) :: energyfile !< The name of the energy file with path. end type sum_output_CS contains !> MOM_sum_output_init initializes the parameters and settings for the MOM_sum_output module. -subroutine MOM_sum_output_init(G, param_file, directory, ntrnc, & +subroutine MOM_sum_output_init(G, US, param_file, directory, ntrnc, & Input_start_time, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's 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. character(len=*), intent(in) :: directory !< The directory where the energy file goes. @@ -167,17 +135,10 @@ subroutine MOM_sum_output_init(G, param_file, directory, ntrnc, & type(time_type), intent(in) :: Input_start_time !< The start time of the simulation. type(Sum_output_CS), pointer :: CS !< A pointer that is set to point to the !! control structure for this module. -! Arguments: G - The ocean's grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in) directory - The directory where the energy file goes. -! (in/out) ntrnc - The integer that stores the number of times the velocity -! has been truncated since the last call to write_energy. -! (in) Input_start_time - The start time of the simulation. -! (in/out) CS - A pointer that is set to point to the control structure -! for this module - real :: Time_unit ! The time unit in seconds for ENERGYSAVEDAYS. - real :: Rho_0, maxvel + ! Local variables + real :: Time_unit ! The time unit in seconds for ENERGYSAVEDAYS. + real :: Rho_0 ! A reference density [kg m-3] + real :: maxvel ! The maximum permitted velocity [m s-1] ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "MOM_sum_output" ! This module's name. @@ -223,7 +184,7 @@ subroutine MOM_sum_output_init(G, param_file, directory, ntrnc, & "The maximum velocity allowed before the velocity \n"//& "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) + call log_param(param_file, mdl, "MAX_ENERGY as used", CS%max_Energy) endif call get_param(param_file, mdl, "ENERGYFILE", energyfile, & @@ -232,9 +193,9 @@ subroutine MOM_sum_output_init(G, param_file, directory, ntrnc, & !query fms_io if there is a filename_appendix (for ensemble runs) call get_filename_appendix(filename_appendix) - if(len_trim(filename_appendix) > 0) then + if (len_trim(filename_appendix) > 0) then energyfile = trim(energyfile) //'.'//trim(filename_appendix) - end if + endif CS%energyfile = trim(slasher(directory))//trim(energyfile) call log_param(param_file, mdl, "output_path/ENERGYFILE", CS%energyfile) @@ -258,8 +219,8 @@ subroutine MOM_sum_output_init(G, param_file, directory, ntrnc, & "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"//& - "entries in the depth-list file.", units="m", & - default=1.0E-10) + "entries in the depth-list file.", & + units="m", default=1.0E-10, scale=US%m_to_Z) if (CS%read_depth_list) then call get_param(param_file, mdl, "DEPTH_LIST_FILE", CS%depth_list_file, & "The name of the depth list file.", default="Depth_list.nc") @@ -267,8 +228,8 @@ subroutine MOM_sum_output_init(G, param_file, directory, ntrnc, & CS%depth_list_file = trim(slasher(directory))//trim(CS%depth_list_file) endif - ALLOC_(CS%lH(G%ke)) - call depth_list_setup(G, CS) + allocate(CS%lH(G%ke)) + call depth_list_setup(G, US, CS) else CS%list_size = 0 endif @@ -304,8 +265,7 @@ subroutine MOM_sum_output_end(CS) !! previous call to MOM_sum_output_init. if (associated(CS)) then if (CS%do_APE_calc) then - DEALLOC_(CS%lH) - deallocate(CS%DL) + deallocate(CS%lH, CS%DL) endif deallocate(CS) @@ -314,15 +274,16 @@ end subroutine MOM_sum_output_end !> This subroutine calculates and writes the total model energy, the energy and !! mass of each layer, and other globally integrated physical quantities. -subroutine write_energy(u, v, h, tv, day, n, G, GV, CS, tracer_CSp, OBC, dt_forcing) +subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, OBC, dt_forcing) 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 real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & - intent(in) :: u !< The zonal velocity, in m s-1. + intent(in) :: u !< The zonal velocity [m s-1]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & - intent(in) :: v !< The meridional velocity, in m s-1. + intent(in) :: v !< The meridional velocity [m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2). + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various !! thermodynamic variables. type(time_type), intent(in) :: day !< The current model time. @@ -335,98 +296,95 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, CS, tracer_CSp, OBC, dt_forc type(ocean_OBC_type), & optional, pointer :: OBC !< Open boundaries control structure. type(time_type), optional, intent(in) :: dt_forcing !< The forcing time step - - real :: eta(SZI_(G),SZJ_(G),SZK_(G)+1) ! The height of interfaces, in m. - real :: areaTm(SZI_(G),SZJ_(G)) ! A masked version of areaT, in m2. - real :: KE(SZK_(G)) ! The total kinetic energy of a layer, in J. - real :: PE(SZK_(G)+1)! The available potential energy of an interface, in J. - real :: KE_tot ! The total kinetic energy, in J. - real :: PE_tot ! The total available potential energy, in J. - real :: H_0APE(SZK_(G)+1) ! The uniform depth which overlies the same - ! volume as is below an interface, in m. - ! H is usually positive. + ! Local variables + real :: eta(SZI_(G),SZJ_(G),SZK_(G)+1) ! The height of interfaces [Z ~> m]. + real :: areaTm(SZI_(G),SZJ_(G)) ! A masked version of areaT [m2]. + real :: KE(SZK_(G)) ! The total kinetic energy of a layer [J]. + real :: PE(SZK_(G)+1)! The available potential energy of an interface [J]. + real :: KE_tot ! The total kinetic energy [J]. + real :: PE_tot ! The total available potential energy [J]. + real :: Z_0APE(SZK_(G)+1) ! The uniform depth which overlies the same + ! volume as is below an interface [Z ~> m]. + real :: H_0APE(SZK_(G)+1) ! A version of Z_0APE, converted to m, usually positive. real :: toten ! The total kinetic & potential energies of - ! all layers, in Joules (i.e. kg m2 s-2). + ! all layers [J] (i.e. kg m2 s-2). real :: En_mass ! The total kinetic and potential energies divided by - ! the total mass of the ocean, in m2 s-2. - real :: vol_lay(SZK_(G)) ! The volume of fluid in a layer, in m3. - real :: volbelow ! The volume of all layers beneath an interface in m3. - real :: mass_lay(SZK_(G)) ! The mass of fluid in a layer, in kg. - real :: mass_tot ! The total mass of the ocean in kg. - real :: vol_tot ! The total ocean volume in m3. + ! the total mass of the ocean [m2 s-2]. + real :: vol_lay(SZK_(G)) ! The volume of fluid in a layer [Z m2 ~> m3]. + real :: volbelow ! The volume of all layers beneath an interface [Z m2 ~> m3]. + real :: mass_lay(SZK_(G)) ! The mass of fluid in a layer [kg]. + real :: mass_tot ! The total mass of the ocean [kg]. + real :: vol_tot ! The total ocean volume [m3]. real :: mass_chg ! The change in total ocean mass of fresh water since - ! the last call to this subroutine, in kg. + ! the last call to this subroutine [kg]. real :: mass_anom ! The change in fresh water that cannot be accounted for - ! by the surface fluxes, in kg. - real :: Salt ! The total amount of salt in the ocean, in PSU kg. + ! by the surface fluxes [kg]. + real :: Salt ! The total amount of salt in the ocean [ppt kg]. real :: Salt_chg ! The change in total ocean salt since the last call - ! to this subroutine, in PSU kg. + ! to this subroutine [ppt kg]. real :: Salt_anom ! The change in salt that cannot be accounted for by - ! the surface fluxes, in PSU kg. - real :: salin ! The mean salinity of the ocean, in PSU. + ! the surface fluxes [ppt kg]. + real :: salin ! The mean salinity of the ocean [ppt]. real :: salin_chg ! The change in total salt since the last call - ! to this subroutine divided by total mass, in PSU. + ! to this subroutine divided by total mass [ppt]. real :: salin_anom ! The change in total salt that cannot be accounted for by - ! the surface fluxes divided by total mass in PSU. - real :: salin_mass_in ! The mass of salt input since the last call, kg. - real :: Heat ! The total amount of Heat in the ocean, in Joules. + ! the surface fluxes divided by total mass [ppt]. + real :: salin_mass_in ! The mass of salt input since the last call [kg]. + real :: Heat ! The total amount of Heat in the ocean [J]. real :: Heat_chg ! The change in total ocean heat since the last call - ! to this subroutine, in Joules. + ! to this subroutine [J]. real :: Heat_anom ! The change in heat that cannot be accounted for by - ! the surface fluxes, in Joules. - real :: temp ! The mean potential temperature of the ocean, in C. + ! the surface fluxes [J]. + real :: temp ! The mean potential temperature of the ocean [degC]. real :: temp_chg ! The change in total heat divided by total heat capacity - ! of the ocean since the last call to this subroutine, C. + ! of the ocean since the last call to this subroutine, degC. real :: temp_anom ! The change in total heat that cannot be accounted for ! by the surface fluxes, divided by the total heat - ! capacity of the ocean, in C. - real :: hint ! The deviation of an interface from H, in m. + ! capacity of the ocean [degC]. + real :: hint ! The deviation of an interface from H [Z ~> m]. real :: hbot ! 0 if the basin is deeper than H, or the - ! height of the basin depth over H otherwise, - ! in m. This makes PE only include real fluid. - real :: hbelow ! The depth of fluid in all layers beneath - ! an interface, in m. + ! height of the basin depth over H otherwise [Z ~> m]. + ! This makes PE only include real fluid. + real :: hbelow ! The depth of fluid in all layers beneath an interface [Z ~> m]. type(EFP_type) :: & mass_EFP, & ! Extended fixed point sums of total mass, etc. salt_EFP, heat_EFP, salt_chg_EFP, heat_chg_EFP, mass_chg_EFP, & mass_anom_EFP, salt_anom_EFP, heat_anom_EFP - real :: CFL_trans ! A transport-based definition of the CFL number, nondim. - real :: CFL_lin ! A simpler definition of the CFL number, nondim. - real :: max_CFL(2) ! The maxima of the CFL numbers, nondim. - real :: Irho0 + real :: CFL_trans ! A transport-based definition of the CFL number [nondim]. + real :: CFL_lin ! A simpler definition of the CFL number [nondim]. + real :: max_CFL(2) ! The maxima of the CFL numbers [nondim]. + real :: Irho0 ! The inverse of the reference density [m3 kg-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & - tmp1 + tmp1 ! A temporary array real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: & - PE_pt + PE_pt ! The potential energy at each point [J]. real, dimension(SZI_(G),SZJ_(G)) :: & - Temp_int, Salt_int - real :: H_to_m, H_to_kg_m2 ! Local copies of unit conversion factors. + Temp_int, Salt_int ! Layer and cell integrated heat and salt [J] and [g Salt]. + real :: H_to_kg_m2 ! Local copy of a unit conversion factor. integer :: num_nc_fields ! The number of fields that will actually go into ! the NetCDF file. integer :: i, j, k, is, ie, js, je, ns, nz, m, Isq, Ieq, Jsq, Jeq - integer :: l, lbelow, labove ! indices of deep_area_vol, used to find - ! H. lbelow & labove are lower & upper - ! limits for l in the search for lH. + integer :: l, lbelow, labove ! indices of deep_area_vol, used to find Z_0APE. + ! lbelow & labove are lower & upper limits for l + ! in the search for the entry in lH to use. integer :: start_of_day, num_days real :: reday, var character(len=240) :: energypath_nc character(len=200) :: mesg character(len=32) :: mesg_intro, time_units, day_str, n_str, date_str logical :: date_stamped - type(time_type) :: dt_force + type(time_type) :: dt_force ! A time_type version of the forcing timestep. real :: Tr_stocks(MAX_FIELDS_) - real :: Tr_min(MAX_FIELDS_),Tr_max(MAX_FIELDS_) + real :: Tr_min(MAX_FIELDS_), Tr_max(MAX_FIELDS_) real :: Tr_min_x(MAX_FIELDS_), Tr_min_y(MAX_FIELDS_), Tr_min_z(MAX_FIELDS_) real :: Tr_max_x(MAX_FIELDS_), Tr_max_y(MAX_FIELDS_), Tr_max_z(MAX_FIELDS_) logical :: Tr_minmax_got(MAX_FIELDS_) = .false. character(len=40), dimension(MAX_FIELDS_) :: & Tr_names, Tr_units integer :: nTr_stocks - real, allocatable :: toten_PE(:) - integer :: pe_num integer :: iyear, imonth, iday, ihour, iminute, isecond, itick ! For call to get_date() logical :: local_open_BC - type(OBC_segment_type), pointer :: segment + type(OBC_segment_type), pointer :: segment => NULL() ! A description for output of each of the fields. type(vardesc) :: vars(NUM_FIELDS+MAX_FIELDS_) @@ -493,7 +451,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, CS, tracer_CSp, OBC, dt_forc is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - H_to_m = GV%H_to_m ; H_to_kg_m2 = GV%H_to_kg_m2 + H_to_kg_m2 = GV%H_to_kg_m2 if (.not.associated(CS)) call MOM_error(FATAL, & "write_energy: Module must be initialized before it is used.") @@ -537,7 +495,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, CS, tracer_CSp, OBC, dt_forc endif mass_tot = reproducing_sum(tmp1, sums=mass_lay, EFP_sum=mass_EFP) - do k=1,nz ; vol_lay(k) = (H_to_m/H_to_kg_m2)*mass_lay(k) ; enddo + do k=1,nz ; vol_lay(k) = (GV%H_to_Z/H_to_kg_m2)*mass_lay(k) ; enddo else tmp1(:,:,:) = 0.0 if (CS%do_APE_calc) then @@ -546,17 +504,17 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, CS, tracer_CSp, OBC, dt_forc enddo ; enddo ; enddo mass_tot = reproducing_sum(tmp1, sums=mass_lay, EFP_sum=mass_EFP) - call find_eta(h, tv, GV%g_Earth, G, GV, eta) + call find_eta(h, tv, G, GV, US, eta) do k=1,nz ; do j=js,je ; do i=is,ie tmp1(i,j,k) = (eta(i,j,K)-eta(i,j,K+1)) * areaTm(i,j) enddo ; enddo ; enddo - vol_tot = H_to_m*reproducing_sum(tmp1, sums=vol_lay) + vol_tot = US%Z_to_m*reproducing_sum(tmp1, sums=vol_lay) else do k=1,nz ; do j=js,je ; do i=is,ie tmp1(i,j,k) = H_to_kg_m2 * h(i,j,k) * areaTm(i,j) enddo ; enddo ; enddo mass_tot = reproducing_sum(tmp1, sums=mass_lay, EFP_sum=mass_EFP) - do k=1,nz ; vol_lay(k) = mass_lay(k) / GV%Rho0 ; enddo + do k=1,nz ; vol_lay(k) = US%m_to_Z * (mass_lay(k) / GV%Rho0) ; enddo endif endif ! Boussinesq @@ -606,11 +564,11 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, CS, tracer_CSp, OBC, dt_forc else if ((CS%timeunit >= 0.99) .and. (CS%timeunit < 1.01)) then time_units = " [seconds] " - else if ((CS%timeunit >= 3599.0) .and. (CS%timeunit < 3601.0)) then + elseif ((CS%timeunit >= 3599.0) .and. (CS%timeunit < 3601.0)) then time_units = " [hours] " - else if ((CS%timeunit >= 86399.0) .and. (CS%timeunit < 86401.0)) then + elseif ((CS%timeunit >= 86399.0) .and. (CS%timeunit < 86401.0)) then time_units = " [days] " - else if ((CS%timeunit >= 3.0e7) .and. (CS%timeunit < 3.2e7)) then + elseif ((CS%timeunit >= 3.0e7) .and. (CS%timeunit < 3.2e7)) then time_units = " [years] " else write(time_units,'(9x,"[",es8.2," s] ")') CS%timeunit @@ -663,55 +621,53 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, CS, tracer_CSp, OBC, dt_forc CS%lH(k) = l endif lbelow = l - H_0APE(K) = CS%DL(l)%depth - (volbelow - CS%DL(l)%vol_below) / CS%DL(l)%area + Z_0APE(K) = CS%DL(l)%depth - (volbelow - CS%DL(l)%vol_below) / CS%DL(l)%area enddo - H_0APE(nz+1) = CS%DL(2)%depth - else - do k=1,nz+1 ; H_0APE(K) = 0.0 ; enddo - endif - -! Calculate the Kinetic Energy integrated over each layer. - tmp1(:,:,:) = 0.0 - do k=1,nz ; do j=js,je ; do i=is,ie - tmp1(i,j,k) = (0.25 * H_to_kg_m2 * (areaTm(i,j) * h(i,j,k))) * & - (u(I-1,j,k)**2 + u(I,j,k)**2 + v(i,J-1,k)**2 + v(i,J,k)**2) - enddo ; enddo ; enddo + Z_0APE(nz+1) = CS%DL(2)%depth -! Calculate the Available Potential Energy integrated over each -! interface. With a nonlinear equation of state or with a bulk -! mixed layer this calculation is only approximate. - do k=1,nz+1 ; PE(K) = 0.0 ; enddo - if (CS%do_APE_calc) then + ! Calculate the Available Potential Energy integrated over each + ! interface. With a nonlinear equation of state or with a bulk + ! mixed layer this calculation is only approximate. With an ALE model + ! this does not make sense. PE_pt(:,:,:) = 0.0 if (GV%Boussinesq) then do j=js,je ; do i=is,ie hbelow = 0.0 do k=nz,1,-1 - hbelow = hbelow + h(i,j,k) * H_to_m - hint = H_0APE(K) + (hbelow - G%bathyT(i,j)) - hbot = H_0APE(K) - G%bathyT(i,j) + hbelow = hbelow + h(i,j,k) * GV%H_to_Z + hint = Z_0APE(K) + (hbelow - G%bathyT(i,j)) + hbot = Z_0APE(K) - G%bathyT(i,j) hbot = (hbot + ABS(hbot)) * 0.5 - PE_pt(i,j,K) = 0.5 * areaTm(i,j) * (GV%Rho0*GV%g_prime(K)) * & + PE_pt(i,j,K) = 0.5 * areaTm(i,j) * US%Z_to_m*(GV%Rho0*GV%g_prime(K)) * & (hint * hint - hbot * hbot) enddo enddo ; enddo else do j=js,je ; do i=is,ie - hbelow = 0.0 do k=nz,1,-1 - hint = H_0APE(K) + eta(i,j,K) ! eta and H_0 have opposite signs. - hbot = max(H_0APE(K) - G%bathyT(i,j), 0.0) - PE_pt(i,j,K) = 0.5 * (areaTm(i,j) * (GV%Rho0*GV%g_prime(K))) * & + hint = Z_0APE(K) + eta(i,j,K) ! eta and H_0 have opposite signs. + hbot = max(Z_0APE(K) - G%bathyT(i,j), 0.0) + PE_pt(i,j,K) = 0.5 * (areaTm(i,j) * US%Z_to_m*(GV%Rho0*GV%g_prime(K))) * & (hint * hint - hbot * hbot) enddo enddo ; enddo endif + + PE_tot = reproducing_sum(PE_pt, sums=PE) + do k=1,nz+1 ; H_0APE(K) = US%Z_to_m*Z_0APE(K) ; enddo + else + PE_tot = 0.0 + do k=1,nz+1 ; PE(K) = 0.0 ; H_0APE(K) = 0.0 ; enddo endif +! Calculate the Kinetic Energy integrated over each layer. + tmp1(:,:,:) = 0.0 + do k=1,nz ; do j=js,je ; do i=is,ie + tmp1(i,j,k) = (0.25 * H_to_kg_m2 * (areaTm(i,j) * h(i,j,k))) * & + (u(I-1,j,k)**2 + u(I,j,k)**2 + v(i,J-1,k)**2 + v(i,J,k)**2) + enddo ; enddo ; enddo KE_tot = reproducing_sum(tmp1, sums=KE) - PE_tot = 0.0 - if (CS%do_APE_calc) & - PE_tot = reproducing_sum(PE_pt, sums=PE) + toten = KE_tot + PE_tot Salt = 0.0 ; Heat = 0.0 @@ -781,7 +737,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, CS, tracer_CSp, OBC, dt_forc if (GV%Boussinesq) then mass_anom_EFP = mass_chg_EFP - CS%fresh_water_in_EFP else - ! net_salt_input needs to be converted from psu m s-1 to kg m-2 s-1. + ! net_salt_input needs to be converted from ppt m s-1 to kg m-2 s-1. mass_anom_EFP = mass_chg_EFP - CS%fresh_water_in_EFP if (CS%use_temperature) & salin_mass_in = 0.001*EFP_to_real(CS%net_salt_in_EFP) @@ -881,7 +837,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, CS, tracer_CSp, OBC, dt_forc write(*,'(" Total ",a,": ",ES24.16,X,a)') & trim(Tr_names(m)), Tr_stocks(m), trim(Tr_units(m)) - if(Tr_minmax_got(m)) then + if (Tr_minmax_got(m)) then write(*,'(64X,"Global Min:",ES24.16,X,"at: (", f7.2,","f7.2,","f8.2,")" )') & Tr_min(m),Tr_min_x(m),Tr_min_y(m),Tr_min_z(m) write(*,'(64X,"Global Max:",ES24.16,X,"at: (", f7.2,","f7.2,","f8.2,")" )') & @@ -949,42 +905,36 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, CS, tracer_CSp, OBC, dt_forc endif end subroutine write_energy -!> This subroutine accumates the net input of volume, and perhaps later salt and -!! heat, through the ocean surface for use in diagnosing conservation. +!> This subroutine accumates the net input of volume, salt and heat, through +!! the ocean surface for use in diagnosing conservation. subroutine accumulate_net_input(fluxes, sfc_state, dt, G, CS) - type(forcing), intent(in) :: fluxes !< A structure containing pointers to any possible forcing fields. Unused fields are unallocated. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to any possible + !! forcing fields. Unused fields are unallocated. type(surface), intent(in) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. - real, intent(in) :: dt !< The amount of time over which to average, in s. + real, intent(in) :: dt !< The amount of time over which to average [s]. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(Sum_output_CS), pointer :: CS !< The control structure returned by a previous call to MOM_sum_output_init. - -! This subroutine accumates the net input of volume, and perhaps later salt and -! heat, through the ocean surface for use in diagnosing conservation. -! Arguments: fluxes - A structure containing pointers to any possible -! forcing fields. Unused fields are unallocated. -! (in) dt - The amount of time over which to average. -! (in) G - The ocean's grid structure. -! (in) CS - The control structure returned by a previous call to -! MOM_sum_output_init. + type(Sum_output_CS), pointer :: CS !< The control structure returned by a previous call + !! to MOM_sum_output_init. + ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & - FW_in, & ! The net fresh water input, integrated over a timestep in kg. + FW_in, & ! The net fresh water input, integrated over a timestep [kg]. salt_in, & ! The total salt added by surface fluxes, integrated - ! over a time step in ppt*kg. + ! over a time step [ppt kg]. heat_in ! The total heat added by surface fluxes, integrated - ! over a time step in Joules. + ! over a time step [J]. real :: FW_input ! The net fresh water input, integrated over a timestep - ! and summed over space, in kg. + ! and summed over space [kg]. real :: salt_input ! The total salt added by surface fluxes, integrated - ! over a time step and summed over space, in ppt * kg. + ! over a time step and summed over space [ppt kg]. real :: heat_input ! The total heat added by boundary fluxes, integrated - ! over a time step and summed over space, in Joules. - real :: C_p ! The heat capacity of seawater, in J K-1 kg-1. + ! over a time step and summed over space [J]. + real :: C_p ! The heat capacity of seawater [J degC-1 kg-1]. type(EFP_type) :: & - FW_in_EFP, & ! Extended fixed point versions of FW_input, salt_input, and - salt_in_EFP, & ! heat_input, in kg, ppt*kg, and Joules. - heat_in_EFP + FW_in_EFP, & ! Extended fixed point version of FW_input [kg] + salt_in_EFP, & ! Extended fixed point version of salt_input [ppt kg] + heat_in_EFP ! Extended fixed point version of heat_input [J] real :: inputs(3) ! A mixed array for combining the sums integer :: i, j, is, ie, js, je @@ -1006,6 +956,10 @@ subroutine accumulate_net_input(fluxes, sfc_state, dt, G, CS) endif endif + if (associated(fluxes%seaice_melt)) then ; do j=js,je ; do i=is,ie + FW_in(i,j) = FW_in(i,j) + dt * G%areaT(i,j) * fluxes%seaice_melt(i,j) + enddo ; enddo ; endif + salt_in(:,:) = 0.0 ; heat_in(:,:) = 0.0 if (CS%use_temperature) then @@ -1014,6 +968,10 @@ subroutine accumulate_net_input(fluxes, sfc_state, dt, G, CS) (fluxes%lw(i,j) + (fluxes%latent(i,j) + fluxes%sens(i,j)))) enddo ; enddo ; endif + if (associated(fluxes%seaice_melt_heat)) then ; do j=js,je ; do i=is,ie + heat_in(i,j) = heat_in(i,j) + dt*G%areaT(i,j) * fluxes%seaice_melt_heat(i,j) + enddo ; enddo ; endif + ! smg: new code ! include heat content from water transport across ocean surface ! if (associated(fluxes%heat_content_lprec)) then ; do j=js,je ; do i=is,ie @@ -1054,7 +1012,7 @@ subroutine accumulate_net_input(fluxes, sfc_state, dt, G, CS) ! enddo ; enddo ; endif if (associated(fluxes%salt_flux)) then ; do j=js,je ; do i=is,ie - ! convert salt_flux from kg (salt)/(m^2 s) to ppt * (m/s). + ! convert salt_flux from kg (salt)/(m^2 s) to ppt * [m s-1]. salt_in(i,j) = dt*G%areaT(i,j)*(1000.0*fluxes%salt_flux(i,j)) enddo ; enddo ; endif endif @@ -1080,25 +1038,23 @@ end subroutine accumulate_net_input !! cross sectional areas at each depth and the volume of fluid deeper !! than each depth. This might be read from a previously created file !! or it might be created anew. (For now only new creation occurs. -subroutine depth_list_setup(G, CS) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(Sum_output_CS), pointer :: CS -! This subroutine sets up an ordered list of depths, along with the -! cross sectional areas at each depth and the volume of fluid deeper -! than each depth. This might be read from a previously created file -! or it might be created anew. (For now only new creation occurs. - +subroutine depth_list_setup(G, US, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(Sum_output_CS), pointer :: CS !< The control structure returned by a + !! previous call to MOM_sum_output_init. + ! Local variables integer :: k if (CS%read_depth_list) then if (file_exists(CS%depth_list_file)) then - call read_depth_list(G, CS, CS%depth_list_file) + call read_depth_list(G, US, CS, CS%depth_list_file) else if (is_root_pe()) call MOM_error(WARNING, "depth_list_setup: "// & trim(CS%depth_list_file)//" does not exist. Creating a new file.") call create_depth_list(G, CS) - call write_depth_list(G, CS, CS%depth_list_file, CS%list_size+1) + call write_depth_list(G, US, CS, CS%depth_list_file, CS%list_size+1) endif else call create_depth_list(G, CS) @@ -1116,17 +1072,17 @@ subroutine create_depth_list(G, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(Sum_output_CS), pointer :: CS !< The control structure set up in MOM_sum_output_init, !! in which the ordered depth list is stored. - + ! Local variables real, dimension(G%Domain%niglobal*G%Domain%njglobal + 1) :: & - Dlist, & !< The global list of bottom depths, in m. - AreaList !< The global list of cell areas, in m2. + Dlist, & !< The global list of bottom depths [Z ~> m]. + AreaList !< The global list of cell areas [m2]. integer, dimension(G%Domain%niglobal*G%Domain%njglobal+1) :: & indx2 !< The position of an element in the original unsorted list. - real :: Dnow !< The depth now being considered for sorting, in m. - real :: Dprev !< The most recent depth that was considered, in m. - real :: vol !< The running sum of open volume below a deptn, in m3. - real :: area !< The open area at the current depth, in m2. - real :: D_list_prev !< The most recent depth added to the list, in m. + real :: Dnow !< The depth now being considered for sorting [Z ~> m]. + real :: Dprev !< The most recent depth that was considered [Z ~> m]. + real :: vol !< The running sum of open volume below a deptn [Z m2 ~> m3]. + real :: area !< The open area at the current depth [m2]. + real :: D_list_prev !< The most recent depth added to the list [Z ~> m]. logical :: add_to_list !< This depth should be included as an entry on the list. integer :: ir, indxt @@ -1237,14 +1193,14 @@ subroutine create_depth_list(G, CS) end subroutine create_depth_list !> This subroutine writes out the depth list to the specified file. -subroutine write_depth_list(G, CS, filename, list_size) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(Sum_output_CS), pointer :: CS - character(len=*), intent(in) :: filename - integer, intent(in) :: list_size - -! This subroutine writes out the depth list to the specified file. - +subroutine write_depth_list(G, US, CS, filename, list_size) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(Sum_output_CS), pointer :: CS !< The control structure returned by a + !! previous call to MOM_sum_output_init. + character(len=*), intent(in) :: filename !< The path to the depth list file to write. + integer, intent(in) :: list_size !< The size of the depth list. + ! Local variables real, allocatable :: tmp(:) integer :: ncid, dimid(1), Did, Aid, Vid, status, k @@ -1296,7 +1252,7 @@ subroutine write_depth_list(G, CS, filename, list_size) if (status /= NF90_NOERR) call MOM_error(WARNING, & filename//trim(NF90_STRERROR(status))) - do k=1,list_size ; tmp(k) = CS%DL(k)%depth ; enddo + do k=1,list_size ; tmp(k) = US%Z_to_m*CS%DL(k)%depth ; enddo status = NF90_PUT_VAR(ncid, Did, tmp) if (status /= NF90_NOERR) call MOM_error(WARNING, & filename//" depth "//trim(NF90_STRERROR(status))) @@ -1306,7 +1262,7 @@ subroutine write_depth_list(G, CS, filename, list_size) if (status /= NF90_NOERR) call MOM_error(WARNING, & filename//" area "//trim(NF90_STRERROR(status))) - do k=1,list_size ; tmp(k) = CS%DL(k)%vol_below ; enddo + do k=1,list_size ; tmp(k) = US%Z_to_m*CS%DL(k)%vol_below ; enddo status = NF90_PUT_VAR(ncid, Vid, tmp) if (status /= NF90_NOERR) call MOM_error(WARNING, & filename//" vol_below "//trim(NF90_STRERROR(status))) @@ -1319,13 +1275,13 @@ end subroutine write_depth_list !> This subroutine reads in the depth list to the specified file !! and allocates and sets up CS%DL and CS%list_size . -subroutine read_depth_list(G, CS, filename) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(Sum_output_CS), pointer :: CS - character(len=*), intent(in) :: filename - -! This subroutine reads in the depth list to the specified file -! and allocates and sets up CS%DL and CS%list_size . +subroutine read_depth_list(G, US, CS, filename) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(Sum_output_CS), pointer :: CS !< The control structure returned by a + !! previous call to MOM_sum_output_init. + character(len=*), intent(in) :: filename !< The path to the depth list file to read. + ! Local variables character(len=32) :: mdl character(len=240) :: var_name, var_msg real, allocatable :: tmp(:) @@ -1334,7 +1290,7 @@ subroutine read_depth_list(G, CS, filename) mdl = "MOM_sum_output read_depth_list:" - status = NF90_OPEN(filename, NF90_NOWRITE, ncid); + status = NF90_OPEN(filename, NF90_NOWRITE, ncid) if (status /= NF90_NOERR) then call MOM_error(FATAL,mdl//" Difficulties opening "//trim(filename)// & " - "//trim(NF90_STRERROR(status))) @@ -1371,7 +1327,7 @@ subroutine read_depth_list(G, CS, filename) " Difficulties reading variable "//trim(var_msg)//& trim(NF90_STRERROR(status))) - do k=1,list_size ; CS%DL(k)%depth = tmp(k) ; enddo + do k=1,list_size ; CS%DL(k)%depth = US%m_to_Z*tmp(k) ; enddo var_name = "area" var_msg = trim(var_name)//" in "//trim(filename)//" - " @@ -1397,7 +1353,7 @@ subroutine read_depth_list(G, CS, filename) " Difficulties reading variable "//trim(var_msg)//& trim(NF90_STRERROR(status))) - do k=1,list_size ; CS%DL(k)%vol_below = tmp(k) ; enddo + do k=1,list_size ; CS%DL(k)%vol_below = US%m_to_Z*tmp(k) ; enddo status = NF90_CLOSE(ncid) if (status /= NF90_NOERR) call MOM_error(WARNING, mdl// & @@ -1407,4 +1363,20 @@ subroutine read_depth_list(G, CS, filename) end subroutine read_depth_list +!> \namespace mom_sum_output +!! +!! By Robert Hallberg, April 1994 - June 2002 +!! +!! This file contains the subroutine (write_energy) that writes +!! horizontally integrated quantities, such as energies and layer +!! volumes, and other summary information to an output file. Some +!! of these quantities (APE or resting interface height) are defined +!! relative to the global histogram of topography. The subroutine +!! that compiles that histogram (depth_list_setup) is also included +!! in this file. +!! +!! In addition, if the number of velocity truncations since the +!! previous call to write_energy exceeds maxtrunc or the total energy +!! exceeds a very large threshold, a fatal termination is triggered. + end module MOM_sum_output diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index fbd0ce2daa..0c4b0386a4 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -7,9 +7,10 @@ module MOM_wave_speed use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : log_version use MOM_grid, only : ocean_grid_type +use MOM_remapping, only : remapping_CS, initialize_remapping, remapping_core_h +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use MOM_remapping, only : remapping_CS, initialize_remapping, remapping_core_h use MOM_EOS, only : calculate_density, calculate_density_derivs implicit none ; private @@ -18,6 +19,11 @@ module MOM_wave_speed public wave_speed, wave_speeds, wave_speed_init, wave_speed_set_param +! 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. + !> Control structure for MOM_wave_speed type, public :: wave_speed_CS ; private logical :: use_ebt_mode = .false. !< If true, calculate the equivalent barotropic wave speed instead @@ -25,11 +31,11 @@ module MOM_wave_speed !! This parameter controls the default behavior of wave_speed() which !! can be overridden by optional arguments. real :: mono_N2_column_fraction = 0. !< The lower fraction of water column over which N2 is limited as - !! monotonic for the purposes of calculating the equivalent barotropic wave speed. - !! This parameter controls the default behavior of wave_speed() which - !! can be overridden by optional arguments. + !! monotonic for the purposes of calculating the equivalent barotropic + !! wave speed. This parameter controls the default behavior of + !! wave_speed() which can be overridden by optional arguments. real :: mono_N2_depth = -1. !< The depth below which N2 is limited as monotonic for the purposes of - !! calculating the equivalent barotropic wave speed. (m) + !! calculating the equivalent barotropic wave speed [Z ~> m]. !! This parameter controls the default behavior of wave_speed() which !! can be overridden by optional arguments. type(remapping_CS) :: remapping_CS !< Used for vertical remapping when calculating equivalent barotropic @@ -40,35 +46,37 @@ module MOM_wave_speed contains !> Calculates the wave speed of the first baroclinic mode. -subroutine wave_speed(h, tv, G, GV, cg1, CS, full_halos, use_ebt_mode, & +subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, & mono_N2_column_fraction, mono_N2_depth, modal_structure) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness in units of H (m or kg/m2) - type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: cg1 !< First mode internal wave speed (m/s) - type(wave_speed_CS), pointer :: CS !< Control structure for MOM_wave_speed - logical, optional, intent(in) :: full_halos !< If true, do the calculation - !! over the entire computational domain. - logical, optional, intent(in) :: use_ebt_mode !< If true, use the equivalent - !! barotropic mode instead of the first baroclinic mode. - real, optional, intent(in) :: mono_N2_column_fraction !< The lower fraction - !! of water column over which N2 is limited as monotonic - !! for the purposes of calculating vertical modal structure. - real, optional, intent(in) :: mono_N2_depth !< A depth below which N2 is limited as - !! monotonic for the purposes of calculating vertical modal structure. + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - optional, intent(out) :: modal_structure !< Normalized model structure (non-dim) + intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: cg1 !< First mode internal wave speed [m s-1] + type(wave_speed_CS), pointer :: CS !< Control structure for MOM_wave_speed + logical, optional, intent(in) :: full_halos !< If true, do the calculation + !! over the entire computational domain. + logical, optional, intent(in) :: use_ebt_mode !< If true, use the equivalent + !! barotropic mode instead of the first baroclinic mode. + real, optional, intent(in) :: mono_N2_column_fraction !< The lower fraction + !! of water column over which N2 is limited as monotonic + !! for the purposes of calculating vertical modal structure. + real, optional, intent(in) :: mono_N2_depth !< A depth below which N2 is limited as + !! monotonic for the purposes of calculating vertical + !! modal structure [m]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + optional, intent(out) :: modal_structure !< Normalized model structure [nondim] ! Local variables real, dimension(SZK_(G)+1) :: & dRho_dT, dRho_dS, & pres, T_int, S_int, & - gprime ! The reduced gravity across each interface, in m s-2. + gprime ! The reduced gravity across each interface [m2 Z-1 s-2 ~> m s-2]. real, dimension(SZK_(G)) :: & Igl, Igu ! The inverse of the reduced gravity across an interface times - ! the thickness of the layer below (Igl) or above (Igu) it, - ! in units of s2 m-2. + ! the thickness of the layer below (Igl) or above (Igu) it [s2 m-2]. real, dimension(SZK_(G),SZI_(G)) :: & Hf, Tf, Sf, Rf real, dimension(SZK_(G)) :: & @@ -76,16 +84,16 @@ subroutine wave_speed(h, tv, G, GV, cg1, CS, full_halos, use_ebt_mode, & real det, ddet, detKm1, detKm2, ddetKm1, ddetKm2 real :: lam, dlam, lam0 real :: min_h_frac - real :: H_to_pres - real :: H_to_m ! Local copy of a unit conversion factor. + real :: Z_to_Pa ! A conversion factor from thicknesses (in Z) to pressure (in Pa) real, dimension(SZI_(G)) :: & - htot, hmin, & ! Thicknesses in m. + htot, hmin, & ! Thicknesses [Z ~> m]. H_here, HxT_here, HxS_here, HxR_here real :: speed2_tot real :: I_Hnew, drxh_sum + real :: L2_to_Z2 ! A scaling factor squared from units of lateral distances to depths [Z2 m-2 ~> 1]. real, parameter :: tol1 = 0.0001, tol2 = 0.001 - real, pointer, dimension(:,:,:) :: T, S - real :: g_Rho0 ! G_Earth/Rho0 in m4 s-2 kg-1. + real, pointer, dimension(:,:,:) :: T => NULL(), S => NULL() + real :: g_Rho0 ! G_Earth/Rho0 [m5 Z-1 s-2 kg-1 ~> m4 s-2 kg-1]. real :: rescale, I_rescale integer :: kf(SZI_(G)) integer, parameter :: max_itt = 10 @@ -107,33 +115,34 @@ subroutine wave_speed(h, tv, G, GV, cg1, CS, full_halos, use_ebt_mode, & is = G%isd ; ie = G%ied ; js = G%jsd ; je = G%jed endif ; endif + L2_to_Z2 = US%m_to_Z**2 + l_use_ebt_mode = CS%use_ebt_mode if (present(use_ebt_mode)) l_use_ebt_mode = use_ebt_mode l_mono_N2_column_fraction = CS%mono_N2_column_fraction if (present(mono_N2_column_fraction)) l_mono_N2_column_fraction = mono_N2_column_fraction - l_mono_N2_depth = CS%mono_N2_depth - if (present(mono_N2_depth)) l_mono_N2_depth = mono_N2_depth + l_mono_N2_depth = US%m_to_Z*CS%mono_N2_depth + if (present(mono_N2_depth)) l_mono_N2_depth = US%m_to_Z*mono_N2_depth calc_modal_structure = l_use_ebt_mode if (present(modal_structure)) calc_modal_structure = .true. if (calc_modal_structure) then do k=1,nz; do j=js,je; do i=is,ie modal_structure(i,j,k) = 0.0 - enddo; enddo; enddo + enddo ; enddo ; enddo endif S => tv%S ; T => tv%T - g_Rho0 = GV%g_Earth/GV%Rho0 + g_Rho0 = GV%g_Earth / GV%Rho0 + Z_to_Pa = GV%g_Earth * GV%Rho0 use_EOS = associated(tv%eqn_of_state) - H_to_pres = GV%g_Earth * GV%Rho0 - H_to_m = GV%H_to_m rescale = 1024.0**4 ; I_rescale = 1.0/rescale min_h_frac = tol1 / real(nz) -!$OMP parallel do default(none) shared(is,ie,js,je,nz,h,G,GV,min_h_frac,use_EOS,T,S,tv,& +!$OMP parallel do default(none) shared(is,ie,js,je,nz,h,G,GV,US,min_h_frac,use_EOS,T,S,tv,& !$OMP calc_modal_structure,l_use_ebt_mode,modal_structure, & -!$OMP l_mono_N2_column_fraction,l_mono_N2_depth,CS, & -!$OMP H_to_pres,H_to_m,cg1,g_Rho0,rescale,I_rescale) & +!$OMP l_mono_N2_column_fraction,l_mono_N2_depth,CS, & +!$OMP Z_to_Pa,cg1,g_Rho0,rescale,I_rescale,L2_to_Z2) & !$OMP private(htot,hmin,kf,H_here,HxT_here,HxS_here,HxR_here, & !$OMP Hf,Tf,Sf,Rf,pres,T_int,S_int,drho_dT, & !$OMP drho_dS,drxh_sum,kc,Hc,Tc,Sc,I_Hnew,gprime, & @@ -146,7 +155,7 @@ subroutine wave_speed(h, tv, G, GV, cg1, CS, full_halos, use_ebt_mode, & ! at the top). This also transposes the row order so that columns can ! be worked upon one at a time. do i=is,ie ; htot(i) = 0.0 ; enddo - do k=1,nz ; do i=is,ie ; htot(i) = htot(i) + h(i,j,k)*H_to_m ; enddo ; enddo + do k=1,nz ; do i=is,ie ; htot(i) = htot(i) + h(i,j,k)*GV%H_to_Z ; enddo ; enddo do i=is,ie hmin(i) = htot(i)*min_h_frac ; kf(i) = 1 ; H_here(i) = 0.0 @@ -154,20 +163,20 @@ subroutine wave_speed(h, tv, G, GV, cg1, CS, full_halos, use_ebt_mode, & enddo if (use_EOS) then do k=1,nz ; do i=is,ie - if ((H_here(i) > hmin(i)) .and. (h(i,j,k)*H_to_m > hmin(i))) then + if ((H_here(i) > hmin(i)) .and. (h(i,j,k)*GV%H_to_Z > hmin(i))) then Hf(kf(i),i) = H_here(i) Tf(kf(i),i) = HxT_here(i) / H_here(i) Sf(kf(i),i) = HxS_here(i) / H_here(i) kf(i) = kf(i) + 1 ! Start a new layer - H_here(i) = h(i,j,k)*H_to_m - HxT_here(i) = (h(i,j,k)*H_to_m)*T(i,j,k) - HxS_here(i) = (h(i,j,k)*H_to_m)*S(i,j,k) + H_here(i) = h(i,j,k)*GV%H_to_Z + HxT_here(i) = (h(i,j,k)*GV%H_to_Z)*T(i,j,k) + HxS_here(i) = (h(i,j,k)*GV%H_to_Z)*S(i,j,k) else - H_here(i) = H_here(i) + h(i,j,k)*H_to_m - HxT_here(i) = HxT_here(i) + (h(i,j,k)*H_to_m)*T(i,j,k) - HxS_here(i) = HxS_here(i) + (h(i,j,k)*H_to_m)*S(i,j,k) + H_here(i) = H_here(i) + h(i,j,k)*GV%H_to_Z + HxT_here(i) = HxT_here(i) + (h(i,j,k)*GV%H_to_Z)*T(i,j,k) + HxS_here(i) = HxS_here(i) + (h(i,j,k)*GV%H_to_Z)*S(i,j,k) endif enddo ; enddo do i=is,ie ; if (H_here(i) > 0.0) then @@ -177,16 +186,16 @@ subroutine wave_speed(h, tv, G, GV, cg1, CS, full_halos, use_ebt_mode, & endif ; enddo else do k=1,nz ; do i=is,ie - if ((H_here(i) > hmin(i)) .and. (h(i,j,k)*H_to_m > hmin(i))) then + if ((H_here(i) > hmin(i)) .and. (h(i,j,k)*GV%H_to_Z > hmin(i))) then Hf(kf(i),i) = H_here(i) ; Rf(kf(i),i) = HxR_here(i) / H_here(i) kf(i) = kf(i) + 1 ! Start a new layer - H_here(i) = h(i,j,k)*H_to_m - HxR_here(i) = (h(i,j,k)*H_to_m)*GV%Rlay(k) + H_here(i) = h(i,j,k)*GV%H_to_Z + HxR_here(i) = (h(i,j,k)*GV%H_to_Z)*GV%Rlay(k) else - H_here(i) = H_here(i) + h(i,j,k)*H_to_m - HxR_here(i) = HxR_here(i) + (h(i,j,k)*H_to_m)*GV%Rlay(k) + H_here(i) = H_here(i) + h(i,j,k)*GV%H_to_Z + HxR_here(i) = HxR_here(i) + (h(i,j,k)*GV%H_to_Z)*GV%Rlay(k) endif enddo ; enddo do i=is,ie ; if (H_here(i) > 0.0) then @@ -200,7 +209,7 @@ subroutine wave_speed(h, tv, G, GV, cg1, CS, full_halos, use_ebt_mode, & if (use_EOS) then pres(1) = 0.0 do k=2,kf(i) - pres(k) = pres(k-1) + H_to_pres*Hf(k-1,i) + pres(k) = pres(k-1) + Z_to_Pa*Hf(k-1,i) T_int(k) = 0.5*(Tf(k,i)+Tf(k-1,i)) S_int(k) = 0.5*(Sf(k,i)+Sf(k-1,i)) enddo @@ -310,26 +319,26 @@ subroutine wave_speed(h, tv, G, GV, cg1, CS, full_halos, use_ebt_mode, & speed2_tot = 0.0 if (l_use_ebt_mode) then Igu(1) = 0. ! Neumann condition for pressure modes - sum_hc = Hc(1)*GV%H_to_m - N2min = gprime(2)/Hc(1) + sum_hc = Hc(1) + N2min = L2_to_Z2*gprime(2)/Hc(1) do k=2,kc hw = 0.5*(Hc(k-1)+Hc(k)) gp = gprime(K) if (l_mono_N2_column_fraction>0. .or. l_mono_N2_depth>=0.) then - if (G%bathyT(i,j)-sum_hcN2min*hw) then - ! Filters out regions where N2 increases with depth but only in a lower fraction of water column - gp = N2min/hw - elseif (l_mono_N2_depth>=0. .and. sum_hc>l_mono_N2_depth .and. gp>N2min*hw) then - ! Filters out regions where N2 increases with depth but only below a certain depth - gp = N2min/hw + if ( ((G%bathyT(i,j)-sum_hc < l_mono_N2_column_fraction*G%bathyT(i,j)) .or. & + ((l_mono_N2_depth >= 0.) .and. (sum_hc > l_mono_N2_depth))) .and. & + (L2_to_Z2*gp > N2min*hw) ) then + ! Filters out regions where N2 increases with depth but only in a lower fraction + ! of the water column or below a certain depth. + gp = US%Z_to_m**2 * (N2min*hw) else - N2min = gp/hw + N2min = L2_to_Z2 * gp/hw endif endif Igu(k) = 1.0/(gp*Hc(k)) Igl(k-1) = 1.0/(gp*Hc(k-1)) speed2_tot = speed2_tot + gprime(k)*(Hc(k-1)+Hc(k))*0.707 - sum_hc = sum_hc + Hc(k)*GV%H_to_m + sum_hc = sum_hc + Hc(k) enddo !Igl(kc) = 0. ! Neumann condition for pressure modes Igl(kc) = 2.*Igu(kc) ! Dirichlet condition for pressure modes @@ -354,7 +363,8 @@ subroutine wave_speed(h, tv, G, GV, cg1, CS, full_halos, use_ebt_mode, & do itt=1,max_itt lam_it(itt) = lam if (l_use_ebt_mode) then - ! This initialization of det,ddet imply Neumann boundary conditions so that first 3 rows of the matrix are + ! This initialization of det,ddet imply Neumann boundary conditions so that first 3 rows + ! of the matrix are ! / b(1)-lam igl(1) 0 0 0 ... \ ! | igu(2) b(2)-lam igl(2) 0 0 ... | ! | 0 igu(3) b(3)-lam igl(3) 0 ... | @@ -373,7 +383,8 @@ subroutine wave_speed(h, tv, G, GV, cg1, CS, full_halos, use_ebt_mode, & ! | ... 0 igu(kc-1) b(kc-1)-lam igl(kc-1) | ! \ ... 0 0 igu(kc) b(kc)-lam / else - ! This initialization of det,ddet imply Dirichlet boundary conditions so that first 3 rows of the matrix are + ! This initialization of det,ddet imply Dirichlet boundary conditions so that first 3 rows + ! of the matrix are ! / b(2)-lam igl(2) 0 0 0 ... | ! | igu(3) b(3)-lam igl(3) 0 0 ... | ! | 0 igu43) b(4)-lam igl(4) 0 ... | @@ -444,9 +455,9 @@ subroutine wave_speed(h, tv, G, GV, cg1, CS, full_halos, use_ebt_mode, & mode_struct(1:kc)=0. endif ! Note that remapping_core_h requires that the same units be used - ! for both the source and target grid thicknesses. - call remapping_core_h(CS%remapping_CS, kc, Hc, mode_struct, & - nz, GV%H_to_m*h(i,j,:), modal_structure(i,j,:)) + ! for both the source and target grid thicknesses, here [H ~> m or kg m-2]. + call remapping_core_h(CS%remapping_CS, kc, GV%Z_to_H*Hc(:), mode_struct, & + nz, h(i,j,:), modal_structure(i,j,:), 1.0e-30*GV%m_to_H, 1.0e-10*GV%m_to_H) endif else cg1(i,j) = 0.0 @@ -501,16 +512,17 @@ subroutine tdma6(n, a, b, c, lam, y) do k = n-1, 1, -1 y(k) = ( yy(k) - c(k) * y(k+1) ) * beta(k) enddo -end subroutine +end subroutine tdma6 !> Calculates the wave speeds for the first few barolinic modes. -subroutine wave_speeds(h, tv, G, GV, nmodes, cn, CS, full_halos) +subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness (m or kg/m2) + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + 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 !< Thermodynamic variables integer, intent(in) :: nmodes !< Number of modes - real, dimension(G%isd:G%ied,G%jsd:G%jed,nmodes), intent(out) :: cn !< Waves speeds (m/s) + real, dimension(G%isd:G%ied,G%jsd:G%jed,nmodes), intent(out) :: cn !< Waves speeds [m s-1] type(wave_speed_CS), optional, pointer :: CS !< Control structure for MOM_wave_speed logical, optional, intent(in) :: full_halos !< If true, do the calculation !! over the entire computational domain. @@ -518,11 +530,10 @@ subroutine wave_speeds(h, tv, G, GV, nmodes, cn, CS, full_halos) real, dimension(SZK_(G)+1) :: & dRho_dT, dRho_dS, & pres, T_int, S_int, & - gprime ! The reduced gravity across each interface, in m s-2. + gprime ! The reduced gravity across each interface [m s-2] real, dimension(SZK_(G)) :: & Igl, Igu ! The inverse of the reduced gravity across an interface times - ! the thickness of the layer below (Igl) or above (Igu) it, - ! in units of s2 m-2. + ! the thickness of the layer below (Igl) or above (Igu) it [s2 m-2]. real, dimension(SZK_(G)-1) :: & a_diag, b_diag, c_diag ! diagonals of tridiagonal matrix; one value for each @@ -551,23 +562,21 @@ subroutine wave_speeds(h, tv, G, GV, nmodes, cn, CS, full_halos) integer :: numint ! number of widows (intervals) in root searching range integer :: nrootsfound ! number of extra roots found (not including 1st root) real :: min_h_frac - real :: H_to_pres - real :: H_to_m ! Local copy of a unit conversion factor. + real :: Z_to_Pa ! A conversion factor from thicknesses (in Z) to pressure (in Pa) real, dimension(SZI_(G)) :: & - htot, hmin, & ! Thicknesses in m. + htot, hmin, & ! Thicknesses [Z ~> m]. H_here, HxT_here, HxS_here, HxR_here - real :: speed2_tot ! overestimate of the mode-1 speed squared, m2 s-2 + real :: speed2_tot ! overestimate of the mode-1 speed squared [m2 s-2] real :: speed2_min ! minimum mode speed (squared) to consider in root searching real, parameter :: reduct_factor = 0.5 ! factor used in setting speed2_min real :: I_Hnew, drxh_sum real, parameter :: tol1 = 0.0001, tol2 = 0.001 - real, pointer, dimension(:,:,:) :: T, S - real :: g_Rho0 ! G_Earth/Rho0 in m4 s-2 kg-1. + real, pointer, dimension(:,:,:) :: T => NULL(), S => NULL() + real :: g_Rho0 ! G_Earth/Rho0 [m5 Z-1 s-2 kg-1 ~> m4 s-2 kg-1]. integer :: kf(SZI_(G)) integer, parameter :: max_itt = 10 - logical :: use_EOS ! If true, density is calculated from T & S using an - ! equation of state. + logical :: use_EOS ! If true, density is calculated from T & S using the equation of state. real, dimension(SZK_(G)+1) :: z_int, N2 integer :: nsub ! number of subintervals used for root finding integer, parameter :: sub_it_max = 4 @@ -577,7 +586,6 @@ subroutine wave_speeds(h, tv, G, GV, nmodes, cn, CS, full_halos) integer :: kc, nrows integer :: sub, sub_it integer :: i, j, k, k2, itt, is, ie, js, je, nz, row, iint, m, ig, jg - integer :: ig_need_sub, jg_need_sub ! for debugging (BDM) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -591,31 +599,19 @@ subroutine wave_speeds(h, tv, G, GV, nmodes, cn, CS, full_halos) endif ; endif S => tv%S ; T => tv%T - g_Rho0 = GV%g_Earth/GV%Rho0 + g_Rho0 = GV%g_Earth / GV%Rho0 use_EOS = associated(tv%eqn_of_state) - - H_to_pres = GV%g_Earth * GV%Rho0 - H_to_m = GV%H_to_m + Z_to_Pa = GV%g_Earth * GV%Rho0 min_h_frac = tol1 / real(nz) -!$OMP parallel do default(none) shared(is,ie,js,je,nz,h,G,GV,min_h_frac,use_EOS,T,S, & -!$OMP H_to_pres,H_to_m,tv,cn,g_Rho0,nmodes) & -!$OMP private(htot,hmin,kf,H_here,HxT_here,HxS_here,HxR_here, & -!$OMP Hf,Tf,Sf,Rf,pres,T_int,S_int,drho_dT, & -!$OMP drho_dS,drxh_sum,kc,Hc,Tc,Sc,I_Hnew,gprime, & -!$OMP Rc,speed2_tot,Igl,Igu,dlam, & -!$OMP det,ddet,ig,jg,z_int,N2,row,nrows,lam_1, & -!$OMP lamMin,speed2_min,lamMax,lamInc,numint,det_l, & -!$OMP ddet_l,xr,xl,det_r,xbl,xbr,ddet_r,xl_sub, & -!$OMP ig_need_sub,jg_need_sub,sub_rootfound,nsub, & -!$OMP det_sub,ddet_sub,lam_n, & -!$OMP a_diag,b_diag,c_diag,nrootsfound) + !$OMP parallel do default(private) shared(is,ie,js,je,nz,h,G,GV,US,min_h_frac,use_EOS,T,S, & + !$OMP Z_to_Pa,tv,cn,g_Rho0,nmodes) do j=js,je ! First merge very thin layers with the one above (or below if they are ! at the top). This also transposes the row order so that columns can ! be worked upon one at a time. do i=is,ie ; htot(i) = 0.0 ; enddo - do k=1,nz ; do i=is,ie ; htot(i) = htot(i) + h(i,j,k)*H_to_m ; enddo ; enddo + do k=1,nz ; do i=is,ie ; htot(i) = htot(i) + h(i,j,k)*GV%H_to_Z ; enddo ; enddo do i=is,ie hmin(i) = htot(i)*min_h_frac ; kf(i) = 1 ; H_here(i) = 0.0 @@ -623,20 +619,20 @@ subroutine wave_speeds(h, tv, G, GV, nmodes, cn, CS, full_halos) enddo if (use_EOS) then do k=1,nz ; do i=is,ie - if ((H_here(i) > hmin(i)) .and. (h(i,j,k)*H_to_m > hmin(i))) then + if ((H_here(i) > hmin(i)) .and. (h(i,j,k)*GV%H_to_Z > hmin(i))) then Hf(kf(i),i) = H_here(i) Tf(kf(i),i) = HxT_here(i) / H_here(i) Sf(kf(i),i) = HxS_here(i) / H_here(i) kf(i) = kf(i) + 1 ! Start a new layer - H_here(i) = h(i,j,k)*H_to_m - HxT_here(i) = (h(i,j,k)*H_to_m)*T(i,j,k) - HxS_here(i) = (h(i,j,k)*H_to_m)*S(i,j,k) + H_here(i) = h(i,j,k)*GV%H_to_Z + HxT_here(i) = (h(i,j,k)*GV%H_to_Z)*T(i,j,k) + HxS_here(i) = (h(i,j,k)*GV%H_to_Z)*S(i,j,k) else - H_here(i) = H_here(i) + h(i,j,k)*H_to_m - HxT_here(i) = HxT_here(i) + (h(i,j,k)*H_to_m)*T(i,j,k) - HxS_here(i) = HxS_here(i) + (h(i,j,k)*H_to_m)*S(i,j,k) + H_here(i) = H_here(i) + h(i,j,k)*GV%H_to_Z + HxT_here(i) = HxT_here(i) + (h(i,j,k)*GV%H_to_Z)*T(i,j,k) + HxS_here(i) = HxS_here(i) + (h(i,j,k)*GV%H_to_Z)*S(i,j,k) endif enddo ; enddo do i=is,ie ; if (H_here(i) > 0.0) then @@ -646,16 +642,16 @@ subroutine wave_speeds(h, tv, G, GV, nmodes, cn, CS, full_halos) endif ; enddo else do k=1,nz ; do i=is,ie - if ((H_here(i) > hmin(i)) .and. (h(i,j,k)*H_to_m > hmin(i))) then + if ((H_here(i) > hmin(i)) .and. (h(i,j,k)*GV%H_to_Z > hmin(i))) then Hf(kf(i),i) = H_here(i) ; Rf(kf(i),i) = HxR_here(i) / H_here(i) kf(i) = kf(i) + 1 ! Start a new layer - H_here(i) = h(i,j,k)*H_to_m - HxR_here(i) = (h(i,j,k)*H_to_m)*GV%Rlay(k) + H_here(i) = h(i,j,k)*GV%H_to_Z + HxR_here(i) = (h(i,j,k)*GV%H_to_Z)*GV%Rlay(k) else - H_here(i) = H_here(i) + h(i,j,k)*H_to_m - HxR_here(i) = HxR_here(i) + (h(i,j,k)*H_to_m)*GV%Rlay(k) + H_here(i) = H_here(i) + h(i,j,k)*GV%H_to_Z + HxR_here(i) = HxR_here(i) + (h(i,j,k)*GV%H_to_Z)*GV%Rlay(k) endif enddo ; enddo do i=is,ie ; if (H_here(i) > 0.0) then @@ -670,7 +666,7 @@ subroutine wave_speeds(h, tv, G, GV, nmodes, cn, CS, full_halos) if (use_EOS) then pres(1) = 0.0 do k=2,kf(i) - pres(k) = pres(k-1) + H_to_pres*Hf(k-1,i) + pres(k) = pres(k-1) + Z_to_Pa*Hf(k-1,i) T_int(k) = 0.5*(Tf(k,i)+Tf(k-1,i)) S_int(k) = 0.5*(Sf(k,i)+Sf(k-1,i)) enddo @@ -782,7 +778,7 @@ subroutine wave_speeds(h, tv, G, GV, nmodes, cn, CS, full_halos) do K=2,kc Igl(K) = 1.0/(gprime(K)*Hc(k)) ; Igu(K) = 1.0/(gprime(K)*Hc(k-1)) z_int(K) = z_int(K-1) + Hc(k-1) - N2(K) = gprime(K)/(0.5*(Hc(k)+Hc(k-1))) + N2(K) = US%m_to_Z**2*gprime(K)/(0.5*(Hc(k)+Hc(k-1))) speed2_tot = speed2_tot + gprime(K)*(Hc(k-1)+Hc(k)) enddo ! Set stratification for surface and bottom (setting equal to nearest interface for now) @@ -790,11 +786,8 @@ subroutine wave_speeds(h, tv, G, GV, nmodes, cn, CS, full_halos) ! Calcualte depth at bottom z_int(kc+1) = z_int(kc)+Hc(kc) ! check that thicknesses sum to total depth - if (abs(z_int(kc+1)-htot(i)) > 1.e-10) then - call MOM_error(WARNING, "wave_structure: mismatch in total depths") - print *, "kc=", kc - print *, "z_int(kc+1)=", z_int(kc+1) - print *, "htot(i)=", htot(i) + if (abs(z_int(kc+1)-htot(i)) > 1.e-12*htot(i)) then + call MOM_error(FATAL, "wave_structure: mismatch in total depths") endif ! Define the diagonals of the tridiagonal matrix @@ -844,22 +837,6 @@ subroutine wave_speeds(h, tv, G, GV, nmodes, cn, CS, full_halos) endif enddo - ! print resutls (for debugging only) - !if(ig .eq. 83 .and. jg .eq. 2) then - ! if(nmodes>1)then - ! print *, "Results after finding first mode:" - ! print *, "first guess at lam_1=", 1./speed2_tot - ! print *, "final guess at lam_1=", lam_1 - ! print *, "det value after iterations, det=", det - ! print *, "ddet value after iterations, det=", ddet - ! print *, "final guess at c1=", cn(i,j,1) - ! print *, "a_diag=",a_diag(1:nrows) - ! print *, "b_diag=",b_diag(1:nrows) - ! print *, "c_diag=",c_diag(1:nrows) - ! !stop - ! endif - !endif - ! Find other eigen values if c1 is of significant magnitude, > cn_thresh nrootsfound = 0 ! number of extra roots found (not including 1st root) if (nmodes>1 .and. kc>=nmodes+1 .and. cn(i,j,1)>c1_thresh) then @@ -874,15 +851,6 @@ subroutine wave_speeds(h, tv, G, GV, nmodes, cn, CS, full_halos) ! set number of intervals within search range numint = nint((lamMax - lamMin)/lamInc) - !if(ig .eq. 144 .and. jg .eq. 5) then - ! print *, 'Looking for other eigenvalues at', ig, jg - ! print *, 'Wave_speed: lamMin=', lamMin - ! print *, 'Wave_speed: cnMax=', 1/sqrt(lamMin) - ! print *, 'Wave_speed: lamMax=', lamMax - ! print *, 'Wave_speed: cnMin=', 1/sqrt(lamMax) - ! print *, 'Wave_speed: lamInc=', lamInc - !endif - ! Find intervals containing zero-crossings (roots) of the determinant ! that are beyond the first root @@ -895,22 +863,11 @@ subroutine wave_speeds(h, tv, G, GV, nmodes, cn, CS, full_halos) xl = xr - lamInc call tridiag_det(a_diag(1:nrows),b_diag(1:nrows),c_diag(1:nrows), & nrows,xr,det_r,ddet_r) - !if(ig .eq. 83 .and. jg .eq. 2) then - ! print *, "Move interval" - ! print *, "iint=",iint - ! print *, "@ xr=",xr - ! print *, "det_r=",det_r - ! print *, "ddet_r=",ddet_r - !endif if (det_l*det_r < 0.0) then ! if function changes sign if (det_l*ddet_l < 0.0) then ! if function at left is headed to zero nrootsfound = nrootsfound + 1 xbl(nrootsfound) = xl xbr(nrootsfound) = xr - !if(ig .eq. 144 .and. jg .eq. 5) then - ! print *, "Root located without subdivision!" - ! print *, "between xbl=",xl,"and xbr=",xr - !endif else ! function changes sign but has a local max/min in interval, ! try subdividing interval as many times as necessary (or sub_it_max). @@ -918,9 +875,7 @@ subroutine wave_speeds(h, tv, G, GV, nmodes, cn, CS, full_halos) !call MOM_error(WARNING, "determinant changes sign"// & ! "but has a local max/min in interval;"//& ! " reduce increment in lam.") - ig_need_sub = i + G%idg_offset ; jg_need_sub = j + G%jdg_offset ! begin subdivision loop ------------------------------------------- - !print *, "subdividing interval at ig=",ig_need_sub,"jg=",jg_need_sub sub_rootfound = .false. ! initialize do sub_it=1,sub_it_max nsub = 2**sub_it ! number of subintervals; nsub=2,4,8,... @@ -935,10 +890,6 @@ subroutine wave_speeds(h, tv, G, GV, nmodes, cn, CS, full_halos) nrootsfound = nrootsfound + 1 xbl(nrootsfound) = xl_sub xbr(nrootsfound) = xr - !if(ig .eq. 144 .and. jg .eq. 5) then - ! print *, "Root located after subdiving",sub_it," times!" - ! print *, "between xbl=",xl_sub,"and xbr=",xr - !endif exit ! exit sub loop endif ! headed toward zero endif ! sign change @@ -950,19 +901,6 @@ subroutine wave_speeds(h, tv, G, GV, nmodes, cn, CS, full_halos) call MOM_error(WARNING, "wave_speed: root not found "// & " after sub_it_max subdivisions of original"// & " interval.") - !if(ig .eq. 144 .and. jg .eq. 5) then - !print *, "xbl=",xbl - !print *, "xbr=",xbr - !print *, "Wave_speed: kc=",kc - !print *, 'Wave_speed: z_int(ig,jg)=', z_int(1:kc+1) - !print *, 'Wave_speed: N2(ig,jg)=', N2(1:kc+1) - !print *, 'Wave_speed: gprime=', gprime(1:kc+1) - !print *, 'Wave_speed: htot=', htot(i) - !print *, 'Wave_speed: cn1=', cn(i,j,1) - !print *, 'Wave_speed: numint=', numint - !print *, 'Wave_speed: nrootsfound=', nrootsfound - !stop - !endif endif ! sub_it == sub_it_max enddo ! sub_it-loop------------------------------------------------- endif ! det_l*ddet_l < 0.0 @@ -975,20 +913,6 @@ subroutine wave_speeds(h, tv, G, GV, nmodes, cn, CS, full_halos) ! oops, lamMax not large enough - could add code to increase (BDM) ! set unfound modes to zero for now (BDM) cn(i,j,nrootsfound+2:nmodes) = 0.0 - !if(ig .eq. 83 .and. jg .eq. 2) then - ! call MOM_error(WARNING, "wave_speed: not all modes found "// & - ! " within search range: increase numint.") - ! print *, "Increase lamMax at ig=",ig," jg=",jg - ! print *, "where lamMax=", lamMax - ! print *, 'numint=', numint - ! print *, "nrootsfound=", nrootsfound - ! print *, "xbl=",xbl - ! print *, "xbr=",xbr - !print *, "kc=",kc - !print *, 'z_int(ig,jg)=', z_int(1:kc+1) - !print *, 'N2(ig,jg)=', N2(1:kc+1) - !stop - !endif else ! else shift interval and keep looking until nmodes or numint is reached det_l = det_r @@ -1023,23 +947,6 @@ subroutine wave_speeds(h, tv, G, GV, nmodes, cn, CS, full_halos) else cn(i,j,:) = 0.0 ! This is a land point. endif ! if not land - ! ----- Spot check - comment out later (BDM) ---------- - !ig = G%idg_offset + i - !jg = G%jdg_offset + j - !if (ig .eq. 83 .and. jg .eq. 2) then - !! print *, "nmodes=",nmodes - ! print *, "lam_1=",lam_1 - ! print *, "lamMin=",lamMin - ! print *, "lamMax=",lamMax - ! print *, "lamInc=",lamInc - ! print *, "nrootsfound=",nrootsfound - ! do m=1,nmodes - ! print *, "c",m,"= ", cn(i,j,m) - ! print *, "xbl",m,"= ", xbl(m) - ! print *, "xbr",m,"= ", xbr(m) - ! enddo - !endif - !------------------------------------------------------- enddo ! i-loop enddo ! j-loop @@ -1061,9 +968,9 @@ subroutine tridiag_det(a,b,c,nrows,lam,det_out,ddet_out) real :: I_rescale ! inverse of rescale integer :: n ! row (layer interface) index - if (size(b) .ne. nrows) call MOM_error(WARNING, "Diagonal b must be same length as nrows.") - if (size(a) .ne. nrows) call MOM_error(WARNING, "Diagonal a must be same length as nrows.") - if (size(c) .ne. nrows) call MOM_error(WARNING, "Diagonal c must be same length as nrows.") + if (size(b) /= nrows) call MOM_error(WARNING, "Diagonal b must be same length as nrows.") + if (size(a) /= nrows) call MOM_error(WARNING, "Diagonal a must be same length as nrows.") + if (size(c) /= nrows) call MOM_error(WARNING, "Diagonal c must be same length as nrows.") I_rescale = 1.0/rescale @@ -1088,10 +995,12 @@ subroutine wave_speed_init(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_de type(wave_speed_CS), pointer :: CS !< Control structure for MOM_wave_speed logical, optional, intent(in) :: use_ebt_mode !< If true, use the equivalent !! barotropic mode instead of the first baroclinic mode. - real, optional, intent(in) :: mono_N2_column_fraction !< The lower fraction of water column over which N2 is limited - !! as monotonic for the purposes of calculating vertical modal structure. + real, optional, intent(in) :: mono_N2_column_fraction !< The lower fraction of water column over + !! which N2 is limited as monotonic for the purposes of + !! calculating the vertical modal structure. real, optional, intent(in) :: mono_N2_depth !< The depth below which N2 is limited - !! as monotonic for the purposes of calculating vertical modal structure. + !! as monotonic for the purposes of calculating the + !! vertical modal structure. ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "MOM_wave_speed" ! This module's name. @@ -1116,17 +1025,19 @@ subroutine wave_speed_set_param(CS, use_ebt_mode, mono_N2_column_fraction, mono_ type(wave_speed_CS), pointer :: CS !< Control structure for MOM_wave_speed logical, optional, intent(in) :: use_ebt_mode !< If true, use the equivalent !! barotropic mode instead of the first baroclinic mode. - real, optional, intent(in) :: mono_N2_column_fraction !< The lower fraction of water column over which N2 is limited - !! as monotonic for the purposes of calculating vertical modal structure. + real, optional, intent(in) :: mono_N2_column_fraction !< The lower fraction of water column over + !! which N2 is limited as monotonic for the purposes of + !! calculating the vertical modal structure. real, optional, intent(in) :: mono_N2_depth !< The depth below which N2 is limited - !! as monotonic for the purposes of calculating vertical modal structure. + !! as monotonic for the purposes of calculating the + !! vertical modal structure. if (.not.associated(CS)) call MOM_error(FATAL, & "wave_speed_set_param called with an associated control structure.") - if (present(use_ebt_mode)) CS%use_ebt_mode=use_ebt_mode - if (present(mono_N2_column_fraction)) CS%mono_N2_column_fraction=mono_N2_column_fraction - if (present(mono_N2_depth)) CS%mono_N2_depth=mono_N2_depth + if (present(use_ebt_mode)) CS%use_ebt_mode = use_ebt_mode + if (present(mono_N2_column_fraction)) CS%mono_N2_column_fraction = mono_N2_column_fraction + if (present(mono_N2_depth)) CS%mono_N2_depth = mono_N2_depth end subroutine wave_speed_set_param diff --git a/src/diagnostics/MOM_wave_structure.F90 b/src/diagnostics/MOM_wave_structure.F90 index 1db88cb804..28ad4c6bfc 100644 --- a/src/diagnostics/MOM_wave_structure.F90 +++ b/src/diagnostics/MOM_wave_structure.F90 @@ -1,31 +1,14 @@ +!> Vertical structure functions for first baroclinic mode wave speed module MOM_wave_structure ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Benjamin Mater & Robert Hallberg, 2015 * -!* * -!* The subroutine in this module calculates the vertical structure * -!* functions of the first baroclinic mode internal wave speed. * -!* Calculation of interface values is the same as done in * -!* MOM_wave_speed by Hallberg, 2008. * -!* * -!* Macros written all in capital letters are defined in MOM_memory.h. * -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q * -!* j+1 > o > o > At ^: v, vh, vav * -!* j x ^ x ^ x At >: u, uh, uav * -!* j > o > o > At o: h * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** +! By Benjamin Mater & Robert Hallberg, 2015 + +! The subroutine in this module calculates the vertical structure +! functions of the first baroclinic mode internal wave speed. +! Calculation of interface values is the same as done in +! MOM_wave_speed by Hallberg, 2008. use MOM_debugging, only : isnan => is_NaN use MOM_diag_mediator, only : post_data, query_averaging_enabled, diag_ctrl @@ -34,6 +17,7 @@ module MOM_wave_structure use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : log_version, param_file_type, get_param use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type @@ -43,106 +27,92 @@ module MOM_wave_structure public wave_structure, wave_structure_init +! 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_wave_structure module type, public :: wave_structure_CS ; !private - type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the - ! timing of diagnostic output. + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. real, allocatable, dimension(:,:,:) :: w_strct - ! Vertical structure of vertical velocity (normalized), in m s-1. + !< Vertical structure of vertical velocity (normalized) [m s-1]. real, allocatable, dimension(:,:,:) :: u_strct - ! Vertical structure of horizontal velocity (normalized), in m s-1. + !< Vertical structure of horizontal velocity (normalized) [m s-1]. real, allocatable, dimension(:,:,:) :: W_profile - ! Vertical profile of w_hat(z), where - ! w(x,y,z,t) = w_hat(z)*exp(i(kx+ly-freq*t)) is the full time- - ! varying vertical velocity with w_hat(z) = W0*w_strct(z), in m s-1. + !< Vertical profile of w_hat(z), where + !! w(x,y,z,t) = w_hat(z)*exp(i(kx+ly-freq*t)) is the full time- + !! varying vertical velocity with w_hat(z) = W0*w_strct(z) [m s-1]. real, allocatable, dimension(:,:,:) :: Uavg_profile - ! Vertical profile of the magnitude of horizontal velocity, - ! (u^2+v^2)^0.5, averaged over a period, in m s-1. + !< Vertical profile of the magnitude of horizontal velocity, + !! (u^2+v^2)^0.5, averaged over a period [m s-1]. real, allocatable, dimension(:,:,:) :: z_depths - ! Depths of layer interfaces, in m. + !< Depths of layer interfaces [m]. real, allocatable, dimension(:,:,:) :: N2 - ! Squared buoyancy frequency at each interface + !< Squared buoyancy frequency at each interface [s-2]. integer, allocatable, dimension(:,:):: num_intfaces - ! Number of layer interfaces (including surface and bottom) - real :: int_tide_source_x ! X Location of generation site - ! for internal tide for testing (BDM) - real :: int_tide_source_y ! Y Location of generation site - ! for internal tide for testing (BDM) + !< Number of layer interfaces (including surface and bottom) + real :: int_tide_source_x !< X Location of generation site + !! for internal tide for testing (BDM) + real :: int_tide_source_y !< Y Location of generation site + !! for internal tide for testing (BDM) end type wave_structure_CS contains !> This subroutine determines the internal wave velocity structure for any mode. -subroutine wave_structure(h, tv, G, GV, cn, ModeNum, freq, CS, En, full_halos) - 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 !< Layer thicknesses, in H - !! (usually m or kg m-2). - type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various - !! thermodynamic variables. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: cn !< The (non-rotational) mode - !! internal gravity wave speed, - !! in m s-1. +!! +!! This subroutine solves for the eigen vector [vertical structure, e(k)] associated with +!! the first baroclinic mode speed [i.e., smallest eigen value (lam = 1/c^2)] of the +!! system d2e/dz2 = -(N2/cn2)e, or (A-lam*I)e = 0, where A = -(1/N2)(d2/dz2), lam = 1/c^2, +!! and I is the identity matrix. 2nd order discretization in the vertical lets this system +!! be represented as +!! +!! -Igu(k)*e(k-1) + (Igu(k)+Igl(k)-lam)*e(k) - Igl(k)*e(k+1) = 0.0 +!! +!! with rigid lid boundary conditions e(1) = e(nz+1) = 0.0 giving +!! +!! (Igu(2)+Igl(2)-lam)*e(2) - Igl(2)*e(3) = 0.0 +!! -Igu(nz)*e(nz-1) + (Igu(nz)+Igl(nz)-lam)*e(nz) = 0.0 +!! +!! where, upon noting N2 = reduced gravity/layer thickness, we get +!! Igl(k) = 1.0/(gprime(k)*H(k)) ; Igu(k) = 1.0/(gprime(k)*H(k-1)) +!! +!! The eigen value for this system is approximated using "wave_speed." This subroutine uses +!! these eigen values (mode speeds) to estimate the corresponding eigen vectors (velocity +!! structure) using the "inverse iteration with shift" method. The algorithm is +!! +!! Pick a starting vector reasonably close to mode structure and with unit magnitude, b_guess +!! For n=1,2,3,... +!! Solve (A-lam*I)e = e_guess for e +!! Set e_guess=e/|e| and repeat, with each iteration refining the estimate of e +subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halos) + 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 + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: cn !< The (non-rotational) mode internal + !! gravity wave speed [m s-1]. integer, intent(in) :: ModeNum !< Mode number - real, intent(in) :: freq !< Intrinsic wave frequency, in s-1. - type(wave_structure_CS), pointer :: CS !< The control structure returned - !! by a previous call to - !! wave_structure_init. + real, intent(in) :: freq !< Intrinsic wave frequency [s-1]. + type(wave_structure_CS), pointer :: CS !< The control structure returned by a + !! previous call to wave_structure_init. real, dimension(SZI_(G),SZJ_(G)), & - optional, intent(in) :: En !< Internal wave energy density, - !! in Jm-2. + optional, intent(in) :: En !< Internal wave energy density [J m-2]. logical,optional, intent(in) :: full_halos !< If true, do the calculation - !! over the entire computational - !! domain. - -! This subroutine determines the internal wave velocity structure for any mode. -! Arguments: h - Layer thickness, in m or kg m-2. -! (in) tv - A structure containing the thermobaric variables. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) cn - The (non-rotational) mode internal gravity wave speed, in m s-1. -! (in) ModeNum - mode number -! (in) freq - intrinsic wave frequency, in s-1 -! (in) CS - The control structure returned by a previous call to -! wave_structure_init. -! (in,opt) En - Internal wave energy density, in Jm-2 -! (in,opt) full_halos - If true, do the calculation over the entire -! computational domain. -! -! This subroutine solves for the eigen vector [vertical structure, e(k)] associated with -! the first baroclinic mode speed [i.e., smallest eigen value (lam = 1/c^2)] of the -! system d2e/dz2 = -(N2/cn2)e, or (A-lam*I)e = 0, where A = -(1/N2)(d2/dz2), lam = 1/c^2, -! and I is the identity matrix. 2nd order discretization in the vertical lets this system -! be represented as -! -! -Igu(k)*e(k-1) + (Igu(k)+Igl(k)-lam)*e(k) - Igl(k)*e(k+1) = 0.0 -! -! with rigid lid boundary conditions e(1) = e(nz+1) = 0.0 giving -! -! (Igu(2)+Igl(2)-lam)*e(2) - Igl(2)*e(3) = 0.0 -! -Igu(nz)*e(nz-1) + (Igu(nz)+Igl(nz)-lam)*e(nz) = 0.0 -! -! where, upon noting N2 = reduced gravity/layer thickness, we get -! Igl(k) = 1.0/(gprime(k)*H(k)) ; Igu(k) = 1.0/(gprime(k)*H(k-1)) -! -! The eigen value for this system is approximated using "wave_speed." This subroutine uses -! these eigen values (mode speeds) to estimate the corresponding eigen vectors (velocity -! structure) using the "inverse iteration with shift" method. The algorithm is -! -! Pick a starting vector reasonably close to mode structure and with unit magnitude, b_guess -! For n=1,2,3,... -! Solve (A-lam*I)e = e_guess for e -! Set e_guess=e/|e| and repeat, with each iteration refining the estimate of e - + !! over the entire computational domain. + ! Local variables real, dimension(SZK_(G)+1) :: & dRho_dT, dRho_dS, & pres, T_int, S_int, & - gprime ! The reduced gravity across each interface, in m s-2. + gprime ! The reduced gravity across each interface [m2 Z-1 s-2 ~> m s-2]. real, dimension(SZK_(G)) :: & Igl, Igu ! The inverse of the reduced gravity across an interface times - ! the thickness of the layer below (Igl) or above (Igu) it, - ! in units of s2 m-2. + ! the thickness of the layer below (Igl) or above (Igu) it [s2 m-2]. real, dimension(SZK_(G),SZI_(G)) :: & Hf, Tf, Sf, Rf real, dimension(SZK_(G)) :: & @@ -153,15 +123,14 @@ subroutine wave_structure(h, tv, G, GV, cn, ModeNum, freq, CS, En, full_halos) real :: lam real :: min_h_frac real :: H_to_pres - real :: H_to_m ! Local copy of a unit conversion factor. real, dimension(SZI_(G)) :: & - hmin, & ! Thicknesses in m. + hmin, & ! Thicknesses [Z ~> m]. H_here, HxT_here, HxS_here, HxR_here real :: speed2_tot real :: I_Hnew, drxh_sum real, parameter :: tol1 = 0.0001, tol2 = 0.001 - real, pointer, dimension(:,:,:) :: T, S - real :: g_Rho0 ! G_Earth/Rho0 in m4 s-2 kg-1. + real, pointer, dimension(:,:,:) :: T => NULL(), S => NULL() + real :: g_Rho0 ! G_Earth/Rho0 in m5 Z-1 s-2 kg-1. real :: rescale, I_rescale integer :: kf(SZI_(G)) integer, parameter :: max_itt = 1 ! number of times to iterate in solving for eigenvector @@ -182,6 +151,7 @@ subroutine wave_structure(h, tv, G, GV, cn, ModeNum, freq, CS, En, full_halos) real :: w2avg ! average of squared vertical velocity structure funtion real :: int_dwdz2, int_w2, int_N2w2, KE_term, PE_term, W0 ! terms in vertically averaged energy equation + real :: gp_unscaled ! A version of gprime rescaled to [m s-2]. real, dimension(SZK_(G)-1) :: lam_z ! product of eigen value and gprime(k); one value for each ! interface (excluding surface and bottom) real, dimension(SZK_(G)-1) :: a_diag, b_diag, c_diag @@ -208,11 +178,10 @@ subroutine wave_structure(h, tv, G, GV, cn, ModeNum, freq, CS, En, full_halos) Pi = (4.0*atan(1.0)) S => tv%S ; T => tv%T - g_Rho0 = GV%g_Earth/GV%Rho0 + g_Rho0 = GV%g_Earth /GV%Rho0 use_EOS = associated(tv%eqn_of_state) H_to_pres = GV%g_Earth * GV%Rho0 - H_to_m = GV%H_to_m rescale = 1024.0**4 ; I_rescale = 1.0/rescale min_h_frac = tol1 / real(nz) @@ -222,7 +191,7 @@ subroutine wave_structure(h, tv, G, GV, cn, ModeNum, freq, CS, En, full_halos) ! at the top). This also transposes the row order so that columns can ! be worked upon one at a time. do i=is,ie ; htot(i,j) = 0.0 ; enddo - do k=1,nz ; do i=is,ie ; htot(i,j) = htot(i,j) + h(i,j,k)*H_to_m ; enddo ; enddo + do k=1,nz ; do i=is,ie ; htot(i,j) = htot(i,j) + h(i,j,k)*GV%H_to_Z ; enddo ; enddo do i=is,ie hmin(i) = htot(i,j)*min_h_frac ; kf(i) = 1 ; H_here(i) = 0.0 @@ -230,20 +199,20 @@ subroutine wave_structure(h, tv, G, GV, cn, ModeNum, freq, CS, En, full_halos) enddo if (use_EOS) then do k=1,nz ; do i=is,ie - if ((H_here(i) > hmin(i)) .and. (h(i,j,k)*H_to_m > hmin(i))) then + if ((H_here(i) > hmin(i)) .and. (h(i,j,k)*GV%H_to_Z > hmin(i))) then Hf(kf(i),i) = H_here(i) Tf(kf(i),i) = HxT_here(i) / H_here(i) Sf(kf(i),i) = HxS_here(i) / H_here(i) kf(i) = kf(i) + 1 ! Start a new layer - H_here(i) = h(i,j,k)*H_to_m - HxT_here(i) = (h(i,j,k)*H_to_m)*T(i,j,k) - HxS_here(i) = (h(i,j,k)*H_to_m)*S(i,j,k) + H_here(i) = h(i,j,k)*GV%H_to_Z + HxT_here(i) = (h(i,j,k)*GV%H_to_Z)*T(i,j,k) + HxS_here(i) = (h(i,j,k)*GV%H_to_Z)*S(i,j,k) else - H_here(i) = H_here(i) + h(i,j,k)*H_to_m - HxT_here(i) = HxT_here(i) + (h(i,j,k)*H_to_m)*T(i,j,k) - HxS_here(i) = HxS_here(i) + (h(i,j,k)*H_to_m)*S(i,j,k) + H_here(i) = H_here(i) + h(i,j,k)*GV%H_to_Z + HxT_here(i) = HxT_here(i) + (h(i,j,k)*GV%H_to_Z)*T(i,j,k) + HxS_here(i) = HxS_here(i) + (h(i,j,k)*GV%H_to_Z)*S(i,j,k) endif enddo ; enddo do i=is,ie ; if (H_here(i) > 0.0) then @@ -253,16 +222,16 @@ subroutine wave_structure(h, tv, G, GV, cn, ModeNum, freq, CS, En, full_halos) endif ; enddo else do k=1,nz ; do i=is,ie - if ((H_here(i) > hmin(i)) .and. (h(i,j,k)*H_to_m > hmin(i))) then + if ((H_here(i) > hmin(i)) .and. (h(i,j,k)*GV%H_to_Z > hmin(i))) then Hf(kf(i),i) = H_here(i) ; Rf(kf(i),i) = HxR_here(i) / H_here(i) kf(i) = kf(i) + 1 ! Start a new layer - H_here(i) = h(i,j,k)*H_to_m - HxR_here(i) = (h(i,j,k)*H_to_m)*GV%Rlay(k) + H_here(i) = h(i,j,k)*GV%H_to_Z + HxR_here(i) = (h(i,j,k)*GV%H_to_Z)*GV%Rlay(k) else - H_here(i) = H_here(i) + h(i,j,k)*H_to_m - HxR_here(i) = HxR_here(i) + (h(i,j,k)*H_to_m)*GV%Rlay(k) + H_here(i) = H_here(i) + h(i,j,k)*GV%H_to_Z + HxR_here(i) = HxR_here(i) + (h(i,j,k)*GV%H_to_Z)*GV%Rlay(k) endif enddo ; enddo do i=is,ie ; if (H_here(i) > 0.0) then @@ -272,10 +241,10 @@ subroutine wave_structure(h, tv, G, GV, cn, ModeNum, freq, CS, En, full_halos) ! From this point, we can work on individual columns without causing memory ! to have page faults. - do i=is,ie ; if(cn(i,j)>0.0)then + do i=is,ie ; if (cn(i,j)>0.0)then !----for debugging, remove later---- ig = i + G%idg_offset ; jg = j + G%jdg_offset - !if(ig .eq. CS%int_tide_source_x .and. jg .eq. CS%int_tide_source_y) then + !if (ig == CS%int_tide_source_x .and. jg == CS%int_tide_source_y) then !----------------------------------- if (G%mask2dT(i,j) > 0.5) then @@ -398,20 +367,20 @@ subroutine wave_structure(h, tv, G, GV, cn, ModeNum, freq, CS, En, full_halos) do K=2,kc Igl(K) = 1.0/(gprime(K)*Hc(k)) ; Igu(K) = 1.0/(gprime(K)*Hc(k-1)) z_int(K) = z_int(K-1) + Hc(k-1) - N2(K) = gprime(K)/(0.5*(Hc(k)+Hc(k-1))) + N2(K) = US%m_to_Z**2*gprime(K)/(0.5*(Hc(k)+Hc(k-1))) enddo ! Set stratification for surface and bottom (setting equal to nearest interface for now) N2(1) = N2(2) ; N2(kc+1) = N2(kc) ! Calcualte depth at bottom z_int(kc+1) = z_int(kc)+Hc(kc) ! check that thicknesses sum to total depth - if (abs(z_int(kc+1)-htot(i,j)) > 1.e-10) then - call MOM_error(WARNING, "wave_structure: mismatch in total depths") - print *, "kc=", kc - print *, "z_int(kc+1)=", z_int(kc+1) - print *, "htot(i,j)=", htot(i,j) + if (abs(z_int(kc+1)-htot(i,j)) > 1.e-14*htot(i,j)) then + call MOM_error(FATAL, "wave_structure: mismatch in total depths") endif + ! Note that many of the calcluation from here on revert to using vertical + ! distances in m, not Z. + ! Populate interior rows of tridiagonal matrix; must multiply through by ! gprime to get tridiagonal matrix to the symmetrical form: ! [-1/H(k-1)]e(k-1) + [1/H(k-1)+1/H(k)-lam_z]e(k) + [-1/H(k)]e(k+1) = 0, @@ -419,30 +388,33 @@ subroutine wave_structure(h, tv, G, GV, cn, ModeNum, freq, CS, En, full_halos) ! Frist, populate interior rows do K=3,kc-1 row = K-1 ! indexing for TD matrix rows - lam_z(row) = lam*gprime(K) - a_diag(row) = gprime(K)*(-Igu(K)) - b_diag(row) = gprime(K)*(Igu(K)+Igl(K)) - lam_z(row) - c_diag(row) = gprime(K)*(-Igl(K)) - if(isnan(lam_z(row)))then ; print *, "Wave_structure: lam_z(row) is NAN" ; endif - if(isnan(a_diag(row)))then ; print *, "Wave_structure: a(k) is NAN" ; endif - if(isnan(b_diag(row)))then ; print *, "Wave_structure: b(k) is NAN" ; endif - if(isnan(c_diag(row)))then ; print *, "Wave_structure: c(k) is NAN" ; endif + gp_unscaled = US%m_to_Z*gprime(K) + lam_z(row) = lam*gp_unscaled + a_diag(row) = gp_unscaled*(-Igu(K)) + b_diag(row) = gp_unscaled*(Igu(K)+Igl(K)) - lam_z(row) + c_diag(row) = gp_unscaled*(-Igl(K)) + if (isnan(lam_z(row)))then ; print *, "Wave_structure: lam_z(row) is NAN" ; endif + if (isnan(a_diag(row)))then ; print *, "Wave_structure: a(k) is NAN" ; endif + if (isnan(b_diag(row)))then ; print *, "Wave_structure: b(k) is NAN" ; endif + if (isnan(c_diag(row)))then ; print *, "Wave_structure: c(k) is NAN" ; endif enddo ! Populate top row of tridiagonal matrix - K=2 ; row = K-1 - lam_z(row) = lam*gprime(K) + K=2 ; row = K-1 ; + gp_unscaled = US%m_to_Z*gprime(K) + lam_z(row) = lam*gp_unscaled a_diag(row) = 0.0 - b_diag(row) = gprime(K)*(Igu(K)+Igl(K)) - lam_z(row) - c_diag(row) = gprime(K)*(-Igl(K)) + b_diag(row) = gp_unscaled*(Igu(K)+Igl(K)) - lam_z(row) + c_diag(row) = gp_unscaled*(-Igl(K)) ! Populate bottom row of tridiagonal matrix K=kc ; row = K-1 - lam_z(row) = lam*gprime(K) - a_diag(row) = gprime(K)*(-Igu(K)) - b_diag(row) = gprime(K)*(Igu(K)+Igl(K)) - lam_z(row) + gp_unscaled = US%m_to_Z*gprime(K) + lam_z(row) = lam*gp_unscaled + a_diag(row) = gp_unscaled*(-Igu(K)) + b_diag(row) = gp_unscaled*(Igu(K)+Igl(K)) - lam_z(row) c_diag(row) = 0.0 ! Guess a vector shape to start with (excludes surface and bottom) - e_guess(1:kc-1) = sin(z_int(2:kc)/htot(i,j)*Pi) + e_guess(1:kc-1) = sin((z_int(2:kc)/htot(i,j)) *Pi) e_guess(1:kc-1) = e_guess(1:kc-1)/sqrt(sum(e_guess(1:kc-1)**2)) ! Perform inverse iteration with tri-diag solver @@ -457,9 +429,9 @@ subroutine wave_structure(h, tv, G, GV, cn, ModeNum, freq, CS, En, full_halos) ! Check to see if solver worked ig_stop = 0 ; jg_stop = 0 - if(isnan(sum(w_strct(1:kc+1))))then + if (isnan(sum(w_strct(1:kc+1))))then print *, "Wave_structure: w_strct has a NAN at ig=", ig, ", jg=", jg - if(iG%iec .or. jG%jec)then + if (iG%iec .or. jG%jec)then print *, "This is occuring at a halo point." endif ig_stop = ig ; jg_stop = jg @@ -471,11 +443,12 @@ subroutine wave_structure(h, tv, G, GV, cn, ModeNum, freq, CS, En, full_halos) !(including surface and bottom) w2avg = 0.0 do k=1,nzm-1 - dz(k) = Hc(k) + dz(k) = US%Z_to_m*Hc(k) w2avg = w2avg + 0.5*(w_strct(K)**2+w_strct(K+1)**2)*dz(k) enddo - w2avg = w2avg/htot(i,j) - w_strct = w_strct/sqrt(htot(i,j)*w2avg*I_a_int) + !### Some mathematical cancellations could occur in the next two lines. + w2avg = w2avg / htot(i,j) + w_strct = w_strct / sqrt(htot(i,j)*w2avg*I_a_int) ! Calculate vertical structure function of u (i.e. dw/dz) do K=2,nzm-1 @@ -525,45 +498,13 @@ subroutine wave_structure(h, tv, G, GV, cn, ModeNum, freq, CS, En, full_halos) endif ! Store values in control structure - CS%w_strct(i,j,1:nzm) = w_strct - CS%u_strct(i,j,1:nzm) = u_strct - CS%W_profile(i,j,1:nzm) = W_profile - CS%Uavg_profile(i,j,1:nzm)= Uavg_profile - CS%z_depths(i,j,1:nzm) = z_int - CS%N2(i,j,1:nzm) = N2 + CS%w_strct(i,j,1:nzm) = w_strct(:) + CS%u_strct(i,j,1:nzm) = u_strct(:) + CS%W_profile(i,j,1:nzm) = W_profile(:) + CS%Uavg_profile(i,j,1:nzm)= Uavg_profile(:) + CS%z_depths(i,j,1:nzm) = US%Z_to_m*z_int(:) + CS%N2(i,j,1:nzm) = N2(:) CS%num_intfaces(i,j) = nzm - - !----for debugging; delete later---- - !if(ig .eq. ig_stop .and. jg .eq. jg_stop) then - !print *, 'cn(ig,jg)=', cn(i,j) - !print *, "e_guess=", e_guess(1:kc-1) - !print *, "|e_guess|=", sqrt(sum(e_guess(1:kc-1)**2)) - !print *, 'f0=', sqrt(f2) - !print *, 'freq=', freq - !print *, 'Kh=', sqrt(Kmag2) - !print *, 'Wave_structure: z_int(ig,jg)=', z_int(1:nzm) - !print *, 'Wave_structure: N2(ig,jg)=', N2(1:nzm) - !print *, 'gprime=', gprime(1:nzm) - !print *, '1/Hc=', 1/Hc - !print *, 'Wave_structure: a_diag(ig,jg)=', a_diag(1:kc-1) - !print *, 'Wave_structure: b_diag(ig,jg)=', b_diag(1:kc-1) - !print *, 'Wave_structure: c_diag(ig,jg)=', c_diag(1:kc-1) - !print *, 'Wave_structure: lam_z(ig,jg)=', lam_z(1:kc-1) - !print *, 'Wave_structure: w_strct(ig,jg)=', w_strct(1:nzm) - !print *, 'En(i,j)=', En(i,j) - !print *, 'Wave_structure: W_profile(ig,jg)=', W_profile(1:nzm) - !print *,'int_dwdz2 =',int_dwdz2 - !print *,'int_w2 =',int_w2 - !print *,'int_N2w2 =',int_N2w2 - !print *,'KEterm=',KE_term - !print *,'PEterm=',PE_term - !print *, 'W0=',W0 - !print *,'Uavg_profile=',Uavg_profile(1:nzm) - !open(unit=1,file='out_N2',form='formatted') ; write(1,*) N2 ; close(1) - !open(unit=2,file='out_z',form='formatted') ; write(2,*) z_int ; close(2) - !endif - !----------------------------------- - else ! If not enough layers, default to zero nzm = kc+1 @@ -595,10 +536,10 @@ subroutine wave_structure(h, tv, G, GV, cn, ModeNum, freq, CS, En, full_halos) end subroutine wave_structure -!> This subroutine solves a tri-diagonal system Ax=y using either the standard -!! Thomas algorithim (TDMA_T) or its more stable variant that invokes the +!> Solves a tri-diagonal system Ax=y using either the standard +!! Thomas algorithm (TDMA_T) or its more stable variant that invokes the !! "Hallberg substitution" (TDMA_H). -subroutine tridiag_solver(a,b,c,h,y,method,x) +subroutine tridiag_solver(a, b, c, h, y, method, x) real, dimension(:), intent(in) :: a !< lower diagonal with first entry equal to zero. real, dimension(:), intent(in) :: b !< middle diagonal. real, dimension(:), intent(in) :: c !< upper diagonal with last entry equal to zero. @@ -610,30 +551,12 @@ subroutine tridiag_solver(a,b,c,h,y,method,x) !! where a(k)=[-alpha(k-1/2)], b(k)=[alpha(k-1/2)+alpha(k+1/2) + h(k)], !! and c(k)=[-alpha(k+1/2)]. Only used with TDMA_H method. real, dimension(:), intent(in) :: y !< vector of known values on right hand side. - character(len=*), intent(in) :: method + character(len=*), intent(in) :: method !< A string describing the algorithm to use real, dimension(:), intent(out) :: x !< vector of unknown values to solve for. - -! This subroutine solves a tri-diagonal system Ax=y using either the standard -! Thomas algorithim (TDMA_T) or its more stable variant that invokes the -! "Hallberg substitution" (TDMA_H). -! -! Arguments: -! (in) a - lower diagonal with first entry equal to zero -! (in) b - middle diagonal -! (in) c - upper diagonal with last entry equal to zero -! (in) h - vector of values that have already been added to b; used for -! systems of the form (e.g. average layer thickness in vertical diffusion case): -! [ -alpha(k-1/2) ] * e(k-1) + -! [ alpha(k-1/2) + alpha(k+1/2) + h(k) ] * e(k) + -! [ -alpha(k+1/2) ] * e(k+1) = y(k) -! where a(k)=[-alpha(k-1/2)], b(k)=[alpha(k-1/2)+alpha(k+1/2) + h(k)], -! and c(k)=[-alpha(k+1/2)]. Only used with TDMA_H method. -! (in) y - vector of known values on right hand side -! (out) x - vector of unknown values to solve for - + ! Local variables integer :: nrow ! number of rows in A matrix - real, allocatable, dimension(:,:) :: A_check ! for solution checking - real, allocatable, dimension(:) :: y_check ! for solution checking +! real, allocatable, dimension(:,:) :: A_check ! for solution checking +! real, allocatable, dimension(:) :: y_check ! for solution checking real, allocatable, dimension(:) :: c_prime, y_prime, q, alpha ! intermediate values for solvers real :: Q_prime, beta ! intermediate values for solver @@ -645,8 +568,8 @@ subroutine tridiag_solver(a,b,c,h,y,method,x) allocate(y_prime(nrow)) allocate(q(nrow)) allocate(alpha(nrow)) - allocate(A_check(nrow,nrow)) - allocate(y_check(nrow)) +! allocate(A_check(nrow,nrow)) +! allocate(y_check(nrow)) if (method == 'TDMA_T') then ! Standard Thomas algoritim (4th variant). @@ -673,14 +596,14 @@ subroutine tridiag_solver(a,b,c,h,y,method,x) ! Check results - delete later !do j=1,nrow ; do i=1,nrow - ! if(i==j)then ; A_check(i,j) = b(i) - ! elseif(i==j+1)then ; A_check(i,j) = a(i) - ! elseif(i==j-1)then ; A_check(i,j) = c(i) + ! if (i==j)then ; A_check(i,j) = b(i) + ! elseif (i==j+1)then ; A_check(i,j) = a(i) + ! elseif (i==j-1)then ; A_check(i,j) = c(i) ! endif !enddo ; enddo !print *, 'A(2,1),A(2,2),A(1,2)=', A_check(2,1), A_check(2,2), A_check(1,2) !y_check = matmul(A_check,x) - !if(all(y_check .ne. y))then + !if (all(y_check /= y))then ! print *, "tridiag_solver: Uh oh, something's not right!" ! print *, "y=", y ! print *, "y_check=", y_check @@ -696,7 +619,7 @@ subroutine tridiag_solver(a,b,c,h,y,method,x) ! symmetric, diagonally dominant matrix, with h>0. ! Need to add a check for these conditions. do k=1,nrow-1 - if (abs(a(k+1)-c(k)) > 1.e-10) then + if (abs(a(k+1)-c(k)) > 1.e-10*(abs(a(k+1))+abs(c(k)))) then call MOM_error(WARNING, "tridiag_solver: matrix not symmetric; need symmetry when invoking TDMA_H") endif enddo @@ -713,14 +636,14 @@ subroutine tridiag_solver(a,b,c,h,y,method,x) ! Forward sweep do k=2,nrow-1 beta = 1/(h(k)+alpha(k-1)*Q_prime+alpha(k)) - if(isnan(beta))then ; print *, "Tridiag_solver: beta is NAN" ; endif + if (isnan(beta))then ; print *, "Tridiag_solver: beta is NAN" ; endif q(k) = beta*alpha(k) y_prime(k) = beta*(y(k)+alpha(k-1)*y_prime(k-1)) Q_prime = beta*(h(k)+alpha(k-1)*Q_prime) enddo - if((h(nrow)+alpha(nrow-1)*Q_prime+alpha(nrow)) == 0.0)then - call MOM_error(WARNING, "Tridiag_solver: this system is not stable; overriding beta(nrow).") - beta = 1/(1e-15) ! place holder for unstable systems - delete later + if ((h(nrow)+alpha(nrow-1)*Q_prime+alpha(nrow)) == 0.0)then + call MOM_error(FATAL, "Tridiag_solver: this system is not stable.") ! ; overriding beta(nrow) + ! This has hard-coded dimensions: beta = 1/(1e-15) ! place holder for unstable systems - delete later else beta = 1/(h(nrow)+alpha(nrow-1)*Q_prime+alpha(nrow)) endif @@ -734,27 +657,21 @@ subroutine tridiag_solver(a,b,c,h,y,method,x) !print *, 'x=',x(1:nrow) endif - deallocate(c_prime,y_prime,q,alpha,A_check,y_check) + deallocate(c_prime,y_prime,q,alpha) +! deallocate(A_check,y_check) end subroutine tridiag_solver - +!> Allocate memory associated with the wave structure module and read parameters. subroutine wave_structure_init(Time, G, param_file, diag, CS) - type(time_type), intent(in) :: Time !< The current model time. - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time - !! parameters. - type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate - !! diagnostic output. - type(wave_structure_CS), pointer :: CS !< A pointer that is set to point to the - !! control structure for this module. -! Arguments: Time - The current model time. -! (in) G - The ocean's grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in) diag - A structure that is used to regulate diagnostic output. -! (in/out) CS - A pointer that is set to point to the control structure -! for this module + type(time_type), intent(in) :: Time !< The current model time. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time + !! parameters. + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate + !! diagnostic output. + type(wave_structure_CS), pointer :: CS !< A pointer that is set to point to the + !! control structure for this module. ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "MOM_wave_structure" ! This module's name. @@ -790,5 +707,4 @@ subroutine wave_structure_init(Time, G, param_file, diag, CS) end subroutine wave_structure_init - end module MOM_wave_structure diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index e94f945c57..b06ffa0a79 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -51,6 +51,11 @@ module MOM_EOS public gsw_sp_from_sr, gsw_pt_from_ct public extract_member_EOS +! 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. + !> Calculates density of sea water from T, S and P interface calculate_density module procedure calculate_density_scalar, calculate_density_array @@ -61,10 +66,13 @@ module MOM_EOS module procedure calculate_spec_vol_scalar, calculate_spec_vol_array end interface calculate_spec_vol +!> Calculate the derivatives of density with temperature and salinity from T, S, and P interface calculate_density_derivs module procedure calculate_density_derivs_scalar, calculate_density_derivs_array end interface calculate_density_derivs +!> Calculates the second derivatives of density with various combinations of temperature, +!! salinity, and pressure from T, S and P interface calculate_density_second_derivs module procedure calculate_density_second_derivs_scalar, calculate_density_second_derivs_array end interface calculate_density_second_derivs @@ -81,54 +89,54 @@ module MOM_EOS !! of the freezing point. logical :: EOS_quadrature !< If true, always use the generic (quadrature) !! code for the integrals of density. - logical :: Compressible = .true. !< If true, in situ density is a function - !! of pressure. + logical :: Compressible = .true. !< If true, in situ density is a function of pressure. ! The following parameters are used with the linear equation of state only. - real :: Rho_T0_S0 !< The density at T=0, S=0, in kg m-3. - real :: dRho_dT !< The partial derivatives of density with temperature - real :: dRho_dS !< and salinity, in kg m-3 K-1 and kg m-3 psu-1. + real :: Rho_T0_S0 !< The density at T=0, S=0 [kg m-3]. + real :: dRho_dT !< The partial derivative of density with temperature [kg m-3 degC-1] + real :: dRho_dS !< The partial derivative of density with salinity [kg m-3 ppt-1]. ! The following parameters are use with the linear expression for the freezing ! point only. - real :: TFr_S0_P0 !< The freezing potential temperature at S=0, P=0 in deg C. - real :: dTFr_dS !< The derivative of freezing point with salinity, in deg C PSU-1. - real :: dTFr_dp !< The derivative of freezing point with pressure, in deg C Pa-1. + real :: TFr_S0_P0 !< The freezing potential temperature at S=0, P=0 [degC]. + real :: dTFr_dS !< The derivative of freezing point with salinity [degC ppt-1]. + real :: dTFr_dp !< The derivative of freezing point with pressure [degC Pa-1]. - logical :: test_EOS = .true. +! logical :: test_EOS = .true. ! If true, test the equation of state end type EOS_type ! The named integers that might be stored in eqn_of_state_type%form_of_EOS. -integer, parameter, public :: EOS_LINEAR = 1 -integer, parameter, public :: EOS_UNESCO = 2 -integer, parameter, public :: EOS_WRIGHT = 3 -integer, parameter, public :: EOS_TEOS10 = 4 -integer, parameter, public :: EOS_NEMO = 5 - -character*(10), parameter :: EOS_LINEAR_STRING = "LINEAR" -character*(10), parameter :: EOS_UNESCO_STRING = "UNESCO" -character*(10), parameter :: EOS_WRIGHT_STRING = "WRIGHT" -character*(10), parameter :: EOS_TEOS10_STRING = "TEOS10" -character*(10), parameter :: EOS_NEMO_STRING = "NEMO" -character*(10), parameter :: EOS_DEFAULT = EOS_WRIGHT_STRING - -integer, parameter :: TFREEZE_LINEAR = 1 -integer, parameter :: TFREEZE_MILLERO = 2 -integer, parameter :: TFREEZE_TEOS10 = 3 -character*(10), parameter :: TFREEZE_LINEAR_STRING = "LINEAR" -character*(10), parameter :: TFREEZE_MILLERO_STRING = "MILLERO_78" -character*(10), parameter :: TFREEZE_TEOS10_STRING = "TEOS10" -character*(10), parameter :: TFREEZE_DEFAULT = TFREEZE_LINEAR_STRING +integer, parameter, public :: EOS_LINEAR = 1 !< A named integer specifying an equation of state +integer, parameter, public :: EOS_UNESCO = 2 !< A named integer specifying an equation of state +integer, parameter, public :: EOS_WRIGHT = 3 !< A named integer specifying an equation of state +integer, parameter, public :: EOS_TEOS10 = 4 !< A named integer specifying an equation of state +integer, parameter, public :: EOS_NEMO = 5 !< A named integer specifying an equation of state + +character*(10), parameter :: EOS_LINEAR_STRING = "LINEAR" !< A string for specifying the equation of state +character*(10), parameter :: EOS_UNESCO_STRING = "UNESCO" !< A string for specifying the equation of state +character*(10), parameter :: EOS_WRIGHT_STRING = "WRIGHT" !< A string for specifying the equation of state +character*(10), parameter :: EOS_TEOS10_STRING = "TEOS10" !< A string for specifying the equation of state +character*(10), parameter :: EOS_NEMO_STRING = "NEMO" !< A string for specifying the equation of state +character*(10), parameter :: EOS_DEFAULT = EOS_WRIGHT_STRING !< The default equation of state + +integer, parameter :: TFREEZE_LINEAR = 1 !< A named integer specifying a freezing point expression +integer, parameter :: TFREEZE_MILLERO = 2 !< A named integer specifying a freezing point expression +integer, parameter :: TFREEZE_TEOS10 = 3 !< A named integer specifying a freezing point expression +character*(10), parameter :: TFREEZE_LINEAR_STRING = "LINEAR" !< A string for specifying the freezing point expression +character*(10), parameter :: TFREEZE_MILLERO_STRING = "MILLERO_78" !< A string for specifying + !! freezing point expression +character*(10), parameter :: TFREEZE_TEOS10_STRING = "TEOS10" !< A string for specifying the freezing point expression +character*(10), parameter :: TFREEZE_DEFAULT = TFREEZE_LINEAR_STRING !< The default freezing point expression contains !> Calls the appropriate subroutine to calculate density of sea water for scalar inputs. !! If rho_ref is present, the anomaly with respect to rho_ref is returned. subroutine calculate_density_scalar(T, S, pressure, rho, EOS, rho_ref) - real, intent(in) :: T !< Potential temperature referenced to the surface (degC) - real, intent(in) :: S !< Salinity (PSU) - real, intent(in) :: pressure !< Pressure (Pa) - real, intent(out) :: rho !< Density (in-situ if pressure is local) (kg m-3) + real, intent(in) :: T !< Potential temperature referenced to the surface [degC] + real, intent(in) :: S !< Salinity [ppt] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: rho !< Density (in-situ if pressure is local) [kg m-3] type(EOS_type), pointer :: EOS !< Equation of state structure - real, optional, intent(in) :: rho_ref !< A reference density in kg m-3. + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_scalar called with an unassociated EOS_type EOS.") @@ -155,14 +163,14 @@ end subroutine calculate_density_scalar !> Calls the appropriate subroutine to calculate the density of sea water for 1-D array inputs. !! If rho_ref is present, the anomaly with respect to rho_ref is returned. subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_ref) - real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface (degC) - real, dimension(:), intent(in) :: S !< Salinity (PSU) - real, dimension(:), intent(in) :: pressure !< Pressure (Pa) - real, dimension(:), intent(out) :: rho !< Density (in-situ if pressure is local) (kg m-3) + real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [ppt] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: rho !< Density (in-situ if pressure is local) [kg m-3] integer, intent(in) :: start !< Start index for computation integer, intent(in) :: npts !< Number of point to compute type(EOS_type), pointer :: EOS !< Equation of state structure - real, optional, intent(in) :: rho_ref !< A reference density in kg m-3. + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_array called with an unassociated EOS_type EOS.") @@ -189,12 +197,12 @@ end subroutine calculate_density_array !> Calls the appropriate subroutine to calculate specific volume of sea water !! for scalar inputs. subroutine calculate_spec_vol_scalar(T, S, pressure, specvol, EOS, spv_ref) - real, intent(in) :: T !< Potential temperature referenced to the surface (degC) - real, intent(in) :: S !< Salinity (PSU) - real, intent(in) :: pressure !< Pressure (Pa) - real, intent(out) :: specvol !< specific volume (in-situ if pressure is local) (m3 kg-1) + real, intent(in) :: T !< Potential temperature referenced to the surface [degC] + real, intent(in) :: S !< Salinity [ppt] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: specvol !< specific volume (in-situ if pressure is local) [m3 kg-1] type(EOS_type), pointer :: EOS !< Equation of state structure - real, optional, intent(in) :: spv_ref !< A reference specific volume in m3 kg-1. + real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. real :: rho @@ -230,14 +238,14 @@ end subroutine calculate_spec_vol_scalar !! for 1-D array inputs. subroutine calculate_spec_vol_array(T, S, pressure, specvol, start, npts, EOS, spv_ref) real, dimension(:), intent(in) :: T !< potential temperature relative to the surface - !! in C. - real, dimension(:), intent(in) :: S !< salinity in PSU. - real, dimension(:), intent(in) :: pressure !< pressure in Pa. - real, dimension(:), intent(out) :: specvol !< in situ specific volume in kg m-3. + !! [degC]. + real, dimension(:), intent(in) :: S !< salinity [ppt]. + real, dimension(:), intent(in) :: pressure !< pressure [Pa]. + real, dimension(:), intent(out) :: specvol !< in situ specific volume [kg m-3]. integer, intent(in) :: start !< the starting point in the arrays. integer, intent(in) :: npts !< the number of values to calculate. type(EOS_type), pointer :: EOS !< Equation of state structure - real, optional, intent(in) :: spv_ref !< A reference specific volume in m3 kg-1. + real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. real, dimension(size(specvol)) :: rho @@ -272,9 +280,10 @@ end subroutine calculate_spec_vol_array !> Calls the appropriate subroutine to calculate the freezing point for scalar inputs. subroutine calculate_TFreeze_scalar(S, pressure, T_fr, EOS) - real, intent(in) :: S !< Salinity (PSU) - real, intent(in) :: pressure !< Pressure (Pa) - real, intent(out) :: T_fr !< Freezing point potential temperature referenced to the surface (degC) + real, intent(in) :: S !< Salinity [ppt] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: T_fr !< Freezing point potential temperature referenced + !! to the surface [degC] type(EOS_type), pointer :: EOS !< Equation of state structure if (.not.associated(EOS)) call MOM_error(FATAL, & @@ -297,9 +306,10 @@ end subroutine calculate_TFreeze_scalar !> Calls the appropriate subroutine to calculate the freezing point for a 1-D array. subroutine calculate_TFreeze_array(S, pressure, T_fr, start, npts, EOS) - real, dimension(:), intent(in) :: S !< Salinity (PSU) - real, dimension(:), intent(in) :: pressure !< Pressure (Pa) - real, dimension(:), intent(out) :: T_fr !< Freezing point potential temperature referenced to the surface (degC) + real, dimension(:), intent(in) :: S !< Salinity [ppt] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: T_fr !< Freezing point potential temperature referenced + !! to the surface [degC] integer, intent(in) :: start !< Starting index within the array integer, intent(in) :: npts !< The number of values to calculate type(EOS_type), pointer :: EOS !< Equation of state structure @@ -324,22 +334,24 @@ end subroutine calculate_TFreeze_array !> Calls the appropriate subroutine to calculate density derivatives for 1-D array inputs. subroutine calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, start, npts, EOS) - real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface (degC) - real, dimension(:), intent(in) :: S !< Salinity (PSU) - real, dimension(:), intent(in) :: pressure !< Pressure (Pa) - real, dimension(:), intent(out) :: drho_dT !< The partial derivative of density with potential tempetature, in kg m-3 K-1. - real, dimension(:), intent(out) :: drho_dS !< The partial derivative of density with salinity, in kg m-3 psu-1. + real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [ppt] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: drho_dT !< The partial derivative of density with potential + !! temperature [kg m-3 degC-1]. + real, dimension(:), intent(out) :: drho_dS !< The partial derivative of density with salinity, + !! in [kg m-3 ppt-1]. integer, intent(in) :: start !< Starting index within the array integer, intent(in) :: npts !< The number of values to calculate type(EOS_type), pointer :: EOS !< Equation of state structure - !! + if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_derivs called with an unassociated EOS_type EOS.") select case (EOS%form_of_EOS) case (EOS_LINEAR) - call calculate_density_derivs_linear(T, S, pressure, drho_dT, drho_dS, EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, & - start, npts) + call calculate_density_derivs_linear(T, S, pressure, drho_dT, drho_dS, EOS%Rho_T0_S0, & + EOS%dRho_dT, EOS%dRho_dS, start, npts) case (EOS_UNESCO) call calculate_density_derivs_unesco(T, S, pressure, drho_dT, drho_dS, start, npts) case (EOS_WRIGHT) @@ -355,13 +367,16 @@ subroutine calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, star end subroutine calculate_density_derivs_array -!> Calls the appropriate subroutines to calculate density derivatives by promoting a scalar to a one-element array +!> Calls the appropriate subroutines to calculate density derivatives by promoting a scalar +!! to a one-element array subroutine calculate_density_derivs_scalar(T, S, pressure, drho_dT, drho_dS, EOS) - real, intent(in) :: T !< Potential temperature referenced to the surface (degC) - real, intent(in) :: S !< Salinity (PSU) - real, intent(in) :: pressure !< Pressure (Pa) - real, intent(out) :: drho_dT !< The partial derivative of density with potential tempetature, in kg m-3 K-1. - real, intent(out) :: drho_dS !< The partial derivative of density with salinity, in kg m-3 psu-1. + real, intent(in) :: T !< Potential temperature referenced to the surface [degC] + real, intent(in) :: S !< Salinity [ppt] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: drho_dT !< The partial derivative of density with potential + !! temperature [kg m-3 degC-1]. + real, intent(out) :: drho_dS !< The partial derivative of density with salinity, + !! in [kg m-3 ppt-1]. type(EOS_type), pointer :: EOS !< Equation of state structure if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_derivs called with an unassociated EOS_type EOS.") @@ -382,33 +397,38 @@ subroutine calculate_density_derivs_scalar(T, S, pressure, drho_dT, drho_dS, EOS end subroutine calculate_density_derivs_scalar !> Calls the appropriate subroutine to calculate density second derivatives for 1-D array inputs. -subroutine calculate_density_second_derivs_array(T, S, pressure, drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, drho_dT_dP, & - start, npts, EOS) - real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface (degC) - real, dimension(:), intent(in) :: S !< Salinity (PSU) - real, dimension(:), intent(in) :: pressure !< Pressure (Pa) - real, dimension(:), intent(out) :: drho_dS_dS !< Partial derivative of beta with respect to S - real, dimension(:), intent(out) :: drho_dS_dT !< Partial derivative of beta with resepct to T - real, dimension(:), intent(out) :: drho_dT_dT !< Partial derivative of alpha with respect to T - real, dimension(:), intent(out) :: drho_dS_dP !< Partial derivative of beta with respect to pressure - real, dimension(:), intent(out) :: drho_dT_dP !< Partial derivative of alpha with respect to pressure +subroutine calculate_density_second_derivs_array(T, S, pressure, drho_dS_dS, drho_dS_dT, drho_dT_dT, & + drho_dS_dP, drho_dT_dP, start, npts, EOS) + real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [ppt] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: drho_dS_dS !< Partial derivative of beta with respect + !! to S [kg m-3 ppt-2] + real, dimension(:), intent(out) :: drho_dS_dT !< Partial derivative of beta with respcct + !! to T [kg m-3 ppt-1 degC-1] + real, dimension(:), intent(out) :: drho_dT_dT !< Partial derivative of alpha with respect + !! to T [kg m-3 degC-2] + real, dimension(:), intent(out) :: drho_dS_dP !< Partial derivative of beta with respect + !! to pressure [kg m-3 ppt-1 Pa-1] + real, dimension(:), intent(out) :: drho_dT_dP !< Partial derivative of alpha with respect + !! to pressure [kg m-3 degC-1 Pa-1] integer, intent(in) :: start !< Starting index within the array integer, intent(in) :: npts !< The number of values to calculate type(EOS_type), pointer :: EOS !< Equation of state structure - !! + if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_derivs called with an unassociated EOS_type EOS.") select case (EOS%form_of_EOS) case (EOS_LINEAR) - call calculate_density_second_derivs_linear(T, S, pressure, drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, & - drho_dT_dP, start, npts) + call calculate_density_second_derivs_linear(T, S, pressure, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP, start, npts) case (EOS_WRIGHT) - call calculate_density_second_derivs_wright(T, S, pressure, drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, & - drho_dT_dP, start, npts) + call calculate_density_second_derivs_wright(T, S, pressure, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP, start, npts) case (EOS_TEOS10) - call calculate_density_second_derivs_teos10(T, S, pressure, drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, & - drho_dT_dP, start, npts) + call calculate_density_second_derivs_teos10(T, S, pressure, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP, start, npts) case default call MOM_error(FATAL, & "calculate_density_derivs: EOS%form_of_EOS is not valid.") @@ -417,31 +437,36 @@ subroutine calculate_density_second_derivs_array(T, S, pressure, drho_dS_dS, drh end subroutine calculate_density_second_derivs_array !> Calls the appropriate subroutine to calculate density second derivatives for scalar nputs. -subroutine calculate_density_second_derivs_scalar(T, S, pressure, drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, drho_dT_dP, & - EOS) - real, intent(in) :: T !< Potential temperature referenced to the surface (degC) - real, intent(in) :: S !< Salinity (PSU) - real, intent(in) :: pressure !< Pressure (Pa) - real, intent(out) :: drho_dS_dS !< Partial derivative of beta with respect to S - real, intent(out) :: drho_dS_dT !< Partial derivative of beta with resepct to T - real, intent(out) :: drho_dT_dT !< Partial derivative of alpha with respect to T - real, intent(out) :: drho_dS_dP !< Partial derivative of beta with respect to pressure - real, intent(out) :: drho_dT_dP !< Partial derivative of alpha with respect to pressure +subroutine calculate_density_second_derivs_scalar(T, S, pressure, drho_dS_dS, drho_dS_dT, drho_dT_dT, & + drho_dS_dP, drho_dT_dP, EOS) + real, intent(in) :: T !< Potential temperature referenced to the surface [degC] + real, intent(in) :: S !< Salinity [ppt] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: drho_dS_dS !< Partial derivative of beta with respect + !! to S [kg m-3 ppt-2] + real, intent(out) :: drho_dS_dT !< Partial derivative of beta with respcct + !! to T [kg m-3 ppt-1 degC-1] + real, intent(out) :: drho_dT_dT !< Partial derivative of alpha with respect + !! to T [kg m-3 degC-2] + real, intent(out) :: drho_dS_dP !< Partial derivative of beta with respect + !! to pressure [kg m-3 ppt-1 Pa-1] + real, intent(out) :: drho_dT_dP !< Partial derivative of alpha with respect + !! to pressure [kg m-3 degC-1 Pa-1] type(EOS_type), pointer :: EOS !< Equation of state structure - !! + if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_derivs called with an unassociated EOS_type EOS.") select case (EOS%form_of_EOS) case (EOS_LINEAR) - call calculate_density_second_derivs_linear(T, S, pressure, drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, & - drho_dT_dP) + call calculate_density_second_derivs_linear(T, S, pressure, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP) case (EOS_WRIGHT) - call calculate_density_second_derivs_wright(T, S, pressure, drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, & - drho_dT_dP) + call calculate_density_second_derivs_wright(T, S, pressure, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP) case (EOS_TEOS10) - call calculate_density_second_derivs_teos10(T, S, pressure, drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, & - drho_dT_dP) + call calculate_density_second_derivs_teos10(T, S, pressure, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP) case default call MOM_error(FATAL, & "calculate_density_derivs: EOS%form_of_EOS is not valid.") @@ -451,11 +476,13 @@ end subroutine calculate_density_second_derivs_scalar !> Calls the appropriate subroutine to calculate specific volume derivatives for an array. subroutine calculate_specific_vol_derivs(T, S, pressure, dSV_dT, dSV_dS, start, npts, EOS) - real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface (degC) - real, dimension(:), intent(in) :: S !< Salinity (PSU) - real, dimension(:), intent(in) :: pressure !< Pressure (Pa) - real, dimension(:), intent(out) :: dSV_dT !< The partial derivative of specific volume with potential temperature, in m3 kg-1 K-1. - real, dimension(:), intent(out) :: dSV_dS !< The partial derivative of specific volume with salinity, in m3 kg-1 / (g/kg). + real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [ppt] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: dSV_dT !< The partial derivative of specific volume with potential + !! temperature [m3 kg-1 degC-1]. + real, dimension(:), intent(out) :: dSV_dS !< The partial derivative of specific volume with salinity + !! [m3 kg-1 ppt-1]. integer, intent(in) :: start !< Starting index within the array integer, intent(in) :: npts !< The number of values to calculate type(EOS_type), pointer :: EOS !< Equation of state structure @@ -497,10 +524,10 @@ end subroutine calculate_specific_vol_derivs !> Calls the appropriate subroutine to calculate the density and compressibility for 1-D array inputs. subroutine calculate_compress(T, S, pressure, rho, drho_dp, start, npts, EOS) - real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface (degC) - real, dimension(:), intent(in) :: S !< Salinity (PSU) - real, dimension(:), intent(in) :: pressure !< Pressure (Pa) - real, dimension(:), intent(out) :: rho !< In situ density in kg m-3. + real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [ppt] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: rho !< In situ density [kg m-3]. real, dimension(:), intent(out) :: drho_dp !< The partial derivative of density with pressure !! (also the inverse of the square of sound speed) in s2 m-2. integer, intent(in) :: start !< Starting index within the array @@ -538,39 +565,40 @@ end subroutine calculate_compress subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & dza, intp_dza, intx_dza, inty_dza, halo_size, & bathyP, dP_tiny, useMassWghtInterp) - !> The horizontal index structure - type(hor_index_type), intent(in) :: HI - !> Potential temperature referenced to the surface (degC) - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), intent(in) :: T - !> Salinity (PSU) - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), intent(in) :: S - !> Pressure at the top of the layer in Pa. - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), intent(in) :: p_t - !> Pressure at the bottom of the layer in Pa. - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), intent(in) :: p_b - !> A mean specific volume that is subtracted out to reduce the magnitude of - !! each of the integrals, m3 kg-1. The calculation is mathematically identical - !! with different values of alpha_ref, but this reduces the effects of roundoff. - real, intent(in) :: alpha_ref - !> Equation of state structure - type(EOS_type), pointer :: EOS - !> The change in the geopotential anomaly across the layer, in m2 s-2. - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), intent(out) :: dza - !> The integral in pressure through the layer of the geopotential anomaly - !! relative to the anomaly at the bottom of the layer, in Pa m2 s-2. - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), optional, intent(out) :: intp_dza - !> The integral in x of the difference between the geopotential anomaly at the - !! top and bottom of the layer divided by the x grid spacing, in m2 s-2. - real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), optional, intent(out) :: intx_dza - !> The integral in y of the difference between the geopotential anomaly at the - !! top and bottom of the layer divided by the y grid spacing, in m2 s-2. - real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), optional, intent(out) :: inty_dza - !> The width of halo points on which to calculate dza. - integer, optional, intent(in) :: halo_size + type(hor_index_type), intent(in) :: HI !< The horizontal index structure + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: T !< Potential temperature referenced to the surface [degC] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: S !< Salinity [ppt] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: p_t !< Pressure at the top of the layer [Pa]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: p_b !< Pressure at the bottom of the layer [Pa]. + real, intent(in) :: alpha_ref !< A mean specific volume that is subtracted out + !! to reduce the magnitude of each of the integrals, m3 kg-1. The + !! calculation is mathematically identical with different values of + !! alpha_ref, but this reduces the effects of roundoff. + type(EOS_type), pointer :: EOS !< Equation of state structure + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(out) :: dza !< The change in the geopotential anomaly across + !! the layer [m2 s-2]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(out) :: intp_dza !< The integral in pressure through the layer of the + !! geopotential anomaly relative to the anomaly at the bottom of the + !! layer [Pa m2 s-2]. + real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & + optional, intent(out) :: intx_dza !< The integral in x of the difference between the + !! geopotential anomaly at the top and bottom of the layer divided by + !! the x grid spacing [m2 s-2]. + real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & + optional, intent(out) :: inty_dza !< The integral in y of the difference between the + !! geopotential anomaly at the top and bottom of the layer divided by + !! the y grid spacing [m2 s-2]. + integer, optional, intent(in) :: halo_size !< The width of halo points on which to calculate dza. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - optional, intent(in) :: bathyP !< The pressure at the bathymetry in Pa + optional, intent(in) :: bathyP !< The pressure at the bathymetry [Pa] real, optional, intent(in) :: dP_tiny !< A miniscule pressure change with - !! the same units as p_t (Pa?) + !! the same units as p_t (Pa?) logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting !! to interpolate T/S for top and bottom integrals. @@ -605,45 +633,41 @@ end subroutine int_specific_vol_dp subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, EOS, & dpa, intz_dpa, intx_dpa, inty_dpa, & bathyT, dz_neglect, useMassWghtInterp) - !> Ocean horizontal index structures for the input arrays - type(hor_index_type), intent(in) :: HII - !> Ocean horizontal index structures for the output arrays - type(hor_index_type), intent(in) :: HIO - !> Potential temperature referenced to the surface (degC) - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), intent(in) :: T - !> Salinity (PSU) - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), intent(in) :: S - !> Height at the top of the layer in m. - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), intent(in) :: z_t - !> Height at the bottom of the layer in m. - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), intent(in) :: z_b - !> A mean density, in kg m-3, that is subtracted out to reduce the magnitude - !! of each of the integrals. (The pressure is calculated as p~=-z*rho_0*G_e.) - real, intent(in) :: rho_ref - !> A density, in kg m-3, that is used to calculate the pressure - !! (as p~=-z*rho_0*G_e) used in the equation of state. - real, intent(in) :: rho_0 - !> The Earth's gravitational acceleration, in m s-2. - real, intent(in) :: G_e - !> Equation of state structure - type(EOS_type), pointer :: EOS - !> The change in the pressure anomaly across the layer, in Pa. - real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), intent(out) :: dpa - !> The integral through the thickness of the layer of the pressure anomaly - !! relative to the anomaly at the top of the layer, in Pa m. - real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), optional, intent(out) :: intz_dpa - !> The integral in x of the difference between the pressure anomaly at the - !! top and bottom of the layer divided by the x grid spacing, in Pa. - real, dimension(HIO%IsdB:HIO%IedB,HIO%jsd:HIO%jed), optional, intent(out) :: intx_dpa - !> The integral in y of the difference between the pressure anomaly at the - !! top and bottom of the layer divided by the y grid spacing, in Pa. - real, dimension(HIO%isd:HIO%ied,HIO%JsdB:HIO%JedB), optional, intent(out) :: inty_dpa + type(hor_index_type), intent(in) :: HII !< Ocean horizontal index structures for the input arrays + type(hor_index_type), intent(in) :: HIO !< Ocean horizontal index structures for the output arrays + real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + intent(in) :: T !< Potential temperature referenced to the surface [degC] real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - optional, intent(in) :: bathyT !< The depth of the bathymetry in m - real, optional, intent(in) :: dz_neglect !< A miniscule thickness change with the - !! same units as z_t + intent(in) :: S !< Salinity [ppt] + real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m]. + real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + intent(in) :: z_b !< Height at the bottom of the layer [Z ~> m]. + real, intent(in) :: rho_ref !< A mean density [kg m-3], that is subtracted out to + !! reduce the magnitude of each of the integrals. + real, intent(in) :: rho_0 !< A density [kg m-3], that is used to calculate the + !! pressure (as p~=-z*rho_0*G_e) used in the equation of state. + real, intent(in) :: G_e !< The Earth's gravitational acceleration [m2 Z-1 s-2 ~> m s-2]. + type(EOS_type), pointer :: EOS !< Equation of state structure + real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & + intent(out) :: dpa !< The change in the pressure anomaly across the layer [Pa]. + real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & + optional, intent(out) :: intz_dpa !< The integral through the thickness of the layer of + !! the pressure anomaly relative to the anomaly at the + !! top of the layer [Pa Z ~> Pa m]. + real, dimension(HIO%IsdB:HIO%IedB,HIO%jsd:HIO%jed), & + optional, intent(out) :: intx_dpa !< The integral in x of the difference between the + !! pressure anomaly at the top and bottom of the layer + !! divided by the x grid spacing [Pa]. + real, dimension(HIO%isd:HIO%ied,HIO%JsdB:HIO%JedB), & + optional, intent(out) :: inty_dpa !< The integral in y of the difference between the + !! pressure anomaly at the top and bottom of the layer + !! divided by the y grid spacing [Pa]. + real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m]. + real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m]. logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to - !! interpolate T/S for top and bottom integrals. + !! interpolate T/S for top and bottom integrals. if (.not.associated(EOS)) call MOM_error(FATAL, & "int_density_dz called with an unassociated EOS_type EOS.") @@ -771,7 +795,8 @@ subroutine EOS_init(param_file, EOS) units="deg C Pa-1", default=0.0) endif - if ((EOS%form_of_EOS == EOS_TEOS10 .OR. EOS%form_of_EOS == EOS_NEMO) .AND. EOS%form_of_TFreeze /= TFREEZE_TEOS10) then + if ((EOS%form_of_EOS == EOS_TEOS10 .OR. EOS%form_of_EOS == EOS_NEMO) .AND. & + EOS%form_of_TFreeze /= TFREEZE_TEOS10) then call MOM_error(FATAL, "interpret_eos_selection: EOS_TEOS10 or EOS_NEMO \n" //& "should only be used along with TFREEZE_FORM = TFREEZE_TEOS10 .") endif @@ -780,19 +805,25 @@ subroutine EOS_init(param_file, EOS) end subroutine EOS_init !> Manually initialized an EOS type (intended for unit testing of routines which need a specific EOS) -subroutine EOS_manual_init(EOS, form_of_EOS, form_of_TFreeze, EOS_quadrature, Compressible, Rho_T0_S0, drho_dT, & - dRho_dS, TFr_S0_P0, dTFr_dS, dTFr_dp) - type(EOS_type), pointer :: EOS - integer, optional, intent(in ) :: form_of_EOS - integer, optional, intent(in ) :: form_of_TFreeze - logical, optional, intent(in ) :: EOS_quadrature - logical, optional, intent(in ) :: Compressible - real , optional, intent(in ) :: Rho_T0_S0 - real , optional, intent(in ) :: drho_dT - real , optional, intent(in ) :: dRho_dS - real , optional, intent(in ) :: TFr_S0_P0 - real , optional, intent(in ) :: dTFr_dS - real , optional, intent(in ) :: dTFr_dp +subroutine EOS_manual_init(EOS, form_of_EOS, form_of_TFreeze, EOS_quadrature, Compressible, & + Rho_T0_S0, drho_dT, dRho_dS, TFr_S0_P0, dTFr_dS, dTFr_dp) + type(EOS_type), pointer :: EOS !< Equation of state structure + integer, optional, intent(in) :: form_of_EOS !< A coded integer indicating the equation of state to use. + integer, optional, intent(in) :: form_of_TFreeze !< A coded integer indicating the expression for + !! the potential temperature of the freezing point. + logical, optional, intent(in) :: EOS_quadrature !< If true, always use the generic (quadrature) + !! code for the integrals of density. + logical, optional, intent(in) :: Compressible !< If true, in situ density is a function of pressure. + real , optional, intent(in) :: Rho_T0_S0 !< Density at T=0 degC and S=0 ppt [kg m-3] + real , optional, intent(in) :: drho_dT !< Partial derivative of density with temperature + !! in [kg m-3 degC-1] + real , optional, intent(in) :: dRho_dS !< Partial derivative of density with salinity + !! in [kg m-3 ppt-1] + real , optional, intent(in) :: TFr_S0_P0 !< The freezing potential temperature at S=0, P=0 [degC]. + real , optional, intent(in) :: dTFr_dS !< The derivative of freezing point with salinity + !! in [degC ppt-1]. + real , optional, intent(in) :: dTFr_dp !< The derivative of freezing point with pressure + !! in [degC Pa-1]. if (present(form_of_EOS )) EOS%form_of_EOS = form_of_EOS if (present(form_of_TFreeze)) EOS%form_of_TFreeze = form_of_TFreeze @@ -827,10 +858,11 @@ end subroutine EOS_end !! EOS_type (EOS argument) to be set to use the linear equation of state !! independent from the rest of the model. subroutine EOS_use_linear(Rho_T0_S0, dRho_dT, dRho_dS, EOS, use_quadrature) - real, intent(in) :: Rho_T0_S0 !< Density at T=0 degC and S=0 ppt (kg m-3) - real, intent(in) :: dRho_dT !< Partial derivative of density with temperature (kg m-3 degC-1) - real, intent(in) :: dRho_dS !< Partial derivative of density with salinity (kg m-3 ppt-1) - logical, optional, intent(in) :: use_quadrature !< Partial derivative of density with salinity (kg m-3 ppt-1) + real, intent(in) :: Rho_T0_S0 !< Density at T=0 degC and S=0 ppt [kg m-3] + real, intent(in) :: dRho_dT !< Partial derivative of density with temperature [kg m-3 degC-1] + real, intent(in) :: dRho_dS !< Partial derivative of density with salinity [kg m-3 ppt-1] + logical, optional, intent(in) :: use_quadrature !< If true, always use the generic (quadrature) + !! code for the integrals of density. type(EOS_type), pointer :: EOS !< Equation of state structure if (.not.associated(EOS)) call MOM_error(FATAL, & @@ -855,57 +887,56 @@ subroutine int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, type(hor_index_type), intent(in) :: HII !< Horizontal index type for input variables. type(hor_index_type), intent(in) :: HIO !< Horizontal index type for output variables. real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: T !< Potential temperature of the layer in C. + intent(in) :: T !< Potential temperature of the layer [degC]. real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: S !< Salinity of the layer in PSU. + intent(in) :: S !< Salinity of the layer [ppt]. real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: z_t !< Height at the top of the layer in m. + intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m]. real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: z_b !< Height at the bottom of the layer in m. - real, intent(in) :: rho_ref !< A mean density, in kg m-3, that is + intent(in) :: z_b !< Height at the bottom of the layer [Z ~> m]. + real, intent(in) :: rho_ref !< A mean density [kg m-3], that is !! subtracted out to reduce the magnitude !! of each of the integrals. - real, intent(in) :: rho_0 !< A density, in kg m-3, that is used + real, intent(in) :: rho_0 !< A density [kg m-3], that is used !! to calculate the pressure (as p~=-z*rho_0*G_e) !! used in the equation of state. - real, intent(in) :: G_e !< The Earth's gravitational acceleration, in m s-2. + real, intent(in) :: G_e !< The Earth's gravitational acceleration [m2 Z-1 s-2 ~> m s-2]. type(EOS_type), pointer :: EOS !< Equation of state structure real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & intent(out) :: dpa !< The change in the pressure anomaly - !! across the layer, in Pa. + !! across the layer [Pa]. real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & optional, intent(out) :: intz_dpa !< The integral through the thickness of the !! layer of the pressure anomaly relative to the - !! anomaly at the top of the layer, in Pa m. + !! anomaly at the top of the layer [Pa Z ~> Pa m]. real, dimension(HIO%IsdB:HIO%IedB,HIO%jsd:HIO%jed), & optional, intent(out) :: intx_dpa !< The integral in x of the difference between !! the pressure anomaly at the top and bottom of the - !! layer divided by the x grid spacing, in Pa. + !! layer divided by the x grid spacing [Pa]. real, dimension(HIO%isd:HIO%ied,HIO%JsdB:HIO%JedB), & optional, intent(out) :: inty_dpa !< The integral in y of the difference between !! the pressure anomaly at the top and bottom of the - !! layer divided by the y grid spacing, in Pa. + !! layer divided by the y grid spacing [Pa]. real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - optional, intent(in) :: bathyT !< The depth of the bathymetry in m - real, optional, intent(in) :: dz_neglect !< A miniscule thickness change with the - !! same units as z_t + optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m]. + real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m]. logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to !! interpolate T/S for top and bottom integrals. real :: T5(5), S5(5), p5(5), r5(5) - real :: rho_anom ! The depth averaged density anomaly in kg m-3. + real :: rho_anom ! The depth averaged density anomaly [kg m-3]. real :: w_left, w_right real, parameter :: C1_90 = 1.0/90.0 ! Rational constants. real :: GxRho, I_Rho - real :: dz ! The layer thickness, in m. - real :: hWght ! A pressure-thickness below topography, in m. - real :: hL, hR ! Pressure-thicknesses of the columns to the left and right, in m. - real :: iDenom ! The inverse of the denominator in the wieghts, in m-2. - real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column, nonDim. - real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column, nonDim. - real :: wt_L, wt_R ! The linear wieghts of the left and right columns, nonDim. - real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns, nonDim. - real :: intz(5) ! The integrals of density with height at the - ! 5 sub-column locations, in m2 s-2. + real :: dz ! The layer thickness [Z ~> m]. + real :: hWght ! A pressure-thickness below topography [Z ~> m]. + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [Z ~> m]. + real :: iDenom ! The inverse of the denominator in the weights [Z-2 ~> m-2]. + real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column [nondim]. + real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column [nondim]. + real :: wt_L, wt_R ! The linear weights of the left and right columns [nondim]. + real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim]. + real :: intz(5) ! The gravitational acceleration times the integrals of density + ! with height at the 5 sub-column locations [Pa]. logical :: do_massWeight ! Indicates whether to do mass weighting. integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, m, n, ioff, joff @@ -1036,35 +1067,50 @@ end subroutine int_density_dz_generic ! ========================================================================== !> Compute pressure gradient force integrals by quadrature for the case where !! T and S are linear profiles. -! ========================================================================== subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & rho_0, G_e, dz_subroundoff, bathyT, HII, HIO, EOS, dpa, & intz_dpa, intx_dpa, inty_dpa, & useMassWghtInterp) - type(hor_index_type), intent(in) :: HII, HIO + type(hor_index_type), intent(in) :: HII !< Ocean horizontal index structures for the input arrays + type(hor_index_type), intent(in) :: HIO !< Ocean horizontal index structures for the output arrays + real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + intent(in) :: T_t !< Potential temperatue at the cell top [degC] + real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + intent(in) :: T_b !< Potential temperatue at the cell bottom [degC] real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: T_t, T_b, S_t, S_b + intent(in) :: S_t !< Salinity at the cell top [ppt] real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: z_t !< The geometric height at the top - !! of the layer, usually in m + intent(in) :: S_b !< Salinity at the cell bottom [ppt] real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: z_b !< The geometric height at the bpttom - !! of the layer, usually in m - real, intent(in) :: rho_ref, rho_0, G_e - real, intent(in) :: dz_subroundoff !< A miniscule thickness - !! change with the same units as z_t + intent(in) :: z_t !< The geometric height at the top of the layer, + !! in depth units [Z ~> m]. real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: bathyT !< The depth of the bathymetry in m - type(EOS_type), pointer :: EOS !< Equation of state structure + intent(in) :: z_b !< The geometric height at the bottom of the layer [Z ~> m]. + real, intent(in) :: rho_ref !< A mean density [kg m-3], that is subtracted out to + !! reduce the magnitude of each of the integrals. + real, intent(in) :: rho_0 !< A density [kg m-3], that is used to calculate the + !! pressure (as p~=-z*rho_0*G_e) used in the equation of state. + real, intent(in) :: G_e !< The Earth's gravitational acceleration [m2 Z-1 s-2 ~> m s-2]. + real, intent(in) :: dz_subroundoff !< A miniscule thickness change [Z ~> m]. + real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m]. + type(EOS_type), pointer :: EOS !< Equation of state structure real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & - intent(out) :: dpa + intent(out) :: dpa !< The change in the pressure anomaly across the layer [Pa]. real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & - optional, intent(out) :: intz_dpa + optional, intent(out) :: intz_dpa !< The integral through the thickness of the layer of + !! the pressure anomaly relative to the anomaly at the + !! top of the layer [Pa Z]. real, dimension(HIO%IsdB:HIO%IedB,HIO%jsd:HIO%jed), & - optional, intent(out) :: intx_dpa + optional, intent(out) :: intx_dpa !< The integral in x of the difference between the + !! pressure anomaly at the top and bottom of the layer + !! divided by the x grid spacing [Pa]. real, dimension(HIO%isd:HIO%ied,HIO%JsdB:HIO%JedB), & - optional, intent(out) :: inty_dpa - logical, optional, intent(in) :: useMassWghtInterp + optional, intent(out) :: inty_dpa !< The integral in y of the difference between the + !! pressure anomaly at the top and bottom of the layer + !! divided by the y grid spacing [Pa]. + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to + !! interpolate T/S for top and bottom integrals. ! This subroutine calculates (by numerical quadrature) integrals of ! pressure anomalies across layers, which are required for calculating the ! finite-volume form pressure accelerations in a Boussinesq model. The one @@ -1075,53 +1121,34 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & ! It is assumed that the salinity and temperature profiles are linear in the ! vertical. The top and bottom values within each layer are provided and ! a linear interpolation is used to compute intermediate values. -! -! Arguments: T - potential temperature relative to the surface in C -! (the 't' and 'b' subscripts refer to the values at -! the top and the bottom of each layer) -! (in) S - salinity in PSU. -! (the 't' and 'b' subscripts refer to the values at -! the top and the bottom of each layer) -! (in) z_t - height at the top of the layer in m. -! (in) z_b - height at the top of the layer in m. -! (in) rho_ref - A mean density, in kg m-3, that is subtracted out to reduce -! the magnitude of each of the integrals. -! (The pressure is calucated as p~=-z*rho_0*G_e.) -! (in) rho_0 - A density, in kg m-3, that is used to calculate the pressure -! (as p~=-z*rho_0*G_e) used in the equation of state. -! (in) G_e - The Earth's gravitational acceleration, in m s-2. -! (in) G - The ocean's grid structure. -! (in) form_of_eos - integer that selects the eqn of state. -! (out) dpa - The change in the pressure anomaly across the layer, -! in Pa. -! (out,opt) intz_dpa - The integral through the thickness of the layer of the -! pressure anomaly relative to the anomaly at the top of -! the layer, in Pa m. -! (out,opt) intx_dpa - The integral in x of the difference between the -! pressure anomaly at the top and bottom of the layer -! divided by the x grid spacing, in Pa. -! (out,opt) inty_dpa - The integral in y of the difference between the -! pressure anomaly at the top and bottom of the layer -! divided by the y grid spacing, in Pa. -! (in,opt) useMassWghtInterp - If true, uses mass weighting to interpolate -! T/S for top and bottom integrals. - - real :: T5((5*HIO%iscB+1):(5*(HIO%iecB+2))) - real :: S5((5*HIO%iscB+1):(5*(HIO%iecB+2))) - real :: p5((5*HIO%iscB+1):(5*(HIO%iecB+2))) - real :: r5((5*HIO%iscB+1):(5*(HIO%iecB+2))) - real :: T15((15*HIO%iscB+1):(15*(HIO%iecB+1))) - real :: S15((15*HIO%iscB+1):(15*(HIO%iecB+1))) - real :: p15((15*HIO%iscB+1):(15*(HIO%iecB+1))) - real :: r15((15*HIO%iscB+1):(15*(HIO%iecB+1))) - real :: wt_t(5), wt_b(5) - real :: rho_anom - real :: w_left, w_right, intz(5) - real, parameter :: C1_90 = 1.0/90.0 ! Rational constants. - real :: GxRho, I_Rho - real :: dz(HIO%iscB:HIO%iecB+1), dz_x(5,HIO%iscB:HIO%iecB), dz_y(5,HIO%isc:HIO%iec) - real :: weight_t, weight_b, hWght, massWeightToggle - real :: Ttl, Tbl, Ttr, Tbr, Stl, Sbl, Str, Sbr, hL, hR, iDenom + + ! Local variables + real :: T5((5*HIO%iscB+1):(5*(HIO%iecB+2))) ! Temperatures along a line of subgrid locations [degC]. + real :: S5((5*HIO%iscB+1):(5*(HIO%iecB+2))) ! Salinities along a line of subgrid locations [ppt]. + real :: p5((5*HIO%iscB+1):(5*(HIO%iecB+2))) ! Pressures along a line of subgrid locations [Pa]. + real :: r5((5*HIO%iscB+1):(5*(HIO%iecB+2))) ! Densities along a line of subgrid locations [kg m-3]. + real :: T15((15*HIO%iscB+1):(15*(HIO%iecB+1))) ! Temperatures at an array of subgrid locations [degC]. + real :: S15((15*HIO%iscB+1):(15*(HIO%iecB+1))) ! Salinities at an array of subgrid locations [ppt]. + real :: p15((15*HIO%iscB+1):(15*(HIO%iecB+1))) ! Pressures at an array of subgrid locations [Pa]. + real :: r15((15*HIO%iscB+1):(15*(HIO%iecB+1))) ! Densities at an array of subgrid locations [kg m-3]. + real :: wt_t(5), wt_b(5) ! Top and bottom weights [nondim]. + real :: rho_anom ! A density anomaly [kg m-3]. + real :: w_left, w_right ! Left and right weights [nondim]. + real :: intz(5) ! The gravitational acceleration times the integrals of density + ! with height at the 5 sub-column locations [Pa]. + real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim]. + real :: GxRho ! Gravitational acceleration times density [kg m-1 Z-1 s-2 ~> kg m-2 s-2]. + real :: I_Rho ! The inverse of the reference density [m3 kg-1]. + 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 :: 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]. + real :: hWght ! A topographically limited thicknes weight [Z ~> m]. + real :: hL, hR ! Thicknesses to the left and right [Z ~> m]. + real :: iDenom ! The denominator of the thickness weight expressions [Z-2 ~> m-2]. integer :: Isq, Ieq, Jsq, Jeq, i, j, m, n integer :: iin, jin, ioff, joff integer :: pos @@ -1342,20 +1369,21 @@ end subroutine int_density_dz_generic_plm !> Find the depth at which the reconstructed pressure matches P_tgt subroutine find_depth_of_pressure_in_cell(T_t, T_b, S_t, S_b, z_t, z_b, P_t, P_tgt, & - rho_ref, G_e, EOS, P_b, z_out) - real, intent(in) :: T_t !< Potential temperatue at the cell top (degC) - real, intent(in) :: T_b !< Potential temperatue at the cell bottom (degC) - real, intent(in) :: S_t !< Salinity at the cell top (ppt) - real, intent(in) :: S_b !< Salinity at the cell bottom (ppt) - real, intent(in) :: z_t !< Absolute height of top of cell (m) (Boussinesq ????) - real, intent(in) :: z_b !< Absolute height of bottom of cell (m) - real, intent(in) :: P_t !< Anomalous pressure of top of cell, relative to g*rho_ref*z_t (Pa) - real, intent(in) :: P_tgt !< Target pressure at height z_out, relative to g*rho_ref*z_out (Pa) + rho_ref, G_e, EOS, P_b, z_out, z_tol) + real, intent(in) :: T_t !< Potential temperatue at the cell top [degC] + real, intent(in) :: T_b !< Potential temperatue at the cell bottom [degC] + real, intent(in) :: S_t !< Salinity at the cell top [ppt] + real, intent(in) :: S_b !< Salinity at the cell bottom [ppt] + real, intent(in) :: z_t !< Absolute height of top of cell [Z ~> m]. (Boussinesq ????) + real, intent(in) :: z_b !< Absolute height of bottom of cell [Z ~> m]. + real, intent(in) :: P_t !< Anomalous pressure of top of cell, relative to g*rho_ref*z_t [Pa] + real, intent(in) :: P_tgt !< Target pressure at height z_out, relative to g*rho_ref*z_out [Pa] real, intent(in) :: rho_ref !< Reference density with which calculation are anomalous to - real, intent(in) :: G_e !< Gravitational acceleration (m/s2) + real, intent(in) :: G_e !< Gravitational acceleration [m2 Z-1 s-2 ~> m s-2] type(EOS_type), pointer :: EOS !< Equation of state structure - real, intent(out) :: P_b !< Pressure at the bottom of the cell (Pa) - real, intent(out) :: z_out !< Absolute depth at which anomalous pressure = p_tgt (m) + real, intent(out) :: P_b !< Pressure at the bottom of the cell [Pa] + real, intent(out) :: z_out !< Absolute depth at which anomalous pressure = p_tgt [Z ~> m]. + real, optional, intent(in) :: z_tol !< The tolerance in finding z_out [Z ~> m]. ! Local variables real :: top_weight, bottom_weight, rho_anom, w_left, w_right, GxRho, dz, dp, F_guess, F_l, F_r real :: Pa, Pa_left, Pa_right, Pa_tol ! Pressure anomalies, P = integral of g*(rho-rho_ref) dz @@ -1381,7 +1409,8 @@ subroutine find_depth_of_pressure_in_cell(T_t, T_b, S_t, S_b, z_t, z_b, P_t, P_t Pa_left = P_t - P_tgt ! Pa_left < 0 F_r = 1. Pa_right = P_b - P_tgt ! Pa_right > 0 - Pa_tol = GxRho * 1.e-5 + Pa_tol = GxRho * 1.e-5 ! 1e-5 has dimensions of m, but should be converted to the units of z. + if (present(z_tol)) Pa_tol = GxRho * z_tol F_guess = F_l - Pa_left / ( Pa_right -Pa_left ) * ( F_r - F_l ) Pa = Pa_right - Pa_left ! To get into iterative loop do while ( abs(Pa) > Pa_tol ) @@ -1413,8 +1442,17 @@ end subroutine find_depth_of_pressure_in_cell !> Returns change in anomalous pressure change from top to non-dimensional !! position pos between z_t and z_b real function frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, pos, EOS) - real, intent(in) :: T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, pos - type(EOS_type), pointer :: EOS !< Equation of state structure + real, intent(in) :: T_t !< Potential temperatue at the cell top [degC] + real, intent(in) :: T_b !< Potential temperatue at the cell bottom [degC] + real, intent(in) :: S_t !< Salinity at the cell top [ppt] + real, intent(in) :: S_b !< Salinity at the cell bottom [ppt] + real, intent(in) :: z_t !< The geometric height at the top of the layer [Z ~> m] + real, intent(in) :: z_b !< The geometric height at the bottom of the layer [Z ~> m] + real, intent(in) :: rho_ref !< A mean density [kg m-3], that is subtracted out to + !! reduce the magnitude of each of the integrals. + real, intent(in) :: G_e !< The Earth's gravitational acceleration [m s-2] + real, intent(in) :: pos !< The fractional vertical position, 0 to 1 [nondim]. + type(EOS_type), pointer :: EOS !< Equation of state structure ! Local variables real, parameter :: C1_90 = 1.0/90.0 ! Rational constants. real :: dz, top_weight, bottom_weight, rho_ave @@ -1442,26 +1480,51 @@ end function frac_dp_at_pos ! ========================================================================== -! Compute pressure gradient force integrals for the case where T and S -! are parabolic profiles -! ========================================================================== +!> Compute pressure gradient force integrals for the case where T and S +!! are parabolic profiles subroutine int_density_dz_generic_ppm (T, T_t, T_b, S, S_t, S_b, & z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, & EOS, dpa, intz_dpa, intx_dpa, inty_dpa) - type(hor_index_type), intent(in) :: HII, HIO + type(hor_index_type), intent(in) :: HII !< Ocean horizontal index structures for the input arrays + type(hor_index_type), intent(in) :: HIO !< Ocean horizontal index structures for the output arrays + real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + intent(in) :: T !< Potential temperature referenced to the surface [degC] + real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + intent(in) :: T_t !< Potential temperatue at the cell top [degC] + real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + intent(in) :: T_b !< Potential temperatue at the cell bottom [degC] + real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + intent(in) :: S !< Salinity [ppt] + real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + intent(in) :: S_t !< Salinity at the cell top [ppt] + real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + intent(in) :: S_b !< Salinity at the cell bottom [ppt] + real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + intent(in) :: z_t !< Height at the top of the layer [Z ~> m]. real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: T, T_t, T_b, S, S_t, S_b, z_t, z_b - real, intent(in) :: rho_ref, rho_0, G_e + intent(in) :: z_b !< Height at the bottom of the layer [Z ~> m]. + real, intent(in) :: rho_ref !< A mean density [kg m-3], that is subtracted out to + !! reduce the magnitude of each of the integrals. + real, intent(in) :: rho_0 !< A density [kg m-3], that is used to calculate the + !! pressure (as p~=-z*rho_0*G_e) used in the equation of state. + real, intent(in) :: G_e !< The Earth's gravitational acceleration [m s-2] type(EOS_type), pointer :: EOS !< Equation of state structure real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & - intent(out) :: dpa + intent(out) :: dpa !< The change in the pressure anomaly across the layer [Pa]. real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & - optional, intent(out) :: intz_dpa - real, dimension(HIO%IsdB:HIO%IedB,HIO%JsdB:HIO%JedB), & - optional, intent(out) :: intx_dpa + optional, intent(out) :: intz_dpa !< The integral through the thickness of the layer of + !! the pressure anomaly relative to the anomaly at the + !! top of the layer [Pa Z ~> Pa m]. + real, dimension(HIO%IsdB:HIO%IedB,HIO%jsd:HIO%jed), & + optional, intent(out) :: intx_dpa !< The integral in x of the difference between the + !! pressure anomaly at the top and bottom of the layer + !! divided by the x grid spacing [Pa]. real, dimension(HIO%isd:HIO%ied,HIO%JsdB:HIO%JedB), & - optional, intent(out) :: inty_dpa + optional, intent(out) :: inty_dpa !< The integral in y of the difference between the + !! pressure anomaly at the top and bottom of the layer + !! divided by the y grid spacing [Pa]. + ! This subroutine calculates (by numerical quadrature) integrals of ! pressure anomalies across layers, which are required for calculating the ! finite-volume form pressure accelerations in a Boussinesq model. The one @@ -1472,35 +1535,8 @@ subroutine int_density_dz_generic_ppm (T, T_t, T_b, S, S_t, S_b, & ! It is assumed that the salinity and temperature profiles are linear in the ! vertical. The top and bottom values within each layer are provided and ! a linear interpolation is used to compute intermediate values. -! -! Arguments: T - potential temperature relative to the surface in C -! (the 't' and 'b' subscripts refer to the values at -! the top and the bottom of each layer) -! (in) S - salinity in PSU. -! (the 't' and 'b' subscripts refer to the values at -! the top and the bottom of each layer) -! (in) z_t - height at the top of the layer in m. -! (in) z_b - height at the top of the layer in m. -! (in) rho_ref - A mean density, in kg m-3, that is subtracted out to reduce -! the magnitude of each of the integrals. -! (The pressure is calucated as p~=-z*rho_0*G_e.) -! (in) rho_0 - A density, in kg m-3, that is used to calculate the pressure -! (as p~=-z*rho_0*G_e) used in the equation of state. -! (in) G_e - The Earth's gravitational acceleration, in m s-2. -! (in) G - The ocean's grid structure. -! (in) form_of_eos - integer that selects the eqn of state. -! (out) dpa - The change in the pressure anomaly across the layer, -! in Pa. -! (out,opt) intz_dpa - The integral through the thickness of the layer of the -! pressure anomaly relative to the anomaly at the top of -! the layer, in Pa m. -! (out,opt) intx_dpa - The integral in x of the difference between the -! pressure anomaly at the top and bottom of the layer -! divided by the x grid spacing, in Pa. -! (out,opt) inty_dpa - The integral in y of the difference between the -! pressure anomaly at the top and bottom of the layer -! divided by the y grid spacing, in Pa. + ! Local variables real :: T5(5), S5(5), p5(5), r5(5) real :: rho_anom real :: w_left, w_right, intz(5) @@ -1508,8 +1544,8 @@ subroutine int_density_dz_generic_ppm (T, T_t, T_b, S, S_t, S_b, & real :: GxRho, I_Rho real :: dz real :: weight_t, weight_b - real :: s0, s1, s2 ! parabola coefficients for S - real :: t0, t1, t2 ! parabola coefficients for T + real :: s0, s1, s2 ! parabola coefficients for S [ppt] + real :: t0, t1, t2 ! parabola coefficients for T [degC] real :: xi ! normalized coordinate real :: T_top, T_mid, T_bot real :: S_top, S_mid, S_bot @@ -1565,7 +1601,7 @@ subroutine int_density_dz_generic_ppm (T, T_t, T_b, S, S_t, S_b, & !rho_anom = C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) - & ! rho_ref - rho_anom = 1000.0 + S(i,j) - rho_ref; + rho_anom = 1000.0 + S(i,j) - rho_ref dpa(i-ioff,j-joff) = G_e*dz*rho_anom ! Use a Bode's-rule-like fifth-order accurate estimate of @@ -1670,10 +1706,10 @@ subroutine int_density_dz_generic_ppm (T, T_t, T_b, S, S_t, S_b, & S_node(9) = 0.5 * ( S_node(6) + S_node(8) ) S_node(7) = 0.5 * ( S_node(3) + S_node(4) ) - call calculate_density ( T_node, S_node, p_node, r_node, 1, 9, EOS ) + call calculate_density( T_node, S_node, p_node, r_node, 1, 9, EOS ) r_node = r_node - rho_ref - call compute_integral_quadratic ( x, y, r_node, intx_dpa(i-ioff,j-joff) ) + call compute_integral_quadratic( x, y, r_node, intx_dpa(i-ioff,j-joff) ) intx_dpa(i-ioff,j-joff) = intx_dpa(i-ioff,j-joff) * G_e @@ -1696,14 +1732,12 @@ end subroutine int_density_dz_generic_ppm ! ============================================================================= -! Compute integral of quadratic function -! ============================================================================= -subroutine compute_integral_quadratic ( x, y, f, integral ) - - ! Arguments - real, intent(in), dimension(4) :: x, y - real, intent(in), dimension(9) :: f - real, intent(out) :: integral +!> Compute the integral of the quadratic function +subroutine compute_integral_quadratic( x, y, f, integral ) + real, dimension(4), intent(in) :: x !< The x-position of the corners + real, dimension(4), intent(in) :: y !< The y-position of the corners + real, dimension(9), intent(in) :: f !< The function at the quadrature points + real, intent(out) :: integral !< The returned integral ! Local variables integer :: i, k @@ -1745,8 +1779,8 @@ subroutine compute_integral_quadratic ( x, y, f, integral ) do k = 1,9 ! Evaluate shape functions and gradients for isomorphism - call evaluate_shape_bilinear ( xi(k), eta(k), phiiso, & - dphiisodxi, dphiisodeta ) + call evaluate_shape_bilinear( xi(k), eta(k), phiiso, & + dphiisodxi, dphiisodeta ) ! Determine gradient of global coordinate at integration point dxdxi = 0.0 @@ -1765,7 +1799,7 @@ subroutine compute_integral_quadratic ( x, y, f, integral ) jacobian_k = dxdxi*dydeta - dydxi*dxdeta ! Evaluate shape functions for interpolation - call evaluate_shape_quadratic ( xi(k), eta(k), phi, dphidxi, dphideta ) + call evaluate_shape_quadratic( xi(k), eta(k), phi, dphidxi, dphideta ) ! Evaluate function at integration point f_k = 0.0 @@ -1781,16 +1815,17 @@ end subroutine compute_integral_quadratic ! ============================================================================= -! Evaluation of the four bilinear shape fn and their gradients at (xi,eta) -! ============================================================================= -subroutine evaluate_shape_bilinear ( xi, eta, phi, dphidxi, dphideta ) - - ! Arguments - real, intent(in) :: xi, eta - real, dimension(4), intent(out) :: phi, dphidxi, dphideta - - ! The shape functions within the parent element are defined as shown - ! here: +!> Evaluation of the four bilinear shape fn and their gradients at (xi,eta) +subroutine evaluate_shape_bilinear( xi, eta, phi, dphidxi, dphideta ) + real, intent(in) :: xi !< The x position to evaluate + real, intent(in) :: eta !< The z position to evaluate + real, dimension(4), intent(out) :: phi !< The weights of the four corners at this point + real, dimension(4), intent(out) :: dphidxi !< The x-gradient of the weights of the four + !! corners at this point + real, dimension(4), intent(out) :: dphideta !< The z-gradient of the weights of the four + !! corners at this point + + ! The shape functions within the parent element are defined as shown here: ! ! (-1,1) 2 o------------o 1 (1,1) ! | | @@ -1819,16 +1854,20 @@ end subroutine evaluate_shape_bilinear ! ============================================================================= -! Evaluation of the nine quadratic shape fn and their gradients at (xi,eta) -! ============================================================================= +!> Evaluation of the nine quadratic shape fn weights and their gradients at (xi,eta) subroutine evaluate_shape_quadratic ( xi, eta, phi, dphidxi, dphideta ) ! Arguments - real, intent(in) :: xi, eta - real, dimension(9), intent(out) :: phi, dphidxi, dphideta - - ! The quadratic shape functions within the parent element are - ! defined as shown here: + real, intent(in) :: xi !< The x position to evaluate + real, intent(in) :: eta !< The z position to evaluate + real, dimension(9), intent(out) :: phi !< The weights of the 9 bilinear quadrature points + !! at this point + real, dimension(9), intent(out) :: dphidxi !< The x-gradient of the weights of the 9 bilinear + !! quadrature points corners at this point + real, dimension(9), intent(out) :: dphideta !< The z-gradient of the weights of the 9 bilinear + !! quadrature points corners at this point + + ! The quadratic shape functions within the parent element are defined as shown here: ! ! 5 (0,1) ! (-1,1) 2 o------o------o 1 (1,1) @@ -1841,9 +1880,9 @@ subroutine evaluate_shape_quadratic ( xi, eta, phi, dphidxi, dphideta ) ! 7 (0,-1) ! - phi = 0.0 - dphidxi = 0.0 - dphideta = 0.0 + phi(:) = 0.0 + dphidxi(:) = 0.0 + dphideta(:) = 0.0 phi(1) = 0.25 * xi * ( 1 + xi ) * eta * ( 1 + eta ) phi(2) = - 0.25 * xi * ( 1 - xi ) * eta * ( 1 + eta ) @@ -1887,37 +1926,37 @@ subroutine int_spec_vol_dp_generic(T, S, p_t, p_b, alpha_ref, HI, EOS, & bathyP, dP_neglect, useMassWghtInterp) type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: T !< Potential temperature of the layer in C. + intent(in) :: T !< Potential temperature of the layer [degC]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: S !< Salinity of the layer in PSU. + intent(in) :: S !< Salinity of the layer [ppt]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_t !< Pressure atop the layer in Pa. + intent(in) :: p_t !< Pressure atop the layer [Pa]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_b !< Pressure below the layer in Pa. + intent(in) :: p_b !< Pressure below the layer [Pa]. real, intent(in) :: alpha_ref !< A mean specific volume that is !! subtracted out to reduce the magnitude of each of the - !! integrals, in m3 kg-1. The calculation is mathematically + !! integrals [m3 kg-1]. The calculation is mathematically !! identical with different values of alpha_ref, but alpha_ref !! alters the effects of roundoff, and answers do change. type(EOS_type), pointer :: EOS !< Equation of state structure real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(out) :: dza !< The change in the geopotential anomaly - !! across the layer, in m2 s-2. + !! across the layer [m2 s-2]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(out) :: intp_dza !< The integral in pressure through the !! layer of the geopotential anomaly relative to the anomaly - !! at the bottom of the layer, in Pa m2 s-2. + !! at the bottom of the layer [Pa m2 s-2]. real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & optional, intent(out) :: intx_dza !< The integral in x of the difference !! between the geopotential anomaly at the top and bottom of - !! the layer divided by the x grid spacing, in m2 s-2. + !! the layer divided by the x grid spacing [m2 s-2]. real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & optional, intent(out) :: inty_dza !< The integral in y of the difference !! between the geopotential anomaly at the top and bottom of - !! the layer divided by the y grid spacing, in m2 s-2. + !! the layer divided by the y grid spacing [m2 s-2]. integer, optional, intent(in) :: halo_size !< The width of halo points on which to calculate dza. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - optional, intent(in) :: bathyP !< The pressure at the bathymetry in Pa + optional, intent(in) :: bathyP !< The pressure at the bathymetry [Pa] real, optional, intent(in) :: dP_neglect !< A miniscule pressure change with !! the same units as p_t (Pa?) logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting @@ -1931,18 +1970,18 @@ subroutine int_spec_vol_dp_generic(T, S, p_t, p_b, alpha_ref, HI, EOS, & ! series for log(1-eps/1+eps) that assumes that |eps| < 0.34. real :: T5(5), S5(5), p5(5), a5(5) - real :: alpha_anom ! The depth averaged specific density anomaly in m3 kg-1. - real :: dp ! The pressure change through a layer, in Pa. -! real :: dp_90(2:4) ! The pressure change through a layer divided by 90, in Pa. - real :: hWght ! A pressure-thickness below topography, in Pa. - real :: hL, hR ! Pressure-thicknesses of the columns to the left and right, in Pa. - real :: iDenom ! The inverse of the denominator in the wieghts, in Pa-2. - real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column, nonDim. - real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column, nonDim. - real :: wt_L, wt_R ! The linear wieghts of the left and right columns, nonDim. - real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns, nonDim. + real :: alpha_anom ! The depth averaged specific density anomaly [m3 kg-1]. + real :: dp ! The pressure change through a layer [Pa]. +! real :: dp_90(2:4) ! The pressure change through a layer divided by 90 [Pa]. + real :: hWght ! A pressure-thickness below topography [Pa]. + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [Pa]. + real :: iDenom ! The inverse of the denominator in the weights [Pa-2]. + real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column [nondim]. + real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column [nondim]. + real :: wt_L, wt_R ! The linear weights of the left and right columns [nondim]. + real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim]. real :: intp(5) ! The integrals of specific volume with pressure at the - ! 5 sub-column locations, in m2 s-2. + ! 5 sub-column locations [m2 s-2]. logical :: do_massWeight ! Indicates whether to do mass weighting. real, parameter :: C1_90 = 1.0/90.0 ! A rational constant. integer :: Isq, Ieq, Jsq, Jeq, ish, ieh, jsh, jeh, i, j, m, n, halo @@ -2077,42 +2116,42 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, intp_dza, intx_dza, inty_dza, useMassWghtInterp) type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: T_t !< Potential temperature at the top of the layer in C. + intent(in) :: T_t !< Potential temperature at the top of the layer [degC]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: T_b !< Potential temperature at the bottom of the layer in C. + intent(in) :: T_b !< Potential temperature at the bottom of the layer [degC]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: S_t !< Salinity at the top the layer in PSU. + intent(in) :: S_t !< Salinity at the top the layer [ppt]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: S_b !< Salinity at the bottom the layer in PSU. + intent(in) :: S_b !< Salinity at the bottom the layer [ppt]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_t !< Pressure atop the layer in Pa. + intent(in) :: p_t !< Pressure atop the layer [Pa]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_b !< Pressure below the layer in Pa. + intent(in) :: p_b !< Pressure below the layer [Pa]. real, intent(in) :: alpha_ref !< A mean specific volume that is !! subtracted out to reduce the magnitude of each of the - !! integrals, in m3 kg-1. The calculation is mathematically + !! integrals [m3 kg-1]. The calculation is mathematically !! identical with different values of alpha_ref, but alpha_ref !! alters the effects of roundoff, and answers do change. real, intent(in) :: dP_neglect !< A miniscule pressure change with !! the same units as p_t (Pa?) real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: bathyP !< The pressure at the bathymetry in Pa + intent(in) :: bathyP !< The pressure at the bathymetry [Pa] type(EOS_type), pointer :: EOS !< Equation of state structure real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(out) :: dza !< The change in the geopotential anomaly - !! across the layer, in m2 s-2. + !! across the layer [m2 s-2]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(out) :: intp_dza !< The integral in pressure through the !! layer of the geopotential anomaly relative to the anomaly - !! at the bottom of the layer, in Pa m2 s-2. + !! at the bottom of the layer [Pa m2 s-2]. real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & optional, intent(out) :: intx_dza !< The integral in x of the difference !! between the geopotential anomaly at the top and bottom of - !! the layer divided by the x grid spacing, in m2 s-2. + !! the layer divided by the x grid spacing [m2 s-2]. real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & optional, intent(out) :: inty_dza !< The integral in y of the difference !! between the geopotential anomaly at the top and bottom of - !! the layer divided by the y grid spacing, in m2 s-2. + !! the layer divided by the y grid spacing [m2 s-2]. logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting !! to interpolate T/S for top and bottom integrals. @@ -2128,18 +2167,18 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, real :: wt_t(5), wt_b(5) real :: T_top, T_bot, S_top, S_bot, P_top, P_bot - real :: alpha_anom ! The depth averaged specific density anomaly in m3 kg-1. - real :: dp ! The pressure change through a layer, in Pa. - real :: dp_90(2:4) ! The pressure change through a layer divided by 90, in Pa. - real :: hWght ! A pressure-thickness below topography, in Pa. - real :: hL, hR ! Pressure-thicknesses of the columns to the left and right, in Pa. - real :: iDenom ! The inverse of the denominator in the wieghts, in Pa-2. - real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column, nonDim. - real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column, nonDim. - real :: wt_L, wt_R ! The linear wieghts of the left and right columns, nonDim. - real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns, nonDim. + real :: alpha_anom ! The depth averaged specific density anomaly [m3 kg-1]. + real :: dp ! The pressure change through a layer [Pa]. + real :: dp_90(2:4) ! The pressure change through a layer divided by 90 [Pa]. + real :: hWght ! A pressure-thickness below topography [Pa]. + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [Pa]. + real :: iDenom ! The inverse of the denominator in the weights [Pa-2]. + real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column [nondim]. + real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column [nondim]. + real :: wt_L, wt_R ! The linear weights of the left and right columns [nondim]. + real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim]. real :: intp(5) ! The integrals of specific volume with pressure at the - ! 5 sub-column locations, in m2 s-2. + ! 5 sub-column locations [m2 s-2]. real, parameter :: C1_90 = 1.0/90.0 ! A rational constant. logical :: do_massWeight ! Indicates whether to do mass weighting. integer :: Isq, Ieq, Jsq, Jeq, i, j, m, n, pos @@ -2300,21 +2339,18 @@ end subroutine int_spec_vol_dp_generic_plm !> Convert T&S to Absolute Salinity and Conservative Temperature if using TEOS10 subroutine convert_temp_salt_for_TEOS10(T, S, press, G, kd, mask_z, EOS) use MOM_grid, only : ocean_grid_type - !> The horizontal index structure - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - - !> Potential temperature referenced to the surface (degC) - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(inout) :: T - !> Salinity (PSU) - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(inout) :: S - !> Pressure at the top of the layer in Pa. - real, dimension(:), intent(in) :: press - !> Equation of state structure - type(EOS_type), pointer :: EOS - !> 3d mask - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: mask_z - integer, intent(in) :: kd - ! + + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), & + intent(inout) :: T !< Potential temperature referenced to the surface [degC] + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), & + intent(inout) :: S !< Salinity [ppt] + real, dimension(:), intent(in) :: press !< Pressure at the top of the layer [Pa]. + type(EOS_type), pointer :: EOS !< Equation of state structure + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), & + intent(in) :: mask_z !< 3d mask regulating which points to convert. + integer, intent(in) :: kd !< The number of layers to work on + integer :: i,j,k real :: gsw_sr_from_sp, gsw_ct_from_pt, gsw_sa_from_sp real :: p @@ -2322,32 +2358,38 @@ subroutine convert_temp_salt_for_TEOS10(T, S, press, G, kd, mask_z, EOS) if (.not.associated(EOS)) call MOM_error(FATAL, & "convert_temp_salt_to_TEOS10 called with an unassociated EOS_type EOS.") - if ((EOS%form_of_EOS .ne. EOS_TEOS10) .and. (EOS%form_of_EOS .ne. EOS_NEMO)) return + if ((EOS%form_of_EOS /= EOS_TEOS10) .and. (EOS%form_of_EOS /= EOS_NEMO)) return do k=1,kd ; do j=G%jsc,G%jec ; do i=G%isc,G%iec - if (mask_z(i,j,k) .ge. 1.0) then + if (mask_z(i,j,k) >= 1.0) then S(i,j,k) = gsw_sr_from_sp(S(i,j,k)) ! p=press(k)/10000. !convert pascal to dbar ! S(i,j,k) = gsw_sa_from_sp(S(i,j,k),p,G%geoLonT(i,j),G%geoLatT(i,j)) T(i,j,k) = gsw_ct_from_pt(S(i,j,k),T(i,j,k)) endif - enddo; enddo; enddo + enddo ; enddo ; enddo end subroutine convert_temp_salt_for_TEOS10 -! Extractor routine for the EOS type if the members need to be accessed outside this module -subroutine extract_member_EOS(EOS, form_of_EOS, form_of_TFreeze, EOS_quadrature, Compressible, Rho_T0_S0, drho_dT, & - dRho_dS, TFr_S0_P0, dTFr_dS, dTFr_dp) - type(EOS_type), pointer :: EOS - integer, optional, intent(out) :: form_of_EOS - integer, optional, intent(out) :: form_of_TFreeze - logical, optional, intent(out) :: EOS_quadrature - logical, optional, intent(out) :: Compressible - real , optional, intent(out) :: Rho_T0_S0 - real , optional, intent(out) :: drho_dT - real , optional, intent(out) :: dRho_dS - real , optional, intent(out) :: TFr_S0_P0 - real , optional, intent(out) :: dTFr_dS - real , optional, intent(out) :: dTFr_dp +!> Extractor routine for the EOS type if the members need to be accessed outside this module +subroutine extract_member_EOS(EOS, form_of_EOS, form_of_TFreeze, EOS_quadrature, Compressible, & + Rho_T0_S0, drho_dT, dRho_dS, TFr_S0_P0, dTFr_dS, dTFr_dp) + type(EOS_type), pointer :: EOS !< Equation of state structure + integer, optional, intent(out) :: form_of_EOS !< A coded integer indicating the equation of state to use. + integer, optional, intent(out) :: form_of_TFreeze !< A coded integer indicating the expression for + !! the potential temperature of the freezing point. + logical, optional, intent(out) :: EOS_quadrature !< If true, always use the generic (quadrature) + !! code for the integrals of density. + logical, optional, intent(out) :: Compressible !< If true, in situ density is a function of pressure. + real , optional, intent(out) :: Rho_T0_S0 !< Density at T=0 degC and S=0 ppt [kg m-3] + real , optional, intent(out) :: drho_dT !< Partial derivative of density with temperature + !! in [kg m-3 degC-1] + real , optional, intent(out) :: dRho_dS !< Partial derivative of density with salinity + !! in [kg m-3 ppt-1] + real , optional, intent(out) :: TFr_S0_P0 !< The freezing potential temperature at S=0, P=0 [degC]. + real , optional, intent(out) :: dTFr_dS !< The derivative of freezing point with salinity + !! [degC PSU-1]. + real , optional, intent(out) :: dTFr_dp !< The derivative of freezing point with pressure + !! [degC Pa-1]. if (present(form_of_EOS )) form_of_EOS = EOS%form_of_EOS if (present(form_of_TFreeze)) form_of_TFreeze = EOS%form_of_TFreeze diff --git a/src/equation_of_state/MOM_EOS_NEMO.F90 b/src/equation_of_state/MOM_EOS_NEMO.F90 index 86ad3cb5be..97ed9f8540 100644 --- a/src/equation_of_state/MOM_EOS_NEMO.F90 +++ b/src/equation_of_state/MOM_EOS_NEMO.F90 @@ -1,3 +1,4 @@ +!> The equation of state using the expressions of Roquet et al. that are used in NEMO module MOM_EOS_NEMO ! This file is part of MOM6. See LICENSE.md for the license. @@ -9,7 +10,7 @@ module MOM_EOS_NEMO !* Roquet, F., Madec, G., McDougall, T. J., and Barker, P. M., 2015. * !* Accurate polynomial expressions for the density and specific volume* !* of seawater using the TEOS-10 standard. Ocean Modelling, 90:29-43. * -!* These algorithms are NOT from NEMO package!! * +!* These algorithms are NOT from the standard NEMO package!! * !*********************************************************************** !use gsw_mod_toolbox, only : gsw_sr_from_sp, gsw_ct_from_pt @@ -21,162 +22,167 @@ module MOM_EOS_NEMO public calculate_density_derivs_nemo public calculate_density_scalar_nemo, calculate_density_array_nemo +!> Compute the in situ density of sea water ([kg m-3]), or its anomaly with respect to +!! a reference density, from absolute salinity (g/kg), conservative temperature (in deg C), +!! and pressure [Pa], using the expressions derived for use with NEMO interface calculate_density_nemo module procedure calculate_density_scalar_nemo, calculate_density_array_nemo end interface calculate_density_nemo +!> For a given thermodynamic state, return the derivatives of density with conservative temperature +!! and absolute salinity, the expressions derived for use with NEMO interface calculate_density_derivs_nemo module procedure calculate_density_derivs_scalar_nemo, calculate_density_derivs_array_nemo end interface calculate_density_derivs_nemo - real, parameter :: Pa2db = 1.e-4 - real, parameter :: rdeltaS = 32. - real, parameter :: r1_S0 = 0.875/35.16504 - real, parameter :: r1_T0 = 1./40. - real, parameter :: r1_P0 = 1.e-4 - real, parameter :: R00 = 4.6494977072e+01 - real, parameter :: R01 = -5.2099962525 - real, parameter :: R02 = 2.2601900708e-01 - real, parameter :: R03 = 6.4326772569e-02 - real, parameter :: R04 = 1.5616995503e-02 - real, parameter :: R05 = -1.7243708991e-03 - real, parameter :: EOS000 = 8.0189615746e+02 - real, parameter :: EOS100 = 8.6672408165e+02 - real, parameter :: EOS200 = -1.7864682637e+03 - real, parameter :: EOS300 = 2.0375295546e+03 - real, parameter :: EOS400 = -1.2849161071e+03 - real, parameter :: EOS500 = 4.3227585684e+02 - real, parameter :: EOS600 = -6.0579916612e+01 - real, parameter :: EOS010 = 2.6010145068e+01 - real, parameter :: EOS110 = -6.5281885265e+01 - real, parameter :: EOS210 = 8.1770425108e+01 - real, parameter :: EOS310 = -5.6888046321e+01 - real, parameter :: EOS410 = 1.7681814114e+01 - real, parameter :: EOS510 = -1.9193502195 - real, parameter :: EOS020 = -3.7074170417e+01 - real, parameter :: EOS120 = 6.1548258127e+01 - real, parameter :: EOS220 = -6.0362551501e+01 - real, parameter :: EOS320 = 2.9130021253e+01 - real, parameter :: EOS420 = -5.4723692739 - real, parameter :: EOS030 = 2.1661789529e+01 - real, parameter :: EOS130 = -3.3449108469e+01 - real, parameter :: EOS230 = 1.9717078466e+01 - real, parameter :: EOS330 = -3.1742946532 - real, parameter :: EOS040 = -8.3627885467 - real, parameter :: EOS140 = 1.1311538584e+01 - real, parameter :: EOS240 = -5.3563304045 - real, parameter :: EOS050 = 5.4048723791e-01 - real, parameter :: EOS150 = 4.8169980163e-01 - real, parameter :: EOS060 = -1.9083568888e-01 - real, parameter :: EOS001 = 1.9681925209e+01 - real, parameter :: EOS101 = -4.2549998214e+01 - real, parameter :: EOS201 = 5.0774768218e+01 - real, parameter :: EOS301 = -3.0938076334e+01 - real, parameter :: EOS401 = 6.6051753097 - real, parameter :: EOS011 = -1.3336301113e+01 - real, parameter :: EOS111 = -4.4870114575 - real, parameter :: EOS211 = 5.0042598061 - real, parameter :: EOS311 = -6.5399043664e-01 - real, parameter :: EOS021 = 6.7080479603 - real, parameter :: EOS121 = 3.5063081279 - real, parameter :: EOS221 = -1.8795372996 - real, parameter :: EOS031 = -2.4649669534 - real, parameter :: EOS131 = -5.5077101279e-01 - real, parameter :: EOS041 = 5.5927935970e-01 - real, parameter :: EOS002 = 2.0660924175 - real, parameter :: EOS102 = -4.9527603989 - real, parameter :: EOS202 = 2.5019633244 - real, parameter :: EOS012 = 2.0564311499 - real, parameter :: EOS112 = -2.1311365518e-01 - real, parameter :: EOS022 = -1.2419983026 - real, parameter :: EOS003 = -2.3342758797e-02 - real, parameter :: EOS103 = -1.8507636718e-02 - real, parameter :: EOS013 = 3.7969820455e-01 - real, parameter :: ALP000 = -6.5025362670e-01 - real, parameter :: ALP100 = 1.6320471316 - real, parameter :: ALP200 = -2.0442606277 - real, parameter :: ALP300 = 1.4222011580 - real, parameter :: ALP400 = -4.4204535284e-01 - real, parameter :: ALP500 = 4.7983755487e-02 - real, parameter :: ALP010 = 1.8537085209 - real, parameter :: ALP110 = -3.0774129064 - real, parameter :: ALP210 = 3.0181275751 - real, parameter :: ALP310 = -1.4565010626 - real, parameter :: ALP410 = 2.7361846370e-01 - real, parameter :: ALP020 = -1.6246342147 - real, parameter :: ALP120 = 2.5086831352 - real, parameter :: ALP220 = -1.4787808849 - real, parameter :: ALP320 = 2.3807209899e-01 - real, parameter :: ALP030 = 8.3627885467e-01 - real, parameter :: ALP130 = -1.1311538584 - real, parameter :: ALP230 = 5.3563304045e-01 - real, parameter :: ALP040 = -6.7560904739e-02 - real, parameter :: ALP140 = -6.0212475204e-02 - real, parameter :: ALP050 = 2.8625353333e-02 - real, parameter :: ALP001 = 3.3340752782e-01 - real, parameter :: ALP101 = 1.1217528644e-01 - real, parameter :: ALP201 = -1.2510649515e-01 - real, parameter :: ALP301 = 1.6349760916e-02 - real, parameter :: ALP011 = -3.3540239802e-01 - real, parameter :: ALP111 = -1.7531540640e-01 - real, parameter :: ALP211 = 9.3976864981e-02 - real, parameter :: ALP021 = 1.8487252150e-01 - real, parameter :: ALP121 = 4.1307825959e-02 - real, parameter :: ALP031 = -5.5927935970e-02 - real, parameter :: ALP002 = -5.1410778748e-02 - real, parameter :: ALP102 = 5.3278413794e-03 - real, parameter :: ALP012 = 6.2099915132e-02 - real, parameter :: ALP003 = -9.4924551138e-03 - real, parameter :: BET000 = 1.0783203594e+01 - real, parameter :: BET100 = -4.4452095908e+01 - real, parameter :: BET200 = 7.6048755820e+01 - real, parameter :: BET300 = -6.3944280668e+01 - real, parameter :: BET400 = 2.6890441098e+01 - real, parameter :: BET500 = -4.5221697773 - real, parameter :: BET010 = -8.1219372432e-01 - real, parameter :: BET110 = 2.0346663041 - real, parameter :: BET210 = -2.1232895170 - real, parameter :: BET310 = 8.7994140485e-01 - real, parameter :: BET410 = -1.1939638360e-01 - real, parameter :: BET020 = 7.6574242289e-01 - real, parameter :: BET120 = -1.5019813020 - real, parameter :: BET220 = 1.0872489522 - real, parameter :: BET320 = -2.7233429080e-01 - real, parameter :: BET030 = -4.1615152308e-01 - real, parameter :: BET130 = 4.9061350869e-01 - real, parameter :: BET230 = -1.1847737788e-01 - real, parameter :: BET040 = 1.4073062708e-01 - real, parameter :: BET140 = -1.3327978879e-01 - real, parameter :: BET050 = 5.9929880134e-03 - real, parameter :: BET001 = -5.2937873009e-01 - real, parameter :: BET101 = 1.2634116779 - real, parameter :: BET201 = -1.1547328025 - real, parameter :: BET301 = 3.2870876279e-01 - real, parameter :: BET011 = -5.5824407214e-02 - real, parameter :: BET111 = 1.2451933313e-01 - real, parameter :: BET211 = -2.4409539932e-02 - real, parameter :: BET021 = 4.3623149752e-02 - real, parameter :: BET121 = -4.6767901790e-02 - real, parameter :: BET031 = -6.8523260060e-03 - real, parameter :: BET002 = -6.1618945251e-02 - real, parameter :: BET102 = 6.2255521644e-02 - real, parameter :: BET012 = -2.6514181169e-03 - real, parameter :: BET003 = -2.3025968587e-04 - - +real, parameter :: Pa2db = 1.e-4 !< Conversion factor between Pa and dbar +!>@{ Parameters in the NEMO equation of state +real, parameter :: rdeltaS = 32. +real, parameter :: r1_S0 = 0.875/35.16504 +real, parameter :: r1_T0 = 1./40. +real, parameter :: r1_P0 = 1.e-4 +real, parameter :: R00 = 4.6494977072e+01 +real, parameter :: R01 = -5.2099962525 +real, parameter :: R02 = 2.2601900708e-01 +real, parameter :: R03 = 6.4326772569e-02 +real, parameter :: R04 = 1.5616995503e-02 +real, parameter :: R05 = -1.7243708991e-03 +real, parameter :: EOS000 = 8.0189615746e+02 +real, parameter :: EOS100 = 8.6672408165e+02 +real, parameter :: EOS200 = -1.7864682637e+03 +real, parameter :: EOS300 = 2.0375295546e+03 +real, parameter :: EOS400 = -1.2849161071e+03 +real, parameter :: EOS500 = 4.3227585684e+02 +real, parameter :: EOS600 = -6.0579916612e+01 +real, parameter :: EOS010 = 2.6010145068e+01 +real, parameter :: EOS110 = -6.5281885265e+01 +real, parameter :: EOS210 = 8.1770425108e+01 +real, parameter :: EOS310 = -5.6888046321e+01 +real, parameter :: EOS410 = 1.7681814114e+01 +real, parameter :: EOS510 = -1.9193502195 +real, parameter :: EOS020 = -3.7074170417e+01 +real, parameter :: EOS120 = 6.1548258127e+01 +real, parameter :: EOS220 = -6.0362551501e+01 +real, parameter :: EOS320 = 2.9130021253e+01 +real, parameter :: EOS420 = -5.4723692739 +real, parameter :: EOS030 = 2.1661789529e+01 +real, parameter :: EOS130 = -3.3449108469e+01 +real, parameter :: EOS230 = 1.9717078466e+01 +real, parameter :: EOS330 = -3.1742946532 +real, parameter :: EOS040 = -8.3627885467 +real, parameter :: EOS140 = 1.1311538584e+01 +real, parameter :: EOS240 = -5.3563304045 +real, parameter :: EOS050 = 5.4048723791e-01 +real, parameter :: EOS150 = 4.8169980163e-01 +real, parameter :: EOS060 = -1.9083568888e-01 +real, parameter :: EOS001 = 1.9681925209e+01 +real, parameter :: EOS101 = -4.2549998214e+01 +real, parameter :: EOS201 = 5.0774768218e+01 +real, parameter :: EOS301 = -3.0938076334e+01 +real, parameter :: EOS401 = 6.6051753097 +real, parameter :: EOS011 = -1.3336301113e+01 +real, parameter :: EOS111 = -4.4870114575 +real, parameter :: EOS211 = 5.0042598061 +real, parameter :: EOS311 = -6.5399043664e-01 +real, parameter :: EOS021 = 6.7080479603 +real, parameter :: EOS121 = 3.5063081279 +real, parameter :: EOS221 = -1.8795372996 +real, parameter :: EOS031 = -2.4649669534 +real, parameter :: EOS131 = -5.5077101279e-01 +real, parameter :: EOS041 = 5.5927935970e-01 +real, parameter :: EOS002 = 2.0660924175 +real, parameter :: EOS102 = -4.9527603989 +real, parameter :: EOS202 = 2.5019633244 +real, parameter :: EOS012 = 2.0564311499 +real, parameter :: EOS112 = -2.1311365518e-01 +real, parameter :: EOS022 = -1.2419983026 +real, parameter :: EOS003 = -2.3342758797e-02 +real, parameter :: EOS103 = -1.8507636718e-02 +real, parameter :: EOS013 = 3.7969820455e-01 +real, parameter :: ALP000 = -6.5025362670e-01 +real, parameter :: ALP100 = 1.6320471316 +real, parameter :: ALP200 = -2.0442606277 +real, parameter :: ALP300 = 1.4222011580 +real, parameter :: ALP400 = -4.4204535284e-01 +real, parameter :: ALP500 = 4.7983755487e-02 +real, parameter :: ALP010 = 1.8537085209 +real, parameter :: ALP110 = -3.0774129064 +real, parameter :: ALP210 = 3.0181275751 +real, parameter :: ALP310 = -1.4565010626 +real, parameter :: ALP410 = 2.7361846370e-01 +real, parameter :: ALP020 = -1.6246342147 +real, parameter :: ALP120 = 2.5086831352 +real, parameter :: ALP220 = -1.4787808849 +real, parameter :: ALP320 = 2.3807209899e-01 +real, parameter :: ALP030 = 8.3627885467e-01 +real, parameter :: ALP130 = -1.1311538584 +real, parameter :: ALP230 = 5.3563304045e-01 +real, parameter :: ALP040 = -6.7560904739e-02 +real, parameter :: ALP140 = -6.0212475204e-02 +real, parameter :: ALP050 = 2.8625353333e-02 +real, parameter :: ALP001 = 3.3340752782e-01 +real, parameter :: ALP101 = 1.1217528644e-01 +real, parameter :: ALP201 = -1.2510649515e-01 +real, parameter :: ALP301 = 1.6349760916e-02 +real, parameter :: ALP011 = -3.3540239802e-01 +real, parameter :: ALP111 = -1.7531540640e-01 +real, parameter :: ALP211 = 9.3976864981e-02 +real, parameter :: ALP021 = 1.8487252150e-01 +real, parameter :: ALP121 = 4.1307825959e-02 +real, parameter :: ALP031 = -5.5927935970e-02 +real, parameter :: ALP002 = -5.1410778748e-02 +real, parameter :: ALP102 = 5.3278413794e-03 +real, parameter :: ALP012 = 6.2099915132e-02 +real, parameter :: ALP003 = -9.4924551138e-03 +real, parameter :: BET000 = 1.0783203594e+01 +real, parameter :: BET100 = -4.4452095908e+01 +real, parameter :: BET200 = 7.6048755820e+01 +real, parameter :: BET300 = -6.3944280668e+01 +real, parameter :: BET400 = 2.6890441098e+01 +real, parameter :: BET500 = -4.5221697773 +real, parameter :: BET010 = -8.1219372432e-01 +real, parameter :: BET110 = 2.0346663041 +real, parameter :: BET210 = -2.1232895170 +real, parameter :: BET310 = 8.7994140485e-01 +real, parameter :: BET410 = -1.1939638360e-01 +real, parameter :: BET020 = 7.6574242289e-01 +real, parameter :: BET120 = -1.5019813020 +real, parameter :: BET220 = 1.0872489522 +real, parameter :: BET320 = -2.7233429080e-01 +real, parameter :: BET030 = -4.1615152308e-01 +real, parameter :: BET130 = 4.9061350869e-01 +real, parameter :: BET230 = -1.1847737788e-01 +real, parameter :: BET040 = 1.4073062708e-01 +real, parameter :: BET140 = -1.3327978879e-01 +real, parameter :: BET050 = 5.9929880134e-03 +real, parameter :: BET001 = -5.2937873009e-01 +real, parameter :: BET101 = 1.2634116779 +real, parameter :: BET201 = -1.1547328025 +real, parameter :: BET301 = 3.2870876279e-01 +real, parameter :: BET011 = -5.5824407214e-02 +real, parameter :: BET111 = 1.2451933313e-01 +real, parameter :: BET211 = -2.4409539932e-02 +real, parameter :: BET021 = 4.3623149752e-02 +real, parameter :: BET121 = -4.6767901790e-02 +real, parameter :: BET031 = -6.8523260060e-03 +real, parameter :: BET002 = -6.1618945251e-02 +real, parameter :: BET102 = 6.2255521644e-02 +real, parameter :: BET012 = -2.6514181169e-03 +real, parameter :: BET003 = -2.3025968587e-04 +!!@} contains !> This subroutine computes the in situ density of sea water (rho in -!! units of kg/m^3) from absolute salinity (S in g/kg), conservative temperature -!! (T in deg C), and pressure in Pa. It uses the expressions derived for use +!! [kg m-3]) from absolute salinity (S [g kg-1]), conservative temperature +!! (T [degC]), and pressure [Pa]. It uses the expressions derived for use !! with NEMO. subroutine calculate_density_scalar_nemo(T, S, pressure, rho, rho_ref) - real, intent(in) :: T !< Conservative temperature in C. - real, intent(in) :: S !< Absolute salinity in g/kg. - real, intent(in) :: pressure !< Pressure in Pa. - real, intent(out) :: rho !< In situ density in kg m-3. - real, optional, intent(in) :: rho_ref !< A reference density in kg m-3. + real, intent(in) :: T !< Conservative temperature [degC]. + real, intent(in) :: S !< Absolute salinity [g kg-1]. + real, intent(in) :: pressure !< pressure [Pa]. + real, intent(out) :: rho !< In situ density [kg m-3]. + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. real :: al0, p0, lambda integer :: j @@ -193,18 +199,19 @@ subroutine calculate_density_scalar_nemo(T, S, pressure, rho, rho_ref) end subroutine calculate_density_scalar_nemo !> This subroutine computes the in situ density of sea water (rho in -!! units of kg/m^3) from absolute salinity (S in g/kg), conservative temperature -!! (T in deg C), and pressure in Pa. It uses the expressions derived for use +!! [kg m-3]) from absolute salinity (S [g kg-1]), conservative temperature +!! (T [degC]), and pressure [Pa]. It uses the expressions derived for use !! with NEMO. subroutine calculate_density_array_nemo(T, S, pressure, rho, start, npts, rho_ref) - real, dimension(:), intent(in) :: T !< Conservative temperature in C. - real, dimension(:), intent(in) :: S !< Absolute salinity in g/kg - real, dimension(:), intent(in) :: pressure !< pressure in Pa. - real, dimension(:), intent(out) :: rho !< in situ density in kg m-3. + real, dimension(:), intent(in) :: T !< Conservative temperature [degC]. + real, dimension(:), intent(in) :: S !< Absolute salinity [g kg-1]. + real, dimension(:), intent(in) :: pressure !< pressure [Pa]. + real, dimension(:), intent(out) :: rho !< in situ density [kg m-3]. integer, intent(in) :: start !< the starting point in the arrays. integer, intent(in) :: npts !< the number of values to calculate. - real, optional, intent(in) :: rho_ref !< A reference density in kg m-3. + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. + ! Local variables real :: zp, zt, zh, zs, zr0, zn, zn0, zn1, zn2, zn3, zs0 integer :: j @@ -255,25 +262,20 @@ subroutine calculate_density_array_nemo(T, S, pressure, rho, start, npts, rho_re enddo end subroutine calculate_density_array_nemo +!> For a given thermodynamic state, calculate the derivatives of density with conservative +!! temperature and absolute salinity, using the expressions derived for use with NEMO. subroutine calculate_density_derivs_array_nemo(T, S, pressure, drho_dT, drho_dS, start, npts) - real, intent(in), dimension(:) :: T !< Conservative temperature in C. - real, intent(in), dimension(:) :: S !< Absolute salinity in g/kg. - real, intent(in), dimension(:) :: pressure !< Pressure in Pa. + real, intent(in), dimension(:) :: T !< Conservative temperature [degC]. + real, intent(in), dimension(:) :: S !< Absolute salinity [g kg-1]. + real, intent(in), dimension(:) :: pressure !< pressure [Pa]. real, intent(out), dimension(:) :: drho_dT !< The partial derivative of density with potential - !! temperature, in kg m-3 K-1. + !! temperature [kg m-3 degC-1]. real, intent(out), dimension(:) :: drho_dS !< The partial derivative of density with salinity, - !! in kg m-3 psu-1. + !! in [kg m-3 ppt-1]. integer, intent(in) :: start !< The starting point in the arrays. integer, intent(in) :: npts !< The number of values to calculate. -! * Arguments: T - conservative temperature in C. * -! * (in) S - absolute salinity in g/kg. * -! * (in) pressure - pressure in Pa. * -! * (out) drho_dT - the partial derivative of density with * -! * potential temperature, in kg m-3 K-1. * -! * (out) drho_dS - the partial derivative of density with * -! * salinity, in kg m-3 psu-1. * -! * (in) start - the starting point in the arrays. * -! * (in) npts - the number of values to calculate. * + + ! Local variables real :: zp,zt , zh , zs , zr0, zn , zn0, zn1, zn2, zn3 integer :: j @@ -337,9 +339,13 @@ end subroutine calculate_density_derivs_array_nemo !> Wrapper to calculate_density_derivs_array for scalar inputs subroutine calculate_density_derivs_scalar_nemo(T, S, pressure, drho_dt, drho_ds) - real, intent(in) :: T, S, pressure - real, intent(out) :: drho_dt - real, intent(out) :: drho_ds + real, intent(in) :: T !< Potential temperature relative to the surface [degC]. + real, intent(in) :: S !< Salinity [g kg-1]. + real, intent(in) :: pressure !< Pressure [Pa]. + real, intent(out) :: drho_dT !< The partial derivative of density with potential + !! temperature [kg m-3 degC-1]. + real, intent(out) :: drho_dS !< The partial derivative of density with salinity, + !! in [kg m-3 ppt-1]. ! Local variables real :: al0, p0, lambda integer :: j @@ -355,26 +361,22 @@ subroutine calculate_density_derivs_scalar_nemo(T, S, pressure, drho_dt, drho_ds drho_ds = drds0(1) end subroutine calculate_density_derivs_scalar_nemo +!> Compute the in situ density of sea water (rho in [kg m-3]) and the compressibility +!! (drho/dp = C_sound^-2, stored as drho_dp [s2 m-2]) from absolute salinity +!! (sal in g/kg), conservative temperature (T [degC]), and pressure [Pa], using the expressions +!! derived for use with NEMO. subroutine calculate_compress_nemo(T, S, pressure, rho, drho_dp, start, npts) - real, intent(in), dimension(:) :: T !< Conservative temperature in C. - real, intent(in), dimension(:) :: S !< Absolute salinity in g/kg. - real, intent(in), dimension(:) :: pressure !< Pressure in Pa. - real, intent(out), dimension(:) :: rho !< In situ density in kg m-3. + real, intent(in), dimension(:) :: T !< Conservative temperature [degC]. + real, intent(in), dimension(:) :: S !< Absolute salinity [g/kg]. + real, intent(in), dimension(:) :: pressure !< pressure [Pa]. + real, intent(out), dimension(:) :: rho !< In situ density [kg m-3]. real, intent(out), dimension(:) :: drho_dp !< The partial derivative of density with pressure !! (also the inverse of the square of sound speed) - !! in s2 m-2. + !! [s2 m-2]. integer, intent(in) :: start !< The starting point in the arrays. integer, intent(in) :: npts !< The number of values to calculate. -! * Arguments: T - conservative temperature in C. * -! * (in) S - absolute salinity in g/kg. * -! * (in) pressure - pressure in Pa. * -! * (out) rho - in situ density in kg m-3. * -! * (out) drho_dp - the partial derivative of density with * -! * pressure (also the inverse of the square of * -! * sound speed) in s2 m-2. * -! * (in) start - the starting point in the arrays. * -! * (in) npts - the number of values to calculate. * -! *====================================================================* + + ! Local variables real :: zs,zt,zp integer :: j diff --git a/src/equation_of_state/MOM_EOS_TEOS10.F90 b/src/equation_of_state/MOM_EOS_TEOS10.F90 index d6a211b6c3..bbe9982b6f 100644 --- a/src/equation_of_state/MOM_EOS_TEOS10.F90 +++ b/src/equation_of_state/MOM_EOS_TEOS10.F90 @@ -1,3 +1,4 @@ +!> The equation of state using the TEOS10 expressions module MOM_EOS_TEOS10 ! This file is part of MOM6. See LICENSE.md for the license. @@ -21,37 +22,48 @@ module MOM_EOS_TEOS10 public calculate_density_second_derivs_teos10 public gsw_sp_from_sr, gsw_pt_from_ct +!> Compute the in situ density of sea water ([kg m-3]), or its anomaly with respect to +!! a reference density, from absolute salinity (g/kg), conservative temperature (in deg C), +!! and pressure [Pa], using the TEOS10 expressions. interface calculate_density_teos10 module procedure calculate_density_scalar_teos10, calculate_density_array_teos10 end interface calculate_density_teos10 +!> Compute the in situ specific volume of sea water (in [m3 kg-1]), or an anomaly with respect +!! to a reference specific volume, from absolute salinity (in g/kg), conservative temperature +!! (in deg C), and pressure [Pa], using the TEOS10 expressions. interface calculate_spec_vol_teos10 module procedure calculate_spec_vol_scalar_teos10, calculate_spec_vol_array_teos10 end interface calculate_spec_vol_teos10 +!> For a given thermodynamic state, return the derivatives of density with conservative temperature +!! and absolute salinity, using the TEOS10 expressions. interface calculate_density_derivs_teos10 module procedure calculate_density_derivs_scalar_teos10, calculate_density_derivs_array_teos10 end interface calculate_density_derivs_teos10 +!> For a given thermodynamic state, return the second derivatives of density with various combinations +!! of conservative temperature, absolute salinity, and pressure, using the TEOS10 expressions. interface calculate_density_second_derivs_teos10 module procedure calculate_density_second_derivs_scalar_teos10, calculate_density_second_derivs_array_teos10 end interface calculate_density_second_derivs_teos10 -real, parameter :: Pa2db = 1.e-4 ! The conversion factor from Pa to dbar. +real, parameter :: Pa2db = 1.e-4 !< The conversion factor from Pa to dbar. contains !> This subroutine computes the in situ density of sea water (rho in -!! units of kg/m^3) from absolute salinity (S in g/kg), conservative temperature -!! (T in deg C), and pressure in Pa. It uses the expression from the +!! [kg m-3]) from absolute salinity (S [g kg-1]), conservative temperature +!! (T [degC]), and pressure [Pa]. It uses the expression from the !! TEOS10 website. subroutine calculate_density_scalar_teos10(T, S, pressure, rho, rho_ref) - real, intent(in) :: T !< Conservative temperature in C. - real, intent(in) :: S !< Absolute salinity in g/kg. - real, intent(in) :: pressure !< Pressure in Pa. - real, intent(out) :: rho !< In situ density in kg m-3. - real, optional, intent(in) :: rho_ref !< A reference density in kg m-3. + real, intent(in) :: T !< Conservative temperature [degC]. + real, intent(in) :: S !< Absolute salinity [g kg-1]. + real, intent(in) :: pressure !< pressure [Pa]. + real, intent(out) :: rho !< In situ density [kg m-3]. + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. + ! Local variables real, dimension(1) :: T0, S0, pressure0 real, dimension(1) :: rho0 @@ -65,18 +77,19 @@ subroutine calculate_density_scalar_teos10(T, S, pressure, rho, rho_ref) end subroutine calculate_density_scalar_teos10 !> This subroutine computes the in situ density of sea water (rho in -!! units of kg/m^3) from absolute salinity (S in g/kg), conservative temperature -!! (T in deg C), and pressure in Pa. It uses the expression from the +!! [kg m-3]) from absolute salinity (S [g kg-1]), conservative temperature +!! (T [degC]), and pressure [Pa]. It uses the expression from the !! TEOS10 website. subroutine calculate_density_array_teos10(T, S, pressure, rho, start, npts, rho_ref) - real, dimension(:), intent(in) :: T !< Conservative temperature in C. - real, dimension(:), intent(in) :: S !< Absolute salinity in g/kg - real, dimension(:), intent(in) :: pressure !< pressure in Pa. - real, dimension(:), intent(out) :: rho !< in situ density in kg m-3. + real, dimension(:), intent(in) :: T !< Conservative temperature [degC]. + real, dimension(:), intent(in) :: S !< Absolute salinity [g kg-1] + real, dimension(:), intent(in) :: pressure !< pressure [Pa]. + real, dimension(:), intent(out) :: rho !< in situ density [kg m-3]. integer, intent(in) :: start !< the starting point in the arrays. integer, intent(in) :: npts !< the number of values to calculate. - real, optional, intent(in) :: rho_ref !< A reference density in kg m-3. + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. + ! Local variables real :: zs, zt, zp integer :: j @@ -96,17 +109,17 @@ subroutine calculate_density_array_teos10(T, S, pressure, rho, start, npts, rho_ end subroutine calculate_density_array_teos10 !> This subroutine computes the in situ specific volume of sea water (specvol in -!! units of m^3/kg) from salinity (S in psu), potential temperature (T in deg C) -!! and pressure in Pa, using the TEOS10 equation of state. +!! [m3 kg-1]) from absolute salinity (S [g kg-1]), conservative temperature (T [degC]) +!! and pressure [Pa], using the TEOS10 equation of state. !! If spv_ref is present, specvol is an anomaly from spv_ref. subroutine calculate_spec_vol_scalar_teos10(T, S, pressure, specvol, spv_ref) - real, intent(in) :: T !< potential temperature relative to the surface - !! in C. - real, intent(in) :: S !< salinity in PSU. - real, intent(in) :: pressure !< pressure in Pa. - real, intent(out) :: specvol !< in situ specific volume in m3 kg-1. - real, optional, intent(in) :: spv_ref !< A reference specific volume in m3 kg-1. + real, intent(in) :: T !< Conservative temperature [degC]. + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< pressure [Pa]. + real, intent(out) :: specvol !< in situ specific volume [m3 kg-1]. + real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. + ! Local variables real, dimension(1) :: T0, S0, pressure0, spv0 T0(1) = T ; S0(1) = S ; pressure0(1) = pressure @@ -117,19 +130,20 @@ end subroutine calculate_spec_vol_scalar_teos10 !> This subroutine computes the in situ specific volume of sea water (specvol in -!! units of m^3/kg) from salinity (S in psu), potential temperature (T in deg C) -!! and pressure in Pa, using the TEOS10 equation of state. +!! [m3 kg-1]) from absolute salinity (S [g kg-1]), conservative temperature (T [degC]) +!! and pressure [Pa], using the TEOS10 equation of state. !! If spv_ref is present, specvol is an anomaly from spv_ref. subroutine calculate_spec_vol_array_teos10(T, S, pressure, specvol, start, npts, spv_ref) - real, dimension(:), intent(in) :: T !< potential temperature relative to the surface - !! in C. - real, dimension(:), intent(in) :: S !< salinity in PSU. - real, dimension(:), intent(in) :: pressure !< pressure in Pa. - real, dimension(:), intent(out) :: specvol !< in situ specific volume in m3 kg-1. + real, dimension(:), intent(in) :: T !< Conservative temperature relative to the surface + !! [degC]. + real, dimension(:), intent(in) :: S !< salinity [g kg-1]. + real, dimension(:), intent(in) :: pressure !< pressure [Pa]. + real, dimension(:), intent(out) :: specvol !< in situ specific volume [m3 kg-1]. integer, intent(in) :: start !< the starting point in the arrays. integer, intent(in) :: npts !< the number of values to calculate. - real, optional, intent(in) :: spv_ref !< A reference specific volume in m3 kg-1. + real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. + ! Local variables real :: zs, zt, zp integer :: j @@ -149,27 +163,21 @@ subroutine calculate_spec_vol_array_teos10(T, S, pressure, specvol, start, npts, end subroutine calculate_spec_vol_array_teos10 - +!> For a given thermodynamic state, calculate the derivatives of density with conservative +!! temperature and absolute salinity, using the TEOS10 expressions. subroutine calculate_density_derivs_array_teos10(T, S, pressure, drho_dT, drho_dS, start, npts) - real, intent(in), dimension(:) :: T !< Conservative temperature in C. - real, intent(in), dimension(:) :: S !< Absolute salinity in g/kg. - real, intent(in), dimension(:) :: pressure !< Pressure in Pa. - real, intent(out), dimension(:) :: drho_dT !< The partial derivative of density with potential - !! temperature, in kg m-3 K-1. - real, intent(out), dimension(:) :: drho_dS !< The partial derivative of density with salinity, - !! in kg m-3 psu-1. + real, intent(in), dimension(:) :: T !< Conservative temperature [degC]. + real, intent(in), dimension(:) :: S !< Absolute salinity [g kg-1]. + real, intent(in), dimension(:) :: pressure !< pressure [Pa]. + real, intent(out), dimension(:) :: drho_dT !< The partial derivative of density with conservative + !! temperature [kg m-3 degC-1]. + real, intent(out), dimension(:) :: drho_dS !< The partial derivative of density with absolute salinity, + !! [kg m-3 (g/kg)-1]. integer, intent(in) :: start !< The starting point in the arrays. integer, intent(in) :: npts !< The number of values to calculate. -! * Arguments: T - conservative temperature in C. * -! * (in) S - absolute salinity in g/kg. * -! * (in) pressure - pressure in Pa. * -! * (out) drho_dT - the partial derivative of density with * -! * potential temperature, in kg m-3 K-1. * -! * (out) drho_dS - the partial derivative of density with * -! * salinity, in kg m-3 psu-1. * -! * (in) start - the starting point in the arrays. * -! * (in) npts - the number of values to calculate. * - real :: zs,zt,zp + + ! Local variables + real :: zs, zt, zp integer :: j do j=start,start+npts-1 @@ -186,38 +194,41 @@ subroutine calculate_density_derivs_array_teos10(T, S, pressure, drho_dT, drho_d end subroutine calculate_density_derivs_array_teos10 +!> For a given thermodynamic state, calculate the derivatives of density with conservative +!! temperature and absolute salinity, using the TEOS10 expressions. subroutine calculate_density_derivs_scalar_teos10(T, S, pressure, drho_dT, drho_dS) - real, intent(in) :: T, S, pressure - real, intent(out) :: drho_dT, drho_dS + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute Salinity [g kg-1] + real, intent(in) :: pressure !< pressure [Pa]. + real, intent(out) :: drho_dT !< The partial derivative of density with conservative + !! temperature [kg m-3 degC-1]. + real, intent(out) :: drho_dS !< The partial derivative of density with absolute salinity, + !! [kg m-3 (g/kg)-1]. + ! Local variables - real :: zs,zt,zp + real :: zs, zt, zp !Conversions zs = S !gsw_sr_from_sp(S) !Convert practical salinity to absolute salinity zt = T !gsw_ct_from_pt(S,T) !Convert potantial temp to conservative temp zp = pressure* Pa2db !Convert pressure from Pascal to decibar - if(S.lt.-1.0e-10) return !Can we assume safely that this is a missing value? + if (S < -1.0e-10) return !Can we assume safely that this is a missing value? call gsw_rho_first_derivatives(zs, zt, zp, drho_dsa=drho_dS, drho_dct=drho_dT) end subroutine calculate_density_derivs_scalar_teos10 +!> For a given thermodynamic state, calculate the derivatives of specific volume with conservative +!! temperature and absolute salinity, using the TEOS10 expressions. subroutine calculate_specvol_derivs_teos10(T, S, pressure, dSV_dT, dSV_dS, start, npts) - real, intent(in), dimension(:) :: T !< Conservative temperature in C. - real, intent(in), dimension(:) :: S !< Absolute salinity in g/kg. - real, intent(in), dimension(:) :: pressure !< Pressure in Pa. + real, intent(in), dimension(:) :: T !< Conservative temperature [degC]. + real, intent(in), dimension(:) :: S !< Absolute salinity [g kg-1]. + real, intent(in), dimension(:) :: pressure !< pressure [Pa]. real, intent(out), dimension(:) :: dSV_dT !< The partial derivative of specific volume with - !! potential temperature, in m3 kg-1 K-1. + !! conservative temperature [m3 kg-1 degC-1]. real, intent(out), dimension(:) :: dSV_dS !< The partial derivative of specific volume with - !! salinity, in m3 kg-1 / (g/kg). + !! absolute salinity [m3 kg-1 (g/kg)-1]. integer, intent(in) :: start !< The starting point in the arrays. integer, intent(in) :: npts !< The number of values to calculate. -! * Arguments: T - conservative temperature in C. * -! * (in) S - absolute salinity in g/kg. * -! * (in) pressure - pressure in Pa. * -! * (out) dSV_dT - the partial derivative of specific volume with * -! * potential temperature, in m3 kg-1 K-1. * -! * (out) dSV_dS - the partial derivative of specific volume with * -! * salinity, in m3 kg-1 / (g/kg). * -! * (in) start - the starting point in the arrays. * -! * (in) npts - the number of values to calculate. * + + ! Local variables real :: zs, zt, zp integer :: j @@ -236,37 +247,36 @@ subroutine calculate_specvol_derivs_teos10(T, S, pressure, dSV_dT, dSV_dS, start end subroutine calculate_specvol_derivs_teos10 !> Calculate the 5 second derivatives of the equation of state for scalar inputs -subroutine calculate_density_second_derivs_scalar_teos10(T, S, pressure, drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, & - drho_dT_dP) - real, intent(in) :: T, S, pressure +subroutine calculate_density_second_derivs_scalar_teos10(T, S, pressure, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP) + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute Salinity [g kg-1] + real, intent(in) :: pressure !< pressure [Pa]. real, intent(out) :: drho_dS_dS !< Partial derivative of beta with respect to S real, intent(out) :: drho_dS_dT !< Partial derivative of beta with resepct to T real, intent(out) :: drho_dT_dT !< Partial derivative of alpha with respect to T real, intent(out) :: drho_dS_dP !< Partial derivative of beta with respect to pressure real, intent(out) :: drho_dT_dP !< Partial derivative of alpha with respect to pressure -! * Arguments: T - conservative temperature in C. * -! * (in) S - absolute salinity in g/kg. * -! * (in) pressure - pressure in Pa. * -! * (out) drho_dT - the partial derivative of density with * -! * potential temperature, in kg m-3 K-1. * -! * (out) drho_dS - the partial derivative of density with * -! * salinity, in kg m-3 psu-1. * - real :: zs,zt,zp + + ! Local variables + real :: zs, zt, zp !Conversions zs = S !gsw_sr_from_sp(S) !Convert practical salinity to absolute salinity zt = T !gsw_ct_from_pt(S,T) !Convert potantial temp to conservative temp zp = pressure* Pa2db !Convert pressure from Pascal to decibar - if(S.lt.-1.0e-10) return !Can we assume safely that this is a missing value? + if (S < -1.0e-10) return !Can we assume safely that this is a missing value? call gsw_rho_second_derivatives(zs, zt, zp, rho_sa_sa=drho_dS_dS, rho_sa_ct=drho_dS_dT, & rho_ct_ct=drho_dT_dT, rho_sa_p=drho_dS_dP, rho_ct_p=drho_dT_dP) end subroutine calculate_density_second_derivs_scalar_teos10 !> Calculate the 5 second derivatives of the equation of state for scalar inputs -subroutine calculate_density_second_derivs_array_teos10(T, S, pressure, drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, & - drho_dT_dP, start, npts) - real, dimension(:), intent(in) :: T, S, pressure +subroutine calculate_density_second_derivs_array_teos10(T, S, pressure, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP, start, npts) + real, dimension(:), intent(in) :: T !< Conservative temperature [degC] + real, dimension(:), intent(in) :: S !< Absolute Salinity [g kg-1] + real, dimension(:), intent(in) :: pressure !< pressure [Pa]. real, dimension(:), intent(out) :: drho_dS_dS !< Partial derivative of beta with respect to S real, dimension(:), intent(out) :: drho_dS_dT !< Partial derivative of beta with resepct to T real, dimension(:), intent(out) :: drho_dT_dT !< Partial derivative of alpha with respect to T @@ -274,15 +284,11 @@ subroutine calculate_density_second_derivs_array_teos10(T, S, pressure, drho_dS_ real, dimension(:), intent(out) :: drho_dT_dP !< Partial derivative of alpha with respect to pressure integer, intent(in) :: start !< The starting point in the arrays. integer, intent(in) :: npts !< The number of values to calculate. -! * Arguments: T - conservative temperature in C. * -! * (in) S - absolute salinity in g/kg. * -! * (in) pressure - pressure in Pa. * -! * (out) drho_dT - the partial derivative of density with * -! * potential temperature, in kg m-3 K-1. * -! * (out) drho_dS - the partial derivative of density with * -! * salinity, in kg m-3 psu-1. * - real :: zs,zt,zp + + ! Local variables + real :: zs, zt, zp integer :: j + do j=start,start+npts-1 !Conversions zs = S(j) !gsw_sr_from_sp(S) !Convert practical salinity to absolute salinity @@ -299,37 +305,23 @@ subroutine calculate_density_second_derivs_array_teos10(T, S, pressure, drho_dS_ end subroutine calculate_density_second_derivs_array_teos10 -!> This subroutine computes the in situ density of sea water (rho in * -!! units of kg/m^3) and the compressibility (drho/dp = C_sound^-2) * -!! (drho_dp in units of s2 m-2) from salinity (sal in psu), potential* -!! temperature (T in deg C), and pressure in Pa. It uses the * +!> This subroutine computes the in situ density of sea water (rho in +!! [kg m-3]) and the compressibility (drho/dp = C_sound^-2) +!! (drho_dp [s2 m-2]) from absolute salinity (sal in g/kg), +!! conservative temperature (T [degC]), and pressure [Pa]. It uses the !! subroutines from TEOS10 website subroutine calculate_compress_teos10(T, S, pressure, rho, drho_dp, start, npts) - real, intent(in), dimension(:) :: T !< Conservative temperature in C. - real, intent(in), dimension(:) :: S !< Absolute salinity in g/kg. - real, intent(in), dimension(:) :: pressure !< Pressure in Pa. - real, intent(out), dimension(:) :: rho !< In situ density in kg m-3. + real, intent(in), dimension(:) :: T !< Conservative temperature [degC]. + real, intent(in), dimension(:) :: S !< Absolute salinity [g kg-1]. + real, intent(in), dimension(:) :: pressure !< Pressure [Pa]. + real, intent(out), dimension(:) :: rho !< In situ density [kg m-3]. real, intent(out), dimension(:) :: drho_dp !< The partial derivative of density with pressure !! (also the inverse of the square of sound speed) - !! in s2 m-2. + !! [s2 m-2]. integer, intent(in) :: start !< The starting point in the arrays. integer, intent(in) :: npts !< The number of values to calculate. -! * Arguments: T - conservative temperature in C. * -! * (in) S - absolute salinity in g/kg. * -! * (in) pressure - pressure in Pa. * -! * (out) rho - in situ density in kg m-3. * -! * (out) drho_dp - the partial derivative of density with * -! * pressure (also the inverse of the square of * -! * sound speed) in s2 m-2. * -! * (in) start - the starting point in the arrays. * -! * (in) npts - the number of values to calculate. * -! *====================================================================* -! * This subroutine computes the in situ density of sea water (rho in * -! * units of kg/m^3) and the compressibility (drho/dp = C_sound^-2) * -! * (drho_dp in units of s2 m-2) from salinity (sal in psu), potential* -! * temperature (T in deg C), and pressure in Pa. It uses the * -! * subroutines from TEOS10 website * -! *====================================================================* + + ! Local variables real :: zs,zt,zp integer :: j diff --git a/src/equation_of_state/MOM_EOS_UNESCO.F90 b/src/equation_of_state/MOM_EOS_UNESCO.F90 index 4489f40a2a..c7dbad3b66 100644 --- a/src/equation_of_state/MOM_EOS_UNESCO.F90 +++ b/src/equation_of_state/MOM_EOS_UNESCO.F90 @@ -1,3 +1,4 @@ +!> The equation of state using the Jackett and McDougall fits to the UNESCO EOS module MOM_EOS_UNESCO ! This file is part of MOM6. See LICENSE.md for the license. @@ -15,15 +16,21 @@ module MOM_EOS_UNESCO public calculate_density_derivs_UNESCO public calculate_density_scalar_UNESCO, calculate_density_array_UNESCO +!> Compute the in situ density of sea water (in [kg m-3]), or its anomaly with respect to +!! a reference density, from salinity [PSU], potential temperature [degC], and pressure [Pa], +!! using the UNESCO (1981) equation of state. interface calculate_density_UNESCO module procedure calculate_density_scalar_UNESCO, calculate_density_array_UNESCO end interface calculate_density_UNESCO +!> Compute the in situ specific volume of sea water (in [m3 kg-1]), or an anomaly with respect +!! to a reference specific volume, from salinity [PSU], potential temperature [degC], and +!! pressure [Pa], using the UNESCO (1981) equation of state. interface calculate_spec_vol_UNESCO module procedure calculate_spec_vol_scalar_UNESCO, calculate_spec_vol_array_UNESCO end interface calculate_spec_vol_UNESCO - +!>@{ Parameters in the UNESCO equation of state ! The following constants are used to calculate rho0. The notation ! is Rab for the contribution to rho0 from T^aS^b. real, parameter :: R00 = 999.842594, R10 = 6.793952e-2, R20 = -9.095290e-3, & @@ -42,20 +49,21 @@ module MOM_EOS_UNESCO Sp30 = 1.956415e-6, Sp01 = 6.704388e-3, Sp11 = -1.847318e-4, Sp21 = 2.059331e-7, & Sp032 = 1.480266e-4, SP000 = 2.102898e-4, SP010 = -1.202016e-5, SP020 = 1.394680e-7, & SP001 = -2.040237e-6, SP011 = 6.128773e-8, SP021 = 6.207323e-10 - +!!@} contains !> This subroutine computes the in situ density of sea water (rho in -!! units of kg/m^3) from salinity (S in psu), potential temperature -!! (T in deg C), and pressure in Pa, using the UNESCO (1981) equation of state. +!! [kg m-3]) from salinity (S [PSU]), potential temperature +!! (T [degC]), and pressure [Pa], using the UNESCO (1981) equation of state. subroutine calculate_density_scalar_UNESCO(T, S, pressure, rho, rho_ref) - real, intent(in) :: T !< Potential temperature relative to the surface in C. - real, intent(in) :: S !< Salinity in PSU. - real, intent(in) :: pressure !< Pressure in Pa. - real, intent(out) :: rho !< In situ density in kg m-3. - real, optional, intent(in) :: rho_ref !< A reference density in kg m-3. + real, intent(in) :: T !< Potential temperature relative to the surface [degC]. + real, intent(in) :: S !< Salinity [PSU]. + real, intent(in) :: pressure !< pressure [Pa]. + real, intent(out) :: rho !< In situ density [kg m-3]. + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. + ! Local variables real, dimension(1) :: T0, S0, pressure0 real, dimension(1) :: rho0 @@ -69,34 +77,24 @@ subroutine calculate_density_scalar_UNESCO(T, S, pressure, rho, rho_ref) end subroutine calculate_density_scalar_UNESCO !> This subroutine computes the in situ density of sea water (rho in -!! units of kg/m^3) from salinity (S in psu), potential temperature -!! (T in deg C), and pressure in Pa, using the UNESCO (1981) equation of state. +!! [kg m-3]) from salinity (S [PSU]), potential temperature +!! (T [degC]), and pressure [Pa], using the UNESCO (1981) equation of state. subroutine calculate_density_array_UNESCO(T, S, pressure, rho, start, npts, rho_ref) - real, dimension(:), intent(in) :: T !< potential temperature relative to the surface in C. - real, dimension(:), intent(in) :: S !< salinity in PSU. - real, dimension(:), intent(in) :: pressure !< pressure in Pa. - real, dimension(:), intent(out) :: rho !< in situ density in kg m-3. + real, dimension(:), intent(in) :: T !< potential temperature relative to the surface [degC]. + real, dimension(:), intent(in) :: S !< salinity [PSU]. + real, dimension(:), intent(in) :: pressure !< pressure [Pa]. + real, dimension(:), intent(out) :: rho !< in situ density [kg m-3]. integer, intent(in) :: start !< the starting point in the arrays. integer, intent(in) :: npts !< the number of values to calculate. - real, optional, intent(in) :: rho_ref !< A reference density in kg m-3. - -! * This subroutine computes the in situ density of sea water (rho in * -! * units of kg/m^3) from salinity (S in psu), potential temperature * -! * (T in deg C), and pressure in Pa. * - -! * Arguments: T - potential temperature relative to the surface in C. * -! * (in) S - salinity in PSU. * -! * (in) pressure - pressure in Pa. * -! * (out) rho - in situ density in kg m-3. * -! * (in) start - the starting point in the arrays. * -! * (in) npts - the number of values to calculate. * - - real :: t_local, t2, t3, t4, t5 ! Temperature to the 1st - 5th power. - real :: s_local, s32, s2 ! Salinity to the 1st, 3/2, & 2nd power. - real :: p1, p2 ! Pressure (in bars) to the 1st and 2nd power. - real :: rho0 ! Density at 1 bar pressure, in kg m-3. - real :: sig0 ! The anomaly of rho0 from R00, in kg m-3. - real :: ks ! The secant bulk modulus in bar. + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. + + ! Local variables + real :: t_local, t2, t3, t4, t5 ! Temperature to the 1st - 5th power [degC^n]. + real :: s_local, s32, s2 ! Salinity to the 1st, 3/2, & 2nd power [PSU^n]. + real :: p1, p2 ! Pressure (in bars) to the 1st and 2nd power [bar] and [bar2]. + real :: rho0 ! Density at 1 bar pressure [kg m-3]. + real :: sig0 ! The anomaly of rho0 from R00 [kg m-3]. + real :: ks ! The secant bulk modulus [bar]. integer :: j do j=start,start+npts-1 @@ -133,17 +131,18 @@ subroutine calculate_density_array_UNESCO(T, S, pressure, rho, start, npts, rho_ end subroutine calculate_density_array_UNESCO !> This subroutine computes the in situ specific volume of sea water (specvol in -!! units of m^3/kg) from salinity (S in psu), potential temperature (T in deg C) -!! and pressure in Pa, using the UNESCO (1981) equation of state. +!! [m3 kg-1]) from salinity (S [PSU]), potential temperature (T [degC]) +!! and pressure [Pa], using the UNESCO (1981) equation of state. !! If spv_ref is present, specvol is an anomaly from spv_ref. subroutine calculate_spec_vol_scalar_UNESCO(T, S, pressure, specvol, spv_ref) real, intent(in) :: T !< potential temperature relative to the surface - !! in C. - real, intent(in) :: S !< salinity in PSU. - real, intent(in) :: pressure !< pressure in Pa. - real, intent(out) :: specvol !< in situ specific volume in m3 kg-1. - real, optional, intent(in) :: spv_ref !< A reference specific volume in m3 kg-1. + !! [degC]. + real, intent(in) :: S !< salinity [PSU]. + real, intent(in) :: pressure !< pressure [Pa]. + real, intent(out) :: specvol !< in situ specific volume [m3 kg-1]. + real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. + ! Local variables real, dimension(1) :: T0, S0, pressure0, spv0 T0(1) = T ; S0(1) = S ; pressure0(1) = pressure @@ -153,24 +152,25 @@ subroutine calculate_spec_vol_scalar_UNESCO(T, S, pressure, specvol, spv_ref) end subroutine calculate_spec_vol_scalar_UNESCO !> This subroutine computes the in situ specific volume of sea water (specvol in -!! units of m^3/kg) from salinity (S in psu), potential temperature (T in deg C) -!! and pressure in Pa, using the UNESCO (1981) equation of state. +!! [m3 kg-1]) from salinity (S [PSU]), potential temperature (T [degC]) +!! and pressure [Pa], using the UNESCO (1981) equation of state. !! If spv_ref is present, specvol is an anomaly from spv_ref. subroutine calculate_spec_vol_array_UNESCO(T, S, pressure, specvol, start, npts, spv_ref) real, dimension(:), intent(in) :: T !< potential temperature relative to the surface - !! in C. - real, dimension(:), intent(in) :: S !< salinity in PSU. - real, dimension(:), intent(in) :: pressure !< pressure in Pa. - real, dimension(:), intent(out) :: specvol !< in situ specific volume in m3 kg-1. + !! [degC]. + real, dimension(:), intent(in) :: S !< salinity [PSU]. + real, dimension(:), intent(in) :: pressure !< pressure [Pa]. + real, dimension(:), intent(out) :: specvol !< in situ specific volume [m3 kg-1]. integer, intent(in) :: start !< the starting point in the arrays. integer, intent(in) :: npts !< the number of values to calculate. - real, optional, intent(in) :: spv_ref !< A reference specific volume in m3 kg-1. - - real :: t_local, t2, t3, t4, t5; ! Temperature to the 1st - 5th power. - real :: s_local, s32, s2; ! Salinity to the 1st, 3/2, & 2nd power. - real :: p1, p2; ! Pressure (in bars) to the 1st and 2nd power. - real :: rho0; ! Density at 1 bar pressure, in kg m-3. - real :: ks; ! The secant bulk modulus in bar. + real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. + + ! Local variables + real :: t_local, t2, t3, t4, t5 ! Temperature to the 1st - 5th power [degC^n]. + real :: s_local, s32, s2 ! Salinity to the 1st, 3/2, & 2nd power [PSU^n]. + real :: p1, p2 ! Pressure (in bars) to the 1st and 2nd power [bar] and [bar2]. + real :: rho0 ! Density at 1 bar pressure [kg m-3]. + real :: ks ! The secant bulk modulus [bar]. integer :: j do j=start,start+npts-1 @@ -211,38 +211,27 @@ end subroutine calculate_spec_vol_array_UNESCO !! with potential temperature and salinity. subroutine calculate_density_derivs_UNESCO(T, S, pressure, drho_dT, drho_dS, start, npts) real, intent(in), dimension(:) :: T !< Potential temperature relative to the surface - !! in C. - real, intent(in), dimension(:) :: S !< Salinity in PSU. - real, intent(in), dimension(:) :: pressure !< Pressure in Pa. + !! [degC]. + real, intent(in), dimension(:) :: S !< Salinity [PSU]. + real, intent(in), dimension(:) :: pressure !< Pressure [Pa]. real, intent(out), dimension(:) :: drho_dT !< The partial derivative of density with potential - !! temperature, in kg m-3 K-1. + !! temperature [kg m-3 degC-1]. real, intent(out), dimension(:) :: drho_dS !< The partial derivative of density with salinity, - !! in kg m-3 psu-1. + !! in [kg m-3 PSU-1]. integer, intent(in) :: start !< The starting point in the arrays. integer, intent(in) :: npts !< The number of values to calculate. -! * This subroutine calculates the partial derivatives of density * -! * with potential temperature and salinity. * -! * * -! * Arguments: T - potential temperature relative to the surface in C. * -! * (in) S - salinity in PSU. * -! * (in) pressure - pressure in Pa. * -! * (out) drho_dT - the partial derivative of density with * -! * potential temperature, in kg m-3 K-1. * -! * (out) drho_dS - the partial derivative of density with * -! * salinity, in kg m-3 psu-1. * -! * (in) start - the starting point in the arrays. * -! * (in) npts - the number of values to calculate. * - real :: t_local, t2, t3, t4, t5; ! Temperature to the 1st - 5th power. - real :: s12, s_local, s32, s2; ! Salinity to the 1/2 - 2nd powers. - real :: p1, p2; ! Pressure (in bars) to the 1st & 2nd power. - real :: rho0; ! Density at 1 bar pressure, in kg m-3. - real :: ks; ! The secant bulk modulus, in bar. - real :: drho0_dT; ! Derivative of rho0 with T, in kg m-3 K-1. - real :: drho0_dS; ! Derivative of rho0 with S, kg m-3 psu-1. - real :: dks_dT; ! Derivative of ks with T, in bar K-1. - real :: dks_dS; ! Derivative of ks with S, in bar psu-1. - real :: denom; ! 1.0 / (ks - p1) in bar-1. + ! Local variables + real :: t_local, t2, t3, t4, t5 ! Temperature to the 1st - 5th power [degC^n]. + real :: s12, s_local, s32, s2 ! Salinity to the 1/2 - 2nd powers [PSU^n]. + real :: p1, p2 ! Pressure to the 1st & 2nd power [bar] and [bar2]. + real :: rho0 ! Density at 1 bar pressure [kg m-3]. + real :: ks ! The secant bulk modulus [bar]. + real :: drho0_dT ! Derivative of rho0 with T [kg m-3 degC-1]. + real :: drho0_dS ! Derivative of rho0 with S [kg m-3 PSU-1]. + real :: dks_dT ! Derivative of ks with T [bar degC-1]. + real :: dks_dS ! Derivative of ks with S [bar psu-1]. + real :: denom ! 1.0 / (ks - p1) [bar-1]. integer :: j do j=start,start+npts-1 @@ -293,37 +282,24 @@ end subroutine calculate_density_derivs_UNESCO !! salinity, potential temperature, and pressure. subroutine calculate_compress_UNESCO(T, S, pressure, rho, drho_dp, start, npts) real, intent(in), dimension(:) :: T !< Potential temperature relative to the surface - !! in C. - real, intent(in), dimension(:) :: S !< Salinity in PSU. - real, intent(in), dimension(:) :: pressure !< Pressure in Pa. - real, intent(out), dimension(:) :: rho !< In situ density in kg m-3. + !! [degC]. + real, intent(in), dimension(:) :: S !< Salinity [PSU]. + real, intent(in), dimension(:) :: pressure !< Pressure [Pa]. + real, intent(out), dimension(:) :: rho !< In situ density [kg m-3]. real, intent(out), dimension(:) :: drho_dp !< The partial derivative of density with pressure !! (also the inverse of the square of sound speed) - !! in s2 m-2. + !! [s2 m-2]. integer, intent(in) :: start !< The starting point in the arrays. integer, intent(in) :: npts !< The number of values to calculate. -! * This subroutine computes the in situ density of sea water (rho) * -! * and the compressibility (drho/dp == C_sound^-2) at the given * -! * salinity, potential temperature, and pressure. * -! * * -! * Arguments: T - potential temperature relative to the surface in C. * -! * (in) S - salinity in PSU. * -! * (in) pressure - pressure in Pa. * -! * (out) rho - in situ density in kg m-3. * -! * (out) drho_dp - the partial derivative of density with * -! * pressure (also the inverse of the square of * -! * sound speed) in s2 m-2. * -! * (in) start - the starting point in the arrays. * -! * (in) npts - the number of values to calculate. * - - real :: t_local, t2, t3, t4, t5; ! Temperature to the 1st - 5th power. - real :: s_local, s32, s2; ! Salinity to the 1st, 3/2, & 2nd power. - real :: p1, p2; ! Pressure (in bars) to the 1st and 2nd power. - real :: rho0; ! Density at 1 bar pressure, in kg m-3. - real :: ks; ! The secant bulk modulus in bar. + ! Local variables + real :: t_local, t2, t3, t4, t5 ! Temperature to the 1st - 5th power [degC^n]. + real :: s_local, s32, s2 ! Salinity to the 1st, 3/2, & 2nd power [PSU^n]. + real :: p1, p2 ! Pressure to the 1st & 2nd power [bar] and [bar2]. + real :: rho0 ! Density at 1 bar pressure [kg m-3]. + real :: ks ! The secant bulk modulus [bar]. real :: ks_0, ks_1, ks_2 - real :: dks_dp; ! The derivative of the secant bulk modulus + real :: dks_dp ! The derivative of the secant bulk modulus ! with pressure, nondimensional. integer :: j diff --git a/src/equation_of_state/MOM_EOS_Wright.F90 b/src/equation_of_state/MOM_EOS_Wright.F90 index ad1908adb5..899f32b27d 100644 --- a/src/equation_of_state/MOM_EOS_Wright.F90 +++ b/src/equation_of_state/MOM_EOS_Wright.F90 @@ -1,3 +1,4 @@ +!> The equation of state using the Wright 1997 expressions module MOM_EOS_Wright ! This file is part of MOM6. See LICENSE.md for the license. @@ -19,22 +20,38 @@ module MOM_EOS_Wright public calculate_density_second_derivs_wright public int_density_dz_wright, int_spec_vol_dp_wright +! 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. + + +!> Compute the in situ density of sea water (in [kg m-3]), or its anomaly with respect to +!! a reference density, from salinity (in psu), potential temperature (in deg C), and pressure [Pa], +!! using the expressions from Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. interface calculate_density_wright module procedure calculate_density_scalar_wright, calculate_density_array_wright end interface calculate_density_wright +!> Compute the in situ specific volume of sea water (in [m3 kg-1]), or an anomaly with respect +!! to a reference specific volume, from salinity (in psu), potential temperature (in deg C), and +!! pressure [Pa], using the expressions from Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. interface calculate_spec_vol_wright module procedure calculate_spec_vol_scalar_wright, calculate_spec_vol_array_wright end interface calculate_spec_vol_wright +!> For a given thermodynamic state, return the derivatives of density with temperature and salinity interface calculate_density_derivs_wright module procedure calculate_density_derivs_scalar_wright, calculate_density_derivs_array_wright end interface +!> For a given thermodynamic state, return the second derivatives of density with various combinations +!! of temperature, salinity, and pressure interface calculate_density_second_derivs_wright module procedure calculate_density_second_derivs_scalar_wright, calculate_density_second_derivs_array_wright end interface +!>@{ Parameters in the Wright equation of state !real :: a0, a1, a2, b0, b1, b2, b3, b4, b5, c0, c1, c2, c3, c4, c5 ! One of the two following blocks of values should be commented out. ! Following are the values for the full range formula. @@ -52,24 +69,25 @@ module MOM_EOS_Wright real, parameter :: b3 = 2.084372e2, b4 = 5.944068e5, b5 = -9.643486e3 real, parameter :: c0 = 1.704853e5, c1 = 7.904722e2, c2 = -7.984422 ! c0/c1 ~= 216 ; c0/c4 ~= -740 real, parameter :: c3 = 5.140652e-2, c4 = -2.302158e2, c5 = -3.079464 +!!@} contains !> This subroutine computes the in situ density of sea water (rho in -!! units of kg/m^3) from salinity (S in psu), potential temperature -!! (T in deg C), and pressure in Pa. It uses the expression from +!! [kg m-3]) from salinity (S [PSU]), potential temperature +!! (T [degC]), and pressure [Pa]. It uses the expression from !! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. subroutine calculate_density_scalar_wright(T, S, pressure, rho, rho_ref) - real, intent(in) :: T !< Potential temperature relative to the surface in C. - real, intent(in) :: S !< Salinity in PSU. - real, intent(in) :: pressure !< Pressure in Pa. - real, intent(out) :: rho !< In situ density in kg m-3. - real, optional, intent(in) :: rho_ref !< A reference density in kg m-3. + real, intent(in) :: T !< Potential temperature relative to the surface [degC]. + real, intent(in) :: S !< Salinity [PSU]. + real, intent(in) :: pressure !< pressure [Pa]. + real, intent(out) :: rho !< In situ density [kg m-3]. + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. ! *====================================================================* ! * This subroutine computes the in situ density of sea water (rho in * -! * units of kg/m^3) from salinity (S in psu), potential temperature * -! * (T in deg C), and pressure in Pa. It uses the expression from * +! * [kg m-3]) from salinity (S [PSU]), potential temperature * +! * (T [degC]), and pressure [Pa]. It uses the expression from * ! * Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. * ! * Coded by R. Hallberg, 7/00 * ! *====================================================================* @@ -86,19 +104,20 @@ subroutine calculate_density_scalar_wright(T, S, pressure, rho, rho_ref) end subroutine calculate_density_scalar_wright !> This subroutine computes the in situ density of sea water (rho in -!! units of kg/m^3) from salinity (S in psu), potential temperature -!! (T in deg C), and pressure in Pa. It uses the expression from +!! [kg m-3]) from salinity (S [PSU]), potential temperature +!! (T [degC]), and pressure [Pa]. It uses the expression from !! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. subroutine calculate_density_array_wright(T, S, pressure, rho, start, npts, rho_ref) - real, dimension(:), intent(in) :: T !< potential temperature relative to the surface in C. - real, dimension(:), intent(in) :: S !< salinity in PSU. - real, dimension(:), intent(in) :: pressure !< pressure in Pa. - real, dimension(:), intent(out) :: rho !< in situ density in kg m-3. + real, dimension(:), intent(in) :: T !< potential temperature relative to the surface [degC]. + real, dimension(:), intent(in) :: S !< salinity [PSU]. + real, dimension(:), intent(in) :: pressure !< pressure [Pa]. + real, dimension(:), intent(out) :: rho !< in situ density [kg m-3]. integer, intent(in) :: start !< the starting point in the arrays. integer, intent(in) :: npts !< the number of values to calculate. - real, optional, intent(in) :: rho_ref !< A reference density in kg m-3. + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. ! Original coded by R. Hallberg, 7/00, anomaly coded in 3/18. + ! Local variables real :: al0, p0, lambda real :: al_TS, p_TSp, lam_TS, pa_000 integer :: j @@ -124,17 +143,18 @@ subroutine calculate_density_array_wright(T, S, pressure, rho, start, npts, rho_ end subroutine calculate_density_array_wright !> This subroutine computes the in situ specific volume of sea water (specvol in -!! units of m^3/kg) from salinity (S in psu), potential temperature (T in deg C) -!! and pressure in Pa. It uses the expression from +!! [m3 kg-1]) from salinity (S [PSU]), potential temperature (T [degC]) +!! and pressure [Pa]. It uses the expression from !! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. !! If spv_ref is present, specvol is an anomaly from spv_ref. subroutine calculate_spec_vol_scalar_wright(T, S, pressure, specvol, spv_ref) - real, intent(in) :: T !< potential temperature relative to the surface in C. - real, intent(in) :: S !< salinity in PSU. - real, intent(in) :: pressure !< pressure in Pa. - real, intent(out) :: specvol !< in situ specific volume in m3 kg-1. - real, optional, intent(in) :: spv_ref !< A reference specific volume in m3 kg-1. + real, intent(in) :: T !< potential temperature relative to the surface [degC]. + real, intent(in) :: S !< salinity [PSU]. + real, intent(in) :: pressure !< pressure [Pa]. + real, intent(out) :: specvol !< in situ specific volume [m3 kg-1]. + real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. + ! Local variables real, dimension(1) :: T0, S0, pressure0, spv0 T0(1) = T ; S0(1) = S ; pressure0(1) = pressure @@ -144,20 +164,21 @@ subroutine calculate_spec_vol_scalar_wright(T, S, pressure, specvol, spv_ref) end subroutine calculate_spec_vol_scalar_wright !> This subroutine computes the in situ specific volume of sea water (specvol in -!! units of m^3/kg) from salinity (S in psu), potential temperature (T in deg C) -!! and pressure in Pa. It uses the expression from +!! [m3 kg-1]) from salinity (S [PSU]), potential temperature (T [degC]) +!! and pressure [Pa]. It uses the expression from !! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. !! If spv_ref is present, specvol is an anomaly from spv_ref. subroutine calculate_spec_vol_array_wright(T, S, pressure, specvol, start, npts, spv_ref) - real, dimension(:), intent(in) :: T !< potential temperature relative to the surface - !! in C. - real, dimension(:), intent(in) :: S !< salinity in PSU. - real, dimension(:), intent(in) :: pressure !< pressure in Pa. - real, dimension(:), intent(out) :: specvol !< in situ specific volume in m3 kg-1. + real, dimension(:), intent(in) :: T !< potential temperature relative to the + !! surface [degC]. + real, dimension(:), intent(in) :: S !< salinity [PSU]. + real, dimension(:), intent(in) :: pressure !< pressure [Pa]. + real, dimension(:), intent(out) :: specvol !< in situ specific volume [m3 kg-1]. integer, intent(in) :: start !< the starting point in the arrays. integer, intent(in) :: npts !< the number of values to calculate. - real, optional, intent(in) :: spv_ref !< A reference specific volume in m3 kg-1. + real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. + ! Local variables real :: al0, p0, lambda integer :: j @@ -176,26 +197,18 @@ end subroutine calculate_spec_vol_array_wright !> For a given thermodynamic state, return the thermal/haline expansion coefficients subroutine calculate_density_derivs_array_wright(T, S, pressure, drho_dT, drho_dS, start, npts) - real, intent(in), dimension(:) :: T !< Potential temperature relative to the surface - !! in C. - real, intent(in), dimension(:) :: S !< Salinity in PSU. - real, intent(in), dimension(:) :: pressure !< Pressure in Pa. + real, intent(in), dimension(:) :: T !< Potential temperature relative to the + !! surface [degC]. + real, intent(in), dimension(:) :: S !< Salinity [PSU]. + real, intent(in), dimension(:) :: pressure !< pressure [Pa]. real, intent(out), dimension(:) :: drho_dT !< The partial derivative of density with potential - !! temperature, in kg m-3 K-1. + !! temperature [kg m-3 degC-1]. real, intent(out), dimension(:) :: drho_dS !< The partial derivative of density with salinity, - !! in kg m-3 psu-1. + !! in [kg m-3 PSU-1]. integer, intent(in) :: start !< The starting point in the arrays. integer, intent(in) :: npts !< The number of values to calculate. -! * Arguments: T - potential temperature relative to the surface in C. * -! * (in) S - salinity in PSU. * -! * (in) pressure - pressure in Pa. * -! * (out) drho_dT - the partial derivative of density with * -! * potential temperature, in kg m-3 K-1. * -! * (out) drho_dS - the partial derivative of density with * -! * salinity, in kg m-3 psu-1. * -! * (in) start - the starting point in the arrays. * -! * (in) npts - the number of values to calculate. * + ! Local variables real :: al0, p0, lambda, I_denom2 integer :: j @@ -219,14 +232,13 @@ end subroutine calculate_density_derivs_array_wright !> The scalar version of calculate_density_derivs which promotes scalar inputs to a 1-element array and then !! demotes the output back to a scalar subroutine calculate_density_derivs_scalar_wright(T, S, pressure, drho_dT, drho_dS) - real, intent(in) :: T !< Potential temperature relative to the surface - !! in C. - real, intent(in) :: S !< Salinity in PSU. - real, intent(in) :: pressure !< Pressure in Pa. + real, intent(in) :: T !< Potential temperature relative to the surface [degC]. + real, intent(in) :: S !< Salinity [PSU]. + real, intent(in) :: pressure !< pressure [Pa]. real, intent(out) :: drho_dT !< The partial derivative of density with potential - !! temperature, in kg m-3 K-1. + !! temperature [kg m-3 degC-1]. real, intent(out) :: drho_dS !< The partial derivative of density with salinity, - !! in kg m-3 psu-1. + !! in [kg m-3 PSU-1]. ! Local variables needed to promote the input/output scalars to 1-element arrays real, dimension(1) :: T0, S0, P0 @@ -244,21 +256,27 @@ end subroutine calculate_density_derivs_scalar_wright !> Second derivatives of density with respect to temperature, salinity, and pressure subroutine calculate_density_second_derivs_array_wright(T, S, P, drho_ds_ds, drho_ds_dt, drho_dt_dt, & drho_ds_dp, drho_dt_dp, start, npts) - real, dimension(:), intent(in ) :: T !< Potential temperature referenced to 0 dbar - real, dimension(:), intent(in ) :: S !< Salinity in PSU - real, dimension(:), intent(in ) :: P !< Pressure in Pa - real, dimension(:), intent( out) :: drho_ds_ds !< Partial derivative of beta with respect to S - real, dimension(:), intent( out) :: drho_ds_dt !< Partial derivative of beta with resepct to T - real, dimension(:), intent( out) :: drho_dt_dt !< Partial derivative of alpha with respect to T - real, dimension(:), intent( out) :: drho_ds_dp !< Partial derivative of beta with respect to pressure - real, dimension(:), intent( out) :: drho_dt_dp !< Partial derivative of alpha with respect to pressure + real, dimension(:), intent(in ) :: T !< Potential temperature referenced to 0 dbar [degC] + real, dimension(:), intent(in ) :: S !< Salinity [PSU] + real, dimension(:), intent(in ) :: P !< Pressure [Pa] + real, dimension(:), intent( out) :: drho_ds_ds !< Partial derivative of beta with respect + !! to S [kg m-3 PSU-2] + real, dimension(:), intent( out) :: drho_ds_dt !< Partial derivative of beta with respcct + !! to T [kg m-3 PSU-1 degC-1] + real, dimension(:), intent( out) :: drho_dt_dt !< Partial derivative of alpha with respect + !! to T [kg m-3 degC-2] + real, dimension(:), intent( out) :: drho_ds_dp !< Partial derivative of beta with respect + !! to pressure [kg m-3 PSU-1 Pa-1] + real, dimension(:), intent( out) :: drho_dt_dp !< Partial derivative of alpha with respect + !! to pressure [kg m-3 degC-1 Pa-1] integer, intent(in ) :: start !< Starting index in T,S,P integer, intent(in ) :: npts !< Number of points to loop over + ! Local variables + real :: z0, z1, z2, z3, z4, z5, z6 ,z7, z8, z9, z10, z11, z2_2, z2_3 integer :: j ! Based on the above expression with common terms factored, there probably exists a more numerically stable ! and/or efficient expression - real :: z0, z1, z2, z3, z4, z5, z6 ,z7, z8, z9, z10, z11, z2_2, z2_3 do j = start,start+npts-1 z0 = T(j)*(b1 + b5*S(j) + T(j)*(b2 + b3*T(j))) @@ -291,13 +309,18 @@ end subroutine calculate_density_second_derivs_array_wright subroutine calculate_density_second_derivs_scalar_wright(T, S, P, drho_ds_ds, drho_ds_dt, drho_dt_dt, & drho_ds_dp, drho_dt_dp) real, intent(in ) :: T !< Potential temperature referenced to 0 dbar - real, intent(in ) :: S !< Salinity in PSU - real, intent(in ) :: P !< Pressure in Pa - real, intent( out) :: drho_ds_ds !< Partial derivative of beta with respect to S - real, intent( out) :: drho_ds_dt !< Partial derivative of beta with resepct to T - real, intent( out) :: drho_dt_dt !< Partial derivative of alpha with respect to T - real, intent( out) :: drho_ds_dp !< Partial derivative of beta with respect to pressure - real, intent( out) :: drho_dt_dp !< Partial derivative of alpha with respect to pressure + real, intent(in ) :: S !< Salinity [PSU] + real, intent(in ) :: P !< pressure [Pa] + real, intent( out) :: drho_ds_ds !< Partial derivative of beta with respect + !! to S [kg m-3 PSU-2] + real, intent( out) :: drho_ds_dt !< Partial derivative of beta with respcct + !! to T [kg m-3 PSU-1 degC-1] + real, intent( out) :: drho_dt_dt !< Partial derivative of alpha with respect + !! to T [kg m-3 degC-2] + real, intent( out) :: drho_ds_dp !< Partial derivative of beta with respect + !! to pressure [kg m-3 PSU-1 Pa-1] + real, intent( out) :: drho_dt_dp !< Partial derivative of alpha with respect + !! to pressure [kg m-3 degC-1 Pa-1] ! Local variables real, dimension(1) :: T0, S0, P0 real, dimension(1) :: drdsds, drdsdt, drdtdt, drdsdp, drdtdp @@ -314,27 +337,20 @@ subroutine calculate_density_second_derivs_scalar_wright(T, S, P, drho_ds_ds, dr end subroutine calculate_density_second_derivs_scalar_wright +!> For a given thermodynamic state, return the partial derivatives of specific volume +!! with temperature and salinity subroutine calculate_specvol_derivs_wright(T, S, pressure, dSV_dT, dSV_dS, start, npts) - real, intent(in), dimension(:) :: T !< Potential temperature relative to the surface - !! in C. - real, intent(in), dimension(:) :: S !< Salinity in g/kg. - real, intent(in), dimension(:) :: pressure !< Pressure in Pa. + real, intent(in), dimension(:) :: T !< Potential temperature relative to the surface [degC]. + real, intent(in), dimension(:) :: S !< Salinity [PSU]. + real, intent(in), dimension(:) :: pressure !< pressure [Pa]. real, intent(out), dimension(:) :: dSV_dT !< The partial derivative of specific volume with - !! potential temperature, in m3 kg-1 K-1. + !! potential temperature [m3 kg-1 degC-1]. real, intent(out), dimension(:) :: dSV_dS !< The partial derivative of specific volume with - !! salinity, in m3 kg-1 / (g/kg). + !! salinity [m3 kg-1 / Pa]. integer, intent(in) :: start !< The starting point in the arrays. integer, intent(in) :: npts !< The number of values to calculate. -! * Arguments: T - potential temperature relative to the surface in C. * -! * (in) S - salinity in g/kg. * -! * (in) pressure - pressure in Pa. * -! * (out) dSV_dT - the partial derivative of specific volume with * -! * potential temperature, in m3 kg-1 K-1. * -! * (out) dSV_dS - the partial derivative of specific volume with * -! * salinity, in m3 kg-1 / (g/kg). * -! * (in) start - the starting point in the arrays. * -! * (in) npts - the number of values to calculate. * + ! Local variables real :: al0, p0, lambda, I_denom integer :: j @@ -355,40 +371,24 @@ subroutine calculate_specvol_derivs_wright(T, S, pressure, dSV_dT, dSV_dS, start end subroutine calculate_specvol_derivs_wright !> This subroutine computes the in situ density of sea water (rho in -!! units of kg/m^3) and the compressibility (drho/dp = C_sound^-2) -!! (drho_dp in units of s2 m-2) from salinity (sal in psu), potential -!! temperature (T in deg C), and pressure in Pa. It uses the expressions +!! [kg m-3]) and the compressibility (drho/dp = C_sound^-2) +!! (drho_dp [s2 m-2]) from salinity (sal in psu), potential +!! temperature (T [degC]), and pressure [Pa]. It uses the expressions !! from Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. !! Coded by R. Hallberg, 1/01 subroutine calculate_compress_wright(T, S, pressure, rho, drho_dp, start, npts) - real, intent(in), dimension(:) :: T !< Potential temperature relative to the surface - !! in C. - real, intent(in), dimension(:) :: S !< Salinity in PSU. - real, intent(in), dimension(:) :: pressure !< Pressure in Pa. - real, intent(out), dimension(:) :: rho !< In situ density in kg m-3. + real, intent(in), dimension(:) :: T !< Potential temperature relative to the surface [degC]. + real, intent(in), dimension(:) :: S !< Salinity [PSU]. + real, intent(in), dimension(:) :: pressure !< pressure [Pa]. + real, intent(out), dimension(:) :: rho !< In situ density [kg m-3]. real, intent(out), dimension(:) :: drho_dp !< The partial derivative of density with pressure !! (also the inverse of the square of sound speed) - !! in s2 m-2. + !! [s2 m-2]. integer, intent(in) :: start !< The starting point in the arrays. integer, intent(in) :: npts !< The number of values to calculate. -! * Arguments: T - potential temperature relative to the surface in C. * -! * (in) S - salinity in PSU. * -! * (in) pressure - pressure in Pa. * -! * (out) rho - in situ density in kg m-3. * -! * (out) drho_dp - the partial derivative of density with * -! * pressure (also the inverse of the square of * -! * sound speed) in s2 m-2. * -! * (in) start - the starting point in the arrays. * -! * (in) npts - the number of values to calculate. * -! *====================================================================* -! * This subroutine computes the in situ density of sea water (rho in * -! * units of kg/m^3) and the compressibility (drho/dp = C_sound^-2) * -! * (drho_dp in units of s2 m-2) from salinity (sal in psu), potential* -! * temperature (T in deg C), and pressure in Pa. It uses the expres-* -! * sions from Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. * -! * Coded by R. Hallberg, 1/01 * -! *====================================================================* + ! Coded by R. Hallberg, 1/01 + ! Local variables real :: al0, p0, lambda, I_denom integer :: j @@ -409,61 +409,62 @@ end subroutine calculate_compress_wright subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, & dpa, intz_dpa, intx_dpa, inty_dpa, & bathyT, dz_neglect, useMassWghtInterp) - type(hor_index_type), intent(in) :: HII, HIO + type(hor_index_type), intent(in) :: HII !< The horizontal index type for the input arrays. + type(hor_index_type), intent(in) :: HIO !< The horizontal index type for the output arrays. real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & intent(in) :: T !< Potential temperature relative to the surface - !! in C. + !! [degC]. real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: S !< Salinity in PSU. + intent(in) :: S !< Salinity [PSU]. real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: z_t !< Height at the top of the layer in m. + intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m]. real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: z_b !< Height at the top of the layer in m. - real, intent(in) :: rho_ref !< A mean density, in kg m-3, that is subtracted out + intent(in) :: z_b !< Height at the top of the layer [Z ~> m]. + real, intent(in) :: rho_ref !< A mean density [kg m-3], that is subtracted out !! to reduce the magnitude of each of the integrals. !! (The pressure is calucated as p~=-z*rho_0*G_e.) - real, intent(in) :: rho_0 !< Density, in kg m-3, that is used to calculate the + real, intent(in) :: rho_0 !< Density [kg m-3], that is used to calculate the !! pressure (as p~=-z*rho_0*G_e) used in the !! equation of state. - real, intent(in) :: G_e !< The Earth's gravitational acceleration, in m s-2. + real, intent(in) :: G_e !< The Earth's gravitational acceleration [m2 Z-1 s-2 ~> m s-2]. real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & intent(out) :: dpa !< The change in the pressure anomaly across the - !! layer, in Pa. + !! layer [Pa]. real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & optional, intent(out) :: intz_dpa !< The integral through the thickness of the layer !! of the pressure anomaly relative to the anomaly - !! at the top of the layer, in Pa m. + !! at the top of the layer [Pa Z ~> Pa m]. real, dimension(HIO%IsdB:HIO%IedB,HIO%jsd:HIO%jed), & optional, intent(out) :: intx_dpa !< The integral in x of the difference between the !! pressure anomaly at the top and bottom of the - !! layer divided by the x grid spacing, in Pa. + !! layer divided by the x grid spacing [Pa]. real, dimension(HIO%isd:HIO%ied,HIO%JsdB:HIO%JedB), & optional, intent(out) :: inty_dpa !< The integral in y of the difference between the !! pressure anomaly at the top and bottom of the - !! layer divided by the y grid spacing, in Pa. + !! layer divided by the y grid spacing [Pa]. real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - optional, intent(in) :: bathyT !< The depth of the bathymetry in m - real, optional, intent(in) :: dz_neglect !< A miniscule thickness change with the - !! same units as z_t + optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m]. + real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m]. logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to - !! interpolate T/S for top and bottom integrals. + !! interpolate T/S for top and bottom integrals. + ! Local variables real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed) :: al0_2d, p0_2d, lambda_2d real :: al0, p0, lambda - real :: rho_anom ! The density anomaly from rho_ref, in kg m-3. + real :: rho_anom ! The density anomaly from rho_ref [kg m-3]. real :: eps, eps2, rem real :: GxRho, I_Rho real :: p_ave, I_al0, I_Lzz - real :: dz ! The layer thickness, in m. - real :: hWght ! A pressure-thickness below topography, in m. - real :: hL, hR ! Pressure-thicknesses of the columns to the left and right, in m. - real :: iDenom ! The inverse of the denominator in the wieghts, in m-2. - real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column, nonDim. - real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column, nonDim. - real :: wt_L, wt_R ! The linear wieghts of the left and right columns, nonDim. - real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns, nonDim. + real :: dz ! The layer thickness [Z ~> m]. + real :: hWght ! A pressure-thickness below topography [Z ~> m]. + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [Z ~> m]. + real :: iDenom ! The inverse of the denominator in the weights [Z-2 ~> m-2]. + real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column [nondim]. + real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column [nondim]. + real :: wt_L, wt_R ! The linear weights of the left and right columns [nondim]. + real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim]. real :: intz(5) ! The integrals of density with height at the - ! 5 sub-column locations, in m2 s-2. + ! 5 sub-column locations [Pa]. logical :: do_massWeight ! Indicates whether to do mass weighting. real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0 ! Rational constants. real, parameter :: C1_9 = 1.0/9.0, C1_90 = 1.0/90.0 ! Rational constants. @@ -613,68 +614,60 @@ end subroutine int_density_dz_wright subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, & intp_dza, intx_dza, inty_dza, halo_size, & bathyP, dP_neglect, useMassWghtInterp) - type(hor_index_type), intent(in) :: HI + type(hor_index_type), intent(in) :: HI !< The ocean's horizontal index type. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T !< Potential temperature relative to the surface - !! in C. + !! [degC]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: S !< Salinity in PSU. + intent(in) :: S !< Salinity [PSU]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_t !< Pressure at the top of the layer in Pa. + intent(in) :: p_t !< Pressure at the top of the layer [Pa]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_b !< Pressure at the top of the layer in Pa. + intent(in) :: p_b !< Pressure at the top of the layer [Pa]. real, intent(in) :: spv_ref !< A mean specific volume that is subtracted out - !! to reduce the magnitude of each of the integrals, m3 kg-1.The calculation is + !! to reduce the magnitude of each of the integrals [m3 kg-1]. The calculation is !! mathematically identical with different values of spv_ref, but this reduces the !! effects of roundoff. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(out) :: dza !< The change in the geopotential anomaly across - !! the layer, in m2 s-2. + !! the layer [m2 s-2]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(out) :: intp_dza !< The integral in pressure through the layer of !! the geopotential anomaly relative to the anomaly - !! at the bottom of the layer, in Pa m2 s-2. + !! at the bottom of the layer [Pa m2 s-2]. real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & optional, intent(out) :: intx_dza !< The integral in x of the difference between the !! geopotential anomaly at the top and bottom of - !! the layer divided by the x grid spacing, - !! in m2 s-2. + !! the layer divided by the x grid spacing [m2 s-2]. real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & optional, intent(out) :: inty_dza !< The integral in y of the difference between the !! geopotential anomaly at the top and bottom of - !! the layer divided by the y grid spacing, - !! in m2 s-2. + !! the layer divided by the y grid spacing [m2 s-2]. integer, optional, intent(in) :: halo_size !< The width of halo points on which to calculate !! dza. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - optional, intent(in) :: bathyP !< The pressure at the bathymetry in Pa + optional, intent(in) :: bathyP !< The pressure at the bathymetry [Pa] real, optional, intent(in) :: dP_neglect !< A miniscule pressure change with - !! the same units as p_t (Pa?) + !! the same units as p_t [Pa] logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting !! to interpolate T/S for top and bottom integrals. -! This subroutine calculates analytical and nearly-analytical integrals in -! pressure across layers of geopotential anomalies, which are required for -! calculating the finite-volume form pressure accelerations in a non-Boussinesq -! model. There are essentially no free assumptions, apart from the use of -! Bode's rule to do the horizontal integrals, and from a truncation in the -! series for log(1-eps/1+eps) that assumes that |eps| < 0.34. - + ! Local variables real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: al0_2d, p0_2d, lambda_2d real :: al0, p0, lambda real :: p_ave real :: rem, eps, eps2 - real :: alpha_anom ! The depth averaged specific density anomaly in m3 kg-1. - real :: dp ! The pressure change through a layer, in Pa. - real :: hWght ! A pressure-thickness below topography, in Pa. - real :: hL, hR ! Pressure-thicknesses of the columns to the left and right, in Pa. - real :: iDenom ! The inverse of the denominator in the wieghts, in Pa-2. - real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column, nonDim. - real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column, nonDim. - real :: wt_L, wt_R ! The linear wieghts of the left and right columns, nonDim. - real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns, nonDim. + real :: alpha_anom ! The depth averaged specific volume anomaly [m3 kg-1]. + real :: dp ! The pressure change through a layer [Pa]. + real :: hWght ! A pressure-thickness below topography [Pa]. + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [Pa]. + real :: iDenom ! The inverse of the denominator in the weights [Pa-2]. + real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column [nondim]. + real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column [nondim]. + real :: wt_L, wt_R ! The linear weights of the left and right columns [nondim]. + real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim]. real :: intp(5) ! The integrals of specific volume with pressure at the - ! 5 sub-column locations, in m2 s-2. + ! 5 sub-column locations [m2 s-2]. logical :: do_massWeight ! Indicates whether to do mass weighting. real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0 ! Rational constants. real, parameter :: C1_9 = 1.0/9.0, C1_90 = 1.0/90.0 ! Rational constants. diff --git a/src/equation_of_state/MOM_EOS_linear.F90 b/src/equation_of_state/MOM_EOS_linear.F90 index 5ad35134ba..55b3835681 100644 --- a/src/equation_of_state/MOM_EOS_linear.F90 +++ b/src/equation_of_state/MOM_EOS_linear.F90 @@ -1,12 +1,8 @@ +!> A simple linear equation of state for sea water with constant coefficients module MOM_EOS_linear ! This file is part of MOM6. See LICENSE.md for the license. -!*********************************************************************** -!* The subroutines in this file implement a simple linear equation of * -!* state for sea water with constant coefficients set as parameters. * -!*********************************************************************** - use MOM_hor_index, only : hor_index_type implicit none ; private @@ -20,18 +16,34 @@ module MOM_EOS_linear public calculate_density_second_derivs_linear public int_density_dz_linear, int_spec_vol_dp_linear +! 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. + +!> Compute the density of sea water (in kg/m^3), or its anomaly from a reference density, +!! using a simple linear equation of state from salinity (in psu), potential temperature (in deg C) +!! and pressure [Pa]. interface calculate_density_linear module procedure calculate_density_scalar_linear, calculate_density_array_linear end interface calculate_density_linear +!> Compute the specific volume of sea water (in m^3/kg), or its anomaly from a reference value, +!! using a simple linear equation of state from salinity (in psu), potential temperature (in deg C) +!! and pressure [Pa]. interface calculate_spec_vol_linear module procedure calculate_spec_vol_scalar_linear, calculate_spec_vol_array_linear end interface calculate_spec_vol_linear +!> For a given thermodynamic state, return the derivatives of density with temperature and +!! salinity using the simple linear equation of state interface calculate_density_derivs_linear module procedure calculate_density_derivs_scalar_linear, calculate_density_derivs_array_linear end interface calculate_density_derivs_linear +!> For a given thermodynamic state, return the second derivatives of density with various +!! combinations of temperature, salinity, and pressure. Note that with a simple linear +!! equation of state these second derivatives are all 0. interface calculate_density_second_derivs_linear module procedure calculate_density_second_derivs_scalar_linear, calculate_density_second_derivs_array_linear end interface calculate_density_second_derivs_linear @@ -39,34 +51,20 @@ module MOM_EOS_linear contains !> This subroutine computes the density of sea water with a trivial -!! linear equation of state (in kg/m^3) from salinity (sal in psu), -!! potential temperature (T in deg C), and pressure in Pa. +!! linear equation of state (in [kg m-3]) from salinity (sal [PSU]), +!! potential temperature (T [degC]), and pressure [Pa]. subroutine calculate_density_scalar_linear(T, S, pressure, rho, & Rho_T0_S0, dRho_dT, dRho_dS, rho_ref) - real, intent(in) :: T !< Potential temperature relative to the surface in C. - real, intent(in) :: S !< Salinity in PSU. - real, intent(in) :: pressure !< Pressure in Pa. - real, intent(out) :: rho !< In situ density in kg m-3. - real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0, in kg m-3. + real, intent(in) :: T !< Potential temperature relative to the surface [degC]. + real, intent(in) :: S !< Salinity [PSU]. + real, intent(in) :: pressure !< pressure [Pa]. + real, intent(out) :: rho !< In situ density [kg m-3]. + real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0 [kg m-3]. real, intent(in) :: dRho_dT !< The derivatives of density with temperature - !! in kg m-3 C-1. + !! [kg m-3 degC-1]. real, intent(in) :: dRho_dS !< The derivatives of density with salinity - !! in kg m-3 psu-1. - real, optional, intent(in) :: rho_ref !< A reference density in kg m-3. - -! * This subroutine computes the density of sea water with a trivial * -! * linear equation of state (in kg/m^3) from salinity (sal in psu), * -! * potential temperature (T in deg C), and pressure in Pa. * -! * * -! * Arguments: T - potential temperature relative to the surface in C. * -! * (in) S - salinity in PSU. * -! * (in) pressure - pressure in Pa. * -! * (out) rho - in situ density in kg m-3. * -! * (in) start - the starting point in the arrays. * -! * (in) npts - the number of values to calculate. * -! * (in) Rho_T0_S0 - The density at T=0, S=0, in kg m-3. * -! * (in) dRho_dT - The derivatives of density with temperature * -! * (in) dRho_dS - and salinity, in kg m-3 C-1 and kg m-3 psu-1. * + !! in [kg m-3 ppt-1]. + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. if (present(rho_ref)) then rho = (Rho_T0_S0 - rho_ref) + (dRho_dT*T + dRho_dS*S) @@ -78,22 +76,22 @@ end subroutine calculate_density_scalar_linear !> This subroutine computes the density of sea water with a trivial !! linear equation of state (in kg/m^3) from salinity (sal in psu), -!! potential temperature (T in deg C), and pressure in Pa. +!! potential temperature (T [degC]), and pressure [Pa]. subroutine calculate_density_array_linear(T, S, pressure, rho, start, npts, & Rho_T0_S0, dRho_dT, dRho_dS, rho_ref) - real, dimension(:), intent(in) :: T !< potential temperature relative to the surface in C. - real, dimension(:), intent(in) :: S !< salinity in PSU. - real, dimension(:), intent(in) :: pressure !< pressure in Pa. - real, dimension(:), intent(out) :: rho !< in situ density in kg m-3. + real, dimension(:), intent(in) :: T !< potential temperature relative to the surface [degC]. + real, dimension(:), intent(in) :: S !< salinity [PSU]. + real, dimension(:), intent(in) :: pressure !< pressure [Pa]. + real, dimension(:), intent(out) :: rho !< in situ density [kg m-3]. integer, intent(in) :: start !< the starting point in the arrays. integer, intent(in) :: npts !< the number of values to calculate. - real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0, in kg m-3. + real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0 [kg m-3]. real, intent(in) :: dRho_dT !< The derivatives of density with temperature - !! in kg m-3 C-1. + !! [kg m-3 degC-1]. real, intent(in) :: dRho_dS !< The derivatives of density with salinity - !! in kg m-3 psu-1. - real, optional, intent(in) :: rho_ref !< A reference density in kg m-3. - + !! in [kg m-3 ppt-1]. + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. + ! Local variables integer :: j if (present(rho_ref)) then ; do j=start,start+npts-1 @@ -105,22 +103,21 @@ subroutine calculate_density_array_linear(T, S, pressure, rho, start, npts, & end subroutine calculate_density_array_linear !> This subroutine computes the in situ specific volume of sea water (specvol in -!! units of m^3/kg) from salinity (S in psu), potential temperature (T in deg C) -!! and pressure in Pa, using a trivial linear equation of state for density. +!! [m3 kg-1]) from salinity (S [PSU]), potential temperature (T [degC]) +!! and pressure [Pa], using a trivial linear equation of state for density. !! If spv_ref is present, specvol is an anomaly from spv_ref. subroutine calculate_spec_vol_scalar_linear(T, S, pressure, specvol, & Rho_T0_S0, dRho_dT, dRho_dS, spv_ref) real, intent(in) :: T !< potential temperature relative to the surface - !! in C. - real, intent(in) :: S !< salinity in PSU. - real, intent(in) :: pressure !< pressure in Pa. - real, intent(out) :: specvol !< in situ specific volume in m3 kg-1. - real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0, in kg m-3. - real, intent(in) :: dRho_dT, dRho_dS !< The derivatives of density with - !! temperature and salinity, in kg m-3 C-1 - !! and kg m-3 psu-1. - real, optional, intent(in) :: spv_ref !< A reference specific volume in m3 kg-1. - + !! [degC]. + real, intent(in) :: S !< Salinity [PSU]. + real, intent(in) :: pressure !< Pressure [Pa]. + real, intent(out) :: specvol !< In situ specific volume [m3 kg-1]. + real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0 [kg m-3]. + real, intent(in) :: dRho_dT !< The derivatives of density with temperature [kg m-3 degC-1]. + real, intent(in) :: dRho_dS !< The derivatives of density with salinity [kg m-3 ppt-1]. + real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. + ! Local variables integer :: j if (present(spv_ref)) then @@ -133,24 +130,23 @@ subroutine calculate_spec_vol_scalar_linear(T, S, pressure, specvol, & end subroutine calculate_spec_vol_scalar_linear !> This subroutine computes the in situ specific volume of sea water (specvol in -!! units of m^3/kg) from salinity (S in psu), potential temperature (T in deg C) -!! and pressure in Pa, using a trivial linear equation of state for density. +!! [m3 kg-1]) from salinity (S [PSU]), potential temperature (T [degC]) +!! and pressure [Pa], using a trivial linear equation of state for density. !! If spv_ref is present, specvol is an anomaly from spv_ref. subroutine calculate_spec_vol_array_linear(T, S, pressure, specvol, start, npts, & Rho_T0_S0, dRho_dT, dRho_dS, spv_ref) real, dimension(:), intent(in) :: T !< potential temperature relative to the surface - !! in C. - real, dimension(:), intent(in) :: S !< salinity in PSU. - real, dimension(:), intent(in) :: pressure !< pressure in Pa. - real, dimension(:), intent(out) :: specvol !< in situ specific volume in m3 kg-1. + !! [degC]. + real, dimension(:), intent(in) :: S !< Salinity [PSU]. + real, dimension(:), intent(in) :: pressure !< Pressure [Pa]. + real, dimension(:), intent(out) :: specvol !< in situ specific volume [m3 kg-1]. integer, intent(in) :: start !< the starting point in the arrays. integer, intent(in) :: npts !< the number of values to calculate. - real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0, in kg m-3. - real, intent(in) :: dRho_dT, dRho_dS !< The derivatives of density with - !! temperature and salinity, in kg m-3 C-1 - !! and kg m-3 psu-1. - real, optional, intent(in) :: spv_ref !< A reference specific volume in m3 kg-1. - + real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0 [kg m-3]. + real, intent(in) :: dRho_dT !< The derivatives of density with temperature [kg m-3 degC-1]. + real, intent(in) :: dRho_dS !< The derivatives of density with salinity [kg m-3 ppt-1]. + real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. + ! Local variables integer :: j if (present(spv_ref)) then ; do j=start,start+npts-1 @@ -167,35 +163,19 @@ end subroutine calculate_spec_vol_array_linear subroutine calculate_density_derivs_array_linear(T, S, pressure, drho_dT_out, & drho_dS_out, Rho_T0_S0, dRho_dT, dRho_dS, start, npts) real, intent(in), dimension(:) :: T !< Potential temperature relative to the surface - !! in C. - real, intent(in), dimension(:) :: S !< Salinity in PSU. - real, intent(in), dimension(:) :: pressure !< Pressure in Pa. + !! [degC]. + real, intent(in), dimension(:) :: S !< Salinity [PSU]. + real, intent(in), dimension(:) :: pressure !< Pressure [Pa]. real, intent(out), dimension(:) :: drho_dT_out !< The partial derivative of density with - !! potential temperature, in kg m-3 K-1. + !! potential temperature [kg m-3 degC-1]. real, intent(out), dimension(:) :: drho_dS_out !< The partial derivative of density with - !! salinity, in kg m-3 psu-1. - real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0, in kg m-3. - real, intent(in) :: dRho_dT, dRho_dS !< The derivatives of density with - !! temperature and salinity, in kg m-3 C-1 - !! and kg m-3 psu-1. + !! salinity [kg m-3 ppt-1]. + real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0 [kg m-3]. + real, intent(in) :: dRho_dT !< The derivative of density with temperature [kg m-3 degC-1]. + real, intent(in) :: dRho_dS !< The derivative of density with salinity [kg m-3 ppt-1]. integer, intent(in) :: start !< The starting point in the arrays. integer, intent(in) :: npts !< The number of values to calculate. - -! * This subroutine calculates the partial derivatives of density * -! * with potential temperature and salinity. * -! * * -! * Arguments: T - potential temperature relative to the surface in C. * -! * (in) S - salinity in PSU. * -! * (in) pressure - pressure in Pa. * -! * (out) drho_dT_out - the partial derivative of density with * -! * potential temperature, in kg m-3 K-1. * -! * (out) drho_dS_out - the partial derivative of density with * -! * salinity, in kg m-3 psu-1. * -! * (in) start - the starting point in the arrays. * -! * (in) npts - the number of values to calculate. * -! * (in) Rho_T0_S0 - The density at T=0, S=0, in kg m-3. * -! * (in) dRho_dT - The derivatives of density with temperature * -! * (in) dRho_dS - and salinity, in kg m-3 C-1 and kg m-3 psu-1. * + ! Local variables integer :: j do j=start,start+npts-1 @@ -210,17 +190,16 @@ end subroutine calculate_density_derivs_array_linear subroutine calculate_density_derivs_scalar_linear(T, S, pressure, drho_dT_out, & drho_dS_out, Rho_T0_S0, dRho_dT, dRho_dS) real, intent(in) :: T !< Potential temperature relative to the surface - !! in C. - real, intent(in) :: S !< Salinity in PSU. - real, intent(in) :: pressure !< Pressure in Pa. + !! [degC]. + real, intent(in) :: S !< Salinity [PSU]. + real, intent(in) :: pressure !< pressure [Pa]. real, intent(out) :: drho_dT_out !< The partial derivative of density with - !! potential temperature, in kg m-3 K-1. + !! potential temperature [kg m-3 degC-1]. real, intent(out) :: drho_dS_out !< The partial derivative of density with - !! salinity, in kg m-3 psu-1. - real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0, in kg m-3. - real, intent(in) :: dRho_dT, dRho_dS !< The derivatives of density with - !! temperature and salinity, in kg m-3 C-1 - !! and kg m-3 psu-1. + !! salinity [kg m-3 ppt-1]. + real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0 [kg m-3]. + real, intent(in) :: dRho_dT !< The derivatives of density with temperature [kg m-3 degC-1]. + real, intent(in) :: dRho_dS !< The derivatives of density with salinity [kg m-3 ppt-1]. drho_dT_out = dRho_dT drho_dS_out = dRho_dS @@ -228,17 +207,21 @@ end subroutine calculate_density_derivs_scalar_linear !> This subroutine calculates the five, partial second derivatives of density w.r.t. !! potential temperature and salinity and pressure which for a linear equation of state should all be 0. -subroutine calculate_density_second_derivs_scalar_linear(T, S,pressure, drho_dS_dS, drho_dS_dT, drho_dT_dT,& - drho_dS_dP, drho_dT_dP) - real, intent(in) :: T !< Potential temperature relative to the surface - !! in C. - real, intent(in) :: S !< Salinity in PSU. - real, intent(in) :: pressure !< Pressure in Pa. - real, intent(out) :: drho_dS_dS !< The partial derivative of density with - real, intent(out) :: drho_dS_dT !< The partial derivative of density with - real, intent(out) :: drho_dT_dT !< The partial derivative of density with - real, intent(out) :: drho_dS_dP !< The partial derivative of density with - real, intent(out) :: drho_dT_dP !< The partial derivative of density with +subroutine calculate_density_second_derivs_scalar_linear(T, S, pressure, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP) + real, intent(in) :: T !< Potential temperature relative to the surface [degC]. + real, intent(in) :: S !< Salinity [PSU]. + real, intent(in) :: pressure !< pressure [Pa]. + real, intent(out) :: drho_dS_dS !< The second derivative of density with + !! salinity [kg m-3 PSU-2]. + real, intent(out) :: drho_dS_dT !< The second derivative of density with + !! temperature and salinity [kg m-3 ppt-1 degC-1]. + real, intent(out) :: drho_dT_dT !< The second derivative of density with + !! temperature [kg m-3 degC-2]. + real, intent(out) :: drho_dS_dP !< The second derivative of density with + !! salinity and pressure [kg m-3 PSU-1 Pa-1]. + real, intent(out) :: drho_dT_dP !< The second derivative of density with + !! temperature and pressure [kg m-3 degC-1 Pa-1]. drho_dS_dS = 0. drho_dS_dT = 0. @@ -252,17 +235,22 @@ end subroutine calculate_density_second_derivs_scalar_linear !! potential temperature and salinity and pressure which for a linear equation of state should all be 0. subroutine calculate_density_second_derivs_array_linear(T, S,pressure, drho_dS_dS, drho_dS_dT, drho_dT_dT,& drho_dS_dP, drho_dT_dP, start, npts) - real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface - !! in C. - real, dimension(:), intent(in) :: S !< Salinity in PSU. - real, dimension(:), intent(in) :: pressure !< Pressure in Pa. - real, dimension(:), intent(out) :: drho_dS_dS !< The partial derivative of density with - real, dimension(:), intent(out) :: drho_dS_dT !< The partial derivative of density with - real, dimension(:), intent(out) :: drho_dT_dT !< The partial derivative of density with - real, dimension(:), intent(out) :: drho_dS_dP !< The partial derivative of density with - real, dimension(:), intent(out) :: drho_dT_dP !< The partial derivative of density with + real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface [degC]. + real, dimension(:), intent(in) :: S !< Salinity [PSU]. + real, dimension(:), intent(in) :: pressure !< pressure [Pa]. + real, dimension(:), intent(out) :: drho_dS_dS !< The second derivative of density with + !! salinity [kg m-3 PSU-2]. + real, dimension(:), intent(out) :: drho_dS_dT !< The second derivative of density with + !! temperature and salinity [kg m-3 ppt-1 degC-1]. + real, dimension(:), intent(out) :: drho_dT_dT !< The second derivative of density with + !! temperature [kg m-3 degC-2]. + real, dimension(:), intent(out) :: drho_dS_dP !< The second derivative of density with + !! salinity and pressure [kg m-3 PSU-1 Pa-1]. + real, dimension(:), intent(out) :: drho_dT_dP !< The second derivative of density with + !! temperature and pressure [kg m-3 degC-1 Pa-1]. integer, intent(in) :: start !< The starting point in the arrays. integer, intent(in) :: npts !< The number of values to calculate. + ! Local variables integer :: j do j=start,start+npts-1 drho_dS_dS(j) = 0. @@ -274,33 +262,25 @@ subroutine calculate_density_second_derivs_array_linear(T, S,pressure, drho_dS_ end subroutine calculate_density_second_derivs_array_linear -! #@# This subroutine needs a doxygen description. +!> Calculate the derivatives of specific volume with temperature and salinity subroutine calculate_specvol_derivs_linear(T, S, pressure, dSV_dT, dSV_dS, & start, npts, Rho_T0_S0, dRho_dT, dRho_dS) real, intent(in), dimension(:) :: T !< Potential temperature relative to the surface - !! in C. - real, intent(in), dimension(:) :: S !< Salinity in g/kg. - real, intent(in), dimension(:) :: pressure !< Pressure in Pa. + !! [degC]. + real, intent(in), dimension(:) :: S !< Salinity [PSU]. + real, intent(in), dimension(:) :: pressure !< pressure [Pa]. real, intent(out), dimension(:) :: dSV_dS !< The partial derivative of specific volume with - !! salinity, in m3 kg-1 / (g/kg). + !! salinity [m3 kg-1 PSU-1]. real, intent(out), dimension(:) :: dSV_dT !< The partial derivative of specific volume with - !! potential temperature, in m3 kg-1 K-1. + !! potential temperature [m3 kg-1 degC-1]. integer, intent(in) :: start !< The starting point in the arrays. integer, intent(in) :: npts !< The number of values to calculate. - real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0, in kg m-3. - real, intent(in) :: dRho_dT, dRho_dS !< The derivatives of density with - !! temperature and salinity, in kg m-3 C-1 - !! and kg m-3 psu-1. - -! * Arguments: T - potential temperature relative to the surface in C. * -! * (in) S - salinity in g/kg. * -! * (in) pressure - pressure in Pa. * -! * (out) dSV_dT - the partial derivative of specific volume with * -! * potential temperature, in m3 kg-1 K-1. * -! * (out) dSV_dS - the partial derivative of specific volume with * -! * salinity, in m3 kg-1 / (g/kg). * -! * (in) start - the starting point in the arrays. * -! * (in) npts - the number of values to calculate. * + real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0 [kg m-3]. + real, intent(in) :: dRho_dT !< The derivative of density with + !! temperature, [kg m-3 degC-1]. + real, intent(in) :: dRho_dS !< The derivative of density with + !! salinity [kg m-3 ppt-1]. + ! Local variables real :: I_rho2 integer :: j @@ -319,37 +299,21 @@ end subroutine calculate_specvol_derivs_linear subroutine calculate_compress_linear(T, S, pressure, rho, drho_dp, start, npts,& Rho_T0_S0, dRho_dT, dRho_dS) real, intent(in), dimension(:) :: T !< Potential temperature relative to the surface - !! in C. - real, intent(in), dimension(:) :: S !< Salinity in PSU. - real, intent(in), dimension(:) :: pressure !< Pressure in Pa. - real, intent(out), dimension(:) :: rho !< In situ density in kg m-3. + !! [degC]. + real, intent(in), dimension(:) :: S !< Salinity [PSU]. + real, intent(in), dimension(:) :: pressure !< pressure [Pa]. + real, intent(out), dimension(:) :: rho !< In situ density [kg m-3]. real, intent(out), dimension(:) :: drho_dp !< The partial derivative of density with pressure !! (also the inverse of the square of sound speed) - !! in s2 m-2. + !! [s2 m-2]. integer, intent(in) :: start !< The starting point in the arrays. integer, intent(in) :: npts !< The number of values to calculate. - real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0, in kg m-3. - real, intent(in) :: dRho_dT, dRho_dS !< The derivatives of density with - !! temperature and salinity, in kg m-3 C-1 - !! and kg m-3 psu-1. - -! * This subroutine computes the in situ density of sea water (rho) * -! * and the compressibility (drho/dp == C_sound^-2) at the given * -! * salinity, potential temperature, and pressure. * -! * * -! * Arguments: T - potential temperature relative to the surface in C. * -! * (in) S - salinity in PSU. * -! * (in) pressure - pressure in Pa. * -! * (out) rho - in situ density in kg m-3. * -! * (out) drho_dp - the partial derivative of density with * -! * pressure (also the inverse of the square of * -! * sound speed) in s2 m-2. * -! * (in) start - the starting point in the arrays. * -! * (in) npts - the number of values to calculate. * -! * (in) Rho_T0_S0 - The density at T=0, S=0, in kg m-3. * -! * (in) dRho_dT - The derivatives of density with temperature * -! * (in) dRho_dS - and salinity, in kg m-3 C-1 and kg m-3 psu-1. * - + real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0 [kg m-3]. + real, intent(in) :: dRho_dT !< The derivative of density with + !! temperature [kg m-3 degC-1]. + real, intent(in) :: dRho_dS !< The derivative of density with + !! salinity [kg m-3 ppt-1]. + ! Local variables integer :: j do j=start,start+npts-1 @@ -364,64 +328,63 @@ end subroutine calculate_compress_linear subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HII, HIO, & Rho_T0_S0, dRho_dT, dRho_dS, dpa, intz_dpa, intx_dpa, inty_dpa, & bathyT, dz_neglect, useMassWghtInterp) - type(hor_index_type), intent(in) :: HII, HIO + type(hor_index_type), intent(in) :: HII !< The horizontal index type for the input arrays. + type(hor_index_type), intent(in) :: HIO !< The horizontal index type for the output arrays. real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & intent(in) :: T !< Potential temperature relative to the surface - !! in C. + !! [degC]. real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: S !< Salinity in PSU. + intent(in) :: S !< Salinity [PSU]. real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: z_t !< Height at the top of the layer in m. + intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m]. real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: z_b !< Height at the top of the layer in m. - real, intent(in) :: rho_ref !< A mean density, in kg m-3, that is subtracted + intent(in) :: z_b !< Height at the top of the layer [Z ~> m]. + real, intent(in) :: rho_ref !< A mean density [kg m-3], that is subtracted !! out to reduce the magnitude of each of the !! integrals. - real, intent(in) :: rho_0_pres !< A density, in kg m-3, that is used to calculate + real, intent(in) :: rho_0_pres !< A density [kg m-3], that is used to calculate !! the pressure (as p~=-z*rho_0_pres*G_e) used in !! the equation of state. rho_0_pres is not used !! here. - real, intent(in) :: G_e !< The Earth's gravitational acceleration, - !! in m s-2. - real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0, in kg m-3. + real, intent(in) :: G_e !< The Earth's gravitational acceleration [m2 Z-1 s-2 ~> m s-2]. + real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0 [kg m-3]. real, intent(in) :: dRho_dT !< The derivative of density with temperature, - !! in kg m-3 C-1. + !! [kg m-3 degC-1]. real, intent(in) :: dRho_dS !< The derivative of density with salinity, - !! in kg m-3 psu-1. + !! in [kg m-3 ppt-1]. real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & intent(out) :: dpa !< The change in the pressure anomaly across the - !! layer, in Pa. + !! layer [Pa]. real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & optional, intent(out) :: intz_dpa !< The integral through the thickness of the layer !! of the pressure anomaly relative to the anomaly - !! at the top of the layer, in Pa m. + !! at the top of the layer [Pa Z]. real, dimension(HIO%IsdB:HIO%IedB,HIO%jsd:HIO%jed), & optional, intent(out) :: intx_dpa !< The integral in x of the difference between the !! pressure anomaly at the top and bottom of the - !! layer divided by the x grid spacing, in Pa. + !! layer divided by the x grid spacing [Pa]. real, dimension(HIO%isd:HIO%ied,HIO%JsdB:HIO%JedB), & optional, intent(out) :: inty_dpa !< The integral in y of the difference between the !! pressure anomaly at the top and bottom of the - !! layer divided by the y grid spacing, in Pa. + !! layer divided by the y grid spacing [Pa]. real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - optional, intent(in) :: bathyT !< The depth of the bathymetry in m - real, optional, intent(in) :: dz_neglect !< A miniscule thickness change with the - !! same units as z_t + optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m]. + real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m]. logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to - !! interpolate T/S for top and bottom integrals. - - real :: rho_anom ! The density anomaly from rho_ref, in kg m-3. - real :: raL, raR ! rho_anom to the left and right, in kg m-3. - real :: dz, dzL, dzR ! Layer thicknesses in m. - real :: hWght ! A pressure-thickness below topography, in m. - real :: hL, hR ! Pressure-thicknesses of the columns to the left and right, in m. - real :: iDenom ! The inverse of the denominator in the wieghts, in m-2. - real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column, nonDim. - real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column, nonDim. - real :: wt_L, wt_R ! The linear wieghts of the left and right columns, nonDim. - real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns, nonDim. + !! interpolate T/S for top and bottom integrals. + ! Local variables + real :: rho_anom ! The density anomaly from rho_ref [kg m-3]. + real :: raL, raR ! rho_anom to the left and right [kg m-3]. + real :: dz, dzL, dzR ! Layer thicknesses [Z ~> m]. + real :: hWght ! A pressure-thickness below topography [Z ~> m]. + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [Z ~> m]. + real :: iDenom ! The inverse of the denominator in the weights [Z-2 ~> m-2]. + real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column [nondim]. + real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column [nondim]. + real :: wt_L, wt_R ! The linear weights of the left and right columns [nondim]. + real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim]. real :: intz(5) ! The integrals of density with height at the - ! 5 sub-column locations, in m2 s-2. + ! 5 sub-column locations [Pa]. logical :: do_massWeight ! Indicates whether to do mass weighting. real, parameter :: C1_6 = 1.0/6.0, C1_90 = 1.0/90.0 ! Rational constants. integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, ioff, joff, m @@ -532,7 +495,7 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HII, enddo ; enddo ; endif end subroutine int_density_dz_linear -!> This subroutine calculates analytical and nearly-analytical integrals in +!> Calculates analytical and nearly-analytical integrals in !! pressure across layers of geopotential anomalies, which are required for !! calculating the finite-volume form pressure accelerations in a non-Boussinesq !! model. Specific volume is assumed to vary linearly between adjacent points. @@ -542,89 +505,60 @@ subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & type(hor_index_type), intent(in) :: HI !< The ocean's horizontal index type. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T !< Potential temperature relative to the surface - !! in C. + !! [degC]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: S !< Salinity in PSU. + intent(in) :: S !< Salinity [PSU]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_t !< Pressure at the top of the layer in Pa. + intent(in) :: p_t !< Pressure at the top of the layer [Pa]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_b !< Pressure at the top of the layer in Pa. + intent(in) :: p_b !< Pressure at the top of the layer [Pa]. real, intent(in) :: alpha_ref !< A mean specific volume that is subtracted out !! to reduce the magnitude of each of the integrals, m3 kg-1. The calculation is !! mathematically identical with different values of alpha_ref, but this reduces the !! effects of roundoff. - real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0, in kg m-3. - real, intent(in) :: dRho_dT !< The derivative of density with temperature, - !! in kg m-3 C-1. + real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0 [kg m-3]. + real, intent(in) :: dRho_dT !< The derivative of density with temperature + !! [kg m-3 degC-1]. real, intent(in) :: dRho_dS !< The derivative of density with salinity, - !! in kg m-3 psu-1. + !! in [kg m-3 ppt-1]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(out) :: dza !< The change in the geopotential anomaly across - !! the layer, in m2 s-2. + !! the layer [m2 s-2]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(out) :: intp_dza !< The integral in pressure through the layer of !! the geopotential anomaly relative to the anomaly - !! at the bottom of the layer, in Pa m2 s-2. + !! at the bottom of the layer [Pa m2 s-2]. real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & optional, intent(out) :: intx_dza !< The integral in x of the difference between the !! geopotential anomaly at the top and bottom of - !! the layer divided by the x grid spacing, - !! in m2 s-2. + !! the layer divided by the x grid spacing + !! [m2 s-2]. real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & optional, intent(out) :: inty_dza !< The integral in y of the difference between the !! geopotential anomaly at the top and bottom of - !! the layer divided by the y grid spacing, - !! in m2 s-2. + !! the layer divided by the y grid spacing + !! [m2 s-2]. integer, optional, intent(in) :: halo_size !< The width of halo points on which to calculate dza. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - optional, intent(in) :: bathyP !< The pressure at the bathymetry in Pa + optional, intent(in) :: bathyP !< The pressure at the bathymetry [Pa] real, optional, intent(in) :: dP_neglect !< A miniscule pressure change with - !! the same units as p_t (Pa?) + !! the same units as p_t [Pa] logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting !! to interpolate T/S for top and bottom integrals. - -! This subroutine calculates analytical and nearly-analytical integrals in -! pressure across layers of geopotential anomalies, which are required for -! calculating the finite-volume form pressure accelerations in a non-Boussinesq -! model. Specific volume is assumed to vary linearly between adjacent points. -! -! Arguments: T - potential temperature relative to the surface in C. -! (in) S - salinity in PSU. -! (in) p_t - pressure at the top of the layer in Pa. -! (in) p_b - pressure at the top of the layer in Pa. -! (in) alpha_ref - A mean specific volume that is subtracted out to reduce -! the magnitude of each of the integrals, m3 kg-1. -! The calculation is mathematically identical with -! different values of alpha_ref, but this reduces the -! effects of roundoff. -! (in) HI - The ocean's horizontal index type. -! (in) Rho_T0_S0 - The density at T=0, S=0, in kg m-3. -! (in) dRho_dT - The derivative of density with temperature in kg m-3 C-1. -! (in) dRho_dS - The derivative of density with salinity, in kg m-3 psu-1. -! (out) dza - The change in the geopotential anomaly across the layer, -! in m2 s-2. -! (out,opt) intp_dza - The integral in pressure through the layer of the -! geopotential anomaly relative to the anomaly at the -! bottom of the layer, in Pa m2 s-2. -! (out,opt) intx_dza - The integral in x of the difference between the -! geopotential anomaly at the top and bottom of the layer -! divided by the x grid spacing, in m2 s-2. -! (out,opt) inty_dza - The integral in y of the difference between the -! geopotential anomaly at the top and bottom of the layer -! divided by the y grid spacing, in m2 s-2. - real :: dRho_TS ! The density anomaly due to T and S, in kg m-3. - real :: alpha_anom ! The specific volume anomaly from 1/rho_ref, in m3 kg-1. - real :: aaL, aaR ! rho_anom to the left and right, in kg m-3. - real :: dp, dpL, dpR ! Layer pressure thicknesses in Pa. - real :: hWght ! A pressure-thickness below topography, in Pa. - real :: hL, hR ! Pressure-thicknesses of the columns to the left and right, in Pa. - real :: iDenom ! The inverse of the denominator in the wieghts, in Pa-2. - real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column, nonDim. - real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column, nonDim. - real :: wt_L, wt_R ! The linear wieghts of the left and right columns, nonDim. - real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns, nonDim. + ! Local variables + real :: dRho_TS ! The density anomaly due to T and S [kg m-3]. + real :: alpha_anom ! The specific volume anomaly from 1/rho_ref [m3 kg-1]. + real :: aaL, aaR ! rho_anom to the left and right [kg m-3]. + real :: dp, dpL, dpR ! Layer pressure thicknesses [Pa]. + real :: hWght ! A pressure-thickness below topography [Pa]. + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [Pa]. + real :: iDenom ! The inverse of the denominator in the weights [Pa-2]. + real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column [nondim]. + real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column [nondim]. + real :: wt_L, wt_R ! The linear weights of the left and right columns [nondim]. + real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim]. real :: intp(5) ! The integrals of specific volume with pressure at the - ! 5 sub-column locations, in m2 s-2. + ! 5 sub-column locations [m2 s-2]. logical :: do_massWeight ! Indicates whether to do mass weighting. real, parameter :: C1_6 = 1.0/6.0, C1_90 = 1.0/90.0 ! Rational constants. integer :: Isq, Ieq, Jsq, Jeq, ish, ieh, jsh, jeh, i, j, m, halo diff --git a/src/equation_of_state/MOM_TFreeze.F90 b/src/equation_of_state/MOM_TFreeze.F90 index aef6b60ecb..50233cae60 100644 --- a/src/equation_of_state/MOM_TFreeze.F90 +++ b/src/equation_of_state/MOM_TFreeze.F90 @@ -1,3 +1,4 @@ +!> Freezing point expressions module MOM_TFreeze ! This file is part of MOM6. See LICENSE.md for the license. @@ -12,72 +13,62 @@ module MOM_TFreeze public calculate_TFreeze_linear, calculate_TFreeze_Millero, calculate_TFreeze_teos10 +!> Compute the freezing point potential temperature [degC] from salinity [ppt] and +!! pressure [Pa] using a simple linear expression, with coefficients passed in as arguments. interface calculate_TFreeze_linear module procedure calculate_TFreeze_linear_scalar, calculate_TFreeze_linear_array end interface calculate_TFreeze_linear +!> Compute the freezing point potential temperature [degC] from salinity [PSU] and +!! pressure [Pa] using the expression from Millero (1978) (and in appendix A of Gill 1982), +!! but with the of the pressure dependence changed from 7.53e-8 to 7.75e-8 to make this an +!! expression for potential temperature (not in situ temperature), using a +!! value that is correct at the freezing point at 35 PSU and 5e6 Pa (500 dbar). interface calculate_TFreeze_Millero module procedure calculate_TFreeze_Millero_scalar, calculate_TFreeze_Millero_array end interface calculate_TFreeze_Millero +!> Compute the freezing point conservative temperature [degC] from absolute salinity [g/kg] +!! and pressure [Pa] using the TEOS10 package. interface calculate_TFreeze_teos10 module procedure calculate_TFreeze_teos10_scalar, calculate_TFreeze_teos10_array end interface calculate_TFreeze_teos10 contains +!> This subroutine computes the freezing point potential temperature +!! [degC] from salinity [ppt], and pressure [Pa] using a simple +!! linear expression, with coefficients passed in as arguments. subroutine calculate_TFreeze_linear_scalar(S, pres, T_Fr, TFr_S0_P0, & dTFr_dS, dTFr_dp) - real, intent(in) :: S, pres - real, intent(out) :: T_Fr - real, intent(in) :: TFr_S0_P0, dTFr_dS, dTFr_dp -! This subroutine computes the freezing point potential temparature -! (in deg C) from salinity (in psu), and pressure (in Pa) using a simple -! linear expression, with coefficients passed in as arguments. -! -! Arguments: S - salinity in PSU. -! (in) pres - pressure in Pa. -! (out) T_Fr - Freezing point potential temperature in deg C. -! (in) TFr_S0_P0 - The freezing point at S=0, p=0, in deg C. -! (in) dTFr_dS - The derivatives of freezing point with salinity, in -! deg C PSU-1. -! (in) dTFr_dp - The derivatives of freezing point with pressure, in -! deg C Pa-1. + real, intent(in) :: S !< salinity [ppt]. + real, intent(in) :: pres !< pressure [Pa]. + real, intent(out) :: T_Fr !< Freezing point potential temperature [degC]. + real, intent(in) :: TFr_S0_P0 !< The freezing point at S=0, p=0 [degC]. + real, intent(in) :: dTFr_dS !< The derivative of freezing point with salinity, + !! [degC ppt-1]. + real, intent(in) :: dTFr_dp !< The derivative of freezing point with pressure, + !! [degC Pa-1]. T_Fr = (TFr_S0_P0 + dTFr_dS*S) + dTFr_dp*pres end subroutine calculate_TFreeze_linear_scalar -!> This subroutine computes the freezing point potential temparature -!! (in deg C) from salinity (in psu), and pressure (in Pa) using a simple +!> This subroutine computes an array of freezing point potential temperatures +!! [degC] from salinity [ppt], and pressure [Pa] using a simple !! linear expression, with coefficients passed in as arguments. subroutine calculate_TFreeze_linear_array(S, pres, T_Fr, start, npts, & TFr_S0_P0, dTFr_dS, dTFr_dp) - real, dimension(:), intent(in) :: S !< salinity in PSU. - real, dimension(:), intent(in) :: pres !< pressure in Pa. - real, dimension(:), intent(out) :: T_Fr !< Freezing point potential temperature in deg C. + real, dimension(:), intent(in) :: S !< salinity [ppt]. + real, dimension(:), intent(in) :: pres !< pressure [Pa]. + real, dimension(:), intent(out) :: T_Fr !< Freezing point potential temperature [degC]. integer, intent(in) :: start !< the starting point in the arrays. integer, intent(in) :: npts !< the number of values to calculate. - real, intent(in) :: TFr_S0_P0 !< The freezing point at S=0, p=0, in deg C. + real, intent(in) :: TFr_S0_P0 !< The freezing point at S=0, p=0, [degC]. real, intent(in) :: dTFr_dS !< The derivative of freezing point with salinity, - !! in deg C PSU-1. + !! [degC PSU-1]. real, intent(in) :: dTFr_dp !< The derivative of freezing point with pressure, - !! in deg C Pa-1. - -! This subroutine computes the freezing point potential temparature -! (in deg C) from salinity (in psu), and pressure (in Pa) using a simple -! linear expression, with coefficients passed in as arguments. -! -! Arguments: S - salinity in PSU. -! (in) pres - pressure in Pa. -! (out) T_Fr - Freezing point potential temperature in deg C. -! (in) start - the starting point in the arrays. -! (in) npts - the number of values to calculate. -! (in) TFr_S0_P0 - The freezing point at S=0, p=0, in deg C. -! (in) dTFr_dS - The derivative of freezing point with salinity, in -! deg C PSU-1. -! (in) dTFr_dp - The derivative of freezing point with pressure, in -! deg C Pa-1. + !! [degC Pa-1]. integer :: j do j=start,start+npts-1 @@ -86,27 +77,18 @@ subroutine calculate_TFreeze_linear_array(S, pres, T_Fr, start, npts, & end subroutine calculate_TFreeze_linear_array -!> This subroutine computes the freezing point potential temparature -!! (in deg C) from salinity (in psu), and pressure (in Pa) using the expression +!> This subroutine computes the freezing point potential temperature +!! [degC] from salinity [ppt], and pressure [Pa] using the expression !! from Millero (1978) (and in appendix A of Gill 1982), but with the of the !! pressure dependence changed from 7.53e-8 to 7.75e-8 to make this an !! expression for potential temperature (not in situ temperature), using a !! value that is correct at the freezing point at 35 PSU and 5e6 Pa (500 dbar). subroutine calculate_TFreeze_Millero_scalar(S, pres, T_Fr) real, intent(in) :: S !< Salinity in PSU. - real, intent(in) :: pres !< Pressure in Pa. - real, intent(out) :: T_Fr !< Freezing point potential temperature in deg C. - -! This subroutine computes the freezing point potential temparature -! (in deg C) from salinity (in psu), and pressure (in Pa) using the expression -! from Millero (1978) (and in appendix A of Gill 1982), but with the of the -! pressure dependence changed from 7.53e-8 to 7.75e-8 to make this an -! expression for potential temperature (not in situ temperature), using a -! value that is correct at the freezing point at 35 PSU and 5e6 Pa (500 dbar). -! -! Arguments: S - salinity in PSU. -! (in) pres - pressure in Pa. -! (out) T_Fr - Freezing point potential temperature in deg C. + real, intent(in) :: pres !< Pressure [Pa]. + real, intent(out) :: T_Fr !< Freezing point potential temperature [degC]. + + ! Local variables real, parameter :: cS1 = -0.0575, cS3_2 = 1.710523e-3, cS2 = -2.154996e-4 real, parameter :: dTFr_dp = -7.75e-8 @@ -114,30 +96,20 @@ subroutine calculate_TFreeze_Millero_scalar(S, pres, T_Fr) end subroutine calculate_TFreeze_Millero_scalar -!> This subroutine computes the freezing point potential temparature -!! (in deg C) from salinity (in psu), and pressure (in Pa) using the expression +!> This subroutine computes the freezing point potential temperature +!! [degC] from salinity [ppt], and pressure [Pa] using the expression !! from Millero (1978) (and in appendix A of Gill 1982), but with the of the !! pressure dependence changed from 7.53e-8 to 7.75e-8 to make this an !! expression for potential temperature (not in situ temperature), using a !! value that is correct at the freezing point at 35 PSU and 5e6 Pa (500 dbar). subroutine calculate_TFreeze_Millero_array(S, pres, T_Fr, start, npts) - real, dimension(:), intent(in) :: S !< Salinity in PSU. - real, dimension(:), intent(in) :: pres !< Pressure in Pa. - real, dimension(:), intent(out) :: T_Fr !< Freezing point potential temperature in deg C. + real, dimension(:), intent(in) :: S !< Salinity [PSU]. + real, dimension(:), intent(in) :: pres !< Pressure [Pa]. + real, dimension(:), intent(out) :: T_Fr !< Freezing point potential temperature [degC]. integer, intent(in) :: start !< The starting point in the arrays. integer, intent(in) :: npts !< The number of values to calculate. -! This subroutine computes the freezing point potential temparature -! (in deg C) from salinity (in psu), and pressure (in Pa) using the expression -! from Millero (1978) (and in appendix A of Gill 1982), but with the of the -! pressure dependence changed from 7.53e-8 to 7.75e-8 to make this an -! expression for potential temperature (not in situ temperature), using a -! value that is correct at the freezing point at 35 PSU and 5e6 Pa (500 dbar). -! -! Arguments: S - salinity in PSU. -! (in) pres - pressure in Pa. -! (out) T_Fr - Freezing point potential temperature in deg C. -! (in) start - the starting point in the arrays. -! (in) npts - the number of values to calculate. + + ! Local variables real, parameter :: cS1 = -0.0575, cS3_2 = 1.710523e-3, cS2 = -2.154996e-4 real, parameter :: dTFr_dp = -7.75e-8 integer :: j @@ -149,20 +121,15 @@ subroutine calculate_TFreeze_Millero_array(S, pres, T_Fr, start, npts) end subroutine calculate_TFreeze_Millero_array -!> This subroutine computes the freezing point conservative temparature -!! (in deg C) from absolute salinity (in g/kg), and pressure (in Pa) using the +!> This subroutine computes the freezing point conservative temperature +!! [degC] from absolute salinity [g/kg], and pressure [Pa] using the !! TEOS10 package. subroutine calculate_TFreeze_teos10_scalar(S, pres, T_Fr) - real, intent(in) :: S !< Absolute salinity in g/kg. - real, intent(in) :: pres !< Pressure in Pa. - real, intent(out) :: T_Fr !< Freezing point conservative temperature in deg C. -! This subroutine computes the freezing point conservative temparature -! (in deg C) from absolute salinity (in g/kg), and pressure (in Pa) using the -! TEOS10 package. -! -! Arguments: S - absolute salinity in g/kg. -! (in) pres - pressure in Pa. -! (out) T_Fr - Freezing point conservative temperature in deg C. + real, intent(in) :: S !< Absolute salinity [g/kg]. + real, intent(in) :: pres !< Pressure [Pa]. + real, intent(out) :: T_Fr !< Freezing point conservative temperature [degC]. + + ! Local variables real, dimension(1) :: S0, pres0 real, dimension(1) :: tfr0 @@ -174,27 +141,18 @@ subroutine calculate_TFreeze_teos10_scalar(S, pres, T_Fr) end subroutine calculate_TFreeze_teos10_scalar -!> This subroutine computes the freezing point conservative temparature -!! (in deg C) from absolute salinity (in g/kg), and pressure (in Pa) using the +!> This subroutine computes the freezing point conservative temperature +!! [degC] from absolute salinity [g/kg], and pressure [Pa] using the !! TEOS10 package. subroutine calculate_TFreeze_teos10_array(S, pres, T_Fr, start, npts) - real, dimension(:), intent(in) :: S !< absolute salinity in g/kg. - real, dimension(:), intent(in) :: pres !< pressure in Pa. - real, dimension(:), intent(out) :: T_Fr !< Freezing point conservative temperature in deg C. + real, dimension(:), intent(in) :: S !< absolute salinity [g/kg]. + real, dimension(:), intent(in) :: pres !< pressure [Pa]. + real, dimension(:), intent(out) :: T_Fr !< Freezing point conservative temperature [degC]. integer, intent(in) :: start !< the starting point in the arrays. integer, intent(in) :: npts !< the number of values to calculate. -! This subroutine computes the freezing point conservative temparature -! (in deg C) from absolute salinity (in g/kg), and pressure (in Pa) using the -! TEOS10 package. -! -! Arguments: S - absolute salinity in g/kg. -! (in) pres - pressure in Pa. -! (out) T_Fr - Freezing point conservative temperature in deg C. -! * (in) start - the starting point in the arrays. * -! * (in) npts - the number of values to calculate. * + ! Local variables real, parameter :: Pa2db = 1.e-4 ! The conversion factor from Pa to dbar. - real :: zs,zp integer :: j ! Assume sea-water contains no dissolved air. @@ -205,11 +163,10 @@ subroutine calculate_TFreeze_teos10_array(S, pres, T_Fr, start, npts) zs = S(j) zp = pres(j)* Pa2db !Convert pressure from Pascal to decibar - if(S(j).lt.-1.0e-10) cycle !Can we assume safely that this is a missing value? + if (S(j) < -1.0e-10) cycle !Can we assume safely that this is a missing value? T_Fr(j) = gsw_ct_freezing_exact(zs,zp,saturation_fraction) enddo - end subroutine calculate_TFreeze_teos10_array end module MOM_TFreeze diff --git a/src/framework/MOM_checksums.F90 b/src/framework/MOM_checksums.F90 index 26ee96b399..df014dc7a5 100644 --- a/src/framework/MOM_checksums.F90 +++ b/src/framework/MOM_checksums.F90 @@ -1,3 +1,4 @@ +!> Routines to calculate checksums of various array and vector types module MOM_checksums ! This file is part of MOM6. See LICENSE.md for the license. @@ -16,69 +17,80 @@ module MOM_checksums public :: chksum_general public :: MOM_checksums_init +!> Checksums a pair of arrays (2d or 3d) staggered at tracer points interface hchksum_pair module procedure chksum_pair_h_2d, chksum_pair_h_3d end interface +!> Checksums a pair velocity arrays (2d or 3d) staggered at C-grid locations interface uvchksum module procedure chksum_uv_2d, chksum_uv_3d end interface +!> Checksums an array (2d or 3d) staggered at C-grid u points. interface uchksum module procedure chksum_u_2d, chksum_u_3d end interface +!> Checksums an array (2d or 3d) staggered at C-grid v points. interface vchksum module procedure chksum_v_2d, chksum_v_3d end interface +!> Checksums a pair of arrays (2d or 3d) staggered at corner points interface Bchksum_pair module procedure chksum_pair_B_2d, chksum_pair_B_3d end interface +!> Checksums an array (2d or 3d) staggered at tracer points. interface hchksum module procedure chksum_h_2d, chksum_h_3d end interface +!> Checksums an array (2d or 3d) staggered at corner points. interface Bchksum module procedure chksum_B_2d, chksum_B_3d end interface -! This is an older interface that has been renamed Bchksum +!> This is an older interface that has been renamed Bchksum interface qchksum module procedure chksum_B_2d, chksum_B_3d end interface +!> This is an older interface for 1-, 2-, or 3-D checksums interface chksum module procedure chksum1d, chksum2d, chksum3d end interface +!> Write a message with either checksums or numerical statistics of arrays interface chk_sum_msg module procedure chk_sum_msg1, chk_sum_msg2, chk_sum_msg3, chk_sum_msg5 end interface +!> Returns .true. if any element of x is a NaN, and .false. otherwise. interface is_NaN 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 :: default_shift=0 -logical :: calculateStatistics=.true. ! If true, report min, max and mean. -logical :: writeChksums=.true. ! If true, report the bitcount checksum -logical :: checkForNaNs=.true. ! If true, checks array for NaNs and cause - ! FATAL error is any are found +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 +logical :: checkForNaNs=.true. !< If true, checks array for NaNs and cause + !! FATAL error is any are found contains -! ===================================================================== - +!> Checksums on a pair of 2d arrays staggered at tracer points. subroutine chksum_pair_h_2d(mesg, arrayA, arrayB, HI, haloshift, omit_corners, scale) 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, arrayB !< The arrays to be checksummed + real, dimension(HI%isd:,HI%jsd:), intent(in) :: arrayA !< The first array to be checksummed + real, dimension(HI%isd:,HI%jsd:), intent(in) :: arrayB !< The second array to be checksummed 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. @@ -93,10 +105,12 @@ subroutine chksum_pair_h_2d(mesg, arrayA, arrayB, HI, haloshift, omit_corners, s 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) 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, arrayB !< The arrays to be checksummed + real, dimension(HI%isd:,HI%jsd:, :), intent(in) :: arrayA !< The first array to be checksummed + real, dimension(HI%isd:,HI%jsd:, :), intent(in) :: arrayB !< The second array to be checksummed 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. @@ -111,7 +125,7 @@ subroutine chksum_pair_h_3d(mesg, arrayA, arrayB, HI, haloshift, omit_corners, s end subroutine chksum_pair_h_3d -!> chksum_h_2d performs checksums on a 2d array staggered at tracer points. +!> Checksums a 2d array staggered at tracer points. subroutine chksum_h_2d(array, mesg, HI, haloshift, omit_corners, scale) 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 @@ -189,24 +203,25 @@ subroutine chksum_h_2d(array, mesg, HI, haloshift, omit_corners, scale) contains integer function subchk(array, HI, di, dj, scale) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%isd:,HI%jsd:), intent(in) :: array - integer, intent(in) :: di, dj - real, intent(in) :: scale + 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 + integer, intent(in) :: di !< i- direction array shift for this checksum + integer, intent(in) :: dj !< j- direction array shift for this checksum + real, intent(in) :: scale !< A scaling factor for this array. integer :: i, j, bc subchk = 0 do j=HI%jsc+dj,HI%jec+dj; do i=HI%isc+di,HI%iec+di bc = bitcount(abs(scale*array(i,j))) subchk = subchk + bc - enddo; enddo + enddo ; enddo call sum_across_PEs(subchk) subchk=mod(subchk,1000000000) end function subchk subroutine subStats(HI, array, mesg) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%isd:,HI%jsd:), intent(in) :: array - character(len=*), intent(in) :: mesg + 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 :: i, j, n real :: aMean, aMin, aMax @@ -229,13 +244,14 @@ 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) 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, arrayB !< The arrays to be checksummed - logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full symmetric computational domain. + real, dimension(HI%isd:,HI%jsd:), intent(in) :: arrayA !< The first array to be checksummed + real, dimension(HI%isd:,HI%jsd:), intent(in) :: arrayB !< The second array to be checksummed + logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full + !! symmetric computational domain. 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. @@ -256,12 +272,15 @@ subroutine chksum_pair_B_2d(mesg, arrayA, arrayB, HI, haloshift, symmetric, omit 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) 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, arrayB !< The arrays to be checksummed + real, dimension(HI%IsdB:,HI%JsdB:, :), intent(in) :: arrayA !< The first array to be checksummed + real, dimension(HI%IsdB:,HI%JsdB:, :), intent(in) :: arrayB !< The second array to be checksummed integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) - logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full symmetric computational domain. + logical, optional, intent(in) :: symmetric !< If true, do the checksums on the 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. @@ -279,7 +298,7 @@ subroutine chksum_pair_B_3d(mesg, arrayA, arrayB, HI, haloshift, symmetric, omit end subroutine chksum_pair_B_3d -!> chksum_B_2d performs checksums on a 2d array staggered at corner points. +!> Checksums a 2d array staggered at corner points. subroutine chksum_B_2d(array, mesg, HI, haloshift, symmetric, omit_corners, scale) type(hor_index_type), intent(in) :: HI !< A horizontal index type real, dimension(HI%IsdB:,HI%JsdB:), & @@ -373,26 +392,28 @@ subroutine chksum_B_2d(array, mesg, HI, haloshift, symmetric, omit_corners, scal contains integer function subchk(array, HI, di, dj, scale) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%IsdB:,HI%JsdB:), intent(in) :: array - integer, intent(in) :: di, dj - real, intent(in) :: scale + 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 + integer, intent(in) :: di !< i- direction array shift for this checksum + integer, intent(in) :: dj !< j- direction array shift for this checksum + real, intent(in) :: scale !< A scaling factor for this array. integer :: i, j, bc subchk = 0 ! This line deliberately uses the h-point computational domain. do J=HI%jsc+dj,HI%jec+dj; do I=HI%isc+di,HI%iec+di bc = bitcount(abs(scale*array(I,J))) subchk = subchk + bc - enddo; enddo + enddo ; enddo call sum_across_PEs(subchk) subchk=mod(subchk,1000000000) end function subchk subroutine subStats(HI, array, mesg, sym_stats) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%IsdB:,HI%JsdB:), intent(in) :: array - character(len=*), intent(in) :: mesg - logical, intent(in) :: sym_stats + 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. integer :: i, j, n, IsB, JsB real :: aMean, aMin, aMax @@ -417,15 +438,15 @@ 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) 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 real, dimension(HI%isd:,HI%JsdB:), intent(in) :: arrayV !< The v-component array to be checksummed integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) - logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full symmetric computational domain. + logical, optional, intent(in) :: symmetric !< If true, do the checksums on the 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 these arrays. @@ -439,13 +460,15 @@ subroutine chksum_uv_2d(mesg, arrayU, arrayV, HI, haloshift, symmetric, omit_cor 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) 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 real, dimension(HI%isd:,HI%JsdB:,:), intent(in) :: arrayV !< The v-component array to be checksummed integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) - logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full symmetric computational domain. + logical, optional, intent(in) :: symmetric !< If true, do the checksums on the 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 these arrays. @@ -459,13 +482,14 @@ subroutine chksum_uv_3d(mesg, arrayU, arrayV, HI, haloshift, symmetric, omit_cor end subroutine chksum_uv_3d -!> chksum_u_2d performs checksums on a 2d array staggered at C-grid u points. +!> Checksums a 2d array staggered at C-grid u points. subroutine chksum_u_2d(array, mesg, HI, haloshift, symmetric, omit_corners, scale) 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 integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) - logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full symmetric computational domain. + logical, optional, intent(in) :: symmetric !< If true, do the checksums on the 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. @@ -557,26 +581,28 @@ subroutine chksum_u_2d(array, mesg, HI, haloshift, symmetric, omit_corners, scal contains integer function subchk(array, HI, di, dj, scale) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%IsdB:,HI%jsd:), intent(in) :: array - integer, intent(in) :: di, dj - real, intent(in) :: scale + 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 + integer, intent(in) :: di !< i- direction array shift for this checksum + integer, intent(in) :: dj !< j- direction array shift for this checksum + real, intent(in) :: scale !< A scaling factor for this array. integer :: i, j, bc subchk = 0 ! This line deliberately uses the h-point computational domain. do j=HI%jsc+dj,HI%jec+dj; do I=HI%isc+di,HI%iec+di bc = bitcount(abs(scale*array(I,j))) subchk = subchk + bc - enddo; enddo + enddo ; enddo call sum_across_PEs(subchk) subchk=mod(subchk,1000000000) end function subchk subroutine subStats(HI, array, mesg, sym_stats) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%IsdB:,HI%jsd:), intent(in) :: array - character(len=*), intent(in) :: mesg - logical, intent(in) :: sym_stats + 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. integer :: i, j, n, IsB real :: aMean, aMin, aMax @@ -600,15 +626,14 @@ end subroutine subStats end subroutine chksum_u_2d -! ===================================================================== - -!> chksum_v_2d performs checksums on a 2d array staggered at C-grid v points. +!> Checksums a 2d array staggered at C-grid v points. subroutine chksum_v_2d(array, mesg, HI, haloshift, symmetric, omit_corners, scale) 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 integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) - logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full symmetric computational domain. + logical, optional, intent(in) :: symmetric !< If true, do the checksums on the 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. @@ -700,26 +725,28 @@ subroutine chksum_v_2d(array, mesg, HI, haloshift, symmetric, omit_corners, scal contains integer function subchk(array, HI, di, dj, scale) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%isd:,HI%JsdB:), intent(in) :: array - integer, intent(in) :: di, dj - real, intent(in) :: scale + 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 + integer, intent(in) :: di !< i- direction array shift for this checksum + integer, intent(in) :: dj !< j- direction array shift for this checksum + real, intent(in) :: scale !< A scaling factor for this array. integer :: i, j, bc subchk = 0 ! This line deliberately uses the h-point computational domain. do J=HI%jsc+dj,HI%jec+dj; do i=HI%isc+di,HI%iec+di bc = bitcount(abs(scale*array(i,J))) subchk = subchk + bc - enddo; enddo + enddo ; enddo call sum_across_PEs(subchk) subchk=mod(subchk,1000000000) end function subchk subroutine subStats(HI, array, mesg, sym_stats) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%isd:,HI%JsdB:), intent(in) :: array - character(len=*), intent(in) :: mesg - logical, intent(in) :: sym_stats + 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. integer :: i, j, n, JsB real :: aMean, aMin, aMax @@ -743,9 +770,7 @@ end subroutine subStats end subroutine chksum_v_2d -! ===================================================================== - -!> chksum_h_3d performs checksums on a 3d array staggered at tracer points. +!> Checksums a 3d array staggered at tracer points. subroutine chksum_h_3d(array, mesg, HI, haloshift, omit_corners, scale) 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 @@ -826,10 +851,11 @@ subroutine chksum_h_3d(array, mesg, HI, haloshift, omit_corners, scale) contains integer function subchk(array, HI, di, dj, scale) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: array - integer, intent(in) :: di, dj - real, intent(in) :: scale + 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 + integer, intent(in) :: di !< i- direction array shift for this checksum + integer, intent(in) :: dj !< j- direction array shift for this checksum + real, intent(in) :: scale !< A scaling factor for this array. integer :: i, j, k, bc subchk = 0 do k=LBOUND(array,3),UBOUND(array,3) ; do j=HI%jsc+dj,HI%jec+dj ; do i=HI%isc+di,HI%iec+di @@ -841,9 +867,9 @@ integer function subchk(array, HI, di, dj, scale) end function subchk subroutine subStats(HI, array, mesg) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: array - character(len=*), intent(in) :: mesg + 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 :: i, j, k, n real :: aMean, aMin, aMax @@ -866,15 +892,14 @@ end subroutine subStats end subroutine chksum_h_3d -! ===================================================================== - -!> chksum_B_3d performs checksums on a 3d array staggered at corner points. +!> Checksums a 3d array staggered at corner points. subroutine chksum_B_3d(array, mesg, HI, haloshift, symmetric, omit_corners, scale) 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 integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) - logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full symmetric computational domain. + logical, optional, intent(in) :: symmetric !< If true, do the checksums on the 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. @@ -966,10 +991,11 @@ subroutine chksum_B_3d(array, mesg, HI, haloshift, symmetric, omit_corners, scal contains integer function subchk(array, HI, di, dj, scale) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%IsdB:,HI%JsdB:,:), intent(in) :: array - integer, intent(in) :: di, dj - real, intent(in) :: scale + 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 + integer, intent(in) :: di !< i- direction array shift for this checksum + integer, intent(in) :: dj !< j- direction array shift for this checksum + real, intent(in) :: scale !< A scaling factor for this array. integer :: i, j, k, bc subchk = 0 ! This line deliberately uses the h-point computational domain. @@ -982,10 +1008,11 @@ integer function subchk(array, HI, di, dj, scale) end function subchk subroutine subStats(HI, array, mesg, sym_stats) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%IsdB:,HI%JsdB:,:), intent(in) :: array - character(len=*), intent(in) :: mesg - logical, intent(in) :: sym_stats + 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. integer :: i, j, k, n, IsB, JsB real :: aMean, aMin, aMax @@ -1009,15 +1036,14 @@ end subroutine subStats end subroutine chksum_B_3d -! ===================================================================== - -!> chksum_u_3d performs checksums on a 3d array staggered at C-grid u points. +!> Checksums a 3d array staggered at C-grid u points. subroutine chksum_u_3d(array, mesg, HI, haloshift, symmetric, omit_corners, scale) 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 integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) - logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full symmetric computational domain. + logical, optional, intent(in) :: symmetric !< If true, do the checksums on the 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. @@ -1109,10 +1135,11 @@ subroutine chksum_u_3d(array, mesg, HI, haloshift, symmetric, omit_corners, scal contains integer function subchk(array, HI, di, dj, scale) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%IsdB:,HI%jsd:,:), intent(in) :: array - integer, intent(in) :: di, dj - real, intent(in) :: scale + 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 + integer, intent(in) :: di !< i- direction array shift for this checksum + integer, intent(in) :: dj !< j- direction array shift for this checksum + real, intent(in) :: scale !< A scaling factor for this array. integer :: i, j, k, bc subchk = 0 ! This line deliberately uses the h-point computational domain. @@ -1125,10 +1152,11 @@ integer function subchk(array, HI, di, dj, scale) end function subchk subroutine subStats(HI, array, mesg, sym_stats) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%IsdB:,HI%jsd:,:), intent(in) :: array - character(len=*), intent(in) :: mesg - logical, intent(in) :: sym_stats + 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. integer :: i, j, k, n, IsB real :: aMean, aMin, aMax @@ -1152,17 +1180,17 @@ end subroutine subStats end subroutine chksum_u_3d -!---chksum_general interface routines !> 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(:,:,:) :: array !< Array to be checksummed - real, optional :: scale_factor !< Factor to scale array by before checksum - integer, optional :: istart !< Starting index in the i-direction - integer, optional :: iend !< Ending index in the i-direction - integer, optional :: jstart !< Starting index in the j-direction - integer, optional :: jend !< Ending index in the j-direction - integer, optional :: kstart !< Starting index in the k-direction - integer, optional :: kend !< Ending index in the k-direction +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 @@ -1191,12 +1219,12 @@ 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(:,:) :: array_2d !< Array to be checksummed - real, optional :: scale_factor !< Factor to scale array by before checksum - integer, optional :: istart !< Starting index in the i-direction - integer, optional :: iend !< Ending index in the i-direction - integer, optional :: jstart !< Starting index in the j-direction - integer, optional :: jend !< Ending index in the j-direction + 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 @@ -1210,11 +1238,11 @@ 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(:) :: array_1d !< Array to be checksummed - real, optional :: scale_factor !< Factor to scale array by before checksum - integer, optional :: istart !< Starting index in the i-direction - integer, optional :: iend !< Ending index in the i-direction - integer :: is, ie, js, je + 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) @@ -1224,15 +1252,14 @@ integer function chksum_general_1d( array_1d, scale_factor, istart, iend ) deallocate(array_3d) end function chksum_general_1d -! ===================================================================== - -!> chksum_v_3d performs checksums on a 3d array staggered at C-grid v points. +!> Checksums a 3d array staggered at C-grid v points. subroutine chksum_v_3d(array, mesg, HI, haloshift, symmetric, omit_corners, scale) 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 integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) - logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full symmetric computational domain. + logical, optional, intent(in) :: symmetric !< If true, do the checksums on the 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. @@ -1324,10 +1351,11 @@ subroutine chksum_v_3d(array, mesg, HI, haloshift, symmetric, omit_corners, scal contains integer function subchk(array, HI, di, dj, scale) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%isd:,HI%JsdB:,:), intent(in) :: array - integer, intent(in) :: di, dj - real, intent(in) :: scale + 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 + integer, intent(in) :: di !< i- direction array shift for this checksum + integer, intent(in) :: dj !< j- direction array shift for this checksum + real, intent(in) :: scale !< A scaling factor for this array. integer :: i, j, k, bc subchk = 0 ! This line deliberately uses the h-point computational domain. @@ -1340,10 +1368,11 @@ integer function subchk(array, HI, di, dj, scale) end function subchk subroutine subStats(HI, array, mesg, sym_stats) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%isd:,HI%JsdB:,:), intent(in) :: array - character(len=*), intent(in) :: mesg - logical, intent(in) :: sym_stats + 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. integer :: i, j, k, n, JsB real :: aMean, aMin, aMax @@ -1367,9 +1396,6 @@ end subroutine subStats end subroutine chksum_v_3d - -! ===================================================================== - ! These are the older version of chksum that do not take the grid staggering ! into account. @@ -1428,15 +1454,14 @@ subroutine chksum1d(array, mesg, start_i, end_i, compare_PEs) end subroutine chksum1d -! ===================================================================== ! These are the older version of chksum that do not take the grid staggering ! into account. !> chksum2d does a checksum of all data in a 2-d array. subroutine chksum2d(array, mesg) - real, dimension(:,:) :: array - character(len=*) :: mesg + real, dimension(:,:) :: array !< The array to be checksummed + character(len=*) :: mesg !< An identifying message integer :: xs,xe,ys,ye,i,j,sum1,bc real :: sum @@ -1463,8 +1488,8 @@ end subroutine chksum2d !> chksum3d does a checksum of all data in a 2-d array. subroutine chksum3d(array, mesg) - real, dimension(:,:,:) :: array - character(len=*) :: mesg + real, dimension(:,:,:) :: array !< The array to be checksummed + character(len=*) :: mesg !< An identifying message integer :: xs,xe,ys,ye,zs,ze,i,j,k, bc,sum1 real :: sum @@ -1489,8 +1514,6 @@ subroutine chksum3d(array, mesg) end subroutine chksum3d -! ===================================================================== - !> This function returns .true. if x is a NaN, and .false. otherwise. function is_NaN_0d(x) real, intent(in) :: x !< The value to be checked for NaNs. @@ -1507,13 +1530,12 @@ function is_NaN_0d(x) end function is_NaN_0d -! ===================================================================== - -!> This function returns .true. if any element of x is a NaN, and .false. otherwise. +!> Returns .true. if any element of x is a NaN, and .false. otherwise. function is_NaN_1d(x, skip_mpp) real, dimension(:), intent(in) :: x !< The array to be checked for NaNs. + logical, optional, intent(in) :: skip_mpp !< If true, only check this array only + !! on the local PE (default false). logical :: is_NaN_1d - logical, optional :: skip_mpp !< If true, only check this array only on the local PE (default false). integer :: i, n logical :: call_mpp @@ -1531,9 +1553,7 @@ function is_NaN_1d(x, skip_mpp) end function is_NaN_1d -! ===================================================================== - -!> This function returns .true. if any element of x is a NaN, and .false. otherwise. +!> Returns .true. if any element of x is a NaN, and .false. otherwise. function is_NaN_2d(x) real, dimension(:,:), intent(in) :: x !< The array to be checked for NaNs. logical :: is_NaN_2d @@ -1550,9 +1570,7 @@ function is_NaN_2d(x) end function is_NaN_2d -! ===================================================================== - -!> This function returns .true. if any element of x is a NaN, and .false. otherwise. +!> Returns .true. if any element of x is a NaN, and .false. otherwise. function is_NaN_3d(x) real, dimension(:,:,:), intent(in) :: x !< The array to be checked for NaNs. logical :: is_NaN_3d @@ -1571,70 +1589,81 @@ 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) - character(len=*), intent(in) :: fmsg, mesg - integer, intent(in) :: bc0 + 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) 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) - character(len=*), intent(in) :: fmsg, mesg - integer, intent(in) :: bc0,bcSW,bcSE,bcNW,bcNE + 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 for SW shifted array + 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) 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) - character(len=*), intent(in) :: fmsg, mesg - integer, intent(in) :: bc0, bcN, bcS, bcE, bcW + 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) :: bcN !< The bitcount for N shifted array + 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) 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) - character(len=*), intent(in) :: fmsg, mesg - integer, intent(in) :: bc0, bcS + 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) 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) - character(len=*), intent(in) :: fmsg, mesg - integer, intent(in) :: bc0, bcW + 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) 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) - character(len=*), intent(in) :: fmsg, mesg - integer, intent(in) :: bc0,bcSW + 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) 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) - character(len=*), intent(in) :: fmsg, mesg - real, intent(in) :: aMean,aMin,aMax + 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) end subroutine chk_sum_msg3 -! ===================================================================== - !> MOM_checksums_init initializes the MOM_checksums module. As it happens, the !! only thing that it does is to log the version of this module. subroutine MOM_checksums_init(param_file) @@ -1647,13 +1676,11 @@ subroutine MOM_checksums_init(param_file) end subroutine MOM_checksums_init -! ===================================================================== - +!> A wrapper for MOM_error used in the checksum code subroutine chksum_error(signal, message) - ! Wrapper for MOM_error to help place specific break points in - ! debuggers - integer, intent(in) :: signal - character(len=*), intent(in) :: message + ! Wrapper for MOM_error to help place specific break points in debuggers + integer, intent(in) :: signal !< An error severity level, such as FATAL or WARNING + character(len=*), intent(in) :: message !< An error message call MOM_error(signal, message) end subroutine chksum_error @@ -1675,6 +1702,5 @@ integer function bitcount( x ) enddo end function bitcount -! ===================================================================== end module MOM_checksums diff --git a/src/framework/MOM_coms.F90 b/src/framework/MOM_coms.F90 index d2a268a741..47601db679 100644 --- a/src/framework/MOM_coms.F90 +++ b/src/framework/MOM_coms.F90 @@ -1,3 +1,5 @@ +!> Interfaces to non-domain-oriented communication subroutines, including the +!! MOM6 reproducing sums facility module MOM_coms ! This file is part of MOM6. See LICENSE.md for the license. @@ -23,49 +25,77 @@ module MOM_coms ! This module provides interfaces to the non-domain-oriented communication ! subroutines. -integer(kind=8), parameter :: prec=2_8**46 ! The precision of each integer. -real, parameter :: r_prec=2.0**46 ! A real version of prec. -real, parameter :: I_prec=1.0/(2.0**46) ! The inverse of prec. +integer(kind=8), parameter :: prec=2_8**46 !< The precision of each integer. +real, parameter :: r_prec=2.0**46 !< A real version of prec. +real, parameter :: I_prec=1.0/(2.0**46) !< The inverse of prec. integer, parameter :: max_count_prec=2**(63-46)-1 - ! The number of values that can be added together - ! with the current value of prec before there will - ! be roundoff problems. + !< The number of values that can be added together + !! with the current value of prec before there will + !! be roundoff problems. -integer, parameter :: ni=6 ! The number of long integers to use to represent - ! a real number. +integer, parameter :: ni=6 !< The number of long integers to use to represent + !< a real number. real, parameter, dimension(ni) :: & pr = (/ r_prec**2, r_prec, 1.0, 1.0/r_prec, 1.0/r_prec**2, 1.0/r_prec**3 /) + !< 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 -logical :: overflow_error = .false., NaN_error = .false. -logical :: debug = .false. ! Making this true enables debugging output. +logical :: overflow_error = .false. !< This becomes true if an overflow is encountered. +logical :: NaN_error = .false. !< This becomes true if a NaN is encountered. +logical :: debug = .false. !< Making this true enables debugging output. +!> Find an accurate and order-invariant sum of distributed 2d or 3d fields interface reproducing_sum module procedure reproducing_sum_2d, reproducing_sum_3d end interface reproducing_sum -! The Extended Fixed Point (EFP) type provides a public interface for doing -! sums and taking differences with this type. +!> The Extended Fixed Point (EFP) type provides a public interface for doing sums +!! and taking differences with this type. +!! +!! The use of this type is documented in +!! Hallberg, R. & A. Adcroft, 2014: An Order-invariant Real-to-Integer Conversion Sum. +!! Parallel Computing, 40(5-6), doi:10.1016/j.parco.2014.04.007. type, public :: EFP_type ; private - integer(kind=8), dimension(ni) :: v + integer(kind=8), dimension(ni) :: v !< The value in this type end type EFP_type -interface operator (+); module procedure EFP_plus ; end interface -interface operator (-); module procedure EFP_minus ; end interface +!> Add two extended-fixed-point numbers +interface operator (+) ; module procedure EFP_plus ; end interface +!> Subtract one extended-fixed-point number from another +interface operator (-) ; module procedure EFP_minus ; end interface +!> Copy the value of one extended-fixed-point number into another interface assignment(=); module procedure EFP_assign ; end interface contains +!> This subroutine uses a conversion to an integer representation of real numbers to give an +!! order-invariant sum of distributed 2-D arrays that reproduces across domain decomposition. +!! This technique is described in Hallberg & Adcroft, 2014, Parallel Computing, +!! doi:10.1016/j.parco.2014.04.007. function reproducing_sum_2d(array, isr, ier, jsr, jer, EFP_sum, reproducing, & overflow_check, err) result(sum) - real, dimension(:,:), intent(in) :: array - integer, optional, intent(in) :: isr, ier, jsr, jer - type(EFP_type), optional, intent(out) :: EFP_sum - logical, optional, intent(in) :: reproducing - logical, optional, intent(in) :: overflow_check - integer, optional, intent(out) :: err - real :: sum ! Result + real, dimension(:,:), intent(in) :: array !< The array to be summed + integer, optional, intent(in) :: isr !< The starting i-index of the sum, noting + !! that the array indices starts at 1 + integer, optional, intent(in) :: ier !< The ending i-index of the sum, noting + !! that the array indices starts at 1 + integer, optional, intent(in) :: jsr !< The starting j-index of the sum, noting + !! that the array indices starts at 1 + integer, optional, intent(in) :: jer !< The ending j-index of the sum, noting + !! that the array indices starts at 1 + type(EFP_type), optional, intent(out) :: EFP_sum !< The result in extended fixed point format + logical, optional, intent(in) :: reproducing !< If present and false, do the sum + !! using the naive non-reproducing approach + logical, optional, intent(in) :: overflow_check !< If present and false, disable + !! checking for overflows in incremental results. + !! This can speed up calculations if the number + !! of values being summed is small enough + integer, optional, intent(out) :: err !< If present, return an error code instead of + !! triggering any fatal errors directly from + !! this routine. + real :: sum !< Result ! This subroutine uses a conversion to an integer representation ! of real numbers to give order-invariant sums that will reproduce @@ -116,20 +146,20 @@ function reproducing_sum_2d(array, isr, ier, jsr, jer, EFP_sum, reproducing, & if (over_check) then if ((je+1-js)*(ie+1-is) < max_count_prec) then do j=js,je ; do i=is,ie - call increment_ints_faster(ints_sum, array(i,j), max_mag_term); + call increment_ints_faster(ints_sum, array(i,j), max_mag_term) enddo ; enddo call carry_overflow(ints_sum, prec_error) elseif ((ie+1-is) < max_count_prec) then do j=js,je do i=is,ie - call increment_ints_faster(ints_sum, array(i,j), max_mag_term); + call increment_ints_faster(ints_sum, array(i,j), max_mag_term) enddo call carry_overflow(ints_sum, prec_error) enddo else do j=js,je ; do i=is,ie call increment_ints(ints_sum, real_to_ints(array(i,j), prec_error), & - prec_error); + prec_error) enddo ; enddo endif else @@ -172,7 +202,7 @@ function reproducing_sum_2d(array, isr, ier, jsr, jer, EFP_sum, reproducing, & else rsum(1) = 0.0 do j=js,je ; do i=is,ie - rsum(1) = rsum(1) + array(i,j); + rsum(1) = rsum(1) + array(i,j) enddo ; enddo call sum_across_PEs(rsum,1) sum = rsum(1) @@ -202,14 +232,27 @@ function reproducing_sum_2d(array, isr, ier, jsr, jer, EFP_sum, reproducing, & end function reproducing_sum_2d +!> This subroutine uses a conversion to an integer representation of real numbers to give an +!! order-invariant sum of distributed 3-D arrays that reproduces across domain decomposition. +!! This technique is described in Hallberg & Adcroft, 2014, Parallel Computing, +!! doi:10.1016/j.parco.2014.04.007. function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, err) & result(sum) - real, dimension(:,:,:), intent(in) :: array - integer, optional, intent(in) :: isr, ier, jsr, jer - real, dimension(:), optional, intent(out) :: sums - type(EFP_type), optional, intent(out) :: EFP_sum - integer, optional, intent(out) :: err - real :: sum ! Result + real, dimension(:,:,:), intent(in) :: array !< The array to be summed + integer, optional, intent(in) :: isr !< The starting i-index of the sum, noting + !! that the array indices starts at 1 + integer, optional, intent(in) :: ier !< The ending i-index of the sum, noting + !! that the array indices starts at 1 + integer, optional, intent(in) :: jsr !< The starting j-index of the sum, noting + !! that the array indices starts at 1 + integer, optional, intent(in) :: jer !< The ending j-index of the sum, noting + !! that the array indices starts at 1 + real, dimension(:), optional, intent(out) :: sums !< The sums by vertical layer + type(EFP_type), optional, intent(out) :: EFP_sum !< The result in extended fixed point format + integer, optional, intent(out) :: err !< If present, return an error code instead of + !! triggering any fatal errors directly from + !! this routine. + real :: sum !< Result ! This subroutine uses a conversion to an integer representation ! of real numbers to give order-invariant sums that will reproduce @@ -260,21 +303,21 @@ function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, err) & if (jsz*isz < max_count_prec) then do k=1,ke do j=js,je ; do i=is,ie - call increment_ints_faster(ints_sums(:,k), array(i,j,k), max_mag_term); + call increment_ints_faster(ints_sums(:,k), array(i,j,k), max_mag_term) enddo ; enddo call carry_overflow(ints_sums(:,k), prec_error) enddo elseif (isz < max_count_prec) then do k=1,ke ; do j=js,je do i=is,ie - call increment_ints_faster(ints_sums(:,k), array(i,j,k), max_mag_term); + call increment_ints_faster(ints_sums(:,k), array(i,j,k), max_mag_term) enddo call carry_overflow(ints_sums(:,k), prec_error) enddo ; enddo else do k=1,ke ; do j=js,je ; do i=is,ie call increment_ints(ints_sums(:,k), & - real_to_ints(array(i,j,k), prec_error), prec_error); + real_to_ints(array(i,j,k), prec_error), prec_error) enddo ; enddo ; enddo endif if (present(err)) then @@ -318,21 +361,21 @@ function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, err) & if (jsz*isz < max_count_prec) then do k=1,ke do j=js,je ; do i=is,ie - call increment_ints_faster(ints_sum, array(i,j,k), max_mag_term); + call increment_ints_faster(ints_sum, array(i,j,k), max_mag_term) enddo ; enddo call carry_overflow(ints_sum, prec_error) enddo elseif (isz < max_count_prec) then do k=1,ke ; do j=js,je do i=is,ie - call increment_ints_faster(ints_sum, array(i,j,k), max_mag_term); + call increment_ints_faster(ints_sum, array(i,j,k), max_mag_term) enddo call carry_overflow(ints_sum, prec_error) enddo ; enddo else do k=1,ke ; do j=js,je ; do i=is,ie call increment_ints(ints_sum, real_to_ints(array(i,j,k), prec_error), & - prec_error); + prec_error) enddo ; enddo ; enddo endif if (present(err)) then @@ -365,10 +408,15 @@ function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, err) & end function reproducing_sum_3d +!> Convert a real number into the array of integers constitute its extended-fixed-point representation function real_to_ints(r, prec_error, overflow) result(ints) - real, intent(in) :: r - integer(kind=8), optional, intent(in) :: prec_error - logical, optional, intent(inout) :: overflow + real, intent(in) :: r !< The real number being converted + integer(kind=8), optional, intent(in) :: prec_error !< The PE-count dependent precision of the + !! integers that is safe from overflows during global + !! sums. This will be larger than the compile-time + !! precision parameter, and is used to detect overflows. + logical, optional, intent(inout) :: overflow !< Returns true if the conversion is being + !! done on a value that is too large to be represented integer(kind=8), dimension(ni) :: ints ! This subroutine converts a real number to an equivalent representation ! using several long integers. @@ -401,8 +449,10 @@ function real_to_ints(r, prec_error, overflow) result(ints) end function real_to_ints +!> Convert the array of integers that constitute an extended-fixed-point +!! representation into a real number function ints_to_real(ints) result(r) - integer(kind=8), dimension(ni), intent(in) :: ints + integer(kind=8), dimension(ni), intent(in) :: ints !< The array of EFP integers real :: r ! This subroutine reverses the conversion in real_to_ints. @@ -412,10 +462,15 @@ function ints_to_real(ints) result(r) do i=1,ni ; r = r + pr(i)*ints(i) ; enddo end function ints_to_real +!> Increment an array of integers that constitutes an extended-fixed-point +!! representation with a another EFP number subroutine increment_ints(int_sum, int2, prec_error) - integer(kind=8), dimension(ni), intent(inout) :: int_sum - integer(kind=8), dimension(ni), intent(in) :: int2 - integer(kind=8), optional, intent(in) :: prec_error + integer(kind=8), dimension(ni), intent(inout) :: int_sum !< The array of EFP integers being incremented + integer(kind=8), dimension(ni), intent(in) :: int2 !< The array of EFP integers being added + integer(kind=8), optional, intent(in) :: prec_error !< The PE-count dependent precision of the + !! integers that is safe from overflows during global + !! sums. This will be larger than the compile-time + !! precision parameter, and is used to detect overflows. ! This subroutine increments a number with another, both using the integer ! representation in real_to_ints. @@ -441,10 +496,12 @@ subroutine increment_ints(int_sum, int2, prec_error) end subroutine increment_ints +!> Increment an EFP number with a real number without doing any carrying of +!! of overflows and using only minimal error checking. subroutine increment_ints_faster(int_sum, r, max_mag_term) - integer(kind=8), dimension(ni), intent(inout) :: int_sum - real, intent(in) :: r - real, intent(inout) :: max_mag_term + integer(kind=8), dimension(ni), intent(inout) :: int_sum !< The array of EFP integers being incremented + real, intent(in) :: r !< The real number being added. + real, intent(inout) :: max_mag_term !< A running maximum magnitude of the r's. ! This subroutine increments a number with another, both using the integer ! representation in real_to_ints, but without doing any carrying of overflow. @@ -466,9 +523,14 @@ subroutine increment_ints_faster(int_sum, r, max_mag_term) end subroutine increment_ints_faster +!> This subroutine handles carrying of the overflow. subroutine carry_overflow(int_sum, prec_error) - integer(kind=8), dimension(ni), intent(inout) :: int_sum - integer(kind=8), intent(in) :: prec_error + integer(kind=8), dimension(ni), intent(inout) :: int_sum !< The array of EFP integers being + !! modified by carries, but without changing value. + integer(kind=8), intent(in) :: prec_error !< The PE-count dependent precision of the + !! integers that is safe from overflows during global + !! sums. This will be larger than the compile-time + !! precision parameter, and is used to detect overflows. ! This subroutine handles carrying of the overflow. integer :: i, num_carry @@ -484,8 +546,13 @@ subroutine carry_overflow(int_sum, prec_error) end subroutine carry_overflow +!> This subroutine carries the overflow, and then makes sure that +!! all integers are of the same sign as the overall value. subroutine regularize_ints(int_sum) - integer(kind=8), dimension(ni), intent(inout) :: int_sum + integer(kind=8), dimension(ni), & + intent(inout) :: int_sum !< The array of integers being modified to take a + !! regular form with all integers of the same sign, + !! but without changing value. ! This subroutine carries the overflow, and then makes sure that ! all integers are of the same sign as the overall value. @@ -521,27 +588,34 @@ subroutine regularize_ints(int_sum) end subroutine regularize_ints +!> Returns the status of the module's error flag function query_EFP_overflow_error() logical :: query_EFP_overflow_error query_EFP_overflow_error = overflow_error end function query_EFP_overflow_error +!> Reset the module's error flag to false subroutine reset_EFP_overflow_error() overflow_error = .false. end subroutine reset_EFP_overflow_error +!> Add two extended-fixed-point numbers function EFP_plus(EFP1, EFP2) - type(EFP_type) :: EFP_plus - type(EFP_type), intent(in) :: EFP1, EFP2 + type(EFP_type) :: EFP_plus !< The result in extended fixed point format + type(EFP_type), intent(in) :: EFP1 !< The first extended fixed point number + type(EFP_type), intent(in) :: EFP2 !< The second extended fixed point number EFP_plus = EFP1 call increment_ints(EFP_plus%v(:), EFP2%v(:)) end function EFP_plus +!> Subract one extended-fixed-point number from another function EFP_minus(EFP1, EFP2) - type(EFP_type) :: EFP_minus - type(EFP_type), intent(in) :: EFP1, EFP2 + type(EFP_type) :: EFP_minus !< The result in extended fixed point format + type(EFP_type), intent(in) :: EFP1 !< The first extended fixed point number + type(EFP_type), intent(in) :: EFP2 !< The extended fixed point number being + !! subtracted from the first extended fixed point number integer :: i do i=1,ni ; EFP_minus%v(i) = -1*EFP2%v(i) ; enddo @@ -549,9 +623,10 @@ function EFP_minus(EFP1, EFP2) call increment_ints(EFP_minus%v(:), EFP1%v(:)) end function EFP_minus +!> Copy one extended-fixed-point number into another subroutine EFP_assign(EFP1, EFP2) - type(EFP_type), intent(out) :: EFP1 - type(EFP_type), intent(in) :: EFP2 + type(EFP_type), intent(out) :: EFP1 !< The recipient extended fixed point number + type(EFP_type), intent(in) :: EFP2 !< The source extended fixed point number integer i ! This subroutine assigns all components of the extended fixed point type ! variable on the RHS (EFP2) to the components of the variable on the LHS @@ -560,17 +635,22 @@ subroutine EFP_assign(EFP1, EFP2) do i=1,ni ; EFP1%v(i) = EFP2%v(i) ; enddo end subroutine EFP_assign +!> Return the real number that an extended-fixed-point number corresponds with function EFP_to_real(EFP1) - type(EFP_type), intent(inout) :: EFP1 + type(EFP_type), intent(inout) :: EFP1 !< The extended fixed point number being converted real :: EFP_to_real call regularize_ints(EFP1%v) EFP_to_real = ints_to_real(EFP1%v) end function EFP_to_real +!> Take the difference between two extended-fixed-point numbers (EFP1 - EFP2) +!! and return the result as a real number function EFP_real_diff(EFP1, EFP2) - type(EFP_type), intent(in) :: EFP1, EFP2 - real :: EFP_real_diff + type(EFP_type), intent(in) :: EFP1 !< The first extended fixed point number + type(EFP_type), intent(in) :: EFP2 !< The extended fixed point number being + !! subtracted from the first extended fixed point number + real :: EFP_real_diff !< The real result type(EFP_type) :: EFP_diff @@ -579,9 +659,11 @@ function EFP_real_diff(EFP1, EFP2) end function EFP_real_diff +!> Return the extended-fixed-point number that a real number corresponds with function real_to_EFP(val, overflow) - real, intent(in) :: val - logical, optional, intent(inout) :: overflow + real, intent(in) :: val !< The real number being converted + logical, optional, intent(inout) :: overflow !< Returns true if the conversion is being + !! done on a value that is too large to be represented type(EFP_type) :: real_to_EFP logical :: over @@ -600,10 +682,15 @@ function real_to_EFP(val, overflow) end function real_to_EFP +!> This subroutine does a sum across PEs of a list of EFP variables, +!! returning the sums in place, with all overflows carried. subroutine EFP_list_sum_across_PEs(EFPs, nval, errors) - type(EFP_type), dimension(:), intent(inout) :: EFPs - integer, intent(in) :: nval - logical, dimension(:), optional, intent(out) :: errors + type(EFP_type), dimension(:), & + intent(inout) :: EFPs !< The list of extended fixed point numbers + !! being summed across PEs. + integer, intent(in) :: nval !< The number of values being summed. + logical, dimension(:), & + optional, intent(out) :: errors !< A list of error flags for each sum ! This subroutine does a sum across PEs of a list of EFP variables, ! returning the sums in place, with all overflows carried. @@ -645,10 +732,9 @@ subroutine EFP_list_sum_across_PEs(EFPs, nval, errors) end subroutine EFP_list_sum_across_PEs +!> This subroutine carries out all of the calls required to close out the infrastructure cleanly. +!! This should only be called in ocean-only runs, as the coupler takes care of this in coupled runs. subroutine MOM_infra_end - ! This subroutine should contain all of the calls that are required - ! to close out the infrastructure cleanly. This should only be called - ! in ocean-only runs, as the coupler takes care of this in coupled runs. call print_memuse_stats( 'Memory HiWaterMark', always=.TRUE. ) call fms_end end subroutine MOM_infra_end diff --git a/src/framework/MOM_constants.F90 b/src/framework/MOM_constants.F90 index 84c82069d0..2db177e08c 100644 --- a/src/framework/MOM_constants.F90 +++ b/src/framework/MOM_constants.F90 @@ -7,6 +7,7 @@ module MOM_constants implicit none ; private +!> The constant offset for converting temperatures in Kelvin to Celsius real, public, parameter :: CELSIUS_KELVIN_OFFSET = 273.15 public :: HLV, HLF diff --git a/src/framework/MOM_diag_manager_wrapper.F90 b/src/framework/MOM_diag_manager_wrapper.F90 index 81e26634a7..709fd80a8e 100644 --- a/src/framework/MOM_diag_manager_wrapper.F90 +++ b/src/framework/MOM_diag_manager_wrapper.F90 @@ -6,6 +6,8 @@ module MOM_diag_manager_wrapper use MOM_time_manager, only : time_type use diag_manager_mod, only : register_diag_field +implicit none ; private + public register_diag_field_fms !> A wrapper for register_diag_field_array() @@ -19,20 +21,25 @@ module MOM_diag_manager_wrapper integer function register_diag_field_array_fms(module_name, field_name, axes, init_time, & long_name, units, missing_value, range, mask_variant, standard_name, & verbose, do_not_log, err_msg, interp_method, tile_count, area, volume) - character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" or "ice_shelf_model" + character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" or + !! "ice_shelf_model" character(len=*), intent(in) :: field_name !< Name of the diagnostic field - integer, intent(in) :: axes(:) !< Container w/ up to 3 integer handles that indicates axes for this field + integer, intent(in) :: axes(:) !< Container w/ up to 3 integer handles that + !! indicates axes for this field type(time_type), intent(in) :: init_time !< Time at which a field is first available? character(len=*), optional, intent(in) :: long_name !< Long name of a field. character(len=*), optional, intent(in) :: units !< Units of a field. character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field real, optional, intent(in) :: missing_value !< A value that indicates missing values. real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) - logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided with post_data calls (not used in MOM?) + logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided with + !! post_data calls (not used in MOM?) logical, optional, intent(in) :: verbose !< If true, FMS is verbose (not used in MOM?) logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?) - character(len=*), optional, intent(out):: err_msg !< String into which an error message might be placed (not used in MOM?) - character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should not be interpolated as a scalar + character(len=*), optional, intent(out):: err_msg !< String into which an error message might be + !! placed (not used in MOM?) + character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should not be + !! interpolated as a scalar integer, optional, intent(in) :: tile_count !< no clue (not used in MOM?) integer, optional, intent(in) :: area !< The FMS id of cell area integer, optional, intent(in) :: volume !< The FMS id of cell volume @@ -50,7 +57,8 @@ end function register_diag_field_array_fms integer function register_diag_field_scalar_fms(module_name, field_name, init_time, & long_name, units, missing_value, range, mask_variant, standard_name, & verbose, do_not_log, err_msg, interp_method, tile_count, area, volume) - character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" or "ice_shelf_model" + character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" + !! or "ice_shelf_model" character(len=*), intent(in) :: field_name !< Name of the diagnostic field type(time_type), intent(in) :: init_time !< Time at which a field is first available? character(len=*), optional, intent(in) :: long_name !< Long name of a field. @@ -58,11 +66,14 @@ integer function register_diag_field_scalar_fms(module_name, field_name, init_ti character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field real, optional, intent(in) :: missing_value !< A value that indicates missing values. real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) - logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided with post_data calls (not used in MOM?) + logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided with + !! post_data calls (not used in MOM?) logical, optional, intent(in) :: verbose !< If true, FMS is verbose (not used in MOM?) logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?) - character(len=*), optional, intent(out):: err_msg !< String into which an error message might be placed (not used in MOM?) - character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should not be interpolated as a scalar + character(len=*), optional, intent(out):: err_msg !< String into which an error message might + !! be placed (not used in MOM?) + character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should not + !! be interpolated as a scalar integer, optional, intent(in) :: tile_count !< no clue (not used in MOM?) integer, optional, intent(in) :: area !< The FMS id of cell area (not used for scalars) integer, optional, intent(in) :: volume !< The FMS id of cell volume (not used for scalars) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index cd378cff09..d862f8c815 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -1,24 +1,21 @@ +!> The subroutines here provide convenient wrappers to the fms diag_manager +!! interfaces with additional diagnostic capabilies. module MOM_diag_mediator ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* The subroutines here provide convenient wrappers to the fms * -!* diag_manager interfaces with additional diagnostic capabilies. * -!* * -!********+*********+*********+*********+*********+*********+*********+** use MOM_checksums, only : chksum_general 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 -use MOM_error_handler, only : MOM_error, FATAL, is_root_pe, assert +use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe, assert 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_safe_alloc, only : safe_alloc_ptr, safe_alloc_alloc use MOM_string_functions, only : lowercase use MOM_time_manager, only : time_type +use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type use MOM_EOS, only : EOS_type use MOM_diag_remap, only : diag_remap_ctrl @@ -46,6 +43,7 @@ module MOM_diag_mediator #undef __DO_SAFETY_CHECKS__ #define IMPLIES(A, B) ((.not. (A)) .or. (B)) +#define MAX_DSAMP_LEV 2 public set_axes_info, post_data, register_diag_field, time_type public set_masks_for_axes @@ -66,10 +64,28 @@ module MOM_diag_mediator public diag_copy_diag_to_storage, diag_copy_storage_to_diag public diag_save_grids, diag_restore_grids +!> Make a diagnostic available for averaging or output. interface post_data - module procedure post_data_3d, post_data_2d, post_data_0d + module procedure post_data_3d, post_data_2d, post_data_1d_k, post_data_0d end interface post_data +interface downsample_field + module procedure downsample_field_2d, downsample_field_3d +end interface downsample_field + +interface downsample_mask + module procedure downsample_mask_2d, downsample_mask_3d +end interface downsample_mask + +interface downsample_diag_field + module procedure downsample_diag_field_2d, downsample_diag_field_3d +end interface downsample_diag_field + +type, private :: diag_dsamp + real, pointer, dimension(:,:) :: mask2d => null() !< Mask for 2d (x-y) axes + real, pointer, dimension(:,:,:) :: mask3d => null() !< Mask for 3d axes +end type diag_dsamp + !> A group of 1D axes that comprise a 1D/2D/3D mesh type, public :: axes_grp character(len=15) :: id !< The id string for this particular combination of handles. @@ -78,9 +94,12 @@ module MOM_diag_mediator type(diag_ctrl), pointer :: diag_cs => null() !< Circular link back to the main diagnostics control structure !! (Used to avoid passing said structure into every possible call). ! ID's for cell_methods - character(len=9) :: x_cell_method = '' !< Default nature of data representation, if axes group includes x-direction. - character(len=9) :: y_cell_method = '' !< Default nature of data representation, if axes group includes y-direction. - character(len=9) :: v_cell_method = '' !< Default nature of data representation, if axes group includes vertical direction. + character(len=9) :: x_cell_method = '' !< Default nature of data representation, if axes group + !! includes x-direction. + character(len=9) :: y_cell_method = '' !< Default nature of data representation, if axes group + !! includes y-direction. + character(len=9) :: v_cell_method = '' !< Default nature of data representation, if axes group + !! includes vertical direction. ! For remapping integer :: nz = 0 !< Vertical dimension of diagnostic integer :: vertical_coordinate_number = 0 !< Index of the corresponding diag_remap_ctrl for this axis group @@ -90,21 +109,26 @@ module MOM_diag_mediator logical :: is_u_point = .false. !< If true, indicates that this axes group is for a u-point located field. logical :: is_v_point = .false. !< If true, indicates that this axes group is for a v-point located field. logical :: is_layer = .false. !< If true, indicates that this axes group is for a layer vertically-located field. - logical :: is_interface = .false. !< If true, indicates that this axes group is for an interface vertically-located field. - logical :: is_native = .true. !< If true, indicates that this axes group is for a native model grid. False for any other - !! grid. Used for rank>2. - logical :: needs_remapping = .false. !< If true, indicates that this axes group is for a intensive layer-located field - !! that must be remapped to these axes. Used for rank>2. - logical :: needs_interpolating = .false. !< If true, indicates that this axes group is for a sampled interface-located field - !! that must be interpolated to these axes. Used for rank>2. + logical :: is_interface = .false. !< If true, indicates that this axes group is for an interface + !! vertically-located field. + logical :: is_native = .true. !< If true, indicates that this axes group is for a native model grid. + !! False for any other grid. Used for rank>2. + logical :: needs_remapping = .false. !< If true, indicates that this axes group is for a intensive layer-located + !! field that must be remapped to these axes. Used for rank>2. + logical :: needs_interpolating = .false. !< If true, indicates that this axes group is for a sampled + !! interface-located field that must be interpolated to + !! these axes. Used for rank>2. + integer :: downsample_level = 1 !< If greater than 1, the factor by which this diagnostic/axes/masks be downsampled ! For horizontally averaged diagnositcs (applies to 2d and 3d fields only) type(axes_grp), pointer :: xyave_axes => null() !< The associated 1d axes for horizontall area-averaged diagnostics ! ID's for cell_measures integer :: id_area = -1 !< The diag_manager id for area to be used for cell_measure of variables with this axes_grp. - integer :: id_volume = -1 !< The diag_manager id for volume to be used for cell_measure of variables with this axes_grp. + integer :: id_volume = -1 !< The diag_manager id for volume to be used for cell_measure of variables + !! with this axes_grp. ! For masking real, pointer, dimension(:,:) :: mask2d => null() !< Mask for 2d (x-y) axes real, pointer, dimension(:,:,:) :: mask3d => null() !< Mask for 3d axes + type(diag_dsamp), dimension(2:MAX_DSAMP_LEV) :: dsamp !< Downsample container end type axes_grp !> Contains an array to store a diagnostic target grid @@ -119,7 +143,28 @@ module MOM_diag_mediator type(diag_grids_type), dimension(:), allocatable :: diag_grids !< Primarily empty, except h field end type diag_grid_storage +!> integers to encode the total cell methods +!integer :: PPP=111 ! x:point,y:point,z:point, this kind of diagnostic is not currently present in diag_table.MOM6 +!integer :: PPS=112 ! x:point,y:point,z:sum , this kind of diagnostic is not currently present in diag_table.MOM6 +!integer :: PPM=113 ! x:point,y:point,z:mean , this kind of diagnostic is not currently present in diag_table.MOM6 +integer :: PSP=121 ! x:point,y:sum,z:point +integer :: PSS=122 ! x:point,y:sum,z:point +integer :: PSM=123 ! x:point,y:sum,z:mean +integer :: PMP=131 ! x:point,y:mean,z:point +integer :: PMM=133 ! x:point,y:mean,z:mean +integer :: SPP=211 ! x:sum,y:point,z:point +integer :: SPS=212 ! x:sum,y:point,z:sum +integer :: SSP=221 ! x:sum;y:sum,z:point +integer :: MPP=311 ! x:mean,y:point,z:point +integer :: MPM=313 ! x:mean,y:point,z:mean +integer :: MMP=331 ! x:mean,y:mean,z:point +integer :: MMS=332 ! x:mean,y:mean,z:sum +integer :: SSS=222 ! x:sum,y:sum,z:sum +integer :: MMM=333 ! x:mean,y:mean,z:mean +integer :: MSK=-1 ! Use the downsample method of a mask + !> This type is used to represent a diagnostic at the diag_mediator level. +!! !! There can be both 'primary' and 'seconday' diagnostics. The primaries !! reside in the diag_cs%diags array. They have an id which is an index !! into this array. The secondaries are 'variations' on the primary diagnostic. @@ -129,13 +174,50 @@ module MOM_diag_mediator logical :: in_use !< True if this entry is being used. integer :: fms_diag_id !< Underlying FMS diag_manager id. integer :: fms_xyave_diag_id = -1 !< For a horizontally area-averaged diagnostic. + integer :: downsample_diag_id = -1 !< For a horizontally area-downsampled diagnostic. character(64) :: debug_str = '' !< For FATAL errors and debugging. - type(axes_grp), pointer :: axes => null() - type(diag_type), pointer :: next => null() !< Pointer to the next diag. + type(axes_grp), pointer :: axes => null() !< The axis group for this diagnostic + type(diag_type), pointer :: next => null() !< Pointer to the next diagnostic real :: conversion_factor = 0. !< A factor to multiply data by before posting to FMS, if non-zero. - logical :: v_extensive = .false. !< True for vertically extensive fields (vertically integrated). False for intensive (concentrations). + logical :: v_extensive = .false. !< True for vertically extensive fields (vertically integrated). + !! False for intensive (concentrations). + integer :: xyz_method = 0 !< A 3 digit integer encoding the diagnostics cell method + !! It can be used to determine the downsample algorithm end type diag_type +type diagcs_dsamp + integer :: isc !< The start i-index of cell centers within the computational domain + integer :: iec !< The end i-index of cell centers within the computational domain + integer :: jsc !< The start j-index of cell centers within the computational domain + integer :: jec !< The end j-index of cell centers within the computational domain + integer :: isd !< The start i-index of cell centers within the data domain + integer :: ied !< The end i-index of cell centers within the data domain + integer :: jsd !< The start j-index of cell centers within the data domain + integer :: jed !< The end j-index of cell centers within the data domain + integer :: isg,ieg,jsg,jeg + integer :: isgB,iegB,jsgB,jegB + + type(axes_grp) :: axesBL, axesTL, axesCuL, axesCvL + type(axes_grp) :: axesBi, axesTi, axesCui, axesCvi + type(axes_grp) :: axesB1, axesT1, axesCu1, axesCv1 + type(axes_grp), dimension(:), allocatable :: remap_axesTL, remap_axesBL, remap_axesCuL, remap_axesCvL + type(axes_grp), dimension(:), allocatable :: remap_axesTi, remap_axesBi, remap_axesCui, remap_axesCvi + + real, dimension(:,:), pointer :: mask2dT => null() !< 2D mask array for cell-center points + real, dimension(:,:), pointer :: mask2dBu => null() !< 2D mask array for cell-corner points + real, dimension(:,:), pointer :: mask2dCu => null() !< 2D mask array for east-face points + real, dimension(:,:), pointer :: mask2dCv => null() !< 2D mask array for north-face points + !>@{ 3D mask arrays for diagnostics at layers (mask...L) and interfaces (mask...i) + real, dimension(:,:,:), pointer :: mask3dTL => null() + real, dimension(:,:,:), pointer :: mask3dBL => null() + real, dimension(:,:,:), pointer :: mask3dCuL => null() + real, dimension(:,:,:), pointer :: mask3dCvL => null() + real, dimension(:,:,:), pointer :: mask3dTi => null() + real, dimension(:,:,:), pointer :: mask3dBi => null() + real, dimension(:,:,:), pointer :: mask3dCui => null() + real, dimension(:,:,:), pointer :: mask3dCvi => null() +end type diagcs_dsamp + !> The following data type a list of diagnostic fields an their variants, !! as well as variables that control the handling of model output. type, public :: diag_ctrl @@ -146,41 +228,56 @@ module MOM_diag_mediator logical :: diag_as_chksum !< If true, log chksums in a text file instead of posting diagnostics ! The following fields are used for the output of the data. - integer :: is, ie, js, je - integer :: isd, ied, jsd, jed - real :: time_int !< The time interval in s for any fields - !! that are offered for averaging. + integer :: is !< The start i-index of cell centers within the computational domain + integer :: ie !< The end i-index of cell centers within the computational domain + integer :: js !< The start j-index of cell centers within the computational domain + integer :: je !< The end j-index of cell centers within the computational domain + + integer :: isd !< The start i-index of cell centers within the data domain + integer :: ied !< The end i-index of cell centers within the data domain + integer :: jsd !< The start j-index of cell centers within the data domain + integer :: jed !< The end j-index of cell centers within the data domain + real :: time_int !< The time interval for any fields + !! that are offered for averaging [s]. type(time_type) :: time_end !< The end time of the valid !! interval for any offered field. logical :: ave_enabled = .false. !< True if averaging is enabled. - ! The following are axis types defined for output. + !>@{ The following are 3D and 2D axis groups defined for output. The names + !! indicate the horizontal (B, T, Cu, or Cv) and vertical (L, i, or 1) locations. type(axes_grp) :: axesBL, axesTL, axesCuL, axesCvL type(axes_grp) :: axesBi, axesTi, axesCui, axesCvi type(axes_grp) :: axesB1, axesT1, axesCu1, axesCv1 - type(axes_grp) :: axesZi, axesZL, axesNull - - ! Mask arrays for diagnostics - real, dimension(:,:), pointer :: mask2dT => null() - real, dimension(:,:), pointer :: mask2dBu => null() - real, dimension(:,:), pointer :: mask2dCu => null() - real, dimension(:,:), pointer :: mask2dCv => null() + !!@} + type(axes_grp) :: axesZi !< A 1-D z-space axis at interfaces + type(axes_grp) :: axesZL !< A 1-D z-space axis at layer centers + type(axes_grp) :: axesNull !< An axis group for scalars + + real, dimension(:,:), pointer :: mask2dT => null() !< 2D mask array for cell-center points + real, dimension(:,:), pointer :: mask2dBu => null() !< 2D mask array for cell-corner points + real, dimension(:,:), pointer :: mask2dCu => null() !< 2D mask array for east-face points + real, dimension(:,:), pointer :: mask2dCv => null() !< 2D mask array for north-face points + !>@{ 3D mask arrays for diagnostics at layers (mask...L) and interfaces (mask...i) real, dimension(:,:,:), pointer :: mask3dTL => null() - real, dimension(:,:,:), pointer :: mask3dBL => null() + real, dimension(:,:,:), pointer :: mask3dBL => null() real, dimension(:,:,:), pointer :: mask3dCuL => null() real, dimension(:,:,:), pointer :: mask3dCvL => null() real, dimension(:,:,:), pointer :: mask3dTi => null() - real, dimension(:,:,:), pointer :: mask3dBi => null() + real, dimension(:,:,:), pointer :: mask3dBi => null() real, dimension(:,:,:), pointer :: mask3dCui => null() real, dimension(:,:,:), pointer :: mask3dCvi => null() + type(diagcs_dsamp), dimension(2:MAX_DSAMP_LEV) :: dsamp !< Downsample control container + + !!@} + ! Space for diagnostics is dynamically allocated as it is needed. ! The chunk size is how much the array should grow on each new allocation. #define DIAG_ALLOC_CHUNK_SIZE 100 - type(diag_type), dimension(:), allocatable :: diags - integer :: next_free_diag_id + type(diag_type), dimension(:), allocatable :: diags !< The list of diagnostics + integer :: next_free_diag_id !< The next unused diagnostic ID - !default missing value to be sent to ALL diagnostics registrations + !> default missing value to be sent to ALL diagnostics registrations real :: missing_value = -1.0e+34 !> Number of diagnostic vertical coordinates (remapped) @@ -190,20 +287,24 @@ module MOM_diag_mediator type(diag_grid_storage) :: diag_grid_temp !< Stores the remapped diagnostic grid logical :: diag_grid_overridden = .false. !< True if the diagnostic grids have been overriden - !> Axes groups for each possible coordinate (these will all be 3D groups) - type(axes_grp), dimension(:), allocatable :: remap_axesZL, remap_axesZi + type(axes_grp), dimension(:), allocatable :: & + remap_axesZL, & !< The 1-D z-space cell-centered axis for remapping + remap_axesZi !< The 1-D z-space interface axis for remapping + !!@{ type(axes_grp), dimension(:), allocatable :: remap_axesTL, remap_axesBL, remap_axesCuL, remap_axesCvL type(axes_grp), dimension(:), allocatable :: remap_axesTi, remap_axesBi, remap_axesCui, remap_axesCvi + !!@} ! Pointer to H, G and T&S needed for remapping - real, dimension(:,:,:), pointer :: h => null() - real, dimension(:,:,:), pointer :: T => null() - real, dimension(:,:,:), pointer :: S => null() - type(EOS_type), pointer :: eqn_of_state => null() - type(ocean_grid_type), pointer :: G => null() - type(verticalGrid_type), pointer :: GV => null() - - ! The volume cell measure (special diagnostic) manager id + real, dimension(:,:,:), pointer :: h => null() !< The thicknesses needed for remapping + real, dimension(:,:,:), pointer :: T => null() !< The temperatures needed for remapping + real, dimension(:,:,:), pointer :: S => null() !< The salinities needed for remapping + type(EOS_type), pointer :: eqn_of_state => null() !< The equation of state type + type(ocean_grid_type), pointer :: G => null() !< The ocean grid type + type(verticalGrid_type), pointer :: GV => null() !< The model's vertical ocean grid + type(unit_scale_type), pointer :: US => null() !< A dimensional unit scaling type + + !> The volume cell measure (special diagnostic) manager id integer :: volume_cell_measure_dm_id = -1 #if defined(DEBUG) || defined(__DO_SAFETY_CHECKS__) @@ -220,22 +321,25 @@ module MOM_diag_mediator contains !> Sets up diagnostics axes -subroutine set_axes_info(G, GV, param_file, diag_cs, set_vertical) - type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(param_file_type), intent(in) :: param_file !< Parameter file structure - type(diag_ctrl), intent(inout) :: diag_cs !< Diagnostics control structure - logical, optional, intent(in) :: set_vertical !< If true or missing, set up +subroutine set_axes_info(G, GV, US, param_file, diag_cs, set_vertical) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Parameter file structure + type(diag_ctrl), intent(inout) :: diag_cs !< Diagnostics control structure + logical, optional, intent(in) :: set_vertical !< If true or missing, set up !! vertical axes ! Local variables integer :: id_xq, id_yq, id_zl, id_zi, id_xh, id_yh - integer :: i, k, nz + integer :: id_zl_native, id_zi_native + integer :: i, j, k, nz real :: zlev(GV%ke), zinter(GV%ke+1) logical :: set_vert set_vert = .true. ; if (present(set_vertical)) set_vert = set_vertical - if(G%symmetric) then + ! Horizontal axes for the native grids + if (G%symmetric) then id_xq = diag_axis_init('xq', G%gridLonB(G%isgB:G%iegB), G%x_axis_units, 'x', & 'q point nominal longitude', Domain2=G%Domain%mpp_domain) id_yq = diag_axis_init('yq', G%gridLatB(G%jsgB:G%jegB), G%y_axis_units, 'y', & @@ -264,7 +368,7 @@ subroutine set_axes_info(G, GV, param_file, diag_cs, set_vertical) else id_zl = -1 ; id_zi = -1 endif - + id_zl_native = id_zl ; id_zi_native = id_zi ! Vertical axes for the interfaces and layers call define_axes_group(diag_cs, (/ id_zi /), diag_cs%axesZi, & v_cell_method='point', is_interface=.true.) @@ -312,6 +416,8 @@ subroutine set_axes_info(G, GV, param_file, diag_cs, set_vertical) ! Axis group for special null axis from diag manager call define_axes_group(diag_cs, (/ null_axis_id /), diag_cs%axesNull) + + !Non-native Non-downsampled if (diag_cs%num_diag_coords>0) then allocate(diag_cs%remap_axesZL(diag_cs%num_diag_coords)) allocate(diag_cs%remap_axesTL(diag_cs%num_diag_coords)) @@ -327,7 +433,7 @@ subroutine set_axes_info(G, GV, param_file, diag_cs, set_vertical) do i=1, diag_cs%num_diag_coords ! For each possible diagnostic coordinate - call diag_remap_configure_axes(diag_cs%diag_remap_cs(i), GV, param_file) + call diag_remap_configure_axes(diag_cs%diag_remap_cs(i), GV, US, param_file) ! This vertical coordinate has been configured so can be used. if (diag_remap_axes_configured(diag_cs%diag_remap_cs(i))) then @@ -347,7 +453,8 @@ subroutine set_axes_info(G, GV, param_file, diag_cs, set_vertical) is_h_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true., & xyave_axes=diag_cs%remap_axesZL(i)) - !! \note Remapping for B points is not yet implemented so needs_remapping is not provided for remap_axesBL + !! \note Remapping for B points is not yet implemented so needs_remapping is not + !! provided for remap_axesBL call define_axes_group(diag_cs, (/ id_xq, id_yq, id_zL /), diag_cs%remap_axesBL(i), & nz=nz, vertical_coordinate_number=i, & x_cell_method='point', y_cell_method='point', v_cell_method='mean', & @@ -396,10 +503,183 @@ subroutine set_axes_info(G, GV, param_file, diag_cs, set_vertical) endif enddo + !Define the downsampled axes + call set_axes_info_dsamp(G, GV, param_file, diag_cs, id_zl_native, id_zi_native) + call diag_grid_storage_init(diag_CS%diag_grid_temp, G, diag_CS) end subroutine set_axes_info +subroutine set_axes_info_dsamp(G, GV, param_file, diag_cs, id_zl_native, id_zi_native) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(param_file_type), intent(in) :: param_file !< Parameter file structure + type(diag_ctrl), intent(inout) :: diag_cs !< Diagnostics control structure + integer, intent(in) :: id_zl_native, id_zi_native + + ! Local variables + integer :: id_xq, id_yq, id_zl, id_zi, id_xh, id_yh + integer :: i, j, k, nz, dl + real, dimension(:), pointer :: gridLonT_dsamp =>NULL() + real, dimension(:), pointer :: gridLatT_dsamp =>NULL() + real, dimension(:), pointer :: gridLonB_dsamp =>NULL() + real, dimension(:), pointer :: gridLatB_dsamp =>NULL() + + id_zl = id_zl_native ; id_zi = id_zi_native + !Axes group for native downsampled diagnostics + do dl=2,MAX_DSAMP_LEV + if(dl .ne. 2) call MOM_error(FATAL, "set_axes_info_dsamp: Downsample level other than 2 is not supported yet!") + if (G%symmetric) then + allocate(gridLonB_dsamp(diag_cs%dsamp(dl)%isgB:diag_cs%dsamp(dl)%iegB)) + allocate(gridLatB_dsamp(diag_cs%dsamp(dl)%jsgB:diag_cs%dsamp(dl)%jegB)) + do i=diag_cs%dsamp(dl)%isgB,diag_cs%dsamp(dl)%iegB; gridLonB_dsamp(i) = G%gridLonB(G%isgB+dl*i); enddo + do j=diag_cs%dsamp(dl)%jsgB,diag_cs%dsamp(dl)%jegB; gridLatB_dsamp(j) = G%gridLatB(G%jsgB+dl*j); enddo + id_xq = diag_axis_init('xq', gridLonB_dsamp, G%x_axis_units, 'x', & + 'q point nominal longitude', Domain2=G%Domain%mpp_domain_d2) + id_yq = diag_axis_init('yq', gridLatB_dsamp, G%y_axis_units, 'y', & + 'q point nominal latitude', Domain2=G%Domain%mpp_domain_d2) + deallocate(gridLonB_dsamp,gridLatB_dsamp) + else + allocate(gridLonB_dsamp(diag_cs%dsamp(dl)%isg:diag_cs%dsamp(dl)%ieg)) + allocate(gridLatB_dsamp(diag_cs%dsamp(dl)%jsg:diag_cs%dsamp(dl)%jeg)) + do i=diag_cs%dsamp(dl)%isg,diag_cs%dsamp(dl)%ieg; gridLonB_dsamp(i) = G%gridLonB(G%isg+dl*i-2); enddo + do j=diag_cs%dsamp(dl)%jsg,diag_cs%dsamp(dl)%jeg; gridLatB_dsamp(j) = G%gridLatB(G%jsg+dl*j-2); enddo + id_xq = diag_axis_init('xq', gridLonB_dsamp, G%x_axis_units, 'x', & + 'q point nominal longitude', Domain2=G%Domain%mpp_domain_d2) + id_yq = diag_axis_init('yq', gridLatB_dsamp, G%y_axis_units, 'y', & + 'q point nominal latitude', Domain2=G%Domain%mpp_domain_d2) + deallocate(gridLonB_dsamp,gridLatB_dsamp) + endif + + allocate(gridLonT_dsamp(diag_cs%dsamp(dl)%isg:diag_cs%dsamp(dl)%ieg)) + allocate(gridLatT_dsamp(diag_cs%dsamp(dl)%jsg:diag_cs%dsamp(dl)%jeg)) + do i=diag_cs%dsamp(dl)%isg,diag_cs%dsamp(dl)%ieg; gridLonT_dsamp(i) = G%gridLonT(G%isg+dl*i-2); enddo + do j=diag_cs%dsamp(dl)%jsg,diag_cs%dsamp(dl)%jeg; gridLatT_dsamp(j) = G%gridLatT(G%jsg+dl*j-2); enddo + id_xh = diag_axis_init('xh', gridLonT_dsamp, G%x_axis_units, 'x', & + 'h point nominal longitude', Domain2=G%Domain%mpp_domain_d2) + id_yh = diag_axis_init('yh', gridLatT_dsamp, G%y_axis_units, 'y', & + 'h point nominal latitude', Domain2=G%Domain%mpp_domain_d2) + + deallocate(gridLonT_dsamp,gridLatT_dsamp) + + ! Axis groupings for the model layers + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh, id_zL /), diag_cs%dsamp(dl)%axesTL, dl, & + x_cell_method='mean', y_cell_method='mean', v_cell_method='mean', & + is_h_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL) + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yq, id_zL /), diag_cs%dsamp(dl)%axesBL, dl, & + x_cell_method='point', y_cell_method='point', v_cell_method='mean', & + is_q_point=.true., is_layer=.true.) + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yh, id_zL /), diag_cs%dsamp(dl)%axesCuL, dl, & + x_cell_method='point', y_cell_method='mean', v_cell_method='mean', & + is_u_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL) + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq, id_zL /), diag_cs%dsamp(dl)%axesCvL, dl, & + x_cell_method='mean', y_cell_method='point', v_cell_method='mean', & + is_v_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL) + + ! Axis groupings for the model interfaces + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh, id_zi /), diag_cs%dsamp(dl)%axesTi, dl, & + x_cell_method='mean', y_cell_method='mean', v_cell_method='point', & + is_h_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi) + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yq, id_zi /), diag_cs%dsamp(dl)%axesBi, dl, & + x_cell_method='point', y_cell_method='point', v_cell_method='point', & + is_q_point=.true., is_interface=.true.) + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yh, id_zi /), diag_cs%dsamp(dl)%axesCui, dl, & + x_cell_method='point', y_cell_method='mean', v_cell_method='point', & + is_u_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi) + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq, id_zi /), diag_cs%dsamp(dl)%axesCvi, dl, & + x_cell_method='mean', y_cell_method='point', v_cell_method='point', & + is_v_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi) + + ! Axis groupings for 2-D arrays + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh /), diag_cs%dsamp(dl)%axesT1, dl, & + x_cell_method='mean', y_cell_method='mean', is_h_point=.true.) + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yq /), diag_cs%dsamp(dl)%axesB1, dl, & + x_cell_method='point', y_cell_method='point', is_q_point=.true.) + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yh /), diag_cs%dsamp(dl)%axesCu1, dl, & + x_cell_method='point', y_cell_method='mean', is_u_point=.true.) + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq /), diag_cs%dsamp(dl)%axesCv1, dl, & + x_cell_method='mean', y_cell_method='point', is_v_point=.true.) + + !Non-native axes + if (diag_cs%num_diag_coords>0) then + allocate(diag_cs%dsamp(dl)%remap_axesTL(diag_cs%num_diag_coords)) + allocate(diag_cs%dsamp(dl)%remap_axesBL(diag_cs%num_diag_coords)) + allocate(diag_cs%dsamp(dl)%remap_axesCuL(diag_cs%num_diag_coords)) + allocate(diag_cs%dsamp(dl)%remap_axesCvL(diag_cs%num_diag_coords)) + allocate(diag_cs%dsamp(dl)%remap_axesTi(diag_cs%num_diag_coords)) + allocate(diag_cs%dsamp(dl)%remap_axesBi(diag_cs%num_diag_coords)) + allocate(diag_cs%dsamp(dl)%remap_axesCui(diag_cs%num_diag_coords)) + allocate(diag_cs%dsamp(dl)%remap_axesCvi(diag_cs%num_diag_coords)) + endif + + do i=1, diag_cs%num_diag_coords + ! For each possible diagnostic coordinate + !call diag_remap_configure_axes(diag_cs%diag_remap_cs(i), GV, param_file) + + ! This vertical coordinate has been configured so can be used. + if (diag_remap_axes_configured(diag_cs%diag_remap_cs(i))) then + + ! This fetches the 1D-axis id for layers and interfaces and overwrite + ! id_zl and id_zi from above. It also returns the number of layers. + call diag_remap_get_axes_info(diag_cs%diag_remap_cs(i), nz, id_zL, id_zi) + + ! Axes for z layers + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh, id_zL /), diag_cs%dsamp(dl)%remap_axesTL(i), dl, & + nz=nz, vertical_coordinate_number=i, & + x_cell_method='mean', y_cell_method='mean', v_cell_method='mean', & + is_h_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true., & + xyave_axes=diag_cs%remap_axesZL(i)) + + !! \note Remapping for B points is not yet implemented so needs_remapping is not + !! provided for remap_axesBL + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yq, id_zL /), diag_cs%dsamp(dl)%remap_axesBL(i), dl, & + nz=nz, vertical_coordinate_number=i, & + x_cell_method='point', y_cell_method='point', v_cell_method='mean', & + is_q_point=.true., is_layer=.true., is_native=.false.) + + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yh, id_zL /), diag_cs%dsamp(dl)%remap_axesCuL(i), dl, & + nz=nz, vertical_coordinate_number=i, & + x_cell_method='point', y_cell_method='mean', v_cell_method='mean', & + is_u_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true., & + xyave_axes=diag_cs%remap_axesZL(i)) + + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq, id_zL /), diag_cs%dsamp(dl)%remap_axesCvL(i), dl, & + nz=nz, vertical_coordinate_number=i, & + x_cell_method='mean', y_cell_method='point', v_cell_method='mean', & + is_v_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true., & + xyave_axes=diag_cs%remap_axesZL(i)) + + ! Axes for z interfaces + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh, id_zi /), diag_cs%dsamp(dl)%remap_axesTi(i), dl, & + nz=nz, vertical_coordinate_number=i, & + x_cell_method='mean', y_cell_method='mean', v_cell_method='point', & + is_h_point=.true., is_interface=.true., is_native=.false., needs_interpolating=.true., & + xyave_axes=diag_cs%remap_axesZi(i)) + + !! \note Remapping for B points is not yet implemented so needs_remapping is not provided for remap_axesBi + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yq, id_zi /), diag_cs%dsamp(dl)%remap_axesBi(i), dl, & + nz=nz, vertical_coordinate_number=i, & + x_cell_method='point', y_cell_method='point', v_cell_method='point', & + is_q_point=.true., is_interface=.true., is_native=.false.) + + call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yh, id_zi /), diag_cs%dsamp(dl)%remap_axesCui(i), dl, & + nz=nz, vertical_coordinate_number=i, & + x_cell_method='point', y_cell_method='mean', v_cell_method='point', & + is_u_point=.true., is_interface=.true., is_native=.false., & + needs_interpolating=.true., xyave_axes=diag_cs%remap_axesZi(i)) + + call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq, id_zi /), diag_cs%dsamp(dl)%remap_axesCvi(i), dl, & + nz=nz, vertical_coordinate_number=i, & + x_cell_method='mean', y_cell_method='point', v_cell_method='point', & + is_v_point=.true., is_interface=.true., is_native=.false., & + needs_interpolating=.true., xyave_axes=diag_cs%remap_axesZi(i)) + endif + enddo + enddo + +end subroutine set_axes_info_dsamp + + !> set_masks_for_axes sets up the 2d and 3d masks for diagnostics using the current grid !! recorded after calling diag_update_remap_grids() subroutine set_masks_for_axes(G, diag_cs) @@ -407,8 +687,8 @@ subroutine set_masks_for_axes(G, diag_cs) type(diag_ctrl), pointer :: diag_cs !< A pointer to a type with many variables !! used for diagnostics ! Local variables - integer :: c, nk, i, j, k - type(axes_grp), pointer :: axes, h_axes ! Current axes, for convenience + integer :: c, nk, i, j, k, ii, jj + type(axes_grp), pointer :: axes => NULL(), h_axes => NULL() ! Current axes, for convenience do c=1, diag_cs%num_diag_coords ! This vertical coordinate has been configured so can be used. @@ -496,8 +776,70 @@ subroutine set_masks_for_axes(G, diag_cs) endif enddo + !Allocate and initialize the downsampled masks for the axes + call set_masks_for_axes_dsamp(G, diag_cs) + end subroutine set_masks_for_axes +subroutine set_masks_for_axes_dsamp(G, diag_cs) + type(ocean_grid_type), target, intent(in) :: G !< The ocean grid type. + type(diag_ctrl), pointer :: diag_cs !< A pointer to a type with many variables + !! used for diagnostics + ! Local variables + integer :: c, nk, i, j, k, ii, jj + integer :: dl + type(axes_grp), pointer :: axes => NULL(), h_axes => NULL() ! Current axes, for convenience + + !Each downsampled axis needs both downsampled and non-downsampled mask + !The downsampled mask is needed for sending out the diagnostics output via diag_manager + !The non-downsampled mask is needed for downsampling the diagnostics field + do dl=2,MAX_DSAMP_LEV + if(dl .ne. 2) call MOM_error(FATAL, "set_masks_for_axes_dsamp: Downsample level other than 2 is not supported!") + do c=1, diag_cs%num_diag_coords + ! Level/layer h-points in diagnostic coordinate + axes => diag_cs%remap_axesTL(c) + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesTL(c)%dsamp(dl)%mask3d, dl,G%isc, G%jsc, & + G%HId2%isc, G%HId2%iec, G%HId2%jsc, G%HId2%jec, G%HId2%isd, G%HId2%ied, G%HId2%jsd, G%HId2%jed) + diag_cs%dsamp(dl)%remap_axesTL(c)%mask3d => axes%mask3d !set non-downsampled mask + ! Level/layer u-points in diagnostic coordinate + axes => diag_cs%remap_axesCuL(c) + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCuL(c)%dsamp(dl)%mask3d, dl,G%IscB,G%JscB, & + G%HId2%IscB,G%HId2%IecB,G%HId2%jsc, G%HId2%jec,G%HId2%IsdB,G%HId2%IedB,G%HId2%jsd, G%HId2%jed) + diag_cs%dsamp(dl)%remap_axesCul(c)%mask3d => axes%mask3d !set non-downsampled mask + ! Level/layer v-points in diagnostic coordinate + axes => diag_cs%remap_axesCvL(c) + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCvL(c)%dsamp(dl)%mask3d, dl,G%isc ,G%JscB, & + G%HId2%isc ,G%HId2%iec, G%HId2%JscB,G%HId2%JecB,G%HId2%isd ,G%HId2%ied, G%HId2%JsdB,G%HId2%JedB) + diag_cs%dsamp(dl)%remap_axesCvL(c)%mask3d => axes%mask3d !set non-downsampled mask + ! Level/layer q-points in diagnostic coordinate + axes => diag_cs%remap_axesBL(c) + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesBL(c)%dsamp(dl)%mask3d, dl,G%IscB,G%JscB, & + G%HId2%IscB,G%HId2%IecB,G%HId2%JscB,G%HId2%JecB,G%HId2%IsdB,G%HId2%IedB,G%HId2%JsdB,G%HId2%JedB) + diag_cs%dsamp(dl)%remap_axesBL(c)%mask3d => axes%mask3d !set non-downsampled mask + ! Interface h-points in diagnostic coordinate (w-point) + axes => diag_cs%remap_axesTi(c) + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesTi(c)%dsamp(dl)%mask3d, dl,G%isc, G%jsc, & + G%HId2%isc, G%HId2%iec, G%HId2%jsc, G%HId2%jec, G%HId2%isd, G%HId2%ied, G%HId2%jsd, G%HId2%jed) + diag_cs%dsamp(dl)%remap_axesTi(c)%mask3d => axes%mask3d !set non-downsampled mask + ! Interface u-points in diagnostic coordinate + axes => diag_cs%remap_axesCui(c) + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCui(c)%dsamp(dl)%mask3d, dl,G%IscB,G%JscB, & + G%HId2%IscB,G%HId2%IecB,G%HId2%jsc, G%HId2%jec,G%HId2%IsdB,G%HId2%IedB,G%HId2%jsd, G%HId2%jed) + diag_cs%dsamp(dl)%remap_axesCui(c)%mask3d => axes%mask3d !set non-downsampled mask + ! Interface v-points in diagnostic coordinate + axes => diag_cs%remap_axesCvi(c) + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCvi(c)%dsamp(dl)%mask3d, dl,G%isc ,G%JscB, & + G%HId2%isc ,G%HId2%iec, G%HId2%JscB,G%HId2%JecB,G%HId2%isd ,G%HId2%ied, G%HId2%JsdB,G%HId2%JedB) + diag_cs%dsamp(dl)%remap_axesCvi(c)%mask3d => axes%mask3d !set non-downsampled mask + ! Interface q-points in diagnostic coordinate + axes => diag_cs%remap_axesBi(c) + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesBi(c)%dsamp(dl)%mask3d, dl,G%IscB,G%JscB, & + G%HId2%IscB,G%HId2%IecB,G%HId2%JscB,G%HId2%JecB,G%HId2%IsdB,G%HId2%IedB,G%HId2%JsdB,G%HId2%JedB) + diag_cs%dsamp(dl)%remap_axesBi(c)%mask3d => axes%mask3d !set non-downsampled mask + enddo + enddo +end subroutine set_masks_for_axes_dsamp + !> Attaches the id of cell areas to axes groups for use with cell_measures subroutine diag_register_area_ids(diag_cs, id_area_t, id_area_q) type(diag_ctrl), intent(inout) :: diag_cs !< Diagnostics control structure @@ -547,7 +889,7 @@ subroutine diag_associate_volume_cell_measure(diag_cs, id_h_volume) type(diag_ctrl), intent(inout) :: diag_cs !< Diagnostics control structure integer, intent(in) :: id_h_volume !< Diag_manager id for volume of h-cells ! Local variables - type(diag_type), pointer :: tmp + type(diag_type), pointer :: tmp => NULL() if (id_h_volume<=0) return ! Do nothing diag_cs%volume_cell_measure_dm_id = id_h_volume ! Record for diag_get_volume_cell_measure_dm_id() @@ -584,21 +926,34 @@ subroutine define_axes_group(diag_cs, handles, axes, nz, vertical_coordinate_num type(axes_grp), intent(out) :: axes !< The group of 1D axes integer, optional, intent(in) :: nz !< Number of layers in this diagnostic grid integer, optional, intent(in) :: vertical_coordinate_number !< Index number for vertical coordinate - character(len=*), optional, intent(in) :: x_cell_method !< A x-direction cell method used to construct the "cell_methods" attribute in CF convention - character(len=*), optional, intent(in) :: y_cell_method !< A y-direction cell method used to construct the "cell_methods" attribute in CF convention - character(len=*), optional, intent(in) :: v_cell_method !< A vertical direction cell method used to construct the "cell_methods" attribute in CF convention - logical, optional, intent(in) :: is_h_point !< If true, indicates this axes group for h-point located fields - logical, optional, intent(in) :: is_q_point !< If true, indicates this axes group for q-point located fields - logical, optional, intent(in) :: is_u_point !< If true, indicates this axes group for u-point located fields - logical, optional, intent(in) :: is_v_point !< If true, indicates this axes group for v-point located fields - logical, optional, intent(in) :: is_layer !< If true, indicates that this axes group is for a layer vertically-located field. - logical, optional, intent(in) :: is_interface !< If true, indicates that this axes group is for an interface vertically-located field. - logical, optional, intent(in) :: is_native !< If true, indicates that this axes group is for a native model grid. False for any other grid. - logical, optional, intent(in) :: needs_remapping !< If true, indicates that this axes group is for a intensive layer-located field - !! that must be remapped to these axes. Used for rank>2. - logical, optional, intent(in) :: needs_interpolating !< If true, indicates that this axes group is for a sampled interface-located field - !! that must be interpolated to these axes. Used for rank>2. - type(axes_grp), optional, target :: xyave_axes !< The corresponding axes group for horizontally area-average diagnostics + character(len=*), optional, intent(in) :: x_cell_method !< A x-direction cell method used to construct the + !! "cell_methods" attribute in CF convention + character(len=*), optional, intent(in) :: y_cell_method !< A y-direction cell method used to construct the + !! "cell_methods" attribute in CF convention + character(len=*), optional, intent(in) :: v_cell_method !< A vertical direction cell method used to construct + !! the "cell_methods" attribute in CF convention + logical, optional, intent(in) :: is_h_point !< If true, indicates this axes group for h-point + !! located fields + logical, optional, intent(in) :: is_q_point !< If true, indicates this axes group for q-point + !! located fields + logical, optional, intent(in) :: is_u_point !< If true, indicates this axes group for + !! u-point located fields + logical, optional, intent(in) :: is_v_point !< If true, indicates this axes group for + !! v-point located fields + logical, optional, intent(in) :: is_layer !< If true, indicates that this axes group is + !! for a layer vertically-located field. + logical, optional, intent(in) :: is_interface !< If true, indicates that this axes group + !! is for an interface vertically-located field. + logical, optional, intent(in) :: is_native !< If true, indicates that this axes group is + !! for a native model grid. False for any other grid. + logical, optional, intent(in) :: needs_remapping !< If true, indicates that this axes group is + !! for a intensive layer-located field that must + !! be remapped to these axes. Used for rank>2. + logical, optional, intent(in) :: needs_interpolating !< If true, indicates that this axes group + !! is for a sampled interface-located field that must + !! be interpolated to these axes. Used for rank>2. + type(axes_grp), optional, target :: xyave_axes !< The corresponding axes group for horizontally + !! area-average diagnostics ! Local variables integer :: n @@ -670,13 +1025,148 @@ subroutine define_axes_group(diag_cs, handles, axes, nz, vertical_coordinate_num end subroutine define_axes_group +!> Defines a group of downsampled "axes" from list of handles +subroutine define_axes_group_dsamp(diag_cs, handles, axes, dl, nz, vertical_coordinate_number, & + x_cell_method, y_cell_method, v_cell_method, & + is_h_point, is_q_point, is_u_point, is_v_point, & + is_layer, is_interface, & + is_native, needs_remapping, needs_interpolating, & + xyave_axes) + type(diag_ctrl), target, intent(in) :: diag_cs !< Diagnostics control structure + integer, dimension(:), intent(in) :: handles !< A list of 1D axis handles + type(axes_grp), intent(out) :: axes !< The group of 1D axes + integer, intent(in) :: dl !< Downsample level + integer, optional, intent(in) :: nz !< Number of layers in this diagnostic grid + integer, optional, intent(in) :: vertical_coordinate_number !< Index number for vertical coordinate + character(len=*), optional, intent(in) :: x_cell_method !< A x-direction cell method used to construct the + !! "cell_methods" attribute in CF convention + character(len=*), optional, intent(in) :: y_cell_method !< A y-direction cell method used to construct the + !! "cell_methods" attribute in CF convention + character(len=*), optional, intent(in) :: v_cell_method !< A vertical direction cell method used to construct + !! the "cell_methods" attribute in CF convention + logical, optional, intent(in) :: is_h_point !< If true, indicates this axes group for h-point + !! located fields + logical, optional, intent(in) :: is_q_point !< If true, indicates this axes group for q-point + !! located fields + logical, optional, intent(in) :: is_u_point !< If true, indicates this axes group for + !! u-point located fields + logical, optional, intent(in) :: is_v_point !< If true, indicates this axes group for + !! v-point located fields + logical, optional, intent(in) :: is_layer !< If true, indicates that this axes group is + !! for a layer vertically-located field. + logical, optional, intent(in) :: is_interface !< If true, indicates that this axes group + !! is for an interface vertically-located field. + logical, optional, intent(in) :: is_native !< If true, indicates that this axes group is + !! for a native model grid. False for any other grid. + logical, optional, intent(in) :: needs_remapping !< If true, indicates that this axes group is + !! for a intensive layer-located field that must + !! be remapped to these axes. Used for rank>2. + logical, optional, intent(in) :: needs_interpolating !< If true, indicates that this axes group + !! is for a sampled interface-located field that must + !! be interpolated to these axes. Used for rank>2. + type(axes_grp), optional, target :: xyave_axes !< The corresponding axes group for horizontally + !! area-average diagnostics + ! Local variables + integer :: n + + n = size(handles) + if (n<1 .or. n>3) call MOM_error(FATAL, "define_axes_group: wrong size for list of handles!") + allocate( axes%handles(n) ) + axes%id = i2s(handles, n) ! Identifying string + axes%rank = n + axes%handles(:) = handles(:) + axes%diag_cs => diag_cs ! A [circular] link back to the diag_cs structure + if (present(x_cell_method)) then + if (axes%rank<2) call MOM_error(FATAL, 'define_axes_group: ' // & + 'Can not set x_cell_method for rank<2.') + axes%x_cell_method = trim(x_cell_method) + else + axes%x_cell_method = '' + endif + if (present(y_cell_method)) then + if (axes%rank<2) call MOM_error(FATAL, 'define_axes_group: ' // & + 'Can not set y_cell_method for rank<2.') + axes%y_cell_method = trim(y_cell_method) + else + axes%y_cell_method = '' + endif + if (present(v_cell_method)) then + if (axes%rank/=1 .and. axes%rank/=3) call MOM_error(FATAL, 'define_axes_group: ' // & + 'Can not set v_cell_method for rank<>1 or 3.') + axes%v_cell_method = trim(v_cell_method) + else + axes%v_cell_method = '' + endif + axes%downsample_level = dl + if (present(nz)) axes%nz = nz + if (present(vertical_coordinate_number)) axes%vertical_coordinate_number = vertical_coordinate_number + if (present(is_h_point)) axes%is_h_point = is_h_point + if (present(is_q_point)) axes%is_q_point = is_q_point + if (present(is_u_point)) axes%is_u_point = is_u_point + if (present(is_v_point)) axes%is_v_point = is_v_point + if (present(is_layer)) axes%is_layer = is_layer + if (present(is_interface)) axes%is_interface = is_interface + if (present(is_native)) axes%is_native = is_native + if (present(needs_remapping)) axes%needs_remapping = needs_remapping + if (present(needs_interpolating)) axes%needs_interpolating = needs_interpolating + if (present(xyave_axes)) axes%xyave_axes => xyave_axes + + ! Setup masks for this axes group + + axes%mask2d => null() + if (axes%rank==2) then + if (axes%is_h_point) axes%mask2d => diag_cs%mask2dT + if (axes%is_u_point) axes%mask2d => diag_cs%mask2dCu + if (axes%is_v_point) axes%mask2d => diag_cs%mask2dCv + if (axes%is_q_point) axes%mask2d => diag_cs%mask2dBu + endif + ! A static 3d mask for non-native coordinates can only be setup when a grid is available + axes%mask3d => null() + if (axes%rank==3 .and. axes%is_native) then + ! Native variables can/should use the native masks copied into diag_cs + if (axes%is_layer) then + if (axes%is_h_point) axes%mask3d => diag_cs%mask3dTL + if (axes%is_u_point) axes%mask3d => diag_cs%mask3dCuL + if (axes%is_v_point) axes%mask3d => diag_cs%mask3dCvL + if (axes%is_q_point) axes%mask3d => diag_cs%mask3dBL + elseif (axes%is_interface) then + if (axes%is_h_point) axes%mask3d => diag_cs%mask3dTi + if (axes%is_u_point) axes%mask3d => diag_cs%mask3dCui + if (axes%is_v_point) axes%mask3d => diag_cs%mask3dCvi + if (axes%is_q_point) axes%mask3d => diag_cs%mask3dBi + endif + endif + + axes%dsamp(dl)%mask2d => null() + if (axes%rank==2) then + if (axes%is_h_point) axes%dsamp(dl)%mask2d => diag_cs%dsamp(dl)%mask2dT + if (axes%is_u_point) axes%dsamp(dl)%mask2d => diag_cs%dsamp(dl)%mask2dCu + if (axes%is_v_point) axes%dsamp(dl)%mask2d => diag_cs%dsamp(dl)%mask2dCv + if (axes%is_q_point) axes%dsamp(dl)%mask2d => diag_cs%dsamp(dl)%mask2dBu + endif + ! A static 3d mask for non-native coordinates can only be setup when a grid is available + axes%dsamp(dl)%mask3d => null() + if (axes%rank==3 .and. axes%is_native) then + ! Native variables can/should use the native masks copied into diag_cs + if (axes%is_layer) then + if (axes%is_h_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dTL + if (axes%is_u_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dCuL + if (axes%is_v_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dCvL + if (axes%is_q_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dBL + elseif (axes%is_interface) then + if (axes%is_h_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dTi + if (axes%is_u_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dCui + if (axes%is_v_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dCvi + if (axes%is_q_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dBi + endif + endif + +end subroutine define_axes_group_dsamp + +!> Set up the array extents for doing diagnostics subroutine set_diag_mediator_grid(G, diag_cs) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(diag_ctrl), intent(inout) :: diag_cs - -! Arguments: -! (inout) G - ocean grid structure -! (inout) diag - structure used to regulate diagnostic output + type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output diag_cs%is = G%isc - (G%isd-1) ; diag_cs%ie = G%iec - (G%isd-1) diag_cs%js = G%jsc - (G%jsd-1) ; diag_cs%je = G%jec - (G%jsd-1) @@ -685,20 +1175,15 @@ subroutine set_diag_mediator_grid(G, diag_cs) end subroutine set_diag_mediator_grid +!> Make a real scalar diagnostic available for averaging or output subroutine post_data_0d(diag_field_id, field, diag_cs, is_static) - integer, intent(in) :: diag_field_id - real, intent(in) :: field - type(diag_ctrl), target, intent(in) :: diag_cs - logical, optional, intent(in) :: is_static - -! Arguments: -! (in) diag_field_id - the id for an output variable returned by a -! previous call to register_diag_field. -! (in) field - 0-d array being offered for output or averaging. -! (inout) diag_cs - structure used to regulate diagnostic output. -! (in,opt) is_static - If true, this is a static field that is always offered. -! (in,opt) mask - If present, use this real array as the data mask. + integer, intent(in) :: diag_field_id !< The id for an output variable returned by a + !! previous call to register_diag_field. + real, intent(in) :: field !< real value being offered for output or averaging + type(diag_ctrl), target, intent(in) :: diag_CS !< Structure used to regulate diagnostic output + logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. + ! Local variables logical :: used, is_stat type(diag_type), pointer :: diag => null() @@ -722,22 +1207,19 @@ subroutine post_data_0d(diag_field_id, field, diag_cs, is_static) if (id_clock_diag_mediator>0) call cpu_clock_end(id_clock_diag_mediator) end subroutine post_data_0d +!> Make a real 1-d array diagnostic available for averaging or output subroutine post_data_1d_k(diag_field_id, field, diag_cs, is_static) - integer, intent(in) :: diag_field_id - real, intent(in) :: field(:) - type(diag_ctrl), target, intent(in) :: diag_cs - logical, optional, intent(in) :: is_static - -! Arguments: -! (in) diag_field_id - id for an output variable returned by a -! previous call to register_diag_field. -! (in) field - 3-d array being offered for output or averaging -! (inout) diag_cs - structure used to regulate diagnostic output -! (in) static - If true, this is a static field that is always offered. + integer, intent(in) :: diag_field_id !< The id for an output variable returned by a + !! previous call to register_diag_field. + real, target, intent(in) :: field(:) !< 1-d array being offered for output or averaging + type(diag_ctrl), target, intent(in) :: diag_CS !< Structure used to regulate diagnostic output + logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. + ! Local variables logical :: used ! The return value of send_data is not used for anything. + real, dimension(:), pointer :: locfield => NULL() logical :: is_stat - integer :: isv, iev, jsv, jev + integer :: k, ks, ke type(diag_type), pointer :: diag => null() if (id_clock_diag_mediator>0) call cpu_clock_begin(id_clock_diag_mediator) @@ -748,32 +1230,45 @@ subroutine post_data_1d_k(diag_field_id, field, diag_cs, is_static) 'post_data_1d_k: Unregistered diagnostic id') diag => diag_cs%diags(diag_field_id) do while (associated(diag)) + + if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) then + ks = lbound(field,1) ; ke = ubound(field,1) + allocate( locfield( ks:ke ) ) + + do k=ks,ke + if (field(k) == diag_cs%missing_value) then + locfield(k) = diag_cs%missing_value + else + locfield(k) = field(k) * diag%conversion_factor + endif + enddo + else + locfield => field + endif + if (is_stat) then - used = send_data(diag%fms_diag_id, field) + used = send_data(diag%fms_diag_id, locfield) elseif (diag_cs%ave_enabled) then - used = send_data(diag%fms_diag_id, field, diag_cs%time_end, weight=diag_cs%time_int) + used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, weight=diag_cs%time_int) endif + if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) deallocate( locfield ) + diag => diag%next enddo if (id_clock_diag_mediator>0) call cpu_clock_end(id_clock_diag_mediator) end subroutine post_data_1d_k +!> Make a real 2-d array diagnostic available for averaging or output subroutine post_data_2d(diag_field_id, field, diag_cs, is_static, mask) - integer, intent(in) :: diag_field_id - real, intent(in) :: field(:,:) - type(diag_ctrl), target, intent(in) :: diag_cs - logical, optional, intent(in) :: is_static - real, optional, intent(in) :: mask(:,:) - -! Arguments: -! (in) diag_field_id - id for an output variable returned by a -! previous call to register_diag_field. -! (in) field - 2-d array being offered for output or averaging. -! (inout) diag_cs - structure used to regulate diagnostic output. -! (in,opt) is_static - If true, this is a static field that is always offered. -! (in,opt) mask - If present, use this real array as the data mask. + integer, intent(in) :: diag_field_id !< The id for an output variable returned by a + !! previous call to register_diag_field. + real, intent(in) :: field(:,:) !< 2-d array being offered for output or averaging + type(diag_ctrl), target, intent(in) :: diag_CS !< Structure used to regulate diagnostic output + logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. + real, optional, intent(in) :: mask(:,:) !< If present, use this real array as the data mask. + ! Local variables type(diag_type), pointer :: diag => null() if (id_clock_diag_mediator>0) call cpu_clock_begin(id_clock_diag_mediator) @@ -783,31 +1278,35 @@ subroutine post_data_2d(diag_field_id, field, diag_cs, is_static, mask) 'post_data_2d: Unregistered diagnostic id') diag => diag_cs%diags(diag_field_id) do while (associated(diag)) - call post_data_2d_low(diag, field, diag_cs, is_static, mask) + call post_data_2d_low(diag, field, diag_cs, is_static, mask) diag => diag%next enddo if (id_clock_diag_mediator>0) call cpu_clock_end(id_clock_diag_mediator) end subroutine post_data_2d +!> Make a real 2-d array diagnostic available for averaging or output +!! using a diag_type instead of an integer id. subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) - type(diag_type), intent(in) :: diag - real, target, intent(in) :: field(:,:) - type(diag_ctrl), intent(in) :: diag_cs - logical, optional, intent(in) :: is_static - real, optional, intent(in) :: mask(:,:) - -! Arguments: -! (in) diag - structure representing the diagnostic to post -! (in) field - 2-d array being offered for output or averaging -! (inout) diag_cs - structure used to regulate diagnostic output -! (in,opt) is_static - If true, this is a static field that is always offered. -! (in,opt) mask - If present, use this real array as the data mask. - - real, dimension(:,:), pointer :: locfield => NULL() - logical :: used, is_stat - integer :: isv, iev, jsv, jev, i, j, chksum + type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post + real, target, intent(in) :: field(:,:) !< 2-d array being offered for output or averaging + type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output + logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. + real, optional,target, intent(in) :: mask(:,:) !< If present, use this real array as the data mask. + ! Local variables + real, dimension(:,:), pointer :: locfield + real, dimension(:,:), pointer :: locmask + character(len=300) :: mesg + logical :: used, is_stat + integer :: cszi, cszj, dszi, dszj + integer :: isv, iev, jsv, jev, i, j, chksum, isv_o,jsv_o + real, dimension(:,:), allocatable, target :: locfield_dsamp + real, dimension(:,:), allocatable, target :: locmask_dsamp + integer :: dl + + locfield => NULL() + locmask => NULL() is_stat = .false. ; if (present(is_static)) is_stat = is_static ! Determine the propery array indices, noting that because of the (:,:) @@ -817,27 +1316,34 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) ! the output data size and assumes that halos are symmetric. isv = diag_cs%is ; iev = diag_cs%ie ; jsv = diag_cs%js ; jev = diag_cs%je - if ( size(field,1) == diag_cs%ied-diag_cs%isd +1 ) then - isv = diag_cs%is ; iev = diag_cs%ie ! Data domain - elseif ( size(field,1) == diag_cs%ied-diag_cs%isd +2 ) then - isv = diag_cs%is ; iev = diag_cs%ie+1 ! Symmetric data domain - elseif ( size(field,1) == diag_cs%ie-diag_cs%is +1 ) then - isv = 1 ; iev = diag_cs%ie + 1-diag_cs%is ! Computational domain - elseif ( size(field,1) == diag_cs%ie-diag_cs%is +2 ) then - isv = 1 ; iev = diag_cs%ie + 2-diag_cs%is ! Symmetric computational domain + cszi = diag_cs%ie-diag_cs%is +1 ; dszi = diag_cs%ied-diag_cs%isd +1 + cszj = diag_cs%je-diag_cs%js +1 ; dszj = diag_cs%jed-diag_cs%jsd +1 + if ( size(field,1) == dszi ) then + isv = diag_cs%is ; iev = diag_cs%ie ! Data domain + elseif ( size(field,1) == dszi + 1 ) then + isv = diag_cs%is ; iev = diag_cs%ie+1 ! Symmetric data domain + elseif ( size(field,1) == cszi) then + isv = 1 ; iev = cszi ! Computational domain + elseif ( size(field,1) == cszi + 1 ) then + isv = 1 ; iev = cszi+1 ! Symmetric computational domain else - call MOM_error(FATAL,"post_data_2d_low: peculiar size in i-direction") - endif - if ( size(field,2) == diag_cs%jed-diag_cs%jsd +1 ) then - jsv = diag_cs%js ; jev = diag_cs%je ! Data domain - elseif ( size(field,2) == diag_cs%jed-diag_cs%jsd +2 ) then - jsv = diag_cs%js ; jev = diag_cs%je+1 ! Symmetric data domain - elseif ( size(field,2) == diag_cs%je-diag_cs%js +1 ) then - jsv = 1 ; jev = diag_cs%je + 1-diag_cs%js ! Computational domain - elseif ( size(field,1) == diag_cs%je-diag_cs%js +2 ) then - jsv = 1 ; jev = diag_cs%je + 2-diag_cs%js ! Symmetric computational domain + write (mesg,*) " peculiar size ",size(field,1)," in i-direction\n"//& + "does not match one of ", cszi, cszi+1, dszi, dszi+1 + call MOM_error(FATAL,"post_data_2d_low: "//trim(diag%debug_str)//trim(mesg)) + endif + + if ( size(field,2) == dszj ) then + jsv = diag_cs%js ; jev = diag_cs%je ! Data domain + elseif ( size(field,2) == dszj + 1 ) then + jsv = diag_cs%js ; jev = diag_cs%je+1 ! Symmetric data domain + elseif ( size(field,2) == cszj ) then + jsv = 1 ; jev = cszj ! Computational domain + elseif ( size(field,2) == cszj+1 ) then + jsv = 1 ; jev = cszj+1 ! Symmetric computational domain else - call MOM_error(FATAL,"post_data_2d_low: peculiar size in j-direction") + write (mesg,*) " peculiar size ",size(field,2)," in j-direction\n"//& + "does not match one of ", cszj, cszj+1, dszj, dszj+1 + call MOM_error(FATAL,"post_data_2d_low: "//trim(diag%debug_str)//trim(mesg)) endif if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) then @@ -853,6 +1359,29 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) else locfield => field endif + + if (present(mask)) then + locmask => mask + elseif(.NOT. is_stat) then + if(associated(diag%axes%mask2d)) locmask => diag%axes%mask2d + endif + + dl=1 + if(.NOT. is_stat) dl = diag%axes%downsample_level !static field downsample i not supported yet + !Downsample the diag field and mask (if present) + if (dl > 1) then + isv_o=isv ; jsv_o=jsv + call downsample_diag_field(locfield, locfield_dsamp, dl, diag_cs, diag,isv,iev,jsv,jev, mask) + if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) deallocate( locfield ) + locfield => locfield_dsamp + if (present(mask)) then + call downsample_field_2d(locmask, locmask_dsamp, dl, MSK, locmask, diag_cs,diag,isv_o,jsv_o,isv,iev,jsv,jev) + locmask => locmask_dsamp + elseif(associated(diag%axes%dsamp(dl)%mask2d)) then + locmask => diag%axes%dsamp(dl)%mask2d + endif + endif + if (diag_cs%diag_as_chksum) then chksum = chksum_general(locfield) if (is_root_pe()) then @@ -861,11 +1390,11 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) else if (is_stat) then if (present(mask)) then - call assert(size(locfield) == size(mask), & + call assert(size(locfield) == size(locmask), & 'post_data_2d_low is_stat: mask size mismatch: '//diag%debug_str) used = send_data(diag%fms_diag_id, locfield, & - is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=mask) - !elseif(associated(diag%axes%mask2d)) then + is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=locmask) + !elseif (associated(diag%axes%mask2d)) then ! used = send_data(diag%fms_diag_id, locfield, & ! is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=diag%axes%mask2d) else @@ -873,16 +1402,12 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) is_in=isv, js_in=jsv, ie_in=iev, je_in=jev) endif elseif (diag_cs%ave_enabled) then - if (present(mask)) then - call assert(size(locfield) == size(mask), & + if (associated(locmask)) then + call assert(size(locfield) == size(locmask), & 'post_data_2d_low: mask size mismatch: '//diag%debug_str) used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & - weight=diag_cs%time_int, rmask=mask) - elseif(associated(diag%axes%mask2d)) then - used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & - is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & - weight=diag_cs%time_int, rmask=diag%axes%mask2d) + weight=diag_cs%time_int, rmask=locmask) else used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & @@ -890,35 +1415,31 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) endif endif endif - if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) & + if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.) .and. dl<2) & deallocate( locfield ) - end subroutine post_data_2d_low +!> Make a real 3-d array diagnostic available for averaging or output. subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h) - integer, intent(in) :: diag_field_id - real, intent(in) :: field(:,:,:) - type(diag_ctrl), target, intent(in) :: diag_cs - logical, optional, intent(in) :: is_static - real, optional, intent(in) :: mask(:,:,:) - real, target, optional, intent(in) :: alt_h(:,:,:) - -! Arguments: -! (in) diag_field_id - id for an output variable returned by a -! previous call to register_diag_field. -! (in) field - 3-d array being offered for output or averaging -! (inout) diag - structure used to regulate diagnostic output -! (in) static - If true, this is a static field that is always offered. -! (in,opt) mask - If present, use this real array as the data mask. + integer, intent(in) :: diag_field_id !< The id for an output variable returned by a + !! previous call to register_diag_field. + real, intent(in) :: field(:,:,:) !< 3-d array being offered for output or averaging + type(diag_ctrl), target, intent(in) :: diag_CS !< Structure used to regulate diagnostic output + logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. + real, optional, intent(in) :: mask(:,:,:) !< If present, use this real array as the data mask. + real, dimension(:,:,:), & + target, optional, intent(in) :: alt_h !< An alternate thickness to use for vertically + !! remapping this diagnostic [H ~> m or kg m-2]. + ! Local variables type(diag_type), pointer :: diag => null() integer :: nz, i, j, k real, dimension(:,:,:), allocatable :: remapped_field logical :: staggered_in_x, staggered_in_y - real, dimension(:,:,:), pointer :: h_diag + real, dimension(:,:,:), pointer :: h_diag => NULL() - if(present(alt_h)) then + if (present(alt_h)) then h_diag => alt_h else h_diag => diag_cs%h @@ -1018,27 +1539,31 @@ subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h) end subroutine post_data_3d +!> Make a real 3-d array diagnostic available for averaging or output +!! using a diag_type instead of an integer id. subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) - type(diag_type), intent(in) :: diag - real, target, intent(in) :: field(:,:,:) - type(diag_ctrl), intent(in) :: diag_cs - logical, optional, intent(in) :: is_static - real, optional, intent(in) :: mask(:,:,:) - -! Arguments: -! (in) diag - the diagnostic to post. -! (in) field - 3-d array being offered for output or averaging -! (inout) diag_cs - structure used to regulate diagnostic output -! (in) static - If true, this is a static field that is always offered. -! (in,opt) mask - If present, use this real array as the data mask. - - real, dimension(:,:,:), pointer :: locfield => NULL() + type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post + real, target, intent(in) :: field(:,:,:) !< 3-d array being offered for output or averaging + type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output + logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. + real, optional,target, intent(in) :: mask(:,:,:) !< If present, use this real array as the data mask. + + ! Local variables + real, dimension(:,:,:), pointer :: locfield + real, dimension(:,:,:), pointer :: locmask + character(len=300) :: mesg logical :: used ! The return value of send_data is not used for anything. logical :: staggered_in_x, staggered_in_y logical :: is_stat - integer :: isv, iev, jsv, jev, ks, ke, i, j, k, isv_c, jsv_c + integer :: cszi, cszj, dszi, dszj + integer :: isv, iev, jsv, jev, ks, ke, i, j, k, isv_c, jsv_c, isv_o,jsv_o integer :: chksum + real, dimension(:,:,:), allocatable, target :: locfield_dsamp + real, dimension(:,:,:), allocatable, target :: locmask_dsamp + integer :: dl + locfield => NULL() + locmask => NULL() is_stat = .false. ; if (present(is_static)) is_stat = is_static ! Determine the proper array indices, noting that because of the (:,:) @@ -1048,33 +1573,41 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) ! the output data size and assumes that halos are symmetric. isv = diag_cs%is ; iev = diag_cs%ie ; jsv = diag_cs%js ; jev = diag_cs%je - if ( size(field,1) == diag_cs%ied-diag_cs%isd +1 ) then - isv = diag_cs%is ; iev = diag_cs%ie ! Data domain - elseif ( size(field,1) == diag_cs%ied-diag_cs%isd +2 ) then - isv = diag_cs%is ; iev = diag_cs%ie+1 ! Symmetric data domain - elseif ( size(field,1) == diag_cs%ie-diag_cs%is +1 ) then - isv = 1 ; iev = diag_cs%ie + 1-diag_cs%is ! Computational domain - elseif ( size(field,1) == diag_cs%ie-diag_cs%is +2 ) then - isv = 1 ; iev = diag_cs%ie + 2-diag_cs%is ! Symmetric computational domain + cszi = (diag_cs%ie-diag_cs%is) +1 ; dszi = (diag_cs%ied-diag_cs%isd) +1 + cszj = (diag_cs%je-diag_cs%js) +1 ; dszj = (diag_cs%jed-diag_cs%jsd) +1 + if ( size(field,1) == dszi ) then + isv = diag_cs%is ; iev = diag_cs%ie ! Data domain + elseif ( size(field,1) == dszi + 1 ) then + isv = diag_cs%is ; iev = diag_cs%ie+1 ! Symmetric data domain + elseif ( size(field,1) == cszi) then + isv = 1 ; iev = cszi ! Computational domain + elseif ( size(field,1) == cszi + 1 ) then + isv = 1 ; iev = cszi+1 ! Symmetric computational domain else - call MOM_error(FATAL,"post_data_3d_low: peculiar size in i-direction") - endif - if ( size(field,2) == diag_cs%jed-diag_cs%jsd +1 ) then - jsv = diag_cs%js ; jev = diag_cs%je ! Data domain - elseif ( size(field,2) == diag_cs%jed-diag_cs%jsd +2 ) then - jsv = diag_cs%js ; jev = diag_cs%je+1 ! Symmetric data domain - elseif ( size(field,2) == diag_cs%je-diag_cs%js +1 ) then - jsv = 1 ; jev = diag_cs%je + 1-diag_cs%js ! Computational domain - elseif ( size(field,1) == diag_cs%je-diag_cs%js +2 ) then - jsv = 1 ; jev = diag_cs%je + 2-diag_cs%js ! Symmetric computational domain + write (mesg,*) " peculiar size ",size(field,1)," in i-direction\n"//& + "does not match one of ", cszi, cszi+1, dszi, dszi+1 + call MOM_error(FATAL,"post_data_3d_low: "//trim(diag%debug_str)//trim(mesg)) + endif + + if ( size(field,2) == dszj ) then + jsv = diag_cs%js ; jev = diag_cs%je ! Data domain + elseif ( size(field,2) == dszj + 1 ) then + jsv = diag_cs%js ; jev = diag_cs%je+1 ! Symmetric data domain + elseif ( size(field,2) == cszj ) then + jsv = 1 ; jev = cszj ! Computational domain + elseif ( size(field,2) == cszj+1 ) then + jsv = 1 ; jev = cszj+1 ! Symmetric computational domain else - call MOM_error(FATAL,"post_data_3d_low: peculiar size in j-direction") + write (mesg,*) " peculiar size ",size(field,2)," in j-direction\n"//& + "does not match one of ", cszj, cszj+1, dszj, dszj+1 + call MOM_error(FATAL,"post_data_3d_low: "//trim(diag%debug_str)//trim(mesg)) endif + ks = lbound(field,3) ; ke = ubound(field,3) if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) then - ks = lbound(field,3) ; ke = ubound(field,3) allocate( locfield( lbound(field,1):ubound(field,1), lbound(field,2):ubound(field,2), ks:ke ) ) - ! locfield(:,:,:) = 0.0 ! Zeroing out this array would be a good idea, but it appears not to be necessary. + ! locfield(:,:,:) = 0.0 ! Zeroing out this array would be a good idea, but it appears + ! not to be necessary. isv_c = isv ; jsv_c = jsv if (diag%fms_xyave_diag_id>0) then staggered_in_x = diag%axes%is_u_point .or. diag%axes%is_q_point @@ -1090,7 +1623,7 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) "have j-direction space to represent the symmetric computational domain.") endif - do k=ks,ke ; do j=jsv_c,jev ; do i=isv_c,iev + do k=ks,ke ; do j=jsv,jev ; do i=isv,iev if (field(i,j,k) == diag_cs%missing_value) then locfield(i,j,k) = diag_cs%missing_value else @@ -1101,6 +1634,28 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) locfield => field endif + if (present(mask)) then + locmask => mask + elseif(associated(diag%axes%mask3d)) then + locmask => diag%axes%mask3d + endif + + dl=1 + if(.NOT. is_stat) dl = diag%axes%downsample_level !static field downsample i not supported yet + !Downsample the diag field and mask (if present) + if (dl > 1) then + isv_o=isv ; jsv_o=jsv + call downsample_diag_field(locfield, locfield_dsamp, dl, diag_cs, diag,isv,iev,jsv,jev, mask) + if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) deallocate( locfield ) + locfield => locfield_dsamp + if (present(mask)) then + call downsample_field_3d(locmask, locmask_dsamp, dl, MSK, locmask, diag_cs,diag,isv_o,jsv_o,isv,iev,jsv,jev) + locmask => locmask_dsamp + elseif(associated(diag%axes%dsamp(dl)%mask3d)) then + locmask => diag%axes%dsamp(dl)%mask3d + endif + endif + if (diag%fms_diag_id>0) then if (diag_cs%diag_as_chksum) then chksum = chksum_general(locfield) @@ -1110,30 +1665,24 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) else if (is_stat) then if (present(mask)) then - call assert(size(locfield) == size(mask), & + call assert(size(locfield) == size(locmask), & 'post_data_3d_low is_stat: mask size mismatch: '//diag%debug_str) used = send_data(diag%fms_diag_id, locfield, & - is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=mask) - !elseif(associated(diag%axes%mask3d)) then - ! used = send_data(diag_field_id, locfield, & - ! is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=diag%axes%mask3d) + is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=locmask) + !elseif (associated(diag%axes%mask2d)) then + ! used = send_data(diag%fms_diag_id, locfield, & + ! is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=diag%axes%mask2d) else used = send_data(diag%fms_diag_id, locfield, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev) endif elseif (diag_cs%ave_enabled) then - if (present(mask)) then - call assert(size(locfield) == size(mask), & + if (associated(locmask)) then + call assert(size(locfield) == size(locmask), & 'post_data_3d_low: mask size mismatch: '//diag%debug_str) used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & - weight=diag_cs%time_int, rmask=mask) - elseif(associated(diag%axes%mask3d)) then - call assert(size(locfield) == size(diag%axes%mask3d), & - 'post_data_3d_low: mask3d size mismatch: '//diag%debug_str) - used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & - is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & - weight=diag_cs%time_int, rmask=diag%axes%mask3d) + weight=diag_cs%time_int, rmask=locmask) else used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & @@ -1142,10 +1691,7 @@ 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.)) & + if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.) .and. dl<2) & deallocate( locfield ) end subroutine post_data_3d_low @@ -1195,116 +1741,133 @@ subroutine post_xy_average(diag_cs, diag, field) weight=diag_cs%time_int) end subroutine post_xy_average +!> This subroutine enables the accumulation of time averages over the specified time interval. subroutine enable_averaging(time_int_in, time_end_in, diag_cs) - real, intent(in) :: time_int_in - type(time_type), intent(in) :: time_end_in - type(diag_ctrl), intent(inout) :: diag_cs + real, intent(in) :: time_int_in !< The time interval [s] over which any + !! values that are offered are valid. + type(time_type), intent(in) :: time_end_in !< The end time of the valid interval + type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output ! This subroutine enables the accumulation of time averages over the ! specified time interval. -! Arguments: -! (in) time_int_in - time interval in s over which any -! values that are offered are valid. -! (in) time_end_in - end time in s of the valid interval -! (inout) diag - structure used to regulate diagnostic output - ! if (num_file==0) return diag_cs%time_int = time_int_in diag_cs%time_end = time_end_in diag_cs%ave_enabled = .true. end subroutine enable_averaging -! Call this subroutine to avoid averaging any offered fields. +!> Call this subroutine to avoid averaging any offered fields. subroutine disable_averaging(diag_cs) - type(diag_ctrl), intent(inout) :: diag_cs - -! Argument: -! diag - structure used to regulate diagnostic output + type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output diag_cs%time_int = 0.0 diag_cs%ave_enabled = .false. end subroutine disable_averaging -! Call this subroutine to determine whether the averaging is -! currently enabled. .true. is returned if it is. +!> Call this subroutine to determine whether the averaging is +!! currently enabled. .true. is returned if it is. function query_averaging_enabled(diag_cs, time_int, time_end) - type(diag_ctrl), intent(in) :: diag_cs - real, optional, intent(out) :: time_int - type(time_type), optional, intent(out) :: time_end + type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output + real, optional, intent(out) :: time_int !< Current setting of diag%time_int [s] + type(time_type), optional, intent(out) :: time_end !< Current setting of diag%time_end logical :: query_averaging_enabled -! Arguments: -! (in) diag - structure used to regulate diagnostic output -! (out,opt) time_int - current setting of diag%time_int, in s -! (out,opt) time_end - current setting of diag%time_end - if (present(time_int)) time_int = diag_cs%time_int if (present(time_end)) time_end = diag_cs%time_end query_averaging_enabled = diag_cs%ave_enabled end function query_averaging_enabled +!> This function returns the valid end time for use with diagnostics that are +!! handled outside of the MOM6 diagnostics infrastructure. function get_diag_time_end(diag_cs) - type(diag_ctrl), intent(in) :: diag_cs + type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output type(time_type) :: get_diag_time_end - -! Argument: -! (in) diag - structure used to regulate diagnostic output - -! This function returns the valid end time for diagnostics that are handled -! outside of the MOM6 infrastructure, such as via the generic tracer code. + ! This function returns the valid end time for diagnostics that are handled + ! outside of the MOM6 infrastructure, such as via the generic tracer code. get_diag_time_end = diag_cs%time_end end function get_diag_time_end -!> Returns the "diag_mediator" handle for a group (native, CMOR, z-coord, ...) of diagnostics derived from one field. -integer function register_diag_field(module_name, field_name, axes, init_time, & +!> Returns the "diag_mediator" handle for a group (native, CMOR, z-coord, ...) of diagnostics +!! derived from one field. +integer function register_diag_field(module_name, field_name, axes_in, init_time, & long_name, units, missing_value, range, mask_variant, standard_name, & verbose, do_not_log, err_msg, interp_method, tile_count, cmor_field_name, & cmor_long_name, cmor_units, cmor_standard_name, cell_methods, & x_cell_method, y_cell_method, v_cell_method, conversion, v_extensive) - character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" or "ice_shelf_model" + character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" + !! or "ice_shelf_model" character(len=*), intent(in) :: field_name !< Name of the diagnostic field - type(axes_grp), target, intent(in) :: axes !< Container w/ up to 3 integer handles that indicates axes for this field + type(axes_grp), target, intent(in) :: axes_in !< Container w/ up to 3 integer handles that + !! indicates axes for this field type(time_type), intent(in) :: init_time !< Time at which a field is first available? character(len=*), optional, intent(in) :: long_name !< Long name of a field. character(len=*), optional, intent(in) :: units !< Units of a field. character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field real, optional, intent(in) :: missing_value !< A value that indicates missing values. real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) - logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided with post_data calls (not used in MOM?) + logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided with + !! post_data calls (not used in MOM?) logical, optional, intent(in) :: verbose !< If true, FMS is verbose (not used in MOM?) logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?) - character(len=*), optional, intent(out):: err_msg !< String into which an error message might be placed (not used in MOM?) - character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should not be interpolated as a scalar + character(len=*), optional, intent(out):: err_msg !< String into which an error message might be + !! placed (not used in MOM?) + character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should not + !! be interpolated as a scalar integer, optional, intent(in) :: tile_count !< no clue (not used in MOM?) 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 - character(len=*), optional, intent(in) :: cell_methods !< String to append as cell_methods attribute. Use '' to have no attribute. - !! If present, this overrides the default constructed from the default for + character(len=*), optional, intent(in) :: cell_methods !< String to append as cell_methods attribute. Use '' to + !! have no attribute. If present, this overrides the + !! default constructed from the default for !! each individual axis direction. - character(len=*), optional, intent(in) :: x_cell_method !< Specifies the cell method for the x-direction. Use '' have no method. - character(len=*), optional, intent(in) :: y_cell_method !< Specifies the cell method for the y-direction. Use '' have no method. - character(len=*), optional, intent(in) :: v_cell_method !< Specifies the cell method for the vertical direction. Use '' have no method. + character(len=*), optional, intent(in) :: x_cell_method !< Specifies the cell method for the x-direction. + !! Use '' have no method. + character(len=*), optional, intent(in) :: y_cell_method !< Specifies the cell method for the y-direction. + !! Use '' have no method. + character(len=*), optional, intent(in) :: v_cell_method !< Specifies the cell method for the vertical direction. + !! Use '' have no method. real, optional, intent(in) :: conversion !< A value to multiply data by before writing to file - logical, optional, intent(in) :: v_extensive !< True for vertically extensive fields (vertically integrated). Default/absent for intensive. + logical, optional, intent(in) :: v_extensive !< True for vertically extensive fields (vertically + !! integrated). Default/absent for intensive. ! Local variables real :: MOM_missing_value - type(diag_ctrl), pointer :: diag_cs + type(diag_ctrl), pointer :: diag_cs => NULL() type(axes_grp), pointer :: remap_axes => null() - integer :: dm_id, i + type(axes_grp), pointer :: axes => null() + integer :: dm_id, i, dl character(len=256) :: new_module_name logical :: active + axes => axes_in MOM_missing_value = axes%diag_cs%missing_value - if(present(missing_value)) MOM_missing_value = missing_value + if (present(missing_value)) MOM_missing_value = missing_value diag_cs => axes%diag_cs dm_id = -1 + if (axes_in%id == diag_cs%axesTL%id) then + axes => diag_cs%axesTL + elseif (axes_in%id == diag_cs%axesBL%id) then + axes => diag_cs%axesBL + elseif (axes_in%id == diag_cs%axesCuL%id ) then + axes => diag_cs%axesCuL + elseif (axes_in%id == diag_cs%axesCvL%id) then + axes => diag_cs%axesCvL + elseif (axes_in%id == diag_cs%axesTi%id) then + axes => diag_cs%axesTi + elseif (axes_in%id == diag_cs%axesBi%id) then + axes => diag_cs%axesBi + elseif (axes_in%id == diag_cs%axesCui%id ) then + axes => diag_cs%axesCui + elseif (axes_in%id == diag_cs%axesCvi%id) then + axes => diag_cs%axesCvi + endif + ! Register the native diagnostic active = register_diag_field_expand_cmor(dm_id, module_name, field_name, axes, & init_time, long_name=long_name, units=units, missing_value=MOM_missing_value, & @@ -1322,23 +1885,23 @@ integer function register_diag_field(module_name, field_name, axes, init_time, & new_module_name = trim(module_name)//'_'//trim(diag_cs%diag_remap_cs(i)%diag_module_suffix) ! Register diagnostics remapped to z vertical coordinate - if (axes%rank == 3) then + if (axes_in%rank == 3) then remap_axes => null() - if ((axes%id .eq. diag_cs%axesTL%id)) then + if ((axes_in%id == diag_cs%axesTL%id)) then remap_axes => diag_cs%remap_axesTL(i) - elseif(axes%id .eq. diag_cs%axesBL%id) then + elseif (axes_in%id == diag_cs%axesBL%id) then remap_axes => diag_cs%remap_axesBL(i) - elseif(axes%id .eq. diag_cs%axesCuL%id ) then + elseif (axes_in%id == diag_cs%axesCuL%id ) then remap_axes => diag_cs%remap_axesCuL(i) - elseif(axes%id .eq. diag_cs%axesCvL%id) then + elseif (axes_in%id == diag_cs%axesCvL%id) then remap_axes => diag_cs%remap_axesCvL(i) - elseif(axes%id .eq. diag_cs%axesTi%id) then + elseif (axes_in%id == diag_cs%axesTi%id) then remap_axes => diag_cs%remap_axesTi(i) - elseif(axes%id .eq. diag_cs%axesBi%id) then + elseif (axes_in%id == diag_cs%axesBi%id) then remap_axes => diag_cs%remap_axesBi(i) - elseif(axes%id .eq. diag_cs%axesCui%id ) then + elseif (axes_in%id == diag_cs%axesCui%id ) then remap_axes => diag_cs%remap_axesCui(i) - elseif(axes%id .eq. diag_cs%axesCvi%id) then + elseif (axes_in%id == diag_cs%axesCvi%id) then remap_axes => diag_cs%remap_axesCvi(i) endif ! When the MOM_diag_to_Z module has been obsoleted we can assume remap_axes will @@ -1364,11 +1927,110 @@ integer function register_diag_field(module_name, field_name, axes, init_time, & endif ! axes%rank == 3 enddo ! i + !Register downsampled diagnostics + do dl=2,MAX_DSAMP_LEV + new_module_name = trim(module_name)//'_d2' + + if (axes_in%rank == 3 .or. axes_in%rank == 2 ) then + axes => null() + if (axes_in%id == diag_cs%axesTL%id) then + axes => diag_cs%dsamp(dl)%axesTL + elseif (axes_in%id == diag_cs%axesBL%id) then + axes => diag_cs%dsamp(dl)%axesBL + elseif (axes_in%id == diag_cs%axesCuL%id ) then + axes => diag_cs%dsamp(dl)%axesCuL + elseif (axes_in%id == diag_cs%axesCvL%id) then + axes => diag_cs%dsamp(dl)%axesCvL + elseif (axes_in%id == diag_cs%axesTi%id) then + axes => diag_cs%dsamp(dl)%axesTi + elseif (axes_in%id == diag_cs%axesBi%id) then + axes => diag_cs%dsamp(dl)%axesBi + elseif (axes_in%id == diag_cs%axesCui%id ) then + axes => diag_cs%dsamp(dl)%axesCui + elseif (axes_in%id == diag_cs%axesCvi%id) then + axes => diag_cs%dsamp(dl)%axesCvi + elseif (axes_in%id == diag_cs%axesT1%id) then + axes => diag_cs%dsamp(dl)%axesT1 + elseif (axes_in%id == diag_cs%axesB1%id) then + axes => diag_cs%dsamp(dl)%axesB1 + elseif (axes_in%id == diag_cs%axesCu1%id ) then + axes => diag_cs%dsamp(dl)%axesCu1 + elseif (axes_in%id == diag_cs%axesCv1%id) then + axes => diag_cs%dsamp(dl)%axesCv1 + else + !Niki: Should we worry about these, e.g., diag_to_Z_CS? + call MOM_error(WARNING,"register_diag_field: Could not find a proper axes for " & + //trim( new_module_name)//"-"//trim(field_name)) + endif + endif + ! Register the native diagnostic + if (associated(axes)) then + active = register_diag_field_expand_cmor(dm_id, new_module_name, field_name, axes, & + init_time, long_name=long_name, units=units, missing_value=MOM_missing_value, & + 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, & + cmor_field_name=cmor_field_name, cmor_long_name=cmor_long_name, & + cmor_units=cmor_units, cmor_standard_name=cmor_standard_name, & + cell_methods=cell_methods, x_cell_method=x_cell_method, & + y_cell_method=y_cell_method, v_cell_method=v_cell_method, & + conversion=conversion, v_extensive=v_extensive) + endif + + ! For each diagnostic coordinate register the diagnostic again under a different module name + do i=1,diag_cs%num_diag_coords + new_module_name = trim(module_name)//'_'//trim(diag_cs%diag_remap_cs(i)%diag_module_suffix)//'_d2' + + ! Register diagnostics remapped to z vertical coordinate + if (axes_in%rank == 3) then + remap_axes => null() + if ((axes_in%id == diag_cs%axesTL%id)) then + remap_axes => diag_cs%dsamp(dl)%remap_axesTL(i) + elseif (axes_in%id == diag_cs%axesBL%id) then + remap_axes => diag_cs%dsamp(dl)%remap_axesBL(i) + elseif (axes_in%id == diag_cs%axesCuL%id ) then + remap_axes => diag_cs%dsamp(dl)%remap_axesCuL(i) + elseif (axes_in%id == diag_cs%axesCvL%id) then + remap_axes => diag_cs%dsamp(dl)%remap_axesCvL(i) + elseif (axes_in%id == diag_cs%axesTi%id) then + remap_axes => diag_cs%dsamp(dl)%remap_axesTi(i) + elseif (axes_in%id == diag_cs%axesBi%id) then + remap_axes => diag_cs%dsamp(dl)%remap_axesBi(i) + elseif (axes_in%id == diag_cs%axesCui%id ) then + remap_axes => diag_cs%dsamp(dl)%remap_axesCui(i) + elseif (axes_in%id == diag_cs%axesCvi%id) then + remap_axes => diag_cs%dsamp(dl)%remap_axesCvi(i) + endif + + ! When the MOM_diag_to_Z module has been obsoleted we can assume remap_axes will + ! always exist but in the mean-time we have to do this check: + ! call assert(associated(remap_axes), 'register_diag_field: remap_axes not set') + if (associated(remap_axes)) then + if (remap_axes%needs_remapping .or. remap_axes%needs_interpolating) then + active = register_diag_field_expand_cmor(dm_id, new_module_name, field_name, remap_axes, & + init_time, long_name=long_name, units=units, missing_value=MOM_missing_value, & + 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, & + cmor_field_name=cmor_field_name, cmor_long_name=cmor_long_name, & + cmor_units=cmor_units, cmor_standard_name=cmor_standard_name, & + cell_methods=cell_methods, x_cell_method=x_cell_method, & + y_cell_method=y_cell_method, v_cell_method=v_cell_method, & + conversion=conversion, v_extensive=v_extensive) + if (active) then + call diag_remap_set_active(diag_cs%diag_remap_cs(i)) + endif + endif ! remap_axes%needs_remapping + endif ! associated(remap_axes) + endif ! axes%rank == 3 + enddo ! i + enddo + register_diag_field = dm_id end function register_diag_field -!> Returns True if either the native of CMOr version of the diagnostic were registered. Updates 'dm_id' +!> Returns True if either the native or CMOr version of the diagnostic were registered. Updates 'dm_id' !! after calling register_diag_field_expand_axes() for both native and CMOR variants of the field. logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, axes, init_time, & long_name, units, missing_value, range, mask_variant, standard_name, & @@ -1378,40 +2040,49 @@ logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, integer, intent(inout) :: dm_id !< The diag_mediator ID for this diagnostic group character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" or "ice_shelf_model" character(len=*), intent(in) :: field_name !< Name of the diagnostic field - type(axes_grp), target, intent(in) :: axes !< Container w/ up to 3 integer handles that indicates axes for this field + type(axes_grp), target, intent(in) :: axes !< Container w/ up to 3 integer handles that indicates axes + !! for this field type(time_type), intent(in) :: init_time !< Time at which a field is first available? character(len=*), optional, intent(in) :: long_name !< Long name of a field. character(len=*), optional, intent(in) :: units !< Units of a field. character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field real, optional, intent(in) :: missing_value !< A value that indicates missing values. real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) - logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided with post_data calls (not used in MOM?) + logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided + !! with post_data calls (not used in MOM?) logical, optional, intent(in) :: verbose !< If true, FMS is verbose (not used in MOM?) logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?) - character(len=*), optional, intent(out):: err_msg !< String into which an error message might be placed (not used in MOM?) - character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should not be interpolated as a scalar + character(len=*), optional, intent(out):: err_msg !< String into which an error message might be + !! placed (not used in MOM?) + character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should + !! not be interpolated as a scalar integer, optional, intent(in) :: tile_count !< no clue (not used in MOM?) 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 - character(len=*), optional, intent(in) :: cell_methods !< String to append as cell_methods attribute. Use '' to have no attribute. - !! If present, this overrides the default constructed from the default for - !! each individual axis direction. - character(len=*), optional, intent(in) :: x_cell_method !< Specifies the cell method for the x-direction. Use '' have no method. - character(len=*), optional, intent(in) :: y_cell_method !< Specifies the cell method for the y-direction. Use '' have no method. - character(len=*), optional, intent(in) :: v_cell_method !< Specifies the cell method for the vertical direction. Use '' have no method. + character(len=*), optional, intent(in) :: cell_methods !< String to append as cell_methods attribute. + !! Use '' to have no attribute. If present, this + !! overrides the default constructed from the default + !! for each individual axis direction. + character(len=*), optional, intent(in) :: x_cell_method !< Specifies the cell method for the x-direction. + !! Use '' have no method. + character(len=*), optional, intent(in) :: y_cell_method !< Specifies the cell method for the y-direction. + !! Use '' have no method. + character(len=*), optional, intent(in) :: v_cell_method !< Specifies the cell method for the vertical direction. + !! Use '' have no method. real, optional, intent(in) :: conversion !< A value to multiply data by before writing to file - logical, optional, intent(in) :: v_extensive !< True for vertically extensive fields (vertically integrated). Default/absent for intensive. + logical, optional, intent(in) :: v_extensive !< True for vertically extensive fields (vertically + !! integrated). Default/absent for intensive. ! Local variables real :: MOM_missing_value - type(diag_ctrl), pointer :: diag_cs + type(diag_ctrl), pointer :: diag_cs => null() type(diag_type), pointer :: this_diag => null() integer :: fms_id, fms_xyave_id character(len=256) :: posted_cmor_units, posted_cmor_standard_name, posted_cmor_long_name, cm_string, msg MOM_missing_value = axes%diag_cs%missing_value - if(present(missing_value)) MOM_missing_value = missing_value + if (present(missing_value)) MOM_missing_value = missing_value register_diag_field_expand_cmor = .false. diag_cs => axes%diag_cs @@ -1453,7 +2124,8 @@ logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, if (fms_id /= DIAG_FIELD_NOT_FOUND .or. fms_xyave_id /= DIAG_FIELD_NOT_FOUND) then call add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name, field_name, msg) this_diag%fms_xyave_diag_id = fms_xyave_id - + !Encode and save the cell methods for this diag + call add_xyz_method(this_diag, axes, x_cell_method, y_cell_method, v_cell_method, v_extensive) if (present(v_extensive)) this_diag%v_extensive = v_extensive if (present(conversion)) this_diag%conversion_factor = conversion register_diag_field_expand_cmor = .true. @@ -1462,9 +2134,9 @@ logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, ! For the CMOR variation of the above diagnostic 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 able to be replaced with a CS%missing field? - posted_cmor_long_name = "not provided" ! + posted_cmor_units = "not provided" ! + posted_cmor_standard_name = "not provided" ! Values might be able to 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 @@ -1478,9 +2150,9 @@ logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, if (present(cmor_long_name)) posted_cmor_long_name = cmor_long_name fms_id = register_diag_field_expand_axes(module_name, cmor_field_name, axes, init_time, & - long_name=trim(posted_cmor_long_name), units=trim(posted_cmor_units), & - missing_value=MOM_missing_value, range=range, mask_variant=mask_variant, & - standard_name=trim(posted_cmor_standard_name), verbose=verbose, do_not_log=do_not_log, & + long_name=trim(posted_cmor_long_name), units=trim(posted_cmor_units), & + missing_value=MOM_missing_value, range=range, mask_variant=mask_variant, & + standard_name=trim(posted_cmor_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, & @@ -1496,16 +2168,16 @@ logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, if (associated(axes%xyave_axes)) then fms_xyave_id = register_diag_field_expand_axes(module_name, trim(cmor_field_name)//'_xyave', & axes%xyave_axes, init_time, & - long_name=trim(posted_cmor_long_name), units=trim(posted_cmor_units), & - missing_value=MOM_missing_value, range=range, mask_variant=mask_variant, & - standard_name=trim(posted_cmor_standard_name), verbose=verbose, do_not_log=do_not_log, & + long_name=trim(posted_cmor_long_name), units=trim(posted_cmor_units), & + missing_value=MOM_missing_value, range=range, mask_variant=mask_variant, & + standard_name=trim(posted_cmor_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 (is_root_pe() .and. diag_CS%available_diag_doc_unit > 0) then msg = 'native name is "'//trim(field_name)//'_xyave"' - call log_available_diag(fms_xyave_id>0, module_name, trim(cmor_field_name)//'_xyave', cm_string, & - msg, diag_CS, posted_cmor_long_name, posted_cmor_units, & + call log_available_diag(fms_xyave_id>0, module_name, trim(cmor_field_name)//'_xyave', & + cm_string, msg, diag_CS, posted_cmor_long_name, posted_cmor_units, & posted_cmor_standard_name) endif endif @@ -1513,7 +2185,8 @@ logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, if (fms_id /= DIAG_FIELD_NOT_FOUND .or. fms_xyave_id /= DIAG_FIELD_NOT_FOUND) then call add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name, field_name, msg) this_diag%fms_xyave_diag_id = fms_xyave_id - + !Encode and save the cell methods for this diag + call add_xyz_method(this_diag, axes, x_cell_method, y_cell_method, v_cell_method, v_extensive) if (present(v_extensive)) this_diag%v_extensive = v_extensive if (present(conversion)) this_diag%conversion_factor = conversion register_diag_field_expand_cmor = .true. @@ -1522,25 +2195,31 @@ logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, end function register_diag_field_expand_cmor -!> Returns an FMS id from register_diag_field_fms (the diag_manager routine) after expanding axes (axes-group) -!! into handles and conditionally adding an FMS area_id for cell_measures. +!> Returns an FMS id from register_diag_field_fms (the diag_manager routine) after expanding axes +!! (axes-group) into handles and conditionally adding an FMS area_id for cell_measures. integer function register_diag_field_expand_axes(module_name, field_name, axes, init_time, & long_name, units, missing_value, range, mask_variant, standard_name, & verbose, do_not_log, err_msg, interp_method, tile_count) - character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" or "ice_shelf_model" + character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" + !! or "ice_shelf_model" character(len=*), intent(in) :: field_name !< Name of the diagnostic field - type(axes_grp), target, intent(in) :: axes !< Container w/ up to 3 integer handles that indicates axes for this field + type(axes_grp), target, intent(in) :: axes !< Container w/ up to 3 integer handles that indicates + !! axes for this field type(time_type), intent(in) :: init_time !< Time at which a field is first available? character(len=*), optional, intent(in) :: long_name !< Long name of a field. character(len=*), optional, intent(in) :: units !< Units of a field. character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field real, optional, intent(in) :: missing_value !< A value that indicates missing values. real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) - logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided with post_data calls (not used in MOM?) + logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided + !! with post_data calls (not used in MOM?) logical, optional, intent(in) :: verbose !< If true, FMS is verbose (not used in MOM?) - logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?) - character(len=*), optional, intent(out):: err_msg !< String into which an error message might be placed (not used in MOM?) - character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should not be interpolated as a scalar + logical, optional, intent(in) :: do_not_log !< If true, do not log something + !! (not used in MOM?) + character(len=*), optional, intent(out):: err_msg !< String into which an error message might be + !! placed (not used in MOM?) + character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should + !! not be interpolated as a scalar integer, optional, intent(in) :: tile_count !< no clue (not used in MOM?) ! Local variables integer :: fms_id, area_id, volume_id @@ -1624,8 +2303,10 @@ subroutine add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name integer, intent(inout) :: dm_id !< The diag_mediator ID for this diagnostic group integer, intent(in) :: fms_id !< The FMS diag_manager ID for this diagnostic type(diag_type), pointer :: this_diag !< This diagnostic - type(axes_grp), target, intent(in) :: axes !< Container w/ up to 3 integer handles that indicates axes for this field - character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" or "ice_shelf_model" + type(axes_grp), target, intent(in) :: axes !< Container w/ up to 3 integer handles that + !! indicates axes for this field + character(len=*), intent(in) :: module_name !< Name of this module, usually + !! "ocean_model" or "ice_shelf_model" character(len=*), intent(in) :: field_name !< Name of diagnostic character(len=*), intent(in) :: msg !< Message for errors @@ -1641,19 +2322,88 @@ subroutine add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name end subroutine add_diag_to_list +!> Adds the encoded "cell_methods" for a diagnostics as a diag% property +!! This allows access to the cell_method for a given diagnostics at the time of sending +subroutine add_xyz_method(diag, axes, x_cell_method, y_cell_method, v_cell_method, v_extensive) + type(diag_type), pointer :: diag !< This diagnostic + type(axes_grp), intent(in) :: axes !< Container w/ up to 3 integer handles that indicates + !! axes for this field + character(len=*), optional, intent(in) :: x_cell_method !< Specifies the cell method for the x-direction. + !! Use '' have no method. + character(len=*), optional, intent(in) :: y_cell_method !< Specifies the cell method for the y-direction. + !! Use '' have no method. + character(len=*), optional, intent(in) :: v_cell_method !< Specifies the cell method for the vertical direction. + !! Use '' have no method. + logical, optional, intent(in) :: v_extensive !< True for vertically extensive fields + !! (vertically integrated). Default/absent for intensive. + integer :: xyz_method + character(len=9) :: mstr + + !This is a simple way to encode the cell method information made from 3 strings + !(x_cell_method,y_cell_method,v_cell_method) in a 3 digit integer xyz + !x_cell_method,y_cell_method,v_cell_method can each be 'point' or 'sum' or 'mean' + !We can encode these with setting 1 for 'point', 2 for 'sum, 3 for 'mean' in + !the 100s position for x, 10s position for y, 1s position for z + !E.g., x:sum,y:point,z:mean is 213 + + xyz_method = 111 + + mstr = diag%axes%v_cell_method + if (present(v_extensive)) then + if (present(v_cell_method)) call MOM_error(FATAL, "attach_cell_methods: " // & + 'Vertical cell method was specified along with the vertically extensive flag.') + if(v_extensive) then + mstr='sum' + else + mstr='mean' + endif + elseif (present(v_cell_method)) then + mstr = v_cell_method + endif + if (trim(mstr)=='sum') then + xyz_method = xyz_method + 1 + elseif (trim(mstr)=='mean') then + xyz_method = xyz_method + 2 + endif + + mstr = diag%axes%y_cell_method + if (present(y_cell_method)) mstr = y_cell_method + if (trim(mstr)=='sum') then + xyz_method = xyz_method + 10 + elseif (trim(mstr)=='mean') then + xyz_method = xyz_method + 20 + endif + + mstr = diag%axes%x_cell_method + if (present(x_cell_method)) mstr = x_cell_method + if (trim(mstr)=='sum') then + xyz_method = xyz_method + 100 + elseif (trim(mstr)=='mean') then + xyz_method = xyz_method + 200 + endif + + diag%xyz_method = xyz_method +end subroutine add_xyz_method + !> Attaches "cell_methods" attribute to a variable based on defaults for axes_grp or optional arguments. subroutine attach_cell_methods(id, axes, ostring, cell_methods, & x_cell_method, y_cell_method, v_cell_method, v_extensive) integer, intent(in) :: id !< Handle to diagnostic - type(axes_grp), intent(in) :: axes !< Container w/ up to 3 integer handles that indicates axes for this field + type(axes_grp), intent(in) :: axes !< Container w/ up to 3 integer handles that indicates + !! axes for this field character(len=*), intent(out) :: ostring !< The cell_methods strings that would appear in the file - character(len=*), optional, intent(in) :: cell_methods !< String to append as cell_methods attribute. Use '' to have no attribute. - !! If present, this overrides the default constructed from the default for - !! each individual axis direction. - character(len=*), optional, intent(in) :: x_cell_method !< Specifies the cell method for the x-direction. Use '' have no method. - character(len=*), optional, intent(in) :: y_cell_method !< Specifies the cell method for the y-direction. Use '' have no method. - character(len=*), optional, intent(in) :: v_cell_method !< Specifies the cell method for the vertical direction. Use '' have no method. - logical, optional, intent(in) :: v_extensive !< True for vertically extensive fields (vertically integrated). Default/absent for intensive. + character(len=*), optional, intent(in) :: cell_methods !< String to append as cell_methods attribute. + !! Use '' to have no attribute. If present, this + !! overrides the default constructed from the default + !! for each individual axis direction. + character(len=*), optional, intent(in) :: x_cell_method !< Specifies the cell method for the x-direction. + !! Use '' have no method. + character(len=*), optional, intent(in) :: y_cell_method !< Specifies the cell method for the y-direction. + !! Use '' have no method. + character(len=*), optional, intent(in) :: v_cell_method !< Specifies the cell method for the vertical direction. + !! Use '' have no method. + logical, optional, intent(in) :: v_extensive !< True for vertically extensive fields + !! (vertically integrated). Default/absent for intensive. ! Local variables character(len=9) :: axis_name logical :: x_mean, y_mean, x_sum, y_sum @@ -1722,6 +2472,7 @@ subroutine attach_cell_methods(id, axes, ostring, cell_methods, & ostring = trim(adjustl(ostring))//' '//trim(axis_name)//':'//trim(v_cell_method) endif elseif (present(v_extensive)) then + if(v_extensive) then if (axes%rank==1) then call get_diag_axis_name(axes%handles(1), axis_name) elseif (axes%rank==3) then @@ -1729,6 +2480,7 @@ subroutine attach_cell_methods(id, axes, ostring, cell_methods, & endif call diag_field_add_attribute(id, 'cell_methods', trim(axis_name)//':sum') ostring = trim(adjustl(ostring))//' '//trim(axis_name)//':sum' + endif else if (len(trim(axes%v_cell_method))>0) then if (axes%rank==1) then @@ -1755,44 +2507,35 @@ function register_scalar_field(module_name, field_name, init_time, diag_cs, & long_name, units, missing_value, range, standard_name, & do_not_log, err_msg, interp_method, cmor_field_name, & cmor_long_name, cmor_units, cmor_standard_name) - integer :: register_scalar_field - character(len=*), intent(in) :: module_name, field_name - type(time_type), intent(in) :: init_time - type(diag_ctrl), intent(inout) :: diag_cs - character(len=*), optional, intent(in) :: long_name, units, standard_name - real, optional, intent(in) :: missing_value, range(2) - logical, optional, intent(in) :: do_not_log - character(len=*), optional, intent(out):: err_msg - character(len=*), optional, intent(in) :: interp_method - character(len=*), optional, intent(in) :: cmor_field_name, cmor_long_name - character(len=*), optional, intent(in) :: cmor_units, cmor_standard_name - - ! Output: An integer handle for a diagnostic array. - ! Arguments: - ! (in) module_name - name of this module, usually "ocean_model" or "ice_shelf_model". - ! (in) field_name - name of the diagnostic field. - ! (in) init_time - time at which a field is first available? - ! (inout) diag_cs - structure used to regulate diagnostic output - ! (in,opt) long_name - long name of a field - ! (in,opt) units - units of a field - ! (in,opt) missing_value - indicates missing values - ! (in,opt) standard_name - standardized name associated with a field - - ! Following params have yet to be used in MOM. - ! (in,opt) range - valid range of a variable - ! (in,opt) verbose - If true, FMS is verbosed - ! (in,opt) do_not_log - If true, do not log something - ! (out,opt) err_msg - character string into which an error message might be placed - ! (in,opt) interp_method - If 'none' indicates the field should not be interpolated as a scalar - ! (in,opt) tile_count - no clue + integer :: register_scalar_field !< An integer handle for a diagnostic array. + character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" + !! or "ice_shelf_model" + character(len=*), intent(in) :: field_name !< Name of the diagnostic field + type(time_type), intent(in) :: init_time !< Time at which a field is first available? + type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output + character(len=*), optional, intent(in) :: long_name !< Long name of a field. + character(len=*), optional, intent(in) :: units !< Units of a field. + character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field + real, optional, intent(in) :: missing_value !< A value that indicates missing values. + real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) + logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?) + character(len=*), optional, intent(out):: err_msg !< String into which an error message might be + !! placed (not used in MOM?) + character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should not + !! be interpolated as a scalar + 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 real :: MOM_missing_value integer :: dm_id, fms_id type(diag_type), pointer :: diag => null(), cmor_diag => null() character(len=256) :: posted_cmor_units, posted_cmor_standard_name, posted_cmor_long_name MOM_missing_value = diag_cs%missing_value - if(present(missing_value)) MOM_missing_value = missing_value + if (present(missing_value)) MOM_missing_value = missing_value dm_id = -1 diag => null() @@ -1860,48 +2603,44 @@ function register_static_field(module_name, field_name, axes, & long_name, units, missing_value, range, mask_variant, standard_name, & do_not_log, interp_method, tile_count, & cmor_field_name, cmor_long_name, cmor_units, cmor_standard_name, area, & - x_cell_method, y_cell_method, area_cell_method) - integer :: register_static_field - character(len=*), intent(in) :: module_name, field_name - type(axes_grp), target, intent(in) :: axes - character(len=*), optional, intent(in) :: long_name, units, standard_name - real, optional, intent(in) :: missing_value, range(2) - logical, optional, intent(in) :: mask_variant, do_not_log - character(len=*), optional, intent(in) :: interp_method - integer, optional, intent(in) :: tile_count - character(len=*), optional, intent(in) :: cmor_field_name, cmor_long_name - character(len=*), optional, intent(in) :: cmor_units, cmor_standard_name + x_cell_method, y_cell_method, area_cell_method, conversion) + integer :: register_static_field !< An integer handle for a diagnostic array. + character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" + !! or "ice_shelf_model" + character(len=*), intent(in) :: field_name !< Name of the diagnostic field + type(axes_grp), target, intent(in) :: axes !< Container w/ up to 3 integer handles that + !! indicates axes for this field + character(len=*), optional, intent(in) :: long_name !< Long name of a field. + character(len=*), optional, intent(in) :: units !< Units of a field. + character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field + real, optional, intent(in) :: missing_value !< A value that indicates missing values. + real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) + logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided with + !! post_data calls (not used in MOM?) + logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?) + character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should not + !! be interpolated as a scalar + integer, optional, intent(in) :: tile_count !< no clue (not used in MOM?) + 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 integer, optional, intent(in) :: area !< fms_id for area_t character(len=*), optional, intent(in) :: x_cell_method !< Specifies the cell method for the x-direction. character(len=*), optional, intent(in) :: y_cell_method !< Specifies the cell method for the y-direction. character(len=*), optional, intent(in) :: area_cell_method !< Specifies the cell method for area + real, optional, intent(in) :: conversion !< A value to multiply data by before writing to file - ! Output: An integer handle for a diagnostic array. - ! Arguments: - ! (in) module_name - name of this module, usually "ocean_model" or "ice_shelf_model". - ! (in) field_name - name of the diagnostic field - ! (in) axes - container with up to 3 integer handles that indicates axes for this field - ! (in,opt) long_name - long name of a field - ! (in,opt) units - units of a field - ! (in,opt) missing_value - A value that indicates missing values. - ! (in,opt) standard_name - standardized name associated with a field - - ! Following params have yet to be used in MOM. - ! (in,opt) range - valid range of a variable - ! (in,opt) mask_variant - If true a logical mask must be provided with post_data calls - ! (in,opt) do_not_log - If true, do not log something - ! (in,opt) interp_method - If 'none' indicates the field should not be interpolated as a scalar - ! (in,opt) tile_count - no clue - + ! Local variables real :: MOM_missing_value - type(diag_ctrl), pointer :: diag_cs + type(diag_ctrl), pointer :: diag_cs => null() type(diag_type), pointer :: diag => null(), cmor_diag => null() integer :: dm_id, fms_id, cmor_id character(len=256) :: posted_cmor_units, posted_cmor_standard_name, posted_cmor_long_name character(len=9) :: axis_name MOM_missing_value = axes%diag_cs%missing_value - if(present(missing_value)) MOM_missing_value = missing_value + if (present(missing_value)) MOM_missing_value = missing_value diag_cs => axes%diag_cs dm_id = -1 @@ -1919,6 +2658,7 @@ function register_static_field(module_name, field_name, axes, & call assert(associated(diag), 'register_static_field: diag allocation failed') 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)) @@ -1961,6 +2701,7 @@ function register_static_field(module_name, field_name, axes, & call alloc_diag_with_id(dm_id, diag_cs, cmor_diag) cmor_diag%fms_diag_id = fms_id cmor_diag%debug_str = trim(module_name)//"-"//trim(cmor_field_name) + if (present(conversion)) cmor_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)) @@ -1990,9 +2731,11 @@ function register_static_field(module_name, field_name, axes, & end function register_static_field +!> Describe an option setting in the diagnostic files. subroutine describe_option(opt_name, value, diag_CS) - character(len=*), intent(in) :: opt_name, value - type(diag_ctrl), intent(in) :: diag_CS + character(len=*), intent(in) :: opt_name !< The name of the option + character(len=*), intent(in) :: value !< A character string with the setting of the option. + type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output character(len=240) :: mesg integer :: len_ind @@ -2017,7 +2760,7 @@ function ocean_register_diag(var_desc, G, diag_CS, day) 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 + type(axes_grp), pointer :: axes => NULL() call query_vardesc(var_desc, units=units, longname=longname, hor_grid=hor_grid, & z_grid=z_grid, caller="ocean_register_diag") @@ -2105,22 +2848,23 @@ function ocean_register_diag(var_desc, G, diag_CS, day) end select ocean_register_diag = register_diag_field("ocean_model", trim(var_name), & - axes, day, trim(longname), trim(units), missing_value = -1.0e+34) + axes, day, trim(longname), trim(units), missing_value=-1.0e+34) end function ocean_register_diag subroutine diag_mediator_infrastructure_init(err_msg) ! This subroutine initializes the FMS diag_manager. - character(len=*), optional, intent(out) :: err_msg + character(len=*), optional, intent(out) :: err_msg !< An error message call diag_manager_init(err_msg=err_msg) end subroutine diag_mediator_infrastructure_init !> diag_mediator_init initializes the MOM diag_mediator and opens the available !! diagnostics file, if appropriate. -subroutine diag_mediator_init(G, GV, nz, param_file, diag_cs, doc_file_dir) +subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) type(ocean_grid_type), target, intent(inout) :: G !< The ocean grid type. type(verticalGrid_type), target, intent(in) :: GV !< The ocean vertical grid structure + type(unit_scale_type), target, intent(in) :: US !< A dimensional unit scaling type integer, intent(in) :: nz !< The number of layers in the model's native grid. type(param_file_type), intent(in) :: param_file !< Parameter file structure type(diag_ctrl), intent(inout) :: diag_cs !< A pointer to a type with many variables @@ -2138,7 +2882,7 @@ subroutine diag_mediator_init(G, GV, nz, param_file, diag_cs, doc_file_dir) character(len=240), allocatable :: diag_coords(:) ! This include declares and sets the variable "version". #include "version_variable.h" - character(len=40) :: mod = "MOM_diag_mediator" ! This module's name. + character(len=40) :: mdl = "MOM_diag_mediator" ! This module's name. 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) @@ -2152,22 +2896,22 @@ subroutine diag_mediator_init(G, GV, nz, param_file, diag_cs, doc_file_dir) enddo ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mod, version, "") + call log_version(param_file, mdl, version, "") - call get_param(param_file, mod, 'NUM_DIAG_COORDS', diag_cs%num_diag_coords, & + call get_param(param_file, mdl, 'NUM_DIAG_COORDS', diag_cs%num_diag_coords, & 'The number of diagnostic vertical coordinates to use.\n'//& '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, mod, 'DIAG_COORDS', diag_coords, & + 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'//& '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, mod, 'DIAG_COORDS', diag_coords, & + 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'//& 'is of the form "MODULE_SUFFIX,PARAMETER_SUFFIX,COORDINATE_NAME".', & @@ -2181,10 +2925,10 @@ subroutine diag_mediator_init(G, GV, nz, param_file, diag_cs, doc_file_dir) deallocate(diag_coords) endif - call get_param(param_file, mod, 'DIAG_MISVAL', diag_cs%missing_value, & + call get_param(param_file, mdl, 'DIAG_MISVAL', diag_cs%missing_value, & 'Set the default missing value to use for diagnostics.', & default=1.e20) - call get_param(param_file, mod, 'DIAG_AS_CHKSUM', diag_cs%diag_as_chksum, & + 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.', & default=.false.) @@ -2192,6 +2936,7 @@ subroutine diag_mediator_init(G, GV, nz, param_file, diag_cs, doc_file_dir) ! Keep pointers grid, h, T, S needed diagnostic remapping diag_cs%G => G diag_cs%GV => GV + diag_cs%US => US diag_cs%h => null() diag_cs%T => null() diag_cs%S => null() @@ -2207,11 +2952,21 @@ subroutine diag_mediator_init(G, GV, nz, param_file, diag_cs, doc_file_dir) diag_cs%isd = G%isd ; diag_cs%ied = G%ied diag_cs%jsd = G%jsd ; diag_cs%jed = G%jed + !Downsample indices for dl=2 (should be generalized to arbitrary dl, perhaps via a G array) + diag_cs%dsamp(2)%isc = G%HId2%isc - (G%HId2%isd-1) ; diag_cs%dsamp(2)%iec = G%HId2%iec - (G%HId2%isd-1) + diag_cs%dsamp(2)%jsc = G%HId2%jsc - (G%HId2%jsd-1) ; diag_cs%dsamp(2)%jec = G%HId2%jec - (G%HId2%jsd-1) + diag_cs%dsamp(2)%isd = G%HId2%isd ; diag_cs%dsamp(2)%ied = G%HId2%ied + diag_cs%dsamp(2)%jsd = G%HId2%jsd ; diag_cs%dsamp(2)%jed = G%HId2%jed + diag_cs%dsamp(2)%isg = G%HId2%isg ; diag_cs%dsamp(2)%ieg = G%HId2%ieg + diag_cs%dsamp(2)%jsg = G%HId2%jsg ; diag_cs%dsamp(2)%jeg = G%HId2%jeg + diag_cs%dsamp(2)%isgB = G%HId2%isgB ; diag_cs%dsamp(2)%iegB = G%HId2%iegB + diag_cs%dsamp(2)%jsgB = G%HId2%jsgB ; diag_cs%dsamp(2)%jegB = G%HId2%jegB + ! Initialze available diagnostic log file if (is_root_pe() .and. (diag_CS%available_diag_doc_unit < 0)) then write(this_pe,'(i6.6)') PE_here() doc_file_dflt = "available_diags."//this_pe - call get_param(param_file, mod, "AVAILABLE_DIAGS_FILE", doc_file, & + call get_param(param_file, mdl, "AVAILABLE_DIAGS_FILE", doc_file, & "A file into which to write a list of all available \n"//& "ocean diagnostics that can be included in a diag_table.", & default=doc_file_dflt, do_not_log=(diag_CS%available_diag_doc_unit/=-1)) @@ -2249,7 +3004,7 @@ subroutine diag_mediator_init(G, GV, nz, param_file, diag_cs, doc_file_dir) 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 - call get_param(param_file, mod, "CHKSUM_DIAG_FILE", doc_file, & + call get_param(param_file, mdl, "CHKSUM_DIAG_FILE", doc_file, & "A file into which to write all checksums of the \n"//& "diagnostics listed in the diag_table.", & default=doc_file_dflt, do_not_log=(diag_CS%chksum_diag_doc_unit/=-1)) @@ -2315,7 +3070,8 @@ subroutine diag_update_remap_grids(diag_cs, alt_h, alt_T, alt_S) !! the current salinity ! Local variables integer :: i - real, dimension(:,:,:), pointer :: h_diag, T_diag, S_diag + real, dimension(:,:,:), pointer :: h_diag => NULL() + real, dimension(:,:,:), pointer :: T_diag => NULL(), S_diag => NULL() if (present(alt_h)) then h_diag => alt_h @@ -2344,7 +3100,7 @@ subroutine diag_update_remap_grids(diag_cs, alt_h, alt_T, alt_S) do i=1, diag_cs%num_diag_coords call diag_remap_update(diag_cs%diag_remap_cs(i), & - diag_cs%G, diag_cs%GV, h_diag, T_diag, S_diag, & + diag_cs%G, diag_cs%GV, diag_cs%US, h_diag, T_diag, S_diag, & diag_cs%eqn_of_state) enddo @@ -2396,10 +3152,13 @@ subroutine diag_masks_set(G, nz, diag_cs) diag_cs%mask3dCvi(:,:,k) = diag_cs%mask2dCv(:,:) enddo + !Allocate and initialize the downsampled masks + call downsample_diag_masks_set(G, nz, diag_cs) + end subroutine diag_masks_set subroutine diag_mediator_close_registration(diag_CS) - type(diag_ctrl), intent(inout) :: diag_CS + type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output integer :: i @@ -2414,8 +3173,8 @@ subroutine diag_mediator_close_registration(diag_CS) end subroutine diag_mediator_close_registration subroutine diag_mediator_end(time, diag_CS, end_diag_manager) - type(time_type), intent(in) :: time - type(diag_ctrl), intent(inout) :: diag_cs + type(time_type), intent(in) :: time !< The current model time + type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output logical, optional, intent(in) :: end_diag_manager !< If true, call diag_manager_end() ! Local variables @@ -2443,6 +3202,20 @@ subroutine diag_mediator_end(time, diag_CS, end_diag_manager) deallocate(diag_cs%mask3dBi) deallocate(diag_cs%mask3dCui) deallocate(diag_cs%mask3dCvi) + do i=2,MAX_DSAMP_LEV + deallocate(diag_cs%dsamp(i)%mask2dT) + deallocate(diag_cs%dsamp(i)%mask2dBu) + deallocate(diag_cs%dsamp(i)%mask2dCu) + deallocate(diag_cs%dsamp(i)%mask2dCv) + deallocate(diag_cs%dsamp(i)%mask3dTL) + deallocate(diag_cs%dsamp(i)%mask3dBL) + deallocate(diag_cs%dsamp(i)%mask3dCuL) + deallocate(diag_cs%dsamp(i)%mask3dCvL) + deallocate(diag_cs%dsamp(i)%mask3dTi) + deallocate(diag_cs%dsamp(i)%mask3dBi) + deallocate(diag_cs%dsamp(i)%mask3dCui) + deallocate(diag_cs%dsamp(i)%mask3dCvi) + enddo #if defined(DEBUG) || defined(__DO_SAFETY_CHECKS__) deallocate(diag_cs%h_old) @@ -2454,24 +3227,26 @@ subroutine diag_mediator_end(time, diag_CS, end_diag_manager) end subroutine diag_mediator_end +!> Convert the first n elements (up to 3) of an integer array to an underscore delimited string. function i2s(a,n_in) -! "Convert the first n elements of an integer array to a string." - integer, dimension(:), intent(in) :: a - integer, optional , intent(in) :: n_in - character(len=15) :: i2s - - character(len=15) :: i2s_temp - integer :: i,n - - n=size(a) - if(present(n_in)) n = n_in - - i2s = '' - do i=1,n - write (i2s_temp, '(I4.4)') a(i) - i2s = trim(i2s) //'_'// trim(i2s_temp) - enddo - i2s = adjustl(i2s) + ! "Convert the first n elements of an integer array to a string." + ! Perhaps this belongs elsewhere in the MOM6 code? + integer, dimension(:), intent(in) :: a !< The array of integers to translate + integer, optional , intent(in) :: n_in !< The number of elements to translate, by default all + character(len=15) :: i2s !< The returned string + + character(len=15) :: i2s_temp + integer :: i,n + + n=size(a) + if (present(n_in)) n = n_in + + i2s = '' + do i=1,min(n,3) + write (i2s_temp, '(I4.4)') a(i) + i2s = trim(i2s) //'_'// trim(i2s_temp) + enddo + i2s = adjustl(i2s) end function i2s !> Returns a new diagnostic id, it may be necessary to expand the diagnostics array. @@ -2524,7 +3299,7 @@ subroutine alloc_diag_with_id(diag_id, diag_cs, diag) type(diag_ctrl), target, intent(inout) :: diag_cs !< structure used to regulate diagnostic output type(diag_type), pointer :: diag !< structure representing a diagnostic (inout) - type(diag_type), pointer :: tmp + type(diag_type), pointer :: tmp => NULL() if (.not. diag_cs%diags(diag_id)%in_use) then diag => diag_cs%diags(diag_id) @@ -2697,4 +3472,587 @@ subroutine diag_grid_storage_end(grid_storage) deallocate(grid_storage%diag_grids) end subroutine diag_grid_storage_end +!< Allocate and initialize the masks for downsampled diagostics in diag_cs +!! The downsampled masks in the axes would later "point" to these. +subroutine downsample_diag_masks_set(G, nz, diag_cs) + type(ocean_grid_type), target, intent(in) :: G !< The ocean grid type. + integer, intent(in) :: nz !< The number of layers in the model's native grid. + type(diag_ctrl), pointer :: diag_cs !< A pointer to a type with many variables + !! used for diagnostics + ! Local variables + integer :: i,j,k,ii,jj,dl + +!print*,'original c extents ',G%isc,G%iec,G%jsc,G%jec +!print*,'original c extents ',G%iscb,G%iecb,G%jscb,G%jecb +!print*,'coarse c extents ',G%HId2%isc,G%HId2%iec,G%HId2%jsc,G%HId2%jec +!print*,'original d extents ',G%isd,G%ied,G%jsd,G%jed +!print*,'coarse d extents ',G%HId2%isd,G%HId2%ied,G%HId2%jsd,G%HId2%jed +! original c extents 5 52 5 52 +! original cB-nonsym extents 5 52 5 52 +! original cB-sym extents 4 52 4 52 +! coarse c extents 3 26 3 26 +! original d extents 1 56 1 56 +! original dB-nonsym extents 1 56 1 56 +! original dB-sym extents 0 56 0 56 +! coarse d extents 1 28 1 28 + + do dl=2,MAX_DSAMP_LEV + ! 2d mask + call downsample_mask(G%mask2dT, diag_cs%dsamp(dl)%mask2dT, dl,G%isc, G%jsc, & + G%HId2%isc, G%HId2%iec, G%HId2%jsc, G%HId2%jec, G%HId2%isd, G%HId2%ied, G%HId2%jsd, G%HId2%jed) + call downsample_mask(G%mask2dBu,diag_cs%dsamp(dl)%mask2dBu, dl,G%IscB,G%JscB, & + G%HId2%IscB,G%HId2%IecB,G%HId2%JscB,G%HId2%JecB,G%HId2%IsdB,G%HId2%IedB,G%HId2%JsdB,G%HId2%JedB) + call downsample_mask(G%mask2dCu,diag_cs%dsamp(dl)%mask2dCu, dl,G%IscB,G%JscB, & + G%HId2%IscB,G%HId2%IecB,G%HId2%jsc, G%HId2%jec,G%HId2%IsdB,G%HId2%IedB,G%HId2%jsd, G%HId2%jed) + call downsample_mask(G%mask2dCv,diag_cs%dsamp(dl)%mask2dCv, dl,G%isc ,G%JscB, & + G%HId2%isc ,G%HId2%iec, G%HId2%JscB,G%HId2%JecB,G%HId2%isd ,G%HId2%ied, G%HId2%JsdB,G%HId2%JedB) + ! 3d native masks are needed by diag_manager but the native variables + ! can only be masked 2d - for ocean points, all layers exists. + allocate(diag_cs%dsamp(dl)%mask3dTL(G%HId2%isd:G%HId2%ied,G%HId2%jsd:G%HId2%jed,1:nz)) + allocate(diag_cs%dsamp(dl)%mask3dBL(G%HId2%IsdB:G%HId2%IedB,G%HId2%JsdB:G%HId2%JedB,1:nz)) + allocate(diag_cs%dsamp(dl)%mask3dCuL(G%HId2%IsdB:G%HId2%IedB,G%HId2%jsd:G%HId2%jed,1:nz)) + allocate(diag_cs%dsamp(dl)%mask3dCvL(G%HId2%isd:G%HId2%ied,G%HId2%JsdB:G%HId2%JedB,1:nz)) + do k=1,nz + diag_cs%dsamp(dl)%mask3dTL(:,:,k) = diag_cs%dsamp(dl)%mask2dT(:,:) + diag_cs%dsamp(dl)%mask3dBL(:,:,k) = diag_cs%dsamp(dl)%mask2dBu(:,:) + diag_cs%dsamp(dl)%mask3dCuL(:,:,k) = diag_cs%dsamp(dl)%mask2dCu(:,:) + diag_cs%dsamp(dl)%mask3dCvL(:,:,k) = diag_cs%dsamp(dl)%mask2dCv(:,:) + enddo + allocate(diag_cs%dsamp(dl)%mask3dTi(G%HId2%isd:G%HId2%ied,G%HId2%jsd:G%HId2%jed,1:nz+1)) + allocate(diag_cs%dsamp(dl)%mask3dBi(G%HId2%IsdB:G%HId2%IedB,G%HId2%JsdB:G%HId2%JedB,1:nz+1)) + allocate(diag_cs%dsamp(dl)%mask3dCui(G%HId2%IsdB:G%HId2%IedB,G%HId2%jsd:G%HId2%jed,1:nz+1)) + allocate(diag_cs%dsamp(dl)%mask3dCvi(G%HId2%isd:G%HId2%ied,G%HId2%JsdB:G%HId2%JedB,1:nz+1)) + do k=1,nz+1 + diag_cs%dsamp(dl)%mask3dTi(:,:,k) = diag_cs%dsamp(dl)%mask2dT(:,:) + diag_cs%dsamp(dl)%mask3dBi(:,:,k) = diag_cs%dsamp(dl)%mask2dBu(:,:) + diag_cs%dsamp(dl)%mask3dCui(:,:,k) = diag_cs%dsamp(dl)%mask2dCu(:,:) + diag_cs%dsamp(dl)%mask3dCvi(:,:,k) = diag_cs%dsamp(dl)%mask2dCv(:,:) + enddo + enddo +end subroutine downsample_diag_masks_set + +!> Get the diagnostics-compute indices (to be passed to send_data) based on the shape of +!! the diag field (the same way they are deduced for non-downsampled fields) +subroutine downsample_diag_indices_get(fo1,fo2, dl, diag_cs,isv,iev,jsv,jev) + integer, intent(in) :: fo1,fo2 !< the sizes of the diag field in x and y + integer, intent(in) :: dl !< integer downsample level + type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output + integer, intent(out) ::isv,iev,jsv,jev !< diagnostics-compute indices (to be passed to send_data) + ! Local variables + integer :: dszi,cszi,dszj,cszj,f1,f2 + character(len=500) :: mesg + logical, save :: first_check = .true. + + !Check ONCE that the downsampled diag-compute domain is commensurate with the original + !non-downsampled diag-compute domain. + !This is a major limitation of the current implementation of the downsampled diagnostics. + !We assume that the compute domain can be subdivided to dl*dl cells, hence avoiding the need of halo updates. + !We want this check to error out only if there was a downsampled diagnostics requested and about to post that is + !why the check is here and not in the init routines. This check need to be done only once, hence the outer if. + if(first_check) then + if(mod(diag_cs%ie-diag_cs%is+1, dl) .ne. 0 .OR. mod(diag_cs%je-diag_cs%js+1, dl) .ne. 0) then + write (mesg,*) "Non-commensurate downsampled domain is not supported. "//& + "Please choose a layout such that NIGLOBAL/Layout_X and NJGLOBAL/Layout_Y are both divisible by dl=",dl,& + " Current domain extents: ", diag_cs%is,diag_cs%ie, diag_cs%js,diag_cs%je + call MOM_error(FATAL,"downsample_diag_indices_get: "//trim(mesg)) + endif + first_check = .false. + endif + + cszi = diag_cs%dsamp(dl)%iec-diag_cs%dsamp(dl)%isc +1 ; dszi = diag_cs%dsamp(dl)%ied-diag_cs%dsamp(dl)%isd +1 + cszj = diag_cs%dsamp(dl)%jec-diag_cs%dsamp(dl)%jsc +1 ; dszj = diag_cs%dsamp(dl)%jed-diag_cs%dsamp(dl)%jsd +1 + isv = diag_cs%dsamp(dl)%isc ; iev = diag_cs%dsamp(dl)%iec + jsv = diag_cs%dsamp(dl)%jsc ; jev = diag_cs%dsamp(dl)%jec + f1 = fo1/dl + f2 = fo2/dl + !Correction for the symmetric case + if (diag_cs%G%symmetric) then + f1 = f1 + mod(fo1,dl) + f2 = f2 + mod(fo2,dl) + endif + if ( f1 == dszi ) then + isv = diag_cs%dsamp(dl)%isc ; iev = diag_cs%dsamp(dl)%iec ! field on Data domain, take compute domain indcies + !The rest is not taken with the full MOM6 diag_table + elseif ( f1 == dszi + 1 ) then + isv = diag_cs%dsamp(dl)%isc ; iev = diag_cs%dsamp(dl)%iec+1 ! Symmetric data domain + elseif ( f1 == cszi) then + isv = 1 ; iev = (diag_cs%dsamp(dl)%iec-diag_cs%dsamp(dl)%isc) +1 ! Computational domain + elseif ( f1 == cszi + 1 ) then + isv = 1 ; iev = (diag_cs%dsamp(dl)%iec-diag_cs%dsamp(dl)%isc) +2 ! Symmetric computational domain + else + write (mesg,*) " peculiar size ",f1," in i-direction\n"//& + "does not match one of ", cszi, cszi+1, dszi, dszi+1 + call MOM_error(FATAL,"downsample_diag_indices_get: "//trim(mesg)) + endif + if ( f2 == dszj ) then + jsv = diag_cs%dsamp(dl)%jsc ; jev = diag_cs%dsamp(dl)%jec ! Data domain + elseif ( f2 == dszj + 1 ) then + jsv = diag_cs%dsamp(dl)%jsc ; jev = diag_cs%dsamp(dl)%jec+1 ! Symmetric data domain + elseif ( f2 == cszj) then + jsv = 1 ; jev = (diag_cs%dsamp(dl)%jec-diag_cs%dsamp(dl)%jsc) +1 ! Computational domain + elseif ( f2 == cszj + 1 ) then + jsv = 1 ; jev = (diag_cs%dsamp(dl)%jec-diag_cs%dsamp(dl)%jsc) +2 ! Symmetric computational domain + else + write (mesg,*) " peculiar size ",f2," in j-direction\n"//& + "does not match one of ", cszj, cszj+1, dszj, dszj+1 + call MOM_error(FATAL,"downsample_diag_indices_get: "//trim(mesg)) + endif +end subroutine downsample_diag_indices_get + +!> This subroutine allocates and computes a downsampled array from an input array +!! It also determines the diagnostics-compurte indices for the downsampled array +!! 3d interface +subroutine downsample_diag_field_3d(locfield, locfield_dsamp, dl, diag_cs, diag,isv,iev,jsv,jev, mask) + real, dimension(:,:,:), pointer :: locfield !< input array pointer + real, dimension(:,:,:), allocatable, intent(inout) :: locfield_dsamp !< output (downsampled) array + type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output + type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post + integer, intent(in) :: dl !< integer downsample level + integer, intent(inout):: isv,iev,jsv,jev !< diagnostics-compute indices (to be passed to send_data) + real, optional,target, intent(in) :: mask(:,:,:) !< If present, use this real array as the data mask. + !locals + real, dimension(:,:,:), pointer :: locmask + integer :: f1,f2,isv_o,jsv_o + + locmask => NULL() + !Get the correct indices corresponding to input field + !Shape of the input diag field + f1=size(locfield,1) + f2=size(locfield,2) + !Save the extents of the original (fine) domain + isv_o=isv;jsv_o=jsv + !Get the shape of the downsampled field and overwrite isv,iev,jsv,jev with them + call downsample_diag_indices_get(f1,f2, dl, diag_cs,isv,iev,jsv,jev) + !Set the non-downsampled mask, it must be associated and initialized + if (present(mask)) then + locmask => mask + elseif (associated(diag%axes%mask3d)) then + locmask => diag%axes%mask3d + else + call MOM_error(FATAL, "downsample_diag_field_3d: Cannot downsample without a mask!!! ") + endif + + call downsample_field(locfield, locfield_dsamp, dl, diag%xyz_method, locmask, diag_cs, diag, & + isv_o,jsv_o,isv,iev,jsv,jev) + +end subroutine downsample_diag_field_3d + +!> This subroutine allocates and computes a downsampled array from an input array +!! It also determines the diagnostics-compurte indices for the downsampled array +!! 2d interface +subroutine downsample_diag_field_2d(locfield, locfield_dsamp, dl, diag_cs, diag,isv,iev,jsv,jev, mask) + real, dimension(:,:), pointer :: locfield !< input array pointer + real, dimension(:,:), allocatable, intent(inout) :: locfield_dsamp !< output (downsampled) array + type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output + type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post + integer, intent(in) :: dl !< integer downsample level + integer, intent(out):: isv,iev,jsv,jev !< diagnostics-compute indices (to be passed to send_data) + real, optional,target, intent(in) :: mask(:,:) !< If present, use this real array as the data mask. + !locals + real, dimension(:,:), pointer :: locmask + integer :: f1,f2,isv_o,jsv_o + + locmask => NULL() + !Get the correct indices corresponding to input field + !Shape of the input diag field + f1=size(locfield,1) + f2=size(locfield,2) + !Save the extents of the original (fine) domain + isv_o=isv;jsv_o=jsv + !Get the shape of the downsampled field and overwrite isv,iev,jsv,jev with them + call downsample_diag_indices_get(f1,f2, dl, diag_cs,isv,iev,jsv,jev) + !Set the non-downsampled mask, it must be associated and initialized + if (present(mask)) then + locmask => mask + elseif (associated(diag%axes%mask2d)) then + locmask => diag%axes%mask2d + else + call MOM_error(FATAL, "downsample_diag_field_2d: Cannot downsample without a mask!!! ") + endif + + call downsample_field(locfield, locfield_dsamp, dl, diag%xyz_method, locmask, diag_cs,diag, & + isv_o,jsv_o,isv,iev,jsv,jev) + +end subroutine downsample_diag_field_2d + +!> The downsample algorithm +!! The downsample method could be deduced (before send_data call) +!! from the diag%x_cell_method, diag%y_cell_method and diag%v_cell_method +!! +!! This is the summary of the downsample algoritm for a diagnostic field f: +!! f(Id,Jd) = \sum_{i,j} f(Id+i,Jd+j) * weight(Id+i,Jd+j) / [ \sum_{i,j} weight(Id+i,Jd+j)] +!! i and j run from 0 to dl-1 (dl being the downsample level) +!! Id,Jd are the downsampled (coarse grid) indices run over the coarsened compute grid, +!! if and jf are the original (fine grid) indices +!! +!!example x_cell y_cell v_cell algorithm_id impemented weight(if,jf) +!!--------------------------------------------------------------------------------------- +!!theta mean mean mean MMM =222 G%areaT(if,jf)*h(if,jf) +!!u point mean mean PMM =022 dyCu(if,jf)*h(if,jf)*delta(if,Id) +!!v mean point mean MPM =202 dxCv(if,jf)*h(if,jf)*delta(jf,Jd) +!!? point sum mean PSM =012 h(if,jf)*delta(if,Id) +!!volcello sum sum sum SSS =111 1 +!!T_dfxy_co sum sum point SSP =110 1 +!!umo point sum sum PSS =011 1*delta(if,Id) +!!vmo sum point sum SPS =101 1*delta(jf,Jd) +!!umo_2d point sum point PSP =010 1*delta(if,Id) +!!vmo_2d sum point point SPP =100 1*delta(jf,Jd) +!!? point mean point PMP =020 dyCu(if,jf)*delta(if,Id) +!!? mean point point MPP =200 dxCv(if,jf)*delta(jf,Jd) +!!w mean mean point MMP =220 G%areaT(if,jf) +!!h*theta mean mean sum MMS =221 G%areaT(if,jf) +!! +!!delta is the Kroneker delta + +!> This subroutine allocates and computes a downsampled array given an input array +!! The downsample method is based on the "cell_methods" for the diagnostics as explained +!! in the above table +!! 3d interface +subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, diag,isv_o,jsv_o,isv_d,iev_d,jsv_d,jev_d) + real, dimension(:,:,:) , pointer :: field_in + real, dimension(:,:,:) , allocatable :: field_out + integer , intent(in) :: dl + integer, intent(in) :: method !< sampling method + real, dimension(:,:,:), pointer :: mask + type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output + type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post + integer , intent(in) :: isv_o,jsv_o !< original indices, In practice isv_o=jsv_o=1 + integer , intent(in) :: isv_d,iev_d,jsv_d,jev_d !< dsampaed indices + !locals + character(len=240) :: mesg + integer :: i,j,ii,jj,i0,j0,f1,f2,f_in1,f_in2 + integer :: k,ks,ke + real :: ave,total_weight,weight + real :: epsilon = 1.0e-20 + + ks=1 ; ke =size(field_in,3) + !Allocate the downsampled field on the downsampled data domain +! allocate(field_out(diag_cs%dsamp(dl)%isd:diag_cs%dsamp(dl)%ied,diag_cs%dsamp(dl)%jsd:diag_cs%dsamp(dl)%jed,ks:ke)) +! allocate(field_out(1:size(field_in,1)/dl,1:size(field_in,2)/dl,ks:ke)) + f_in1 = size(field_in,1) + f_in2 = size(field_in,2) + f1 = f_in1/dl + f2 = f_in2/dl + !Correction for the symmetric case + if (diag_cs%G%symmetric) then + f1 = f1 + mod(f_in1,dl) + f2 = f2 + mod(f_in2,dl) + endif + allocate(field_out(1:f1,1:f2,ks:ke)) + + !Fill the downsampled field on the downsampled diagnostics (almost always compuate) domain + if(method .eq. MMM) then + do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + total_weight = 0.0 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 +! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 !This seems to be faster!!!! + weight = mask(ii,jj,k)*diag_cs%G%areaT(ii,jj)*diag_cs%h(ii,jj,k) + total_weight = total_weight + weight + ave=ave+field_in(ii,jj,k)*weight + enddo; enddo + field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo; enddo; enddo + elseif(method .eq. SSS) then !e.g., volcello + do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + total_weight = 0.0 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 +! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 + weight = mask(ii,jj,k) + total_weight = total_weight + weight + ave=ave+field_in(ii,jj,k)*weight + enddo; enddo + field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo; enddo; enddo + elseif(method .eq. MMP .or. method .eq. MMS) then !e.g., T_advection_xy + do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + total_weight = 0.0 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 +! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 + weight = mask(ii,jj,k)*diag_cs%G%areaT(ii,jj) + total_weight = total_weight + weight + ave=ave+field_in(ii,jj,k)*weight + enddo; enddo + field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo; enddo; enddo + elseif(method .eq. PMM) then + do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + total_weight = 0.0 + ii=i0 + do jj=j0,j0+dl-1 + weight =mask(ii,jj,k)*diag_cs%G%dyCu(ii,jj)*diag_cs%h(ii,jj,k) + total_weight = total_weight +weight + ave=ave+field_in(ii,jj,k)*weight + enddo + field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo; enddo; enddo + elseif(method .eq. PSM) then + do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + total_weight = 0.0 + ii=i0 + do jj=j0,j0+dl-1 + weight =mask(ii,jj,k)*diag_cs%h(ii,jj,k) + total_weight = total_weight +weight + ave=ave+field_in(ii,jj,k)*weight + enddo + field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo; enddo; enddo + elseif(method .eq. PSS) then !e.g. umo + do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + total_weight = 0.0 + ii=i0 + do jj=j0,j0+dl-1 + weight =mask(ii,jj,k) + total_weight = total_weight +weight + ave=ave+field_in(ii,jj,k)*weight + enddo + field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo; enddo; enddo + elseif(method .eq. SPS) then !e.g. vmo + do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + total_weight = 0.0 + jj=j0 + do ii=i0,i0+dl-1 + weight =mask(ii,jj,k) + total_weight = total_weight +weight + ave=ave+field_in(ii,jj,k)*weight + enddo + field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo; enddo; enddo + elseif(method .eq. MPM) then + do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + total_weight = 0.0 + jj=j0 + do ii=i0,i0+dl-1 + weight = mask(ii,jj,k)*diag_cs%G%dxCv(ii,jj)*diag_cs%h(ii,jj,k) + total_weight = total_weight + weight + ave=ave+field_in(ii,jj,k)*weight + enddo + field_out(i,j,k) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo; enddo; enddo + elseif(method .eq. MSK) then !The input field is a mask, subsample + field_out(:,:,:) = 0.0 + do k= ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 + ave=ave+field_in(ii,jj,k) + enddo; enddo + if(ave > 0.0) field_out(i,j,k)=1.0 + enddo; enddo; enddo + else + write (mesg,*) " unknown sampling method: ",method + call MOM_error(FATAL, "downsample_field_3d: "//trim(mesg)//" "//trim(diag%debug_str)) + endif + +end subroutine downsample_field_3d + +subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs,diag,isv_o,jsv_o,isv_d,iev_d,jsv_d,jev_d) + real, dimension(:,:) , pointer :: field_in + real, dimension(:,:) , allocatable :: field_out + integer , intent(in) :: dl + integer, intent(in) :: method !< sampling method + real, dimension(:,:), pointer :: mask + type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output + type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post + integer , intent(in) :: isv_o,jsv_o !< original indices, In practice isv_o=jsv_o=1 + integer , intent(in) :: isv_d,iev_d,jsv_d,jev_d !< dsampaed indices + !locals + character(len=240) :: mesg + integer :: i,j,ii,jj,i0,j0,f1,f2,f_in1,f_in2 + real :: ave,total_weight,weight + real :: epsilon = 1.0e-20 + + !Allocate the downsampled field on the downsampled data domain +! allocate(field_out(diag_cs%dsamp(dl)%isd:diag_cs%dsamp(dl)%ied,diag_cs%dsamp(dl)%jsd:diag_cs%dsamp(dl)%jed)) +! allocate(field_out(1:size(field_in,1)/dl,1:size(field_in,2)/dl)) + !Fill the downsampled field on the downsampled diagnostics (almost always compuate) domain + f_in1 = size(field_in,1) + f_in2 = size(field_in,2) + f1 = f_in1/dl + f2 = f_in2/dl + !Correction for the symmetric case + if (diag_cs%G%symmetric) then + f1 = f1 + mod(f_in1,dl) + f2 = f2 + mod(f_in2,dl) + endif + allocate(field_out(1:f1,1:f2)) + + if(method .eq. MMP) then + do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + total_weight = 0.0 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 +! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 + weight = mask(ii,jj)*diag_cs%G%areaT(ii,jj) + total_weight = total_weight + weight + ave=ave+field_in(ii,jj)*weight + enddo; enddo + field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo; enddo + elseif(method .eq. SSP) then ! e.g., T_dfxy_cont_tendency_2d + do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + total_weight = 0.0 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 +! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 + weight = mask(ii,jj) + total_weight = total_weight + weight + ave=ave+field_in(ii,jj)*weight + enddo; enddo + field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo; enddo + elseif(method .eq. PSP) then ! e.g., umo_2d + do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + total_weight = 0.0 + ii=i0 + do jj=j0,j0+dl-1 + weight =mask(ii,jj) + total_weight = total_weight +weight + ave=ave+field_in(ii,jj)*weight + enddo + field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo; enddo + elseif(method .eq. SPP) then ! e.g., vmo_2d + do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + total_weight = 0.0 + jj=j0 + do ii=i0,i0+dl-1 + weight =mask(ii,jj) + total_weight = total_weight +weight + ave=ave+field_in(ii,jj)*weight + enddo + field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo; enddo + elseif(method .eq. PMP) then + do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + total_weight = 0.0 + ii=i0 + do jj=j0,j0+dl-1 + weight =mask(ii,jj)*diag_cs%G%dyCu(ii,jj)!*diag_cs%h(ii,jj,1) !Niki? + total_weight = total_weight +weight + ave=ave+field_in(ii,jj)*weight + enddo + field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo; enddo + elseif(method .eq. MPP) then + do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + total_weight = 0.0 + jj=j0 + do ii=i0,i0+dl-1 + weight =mask(ii,jj)*diag_cs%G%dxCv(ii,jj)!*diag_cs%h(ii,jj,1) !Niki? + total_weight = total_weight +weight + ave=ave+field_in(ii,jj)*weight + enddo + field_out(i,j) = ave/(total_weight+epsilon) !Avoid zero mask at all aggregating cells where ave=0.0 + enddo; enddo + elseif(method .eq. MSK) then !The input field is a mask, subsample + field_out(:,:) = 0.0 + do j=jsv_d,jev_d ; do i=isv_d,iev_d + i0 = isv_o+dl*(i-isv_d) + j0 = jsv_o+dl*(j-jsv_d) + ave = 0.0 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 + ave=ave+field_in(ii,jj) + enddo; enddo + if(ave > 0.0) field_out(i,j)=1.0 + enddo; enddo + else + write (mesg,*) " unknown sampling method: ",method + call MOM_error(FATAL, "downsample_field_2d: "//trim(mesg)//" "//trim(diag%debug_str)) + endif + +end subroutine downsample_field_2d + +!> Allocate and compute the downsampled masks +!! The masks are downsampled based on a minority rule, i.e., a coarse cell is open (1) +!! if at least one of the sub-cells are open, otherwise it's closed (0) +subroutine downsample_mask_2d(field_in, field_out, dl, isc_o,jsc_o, isc_d,iec_d,jsc_d,jec_d , isd_d,ied_d,jsd_d,jed_d) + real, dimension(:,:) , intent(in) :: field_in + real, dimension(:,:) , pointer :: field_out + integer , intent(in) :: dl + integer , intent(in) :: isc_o,jsc_o + integer , intent(in) :: isc_d,iec_d,jsc_d,jec_d !< downsampled mask compute indices + integer , intent(in) :: isd_d,ied_d,jsd_d,jed_d !< downsampled mask data indices + integer :: i,j,ii,jj,i0,j0 + real :: tot_non_zero + !downsampled mask = 0 unless the mask value of one of the downsampling cells is 1 + allocate(field_out(isd_d:ied_d,jsd_d:jed_d)) + field_out(:,:) = 0.0 + do j=jsc_d,jec_d ; do i=isc_d,iec_d + i0 = isc_o+dl*(i-isc_d) + j0 = jsc_o+dl*(j-jsc_d) + tot_non_zero = 0.0 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 + tot_non_zero = tot_non_zero + field_in(ii,jj) + enddo;enddo + if(tot_non_zero > 0.0) field_out(i,j)=1.0 + enddo; enddo +end subroutine downsample_mask_2d + +subroutine downsample_mask_3d(field_in, field_out, dl, isc_o,jsc_o, isc_d,iec_d,jsc_d,jec_d , isd_d,ied_d,jsd_d,jed_d) + real, dimension(:,:,:) , intent(in) :: field_in + real, dimension(:,:,:) , pointer :: field_out + integer , intent(in) :: dl + integer , intent(in) :: isc_o,jsc_o + integer , intent(in) :: isc_d,iec_d,jsc_d,jec_d !< downsampled mask compute indices + integer , intent(in) :: isd_d,ied_d,jsd_d,jed_d !< downsampled mask data indices + integer :: i,j,ii,jj,i0,j0,k,ks,ke + real :: tot_non_zero + !downsampled mask = 0 unless the mask value of one of the downsampling cells is 1 + ks = lbound(field_in,3) ; ke = ubound(field_in,3) + allocate(field_out(isd_d:ied_d,jsd_d:jed_d,ks:ke)) + field_out(:,:,:) = 0.0 + do k= ks,ke ; do j=jsc_d,jec_d ; do i=isc_d,iec_d + i0 = isc_o+dl*(i-isc_d) + j0 = jsc_o+dl*(j-jsc_d) + tot_non_zero = 0.0 + do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 + tot_non_zero = tot_non_zero + field_in(ii,jj,k) + enddo;enddo + if(tot_non_zero > 0.0) field_out(i,j,k)=1.0 + enddo; enddo; enddo +end subroutine downsample_mask_3d + end module MOM_diag_mediator + diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index 9ba8988d0f..632258d5d2 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -1,15 +1,17 @@ -!> This module is used for runtime remapping of diagnostics to z star, sigma and -!! rho vertical coordinates. It defines the diag_remap_ctrl type which -!! represents a remapping of diagnostics to a particular vertical coordinate. -!! The module is used by the diag mediator module in the following way: -!! 1) _init() is called to initialise a diag_remap_ctrl instance. -!! 2) _configure_axes() is called to read the configuration file and set up the +!> provides runtime remapping of diagnostics to z star, sigma and +!! rho vertical coordinates. +!! +!! The diag_remap_ctrl type represents a remapping of diagnostics to a particular +!! vertical coordinate. The module is used by the diag mediator module in the +!! following way: +!! 1. diag_remap_init() is called to initialize a diag_remap_ctrl instance. +!! 2. diag_remap_configure_axes() is called to read the configuration file and set up the !! vertical coordinate / axes definitions. -!! 3) _get_axes_info() returns information needed for the diag mediator to +!! 3. diag_remap_get_axes_info() returns information needed for the diag mediator to !! define new axes for the remapped diagnostics. -!! 4) _update() is called periodically (whenever h, T or S change) to either +!! 4. diag_remap_update() is called periodically (whenever h, T or S change) to either !! create or update the target remapping grids. -!! 5) _do_remap() is called from within a diag post() to do the remapping before +!! 5. diag_remap_do_remap() is called from within a diag post() to do the remapping before !! the diagnostic is written out. module MOM_diag_remap @@ -24,6 +26,7 @@ module MOM_diag_remap use MOM_io, only : file_exists, field_size use MOM_string_functions, only : lowercase, extractWord use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type use MOM_EOS, only : EOS_type use MOM_remapping, only : remapping_CS, initialize_remapping @@ -53,8 +56,8 @@ module MOM_diag_remap public vertically_interpolate_diag_field public horizontally_average_diag_field -!> This type represents remapping of diagnostics to a particular vertical -!! coordinate. +!> Represents remapping of diagnostics to a particular vertical coordinate. +!! !! There is one of these types for each vertical coordinate. The vertical axes !! of a diagnostic will reference an instance of this type indicating how (or !! if) the diagnostic should be vertically remapped when being posted. @@ -134,10 +137,11 @@ end subroutine diag_remap_set_active !> Configure the vertical axes for a diagnostic remapping control structure. !! Reads a configuration parameters to determine coordinate generation. -subroutine diag_remap_configure_axes(remap_cs, GV, param_file) +subroutine diag_remap_configure_axes(remap_cs, GV, US, param_file) type(diag_remap_ctrl), intent(inout) :: remap_cs !< Diag remap control structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(param_file_type), intent(in) :: param_file !< Parameter file structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Parameter file structure ! Local variables integer :: nzi(4), nzl(4), k character(len=200) :: inputdir, string, filename, int_varname, layer_varname @@ -150,7 +154,7 @@ subroutine diag_remap_configure_axes(remap_cs, GV, param_file) real, allocatable, dimension(:) :: interfaces, layers - call initialize_regridding(remap_cs%regrid_cs, GV, GV%max_depth, param_file, mod, & + call initialize_regridding(remap_cs%regrid_cs, GV, US, GV%max_depth, param_file, mod, & trim(remap_cs%vertical_coord_name), "DIAG_COORD", trim(remap_cs%diag_coord_name)) call set_regrid_params(remap_cs%regrid_cs, min_thickness=0., integrate_downward_for_e=.false.) @@ -209,7 +213,7 @@ end subroutine diag_remap_get_axes_info !! Configuration is complete when diag_remap_configure_axes() has been !! successfully called. function diag_remap_axes_configured(remap_cs) - type(diag_remap_ctrl), intent(in) :: remap_cs + type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coordinate control structure logical :: diag_remap_axes_configured diag_remap_axes_configured = remap_cs%configured @@ -221,11 +225,14 @@ function diag_remap_axes_configured(remap_cs) !! height or layer thicknesses changes. In the case of density-based !! coordinates then technically we should also regenerate the !! target grid whenever T/S change. -subroutine diag_remap_update(remap_cs, G, GV, h, T, S, eqn_of_state) +subroutine diag_remap_update(remap_cs, G, GV, US, h, T, S, eqn_of_state) type(diag_remap_ctrl), intent(inout) :: remap_cs !< Diagnostic coordinate control structure type(ocean_grid_type), pointer :: G !< The ocean's grid type type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - real, dimension(:, :, :), intent(in) :: h, T, S !< New thickness, T and S + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(:, :, :), intent(in) :: h !< New thickness + real, dimension(:, :, :), intent(in) :: T !< New T + real, dimension(:, :, :), intent(in) :: S !< New S type(EOS_type), pointer :: eqn_of_state !< A pointer to the equation of state ! Local variables @@ -265,22 +272,22 @@ subroutine diag_remap_update(remap_cs, G, GV, h, T, S, eqn_of_state) if (remap_cs%vertical_coord == coordinateMode('ZSTAR')) then call build_zstar_column(get_zlike_CS(remap_cs%regrid_cs), & - G%bathyT(i,j)*GV%m_to_H, sum(h(i,j,:)), & - zInterfaces, zScale=GV%m_to_H) + GV%Z_to_H*G%bathyT(i,j), sum(h(i,j,:)), & + zInterfaces, zScale=GV%Z_to_H) elseif (remap_cs%vertical_coord == coordinateMode('SIGMA')) then call build_sigma_column(get_sigma_CS(remap_cs%regrid_cs), & - GV%m_to_H*G%bathyT(i,j), sum(h(i,j,:)), zInterfaces) + GV%Z_to_H*G%bathyT(i,j), sum(h(i,j,:)), zInterfaces) elseif (remap_cs%vertical_coord == coordinateMode('RHO')) then call build_rho_column(get_rho_CS(remap_cs%regrid_cs), G%ke, & - G%bathyT(i,j), h(i,j,:), T(i, j, :), S(i, j, :), & + US%Z_to_m*G%bathyT(i,j), h(i,j,:), T(i,j,:), S(i,j,:), & eqn_of_state, zInterfaces, h_neglect, h_neglect_edge) elseif (remap_cs%vertical_coord == coordinateMode('SLIGHT')) then ! call build_slight_column(remap_cs%regrid_cs,remap_cs%remap_cs, nz, & -! G%bathyT(i,j), sum(h(i,j,:)), zInterfaces) +! US%Z_to_m*G%bathyT(i,j), sum(h(i,j,:)), zInterfaces) call MOM_error(FATAL,"diag_remap_update: SLIGHT coordinate not coded for diagnostics yet!") elseif (remap_cs%vertical_coord == coordinateMode('HYCOM1')) then ! call build_hycom1_column(remap_cs%regrid_cs, nz, & -! G%bathyT(i,j), sum(h(i,j,:)), zInterfaces) +! US%Z_to_m*G%bathyT(i,j), sum(h(i,j,:)), zInterfaces) call MOM_error(FATAL,"diag_remap_update: HYCOM1 coordinate not coded for diagnostics yet!") endif remap_cs%h(i,j,:) = zInterfaces(1:nz) - zInterfaces(2:nz+1) diff --git a/src/framework/MOM_document.F90 b/src/framework/MOM_document.F90 index a61c20cf5a..36f43528be 100644 --- a/src/framework/MOM_document.F90 +++ b/src/framework/MOM_document.F90 @@ -1,14 +1,9 @@ +!> The subroutines here provide hooks for document generation functions at +!! various levels of granularity. module MOM_document ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* The subroutines here provide hooks for document generation * -!* functions at various levels of granularity. * -!* * -!********+*********+*********+*********+*********+*********+*********+** - use MOM_time_manager, only : time_type use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe @@ -17,6 +12,7 @@ module MOM_document public doc_param, doc_subroutine, doc_function, doc_module, doc_init, doc_end public doc_openBlock, doc_closeBlock +!> Document parameter values interface doc_param module procedure doc_param_none, & doc_param_logical, doc_param_logical_array, & @@ -26,43 +22,49 @@ module MOM_document doc_param_time end interface -integer, parameter :: mLen = 1240 ! Length of interface/message strings +integer, parameter :: mLen = 1240 !< Length of interface/message strings +!> A structure that controls where the documentation occurs, its veborsity and formatting. type, public :: doc_type ; private - integer :: unitAll = -1 ! The open unit number for docFileBase + .all. - integer :: unitShort = -1 ! The open unit number for docFileBase + .short. - integer :: unitLayout = -1 ! The open unit number for docFileBase + .layout. - integer :: unitDebugging = -1 ! The open unit number for docFileBase + .debugging. - logical :: filesAreOpen = .false. ! True if any files were successfully opened. - character(len=mLen) :: docFileBase = '' ! The basename of the files where run-time - ! parameters, settings and defaults are documented. - logical :: complete = .true. ! If true, document all parameters. - logical :: minimal = .true. ! If true, document non-default parameters. - logical :: layout = .true. ! If true, document layout parameters. - logical :: debugging = .true. ! If true, document debugging parameters. - 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. - type(link_msg), pointer :: chain_msg => NULL() ! Db of messages - character(len=240) :: blockPrefix = '' ! The full name of the current block. + integer :: unitAll = -1 !< The open unit number for docFileBase + .all. + integer :: unitShort = -1 !< The open unit number for docFileBase + .short. + integer :: unitLayout = -1 !< The open unit number for docFileBase + .layout. + integer :: unitDebugging = -1 !< The open unit number for docFileBase + .debugging. + logical :: filesAreOpen = .false. !< True if any files were successfully opened. + character(len=mLen) :: docFileBase = '' !< The basename of the files where run-time + !! parameters, settings and defaults are documented. + logical :: complete = .true. !< If true, document all parameters. + logical :: minimal = .true. !< If true, document non-default parameters. + logical :: layout = .true. !< If true, document layout parameters. + logical :: debugging = .true. !< If true, document debugging parameters. + 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. + 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 +!> A linked list of the parameter documentation messages that have been issued so far. type :: link_msg ; private - type(link_msg), pointer :: next => NULL() ! Facilitates linked list - character(len=80) :: name ! Parameter name - character(len=620) :: msg ! Parameter value and default + type(link_msg), pointer :: next => NULL() !< Facilitates linked list + character(len=80) :: name !< Parameter name + character(len=620) :: msg !< Parameter value and default end type link_msg -character(len=4), parameter :: STRING_TRUE = 'True' -character(len=5), parameter :: STRING_FALSE = 'False' +character(len=4), parameter :: STRING_TRUE = 'True' !< A string for true logicals +character(len=5), parameter :: STRING_FALSE = 'False' !< A string for false logicals contains ! ---------------------------------------------------------------------- +!> This subroutine handles parameter documentation with no value. subroutine doc_param_none(doc, varname, desc, units) - type(doc_type), pointer :: doc - character(len=*), intent(in) :: varname, desc, units + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: varname !< The name of the parameter being documented + character(len=*), intent(in) :: desc !< A description of the parameter being documented + character(len=*), intent(in) :: units !< The units of the parameter being documented ! This subroutine handles parameter documentation with no value. integer :: numspc character(len=mLen) :: mesg @@ -80,14 +82,18 @@ subroutine doc_param_none(doc, varname, desc, units) endif end subroutine doc_param_none +!> This subroutine handles parameter documentation for logicals. subroutine doc_param_logical(doc, varname, desc, units, val, default, & layoutParam, debuggingParam) - type(doc_type), pointer :: doc - character(len=*), intent(in) :: varname, desc, units - logical, intent(in) :: val - logical, optional, intent(in) :: default - logical, optional, intent(in) :: layoutParam - logical, optional, intent(in) :: debuggingParam + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: varname !< The name of the parameter being documented + character(len=*), intent(in) :: desc !< A description of the parameter being documented + character(len=*), intent(in) :: units !< The units of the parameter being documented + logical, intent(in) :: val !< The value of this parameter + logical, optional, intent(in) :: default !< The default value of this parameter + 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. ! This subroutine handles parameter documentation for logicals. character(len=mLen) :: mesg logical :: equalsDefault @@ -118,14 +124,18 @@ subroutine doc_param_logical(doc, varname, desc, units, val, default, & endif end subroutine doc_param_logical +!> This subroutine handles parameter documentation for arrays of logicals. subroutine doc_param_logical_array(doc, varname, desc, units, vals, default, & layoutParam, debuggingParam) - type(doc_type), pointer :: doc - character(len=*), intent(in) :: varname, desc, units - logical, intent(in) :: vals(:) - logical, optional, intent(in) :: default - logical, optional, intent(in) :: layoutParam - logical, optional, intent(in) :: debuggingParam + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: varname !< The name of the parameter being documented + character(len=*), intent(in) :: desc !< A description of the parameter being documented + character(len=*), intent(in) :: units !< The units of the parameter being documented + logical, intent(in) :: vals(:) !< The array of values to record + logical, optional, intent(in) :: default !< The default value of this parameter + 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. ! This subroutine handles parameter documentation for arrays of logicals. integer :: i character(len=mLen) :: mesg @@ -164,14 +174,18 @@ subroutine doc_param_logical_array(doc, varname, desc, units, vals, default, & endif end subroutine doc_param_logical_array +!> This subroutine handles parameter documentation for integers. subroutine doc_param_int(doc, varname, desc, units, val, default, & layoutParam, debuggingParam) - type(doc_type), pointer :: doc - character(len=*), intent(in) :: varname, desc, units - integer, intent(in) :: val - integer, optional, intent(in) :: default - logical, optional, intent(in) :: layoutParam - logical, optional, intent(in) :: debuggingParam + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: varname !< The name of the parameter being documented + character(len=*), intent(in) :: desc !< A description of the parameter being documented + character(len=*), intent(in) :: units !< The units of the parameter being documented + integer, intent(in) :: val !< The value of this parameter + integer, optional, intent(in) :: default !< The default value of this parameter + 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. ! This subroutine handles parameter documentation for integers. character(len=mLen) :: mesg character(len=doc%commentColumn) :: valstring @@ -196,14 +210,18 @@ subroutine doc_param_int(doc, varname, desc, units, val, default, & endif end subroutine doc_param_int +!> This subroutine handles parameter documentation for arrays of integers. subroutine doc_param_int_array(doc, varname, desc, units, vals, default, & layoutParam, debuggingParam) - type(doc_type), pointer :: doc - character(len=*), intent(in) :: varname, desc, units - integer, intent(in) :: vals(:) - integer, optional, intent(in) :: default - logical, optional, intent(in) :: layoutParam - logical, optional, intent(in) :: debuggingParam + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: varname !< The name of the parameter being documented + character(len=*), intent(in) :: desc !< A description of the parameter being documented + character(len=*), intent(in) :: units !< The units of the parameter being documented + integer, intent(in) :: vals(:) !< The array of values to record + integer, optional, intent(in) :: default !< The default value of this parameter + 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. ! This subroutine handles parameter documentation for arrays of integers. integer :: i character(len=mLen) :: mesg @@ -235,12 +253,16 @@ subroutine doc_param_int_array(doc, varname, desc, units, vals, default, & end subroutine doc_param_int_array +!> This subroutine handles parameter documentation for reals. subroutine doc_param_real(doc, varname, desc, units, val, default, debuggingParam) - type(doc_type), pointer :: doc - character(len=*), intent(in) :: varname, desc, units - real, intent(in) :: val - real, optional, intent(in) :: default - logical, optional, intent(in) :: debuggingParam + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: varname !< The name of the parameter being documented + character(len=*), intent(in) :: desc !< A description of the parameter being documented + character(len=*), intent(in) :: units !< The units of the parameter being documented + real, intent(in) :: val !< The value of this parameter + real, optional, intent(in) :: default !< The default value of this parameter + logical, optional, intent(in) :: debuggingParam !< If present and true, this is a debugging parameter. ! This subroutine handles parameter documentation for reals. character(len=mLen) :: mesg character(len=doc%commentColumn) :: valstring @@ -265,12 +287,16 @@ subroutine doc_param_real(doc, varname, desc, units, val, default, debuggingPara endif end subroutine doc_param_real +!> This subroutine handles parameter documentation for arrays of reals. subroutine doc_param_real_array(doc, varname, desc, units, vals, default, debuggingParam) - type(doc_type), pointer :: doc - character(len=*), intent(in) :: varname, desc, units - real, intent(in) :: vals(:) - real, optional, intent(in) :: default - logical, optional, intent(in) :: debuggingParam + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: varname !< The name of the parameter being documented + character(len=*), intent(in) :: desc !< A description of the parameter being documented + character(len=*), intent(in) :: units !< The units of the parameter being documented + real, intent(in) :: vals(:) !< The array of values to record + real, optional, intent(in) :: default !< The default value of this parameter + logical, optional, intent(in) :: debuggingParam !< If present and true, this is a debugging parameter. ! This subroutine handles parameter documentation for arrays of reals. integer :: i character(len=mLen) :: mesg @@ -299,14 +325,19 @@ subroutine doc_param_real_array(doc, varname, desc, units, vals, default, debugg end subroutine doc_param_real_array +!> This subroutine handles parameter documentation for character strings. subroutine doc_param_char(doc, varname, desc, units, val, default, & layoutParam, debuggingParam) - type(doc_type), pointer :: doc - character(len=*), intent(in) :: varname, desc, units - character(len=*), intent(in) :: val - character(len=*), optional, intent(in) :: default - logical, optional, intent(in) :: layoutParam - logical, optional, intent(in) :: debuggingParam + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: varname !< The name of the parameter being documented + character(len=*), intent(in) :: desc !< A description of the parameter being documented + character(len=*), intent(in) :: units !< The units of the parameter being documented + character(len=*), intent(in) :: val !< The value of the parameter + character(len=*), & + optional, intent(in) :: default !< The default value of this parameter + 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. ! This subroutine handles parameter documentation for character strings. character(len=mLen) :: mesg logical :: equalsDefault @@ -330,10 +361,12 @@ subroutine doc_param_char(doc, varname, desc, units, val, default, & end subroutine doc_param_char +!> This subroutine handles documentation for opening a parameter block. subroutine doc_openBlock(doc, blockName, desc) - type(doc_type), pointer :: doc - character(len=*), intent(in) :: blockName - character(len=*), optional, intent(in) :: desc + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: blockName !< The name of the parameter block being opened + character(len=*), optional, intent(in) :: desc !< A description of the parameter block being opened ! This subroutine handles documentation for opening a parameter block. character(len=mLen) :: mesg character(len=doc%commentColumn) :: valstring @@ -353,9 +386,11 @@ subroutine doc_openBlock(doc, blockName, desc) doc%blockPrefix = trim(doc%blockPrefix)//trim(blockName)//'%' end subroutine doc_openBlock +!> This subroutine handles documentation for closing a parameter block. subroutine doc_closeBlock(doc, blockName) - type(doc_type), pointer :: doc - character(len=*), intent(in) :: blockName + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: blockName !< The name of the parameter block being closed ! This subroutine handles documentation for closing a parameter block. character(len=mLen) :: mesg character(len=doc%commentColumn) :: valstring @@ -377,14 +412,18 @@ subroutine doc_closeBlock(doc, blockName) endif end subroutine doc_closeBlock +!> This subroutine handles parameter documentation for time-type variables. subroutine doc_param_time(doc, varname, desc, units, val, default, & layoutParam, debuggingParam) - type(doc_type), pointer :: doc - character(len=*), intent(in) :: varname, desc, units - type(time_type), intent(in) :: val - type(time_type), optional, intent(in) :: default - logical, optional, intent(in) :: layoutParam - logical, optional, intent(in) :: debuggingParam + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: varname !< The name of the parameter being documented + character(len=*), intent(in) :: desc !< A description of the parameter being documented + character(len=*), intent(in) :: units !< The units of the parameter being documented + type(time_type), intent(in) :: val !< The value of the parameter + type(time_type), optional, intent(in) :: default !< The default value of this parameter + 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. ! This subroutine handles parameter documentation for time-type variables. ! ### This needs to be written properly! integer :: numspc @@ -407,14 +446,17 @@ subroutine doc_param_time(doc, varname, desc, units, val, default, & end subroutine doc_param_time +!> This subroutine writes out the message and description to the documetation files. subroutine writeMessageAndDesc(doc, vmesg, desc, valueWasDefault, indent, & layoutParam, debuggingParam) - type(doc_type), intent(in) :: doc - character(len=*), intent(in) :: vmesg, desc - logical, optional, intent(in) :: valueWasDefault - integer, optional, intent(in) :: indent - logical, optional, intent(in) :: layoutParam - logical, optional, intent(in) :: debuggingParam + type(doc_type), intent(in) :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: vmesg !< A message with the parameter name, units, and default value. + character(len=*), intent(in) :: desc !< A description of the parameter being documented + logical, optional, intent(in) :: valueWasDefault !< If true, this parameter has its default value + 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 @@ -472,8 +514,9 @@ end subroutine writeMessageAndDesc ! ---------------------------------------------------------------------- +!> This function returns a string with a real formatted like '(G)' function real_string(val) - real, intent(in) :: val + real, intent(in) :: val !< The value being written into a string character(len=32) :: real_string ! This function returns a string with a real formatted like '(G)' integer :: len, ind @@ -523,10 +566,14 @@ function real_string(val) real_string = adjustl(real_string) end function real_string -function real_array_string(vals,sep) - character(len=1320) :: real_array_string - real, intent(in) :: vals(:) - character(len=*), optional :: sep +!> Returns a character string of a comma-separated, compact formatted, reals +!> e.g. "1., 2., 5*3., 5.E2", that give the list of values. +function real_array_string(vals, sep) + character(len=1320) :: real_array_string !< The output string listing vals + real, intent(in) :: vals(:) !< The array of values to record + character(len=*), & + optional, intent(in) :: sep !< The separator between successive values, + !! by default it is ', '. ! Returns a character string of a comma-separated, compact formatted, reals ! e.g. "1., 2., 5*3., 5.E2" ! Local variables @@ -562,9 +609,10 @@ function real_array_string(vals,sep) enddo end function real_array_string +!> This function tests whether a real value is encoded in a string. function testFormattedFloatIsReal(str, val) - character(len=*), intent(in) :: str - real, intent(in) :: val + character(len=*), intent(in) :: str !< The string that match val + real, intent(in) :: val !< The value being tested logical :: testFormattedFloatIsReal ! Local variables real :: scannedVal @@ -577,25 +625,31 @@ function testFormattedFloatIsReal(str, val) endif end function testFormattedFloatIsReal +!> This function returns a string with an integer formatted like '(I)' function int_string(val) - integer, intent(in) :: val + integer, intent(in) :: val !< The value being written into a string character(len=24) :: int_string ! This function returns a string with an integer formatted like '(I)' write(int_string, '(i24)') val int_string = adjustl(int_string) end function int_string +!> This function returns a string with an logical formatted like '(L)' function logical_string(val) - logical, intent(in) :: val + logical, intent(in) :: val !< The value being written into a string character(len=24) :: logical_string ! This function returns a string with an logical formatted like '(L)' write(logical_string, '(l24)') val logical_string = adjustl(logical_string) end function logical_string +!> This function returns a string for formatted parameter assignment function define_string(doc,varName,valString,units) - type(doc_type), pointer :: doc - character(len=*), intent(in) :: varName, valString, units + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: varName !< The name of the parameter being documented + character(len=*), intent(in) :: valString !< A string containing the value of the parameter + character(len=*), intent(in) :: units !< The units of the parameter being documented character(len=mLen) :: define_string ! This function returns a string for formatted parameter assignment integer :: numSpaces @@ -610,9 +664,12 @@ function define_string(doc,varName,valString,units) if (len_trim(units) > 0) define_string = trim(define_string)//" ["//trim(units)//"]" end function define_string +!> This function returns a string for formatted false logicals function undef_string(doc,varName,units) - type(doc_type), pointer :: doc - character(len=*), intent(in) :: varName, units + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: varName !< The name of the parameter being documented + character(len=*), intent(in) :: units !< The units of the parameter being documented character(len=mLen) :: undef_string ! This function returns a string for formatted false logicals integer :: numSpaces @@ -630,9 +687,12 @@ end function undef_string ! ---------------------------------------------------------------------- +!> This subroutine handles the module documentation subroutine doc_module(doc, modname, desc) - type(doc_type), pointer :: doc - character(len=*), intent(in) :: modname, desc + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: modname !< The name of the module being documented + character(len=*), intent(in) :: desc !< A description of the module being documented ! This subroutine handles the module documentation character(len=mLen) :: mesg @@ -646,18 +706,26 @@ subroutine doc_module(doc, modname, desc) endif end subroutine doc_module +!> This subroutine handles the subroutine documentation subroutine doc_subroutine(doc, modname, subname, desc) - type(doc_type), pointer :: doc - character(len=*), intent(in) :: modname, subname, desc + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: modname !< The name of the module being documented + character(len=*), intent(in) :: subname !< The name of the subroutine being documented + character(len=*), intent(in) :: desc !< A description of the subroutine being documented ! This subroutine handles the subroutine documentation if (.not. (is_root_pe() .and. associated(doc))) return call open_doc_file(doc) end subroutine doc_subroutine +!> This subroutine handles the function documentation subroutine doc_function(doc, modname, fnname, desc) - type(doc_type), pointer :: doc - character(len=*), intent(in) :: modname, fnname, desc + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: modname !< The name of the module being documented + character(len=*), intent(in) :: fnname !< The name of the function being documented + character(len=*), intent(in) :: desc !< A description of the function being documented ! This subroutine handles the function documentation if (.not. (is_root_pe() .and. associated(doc))) return call open_doc_file(doc) @@ -666,12 +734,20 @@ end subroutine doc_function ! ---------------------------------------------------------------------- +!> Initialize the parameter documentation subroutine doc_init(docFileBase, doc, minimal, complete, layout, debugging) - character(len=*), intent(in) :: docFileBase - type(doc_type), pointer :: doc - logical, optional, intent(in) :: minimal, complete, layout, debugging -! Arguments: docFileBase - The name of the doc file. -! (inout) doc - The doc_type to populate. + character(len=*), intent(in) :: docFileBase !< The base file name for this set of parameters, + !! for example MOM_parameter_doc + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + logical, optional, intent(in) :: minimal !< If present and true, write out the files (.short) documenting + !! those parameters that do not take on their default values. + logical, optional, intent(in) :: complete !< If present and true, write out the (.all) files documenting all + !! parameters + logical, optional, intent(in) :: layout !< If present and true, write out the (.layout) files documenting + !! the layout parameters + logical, optional, intent(in) :: debugging !< If present and true, write out the (.debugging) files documenting + !! the debugging parameters if (.not. associated(doc)) then allocate(doc) @@ -685,8 +761,12 @@ subroutine doc_init(docFileBase, doc, minimal, complete, layout, debugging) end subroutine doc_init +!> This subroutine allocates and populates a structure that controls where the +!! documentation occurs and its formatting, and opens up the files controlled +!! by this structure subroutine open_doc_file(doc) - type(doc_type), pointer :: doc + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting logical :: opened, new_file integer :: ios @@ -781,6 +861,7 @@ subroutine open_doc_file(doc) end subroutine open_doc_file +!> Find an unused unit number, returning >0 if found, and triggering a FATAL error if not. function find_unused_unit_number() ! Find an unused unit number. ! Returns >0 if found. FATAL if not. @@ -794,9 +875,12 @@ function find_unused_unit_number() "doc_init failed to find an unused unit number.") end function find_unused_unit_number +!> This subroutine closes the the files controlled by doc, and sets flags in +!! doc to indicate that parameterization is no longer permitted. subroutine doc_end(doc) - type(doc_type), pointer :: doc - type(link_msg), pointer :: this, next + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + type(link_msg), pointer :: this => NULL(), next => NULL() if (.not.associated(doc)) return @@ -832,12 +916,16 @@ end subroutine doc_end ! ----------------------------------------------------------------------------- +!> Returns true if documentation has already been written function mesgHasBeenDocumented(doc,varName,mesg) - type(doc_type), pointer :: doc - character(len=*), intent(in) :: varName, mesg + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: varName !< The name of the parameter being documented + character(len=*), intent(in) :: mesg !< A message with parameter values, defaults, and descriptions + !! to compare with the message that was written previously logical :: mesgHasBeenDocumented ! Returns true if documentation has already been written - type(link_msg), pointer :: newLink, this, last + type(link_msg), pointer :: newLink => NULL(), this => NULL(), last => NULL() mesgHasBeenDocumented = .false. diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index 10346f2542..55e6e47b63 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -1,3 +1,4 @@ +!> Describes the decomposed MOM domain and has routines for communications across PEs module MOM_domains ! This file is part of MOM6. See LICENSE.md for the license. @@ -26,49 +27,55 @@ module MOM_domains use mpp_domains_mod, only : compute_block_extent => mpp_compute_block_extent use mpp_parameter_mod, only : AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR, BITWISE_EXACT_SUM, CORNER use mpp_parameter_mod, only : To_East => WUPDATE, To_West => EUPDATE, Omit_Corners => EDGEUPDATE -use mpp_parameter_mod, only : To_North => SUPDATE, To_South => NUPDATE +use mpp_parameter_mod, only : To_North => SUPDATE, To_South => NUPDATE, CENTER use fms_io_mod, only : file_exist, parse_mask_table implicit none ; private -! #include - -public :: MOM_domains_init, MOM_infra_init, MOM_infra_end, get_domain_extent +public :: MOM_domains_init, MOM_infra_init, MOM_infra_end, get_domain_extent, get_domain_extent_dsamp2 public :: MOM_define_domain, MOM_define_io_domain, clone_MOM_domain -public :: pass_var, pass_vector, broadcast, PE_here, root_PE, num_PEs -public :: pass_var_start, pass_var_complete, fill_symmetric_edges +public :: pass_var, pass_vector, PE_here, root_PE, num_PEs +public :: pass_var_start, pass_var_complete, fill_symmetric_edges, broadcast public :: pass_vector_start, pass_vector_complete public :: global_field_sum, sum_across_PEs, min_across_PEs, max_across_PEs -public :: AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR, BITWISE_EXACT_SUM, CORNER +public :: AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR, BITWISE_EXACT_SUM, CORNER, CENTER public :: To_East, To_West, To_North, To_South, To_All, Omit_Corners public :: create_group_pass, do_group_pass, group_pass_type public :: start_group_pass, complete_group_pass public :: compute_block_extent, get_global_shape +public :: get_simple_array_i_ind, get_simple_array_j_ind +!> Do a halo update on an array interface pass_var module procedure pass_var_3d, pass_var_2d end interface pass_var +!> Do a halo update on a pair of arrays representing the two components of a vector interface pass_vector module procedure pass_vector_3d, pass_vector_2d end interface pass_vector +!> Initiate a non-blocking halo update on an array interface pass_var_start module procedure pass_var_start_3d, pass_var_start_2d end interface pass_var_start +!> Complete a non-blocking halo update on an array interface pass_var_complete module procedure pass_var_complete_3d, pass_var_complete_2d end interface pass_var_complete +!> Initiate a halo update on a pair of arrays representing the two components of a vector interface pass_vector_start module procedure pass_vector_start_3d, pass_vector_start_2d end interface pass_vector_start +!> Complete a halo update on a pair of arrays representing the two components of a vector interface pass_vector_complete module procedure pass_vector_complete_3d, pass_vector_complete_2d end interface pass_vector_complete +!> Set up a group of halo updates interface create_group_pass module procedure create_var_group_pass_2d module procedure create_var_group_pass_3d @@ -76,11 +83,14 @@ module MOM_domains module procedure create_vector_group_pass_3d end interface create_group_pass +!> Do a set of halo updates that fill in the values at the duplicated edges +!! of a staggered symmetric memory domain interface fill_symmetric_edges module procedure fill_vector_symmetric_edges_2d !, fill_vector_symmetric_edges_3d ! module procedure fill_scalar_symmetric_edges_2d, fill_scalar_symmetric_edges_3d end interface fill_symmetric_edges +!> Copy one MOM_domain_type into another interface clone_MOM_domain module procedure clone_MD_to_MD, clone_MD_to_d2D end interface clone_MOM_domain @@ -89,6 +99,8 @@ module MOM_domains type, public :: MOM_domain_type type(domain2D), pointer :: mpp_domain => NULL() !< The FMS domain with halos !! on this processor, centered at h points. + type(domain2D), pointer :: mpp_domain_d2 => NULL() !< A coarse FMS domain with halos + !! on this processor, centered at h points. integer :: niglobal !< The total horizontal i-domain size. integer :: njglobal !< The total horizontal j-domain size. integer :: nihalo !< The i-halo size in memory. @@ -109,7 +121,6 @@ module MOM_domains !! domain in the i-direction in a define_domain call. integer :: Y_FLAGS !< Flag that specifies the properties of the !! domain in the j-direction in a define_domain call. - logical :: use_io_layout !< True if an I/O layout is available. logical, pointer :: maskmap(:,:) => NULL() !< A pointer to an array indicating !! which logical processors are actually used for !! the ocean code. The other logical processors @@ -118,7 +129,7 @@ module MOM_domains !! assigned if all logical processors are used. end type MOM_domain_type -integer, parameter :: To_All = To_East + To_West + To_North + To_South +integer, parameter :: To_All = To_East + To_West + To_North + To_South !< A flag for passing in all directions contains @@ -145,21 +156,7 @@ subroutine pass_var_3d(array, MOM_dom, sideflag, complete, position, halo, & !! halo by default. integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be !! started then stopped to time this routine. -! Arguments: array - The array which is having its halos points exchanged. -! (in) MOM_dom - The MOM_domain_type containing the mpp_domain needed to -! determine where data should be sent. -! (in) sideflag - An optional integer indicating which directions the -! data should be sent. It is TO_ALL or the sum of any of -! TO_EAST, TO_WEST, TO_NORTH, and TO_SOUTH. For example, -! TO_EAST sends the data to the processor to the east, so -! the halos on the western side are filled. TO_ALL is -! the default if sideflag is omitted. -! (in,opt) complete - An optional argument indicating whether the halo updates -! should be completed before progress resumes. Omitting -! complete is the same as setting complete to .true. -! (in,opt) position - An optional argument indicating the position. This is -! usally CORNER, but is CENTER by default. -! (in,opt) halo - The size of the halo to update - the full halo by default. + integer :: dirflag logical :: block_til_complete @@ -184,8 +181,7 @@ subroutine pass_var_3d(array, MOM_dom, sideflag, complete, position, halo, & end subroutine pass_var_3d !> pass_var_2d does a halo update for a two-dimensional array. -subroutine pass_var_2d(array, MOM_dom, sideflag, complete, position, halo, & - clock) +subroutine pass_var_2d(array, MOM_dom, sideflag, complete, position, halo, inner_halo, clock) real, dimension(:,:), intent(inout) :: array !< The array which is having its halos points !! exchanged. type(MOM_domain_type), intent(inout) :: MOM_dom !< The MOM_domain_type containing the mpp_domain @@ -203,24 +199,18 @@ subroutine pass_var_2d(array, MOM_dom, sideflag, complete, position, halo, & !! by default. integer, optional, intent(in) :: halo !< The size of the halo to update - the full halo !! by default. - integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be + integer, optional, intent(in) :: inner_halo !< The size of an inner halo to avoid updating, + !! or 0 to avoid updating symmetric memory + !! computational domain points. Setting this >=0 + !! also enforces that complete=.true. + integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be !! started then stopped to time this routine. -! Arguments: array - The array which is having its halos points exchanged. -! (in) MOM_dom - The MOM_domain_type containing the mpp_domain needed to -! determine where data should be sent. -! (in) sideflag - An optional integer indicating which directions the -! data should be sent. It is TO_ALL or the sum of any of -! TO_EAST, TO_WEST, TO_NORTH, and TO_SOUTH. For example, -! TO_EAST sends the data to the processor to the east, so -! the halos on the western side are filled. TO_ALL is -! the default if sideflag is omitted. -! (in,opt) complete - An optional argument indicating whether the halo updates -! should be completed before progress resumes. Omitting -! complete is the same as setting complete to .true. -! (in,opt) position - An optional argument indicating the position. This is -! usally CORNER, but is CENTER by default. -! (in,opt) halo - The size of the halo to update - the full halo by default. + ! Local variables + real, allocatable, dimension(:,:) :: tmp + integer :: pos, i_halo, j_halo + integer :: isc, iec, jsc, jec, isd, ied, jsd, jed, IscB, IecB, JscB, JecB + integer :: inner, i, j, isfw, iefw, isfe, iefe, jsfs, jefs, jsfn, jefn integer :: dirflag logical :: block_til_complete @@ -228,8 +218,15 @@ subroutine pass_var_2d(array, MOM_dom, sideflag, complete, position, halo, & dirflag = To_All ! 60 if (present(sideflag)) then ; if (sideflag > 0) dirflag = sideflag ; endif - block_til_complete = .true. - if (present(complete)) block_til_complete = complete + block_til_complete = .true. ; if (present(complete)) block_til_complete = complete + pos = CENTER ; if (present(position)) pos = position + + if (present(inner_halo)) then ; if (inner_halo >= 0) then + ! Store the original values. + allocate(tmp(size(array,1), size(array,2))) + tmp(:,:) = array(:,:) + block_til_complete = .true. + endif ; endif if (present(halo) .and. MOM_dom%thin_halo_updates) then call mpp_update_domains(array, MOM_dom%mpp_domain, flags=dirflag, & @@ -240,6 +237,46 @@ subroutine pass_var_2d(array, MOM_dom, sideflag, complete, position, halo, & complete=block_til_complete, position=position) endif + if (present(inner_halo)) then ; if (inner_halo >= 0) then + call mpp_get_compute_domain(MOM_dom%mpp_domain, isc, iec, jsc, jec) + call mpp_get_data_domain(MOM_dom%mpp_domain, isd, ied, jsd, jed) + ! Convert to local indices for arrays starting at 1. + isc = isc - (isd-1) ; iec = iec - (isd-1) ; ied = ied - (isd-1) ; isd = 1 + jsc = jsc - (jsd-1) ; jec = jec - (jsd-1) ; jed = jed - (jsd-1) ; jsd = 1 + i_halo = min(inner_halo, isc-1) ; j_halo = min(inner_halo, jsc-1) + + ! Figure out the array index extents of the eastern, western, northern and southern regions to copy. + if (pos == CENTER) then + if (size(array,1) == ied) then + isfw = isc - i_halo ; iefw = isc ; isfe = iec ; iefe = iec + i_halo + else ; call MOM_error(FATAL, "pass_var_2d: wrong i-size for CENTER array.") ; endif + if (size(array,2) == jed) then + isfw = isc - i_halo ; iefw = isc ; isfe = iec ; iefe = iec + i_halo + else ; call MOM_error(FATAL, "pass_var_2d: wrong j-size for CENTER array.") ; endif + elseif (pos == CORNER) then + if (size(array,1) == ied) then + isfw = max(isc - (i_halo+1), 1) ; iefw = isc ; isfe = iec ; iefe = iec + i_halo + elseif (size(array,1) == ied+1) then + isfw = isc - i_halo ; iefw = isc+1 ; isfe = iec+1 ; iefe = min(iec + 1 + i_halo, ied+1) + else ; call MOM_error(FATAL, "pass_var_2d: wrong i-size for CORNER array.") ; endif + if (size(array,2) == jed) then + jsfs = max(jsc - (j_halo+1), 1) ; jefs = jsc ; jsfn = jec ; jefn = jec + j_halo + elseif (size(array,2) == jed+1) then + jsfs = jsc - j_halo ; jefs = jsc+1 ; jsfn = jec+1 ; jefn = min(jec + 1 + j_halo, jed+1) + else ; call MOM_error(FATAL, "pass_var_2d: wrong j-size for CORNER array.") ; endif + else + call MOM_error(FATAL, "pass_var_2d: Unrecognized position") + endif + + ! Copy back the stored inner halo points + do j=jsfs,jefn ; do i=isfw,iefw ; array(i,j) = tmp(i,j) ; enddo ; enddo + do j=jsfs,jefn ; do i=isfe,iefe ; array(i,j) = tmp(i,j) ; enddo ; enddo + do j=jsfs,jefs ; do i=isfw,iefe ; array(i,j) = tmp(i,j) ; enddo ; enddo + do j=jsfn,jefn ; do i=isfw,iefe ; array(i,j) = tmp(i,j) ; enddo ; enddo + + deallocate(tmp) + endif ; endif + if (present(clock)) then ; if (clock>0) call cpu_clock_end(clock) ; endif end subroutine pass_var_2d @@ -268,23 +305,7 @@ function pass_var_start_2d(array, MOM_dom, sideflag, position, complete, halo, & integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be !! started then stopped to time this routine. integer :: pass_var_start_2d !0) call cpu_clock_begin(clock) ; endif @@ -329,23 +350,7 @@ function pass_var_start_3d(array, MOM_dom, sideflag, position, complete, halo, & integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be !! started then stopped to time this routine. integer :: pass_var_start_3d !< The integer index for this update. -! Arguments: array - The array which is having its halos points exchanged. -! (in) MOM_dom - The MOM_domain_type containing the mpp_domain needed to -! determine where data should be sent. -! (in) sideflag - An optional integer indicating which directions the -! data should be sent. It is TO_ALL or the sum of any of -! TO_EAST, TO_WEST, TO_NORTH, and TO_SOUTH. For example, -! TO_EAST sends the data to the processor to the east, so -! the halos on the western side are filled. TO_ALL is -! the default if sideflag is omitted. -! (in) position - An optional argument indicating the position. This is -! may be CORNER, but is CENTER by default. -! (in) complete - An optional argument indicating whether the halo updates -! should be initiated immediately or wait for second -! pass_..._start call. Omitting complete is the same as -! setting complete to .true. -! (in,opt) halo - The size of the halo to update - the full halo by default. -! (return value) - The integer index for this update. + integer :: dirflag if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif @@ -388,20 +393,7 @@ subroutine pass_var_complete_2d(id_update, array, MOM_dom, sideflag, position, h !! halo by default. integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be !! started then stopped to time this routine. -! Arguments: id_update - The integer id of this update which has been returned -! from a previous call to pass_var_start. -! (inout) array - The array which is having its halos points exchanged. -! (in) MOM_dom - The MOM_domain_type containing the mpp_domain needed to -! determine where data should be sent. -! (in) sideflag - An optional integer indicating which directions the -! data should be sent. It is TO_ALL or the sum of any of -! TO_EAST, TO_WEST, TO_NORTH, and TO_SOUTH. For example, -! TO_EAST sends the data to the processor to the east, so -! the halos on the western side are filled. TO_ALL is -! the default if sideflag is omitted. -! (in) position - An optional argument indicating the position. This is -! may be CORNER, but is CENTER by default. -! (in,opt) halo - The size of the halo to update - the full halo by default. + integer :: dirflag if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif @@ -444,20 +436,7 @@ subroutine pass_var_complete_3d(id_update, array, MOM_dom, sideflag, position, h !! halo by default. integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be !! started then stopped to time this routine. -! Arguments: id_update - The integer id of this update which has been returned -! from a previous call to pass_var_start. -! (inout) array - The array which is having its halos points exchanged. -! (in) MOM_dom - The MOM_domain_type containing the mpp_domain needed to -! determine where data should be sent. -! (in) sideflag - An optional integer indicating which directions the -! data should be sent. It is TO_ALL or the sum of any of -! TO_EAST, TO_WEST, TO_NORTH, and TO_SOUTH. For example, -! TO_EAST sends the data to the processor to the east, so -! the halos on the western side are filled. TO_ALL is -! the default if sideflag is omitted. -! (in) position - An optional argument indicating the position. This is -! may be CORNER, but is CENTER by default. -! (in,opt) halo - The size of the halo to update - the full halo by default. + integer :: dirflag if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif @@ -507,29 +486,8 @@ subroutine pass_vector_2d(u_cmpt, v_cmpt, MOM_dom, direction, stagger, complete, !! halo by default. integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be !! started then stopped to time this routine. -! Arguments: u_cmpt - The nominal zonal (u) component of the vector pair which -! is having its halos points exchanged. -! (inout) v_cmpt - The nominal meridional (v) component of the vector pair -! which is having its halos points exchanged. -! (in) MOM_dom - The MOM_domain_type containing the mpp_domain needed to -! determine where data should be sent. -! (in) direction - An optional integer indicating which directions the -! data should be sent. It is TO_ALL or the sum of any of -! TO_EAST, TO_WEST, TO_NORTH, and TO_SOUTH, possibly -! plus SCALAR_PAIR if these are paired non-directional -! scalars discretized at the typical vector component -! locations. For example, TO_EAST sends the data to the -! processor to the east, so the halos on the western -! side are filled. TO_ALL is the default if omitted. -! (in) stagger - An optional flag, which may be one of A_GRID, BGRID_NE, -! or CGRID_NE, indicating where the two components of the -! vector are discretized. Omitting stagger is the same as -! setting it to CGRID_NE. -! (in) complete - An optional argument indicating whether the halo updates -! should be completed before progress resumes. Omitting -! complete is the same as setting complete to .true. -! (in,opt) halo - The size of the halo to update - the full halo by default. + ! Local variables integer :: stagger_local integer :: dirflag logical :: block_til_complete @@ -579,18 +537,8 @@ subroutine fill_vector_symmetric_edges_2d(u_cmpt, v_cmpt, MOM_dom, stagger, scal logical, optional, intent(in) :: scalar !< An optional argument indicating whether. integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be !! started then stopped to time this routine. -! Arguments: u_cmpt - The nominal zonal (u) component of the vector pair which -! is having its halos points exchanged. -! (inout) v_cmpt - The nominal meridional (v) component of the vector pair -! which is having its halos points exchanged. -! (in) MOM_dom - The MOM_domain_type containing the mpp_domain needed to -! determine where data should be sent. -! (in) stagger - An optional flag, which may be one of A_GRID, BGRID_NE, -! or CGRID_NE, indicating where the two components of the -! vector are discretized. Omitting stagger is the same as -! setting it to CGRID_NE. -! (in) scalar - An optional argument indicating whether + ! Local variables integer :: stagger_local integer :: dirflag integer :: i, j, isc, iec, jsc, jec, isd, ied, jsd, jed, IscB, IecB, JscB, JecB @@ -684,29 +632,8 @@ subroutine pass_vector_3d(u_cmpt, v_cmpt, MOM_dom, direction, stagger, complete, !! halo by default. integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be !! started then stopped to time this routine. -! Arguments: u_cmpt - The nominal zonal (u) component of the vector pair which -! is having its halos points exchanged. -! (inout) v_cmpt - The nominal meridional (v) component of the vector pair -! which is having its halos points exchanged. -! (in) MOM_dom - The MOM_domain_type containing the mpp_domain needed to -! determine where data should be sent. -! (in) direction - An optional integer indicating which directions the -! data should be sent. It is TO_ALL or the sum of any of -! TO_EAST, TO_WEST, TO_NORTH, and TO_SOUTH, possibly -! plus SCALAR_PAIR if these are paired non-directional -! scalars discretized at the typical vector component -! locations. For example, TO_EAST sends the data to the -! processor to the east, so the halos on the western -! side are filled. TO_ALL is the default if omitted. -! (in) stagger - An optional flag, which may be one of A_GRID, BGRID_NE, -! or CGRID_NE, indicating where the two components of the -! vector are discretized. Omitting stagger is the same as -! setting it to CGRID_NE. -! (in) complete - An optional argument indicating whether the halo updates -! should be completed before progress resumes. Omitting -! complete is the same as setting complete to .true. -! (in,opt) halo - The size of the halo to update - the full halo by default. + ! Local variables integer :: stagger_local integer :: dirflag logical :: block_til_complete @@ -765,30 +692,8 @@ function pass_vector_start_2d(u_cmpt, v_cmpt, MOM_dom, direction, stagger, compl !! started then stopped to time this routine. integer :: pass_vector_start_2d !< The integer index for this !! update. -! Arguments: u_cmpt - The nominal zonal (u) component of the vector pair which -! is having its halos points exchanged. -! (inout) v_cmpt - The nominal meridional (v) component of the vector pair -! which is having its halos points exchanged. -! (in) MOM_dom - The MOM_domain_type containing the mpp_domain needed to -! determine where data should be sent. -! (in) direction - An optional integer indicating which directions the -! data should be sent. It is TO_ALL or the sum of any of -! TO_EAST, TO_WEST, TO_NORTH, and TO_SOUTH, possibly -! plus SCALAR_PAIR if these are paired non-directional -! scalars discretized at the typical vector component -! locations. For example, TO_EAST sends the data to the -! processor to the east, so the halos on the western -! side are filled. TO_ALL is the default if omitted. -! (in) stagger - An optional flag, which may be one of A_GRID, BGRID_NE, -! or CGRID_NE, indicating where the two components of the -! vector are discretized. Omitting stagger is the same as -! setting it to CGRID_NE. -! (in) complete - An optional argument indicating whether the halo updates -! should be initiated immediately or wait for second -! pass_..._start call. Omitting complete is the same as -! setting complete to .true. -! (in,opt) halo - The size of the halo to update - the full halo by default. -! (return value) - The integer index for this update. + + ! Local variables integer :: stagger_local integer :: dirflag @@ -844,30 +749,7 @@ function pass_vector_start_3d(u_cmpt, v_cmpt, MOM_dom, direction, stagger, compl !! started then stopped to time this routine. integer :: pass_vector_start_3d !< The integer index for this !! update. -! Arguments: u_cmpt - The nominal zonal (u) component of the vector pair which -! is having its halos points exchanged. -! (inout) v_cmpt - The nominal meridional (v) component of the vector pair -! which is having its halos points exchanged. -! (in) MOM_dom - The MOM_domain_type containing the mpp_domain needed to -! determine where data should be sent. -! (in) direction - An optional integer indicating which directions the -! data should be sent. It is TO_ALL or the sum of any of -! TO_EAST, TO_WEST, TO_NORTH, and TO_SOUTH, possibly -! plus SCALAR_PAIR if these are paired non-directional -! scalars discretized at the typical vector component -! locations. For example, TO_EAST sends the data to the -! processor to the east, so the halos on the western -! side are filled. TO_ALL is the default if omitted. -! (in) stagger - An optional flag, which may be one of A_GRID, BGRID_NE, -! or CGRID_NE, indicating where the two components of the -! vector are discretized. Omitting stagger is the same as -! setting it to CGRID_NE. -! (in) complete - An optional argument indicating whether the halo updates -! should be initiated immediately or wait for second -! pass_..._start call. Omitting complete is the same as -! setting complete to .true. -! (in,opt) halo - The size of the halo to update - the full halo by default. -! (return value) - The integer index for this update. + ! Local variables integer :: stagger_local integer :: dirflag @@ -921,28 +803,7 @@ subroutine pass_vector_complete_2d(id_update, u_cmpt, v_cmpt, MOM_dom, direction !! halo by default. integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be !! started then stopped to time this routine. -! Arguments: id_update - The integer id of this update which has been returned -! from a previous call to pass_var_start. -! (inout) u_cmpt - The nominal zonal (u) component of the vector pair which -! is having its halos points exchanged. -! (inout) v_cmpt - The nominal meridional (v) component of the vector pair -! which is having its halos points exchanged. -! (in) MOM_dom - The MOM_domain_type containing the mpp_domain needed to -! determine where data should be sent. -! (in) direction - An optional integer indicating which directions the -! data should be sent. It is TO_ALL or the sum of any of -! TO_EAST, TO_WEST, TO_NORTH, and TO_SOUTH, possibly -! plus SCALAR_PAIR if these are paired non-directional -! scalars discretized at the typical vector component -! locations. For example, TO_EAST sends the data to the -! processor to the east, so the halos on the western -! side are filled. TO_ALL is the default if omitted. -! (in) stagger - An optional flag, which may be one of A_GRID, BGRID_NE, -! or CGRID_NE, indicating where the two components of the -! vector are discretized. Omitting stagger is the same as -! setting it to CGRID_NE. -! (in,opt) halo - The size of the halo to update - the full halo by default. -! (return value) - The integer index for this update. + ! Local variables integer :: stagger_local integer :: dirflag @@ -996,28 +857,7 @@ subroutine pass_vector_complete_3d(id_update, u_cmpt, v_cmpt, MOM_dom, direction !! halo by default. integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be !! started then stopped to time this routine. -! Arguments: id_update - The integer id of this update which has been returned -! from a previous call to pass_var_start. -! (inout) u_cmpt - The nominal zonal (u) component of the vector pair which -! is having its halos points exchanged. -! (inout) v_cmpt - The nominal meridional (v) component of the vector pair -! which is having its halos points exchanged. -! (in) MOM_dom - The MOM_domain_type containing the mpp_domain needed to -! determine where data should be sent. -! (in) direction - An optional integer indicating which directions the -! data should be sent. It is TO_ALL or the sum of any of -! TO_EAST, TO_WEST, TO_NORTH, and TO_SOUTH, possibly -! plus SCALAR_PAIR if these are paired non-directional -! scalars discretized at the typical vector component -! locations. For example, TO_EAST sends the data to the -! processor to the east, so the halos on the western -! side are filled. TO_ALL is the default if omitted. -! (in) stagger - An optional flag, which may be one of A_GRID, BGRID_NE, -! or CGRID_NE, indicating where the two components of the -! vector are discretized. Omitting stagger is the same as -! setting it to CGRID_NE. -! (in,opt) halo - The size of the halo to update - the full halo by default. -! (return value) - The integer index for this update. + ! Local variables integer :: stagger_local integer :: dirflag @@ -1064,21 +904,7 @@ subroutine create_var_group_pass_2d(group, array, MOM_dom, sideflag, position, & !! halo by default. integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be !! started then stopped to time this routine. -! Arguments: -! (inout) group - The data type that store information for group update. -! This data will be used in do_group_pass. -! (inout) array - The array which is having its halos points exchanged. -! (in) MOM_dom - The MOM_domain_type containing the mpp_domain needed to -! determine where data should be sent. -! (in,opt) sideflag - An optional integer indicating which directions the -! data should be sent. It is TO_ALL or the sum of any of -! TO_EAST, TO_WEST, TO_NORTH, and TO_SOUTH. For example, -! TO_EAST sends the data to the processor to the east, so -! the halos on the western side are filled. TO_ALL is -! the default if sideflag is omitted. -! (in,opt) position - An optional argument indicating the position. This is -! may be CORNER, but is CENTER by default. -! (in,opt) halo - The size of the halo to update - the full halo by default. + ! Local variables integer :: dirflag if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif @@ -1123,21 +949,7 @@ subroutine create_var_group_pass_3d(group, array, MOM_dom, sideflag, position, h !! halo by default. integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be !! started then stopped to time this routine. -! Arguments: -! (inout) group - The data type that store information for group update. -! This data will be used in do_group_pass. -! (inout) array - The array which is having its halos points exchanged. -! (in) MOM_dom - The MOM_domain_type containing the mpp_domain needed to -! determine where data should be sent. -! (in,opt) sideflag - An optional integer indicating which directions the -! data should be sent. It is TO_ALL or the sum of any of -! TO_EAST, TO_WEST, TO_NORTH, and TO_SOUTH. For example, -! TO_EAST sends the data to the processor to the east, so -! the halos on the western side are filled. TO_ALL is -! the default if sideflag is omitted. -! (in,opt) position - An optional argument indicating the position. This is -! may be CORNER, but is CENTER by default. -! (in,opt) halo - The size of the halo to update - the full halo by default. + ! Local variables integer :: dirflag if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif @@ -1189,28 +1001,7 @@ subroutine create_vector_group_pass_2d(group, u_cmpt, v_cmpt, MOM_dom, direction !! halo by default. integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be !! started then stopped to time this routine. -! Arguments: -! (inout) group - The data type that store information for group update. -! This data will be used in do_group_pass. -! (inout) u_cmpt - The nominal zonal (u) component of the vector pair which -! is having its halos points exchanged. -! (inout) v_cmpt - The nominal meridional (v) component of the vector pair -! which is having its halos points exchanged. -! (in) MOM_dom - The MOM_domain_type containing the mpp_domain needed to -! determine where data should be sent. -! (in) direction - An optional integer indicating which directions the -! data should be sent. It is TO_ALL or the sum of any of -! TO_EAST, TO_WEST, TO_NORTH, and TO_SOUTH, possibly -! plus SCALAR_PAIR if these are paired non-directional -! scalars discretized at the typical vector component -! locations. For example, TO_EAST sends the data to the -! processor to the east, so the halos on the western -! side are filled. TO_ALL is the default if omitted. -! (in) stagger - An optional flag, which may be one of A_GRID, BGRID_NE, -! or CGRID_NE, indicating where the two components of the -! vector are discretized. Omitting stagger is the same as -! setting it to CGRID_NE. -! (in,opt) halo - The size of the halo to update - the full halo by default. + ! Local variables integer :: stagger_local integer :: dirflag @@ -1267,29 +1058,7 @@ subroutine create_vector_group_pass_3d(group, u_cmpt, v_cmpt, MOM_dom, direction integer, optional, intent(in) :: clock !< The handle for a cpu time clock that should be !! started then stopped to time this routine. -! Arguments: -! (inout) group - The data type that store information for group update. -! This data will be used in do_group_pass. -! (inout) u_cmpt - The nominal zonal (u) component of the vector pair which -! is having its halos points exchanged. -! (inout) v_cmpt - The nominal meridional (v) component of the vector pair -! which is having its halos points exchanged. -! (in) MOM_dom - The MOM_domain_type containing the mpp_domain needed to -! determine where data should be sent. -! (in) direction - An optional integer indicating which directions the -! data should be sent. It is TO_ALL or the sum of any of -! TO_EAST, TO_WEST, TO_NORTH, and TO_SOUTH, possibly -! plus SCALAR_PAIR if these are paired non-directional -! scalars discretized at the typical vector component -! locations. For example, TO_EAST sends the data to the -! processor to the east, so the halos on the western -! side are filled. TO_ALL is the default if omitted. -! (in) stagger - An optional flag, which may be one of A_GRID, BGRID_NE, -! or CGRID_NE, indicating where the two components of the -! vector are discretized. Omitting stagger is the same as -! setting it to CGRID_NE. -! (in,opt) halo - The size of the halo to update - the full halo by default. - + ! Local variables integer :: stagger_local integer :: dirflag @@ -1328,11 +1097,6 @@ subroutine do_group_pass(group, MOM_dom, clock) !! started then stopped to time this routine. real :: d_type -! Arguments: -! (inout) group - The data type that store information for group update. -! (in) MOM_dom - The MOM_domain_type containing the mpp_domain needed to -! determine where data should be sent. - if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif call mpp_do_group_update(group, MOM_dom%mpp_domain, d_type) @@ -1354,11 +1118,6 @@ subroutine start_group_pass(group, MOM_dom, clock) real :: d_type -! Arguments: -! (inout) group - The data type that store information for group update. -! (in) MOM_dom - The MOM_domain_type containing the mpp_domain needed to -! determine where data should be sent. - if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif call mpp_start_group_update(group, MOM_dom%mpp_domain, d_type) @@ -1379,11 +1138,6 @@ subroutine complete_group_pass(group, MOM_dom, clock) !! started then stopped to time this routine. real :: d_type -! Arguments: -! (inout) group - The data type that store information for group update. -! (in) MOM_dom - The MOM_domain_type containing the mpp_domain needed to -! determine where data should be sent. - if (present(clock)) then ; if (clock>0) call cpu_clock_begin(clock) ; endif call mpp_complete_group_update(group, MOM_dom%mpp_domain, d_type) @@ -1421,7 +1175,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & integer, optional, intent(in) :: NJPROC !< Processor counts, required with !! static memory. integer, dimension(2), optional, intent(inout) :: min_halo !< If present, this sets the - !! minimum halo size for this domain in the x- and y- + !! minimum halo size for this domain in the i- and j- !! directions, and returns the actual halo size used. character(len=*), optional, intent(in) :: domain_name !< A name for this domain, "MOM" !! if missing. @@ -1430,26 +1184,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & character(len=*), optional, intent(in) :: param_suffix !< A suffix to apply to !! layout-specific parameters. - -! Arguments: MOM_dom - A pointer to the MOM_domain_type being defined here. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in,opt) symmetric - If present, this specifies whether this domain -! is symmetric, regardless of whether the macro -! SYMMETRIC_MEMORY_ is defined. -! (in,opt) static_memory - If present and true, this domain type is set up for -! static memory and error checking of various input -! values is performed against those in the input file. -! (in,opt) NIHALO, NJHALO - Default halo sizes, required with static memory. -! (in,opt) NIGLOBAL, NJGLOBAL - Total domain sizes, required with static memory. -! (in,opt) NIPROC, NJPROC - Processor counts, required with static memory. -! (in,opt) min_halo - If present, this sets the minimum halo size for this -! domain in the x- and y- directions, and returns the -! actual halo size used. -! (in,opt) domain_name - A name for this domain, "MOM" if missing. -! (in,opt) include_name - A name for model's include file, "MOM_memory.h" if missing. -! (in,opt) param_suffix - A suffix to apply to layout-specific parameters. - + ! Local variables integer, dimension(2) :: layout = (/ 1, 1 /) integer, dimension(2) :: io_layout = (/ 0, 0 /) integer, dimension(4) :: global_indices @@ -1471,7 +1206,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & character(len=8) :: char_xsiz, char_ysiz, char_niglobal, char_njglobal character(len=40) :: nihalo_nm, njhalo_nm, layout_nm, io_layout_nm, masktable_nm character(len=40) :: niproc_nm, njproc_nm - + integer :: xhalo_d2,yhalo_d2 ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl ! This module's name. @@ -1479,6 +1214,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & if (.not.associated(MOM_dom)) then allocate(MOM_dom) allocate(MOM_dom%mpp_domain) + allocate(MOM_dom%mpp_domain_d2) endif pe = PE_here() @@ -1536,34 +1272,40 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & default=.false.) #ifndef NOT_SET_AFFINITY -!$ call get_param(param_file, mdl, "OCEAN_OMP_THREADS", ocean_nthreads, & -!$ "The number of OpenMP threads that MOM6 will use.", & -!$ default = 1, layoutParam=.true.) -!$ call get_param(param_file, mdl, "OCEAN_OMP_HYPER_THREAD", ocean_omp_hyper_thread, & -!$ "If True, use hyper-threading.", default = .false., layoutParam=.true.) -!$ if (ocean_omp_hyper_thread) then -!$ call get_param(param_file, mdl, "OMP_CORES_PER_NODE", omp_cores_per_node, & -!$ "Number of cores per node needed for hyper-threading.", & -!$ fail_if_missing=.true., layoutParam=.true.) -!$ endif -!$ call omp_set_num_threads(ocean_nthreads) +!$OMP PARALLEL +!$OMP master +!$ ocean_nthreads = omp_get_num_threads() +!$OMP END MASTER +!$OMP END PARALLEL +!$ if(ocean_nthreads < 2 ) then +!$ call get_param(param_file, mdl, "OCEAN_OMP_THREADS", ocean_nthreads, & +!$ "The number of OpenMP threads that MOM6 will use.", & +!$ default = 1, layoutParam=.true.) +!$ call get_param(param_file, mdl, "OCEAN_OMP_HYPER_THREAD", ocean_omp_hyper_thread, & +!$ "If True, use hyper-threading.", default = .false., layoutParam=.true.) +!$ if (ocean_omp_hyper_thread) then +!$ call get_param(param_file, mdl, "OMP_CORES_PER_NODE", omp_cores_per_node, & +!$ "Number of cores per node needed for hyper-threading.", & +!$ fail_if_missing=.true., layoutParam=.true.) +!$ endif +!$ call omp_set_num_threads(ocean_nthreads) +!$ base_cpu = get_cpu_affinity() !$OMP PARALLEL private(adder) -!$ base_cpu = get_cpu_affinity() -!$ if (ocean_omp_hyper_thread) then -!$ if (mod(omp_get_thread_num(),2) == 0) then -!$ adder = omp_get_thread_num()/2 +!$ if (ocean_omp_hyper_thread) then +!$ if (mod(omp_get_thread_num(),2) == 0) then +!$ adder = omp_get_thread_num()/2 +!$ else +!$ adder = omp_cores_per_node + omp_get_thread_num()/2 +!$ endif !$ else -!$ adder = omp_cores_per_node + omp_get_thread_num()/2 +!$ adder = omp_get_thread_num() !$ endif -!$ else -!$ adder = omp_get_thread_num() -!$ endif -!$ call set_cpu_affinity(base_cpu + adder) -!!$ write(6,*) " ocean ", omp_get_num_threads(), get_cpu_affinity(), adder, omp_get_thread_num() +!$ call set_cpu_affinity(base_cpu + adder) +!!$ write(6,*) " ocean ", base_cpu, get_cpu_affinity(), adder, omp_get_thread_num(), omp_get_num_threads() !!$ call flush(6) !$OMP END PARALLEL +!$ 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"//& @@ -1717,11 +1459,11 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & "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 x-direction. With \n"//& + "The number of processors in the y-direction. With \n"//& "STATIC_MEMORY_ this is set in "//trim(inc_nm)//" at compile time.",& layoutParam=.true.) call log_param(param_file, mdl, trim(layout_nm), layout, & - "The processor layout that was acutally used.",& + "The processor layout that was actually used.",& layoutParam=.true.) ! Idiot check that fewer PEs than columns have been requested @@ -1738,7 +1480,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & call parse_mask_table(mask_table, MOM_dom%maskmap, dom_name) endif - ! Set up the I/O lay-out, and check that it uses an even multiple of the + ! Set up the I/O layout, and check that it uses an even multiple of the ! number of PEs in each direction. io_layout(:) = (/ 1, 1 /) call get_param(param_file, mdl, trim(io_layout_nm), io_layout, & @@ -1751,8 +1493,8 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & &"are not allowed in ")') io_layout(1) call MOM_error(FATAL, mesg//trim(IO_layout_nm)) elseif (io_layout(1) > 0) then ; if (modulo(layout(1), io_layout(1)) /= 0) then - write(mesg,'("MOM_domains_init: The x-direction I/O-layout, IO_LAYOUT(1)=",i4, & - &", does not evenly divide the x-direction layout, NIPROC=,",i4,".")') & + write(mesg,'("MOM_domains_init: The i-direction I/O-layout, IO_LAYOUT(1)=",i4, & + &", does not evenly divide the i-direction layout, NIPROC=,",i4,".")') & io_layout(1),layout(1) call MOM_error(FATAL, mesg) endif ; endif @@ -1762,8 +1504,8 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & &"are not allowed in ")') io_layout(2) call MOM_error(FATAL, mesg//trim(IO_layout_nm)) elseif (io_layout(2) /= 0) then ; if (modulo(layout(2), io_layout(2)) /= 0) then - write(mesg,'("MOM_domains_init: The y-direction I/O-layout, IO_LAYOUT(2)=",i4, & - &", does not evenly divide the y-direction layout, NJPROC=,",i4,".")') & + write(mesg,'("MOM_domains_init: The j-direction I/O-layout, IO_LAYOUT(2)=",i4, & + &", does not evenly divide the j-direction layout, NJPROC=,",i4,".")') & io_layout(2),layout(2) call MOM_error(FATAL, mesg) endif ; endif @@ -1806,7 +1548,6 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & MOM_dom%Y_FLAGS = Y_FLAGS MOM_dom%layout = layout MOM_dom%io_layout = io_layout - MOM_dom%use_io_layout = (io_layout(1) + io_layout(2) > 0) if (is_static) then ! A requirement of equal sized compute domains is necessary when STATIC_MEMORY_ @@ -1828,18 +1569,54 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & endif endif + global_indices(1) = 1 ; global_indices(2) = int(MOM_dom%niglobal/2) + global_indices(3) = 1 ; global_indices(4) = int(MOM_dom%njglobal/2) + !For downsampled domain, recommend a halo of 1 (or 0?) since we're not doing wide-stencil computations. + !But that does not work because the downsampled field would not have the correct size to pass the checks, e.g., we get + !error: downsample_diag_indices_get: peculiar size 28 in i-direction\ndoes not match one of 24 25 26 27 + xhalo_d2 = int(MOM_dom%nihalo/2) + yhalo_d2 = int(MOM_dom%njhalo/2) + if (mask_table_exists) then + call MOM_define_domain( global_indices, layout, MOM_dom%mpp_domain_d2, & + xflags=X_FLAGS, yflags=Y_FLAGS, & + xhalo=xhalo_d2, yhalo=yhalo_d2, & + symmetry = MOM_dom%symmetric, name=trim("MOMc"), & + maskmap=MOM_dom%maskmap ) + else + call MOM_define_domain( global_indices, layout, MOM_dom%mpp_domain_d2, & + xflags=X_FLAGS, yflags=Y_FLAGS, & + xhalo=xhalo_d2, yhalo=yhalo_d2, & + symmetry = MOM_dom%symmetric, name=trim("MOMc")) + endif + + if ((io_layout(1) > 0) .and. (io_layout(2) > 0) .and. & + (layout(1)*layout(2) > 1)) then + call MOM_define_io_domain(MOM_dom%mpp_domain_d2, io_layout) + endif + end subroutine MOM_domains_init !> clone_MD_to_MD copies one MOM_domain_type into another, while allowing !! some properties of the new type to differ from the original one. subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, & domain_name) - type(MOM_domain_type), intent(in) :: MD_in - type(MOM_domain_type), pointer :: MOM_dom - integer, dimension(2), optional, intent(inout) :: min_halo - integer, optional, intent(in) :: halo_size - logical, optional, intent(in) :: symmetric - character(len=*), optional, intent(in) :: domain_name + type(MOM_domain_type), intent(in) :: MD_in !< An existing MOM_domain + type(MOM_domain_type), pointer :: MOM_dom !< A pointer to a MOM_domain that will be + !! allocated if it is unassociated, and will have data + !! copied from MD_in + integer, dimension(2), & + optional, intent(inout) :: min_halo !< If present, this sets the + !! minimum halo size for this domain in the i- and j- + !! directions, and returns the actual halo size used. + integer, optional, intent(in) :: halo_size !< If present, this sets the halo + !! size for the domian in the i- and j-directions. + !! min_halo and halo_size can not both be present. + logical, optional, intent(in) :: symmetric !< If present, this specifies + !! whether the new domain is symmetric, regardless of + !! whether the macro SYMMETRIC_MEMORY_ is defined. + character(len=*), & + optional, intent(in) :: domain_name !< A name for the new domain, "MOM" + !! if missing. integer :: global_indices(4) logical :: mask_table_exists @@ -1848,6 +1625,7 @@ subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, & if (.not.associated(MOM_dom)) then allocate(MOM_dom) allocate(MOM_dom%mpp_domain) + allocate(MOM_dom%mpp_domain_d2) endif ! Save the extra data for creating other domains of different resolution that overlay this domain @@ -1859,7 +1637,6 @@ subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, & MOM_dom%X_FLAGS = MD_in%X_FLAGS ; MOM_dom%Y_FLAGS = MD_in%Y_FLAGS MOM_dom%layout(:) = MD_in%layout(:) ; MOM_dom%io_layout(:) = MD_in%io_layout(:) - MOM_dom%use_io_layout = (MOM_dom%io_layout(1) + MOM_dom%io_layout(2) > 0) if (associated(MD_in%maskmap)) then mask_table_exists = .true. @@ -1915,12 +1692,21 @@ end subroutine clone_MD_to_MD !! the original one. subroutine clone_MD_to_d2D(MD_in, mpp_domain, min_halo, halo_size, symmetric, & domain_name) - type(MOM_domain_type), intent(in) :: MD_in - type(domain2d), intent(inout) :: mpp_domain - integer, dimension(2), optional, intent(inout) :: min_halo - integer, optional, intent(in) :: halo_size - logical, optional, intent(in) :: symmetric - character(len=*), optional, intent(in) :: domain_name + type(MOM_domain_type), intent(in) :: MD_in !< An existing MOM_domain to be cloned + type(domain2d), intent(inout) :: mpp_domain !< The new mpp_domain to be set up + integer, dimension(2), & + optional, intent(inout) :: min_halo !< If present, this sets the + !! minimum halo size for this domain in the i- and j- + !! directions, and returns the actual halo size used. + integer, optional, intent(in) :: halo_size !< If present, this sets the halo + !! size for the domian in the i- and j-directions. + !! min_halo and halo_size can not both be present. + logical, optional, intent(in) :: symmetric !< If present, this specifies + !! whether the new domain is symmetric, regardless of + !! whether the macro SYMMETRIC_MEMORY_ is defined. + character(len=*), & + optional, intent(in) :: domain_name !< A name for the new domain, "MOM" + !! if missing. integer :: global_indices(4), layout(2), io_layout(2) integer :: X_FLAGS, Y_FLAGS, niglobal, njglobal, nihalo, njhalo @@ -1976,43 +1762,38 @@ subroutine clone_MD_to_d2D(MD_in, mpp_domain, min_halo, halo_size, symmetric, & end subroutine clone_MD_to_d2D -!> get_domain_extent returns various data that has been stored in a MOM_domain_type. +!> Returns various data that has been stored in a MOM_domain_type subroutine get_domain_extent(Domain, isc, iec, jsc, jec, isd, ied, jsd, jed, & isg, ieg, jsg, jeg, idg_offset, jdg_offset, & symmetric, local_indexing, index_offset) type(MOM_domain_type), & - intent(in) :: Domain - integer, intent(out) :: isc, iec, jsc, jec !< The start & end indices of the computational - !! domain. - integer, intent(out) :: isd, ied, jsd, jed !< The start & end indices of the data domain. - integer, intent(out) :: isg, ieg, jsg, jeg !< The start & end indices of the global domain. - integer, intent(out) :: idg_offset, jdg_offset !< The offset between the corresponding global and - !! data index spaces. - logical, intent(out) :: symmetric !< True if symmetric memory is used. - logical, optional, & - intent(in) :: local_indexing !< If true, local tracer array indices start at 1, - !! as in most MOM6 or GOLD code. - integer, optional, & - intent(in) :: index_offset !< A fixed additional offset to all indices. This - !! can be useful for some types of debugging with - !! dynamic memory allocation. - -! Arguments: Domain - The MOM_domain_type from which the indices are extracted. -! (out) isc, iec, jsc, jec - the start & end indices of the -! computational domain. -! (out) isd, ied, jsd, jed - the start & end indices of the data domain. -! (out) isg, ieg, jsg, jeg - the start & end indices of the global domain. -! (out) idg_offset, jdg_offset - the offset between the corresponding -! global and data index spaces. -! (out) symmetric - true if symmetric memory is used. -! (in,opt) local_indexing - if true, local tracer array indices start at 1, as -! in most MOM6 or GOLD code. -! (in,opt) index_offset - A fixed additional offset to all indices. This can -! be useful for some types of debugging with dynamic -! memory allocation. - + intent(in) :: Domain !< The MOM domain from which to extract information + integer, intent(out) :: isc !< The start i-index of the computational domain + integer, intent(out) :: iec !< The end i-index of the computational domain + integer, intent(out) :: jsc !< The start j-index of the computational domain + integer, intent(out) :: jec !< The end j-index of the computational domain + integer, intent(out) :: isd !< The start i-index of the data domain + integer, intent(out) :: ied !< The end i-index of the data domain + integer, intent(out) :: jsd !< The start j-index of the data domain + integer, intent(out) :: jed !< The end j-index of the data domain + integer, intent(out) :: isg !< The start i-index of the global domain + integer, intent(out) :: ieg !< The end i-index of the global domain + integer, intent(out) :: jsg !< The start j-index of the global domain + integer, intent(out) :: jeg !< The end j-index of the global domain + integer, intent(out) :: idg_offset !< The offset between the corresponding global and + !! data i-index spaces. + integer, intent(out) :: jdg_offset !< The offset between the corresponding global and + !! data j-index spaces. + logical, intent(out) :: symmetric !< True if symmetric memory is used. + logical, optional, intent(in) :: local_indexing !< If true, local tracer array indices start at 1, + !! as in most MOM6 code. + integer, optional, intent(in) :: index_offset !< A fixed additional offset to all indices. This + !! can be useful for some types of debugging with + !! dynamic memory allocation. + ! Local variables integer :: ind_off logical :: local + local = .true. ; if (present(local_indexing)) local = local_indexing ind_off = 0 ; if (present(index_offset)) ind_off = index_offset @@ -2040,9 +1821,100 @@ subroutine get_domain_extent(Domain, isc, iec, jsc, jec, isd, ied, jsd, jed, & end subroutine get_domain_extent +subroutine get_domain_extent_dsamp2(Domain, isc_d2, iec_d2, jsc_d2, jec_d2,& + isd_d2, ied_d2, jsd_d2, jed_d2,& + isg_d2, ieg_d2, jsg_d2, jeg_d2) + type(MOM_domain_type), & + intent(in) :: Domain !< The MOM domain from which to extract information + integer, intent(out) :: isc_d2, iec_d2, jsc_d2, jec_d2 + integer, intent(out) :: isd_d2, ied_d2, jsd_d2, jed_d2 + integer, intent(out) :: isg_d2, ieg_d2, jsg_d2, jeg_d2 + call mpp_get_compute_domain(Domain%mpp_domain_d2, isc_d2, iec_d2, jsc_d2, jec_d2) + call mpp_get_data_domain(Domain%mpp_domain_d2, isd_d2, ied_d2, jsd_d2, jed_d2) + call mpp_get_global_domain (Domain%mpp_domain_d2, isg_d2, ieg_d2, jsg_d2, jeg_d2) + ! This code institutes the MOM convention that local array indices start at 1. + isc_d2 = isc_d2-isd_d2+1 ; iec_d2 = iec_d2-isd_d2+1 + jsc_d2 = jsc_d2-jsd_d2+1 ; jec_d2 = jec_d2-jsd_d2+1 + ied_d2 = ied_d2-isd_d2+1 ; jed_d2 = jed_d2-jsd_d2+1 + isd_d2 = 1 ; jsd_d2 = 1 +end subroutine get_domain_extent_dsamp2 + +!> Return the (potentially symmetric) computational domain i-bounds for an array +!! passed without index specifications (i.e. indices start at 1) based on an array size. +subroutine get_simple_array_i_ind(domain, size, is, ie, symmetric) + type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information + integer, intent(in) :: size !< The i-array size + integer, intent(out) :: is !< The computational domain starting i-index. + integer, intent(out) :: ie !< The computational domain ending i-index. + logical, optional, intent(in) :: symmetric !< If present, indicates whether symmetric sizes + !! can be considered. + ! Local variables + logical :: sym + character(len=120) :: mesg, mesg2 + integer :: isc, iec, jsc, jec, isd, ied, jsd, jed + + call mpp_get_compute_domain(Domain%mpp_domain, isc, iec, jsc, jec) + call mpp_get_data_domain(Domain%mpp_domain, isd, ied, jsd, jed) + + isc = isc-isd+1 ; iec = iec-isd+1 ; ied = ied-isd+1 ; isd = 1 + sym = Domain%symmetric ; if (present(symmetric)) sym = symmetric + + if (size == ied) then ; is = isc ; ie = iec + elseif (size == 1+iec-isc) then ; is = 1 ; ie = size + elseif (sym .and. (size == 1+ied)) then ; is = isc ; ie = iec+1 + elseif (sym .and. (size == 2+iec-isc)) then ; is = 1 ; ie = size+1 + else + write(mesg,'("Unrecognized size ", i6, "in call to get_simple_array_i_ind. \")') size + if (sym) then + write(mesg2,'("Valid sizes are : ", 2i7)') ied, 1+iec-isc + else + write(mesg2,'("Valid sizes are : ", 4i7)') ied, 1+iec-isc, 1+ied, 2+iec-isc + endif + call MOM_error(FATAL, trim(mesg)//trim(mesg2)) + endif + +end subroutine get_simple_array_i_ind + + +!> Return the (potentially symmetric) computational domain j-bounds for an array +!! passed without index specifications (i.e. indices start at 1) based on an array size. +subroutine get_simple_array_j_ind(domain, size, js, je, symmetric) + type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information + integer, intent(in) :: size !< The j-array size + integer, intent(out) :: js !< The computational domain starting j-index. + integer, intent(out) :: je !< The computational domain ending j-index. + logical, optional, intent(in) :: symmetric !< If present, indicates whether symmetric sizes + !! can be considered. + ! Local variables + logical :: sym + character(len=120) :: mesg, mesg2 + integer :: isc, iec, jsc, jec, isd, ied, jsd, jed + + call mpp_get_compute_domain(Domain%mpp_domain, isc, iec, jsc, jec) + call mpp_get_data_domain(Domain%mpp_domain, isd, ied, jsd, jed) + + jsc = jsc-jsd+1 ; jec = jec-jsd+1 ; jed = jed-jsd+1 ; jsd = 1 + sym = Domain%symmetric ; if (present(symmetric)) sym = symmetric + + if (size == jed) then ; js = jsc ; je = jec + elseif (size == 1+jec-jsc) then ; js = 1 ; je = size + elseif (sym .and. (size == 1+jed)) then ; js = jsc ; je = jec+1 + elseif (sym .and. (size == 2+jec-jsc)) then ; js = 1 ; je = size+1 + else + write(mesg,'("Unrecognized size ", i6, "in call to get_simple_array_j_ind. \")') size + if (sym) then + write(mesg2,'("Valid sizes are : ", 2i7)') jed, 1+jec-jsc + else + write(mesg2,'("Valid sizes are : ", 4i7)') jed, 1+jec-jsc, 1+jed, 2+jec-jsc + endif + call MOM_error(FATAL, trim(mesg)//trim(mesg2)) + endif + +end subroutine get_simple_array_j_ind + !> Returns the global shape of h-point arrays subroutine get_global_shape(domain, niglobal, njglobal) - type(MOM_domain_type), intent(in) :: domain !< MOM domain + type(MOM_domain_type), intent(in) :: domain !< MOM domain integer, intent(out) :: niglobal !< i-index global size of h-point arrays integer, intent(out) :: njglobal !< j-index global size of h-point arrays diff --git a/src/framework/MOM_dyn_horgrid.F90 b/src/framework/MOM_dyn_horgrid.F90 index a11646aa2a..11155d73e6 100644 --- a/src/framework/MOM_dyn_horgrid.F90 +++ b/src/framework/MOM_dyn_horgrid.F90 @@ -1,3 +1,5 @@ +!> Contains a shareable dynamic type for describing horizontal grids and metric data +!! and utilty routines that work on this type. module MOM_dyn_horgrid ! This file is part of MOM6. See LICENSE.md for the license. @@ -9,116 +11,160 @@ module MOM_dyn_horgrid implicit none ; private public create_dyn_horgrid, destroy_dyn_horgrid, set_derived_dyn_horgrid +public rescale_dyn_horgrid_bathymetry +! 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. + +!> Describes the horizontal ocean grid with only dynamic memory arrays type, public :: dyn_horgrid_type - type(MOM_domain_type), pointer :: Domain => NULL() - type(MOM_domain_type), pointer :: Domain_aux => NULL() ! A non-symmetric auxiliary domain type. - - ! These elements can be copied from a provided hor_index_type. - type(hor_index_type) :: HI ! Make this a pointer? - integer :: isc, iec, jsc, jec ! The range of the computational domain indices - integer :: isd, ied, jsd, jed ! and data domain indices at tracer cell centers. - integer :: isg, ieg, jsg, jeg ! The range of the global domain tracer cell indices. - integer :: IscB, IecB, JscB, JecB ! The range of the computational domain indices - integer :: IsdB, IedB, JsdB, JedB ! and data domain indices at tracer cell vertices. - integer :: IsgB, IegB, JsgB, JegB ! The range of the global domain vertex indices. - integer :: isd_global ! The values of isd and jsd in the global - integer :: jsd_global ! (decomposition invariant) index space. - integer :: idg_offset ! The offset between the corresponding global - integer :: jdg_offset ! and local array indices. - logical :: symmetric ! True if symmetric memory is used. - - logical :: nonblocking_updates ! If true, non-blocking halo updates are - ! allowed. The default is .false. (for now). - integer :: first_direction ! An integer that indicates which direction is - ! to be updated first in directionally split - ! parts of the calculation. This can be altered - ! during the course of the run via calls to - ! set_first_direction. + type(MOM_domain_type), pointer :: Domain => NULL() !< Ocean model domain + type(MOM_domain_type), pointer :: Domain_aux => NULL() !< A non-symmetric auxiliary domain type. + type(hor_index_type) :: HI !< Horizontal index ranges + + integer :: isc !< The start i-index of cell centers within the computational domain + integer :: iec !< The end i-index of cell centers within the computational domain + integer :: jsc !< The start j-index of cell centers within the computational domain + integer :: jec !< The end j-index of cell centers within the computational domain + + integer :: isd !< The start i-index of cell centers within the data domain + integer :: ied !< The end i-index of cell centers within the data domain + integer :: jsd !< The start j-index of cell centers within the data domain + integer :: jed !< The end j-index of cell centers within the data domain + + integer :: isg !< The start i-index of cell centers within the global domain + integer :: ieg !< The end i-index of cell centers within the global domain + integer :: jsg !< The start j-index of cell centers within the global domain + integer :: jeg !< The end j-index of cell centers within the global domain + + integer :: IscB !< The start i-index of cell vertices within the computational domain + integer :: IecB !< The end i-index of cell vertices within the computational domain + integer :: JscB !< The start j-index of cell vertices within the computational domain + integer :: JecB !< The end j-index of cell vertices within the computational domain + + integer :: IsdB !< The start i-index of cell vertices within the data domain + integer :: IedB !< The end i-index of cell vertices within the data domain + integer :: JsdB !< The start j-index of cell vertices within the data domain + integer :: JedB !< The end j-index of cell vertices within the data domain + + integer :: IsgB !< The start i-index of cell vertices within the global domain + integer :: IegB !< The end i-index of cell vertices within the global domain + integer :: JsgB !< The start j-index of cell vertices within the global domain + integer :: JegB !< The end j-index of cell vertices within the global domain + + integer :: isd_global !< The value of isd in the global index space (decompoistion invariant). + integer :: jsd_global !< The value of isd in the global index space (decompoistion invariant). + integer :: idg_offset !< The offset between the corresponding global and local i-indices. + integer :: jdg_offset !< The offset between the corresponding global and local j-indices. + logical :: symmetric !< True if symmetric memory is used. + + logical :: nonblocking_updates !< If true, non-blocking halo updates are + !! allowed. The default is .false. (for now). + integer :: first_direction !< An integer that indicates which direction is to be updated first in + !! directionally split parts of the calculation. This can be altered + !! during the course of the run via calls to set_first_direction. real, allocatable, dimension(:,:) :: & - mask2dT, & ! 0 for land points and 1 for ocean points on the h-grid. Nd. - geoLatT, & ! The geographic latitude at q points in degrees of latitude or m. - geoLonT, & ! The geographic longitude at q points in degrees of longitude or m. - dxT, IdxT, & ! dxT is delta x at h points, in m, and IdxT is 1/dxT in m-1. - dyT, IdyT, & ! dyT is delta y at h points, in m, and IdyT is 1/dyT in m-1. - areaT, & ! areaT is the area of an h-cell, in m2. - IareaT, & ! IareaT = 1/areaT, in m-2. - sin_rot, & ! The sine and cosine of the angular rotation between the local - cos_rot ! model grid's northward and the true northward directions. + mask2dT, & !< 0 for land points and 1 for ocean points on the h-grid [nondim]. + geoLatT, & !< The geographic latitude at q points [degrees of latitude] or [m]. + geoLonT, & !< The geographic longitude at q points [degrees of longitude] or [m]. + dxT, & !< dxT is delta x at h points [m]. + IdxT, & !< 1/dxT [m-1]. + dyT, & !< dyT is delta y at h points [m]. + IdyT, & !< IdyT is 1/dyT [m-1]. + areaT, & !< The area of an h-cell [m2]. + IareaT !< 1/areaT [m-2]. + real, allocatable, dimension(:,:) :: sin_rot + !< The sine of the angular rotation between the local model grid's northward + !! and the true northward directions [nondim]. + real, allocatable, dimension(:,:) :: cos_rot + !< The cosine of the angular rotation between the local model grid's northward + !! and the true northward directions [nondim]. real, allocatable, dimension(:,:) :: & - mask2dCu, & ! 0 for boundary points and 1 for ocean points on the u grid. Nondim. - geoLatCu, & ! The geographic latitude at u points in degrees of latitude or m. - geoLonCu, & ! The geographic longitude at u points in degrees of longitude or m. - dxCu, IdxCu, & ! dxCu is delta x at u points, in m, and IdxCu is 1/dxCu in m-1. - dyCu, IdyCu, & ! dyCu is delta y at u points, in m, and IdyCu is 1/dyCu in m-1. - dy_Cu, & ! The unblocked lengths of the u-faces of the h-cell in m. - IareaCu, & ! The masked inverse areas of u-grid cells in m2. - areaCu ! The areas of the u-grid cells in m2. + mask2dCu, & !< 0 for boundary points and 1 for ocean points on the u grid [nondim]. + geoLatCu, & !< The geographic latitude at u points [degrees of latitude] or [m]. + geoLonCu, & !< The geographic longitude at u points [degrees of longitude] or [m]. + dxCu, & !< dxCu is delta x at u points [m]. + IdxCu, & !< 1/dxCu [m-1]. + dyCu, & !< dyCu is delta y at u points [m]. + IdyCu, & !< 1/dyCu [m-1]. + dy_Cu, & !< The unblocked lengths of the u-faces of the h-cell [m]. + IareaCu, & !< The masked inverse areas of u-grid cells [m2]. + areaCu !< The areas of the u-grid cells [m2]. real, allocatable, dimension(:,:) :: & - mask2dCv, & ! 0 for boundary points and 1 for ocean points on the v grid. Nondim. - geoLatCv, & ! The geographic latitude at v points in degrees of latitude or m. - geoLonCv, & ! The geographic longitude at v points in degrees of longitude or m. - dxCv, IdxCv, & ! dxCv is delta x at v points, in m, and IdxCv is 1/dxCv in m-1. - dyCv, IdyCv, & ! dyCv is delta y at v points, in m, and IdyCv is 1/dyCv in m-1. - dx_Cv, & ! The unblocked lengths of the v-faces of the h-cell in m. - IareaCv, & ! The masked inverse areas of v-grid cells in m2. - areaCv ! The areas of the v-grid cells in m2. + mask2dCv, & !< 0 for boundary points and 1 for ocean points on the v grid [nondim]. + geoLatCv, & !< The geographic latitude at v points [degrees of latitude] or [m]. + geoLonCv, & !< The geographic longitude at v points [degrees of longitude] or [m]. + dxCv, & !< dxCv is delta x at v points [m]. + IdxCv, & !< 1/dxCv [m-1]. + dyCv, & !< dyCv is delta y at v points [m]. + IdyCv, & !< 1/dyCv [m-1]. + dx_Cv, & !< The unblocked lengths of the v-faces of the h-cell [m]. + IareaCv, & !< The masked inverse areas of v-grid cells [m2]. + areaCv !< The areas of the v-grid cells [m2]. real, allocatable, dimension(:,:) :: & - mask2dBu, & ! 0 for boundary points and 1 for ocean points on the q grid. Nondim. - geoLatBu, & ! The geographic latitude at q points in degrees of latitude or m. - geoLonBu, & ! The geographic longitude at q points in degrees of longitude or m. - dxBu, IdxBu, & ! dxBu is delta x at q points, in m, and IdxBu is 1/dxBu in m-1. - dyBu, IdyBu, & ! dyBu is delta y at q points, in m, and IdyBu is 1/dyBu in m-1. - areaBu, & ! areaBu is the area of a q-cell, in m2 - IareaBu ! IareaBu = 1/areaBu in m-2. - - real, pointer, dimension(:) :: & - gridLatT => NULL(), gridLatB => NULL() ! The latitude of T or B points for - ! the purpose of labeling the output axes. - ! On many grids these are the same as geoLatT & geoLatBu. - real, pointer, dimension(:) :: & - gridLonT => NULL(), gridLonB => NULL() ! The longitude of T or B points for - ! the purpose of labeling the output axes. - ! On many grids these are the same as geoLonT & geoLonBu. + mask2dBu, & !< 0 for boundary points and 1 for ocean points on the q grid [nondim]. + geoLatBu, & !< The geographic latitude at q points [degrees of latitude] or [m]. + geoLonBu, & !< The geographic longitude at q points [degrees of longitude] or [m]. + dxBu, & !< dxBu is delta x at q points [m]. + IdxBu, & !< 1/dxBu [m-1]. + dyBu, & !< dyBu is delta y at q points [m]. + IdyBu, & !< 1/dyBu [m-1]. + areaBu, & !< areaBu is the area of a q-cell [m2] + IareaBu !< IareaBu = 1/areaBu [m-2]. + + real, pointer, dimension(:) :: gridLatT => NULL() + !< The latitude of T points for the purpose of labeling the output axes. + !! On many grids this is the same as geoLatT. + real, pointer, dimension(:) :: gridLatB => NULL() + !< The latitude of B points for the purpose of labeling the output axes. + !! On many grids this is the same as geoLatBu. + real, pointer, dimension(:) :: gridLonT => NULL() + !< The longitude of T points for the purpose of labeling the output axes. + !! On many grids this is the same as geoLonT. + real, pointer, dimension(:) :: gridLonB => NULL() + !< The longitude of B points for the purpose of labeling the output axes. + !! On many grids this is the same as geoLonBu. character(len=40) :: & - x_axis_units, & ! The units that are used in labeling the coordinate - y_axis_units ! axes. Except on a Cartesian grid, these are usually - ! some variant of "degrees". + x_axis_units, & !< The units that are used in labeling the x coordinate axes. + y_axis_units !< The units that are used in labeling the y coordinate axes. + ! Except on a Cartesian grid, these are usually some variant of "degrees". real, allocatable, dimension(:,:) :: & - bathyT ! Ocean bottom depth at tracer points, in m. + bathyT !< Ocean bottom depth at tracer points, in depth units [Z ~> m]. - logical :: bathymetry_at_vel ! If true, there are separate values for the - ! basin depths at velocity points. Otherwise the effects of - ! of topography are entirely determined from thickness points. + logical :: bathymetry_at_vel !< If true, there are separate values for the + !! basin depths at velocity points. Otherwise the effects of + !! of topography are entirely determined from thickness points. real, allocatable, dimension(:,:) :: & - Dblock_u, & ! Topographic depths at u-points at which the flow is blocked - Dopen_u ! (Dblock_u) and open at width dy_Cu (Dopen_u), both in m. + Dblock_u, & !< Topographic depths at u-points at which the flow is blocked [Z ~> m]. + Dopen_u !< Topographic depths at u-points at which the flow is open at width dy_Cu [Z ~> m]. real, allocatable, dimension(:,:) :: & - Dblock_v, & ! Topographic depths at v-points at which the flow is blocked - Dopen_v ! (Dblock_v) and open at width dx_Cv (Dopen_v), both in m. + Dblock_v, & !< Topographic depths at v-points at which the flow is blocked [Z ~> m]. + Dopen_v !< Topographic depths at v-points at which the flow is open at width dx_Cv [Z ~> m]. real, allocatable, dimension(:,:) :: & - CoriolisBu ! The Coriolis parameter at corner points, in s-1. + CoriolisBu !< The Coriolis parameter at corner points [s-1]. real, allocatable, dimension(:,:) :: & - dF_dx, dF_dy ! Derivatives of f (Coriolis parameter) at h-points, in s-1 m-1. + df_dx, & !< Derivative d/dx f (Coriolis parameter) at h-points [s-1 m-1]. + df_dy !< Derivative d/dy f (Coriolis parameter) at h-points [s-1 m-1]. ! These variables are global sums that are useful for 1-d diagnostics - real :: areaT_global ! Global sum of h-cell area in m2 - real :: IareaT_global ! Global sum of inverse h-cell area (1/areaT_global) - ! in m2 + real :: areaT_global !< Global sum of h-cell area [m2] + real :: IareaT_global !< Global sum of inverse h-cell area (1/areaT_global) [m-2] ! These parameters are run-time parameters that are used during some ! initialization routines (but not all) - real :: south_lat ! The latitude (or y-coordinate) of the first v-line - real :: west_lon ! The longitude (or x-coordinate) of the first u-line - real :: len_lat = 0. ! The latitudinal (or y-coord) extent of physical domain - real :: len_lon = 0. ! The longitudinal (or x-coord) extent of physical domain - real :: Rad_Earth = 6.378e6 ! The radius of the planet in meters. - real :: max_depth ! The maximum depth of the ocean in meters. + real :: south_lat !< The latitude (or y-coordinate) of the first v-line + real :: west_lon !< The longitude (or x-coordinate) of the first u-line + real :: len_lat = 0. !< The latitudinal (or y-coord) extent of physical domain + real :: len_lon = 0. !< The longitudinal (or x-coord) extent of physical domain + real :: Rad_Earth = 6.378e6 !< The radius of the planet [m]. + real :: max_depth !< The maximum depth of the ocean [Z ~> m]. end type dyn_horgrid_type contains @@ -232,6 +278,39 @@ subroutine create_dyn_horgrid(G, HI, bathymetry_at_vel) end subroutine create_dyn_horgrid +!> rescale_dyn_horgrid_bathymetry permits a change in the internal units for the bathymetry on the +!! grid, both rescaling the depths and recording the new internal depth units. +subroutine rescale_dyn_horgrid_bathymetry(G, m_in_new_units) + type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid type + real, intent(in) :: m_in_new_units !< The new internal representation of 1 m depth. + + ! Local variables + real :: rescale + integer :: i, j, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + if (m_in_new_units == 1.0) return + if (m_in_new_units < 0.0) & + call MOM_error(FATAL, "rescale_grid_bathymetry: Negative depth units are not permitted.") + if (m_in_new_units == 0.0) & + call MOM_error(FATAL, "rescale_grid_bathymetry: Zero depth units are not permitted.") + + rescale = 1.0 / m_in_new_units + do j=jsd,jed ; do i=isd,ied + G%bathyT(i,j) = rescale*G%bathyT(i,j) + enddo ; enddo + if (G%bathymetry_at_vel) then ; do j=jsd,jed ; do I=IsdB,IedB + G%Dblock_u(I,j) = rescale*G%Dblock_u(I,j) ; G%Dopen_u(I,j) = rescale*G%Dopen_u(I,j) + enddo ; enddo ; endif + if (G%bathymetry_at_vel) then ; do J=JsdB,JedB ; do i=isd,ied + G%Dblock_v(i,J) = rescale*G%Dblock_v(i,J) ; G%Dopen_v(i,J) = rescale*G%Dopen_v(i,J) + enddo ; enddo ; endif + G%max_depth = rescale*G%max_depth + +end subroutine rescale_dyn_horgrid_bathymetry + !> set_derived_dyn_horgrid calculates metric terms that are derived from other metrics. subroutine set_derived_dyn_horgrid(G) type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid type diff --git a/src/framework/MOM_error_handler.F90 b/src/framework/MOM_error_handler.F90 index 48edffc1f6..30300d6e33 100644 --- a/src/framework/MOM_error_handler.F90 +++ b/src/framework/MOM_error_handler.F90 @@ -1,16 +1,8 @@ +!> Routines for error handling and I/O management module MOM_error_handler ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By R. Hallberg, 2005-2012. * -!* * -!* This module wraps the mpp_mod error handling code and the * -!* mpp functions stdlog() and stdout() that return open unit numbers. * -!* * -!********+*********+*********+*********+*********+*********+*********+** - use mpp_mod, only : mpp_error, NOTE, WARNING, FATAL use mpp_mod, only : mpp_pe, mpp_root_pe, stdlog, stdout @@ -21,18 +13,19 @@ module MOM_error_handler public callTree_showQuery, callTree_enter, callTree_leave, callTree_waypoint public assert -! Verbosity level: -! 0 - FATAL messages only -! 1 - FATAL + WARNING messages only -! 2 - FATAL + WARNING + NOTE messages only [default] -! 3 - above + informational -! 4 - -! 5 - -! 6 - above + call tree -! 7 - -! 8 - -! 9 - anything and everything (also set with #define DEBUG) integer :: verbosity = 6 +!< Verbosity level: +!! 0 - FATAL messages only +!! 1 - FATAL + WARNING messages only +!! 2 - FATAL + WARNING + NOTE messages only [default] +!! 3 - above + informational +!! 4 - +!! 5 - +!! 6 - above + call tree +!! 7 - +!! 8 - +!! 9 - anything and everything (also set with DEBUG=True) + ! Note that this module default will only hold until the ! VERBOSITY parameter is parsed and the given default imposed. ! We set it to 6 here so that the call tree will print before @@ -41,11 +34,12 @@ module MOM_error_handler ! a type passed by argument (preferred for most data) for convenience ! and to reduce obfuscation of code -! The level of calling within the call tree integer :: callTreeIndentLevel = 0 +!< The level of calling within the call tree contains +!> This returns .true. if the current PE is the root PE. function is_root_pe() ! This returns .true. if the current PE is the root PE. logical :: is_root_pe @@ -54,10 +48,12 @@ function is_root_pe() return end function is_root_pe +!> This provides a convenient interface for writing an informative comment. subroutine MOM_mesg(message, verb, all_print) - character(len=*), intent(in) :: message - integer, optional, intent(in) :: verb - logical, optional, intent(in) :: all_print + character(len=*), intent(in) :: message !< A message to write out + integer, optional, intent(in) :: verb !< A level of verbosity for this message + logical, optional, intent(in) :: all_print !< If present and true, any PEs are + !! able to write this message. ! This provides a convenient interface for writing an informative comment. integer :: verb_msg logical :: write_msg @@ -70,10 +66,13 @@ subroutine MOM_mesg(message, verb, all_print) end subroutine MOM_mesg +!> This provides a convenient interface for writing an mpp_error message +!! with run-time filter based on a verbosity. subroutine MOM_error(level, message, all_print) - integer, intent(in) :: level - character(len=*), intent(in) :: message - logical, optional, intent(in) :: all_print + integer, intent(in) :: level !< The verbosity level of this message + character(len=*), intent(in) :: message !< A message to write out + logical, optional, intent(in) :: all_print !< If present and true, any PEs are + !! able to write this message. ! This provides a convenient interface for writing an mpp_error message ! with run-time filter based on a verbosity. logical :: write_msg @@ -93,8 +92,9 @@ subroutine MOM_error(level, message, all_print) end select end subroutine MOM_error +!> This subroutine sets the level of verbosity filtering MOM error messages subroutine MOM_set_verbosity(verb) - integer, intent(in) :: verb + integer, intent(in) :: verb !< A level of verbosity to set character(len=80) :: msg if (verb>0 .and. verb<10) then verbosity=verb @@ -104,13 +104,16 @@ subroutine MOM_set_verbosity(verb) endif end subroutine MOM_set_verbosity +!> This subroutine gets the level of verbosity filtering MOM error messages function MOM_get_verbosity() integer :: MOM_get_verbosity MOM_get_verbosity = verbosity end function MOM_get_verbosity +!> This tests whether the level of verbosity filtering MOM error messages is +!! sufficient to write a message of verbosity level verb function MOM_verbose_enough(verb) - integer, intent(in) :: verb + integer, intent(in) :: verb !< A level of verbosity to test logical :: MOM_verbose_enough MOM_verbose_enough = (verbosity >= verb) end function MOM_verbose_enough @@ -124,8 +127,8 @@ end function callTree_showQuery !> Writes a message about entering a subroutine if call tree reporting is active subroutine callTree_enter(mesg,n) - character(len=*) :: mesg !< Message to write - integer, optional :: n !< An optional integer to write at end of message + character(len=*), intent(in) :: mesg !< Message to write + integer, optional, intent(in) :: n !< An optional integer to write at end of message ! Local variables character(len=8) :: nAsString callTreeIndentLevel = callTreeIndentLevel + 1 @@ -155,8 +158,8 @@ end subroutine callTree_leave !> Writes a message about reaching a milestone if call tree reporting is active subroutine callTree_waypoint(mesg,n) - character(len=*) :: mesg !< Message to write - integer, optional :: n !< An optional integer to write at end of message + character(len=*), intent(in) :: mesg !< Message to write + integer, optional, intent(in) :: n !< An optional integer to write at end of message ! Local variables character(len=8) :: nAsString if (callTreeIndentLevel<0) write(0,*) 'callTree_waypoint: error callTreeIndentLevel=',callTreeIndentLevel,trim(mesg) diff --git a/src/framework/MOM_file_parser.F90 b/src/framework/MOM_file_parser.F90 index 5f5d927016..5c80fb9d51 100644 --- a/src/framework/MOM_file_parser.F90 +++ b/src/framework/MOM_file_parser.F90 @@ -1,38 +1,13 @@ +!> The MOM6 facility to parse input files for runtime parameters module MOM_file_parser ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Robert Hallberg and Alistair Adcroft, updated 9/2013. * -!* * -!* The subroutines here parse a set of input files for the value * -!* a named parameter and sets that parameter at run time. Currently * -!* these files use use one of several formats: * -!* #define VAR ! To set the logical VAR to true. * -!* VAR = True ! To set the logical VAR to true. * -!* #undef VAR ! To set the logical VAR to false. * -!* VAR = False ! To set the logical VAR to false. * -!* #define VAR 999 ! To set the real or integer VAR to 999. * -!* VAR = 999 ! To set the real or integer VAR to 999. * -!* #override VAR = 888 ! To override a previously set value. * -!* VAR = 1.1, 2.2, 3.3 ! To set an array of real values. * -!* * -!* In addition, when set by the get_param interface, the values of * -!* parameters are automatically logged, along with defaults, units, * -!* and a description. It is an error for a variable to be overridden * -!* more than once, and MOM6 has a facility to check for unused lines * -!* to set variables, which may indicate miss-spelled or archaic * -!* parameters. Parameter names are case-specific, and lines may use * -!* a F90 or C++ style comment, starting with ! or //. * -!* * -!********+*********+*********+*********+*********+*********+*********+** - use MOM_coms, only : root_PE, broadcast use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg use MOM_error_handler, only : is_root_pe, stdlog, stdout -use MOM_time_manager, only : set_time, get_time, time_type, get_ticks_per_second -use MOM_time_manager, only : set_date, get_date +use MOM_time_manager, only : get_time, time_type, get_ticks_per_second +use MOM_time_manager, only : set_date, get_date, real_to_time, operator(-), set_time use MOM_document, only : doc_param, doc_module, doc_init, doc_end, doc_type use MOM_document, only : doc_openBlock, doc_closeBlock use MOM_string_functions, only : left_int, left_ints, slasher @@ -40,103 +15,120 @@ module MOM_file_parser implicit none ; private -integer, parameter, public :: MAX_PARAM_FILES = 5 ! Maximum number of parameter files. -integer, parameter :: INPUT_STR_LENGTH = 200 ! Maximum linelength in parameter file. -integer, parameter :: FILENAME_LENGTH = 200 ! Maximum number of characters in - ! file names. +integer, parameter, public :: MAX_PARAM_FILES = 5 !< Maximum number of parameter files. +integer, parameter :: INPUT_STR_LENGTH = 320 !< Maximum line length in parameter file. +integer, parameter :: FILENAME_LENGTH = 200 !< Maximum number of characters in file names. ! The all_PEs_read option should be eliminated with post-riga shared code. -logical :: all_PEs_read = .false. +logical :: all_PEs_read = .false. !< If true, all PEs read the input files + !! TODO: Eliminate this parameter -! Defaults +!>@{ Default values for parameters logical, parameter :: report_unused_default = .false. logical, parameter :: unused_params_fatal_default = .false. logical, parameter :: log_to_stdout_default = .false. logical, parameter :: complete_doc_default = .true. logical, parameter :: minimal_doc_default = .true. +!!@} +!> The valid lines extracted from an input parameter file without comments type, private :: file_data_type ; private - integer :: num_lines = 0 - character(len=INPUT_STR_LENGTH), pointer, dimension(:) :: line => NULL() - logical, pointer, dimension(:) :: line_used => NULL() + integer :: num_lines = 0 !< The number of lines in this type + character(len=INPUT_STR_LENGTH), pointer, dimension(:) :: line => NULL() !< The line content + logical, pointer, dimension(:) :: line_used => NULL() !< If true, the line has been read end type file_data_type +!> A link in the list of variables that have already had override warnings issued type :: link_parameter ; private - type(link_parameter), pointer :: next => NULL() ! Facilitates linked list - character(len=80) :: name ! Parameter name - logical :: hasIssuedOverrideWarning = .false. ! Has a default value + type(link_parameter), pointer :: next => NULL() !< Facilitates linked list + character(len=80) :: name !< Parameter name + logical :: hasIssuedOverrideWarning = .false. !< Has a default value end type link_parameter +!> Specify the active parameter block type :: parameter_block ; private - character(len=240) :: name = '' ! Parameter name + character(len=240) :: name = '' !< The active parameter block name end type parameter_block +!> A structure that can be parsed to read and document run-time parameters. type, public :: param_file_type ; private - integer :: nfiles = 0 ! The number of open files. - integer :: iounit(MAX_PARAM_FILES) ! The unit number of an open file. - character(len=FILENAME_LENGTH) :: filename(MAX_PARAM_FILES) ! The names of the open files. - logical :: NetCDF_file(MAX_PARAM_FILES)! If true, the input file is in NetCDF. + integer :: nfiles = 0 !< The number of open files. + integer :: iounit(MAX_PARAM_FILES) !< The unit numbers of open files. + character(len=FILENAME_LENGTH) :: filename(MAX_PARAM_FILES) !< The names of the open files. + logical :: NetCDF_file(MAX_PARAM_FILES) !< If true, the input file is in NetCDF. ! This is not yet implemented. - type(file_data_type) :: param_data(MAX_PARAM_FILES) ! Structures that contain - ! the valid data lines from the parameter - ! files, enabling all subsequent reads of - ! parameter data to occur internally. - logical :: report_unused = report_unused_default ! If true, report any - ! parameter lines that are not used in the run. - logical :: unused_params_fatal = unused_params_fatal_default ! If true, kill - ! the run if there are any unused parameters. - logical :: log_to_stdout = log_to_stdout_default ! If true, all log - ! messages are also sent to stdout. - logical :: log_open = .false. ! True if the log file has been opened. - integer :: stdout, stdlog ! The units from stdout() and stdlog(). - character(len=240) :: doc_file ! A file where all run-time parameters, their - ! settings and defaults are documented. - logical :: complete_doc = complete_doc_default ! If true, document all - ! run-time parameters. - logical :: minimal_doc = minimal_doc_default ! If true, document only those - ! run-time parameters that differ from defaults. - type(doc_type), pointer :: doc => NULL() ! A structure that contains information - ! related to parameter documentation. - type(link_parameter), pointer :: chain => NULL() ! Facilitates linked list - type(parameter_block), pointer :: blockName => NULL() ! Name of active parameter block + type(file_data_type) :: param_data(MAX_PARAM_FILES) !< Structures that contain + !! the valid data lines from the parameter + !! files, enabling all subsequent reads of + !! parameter data to occur internally. + logical :: report_unused = report_unused_default !< If true, report any + !! parameter lines that are not used in the run. + logical :: unused_params_fatal = unused_params_fatal_default !< If true, kill + !! the run if there are any unused parameters. + logical :: log_to_stdout = log_to_stdout_default !< If true, all log + !! messages are also sent to stdout. + logical :: log_open = .false. !< True if the log file has been opened. + integer :: stdout !< The unit number from stdout(). + integer :: stdlog !< The unit number from stdlog(). + character(len=240) :: doc_file !< A file where all run-time parameters, their + !! settings and defaults are documented. + logical :: complete_doc = complete_doc_default !< If true, document all + !! run-time parameters. + logical :: minimal_doc = minimal_doc_default !< If true, document only those + !! run-time parameters that differ from defaults. + type(doc_type), pointer :: doc => NULL() !< A structure that contains information + !! related to parameter documentation. + type(link_parameter), pointer :: chain => NULL() !< Facilitates linked list + type(parameter_block), pointer :: blockName => NULL() !< Name of active parameter block end type param_file_type public read_param, open_param_file, close_param_file, log_param, log_version public doc_param, get_param public clearParameterBlock, openParameterBlock, closeParameterBlock +!> An overloaded interface to read various types of parameters interface read_param module procedure read_param_int, read_param_real, read_param_logical, & read_param_char, read_param_char_array, read_param_time, & read_param_int_array, read_param_real_array end interface +!> An overloaded interface to log the values of various types of parameters interface log_param module procedure log_param_int, log_param_real, log_param_logical, & log_param_char, log_param_time, & log_param_int_array, log_param_real_array end interface +!> An overloaded interface to read and log the values of various types of parameters interface get_param module procedure get_param_int, get_param_real, get_param_logical, & get_param_char, get_param_char_array, get_param_time, & get_param_int_array, get_param_real_array end interface + +!> An overloaded interface to log version information about modules interface log_version module procedure log_version_cs, log_version_plain end interface contains +!> Make the contents of a parameter input file availalble in a param_file_type subroutine open_param_file(filename, CS, checkable, component, doc_file_dir) - character(len=*), intent(in) :: filename - type(param_file_type), intent(inout) :: CS - logical, optional, intent(in) :: checkable - character(len=*), optional, intent(in) :: component - character(len=*), optional, intent(in) :: doc_file_dir + character(len=*), intent(in) :: filename !< An input file name, optionally with the full path + type(param_file_type), intent(inout) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + logical, optional, intent(in) :: checkable !< If this is false, it disables checks of this + !! file for unused parameters. The default is True. + character(len=*), optional, intent(in) :: component !< If present, this component name is used + !! to generate parameter documentation file names; the default is"MOM" + character(len=*), optional, intent(in) :: doc_file_dir !< An optional directory in which to write out + !! the documentation files. The default is effectively './'. + ! Local variables logical :: file_exists, unit_in_use, Netcdf_file, may_check integer :: ios, iounit, strlen, i character(len=240) :: doc_path - type(parameter_block), pointer :: block + type(parameter_block), pointer :: block => NULL() may_check = .true. ; if (present(checkable)) may_check = checkable @@ -244,17 +236,20 @@ subroutine open_param_file(filename, CS, checkable, component, doc_file_dir) end subroutine open_param_file +!> Close any open input files and deallocate memory associated with this param_file_type. +!! To use this type again, open_param_file would have to be called again. subroutine close_param_file(CS, quiet_close, component) - type(param_file_type), intent(inout) :: CS - logical, optional, intent(in) :: quiet_close - character(len=*), optional, intent(in) :: component -! Arguments: CS - the param_file_type to close -! (in,opt) quiet_close - if present and true, do not do any logging with this -! call. -! This include declares and sets the variable "version". -#include "version_variable.h" + type(param_file_type), intent(inout) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + logical, optional, intent(in) :: quiet_close !< if present and true, do not do any + !! logging with this call. + character(len=*), optional, intent(in) :: component !< If present, this component name is used + !! to generate parameter documentation file names + ! Local variables character(len=128) :: docfile_default character(len=40) :: mdl ! This module's name. + ! This include declares and sets the variable "version". +# include "version_variable.h" integer :: i, n, num_unused if (present(quiet_close)) then ; if (quiet_close) then @@ -337,18 +332,22 @@ subroutine close_param_file(CS, quiet_close, component) end subroutine close_param_file +!> Read the contents of a parameter input file, and store the contents in a +!! file_data_type after removing comments and simplifying white space subroutine populate_param_data(iounit, filename, param_data) - integer, intent(in) :: iounit - character(len=*), intent(in) :: filename - type(file_data_type), intent(inout) :: param_data + integer, intent(in) :: iounit !< The IO unit number that is open for filename + character(len=*), intent(in) :: filename !< An input file name, optionally with the full path + type(file_data_type), intent(inout) :: param_data !< A list of the input lines that set parameters + !! after comments have been stripped out. + ! Local variables character(len=INPUT_STR_LENGTH) :: line integer :: num_lines logical :: inMultiLineComment -! Find the number of keyword lines in a parameter file -! Allocate the space to hold the lines in param_data%line -! Populate param_data%line with the keyword lines from parameter file + ! Find the number of keyword lines in a parameter file + ! Allocate the space to hold the lines in param_data%line + ! Populate param_data%line with the keyword lines from parameter file if (iounit <= 0) return @@ -432,11 +431,15 @@ subroutine populate_param_data(iounit, filename, param_data) end subroutine populate_param_data + +!> Return True if a /* appears on this line without a closing */ function openMultiLineComment(string) - character(len=*), intent(in) :: string + character(len=*), intent(in) :: string !< The input string to process logical :: openMultiLineComment -! True if a /* appears on this line without a closing */ + + ! Local variables integer :: icom, last + openMultiLineComment = .false. last = lastNonCommentIndex(string)+1 icom = index(string(last:), "/*") @@ -447,39 +450,47 @@ function openMultiLineComment(string) icom = index(string(last:), "*/") ; if (icom > 0) openMultiLineComment=.false. end function openMultiLineComment +!> Return True if a */ appears on this line function closeMultiLineComment(string) - character(len=*), intent(in) :: string + character(len=*), intent(in) :: string !< The input string to process logical :: closeMultiLineComment ! True if a */ appears on this line closeMultiLineComment = .false. if (index(string, "*/")>0) closeMultiLineComment=.true. end function closeMultiLineComment +!> Find position of last character before any comments, As marked by "!", "//", or "/*" +!! following F90, C++, or C syntax function lastNonCommentIndex(string) - character(len=*), intent(in) :: string + character(len=*), intent(in) :: string !< The input string to process integer :: lastNonCommentIndex -! Find position of last character before any comments -! This s/r is the only place where a comment needs to be defined + + ! Local variables integer :: icom, last + + ! This subroutine is the only place where a comment needs to be defined last = len_trim(string) icom = index(string(:last), "!") ; if (icom > 0) last = icom-1 ! F90 style - icom = index(string(:last), "//") ; if (icom > 0) last = icom-1 ! C+ style + icom = index(string(:last), "//") ; if (icom > 0) last = icom-1 ! C++ style icom = index(string(:last), "/*") ; if (icom > 0) last = icom-1 ! C style lastNonCommentIndex = last end function lastNonCommentIndex +!> Find position of last non-blank character before any comments function lastNonCommentNonBlank(string) - character(len=*), intent(in) :: string + character(len=*), intent(in) :: string !< The input string to process integer :: lastNonCommentNonBlank -! Find position of last non-blank character before any comments + lastNonCommentNonBlank = len_trim(string(:lastNonCommentIndex(string))) ! Ignore remaining trailing blanks end function lastNonCommentNonBlank +!> Returns a string with tabs replaced by a blank function replaceTabs(string) - character(len=*), intent(in) :: string + character(len=*), intent(in) :: string !< The input string to process character(len=len(string)) :: replaceTabs -! Returns string with tabs replaced by a ablank + integer :: i + do i=1, len(string) if (string(i:i)==achar(9)) then replaceTabs(i:i)=" " @@ -489,24 +500,29 @@ function replaceTabs(string) enddo end function replaceTabs +!> Trims comments and leading blanks from string function removeComments(string) - character(len=*), intent(in) :: string + character(len=*), intent(in) :: string !< The input string to process character(len=len(string)) :: removeComments -! Trims comments and leading blanks from string + integer :: last + removeComments=repeat(" ",len(string)) last = lastNonCommentNonBlank(string) removeComments(:last)=adjustl(string(:last)) ! Copy only the non-comment part of string end function removeComments +!> Constructs a string with all repeated whitespace replaced with single blanks +!! and insert white space where it helps delineate tokens (e.g. around =) function simplifyWhiteSpace(string) - character(len=*), intent(in) :: string + character(len=*), intent(in) :: string !< A string to modify to simpify white space character(len=len(string)+16) :: simplifyWhiteSpace -! Constructs a string with all repeated whitespace replaced with single blanks -! and insert white space where it helps delineate tokens (e.g. around =) + + ! Local variables integer :: i,j logical :: nonBlank = .false., insideString = .false. character(len=1) :: quoteChar=" " + nonBlank = .false.; insideString = .false. ! NOTE: For some reason this line is needed?? i=0 simplifyWhiteSpace=repeat(" ",len(string)+16) @@ -551,16 +567,16 @@ function simplifyWhiteSpace(string) endif end function simplifyWhiteSpace +!> This subroutine reads the value of an integer model parameter from a parameter file. subroutine read_param_int(CS, varname, value, fail_if_missing) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: varname - integer, intent(inout) :: value - logical, optional, intent(in) :: fail_if_missing -! This subroutine determines the value of an integer model parameter -! from a parameter file. The arguments are the unit of the open file -! which is to be read, the (case-sensitive) variable name, the variable -! where the value is to be stored, and (optionally) a flag indicating -! whether to fail if this parameter can not be found. + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + integer, intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file + ! Local variables character(len=INPUT_STR_LENGTH) :: value_string(1) logical :: found, defined @@ -583,16 +599,16 @@ subroutine read_param_int(CS, varname, value, fail_if_missing) ' parsing "'//trim(value_string(1))//'"') end subroutine read_param_int +!> This subroutine reads the values of an array of integer model parameters from a parameter file. subroutine read_param_int_array(CS, varname, value, fail_if_missing) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: varname - integer, intent(inout) :: value(:) - logical, optional, intent(in) :: fail_if_missing -! This subroutine determines the value of an integer model parameter -! from a parameter file. The arguments are the unit of the open file -! which is to be read, the (case-sensitive) variable name, the variable -! where the value is to be stored, and (optionally) a flag indicating -! whether to fail if this parameter can not be found. + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + integer, dimension(:), intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file + ! Local variables character(len=INPUT_STR_LENGTH) :: value_string(1) logical :: found, defined @@ -616,22 +632,26 @@ subroutine read_param_int_array(CS, varname, value, fail_if_missing) ' parsing "'//trim(value_string(1))//'"') end subroutine read_param_int_array -subroutine read_param_real(CS, varname, value, fail_if_missing) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: varname - real, intent(inout) :: value - logical, optional, intent(in) :: fail_if_missing -! This subroutine determines the value of an integer model parameter -! from a parameter file. The arguments are the unit of the open file -! which is to be read, the (case-sensitive) variable name, the variable -! where the value is to be stored, and (optionally) a flag indicating -! whether to fail if this parameter can not be found. +!> This subroutine reads the value of a real model parameter from a parameter file. +subroutine read_param_real(CS, varname, value, fail_if_missing, scale) + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + real, intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file + real, optional, intent(in) :: scale !< A scaling factor that the parameter is multiplied + !! by before it is returned. + + ! Local variables character(len=INPUT_STR_LENGTH) :: value_string(1) logical :: found, defined call get_variable_line(CS, varname, found, defined, value_string) if (found .and. defined .and. (LEN_TRIM(value_string(1)) > 0)) then read(value_string(1),*,err=1003) value + if (present(scale)) value = scale*value else if (present(fail_if_missing)) then ; if (fail_if_missing) then if (.not.found) then @@ -648,23 +668,28 @@ subroutine read_param_real(CS, varname, value, fail_if_missing) ' parsing "'//trim(value_string(1))//'"') end subroutine read_param_real -subroutine read_param_real_array(CS, varname, value, fail_if_missing) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: varname - real, intent(inout) :: value(:) - logical, optional, intent(in) :: fail_if_missing -! This subroutine determines the value of an integer model parameter -! from a parameter file. The arguments are the unit of the open file -! which is to be read, the (case-sensitive) variable name, the variable -! where the value is to be stored, and (optionally) a flag indicating -! whether to fail if this parameter can not be found. +!> This subroutine reads the values of an array of real model parameters from a parameter file. +subroutine read_param_real_array(CS, varname, value, fail_if_missing, scale) + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + real, dimension(:), intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file + real, optional, intent(in) :: scale !< A scaling factor that the parameter is multiplied + !! by before it is returned. + + ! Local variables character(len=INPUT_STR_LENGTH) :: value_string(1) logical :: found, defined call get_variable_line(CS, varname, found, defined, value_string) if (found .and. defined .and. (LEN_TRIM(value_string(1)) > 0)) then read(value_string(1),*,end=991,err=1004) value - 991 return +991 continue + if (present(scale)) value(:) = scale*value(:) + return else if (present(fail_if_missing)) then ; if (fail_if_missing) then if (.not.found) then @@ -681,16 +706,16 @@ subroutine read_param_real_array(CS, varname, value, fail_if_missing) ' parsing "'//trim(value_string(1))//'"') end subroutine read_param_real_array +!> This subroutine reads the value of a character string model parameter from a parameter file. subroutine read_param_char(CS, varname, value, fail_if_missing) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: varname - character(len=*), intent(inout) :: value - logical, optional, intent(in) :: fail_if_missing -! This subroutine determines the value of an integer model parameter -! from a parameter file. The arguments are the unit of the open file -! which is to be read, the (case-sensitive) variable name, the variable -! where the value is to be stored, and (optionally) a flag indicating -! whether to fail if this parameter can not be found. + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + character(len=*), intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file + ! Local variables character(len=INPUT_STR_LENGTH) :: value_string(1) logical :: found, defined @@ -704,16 +729,17 @@ subroutine read_param_char(CS, varname, value, fail_if_missing) end subroutine read_param_char +!> This subroutine reads the values of an array of character string model parameters from a parameter file. subroutine read_param_char_array(CS, varname, value, fail_if_missing) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: varname - character(len=*), intent(inout) :: value(:) - logical, optional, intent(in) :: fail_if_missing -! This subroutine determines the value of an integer model parameter -! from a parameter file. The arguments are the unit of the open file -! which is to be read, the (case-sensitive) variable name, the variable -! where the value is to be stored, and (optionally) a flag indicating -! whether to fail if this parameter can not be found. + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + character(len=*), dimension(:), intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file + + ! Local variables character(len=INPUT_STR_LENGTH) :: value_string(1), loc_string logical :: found, defined integer :: i, i_out @@ -741,16 +767,17 @@ subroutine read_param_char_array(CS, varname, value, fail_if_missing) end subroutine read_param_char_array +!> This subroutine reads the value of a logical model parameter from a parameter file. subroutine read_param_logical(CS, varname, value, fail_if_missing) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: varname - logical, intent(inout) :: value - logical, optional, intent(in) :: fail_if_missing -! This subroutine determines the value of an integer model parameter -! from a parameter file. The arguments are the unit of the open file -! which is to be read, the (case-sensitive) variable name, the variable -! where the value is to be stored, and (optionally) a flag indicating -! whether to fail if this parameter can not be found. + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + logical, intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file + + ! Local variables character(len=INPUT_STR_LENGTH) :: value_string(1) logical :: found, defined @@ -763,25 +790,26 @@ subroutine read_param_logical(CS, varname, value, fail_if_missing) endif ; endif end subroutine read_param_logical - +!> This subroutine reads the value of a time_type model parameter from a parameter file. subroutine read_param_time(CS, varname, value, timeunit, fail_if_missing, date_format) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: varname - type(time_type), intent(inout) :: value - real, optional, intent(in) :: timeunit - logical, optional, intent(in) :: fail_if_missing - logical, optional, intent(out) :: date_format -! This subroutine determines the value of an time-type model parameter -! from a parameter file. The arguments are the unit of the open file -! which is to be read, the (case-sensitive) variable name, the variable -! where the value is to be stored, and (optionally) a flag indicating -! whether to fail if this parameter can not be found. The unique argument -! to read time is the number of seconds to use as the unit of time being read. + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + type(time_type), intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file + real, optional, intent(in) :: timeunit !< The number of seconds in a time unit for real-number input. + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file + logical, optional, intent(out) :: date_format !< If present, this indicates whether this + !! parameter was read in a date format, so that it can + !! later be logged in the same format. + + ! Local variables character(len=INPUT_STR_LENGTH) :: value_string(1) character(len=240) :: err_msg logical :: found, defined real :: real_time, time_unit - integer :: days, secs, vals(7) + integer :: vals(7) if (present(date_format)) date_format = .false. @@ -814,10 +842,8 @@ subroutine read_param_time(CS, varname, value, timeunit, fail_if_missing, date_f else time_unit = 1.0 ; if (present(timeunit)) time_unit = timeunit read( value_string(1), *) real_time - days = int(real_time*(time_unit/86400.0)) - secs = int(floor((real_time*(time_unit/86400.0)-days)*86400.0 + 0.5)) - value = set_time(secs, days) - endif + value = real_to_time(real_time*time_unit) + endif else if (present(fail_if_missing)) then ; if (fail_if_missing) then if (.not.found) then @@ -834,8 +860,9 @@ subroutine read_param_time(CS, varname, value, timeunit, fail_if_missing, date_f trim(varname)// ' parsing "'//trim(value_string(1))//'"') end subroutine read_param_time +!> This function removes single and double quotes from a character string function strip_quotes(val_str) - character(len=*) :: val_str + character(len=*) :: val_str !< The character string to work on character(len=INPUT_STR_LENGTH) :: strip_quotes ! Local variables integer :: i @@ -854,13 +881,20 @@ function strip_quotes(val_str) enddo end function strip_quotes +!> This subtoutine extracts the contents of lines in the param_file_type that refer to +!! a named parameter. The value_string that is returned must be interepreted in a way +!! that depends on the type of this variable. subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsLogical) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: varname - logical, intent(out) :: found, defined - character(len=*), intent(out) :: value_string(:) - logical, optional, intent(in) :: paramIsLogical + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + logical, intent(out) :: found !< If true, this parameter has been found in CS + logical, intent(out) :: defined !< If true, this parameter is set (or true) in the CS + character(len=*), intent(out) :: value_string(:) !< A string that encodes the new value + logical, optional, intent(in) :: paramIsLogical !< If true, this is a logical parameter + !! that can be simply defined without parsing a value_string. + ! Local variables character(len=INPUT_STR_LENGTH) :: val_str, lname, origLine character(len=INPUT_STR_LENGTH) :: line, continuationBuffer, blockName character(len=FILENAME_LENGTH) :: filename @@ -885,7 +919,7 @@ subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsL ! return variables indicating whether this variable is defined and the string ! that contains the value of this variable. found = .false. - oval = 0; ival = 0; + oval = 0; ival = 0 max_vals = SIZE(value_string) do is=1,max_vals ; value_string(is) = " " ; enddo @@ -1170,18 +1204,22 @@ subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsL end subroutine get_variable_line -subroutine flag_line_as_read(line_used,count) - logical, dimension(:), pointer :: line_used - integer, intent(in) :: count +!> Record that a line has been used to set a parameter +subroutine flag_line_as_read(line_used, count) + logical, dimension(:), pointer :: line_used !< A structure indicating which lines have been read + integer, intent(in) :: count !< The parameter on this line number has been read line_used(count) = .true. end subroutine flag_line_as_read +!> Returns true if an override warning has been issued for the variable varName function overrideWarningHasBeenIssued(chain, varName) - type(link_parameter), pointer :: chain - character(len=*), intent(in) :: varName + type(link_parameter), pointer :: chain !< The linked list of variables that have already had + !! override warnings issued + character(len=*), intent(in) :: varName !< The name of the variable being queried for warnings logical :: overrideWarningHasBeenIssued -! Returns true if an override warning has been issued for the variable varName - type(link_parameter), pointer :: newLink, this + ! Local variables + type(link_parameter), pointer :: newLink => NULL(), this => NULL() + overrideWarningHasBeenIssued = .false. this => chain do while( associated(this) ) @@ -1234,18 +1272,23 @@ subroutine log_version_plain(modulename, version) end subroutine log_version_plain +!> Log the name and value of an integer model parameter in documentation files. subroutine log_param_int(CS, modulename, varname, value, desc, units, & default, layoutParam, debuggingParam) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: modulename - character(len=*), intent(in) :: varname - integer, intent(in) :: value - character(len=*), optional, intent(in) :: desc, units - integer, optional, intent(in) :: default - logical, optional, intent(in) :: layoutParam - logical, optional, intent(in) :: debuggingParam -! This subroutine writes the value of an integer parameter to a log file, -! along with its name and the module it came from. + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: modulename !< The name of the module using this parameter + character(len=*), intent(in) :: varname !< The name of the parameter to log + integer, intent(in) :: value !< The value of the parameter to log + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this parameter is not written to a doc file + character(len=*), optional, intent(in) :: units !< The units of this parameter + integer, optional, intent(in) :: default !< The default value of the parameter + logical, optional, intent(in) :: layoutParam !< If present and true, this parameter is + !! logged in the layout parameter file + logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is + !! logged in the debugging parameter file + character(len=240) :: mesg, myunits write(mesg, '(" ",a," ",a,": ",a)') trim(modulename), trim(varname), trim(left_int(value)) @@ -1261,18 +1304,23 @@ subroutine log_param_int(CS, modulename, varname, value, desc, units, & end subroutine log_param_int +!> Log the name and values of an array of integer model parameter in documentation files. subroutine log_param_int_array(CS, modulename, varname, value, desc, & units, default, layoutParam, debuggingParam) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: modulename - character(len=*), intent(in) :: varname - integer, intent(in) :: value(:) - character(len=*), optional, intent(in) :: desc, units - integer, optional, intent(in) :: default - logical, optional, intent(in) :: layoutParam - logical, optional, intent(in) :: debuggingParam -! This subroutine writes the value of an integer parameter to a log file, -! along with its name and the module it came from. + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: modulename !< The name of the module using this parameter + character(len=*), intent(in) :: varname !< The name of the parameter to log + integer, dimension(:), intent(in) :: value !< The value of the parameter to log + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this parameter is not written to a doc file + character(len=*), optional, intent(in) :: units !< The units of this parameter + integer, optional, intent(in) :: default !< The default value of the parameter + logical, optional, intent(in) :: layoutParam !< If present and true, this parameter is + !! logged in the layout parameter file + logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is + !! logged in the debugging parameter file + character(len=1320) :: mesg character(len=240) :: myunits @@ -1289,17 +1337,21 @@ subroutine log_param_int_array(CS, modulename, varname, value, desc, & end subroutine log_param_int_array +!> Log the name and value of a real model parameter in documentation files. subroutine log_param_real(CS, modulename, varname, value, desc, units, & default, debuggingParam) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: modulename - character(len=*), intent(in) :: varname - real, intent(in) :: value - character(len=*), optional, intent(in) :: desc, units - real, optional, intent(in) :: default - logical, optional, intent(in) :: debuggingParam -! This subroutine writes the value of a real parameter to a log file, -! along with its name and the module it came from. + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: modulename !< The name of the calling module + character(len=*), intent(in) :: varname !< The name of the parameter to log + real, intent(in) :: value !< The value of the parameter to log + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this parameter is not written to a doc file + character(len=*), optional, intent(in) :: units !< The units of this parameter + real, optional, intent(in) :: default !< The default value of the parameter + logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is + !! logged in the debugging parameter file + character(len=240) :: mesg, myunits write(mesg, '(" ",a," ",a,": ",a)') & @@ -1316,16 +1368,19 @@ subroutine log_param_real(CS, modulename, varname, value, desc, units, & end subroutine log_param_real +!> Log the name and values of an array of real model parameter in documentation files. subroutine log_param_real_array(CS, modulename, varname, value, desc, & units, default) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: modulename - character(len=*), intent(in) :: varname - real, intent(in) :: value(:) - character(len=*), optional, intent(in) :: desc, units - real, optional, intent(in) :: default -! This subroutine writes the value of a real parameter to a log file, -! along with its name and the module it came from. + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: modulename !< The name of the calling module + character(len=*), intent(in) :: varname !< The name of the parameter to log + real, dimension(:), intent(in) :: value !< The value of the parameter to log + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this parameter is not written to a doc file + character(len=*), optional, intent(in) :: units !< The units of this parameter + real, optional, intent(in) :: default !< The default value of the parameter + character(len=1320) :: mesg character(len=240) :: myunits @@ -1345,18 +1400,23 @@ subroutine log_param_real_array(CS, modulename, varname, value, desc, & end subroutine log_param_real_array +!> Log the name and value of a logical model parameter in documentation files. subroutine log_param_logical(CS, modulename, varname, value, desc, & units, default, layoutParam, debuggingParam) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: modulename - character(len=*), intent(in) :: varname - logical, intent(in) :: value - character(len=*), optional, intent(in) :: desc, units - logical, optional, intent(in) :: default - logical, optional, intent(in) :: layoutParam - logical, optional, intent(in) :: debuggingParam -! This subroutine writes the value of a logical parameter to a log file, -! along with its name and the module it came from. + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: modulename !< The name of the calling module + character(len=*), intent(in) :: varname !< The name of the parameter to log + logical, intent(in) :: value !< The value of the parameter to log + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this parameter is not written to a doc file + character(len=*), optional, intent(in) :: units !< The units of this parameter + logical, optional, intent(in) :: default !< The default value of the parameter + logical, optional, intent(in) :: layoutParam !< If present and true, this parameter is + !! logged in the layout parameter file + logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is + !! logged in the debugging parameter file + character(len=240) :: mesg, myunits if (value) then @@ -1376,18 +1436,23 @@ subroutine log_param_logical(CS, modulename, varname, value, desc, & end subroutine log_param_logical +!> Log the name and value of a character string model parameter in documentation files. subroutine log_param_char(CS, modulename, varname, value, desc, units, & default, layoutParam, debuggingParam) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: modulename - character(len=*), intent(in) :: varname - character(len=*), intent(in) :: value - character(len=*), optional, intent(in) :: desc, units - character(len=*), optional, intent(in) :: default - logical, optional, intent(in) :: layoutParam - logical, optional, intent(in) :: debuggingParam -! This subroutine writes the value of a character string parameter to a log -! file, along with its name and the module it came from. + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: modulename !< The name of the calling module + character(len=*), intent(in) :: varname !< The name of the parameter to log + character(len=*), intent(in) :: value !< The value of the parameter to log + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this parameter is not written to a doc file + character(len=*), optional, intent(in) :: units !< The units of this parameter + character(len=*), optional, intent(in) :: default !< The default value of the parameter + logical, optional, intent(in) :: layoutParam !< If present and true, this parameter is + !! logged in the layout parameter file + logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is + !! logged in the debugging parameter file + character(len=240) :: mesg, myunits write(mesg, '(" ",a," ",a,": ",a)') & @@ -1408,17 +1473,25 @@ end subroutine log_param_char !! along with its name and the module it came from. subroutine log_param_time(CS, modulename, varname, value, desc, units, & default, timeunit, layoutParam, debuggingParam, log_date) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: modulename - character(len=*), intent(in) :: varname - type(time_type), intent(in) :: value - character(len=*), optional, intent(in) :: desc, units - type(time_type), optional, intent(in) :: default - real, optional, intent(in) :: timeunit + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: modulename !< The name of the calling module + character(len=*), intent(in) :: varname !< The name of the parameter to log + type(time_type), intent(in) :: value !< The value of the parameter to log + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this parameter is not written to a doc file + character(len=*), optional, intent(in) :: units !< The units of this parameter + type(time_type), optional, intent(in) :: default !< The default value of the parameter + real, optional, intent(in) :: timeunit !< The number of seconds in a time unit for + !! real-number output. logical, optional, intent(in) :: log_date !< If true, log the time_type in date format. - logical, optional, intent(in) :: layoutParam - logical, optional, intent(in) :: debuggingParam + !! If missing the default is false. + logical, optional, intent(in) :: layoutParam !< If present and true, this parameter is + !! logged in the layout parameter file + logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is + !! logged in the debugging parameter file + ! Local variables real :: real_time, real_default logical :: use_timeunit, date_format character(len=240) :: mesg, myunits @@ -1492,6 +1565,7 @@ function convert_date_to_string(date) result(date_string) type(time_type), intent(in) :: date !< The date to be translated into a string. character(len=40) :: date_string !< A date string in a format like YYYY-MM-DD HH:MM:SS.sss + ! Local variables character(len=40) :: sub_string real :: real_secs integer :: yrs, mons, days, hours, mins, secs, ticks, ticks_per_sec @@ -1516,21 +1590,35 @@ function convert_date_to_string(date) result(date_string) end function convert_date_to_string +!> This subroutine reads the value of an integer model parameter from a parameter file +!! and logs it in documentation files. subroutine get_param_int(CS, modulename, varname, value, desc, units, & default, fail_if_missing, do_not_read, do_not_log, & static_value, layoutParam, debuggingParam) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: modulename - character(len=*), intent(in) :: varname - integer, intent(inout) :: value - character(len=*), optional, intent(in) :: desc, units - integer, optional, intent(in) :: default, static_value - logical, optional, intent(in) :: fail_if_missing - logical, optional, intent(in) :: do_not_read, do_not_log - logical, optional, intent(in) :: layoutParam - logical, optional, intent(in) :: debuggingParam -! This subroutine writes the value of a real parameter to a log file, -! along with its name and the module it came from. + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: modulename !< The name of the calling module + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + integer, intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file and logged + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this parameter is not written to a doc file + character(len=*), optional, intent(in) :: units !< The units of this parameter + integer, optional, intent(in) :: default !< The default value of the parameter + integer, optional, intent(in) :: static_value !< If this parameter is static, it takes + !! this value, which can be compared for consistency with + !! what is in the parameter file. + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file + logical, optional, intent(in) :: do_not_read !< If present and true, do not read a + !! value for this parameter, although it might be logged. + logical, optional, intent(in) :: do_not_log !< If present and true, do not log this + !! parameter to the documentation files + logical, optional, intent(in) :: layoutParam !< If present and true, this parameter is + !! logged in the layout parameter file + logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is + !! logged in the debugging parameter file + logical :: do_read, do_log do_read = .true. ; if (present(do_not_read)) do_read = .not.do_not_read @@ -1549,21 +1637,35 @@ subroutine get_param_int(CS, modulename, varname, value, desc, units, & end subroutine get_param_int +!> This subroutine reads the values of an array of integer model parameters from a parameter file +!! and logs them in documentation files. subroutine get_param_int_array(CS, modulename, varname, value, desc, units, & default, fail_if_missing, do_not_read, do_not_log, & static_value, layoutParam, debuggingParam) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: modulename - character(len=*), intent(in) :: varname - integer, intent(inout) :: value(:) - character(len=*), optional, intent(in) :: desc, units - integer, optional, intent(in) :: default, static_value - logical, optional, intent(in) :: fail_if_missing - logical, optional, intent(in) :: do_not_read, do_not_log - logical, optional, intent(in) :: layoutParam - logical, optional, intent(in) :: debuggingParam -! This subroutine writes the value of a real parameter to a log file, -! along with its name and the module it came from. + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: modulename !< The name of the calling module + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + integer, dimension(:), intent(inout) :: value !< The value of the parameter that may be reset + !! from the parameter file + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this parameter is not written to a doc file + character(len=*), optional, intent(in) :: units !< The units of this parameter + integer, optional, intent(in) :: default !< The default value of the parameter + integer, optional, intent(in) :: static_value !< If this parameter is static, it takes + !! this value, which can be compared for consistency with + !! what is in the parameter file. + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file + logical, optional, intent(in) :: do_not_read !< If present and true, do not read a + !! value for this parameter, although it might be logged. + logical, optional, intent(in) :: do_not_log !< If present and true, do not log this + !! parameter to the documentation files + logical, optional, intent(in) :: layoutParam !< If present and true, this parameter is + !! logged in the layout parameter file + logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is + !! logged in the debugging parameter file + logical :: do_read, do_log do_read = .true. ; if (present(do_not_read)) do_read = .not.do_not_read @@ -1582,20 +1684,37 @@ subroutine get_param_int_array(CS, modulename, varname, value, desc, units, & end subroutine get_param_int_array +!> This subroutine reads the value of a real model parameter from a parameter file +!! and logs it in documentation files. subroutine get_param_real(CS, modulename, varname, value, desc, units, & default, fail_if_missing, do_not_read, do_not_log, & - static_value, debuggingParam) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: modulename - character(len=*), intent(in) :: varname - real, intent(inout) :: value - character(len=*), optional, intent(in) :: desc, units - real, optional, intent(in) :: default, static_value - logical, optional, intent(in) :: fail_if_missing - logical, optional, intent(in) :: do_not_read, do_not_log - logical, optional, intent(in) :: debuggingParam -! This subroutine writes the value of a real parameter to a log file, -! along with its name and the module it came from. + static_value, debuggingParam, scale, unscaled) + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: modulename !< The name of the calling module + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + real, intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file and logged + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this parameter is not written to a doc file + character(len=*), optional, intent(in) :: units !< The units of this parameter + real, optional, intent(in) :: default !< The default value of the parameter + real, optional, intent(in) :: static_value !< If this parameter is static, it takes + !! this value, which can be compared for consistency with + !! what is in the parameter file. + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file + logical, optional, intent(in) :: do_not_read !< If present and true, do not read a + !! value for this parameter, although it might be logged. + logical, optional, intent(in) :: do_not_log !< If present and true, do not log this + !! parameter to the documentation files + logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is + !! logged in the debugging parameter file + real, optional, intent(in) :: scale !< A scaling factor that the parameter is + !! multiplied by before it is returned. + real, optional, intent(out) :: unscaled !< The value of the parameter that would be + !! returned without any multiplication by a scaling factor. + logical :: do_read, do_log do_read = .true. ; if (present(do_not_read)) do_read = .not.do_not_read @@ -1612,20 +1731,39 @@ subroutine get_param_real(CS, modulename, varname, value, desc, units, & default, debuggingParam) endif + if (present(unscaled)) unscaled = value + if (present(scale)) value = scale*value + end subroutine get_param_real +!> This subroutine reads the values of an array of real model parameters from a parameter file +!! and logs them in documentation files. subroutine get_param_real_array(CS, modulename, varname, value, desc, units, & - default, fail_if_missing, do_not_read, do_not_log, static_value) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: modulename - character(len=*), intent(in) :: varname - real, intent(inout) :: value(:) - character(len=*), optional, intent(in) :: desc, units - real, optional, intent(in) :: default, static_value - logical, optional, intent(in) :: fail_if_missing - logical, optional, intent(in) :: do_not_read, do_not_log -! This subroutine writes the value of a real parameter to a log file, -! along with its name and the module it came from. + default, fail_if_missing, do_not_read, do_not_log, static_value, scale, unscaled) + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: modulename !< The name of the calling module + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + real, dimension(:), intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file and logged + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this parameter is not written to a doc file + character(len=*), optional, intent(in) :: units !< The units of this parameter + real, optional, intent(in) :: default !< The default value of the parameter + real, optional, intent(in) :: static_value !< If this parameter is static, it takes + !! this value, which can be compared for consistency with + !! what is in the parameter file. + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file + logical, optional, intent(in) :: do_not_read !< If present and true, do not read a + !! value for this parameter, although it might be logged. + logical, optional, intent(in) :: do_not_log !< If present and true, do not log this + !! parameter to the documentation files + real, optional, intent(in) :: scale !< A scaling factor that the parameter is + !! multiplied by before it is returned. + real, dimension(:), optional, intent(out) :: unscaled !< The value of the parameter that would be + !! returned without any multiplication by a scaling factor. + logical :: do_read, do_log do_read = .true. ; if (present(do_not_read)) do_read = .not.do_not_read @@ -1642,23 +1780,40 @@ subroutine get_param_real_array(CS, modulename, varname, value, desc, units, & units, default) endif + if (present(unscaled)) unscaled(:) = value(:) + if (present(scale)) value(:) = scale*value(:) + end subroutine get_param_real_array +!> This subroutine reads the value of a character string model parameter from a parameter file +!! and logs it in documentation files. subroutine get_param_char(CS, modulename, varname, value, desc, units, & default, fail_if_missing, do_not_read, do_not_log, & static_value, layoutParam, debuggingParam) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: modulename - character(len=*), intent(in) :: varname - character(len=*), intent(inout) :: value - character(len=*), optional, intent(in) :: desc, units - character(len=*), optional, intent(in) :: default, static_value - logical, optional, intent(in) :: fail_if_missing - logical, optional, intent(in) :: do_not_read, do_not_log - logical, optional, intent(in) :: layoutParam - logical, optional, intent(in) :: debuggingParam -! This subroutine writes the value of a real parameter to a log file, -! along with its name and the module it came from. + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: modulename !< The name of the calling module + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + character(len=*), intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file and logged + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this parameter is not written to a doc file + character(len=*), optional, intent(in) :: units !< The units of this parameter + character(len=*), optional, intent(in) :: default !< The default value of the parameter + character(len=*), optional, intent(in) :: static_value !< If this parameter is static, it takes + !! this value, which can be compared for consistency with + !! what is in the parameter file. + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file + logical, optional, intent(in) :: do_not_read !< If present and true, do not read a + !! value for this parameter, although it might be logged. + logical, optional, intent(in) :: do_not_log !< If present and true, do not log this + !! parameter to the documentation files + logical, optional, intent(in) :: layoutParam !< If present and true, this parameter is + !! logged in the layout parameter file + logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is + !! logged in the debugging parameter file + logical :: do_read, do_log do_read = .true. ; if (present(do_not_read)) do_read = .not.do_not_read @@ -1677,18 +1832,31 @@ subroutine get_param_char(CS, modulename, varname, value, desc, units, & end subroutine get_param_char +!> This subroutine reads the values of an array of character string model parameters +!! from a parameter file and logs them in documentation files. subroutine get_param_char_array(CS, modulename, varname, value, desc, units, & default, fail_if_missing, do_not_read, do_not_log, static_value) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: modulename - character(len=*), intent(in) :: varname - character(len=*), intent(inout) :: value(:) - character(len=*), optional, intent(in) :: desc, units - character(len=*), optional, intent(in) :: default, static_value - logical, optional, intent(in) :: fail_if_missing - logical, optional, intent(in) :: do_not_read, do_not_log -! This subroutine writes the value of a real parameter to a log file, -! along with its name and the module it came from. + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: modulename !< The name of the calling module + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + character(len=*), dimension(:), intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file and logged + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this parameter is not written to a doc file + character(len=*), optional, intent(in) :: units !< The units of this parameter + character(len=*), optional, intent(in) :: default !< The default value of the parameter + character(len=*), optional, intent(in) :: static_value !< If this parameter is static, it takes + !! this value, which can be compared for consistency with + !! what is in the parameter file. + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file + logical, optional, intent(in) :: do_not_read !< If present and true, do not read a + !! value for this parameter, although it might be logged. + logical, optional, intent(in) :: do_not_log !< If present and true, do not log this + !! parameter to the documentation files + + ! Local variables logical :: do_read, do_log integer :: i, len_tot, len_val character(len=240) :: cat_val @@ -1717,21 +1885,35 @@ subroutine get_param_char_array(CS, modulename, varname, value, desc, units, & end subroutine get_param_char_array +!> This subroutine reads the value of a logical model parameter from a parameter file +!! and logs it in documentation files. subroutine get_param_logical(CS, modulename, varname, value, desc, units, & default, fail_if_missing, do_not_read, do_not_log, & static_value, layoutParam, debuggingParam) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: modulename - character(len=*), intent(in) :: varname - logical, intent(inout) :: value - character(len=*), optional, intent(in) :: desc, units - logical, optional, intent(in) :: default, static_value - logical, optional, intent(in) :: fail_if_missing - logical, optional, intent(in) :: do_not_read, do_not_log - logical, optional, intent(in) :: layoutParam - logical, optional, intent(in) :: debuggingParam -! This subroutine writes the value of a real parameter to a log file, -! along with its name and the module it came from. + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: modulename !< The name of the calling module + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + logical, intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file and logged + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this parameter is not written to a doc file + character(len=*), optional, intent(in) :: units !< The units of this parameter + logical, optional, intent(in) :: default !< The default value of the parameter + logical, optional, intent(in) :: static_value !< If this parameter is static, it takes + !! this value, which can be compared for consistency with + !! what is in the parameter file. + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file + logical, optional, intent(in) :: do_not_read !< If present and true, do not read a + !! value for this parameter, although it might be logged. + logical, optional, intent(in) :: do_not_log !< If present and true, do not log this + !! parameter to the documentation files + logical, optional, intent(in) :: layoutParam !< If present and true, this parameter is + !! logged in the layout parameter file + logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is + !! logged in the debugging parameter file + logical :: do_read, do_log do_read = .true. ; if (present(do_not_read)) do_read = .not.do_not_read @@ -1750,24 +1932,40 @@ subroutine get_param_logical(CS, modulename, varname, value, desc, units, & end subroutine get_param_logical +!> This subroutine reads the value of a time-type model parameter from a parameter file +!! and logs it in documentation files. subroutine get_param_time(CS, modulename, varname, value, desc, units, & default, fail_if_missing, do_not_read, do_not_log, & timeunit, static_value, layoutParam, debuggingParam, & log_as_date) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: modulename - character(len=*), intent(in) :: varname - type(time_type), intent(inout) :: value - character(len=*), optional, intent(in) :: desc, units - type(time_type), optional, intent(in) :: default, static_value - logical, optional, intent(in) :: fail_if_missing - logical, optional, intent(in) :: do_not_read, do_not_log - real, optional, intent(in) :: timeunit - logical, optional, intent(in) :: layoutParam - logical, optional, intent(in) :: debuggingParam - logical, optional, intent(in) :: log_as_date -! This subroutine writes the value of a real parameter to a log file, -! along with its name and the module it came from. + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: modulename !< The name of the calling module + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + type(time_type), intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file and logged + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this parameter is not written to a doc file + character(len=*), optional, intent(in) :: units !< The units of this parameter + type(time_type), optional, intent(in) :: default !< The default value of the parameter + type(time_type), optional, intent(in) :: static_value !< If this parameter is static, it takes + !! this value, which can be compared for consistency with + !! what is in the parameter file. + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file + logical, optional, intent(in) :: do_not_read !< If present and true, do not read a + !! value for this parameter, although it might be logged. + logical, optional, intent(in) :: do_not_log !< If present and true, do not log this + !! parameter to the documentation files + real, optional, intent(in) :: timeunit !< The number of seconds in a time unit for + !! real-number input to be translated to a time. + logical, optional, intent(in) :: layoutParam !< If present and true, this parameter is + !! logged in the layout parameter file + logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is + !! logged in the debugging parameter file + logical, optional, intent(in) :: log_as_date !< If true, log the time_type in date + !! format. The default is false. + logical :: do_read, do_log, date_format, log_date do_read = .true. ; if (present(do_not_read)) do_read = .not.do_not_read @@ -1791,10 +1989,12 @@ end subroutine get_param_time ! ----------------------------------------------------------------------------- +!> Resets the parameter block name to blank subroutine clearParameterBlock(CS) - type(param_file_type), intent(in) :: CS -! Resets the parameter block name to blank - type(parameter_block), pointer :: block + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + + type(parameter_block), pointer :: block => NULL() if (associated(CS%blockName)) then block => CS%blockName block%name = '' @@ -1804,12 +2004,14 @@ subroutine clearParameterBlock(CS) endif end subroutine clearParameterBlock +!> Tags blockName onto the end of the active parameter block name subroutine openParameterBlock(CS,blockName,desc) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: blockName - character(len=*), optional, intent(in) :: desc -! Tags blockName onto the end of the active parameter block name - type(parameter_block), pointer :: block + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: blockName !< The name of a parameter block being added + character(len=*), optional, intent(in) :: desc !< A description of the parameter block being added + + type(parameter_block), pointer :: block => NULL() if (associated(CS%blockName)) then block => CS%blockName block%name = pushBlockLevel(block%name,blockName) @@ -1820,10 +2022,12 @@ subroutine openParameterBlock(CS,blockName,desc) endif end subroutine openParameterBlock +!> Remove the lowest level of recursion from the active block name subroutine closeParameterBlock(CS) - type(param_file_type), intent(in) :: CS -! Remove the lowest level of recursion from the active block name - type(parameter_block), pointer :: block + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + + type(parameter_block), pointer :: block => NULL() if (associated(CS%blockName)) then block => CS%blockName @@ -1838,10 +2042,12 @@ subroutine closeParameterBlock(CS) block%name = popBlockLevel(block%name) end subroutine closeParameterBlock +!> Extends block name (deeper level of parameter block) function pushBlockLevel(oldblockName,newBlockName) - character(len=*), intent(in) :: oldBlockName, newBlockName + character(len=*), intent(in) :: oldBlockName !< A sequence of hierarchical parameter block names + character(len=*), intent(in) :: newBlockName !< A new block name to add to the end of the sequence character(len=len(oldBlockName)+40) :: pushBlockLevel -! Extends block name (deeper level of parameter block) + if (len_trim(oldBlockName)>0) then pushBlockLevel=trim(oldBlockName)//'%'//trim(newBlockName) else @@ -1849,10 +2055,11 @@ function pushBlockLevel(oldblockName,newBlockName) endif end function pushBlockLevel +!> Truncates block name (shallower level of parameter block) function popBlockLevel(oldblockName) - character(len=*), intent(in) :: oldBlockName + character(len=*), intent(in) :: oldBlockName !< A sequence of hierarchical parameter block names character(len=len(oldBlockName)+40) :: popBlockLevel -! Truncates block name (shallower level of parameter block) + integer :: i i = index(trim(oldBlockName), '%', .true.) if (i>1) then @@ -1865,4 +2072,29 @@ function popBlockLevel(oldblockName) endif end function popBlockLevel +!> \namespace mom_file_parser +!! +!! By Robert Hallberg and Alistair Adcroft, updated 9/2013. +!! +!! The subroutines here parse a set of input files for the value +!! a named parameter and sets that parameter at run time. Currently +!! these files use use one of several formats: +!! \#define VAR ! To set the logical VAR to true. +!! VAR = True ! To set the logical VAR to true. +!! \#undef VAR ! To set the logical VAR to false. +!! VAR = False ! To set the logical VAR to false. +!! \#define VAR 999 ! To set the real or integer VAR to 999. +!! VAR = 999 ! To set the real or integer VAR to 999. +!! \#override VAR = 888 ! To override a previously set value. +!! VAR = 1.1, 2.2, 3.3 ! To set an array of real values. + ! Note that in the comments above, dOxygen translates \# to # . +!! +!! In addition, when set by the get_param interface, the values of +!! parameters are automatically logged, along with defaults, units, +!! and a description. It is an error for a variable to be overridden +!! more than once, and MOM6 has a facility to check for unused lines +!! to set variables, which may indicate miss-spelled or archaic +!! parameters. Parameter names are case-specific, and lines may use +!! a F90 or C++ style comment, starting with ! or //. + end module MOM_file_parser diff --git a/src/framework/MOM_get_input.F90 b/src/framework/MOM_get_input.F90 index 2687579750..de75e9713b 100644 --- a/src/framework/MOM_get_input.F90 +++ b/src/framework/MOM_get_input.F90 @@ -38,7 +38,7 @@ subroutine get_MOM_input(param_file, dirs, check_params, default_input_filename, character(len=*), optional, intent(in) :: default_input_filename !< If present, is the value assumed for !! input_filename if input_filename is not listed !! in the namelist MOM_input_nml. - integer, intent(in), optional :: ensemble_num !< The ensemble id of the current member + integer, optional, intent(in) :: ensemble_num !< The ensemble id of the current member ! Local variables integer, parameter :: npf = 5 ! Maximum number of parameter files character(len=240) :: & diff --git a/src/framework/MOM_hor_index.F90 b/src/framework/MOM_hor_index.F90 index 4326693957..2fda7bd68d 100644 --- a/src/framework/MOM_hor_index.F90 +++ b/src/framework/MOM_hor_index.F90 @@ -48,6 +48,7 @@ module MOM_hor_index logical :: symmetric !< True if symmetric memory is used. end type hor_index_type +!> Copy the contents of one horizontal index type into another interface assignment(=); module procedure HIT_assign ; end interface contains @@ -118,9 +119,9 @@ end subroutine HIT_assign !! The non-symmetric memory mode will then also work, albeit with a different (less efficient) communication pattern. !! !! Using the hor_index_type HI: -!! - declaration of h-point data is of the form `h(HI%%isd:HI%%ied,HI%%jsd:HI%%jed)`; -!! - declaration of q-point data is of the form `q(HI%%IsdB:HI%%IedB,HI%%JsdB:HI%%JedB)`; -!! - declaration of u-point data is of the form `u(HI%%IsdB:HI%%IedB,HI%%jsd:HI%%jed)`; +!! - declaration of h-point data is of the form `h(HI%%isd:HI%%ied,HI%%jsd:HI%%jed)` +!! - declaration of q-point data is of the form `q(HI%%IsdB:HI%%IedB,HI%%JsdB:HI%%JedB)` +!! - declaration of u-point data is of the form `u(HI%%IsdB:HI%%IedB,HI%%jsd:HI%%jed)` !! - declaration of v-point data is of the form `v(HI%%isd:HI%%ied,HI%%JsdB:HI%%JedB)`. !! !! For more detail explanation of horizontal indexing see \ref Horizontal_indexing. diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index 1d692cf393..21d581978a 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -1,4 +1,6 @@ +!> Horizontal interpolation module MOM_horizontal_regridding + ! This file is part of MOM6. See LICENSE.md for the license. use MOM_debugging, only : hchksum @@ -17,7 +19,7 @@ module MOM_horizontal_regridding use MOM_io, only : open_file, read_data, read_axis_data, SINGLE_FILE, MULTIPLE use MOM_io, only : slasher, vardesc, write_field use MOM_string_functions, only : uppercase -use MOM_time_manager, only : time_type, set_time, get_external_field_size +use MOM_time_manager, only : time_type, get_external_field_size use MOM_time_manager, only : init_external_field, time_interp_external use MOM_time_manager, only : get_external_field_axes, get_external_field_missing use MOM_variables, only : thermo_var_ptrs @@ -38,28 +40,32 @@ module MOM_horizontal_regridding public :: horiz_interp_and_extrap_tracer, myStats -character(len=40) :: mdl = "MOM_horizontal_regridding" ! This module's name. +! character(len=40) :: mdl = "MOM_horizontal_regridding" ! This module's name. +!> Fill grid edges interface fill_boundaries module procedure fill_boundaries_real module procedure fill_boundaries_int end interface +!> Extrapolate and interpolate data interface horiz_interp_and_extrap_tracer - module procedure horiz_interp_and_extrap_tracer_record - module procedure horiz_interp_and_extrap_tracer_fms_id + module procedure horiz_interp_and_extrap_tracer_record + module procedure horiz_interp_and_extrap_tracer_fms_id end interface -real, parameter :: epsln=1.e-10 - contains - +!> Write to the terminal some basic statistics about the k-th level of an array subroutine myStats(array, missing, is, ie, js, je, k, mesg) - real, dimension(:,:), intent(in) :: array - real, intent(in) :: missing - integer :: is,ie,js,je,k - character(len=*) :: mesg + real, dimension(:,:), intent(in) :: array !< input array (ND) + real, intent(in) :: missing !< missing value (ND) + !!@{ + !> Horizontal loop bounds to calculate statistics for + integer :: is,ie,js,je + !!@} + integer :: k !< Level to calculate statistics for + character(len=*) :: mesg !< Label to use in message ! Local variables real :: minA, maxA integer :: i,j @@ -67,21 +73,19 @@ subroutine myStats(array, missing, is, ie, js, je, k, mesg) character(len=120) :: lMesg minA = 9.E24 ; maxA = -9.E24 ; found = .false. - do j = js, je - do i = is, ie - if (array(i,j) /= array(i,j)) stop 'Nan!' - if (abs(array(i,j)-missing)>1.e-6*abs(missing)) then - if (found) then - minA = min(minA, array(i,j)) - maxA = max(maxA, array(i,j)) - else - found = .true. - minA = array(i,j) - maxA = array(i,j) - endif - endif - enddo - enddo + do j=js,je ; do i=is,ie + if (array(i,j) /= array(i,j)) stop 'Nan!' + if (abs(array(i,j)-missing) > 1.e-6*abs(missing)) then + if (found) then + minA = min(minA, array(i,j)) + maxA = max(maxA, array(i,j)) + else + found = .true. + minA = array(i,j) + maxA = array(i,j) + endif + endif + enddo ; enddo call min_across_PEs(minA) call max_across_PEs(maxA) if (is_root_pe()) then @@ -89,40 +93,42 @@ subroutine myStats(array, missing, is, ie, js, je, k, mesg) 'init_from_Z: min=',minA,' max=',maxA,' Level=',k,trim(mesg) call MOM_mesg(lMesg,2) endif + end subroutine myStats -subroutine fill_miss_2d(aout,good,fill,prev,G,smooth,num_pass,relc,crit,keep_bug,debug) - ! - !# Use ICE-9 algorithm to populate points (fill=1) with - !# valid data (good=1). If no information is available, - !# Then use a previous guess (prev). Optionally (smooth) - !# blend the filled points to achieve a more desirable result. - ! - ! (in) a : input 2-d array with missing values - ! (in) good : valid data mask for incoming array (1==good data; 0==missing data) - ! (in) fill : same shape array of points which need filling (1==please fill;0==leave it alone) - ! (in) prev : first guess where isolated holes exist, - ! + +!> Use ICE-9 algorithm to populate points (fill=1) with +!! valid data (good=1). If no information is available, +!! Then use a previous guess (prev). Optionally (smooth) +!! blend the filled points to achieve a more desirable result. +subroutine fill_miss_2d(aout, good, fill, prev, G, smooth, num_pass, relc, crit, keep_bug, debug) use MOM_coms, only : sum_across_PEs - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. - real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: aout - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: good !< Valid data mask for incoming array - !! (1==good data; 0==missing data). - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: fill !< Same shape array of points which need - !! filling (1==please fill;0==leave - !! it alone). - real, dimension(SZI_(G),SZJ_(G)), optional, & - intent(in) :: prev !< First guess where isolated holes exist. - logical, intent(in), optional :: smooth - integer, intent(in), optional :: num_pass - real, intent(in), optional :: relc,crit - logical, intent(in), optional :: keep_bug, debug + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + real, dimension(SZI_(G),SZJ_(G)), & + intent(inout) :: aout !< The array with missing values to fill + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: good !< Valid data mask for incoming array + !! (1==good data; 0==missing data). + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: fill !< Same shape array of points which need + !! filling (1==fill;0==dont fill) + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(in) :: prev !< First guess where isolated holes exist. + logical, optional, intent(in) :: smooth !< If present and true, apply a number of + !! Laplacian iterations to the interpolated data + integer, optional, intent(in) :: num_pass !< The maximum number of iterations + real, optional, intent(in) :: relc !< A relaxation coefficient for Laplacian (ND) + real, optional, intent(in) :: crit !< A minimal value for deltas between iterations. + logical, optional, intent(in) :: keep_bug !< Use an algorithm with a bug that dates + !! to the "sienna" code release. + logical, optional, intent(in) :: debug !< If true, write verbose debugging messages. real, dimension(SZI_(G),SZJ_(G)) :: b,r - real, dimension(SZI_(G),SZJ_(G)) :: fill_pts,good_,good_new + real, dimension(SZI_(G),SZJ_(G)) :: fill_pts, good_, good_new + character(len=256) :: mesg ! The text of an error message integer :: i,j,k real :: east,west,north,south,sor real :: ge,gw,gn,gs,ngood @@ -156,110 +162,111 @@ subroutine fill_miss_2d(aout,good,fill,prev,G,smooth,num_pass,relc,crit,keep_bug do_smooth=.false. if (PRESENT(smooth)) do_smooth=smooth - fill_pts(:,:)=fill(:,:) + fill_pts(:,:) = fill(:,:) nfill = sum(fill(is:ie,js:je)) call sum_across_PEs(nfill) nfill_prev = nfill - good_(:,:)=good(:,:) - r(:,:)=0.0 + good_(:,:) = good(:,:) + r(:,:) = 0.0 do while (nfill > 0.0) - call pass_var(good_,G%Domain) - call pass_var(aout,G%Domain) - - b(:,:)=aout(:,:) - good_new(:,:)=good_(:,:) - - do j=js,je - i_loop: do i=is,ie - - if (good_(i,j) .eq. 1.0 .or. fill(i,j) .eq. 0.) cycle i_loop - - ge=good_(i+1,j);gw=good_(i-1,j) - gn=good_(i,j+1);gs=good_(i,j-1) - east=0.0;west=0.0;north=0.0;south=0.0 - if (ge.eq.1.0) east=aout(i+1,j)*ge - if (gw.eq.1.0) west=aout(i-1,j)*gw - if (gn.eq.1.0) north=aout(i,j+1)*gn - if (gs.eq.1.0) south=aout(i,j-1)*gs - - ngood = ge+gw+gn+gs - if (ngood > 0.) then - b(i,j)=(east+west+north+south)/ngood - fill_pts(i,j)=0.0 - good_new(i,j)=1.0 - endif - enddo i_loop - enddo - - aout(is:ie,js:je)=b(is:ie,js:je) - good_(is:ie,js:je)=good_new(is:ie,js:je) - nfill_prev = nfill - nfill = sum(fill_pts(is:ie,js:je)) - call sum_across_PEs(nfill) - - if (nfill == nfill_prev .and. PRESENT(prev)) then - do j=js,je - do i=is,ie - if (fill_pts(i,j).eq.1.0) then - aout(i,j)=prev(i,j) - fill_pts(i,j)=0.0 - endif - enddo - enddo - else if (nfill .eq. nfill_prev) then - print *,& - 'Unable to fill missing points using either data at the same vertical level from a connected basin'//& - 'or using a point from a previous vertical level. Make sure that the original data has some valid'//& - 'data in all basins.' - print *,'nfill=',nfill - endif - - nfill = sum(fill_pts(is:ie,js:je)) - call sum_across_PEs(nfill) - - end do - - if (do_smooth) then - do k=1,npass - call pass_var(aout,G%Domain) - do j=js,je - do i=is,ie - if (fill(i,j) .eq. 1) then - east=max(good(i+1,j),fill(i+1,j));west=max(good(i-1,j),fill(i-1,j)) - north=max(good(i,j+1),fill(i,j+1));south=max(good(i,j-1),fill(i,j-1)) - r(i,j) = relax_coeff*(south*aout(i,j-1)+north*aout(i,j+1)+west*aout(i-1,j)+east*aout(i+1,j) - (south+north+west+east)*aout(i,j)) - else - r(i,j) = 0. - endif - enddo - enddo - aout(is:ie,js:je)=r(is:ie,js:je)+aout(is:ie,js:je) - ares = maxval(abs(r)) - call max_across_PEs(ares) - if (ares <= acrit) exit - enddo - endif + call pass_var(good_,G%Domain) + call pass_var(aout,G%Domain) + + b(:,:)=aout(:,:) + good_new(:,:)=good_(:,:) + + do j=js,je ; do i=is,ie + + if (good_(i,j) == 1.0 .or. fill(i,j) == 0.) cycle + + ge=good_(i+1,j) ; gw=good_(i-1,j) + gn=good_(i,j+1) ; gs=good_(i,j-1) + east=0.0 ; west=0.0 ; north=0.0 ; south=0.0 + if (ge == 1.0) east = aout(i+1,j)*ge + if (gw == 1.0) west = aout(i-1,j)*gw + if (gn == 1.0) north = aout(i,j+1)*gn + if (gs == 1.0) south = aout(i,j-1)*gs + + ngood = ge+gw+gn+gs + if (ngood > 0.) then + b(i,j)=(east+west+north+south)/ngood + !### Replace this with + ! b(i,j) = ((east+west) + (north+south))/ngood + fill_pts(i,j) = 0.0 + good_new(i,j) = 1.0 + endif + enddo ; enddo + + aout(is:ie,js:je) = b(is:ie,js:je) + good_(is:ie,js:je) = good_new(is:ie,js:je) + nfill_prev = nfill + nfill = sum(fill_pts(is:ie,js:je)) + call sum_across_PEs(nfill) + + if (nfill == nfill_prev .and. PRESENT(prev)) then + do j=js,je ; do i=is,ie ; if (fill_pts(i,j) == 1.0) then + aout(i,j) = prev(i,j) + fill_pts(i,j) = 0.0 + endif ; enddo ; enddo + elseif (nfill == nfill_prev) then + call MOM_error(WARNING, & + 'Unable to fill missing points using either data at the same vertical level from a connected basin'//& + 'or using a point from a previous vertical level. Make sure that the original data has some valid'//& + 'data in all basins.', .true.) + write(mesg,*) 'nfill=',nfill + call MOM_error(WARNING, mesg, .true.) + endif + + nfill = sum(fill_pts(is:ie,js:je)) + call sum_across_PEs(nfill) - do j=js,je - do i=is,ie - if (good_(i,j).eq.0.0 .and. fill_pts(i,j) .eq. 1.0) then - print *,'in fill_miss, fill, good,i,j= ',fill_pts(i,j),good_(i,j),i,j - call MOM_error(FATAL,"MOM_initialize: "// & - "fill is true and good is false after fill_miss, how did this happen? ") - endif - enddo enddo - return + if (do_smooth) then ; do k=1,npass + call pass_var(aout,G%Domain) + do j=js,je ; do i=is,ie + if (fill(i,j) == 1) then + east = max(good(i+1,j),fill(i+1,j)) ; west = max(good(i-1,j),fill(i-1,j)) + north = max(good(i,j+1),fill(i,j+1)) ; south = max(good(i,j-1),fill(i,j-1)) + r(i,j) = relax_coeff*(south*aout(i,j-1)+north*aout(i,j+1) + & + west*aout(i-1,j)+east*aout(i+1,j) - & + (south+north+west+east)*aout(i,j)) + !### Appropriate parentheses should be added here, but they will change answers. + ! r(i,j) = relax_coeff*( ((south*aout(i,j-1) + north*aout(i,j+1)) + & + ! (west*aout(i-1,j)+east*aout(i+1,j))) - & + ! ((south+north)+(west+east))*aout(i,j) ) + else + r(i,j) = 0. + endif + enddo ; enddo + ares = 0.0 + do j=js,je ; do i=is,ie + aout(i,j) = r(i,j) + aout(i,j) + ares = max(ares, abs(r(i,j))) + enddo ; enddo + call max_across_PEs(ares) + if (ares <= acrit) exit + enddo ; endif + + do j=js,je ; do i=is,ie + if (good_(i,j) == 0.0 .and. fill_pts(i,j) == 1.0) then + write(mesg,*) 'In fill_miss, fill, good,i,j= ',fill_pts(i,j),good_(i,j),i,j + call MOM_error(WARNING, mesg, .true.) + call MOM_error(FATAL,"MOM_initialize: "// & + "fill is true and good is false after fill_miss, how did this happen? ") + endif + enddo ; enddo end subroutine fill_miss_2d -subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, recnum, G, tr_z, mask_z, z_in, & - z_edges_in, missing_value, reentrant_x, tripolar_n, homogenize ) +!> Extrapolate and interpolate from a file record +subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, recnum, G, tr_z, & + mask_z, z_in, z_edges_in, missing_value, reentrant_x, & + tripolar_n, homogenize, m_to_Z) character(len=*), intent(in) :: filename !< Path to file containing tracer to be !! interpolated. @@ -268,19 +275,24 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, integer, intent(in) :: recnum !< Record number of tracer to be read. type(ocean_grid_type), intent(inout) :: G !< Grid object real, allocatable, dimension(:,:,:) :: tr_z !< pointer to allocatable tracer array on local - !! model grid and native vertical levels. + !! model grid and input-file vertical levels. real, allocatable, dimension(:,:,:) :: mask_z !< pointer to allocatable tracer mask array on - !! local model grid and native vertical levels. + !! local model grid and input-file vertical levels. real, allocatable, dimension(:) :: z_in !< Cell grid values for input data. real, allocatable, dimension(:) :: z_edges_in !< Cell grid edge values for input data. - real, intent(out) :: missing_value - logical, intent(in) :: reentrant_x, tripolar_n - logical, intent(in), optional :: homogenize + real, intent(out) :: missing_value !< The missing value in the returned array. + logical, intent(in) :: reentrant_x !< If true, this grid is reentrant in the x-direction + logical, intent(in) :: tripolar_n !< If true, this is a northern tripolar grid + logical, optional, intent(in) :: homogenize !< If present and true, horizontally homogenize data + !! to produce perfectly "flat" initial conditions + real, optional, intent(in) :: m_to_Z !< A conversion factor from meters to the units + !! of depth. If missing, G%bathyT must be in m. - real, dimension(:,:), allocatable :: tr_in,tr_inp !< A 2-d array for holding input data on - !! native horizontal grid and extended grid - !! with poles. - real, dimension(:,:), allocatable :: mask_in !< A 2-d mask for extended input grid. + ! Local variables + real, dimension(:,:), allocatable :: tr_in, tr_inp ! A 2-d array for holding input data on + ! native horizontal grid and extended grid + ! with poles. + real, dimension(:,:), allocatable :: mask_in ! A 2-d mask for extended input grid. real :: PI_180 integer :: rcode, ncid, varid, ndims, id, jd, kd, jdp @@ -328,40 +340,40 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, rcode = NF90_OPEN(filename, NF90_NOWRITE, ncid) - if (rcode .ne. 0) call MOM_error(FATAL,"error opening file "//trim(filename)//& + if (rcode /= 0) call MOM_error(FATAL,"error opening file "//trim(filename)//& " in hinterp_extrap") rcode = NF90_INQ_VARID(ncid, varnam, varid) - if (rcode .ne. 0) call MOM_error(FATAL,"error finding variable "//trim(varnam)//& + if (rcode /= 0) call MOM_error(FATAL,"error finding variable "//trim(varnam)//& " in file "//trim(filename)//" in hinterp_extrap") rcode = NF90_INQUIRE_VARIABLE(ncid, varid, ndims=ndims, dimids=dims) - if (rcode .ne. 0) call MOM_error(FATAL,'error inquiring dimensions hinterp_extrap') + if (rcode /= 0) call MOM_error(FATAL,'error inquiring dimensions hinterp_extrap') if (ndims < 3) call MOM_error(FATAL,"Variable "//trim(varnam)//" in file "// & trim(filename)//" has too few dimensions.") rcode = NF90_INQUIRE_DIMENSION(ncid, dims(1), dim_name(1), len=id) - if (rcode .ne. 0) call MOM_error(FATAL,"error reading dimension 1 data for "// & + if (rcode /= 0) call MOM_error(FATAL,"error reading dimension 1 data for "// & trim(varnam)//" in file "// trim(filename)//" in hinterp_extrap") rcode = NF90_INQ_VARID(ncid, dim_name(1), dim_id(1)) - if (rcode .ne. 0) call MOM_error(FATAL,"error finding variable "//trim(dim_name(1))//& + if (rcode /= 0) call MOM_error(FATAL,"error finding variable "//trim(dim_name(1))//& " in file "//trim(filename)//" in hinterp_extrap") rcode = NF90_INQUIRE_DIMENSION(ncid, dims(2), dim_name(2), len=jd) - if (rcode .ne. 0) call MOM_error(FATAL,"error reading dimension 2 data for "// & + if (rcode /= 0) call MOM_error(FATAL,"error reading dimension 2 data for "// & trim(varnam)//" in file "// trim(filename)//" in hinterp_extrap") rcode = NF90_INQ_VARID(ncid, dim_name(2), dim_id(2)) - if (rcode .ne. 0) call MOM_error(FATAL,"error finding variable "//trim(dim_name(2))//& + if (rcode /= 0) call MOM_error(FATAL,"error finding variable "//trim(dim_name(2))//& " in file "//trim(filename)//" in hinterp_extrap") rcode = NF90_INQUIRE_DIMENSION(ncid, dims(3), dim_name(3), len=kd) - if (rcode .ne. 0) call MOM_error(FATAL,"error reading dimension 3 data for "// & + if (rcode /= 0) call MOM_error(FATAL,"error reading dimension 3 data for "// & trim(varnam)//" in file "// trim(filename)//" in hinterp_extrap") rcode = NF90_INQ_VARID(ncid, dim_name(3), dim_id(3)) - if (rcode .ne. 0) call MOM_error(FATAL,"error finding variable "//trim(dim_name(3))//& + if (rcode /= 0) call MOM_error(FATAL,"error finding variable "//trim(dim_name(3))//& " in file "//trim(filename)//" in hinterp_extrap") missing_value=0.0 rcode = NF90_GET_ATT(ncid, varid, "_FillValue", missing_value) - if (rcode .ne. 0) call MOM_error(FATAL,"error finding missing value for "//& + if (rcode /= 0) call MOM_error(FATAL,"error finding missing value for "//& trim(varnam)//" in file "// trim(filename)//" in hinterp_extrap") if (allocated(lon_in)) deallocate(lon_in) @@ -377,19 +389,21 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, start = 1; count = 1; count(1) = id rcode = NF90_GET_VAR(ncid, dim_id(1), lon_in, start, count) - if (rcode .ne. 0) call MOM_error(FATAL,"error reading dimension 1 values for var_name "// & + if (rcode /= 0) call MOM_error(FATAL,"error reading dimension 1 values for var_name "// & trim(varnam)//",dim_name "//trim(dim_name(1))//" in file "// trim(filename)//" in hinterp_extrap") start = 1; count = 1; count(1) = jd rcode = NF90_GET_VAR(ncid, dim_id(2), lat_in, start, count) - if (rcode .ne. 0) call MOM_error(FATAL,"error reading dimension 2 values for var_name "// & + if (rcode /= 0) call MOM_error(FATAL,"error reading dimension 2 values for var_name "// & trim(varnam)//",dim_name "//trim(dim_name(2))//" in file "// trim(filename)//" in hinterp_extrap") start = 1; count = 1; count(1) = kd rcode = NF90_GET_VAR(ncid, dim_id(3), z_in, start, count) - if (rcode .ne. 0) call MOM_error(FATAL,"error reading dimension 3 values for var_name "// & + if (rcode /= 0) call MOM_error(FATAL,"error reading dimension 3 values for var_name "// & trim(varnam//",dim_name "//trim(dim_name(3)))//" in file "// trim(filename)//" in hinterp_extrap") call cpu_clock_end(id_clock_read) + if (present(m_to_Z)) then ; do k=1,kd ; z_in(k) = m_to_Z * z_in(k) ; enddo ; endif + ! extrapolate the input data to the north pole using the northerm-most latitude max_lat = maxval(lat_in) @@ -410,8 +424,8 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, ! construct level cell boundaries as the mid-point between adjacent centers z_edges_in(1) = 0.0 - do k=2,kd - z_edges_in(k)=0.5*(z_in(k-1)+z_in(k)) + do K=2,kd + z_edges_in(K)=0.5*(z_in(k-1)+z_in(k)) enddo z_edges_in(kd+1)=2.0*z_in(kd) - z_in(kd-1) @@ -448,16 +462,16 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, write(laynum,'(I8)') k ; laynum = adjustl(laynum) if (is_root_pe()) then - start = 1; start(3) = k; count = 1; count(1) = id; count(2) = jd + start = 1 ; start(3) = k ; count(:) = 1 ; count(1) = id ; count(2) = jd rcode = NF90_GET_VAR(ncid,varid, tr_in, start, count) - if (rcode .ne. 0) call MOM_error(FATAL,"hinterp_and_extract_from_Fie: "//& + if (rcode /= 0) call MOM_error(FATAL,"hinterp_and_extract_from_Fie: "//& "error reading level "//trim(laynum)//" of variable "//& trim(varnam)//" in file "// trim(filename)) if (add_np) then last_row(:)=tr_in(:,jd); pole=0.0;npole=0.0 do i=1,id - if (abs(tr_in(i,jd)-missing_value) .gt. abs(roundoff*missing_value)) then + if (abs(tr_in(i,jd)-missing_value) > abs(roundoff*missing_value)) then pole = pole+last_row(i) npole = npole+1.0 endif @@ -476,18 +490,18 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, endif call mpp_sync() - call mpp_broadcast(tr_inp,id*jdp,root_PE()) - call mpp_sync_self () + call mpp_broadcast(tr_inp, id*jdp, root_PE()) + call mpp_sync_self() mask_in=0.0 do j=1,jdp do i=1,id - if (abs(tr_inp(i,j)-missing_value) .gt. abs(roundoff*missing_value)) then - mask_in(i,j)=1.0 - tr_inp(i,j) = tr_inp(i,j) * conversion + if (abs(tr_inp(i,j)-missing_value) > abs(roundoff*missing_value)) then + mask_in(i,j) = 1.0 + tr_inp(i,j) = tr_inp(i,j) * conversion else - tr_inp(i,j)=missing_value + tr_inp(i,j) = missing_value endif enddo enddo @@ -512,7 +526,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, mask_out=1.0 do j=js,je do i=is,ie - if (abs(tr_out(i,j)-missing_value) .lt. abs(roundoff*missing_value)) mask_out(i,j)=0. + if (abs(tr_out(i,j)-missing_value) < abs(roundoff*missing_value)) mask_out(i,j)=0. enddo enddo @@ -521,14 +535,15 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, nPoints = 0 ; varAvg = 0. do j=js,je do i=is,ie - if (mask_out(i,j) .lt. 1.0) then + if (mask_out(i,j) < 1.0) then tr_out(i,j)=missing_value else good(i,j)=1.0 nPoints = nPoints + 1 varAvg = varAvg + tr_out(i,j) endif - if (G%mask2dT(i,j) == 1.0 .and. z_edges_in(k) <= G%bathyT(i,j) .and. mask_out(i,j) .lt. 1.0) fill(i,j)=1.0 + if (G%mask2dT(i,j) == 1.0 .and. z_edges_in(k) <= G%bathyT(i,j) .and. mask_out(i,j) < 1.0) & + fill(i,j)=1.0 enddo enddo call pass_var(fill,G%Domain) @@ -553,18 +568,18 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, ! tr_out contains input z-space data on the model grid with missing values ! now fill in missing values using "ICE-nine" algorithm. - tr_outf(:,:)=tr_out(:,:) - if (k==1) tr_prev(:,:)=tr_outf(:,:) - good2(:,:)=good(:,:) - fill2(:,:)=fill(:,:) + tr_outf(:,:) = tr_out(:,:) + if (k==1) tr_prev(:,:) = tr_outf(:,:) + good2(:,:) = good(:,:) + fill2(:,:) = fill(:,:) - call fill_miss_2d(tr_outf,good2,fill2,tr_prev,G,smooth=.true.) - call myStats(tr_outf,missing_value,is,ie,js,je,k,'field from fill_miss_2d()') + call fill_miss_2d(tr_outf, good2, fill2, tr_prev, G, smooth=.true.) + call myStats(tr_outf, missing_value, is, ie, js, je, k, 'field from fill_miss_2d()') - tr_z(:,:,k) = tr_outf(:,:)*G%mask2dT(:,:) - mask_z(:,:,k) = good2(:,:)+fill2(:,:) + tr_z(:,:,k) = tr_outf(:,:) * G%mask2dT(:,:) + mask_z(:,:,k) = good2(:,:) + fill2(:,:) - tr_prev(:,:)=tr_z(:,:,k) + tr_prev(:,:) = tr_z(:,:,k) if (debug) then call hchksum(tr_prev,'field after fill ',G%HI) @@ -574,8 +589,10 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, end subroutine horiz_interp_and_extrap_tracer_record -subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, tr_z, mask_z, z_in, & - z_edges_in, missing_value, reentrant_x, tripolar_n, homogenize ) +!> Extrapolate and interpolate using a FMS time interpolation handle +subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, tr_z, mask_z, & + z_in, z_edges_in, missing_value, reentrant_x, & + tripolar_n, homogenize, m_to_Z) integer, intent(in) :: fms_id !< A unique id used by the FMS time interpolator type(time_type), intent(in) :: Time !< A FMS time type @@ -586,11 +603,16 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t real, allocatable, dimension(:,:,:) :: mask_z !< pointer to allocatable tracer mask array on !! local model grid and native vertical levels. real, allocatable, dimension(:) :: z_in !< Cell grid values for input data. - real, allocatable, dimension(:) :: z_edges_in !< Cell grid edge values for input data. - real, intent(out) :: missing_value - logical, intent(in) :: reentrant_x, tripolar_n - logical, intent(in), optional :: homogenize + real, allocatable, dimension(:) :: z_edges_in !< Cell grid edge values for input data. (Intent out) + real, intent(out) :: missing_value !< The missing value in the returned array. + logical, intent(in) :: reentrant_x !< If true, this grid is reentrant in the x-direction + logical, intent(in) :: tripolar_n !< If true, this is a northern tripolar grid + logical, optional, intent(in) :: homogenize !< If present and true, horizontally homogenize data + !! to produce perfectly "flat" initial conditions + real, optional, intent(in) :: m_to_Z !< A conversion factor from meters to the units + !! of depth. If missing, G%bathyT must be in m. + ! Local variables real, dimension(:,:), allocatable :: tr_in,tr_inp !< A 2-d array for holding input data on !! native horizontal grid and extended grid !! with poles. @@ -659,9 +681,11 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t call mpp_get_axis_data(axes_data(2), lat_in) call mpp_get_axis_data(axes_data(3), z_in) + if (present(m_to_Z)) then ; do k=1,kd ; z_in(k) = m_to_Z * z_in(k) ; enddo ; endif + call cpu_clock_end(id_clock_read) - missing_value=get_external_field_missing(fms_id) + missing_value = get_external_field_missing(fms_id) ! extrapolate the input data to the north pole using the northerm-most latitude @@ -669,14 +693,14 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t max_lat = maxval(lat_in) add_np=.false. if (max_lat < 90.0) then - add_np=.true. - jdp=jd+1 + add_np = .true. + jdp = jd+1 allocate(lat_inp(jdp)) - lat_inp(1:jd)=lat_in(:) - lat_inp(jd+1)=90.0 + lat_inp(1:jd) = lat_in(:) + lat_inp(jd+1) = 90.0 deallocate(lat_in) allocate(lat_in(1:jdp)) - lat_in(:)=lat_inp(:) + lat_in(:) = lat_inp(:) else jdp=jd endif @@ -685,16 +709,16 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t z_edges_in(1) = 0.0 do k=2,kd - z_edges_in(k)=0.5*(z_in(k-1)+z_in(k)) + z_edges_in(k) = 0.5*(z_in(k-1)+z_in(k)) enddo - z_edges_in(kd+1)=2.0*z_in(kd) - z_in(kd-1) + z_edges_in(kd+1) = 2.0*z_in(kd) - z_in(kd-1) call horiz_interp_init() lon_in = lon_in*PI_180 lat_in = lat_in*PI_180 - allocate(x_in(id,jdp),y_in(id,jdp)) - call meshgrid(lon_in,lat_in, x_in, y_in) + allocate(x_in(id,jdp), y_in(id,jdp)) + call meshgrid(lon_in, lat_in, x_in, y_in) lon_out(:,:) = G%geoLonT(:,:)*PI_180 lat_out(:,:) = G%geoLatT(:,:)*PI_180 @@ -711,7 +735,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t if (z_edges_in(kd+1) abs(roundoff*missing_value)) then pole = pole+last_row(i) npole = npole+1.0 endif @@ -747,99 +771,91 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t endif call mpp_sync() - call mpp_broadcast(tr_inp,id*jdp,root_PE()) - call mpp_sync_self () + call mpp_broadcast(tr_inp, id*jdp, root_PE()) + call mpp_sync_self() mask_in=0.0 - do j=1,jdp - do i=1,id - if (abs(tr_inp(i,j)-missing_value) .gt. abs(roundoff*missing_value)) then - mask_in(i,j)=1.0 - tr_inp(i,j) = tr_inp(i,j) * conversion - else - tr_inp(i,j)=missing_value - endif - enddo - enddo - - -! call fms routine horiz_interp to interpolate input level data to model horizontal grid - + do j=1,jdp ; do i=1,id + if (abs(tr_inp(i,j)-missing_value) > abs(roundoff*missing_value)) then + mask_in(i,j)=1.0 + tr_inp(i,j) = tr_inp(i,j) * conversion + else + tr_inp(i,j) = missing_value + endif + enddo ; enddo + ! call fms routine horiz_interp to interpolate input level data to model horizontal grid if (k == 1) then - call horiz_interp_new(Interp,x_in,y_in,lon_out(is:ie,js:je),lat_out(is:ie,js:je), & - interp_method='bilinear',src_modulo=reentrant_x) + call horiz_interp_new(Interp, x_in, y_in, lon_out(is:ie,js:je), lat_out(is:ie,js:je), & + interp_method='bilinear', src_modulo=reentrant_x) endif -! if (debug) then - call myStats(tr_in,missing_value, 1,id,1,jd,k,'Tracer from file') -! endif + if (debug) then + call myStats(tr_in, missing_value, 1, id, 1, jd, k, 'Tracer from file') + endif tr_out(:,:) = 0.0 - call horiz_interp(Interp,tr_inp,tr_out(is:ie,js:je), missing_value=missing_value, new_missing_handle=.true.) + call horiz_interp(Interp, tr_inp, tr_out(is:ie,js:je), missing_value=missing_value, & + new_missing_handle=.true.) - mask_out=1.0 - do j=js,je - do i=is,ie - if (abs(tr_out(i,j)-missing_value) .lt. abs(roundoff*missing_value)) mask_out(i,j)=0. - enddo - enddo + mask_out(:,:) = 1.0 + do j=js,je ; do i=is,ie + if (abs(tr_out(i,j)-missing_value) < abs(roundoff*missing_value)) mask_out(i,j) = 0. + enddo ; enddo - fill = 0.0; good = 0.0 + fill(:,:) = 0.0 ; good(:,:) = 0.0 nPoints = 0 ; varAvg = 0. - do j=js,je - do i=is,ie - if (mask_out(i,j) .lt. 1.0) then - tr_out(i,j)=missing_value - else - good(i,j)=1.0 - nPoints = nPoints + 1 - varAvg = varAvg + tr_out(i,j) - endif - if (G%mask2dT(i,j) == 1.0 .and. z_edges_in(k) <= G%bathyT(i,j) .and. mask_out(i,j) .lt. 1.0) fill(i,j)=1.0 - enddo - enddo - call pass_var(fill,G%Domain) - call pass_var(good,G%Domain) + do j=js,je ; do i=is,ie + if (mask_out(i,j) < 1.0) then + tr_out(i,j) = missing_value + else + good(i,j) = 1.0 + nPoints = nPoints + 1 + varAvg = varAvg + tr_out(i,j) + endif + if ((G%mask2dT(i,j) == 1.0) .and. (z_edges_in(k) <= G%bathyT(i,j)) .and. & + (mask_out(i,j) < 1.0)) & + fill(i,j)=1.0 + enddo ; enddo + call pass_var(fill, G%Domain) + call pass_var(good, G%Domain) if (debug) then - call myStats(tr_out,missing_value, is,ie,js,je,k,'variable from horiz_interp()') + call myStats(tr_out, missing_value, is, ie, js, je, k, 'variable from horiz_interp()') endif ! Horizontally homogenize data to produce perfectly "flat" initial conditions - if (PRESENT(homogenize)) then - if (homogenize) then - call sum_across_PEs(nPoints) - call sum_across_PEs(varAvg) - if (nPoints>0) then - varAvg = varAvg/real(nPoints) - endif - tr_out(:,:) = varAvg - endif - endif + if (PRESENT(homogenize)) then ; if (homogenize) then + call sum_across_PEs(nPoints) + call sum_across_PEs(varAvg) + if (nPoints>0) then + varAvg = varAvg/real(nPoints) + endif + tr_out(:,:) = varAvg + endif ; endif -! tr_out contains input z-space data on the model grid with missing values -! now fill in missing values using "ICE-nine" algorithm. + ! tr_out contains input z-space data on the model grid with missing values + ! now fill in missing values using "ICE-nine" algorithm. - tr_outf(:,:)=tr_out(:,:) - if (k==1) tr_prev(:,:)=tr_outf(:,:) - good2(:,:)=good(:,:) - fill2(:,:)=fill(:,:) + tr_outf(:,:) = tr_out(:,:) + if (k==1) tr_prev(:,:) = tr_outf(:,:) + good2(:,:) = good(:,:) + fill2(:,:) = fill(:,:) - call fill_miss_2d(tr_outf,good2,fill2,tr_prev,G,smooth=.true.) + call fill_miss_2d(tr_outf, good2, fill2, tr_prev, G, smooth=.true.) ! if (debug) then -! call hchksum(tr_outf,'field from fill_miss_2d ',G%HI) +! call hchksum(tr_outf, 'field from fill_miss_2d ', G%HI) ! endif -! call myStats(tr_outf,missing_value,is,ie,js,je,k,'field from fill_miss_2d()') +! call myStats(tr_outf, missing_value, is, ie, js, je, k, 'field from fill_miss_2d()') tr_z(:,:,k) = tr_outf(:,:)*G%mask2dT(:,:) - mask_z(:,:,k) = good2(:,:)+fill2(:,:) - tr_prev(:,:)=tr_z(:,:,k) + mask_z(:,:,k) = good2(:,:) + fill2(:,:) + tr_prev(:,:) = tr_z(:,:,k) if (debug) then call hchksum(tr_prev,'field after fill ',G%HI) @@ -848,151 +864,145 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t enddo ! kd end subroutine horiz_interp_and_extrap_tracer_fms_id -subroutine meshgrid(x,y,x_T,y_T) -!< create a 2d-mesh of grid coordinates -!! from 1-d arrays. -real, dimension(:), intent(in) :: x,y -real, dimension(size(x,1),size(y,1)), intent(inout) :: x_T,y_T -integer :: ni,nj,i,j +!> Create a 2d-mesh of grid coordinates from 1-d arrays. +subroutine meshgrid(x, y, x_T, y_T) + real, dimension(:), intent(in) :: x !< input 1-dimensional vector + real, dimension(:), intent(in) :: y !< input 1-dimensional vector + real, dimension(size(x,1),size(y,1)), intent(inout) :: x_T !< output 2-dimensional array + real, dimension(size(x,1),size(y,1)), intent(inout) :: y_T !< output 2-dimensional array -ni=size(x,1);nj=size(y,1) + integer :: ni,nj,i,j -do j=1,nj - x_T(:,j)=x(:) -enddo + ni=size(x,1) ; nj=size(y,1) -do i=1,ni - y_T(i,:)=y(:) -enddo + do j=1,nj ; do i=1,ni + x_T(i,j) = x(i) + enddo ; enddo -return + do j=1,nj ; do i=1,ni + y_T(i,j) = y(j) + enddo ; enddo end subroutine meshgrid + +! None of the subsequent code appears to be used at all. + +!> Fill grid edges for integer data function fill_boundaries_int(m,cyclic_x,tripolar_n) result(mp) -! -! fill grid edges -! -integer, dimension(:,:), intent(in) :: m -logical, intent(in) :: cyclic_x, tripolar_n -real, dimension(size(m,1),size(m,2)) :: m_real -real, dimension(0:size(m,1)+1,0:size(m,2)+1) :: mp_real -integer, dimension(0:size(m,1)+1,0:size(m,2)+1) :: mp + integer, dimension(:,:), intent(in) :: m !< input array (ND) + logical, intent(in) :: cyclic_x !< True if domain is zonally re-entrant + logical, intent(in) :: tripolar_n !< True if domain has an Arctic fold + integer, dimension(0:size(m,1)+1,0:size(m,2)+1) :: mp -m_real = real(m) + real, dimension(size(m,1),size(m,2)) :: m_real + real, dimension(0:size(m,1)+1,0:size(m,2)+1) :: mp_real -mp_real = fill_boundaries_real(m_real,cyclic_x,tripolar_n) + m_real = real(m) -mp = int(mp_real) + mp_real = fill_boundaries_real(m_real,cyclic_x,tripolar_n) -return + mp = int(mp_real) end function fill_boundaries_int +!> Fill grid edges for real data function fill_boundaries_real(m,cyclic_x,tripolar_n) result(mp) -!< fill grid edges + real, dimension(:,:), intent(in) :: m !< input array (ND) + logical, intent(in) :: cyclic_x !< True if domain is zonally re-entrant + logical, intent(in) :: tripolar_n !< True if domain has an Arctic fold + real, dimension(0:size(m,1)+1,0:size(m,2)+1) :: mp -real, dimension(:,:), intent(in) :: m -logical, intent(in) :: cyclic_x, tripolar_n -real, dimension(0:size(m,1)+1,0:size(m,2)+1) :: mp + integer :: ni,nj,i,j -integer :: ni,nj,i,j + ni=size(m,1); nj=size(m,2) -ni=size(m,1); nj=size(m,2) + mp(1:ni,1:nj)=m(:,:) -mp(1:ni,1:nj)=m(:,:) - -if (cyclic_x) then - mp(0,1:nj)=m(ni,1:nj) - mp(ni+1,1:nj)=m(1,1:nj) -else - mp(0,1:nj)=m(1,1:nj) - mp(ni+1,1:nj)=m(ni,1:nj) -endif - -mp(1:ni,0)=m(1:ni,1) -if (tripolar_n) then - do i=1,ni - mp(i,nj+1)=m(ni-i+1,nj) - enddo -else - mp(1:ni,nj+1)=m(1:ni,nj) -endif + if (cyclic_x) then + mp(0,1:nj)=m(ni,1:nj) + mp(ni+1,1:nj)=m(1,1:nj) + else + mp(0,1:nj)=m(1,1:nj) + mp(ni+1,1:nj)=m(ni,1:nj) + endif -return + mp(1:ni,0)=m(1:ni,1) + if (tripolar_n) then + do i=1,ni + mp(i,nj+1)=m(ni-i+1,nj) + enddo + else + mp(1:ni,nj+1)=m(1:ni,nj) + endif end function fill_boundaries_real -subroutine smooth_heights(zi,fill,bad,sor,niter,cyclic_x, tripolar_n) -!< Solve del2 (zi) = 0 using successive iterations +!> Solve del2 (zi) = 0 using successive iterations !! with a 5 point stencil. Only points fill==1 are !! modified. Except where bad==1, information propagates !! isotropically in index space. The resulting solution !! in each region is an approximation to del2(zi)=0 subject to !! boundary conditions along the valid points curve bounding this region. +subroutine smooth_heights(zi,fill,bad,sor,niter,cyclic_x, tripolar_n) + real, dimension(:,:), intent(inout) :: zi !< input and output array (ND) + integer, dimension(size(zi,1),size(zi,2)), intent(in) :: fill !< same shape as zi, 1=fill + integer, dimension(size(zi,1),size(zi,2)), intent(in) :: bad !< same shape as zi, 1=bad data + real, intent(in) :: sor !< relaxation coefficient (ND) + integer, intent(in) :: niter !< maximum number of iterations + logical, intent(in) :: cyclic_x !< true if domain is zonally reentrant + logical, intent(in) :: tripolar_n !< true if domain has an Arctic fold -real, dimension(:,:), intent(inout) :: zi -integer, dimension(size(zi,1),size(zi,2)), intent(in) :: fill -integer, dimension(size(zi,1),size(zi,2)), intent(in) :: bad -real, intent(in) :: sor -integer, intent(in) :: niter -logical, intent(in) :: cyclic_x, tripolar_n - -integer :: i,j,k,n -integer :: ni,nj - -real, dimension(size(zi,1),size(zi,2)) :: res, m -integer, dimension(size(zi,1),size(zi,2),4) :: B -real, dimension(0:size(zi,1)+1,0:size(zi,2)+1) :: mp -integer, dimension(0:size(zi,1)+1,0:size(zi,2)+1) :: nm - -real :: Isum, bsum - -ni=size(zi,1); nj=size(zi,2) + ! Local variables + real, dimension(size(zi,1),size(zi,2)) :: res, m + integer, dimension(size(zi,1),size(zi,2),4) :: B + real, dimension(0:size(zi,1)+1,0:size(zi,2)+1) :: mp + integer, dimension(0:size(zi,1)+1,0:size(zi,2)+1) :: nm + integer :: i,j,k,n + integer :: ni,nj + real :: Isum, bsum + ni=size(zi,1) ; nj=size(zi,2) -mp=fill_boundaries(zi,cyclic_x,tripolar_n) -B(:,:,:)=0.0 -nm=fill_boundaries(bad,cyclic_x,tripolar_n) + mp(:,:) = fill_boundaries(zi,cyclic_x,tripolar_n) -do j=1,nj - do i=1,ni - if (fill(i,j) .eq. 1) then - B(i,j,1)=1-nm(i+1,j);B(i,j,2)=1-nm(i-1,j) - B(i,j,3)=1-nm(i,j+1);B(i,j,4)=1-nm(i,j-1) - endif - enddo -enddo + B(:,:,:) = 0.0 + nm(:,:) = fill_boundaries(bad,cyclic_x,tripolar_n) -do n=1,niter do j=1,nj do i=1,ni - if (fill(i,j) .eq. 1) then - bsum = real(B(i,j,1)+B(i,j,2)+B(i,j,3)+B(i,j,4)) - Isum = 1.0/bsum - res(i,j)=Isum*(B(i,j,1)*mp(i+1,j)+B(i,j,2)*mp(i-1,j)+& - B(i,j,3)*mp(i,j+1)+B(i,j,4)*mp(i,j-1)) - mp(i,j) + if (fill(i,j) == 1) then + B(i,j,1)=1-nm(i+1,j);B(i,j,2)=1-nm(i-1,j) + B(i,j,3)=1-nm(i,j+1);B(i,j,4)=1-nm(i,j-1) endif enddo enddo - res(:,:)=res(:,:)*sor - do j=1,nj - do i=1,ni - mp(i,j)=mp(i,j)+res(i,j) + do n=1,niter + do j=1,nj + do i=1,ni + if (fill(i,j) == 1) then + bsum = real(B(i,j,1)+B(i,j,2)+B(i,j,3)+B(i,j,4)) + Isum = 1.0/bsum + res(i,j)=Isum*(B(i,j,1)*mp(i+1,j)+B(i,j,2)*mp(i-1,j)+& + B(i,j,3)*mp(i,j+1)+B(i,j,4)*mp(i,j-1)) - mp(i,j) + endif + enddo enddo - enddo - - zi(:,:)=mp(1:ni,1:nj) - mp = fill_boundaries(zi,cyclic_x,tripolar_n) -end do - + res(:,:)=res(:,:)*sor + do j=1,nj + do i=1,ni + mp(i,j)=mp(i,j)+res(i,j) + enddo + enddo -return + zi(:,:)=mp(1:ni,1:nj) + mp = fill_boundaries(zi,cyclic_x,tripolar_n) + enddo end subroutine smooth_heights diff --git a/src/framework/MOM_intrinsic_functions.F90 b/src/framework/MOM_intrinsic_functions.F90 index 6e829c2072..fdda8849ae 100644 --- a/src/framework/MOM_intrinsic_functions.F90 +++ b/src/framework/MOM_intrinsic_functions.F90 @@ -1,31 +1,28 @@ +!> A module with intrinsic functions that are used by MOM but are not supported +!! by some compilers. module MOM_intrinsic_functions ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* This module holds intrinsic functions which are used by MOM but * -!* are not supported by some compilers. * -!* * -!********+*********+*********+*********+*********+*********+*********+** +implicit none ; private - implicit none - private +public :: invcosh - public :: invcosh +contains - contains - - function invcosh(x) - real, intent(in) :: x - real :: invcosh +!> Evaluate the inverse cosh, either using a math library or an +!! equivalent expression +function invcosh(x) + real, intent(in) :: x !< The argument of the inverse of cosh. NaNs will + !! occur if x<1, but there is no error checking + real :: invcosh #ifdef __INTEL_COMPILER - invcosh=acosh(x) + invcosh = acosh(x) #else - invcosh=log(x+sqrt(x*x-1)) + invcosh = log(x+sqrt(x*x-1)) #endif - end function invcosh +end function invcosh end module MOM_intrinsic_functions diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index d708fcdf27..c516c96e86 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -6,6 +6,7 @@ module MOM_io use MOM_error_handler, only : MOM_error, NOTE, FATAL, WARNING use MOM_domains, only : MOM_domain_type, AGRID, BGRID_NE, CGRID_NE +use MOM_domains, only : get_simple_array_i_ind, get_simple_array_j_ind use MOM_file_parser, only : log_version, param_file_type use MOM_grid, only : ocean_grid_type use MOM_dyn_horgrid, only : dyn_horgrid_type @@ -17,7 +18,7 @@ module MOM_io use fms_io_mod, only : file_exist, field_size, read_data use fms_io_mod, only : field_exists => field_exist, io_infra_end=>fms_io_exit use fms_io_mod, only : get_filename_appendix => get_filename_appendix -use mpp_domains_mod, only : domain1d, mpp_get_domain_components +use mpp_domains_mod, only : domain1d, domain2d, mpp_get_domain_components use mpp_domains_mod, only : CENTER, CORNER, NORTH_FACE=>NORTH, EAST_FACE=>EAST use mpp_io_mod, only : open_file => mpp_open, close_file => mpp_close use mpp_io_mod, only : mpp_write_meta, write_field => mpp_write, mpp_get_info @@ -30,7 +31,7 @@ module MOM_io use mpp_io_mod, only : MPP_APPEND, MPP_MULTI, MPP_OVERWR, MPP_NETCDF, MPP_RDONLY use mpp_io_mod, only : get_file_info=>mpp_get_info, get_file_atts=>mpp_get_atts use mpp_io_mod, only : get_file_fields=>mpp_get_fields, get_file_times=>mpp_get_times -use mpp_io_mod, only : read_field=>mpp_read, io_infra_init=>mpp_io_init +use mpp_io_mod, only : io_infra_init=>mpp_io_init use netcdf @@ -38,7 +39,7 @@ module MOM_io public :: close_file, create_file, field_exists, field_size, fieldtype, get_filename_appendix public :: file_exists, flush_file, get_file_info, get_file_atts, get_file_fields -public :: get_file_times, open_file, read_axis_data, read_data, read_field +public :: get_file_times, open_file, read_axis_data, read_data public :: num_timelevels, MOM_read_data, MOM_read_vector, ensembler public :: reopen_file, slasher, write_field, write_version_number, MOM_io_init public :: open_namelist_file, check_nml_error, io_infra_init, io_infra_end @@ -63,11 +64,13 @@ module MOM_io !! convert from intensive to extensive end type vardesc +!> Indicate whether a file exists, perhaps with domain decomposition interface file_exists - module procedure file_exist + module procedure FMS_file_exists module procedure MOM_file_exists end interface +!> Read a data field from a file interface MOM_read_data module procedure MOM_read_data_4d module procedure MOM_read_data_3d @@ -75,6 +78,7 @@ module MOM_io module procedure MOM_read_data_1d end interface +!> Read a pair of data fields representing the two components of a vector from a file interface MOM_read_vector module procedure MOM_read_vector_3d module procedure MOM_read_vector_2d @@ -93,7 +97,7 @@ subroutine create_file(unit, filename, vars, novars, fields, threading, timeunit integer, intent(in) :: novars !< number of fields written to filename type(fieldtype), intent(inout) :: fields(:) !< array of fieldtypes for each variable integer, optional, intent(in) :: threading !< SINGLE_FILE or MULTIPLE - real, optional, intent(in) :: timeunit !< length, in seconds, of the units for time. The + real, optional, intent(in) :: timeunit !< length of the units for time [s]. The !! default value is 86400.0, for 1 day. type(ocean_grid_type), optional, intent(in) :: G !< ocean horizontal grid structure; G or dG !! is required if the new file uses any @@ -151,9 +155,7 @@ subroutine create_file(unit, filename, vars, novars, fields, threading, timeunit endif one_file = .true. - if (domain_set) then - one_file = ((thread == SINGLE_FILE) .or. .not.Domain%use_io_layout) - endif + if (domain_set) one_file = (thread == SINGLE_FILE) if (one_file) then call open_file(unit, filename, MPP_OVERWR, MPP_NETCDF, threading=thread) @@ -216,7 +218,7 @@ subroutine create_file(unit, filename, vars, novars, fields, threading, timeunit call MOM_error(WARNING, "MOM_io create_file: "//trim(vars(k)%name)//& " has unrecognized t_grid "//trim(vars(k)%t_grid)) end select - end do + enddo if ((use_lath .or. use_lonh .or. use_latq .or. use_lonq)) then if (.not.domain_set) call MOM_error(FATAL, "create_file: "//& @@ -227,8 +229,9 @@ subroutine create_file(unit, filename, vars, novars, fields, threading, timeunit if ((use_layer .or. use_int) .and. .not.present(GV)) call MOM_error(FATAL, & "create_file: A vertical grid type is required to create a file with a vertical coordinate.") -! Specify all optional arguments to mpp_write_meta: name, units, longname, cartesian, calendar, sense, domain, data, min) -! Otherwise if optional arguments are added to mpp_write_meta the compiler may (and in case of GNU is) get confused and crash. +! Specify all optional arguments to mpp_write_meta: name, units, longname, cartesian, calendar, sense, +! domain, data, min). Otherwise if optional arguments are added to mpp_write_meta the compiler may +! (and in case of GNU does) get confused and crash. if (use_lath) & call mpp_write_meta(unit, axis_lath, name="lath", units=y_axis_units, longname="Latitude", & cartesian='Y', domain = y_domain, data=gridLatT(jsg:jeg)) @@ -259,13 +262,13 @@ subroutine create_file(unit, filename, vars, novars, fields, threading, timeunit ! Set appropriate units, depending on the value. if (timeunit < 0.0) then time_units = "days" ! The default value. - else if ((timeunit >= 0.99) .and. (timeunit < 1.01)) then + elseif ((timeunit >= 0.99) .and. (timeunit < 1.01)) then time_units = "seconds" - else if ((timeunit >= 3599.0) .and. (timeunit < 3601.0)) then + elseif ((timeunit >= 3599.0) .and. (timeunit < 3601.0)) then time_units = "hours" - else if ((timeunit >= 86399.0) .and. (timeunit < 86401.0)) then + elseif ((timeunit >= 86399.0) .and. (timeunit < 86401.0)) then time_units = "days" - else if ((timeunit >= 3.0e7) .and. (timeunit < 3.2e7)) then + elseif ((timeunit >= 3.0e7) .and. (timeunit < 3.2e7)) then time_units = "years" else write(time_units,'(es8.2," s")') timeunit @@ -322,7 +325,7 @@ subroutine create_file(unit, filename, vars, novars, fields, threading, timeunit end select pack = 1 - if(present(checksums)) then + if (present(checksums)) then call mpp_write_meta(unit, fields(k), axes(1:numaxes), vars(k)%name, vars(k)%units, & vars(k)%longname, pack = pack, checksum=checksums(k,:)) else @@ -354,7 +357,7 @@ subroutine reopen_file(unit, filename, vars, novars, fields, threading, timeunit integer, intent(in) :: novars !< number of fields written to filename type(fieldtype), intent(inout) :: fields(:) !< array of fieldtypes for each variable integer, optional, intent(in) :: threading !< SINGLE_FILE or MULTIPLE - real, optional, intent(in) :: timeunit !< length, in seconds, of the units for time. The + real, optional, intent(in) :: timeunit !< length of the units for time [s]. The !! default value is 86400.0, for 1 day. type(ocean_grid_type), optional, intent(in) :: G !< ocean horizontal grid structure; G or dG !! is required if a new file uses any @@ -394,9 +397,7 @@ subroutine reopen_file(unit, filename, vars, novars, fields, threading, timeunit endif one_file = .true. - if (domain_set) then - one_file = ((thread == SINGLE_FILE) .or. .not.Domain%use_io_layout) - endif + if (domain_set) one_file = (thread == SINGLE_FILE) if (one_file) then call open_file(unit, filename, MPP_APPEND, MPP_NETCDF, threading=thread) @@ -425,17 +426,18 @@ subroutine reopen_file(unit, filename, vars, novars, fields, threading, timeunit ! call mpp_get_field_atts(fields(i),name) ! !if (trim(name) /= trim(vars%name) then ! !write (mesg,'("Reopening file ",a," variable ",a," is called ",a,".")',& -! ! filename,vars%name,name); +! ! filename,vars%name,name) ! !call MOM_error(NOTE,"MOM_io: "//mesg) ! enddo endif end subroutine reopen_file - +!> Read the data associated with a named axis in a file subroutine read_axis_data(filename, axis_name, var) - character(len=*), intent(in) :: filename, axis_name - real, dimension(:), intent(out) :: var + character(len=*), intent(in) :: filename !< Name of the file to read + character(len=*), intent(in) :: axis_name !< Name of the axis to read + real, dimension(:), intent(out) :: var !< The axis location data integer :: i,len,unit, ndim, nvar, natt, ntime logical :: axis_found @@ -635,19 +637,19 @@ end function var_desc !! All arguments are optional, except the vardesc type to be modified. subroutine modify_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & cmor_field_name, cmor_units, cmor_longname, conversion, caller) - type(vardesc), intent(inout) :: vd !< vardesc type that is modified - character(len=*), optional, intent(in) :: name !< name of variable - character(len=*), optional, intent(in) :: units !< units of variable - character(len=*), optional, intent(in) :: longname !< long name of variable - character(len=*), optional, intent(in) :: hor_grid !< horizonal staggering of variable - character(len=*), optional, intent(in) :: z_grid !< vertical staggering of variable - character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1 - character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name - character(len=*), optional, intent(in) :: cmor_units !< CMOR physical dimensions of variable - character(len=*), optional, intent(in) :: cmor_longname !< CMOR long name - real , optional, intent(in) :: conversion !< for unit conversions, such as needed to - !! convert from intensive to extensive - character(len=*), optional, intent(in) :: caller !< calling routine? + type(vardesc), intent(inout) :: vd !< vardesc type that is modified + character(len=*), optional, intent(in) :: name !< name of variable + character(len=*), optional, intent(in) :: units !< units of variable + character(len=*), optional, intent(in) :: longname !< long name of variable + character(len=*), optional, intent(in) :: hor_grid !< horizonal staggering of variable + character(len=*), optional, intent(in) :: z_grid !< vertical staggering of variable + character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1 + character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name + character(len=*), optional, intent(in) :: cmor_units !< CMOR physical dimensions of variable + character(len=*), optional, intent(in) :: cmor_longname !< CMOR long name + real , optional, intent(in) :: conversion !< for unit conversions, such as needed + !! to convert from intensive to extensive + character(len=*), optional, intent(in) :: caller !< calling routine? character(len=120) :: cllr cllr = "mod_vardesc" @@ -828,24 +830,43 @@ function MOM_file_exists(filename, MOM_Domain) end function MOM_file_exists +!> Returns true if the named file or its domain-decomposed variant exists. +function FMS_file_exists(filename, domain, no_domain) + character(len=*), intent(in) :: filename !< The name of the file being inquired about + type(domain2d), optional, intent(in) :: domain !< The mpp domain2d that describes the decomposition + logical, optional, intent(in) :: no_domain !< This file does not use domain decomposition +! This function uses the fms_io function file_exist to determine whether +! a named file (or its decomposed variant) exists. + + logical :: FMS_file_exists + + FMS_file_exists = file_exist(filename, domain, no_domain) + +end function FMS_file_exists !> This function uses the fms_io function read_data to read 1-D !! data field named "fieldname" from file "filename". -subroutine MOM_read_data_1d(filename, fieldname, data, timelevel) +subroutine MOM_read_data_1d(filename, fieldname, data, timelevel, scale) character(len=*), intent(in) :: filename !< The name of the file to read character(len=*), intent(in) :: fieldname !< The variable name of the data in the file real, dimension(:), intent(inout) :: data !< The 1-dimensional array into which the data integer, optional, intent(in) :: timelevel !< The time level in the file to read + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied + !! by before they are returned. call read_data(filename, fieldname, data, timelevel=timelevel, no_domain=.true.) + if (present(scale)) then ; if (scale /= 1.0) then + data(:) = scale*data(:) + endif ; endif + end subroutine MOM_read_data_1d !> This function uses the fms_io function read_data to read a distributed !! 2-D data field named "fieldname" from file "filename". Valid values for !! "position" include CORNER, CENTER, EAST_FACE and NORTH_FACE. subroutine MOM_read_data_2d(filename, fieldname, data, MOM_Domain, & - timelevel, position) + timelevel, position, scale) character(len=*), intent(in) :: filename !< The name of the file to read character(len=*), intent(in) :: fieldname !< The variable name of the data in the file real, dimension(:,:), intent(inout) :: data !< The 2-dimensional array into which the data @@ -853,17 +874,27 @@ subroutine MOM_read_data_2d(filename, fieldname, data, MOM_Domain, & type(MOM_domain_type), intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition integer, optional, intent(in) :: timelevel !< The time level in the file to read integer, optional, intent(in) :: position !< A flag indicating where this data is located + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied + !! by before they are returned. + + integer :: is, ie, js, je call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & timelevel=timelevel, position=position) + if (present(scale)) then ; if (scale /= 1.0) then + call get_simple_array_i_ind(MOM_Domain, size(data,1), is, ie) + call get_simple_array_j_ind(MOM_Domain, size(data,2), js, je) + data(is:ie,js:je) = scale*data(is:ie,js:je) + endif ; endif + end subroutine MOM_read_data_2d !> This function uses the fms_io function read_data to read a distributed !! 3-D data field named "fieldname" from file "filename". Valid values for !! "position" include CORNER, CENTER, EAST_FACE and NORTH_FACE. subroutine MOM_read_data_3d(filename, fieldname, data, MOM_Domain, & - timelevel, position) + timelevel, position, scale) character(len=*), intent(in) :: filename !< The name of the file to read character(len=*), intent(in) :: fieldname !< The variable name of the data in the file real, dimension(:,:,:), intent(inout) :: data !< The 3-dimensional array into which the data @@ -871,17 +902,27 @@ subroutine MOM_read_data_3d(filename, fieldname, data, MOM_Domain, & type(MOM_domain_type), intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition integer, optional, intent(in) :: timelevel !< The time level in the file to read integer, optional, intent(in) :: position !< A flag indicating where this data is located + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied + !! by before they are returned. + + integer :: is, ie, js, je call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & timelevel=timelevel, position=position) + if (present(scale)) then ; if (scale /= 1.0) then + call get_simple_array_i_ind(MOM_Domain, size(data,1), is, ie) + call get_simple_array_j_ind(MOM_Domain, size(data,2), js, je) + data(is:ie,js:je,:) = scale*data(is:ie,js:je,:) + endif ; endif + end subroutine MOM_read_data_3d !> This function uses the fms_io function read_data to read a distributed !! 4-D data field named "fieldname" from file "filename". Valid values for !! "position" include CORNER, CENTER, EAST_FACE and NORTH_FACE. subroutine MOM_read_data_4d(filename, fieldname, data, MOM_Domain, & - timelevel, position) + timelevel, position, scale) character(len=*), intent(in) :: filename !< The name of the file to read character(len=*), intent(in) :: fieldname !< The variable name of the data in the file real, dimension(:,:,:,:), intent(inout) :: data !< The 4-dimensional array into which the data @@ -889,10 +930,20 @@ subroutine MOM_read_data_4d(filename, fieldname, data, MOM_Domain, & type(MOM_domain_type), intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition integer, optional, intent(in) :: timelevel !< The time level in the file to read integer, optional, intent(in) :: position !< A flag indicating where this data is located + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied + !! by before they are returned. + + integer :: is, ie, js, je call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & timelevel=timelevel, position=position) + if (present(scale)) then ; if (scale /= 1.0) then + call get_simple_array_i_ind(MOM_Domain, size(data,1), is, ie) + call get_simple_array_j_ind(MOM_Domain, size(data,2), js, je) + data(is:ie,js:je,:,:) = scale*data(is:ie,js:je,:,:) + endif ; endif + end subroutine MOM_read_data_4d @@ -900,7 +951,7 @@ end subroutine MOM_read_data_4d !! 2-D data fields with names given by "[uv]_fieldname" from file "filename". Valid values for !! "stagger" include CGRID_NE, BGRID_NE, and AGRID. subroutine MOM_read_vector_2d(filename, u_fieldname, v_fieldname, u_data, v_data, MOM_Domain, & - timelevel, stagger, scalar_pair) + timelevel, stagger, scalar_pair, scale) character(len=*), intent(in) :: filename !< The name of the file to read character(len=*), intent(in) :: u_fieldname !< The variable name of the u data in the file character(len=*), intent(in) :: v_fieldname !< The variable name of the v data in the file @@ -911,8 +962,10 @@ subroutine MOM_read_vector_2d(filename, u_fieldname, v_fieldname, u_data, v_data type(MOM_domain_type), intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition integer, optional, intent(in) :: timelevel !< The time level in the file to read integer, optional, intent(in) :: stagger !< A flag indicating where this vector is discretized - logical, optional, intent(in) :: scalar_pair !< If true, a pair of scalars are to be read.cretized - + logical, optional, intent(in) :: scalar_pair !< If true, a pair of scalars are to be read.cretized + real, optional, intent(in) :: scale !< A scaling factor that the fields are multiplied + !! by before they are returned. + integer :: is, ie, js, je integer :: u_pos, v_pos u_pos = EAST_FACE ; v_pos = NORTH_FACE @@ -927,6 +980,15 @@ subroutine MOM_read_vector_2d(filename, u_fieldname, v_fieldname, u_data, v_data call read_data(filename, v_fieldname, v_data, MOM_Domain%mpp_domain, & timelevel=timelevel, position=v_pos) + if (present(scale)) then ; if (scale /= 1.0) then + call get_simple_array_i_ind(MOM_Domain, size(u_data,1), is, ie) + call get_simple_array_j_ind(MOM_Domain, size(u_data,2), js, je) + u_data(is:ie,js:je) = scale*u_data(is:ie,js:je) + call get_simple_array_i_ind(MOM_Domain, size(v_data,1), is, ie) + call get_simple_array_j_ind(MOM_Domain, size(v_data,2), js, je) + v_data(is:ie,js:je) = scale*v_data(is:ie,js:je) + endif ; endif + end subroutine MOM_read_vector_2d @@ -934,7 +996,7 @@ end subroutine MOM_read_vector_2d !! 3-D data fields with names given by "[uv]_fieldname" from file "filename". Valid values for !! "stagger" include CGRID_NE, BGRID_NE, and AGRID. subroutine MOM_read_vector_3d(filename, u_fieldname, v_fieldname, u_data, v_data, MOM_Domain, & - timelevel, stagger, scalar_pair) + timelevel, stagger, scalar_pair, scale) character(len=*), intent(in) :: filename !< The name of the file to read character(len=*), intent(in) :: u_fieldname !< The variable name of the u data in the file character(len=*), intent(in) :: v_fieldname !< The variable name of the v data in the file @@ -945,8 +1007,11 @@ subroutine MOM_read_vector_3d(filename, u_fieldname, v_fieldname, u_data, v_data type(MOM_domain_type), intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition integer, optional, intent(in) :: timelevel !< The time level in the file to read integer, optional, intent(in) :: stagger !< A flag indicating where this vector is discretized - logical, optional, intent(in) :: scalar_pair !< If true, a pair of scalars are to be read.cretized + logical, optional, intent(in) :: scalar_pair !< If true, a pair of scalars are to be read.cretized + real, optional, intent(in) :: scale !< A scaling factor that the fields are multiplied + !! by before they are returned. + integer :: is, ie, js, je integer :: u_pos, v_pos u_pos = EAST_FACE ; v_pos = NORTH_FACE @@ -961,6 +1026,15 @@ subroutine MOM_read_vector_3d(filename, u_fieldname, v_fieldname, u_data, v_data call read_data(filename, v_fieldname, v_data, MOM_Domain%mpp_domain, & timelevel=timelevel, position=v_pos) + if (present(scale)) then ; if (scale /= 1.0) then + call get_simple_array_i_ind(MOM_Domain, size(u_data,1), is, ie) + call get_simple_array_j_ind(MOM_Domain, size(u_data,2), js, je) + u_data(is:ie,js:je,:) = scale*u_data(is:ie,js:je,:) + call get_simple_array_i_ind(MOM_Domain, size(v_data,1), is, ie) + call get_simple_array_j_ind(MOM_Domain, size(v_data,2), js, je) + v_data(is:ie,js:je,:) = scale*v_data(is:ie,js:je,:) + endif ; endif + end subroutine MOM_read_vector_3d @@ -994,7 +1068,7 @@ end subroutine MOM_io_init !! !! * write_field: write a field to an open file. !! * write_time: write a value of the time axis to an open file. -!! * read_field: read a field from an open file. +!! * read_data: read a variable from an open file. !! * read_time: read a time from an open file. !! !! * name_output_file: provide a name for an output file based on a diff --git a/src/framework/MOM_memory_macros.h b/src/framework/MOM_memory_macros.h index 7de33e4949..0fc771f856 100644 --- a/src/framework/MOM_memory_macros.h +++ b/src/framework/MOM_memory_macros.h @@ -7,127 +7,185 @@ !//! \file MOM_memory_macros.h #ifdef STATIC_MEMORY_ +!/* Static memory allocation section */ + +!/// Deallocates array x when using dynamic memory mode. Does nothing in static memory mode. # define DEALLOC_(x) +!/// Allocates array x when using dynamic memory mode. Does nothing in static memory mode. # define ALLOC_(x) +!/// Attaches the ALLOCATABLE attribute to an array in dynamic memory mode. Does nothing in static memory mode. # define ALLOCABLE_ +!/// Attaches the POINTER attribute to an array in dynamic memory mode. Does nothing in static memory mode. # define PTR_ +!/// Nullify a pointer in dynamic memory mode. Does nothing in static memory mode. # define TO_NULL_ -! NIMEM and NJMEM are the maximum number of grid points in the -! x- and y-directions on each processsor. +!/* These are the macros that should be used when setting up ALLOCABLE_ or PTR_ (heap) variables. */ + +!/// Expands to : in dynamic memory mode, or is the i-shape of a tile in static memory mode. +!/// Use for heap (ALLOCABLE_ or PTR_) variables at h- or v- points. # define NIMEM_ (((NIGLOBAL_-1)/NIPROC_)+1+2*NIHALO_) +!/// Expands to : in dynamic memory mode, or is the j-shape of a tile in static memory mode. +!/// Use for heap (ALLOCABLE_ or PTR_) variables at h- or u- points. # define NJMEM_ (((NJGLOBAL_-1)/NJPROC_)+1+2*NJHALO_) -! These are the macros that should be used when setting up ALLOCABLE_ or -! PTR_ (heap) variables. # ifdef SYMMETRIC_MEMORY_ +!/// Expands to : or 0: in dynamic memory mode, or is the staggered i-shape of a tile in static memory mode. +!/// Use for heap (ALLOCABLE_ or PTR_) variables at q- or u- points. # define NIMEMB_ 0:NIMEM_ +!/// Expands to : or 0: in dynamic memory mode, or is the staggered j-shape of a tile in static memory mode. +!/// Use for heap (ALLOCABLE_ or PTR_) variables at q- or v- points. # define NJMEMB_ 0:NJMEM_ # else +!/// Expands to : or 0: in dynamic memory mode, or is the staggered i-shape of a tile in static memory mode. +!/// Use for heap (ALLOCABLE_ or PTR_) variables at q- or u- points. # define NIMEMB_ NIMEM_ +!/// Expands to : or 0: in dynamic memory mode, or is the staggered j-shape of a tile in static memory mode. +!/// Use for heap (ALLOCABLE_ or PTR_) variables at q- or v- points. # define NJMEMB_ NJMEM_ # endif +!/// Expands to : in dynamic memory mode, or to NIMEMB_ in static memory mode. +!/// Use for heap (ALLOCABLE_ or PTR_) variables at h- or v- points. # define NIMEMB_PTR_ NIMEMB_ +!/// Expands to : in dynamic memory mode, or to NJMEMB_ in static memory mode. +!/// Use for heap (ALLOCABLE_ or PTR_) variables at h- or u- points. # define NJMEMB_PTR_ NJMEMB_ +!/// Expands to 0: in dynamic memory mode, or is the staggered i-shape of a tile in static memory mode. +!/// Use for always-symmetric heap (ALLOCABLE_ or PTR_) variables at q- or u- points. # define NIMEMB_SYM_ 0:NIMEM_ +!/// Expands to 0: in dynamic memory mode, or is the staggered j-shape of a tile in static memory mode. +!/// Use for always-symmetric heap (ALLOCABLE_ or PTR_) variables at q- or v- points. # define NJMEMB_SYM_ 0:NJMEM_ +!/// Expands to : in dynamic memory mode or is to the number of layers in static memory mode. +!/// Use for heap (ALLOCABLE_ or PTR_) layer variables. # define NKMEM_ NK_ +!/// Expands to 0: in dynamic memory mode or to 0:NK_ in static memory mode. +!/// Use for heap (ALLOCABLE_ or PTR_) interface variables. # define NKMEM0_ 0:NK_ +!/// Expands to : in dynamic memory mode or to NK_+1 in static memory mode. +!/// Use for heap (ALLOCABLE_ or PTR_) interface variables. # define NK_INTERFACE_ NK_+1 +!/// Expands to : or 1. UNKNOWN PURPOSE! # define C1_ 1 +!/// Expands to : or 2. UNKNOWN PURPOSE! # define C2_ 2 +!/// Expands to : or 3. UNKNOWN PURPOSE! # define C3_ 3 -! These are the macros that should be used for subroutine arguments -! or for automatically allocated (stack) variables. + +!/* These are the macros that should be used for subroutine arguments or for automatically allocated (stack) variables. */ + +!/// The i-shape of a dummy argument staggered at h- or v-points. # define SZI_(G) NIMEM_ +!/// The j-shape of a dummy argument staggered at h- or u-points. # define SZJ_(G) NJMEM_ +!/// The k-shape of a layer dummy argument. # define SZK_(G) NK_ +!/// The k-shape of an interface dummy argument. # define SZK0_(G) 0:NK_ +!/// The i-shape of a dummy argument staggered at q- or u-points. # define SZIB_(G) NIMEMB_ +!/// The j-shape of a dummy argument staggered at q- or v-points. # define SZJB_(G) NJMEMB_ +!/// The i-shape of a symmetric dummy argument staggered at q- or u-points. # define SZIBS_(G) 0:NIMEM_ +!/// The j-shape of a symmetric dummy argument staggered at q- or v-points. # define SZJBS_(G) 0:NJMEM_ #else !/* Dynamic memory allocation section */ -!/*! Deallocates array x when using dynamic memory mode. Does nothing in static memory mode.*/ +!/// Deallocates array x when using dynamic memory mode. Does nothing in static memory mode. # define DEALLOC_(x) deallocate(x) -!/*! Allocates array x when using dynamic memory mode. Does nothing in static memory mode.*/ +!/// Allocates array x when using dynamic memory mode. Does nothing in static memory mode. # define ALLOC_(x) allocate(x) -!/*! Attaches the ALLOCATABLE attribute to an array in dynamic memory mode. Does nothing in static memory mode.*/ +!/// Attaches the ALLOCATABLE attribute to an array in dynamic memory mode. Does nothing in static memory mode. # define ALLOCABLE_ ,allocatable -!/*! Attaches the POINTER attribute to an array in dynamic memory mode. Does nothing in static memory mode.*/ +!/// Attaches the POINTER attribute to an array in dynamic memory mode. Does nothing in static memory mode. # define PTR_ ,pointer -!/*! Nullify a pointer in dynamic memory mode. Does nothing in static memory mode.*/ +!/// Nullify a pointer in dynamic memory mode. Does nothing in static memory mode. # define TO_NULL_ =>NULL() !/* These are the macros that should be used when setting up ALLOCABLE_ or PTR_ (heap) variables. */ -!/*! Expands to : in dynamic memory mode, or is the i-shape of a tile in static memory mode. Use for heap (ALLOCABLE_ or PTR_) variables at h- or v- points. */ +!/// Expands to : in dynamic memory mode, or is the i-shape of a tile in static memory mode. +!/// Use for heap (ALLOCABLE_ or PTR_) variables at h- or v- points. # define NIMEM_ : -!/*! Expands to : in dynamic memory mode, or is the j-shape of a tile in static memory mode. Use for heap (ALLOCABLE_ or PTR_) variables at h- or u- points. */ +!/// Expands to : in dynamic memory mode, or is the j-shape of a tile in static memory mode. +!/// Use for heap (ALLOCABLE_ or PTR_) variables at h- or u- points. # define NJMEM_ : -!/*! Expands to : in dynamic memory mode, or to NIMEMB_ in static memory mode. Use for heap (ALLOCABLE_ or PTR_) variables at h- or v- points. */ +!/// Expands to : in dynamic memory mode, or to NIMEMB_ in static memory mode. +!/// Use for heap (ALLOCABLE_ or PTR_) variables at h- or v- points. # define NIMEMB_PTR_ : -!/*! Expands to : in dynamic memory mode, or to NJMEMB_ in static memory mode. Use for heap (ALLOCABLE_ or PTR_) variables at h- or u- points. */ +!/// Expands to : in dynamic memory mode, or to NJMEMB_ in static memory mode. +!/// Use for heap (ALLOCABLE_ or PTR_) variables at h- or u- points. # define NJMEMB_PTR_ : # ifdef SYMMETRIC_MEMORY_ -!/*! Expands to : or 0: in dynamic memory mode, or is the staggered i-shape of a tile in static memory mode. Use for heap (ALLOCABLE_ or PTR_) variables at q- or u- points. */ +!/// Expands to : or 0: in dynamic memory mode, or is the staggered i-shape of a tile in static memory mode. +!/// Use for heap (ALLOCABLE_ or PTR_) variables at q- or u- points. # define NIMEMB_ 0: -!/*! Expands to : or 0: in dynamic memory mode, or is the staggered j-shape of a tile in static memory mode. Use for heap (ALLOCABLE_ or PTR_) variables at q- or v- points. */ +!/// Expands to : or 0: in dynamic memory mode, or is the staggered j-shape of a tile in static memory mode. +!/// Use for heap (ALLOCABLE_ or PTR_) variables at q- or v- points. # define NJMEMB_ 0: # else +!/// Expands to : or 0: in dynamic memory mode, or is the staggered i-shape of a tile in static memory mode. +!/// Use for heap (ALLOCABLE_ or PTR_) variables at q- or u- points. # define NIMEMB_ : +!/// Expands to : or 0: in dynamic memory mode, or is the staggered j-shape of a tile in static memory mode. +!/// Use for heap (ALLOCABLE_ or PTR_) variables at q- or v- points. # define NJMEMB_ : # endif -!/*! Expands to 0: in dynamic memory mode, or is the staggered i-shape of a tile in static memory mode. Use for always-symmetric heap (ALLOCABLE_ or PTR_) variables at q- or u- points. */ +!/// Expands to 0: in dynamic memory mode, or is the staggered i-shape of a tile in static memory mode. +!/// Use for always-symmetric heap (ALLOCABLE_ or PTR_) variables at q- or u- points. # define NIMEMB_SYM_ 0: -!/*! Expands to 0: in dynamic memory mode, or is the staggered j-shape of a tile in static memory mode. Use for always-symmetric heap (ALLOCABLE_ or PTR_) variables at q- or v- points. */ +!/// Expands to 0: in dynamic memory mode, or is the staggered j-shape of a tile in static memory mode. +!/// Use for always-symmetric heap (ALLOCABLE_ or PTR_) variables at q- or v- points. # define NJMEMB_SYM_ 0: -!/*! Expands to : in dynamic memory mode or is to the number of layers in static memory mode. Use for heap (ALLOCABLE_ or PTR_) layer variables. */ +!/// Expands to : in dynamic memory mode or is to the number of layers in static memory mode. +!/// Use for heap (ALLOCABLE_ or PTR_) layer variables. # define NKMEM_ : -!/*! Expands to 0: in dynamic memory mode or to 0:NK_ in static memory mode. Use for heap (ALLOCABLE_ or PTR_) interface variables. */ +!/// Expands to 0: in dynamic memory mode or to 0:NK_ in static memory mode. +!/// Use for heap (ALLOCABLE_ or PTR_) interface variables. # define NKMEM0_ 0: -!/*! Expands to : in dynamic memory mode or to NK_+1 in static memory mode. Use for heap (ALLOCABLE_ or PTR_) interface variables. */ +!/// Expands to : in dynamic memory mode or to NK_+1 in static memory mode. +!/// Use for heap (ALLOCABLE_ or PTR_) interface variables. # define NK_INTERFACE_ : -!/*! Expands to : or 1. UNKNOWN PURPOSE! */ +!/// Expands to : or 1. UNKNOWN PURPOSE! # define C1_ : -!/*! Expands to : or 2. UNKNOWN PURPOSE! */ +!/// Expands to : or 2. UNKNOWN PURPOSE! # define C2_ : -!/*! Expands to : or 3. UNKNOWN PURPOSE! */ +!/// Expands to : or 3. UNKNOWN PURPOSE! # define C3_ : -!/*! \todo Explain or remove C1_, C2_ and C3_ */ +!/// \todo Explain or remove C1_, C2_ and C3_ !/* These are the macros that should be used for subroutine arguments or for automatically allocated (stack) variables. */ -!/*! The i-shape of a dummy argument staggered at h- or v-points. */ +!/// The i-shape of a dummy argument staggered at h- or v-points. # define SZI_(G) G%isd:G%ied -!/*! The j-shape of a dummy argument staggered at h- or u-points. */ +!/// The j-shape of a dummy argument staggered at h- or u-points. # define SZJ_(G) G%jsd:G%jed -!/*! The k-shape of a layer dummy argument. */ +!/// The k-shape of a layer dummy argument. # define SZK_(G) G%ke -!/*! The k-shape of an interface dummy argument. */ +!/// The k-shape of an interface dummy argument. # define SZK0_(G) 0:G%ke -!/*! The i-shape of a dummy argument staggered at q- or u-points. */ +!/// The i-shape of a dummy argument staggered at q- or u-points. # define SZIB_(G) G%IsdB:G%IedB -!/*! The j-shape of a dummy argument staggered at q- or v-points. */ +!/// The j-shape of a dummy argument staggered at q- or v-points. # define SZJB_(G) G%JsdB:G%JedB -!/*! The i-shape of a symmetric dummy argument staggered at q- or u-points. */ +!/// The i-shape of a symmetric dummy argument staggered at q- or u-points. # define SZIBS_(G) G%isd-1:G%ied -!/*! The j-shape of a symmetric dummy argument staggered at q- or v-points. */ +!/// The j-shape of a symmetric dummy argument staggered at q- or v-points. # define SZJBS_(G) G%jsd-1:G%jed #endif !/* These dynamic size macros always give the same results (for now). */ -!/*! The i-shape of a dynamic dummy argument staggered at h- or v-points. */ +!/// The i-shape of a dynamic dummy argument staggered at h- or v-points. #define SZDI_(G) G%isd:G%ied -!/*! The i-shape of a dynamic dummy argument staggered at q- or u-points. */ +!/// The i-shape of a dynamic dummy argument staggered at q- or u-points. #define SZDIB_(G) G%IsdB:G%IedB -!/*! The j-shape of a dynamic dummy argument staggered at h- or u-points. */ +!/// The j-shape of a dynamic dummy argument staggered at h- or u-points. #define SZDJ_(G) G%jsd:G%jed -!/*! The j-shape of a dynamic dummy argument staggered at q- or v-points. */ +!/// The j-shape of a dynamic dummy argument staggered at q- or v-points. #define SZDJB_(G) G%JsdB:G%JedB diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index d397dede55..4d89dccc7b 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -1,63 +1,23 @@ +!> The MOM6 facility for reading and writing restart files, and querying what has been read. module MOM_restart ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Robert Hallberg, April 1994 - June 2002 * -!* * -!* This file contains four subroutines associated with saving * -!* restart files or restoring the model state from files. * -!* * -!* register_restart_field is used to specify the fields that will * -!* be written to restart files. * -!* * -!* Save_restart saves a restart file from which a simulation can * -!* be restarted with results that are identical to those which would * -!* have been attained if there had been no interruption. If this * -!* file would be larger than 2 Gbytes, it is broken up into a number * -!* of smaller files. * -!* * -!* The subroutine restore_state initializes the fields for the * -!* simulations from a number of restart files or other NetCDF files. * -!* Each restart field is initialized from the first file in the * -!* list in which it is found. The files are separated by spaces, * -!* and all must be in the specified directory. If 'r' is included * -!* in the list, it is expanded to include all of the restart files * -!* that are found in the directory. * -!* * -!* query_initialized returns true if a field (or the entire restart * -!* file) has been initialized from a restart file and false otherwise.* -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q, CoriolisBu * -!* j+1 > o > o > At ^: v * -!* j x ^ x ^ x At >: u * -!* j > o > o > At o: h, bathyT, tr * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 * -!* i i+1 * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** - use MOM_domains, only : pe_here, num_PEs 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_string_functions, only : lowercase use MOM_grid, only : ocean_grid_type use MOM_io, only : create_file, fieldtype, file_exists, open_file, close_file -use MOM_io, only : read_field, write_field, MOM_read_data, read_data, get_filename_appendix +use MOM_io, only : write_field, MOM_read_data, read_data, get_filename_appendix use MOM_io, only : get_file_info, get_file_atts, get_file_fields, get_file_times use MOM_io, only : vardesc, var_desc, query_vardesc, modify_vardesc use MOM_io, only : MULTIPLE, NETCDF_FILE, READONLY_FILE, SINGLE_FILE use MOM_io, only : CENTER, CORNER, NORTH_FACE, EAST_FACE -use MOM_time_manager, only : time_type, get_time, get_date, set_date, set_time -use MOM_time_manager, only : days_in_month +use MOM_time_manager, only : time_type, time_type_to_real, real_to_time +use MOM_time_manager, only : days_in_month, get_date, set_date use MOM_verticalGrid, only : verticalGrid_type -use mpp_mod, only: mpp_chksum +use mpp_mod, only: mpp_chksum,mpp_pe use mpp_io_mod, only: mpp_attribute_exist, mpp_get_atts implicit none ; private @@ -66,66 +26,73 @@ module MOM_restart public save_restart, query_initialized, restart_init_end, vardesc public restart_files_exist, determine_is_new_run, is_new_run +!> A type for making arrays of pointers to 4-d arrays type p4d - real, dimension(:,:,:,:), pointer :: p => NULL() + real, dimension(:,:,:,:), pointer :: p => NULL() !< A pointer to a 4d array end type p4d +!> A type for making arrays of pointers to 3-d arrays type p3d - real, dimension(:,:,:), pointer :: p => NULL() + real, dimension(:,:,:), pointer :: p => NULL() !< A pointer to a 3d array end type p3d +!> A type for making arrays of pointers to 2-d arrays type p2d - real, dimension(:,:), pointer :: p => NULL() + real, dimension(:,:), pointer :: p => NULL() !< A pointer to a 2d array end type p2d +!> A type for making arrays of pointers to 1-d arrays type p1d - real, dimension(:), pointer :: p => NULL() + real, dimension(:), pointer :: p => NULL() !< A pointer to a 1d array end type p1d +!> A type for making arrays of pointers to scalars type p0d - real, pointer :: p => NULL() + real, pointer :: p => NULL() !< A pointer to a scalar end type p0d +!> A structure with information about a single restart field type field_restart - type(vardesc) :: vars ! Descriptions of the fields that - ! are to be read from or written - ! to the restart file. - logical :: mand_var ! If .true. the run will abort if this - ! field is not successfully read - ! from the restart file. - logical :: initialized ! .true. if this field has been read - ! from the restart file. - character(len=32) :: var_name ! A name by which a variable may be queried. + type(vardesc) :: vars !< Description of a field that is to be read from or written + !! to the restart file. + logical :: mand_var !< If .true. the run will abort if this field is not successfully + !! read from the restart file. + logical :: initialized !< .true. if this field has been read from the restart file. + character(len=32) :: var_name !< A name by which a variable may be queried. end type field_restart +!> A restart registry and the control structure for restarts type, public :: MOM_restart_CS ; private - logical :: restart ! restart is set to .true. if the run has been started - ! from a full restart file. Otherwise some fields must - ! be initialized approximately. - integer :: novars = 0 ! The number of restart fields that have been registered. - logical :: parallel_restartfiles ! If true, each PE writes its own restart file, - ! otherwise they are combined internally. - logical :: large_file_support ! If true, NetCDF 3.6 or later is being used - ! and large-file-support is enabled. - logical :: new_run ! If true, the input filenames and restart file - ! existence will result in a new run that is not - ! initializedfrom restart files. - logical :: new_run_set = .false. ! If true, new_run has been determined for this restart_CS. - logical :: checksum_required ! 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. - character(len=240) :: restartfile ! The name or name root for MOM restart files. - + logical :: restart !< restart is set to .true. if the run has been started from a full restart + !! file. Otherwise some fields must be initialized approximately. + integer :: novars = 0 !< The number of restart fields that have been registered. + logical :: parallel_restartfiles !< If true, each PE writes its own restart file, + !! otherwise they are combined internally. + logical :: large_file_support !< If true, NetCDF 3.6 or later is being used + !! and large-file-support is enabled. + logical :: new_run !< If true, the input filenames and restart file existence will + !! result in a new run that is not initialized from restart files. + logical :: new_run_set = .false. !< If true, new_run has been determined for this restart_CS. + logical :: checksum_required !< 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. + character(len=240) :: restartfile !< The name or name root for MOM restart files. + + !> An array of descriptions of the registered fields type(field_restart), pointer :: restart_field(:) => NULL() + + !>@{ Pointers to the fields that have been registered for restarts type(p0d), pointer :: var_ptr0d(:) => NULL() type(p1d), pointer :: var_ptr1d(:) => NULL() type(p2d), pointer :: var_ptr2d(:) => NULL() type(p3d), pointer :: var_ptr3d(:) => NULL() type(p4d), pointer :: var_ptr4d(:) => NULL() - integer :: max_fields + !!@} + integer :: max_fields !< The maximum number of restart fields end type MOM_restart_CS +!> Register fields for restarts interface register_restart_field module procedure register_restart_field_ptr4d, register_restart_field_4d module procedure register_restart_field_ptr3d, register_restart_field_3d @@ -134,6 +101,7 @@ module MOM_restart module procedure register_restart_field_ptr0d, register_restart_field_0d end interface +!> Indicate whether a field has been read from a restart file interface query_initialized module procedure query_initialized_name module procedure query_initialized_0d, query_initialized_0d_name @@ -147,7 +115,8 @@ module MOM_restart !> Register a 3-d field for restarts, providing the metadata in a structure subroutine register_restart_field_ptr3d(f_ptr, var_desc, mandatory, CS) - real, dimension(:,:,:), target :: f_ptr !< A pointer to the field to be read or written + real, dimension(:,:,:), & + target, intent(in) :: f_ptr !< A pointer to the field to be read or written type(vardesc), intent(in) :: var_desc !< A structure with metadata about this variable logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. @@ -177,7 +146,8 @@ end subroutine register_restart_field_ptr3d !> Register a 4-d field for restarts, providing the metadata in a structure subroutine register_restart_field_ptr4d(f_ptr, var_desc, mandatory, CS) - real, dimension(:,:,:,:), target :: f_ptr !< A pointer to the field to be read or written + real, dimension(:,:,:,:), & + target, intent(in) :: f_ptr !< A pointer to the field to be read or written type(vardesc), intent(in) :: var_desc !< A structure with metadata about this variable logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. @@ -207,7 +177,8 @@ end subroutine register_restart_field_ptr4d !> Register a 2-d field for restarts, providing the metadata in a structure subroutine register_restart_field_ptr2d(f_ptr, var_desc, mandatory, CS) - real, dimension(:,:), target :: f_ptr !< A pointer to the field to be read or written + real, dimension(:,:), & + target, intent(in) :: f_ptr !< A pointer to the field to be read or written type(vardesc), intent(in) :: var_desc !< A structure with metadata about this variable logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. @@ -237,7 +208,7 @@ end subroutine register_restart_field_ptr2d !> Register a 1-d field for restarts, providing the metadata in a structure subroutine register_restart_field_ptr1d(f_ptr, var_desc, mandatory, CS) - real, dimension(:), target :: f_ptr !< A pointer to the field to be read or written + real, dimension(:), target, intent(in) :: f_ptr !< A pointer to the field to be read or written type(vardesc), intent(in) :: var_desc !< A structure with metadata about this variable logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. @@ -267,7 +238,7 @@ end subroutine register_restart_field_ptr1d !> Register a 0-d field for restarts, providing the metadata in a structure subroutine register_restart_field_ptr0d(f_ptr, var_desc, mandatory, CS) - real, target :: f_ptr !< A pointer to the field to be read or written + real, target, intent(in) :: f_ptr !< A pointer to the field to be read or written type(vardesc), intent(in) :: var_desc !< A structure with metadata about this variable logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. @@ -300,7 +271,8 @@ end subroutine register_restart_field_ptr0d !> Register a 4-d field for restarts, providing the metadata as individual arguments subroutine register_restart_field_4d(f_ptr, name, mandatory, CS, longname, units, & hor_grid, z_grid, t_grid) - real, dimension(:,:,:,:), target :: f_ptr !< A pointer to the field to be read or written + real, dimension(:,:,:,:), & + target, intent(in) :: f_ptr !< A pointer to the field to be read or written character(len=*), intent(in) :: name !< variable name to be used in the restart file logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. @@ -326,7 +298,8 @@ end subroutine register_restart_field_4d !> Register a 3-d field for restarts, providing the metadata as individual arguments subroutine register_restart_field_3d(f_ptr, name, mandatory, CS, longname, units, & hor_grid, z_grid, t_grid) - real, dimension(:,:,:), target :: f_ptr !< A pointer to the field to be read or written + real, dimension(:,:,:), & + target, intent(in) :: f_ptr !< A pointer to the field to be read or written character(len=*), intent(in) :: name !< variable name to be used in the restart file logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. @@ -352,7 +325,8 @@ end subroutine register_restart_field_3d !> Register a 2-d field for restarts, providing the metadata as individual arguments subroutine register_restart_field_2d(f_ptr, name, mandatory, CS, longname, units, & hor_grid, z_grid, t_grid) - real, dimension(:,:), target :: f_ptr !< A pointer to the field to be read or written + real, dimension(:,:), & + target, intent(in) :: f_ptr !< A pointer to the field to be read or written character(len=*), intent(in) :: name !< variable name to be used in the restart file logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. @@ -380,7 +354,7 @@ end subroutine register_restart_field_2d !> Register a 1-d field for restarts, providing the metadata as individual arguments subroutine register_restart_field_1d(f_ptr, name, mandatory, CS, longname, units, & hor_grid, z_grid, t_grid) - real, dimension(:), target :: f_ptr !< A pointer to the field to be read or written + real, dimension(:), target, intent(in) :: f_ptr !< A pointer to the field to be read or written character(len=*), intent(in) :: name !< variable name to be used in the restart file logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. @@ -408,7 +382,7 @@ end subroutine register_restart_field_1d !> Register a 0-d field for restarts, providing the metadata as individual arguments subroutine register_restart_field_0d(f_ptr, name, mandatory, CS, longname, units, & t_grid) - real, target :: f_ptr !< A pointer to the field to be read or written + real, target, intent(in) :: f_ptr !< A pointer to the field to be read or written character(len=*), intent(in) :: name !< variable name to be used in the restart file logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. @@ -432,15 +406,12 @@ end subroutine register_restart_field_0d !> query_initialized_name determines whether a named field has been successfully !! read from a restart file yet. function query_initialized_name(name, CS) result(query_initialized) - character(len=*) :: name - type(MOM_restart_CS), pointer :: CS + character(len=*), intent(in) :: name !< The name of the field that is being queried + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized ! This subroutine returns .true. if the field referred to by name has ! initialized from a restart file, and .false. otherwise. -! -! Arguments: name - A pointer to the field that is being queried. -! (in) CS - The control structure returned by a previous call to -! restart_init. + integer :: m,n if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "query_initialized: Module must be initialized before it is used.") @@ -467,16 +438,14 @@ function query_initialized_name(name, CS) result(query_initialized) end function query_initialized_name +!> Indicate whether the field pointed to by f_ptr has been initialized from a restart file. function query_initialized_0d(f_ptr, CS) result(query_initialized) - real, target :: f_ptr - type(MOM_restart_CS), pointer :: CS + real, target, intent(in) :: f_ptr !< A pointer to the field that is being queried + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized ! This subroutine tests whether the field pointed to by f_ptr has ! been initialized from a restart file. -! -! Arguments: f_ptr - A pointer to the field that is being queried. -! (in) CS - The control structure returned by a previous call to -! restart_init. + integer :: m,n if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "query_initialized: Module must be initialized before it is used.") @@ -496,16 +465,14 @@ function query_initialized_0d(f_ptr, CS) result(query_initialized) end function query_initialized_0d +!> Indicate whether the field pointed to by f_ptr has been initialized from a restart file. function query_initialized_1d(f_ptr, CS) result(query_initialized) - real, dimension(:), target :: f_ptr - type(MOM_restart_CS), pointer :: CS + real, dimension(:), target, intent(in) :: f_ptr !< A pointer to the field that is being queried + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized ! This subroutine tests whether the field pointed to by f_ptr has ! been initialized from a restart file. -! -! Arguments: f_ptr - A pointer to the field that is being queried. -! (in) CS - The control structure returned by a previous call to -! restart_init. + integer :: m,n if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "query_initialized: Module must be initialized before it is used.") @@ -525,16 +492,15 @@ function query_initialized_1d(f_ptr, CS) result(query_initialized) end function query_initialized_1d +!> Indicate whether the field pointed to by f_ptr has been initialized from a restart file. function query_initialized_2d(f_ptr, CS) result(query_initialized) - real, dimension(:,:), target :: f_ptr - type(MOM_restart_CS), pointer :: CS + real, dimension(:,:), & + target, intent(in) :: f_ptr !< A pointer to the field that is being queried + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized ! This subroutine tests whether the field pointed to by f_ptr has ! been initialized from a restart file. -! -! Arguments: f_ptr - A pointer to the field that is being queried. -! (in) CS - The control structure returned by a previous call to -! restart_init. + integer :: m,n if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "query_initialized: Module must be initialized before it is used.") @@ -554,16 +520,15 @@ function query_initialized_2d(f_ptr, CS) result(query_initialized) end function query_initialized_2d +!> Indicate whether the field pointed to by f_ptr has been initialized from a restart file. function query_initialized_3d(f_ptr, CS) result(query_initialized) - real, dimension(:,:,:), target :: f_ptr - type(MOM_restart_CS), pointer :: CS + real, dimension(:,:,:), & + target, intent(in) :: f_ptr !< A pointer to the field that is being queried + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized ! This subroutine tests whether the field pointed to by f_ptr has ! been initialized from a restart file. -! -! Arguments: f_ptr - A pointer to the field that is being queried. -! (in) CS - The control structure returned by a previous call to -! restart_init. + integer :: m,n if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "query_initialized: Module must be initialized before it is used.") @@ -583,16 +548,15 @@ function query_initialized_3d(f_ptr, CS) result(query_initialized) end function query_initialized_3d +!> Indicate whether the field pointed to by f_ptr has been initialized from a restart file. function query_initialized_4d(f_ptr, CS) result(query_initialized) - real, dimension(:,:,:,:), target :: f_ptr - type(MOM_restart_CS), pointer :: CS + real, dimension(:,:,:,:), & + target, intent(in) :: f_ptr !< A pointer to the field that is being queried + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized ! This subroutine tests whether the field pointed to by f_ptr has ! been initialized from a restart file. -! -! Arguments: f_ptr - A pointer to the field that is being queried. -! (in) CS - The control structure returned by a previous call to -! restart_init. + integer :: m,n if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "query_initialized: Module must be initialized before it is used.") @@ -612,18 +576,16 @@ function query_initialized_4d(f_ptr, CS) result(query_initialized) end function query_initialized_4d +!> Indicate whether the field pointed to by f_ptr or with the specified variable +!! name has been initialized from a restart file. function query_initialized_0d_name(f_ptr, name, CS) result(query_initialized) - real, target :: f_ptr - character(len=*) :: name - type(MOM_restart_CS), pointer :: CS + real, target, intent(in) :: f_ptr !< A pointer to the field that is being queried + character(len=*), intent(in) :: name !< The name of the field that is being queried + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized ! This subroutine tests whether the field pointed to by f_ptr or with the ! specified variable name has been initialized from a restart file. -! -! Arguments: f_ptr - A pointer to the field that is being queried. -! (in) name - The name of the field that is being queried. -! (in) CS - The control structure returned by a previous call to -! restart_init. + integer :: m,n if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "query_initialized: Module must be initialized before it is used.") @@ -649,18 +611,17 @@ function query_initialized_0d_name(f_ptr, name, CS) result(query_initialized) end function query_initialized_0d_name +!> Indicate whether the field pointed to by f_ptr or with the specified variable +!! name has been initialized from a restart file. function query_initialized_1d_name(f_ptr, name, CS) result(query_initialized) - real, dimension(:), target :: f_ptr - character(len=*) :: name - type(MOM_restart_CS), pointer :: CS + real, dimension(:), & + target, intent(in) :: f_ptr !< A pointer to the field that is being queried + character(len=*), intent(in) :: name !< The name of the field that is being queried + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized ! This subroutine tests whether the field pointed to by f_ptr or with the ! specified variable name has been initialized from a restart file. -! -! Arguments: f_ptr - A pointer to the field that is being queried. -! (in) name - The name of the field that is being queried. -! (in) CS - The control structure returned by a previous call to -! restart_init. + integer :: m,n if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "query_initialized: Module must be initialized before it is used.") @@ -686,18 +647,17 @@ function query_initialized_1d_name(f_ptr, name, CS) result(query_initialized) end function query_initialized_1d_name +!> Indicate whether the field pointed to by f_ptr or with the specified variable +!! name has been initialized from a restart file. function query_initialized_2d_name(f_ptr, name, CS) result(query_initialized) - real, dimension(:,:), target :: f_ptr - character(len=*) :: name - type(MOM_restart_CS), pointer :: CS + real, dimension(:,:), & + target, intent(in) :: f_ptr !< A pointer to the field that is being queried + character(len=*), intent(in) :: name !< The name of the field that is being queried + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized ! This subroutine tests whether the field pointed to by f_ptr or with the ! specified variable name has been initialized from a restart file. -! -! Arguments: f_ptr - A pointer to the field that is being queried. -! (in) name - The name of the field that is being queried. -! (in) CS - The control structure returned by a previous call to -! restart_init. + integer :: m,n if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "query_initialized: Module must be initialized before it is used.") @@ -723,18 +683,17 @@ function query_initialized_2d_name(f_ptr, name, CS) result(query_initialized) end function query_initialized_2d_name +!> Indicate whether the field pointed to by f_ptr or with the specified variable +!! name has been initialized from a restart file. function query_initialized_3d_name(f_ptr, name, CS) result(query_initialized) - real, dimension(:,:,:), target :: f_ptr - character(len=*) :: name - type(MOM_restart_CS), pointer :: CS + real, dimension(:,:,:), & + target, intent(in) :: f_ptr !< A pointer to the field that is being queried + character(len=*), intent(in) :: name !< The name of the field that is being queried + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized ! This subroutine tests whether the field pointed to by f_ptr or with the ! specified variable name has been initialized from a restart file. -! -! Arguments: f_ptr - A pointer to the field that is being queried. -! (in) name - The name of the field that is being queried. -! (in) CS - The control structure returned by a previous call to -! restart_init. + integer :: m, n if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "query_initialized: Module must be initialized before it is used.") @@ -760,18 +719,17 @@ function query_initialized_3d_name(f_ptr, name, CS) result(query_initialized) end function query_initialized_3d_name +!> Indicate whether the field pointed to by f_ptr or with the specified variable +!! name has been initialized from a restart file. function query_initialized_4d_name(f_ptr, name, CS) result(query_initialized) - real, dimension(:,:,:,:), target :: f_ptr - character(len=*) :: name - type(MOM_restart_CS), pointer :: CS + real, dimension(:,:,:,:), & + target, intent(in) :: f_ptr !< A pointer to the field that is being queried + character(len=*), intent(in) :: name !< The name of the field that is being queried + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized ! This subroutine tests whether the field pointed to by f_ptr or with the ! specified variable name has been initialized from a restart file. -! -! Arguments: f_ptr - A pointer to the field that is being queried. -! (in) name - The name of the field that is being queried. -! (in) CS - The control structure returned by a previous call to -! restart_init. + integer :: m, n if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "query_initialized: Module must be initialized before it is used.") @@ -797,30 +755,25 @@ function query_initialized_4d_name(f_ptr, name, CS) result(query_initialized) end function query_initialized_4d_name +!> save_restart saves all registered variables to restart files. subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV) -! save_restart saves all registered variables to restart files. - character(len=*), intent(in) :: directory - type(time_type), intent(in) :: time - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(MOM_restart_CS), pointer :: CS - logical, optional, intent(in) :: time_stamped - character(len=*), optional, intent(in) :: filename + character(len=*), intent(in) :: directory !< The directory where the restart files + !! are to be written + type(time_type), intent(in) :: time !< The current model time + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(MOM_restart_CS), pointer :: CS !< The control structure returned by a previous + !! call to restart_init. + logical, optional, intent(in) :: time_stamped !< If present and true, add time-stamp + !! to the restart file names. + character(len=*), optional, intent(in) :: filename !< A filename that overrides the name in CS%restartfile. type(verticalGrid_type), optional, intent(in) :: GV !< The ocean's vertical grid structure -! Arguments: directory - The directory where the restart file goes. -! (in) time - The time of this restart file. -! (in) G - The ocean's grid structure. -! (in) CS - The control structure returned by a previous call to -! restart_init. -! (in, opt) time_stamped - If true, the restart file names include -! a unique time stamp. The default is false. -! (in, opt) filename - A filename that overrides the name in CS%restartfile. -! -! (in, opt) GV - The ocean's vertical grid structure. + + ! Local variables type(vardesc) :: vars(CS%max_fields) ! Descriptions of the fields that ! are to be read from the restart file. type(fieldtype) :: fields(CS%max_fields) ! - character(len=200) :: restartpath ! The restart file path (dir/file). - character(len=80) :: restartname ! The restart file name (no dir). + character(len=512) :: restartpath ! The restart file path (dir/file). + character(len=256) :: restartname ! The restart file name (no dir). character(len=8) :: suffix ! A suffix (like _2) that is appended ! to the name of files after the first. integer(kind=8) :: var_sz, size_in_file ! The size in bytes of each variable @@ -848,15 +801,14 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV) ! With parallel read & write, it is possible to disable the following... -! jgj: this was set to 4294967292, changed to 4294967295 (see mpp_parameter.F90) - if (CS%large_file_support) max_file_size = 4294967295_8 + ! The maximum file size is 4294967292, according to the NetCDF documentation. + if (CS%large_file_support) max_file_size = 4294967292_8 num_files = 0 next_var = 0 nz = 1 ; if (present(GV)) nz = GV%ke - call get_time(time,seconds,days) - restart_time = real(days) + real(seconds)/86400.0 + restart_time = time_type_to_real(time) / 86400.0 restartname = trim(CS%restartfile) if (present(filename)) restartname = trim(filename) @@ -869,7 +821,7 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV) seconds = seconds + 60*minute + 3600*hour if (year <= 9999) then write(restartname,'("_Y",I4.4,"_D",I3.3,"_S",I5.5)') year, days, seconds - else if (year <= 99999) then + elseif (year <= 99999) then write(restartname,'("_Y",I5.5,"_D",I3.3,"_S",I5.5)') year, days, seconds else write(restartname,'("_Y",I10.10,"_D",I3.3,"_S",I5.5)') year, days, seconds @@ -914,14 +866,14 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV) !query fms_io if there is a filename_appendix (for ensemble runs) call get_filename_appendix(filename_appendix) - if(len_trim(filename_appendix) > 0) then + if (len_trim(filename_appendix) > 0) then length = len_trim(restartname) - if(restartname(length-2:length) == '.nc') then + if (restartname(length-2:length) == '.nc') then restartname = restartname(1:length-3)//'.'//trim(filename_appendix)//'.nc' else restartname = restartname(1:length) //'.'//trim(filename_appendix) - end if - end if + endif + endif restartpath = trim(directory)// trim(restartname) @@ -965,7 +917,7 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV) elseif (associated(CS%var_ptr1d(m)%p)) then check_val(m-start_var+1,1) = mpp_chksum(CS%var_ptr1d(m)%p) elseif (associated(CS%var_ptr0d(m)%p)) then - check_val(m-start_var+1,1) = mpp_chksum(CS%var_ptr0d(m)%p) + check_val(m-start_var+1,1) = mpp_chksum(CS%var_ptr0d(m)%p,pelist=(/mpp_pe()/)) endif enddo @@ -1020,16 +972,7 @@ subroutine restore_state(filename, directory, day, G, CS) ! generated files. All restart variables are read from the first ! file in the input filename list in which they are found. -! Arguments: filename - A series of space delimited strings, each of -! which is either "r" or the name of a file -! from which the run is to be restarted. -! (in) directory - The directory where the restart or save -! files should be found. -! (out) day - The time of the restarted run. -! (in) G - The ocean's grid structure. -! (in/out) CS - The control structure returned by a previous call to -! restart_init. - + ! Local variables character(len=200) :: filepath ! The path (dir/file) to the file being opened. character(len=80) :: fname ! The name of the current file. character(len=8) :: suffix ! A suffix (like "_2") that is added to any @@ -1038,7 +981,7 @@ subroutine restore_state(filename, directory, day, G, CS) character(len=80) :: varname ! A variable's name. integer :: num_file ! The number of files (restart files and others ! explicitly in filename) that are open. - integer :: i, n, m, start_of_day, num_days, missing_fields + integer :: i, n, m, missing_fields integer :: isL, ieL, jsL, jeL, is0, js0 integer :: sizes(7) integer :: ndim, nvar, natt, ntime, pos @@ -1052,7 +995,7 @@ subroutine restore_state(filename, directory, day, G, CS) real, allocatable :: time_vals(:) type(fieldtype), allocatable :: fields(:) logical :: check_exist, is_there_a_checksum - integer(kind=8),dimension(1) :: checksum_file + integer(kind=8),dimension(3) :: checksum_file integer(kind=8) :: checksum_data if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & @@ -1084,9 +1027,7 @@ subroutine restore_state(filename, directory, day, G, CS) t1 = time_vals(1) deallocate(time_vals) - start_of_day = INT((t1 - INT(t1)) *86400) ! Number of seconds. - num_days = INT(t1) - day = set_time(start_of_day, num_days) + day = real_to_time(t1*86400.0) exit enddo @@ -1145,127 +1086,56 @@ subroutine restore_state(filename, directory, day, G, CS) call get_file_atts(fields(i),name=varname) if (lowercase(trim(varname)) == lowercase(trim(CS%restart_field(m)%var_name))) then check_exist = mpp_attribute_exist(fields(i),"checksum") - checksum_file = -1 + checksum_file(:) = -1 checksum_data = -1 is_there_a_checksum = .false. if ( check_exist ) then call mpp_get_atts(fields(i),checksum=checksum_file) is_there_a_checksum = .true. endif - if (.NOT. CS%checksum_required ) is_there_a_checksum = .false. ! Do not need to do data checksumming. + if (.NOT. CS%checksum_required) is_there_a_checksum = .false. ! Do not need to do data checksumming. if (associated(CS%var_ptr1d(m)%p)) then ! Read a 1d array, which should be invariant to domain decomposition. call read_data(unit_path(n), varname, CS%var_ptr1d(m)%p, & - no_domain=.true., timelevel=1) - if ( is_there_a_checksum ) checksum_data = mpp_chksum(CS%var_ptr1d(m)%p) + G%Domain%mpp_domain, timelevel=1) + if (is_there_a_checksum) checksum_data = mpp_chksum(CS%var_ptr1d(m)%p) elseif (associated(CS%var_ptr0d(m)%p)) then ! Read a scalar... call read_data(unit_path(n), varname, CS%var_ptr0d(m)%p, & - no_domain=.true., timelevel=1) - if ( is_there_a_checksum ) checksum_data = mpp_chksum(CS%var_ptr0d(m)%p) - elseif ((pos == 0) .and. associated(CS%var_ptr2d(m)%p)) then ! Read a non-decomposed 2d array. - ! Probably should query the field type to make sure that the sizes are right. - call read_data(unit_path(n), varname, CS%var_ptr2d(m)%p, & - no_domain=.true., timelevel=1) - if ( is_there_a_checksum ) checksum_data = mpp_chksum(CS%var_ptr2d(m)%p(isL:ieL,jsL:jeL)) - elseif ((pos == 0) .and. associated(CS%var_ptr3d(m)%p)) then ! Read a non-decomposed 3d array. - ! Probably should query the field type to make sure that the sizes are right. - call read_data(unit_path(n), varname, CS%var_ptr3d(m)%p, & - no_domain=.true., timelevel=1) - if ( is_there_a_checksum ) checksum_data = mpp_chksum(CS%var_ptr3d(m)%p(isL:ieL,jsL:jeL,:)) - elseif ((pos == 0) .and. associated(CS%var_ptr4d(m)%p)) then ! Read a non-decomposed 4d array. - ! Probably should query the field type to make sure that the sizes are right. - call read_data(unit_path(n), varname, CS%var_ptr4d(m)%p, & - no_domain=.true., timelevel=1) - if ( is_there_a_checksum ) checksum_data = mpp_chksum(CS%var_ptr4d(m)%p(isL:ieL,jsL:jeL,:,:)) - elseif (unit_is_global(n) .or. G%Domain%use_io_layout) then - if (associated(CS%var_ptr3d(m)%p)) then - ! Read 3d array... Time level 1 is always used. - call MOM_read_data(unit_path(n), varname, CS%var_ptr3d(m)%p, & - G%Domain, 1, position=pos) - if ( is_there_a_checksum ) checksum_data = mpp_chksum(CS%var_ptr3d(m)%p(isL:ieL,jsL:jeL,:)) - elseif (associated(CS%var_ptr2d(m)%p)) then ! Read 2d array... + G%Domain%mpp_domain, timelevel=1) + if (is_there_a_checksum) checksum_data = mpp_chksum(CS%var_ptr0d(m)%p,pelist=(/mpp_pe()/)) + elseif (associated(CS%var_ptr2d(m)%p)) then ! Read a 2d array. + if (pos /= 0) then call MOM_read_data(unit_path(n), varname, CS%var_ptr2d(m)%p, & - G%Domain, 1, position=pos) - if ( is_there_a_checksum ) checksum_data = mpp_chksum(CS%var_ptr2d(m)%p(isL:ieL,jsL:jeL)) - elseif (associated(CS%var_ptr4d(m)%p)) then ! Read 4d array... - call MOM_read_data(unit_path(n), varname, CS%var_ptr4d(m)%p, & - G%Domain, 1, position=pos) - if ( is_there_a_checksum ) checksum_data = mpp_chksum(CS%var_ptr4d(m)%p(isL:ieL,jsL:jeL,:,:)) - else - call MOM_error(FATAL, "MOM_restart restore_state: "//& - "No pointers set for "//trim(varname)) - endif - else ! Do not use an io_layout. !### GET RID OF THIS BRANCH ONCE read_data_4d_new IS AVAILABLE. - ! This file is decomposed onto the current processors. We need - ! to check whether the sizes look right, and abort if not. - call get_file_atts(fields(i),ndim=ndim,siz=sizes) - - ! NOTE: The index ranges f var_ptrs always start with 1, so with - ! symmetric memory the staggering is swapped from NE to SW! - is0 = 1-G%isd - if ((pos == EAST_FACE) .or. (pos == CORNER)) is0 = 1-G%IsdB - if (sizes(1) == G%iec-G%isc+1) then - isL = G%isc+is0 ; ieL = G%iec+is0 - elseif (sizes(1) == G%IecB-G%IscB+1) then - isL = G%IscB+is0 ; ieL = G%IecB+is0 - elseif (((pos == EAST_FACE) .or. (pos == CORNER)) .and. & - (G%IscB == G%isc) .and. (sizes(1) == G%iec-G%isc+2)) then - ! This is reading a symmetric file in a non-symmetric model. - isL = G%isc-1+is0 ; ieL = G%iec+is0 - else - call MOM_error(WARNING, "MOM_restart restore_state, "//trim(varname)//& - " has the wrong i-size in "//trim(unit_path(n))) - exit + G%Domain, timelevel=1, position=pos) + else ! This array is not domain-decomposed. This variant may be under-tested. + call read_data(unit_path(n), varname, CS%var_ptr2d(m)%p, & + no_domain=.true., timelevel=1) endif - - js0 = 1-G%jsd - if ((pos == NORTH_FACE) .or. (pos == CORNER)) js0 = 1-G%JsdB - if (sizes(2) == G%jec-G%jsc+1) then - jsL = G%jsc+js0 ; jeL = G%jec+js0 - elseif (sizes(2) == G%jecB-G%jscB+1) then - jsL = G%jscB+js0 ; jeL = G%jecB+js0 - elseif (((pos == NORTH_FACE) .or. (pos == CORNER)) .and. & - (G%JscB == G%jsc) .and. (sizes(2) == G%jec-G%jsc+2)) then - ! This is reading a symmetric file in a non-symmetric model. - jsL = G%jsc-1+js0 ; jeL = G%jec+js0 - else - call MOM_error(WARNING, "MOM_restart restore_state, "//trim(varname)//& - " has the wrong j-size in "//trim(unit_path(n))) - exit + if (is_there_a_checksum) checksum_data = mpp_chksum(CS%var_ptr2d(m)%p(isL:ieL,jsL:jeL)) + elseif (associated(CS%var_ptr3d(m)%p)) then ! Read a 3d array. + if (pos /= 0) then + call MOM_read_data(unit_path(n), varname, CS%var_ptr3d(m)%p, & + G%Domain, timelevel=1, position=pos) + else ! This array is not domain-decomposed. This variant may be under-tested. + call read_data(unit_path(n), varname, CS%var_ptr3d(m)%p, & + no_domain=.true., timelevel=1) endif - - if (associated(CS%var_ptr3d(m)%p)) then - if (ntime == 0) then - call read_field(unit(n), fields(i), & - CS%var_ptr3d(m)%p(isL:ieL,jsL:jeL,:)) - else - call read_field(unit(n), fields(i), & - CS%var_ptr3d(m)%p(isL:ieL,jsL:jeL,:), 1) - endif - elseif (associated(CS%var_ptr2d(m)%p)) then - if (ntime == 0) then - call read_field(unit(n), fields(i), & - CS%var_ptr2d(m)%p(isL:ieL,jsL:jeL)) - else - call read_field(unit(n), fields(i), & - CS%var_ptr2d(m)%p(isL:ieL,jsL:jeL), 1) - endif - elseif (associated(CS%var_ptr4d(m)%p)) then - if (ntime == 0) then - call read_field(unit(n), fields(i), & - CS%var_ptr4d(m)%p(isL:ieL,jsL:jeL,:,:)) - else - call read_field(unit(n), fields(i), & - CS%var_ptr4d(m)%p(isL:ieL,jsL:jeL,:,:), 1) - endif - else - call MOM_error(FATAL, "MOM_restart restore_state: "//& - "No pointers set for "//trim(varname)) + if (is_there_a_checksum) checksum_data = mpp_chksum(CS%var_ptr3d(m)%p(isL:ieL,jsL:jeL,:)) + elseif (associated(CS%var_ptr4d(m)%p)) then ! Read a 4d array. + if (pos /= 0) then + call MOM_read_data(unit_path(n), varname, CS%var_ptr4d(m)%p, & + G%Domain, timelevel=1, position=pos) + else ! This array is not domain-decomposed. This variant may be under-tested. + call read_data(unit_path(n), varname, CS%var_ptr4d(m)%p, & + no_domain=.true., timelevel=1) endif + if (is_there_a_checksum) checksum_data = mpp_chksum(CS%var_ptr4d(m)%p(isL:ieL,jsL:jeL,:,:)) + else + call MOM_error(FATAL, "MOM_restart restore_state: No pointers set for "//trim(varname)) endif - if(is_root_pe() .and. is_there_a_checksum .and. (checksum_file(1) /= checksum_data)) then + if (is_root_pe() .and. is_there_a_checksum .and. (checksum_file(1) /= checksum_data)) then write (mesg,'(a,Z16,a,Z16,a)') "Checksum of input field "// trim(varname)//" ",checksum_data,& " does not match value ", checksum_file(1), & " stored in "//trim(unit_path(n)//"." ) @@ -1399,18 +1269,10 @@ function open_restart_units(filename, directory, G, CS, units, file_paths, & ! generated files. All restart variables are read from the first ! file in the input filename list in which they are found. -! Arguments: filename - A series of space delimited strings, each of -! which is either "r" or the name of a file -! from which the run is to be restarted. -! (in) directory - The directory where the restart or save -! files should be found. -! (in) G - The ocean's grid structure. -! (in/out) CS - The control structure returned by a previous call to -! restart_init. - - character(len=200) :: filepath ! The path (dir/file) to the file being opened. - character(len=80) :: fname ! The name of the current file. - character(len=8) :: suffix ! A suffix (like "_2") that is added to any + ! Local variables + character(len=256) :: filepath ! The path (dir/file) to the file being opened. + character(len=256) :: fname ! The name of the current file. + character(len=8) :: suffix ! A suffix (like "_2") that is added to any ! additional restart files. ! character(len=256) :: mesg ! A message for warnings. integer :: num_restart ! The number of restart files that have already @@ -1435,8 +1297,12 @@ function open_restart_units(filename, directory, G, CS, units, file_paths, & enddo fname = filename(start_char:m-1) start_char = m - do while ((start_char <= len_trim(filename)) .and. (filename(start_char:start_char) == ' ')) - start_char = start_char + 1 + do while (start_char <= len_trim(filename)) + if (filename(start_char:start_char) == ' ') then + start_char = start_char + 1 + else + exit + endif enddo if ((fname(1:1)=='r') .and. ( len_trim(fname) == 1)) then @@ -1447,14 +1313,14 @@ function open_restart_units(filename, directory, G, CS, units, file_paths, & !query fms_io if there is a filename_appendix (for ensemble runs) call get_filename_appendix(filename_appendix) - if(len_trim(filename_appendix) > 0) then + if (len_trim(filename_appendix) > 0) then length = len_trim(restartname) - if(restartname(length-2:length) == '.nc') then + if (restartname(length-2:length) == '.nc') then restartname = restartname(1:length-3)//'.'//trim(filename_appendix)//'.nc' else restartname = restartname(1:length) //'.'//trim(filename_appendix) - end if - end if + endif + endif filepath = trim(directory) // trim(restartname) if (num_restart < 10) then @@ -1475,24 +1341,11 @@ function open_restart_units(filename, directory, G, CS, units, file_paths, & threading = MULTIPLE, fileset = SINGLE_FILE) if (present(global_files)) global_files(n) = .true. elseif (CS%parallel_restartfiles) then - if (G%Domain%use_io_layout) then - ! Look for decomposed files using the I/O Layout. - fexists = file_exists(filepath, G%Domain) - if (fexists .and. (present(units))) & - call open_file(units(n), trim(filepath), READONLY_FILE, NETCDF_FILE, & - domain=G%Domain%mpp_domain) - else - ! Look for any PE-specific files of the form NAME.nc.####. - if (num_PEs()>10000) then - write(filepath, '(a,i6.6)' ) trim(filepath)//'.', pe_here() - else - write(filepath, '(a,i4.4)' ) trim(filepath)//'.', pe_here() - endif - inquire(file=filepath, exist=fexists) - if (fexists .and. (present(units))) & - call open_file(units(n), trim(filepath), READONLY_FILE, NETCDF_FILE, & - threading = MULTIPLE, fileset = SINGLE_FILE) - endif + ! Look for decomposed files using the I/O Layout. + fexists = file_exists(filepath, G%Domain) + if (fexists .and. (present(units))) & + call open_file(units(n), trim(filepath), READONLY_FILE, NETCDF_FILE, & + domain=G%Domain%mpp_domain) if (fexists .and. present(global_files)) global_files(n) = .false. endif @@ -1531,17 +1384,15 @@ function open_restart_units(filename, directory, G, CS, units, file_paths, & end function open_restart_units +!> Initialize this module and set up a restart control structure. subroutine restart_init(param_file, CS, restart_root) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(MOM_restart_CS), pointer :: CS - character(len=*), optional, intent(in) :: restart_root -! Arguments: param_file - A structure indicating the open file to parse for -! model parameter values. -! (in/out) CS - A pointer that is set to point to the control structure -! for this module. -! (in,opt) restart_root - A filename root that overrides the value in -! RESTARTFILE. This will enable the use of this -! module by other components. + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object that is allocated here + character(len=*), optional, & + intent(in) :: restart_root !< A filename root that overrides the value + !! set by RESTARTFILE to enable the use of this module by + !! other components than MOM. + ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "MOM_restart" ! This module's name. @@ -1590,8 +1441,9 @@ subroutine restart_init(param_file, CS, restart_root) end subroutine restart_init +!> Indicate that all variables have now been registered. subroutine restart_init_end(CS) - type(MOM_restart_CS), pointer :: CS + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object if (associated(CS)) then if (CS%novars == 0) call restart_end(CS) @@ -1599,8 +1451,9 @@ subroutine restart_init_end(CS) end subroutine restart_init_end +!> Deallocate memory associated with a MOM_restart_CS variable. subroutine restart_end(CS) - type(MOM_restart_CS), pointer :: CS + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object if (associated(CS%restart_field)) deallocate(CS%restart_field) if (associated(CS%var_ptr0d)) deallocate(CS%var_ptr0d) @@ -1613,9 +1466,8 @@ subroutine restart_end(CS) end subroutine restart_end subroutine restart_error(CS) - type(MOM_restart_CS), pointer :: CS -! Arguments: CS - A pointer that is set to point to the control structure -! for this module. (Intent in.) + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object + character(len=16) :: num ! String for error messages if (CS%novars > CS%max_fields) then diff --git a/src/framework/MOM_safe_alloc.F90 b/src/framework/MOM_safe_alloc.F90 index 196a6b40e6..47dd8376a3 100644 --- a/src/framework/MOM_safe_alloc.F90 +++ b/src/framework/MOM_safe_alloc.F90 @@ -1,26 +1,23 @@ +!> Convenience functions for safely allocating memory without +!! accidentally reallocating pointer and causing memory leaks. module MOM_safe_alloc ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* The subroutines here provide a convenient way to safely allocate * -!* memory without accidentally reallocating a pointer and causing a * -!* memory leak. * -!* * -!********+*********+*********+*********+*********+*********+*********+** - implicit none ; private public safe_alloc_ptr, safe_alloc_alloc +!> Allocate a pointer to a 1-d, 2-d or 3-d array interface safe_alloc_ptr - module procedure safe_alloc_ptr_3d_2arg, safe_alloc_ptr_2d_2arg + module procedure safe_alloc_ptr_3d_3arg, safe_alloc_ptr_3d_6arg, safe_alloc_ptr_2d_2arg module procedure safe_alloc_ptr_3d, safe_alloc_ptr_2d, safe_alloc_ptr_1d end interface safe_alloc_ptr +!> Allocate a 2-d or 3-d allocatable array interface safe_alloc_alloc module procedure safe_alloc_allocatable_3d, safe_alloc_allocatable_2d + module procedure safe_alloc_allocatable_3d_6arg end interface safe_alloc_alloc ! This combined interface might work with a later version of Fortran, but @@ -34,10 +31,11 @@ module MOM_safe_alloc contains +!> Allocate a pointer to a 1-d array subroutine safe_alloc_ptr_1d(ptr, i1, i2) - real, pointer :: ptr(:) - integer, intent(in) :: i1 - integer, optional, intent(in) :: i2 + real, dimension(:), pointer :: ptr !< A pointer to allocate + integer, intent(in) :: i1 !< The size of the array, or its starting index if i2 is present + integer, optional, intent(in) :: i2 !< The ending index of the array if (.not.associated(ptr)) then if (present(i2)) then allocate(ptr(i1:i2)) @@ -48,58 +46,113 @@ subroutine safe_alloc_ptr_1d(ptr, i1, i2) endif end subroutine safe_alloc_ptr_1d +!> Allocate a pointer to a 2-d array based on its dimension sizes subroutine safe_alloc_ptr_2d_2arg(ptr, ni, nj) - real, pointer :: ptr(:,:) - integer, intent(in) :: ni, nj + real, dimension(:,:), pointer :: ptr !< A pointer to allocate + integer, intent(in) :: ni !< The size of the 1st dimension of the array + integer, intent(in) :: nj !< The size of the 2nd dimension of the array if (.not.associated(ptr)) then allocate(ptr(ni,nj)) ptr(:,:) = 0.0 endif end subroutine safe_alloc_ptr_2d_2arg -subroutine safe_alloc_ptr_3d_2arg(ptr, ni, nj, nk) - real, pointer :: ptr(:,:,:) - integer, intent(in) :: ni, nj, nk +!> Allocate a pointer to a 3-d array based on its dimension sizes +subroutine safe_alloc_ptr_3d_3arg(ptr, ni, nj, nk) + real, dimension(:,:,:), pointer :: ptr !< A pointer to allocate + integer, intent(in) :: ni !< The size of the 1st dimension of the array + integer, intent(in) :: nj !< The size of the 2nd dimension of the array + integer, intent(in) :: nk !< The size of the 3rd dimension of the array if (.not.associated(ptr)) then allocate(ptr(ni,nj,nk)) ptr(:,:,:) = 0.0 endif -end subroutine safe_alloc_ptr_3d_2arg +end subroutine safe_alloc_ptr_3d_3arg +!> Allocate a pointer to a 2-d array based on its index starting and ending values subroutine safe_alloc_ptr_2d(ptr, is, ie, js, je) - real, pointer :: ptr(:,:) - integer, intent(in) :: is, ie, js, je + real, dimension(:,:), pointer :: ptr !< A pointer to allocate + integer, intent(in) :: is !< The start index to allocate for the 1st dimension + integer, intent(in) :: ie !< The end index to allocate for the 1st dimension + integer, intent(in) :: js !< The start index to allocate for the 2nd dimension + integer, intent(in) :: je !< The end index to allocate for the 2nd dimension if (.not.associated(ptr)) then allocate(ptr(is:ie,js:je)) ptr(:,:) = 0.0 endif end subroutine safe_alloc_ptr_2d +!> Allocate a pointer to a 3-d array based on its index starting and ending values subroutine safe_alloc_ptr_3d(ptr, is, ie, js, je, nk) - real, pointer :: ptr(:,:,:) - integer, intent(in) :: is, ie, js, je, nk + real, dimension(:,:,:), pointer :: ptr !< A pointer to allocate + integer, intent(in) :: is !< The start index to allocate for the 1st dimension + integer, intent(in) :: ie !< The end index to allocate for the 1st dimension + integer, intent(in) :: js !< The start index to allocate for the 2nd dimension + integer, intent(in) :: je !< The end index to allocate for the 2nd dimension + integer, intent(in) :: nk !< The size to allocate for the 3rd dimension if (.not.associated(ptr)) then allocate(ptr(is:ie,js:je,nk)) ptr(:,:,:) = 0.0 endif end subroutine safe_alloc_ptr_3d +!> Allocate a pointer to a 3-d array based on its index starting and ending values +subroutine safe_alloc_ptr_3d_6arg(ptr, is, ie, js, je, ks, ke) + real, dimension(:,:,:), pointer :: ptr !< A pointer to allocate + integer, intent(in) :: is !< The start index to allocate for the 1st dimension + integer, intent(in) :: ie !< The end index to allocate for the 1st dimension + integer, intent(in) :: js !< The start index to allocate for the 2nd dimension + integer, intent(in) :: je !< The end index to allocate for the 2nd dimension + integer, intent(in) :: ks !< The start index to allocate for the 3rd dimension + integer, intent(in) :: ke !< The end index to allocate for the 3rd dimension + if (.not.associated(ptr)) then + allocate(ptr(is:ie,js:je,ks:ke)) + ptr(:,:,:) = 0.0 + endif +end subroutine safe_alloc_ptr_3d_6arg + + +!> Allocate a 2-d allocatable array based on its index starting and ending values subroutine safe_alloc_allocatable_2d(ptr, is, ie, js, je) - real, allocatable :: ptr(:,:) - integer, intent(in) :: is, ie, js, je + real, dimension(:,:), allocatable :: ptr !< An allocatable array to allocate + integer, intent(in) :: is !< The start index to allocate for the 1st dimension + integer, intent(in) :: ie !< The end index to allocate for the 1st dimension + integer, intent(in) :: js !< The start index to allocate for the 2nd dimension + integer, intent(in) :: je !< The end index to allocate for the 2nd dimension if (.not.allocated(ptr)) then allocate(ptr(is:ie,js:je)) ptr(:,:) = 0.0 endif end subroutine safe_alloc_allocatable_2d +!> Allocate a 3-d allocatable array based on its index starting and ending values +!! and k-index size subroutine safe_alloc_allocatable_3d(ptr, is, ie, js, je, nk) - real, allocatable :: ptr(:,:,:) - integer, intent(in) :: is, ie, js, je, nk + real, dimension(:,:,:), allocatable :: ptr !< An allocatable array to allocate + integer, intent(in) :: is !< The start index to allocate for the 1st dimension + integer, intent(in) :: ie !< The end index to allocate for the 1st dimension + integer, intent(in) :: js !< The start index to allocate for the 2nd dimension + integer, intent(in) :: je !< The end index to allocate for the 2nd dimension + integer, intent(in) :: nk !< The size to allocate for the 3rd dimension if (.not.allocated(ptr)) then allocate(ptr(is:ie,js:je,nk)) ptr(:,:,:) = 0.0 endif end subroutine safe_alloc_allocatable_3d +!> Allocate a 3-d allocatable array based on its 6 index starting and ending values +subroutine safe_alloc_allocatable_3d_6arg(ptr, is, ie, js, je, ks, ke) + real, dimension(:,:,:), allocatable :: ptr !< An allocatable array to allocate + integer, intent(in) :: is !< The start index to allocate for the 1st dimension + integer, intent(in) :: ie !< The end index to allocate for the 1st dimension + integer, intent(in) :: js !< The start index to allocate for the 2nd dimension + integer, intent(in) :: je !< The end index to allocate for the 2nd dimension + integer, intent(in) :: ks !< The start index to allocate for the 3rd dimension + integer, intent(in) :: ke !< The end index to allocate for the 3rd dimension + if (.not.allocated(ptr)) then + allocate(ptr(is:ie,js:je,ks:ke)) + ptr(:,:,:) = 0.0 + endif +end subroutine safe_alloc_allocatable_3d_6arg + end module MOM_safe_alloc diff --git a/src/framework/MOM_spatial_means.F90 b/src/framework/MOM_spatial_means.F90 index 38c4b61180..00f1474879 100644 --- a/src/framework/MOM_spatial_means.F90 +++ b/src/framework/MOM_spatial_means.F90 @@ -1,3 +1,4 @@ +!> Functions and routines to take area, volume, mass-weighted, layerwise, zonal or meridional means module MOM_spatial_means ! This file is part of MOM6. See LICENSE.md for the license. @@ -23,9 +24,10 @@ module MOM_spatial_means contains +!> Return the global area mean of a variable. This uses reproducing sums. function global_area_mean(var,G) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G), SZJ_(G)), intent(in) :: var + real, dimension(SZI_(G), SZJ_(G)), intent(in) :: var !< The variable to average real, dimension(SZI_(G), SZJ_(G)) :: tmpForSumming real :: global_area_mean @@ -40,9 +42,10 @@ function global_area_mean(var,G) end function global_area_mean +!> Return the global area integral of a variable. This uses reproducing sums. function global_area_integral(var,G) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G), SZJ_(G)), intent(in) :: var + real, dimension(SZI_(G), SZJ_(G)), intent(in) :: var !< The variable to integrate real, dimension(SZI_(G), SZJ_(G)) :: tmpForSumming real :: global_area_integral @@ -57,11 +60,12 @@ function global_area_integral(var,G) end function global_area_integral +!> Return the layerwise global thickness-weighted mean of a variable. This uses reproducing sums. function global_layer_mean(var, h, G, GV) 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_(GV)), intent(in) :: var - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: var !< The variable to average + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] real, dimension(SZK_(GV)) :: global_layer_mean real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: tmpForSumming, weight @@ -86,14 +90,14 @@ function global_layer_mean(var, h, G, GV) end function global_layer_mean -!> Find the global thickness-weighted mean of a variable. +!> Find the global thickness-weighted mean of a variable. This uses reproducing sums. function global_volume_mean(var, h, G, GV) 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_(GV)), & intent(in) :: var !< The variable being averaged real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] real :: global_volume_mean !< The thickness-weighted average of var real :: weight_here @@ -114,12 +118,12 @@ function global_volume_mean(var, h, G, GV) end function global_volume_mean -!> Find the global mass-weighted integral of a variable +!> Find the global mass-weighted integral of a variable. This uses reproducing sums. function global_mass_integral(h, G, GV, var, on_PE_only) 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_(GV)), & - intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & optional, intent(in) :: var !< The variable being integrated logical, optional, intent(in) :: on_PE_only !< If present and true, the sum is only @@ -158,20 +162,16 @@ function global_mass_integral(h, G, GV, var, on_PE_only) end function global_mass_integral +!> Determine the global mean of a field along rows of constant i, returning it +!! in a 1-d array using the local indexing. This uses reproducing sums. subroutine global_i_mean(array, i_mean, G, mask) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: array - real, dimension(SZJ_(G)), intent(out) :: i_mean - real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: mask - -! This subroutine determines the global mean of a field along rows of -! constant i, returning it in a 1-d array using the local indexing. - -! Arguments: array - The 2-d array whose i-mean is to be taken. -! (out) i_mean - Global mean of array along its i-axis. -! (in) G - The ocean's grid structure. -! (in) mask - An array used for weighting the i-mean. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: array !< The variable being averaged + real, dimension(SZJ_(G)), intent(out) :: i_mean !< Global mean of array along its i-axis + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(in) :: mask !< An array used for weighting the i-mean + ! Local variables type(EFP_type), allocatable, dimension(:) :: asum, mask_sum real :: mask_sum_r integer :: is, ie, js, je, idg_off, jdg_off @@ -236,20 +236,16 @@ subroutine global_i_mean(array, i_mean, G, mask) end subroutine global_i_mean +!> Determine the global mean of a field along rows of constant j, returning it +!! in a 1-d array using the local indexing. This uses reproducing sums. subroutine global_j_mean(array, j_mean, G, mask) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: array - real, dimension(SZI_(G)), intent(out) :: j_mean - real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: mask - -! This subroutine determines the global mean of a field along rows of -! constant j, returning it in a 1-d array using the local indexing. - -! Arguments: array - The 2-d array whose j-mean is to be taken. -! (out) j_mean - Global mean of array along its j-axis. -! (in) G - The ocean's grid structure. -! (in) mask - An array used for weighting the j-mean. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: array !< The variable being averaged + real, dimension(SZI_(G)), intent(out) :: j_mean !< Global mean of array along its j-axis + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(in) :: mask !< An array used for weighting the j-mean + ! Local variables type(EFP_type), allocatable, dimension(:) :: asum, mask_sum real :: mask_sum_r integer :: is, ie, js, je, idg_off, jdg_off diff --git a/src/framework/MOM_string_functions.F90 b/src/framework/MOM_string_functions.F90 index c0f3ba2b28..0a4058995a 100644 --- a/src/framework/MOM_string_functions.F90 +++ b/src/framework/MOM_string_functions.F90 @@ -1,17 +1,8 @@ +!> Handy functions for manipulating strings module MOM_string_functions ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Alistair Adcroft and Robert Hallberg, last updated Sept. 2013. * -!* * -!* The functions here perform a set of useful manipulations of * -!* character strings. Although they are a part of MOM6, the do not * -!* require any other MOM software to be useful. * -!* * -!********+*********+*********+*********+*********+*********+*********+** - implicit none ; private public lowercase, uppercase @@ -27,14 +18,14 @@ module MOM_string_functions contains +!> Return a string in which all uppercase letters have been replaced by +!! their lowercase counterparts. function lowercase(input_string) + character(len=*), intent(in) :: input_string !< The string to modify + character(len=len(input_string)) :: lowercase !< The modified output string ! This function returns a string in which all uppercase letters have been ! replaced by their lowercase counterparts. It is loosely based on the ! lowercase function in mpp_util.F90. - ! Arguments - character(len=*), intent(in) :: input_string - character(len=len(input_string)) :: lowercase - ! Local variables integer, parameter :: co=iachar('a')-iachar('A') ! case offset integer :: k @@ -42,16 +33,17 @@ function lowercase(input_string) do k=1, len_trim(input_string) if (lowercase(k:k) >= 'A' .and. lowercase(k:k) <= 'Z') & lowercase(k:k) = achar(ichar(lowercase(k:k))+co) - end do + enddo end function lowercase +!> Return a string in which all uppercase letters have been replaced by +!! their lowercase counterparts. function uppercase(input_string) - character(len=*), intent(in) :: input_string - character(len=len(input_string)) :: uppercase + character(len=*), intent(in) :: input_string !< The string to modify + character(len=len(input_string)) :: uppercase !< The modified output string ! This function returns a string in which all lowercase letters have been ! replaced by their uppercase counterparts. It is loosely based on the ! uppercase function in mpp_util.F90. - ! Arguments integer, parameter :: co=iachar('A')-iachar('a') ! case offset integer :: k @@ -59,28 +51,26 @@ function uppercase(input_string) do k=1, len_trim(input_string) if (uppercase(k:k) >= 'a' .and. uppercase(k:k) <= 'z') & uppercase(k:k) = achar(ichar(uppercase(k:k))+co) - end do + enddo end function uppercase +!> Returns a character string of a left-formatted integer +!! e.g. "123 " (assumes 19 digit maximum) function left_int(i) -! Returns a character string of a left-formatted integer -! e.g. "123 " (assumes 19 digit maximum) - ! Arguments - character(len=19) :: left_int - integer, intent(in) :: i - ! Local variables + integer, intent(in) :: i !< The integer to convert to a string + character(len=19) :: left_int !< The output string + character(len=19) :: tmp write(tmp(1:19),'(I19)') i write(left_int(1:19),'(A)') adjustl(tmp) end function left_int +!> Returns a character string of a comma-separated, compact formatted, +!! integers e.g. "1, 2, 3, 4" function left_ints(i) -! Returns a character string of a comma-separated, compact formatted, -! integers e.g. "1, 2, 3, 4" - ! Arguments - character(len=1320) :: left_ints - integer, intent(in) :: i(:) - ! Local variables + integer, intent(in) :: i(:) !< The array of integers to convert to a string + character(len=1320) :: left_ints !< The output string + character(len=1320) :: tmp integer :: j write(left_ints(1:1320),'(A)') trim(left_int(i(1))) @@ -92,10 +82,11 @@ function left_ints(i) endif end function left_ints +!> Returns a left-justified string with a real formatted like '(G)' function left_real(val) - real, intent(in) :: val - character(len=32) :: left_real -! Returns a left-justified string with a real formatted like '(G)' + real, intent(in) :: val !< The real variable to convert to a string + character(len=32) :: left_real !< The output string + integer :: l, ind if ((abs(val) < 1.0e4) .and. (abs(val) >= 1.0e-3)) then @@ -143,17 +134,18 @@ function left_real(val) left_real = adjustl(left_real) end function left_real +!> Returns a character string of a comma-separated, compact formatted, reals +!! e.g. "1., 2., 5*3., 5.E2" function left_reals(r,sep) -! Returns a character string of a comma-separated, compact formatted, reals -! e.g. "1., 2., 5*3., 5.E2" - ! Arguments - character(len=1320) :: left_reals - real, intent(in) :: r(:) - character(len=*), optional :: sep - ! Local variables + real, intent(in) :: r(:) !< The array of real variables to convert to a string + character(len=*), optional, intent(in) :: sep !< The separator between + !! successive values, by default it is ', '. + character(len=1320) :: left_reals !< The output string + integer :: j, n, b, ns logical :: doWrite character(len=10) :: separator + n=1 ; doWrite=.true. ; left_reals='' ; b=1 if (present(sep)) then separator=sep ; ns=len(sep) @@ -183,11 +175,10 @@ function left_reals(r,sep) enddo end function left_reals +!> Returns True if the string can be read/parsed to give the exact value of "val" function isFormattedFloatEqualTo(str, val) -! Returns True if the string can be read/parsed to give the exact -! value of "val" - character(len=*), intent(in) :: str - real, intent(in) :: val + character(len=*), intent(in) :: str !< The string to parse + real, intent(in) :: val !< The real value to compare with logical :: isFormattedFloatEqualTo ! Local variables real :: scannedVal @@ -202,8 +193,8 @@ end function isFormattedFloatEqualTo !! or "" if the string is not long enough. Both spaces and commas !! are interpreted as separators. character(len=120) function extractWord(string, n) - character(len=*), intent(in) :: string - integer, intent(in) :: n + character(len=*), intent(in) :: string !< The string to scan + integer, intent(in) :: n !< Number of word to extract extractWord = extract_word(string, ' ,', n) @@ -222,7 +213,7 @@ end function extractWord extract_word = '' lastCharIsSeperator = .true. ns = len_trim(string) - i = 0; b=0; e=0; nw=0; + i = 0; b=0; e=0; nw=0 do while (i \namespace mom_string_functions +!! +!! By Alistair Adcroft and Robert Hallberg, last updated Sept. 2013. +!! +!! The functions here perform a set of useful manipulations of +!! character strings. Although they are a part of MOM6, the do not +!! require any other MOM software to be useful. + end module MOM_string_functions diff --git a/src/framework/MOM_time_manager.F90 b/src/framework/MOM_time_manager.F90 index 25c367c1ef..229c3ded3a 100644 --- a/src/framework/MOM_time_manager.F90 +++ b/src/framework/MOM_time_manager.F90 @@ -20,8 +20,9 @@ module MOM_time_manager implicit none ; private -public :: time_type, get_time, set_time, time_type_to_real, real_to_time_type -public :: set_ticks_per_second , get_ticks_per_second +public :: time_type, get_time, set_time +public :: time_type_to_real, real_to_time_type, real_to_time +public :: set_ticks_per_second, get_ticks_per_second public :: operator(+), operator(-), operator(*), operator(/) public :: operator(>), operator(<), operator(>=), operator(<=) public :: operator(==), operator(/=), operator(//) @@ -35,4 +36,29 @@ module MOM_time_manager public :: get_external_field_axes public :: get_external_field_missing +contains + +!> This is an alternate implementation of the FMS function real_to_time_type that is accurate over +!! a larger range of input values. With 32 bit signed integers, this version should work over the +!! entire valid range (2^31 days or ~5.8835 million years) of time_types, whereas the standard +!! version in the FMS time_manager stops working for conversions of times greater than 2^31 seconds, +!! or ~68.1 years. +function real_to_time(x, err_msg) + type(time_type) :: real_to_time !< The output time as a time_type + real, intent(in) :: x !< The input time in real seconds. + character(len=*), intent(out), optional :: err_msg !< An optional returned error message. + + ! Local variables + integer :: seconds, days, ticks + real :: real_subsecond_remainder + + days = floor(x/86400.) + seconds = floor(x - 86400.*days) + real_subsecond_remainder = x - (days*86400. + seconds) + ticks = nint(real_subsecond_remainder * get_ticks_per_second()) + + real_to_time = set_time(seconds=seconds, days=days, ticks=ticks, err_msg=err_msg) +end function real_to_time + + end module MOM_time_manager diff --git a/src/framework/MOM_unit_scaling.F90 b/src/framework/MOM_unit_scaling.F90 new file mode 100644 index 0000000000..60b07c1fbd --- /dev/null +++ b/src/framework/MOM_unit_scaling.F90 @@ -0,0 +1,125 @@ +!> Provides a transparent unit rescaling type to facilitate dimensional consistency testing +module MOM_unit_scaling + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type + +implicit none ; private + +public unit_scaling_init, unit_scaling_end, fix_restart_unit_scaling + +!> Describes various unit conversion factors +type, public :: unit_scale_type + real :: m_to_Z !< A constant that translates distances in meters to the units of depth. + real :: Z_to_m !< A constant that translates distances in the units of depth to meters. + real :: m_to_L !< A constant that translates lengths in meters to the units of horizontal lengths. + real :: L_to_m !< A constant that translates lengths in the units of horizontal lengths to meters. + real :: s_to_T !< A constant that time intervals in seconds to the units of time. + real :: T_to_s !< A constant that the units of time to seconds. + + ! These are useful combinations of the fundamental scale conversion factors above. + real :: Z_to_L !< Convert vertical distances to lateral lengths + real :: L_to_Z !< Convert vertical distances to lateral lengths + real :: L_T_to_m_s !< Convert lateral velocities from L T-1 to m s-1. + real :: m_s_to_L_T !< Convert lateral velocities from m s-1 to L T-1. + real :: L_T2_to_m_s2 !< Convert lateral accelerations from L T-2 to m s-2. + real :: Z2_T_to_m2_s !< Convert vertical diffusivities from Z2 T-1 to m2 s-1. + real :: m2_s_to_Z2_T !< Convert vertical diffusivities from m2 s-1 to Z2 T-1. + + ! These are used for changing scaling across restarts. + real :: m_to_Z_restart = 0.0 !< A copy of the m_to_Z that is used in restart files. + real :: m_to_L_restart = 0.0 !< A copy of the m_to_L that is used in restart files. + real :: s_to_T_restart = 0.0 !< A copy of the s_to_T that is used in restart files. +end type unit_scale_type + +contains + +!> Allocates and initializes the ocean model unit scaling type +subroutine unit_scaling_init( param_file, US ) + type(param_file_type), intent(in) :: param_file !< Parameter file handle/type + type(unit_scale_type), pointer :: US !< A dimensional unit scaling type + + ! This routine initializes a unit_scale_type structure (US). + + ! Local variables + integer :: Z_power, L_power, T_power + real :: Z_rescale_factor, L_rescale_factor, T_rescale_factor + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=16) :: mdl = "MOM_unit_scaling" + + if (associated(US)) call MOM_error(FATAL, & + 'unit_scaling_init: called with an associated US pointer.') + allocate(US) + + ! Read all relevant parameters and write them to the model log. + 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"//& + "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"//& + "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"//& + "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: "//& + "Z_RESCALE_POWER is outside of the valid range of -300 to 300.") + if (abs(L_power) > 300) call MOM_error(FATAL, "unit_scaling_init: "//& + "L_RESCALE_POWER is outside of the valid range of -300 to 300.") + if (abs(T_power) > 300) call MOM_error(FATAL, "unit_scaling_init: "//& + "T_RESCALE_POWER is outside of the valid range of -300 to 300.") + + Z_rescale_factor = 1.0 + if (Z_power /= 0) Z_rescale_factor = 2.0**Z_power + US%Z_to_m = 1.0 * Z_rescale_factor + US%m_to_Z = 1.0 / Z_rescale_factor + + L_rescale_factor = 1.0 + if (L_power /= 0) L_rescale_factor = 2.0**L_power + US%L_to_m = 1.0 * L_rescale_factor + US%m_to_L = 1.0 / L_rescale_factor + + T_rescale_factor = 1.0 + if (T_power /= 0) T_rescale_factor = 2.0**T_power + US%T_to_s = 1.0 * T_rescale_factor + US%s_to_T = 1.0 / T_rescale_factor + + ! These are useful combinations of the fundamental scale conversion factors set above. + US%Z_to_L = US%Z_to_m * US%m_to_L + US%L_to_Z = US%L_to_m * US%m_to_Z + US%L_T_to_m_s = US%L_to_m * US%s_to_T + US%m_s_to_L_T = US%m_to_L * US%T_to_s + US%L_T2_to_m_s2 = US%L_to_m * US%s_to_T**2 + ! It does not look like US%m_s2_to_L_T2 would be used, so it does not exist. + US%Z2_T_to_m2_s = US%Z_to_m**2 * US%s_to_T + US%m2_s_to_Z2_T = US%m_to_Z**2 * US%T_to_s + +end subroutine unit_scaling_init + +!> Set the unit scaling factors for output to restart files to the unit scaling +!! factors for this run. +subroutine fix_restart_unit_scaling(US) + type(unit_scale_type), intent(inout) :: US !< A dimensional unit scaling type + + US%m_to_Z_restart = US%m_to_Z + US%m_to_L_restart = US%m_to_L + US%s_to_T_restart = US%s_to_T + +end subroutine fix_restart_unit_scaling + +!> Deallocates a unit scaling structure. +subroutine unit_scaling_end( US ) + type(unit_scale_type), pointer :: US !< A dimensional unit scaling type + + deallocate( US ) + +end subroutine unit_scaling_end + +end module MOM_unit_scaling diff --git a/src/framework/MOM_write_cputime.F90 b/src/framework/MOM_write_cputime.F90 index 17d4a3153a..c85e3ecb7b 100644 --- a/src/framework/MOM_write_cputime.F90 +++ b/src/framework/MOM_write_cputime.F90 @@ -1,21 +1,10 @@ +!> A module to monitor the overall CPU time used by MOM6 and project when to stop the model module MOM_write_cputime ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Robert Hallberg, May 2006. * -!* * -!* This file contains the subroutine (write_cputime) that writes * -!* the summed CPU time across all processors to an output file. In * -!* addition, write_cputime estimates how many more time steps can be * -!* taken before 95% of the available CPU time is used, so that the * -!* model can be checkpointed at that time. * -!* * -!********+*********+*********+*********+*********+*********+*********+** - use MOM_coms, only : sum_across_PEs, pe_here, num_pes -use MOM_error_handler, only : MOM_error, FATAL, is_root_pe +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, is_root_pe use MOM_io, only : open_file, APPEND_FILE, ASCII_FILE, WRITEONLY_FILE use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_time_manager, only : time_type, get_time, operator(>) @@ -26,33 +15,34 @@ module MOM_write_cputime !----------------------------------------------------------------------- -integer :: CLOCKS_PER_SEC = 1000 -integer :: MAX_TICKS = 1000 +integer :: CLOCKS_PER_SEC = 1000 !< The number of clock cycles per second, used by the system clock +integer :: MAX_TICKS = 1000 !< The number of ticks per second, used by the system clock +!> A control structure that regulates the writing of CPU time type, public :: write_cputime_CS ; private - real :: maxcpu ! The maximum amount of cpu time per processor - ! for which MOM should run before saving a restart - ! file and quiting with a return value that - ! indicates that further execution is required to - ! complete the simulation, in wall-clock seconds. - type(time_type) :: Start_time ! The start time of the simulation. - ! Start_time is set in MOM_initialization.F90 - real :: startup_cputime ! The CPU time used in the startup phase of the model. - real :: prev_cputime = 0.0 ! The last measured CPU time. - real :: dn_dcpu_min = -1.0 ! The minimum derivative of timestep with CPU time. - real :: cputime2 = 0.0 ! The accumulated cpu time. - integer :: previous_calls = 0 ! The number of times write_CPUtime has been called. - integer :: prev_n = 0 ! The value of n from the last call. - integer :: fileCPU_ascii ! The unit number of the CPU time file. - character(len=200) :: CPUfile ! The name of the CPU time file. + real :: maxcpu !< The maximum amount of cpu time per processor + !! for which MOM should run before saving a restart + !! file and quiting with a return value that + !! indicates that further execution is required to + !! complete the simulation, in wall-clock seconds. + type(time_type) :: Start_time !< The start time of the simulation. + !! Start_time is set in MOM_initialization.F90 + real :: startup_cputime !< The CPU time used in the startup phase of the model. + real :: prev_cputime = 0.0 !< The last measured CPU time. + real :: dn_dcpu_min = -1.0 !< The minimum derivative of timestep with CPU time. + real :: cputime2 = 0.0 !< The accumulated cpu time. + integer :: previous_calls = 0 !< The number of times write_CPUtime has been called. + integer :: prev_n = 0 !< The value of n from the last call. + integer :: fileCPU_ascii !< The unit number of the CPU time file. + character(len=200) :: CPUfile !< The name of the CPU time file. end type write_cputime_CS contains +!> Evaluate the CPU time returned by SYSTEM_CLOCK at the start of a run subroutine write_cputime_start_clock(CS) - type(write_cputime_CS), pointer :: CS -! Argument: CS - A pointer that is set to point to the control structure -! for this module + type(write_cputime_CS), pointer :: CS !< The control structure set up by a previous + !! call to MOM_write_cputime_init. integer :: new_cputime ! The CPU time returned by SYSTEM_CLOCK if (.not.associated(CS)) allocate(CS) @@ -60,17 +50,15 @@ subroutine write_cputime_start_clock(CS) CS%prev_cputime = new_cputime end subroutine write_cputime_start_clock +!> Initialize the MOM_write_cputime module. subroutine MOM_write_cputime_init(param_file, directory, Input_start_time, CS) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - character(len=*), intent(in) :: directory - type(time_type), intent(in) :: Input_start_time - type(write_cputime_CS), pointer :: CS -! Arguments: param_file - A structure indicating the open file to parse for -! model parameter values. -! (in) directory - The directory where the energy file goes. -! (in) Input_start_time - The start time of the simulation. -! (in/out) CS - A pointer that may be set to point to the control structure -! for this module. + character(len=*), intent(in) :: directory !< The directory where the CPU time file goes. + type(time_type), intent(in) :: Input_start_time !< The start model time of the simulation. + type(write_cputime_CS), pointer :: CS !< A pointer that may be set to point to the + !! control structure for this module. + + ! Local variables integer :: new_cputime ! The CPU time returned by SYSTEM_CLOCK ! This include declares and sets the variable "version". #include "version_variable.h" @@ -106,26 +94,22 @@ subroutine MOM_write_cputime_init(param_file, directory, Input_start_time, CS) end subroutine MOM_write_cputime_init +!> This subroutine assesses how much CPU time the model has taken and determines how long the model +!! should be run before it saves a restart file and stops itself. subroutine write_cputime(day, n, nmax, CS) - type(time_type), intent(inout) :: day - integer, intent(in) :: n - integer, intent(inout) :: nmax - type(write_cputime_CS), pointer :: CS -! This subroutine assesses how much CPU time the model has -! taken and determines how long the model should be run before it -! saves a restart file and stops itself. - -! Arguments: day - The current model time. -! (in) n - The time step number of the current execution. -! (out) nmax - The number of iterations after which to stop so -! that the simulation will not run out of CPU time. -! (in) G - The ocean's grid structure. -! (in) CS - The control structure returned by a previous call to -! MOM_write_cputime_init. + type(time_type), intent(inout) :: day !< The current model time. + integer, intent(in) :: n !< The time step number of the current execution. + integer, intent(inout) :: nmax !< The number of iterations after which to stop so + !! that the simulation will not run out of CPU time. + type(write_cputime_CS), pointer :: CS !< The control structure set up by a previous + !! call to MOM_write_cputime_init. + + ! Local variables real :: d_cputime ! The change in CPU time since the last call ! this subroutine. integer :: new_cputime ! The CPU time returned by SYSTEM_CLOCK real :: reday ! A real version of day. + character(len=256) :: mesg ! The text of an error message integer :: start_of_day, num_days if (.not.associated(CS)) call MOM_error(FATAL, & @@ -159,9 +143,8 @@ subroutine write_cputime(day, n, nmax, CS) nmax = n + INT( CS%dn_dcpu_min * & (0.95*CS%maxcpu * REAL(num_pes())*CLOCKS_PER_SEC - & (CS%startup_cputime + CS%cputime2)) ) -! if (is_root_pe() ) then -! write(*,*) "Resetting nmax to ",nmax," at day",reday -! endif +! write(mesg,*) "Resetting nmax to ",nmax," at day",reday +! call MOM_mesg(mesg) endif endif CS%prev_cputime = new_cputime ; CS%prev_n = n @@ -195,4 +178,14 @@ subroutine write_cputime(day, n, nmax, CS) end subroutine write_cputime +!> \namespace mom_write_cputime +!! +!! By Robert Hallberg, May 2006. +!! +!! This file contains the subroutine (write_cputime) that writes +!! the summed CPU time across all processors to an output file. In +!! addition, write_cputime estimates how many more time steps can be +!! taken before 95% of the available CPU time is used, so that the +!! model can be checkpointed at that time. + end module MOM_write_cputime diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index efa74e561e..fa4d2b0581 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -1,6 +1,6 @@ !> Implements the thermodynamic aspects of ocean / ice-shelf interactions, -! along with a crude placeholder for a later implementation of full -! ice shelf dynamics, all using the MOM framework and coding style. +!! along with a crude placeholder for a later implementation of full +!! ice shelf dynamics, all using the MOM framework and coding style. module MOM_ice_shelf ! This file is part of MOM6. See LICENSE.md for the license. @@ -11,8 +11,9 @@ module MOM_ice_shelf use MOM_diag_mediator, only : diag_mediator_init, set_diag_mediator_grid use MOM_diag_mediator, only : diag_ctrl, time_type, enable_averaging, disable_averaging use MOM_domains, only : MOM_domains_init, clone_MOM_domain -use MOM_domains, only : pass_var, pass_vector, TO_ALL, CGRID_NE, BGRID_NE +use MOM_domains, only : pass_var, pass_vector, TO_ALL, CGRID_NE, BGRID_NE, CORNER use MOM_dyn_horgrid, only : dyn_horgrid_type, create_dyn_horgrid, destroy_dyn_horgrid +use MOM_dyn_horgrid, only : rescale_dyn_horgrid_bathymetry use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type use MOM_grid, only : MOM_grid_init, ocean_grid_type @@ -21,165 +22,89 @@ module MOM_ice_shelf use MOM_fixed_initialization, only : MOM_initialize_rotation use user_initialization, only : user_initialize_topography use MOM_io, only : field_exists, file_exists, MOM_read_data, write_version_number -use MOM_io, only : slasher, vardesc, var_desc, fieldtype +use MOM_io, only : slasher, fieldtype use MOM_io, only : write_field, close_file, SINGLE_FILE, MULTIPLE use MOM_restart, only : register_restart_field, query_initialized, save_restart use MOM_restart, only : restart_init, restore_state, MOM_restart_CS -use MOM_time_manager, only : time_type, set_time, time_type_to_real +use MOM_time_manager, only : time_type, time_type_to_real, time_type_to_real, real_to_time use MOM_transcribe_grid, only : copy_dyngrid_to_MOM_grid, copy_MOM_grid_to_dyngrid +use MOM_unit_scaling, only : unit_scale_type, unit_scaling_init, fix_restart_unit_scaling use MOM_variables, only : surface use MOM_forcing_type, only : forcing, allocate_forcing_type, MOM_forcing_chksum use MOM_forcing_type, only : mech_forcing, allocate_mech_forcing, MOM_mech_forcing_chksum +use MOM_forcing_type, only : copy_common_forcing_fields use MOM_get_input, only : directories, Get_MOM_input use MOM_EOS, only : calculate_density, calculate_density_derivs, calculate_TFreeze use MOM_EOS, only : EOS_type, EOS_init -!MJHuse MOM_ice_shelf_initialize, only : initialize_ice_shelf_boundary, initialize_ice_thickness +use MOM_ice_shelf_dynamics, only : ice_shelf_dyn_CS, update_ice_shelf +use MOM_ice_shelf_dynamics, only : register_ice_shelf_dyn_restarts, initialize_ice_shelf_dyn +use MOM_ice_shelf_dynamics, only : ice_shelf_min_thickness_calve +use MOM_ice_shelf_dynamics, only : ice_time_step_CFL, ice_shelf_dyn_end use MOM_ice_shelf_initialize, only : initialize_ice_thickness +!MJH use MOM_ice_shelf_initialize, only : initialize_ice_shelf_boundary +use MOM_ice_shelf_state, only : ice_shelf_state, ice_shelf_state_end, ice_shelf_state_init use user_shelf_init, only : USER_initialize_shelf_mass, USER_update_shelf_mass use user_shelf_init, only : user_ice_shelf_CS -use constants_mod, only: GRAV -use mpp_mod, only : mpp_sum, mpp_max, mpp_min, mpp_pe, mpp_npes, mpp_sync -use MOM_coms, only : reproducing_sum -use MOM_checksums, only : hchksum, qchksum, chksum, uchksum, vchksum +use MOM_coms, only : reproducing_sum, sum_across_PEs +use MOM_checksums, only : hchksum, qchksum, chksum, uchksum, vchksum, uvchksum use time_interp_external_mod, only : init_external_field, time_interp_external use time_interp_external_mod, only : time_interp_external_init -use time_manager_mod, only : print_time, time_type_to_real, real_to_time_type +use time_manager_mod, only : print_time implicit none ; private #include #ifdef SYMMETRIC_LAND_ICE # define GRID_SYM_ .true. -# define NILIMB_SYM_ NIMEMB_SYM_ -# define NJLIMB_SYM_ NJMEMB_SYM_ -# define ISUMSTART_INT_ CS%grid%iscB+1 -# define JSUMSTART_INT_ CS%grid%jscB+1 #else # define GRID_SYM_ .false. -# define NILIMB_SYM_ NIMEMB_ -# define NJLIMB_SYM_ NJMEMB_ -# define ISUMSTART_INT_ CS%grid%iscB -# define JSUMSTART_INT_ CS%grid%jscB #endif public shelf_calc_flux, add_shelf_flux, initialize_ice_shelf, ice_shelf_end -public ice_shelf_save_restart, solo_time_step +public ice_shelf_save_restart, solo_time_step, add_shelf_forces + +! 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. !> Control structure that contains ice shelf parameters and diagnostics handles type, public :: ice_shelf_CS ; private ! Parameters - type(MOM_restart_CS), pointer :: restart_CSp => NULL() + type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< A pointer to the restart control + !! structure for the ice shelves type(ocean_grid_type) :: grid !< Grid for the ice-shelf model + type(unit_scale_type), pointer :: & + US => NULL() !< A structure containing various unit conversion factors !type(dyn_horgrid_type), pointer :: dG !< Dynamic grid for the ice-shelf model type(ocean_grid_type), pointer :: ocn_grid => NULL() !< A pointer to the ocean model grid !! The rest is private real :: flux_factor = 1.0 !< A factor that can be used to turn off ice shelf - !! melting (flux_factor = 0). - character(len=128) :: restart_output_dir = ' ' + !! melting (flux_factor = 0) [nondim]. + character(len=128) :: restart_output_dir = ' ' !< The directory in which to write restart files + type(ice_shelf_state), pointer :: ISS => NULL() !< A structure with elements that describe + !! the ice-shelf state + type(ice_shelf_dyn_CS), pointer :: dCS => NULL() !< The control structure for the ice-shelf dynamics. + real, pointer, dimension(:,:) :: & - mass_shelf => NULL(), & !< The mass per unit area of the ice shelf or - !! sheet, in kg m-2. - area_shelf_h => NULL(), & !< The area per cell covered by the ice shelf, in m2. - - t_flux => NULL(), & !< The UPWARD sensible ocean heat flux at the - !! ocean-ice interface, in W m-2. - salt_flux => NULL(), & !< The downward salt flux at the ocean-ice - !! interface, in kg m-2 s-1. - lprec => NULL(), & !< The downward liquid water flux at the - !! ocean-ice interface, in kg m-2 s-1. - exch_vel_t => NULL(), & !< Sub-shelf thermal exchange velocity, in m/s - exch_vel_s => NULL(), & !< Sub-shelf salt exchange velocity, in m/s - utide => NULL(), & !< tidal velocity, in m/s - tfreeze => NULL(), & !< The freezing point potential temperature - !! an the ice-ocean interface, in deg C. - tflux_shelf => NULL(), & !< The UPWARD diffusive heat flux in the ice - !! shelf at the ice-ocean interface, in W m-2. - !!! DNG !!! - u_shelf => NULL(), & !< the zonal (?) velocity of the ice shelf/sheet, - ! in meters per second??? on q-points (B grid) - v_shelf => NULL(), & !< the meridional velocity of the ice shelf/sheet, - !! in m/s ?? on q-points (B grid) - h_shelf => NULL(), & !< the thickness of the shelf in m, redundant - !! with mass but may make code more readable - hmask => NULL(),& !< Mask used to indicate ice-covered cells, as - !! well as partially-covered 1: fully covered, - !! solve for velocity here (for now all ice-covered - !! cells are treated the same, this may change) - !! 2: partially covered, do not solve for velocity - !! 0: no ice in cell. - !! 3: bdry condition on thickness set - not in - !! computational domain - !! -2 : default (out of computational boundary, - !! and not = 3 - !! NOTE: hmask will change over time and - !! NEEDS TO BE MAINTAINED otherwise the wrong nodes - !! will be included in velocity calcs. - u_face_mask => NULL(), & !> masks for velocity boundary conditions - v_face_mask => NULL(), & !! on *C GRID* - this is because the FEM - !! cares about FACES THAT GET INTEGRATED OVER, - !! not vertices. Will represent boundary conditions - !! on computational boundary (or permanent boundary - !! between fast-moving and near-stagnant ice - !! FOR NOW: 1=interior bdry, 0=no-flow boundary, - !! 2=stress bdry condition, 3=inhomogeneous - !! dirichlet boundary, 4=flux boundary: at these - !! faces a flux will be specified which will - !! override velocities; a homogeneous velocity - !! condition will be specified (this seems to give - !! the solver less difficulty) - u_face_mask_boundary => NULL(), v_face_mask_boundary => NULL(), & - u_flux_boundary_values => NULL(), v_flux_boundary_values => NULL(), & - ! needed where u_face_mask is equal to 4, similary for v_face_mask - umask => NULL(), vmask => NULL(), & !< masks on the actual degrees of freedom (B grid) - !! 1=normal node, 3=inhomogeneous boundary node, - !! 0 - no flow node (will also get ice-free nodes) - calve_mask => NULL(), & !< a mask to prevent the ice shelf front from - !! advancing past its initial position (but it may - !! retreat) - !!! OVS !!! - t_shelf => NULL(), & ! veritcally integrated temperature the ice shelf/stream... oC - ! on q-points (B grid) - tmask => NULL(), & - ! masks for temperature boundary conditions ??? - ice_visc_bilinear => NULL(), & - ice_visc_lower_tri => NULL(), & - ice_visc_upper_tri => NULL(), & - thickness_boundary_values => NULL(), & - u_boundary_values => NULL(), & - v_boundary_values => NULL(), & - h_boundary_values => NULL(), & -!!! OVS !!! - t_boundary_values => NULL(), & - - taub_beta_eff_bilinear => NULL(), & ! nonlinear part of "linearized" basal stress - exact form depends on basal law exponent - ! and/or whether flow is "hybridized" a la Goldberg 2011 - taub_beta_eff_lower_tri => NULL(), & - taub_beta_eff_upper_tri => NULL(), & - - OD_rt => NULL(), float_frac_rt => NULL(), & !< two arrays that represent averages - OD_av => NULL(), float_frac => NULL() !! of ocean values that are maintained - !! within the ice shelf module and updated based on the "ocean state". - !! OD_av is ocean depth, and float_frac is the average amount of time - !! a cell is "exposed", i.e. the column thickness is below a threshold. - !! both are averaged over the time of a diagnostic (ice velocity) - - !! [if float_frac = 1 ==> grounded; obv. counterintuitive; might fix] - - real :: ustar_bg !< A minimum value for ustar under ice shelves, in m s-1. - real :: cdrag !< drag coefficient under ice shelves , non-dimensional. - real :: g_Earth !< The gravitational acceleration in m s-2. - real :: Cp !< The heat capacity of sea water, in J kg-1 K-1. - real :: Rho0 !< A reference ocean density in kg/m3. - real :: Cp_ice !< The heat capacity of fresh ice, in J kg-1 K-1. + utide => NULL() !< tidal velocity [m s-1] + + real :: ustar_bg !< A minimum value for ustar under ice shelves [Z s-1 ~> m s-1]. + real :: cdrag !< drag coefficient under ice shelves [nondim]. + real :: g_Earth !< The gravitational acceleration [m s-2] + real :: Cp !< The heat capacity of sea water [J kg-1 degC-1]. + real :: Rho0 !< A reference ocean density [kg m-3]. + real :: Cp_ice !< The heat capacity of fresh ice [J kg-1 degC-1]. real :: gamma_t !< The (fixed) turbulent exchange velocity in the - !< 2-equation formulation, in m s-1. - real :: Salin_ice !< The salinity of shelf ice, in PSU. - real :: Temp_ice !< The core temperature of shelf ice, in C. - real :: kv_ice !< The viscosity of ice, in m2 s-1. - real :: density_ice !< A typical density of ice, in kg m-3. - real :: kv_molec !< The molecular kinematic viscosity of sea water, m2 s-1. - real :: kd_molec_salt!< The molecular diffusivity of salt, in m2 s-1. - real :: kd_molec_temp!< The molecular diffusivity of heat, in m2 s-1. - real :: Lat_fusion !< The latent heat of fusion, in J kg-1. + !< 2-equation formulation [m s-1]. + real :: Salin_ice !< The salinity of shelf ice [ppt]. + real :: Temp_ice !< The core temperature of shelf ice [degC]. + real :: kv_ice !< The viscosity of ice [m2 s-1]. + real :: density_ice !< A typical density of ice [kg m-3]. + real :: rho_ice !< Nominal ice density [kg m-2 Z-1 ~> kg m-3]. + real :: kv_molec !< The molecular kinematic viscosity of sea water [m2 s-1]. + real :: kd_molec_salt!< The molecular diffusivity of salt [m2 s-1]. + real :: kd_molec_temp!< The molecular diffusivity of heat [m2 s-1]. + real :: Lat_fusion !< The latent heat of fusion [J kg-1]. real :: Gamma_T_3EQ !< Nondimensional heat-transfer coefficient, used in the 3Eq. formulation !< This number should be specified by the user. real :: col_thick_melt_threshold !< if the mixed layer is below this threshold, melt rate @@ -192,71 +117,30 @@ module MOM_ice_shelf !! is initialized - so need to reorganize MOM driver. !! it will be the prognistic timestep ... maybe. - !!! all need to be initialized - logical :: solo_ice_sheet !< whether the ice model is running without being !! coupled to the ocean logical :: GL_regularize !< whether to regularize the floatation condition !! at the grounding line a la Goldberg Holland Schoof 2009 - integer :: n_sub_regularize - !< partition of cell over which to integrate for - !! interpolated grounding line the (rectangular) is - !! divided into nxn equally-sized rectangles, over which - !! basal contribution is integrated (iterative quadrature) logical :: GL_couple !< whether to let the floatation condition be !!determined by ocean column thickness means update_OD_ffrac !! will be called (note: GL_regularize and GL_couple !! should be exclusive) - - real :: A_glen_isothermal - real :: n_glen - real :: eps_glen_min - real :: C_basal_friction - real :: n_basal_friction real :: density_ocean_avg !< this does not affect ocean circulation OR thermodynamics !! it is to estimate the gravitational driving force at the - !! shelf front(until we think of a better way to do it- + !! shelf front (until we think of a better way to do it, !! but any difference will be negligible) - real :: thresh_float_col_depth ! the water column depth over which the shelf if considered to be floating - logical :: moving_shelf_front - logical :: calve_to_mask - real :: min_thickness_simple_calve ! min. ice shelf thickness criteria for calving - real :: T0, S0 ! temp/salt at ocean surface in the restoring region - real :: input_flux - real :: input_thickness - - real :: len_lat ! this really should be a Grid or Domain field - - - real :: velocity_update_time_step ! the time to update the velocity through the nonlinear - ! elliptic equation. i think this should be done no more often than - ! ~ once a day (maybe longer) because it will depend on ocean values - ! that are averaged over this time interval, and the solve will begin - ! to lose meaning if it is done too frequently - integer :: velocity_update_sub_counter ! there is no outer loop for the velocity solve; the counter will have to be stored - integer :: velocity_update_counter ! the "outer" timestep number - integer :: nstep_velocity ! ~ (velocity_update_time_step / time_step) - - real :: cg_tolerance, nonlinear_tolerance - integer :: cg_max_iterations - integer :: nonlin_solve_err_mode ! 1: exit vel solve based on nonlin residual - ! 2: exit based on "fixed point" metric (|u - u_last| / |u| < tol where | | is infty-norm - real :: CFL_factor ! in uncoupled run, how to limit subcycled advective timestep - ! i.e. dt = CFL_factor * min (dx / u) - logical :: use_reproducing_sums !< use new reproducing sums of Bob & Alistair for - !! global sums. - !! NOTE: for this to work all tiles must have the same & of - !! elements. this means thatif a symmetric grid is being - !! used, the southwest nodes of the southwest tiles will not - !! be included in the - - - logical :: switch_var ! for debdugging - a switch to ensure some event happens only once + logical :: calve_to_mask !< If true, calve any ice that passes outside of a masked area + real :: min_thickness_simple_calve !< min. ice shelf thickness criteria for calving [Z ~> m]. + real :: T0 !< temperature at ocean surface in the restoring region [degC] + real :: S0 !< Salinity at ocean surface in the restoring region [ppt]. + real :: input_flux !< Ice volume flux at an upstream open boundary [m3 s-1]. + real :: input_thickness !< Ice thickness at an upstream open boundary [m]. type(time_type) :: Time !< The component's time. type(EOS_type), pointer :: eqn_of_state => NULL() !< Type that indicates the !! equation of state to use. - logical :: shelf_mass_is_dynamic !< True if the ice shelf mass changes with time. + logical :: active_shelf_dynamics !< True if the ice shelf mass changes as a result + !! the dynamic ice-shelf model. logical :: override_shelf_movement !< If true, user code specifies the shelf movement !! instead of using the dynamic ice-shelf mode. logical :: isthermo !< True if the ice shelf can exchange heat and @@ -270,103 +154,76 @@ module MOM_ice_shelf logical :: constant_sea_level !< if true, apply an evaporative, heat and salt !! fluxes. It will avoid large increase in sea level. real :: cutoff_depth !< depth above which melt is set to zero (>= 0). - real :: lambda1, lambda2, lambda3 !< liquidus coeffs. Needed if find_salt_root = true - !>@{ - ! Diagnostic handles + real :: lambda1 !< liquidus coeff., Needed if find_salt_root = true + real :: lambda2 !< liquidus coeff., Needed if find_salt_root = true + real :: lambda3 !< liquidus coeff., Needed if find_salt_root = true + !>@{ Diagnostic handles integer :: id_melt = -1, id_exch_vel_s = -1, id_exch_vel_t = -1, & id_tfreeze = -1, id_tfl_shelf = -1, & id_thermal_driving = -1, id_haline_driving = -1, & id_u_ml = -1, id_v_ml = -1, id_sbdry = -1, & - id_u_shelf = -1, id_v_shelf = -1, id_h_shelf = -1, id_h_mask = -1, & - id_u_mask = -1, id_v_mask = -1, id_t_shelf = -1, id_t_mask = -1, & - id_surf_elev = -1, id_bathym = -1, id_float_frac = -1, id_col_thick = -1, & - id_area_shelf_h = -1, id_OD_av = -1, id_float_frac_rt = -1,& + id_h_shelf = -1, id_h_mask = -1, & + id_surf_elev = -1, id_bathym = -1, & + id_area_shelf_h = -1, & id_ustar_shelf = -1, id_shelf_mass = -1, id_mass_flux = -1 !>@} - ! ids for outputting intermediate thickness in advection subroutine (debugging) - !integer :: id_h_after_uflux = -1, id_h_after_vflux = -1, id_h_after_adv = -1 integer :: id_read_mass !< An integer handle used in time interpolation of !! the ice shelf mass read from a file integer :: id_read_area !< An integer handle used in time interpolation of !! the ice shelf mass read from a file - type(diag_ctrl), pointer :: diag !< A structure that is used to control diagnostic - !! output. - type(user_ice_shelf_CS), pointer :: user_CS => NULL() + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to control diagnostic output. + type(user_ice_shelf_CS), pointer :: user_CS => NULL() !< A pointer to the control structure for + !! user-supplied modifications to the ice shelf code. - logical :: write_output_to_file !< this is for seeing arrays w/out netcdf capability logical :: debug !< If true, write verbose checksums for debugging purposes !! and use reproducible sums end type ice_shelf_CS -integer :: id_clock_shelf, id_clock_pass !< Clock for group pass calls +integer :: id_clock_shelf !< CPU Clock for the ice shelf code +integer :: id_clock_pass !< CPU Clock for group pass calls contains -!> used for flux limiting in advective subroutines Van Leer limiter (source: Wikipedia) -function slope_limiter (num, denom) - real, intent(in) :: num - real, intent(in) :: denom - real :: slope_limiter - real :: r - - if (denom .eq. 0) then - slope_limiter = 0 - elseif (num*denom .le. 0) then - slope_limiter = 0 - else - r = num/denom - slope_limiter = (r+abs(r))/(1+abs(r)) - endif - -end function slope_limiter - -!> Calculate area of quadrilateral. -function quad_area (X, Y) - real, dimension(4), intent(in) :: X - real, dimension(4), intent(in) :: Y - real :: quad_area, p2, q2, a2, c2, b2, d2 - -! X and Y must be passed in the form - ! 3 - 4 - ! | | - ! 1 - 2 - - p2 = (X(4)-X(1))**2 + (Y(4)-Y(1))**2 ; q2 = (X(3)-X(2))**2 + (Y(3)-Y(2))**2 - a2 = (X(3)-X(4))**2 + (Y(3)-Y(4))**2 ; c2 = (X(1)-X(2))**2 + (Y(1)-Y(2))**2 - b2 = (X(2)-X(4))**2 + (Y(2)-Y(4))**2 ; d2 = (X(3)-X(1))**2 + (Y(3)-Y(1))**2 - quad_area = .25 * sqrt(4*P2*Q2-(B2+D2-A2-C2)**2) - -end function quad_area - !> Calculates fluxes between the ocean and ice-shelf using the three-equations !! formulation (optional to use just two equations). !! See \ref section_ICE_SHELF_equations -subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) +subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) type(surface), intent(inout) :: state !< structure containing fields that !!describe the surface state of the ocean - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(forcing), intent(inout) :: fluxes !< structure containing pointers to - !!any possible forcing fields. - !!Unused fields have NULL ptrs. - type(time_type), intent(in) :: Time !< Start time of the fluxes. + type(forcing), intent(inout) :: fluxes !< structure containing pointers to any possible + !! thermodynamic or mass-flux forcing fields. + type(time_type), intent(in) :: Time !< Start time of the fluxes. real, intent(in) :: time_step !< Length of time over which - !! these fluxes will be applied, in s. + !! these fluxes will be applied [s]. type(ice_shelf_CS), pointer :: CS !< A pointer to the control structure !! returned by a previous call to !! initialize_ice_shelf. + type(mech_forcing), optional, intent(inout) :: forces !< A structure with the driving mechanical forces + + type(ocean_grid_type), pointer :: G => NULL() ! The grid structure used by the ice shelf. + type(unit_scale_type), pointer :: US => NULL() ! Pointer to a structure containing + ! various unit conversion factors + type(ice_shelf_state), pointer :: ISS => NULL() !< A structure with elements that describe + !! the ice-shelf state real, dimension(SZI_(CS%grid)) :: & - Rhoml, & !< Ocean mixed layer density in kg m-3. + Rhoml, & !< Ocean mixed layer density [kg m-3]. dR0_dT, & !< Partial derivative of the mixed layer density - !< with temperature, in units of kg m-3 K-1. + !< with temperature [kg m-3 degC-1]. dR0_dS, & !< Partial derivative of the mixed layer density - !< with salinity, in units of kg m-3 psu-1. - p_int !< The pressure at the ice-ocean interface, in Pa. + !< with salinity [kg m-3 ppt-1]. + p_int !< The pressure at the ice-ocean interface [Pa]. - real, dimension(:,:), allocatable :: mass_flux !< total mass flux of freshwater across - real, dimension(:,:), allocatable :: haline_driving !< (SSS - S_boundary) ice-ocean + real, dimension(SZI_(CS%grid),SZJ_(CS%grid)) :: & + exch_vel_t, & !< Sub-shelf thermal exchange velocity [m s-1] + exch_vel_s !< Sub-shelf salt exchange velocity [m s-1] + + real, dimension(SZDI_(CS%grid),SZDJ_(CS%grid)) :: & + mass_flux !< total mass flux of freshwater across + real, dimension(SZDI_(CS%grid),SZDJ_(CS%grid)) :: & + haline_driving !< (SSS - S_boundary) ice-ocean !! interface, positive for melting and negative for freezing. !! This is computed as part of the ISOMIP diagnostics. real, parameter :: VK = 0.40 !< Von Karman's constant - dimensionless @@ -374,23 +231,24 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) !! viscosity is linearly increasing. (Was 1/8. Why?) real, parameter :: RC = 0.20 ! critical flux Richardson number. real :: I_ZETA_N !< The inverse of ZETA_N. - real :: LF, I_LF !< Latent Heat of fusion (J kg-1) and its inverse. + real :: LF, I_LF !< Latent Heat of fusion [J kg-1] and its inverse. real :: I_VK !< The inverse of VK. - real :: PR, SC !< The Prandtl number and Schmidt number, nondim. + real :: PR, SC !< The Prandtl number and Schmidt number [nondim]. ! 3 equations formulation variables - real, dimension(:,:), allocatable :: Sbdry !< Salinities in the ocean at the interface - !! with the ice shelf, in PSU. + real, dimension(SZDI_(CS%grid),SZDJ_(CS%grid)) :: & + Sbdry !< Salinities in the ocean at the interface with the ice shelf [ppt]. real :: Sbdry_it real :: Sbdry1, Sbdry2, S_a, S_b, S_c ! use to find salt roots - real :: dS_it !< The interface salinity change during an iteration, in PSU. - real :: hBL_neut !< The neutral boundary layer thickness, in m. + real :: dS_it !< The interface salinity change during an iteration [ppt]. + real :: hBL_neut !< The neutral boundary layer thickness [m]. real :: hBL_neut_h_molec !< The ratio of the neutral boundary layer thickness - !! to the molecular boundary layer thickness, ND. - real :: wT_flux !< The vertical fluxes of heat and buoyancy just inside the - real :: wB_flux !< ocean, in C m s-1 and m2 s-3, ###CURRENTLY POSITIVE UPWARD. - real :: dB_dS !< The derivative of buoyancy with salinity, in m s-2 PSU-1. - real :: dB_dT !< The derivative of buoyancy with temperature, in m s-2 C-1. + !! to the molecular boundary layer thickness [nondim]. + !### THESE ARE CURRENTLY POSITIVE UPWARD. + real :: wT_flux !< The vertical flux of heat just inside the ocean [degC m s-1]. + real :: wB_flux !< The vertical flux of heat just inside the ocean [m2 s-3]. + real :: dB_dS !< The derivative of buoyancy with salinity [m s-2 ppt-1]. + real :: dB_dT !< The derivative of buoyancy with temperature [m s-2 degC-1]. real :: I_n_star, n_star_term, absf real :: dIns_dwB !< The partial derivative of I_n_star with wB_flux, in ???. real :: dT_ustar, dS_ustar @@ -408,19 +266,23 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) real :: I_Gam_T, I_Gam_S, dG_dwB, iDens real :: u_at_h, v_at_h, Isqrt2 logical :: Sb_min_set, Sb_max_set - character(4) :: stepnum - character(2) :: procnum + logical :: update_ice_vel ! If true, it is time to update the ice shelf velocities. + logical :: coupled_GL ! If true, the grouding line position is determined based on + ! coupled ice-ocean dynamics. - type(ocean_grid_type), pointer :: G real, parameter :: c2_3 = 2.0/3.0 - integer :: i, j, is, ie, js, je, ied, jed, it1, it3, iters_vel_solve + character(len=160) :: mesg ! The text of an error message + integer :: i, j, is, ie, js, je, ied, jed, it1, it3 real, parameter :: rho_fw = 1000.0 ! fresh water density + if (.not. associated(CS)) call MOM_error(FATAL, "shelf_calc_flux: "// & "initialize_ice_shelf must be called before shelf_calc_flux.") call cpu_clock_begin(id_clock_shelf) + G => CS%grid ; US => CS%US + ISS => CS%ISS + ! useful parameters - G => CS%grid is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; ied = G%ied ; jed = G%jed I_ZETA_N = 1.0 / ZETA_N LF = CS%Lat_fusion @@ -442,36 +304,36 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) ! these fields are already set to zero during initialization ! However, they seem to be changed somewhere and, for diagnostic ! reasons, it is better to set them to zero again. - CS%tflux_shelf(:,:) = 0.0; CS%exch_vel_t(:,:) = 0.0 - CS%lprec(:,:) = 0.0; CS%exch_vel_s(:,:) = 0.0 - CS%salt_flux(:,:) = 0.0; CS%t_flux(:,:) = 0.0 - CS%tfreeze(:,:) = 0.0 + exch_vel_t(:,:) = 0.0 ; exch_vel_s(:,:) = 0.0 + ISS%tflux_shelf(:,:) = 0.0 ; ISS%water_flux(:,:) = 0.0 + ISS%salt_flux(:,:) = 0.0; ISS%tflux_ocn(:,:) = 0.0 + ISS%tfreeze(:,:) = 0.0 ! define Sbdry to avoid Run-Time Check Failure, when melt is not computed. - allocate( haline_driving(G%ied,G%jed) ); haline_driving(:,:) = 0.0 - allocate( Sbdry(G%ied,G%jed) ); Sbdry(:,:) = state%sss(:,:) + haline_driving(:,:) = 0.0 + Sbdry(:,:) = state%sss(:,:) !update time CS%Time = Time - if (CS%shelf_mass_is_dynamic .and. CS%override_shelf_movement) then - CS%time_step = time_step - ! update shelf mass - if (CS%mass_from_file) call update_shelf_mass(G, CS, Time, fluxes) + if (CS%override_shelf_movement) then + CS%time_step = time_step + ! update shelf mass + if (CS%mass_from_file) call update_shelf_mass(G, CS, ISS, Time) endif - if (CS%DEBUG) then - call hchksum (fluxes%frac_shelf_h, "frac_shelf_h before apply melting", G%HI, haloshift=0) - call hchksum (state%sst, "sst before apply melting", G%HI, haloshift=0) - call hchksum (state%sss, "sss before apply melting", G%HI, haloshift=0) - call hchksum (state%u, "u_ml before apply melting", G%HI, haloshift=0) - call hchksum (state%v, "v_ml before apply melting", G%HI, haloshift=0) - call hchksum (state%ocean_mass, "ocean_mass before apply melting", G%HI, haloshift=0) - endif + if (CS%DEBUG) then + call hchksum(fluxes%frac_shelf_h, "frac_shelf_h before apply melting", G%HI, haloshift=0) + call hchksum(state%sst, "sst before apply melting", G%HI, haloshift=0) + call hchksum(state%sss, "sss before apply melting", G%HI, haloshift=0) + call hchksum(state%u, "u_ml before apply melting", G%HI, haloshift=0) + call hchksum(state%v, "v_ml before apply melting", G%HI, haloshift=0) + call hchksum(state%ocean_mass, "ocean_mass before apply melting", G%HI, haloshift=0) + endif do j=js,je ! Find the pressure at the ice-ocean interface, averaged only over the ! part of the cell covered by ice shelf. - do i=is,ie ; p_int(i) = CS%g_Earth * CS%mass_shelf(i,j) ; enddo + do i=is,ie ; p_int(i) = CS%g_Earth * ISS%mass_shelf(i,j) ; enddo ! Calculate insitu densities and expansion coefficients call calculate_density(state%sst(:,j),state%sss(:,j), p_int, & @@ -488,7 +350,7 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) ! propose instead to allow where Hml > [some threshold] if ((iDens*state%ocean_mass(i,j) > CS%col_thick_melt_threshold) .and. & - (CS%area_shelf_h(i,j) > 0.0) .and. & + (ISS%area_shelf_h(i,j) > 0.0) .and. & (CS%isthermo) .and. (state%Hml(i,j) > 0.0) ) then if (CS%threeeq) then @@ -500,12 +362,11 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) u_at_h = state%u(i,j) v_at_h = state%v(i,j) - fluxes%ustar_shelf(i,j)= sqrt(CS%cdrag*((u_at_h**2.0 + v_at_h**2.0) +& - CS%utide(i,j)**1)) + !### I think that CS%utide**1 should be CS%utide**2 + fluxes%ustar_shelf(i,j) = MAX(CS%ustar_bg, US%m_to_Z * & + sqrt(CS%cdrag*((u_at_h**2.0 + v_at_h**2.0) + CS%utide(i,j)**1))) - ustar_h = MAX(CS%ustar_bg, fluxes%ustar_shelf(i,j)) - - fluxes%ustar_shelf(i,j) = ustar_h + ustar_h = US%Z_to_m*fluxes%ustar_shelf(i,j) if (associated(state%taux_shelf) .and. associated(state%tauy_shelf)) then state%taux_shelf(i,j) = ustar_h*ustar_h*CS%Rho0*Isqrt2 @@ -536,16 +397,17 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) state%sst(i,j))-LF*CS%Gamma_T_3EQ/35.0 S_c = LF*(CS%Gamma_T_3EQ/35.0)*state%sss(i,j) + !### Depending on the sign of S_b, one of these will be inaccurate! Sbdry1 = (-S_b + SQRT(S_b*S_b-4*S_a*S_c))/(2*S_a) Sbdry2 = (-S_b - SQRT(S_b*S_b-4*S_a*S_c))/(2*S_a) Sbdry(i,j) = MAX(Sbdry1, Sbdry2) ! Safety check if (Sbdry(i,j) < 0.) then - write(*,*)'state%sss(i,j)',state%sss(i,j) - write(*,*)'S_a, S_b, S_c',S_a, S_b, S_c - write(*,*)'I,J,Sbdry1,Sbdry2',i,j,Sbdry1,Sbdry2 - call MOM_error(FATAL, & - "shelf_calc_flux: Negative salinity (Sbdry).") + write(mesg,*) 'state%sss(i,j) = ',state%sss(i,j), 'S_a, S_b, S_c', S_a, S_b, S_c + call MOM_error(WARNING, mesg, .true.) + write(mesg,*) 'I,J,Sbdry1,Sbdry2',i,j,Sbdry1,Sbdry2 + call MOM_error(WARNING, mesg, .true.) + call MOM_error(FATAL, "shelf_calc_flux: Negative salinity (Sbdry).") endif else ! Guess sss as the iteration starting point for the boundary salinity. @@ -555,9 +417,9 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) do it1 = 1,20 ! Determine the potential temperature at the ice-ocean interface. - call calculate_TFreeze(Sbdry(i,j), p_int(i), CS%tfreeze(i,j), CS%eqn_of_state) + call calculate_TFreeze(Sbdry(i,j), p_int(i), ISS%tfreeze(i,j), CS%eqn_of_state) - dT_ustar = (state%sst(i,j) - CS%tfreeze(i,j)) * ustar_h + dT_ustar = (state%sst(i,j) - ISS%tfreeze(i,j)) * ustar_h dS_ustar = (state%sss(i,j) - Sbdry(i,j)) * ustar_h ! First, determine the buoyancy flux assuming no effects of stability @@ -565,13 +427,13 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) ! when the buoyancy flux is destabilizing. if (CS%const_gamma) then ! if using a constant gamma_T - ! note the different form, here I_Gam_T is NOT 1/Gam_T! - I_Gam_T = CS%Gamma_T_3EQ - I_Gam_S = CS%Gamma_T_3EQ/35. + ! note the different form, here I_Gam_T is NOT 1/Gam_T! + I_Gam_T = CS%Gamma_T_3EQ + I_Gam_S = CS%Gamma_T_3EQ/35. else - Gam_turb = I_VK * (ln_neut + (0.5 * I_ZETA_N - 1.0)) - I_Gam_T = 1.0 / (Gam_mol_t + Gam_turb) - I_Gam_S = 1.0 / (Gam_mol_s + Gam_turb) + Gam_turb = I_VK * (ln_neut + (0.5 * I_ZETA_N - 1.0)) + I_Gam_T = 1.0 / (Gam_mol_t + Gam_turb) + I_Gam_S = 1.0 / (Gam_mol_s + Gam_turb) endif wT_flux = dT_ustar * I_Gam_T @@ -600,9 +462,9 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) endif if (CS%const_gamma) then ! if using a constant gamma_T - ! note the different form, here I_Gam_T is NOT 1/Gam_T! - I_Gam_T = CS%Gamma_T_3EQ - I_Gam_S = CS%Gamma_T_3EQ/35. + ! note the different form, here I_Gam_T is NOT 1/Gam_T! + I_Gam_T = CS%Gamma_T_3EQ + I_Gam_S = CS%Gamma_T_3EQ/35. else I_Gam_T = 1.0 / (Gam_mol_t + Gam_turb) I_Gam_S = 1.0 / (Gam_mol_s + Gam_turb) @@ -624,9 +486,9 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) enddo !it3 endif - CS%t_flux(i,j) = RhoCp * wT_flux - CS%exch_vel_t(i,j) = ustar_h * I_Gam_T - CS%exch_vel_s(i,j) = ustar_h * I_Gam_S + ISS%tflux_ocn(i,j) = RhoCp * wT_flux + exch_vel_t(i,j) = ustar_h * I_Gam_T + exch_vel_s(i,j) = ustar_h * I_Gam_S !Calculate the heat flux inside the ice shelf. @@ -636,39 +498,39 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) ! dT/dz ~= min( (lprec/(rho_ice*K_ice))*(CS%Temp_Ice-T_freeze) , 0.0 ) !If this approximation is not made, iterations are required... See H+J Fig 3. - if (CS%t_flux(i,j) <= 0.0) then ! Freezing occurs, so zero ice heat flux. - CS%lprec(i,j) = I_LF * CS%t_flux(i,j) - CS%tflux_shelf(i,j) = 0.0 + if (ISS%tflux_ocn(i,j) <= 0.0) then ! Freezing occurs, so zero ice heat flux. + ISS%water_flux(i,j) = I_LF * ISS%tflux_ocn(i,j) + ISS%tflux_shelf(i,j) = 0.0 else if (CS%insulator) then - !no conduction/perfect insulator - CS%tflux_shelf(i,j) = 0.0 - CS%lprec(i,j) = I_LF * (- CS%tflux_shelf(i,j) + CS%t_flux(i,j)) + !no conduction/perfect insulator + ISS%tflux_shelf(i,j) = 0.0 + ISS%water_flux(i,j) = I_LF * (- ISS%tflux_shelf(i,j) + ISS%tflux_ocn(i,j)) else - ! With melting, from H&J 1999, eqs (31) & (26)... - ! Q_ice ~= cp_ice * (CS%Temp_Ice-T_freeze) * lprec - ! RhoLF*lprec = Q_ice + CS%t_flux(i,j) - ! lprec = (CS%t_flux(i,j)) / (LF + cp_ice * (T_freeze-CS%Temp_Ice)) - CS%lprec(i,j) = CS%t_flux(i,j) / & - (LF + CS%CP_Ice * (CS%Tfreeze(i,j) - CS%Temp_Ice)) - - CS%tflux_shelf(i,j) = CS%t_flux(i,j) - LF*CS%lprec(i,j) + ! With melting, from H&J 1999, eqs (31) & (26)... + ! Q_ice ~= cp_ice * (CS%Temp_Ice-T_freeze) * lprec + ! RhoLF*lprec = Q_ice + ISS%tflux_ocn(i,j) + ! lprec = (ISS%tflux_ocn(i,j)) / (LF + cp_ice * (T_freeze-CS%Temp_Ice)) + ISS%water_flux(i,j) = ISS%tflux_ocn(i,j) / & + (LF + CS%CP_Ice * (ISS%tfreeze(i,j) - CS%Temp_Ice)) + + ISS%tflux_shelf(i,j) = ISS%tflux_ocn(i,j) - LF*ISS%water_flux(i,j) endif endif !other options: dTi/dz linear through shelf - ! dTi_dz = (CS%Temp_Ice - CS%tfreeze(i,j))/G%draft(i,j) - ! CS%tflux_shelf(i,j) = - Rho_Ice * CS%CP_Ice * KTI * dTi_dz + ! dTi_dz = (CS%Temp_Ice - ISS%tfreeze(i,j))/G%draft(i,j) + ! ISS%tflux_shelf(i,j) = - Rho_Ice * CS%CP_Ice * KTI * dTi_dz if (CS%find_salt_root) then exit ! no need to do interaction, so exit loop else - mass_exch = CS%exch_vel_s(i,j) * CS%Rho0 + mass_exch = exch_vel_s(i,j) * CS%Rho0 Sbdry_it = (state%sss(i,j) * mass_exch + CS%Salin_ice * & - CS%lprec(i,j)) / (mass_exch + CS%lprec(i,j)) + ISS%water_flux(i,j)) / (mass_exch + ISS%water_flux(i,j)) dS_it = Sbdry_it - Sbdry(i,j) if (abs(dS_it) < 1e-4*(0.5*(state%sss(i,j) + Sbdry(i,j) + 1.e-10))) exit @@ -685,11 +547,11 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) endif ! dS_it < 0.0 if (Sb_min_set .and. Sb_max_set) then - ! Use the false position method for the next iteration. - Sbdry(i,j) = Sb_min + (Sb_max-Sb_min) * & - (dS_min / (dS_min - dS_max)) + ! Use the false position method for the next iteration. + Sbdry(i,j) = Sb_min + (Sb_max-Sb_min) * & + (dS_min / (dS_min - dS_max)) else - Sbdry(i,j) = Sbdry_it + Sbdry(i,j) = Sbdry_it endif ! Sb_min_set Sbdry(i,j) = Sbdry_it @@ -703,16 +565,16 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) ! is specified and large enough that the ocean salinity at the interface ! is about the same as the boundary layer salinity. - call calculate_TFreeze(state%sss(i,j), p_int(i), CS%tfreeze(i,j), CS%eqn_of_state) + call calculate_TFreeze(state%sss(i,j), p_int(i), ISS%tfreeze(i,j), CS%eqn_of_state) - CS%exch_vel_t(i,j) = CS%gamma_t - CS%t_flux(i,j) = RhoCp * CS%exch_vel_t(i,j) * (state%sst(i,j) - CS%tfreeze(i,j)) - CS%tflux_shelf(i,j) = 0.0 - CS%lprec(i,j) = I_LF * CS%t_flux(i,j) + exch_vel_t(i,j) = CS%gamma_t + ISS%tflux_ocn(i,j) = RhoCp * exch_vel_t(i,j) * (state%sst(i,j) - ISS%tfreeze(i,j)) + ISS%tflux_shelf(i,j) = 0.0 + ISS%water_flux(i,j) = I_LF * ISS%tflux_ocn(i,j) Sbdry(i,j) = 0.0 endif else !not shelf - CS%t_flux(i,j) = 0.0 + ISS%tflux_ocn(i,j) = 0.0 endif ! haline_driving(:,:) = state%sss(i,j) - Sbdry(i,j) @@ -720,353 +582,394 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) enddo ! i-loop enddo ! j-loop - ! CS%lprec = precipitating liquid water into the ocean ( kg/(m^2 s) ) + ! ISS%water_flux = net liquid water into the ocean ( kg/(m^2 s) ) ! We want melt in m/year if (CS%const_gamma) then ! use ISOMIP+ eq. with rho_fw - fluxes%iceshelf_melt = CS%lprec * (86400.0*365.0/rho_fw) * CS%flux_factor + fluxes%iceshelf_melt = ISS%water_flux * (86400.0*365.0/rho_fw) * CS%flux_factor else ! use original eq. - fluxes%iceshelf_melt = CS%lprec * (86400.0*365.0/CS%density_ice) * CS%flux_factor + fluxes%iceshelf_melt = ISS%water_flux * (86400.0*365.0/CS%density_ice) * CS%flux_factor endif - do j=js,je - do i=is,ie - if ((iDens*state%ocean_mass(i,j) > CS%col_thick_melt_threshold) .and. & - (CS%area_shelf_h(i,j) > 0.0) .and. & - (CS%isthermo) .and. (state%Hml(i,j) > 0.0) ) then - - ! Set melt to zero above a cutoff pressure - ! (CS%Rho0*CS%cutoff_depth*CS%g_Earth) this is needed for the isomip - ! test case. - if ((CS%g_Earth * CS%mass_shelf(i,j)) < CS%Rho0*CS%cutoff_depth* & - CS%g_Earth) then - CS%lprec(i,j) = 0.0 - fluxes%iceshelf_melt(i,j) = 0.0 - endif - ! Compute haline driving, which is one of the diags. used in ISOMIP - haline_driving(i,j) = (CS%lprec(i,j) * Sbdry(i,j)) / & - (CS%Rho0 * CS%exch_vel_s(i,j)) - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!Safety checks !!!!!!!!!!!!!!!!!!!!!!!!! - !1)Check if haline_driving computed above is consistent with - ! haline_driving = state%sss - Sbdry - !if (fluxes%iceshelf_melt(i,j) /= 0.0) then - ! if (haline_driving(i,j) /= (state%sss(i,j) - Sbdry(i,j))) then - ! write(*,*)'Something is wrong at i,j',i,j - ! write(*,*)'haline_driving, sss-Sbdry',haline_driving(i,j), & - ! (state%sss(i,j) - Sbdry(i,j)) - ! call MOM_error(FATAL, & - ! "shelf_calc_flux: Inconsistency in melt and haline_driving") - ! endif - !endif - - ! 2) check if |melt| > 0 when star_shelf = 0. - ! this should never happen - if (abs(fluxes%iceshelf_melt(i,j))>0.0) then - if (fluxes%ustar_shelf(i,j) == 0.0) then - write(*,*)'Something is wrong at i,j',i,j - call MOM_error(FATAL, & - "shelf_calc_flux: |melt| > 0 and star_shelf = 0.") - endif - endif - endif ! area_shelf_h - !!!!!!!!!!!!!!!!!!!!!!!!!!!!End of safety checks !!!!!!!!!!!!!!!!!!! - enddo ! i-loop - enddo ! j-loop + do j=js,je ; do i=is,ie + if ((iDens*state%ocean_mass(i,j) > CS%col_thick_melt_threshold) .and. & + (ISS%area_shelf_h(i,j) > 0.0) .and. & + (CS%isthermo) .and. (state%Hml(i,j) > 0.0) ) then + + ! Set melt to zero above a cutoff pressure + ! (CS%Rho0*CS%cutoff_depth*CS%g_Earth) this is needed for the isomip + ! test case. + if ((CS%g_Earth * ISS%mass_shelf(i,j)) < CS%Rho0*CS%cutoff_depth* & + CS%g_Earth) then + ISS%water_flux(i,j) = 0.0 + fluxes%iceshelf_melt(i,j) = 0.0 + endif + ! Compute haline driving, which is one of the diags. used in ISOMIP + haline_driving(i,j) = (ISS%water_flux(i,j) * Sbdry(i,j)) / & + (CS%Rho0 * exch_vel_s(i,j)) + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!Safety checks !!!!!!!!!!!!!!!!!!!!!!!!! + !1)Check if haline_driving computed above is consistent with + ! haline_driving = state%sss - Sbdry + !if (fluxes%iceshelf_melt(i,j) /= 0.0) then + ! if (haline_driving(i,j) /= (state%sss(i,j) - Sbdry(i,j))) then + ! write(mesg,*) 'at i,j=',i,j,' haline_driving, sss-Sbdry',haline_driving(i,j), & + ! (state%sss(i,j) - Sbdry(i,j)) + ! call MOM_error(FATAL, & + ! "shelf_calc_flux: Inconsistency in melt and haline_driving"//trim(mesg)) + ! endif + !endif + + ! 2) check if |melt| > 0 when ustar_shelf = 0. + ! this should never happen + if ((abs(fluxes%iceshelf_melt(i,j))>0.0) .and. (fluxes%ustar_shelf(i,j) == 0.0)) then + write(mesg,*) "|melt| = ",fluxes%iceshelf_melt(i,j)," > 0 and ustar_shelf = 0. at i,j", i, j + call MOM_error(FATAL, "shelf_calc_flux: "//trim(mesg)) + endif + endif ! area_shelf_h + !!!!!!!!!!!!!!!!!!!!!!!!!!!!End of safety checks !!!!!!!!!!!!!!!!!!! + enddo ; enddo ! i- and j-loops - ! mass flux (kg/s), part of ISOMIP diags. - allocate( mass_flux(G%ied,G%jed) ); mass_flux(:,:) = 0.0 - mass_flux = (CS%lprec) * CS%area_shelf_h + ! mass flux [kg s-1], part of ISOMIP diags. + mass_flux(:,:) = 0.0 + mass_flux(:,:) = ISS%water_flux(:,:) * ISS%area_shelf_h(:,:) - if (CS%shelf_mass_is_dynamic) then + if (CS%active_shelf_dynamics .or. CS%override_shelf_movement) then call cpu_clock_begin(id_clock_pass) - call pass_var(CS%area_shelf_h, G%domain, complete=.false.) - call pass_var(CS%mass_shelf, G%domain) + call pass_var(ISS%area_shelf_h, G%domain, complete=.false.) + call pass_var(ISS%mass_shelf, G%domain) call cpu_clock_end(id_clock_pass) endif ! Melting has been computed, now is time to update thickness and mass - if (CS%shelf_mass_is_dynamic .and. CS%override_shelf_movement) then - if (.not. (CS%mass_from_file)) then - - call change_thickness_using_melt(CS,G,time_step, fluxes) + if ( CS%override_shelf_movement .and. (.not.CS%mass_from_file)) then + call change_thickness_using_melt(ISS, G, time_step, fluxes, CS%rho_ice, CS%debug) + if (CS%debug) then + call hchksum(ISS%h_shelf, "h_shelf after change thickness using melt", G%HI, haloshift=0, scale=US%Z_to_m) + call hchksum(ISS%mass_shelf, "mass_shelf after change thickness using melt", G%HI, haloshift=0) endif - endif - if (CS%DEBUG) then - call MOM_forcing_chksum("Before add shelf flux", fluxes, G, haloshift=0) - endif - call add_shelf_flux(G, CS, state, forces, fluxes) + if (CS%DEBUG) call MOM_forcing_chksum("Before add shelf flux", fluxes, G, US, haloshift=0) + + call add_shelf_flux(G, CS, state, fluxes) ! now the thermodynamic data is passed on... time to update the ice dynamic quantities - if (CS%shelf_mass_is_dynamic .and. .not.CS%override_shelf_movement) then + if (CS%active_shelf_dynamics) then + update_ice_vel = .false. + coupled_GL = (CS%GL_couple .and. .not.CS%solo_ice_sheet) ! advect the ice shelf, and advance the front. Calving will be in here somewhere as well.. ! when we decide on how to do it + call update_ice_shelf(CS%dCS, ISS, G, US, time_step, Time, state%ocean_mass, coupled_GL) - ! note time_step is [s] and lprec is [kg / m^2 / s] - - call ice_shelf_advect (CS, time_step, CS%lprec, Time) - - CS%velocity_update_sub_counter = CS%velocity_update_sub_counter+1 - - if (CS%GL_couple .and. .not. CS%solo_ice_sheet) then - call update_OD_ffrac (CS, state%ocean_mass, CS%velocity_update_sub_counter, CS%nstep_velocity, CS%time_step, CS%velocity_update_time_step) - else - call update_OD_ffrac_uncoupled (CS) - endif - - if (CS%velocity_update_sub_counter .eq. CS%nstep_velocity) then - - if (is_root_pe()) write(*,*) "ABOUT TO CALL VELOCITY SOLVER" - - call ice_shelf_solve_outer (CS, CS%u_shelf, CS%v_shelf, 1, iters_vel_solve, Time) - - CS%velocity_update_sub_counter = 0 - - endif endif call enable_averaging(time_step,Time,CS%diag) - if (CS%id_shelf_mass > 0) call post_data(CS%id_shelf_mass, CS%mass_shelf, CS%diag) - if (CS%id_area_shelf_h > 0) call post_data(CS%id_area_shelf_h, CS%area_shelf_h, CS%diag) - if (CS%id_ustar_shelf > 0) call post_data(CS%id_ustar_shelf, fluxes%ustar_shelf, CS%diag) - if (CS%id_melt > 0) call post_data(CS%id_melt, fluxes%iceshelf_melt, CS%diag) - if (CS%id_thermal_driving > 0) call post_data(CS%id_thermal_driving, (state%sst-CS%tfreeze), CS%diag) - if (CS%id_Sbdry > 0) call post_data(CS%id_Sbdry, Sbdry, CS%diag) - if (CS%id_haline_driving > 0) call post_data(CS%id_haline_driving, haline_driving, CS%diag) - if (CS%id_mass_flux > 0) call post_data(CS%id_mass_flux, mass_flux, CS%diag) - if (CS%id_u_ml > 0) call post_data(CS%id_u_ml,state%u,CS%diag) - if (CS%id_v_ml > 0) call post_data(CS%id_v_ml,state%v,CS%diag) - if (CS%id_tfreeze > 0) call post_data(CS%id_tfreeze, CS%tfreeze, CS%diag) - if (CS%id_tfl_shelf > 0) call post_data(CS%id_tfl_shelf, CS%tflux_shelf, CS%diag) - if (CS%id_exch_vel_t > 0) call post_data(CS%id_exch_vel_t, CS%exch_vel_t, CS%diag) - if (CS%id_exch_vel_s > 0) call post_data(CS%id_exch_vel_s, CS%exch_vel_s, CS%diag) - if (CS%id_col_thick > 0) call post_data(CS%id_col_thick, CS%OD_av, CS%diag) - if (CS%id_h_shelf > 0) call post_data(CS%id_h_shelf,CS%h_shelf,CS%diag) - if (CS%id_h_mask > 0) call post_data(CS%id_h_mask,CS%hmask,CS%diag) - if (CS%id_u_shelf > 0) call post_data(CS%id_u_shelf,CS%u_shelf,CS%diag) - if (CS%id_v_shelf > 0) call post_data(CS%id_v_shelf,CS%v_shelf,CS%diag) - if (CS%id_float_frac > 0) call post_data(CS%id_float_frac,CS%float_frac,CS%diag) - if (CS%id_OD_av >0) call post_data(CS%id_OD_av,CS%OD_av,CS%diag) - if (CS%id_float_frac_rt>0) call post_data(CS%id_float_frac_rt,CS%float_frac_rt,CS%diag) + if (CS%id_shelf_mass > 0) call post_data(CS%id_shelf_mass, ISS%mass_shelf, CS%diag) + if (CS%id_area_shelf_h > 0) call post_data(CS%id_area_shelf_h, ISS%area_shelf_h, CS%diag) + if (CS%id_ustar_shelf > 0) call post_data(CS%id_ustar_shelf, fluxes%ustar_shelf, CS%diag) + if (CS%id_melt > 0) call post_data(CS%id_melt, fluxes%iceshelf_melt, CS%diag) + if (CS%id_thermal_driving > 0) call post_data(CS%id_thermal_driving, (state%sst-ISS%tfreeze), CS%diag) + if (CS%id_Sbdry > 0) call post_data(CS%id_Sbdry, Sbdry, CS%diag) + if (CS%id_haline_driving > 0) call post_data(CS%id_haline_driving, haline_driving, CS%diag) + if (CS%id_mass_flux > 0) call post_data(CS%id_mass_flux, mass_flux, CS%diag) + if (CS%id_u_ml > 0) call post_data(CS%id_u_ml, state%u, CS%diag) + if (CS%id_v_ml > 0) call post_data(CS%id_v_ml, state%v, CS%diag) + if (CS%id_tfreeze > 0) call post_data(CS%id_tfreeze, ISS%tfreeze, CS%diag) + if (CS%id_tfl_shelf > 0) call post_data(CS%id_tfl_shelf, ISS%tflux_shelf, CS%diag) + if (CS%id_exch_vel_t > 0) call post_data(CS%id_exch_vel_t, exch_vel_t, CS%diag) + if (CS%id_exch_vel_s > 0) call post_data(CS%id_exch_vel_s, exch_vel_s, CS%diag) + if (CS%id_h_shelf > 0) call post_data(CS%id_h_shelf,ISS%h_shelf,CS%diag) + if (CS%id_h_mask > 0) call post_data(CS%id_h_mask,ISS%hmask,CS%diag) call disable_averaging(CS%diag) + if (present(forces)) then + call add_shelf_forces(G, CS, forces, do_shelf_area=(CS%active_shelf_dynamics .or. & + CS%override_shelf_movement)) + endif + call cpu_clock_end(id_clock_shelf) - if (CS%DEBUG) then - call MOM_forcing_chksum("End of shelf calc flux", fluxes, G, haloshift=0) - endif + if (CS%DEBUG) call MOM_forcing_chksum("End of shelf calc flux", fluxes, G, US, haloshift=0) end subroutine shelf_calc_flux !> Changes the thickness (mass) of the ice shelf based on sub-ice-shelf melting -subroutine change_thickness_using_melt(CS,G,time_step, fluxes) - type(ocean_grid_type), intent(inout) :: G - type(ice_shelf_CS), intent(inout) :: CS - real, intent(in) :: time_step - type(forcing), intent(inout) :: fluxes +subroutine change_thickness_using_melt(ISS, G, time_step, fluxes, rho_ice, debug) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(ice_shelf_state), intent(inout) :: ISS !< A structure with elements that describe + !! the ice-shelf state + real, intent(in) :: time_step !< The time step for this update [s]. + type(forcing), intent(inout) :: fluxes !< structure containing pointers to any possible + !! thermodynamic or mass-flux forcing fields. + real, intent(in) :: rho_ice !< The density of ice-shelf ice [kg m-2 Z-1 ~> kg m-3]. + logical, optional, intent(in) :: debug !< If present and true, write chksums ! locals + real :: I_rho_ice integer :: i, j - do j=G%jsc,G%jec - do i=G%isc,G%iec + I_rho_ice = 1.0 / rho_ice - if ((CS%hmask(i,j) .eq. 1) .or. (CS%hmask(i,j) .eq. 2)) then - ! first, zero out fluxes applied during previous time step - if (associated(fluxes%lprec)) fluxes%lprec(i,j) = 0.0 - if (associated(fluxes%sens)) fluxes%sens(i,j) = 0.0 - if (associated(fluxes%frac_shelf_h)) fluxes%frac_shelf_h(i,j) = 0.0 - if (associated(fluxes%p_surf)) fluxes%p_surf(i,j) = 0.0 - if (associated(fluxes%salt_flux)) fluxes%salt_flux(i,j) = 0.0 + do j=G%jsc,G%jec ; do i=G%isc,G%iec + if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2)) then + ! first, zero out fluxes applied during previous time step + if (associated(fluxes%lprec)) fluxes%lprec(i,j) = 0.0 + if (associated(fluxes%sens)) fluxes%sens(i,j) = 0.0 + if (associated(fluxes%frac_shelf_h)) fluxes%frac_shelf_h(i,j) = 0.0 + if (associated(fluxes%salt_flux)) fluxes%salt_flux(i,j) = 0.0 + + if (ISS%water_flux(i,j) / rho_ice * time_step < ISS%h_shelf(i,j)) then + ISS%h_shelf(i,j) = ISS%h_shelf(i,j) - ISS%water_flux(i,j) / rho_ice * time_step + else + ! the ice is about to melt away, so set thickness, area, and mask to zero + ! NOTE: this is not mass conservative should maybe scale salt & heat flux for this cell + ISS%h_shelf(i,j) = 0.0 + ISS%hmask(i,j) = 0.0 + ISS%area_shelf_h(i,j) = 0.0 + endif + endif + enddo ; enddo - if (CS%lprec(i,j) / CS%density_ice * time_step .lt. CS%h_shelf (i,j)) then - CS%h_shelf (i,j) = CS%h_shelf (i,j) - CS%lprec(i,j) / CS%density_ice * time_step - else - ! the ice is about to melt away - ! in this case set thickness, area, and mask to zero - ! NOTE: not mass conservative - ! should maybe scale salt & heat flux for this cell - - CS%h_shelf(i,j) = 0.0 - CS%hmask(i,j) = 0.0 - CS%area_shelf_h(i,j) = 0.0 - endif - endif - enddo - enddo - - call pass_var(CS%area_shelf_h, G%domain) - call pass_var(CS%h_shelf, G%domain) - call pass_var(CS%hmask, G%domain) - - do j=G%jsd,G%jed - do i=G%isd,G%ied - - if ((CS%hmask(i,j) .eq. 1) .or. (CS%hmask(i,j) .eq. 2)) then - CS%mass_shelf(i,j) = CS%h_shelf(i,j)*CS%density_ice - endif - enddo - enddo - - call pass_var(CS%mass_shelf, G%domain) + call pass_var(ISS%area_shelf_h, G%domain) + call pass_var(ISS%h_shelf, G%domain) + call pass_var(ISS%hmask, G%domain) - if (CS%DEBUG) then - call hchksum (CS%h_shelf, "h_shelf after change thickness using melt", G%HI, haloshift=0) - call hchksum (CS%mass_shelf, "mass_shelf after change thickness using melt", G%HI, haloshift=0) + !### combine this with the loops above. + do j=G%jsd,G%jed ; do i=G%isd,G%ied + if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2)) then + ISS%mass_shelf(i,j) = ISS%h_shelf(i,j)*rho_ice endif + enddo ; enddo + + call pass_var(ISS%mass_shelf, G%domain) end subroutine change_thickness_using_melt -!> Updates suface fluxes that are influenced by sub-ice-shelf melting -subroutine add_shelf_flux(G, CS, state, forces, fluxes) - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. - type(ice_shelf_CS), pointer :: CS !< This module's control structure. - type(surface), intent(inout) :: state!< Surface ocean state - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(forcing), intent(inout) :: fluxes !< A structure of surface fluxes that may be used/updated. +!> This subroutine adds the mechanical forcing fields and perhaps shelf areas, based on +!! the ice state in ice_shelf_CS. +subroutine add_shelf_forces(G, CS, forces, do_shelf_area) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(ice_shelf_CS), pointer :: CS !< This module's control structure. + type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces + logical, optional, intent(in) :: do_shelf_area !< If true find the shelf-covered areas. - ! local variables - real :: Irho0 !< The inverse of the mean density in m3 kg-1. - real :: frac_area !< The fractional area covered by the ice shelf, nondim. - real :: shelf_mass0 !< Total ice shelf mass at previous time (Time-dt). - real :: shelf_mass1 !< Total ice shelf mass at current time (Time). - real :: delta_mass_shelf!< Change in ice shelf mass over one time step in kg/s - real :: taux2, tauy2 !< The squared surface stresses, in Pa. - real :: asu1, asu2 !< Ocean areas covered by ice shelves at neighboring u- - real :: asv1, asv2 !< and v-points, in m2. - real :: fraz !< refreezing rate in kg m-2 s-1 - real :: mean_melt_flux !< spatial mean melt flux kg/s - real :: sponge_area !< total area of sponge region - real :: t0 !< The previous time (Time-dt) in sec. - type(time_type) :: Time0!< The previous time (Time-dt) - real, dimension(:,:), allocatable, target :: last_mass_shelf !< Ice shelf mass - ! at at previous time (Time-dt), in kg/m^2 - real, dimension(:,:), allocatable, target :: last_h_shelf !< Ice shelf thickness - ! at at previous time (Time-dt), in m - real, dimension(:,:), allocatable, target :: last_hmask !< Ice shelf mask - ! at at previous time (Time-dt) - real, dimension(:,:), allocatable, target :: last_area_shelf_h !< Ice shelf area - ! at at previous time (Time-dt), m^2 + real :: kv_rho_ice ! The viscosity of ice divided by its density [m5 kg-1 s-1]. + real :: press_ice ! The pressure of the ice shelf per unit area of ocean (not ice) [Pa]. + logical :: find_area ! If true find the shelf areas at u & v points. + type(ice_shelf_state), pointer :: ISS => NULL() ! A structure with elements that describe + ! the ice-shelf state - real, parameter :: rho_fw = 1000.0 ! fresh water density integer :: i, j, is, ie, js, je, isd, ied, jsd, jed is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed - Irho0 = 1.0 / CS%Rho0 - ! Determine ustar and the square magnitude of the velocity in the - ! bottom boundary layer. Together these give the TKE source and - ! vertical decay scale. - if (CS%shelf_mass_is_dynamic) then - do j=jsd,jed ; do i=isd,ied - if (G%areaT(i,j) > 0.0) & - fluxes%frac_shelf_h(i,j) = CS%area_shelf_h(i,j) / G%areaT(i,j) - enddo ; enddo - !do I=isd,ied-1 ; do j=isd,jed - do j=jsd,jed ; do i=isd,ied-1 ! ### changed stride order; i->ied-1? + if ((CS%grid%isc /= G%isc) .or. (CS%grid%iec /= G%iec) .or. & + (CS%grid%jsc /= G%jsc) .or. (CS%grid%jec /= G%jec)) & + call MOM_error(FATAL,"add_shelf_forces: Incompatible ocean and ice shelf grids.") + + ISS => CS%ISS + + find_area = .true. ; if (present(do_shelf_area)) find_area = do_shelf_area + + if (find_area) then + ! The frac_shelf is set over the widest possible area. Could it be smaller? + do j=jsd,jed ; do I=isd,ied-1 forces%frac_shelf_u(I,j) = 0.0 - if ((G%areaT(i,j) + G%areaT(i+1,j) > 0.0)) & ! .and. (G%dxdy_u(I,j) > 0.0)) & - forces%frac_shelf_u(I,j) = ((CS%area_shelf_h(i,j) + CS%area_shelf_h(i+1,j)) / & + if ((G%areaT(i,j) + G%areaT(i+1,j) > 0.0)) & ! .and. (G%areaCu(I,j) > 0.0)) & + forces%frac_shelf_u(I,j) = ((ISS%area_shelf_h(i,j) + ISS%area_shelf_h(i+1,j)) / & (G%areaT(i,j) + G%areaT(i+1,j))) - !### Either the min here or the max below must be wrong, but is either right? -RWH - forces%rigidity_ice_u(I,j) = (CS%kv_ice / CS%density_ice) * & - min(CS%mass_shelf(i,j), CS%mass_shelf(i+1,j)) enddo ; enddo - do j=jsd,jed-1 ; do i=isd,ied ! ### change stride order; j->jed-1? - !do i=isd,ied ; do J=isd,jed-1 + do J=jsd,jed-1 ; do i=isd,ied forces%frac_shelf_v(i,J) = 0.0 - if ((G%areaT(i,j) + G%areaT(i,j+1) > 0.0)) & ! .and. (G%dxdy_v(i,J) > 0.0)) & - forces%frac_shelf_v(i,J) = ((CS%area_shelf_h(i,j) + CS%area_shelf_h(i,j+1)) / & + if ((G%areaT(i,j) + G%areaT(i,j+1) > 0.0)) & ! .and. (G%areaCv(i,J) > 0.0)) & + forces%frac_shelf_v(i,J) = ((ISS%area_shelf_h(i,j) + ISS%area_shelf_h(i,j+1)) / & (G%areaT(i,j) + G%areaT(i,j+1))) - !### Either the max here or the min above must be wrong, but is either right? -RWH - forces%rigidity_ice_v(i,J) = (CS%kv_ice / CS%density_ice) * & - max(CS%mass_shelf(i,j), CS%mass_shelf(i,j+1)) enddo ; enddo call pass_vector(forces%frac_shelf_u, forces%frac_shelf_v, G%domain, TO_ALL, CGRID_NE) - else - ! This is needed because rigidity is potentially modified in the coupler. Reset - ! in the ice shelf cavity: MJH + endif - do j=jsd,jed ; do i=isd,ied-1 ! changed stride - forces%rigidity_ice_u(I,j) = (CS%kv_ice / CS%density_ice) * & - min(CS%mass_shelf(i,j), CS%mass_shelf(i+1,j)) - enddo ; enddo + !### Consider working over a smaller array range. + do j=jsd,jed ; do i=isd,ied + press_ice = (ISS%area_shelf_h(i,j) * G%IareaT(i,j)) * (CS%g_Earth * ISS%mass_shelf(i,j)) + if (associated(forces%p_surf)) then + if (.not.forces%accumulate_p_surf) forces%p_surf(i,j) = 0.0 + forces%p_surf(i,j) = forces%p_surf(i,j) + press_ice + endif + if (associated(forces%p_surf_full)) then + if (.not.forces%accumulate_p_surf) forces%p_surf_full(i,j) = 0.0 + forces%p_surf_full(i,j) = forces%p_surf_full(i,j) + press_ice + endif + enddo ; enddo - do j=jsd,jed-1 ; do i=isd,ied ! changed stride - forces%rigidity_ice_v(i,J) = (CS%kv_ice / CS%density_ice) * & - max(CS%mass_shelf(i,j), CS%mass_shelf(i,j+1)) - enddo ; enddo - endif + ! For various reasons, forces%rigidity_ice_[uv] is always updated here. Note + ! that it may have been zeroed out where IOB is translated to forces and + ! contributions from icebergs and the sea-ice pack added subsequently. + !### THE RIGIDITY SHOULD ALSO INCORPORATE AREAL-COVERAGE INFORMATION. + kv_rho_ice = CS%kv_ice / CS%density_ice + do j=js,je ; do I=is-1,ie + if (.not.forces%accumulate_rigidity) forces%rigidity_ice_u(I,j) = 0.0 + forces%rigidity_ice_u(I,j) = forces%rigidity_ice_u(I,j) + & + kv_rho_ice * min(ISS%mass_shelf(i,j), ISS%mass_shelf(i+1,j)) + enddo ; enddo + do J=js-1,je ; do i=is,ie + if (.not.forces%accumulate_rigidity) forces%rigidity_ice_v(i,J) = 0.0 + forces%rigidity_ice_v(i,J) = forces%rigidity_ice_v(i,J) + & + kv_rho_ice * min(ISS%mass_shelf(i,j), ISS%mass_shelf(i,j+1)) + enddo ; enddo if (CS%debug) then - if (associated(state%taux_shelf)) then - call uchksum(state%taux_shelf, "taux_shelf", G%HI, haloshift=0) + call uvchksum("rigidity_ice_[uv]", forces%rigidity_ice_u, forces%rigidity_ice_v, & + G%HI, symmetric=.true.) + call uvchksum("frac_shelf_[uv]", forces%frac_shelf_u, forces%frac_shelf_v, & + G%HI, symmetric=.true.) + endif + +end subroutine add_shelf_forces + +!> This subroutine adds the ice shelf pressure to the fluxes type. +subroutine add_shelf_pressure(G, CS, fluxes) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(ice_shelf_CS), intent(in) :: CS !< This module's control structure. + type(forcing), intent(inout) :: fluxes !< A structure of surface fluxes that may be updated. + + real :: press_ice !< The pressure of the ice shelf per unit area of ocean (not ice) [Pa]. + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + if ((CS%grid%isc /= G%isc) .or. (CS%grid%iec /= G%iec) .or. & + (CS%grid%jsc /= G%jsc) .or. (CS%grid%jec /= G%jec)) & + call MOM_error(FATAL,"add_shelf_pressure: Incompatible ocean and ice shelf grids.") + + do j=js,je ; do i=is,ie + press_ice = (CS%ISS%area_shelf_h(i,j) * G%IareaT(i,j)) * (CS%g_Earth * CS%ISS%mass_shelf(i,j)) + if (associated(fluxes%p_surf)) then + if (.not.fluxes%accumulate_p_surf) fluxes%p_surf(i,j) = 0.0 + fluxes%p_surf(i,j) = fluxes%p_surf(i,j) + press_ice + endif + if (associated(fluxes%p_surf_full)) then + if (.not.fluxes%accumulate_p_surf) fluxes%p_surf_full(i,j) = 0.0 + fluxes%p_surf_full(i,j) = fluxes%p_surf_full(i,j) + press_ice endif - if (associated(state%tauy_shelf)) then - call vchksum(state%tauy_shelf, "tauy_shelf", G%HI, haloshift=0) - call vchksum(forces%rigidity_ice_u, "rigidity_ice_u", G%HI, haloshift=0) - call vchksum(forces%rigidity_ice_v, "rigidity_ice_v", G%HI, haloshift=0) - call vchksum(forces%frac_shelf_u, "frac_shelf_u", G%HI, haloshift=0) - call vchksum(forces%frac_shelf_v, "frac_shelf_v", G%HI, haloshift=0) + enddo ; enddo + +end subroutine add_shelf_pressure + +!> Updates surface fluxes that are influenced by sub-ice-shelf melting +subroutine add_shelf_flux(G, CS, state, fluxes) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(ice_shelf_CS), pointer :: CS !< This module's control structure. + type(surface), intent(inout) :: state!< Surface ocean state + type(forcing), intent(inout) :: fluxes !< A structure of surface fluxes that may be used/updated. + + ! local variables + real :: Irho0 !< The inverse of the mean density [m3 kg-1]. + real :: frac_area !< The fractional area covered by the ice shelf [nondim]. + real :: shelf_mass0 !< Total ice shelf mass at previous time (Time-dt). + real :: shelf_mass1 !< Total ice shelf mass at current time (Time). + real :: delta_mass_shelf!< Change in ice shelf mass over one time step [kg s-1] + real :: taux2, tauy2 !< The squared surface stresses [Pa]. + real :: press_ice !< The pressure of the ice shelf per unit area of ocean (not ice) [Pa]. + real :: asu1, asu2 !< Ocean areas covered by ice shelves at neighboring u- + real :: asv1, asv2 !< and v-points [m2]. + real :: fraz !< refreezing rate [kg m-2 s-1] + real :: mean_melt_flux !< spatial mean melt flux [kg s-1] or [kg m-2 s-1] at various points in the code. + real :: sponge_area !< total area of sponge region [m2] + real :: t0 !< The previous time (Time-dt) [s]. + type(time_type) :: Time0!< The previous time (Time-dt) + real, dimension(SZDI_(G),SZDJ_(G)) :: last_mass_shelf !< Ice shelf mass + !! at at previous time (Time-dt) [kg m-2] + real, dimension(SZDI_(G),SZDJ_(G)) :: last_h_shelf !< Ice shelf thickness [Z ~> m] + !! at at previous time (Time-dt) + real, dimension(SZDI_(G),SZDJ_(G)) :: last_hmask !< Ice shelf mask + !! at at previous time (Time-dt) + real, dimension(SZDI_(G),SZDJ_(G)) :: last_area_shelf_h !< Ice shelf area [m2] + !! at at previous time (Time-dt) + type(ice_shelf_state), pointer :: ISS => NULL() !< A structure with elements that describe + !! the ice-shelf state + + real :: kv_rho_ice ! The viscosity of ice divided by its density [m5 kg-1 s-1] + real, parameter :: rho_fw = 1000.0 ! fresh water density + character(len=160) :: mesg ! The text of an error message + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed + + if ((CS%grid%isc /= G%isc) .or. (CS%grid%iec /= G%iec) .or. & + (CS%grid%jsc /= G%jsc) .or. (CS%grid%jec /= G%jec)) & + call MOM_error(FATAL,"add_shelf_flux: Incompatible ocean and ice shelf grids.") + + ISS => CS%ISS + + call add_shelf_pressure(G, CS, fluxes) + + ! Determine ustar and the square magnitude of the velocity in the + ! bottom boundary layer. Together these give the TKE source and + ! vertical decay scale. + + if (CS%debug) then + if (associated(state%taux_shelf) .and. associated(state%tauy_shelf)) then + call uvchksum("tau[xy]_shelf", state%taux_shelf, state%tauy_shelf, & + G%HI, haloshift=0) endif endif if (associated(state%taux_shelf) .and. associated(state%tauy_shelf)) then call pass_vector(state%taux_shelf, state%tauy_shelf, G%domain, TO_ALL, CGRID_NE) endif + ! GMM: melting is computed using ustar_shelf (and not ustar), which has already + ! been passed, I so believe we do not need to update fluxes%ustar. +! Irho0 = 1.0 / CS%Rho0 +! do j=js,je ; do i=is,ie ; if (fluxes%frac_shelf_h(i,j) > 0.0) then + ! ### THIS SHOULD BE AN AREA WEIGHTED AVERAGE OF THE ustar_shelf POINTS. + ! taux2 = 0.0 ; tauy2 = 0.0 + ! asu1 = (ISS%area_shelf_h(i-1,j) + ISS%area_shelf_h(i,j)) + ! asu2 = (ISS%area_shelf_h(i,j) + ISS%area_shelf_h(i+1,j)) + ! asv1 = (ISS%area_shelf_h(i,j-1) + ISS%area_shelf_h(i,j)) + ! asv2 = (ISS%area_shelf_h(i,j) + ISS%area_shelf_h(i,j+1)) + ! if ((asu1 + asu2 > 0.0) .and. associated(state%taux_shelf)) & + ! taux2 = (asu1 * state%taux_shelf(I-1,j)**2 + & + ! asu2 * state%taux_shelf(I,j)**2 ) / (asu1 + asu2) + ! if ((asv1 + asv2 > 0.0) .and. associated(state%tauy_shelf)) & + ! tauy2 = (asv1 * state%tauy_shelf(i,J-1)**2 + & + ! asv2 * state%tauy_shelf(i,J)**2 ) / (asv1 + asv2) + + !fluxes%ustar(i,j) = MAX(CS%ustar_bg, US%m_to_Z*sqrt(Irho0 * sqrt(taux2 + tauy2))) +! endif ; enddo ; enddo + + if (CS%active_shelf_dynamics .or. CS%override_shelf_movement) then + do j=jsd,jed ; do i=isd,ied + if (G%areaT(i,j) > 0.0) & + fluxes%frac_shelf_h(i,j) = ISS%area_shelf_h(i,j) * G%IareaT(i,j) + enddo ; enddo + endif - if (associated(fluxes%sw_vis_dir)) fluxes%sw_vis_dir = 0.0 - if (associated(fluxes%sw_vis_dif)) fluxes%sw_vis_dif = 0.0 - if (associated(fluxes%sw_nir_dir)) fluxes%sw_nir_dir = 0.0 - if (associated(fluxes%sw_nir_dif)) fluxes%sw_nir_dif = 0.0 - - do j=G%jsc,G%jec ; do i=G%isc,G%iec - frac_area = fluxes%frac_shelf_h(i,j) - if (frac_area > 0.0) then - ! ### THIS SHOULD BE AN AREA WEIGHTED AVERAGE OF THE ustar_shelf POINTS. - taux2 = 0.0 ; tauy2 = 0.0 - asu1 = forces%frac_shelf_u(i-1,j) * (G%areaT(i-1,j) + G%areaT(i,j)) ! G%dxdy_u(i-1,j) - asu2 = forces%frac_shelf_u(i,j) * (G%areaT(i,j) + G%areaT(i+1,j)) ! G%dxdy_u(i,j) - asv1 = forces%frac_shelf_v(i,j-1) * (G%areaT(i,j-1) + G%areaT(i,j)) ! G%dxdy_v(i,j-1) - asv2 = forces%frac_shelf_v(i,j) * (G%areaT(i,j) + G%areaT(i,j+1)) ! G%dxdy_v(i,j) - if ((asu1 + asu2 > 0.0) .and. associated(state%taux_shelf)) & - taux2 = (asu1 * state%taux_shelf(i-1,j)**2 + & - asu2 * state%taux_shelf(i,j)**2 ) / (asu1 + asu2) - if ((asv1 + asv2 > 0.0) .and. associated(state%tauy_shelf)) & - tauy2 = (asv1 * state%tauy_shelf(i,j-1)**2 + & - asv2 * state%tauy_shelf(i,j)**2 ) / (asv1 + asv2) - - ! GMM: melting is computed using ustar_shelf (and not ustar), which has already - ! been passed, so believe we do not need to update fluxes%ustar. - !fluxes%ustar(i,j) = MAX(CS%ustar_bg, sqrt(Irho0 * sqrt(taux2 + tauy2))) - - if (associated(fluxes%sw)) fluxes%sw(i,j) = 0.0 - if (associated(fluxes%lw)) fluxes%lw(i,j) = 0.0 - if (associated(fluxes%latent)) fluxes%latent(i,j) = 0.0 - if (associated(fluxes%evap)) fluxes%evap(i,j) = 0.0 - if (associated(fluxes%lprec)) then - if (CS%lprec(i,j) > 0.0 ) then - fluxes%lprec(i,j) = frac_area*CS%lprec(i,j)*CS%flux_factor - else - fluxes%lprec(i,j) = 0.0 - fluxes%evap(i,j) = frac_area*CS%lprec(i,j)*CS%flux_factor - endif + do j=js,je ; do i=is,ie ; if (ISS%area_shelf_h(i,j) > 0.0) then + frac_area = fluxes%frac_shelf_h(i,j) !### Should this be 1-frac_shelf_h? + if (associated(fluxes%sw)) fluxes%sw(i,j) = 0.0 + if (associated(fluxes%sw_vis_dir)) fluxes%sw_vis_dir(i,j) = 0.0 + if (associated(fluxes%sw_vis_dif)) fluxes%sw_vis_dif(i,j) = 0.0 + if (associated(fluxes%sw_nir_dir)) fluxes%sw_nir_dir(i,j) = 0.0 + if (associated(fluxes%sw_nir_dif)) fluxes%sw_nir_dif(i,j) = 0.0 + if (associated(fluxes%lw)) fluxes%lw(i,j) = 0.0 + if (associated(fluxes%latent)) fluxes%latent(i,j) = 0.0 + if (associated(fluxes%evap)) fluxes%evap(i,j) = 0.0 + if (associated(fluxes%lprec)) then + if (ISS%water_flux(i,j) > 0.0) then + fluxes%lprec(i,j) = frac_area*ISS%water_flux(i,j)*CS%flux_factor + else + fluxes%lprec(i,j) = 0.0 + fluxes%evap(i,j) = frac_area*ISS%water_flux(i,j)*CS%flux_factor endif - - - if (associated(fluxes%sens)) fluxes%sens(i,j) = -frac_area*CS%t_flux(i,j)*CS%flux_factor - if (associated(fluxes%salt_flux)) fluxes%salt_flux(i,j) = frac_area * CS%salt_flux(i,j)*CS%flux_factor - if (associated(fluxes%p_surf)) fluxes%p_surf(i,j) = frac_area * CS%g_Earth * CS%mass_shelf(i,j) - ! Same for IOB%p - if (associated(fluxes%p_surf_full) ) fluxes%p_surf_full(i,j) = & - frac_area * CS%g_Earth * CS%mass_shelf(i,j) - endif - enddo ; enddo + + if (associated(fluxes%sens)) & + fluxes%sens(i,j) = -frac_area*ISS%tflux_ocn(i,j)*CS%flux_factor + if (associated(fluxes%salt_flux)) & + fluxes%salt_flux(i,j) = frac_area * ISS%salt_flux(i,j)*CS%flux_factor + endif ; enddo ; enddo ! keep sea level constant by removing mass in the sponge ! region (via virtual precip, vprec). Apply additional @@ -1075,139 +978,127 @@ subroutine add_shelf_flux(G, CS, state, forces, fluxes) ! This is needed for some of the ISOMIP+ experiments. if (CS%constant_sea_level) then + !### This code has lots of problems with hard coded constants and the use of + !### of non-reproducing sums. It needs to be refactored. -RWH if (.not. associated(fluxes%salt_flux)) allocate(fluxes%salt_flux(ie,je)) if (.not. associated(fluxes%vprec)) allocate(fluxes%vprec(ie,je)) - fluxes%salt_flux(:,:) = 0.0; fluxes%vprec(:,:) = 0.0 + fluxes%salt_flux(:,:) = 0.0 ; fluxes%vprec(:,:) = 0.0 mean_melt_flux = 0.0; sponge_area = 0.0 do j=js,je ; do i=is,ie - frac_area = fluxes%frac_shelf_h(i,j) - if (frac_area > 0.0) then - mean_melt_flux = mean_melt_flux + (CS%lprec(i,j)) * CS%area_shelf_h(i,j) - endif + frac_area = fluxes%frac_shelf_h(i,j) + if (frac_area > 0.0) & + mean_melt_flux = mean_melt_flux + (ISS%water_flux(i,j)) * ISS%area_shelf_h(i,j) - if (G%geoLonT(i,j) >= 790.0 .AND. G%geoLonT(i,j) <= 800.0) then - sponge_area = sponge_area + G%areaT(i,j) - endif - enddo; enddo + !### These hard-coded limits need to be corrected. They are inappropriate here. + if (G%geoLonT(i,j) >= 790.0 .AND. G%geoLonT(i,j) <= 800.0) then + sponge_area = sponge_area + G%areaT(i,j) + endif + enddo ; enddo ! take into account changes in mass (or thickness) when imposing ice shelf mass - if (CS%shelf_mass_is_dynamic .and. CS%override_shelf_movement .and. & - CS%mass_from_file) then - t0 = time_type_to_real(CS%Time) - CS%time_step - - ! just compute changes in mass after first time step - if (t0>0.0) then - Time0 = real_to_time_type(t0) - allocate(last_mass_shelf(isd:ied,jsd:jed)) - allocate(last_h_shelf(isd:ied,jsd:jed)) - allocate(last_area_shelf_h(isd:ied,jsd:jed)) - allocate(last_hmask(isd:ied,jsd:jed)) - last_hmask(:,:) = CS%hmask(:,:); last_area_shelf_h(:,:) = CS%area_shelf_h(:,:) - call time_interp_external(CS%id_read_mass, Time0, last_mass_shelf) - last_h_shelf = last_mass_shelf/CS%density_ice - - ! apply calving - if (CS%min_thickness_simple_calve > 0.0) then - call ice_shelf_min_thickness_calve (CS,last_h_shelf,last_area_shelf_h,last_hmask) - ! convert to mass again - last_mass_shelf = last_h_shelf * CS%density_ice - endif - - shelf_mass0 = 0.0; shelf_mass1 = 0.0 - ! get total ice shelf mass at (Time-dt) and (Time), in kg - do j=js,je ; do i=is,ie - ! just floating shelf (0.1 is a threshold for min ocean thickness) - if (((1.0/CS%density_ocean_avg)*state%ocean_mass(i,j) > 0.1) .and. & - (CS%area_shelf_h(i,j) > 0.0)) then - - shelf_mass0 = shelf_mass0 + (last_mass_shelf(i,j) * CS%area_shelf_h(i,j)) - shelf_mass1 = shelf_mass1 + (CS%mass_shelf(i,j) * CS%area_shelf_h(i,j)) + if (CS%override_shelf_movement .and. CS%mass_from_file) then + t0 = time_type_to_real(CS%Time) - CS%time_step + + ! just compute changes in mass after first time step + if (t0>0.0) then + Time0 = real_to_time(t0) + last_hmask(:,:) = ISS%hmask(:,:) ; last_area_shelf_h(:,:) = ISS%area_shelf_h(:,:) + call time_interp_external(CS%id_read_mass, Time0, last_mass_shelf) + last_h_shelf(:,:) = last_mass_shelf(:,:) / CS%rho_ice + + ! apply calving + if (CS%min_thickness_simple_calve > 0.0) then + call ice_shelf_min_thickness_calve(G, last_h_shelf, last_area_shelf_h, last_hmask, & + CS%min_thickness_simple_calve) + ! convert to mass again + last_mass_shelf(:,:) = last_h_shelf(:,:) * CS%rho_ice + endif - endif - enddo; enddo - call mpp_sum(shelf_mass0); call mpp_sum(shelf_mass1) - delta_mass_shelf = (shelf_mass1 - shelf_mass0)/CS%time_step + shelf_mass0 = 0.0; shelf_mass1 = 0.0 + ! get total ice shelf mass at (Time-dt) and (Time), in kg + do j=js,je ; do i=is,ie + ! just floating shelf (0.1 is a threshold for min ocean thickness) + if (((1.0/CS%density_ocean_avg)*state%ocean_mass(i,j) > 0.1) .and. & + (ISS%area_shelf_h(i,j) > 0.0)) then + shelf_mass0 = shelf_mass0 + (last_mass_shelf(i,j) * ISS%area_shelf_h(i,j)) + shelf_mass1 = shelf_mass1 + (ISS%mass_shelf(i,j) * ISS%area_shelf_h(i,j)) + endif + enddo ; enddo + call sum_across_PEs(shelf_mass0); call sum_across_PEs(shelf_mass1) + delta_mass_shelf = (shelf_mass1 - shelf_mass0)/CS%time_step ! delta_mass_shelf = (shelf_mass1 - shelf_mass0)* & ! (rho_fw/CS%density_ice)/CS%time_step -! if (is_root_pe()) write(*,*)'delta_mass_shelf',delta_mass_shelf - else! first time step - delta_mass_shelf = 0.0 - endif +! write(mesg,*)'delta_mass_shelf = ',delta_mass_shelf +! call MOM_mesg(mesg,5) + else! first time step + delta_mass_shelf = 0.0 + endif else ! ice shelf mass does not change - delta_mass_shelf = 0.0 + delta_mass_shelf = 0.0 endif - call mpp_sum(mean_melt_flux) - call mpp_sum(sponge_area) + call sum_across_PEs(mean_melt_flux) + call sum_across_PEs(sponge_area) ! average total melt flux over sponge area mean_melt_flux = (mean_melt_flux+delta_mass_shelf) / sponge_area !kg/(m^2 s) ! apply fluxes do j=js,je ; do i=is,ie - ! Note the following is hard coded for ISOMIP - if (G%geoLonT(i,j) >= 790.0 .AND. G%geoLonT(i,j) <= 800.0) then - fluxes%vprec(i,j) = -mean_melt_flux * CS%density_ice/1000. ! evap is negative - fluxes%sens(i,j) = fluxes%vprec(i,j) * CS%Cp * CS%T0 ! W /m^2 - fluxes%salt_flux(i,j) = fluxes%vprec(i,j) * CS%S0*1.0e-3 ! kg (salt)/(m^2 s) - endif - enddo; enddo + ! Note the following is hard coded for ISOMIP + if (G%geoLonT(i,j) >= 790.0 .AND. G%geoLonT(i,j) <= 800.0) then + fluxes%vprec(i,j) = -mean_melt_flux * CS%density_ice/1000. ! evap is negative + fluxes%sens(i,j) = fluxes%vprec(i,j) * CS%Cp * CS%T0 ! W /m^2 + fluxes%salt_flux(i,j) = fluxes%vprec(i,j) * CS%S0*1.0e-3 ! kg (salt)/(m^2 s) + endif + enddo ; enddo if (CS%DEBUG) then - if (is_root_pe()) write(*,*)'Mean melt flux (kg/(m^2 s)),dt',mean_melt_flux,CS%time_step - call MOM_forcing_chksum("After constant sea level", fluxes, G, haloshift=0) - endif - - endif!constant_sea_level - - ! If the shelf mass is changing, the forces%rigidity_ice_[uv] needs to be - ! updated here. - - if (CS%shelf_mass_is_dynamic) then - do j=G%jsc,G%jec ; do i=G%isc-1,G%iec - forces%rigidity_ice_u(I,j) = (CS%kv_ice / CS%density_ice) * & - max(CS%mass_shelf(i,j), CS%mass_shelf(i+1,j)) - enddo ; enddo + write(mesg,*) 'Mean melt flux [kg m-2 s-1], dt = ', mean_melt_flux, CS%time_step + call MOM_mesg(mesg) + call MOM_forcing_chksum("After constant sea level", fluxes, G, CS%US, haloshift=0) + endif - do j=G%jsc-1,G%jec ; do i=G%isc,G%iec - forces%rigidity_ice_v(i,J) = (CS%kv_ice / CS%density_ice) * & - max(CS%mass_shelf(i,j), CS%mass_shelf(i,j+1)) - enddo ; enddo - endif + endif !constant_sea_level end subroutine add_shelf_flux !> Initializes shelf model data, parameters and diagnostics subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fluxes, Time_in, solo_ice_sheet_in) - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(ocean_grid_type), pointer :: ocn_grid - type(time_type), intent(inout) :: Time - type(ice_shelf_CS), pointer :: CS - type(diag_ctrl), target, intent(in) :: diag - type(forcing), optional, intent(inout) :: fluxes - type(mech_forcing), optional, intent(inout) :: forces - type(time_type), optional, intent(in) :: Time_in - logical, optional, intent(in) :: solo_ice_sheet_in - - type(ocean_grid_type), pointer :: G, OG ! Convenience pointers + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(ocean_grid_type), pointer :: ocn_grid !< The calling ocean model's horizontal grid structure + type(time_type), intent(inout) :: Time !< The clock that that will indicate the model time + type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate the diagnostic output. + type(forcing), optional, intent(inout) :: fluxes !< A structure containing pointers to any possible + !! thermodynamic or mass-flux forcing fields. + type(mech_forcing), optional, intent(inout) :: forces !< A structure with the driving mechanical forces + type(time_type), optional, intent(in) :: Time_in !< The time at initialization. + logical, optional, intent(in) :: solo_ice_sheet_in !< If present, this indicates whether + !! a solo ice-sheet driver. + + type(ocean_grid_type), pointer :: G => NULL(), OG => NULL() ! Pointers to grids for convenience. + type(unit_scale_type), pointer :: US => NULL() ! Pointer to a structure containing + ! various unit conversion factors + type(ice_shelf_state), pointer :: ISS => NULL() !< A structure with elements that describe + !! the ice-shelf state type(directories) :: dirs - type(vardesc) :: vd type(dyn_horgrid_type), pointer :: dG => NULL() + real :: Z_rescale ! A rescaling factor for heights from the representation in + ! a reastart fole to the internal representation in this run. real :: cdrag, drag_bg_vel logical :: new_sim, save_IC, var_force !This include declares and sets the variable "version". #include "version_variable.h" character(len=200) :: config character(len=200) :: IC_file,filename,inputdir - character(len=40) :: var_name character(len=40) :: mdl = "MOM_ice_shelf" ! This module's name. - character(len=2) :: procnum - integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, Isdq, Iedq, Jsdq, Jedq, iters + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, Isdq, Iedq, Jsdq, Jedq integer :: wd_halos(2) - logical :: read_TideAmp + logical :: read_TideAmp, shelf_mass_is_dynamic, debug character(len=240) :: Tideamp_file real :: utide if (associated(CS)) then @@ -1222,6 +1113,9 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl ! MOM's grid and infrastructure. call Get_MOM_Input(dirs=dirs) + ! Determining the internal unit scaling factors for this run. + call unit_scaling_init(param_file, CS%US) + ! Set up the ice-shelf domain and grid wd_halos(:)=0 call MOM_domains_init(CS%grid%domain, param_file, min_halo=wd_halos, symmetric=GRID_SYM_) @@ -1235,16 +1129,18 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl call set_grid_metrics(dG, param_file) ! call set_diag_mediator_grid(CS%grid, CS%diag) - ! The ocean grid is possibly different - if (associated(ocn_grid)) CS%ocn_grid => ocn_grid + ! The ocean grid possibly uses different symmetry. + if (associated(ocn_grid)) then ; CS%ocn_grid => ocn_grid + else ; CS%ocn_grid => CS%grid ; endif ! Convenience pointers G => CS%grid OG => CS%ocn_grid + US => CS%US if (is_root_pe()) then - write(0,*) 'OG: ', OG%isd, OG%isc, OG%iec, OG%ied, OG%jsd, OG%jsc, OG%jsd, OG%jed - write(0,*) 'IG: ', G%isd, G%isc, G%iec, G%ied, G%jsd, G%jsc, G%jsd, G%jed + write(0,*) 'OG: ', OG%isd, OG%isc, OG%iec, OG%ied, OG%jsd, OG%jsc, OG%jsd, OG%jed + write(0,*) 'IG: ', G%isd, G%isc, G%iec, G%ied, G%jsd, G%jsc, G%jsd, G%jed endif CS%Time = Time ! ### This might not be in the right place? @@ -1262,30 +1158,32 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl Isdq = G%IsdB ; Iedq = G%IedB ; Jsdq = G%JsdB ; Jedq = G%JedB CS%Lat_fusion = 3.34e5 - CS%override_shelf_movement = .false. - - CS%use_reproducing_sums = .false. - CS%switch_var = .false. + CS%override_shelf_movement = .false. ; CS%active_shelf_dynamics = .false. call log_version(param_file, mdl, version, "") - call get_param(param_file, mdl, "DEBUG_IS", CS%debug, default=.false.) - call get_param(param_file, mdl, "DYNAMIC_SHELF_MASS", CS%shelf_mass_is_dynamic, & + call get_param(param_file, mdl, "DEBUG", debug, default=.false.) + call get_param(param_file, mdl, "DEBUG_IS", CS%debug, & + "If true, write verbose debugging messages for the ice shelf.", & + default=debug) + call get_param(param_file, mdl, "DYNAMIC_SHELF_MASS", shelf_mass_is_dynamic, & "If true, the ice sheet mass can evolve with time.", & default=.false.) - if (CS%shelf_mass_is_dynamic) then + 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"//& "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, & - "THIS PARAMETER NEEDS A DESCRIPTION.", default=.false.) - call get_param(param_file, mdl, "GROUNDING_LINE_INTERP_SUBGRID_N", CS%n_sub_regularize, & - "THIS PARAMETER NEEDS A DESCRIPTION.", default=0) + "If true, regularize the floatation condition at the \n"//& + "grounding line as in Goldberg Holland Schoof 2009.", default=.false.) call get_param(param_file, mdl, "GROUNDING_LINE_COUPLE", CS%GL_couple, & - "THIS PARAMETER NEEDS A DESCRIPTION.", default=.false.) + "If true, let the floatation condition be determined by \n"//& + "ocean column thickness. This means that update_OD_ffrac \n"//& + "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.eq.0)) call MOM_error (FATAL, & - "GROUNDING_LINE_INTERP_SUBGRID_N must be a positive integer if GL regularization is used") endif + call get_param(param_file, mdl, "SHELF_THERMO", CS%isthermo, & "If true, use a thermodynamically interactive ice shelf.", & default=.false.) @@ -1300,7 +1198,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "Depth above which the melt is set to zero (it must be >= 0) \n"//& "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 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"//& @@ -1400,8 +1298,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "The time step for changing forcing, coupling with other \n"//& "components, or potentially writing certain diagnostics. \n"//& "The default value is given by DT.", units="s", default=0.0) - call get_param(param_file, mdl, "SHELF_DIAG_TIMESTEP", CS%velocity_update_time_step, & - "A timestep to use for diagnostics of the shelf.", default=0.0) call get_param(param_file, mdl, "COL_THICK_MELT_THRESHOLD", CS%col_thick_melt_threshold, & "The minimum ML thickness where melting is allowed.", units="m", & @@ -1426,91 +1322,36 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl call get_param(param_file, mdl, "UTIDE", utide, & "The constant tidal amplitude used with INT_TIDE_DISSIPATION.", & units="m s-1", default=0.0) - CS%utide = utide + CS%utide(:,:) = utide endif call EOS_init(param_file, CS%eqn_of_state) !! new parameters that need to be in MOM_input - if (CS%shelf_mass_is_dynamic .and. .not.CS%override_shelf_movement) then - - call get_param(param_file, mdl, "A_GLEN_ISOTHERM", CS%A_glen_isothermal, & - "Ice viscosity parameter in Glen's Law", & - units="Pa -1/3 a", default=9.461e-18) - call get_param(param_file, mdl, "GLEN_EXPONENT", CS%n_glen, & - "nonlinearity exponent in Glen's Law", & - units="none", default=3.) - call get_param(param_file, mdl, "MIN_STRAIN_RATE_GLEN", CS%eps_glen_min, & - "min. strain rate to avoid infinite Glen's law viscosity", & - units="a-1", default=1.e-12) - call get_param(param_file, mdl, "BASAL_FRICTION_COEFF", CS%C_basal_friction, & - "ceofficient in sliding law \tau_b = C u^(n_basal_friction)", & - units="Pa (m-a)-(n_basal_friction)", fail_if_missing=.true.) - call get_param(param_file, mdl, "BASAL_FRICTION_EXP", CS%n_basal_friction, & - "exponent in sliding law \tau_b = C u^(m_slide)", & - units="none", fail_if_missing=.true.) + if (CS%active_shelf_dynamics) then + call get_param(param_file, mdl, "DENSITY_ICE", CS%density_ice, & "A typical density of ice.", units="kg m-3", default=917.0) call get_param(param_file, mdl, "INPUT_FLUX_ICE_SHELF", CS%input_flux, & - "volume flux at upstream boundary", & - units="m2 s-1", default=0.) + "volume flux at upstream boundary", units="m2 s-1", default=0.) call get_param(param_file, mdl, "INPUT_THICK_ICE_SHELF", CS%input_thickness, & - "flux thickness at upstream boundary", & - units="m", default=1000.) - call get_param(param_file, mdl, "ICE_VELOCITY_TIMESTEP", CS%velocity_update_time_step, & - "seconds between ice velocity calcs", units="s", & - fail_if_missing=.true.) - - call get_param(param_file, mdl, "CONJUGATE_GRADIENT_TOLERANCE", CS%cg_tolerance, & - "tolerance in CG solver, relative to initial residual", default=1.e-6) - call get_param(param_file, mdl, "ICE_NONLINEAR_TOLERANCE", & - CS%nonlinear_tolerance,"nonlin tolerance in iterative velocity solve",default=1.e-6) - 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"// & - "will only be important with use of tides", & - units="m",default=1.e-3) - - call get_param(param_file, mdl, "SHELF_MOVING_FRONT", CS%moving_shelf_front, & - "whether or not to advance shelf front (and calve..)") - call get_param(param_file, mdl, "CALVE_TO_MASK", CS%calve_to_mask, & - "if true, do not allow an ice shelf where prohibited by a mask") - call get_param(param_file, mdl, "ICE_SHELF_CFL_FACTOR", CS%CFL_factor, & - "limit timestep as a factor of min (\Delta x / u); \n"// & - "only important for ice-only model", & - default=0.25) - 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 residual (1) \n"// & - "or relative change since last iteration (2)", & - default=1) - - - if (CS%debug) CS%use_reproducing_sums = .true. - - CS%nstep_velocity = FLOOR (CS%velocity_update_time_step / CS%time_step) - CS%velocity_update_counter = 0 - CS%velocity_update_sub_counter = 0 + "flux thickness at upstream boundary", units="m", default=1000.) else - CS%nstep_velocity = 0 ! This is here because of inconsistent defaults. I don't know why. RWH call get_param(param_file, mdl, "DENSITY_ICE", CS%density_ice, & "A typical density of ice.", units="kg m-3", default=900.0) endif - + CS%rho_ice = CS%density_ice*US%Z_to_m call get_param(param_file, mdl, "MIN_THICKNESS_SIMPLE_CALVE", & CS%min_thickness_simple_calve, & - "min thickness rule for VERY simple calving law",& - units="m", default=0.0) - - call get_param(param_file, mdl, "WRITE_OUTPUT_TO_FILE", & - CS%write_output_to_file, "for debugging purposes",default=.false.) + "Min thickness rule for the very simple calving law",& + units="m", default=0.0, scale=US%m_to_Z) call get_param(param_file, mdl, "USTAR_SHELF_BG", CS%ustar_bg, & - "The minimum value of ustar under ice sheves.", units="m s-1", & - default=0.0) + "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"//& "the velocity field to the surface stress.", units="nondim", & @@ -1521,80 +1362,27 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "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.", units="m s-1", default=0.0) + "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 - ! Allocate and initialize variables - allocate( CS%mass_shelf(isd:ied,jsd:jed) ) ; CS%mass_shelf(:,:) = 0.0 - allocate( CS%area_shelf_h(isd:ied,jsd:jed) ) ; CS%area_shelf_h(:,:) = 0.0 - allocate( CS%t_flux(isd:ied,jsd:jed) ) ; CS%t_flux(:,:) = 0.0 - allocate( CS%lprec(isd:ied,jsd:jed) ) ; CS%lprec(:,:) = 0.0 - allocate( CS%salt_flux(isd:ied,jsd:jed) ) ; CS%salt_flux(:,:) = 0.0 - - allocate( CS%tflux_shelf(isd:ied,jsd:jed) ) ; CS%tflux_shelf(:,:) = 0.0 - allocate( CS%tfreeze(isd:ied,jsd:jed) ) ; CS%tfreeze(:,:) = 0.0 - allocate( CS%exch_vel_s(isd:ied,jsd:jed) ) ; CS%exch_vel_s(:,:) = 0.0 - allocate( CS%exch_vel_t(isd:ied,jsd:jed) ) ; CS%exch_vel_t(:,:) = 0.0 - - allocate ( CS%h_shelf(isd:ied,jsd:jed) ) ; CS%h_shelf(:,:) = 0.0 - allocate ( CS%hmask(isd:ied,jsd:jed) ) ; CS%hmask(:,:) = -2.0 - - - ! OVS vertically integrated Temperature - allocate ( CS%t_shelf(isd:ied,jsd:jed) ) ; CS%t_shelf(:,:) = -10.0 - allocate ( CS%t_boundary_values(isd:ied,jsd:jed) ) ; CS%t_boundary_values(:,:) = -15.0 - allocate ( CS%tmask(Isdq:Iedq,Jsdq:Jedq) ) ; CS%tmask(:,:) = -1.0 - - if (CS%shelf_mass_is_dynamic .and. .not.CS%override_shelf_movement) then - ! DNG - allocate ( CS%u_shelf(Isdq:Iedq,Jsdq:Jedq) ) ; CS%u_shelf(:,:) = 0.0 - allocate ( CS%v_shelf(Isdq:Iedq,Jsdq:Jedq) ) ; CS%v_shelf(:,:) = 0.0 - allocate ( CS%u_boundary_values(Isdq:Iedq,Jsdq:Jedq) ) ; CS%u_boundary_values(:,:) = 0.0 - allocate ( CS%v_boundary_values(Isdq:Iedq,Jsdq:Jedq) ) ; CS%v_boundary_values(:,:) = 0.0 - allocate ( CS%h_boundary_values(isd:ied,jsd:jed) ) ; CS%h_boundary_values(:,:) = 0.0 - allocate ( CS%thickness_boundary_values(isd:ied,jsd:jed) ) ; CS%thickness_boundary_values(:,:) = 0.0 - allocate ( CS%ice_visc_bilinear(isd:ied,jsd:jed) ) ; CS%ice_visc_bilinear(:,:) = 0.0 - allocate ( CS%ice_visc_lower_tri(isd:ied,jsd:jed) ) ; CS%ice_visc_lower_tri = 0.0 - allocate ( CS%ice_visc_upper_tri(isd:ied,jsd:jed) ) ; CS%ice_visc_upper_tri = 0.0 - allocate ( CS%u_face_mask(Isdq:Iedq,jsd:jed) ) ; CS%u_face_mask(:,:) = 0.0 - allocate ( CS%v_face_mask(isd:ied,Jsdq:Jedq) ) ; CS%v_face_mask(:,:) = 0.0 - allocate ( CS%u_face_mask_boundary(Isdq:Iedq,jsd:jed) ) ; CS%u_face_mask_boundary(:,:) = -2.0 - allocate ( CS%v_face_mask_boundary(isd:ied,Jsdq:Jedq) ) ; CS%v_face_mask_boundary(:,:) = -2.0 - allocate ( CS%u_flux_boundary_values(Isdq:Iedq,jsd:jed) ) ; CS%u_flux_boundary_values(:,:) = 0.0 - allocate ( CS%v_flux_boundary_values(isd:ied,Jsdq:Jedq) ) ; CS%v_flux_boundary_values(:,:) = 0.0 - allocate ( CS%umask(Isdq:Iedq,Jsdq:Jedq) ) ; CS%umask(:,:) = -1.0 - allocate ( CS%vmask(Isdq:Iedq,Jsdq:Jedq) ) ; CS%vmask(:,:) = -1.0 - - allocate ( CS%taub_beta_eff_bilinear(isd:ied,jsd:jed) ) ; CS%taub_beta_eff_bilinear(:,:) = 0.0 - allocate ( CS%taub_beta_eff_upper_tri(isd:ied,jsd:jed) ) ; CS%taub_beta_eff_upper_tri(:,:) = 0.0 - allocate ( CS%taub_beta_eff_lower_tri(isd:ied,jsd:jed) ) ; CS%taub_beta_eff_lower_tri(:,:) = 0.0 - allocate ( CS%OD_rt(isd:ied,jsd:jed) ) ; CS%OD_rt(:,:) = 0.0 - allocate ( CS%OD_av(isd:ied,jsd:jed) ) ; CS%OD_av(:,:) = 0.0 - allocate ( CS%float_frac(isd:ied,jsd:jed) ) ; CS%float_frac(:,:) = 0.0 - allocate ( CS%float_frac_rt(isd:ied,jsd:jed) ) ; CS%float_frac_rt(:,:) = 0.0 - - if (CS%calve_to_mask) then - allocate ( CS%calve_mask (isd:ied,jsd:jed) ) ; CS%calve_mask(:,:) = 0.0 - endif - - endif + ! Allocate and initialize state variables to default values + call ice_shelf_state_init(CS%ISS, CS%grid) + ISS => CS%ISS ! Allocate the arrays for passing ice-shelf data through the forcing type. if (.not. CS%solo_ice_sheet) then - if (is_root_pe()) print *,"initialize_ice_shelf: allocating fluxes" + call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: allocating fluxes.") ! GMM: the following assures that water/heat fluxes are just allocated ! when SHELF_THERMO = True. These fluxes are necessary if one wants to ! use either ENERGETICS_SFC_PBL (ALE mode) or BULKMIXEDLAYER (layer mode). if (present(fluxes)) & - call allocate_forcing_type(G, fluxes, ustar=.true., shelf=.true., & + call allocate_forcing_type(CS%ocn_grid, fluxes, ustar=.true., shelf=.true., & press=.true., water=CS%isthermo, heat=CS%isthermo) if (present(forces)) & - call allocate_mech_forcing(G, forces, ustar=.true., shelf=.true., & - press=.true.) + call allocate_mech_forcing(CS%ocn_grid, forces, ustar=.true., shelf=.true., press=.true.) else - if (is_root_pe()) print *,"allocating fluxes in solo mode" + call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: allocating fluxes in solo mode.") if (present(fluxes)) & call allocate_forcing_type(G, fluxes, ustar=.true., shelf=.true., press=.true.) if (present(forces)) & @@ -1602,66 +1390,42 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl endif ! Set up the bottom depth, G%D either analytically or from file - call MOM_initialize_topography(G%bathyT, G%max_depth, dG, param_file) + call MOM_initialize_topography(dG%bathyT, G%max_depth, dG, param_file) + call rescale_dyn_horgrid_bathymetry(dG, US%Z_to_m) + ! Set up the Coriolis parameter, G%f, usually analytically. - call MOM_initialize_rotation(G%CoriolisBu, dG, param_file) + call MOM_initialize_rotation(dG%CoriolisBu, dG, param_file) + ! This copies grid elements, inglucy bathyT and CoriolisBu from dG to CS%grid. call copy_dyngrid_to_MOM_grid(dG, CS%grid) call destroy_dyn_horgrid(dG) ! Set up the restarts. call restart_init(param_file, CS%restart_CSp, "Shelf.res") - vd = var_desc("shelf_mass","kg m-2","Ice shelf mass",z_grid='1') - call register_restart_field(CS%mass_shelf, vd, .true., CS%restart_CSp) - vd = var_desc("shelf_area","m2","Ice shelf area in cell",z_grid='1') - call register_restart_field(CS%area_shelf_h, vd, .true., CS%restart_CSp) - vd = var_desc("h_shelf","m","ice sheet/shelf thickness",z_grid='1') - call register_restart_field(CS%h_shelf, vd, .true., CS%restart_CSp) - - if (CS%shelf_mass_is_dynamic .and. .not.CS%override_shelf_movement) then - ! additional restarts for ice shelf state - vd = var_desc("u_shelf","m s-1","ice sheet/shelf velocity",'q',z_grid='1') - call register_restart_field(CS%u_shelf, vd, .true., CS%restart_CSp) - vd = var_desc("v_shelf","m s-1","ice sheet/shelf velocity",'q',z_grid='1') - call register_restart_field(CS%v_shelf, vd, .true., CS%restart_CSp) - !vd = var_desc("h_shelf","m","ice sheet/shelf thickness",z_grid='1') - !call register_restart_field(CS%h_shelf, vd, .true., CS%restart_CSp) - - vd = var_desc("h_mask","none","ice sheet/shelf thickness mask",z_grid='1') - call register_restart_field(CS%hmask, vd, .true., CS%restart_CSp) - - ! OVS vertically integrated stream/shelf temperature - vd = var_desc("t_shelf","deg C","ice sheet/shelf temperature",z_grid='1') - call register_restart_field(CS%t_shelf, vd, .true., CS%restart_CSp) - - - ! vd = var_desc("area_shelf_h","m-2","ice-covered area of a cell",z_grid='1') - ! call register_restart_field(CS%area_shelf_h, CS%area_shelf_h, vd, .true., CS%restart_CSp) - - vd = var_desc("OD_av","m","avg ocean depth in a cell",z_grid='1') - call register_restart_field(CS%OD_av, vd, .true., CS%restart_CSp) - - ! vd = var_desc("OD_av_rt","m","avg ocean depth in a cell, intermed",z_grid='1') - ! call register_restart_field(CS%OD_av_rt, CS%OD_av_rt, vd, .true., CS%restart_CSp) - - vd = var_desc("float_frac","m","degree of grounding",z_grid='1') - call register_restart_field(CS%float_frac, vd, .true., CS%restart_CSp) - - ! vd = var_desc("float_frac_rt","m","degree of grounding, intermed",z_grid='1') - ! call register_restart_field(CS%float_frac_rt, CS%float_frac_rt, vd, .true., CS%restart_CSp) - - vd = var_desc("viscosity","m","glens law ice visc",z_grid='1') - call register_restart_field(CS%ice_visc_bilinear, vd, .true., CS%restart_CSp) - vd = var_desc("tau_b_beta","m","coefficient of basal traction",z_grid='1') - call register_restart_field(CS%taub_beta_eff_bilinear, vd, .true., CS%restart_CSp) + call register_restart_field(ISS%mass_shelf, "shelf_mass", .true., CS%restart_CSp, & + "Ice shelf mass", "kg m-2") + call register_restart_field(ISS%area_shelf_h, "shelf_area", .true., CS%restart_CSp, & + "Ice shelf area in cell", "m2") + call register_restart_field(ISS%h_shelf, "h_shelf", .true., CS%restart_CSp, & + "ice sheet/shelf thickness", "m") + call register_restart_field(US%m_to_Z_restart, "m_to_Z", .false., CS%restart_CSp, & + "Height unit conversion factor", "Z meter-1") + if (CS%active_shelf_dynamics) then + call register_restart_field(ISS%hmask, "h_mask", .true., CS%restart_CSp, & + "ice sheet/shelf thickness mask" ,"none") endif + ! if (CS%active_shelf_dynamics) then !### Consider adding an ice shelf dynamics switch. + ! Allocate CS%dCS and specify additional restarts for ice shelf dynamics + call register_ice_shelf_dyn_restarts(G, param_file, CS%dCS, CS%restart_CSp) + ! endif + !GMM - I think we do not need to save ustar_shelf and iceshelf_melt in the restart file - ! if (.not. CS%solo_ice_sheet) then - ! vd = var_desc("ustar_shelf","m s-1","Friction velocity under ice shelves",z_grid='1') - ! call register_restart_field(fluxes%ustar_shelf, vd, .true., CS%restart_CSp) - ! vd = var_desc("iceshelf_melt","m year-1","Ice Shelf Melt Rate",z_grid='1') - ! call register_restart_field(fluxes%iceshelf_melt, vd, .true., CS%restart_CSp) + !if (.not. CS%solo_ice_sheet) then + ! call register_restart_field(fluxes%ustar_shelf, "ustar_shelf", .false., CS%restart_CSp, & + ! "Friction velocity under ice shelves", "m s-1") + ! call register_restart_field(fluxes%iceshelf_melt, "iceshelf_melt", .false., CS%restart_CSp, & + ! "Ice Shelf Melt Rate", "m year-1") !endif CS%restart_output_dir = dirs%restart_output_dir @@ -1673,218 +1437,100 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl if (CS%override_shelf_movement .and. CS%mass_from_file) then ! initialize the ids for reading shelf mass from a netCDF - call initialize_shelf_mass(G, param_file, CS) + call initialize_shelf_mass(G, param_file, CS, ISS) if (new_sim) then ! new simulation, initialize ice thickness as in the static case - call initialize_ice_thickness (CS%h_shelf, CS%area_shelf_h, CS%hmask, G, param_file) + call initialize_ice_thickness(ISS%h_shelf, ISS%area_shelf_h, ISS%hmask, G, US, param_file) ! next make sure mass is consistent with thickness - do j=G%jsd,G%jed - do i=G%isd,G%ied - if ((CS%hmask(i,j) .eq. 1) .or. (CS%hmask(i,j) .eq. 2)) then - CS%mass_shelf(i,j) = CS%h_shelf(i,j)*CS%density_ice + do j=G%jsd,G%jed ; do i=G%isd,G%ied + if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2)) then + ISS%mass_shelf(i,j) = ISS%h_shelf(i,j)*CS%rho_ice endif - enddo - enddo - - if (CS%min_thickness_simple_calve > 0.0) then - call ice_shelf_min_thickness_calve (CS, CS%h_shelf, CS%area_shelf_h, CS%hmask) - endif + enddo ; enddo + if (CS%min_thickness_simple_calve > 0.0) & + call ice_shelf_min_thickness_calve(G, ISS%h_shelf, ISS%area_shelf_h, ISS%hmask, & + CS%min_thickness_simple_calve) endif + endif - ! else if (CS%shelf_mass_is_dynamic) then - ! call initialize_ice_shelf_boundary ( CS%u_face_mask_boundary, CS%v_face_mask_boundary, & - ! CS%u_flux_boundary_values, CS%v_flux_boundary_values, & - ! CS%u_boundary_values, CS%v_boundary_values, CS%h_boundary_values, & -! CS%hmask, G, param_file) - end if - - if (CS%shelf_mass_is_dynamic .and. .not. CS%override_shelf_movement) then - ! the only reason to initialize boundary conds is if the shelf is dynamic + if (CS%active_shelf_dynamics) then + ! the only reason to initialize boundary conds is if the shelf is dynamic - MJH - !MJHcall initialize_ice_shelf_boundary ( CS%u_face_mask_boundary, CS%v_face_mask_boundary, & - !MJH CS%u_flux_boundary_values, CS%v_flux_boundary_values, & - !MJH CS%u_boundary_values, CS%v_boundary_values, CS%h_boundary_values, & - !MJH CS%hmask, G, param_file) + ! call initialize_ice_shelf_boundary ( CS%u_face_mask_bdry, CS%v_face_mask_bdry, & + ! CS%u_flux_bdry_val, CS%v_flux_bdry_val, & + ! CS%u_bdry_val, CS%v_bdry_val, CS%h_bdry_val, & + ! ISS%hmask, G, param_file) - end if + endif if (new_sim .and. (.not. (CS%override_shelf_movement .and. CS%mass_from_file))) then ! This model is initialized internally or from a file. - call initialize_ice_thickness (CS%h_shelf, CS%area_shelf_h, CS%hmask, G, param_file) + call initialize_ice_thickness(ISS%h_shelf, ISS%area_shelf_h, ISS%hmask, G, US, param_file) ! next make sure mass is consistent with thickness - do j=G%jsd,G%jed - do i=G%isd,G%ied - if ((CS%hmask(i,j) .eq. 1) .or. (CS%hmask(i,j) .eq. 2)) then - CS%mass_shelf(i,j) = CS%h_shelf(i,j)*CS%density_ice - endif - enddo - enddo + do j=G%jsd,G%jed ; do i=G%isd,G%ied + if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2)) then + ISS%mass_shelf(i,j) = ISS%h_shelf(i,j)*CS%rho_ice + endif + enddo ; enddo ! else ! Previous block for new_sim=.T., this block restores the state. elseif (.not.new_sim) then - ! This line calls a subroutine that reads the initial conditions - ! from a restart file. - call restore_state(dirs%input_filename, dirs%restart_input_dir, Time, & + ! This line calls a subroutine that reads the initial conditions from a restart file. + call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: Restoring ice shelf from file.") + call restore_state(dirs%input_filename, dirs%restart_input_dir, Time, & G, CS%restart_CSp) - ! i think this call isnt necessary - all it does is set hmask to 3 at - ! the dirichlet boundary, and now this is done elsewhere - ! call initialize_shelf_mass(G, param_file, CS, .false.) - - if (CS%shelf_mass_is_dynamic .and. .not.CS%override_shelf_movement) then - - ! this is unfortunately necessary; if grid is not symmetric the boundary values - ! of u and v are otherwise not set till the end of the first linear solve, and so - ! viscosity is not calculated correctly - if (.not. G%symmetric) then - do j=G%jsd,G%jed - do i=G%isd,G%ied - if (((i+G%idg_offset) .eq. (G%domain%nihalo+1)).and.(CS%u_face_mask(i-1,j).eq.3)) then - CS%u_shelf (i-1,j-1) = CS%u_boundary_values (i-1,j-1) - CS%u_shelf (i-1,j) = CS%u_boundary_values (i-1,j) - endif - if (((j+G%jdg_offset) .eq. (G%domain%njhalo+1)).and.(CS%v_face_mask(i,j-1).eq.3)) then - CS%u_shelf (i-1,j-1) = CS%u_boundary_values (i-1,j-1) - CS%u_shelf (i,j-1) = CS%u_boundary_values (i,j-1) - endif - enddo - enddo - endif - - call pass_var (CS%OD_av,G%domain) - call pass_var (CS%float_frac,G%domain) - call pass_var (CS%ice_visc_bilinear,G%domain) - call pass_var (CS%taub_beta_eff_bilinear,G%domain) - call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE) - call pass_var (CS%area_shelf_h,G%domain) - call pass_var (CS%h_shelf,G%domain) - call pass_var (CS%hmask,G%domain) - - if (is_root_pe()) PRINT *, "RESTORING ICE SHELF FROM FILE!!!!!!!!!!!!!" + if ((US%m_to_Z_restart /= 0.0) .and. (US%m_to_Z_restart /= US%m_to_Z)) then + Z_rescale = US%m_to_Z / US%m_to_Z_restart + do j=G%jsc,G%jec ; do i=G%isc,G%iec + ISS%h_shelf(i,j) = Z_rescale * ISS%h_shelf(i,j) + enddo ; enddo endif endif ! .not. new_sim CS%Time = Time - call pass_var(CS%area_shelf_h, G%domain) - call pass_var(CS%h_shelf, G%domain) - call pass_var(CS%mass_shelf, G%domain) - - ! Transfer the appropriate fields to the forcing type. - if (CS%shelf_mass_is_dynamic .and. .not.CS%override_shelf_movement) then - call cpu_clock_begin(id_clock_pass) - call pass_var(G%bathyT, G%domain) - call pass_var(CS%hmask, G%domain) - call update_velocity_masks (CS) - call cpu_clock_end(id_clock_pass) - endif + call cpu_clock_begin(id_clock_pass) + call pass_var(ISS%area_shelf_h, G%domain) + call pass_var(ISS%h_shelf, G%domain) + call pass_var(ISS%mass_shelf, G%domain) + call pass_var(ISS%hmask, G%domain) + call pass_var(G%bathyT, G%domain) + call cpu_clock_end(id_clock_pass) do j=jsd,jed ; do i=isd,ied - if (CS%area_shelf_h(i,j) > G%areaT(i,j)) then + if (ISS%area_shelf_h(i,j) > G%areaT(i,j)) then call MOM_error(WARNING,"Initialize_ice_shelf: area_shelf_h exceeds G%areaT.") - CS%area_shelf_h(i,j) = G%areaT(i,j) - endif - if (present(fluxes)) then - if (G%areaT(i,j) > 0.0) fluxes%frac_shelf_h(i,j) = CS%area_shelf_h(i,j) / G%areaT(i,j) - if (associated(fluxes%p_surf)) & - fluxes%p_surf(i,j) = fluxes%p_surf(i,j) + & - fluxes%frac_shelf_h(i,j) * (CS%g_Earth * CS%mass_shelf(i,j)) - if (associated(fluxes%p_surf_full)) & - fluxes%p_surf_full(i,j) = fluxes%p_surf_full(i,j) + & - fluxes%frac_shelf_h(i,j) * (CS%g_Earth * CS%mass_shelf(i,j)) + ISS%area_shelf_h(i,j) = G%areaT(i,j) endif enddo ; enddo + if (present(fluxes)) then ; do j=jsd,jed ; do i=isd,ied + if (G%areaT(i,j) > 0.0) fluxes%frac_shelf_h(i,j) = ISS%area_shelf_h(i,j) / G%areaT(i,j) + enddo ; enddo ; endif if (CS%DEBUG) then - call hchksum (fluxes%frac_shelf_h, "IS init: frac_shelf_h", G%HI, haloshift=0) - endif - - if (present(forces) .and. .not. CS%solo_ice_sheet) then - do j=jsd,jed ; do i=isd,ied-1 - forces%frac_shelf_u(I,j) = 0.0 - if ((G%areaT(i,j) + G%areaT(i+1,j) > 0.0)) & ! .and. (G%dxdy_u(I,j) > 0.0)) & - forces%frac_shelf_u(I,j) = ((CS%area_shelf_h(i,j) + CS%area_shelf_h(i+1,j)) / & - (G%areaT(i,j) + G%areaT(i+1,j))) - forces%rigidity_ice_u(I,j) = (CS%kv_ice / CS%density_ice) * & - min(CS%mass_shelf(i,j), CS%mass_shelf(i+1,j)) - enddo ; enddo - - - do j=jsd,jed-1 ; do i=isd,ied - forces%frac_shelf_v(i,J) = 0.0 - if ((G%areaT(i,j) + G%areaT(i,j+1) > 0.0)) & ! .and. (G%dxdy_v(i,J) > 0.0)) & - forces%frac_shelf_v(i,J) = ((CS%area_shelf_h(i,j) + CS%area_shelf_h(i,j+1)) / & - (G%areaT(i,j) + G%areaT(i,j+1))) - forces%rigidity_ice_v(i,J) = (CS%kv_ice / CS%density_ice) * & - min(CS%mass_shelf(i,j), CS%mass_shelf(i,j+1)) - enddo ; enddo - endif - - if (present(forces) .and. .not.CS%solo_ice_sheet) then - call pass_vector(forces%frac_shelf_u, forces%frac_shelf_v, G%domain, TO_ALL, CGRID_NE) + call hchksum(fluxes%frac_shelf_h, "IS init: frac_shelf_h", G%HI, haloshift=0) endif - ! call savearray2 ('frac_shelf_u'//procnum,forces%frac_shelf_u,CS%write_output_to_file) - ! call savearray2 ('frac_shelf_v'//procnum,forces%frac_shelf_v,CS%write_output_to_file) - ! call savearray2 ('frac_shelf_h'//procnum,fluxes%frac_shelf_h,CS%write_output_to_file) - ! call savearray2 ('area_shelf_h'//procnum,CS%area_shelf_h,CS%write_output_to_file) - ! if we are calving to a mask, i.e. if a mask exists where a shelf cannot, then we read - ! the mask from a file + if (present(forces)) & + call add_shelf_forces(G, CS, forces, do_shelf_area=.not.CS%solo_ice_sheet) - if (CS%shelf_mass_is_dynamic .and. CS%calve_to_mask .and. & - .not.CS%override_shelf_movement) then + if (present(fluxes)) call add_shelf_pressure(G, CS, fluxes) - call MOM_mesg(" MOM_ice_shelf.F90, initialize_ice_shelf: reading calving_mask") - - call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") - inputdir = slasher(inputdir) - call get_param(param_file, mdl, "CALVING_MASK_FILE", IC_file, & - "The file with a mask for where calving might occur.", & - default="ice_shelf_h.nc") - call get_param(param_file, mdl, "CALVING_MASK_VARNAME", var_name, & - "The variable to use in masking calving.", & - default="area_shelf_h") - - filename = trim(inputdir)//trim(IC_file) - call log_param(param_file, mdl, "INPUTDIR/CALVING_MASK_FILE", filename) - if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & - " calving mask file: Unable to open "//trim(filename)) - - call MOM_read_data(filename,trim(var_name),CS%calve_mask,G%Domain) - do j=G%jsc,G%jec - do i=G%isc,G%iec - if (CS%calve_mask(i,j) > 0.0) CS%calve_mask(i,j) = 1.0 - enddo - enddo - - call pass_var (CS%calve_mask,G%domain) + if (CS%active_shelf_dynamics .and. .not.CS%isthermo) then + ISS%water_flux(:,:) = 0.0 endif - if (CS%shelf_mass_is_dynamic .and. .not.CS%override_shelf_movement) then -! call init_boundary_values (CS, time, CS%input_flux, CS%input_thickness, new_sim) - - if (.not. CS%isthermo) then - CS%lprec(:,:) = 0.0 - endif - - - if (new_sim) then - if (is_root_pe()) print *,"NEW SIM: initialize velocity" - call update_OD_ffrac_uncoupled (CS) - call ice_shelf_solve_outer (CS, CS%u_shelf, CS%v_shelf, 1, iters, Time) - -! write (procnum,'(I2)') mpp_pe() + if (shelf_mass_is_dynamic) & + call initialize_ice_shelf_dyn(param_file, Time, ISS, CS%dCS, G, US, diag, new_sim, solo_ice_sheet_in) - if (CS%id_u_shelf > 0) call post_data(CS%id_u_shelf,CS%u_shelf,CS%diag) - if (CS%id_v_shelf > 0) call post_data(CS%id_v_shelf,CS%v_shelf,CS%diag) - endif - endif + call fix_restart_unit_scaling(US) call get_param(param_file, mdl, "SAVE_INITIAL_CONDS", save_IC, & "If true, save the ice shelf initial conditions.", & @@ -1895,7 +1541,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl if (save_IC .and. .not.((dirs%input_filename(1:1) == 'r') .and. & (LEN_TRIM(dirs%input_filename) == 1))) then - call save_restart(dirs%output_directory, CS%Time, G, & CS%restart_CSp, filename=IC_file) endif @@ -1905,6 +1550,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl 'Ice Shelf Area in cell', 'meter-2') CS%id_shelf_mass = register_diag_field('ocean_model', 'shelf_mass', CS%diag%axesT1, CS%Time, & 'mass of shelf', 'kg/m^2') + CS%id_h_shelf = register_diag_field('ocean_model', 'h_shelf', CS%diag%axesT1, CS%Time, & + 'ice shelf thickness', 'm', conversion=US%Z_to_m) CS%id_mass_flux = register_diag_field('ocean_model', 'mass_flux', CS%diag%axesT1,& CS%Time,'Total mass flux of freshwater across the ice-ocean interface.', 'kg/s') CS%id_melt = register_diag_field('ocean_model', 'melt', CS%diag%axesT1, CS%Time, & @@ -1928,41 +1575,10 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl CS%id_tfl_shelf = register_diag_field('ocean_model', 'tflux_shelf', CS%diag%axesT1, CS%Time, & 'Heat conduction into ice shelf', 'W m-2') CS%id_ustar_shelf = register_diag_field('ocean_model', 'ustar_shelf', CS%diag%axesT1, CS%Time, & - 'Fric vel under shelf', 'm/s') - - if (CS%shelf_mass_is_dynamic .and. .not.CS%override_shelf_movement) then - CS%id_u_shelf = register_diag_field('ocean_model','u_shelf',CS%diag%axesCu1,CS%Time, & - 'x-velocity of ice', 'm yr-1') - CS%id_v_shelf = register_diag_field('ocean_model','v_shelf',CS%diag%axesCv1,CS%Time, & - 'y-velocity of ice', 'm yr-1') - CS%id_u_mask = register_diag_field('ocean_model','u_mask',CS%diag%axesCu1,CS%Time, & - 'mask for u-nodes', 'none') - CS%id_v_mask = register_diag_field('ocean_model','v_mask',CS%diag%axesCv1,CS%Time, & - 'mask for v-nodes', 'none') - CS%id_h_mask = register_diag_field('ocean_model','h_mask',CS%diag%axesT1,CS%Time, & - 'ice shelf thickness', 'none') - CS%id_surf_elev = register_diag_field('ocean_model','ice_surf',CS%diag%axesT1,CS%Time, & - 'ice surf elev', 'm') - CS%id_float_frac = register_diag_field('ocean_model','ice_float_frac',CS%diag%axesT1,CS%Time, & - 'fraction of cell that is floating (sort of)', 'none') - CS%id_col_thick = register_diag_field('ocean_model','col_thick',CS%diag%axesT1,CS%Time, & - 'ocean column thickness passed to ice model', 'm') - CS%id_OD_av = register_diag_field('ocean_model','OD_av',CS%diag%axesT1,CS%Time, & - 'intermediate ocean column thickness passed to ice model', 'm') - CS%id_float_frac_rt = register_diag_field('ocean_model','float_frac_rt',CS%diag%axesT1,CS%Time, & - 'timesteps where cell is floating ', 'none') - !CS%id_h_after_uflux = register_diag_field('ocean_model','h_after_uflux',CS%diag%axesh1,CS%Time, & - ! 'thickness after u flux ', 'none') - !CS%id_h_after_vflux = register_diag_field('ocean_model','h_after_vflux',CS%diag%axesh1,CS%Time, & - ! 'thickness after v flux ', 'none') - !CS%id_h_after_adv = register_diag_field('ocean_model','h_after_adv',CS%diag%axesh1,CS%Time, & - ! 'thickness after front adv ', 'none') - -!!! OVS vertically integrated temperature - CS%id_t_shelf = register_diag_field('ocean_model','t_shelf',CS%diag%axesT1,CS%Time, & - 'T of ice', 'oC') - CS%id_t_mask = register_diag_field('ocean_model','tmask',CS%diag%axesT1,CS%Time, & - 'mask for T-nodes', 'none') + 'Fric vel under shelf', 'm/s', conversion=US%Z_to_m) + if (CS%active_shelf_dynamics) then + CS%id_h_mask = register_diag_field('ocean_model', 'h_mask', CS%diag%axesT1, CS%Time, & + 'ice shelf thickness mask', 'none') endif id_clock_shelf = cpu_clock_id('Ice shelf', grain=CLOCK_COMPONENT) @@ -1971,12 +1587,13 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl end subroutine initialize_ice_shelf !> Initializes shelf mass based on three options (file, zero and user) -subroutine initialize_shelf_mass(G, param_file, CS, new_sim) +subroutine initialize_shelf_mass(G, param_file, CS, ISS, new_sim) - type(ocean_grid_type), intent(in) :: G + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(ice_shelf_CS), pointer :: CS - logical, optional :: new_sim + type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), intent(inout) :: ISS !< The ice shelf state type that is being updated + logical, optional, intent(in) :: new_sim !< If present and false, this run is being restarted integer :: i, j, is, ie, js, je logical :: read_shelf_area, new_sim_2 @@ -1986,11 +1603,7 @@ subroutine initialize_shelf_mass(G, param_file, CS, new_sim) character(len=40) :: mdl = "MOM_ice_shelf" is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - if (.not. present(new_sim)) then - new_sim_2 = .true. - else - new_sim_2 = .false. - endif + 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"//& @@ -2023,14 +1636,8 @@ subroutine initialize_shelf_mass(G, param_file, CS, new_sim) filename = trim(slasher(inputdir))//trim(shelf_file) call log_param(param_file, mdl, "INPUTDIR/SHELF_FILE", filename) - if (CS%DEBUG) then - CS%id_read_mass = init_external_field(filename,shelf_mass_var, & - domain=G%Domain%mpp_domain,verbose=.true.) - else - CS%id_read_mass = init_external_field(filename,shelf_mass_var, & - domain=G%Domain%mpp_domain) - - endif + CS%id_read_mass = init_external_field(filename, shelf_mass_var, & + domain=G%Domain%mpp_domain, verbose=CS%debug) if (read_shelf_area) then call get_param(param_file, mdl, "SHELF_AREA_VAR", shelf_area_var, & @@ -2038,7 +1645,7 @@ subroutine initialize_shelf_mass(G, param_file, CS, new_sim) default="shelf_area") CS%id_read_area = init_external_field(filename,shelf_area_var, & - domain=G%Domain%mpp_domain) + domain=G%Domain%mpp_domain) endif if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & @@ -2046,13 +1653,13 @@ subroutine initialize_shelf_mass(G, param_file, CS, new_sim) case ("zero") do j=js,je ; do i=is,ie - CS%mass_shelf(i,j) = 0.0 - CS%area_shelf_h(i,j) = 0.0 + ISS%mass_shelf(i,j) = 0.0 + ISS%area_shelf_h(i,j) = 0.0 enddo ; enddo case ("USER") - call USER_initialize_shelf_mass(CS%mass_shelf, CS%area_shelf_h, & - CS%h_shelf, CS%hmask, G, CS%user_CS, param_file, new_sim_2) + call USER_initialize_shelf_mass(ISS%mass_shelf, ISS%area_shelf_h, & + ISS%h_shelf, ISS%hmask, G, CS%US, CS%user_CS, param_file, new_sim_2) case default ; call MOM_error(FATAL,"initialize_ice_shelf: "// & "Unrecognized ice shelf setup "//trim(config)) @@ -2061,106 +1668,43 @@ subroutine initialize_shelf_mass(G, param_file, CS, new_sim) end subroutine initialize_shelf_mass !> Updates the ice shelf mass using data from a file. -subroutine update_shelf_mass(G, CS, Time, fluxes) - type(ocean_grid_type), intent(inout) :: G - type(ice_shelf_CS), pointer :: CS - type(time_type), intent(in) :: Time - type(forcing), intent(inout) :: fluxes +subroutine update_shelf_mass(G, CS, ISS, Time) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(ice_shelf_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), intent(inout) :: ISS !< The ice shelf state type that is being updated + type(time_type), intent(in) :: Time !< The current model time ! local variables integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - ! first, zero out fluxes applied during previous time step - do j=js,je; do i=is,ie - - - enddo; enddo - - call time_interp_external(CS%id_read_mass, Time, CS%mass_shelf) + call time_interp_external(CS%id_read_mass, Time, ISS%mass_shelf) do j=js,je ; do i=is,ie - ! first, zero out fluxes applied during previous time step - if (CS%area_shelf_h(i,j) > 0.0) then - if (associated(fluxes%lprec)) fluxes%lprec(i,j) = 0.0 - if (associated(fluxes%sens)) fluxes%sens(i,j) = 0.0 - if (associated(fluxes%frac_shelf_h)) fluxes%frac_shelf_h(i,j) = 0.0 - if (associated(fluxes%p_surf)) fluxes%p_surf(i,j) = 0.0 - if (associated(fluxes%salt_flux)) fluxes%salt_flux(i,j) = 0.0 - endif - CS%area_shelf_h(i,j) = 0.0 - CS%hmask(i,j) = 0. - if (CS%mass_shelf(i,j) > 0.0) then - CS%area_shelf_h(i,j) = G%areaT(i,j) - CS%h_shelf(i,j) = CS%mass_shelf(i,j)/CS%density_ice - CS%hmask(i,j) = 1. - endif + ISS%area_shelf_h(i,j) = 0.0 + ISS%hmask(i,j) = 0. + if (ISS%mass_shelf(i,j) > 0.0) then + ISS%area_shelf_h(i,j) = G%areaT(i,j) + ISS%h_shelf(i,j) = ISS%mass_shelf(i,j) / CS%rho_ice + ISS%hmask(i,j) = 1. + endif enddo ; enddo - !call USER_update_shelf_mass(CS%mass_shelf, CS%area_shelf_h, CS%h_shelf, & - ! CS%hmask, CS%grid, CS%user_CS, Time, .true.) + !call USER_update_shelf_mass(ISS%mass_shelf, ISS%area_shelf_h, ISS%h_shelf, & + ! ISS%hmask, CS%grid, CS%user_CS, Time, .true.) if (CS%min_thickness_simple_calve > 0.0) then - call ice_shelf_min_thickness_calve (CS, CS%h_shelf, CS%area_shelf_h, CS%hmask) + call ice_shelf_min_thickness_calve(G, ISS%h_shelf, ISS%area_shelf_h, ISS%hmask, & + CS%min_thickness_simple_calve) endif - call pass_var(CS%area_shelf_h, G%domain) - call pass_var(CS%h_shelf, G%domain) - call pass_var(CS%hmask, G%domain) - call pass_var(CS%mass_shelf, G%domain) - - - ! update psurf and frac_shelf_h in fluxes - do j=js,je ; do i=is,ie - if (associated(fluxes%p_surf)) & - fluxes%p_surf(i,j) = (CS%g_Earth * CS%mass_shelf(i,j)) - if (associated(fluxes%p_surf_full)) & - fluxes%p_surf_full(i,j) = (CS%g_Earth * CS%mass_shelf(i,j)) - if (G%areaT(i,j) > 0.0) & - fluxes%frac_shelf_h(i,j) = CS%area_shelf_h(i,j) / G%areaT(i,j) - enddo ; enddo - + call pass_var(ISS%area_shelf_h, G%domain) + call pass_var(ISS%h_shelf, G%domain) + call pass_var(ISS%hmask, G%domain) + call pass_var(ISS%mass_shelf, G%domain) end subroutine update_shelf_mass -subroutine initialize_diagnostic_fields (CS, FE, Time) - type(ice_shelf_CS), pointer :: CS - integer :: FE - type(time_type), intent(in) :: Time - - type(ocean_grid_type), pointer :: G - integer :: i, j, iters, isd, ied, jsd, jed - real :: rhoi, rhow, OD - type(time_type) :: dummy_time - real,dimension(:,:),pointer :: OD_av, float_frac, h_shelf - - G => CS%grid - rhoi = CS%density_ice - rhow = CS%density_ocean_avg - dummy_time = set_time (0,0) - OD_av => CS%OD_av - h_shelf => CS%h_shelf - float_frac => CS%float_frac - isd=G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - - do j=jsd,jed - do i=isd,ied - OD = G%bathyT(i,j) - rhoi/rhow * h_shelf (i,j) - if (OD.ge.0) then - ! ice thickness does not take up whole ocean column -> floating - OD_av (i,j) = OD - float_frac(i,j) = 0. - else - OD_av (i,j) = 0. - float_frac(i,j) = 1. - endif - enddo - enddo - - call ice_shelf_solve_outer (CS, CS%u_shelf, CS%v_shelf, FE, iters, dummy_time) - -end subroutine initialize_diagnostic_fields - !> Save the ice shelf restart file subroutine ice_shelf_save_restart(CS, Time, directory, time_stamped, filename_suffix) type(ice_shelf_CS), pointer :: CS !< ice shelf control structure @@ -2172,23 +1716,11 @@ subroutine ice_shelf_save_restart(CS, Time, directory, time_stamped, filename_su character(len=*), optional, intent(in) :: filename_suffix !< An optional suffix (e.g., a !! time-stamp) to append to the restart file names. ! local variables - type(ocean_grid_type), pointer :: G + type(ocean_grid_type), pointer :: G => NULL() character(len=200) :: restart_dir - character(2) :: procnum G => CS%grid -! write (procnum,'(I2)') mpp_pe() - - !### THESE ARE ONLY HERE FOR DEBUGGING? -! call savearray2 ("U_before_"//"p"//trim(procnum),CS%u_shelf,CS%write_output_to_file) -! call savearray2 ("V_before_"//"p"//trim(procnum),CS%v_shelf,CS%write_output_to_file) -! call savearray2 ("H_before_"//"p"//trim(procnum),CS%h_shelf,CS%write_output_to_file) -! call savearray2 ("Hmask_before_"//"p"//trim(procnum),CS%hmask,CS%write_output_to_file) -! call savearray2 ("Harea_before_"//"p"//trim(procnum),CS%area_shelf_h,CS%write_output_to_file) -! call savearray2 ("Visc_before_"//"p"//trim(procnum),CS%ice_visc_bilinear,CS%write_output_to_file) -! call savearray2 ("taub_before_"//"p"//trim(procnum),CS%taub_beta_eff_bilinear,CS%write_output_to_file) -! call savearray2 ("taub_before_"//"p"//trim(procnum),CS%taub_beta_eff_bilinear,CS%write_output_to_file) if (present(directory)) then ; restart_dir = directory else ; restart_dir = CS%restart_output_dir ; endif @@ -2196,4490 +1728,102 @@ subroutine ice_shelf_save_restart(CS, Time, directory, time_stamped, filename_su end subroutine ice_shelf_save_restart +!> Deallocates all memory associated with this module +subroutine ice_shelf_end(CS) + type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure -subroutine ice_shelf_advect(CS, time_step, melt_rate, Time) - type(ice_shelf_CS), pointer :: CS - real, intent(in) :: time_step - real, dimension(:,:), pointer :: melt_rate - type(time_type), intent(in) :: Time - -! time_step: time step in sec -! melt_rate: basal melt rate in kg/m^2/s - -! 3/8/11 DNG -! Arguments: -! CS - A structure containing the ice shelf state - including current velocities -! h0 - an array containing the thickness at the beginning of the call -! h_after_uflux - an array containing the thickness after advection in u-direction -! h_after_vflux - similar -! -! This subroutine takes the velocity (on the Bgrid) and timesteps h_t = - div (uh) once. -! ADDITIONALLY, it will update the volume of ice in partially-filled cells, and update -! hmask accordingly -! -! The flux overflows are included here. That is because they will be used to advect 3D scalars -! into partial cells - - ! - ! flux_enter: this is to capture flow into partially covered cells; it gives the mass flux into a given - ! cell across its boundaries. - ! ###Perhaps flux_enter should be changed into u-face and v-face - ! ###fluxes, which can then be used in halo updates, etc. - ! - ! from left neighbor: flux_enter (:,:,1) - ! from right neighbor: flux_enter (:,:,2) - ! from bottom neighbor: flux_enter (:,:,3) - ! from top neighbor: flux_enter (:,:,4) - ! - ! THESE ARE NOT CONSISTENT ==> FIND OUT WHAT YOU IMPLEMENTED - - ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary - ! - ! o--- (4) ---o - ! | | - ! (1) (2) - ! | | - ! o--- (3) ---o - ! - - type(ocean_grid_type), pointer :: G - real, dimension(size(CS%h_shelf,1),size(CS%h_shelf,2)) :: h_after_uflux, h_after_vflux - real, dimension(size(CS%h_shelf,1),size(CS%h_shelf,2),4) :: flux_enter - integer :: isd, ied, jsd, jed, i, j, isc, iec, jsc, jec - real :: rho, spy, thick_bd - real, dimension(:,:), pointer :: hmask - character(len=2) :: procnum - - hmask => CS%hmask - G => CS%grid - rho = CS%density_ice - spy = 365 * 86400 ! seconds per year; is there a global constant for this? No - it is dependent upon a calendar. - - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec - flux_enter (:,:,:) = 0.0 - - h_after_uflux (:,:) = 0.0 - h_after_vflux (:,:) = 0.0 -! if (is_root_pe()) write(*,*) "ice_shelf_advect called" - - do j=jsd,jed - do i=isd,ied - thick_bd = CS%thickness_boundary_values(i,j) - if (thick_bd .ne. 0.0) then - CS%h_shelf(i,j) = CS%thickness_boundary_values(i,j) - endif - enddo - enddo + if (.not.associated(CS)) return - call ice_shelf_advect_thickness_x (CS, time_step/spy, CS%h_shelf, h_after_uflux, flux_enter) + call ice_shelf_state_end(CS%ISS) -! call enable_averaging(time_step,Time,CS%diag) - ! call pass_var (h_after_uflux, G%domain) -! if (CS%id_h_after_uflux > 0) call post_data(CS%id_h_after_uflux, h_after_uflux, CS%diag) -! call disable_averaging(CS%diag) + if (CS%active_shelf_dynamics) call ice_shelf_dyn_end(CS%dCS) - call ice_shelf_advect_thickness_y (CS, time_step/spy, h_after_uflux, h_after_vflux, flux_enter) + deallocate(CS) -! call enable_averaging(time_step,Time,CS%diag) -! call pass_var (h_after_vflux, G%domain) -! if (CS%id_h_after_vflux > 0) call post_data(CS%id_h_after_vflux, h_after_vflux, CS%diag) -! call disable_averaging(CS%diag) +end subroutine ice_shelf_end - do j=jsd,jed - do i=isd,ied - if (CS%hmask(i,j) .eq. 1) then - CS%h_shelf (i,j) = h_after_vflux(i,j) - endif - enddo - enddo - - if (CS%moving_shelf_front) then - call shelf_advance_front (CS, flux_enter) - if (CS%min_thickness_simple_calve > 0.0) then - call ice_shelf_min_thickness_calve (CS, CS%h_shelf, CS%area_shelf_h, CS%hmask) - endif - if (CS%calve_to_mask) then - call calve_to_mask (CS, CS%h_shelf, CS%area_shelf_h, CS%hmask, CS%calve_mask) - endif - endif - - !call enable_averaging(time_step,Time,CS%diag) - !if (CS%id_h_after_adv > 0) call post_data(CS%id_h_after_adv, CS%h_shelf, CS%diag) - !call disable_averaging(CS%diag) - - !call change_thickness_using_melt(CS,G,time_step, fluxes) - - call update_velocity_masks (CS) - -end subroutine ice_shelf_advect - -subroutine ice_shelf_solve_outer (CS, u, v, FE, iters, time) - type(ice_shelf_CS), pointer :: CS - real, dimension(NILIMB_SYM_,NJLIMB_SYM_), intent(inout) :: u, v - integer, intent(in) :: FE - integer, intent(out) :: iters - type(time_type), intent(in) :: time - - real, dimension(:,:), pointer :: TAUDX, TAUDY, u_prev_iterate, v_prev_iterate, & - u_bdry_cont, v_bdry_cont, Au, Av, err_u, err_v, & - geolonq, geolatq, u_last, v_last, float_cond, H_node - type(ocean_grid_type), pointer :: G - integer :: conv_flag, i, j, k,l, iter, isym, & - isdq, iedq, jsdq, jedq, isd, ied, jsd, jed, isumstart, jsumstart, nodefloat, nsub - real :: err_max, err_tempu, err_tempv, err_init, area, max_vel, tempu, tempv, rhoi, rhow - real, pointer, dimension(:,:,:,:) :: Phi - real, pointer, dimension(:,:,:,:,:,:) :: Phisub - real, dimension (8,4) :: Phi_temp - real, dimension (2,2) :: X,Y - character(2) :: iternum - character(2) :: procnum, numproc - - ! for GL interpolation - need to make this a readable parameter - nsub = CS%n_sub_regularize - - G => CS%grid - isdq = G%isdB ; iedq = G%iedB ; jsdq = G%jsdB ; jedq = G%jedB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - rhoi = CS%density_ice - rhow = CS%density_ocean_avg - allocate(TAUDX (isdq:iedq,jsdq:jedq) ) ; TAUDX(:,:)=0 - allocate(TAUDY (isdq:iedq,jsdq:jedq) ) ; TAUDY(:,:)=0 - allocate(u_prev_iterate (isdq:iedq,jsdq:jedq) ) - allocate(v_prev_iterate (isdq:iedq,jsdq:jedq) ) - allocate(u_bdry_cont (isdq:iedq,jsdq:jedq) ) ; u_bdry_cont(:,:)=0 - allocate(v_bdry_cont (isdq:iedq,jsdq:jedq) ) ; v_bdry_cont(:,:)=0 - allocate(Au (isdq:iedq,jsdq:jedq) ) ; Au(:,:)=0 - allocate(Av (isdq:iedq,jsdq:jedq) ) ; Av(:,:)=0 - allocate(err_u (isdq:iedq,jsdq:jedq) ) - allocate(err_v (isdq:iedq,jsdq:jedq) ) - allocate(u_last (isdq:iedq,jsdq:jedq) ) - allocate(v_last (isdq:iedq,jsdq:jedq) ) - - ! need to make these conditional on GL interpolation - allocate(float_cond (G%isd:G%ied,G%jsd:G%jed)) ; float_cond(:,:)=0 - allocate(H_node (G%isdB:G%iedB,G%jsdB:G%jedB)) ; H_node(:,:)=0 - allocate(Phisub (nsub,nsub,2,2,2,2)) ; Phisub = 0.0 - - geolonq => G%geoLonBu ; geolatq => G%geoLatBu - - if (G%isc+G%idg_offset==G%isg) then - ! tile is at west bdry - isumstart = G%iscB - else - ! tile is interior - isumstart = ISUMSTART_INT_ - endif - - if (G%jsc+G%jdg_offset==G%jsg) then - ! tile is at south bdry - jsumstart = G%jscB - else - ! tile is interior - jsumstart = JSUMSTART_INT_ - endif - - call calc_shelf_driving_stress (CS, TAUDX, TAUDY, CS%OD_av, FE) - - ! this is to determine which cells contain the grounding line, - ! the criterion being that the cell is ice-covered, with some nodes - ! floating and some grounded - ! floatation condition is estimated by assuming topography is cellwise constant - ! and H is bilinear in a cell; floating where rho_i/rho_w * H_node + D is nonpositive - - ! need to make this conditional on GL interp - - if (CS%GL_regularize) then - - call interpolate_H_to_B (CS, CS%h_shelf, CS%hmask, H_node) - call savearray2 ("H_node",H_node,CS%write_output_to_file) - - do j=G%jsc,G%jec - do i=G%isc,G%iec - nodefloat = 0 - do k=0,1 - do l=0,1 - if ((CS%hmask(i,j) .eq. 1) .and. & - (rhoi/rhow * H_node(i-1+k,j-1+l) - G%bathyT(i,j) .le. 0)) then - nodefloat = nodefloat + 1 - endif - enddo - enddo - if ((nodefloat .gt. 0) .and. (nodefloat .lt. 4)) then - !print *,"nodefloat",nodefloat - float_cond (i,j) = 1.0 - CS%float_frac (i,j) = 1.0 - endif - enddo - enddo - call savearray2 ("float_cond",float_cond,CS%write_output_to_file) - - call pass_var (float_cond, G%Domain) - - call bilinear_shape_functions_subgrid (Phisub, nsub) - - call savearray2("Phisub1111",Phisub(:,:,1,1,1,1),CS%write_output_to_file) - - endif - - ! make above conditional - - u_prev_iterate (:,:) = u(:,:) - v_prev_iterate (:,:) = v(:,:) - - isym=0 - - ! must prepare phi - if (FE .eq. 1) then - allocate (Phi (isd:ied,jsd:jed,1:8,1:4)) ; Phi(:,:,:,:)=0 - - do j=jsd,jed - do i=isd,ied - - if (((i .gt. isd) .and. (j .gt. jsd)) .or. (isym .eq. 1)) then - X(:,:) = geolonq (i-1:i,j-1:j)*1000 - Y(:,:) = geolatq (i-1:i,j-1:j)*1000 - else - X(2,:) = geolonq(i,j)*1000 - X(1,:) = geolonq(i,j)*1000-G%dxT(i,j) - Y(:,2) = geolatq(i,j)*1000 - Y(:,1) = geolatq(i,j)*1000-G%dyT(i,j) - endif - - call bilinear_shape_functions (X, Y, Phi_temp, area) - Phi (i,j,:,:) = Phi_temp - - enddo - enddo - endif - - if (FE .eq. 1) then - call calc_shelf_visc_bilinear (CS, u, v) - - call pass_var (CS%ice_visc_bilinear, G%domain) - call pass_var (CS%taub_beta_eff_bilinear, G%domain) - else - call calc_shelf_visc_triangular (CS,u,v) - - call pass_var (CS%ice_visc_upper_tri, G%domain) - call pass_var (CS%taub_beta_eff_upper_tri, G%domain) - call pass_var (CS%ice_visc_lower_tri, G%domain) - call pass_var (CS%taub_beta_eff_lower_tri, G%domain) - endif - - ! makes sure basal stress is only applied when it is supposed to be - - do j=G%jsd,G%jed - do i=G%isd,G%ied - if (FE .eq. 1) then - CS%taub_beta_eff_bilinear (i,j) = CS%taub_beta_eff_bilinear (i,j) * CS%float_frac (i,j) - else - CS%taub_beta_eff_upper_tri (i,j) = CS%taub_beta_eff_upper_tri (i,j) * CS%float_frac (i,j) - CS%taub_beta_eff_lower_tri (i,j) = CS%taub_beta_eff_lower_tri (i,j) * CS%float_frac (i,j) - endif - enddo - enddo - - if (FE .eq. 1) then - call apply_boundary_values_bilinear (CS, time, Phisub, H_node, float_cond, & - rhoi/rhow, u_bdry_cont, v_bdry_cont) - elseif (FE .eq. 2) then - call apply_boundary_values_triangle (CS, time, u_bdry_cont, v_bdry_cont) - endif - - Au(:,:) = 0.0 ; Av(:,:) = 0.0 - - if (FE .eq. 1) then - call CG_action_bilinear (Au, Av, u, v, Phi, Phisub, CS%umask, CS%vmask, CS%hmask, H_node, & - CS%ice_visc_bilinear, float_cond, G%bathyT, CS%taub_beta_eff_bilinear, G%areaT, & - G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi/rhow) - elseif (FE .eq. 2) then - call CG_action_triangular (Au, Av, u, v, CS%umask, CS%vmask, CS%hmask, CS%ice_visc_upper_tri, & - CS%ice_visc_lower_tri, CS%taub_beta_eff_upper_tri, CS%taub_beta_eff_lower_tri, & - G%dxT, G%dyT, G%areaT, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, isym) - endif - -! write (procnum,'(I2)') mpp_pe() - - - err_init = 0 ; err_tempu = 0; err_tempv = 0 - do j=jsumstart,G%jecB - do i=isumstart,G%iecB - if (CS%umask(i,j) .eq. 1) then - err_tempu = ABS (Au(i,j) + u_bdry_cont(i,j) - TAUDX(i,j)) - endif - if (CS%vmask(i,j) .eq. 1) then - err_tempv = MAX(ABS (Av(i,j) + v_bdry_cont(i,j) - TAUDY(i,j)), err_tempu) - endif - if (err_tempv .ge. err_init) then - err_init = err_tempv - endif - enddo - enddo - - call mpp_max (err_init) - - if (is_root_pe()) print *,"INITIAL nonlinear residual: ",err_init - - u_last(:,:) = u(:,:) ; v_last(:,:) = v(:,:) - - !! begin loop - - do iter=1,100 - - - call ice_shelf_solve_inner (CS, u, v, TAUDX, TAUDY, H_node, float_cond, & - FE, conv_flag, iters, time, Phi, Phisub) - - - if (CS%DEBUG) then - call qchksum (u, "u shelf", G%HI, haloshift=2) - call qchksum (v, "v shelf", G%HI, haloshift=2) - endif - - if (is_root_pe()) print *,"linear solve done",iters," iterations" - - if (FE .eq. 1) then - call calc_shelf_visc_bilinear (CS,u,v) - call pass_var (CS%ice_visc_bilinear, G%domain) - call pass_var (CS%taub_beta_eff_bilinear, G%domain) - else - call calc_shelf_visc_triangular (CS,u,v) - call pass_var (CS%ice_visc_upper_tri, G%domain) - call pass_var (CS%taub_beta_eff_upper_tri, G%domain) - call pass_var (CS%ice_visc_lower_tri, G%domain) - call pass_var (CS%taub_beta_eff_lower_tri, G%domain) - endif - - if (iter .eq. 1) then -! call savearray2 ("visc1",CS%ice_visc_bilinear,CS%write_output_to_file) - endif - - ! makes sure basal stress is only applied when it is supposed to be - - do j=G%jsd,G%jed - do i=G%isd,G%ied - if (FE .eq. 1) then - CS%taub_beta_eff_bilinear (i,j) = CS%taub_beta_eff_bilinear (i,j) * CS%float_frac (i,j) - else - CS%taub_beta_eff_upper_tri (i,j) = CS%taub_beta_eff_upper_tri (i,j) * CS%float_frac (i,j) - CS%taub_beta_eff_lower_tri (i,j) = CS%taub_beta_eff_lower_tri (i,j) * CS%float_frac (i,j) - endif - enddo - enddo - - u_bdry_cont (:,:) = 0 ; v_bdry_cont (:,:) = 0 - - if (FE .eq. 1) then - call apply_boundary_values_bilinear (CS, time, Phisub, H_node, float_cond, & - rhoi/rhow, u_bdry_cont, v_bdry_cont) - elseif (FE .eq. 2) then - call apply_boundary_values_triangle (CS, time, u_bdry_cont, v_bdry_cont) - endif - - Au(:,:) = 0 ; Av(:,:) = 0 - - if (FE .eq. 1) then - call CG_action_bilinear (Au, Av, u, v, Phi, Phisub, CS%umask, CS%vmask, CS%hmask, H_node, & - CS%ice_visc_bilinear, float_cond, G%bathyT, CS%taub_beta_eff_bilinear, G%areaT, G%isc-1, & - G%iec+1, G%jsc-1, G%jec+1, rhoi/rhow) - elseif (FE .eq. 2) then - call CG_action_triangular (Au, Av, u, v, CS%umask, CS%vmask, CS%hmask, CS%ice_visc_upper_tri, & - CS%ice_visc_lower_tri, CS%taub_beta_eff_upper_tri, CS%taub_beta_eff_lower_tri, & - G%dxT, G%dyT, G%areaT, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, isym) - endif - - err_max = 0 - - if (CS%nonlin_solve_err_mode .eq. 1) then - - do j=jsumstart,G%jecB - do i=isumstart,G%iecB - if (CS%umask(i,j) .eq. 1) then - err_tempu = ABS (Au(i,j) + u_bdry_cont(i,j) - TAUDX(i,j)) - endif - if (CS%vmask(i,j) .eq. 1) then - err_tempv = MAX(ABS (Av(i,j) + v_bdry_cont(i,j) - TAUDY(i,j)), err_tempu) - endif - if (err_tempv .ge. err_max) then - err_max = err_tempv - endif - enddo - enddo - - call mpp_max (err_max) - - elseif (CS%nonlin_solve_err_mode .eq. 2) then - - max_vel = 0 ; tempu = 0 ; tempv = 0 - - do j=jsumstart,G%jecB - do i=isumstart,G%iecB - if (CS%umask(i,j) .eq. 1) then - err_tempu = ABS (u_last(i,j)-u(i,j)) - tempu = u(i,j) - endif - if (CS%vmask(i,j) .eq. 1) then - err_tempv = MAX(ABS (v_last(i,j)- v(i,j)), err_tempu) - tempv = SQRT(v(i,j)**2+tempu**2) - endif - if (err_tempv .ge. err_max) then - err_max = err_tempv - endif - if (tempv .ge. max_vel) then - max_vel = tempv - endif - enddo - enddo - - u_last (:,:) = u(:,:) - v_last (:,:) = v(:,:) - - call mpp_max (max_vel) - call mpp_max (err_max) - err_init = max_vel - - endif - - if (is_root_pe()) print *,"nonlinear residual: ",err_max/err_init - - if (err_max .le. CS%nonlinear_tolerance * err_init) then - if (is_root_pe()) & - print *,"exiting nonlinear solve after ",iter," iterations" - exit - endif - - enddo - - !write (procnum,'(I1)') mpp_pe() - !write (numproc,'(I1)') mpp_npes() - - deallocate (TAUDX) - deallocate (TAUDY) - deallocate (u_prev_iterate) - deallocate (v_prev_iterate) - deallocate (u_bdry_cont) - deallocate (v_bdry_cont) - deallocate (Au) - deallocate (Av) - deallocate (err_u) - deallocate (err_v) - deallocate (u_last) - deallocate (v_last) - deallocate (H_node) - deallocate (float_cond) - deallocate (Phisub) - -end subroutine ice_shelf_solve_outer - -subroutine ice_shelf_solve_inner (CS, u, v, taudx, taudy, H_node, float_cond, FE, conv_flag, iters, time, Phi, Phisub) - type(ice_shelf_CS), pointer :: CS - real, dimension(NILIMB_SYM_,NJLIMB_SYM_), intent(inout) :: u, v - real, dimension(NILIMB_SYM_,NJLIMB_SYM_), intent(in) :: taudx, taudy, H_node - real, dimension(:,:),intent(in) :: float_cond - integer, intent(in) :: FE - integer, intent(out) :: conv_flag, iters - type(time_type) :: time - real, pointer, dimension(:,:,:,:) :: Phi - real, dimension (:,:,:,:,:,:),pointer :: Phisub - -! one linear solve (nonlinear iteration) of the solution for velocity - -! in this subroutine: -! boundary contributions are added to taud to get the RHS -! diagonal of matrix is found (for Jacobi precondition) -! CG iteration is carried out for max. iterations or until convergence - -! assumed - u, v, taud, visc, beta_eff are valid on the halo - - - real, dimension(:,:), pointer :: hmask, umask, vmask, u_bdry, v_bdry, & - visc, visc_lo, beta, beta_lo, geolonq, geolatq - real, dimension(LBOUND(u,1):UBOUND(u,1),LBOUND(u,2):UBOUND(u,2)) :: & - Ru, Rv, Zu, Zv, DIAGu, DIAGv, RHSu, RHSv, & - ubd, vbd, Au, Av, Du, Dv, & - Zu_old, Zv_old, Ru_old, Rv_old, & - sum_vec, sum_vec_2 - integer :: iter, i, j, isym, isd, ied, jsd, jed, & - isc, iec, jsc, jec, is, js, ie, je, isumstart, jsumstart, & - isdq, iedq, jsdq, jedq, iscq, iecq, jscq, jecq, nx_halo, ny_halo - real :: tol, beta_k, alpha_k, area, dot_p1, dot_p2, resid0, cg_halo, dot_p1a, dot_p2a - type(ocean_grid_type), pointer :: G - character(1) :: procnum - character(2) :: gridsize - - real, dimension (8,4) :: Phi_temp - real, dimension (2,2) :: X,Y - - hmask => CS%hmask - umask => CS%umask - vmask => CS%vmask - u_bdry => CS%u_boundary_values - v_bdry => CS%v_boundary_values - - G => CS%grid - geolonq => G%geoLonBu - geolatq => G%geoLatBu - hmask => CS%hmask - isdq = G%isdB ; iedq = G%iedB ; jsdq = G%jsdB ; jedq = G%jedB - iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB - ny_halo = G%domain%njhalo ; nx_halo = G%domain%nihalo - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec - - Zu(:,:) = 0 ; Zv(:,:) = 0 ; DIAGu(:,:) = 0 ; DIAGv(:,:) = 0 - Ru(:,:) = 0 ; Rv (:,:) = 0 ; Au (:,:) = 0 ; Av (:,:) = 0 - Du(:,:) = 0 ; Dv (:,:) = 0 ; ubd(:,:) = 0 ; vbd(:,:) = 0 - dot_p1 = 0 ; dot_p2 = 0 - -! if (G%symmetric) then -! isym = 1 -! else -! isym = 0 -! endif - - isym = 0 - - if (G%isc+G%idg_offset==G%isg) then - ! tile is at west bdry - isumstart = G%iscB - else - ! tile is interior - isumstart = ISUMSTART_INT_ - endif - - if (G%jsc+G%jdg_offset==G%jsg) then - ! tile is at south bdry - jsumstart = G%jscB - else - ! tile is interior - jsumstart = JSUMSTART_INT_ - endif - - if (FE .eq. 1) then - visc => CS%ice_visc_bilinear - beta => CS%taub_beta_eff_bilinear - elseif (FE .eq. 2) then - visc => CS%ice_visc_upper_tri - visc_lo => CS%ice_visc_lower_tri - beta => CS%taub_beta_eff_upper_tri - beta_lo => CS%taub_beta_eff_lower_tri - endif - - if (FE .eq. 1) then - call apply_boundary_values_bilinear (CS, time, Phisub, H_node, float_cond, & - CS%density_ice/CS%density_ocean_avg, ubd, vbd) - elseif (FE .eq. 2) then - call apply_boundary_values_triangle (CS, time, ubd, vbd) - endif - - RHSu(:,:) = taudx(:,:) - ubd(:,:) - RHSv(:,:) = taudy(:,:) - vbd(:,:) - - - call pass_vector(RHSu, RHSv, G%domain, TO_ALL, BGRID_NE) - - - if (FE .eq. 1) then - call matrix_diagonal_bilinear(CS, float_cond, H_node, & - CS%density_ice/CS%density_ocean_avg, Phisub, DIAGu, DIAGv) -! DIAGu(:,:) = 1 ; DIAGv(:,:) = 1 - elseif (FE .eq. 2) then - call matrix_diagonal_triangle (CS, DIAGu, DIAGv) - DIAGu(:,:) = 1 ; DIAGv(:,:) = 1 - endif - - call pass_vector(DIAGu, DIAGv, G%domain, TO_ALL, BGRID_NE) - - - - if (FE .eq. 1) then - call CG_action_bilinear (Au, Av, u, v, Phi, Phisub, umask, vmask, hmask, & - H_node, visc, float_cond, G%bathyT, beta, G%areaT, isc-1, iec+1, jsc-1, & - jec+1, CS%density_ice/CS%density_ocean_avg) - elseif (FE .eq. 2) then - call CG_action_triangular (Au, Av, u, v, umask, vmask, hmask, visc, visc_lo, & - beta, beta_lo, G%dxT, G%dyT, G%areaT, isc-1, iec+1, jsc-1, jec+1, isym) - endif - - call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) - - Ru(:,:) = RHSu(:,:) - Au(:,:) ; Rv(:,:) = RHSv(:,:) - Av(:,:) - - if (.not. CS%use_reproducing_sums) then - - do j=jsumstart,jecq - do i=isumstart,iecq - if (umask(i,j) .eq. 1) dot_p1 = dot_p1 + Ru(i,j)**2 - if (vmask(i,j) .eq. 1) dot_p1 = dot_p1 + Rv(i,j)**2 - enddo - enddo - - call mpp_sum (dot_p1) - - else - - sum_vec(:,:) = 0.0 - - do j=JSUMSTART_INT_,jecq - do i=ISUMSTART_INT_,iecq - if (umask(i,j) .eq. 1) sum_vec(i,j) = Ru(i,j)**2 - if (vmask(i,j) .eq. 1) sum_vec(i,j) = sum_vec(i,j) + Rv(i,j)**2 - enddo - enddo - - dot_p1 = reproducing_sum ( sum_vec, ISUMSTART_INT_, iecq, & - JSUMSTART_INT_, jecq ) - - endif - - resid0 = sqrt (dot_p1) - - do j=jsdq,jedq - do i=isdq,iedq - if (umask(i,j) .eq. 1) Zu(i,j) = Ru (i,j) / DIAGu (i,j) - if (vmask(i,j) .eq. 1) Zv(i,j) = Rv (i,j) / DIAGv (i,j) - enddo - enddo - - Du(:,:) = Zu(:,:) ; Dv(:,:) = Zv(:,:) - - cg_halo = 3 - conv_flag = 0 - - !!!!!!!!!!!!!!!!!! - !! !! - !! MAIN CG LOOP !! - !! !! - !!!!!!!!!!!!!!!!!! - - - - ! initially, c-grid data is valid up to 3 halo nodes out - - do iter = 1,CS%cg_max_iterations - - ! assume asymmetry - ! thus we can never assume that any arrays are legit more than 3 vertices past - ! the computational domain - this is their state in the initial iteration - - - is = isc - cg_halo ; ie = iecq + cg_halo - js = jscq - cg_halo ; je = jecq + cg_halo - - Au(:,:) = 0 ; Av(:,:) = 0 - - if (FE .eq. 1) then - - call CG_action_bilinear (Au, Av, Du, Dv, Phi, Phisub, umask, vmask, hmask, & - H_node, visc, float_cond, G%bathyT, beta, G%areaT, is, ie, js, & - je, CS%density_ice/CS%density_ocean_avg) - - elseif (FE .eq. 2) then - - call CG_action_triangular (Au, Av, Du, Dv, umask, vmask, hmask, visc, visc_lo, & - beta, beta_lo, G%dxT, G%dyT, G%areaT, is, ie, js, je, isym) - endif - - - ! Au, Av valid region moves in by 1 - - if ( .not. CS%use_reproducing_sums) then - - - ! alpha_k = (Z \dot R) / (D \dot AD} - dot_p1 = 0 ; dot_p2 = 0 - do j=jsumstart,jecq - do i=isumstart,iecq - if (umask(i,j) .eq. 1) then - dot_p1 = dot_p1 + Zu(i,j)*Ru(i,j) - dot_p2 = dot_p2 + Du(i,j)*Au(i,j) - endif - if (vmask(i,j) .eq. 1) then - dot_p1 = dot_p1 + Zv(i,j)*Rv(i,j) - dot_p2 = dot_p2 + Dv(i,j)*Av(i,j) - endif - enddo - enddo - call mpp_sum (dot_p1) ; call mpp_sum (dot_p2) - else - - sum_vec(:,:) = 0.0 ; sum_vec_2(:,:) = 0.0 - - do j=jscq,jecq - do i=iscq,iecq - if (umask(i,j) .eq. 1) sum_vec(i,j) = Zu(i,j) * Ru(i,j) - if (vmask(i,j) .eq. 1) sum_vec(i,j) = sum_vec(i,j) + & - Zv(i,j) * Rv(i,j) - - if (umask(i,j) .eq. 1) sum_vec_2(i,j) = Du(i,j) * Au(i,j) - if (vmask(i,j) .eq. 1) sum_vec_2(i,j) = sum_vec_2(i,j) + & - Dv(i,j) * Av(i,j) - enddo - enddo - - dot_p1 = reproducing_sum ( sum_vec, iscq, iecq, & - jscq, jecq ) - - dot_p2 = reproducing_sum ( sum_vec_2, iscq, iecq, & - jscq, jecq ) - - endif - - alpha_k = dot_p1/dot_p2 - - !### These should probably use explicit index notation so that they are - !### not applied outside of the valid range. - RWH - - ! u(:,:) = u(:,:) + alpha_k * Du(:,:) - ! v(:,:) = v(:,:) + alpha_k * Dv(:,:) - - do j=jsd,jed - do i=isd,ied - if (umask(i,j) .eq. 1) u(i,j) = u(i,j) + alpha_k * Du(i,j) - if (vmask(i,j) .eq. 1) v(i,j) = v(i,j) + alpha_k * Dv(i,j) - enddo - enddo - - do j=jsd,jed - do i=isd,ied - if (umask(i,j) .eq. 1) then - Ru_old(i,j) = Ru(i,j) ; Zu_old(i,j) = Zu(i,j) - endif - if (vmask(i,j) .eq. 1) then - Rv_old(i,j) = Rv(i,j) ; Zv_old(i,j) = Zv(i,j) - endif - enddo - enddo - -! Ru(:,:) = Ru(:,:) - alpha_k * Au(:,:) -! Rv(:,:) = Rv(:,:) - alpha_k * Av(:,:) - - do j=jsd,jed - do i=isd,ied - if (umask(i,j) .eq. 1) Ru(i,j) = Ru(i,j) - alpha_k * Au(i,j) - if (vmask(i,j) .eq. 1) Rv(i,j) = Rv(i,j) - alpha_k * Av(i,j) - enddo - enddo - - - do j=jsdq,jedq - do i=isdq,iedq - if (umask(i,j) .eq. 1) then - Zu(i,j) = Ru (i,j) / DIAGu (i,j) - endif - if (vmask(i,j) .eq. 1) then - Zv(i,j) = Rv (i,j) / DIAGv (i,j) - endif - enddo - enddo - - ! R,u,v,Z valid region moves in by 1 - - if (.not. CS%use_reproducing_sums) then - - ! beta_k = (Z \dot R) / (Zold \dot Rold} - dot_p1 = 0 ; dot_p2 = 0 - do j=jsumstart,jecq - do i=isumstart,iecq - if (umask(i,j) .eq. 1) then - dot_p1 = dot_p1 + Zu(i,j)*Ru(i,j) - dot_p2 = dot_p2 + Zu_old(i,j)*Ru_old(i,j) - endif - if (vmask(i,j) .eq. 1) then - dot_p1 = dot_p1 + Zv(i,j)*Rv(i,j) - dot_p2 = dot_p2 + Zv_old(i,j)*Rv_old(i,j) - endif - enddo - enddo - call mpp_sum (dot_p1) ; call mpp_sum (dot_p2) - - - else - - sum_vec(:,:) = 0.0 ; sum_vec_2(:,:) = 0.0 - - do j=JSUMSTART_INT_,jecq - do i=ISUMSTART_INT_,iecq - if (umask(i,j) .eq. 1) sum_vec(i,j) = Zu(i,j) * Ru(i,j) - if (vmask(i,j) .eq. 1) sum_vec(i,j) = sum_vec(i,j) + & - Zv(i,j) * Rv(i,j) - - if (umask(i,j) .eq. 1) sum_vec_2(i,j) = Zu_old(i,j) * Ru_old(i,j) - if (vmask(i,j) .eq. 1) sum_vec_2(i,j) = sum_vec_2(i,j) + & - Zv_old(i,j) * Rv_old(i,j) - enddo - enddo - - - dot_p1 = reproducing_sum ( sum_vec, ISUMSTART_INT_, iecq, & - JSUMSTART_INT_, jecq ) - - dot_p2 = reproducing_sum ( sum_vec_2, ISUMSTART_INT_, iecq, & - JSUMSTART_INT_, jecq ) - - endif - - beta_k = dot_p1/dot_p2 - - -! Du(:,:) = Zu(:,:) + beta_k * Du(:,:) -! Dv(:,:) = Zv(:,:) + beta_k * Dv(:,:) - - do j=jsd,jed - do i=isd,ied - if (umask(i,j) .eq. 1) Du(i,j) = Zu(i,j) + beta_k * Du(i,j) - if (vmask(i,j) .eq. 1) Dv(i,j) = Zv(i,j) + beta_k * Dv(i,j) - enddo - enddo - - ! D valid region moves in by 1 - - dot_p1 = 0 - - if (.not. CS%use_reproducing_sums) then - - do j=jsumstart,jecq - do i=isumstart,iecq - if (umask(i,j) .eq. 1) then - dot_p1 = dot_p1 + Ru(i,j)**2 - endif - if (vmask(i,j) .eq. 1) then - dot_p1 = dot_p1 + Rv(i,j)**2 - endif - enddo - enddo - call mpp_sum (dot_p1) - - else - - sum_vec(:,:) = 0.0 - - do j=JSUMSTART_INT_,jecq - do i=ISUMSTART_INT_,iecq - if (umask(i,j) .eq. 1) sum_vec(i,j) = Ru(i,j)**2 - if (vmask(i,j) .eq. 1) sum_vec(i,j) = sum_vec(i,j) + Rv(i,j)**2 - enddo - enddo - - dot_p1 = reproducing_sum ( sum_vec, ISUMSTART_INT_, iecq, & - JSUMSTART_INT_, jecq ) - -! if (is_root_pe()) print *, dot_p1 -! if (is_root_pe()) print *, dot_p1a - - endif - - dot_p1 = sqrt (dot_p1) - -! if (mpp_pe () == 0) then -! print *,"|r|",dot_p1 -! endif - - if (dot_p1 .le. CS%cg_tolerance * resid0) then - iters = iter - conv_flag = 1 - exit - endif - - cg_halo = cg_halo - 1 - - if (cg_halo .eq. 0) then - ! pass vectors - call pass_vector(Du, Dv, G%domain, TO_ALL, BGRID_NE) - call pass_vector(u, v, G%domain, TO_ALL, BGRID_NE) - call pass_vector(Ru, Rv, G%domain, TO_ALL, BGRID_NE) - cg_halo = 3 - endif - - enddo ! end of CG loop - - do j=jsdq,jedq - do i=isdq,iedq - if (umask(i,j) .eq. 3) then - u(i,j) = u_bdry(i,j) - elseif (umask(i,j) .eq. 0) then - u(i,j) = 0 - endif - - if (vmask(i,j) .eq. 3) then - v(i,j) = v_bdry(i,j) - elseif (vmask(i,j) .eq. 0) then - v(i,j) = 0 - endif - enddo - enddo - - call pass_vector (u,v, G%domain, TO_ALL, BGRID_NE) - - if (conv_flag .eq. 0) then - iters = CS%cg_max_iterations - endif - -end subroutine ice_shelf_solve_inner - -subroutine ice_shelf_advect_thickness_x (CS, time_step, h0, h_after_uflux, flux_enter) - type(ice_shelf_CS), pointer :: CS - real, intent(in) :: time_step - real, dimension(:,:), intent(in) :: h0 - real, dimension(:,:), intent(inout) :: h_after_uflux - real, dimension(:,:,:), intent(inout) :: flux_enter - - ! use will be made of CS%hmask here - its value at the boundary will be zero, just like uncovered cells - - ! if there is an input bdry condition, the thickness there will be set in initialization - - ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary - ! - ! from left neighbor: flux_enter (:,:,1) - ! from right neighbor: flux_enter (:,:,2) - ! from bottom neighbor: flux_enter (:,:,3) - ! from top neighbor: flux_enter (:,:,4) - ! - ! o--- (4) ---o - ! | | - ! (1) (2) - ! | | - ! o--- (3) ---o - ! - - integer :: isym, i, j, is, ie, js, je, isd, ied, jsd, jed, gjed, gied - integer :: i_off, j_off - logical :: at_east_bdry, at_west_bdry, one_off_west_bdry, one_off_east_bdry - type(ocean_grid_type), pointer :: G - real, dimension(-2:2) :: stencil - real, dimension(:,:), pointer :: hmask, u_face_mask, u_flux_boundary_values - real :: u_face, & ! positive if out - flux_diff_cell, phi, dxh, dyh, dxdyh - - character (len=1) :: debug_str, procnum - -! if (CS%grid%symmetric) then -! isym = 1 -! else -! isym = 0 -! endif - - isym = 0 - - G => CS%grid - hmask => CS%hmask - u_face_mask => CS%u_face_mask - u_flux_boundary_values => CS%u_flux_boundary_values - is = G%isc-2 ; ie = G%iec+2 ; js = G%jsc ; je = G%jec ; isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - i_off = G%idg_offset ; j_off = G%jdg_offset - - do j=jsd+1,jed-1 - if (((j+j_off) .le. G%domain%njglobal+G%domain%njhalo) .AND. & - ((j+j_off) .ge. G%domain%njhalo+1)) then ! based on mehmet's code - only if btw north & south boundaries - - stencil(:) = -1 -! if (i+i_off .eq. G%domain%nihalo+G%domain%nihalo) - do i=is,ie - - if (((i+i_off) .le. G%domain%niglobal+G%domain%nihalo) .AND. & - ((i+i_off) .ge. G%domain%nihalo+1)) then - - if (i+i_off .eq. G%domain%nihalo+1) then - at_west_bdry=.true. - else - at_west_bdry=.false. - endif - - if (i+i_off .eq. G%domain%niglobal+G%domain%nihalo) then - at_east_bdry=.true. - else - at_east_bdry=.false. - endif - - if (hmask(i,j) .eq. 1) then - - dxh = G%dxT(i,j) ; dyh = G%dyT(i,j) ; dxdyh = G%areaT(i,j) - - h_after_uflux(i,j) = h0(i,j) - - stencil(:) = h0(i-2:i+2,j) ! fine as long has nx_halo >= 2 - - flux_diff_cell = 0 - - ! 1ST DO LEFT FACE - - if (u_face_mask (i-1,j) .eq. 4.) then - - flux_diff_cell = flux_diff_cell + dyh * time_step * u_flux_boundary_values (i-1,j) / dxdyh - - else - - ! get u-velocity at center of left face - u_face = 0.5 * (CS%u_shelf(i-1,j-1) + CS%u_shelf(i-1,j)) - - ! if (at_west_bdry .and. (i .eq. G%isc)) then - ! print *, j, u_face, stencil(-1) - ! endif - - if (u_face .gt. 0) then !flux is into cell - we need info from h(i-2), h(i-1) if available - - ! i may not cover all the cases.. but i cover the realistic ones - - if (at_west_bdry .AND. (hmask(i-1,j).eq.3)) then ! at western bdry but there is a thickness bdry condition, - ! and the stencil contains it - stencil (-1) = CS%thickness_boundary_values(i-1,j) - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step * stencil(-1) / dxdyh - - elseif (hmask(i-1,j) * hmask(i-2,j) .eq. 1) then ! h(i-2) and h(i-1) are valid - phi = slope_limiter (stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh* time_step / dxdyh * & - (stencil(-1) - phi * (stencil(-1)-stencil(0))/2) - - else ! h(i-1) is valid - ! (o.w. flux would most likely be out of cell) - ! but h(i-2) is not - - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step / dxdyh * stencil(-1) - - endif - - elseif (u_face .lt. 0) then !flux is out of cell - we need info from h(i-1), h(i+1) if available - if (hmask(i-1,j) * hmask(i+1,j) .eq. 1) then ! h(i-1) and h(i+1) are both valid - phi = slope_limiter (stencil(0)-stencil(1), stencil(-1)-stencil(0)) - flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * & - (stencil(0) - phi * (stencil(0)-stencil(-1))/2) - - else - flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * stencil(0) - - if ((hmask(i-1,j) .eq. 0) .OR. (hmask(i-1,j) .eq. 2)) then - flux_enter(i-1,j,2) = ABS(u_face) * dyh * time_step * stencil(0) - endif - endif - endif - endif - - ! NEXT DO RIGHT FACE - - ! get u-velocity at center of right face - - if (u_face_mask (i+1,j) .eq. 4.) then - - flux_diff_cell = flux_diff_cell + dyh * time_step * u_flux_boundary_values (i+1,j) / dxdyh - - else - - u_face = 0.5 * (CS%u_shelf(i,j-1) + CS%u_shelf(i,j)) - - if (u_face .lt. 0) then !flux is into cell - we need info from h(i+2), h(i+1) if available - - if (at_east_bdry .AND. (hmask(i+1,j).eq.3)) then ! at eastern bdry but there is a thickness bdry condition, - ! and the stencil contains it - - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step * stencil(1) / dxdyh - - elseif (hmask(i+1,j) * hmask(i+2,j) .eq. 1) then ! h(i+2) and h(i+1) are valid - - phi = slope_limiter (stencil(1)-stencil(2), stencil(0)-stencil(1)) - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step / dxdyh * & - (stencil(1) - phi * (stencil(1)-stencil(0))/2) - - else ! h(i+1) is valid - ! (o.w. flux would most likely be out of cell) - ! but h(i+2) is not - - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step / dxdyh * stencil(1) - - endif - - elseif (u_face .gt. 0) then !flux is out of cell - we need info from h(i-1), h(i+1) if available - - if (hmask(i-1,j) * hmask(i+1,j) .eq. 1) then ! h(i-1) and h(i+1) are both valid - - phi = slope_limiter (stencil(0)-stencil(-1), stencil(1)-stencil(0)) - flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * & - (stencil(0) - phi * (stencil(0)-stencil(1))/2) - - else ! h(i+1) is valid - ! (o.w. flux would most likely be out of cell) - ! but h(i+2) is not - - flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * stencil(0) - - if ((hmask(i+1,j) .eq. 0) .OR. (hmask(i+1,j) .eq. 2)) then - flux_enter(i+1,j,1) = ABS(u_face) * dyh * time_step * stencil(0) - endif - - endif - - endif - - h_after_uflux(i,j) = h_after_uflux(i,j) + flux_diff_cell - - endif - - elseif ((hmask(i,j) .eq. 0) .OR. (hmask(i,j) .eq. 2)) then - - if (at_west_bdry .AND. (hmask(i-1,j) .EQ. 3)) then - u_face = 0.5 * (CS%u_shelf(i-1,j-1) + CS%u_shelf(i-1,j)) - flux_enter (i,j,1) = ABS(u_face) * G%dyT(i,j) * time_step * CS%thickness_boundary_values(i-1,j) - elseif (u_face_mask (i-1,j) .eq. 4.) then - flux_enter (i,j,1) = G%dyT(i,j) * time_step * u_flux_boundary_values (i-1,j) - endif - - if (at_east_bdry .AND. (hmask(i+1,j) .EQ. 3)) then - u_face = 0.5 * (CS%u_shelf(i,j-1) + CS%u_shelf(i,j)) - flux_enter(i,j,2) = ABS(u_face) * G%dyT(i,j) * time_step * CS%thickness_boundary_values(i+1,j) - elseif (u_face_mask (i+1,j) .eq. 4.) then - flux_enter (i,j,2) = G%dyT(i,j) * time_step * u_flux_boundary_values (i+1,j) - endif - - if ((i .eq. is) .AND. (hmask(i,j) .eq. 0) .AND. (hmask(i-1,j) .eq. 1)) then - ! this is solely for the purposes of keeping the mask consistent while advancing the front without having - ! to call pass_var - if cell is empty and cell to left is ice-covered then this cell will become partly covered - - hmask(i,j) = 2 - elseif ((i .eq. ie) .AND. (hmask(i,j) .eq. 0) .AND. (hmask(i+1,j) .eq. 1)) then - ! this is solely for the purposes of keeping the mask consistent while advancing the front without having - ! to call pass_var - if cell is empty and cell to left is ice-covered then this cell will become partly covered - - hmask(i,j) = 2 - - endif - - endif - - endif - - enddo ! i loop - - endif - - enddo ! j loop - -! write (procnum,'(I1)') mpp_pe() - -end subroutine ice_shelf_advect_thickness_x - -subroutine ice_shelf_advect_thickness_y (CS, time_step, h_after_uflux, h_after_vflux, flux_enter) - type(ice_shelf_CS), pointer :: CS - real, intent(in) :: time_step - real, dimension(:,:), intent(in) :: h_after_uflux - real, dimension(:,:), intent(inout) :: h_after_vflux - real, dimension(:,:,:), intent(inout) :: flux_enter - - ! use will be made of CS%hmask here - its value at the boundary will be zero, just like uncovered cells - - ! if there is an input bdry condition, the thickness there will be set in initialization - - ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary - ! - ! from left neighbor: flux_enter (:,:,1) - ! from right neighbor: flux_enter (:,:,2) - ! from bottom neighbor: flux_enter (:,:,3) - ! from top neighbor: flux_enter (:,:,4) - ! - ! o--- (4) ---o - ! | | - ! (1) (2) - ! | | - ! o--- (3) ---o - ! - - integer :: isym, i, j, is, ie, js, je, isd, ied, jsd, jed, gjed, gied - integer :: i_off, j_off - logical :: at_north_bdry, at_south_bdry, one_off_west_bdry, one_off_east_bdry - type(ocean_grid_type), pointer :: G - real, dimension(-2:2) :: stencil - real, dimension(:,:), pointer :: hmask, v_face_mask, v_flux_boundary_values - real :: v_face, & ! positive if out - flux_diff_cell, phi, dxh, dyh, dxdyh - character(len=1) :: debug_str, procnum - -! if (CS%grid%symmetric) then -! isym = 1 -! else -! isym = 0 -! endif - - isym = 0 - - G => CS%grid - hmask => CS%hmask - v_face_mask => CS%v_face_mask - v_flux_boundary_values => CS%v_flux_boundary_values - is = G%isc ; ie = G%iec ; js = G%jsc-1 ; je = G%jec+1 ; isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - i_off = G%idg_offset ; j_off = G%jdg_offset - - do i=isd+2,ied-2 - if (((i+i_off) .le. G%domain%niglobal+G%domain%nihalo) .AND. & - ((i+i_off) .ge. G%domain%nihalo+1)) then ! based on mehmet's code - only if btw east & west boundaries - - stencil(:) = -1 - - do j=js,je - - if (((j+j_off) .le. G%domain%njglobal+G%domain%njhalo) .AND. & - ((j+j_off) .ge. G%domain%njhalo+1)) then - - if (j+j_off .eq. G%domain%njhalo+1) then - at_south_bdry=.true. - else - at_south_bdry=.false. - endif - - if (j+j_off .eq. G%domain%njglobal+G%domain%njhalo) then - at_north_bdry=.true. - else - at_north_bdry=.false. - endif - - if (hmask(i,j) .eq. 1) then - dxh = G%dxT(i,j) ; dyh = G%dyT(i,j) ; dxdyh = G%areaT(i,j) - h_after_vflux (i,j) = h_after_uflux (i,j) - - stencil (:) = h_after_uflux (i,j-2:j+2) ! fine as long has ny_halo >= 2 - flux_diff_cell = 0 - - ! 1ST DO south FACE - - if (v_face_mask (i,j-1) .eq. 4.) then - - flux_diff_cell = flux_diff_cell + dxh * time_step * v_flux_boundary_values (i,j-1) / dxdyh - - else - - ! get u-velocity at center of left face - v_face = 0.5 * (CS%v_shelf(i-1,j-1) + CS%v_shelf(i,j-1)) - - if (v_face .gt. 0) then !flux is into cell - we need info from h(j-2), h(j-1) if available - - ! i may not cover all the cases.. but i cover the realistic ones - - if (at_south_bdry .AND. (hmask(i,j-1).eq.3)) then ! at western bdry but there is a thickness bdry condition, - ! and the stencil contains it - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step * stencil(-1) / dxdyh - - elseif (hmask(i,j-1) * hmask(i,j-2) .eq. 1) then ! h(j-2) and h(j-1) are valid - - phi = slope_limiter (stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * & - (stencil(-1) - phi * (stencil(-1)-stencil(0))/2) - - else ! h(j-1) is valid - ! (o.w. flux would most likely be out of cell) - ! but h(j-2) is not - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * stencil(-1) - endif - - elseif (v_face .lt. 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available - - if (hmask(i,j-1) * hmask(i,j+1) .eq. 1) then ! h(j-1) and h(j+1) are both valid - phi = slope_limiter (stencil(0)-stencil(1), stencil(-1)-stencil(0)) - flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * & - (stencil(0) - phi * (stencil(0)-stencil(-1))/2) - else - flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * stencil(0) - - if ((hmask(i,j-1) .eq. 0) .OR. (hmask(i,j-1) .eq. 2)) then - flux_enter(i,j-1,4) = ABS(v_face) * dyh * time_step * stencil(0) - endif - - endif - - endif - - endif - - ! NEXT DO north FACE - - if (v_face_mask(i,j+1) .eq. 4.) then - - flux_diff_cell = flux_diff_cell + dxh * time_step * v_flux_boundary_values (i,j+1) / dxdyh - - else - - ! get u-velocity at center of right face - v_face = 0.5 * (CS%v_shelf(i-1,j) + CS%v_shelf(i,j)) - - if (v_face .lt. 0) then !flux is into cell - we need info from h(j+2), h(j+1) if available - - if (at_north_bdry .AND. (hmask(i,j+1).eq.3)) then ! at eastern bdry but there is a thickness bdry condition, - ! and the stencil contains it - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step * stencil(1) / dxdyh - elseif (hmask(i,j+1) * hmask(i,j+2) .eq. 1) then ! h(j+2) and h(j+1) are valid - phi = slope_limiter (stencil(1)-stencil(2), stencil(0)-stencil(1)) - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * & - (stencil(1) - phi * (stencil(1)-stencil(0))/2) - else ! h(j+1) is valid - ! (o.w. flux would most likely be out of cell) - ! but h(j+2) is not - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * stencil(1) - endif - - elseif (v_face .gt. 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available - - if (hmask(i,j-1) * hmask(i,j+1) .eq. 1) then ! h(j-1) and h(j+1) are both valid - phi = slope_limiter (stencil(0)-stencil(-1), stencil(1)-stencil(0)) - flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * & - (stencil(0) - phi * (stencil(0)-stencil(1))/2) - else ! h(j+1) is valid - ! (o.w. flux would most likely be out of cell) - ! but h(j+2) is not - flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * stencil(0) - if ((hmask(i,j+1) .eq. 0) .OR. (hmask(i,j+1) .eq. 2)) then - flux_enter(i,j+1,3) = ABS(v_face) * dxh * time_step * stencil(0) - endif - endif - - endif - - endif - - h_after_vflux (i,j) = h_after_vflux (i,j) + flux_diff_cell - - elseif ((hmask(i,j) .eq. 0) .OR. (hmask(i,j) .eq. 2)) then - - if (at_south_bdry .AND. (hmask(i,j-1) .EQ. 3)) then - v_face = 0.5 * (CS%u_shelf(i-1,j-1) + CS%u_shelf(i,j-1)) - flux_enter (i,j,3) = ABS(v_face) * G%dxT(i,j) * time_step * CS%thickness_boundary_values(i,j-1) - elseif (v_face_mask(i,j-1) .eq. 4.) then - flux_enter (i,j,3) = G%dxT(i,j) * time_step * v_flux_boundary_values (i,j-1) - endif - - if (at_north_bdry .AND. (hmask(i,j+1) .EQ. 3)) then - v_face = 0.5 * (CS%u_shelf(i-1,j) + CS%u_shelf(i,j)) - flux_enter (i,j,4) = ABS(v_face) * G%dxT(i,j) * time_step * CS%thickness_boundary_values(i,j+1) - elseif (v_face_mask(i,j+1) .eq. 4.) then - flux_enter (i,j,4) = G%dxT(i,j) * time_step * v_flux_boundary_values (i,j+1) - endif - - if ((j .eq. js) .AND. (hmask(i,j) .eq. 0) .AND. (hmask(i,j-1) .eq. 1)) then - ! this is solely for the purposes of keeping the mask consistent while advancing the front without having - ! to call pass_var - if cell is empty and cell to left is ice-covered then this cell will become partly covered - hmask (i,j) = 2 - elseif ((j .eq. je) .AND. (hmask(i,j) .eq. 0) .AND. (hmask(i,j+1) .eq. 1)) then - ! this is solely for the purposes of keeping the mask consistent while advancing the front without having - ! to call pass_var - if cell is empty and cell to left is ice-covered then this cell will become partly covered - hmask (i,j) = 2 - endif - - endif - endif - enddo ! j loop - endif - enddo ! i loop - - !write (procnum,'(I1)') mpp_pe() - -end subroutine ice_shelf_advect_thickness_y - -subroutine shelf_advance_front (CS, flux_enter) - type(ice_shelf_CS), pointer :: CS - real, dimension(:,:,:), intent(inout) :: flux_enter - - ! in this subroutine we go through the computational cells only and, if they are empty or partial cells, - ! we find the reference thickness and update the shelf mass and partial area fraction and the hmask if necessary - - ! if any cells go from partial to complete, we then must set the thickness, update hmask accordingly, - ! and divide the overflow across the adjacent EMPTY (not partly-covered) cells. - ! (it is highly unlikely there will not be any; in which case this will need to be rethought.) - - ! most likely there will only be one "overflow". if not, though, a pass_var of all relevant variables - ! is done; there will therefore be a loop which, in practice, will hopefully not have to go through - ! many iterations - - ! when 3d advected scalars are introduced, they will be impacted by what is done here - - ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary - ! - ! from left neighbor: flux_enter (:,:,1) - ! from right neighbor: flux_enter (:,:,2) - ! from bottom neighbor: flux_enter (:,:,3) - ! from top neighbor: flux_enter (:,:,4) - ! - ! o--- (4) ---o - ! | | - ! (1) (2) - ! | | - ! o--- (3) ---o - ! - - integer :: i, j, isc, iec, jsc, jec, n_flux, k, l, iter_count, isym - integer :: i_off, j_off - integer :: iter_flag - type(ocean_grid_type), pointer :: G - real, dimension(:,:), pointer :: hmask, mass_shelf, area_shelf_h, u_face_mask, v_face_mask, h_shelf - real :: h_reference, dxh, dyh, dxdyh, rho, partial_vol, tot_flux - integer, dimension(4) :: mapi, mapj, new_partial -! real, dimension(size(flux_enter,1),size(flux_enter,2),size(flux_enter,2)) :: flux_enter_replace - real, dimension (:,:,:), pointer :: flux_enter_replace => NULL() - - G => CS%grid - h_shelf => CS%h_shelf - hmask => CS%hmask - mass_shelf => CS%mass_shelf - area_shelf_h => CS%area_shelf_h - u_face_mask => CS%u_face_mask - v_face_mask => CS%v_face_mask - isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec - i_off = G%idg_offset ; j_off = G%jdg_offset - rho = CS%density_ice - iter_count = 0 ; iter_flag = 1 - -! if (G%symmetric) then -! isym = 1 -! else -! isym = 0 -! endif - - isym = 0 - - mapi(1) = -1 ; mapi(2) = 1 ; mapi(3:4) = 0 - mapj(3) = -1 ; mapj(4) = 1 ; mapj(1:2) = 0 - - do while (iter_flag .eq. 1) - - iter_flag = 0 - - if (iter_count .gt. 0) then - flux_enter (:,:,:) = flux_enter_replace(:,:,:) - flux_enter_replace (:,:,:) = 0.0 - endif - - iter_count = iter_count + 1 - - ! if iter_count .ge. 3 then some halo updates need to be done... - - - - do j=jsc-1,jec+1 - - if (((j+j_off) .le. G%domain%njglobal+G%domain%njhalo) .AND. & - ((j+j_off) .ge. G%domain%njhalo+1)) then - - do i=isc-1,iec+1 - - if (((i+i_off) .le. G%domain%niglobal+G%domain%nihalo) .AND. & - ((i+i_off) .ge. G%domain%nihalo+1)) then - ! first get reference thickness by averaging over cells that are fluxing into this cell - n_flux = 0 - h_reference = 0.0 - tot_flux = 0.0 - - do k=1,2 - if (flux_enter(i,j,k) .gt. 0) then - n_flux = n_flux + 1 - h_reference = h_reference + h_shelf(i+2*k-3,j) - tot_flux = tot_flux + flux_enter(i,j,k) - flux_enter(i,j,k) = 0.0 - endif - enddo - - do k=1,2 - if (flux_enter(i,j,k+2) .gt. 0) then - n_flux = n_flux + 1 - h_reference = h_reference + h_shelf (i,j+2*k-3) - tot_flux = tot_flux + flux_enter(i,j,k+2) - flux_enter (i,j,k+2) = 0.0 - endif - enddo - - if (n_flux .gt. 0) then - dxdyh = G%areaT(i,j) - h_reference = h_reference / real(n_flux) - partial_vol = h_shelf (i,j) * area_shelf_h (i,j) + tot_flux - - if ((partial_vol / dxdyh) .eq. h_reference) then ! cell is exactly covered, no overflow - hmask (i,j) = 1 - h_shelf (i,j) = h_reference - area_shelf_h(i,j) = dxdyh - elseif ((partial_vol / dxdyh) .lt. h_reference) then - hmask (i,j) = 2 - ! mass_shelf (i,j) = partial_vol * rho - area_shelf_h (i,j) = partial_vol / h_reference - h_shelf (i,j) = h_reference - else - if (.not. associated (flux_enter_replace)) then - allocate ( flux_enter_replace (G%isd:G%ied,G%jsd:G%jed,1:4) ) - flux_enter_replace (:,:,:) = 0.0 - endif - - hmask (i,j) = 1 - area_shelf_h(i,j) = dxdyh - !h_temp (i,j) = h_reference - partial_vol = partial_vol - h_reference * dxdyh - - iter_flag = 1 - - n_flux = 0 ; new_partial (:) = 0 - - do k=1,2 - if (u_face_mask (i-2+k,j) .eq. 2) then - n_flux = n_flux + 1 - elseif (hmask (i+2*k-3,j) .eq. 0) then - n_flux = n_flux + 1 - new_partial (k) = 1 - endif - enddo - do k=1,2 - if (v_face_mask (i,j-2+k) .eq. 2) then - n_flux = n_flux + 1 - elseif (hmask (i,j+2*k-3) .eq. 0) then - n_flux = n_flux + 1 - new_partial (k+2) = 1 - endif - enddo - - if (n_flux .eq. 0) then ! there is nowhere to put the extra ice! - h_shelf(i,j) = h_reference + partial_vol / dxdyh - else - h_shelf(i,j) = h_reference - - do k=1,2 - if (new_partial(k) .eq. 1) & - flux_enter_replace (i+2*k-3,j,3-k) = partial_vol / real(n_flux) - enddo - do k=1,2 ! ### Combine these two loops? - if (new_partial(k+2) .eq. 1) & - flux_enter_replace(i,j+2*k-3,5-k) = partial_vol / real(n_flux) - enddo - endif - - endif ! Parital_vol test. - endif ! n_flux gt 0 test. - - endif - enddo ! j-loop - endif - enddo - - ! call mpp_max(iter_flag) - - enddo ! End of do while(iter_flag) loop - - call mpp_max(iter_count) - - if(is_root_pe() .and. (iter_count.gt.1)) print *, iter_count, "MAX ITERATIONS,ADVANCE FRONT" - - if (associated(flux_enter_replace)) deallocate(flux_enter_replace) - -end subroutine shelf_advance_front - -!> Apply a very simple calving law using a minimum thickness rule -subroutine ice_shelf_min_thickness_calve (CS, h_shelf, area_shelf_h,hmask) - type(ice_shelf_CS), pointer :: CS - real, dimension(:,:), intent(inout) :: h_shelf, area_shelf_h, hmask - type(ocean_grid_type), pointer :: G - integer :: i,j - - G => CS%grid - - do j=G%jsd,G%jed - do i=G%isd,G%ied -! if ((h_shelf(i,j) .lt. CS%min_thickness_simple_calve) .and. (hmask(i,j).eq.1) .and. & -! (CS%float_frac(i,j) .eq. 0.0)) then - if ((h_shelf(i,j) .lt. CS%min_thickness_simple_calve) .and. (area_shelf_h(i,j).gt. 0.)) then - h_shelf(i,j) = 0.0 - area_shelf_h(i,j) = 0.0 - hmask(i,j) = 0.0 - endif - enddo - enddo - -end subroutine ice_shelf_min_thickness_calve - -subroutine calve_to_mask (CS, h_shelf, area_shelf_h, hmask, calve_mask) - type(ice_shelf_CS), pointer :: CS - real, dimension(:,:), intent(inout) :: h_shelf, area_shelf_h, hmask, calve_mask - - type(ocean_grid_type), pointer :: G - integer :: i,j - - G => CS%grid - - if (CS%calve_to_mask) then - do j=G%jsc,G%jec - do i=G%isc,G%iec - if ((calve_mask(i,j) .eq. 0.0) .and. (hmask(i,j) .ne. 0.0)) then - h_shelf(i,j) = 0.0 - area_shelf_h(i,j) = 0.0 - hmask(i,j) = 0.0 - endif - enddo - enddo - endif - -end subroutine calve_to_mask - -subroutine calc_shelf_driving_stress (CS, TAUD_X, TAUD_Y, OD, FE) - type(ice_shelf_CS), pointer :: CS - real, dimension(:,:), intent(in) :: OD - real, dimension(NILIMB_SYM_,NJLIMB_SYM_), intent(inout) :: TAUD_X, TAUD_Y - integer, intent(in) :: FE - -! driving stress! - -! ! TAUD_X and TAUD_Y will hold driving stress in the x- and y- directions when done. -! they will sit on the BGrid, and so their size depends on whether the grid is symmetric -! -! Since this is a finite element solve, they will actually have the form \int \phi_i rho g h \nabla s -! -! OD -this is important and we do not yet know where (in MOM) it will come from. It represents -! "average" ocean depth -- and is needed to find surface elevation -! (it is assumed that base_ice = bed + OD) - -! FE : 1 if bilinear, 2 if triangular linear FE - - real, dimension (:,:), pointer :: D, & ! ocean floor depth - H, & ! ice shelf thickness - hmask, u_face_mask, v_face_mask, float_frac - real, dimension (SIZE(OD,1),SIZE(OD,2)) :: S, & ! surface elevation - BASE ! basal elevation of shelf/stream - character(1) :: procnum - - - real :: rho, rhow, sx, sy, neumann_val, dxh, dyh, dxdyh - - type(ocean_grid_type), pointer :: G - integer :: isym, i, j, iscq, iecq, jscq, jecq, isd, jsd, is, js, iegq, jegq, giec, gjec, gisc, gjsc, cnt, isc, jsc, iec, jec - integer :: i_off, j_off - - G => CS%grid - - isym = 0 - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB - isd = G%isd ; jsd = G%jsd - iegq = G%iegB ; jegq = G%jegB - gisc = G%domain%nihalo+1 ; gjsc = G%domain%njhalo+1 - giec = G%domain%niglobal+G%domain%nihalo ; gjec = G%domain%njglobal+G%domain%njhalo - is = iscq - (1-isym); js = jscq - (1-isym) - i_off = G%idg_offset ; j_off = G%jdg_offset - - D => G%bathyT - H => CS%h_shelf - float_frac => CS%float_frac - hmask => CS%hmask - u_face_mask => CS%u_face_mask - v_face_mask => CS%v_face_mask - rho = CS%density_ice - rhow = CS%density_ocean_avg - - call savearray2 ("H",H,CS%write_output_to_file) -! call savearray2 ("hmask",hmask,CS%write_output_to_file) - call savearray2 ("u_face_mask", CS%u_face_mask_boundary,CS%write_output_to_file) - call savearray2 ("umask", CS%umask,CS%write_output_to_file) - call savearray2 ("v_face_mask", CS%v_face_mask_boundary,CS%write_output_to_file) - call savearray2 ("vmask", CS%vmask,CS%write_output_to_file) - -! if (G%symmetric) then -! isym=1 -! else -! isym=0 -! endif - - isym = 0 - - ! prelim - go through and calculate S - - ! or is this faster? - BASE(:,:) = -D(:,:) + OD(:,:) - S(:,:) = BASE(:,:) + H(:,:) - -! write (procnum,'(I1)') mpp_pe() - - do j=jsc-1,jec+1 - do i=isc-1,iec+1 - cnt = 0 - sx = 0 - sy = 0 - dxh = G%dxT(i,j) - dyh = G%dyT(i,j) - dxdyh = G%areaT(i,j) -! print *,dxh," ",dyh," ",dxdyh - - if (hmask(i,j) .eq. 1) then ! we are inside the global computational bdry, at an ice-filled cell - - ! calculate sx - if ((i+i_off) .eq. gisc) then ! at left computational bdry - if (hmask(i+1,j) .eq. 1) then - sx = (S(i+1,j)-S(i,j))/dxh - else - sx = 0 - endif - elseif ((i+i_off) .eq. giec) then ! at right computational bdry - if (hmask(i-1,j) .eq. 1) then - sx = (S(i,j)-S(i-1,j))/dxh - else - sx=0 - endif - else ! interior - if (hmask(i+1,j) .eq. 1) then - cnt = cnt+1 - sx = S(i+1,j) - else - sx = S(i,j) - endif - if (hmask(i-1,j) .eq. 1) then - cnt = cnt+1 - sx = sx - S(i-1,j) - else - sx = sx - S(i,j) - endif - if (cnt .eq. 0) then - sx=0 - else - sx = sx / (cnt * dxh) - endif - endif - - cnt = 0 - - ! calculate sy, similarly - if ((j+j_off) .eq. gjsc) then ! at south computational bdry - if (hmask(i,j+1) .eq. 1) then - sy = (S(i,j+1)-S(i,j))/dyh - else - sy = 0 - endif - elseif ((j+j_off) .eq. gjec) then ! at nprth computational bdry - if (hmask(i,j-1) .eq. 1) then - sy = (S(i,j)-S(i,j-1))/dyh - else - sy = 0 - endif - else ! interior - if (hmask(i,j+1) .eq. 1) then - cnt = cnt+1 - sy = S(i,j+1) - else - sy = S(i,j) - endif - if (hmask(i,j-1) .eq. 1) then - cnt = cnt+1 - sy = sy - S(i,j-1) - else - sy = sy - S(i,j) - endif - if (cnt .eq. 0) then - sy=0 - else - sy = sy / (cnt * dyh) - endif - endif - - - if (FE .eq. 1) then - - ! SW vertex - taud_x (i-1,j-1) = taud_x (i-1,j-1) - .25 * rho * grav * H(i,j) * sx * dxdyh - taud_y(i-1,j-1) = taud_y(i-1,j-1) - .25 * rho * grav * H(i,j) * sy * dxdyh - - ! SE vertex - taud_x(i,j-1) = taud_x(i,j-1) - .25 * rho * grav * H(i,j) * sx * dxdyh - taud_y(i,j-1) = taud_y(i,j-1) - .25 * rho * grav * H(i,j) * sy * dxdyh - - ! NW vertex - taud_x(i-1,j) = taud_x(i-1,j) - .25 * rho * grav * H(i,j) * sx * dxdyh - taud_y(i-1,j) = taud_y(i-1,j) - .25 * rho * grav * H(i,j) * sy * dxdyh - - ! NE vertex - taud_x(i,j) = taud_x(i,j) - .25 * rho * grav * H(i,j) * sx * dxdyh - taud_y(i,j) = taud_y(i,j) - .25 * rho * grav * H(i,j) * sy * dxdyh - - - else - - ! SW vertex - taud_x(i-1,j-1) = taud_x(i-1,j-1) - (1./6) * rho * grav * H(i,j) * sx * dxdyh - taud_y(i-1,j-1) = taud_y(i-1,j-1) - (1./6) * rho * grav * H(i,j) * sy * dxdyh - - ! SE vertex - taud_x(i,j-1) = taud_x(i,j-1) - (1./3) * rho * grav * H(i,j) * sx * dxdyh - taud_y(i,j-1) = taud_y(i,j-1) - (1./3) * rho * grav * H(i,j) * sy * dxdyh - - ! NW vertex - taud_x(i-1,j) = taud_x(i-1,j) - (1./3) * rho * grav * H(i,j) * sx * dxdyh - taud_y(i-1,j) = taud_y(i-1,j) - (1./3) * rho * grav * H(i,j) * sy * dxdyh - - ! NE vertex - taud_x(i,j) = taud_x(i,j) - (1./6) * rho * grav * H(i,j) * sx * dxdyh - taud_y(i,j) = taud_y(i,j) - (1./6) * rho * grav * H(i,j) * sy * dxdyh - - endif - - if (float_frac(i,j) .eq. 1) then - neumann_val = .5 * grav * (rho * H (i,j) ** 2 - rhow * D(i,j) ** 2) - else - neumann_val = .5 * grav * (1-rho/rhow) * rho * H(i,j) ** 2 - endif - - - if ((u_face_mask(i-1,j) .eq. 2) .OR. (hmask(i-1,j) .eq. 0) .OR. (hmask(i-1,j) .eq. 2) ) then ! left face of the cell is at a stress boundary - ! the depth-integrated longitudinal stress is equal to the difference of depth-integrated pressure on either side of the face - ! on the ice side, it is rho g h^2 / 2 - ! on the ocean side, it is rhow g (delta OD)^2 / 2 - ! OD can be zero under the ice; but it is ASSUMED on the ice-free side of the face, topography elevation is not above the base of the - ! ice in the current cell - taud_x(i-1,j-1) = taud_x(i-1,j-1) - .5 * dyh * neumann_val ! note negative sign is due to direction of normal vector - taud_x(i-1,j) = taud_x(i-1,j) - .5 * dyh * neumann_val - endif - - if ((u_face_mask(i,j) .eq. 2) .OR. (hmask(i+1,j) .eq. 0) .OR. (hmask(i+1,j) .eq. 2) ) then ! right face of the cell is at a stress boundary - taud_x(i,j-1) = taud_x(i,j-1) + .5 * dyh * neumann_val - taud_x(i,j) = taud_x(i,j) + .5 * dyh * neumann_val - endif - - if ((v_face_mask(i,j-1) .eq. 2) .OR. (hmask(i,j-1) .eq. 0) .OR. (hmask(i,j-1) .eq. 2) ) then ! south face of the cell is at a stress boundary - taud_y(i-1,j-1) = taud_y(i-1,j-1) - .5 * dxh * neumann_val - taud_y(i,j-1) = taud_y(i,j-1) - .5 * dxh * neumann_val - endif - - if ((v_face_mask(i,j) .eq. 2) .OR. (hmask(i,j+1) .eq. 0) .OR. (hmask(i,j+1) .eq. 2) ) then ! north face of the cell is at a stress boundary - taud_y(i-1,j) = taud_y(i-1,j) + .5 * dxh * neumann_val ! note negative sign is due to direction of normal vector - taud_y(i,j) = taud_y(i,j) + .5 * dxh * neumann_val - endif - - endif - enddo - enddo - - -! call savearray2 ("Taux"//"p"//procnum,taud_x,CS%write_output_to_file) -! call savearray2 ("Tauy"//"p"//procnum,taud_y,CS%write_output_to_file) - -end subroutine calc_shelf_driving_stress - -subroutine init_boundary_values (CS, time, input_flux, input_thick, new_sim) - type(time_type), intent(in) :: Time - type(ice_shelf_CS), pointer :: CS - real, intent(in) :: input_flux, input_thick - logical, optional :: new_sim - -! this will be a per-setup function. the boundary values of thickness and velocity -! (and possibly other variables) will be updated in this function - -! FOR RESTARTING PURPOSES: if grid is not symmetric and the model is restarted, we will -! need to update those velocity points not *technically* in any -! computational domain -- if this function gets moves to another module, -! DO NOT TAKE THE RESTARTING BIT WITH IT - - real, dimension (:,:) , pointer :: thickness_boundary_values, & - u_boundary_values, & - v_boundary_values, & - u_face_mask, v_face_mask, hmask - type(ocean_grid_type), pointer :: G - integer :: isym, i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, iegq, jegq, giec, gjec, gisc, gjsc, cnt, isc, jsc, iec, jec - integer :: i_off, j_off - real :: A, n, ux, uy, vx, vy, eps_min, domain_width - - G => CS%grid - -! if (G%symmetric) then -! isym=1 -! else -! isym=0 -! endif - - isym = 0 - - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec -! iscq = G%iscq ; iecq = G%iecq ; jscq = G%jscq ; jecq = G%jecq - isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed -! iegq = G%iegq ; jegq = G%jegq - i_off = G%idg_offset ; j_off = G%jdg_offset - - thickness_boundary_values => CS%thickness_boundary_values - u_boundary_values => CS%u_boundary_values ; v_boundary_values => CS%v_boundary_values - u_face_mask => CS%u_face_mask ; v_face_mask => CS%v_face_mask ; hmask => CS%hmask - - domain_width = CS%len_lat - - ! this loop results in some values being set twice but... eh. - - do j=jsd,jed - do i=isd,ied - -! if ((i .eq. 4) .AND. ((mpp_pe() .eq. 0) .or. (mpp_pe() .eq. 6))) then -! print *,hmask(i,j),i,j,mpp_pe() -! endif - - if (hmask(i,j) .eq. 3) then - thickness_boundary_values (i,j) = input_thick - endif - - if ((hmask(i,j) .eq. 0) .or. (hmask(i,j) .eq. 1) .or. (hmask(i,j) .eq. 2)) then - if ((i.le.iec).and.(i.ge.isc)) then - if (u_face_mask (i-1,j) .eq. 3) then - u_boundary_values (i-1,j-1) = (1 - ((G%geoLatBu(i-1,j-1) - 0.5*CS%len_lat)*2./CS%len_lat)**2) * & - 1.5 * input_flux / input_thick - u_boundary_values (i-1,j) = (1 - ((G%geoLatBu(i-1,j) - 0.5*CS%len_lat)*2./CS%len_lat)**2) * & - 1.5 * input_flux / input_thick - endif - endif - endif - - if (.not.(new_sim)) then - if (.not. G%symmetric) then - if (((i+i_off) .eq. (G%domain%nihalo+1)).and.(u_face_mask(i-1,j).eq.3)) then - CS%u_shelf (i-1,j-1) = u_boundary_values (i-1,j-1) - CS%u_shelf (i-1,j) = u_boundary_values (i-1,j) -! print *, u_boundary_values (i-1,j) - endif - if (((j+j_off) .eq. (G%domain%njhalo+1)).and.(v_face_mask(i,j-1).eq.3)) then - CS%u_shelf (i-1,j-1) = u_boundary_values (i-1,j-1) - CS%u_shelf (i,j-1) = u_boundary_values (i,j-1) - endif - endif - endif - enddo - enddo - -end subroutine init_boundary_values - -subroutine CG_action_triangular (uret, vret, u, v, umask, vmask, hmask, nu_upper, nu_lower, & - beta_upper, beta_lower, dxh, dyh, dxdyh, is, ie, js, je, isym) - -real, dimension (:,:), intent (inout) :: uret, vret -real, dimension (:,:), intent (in) :: u, v -real, dimension (:,:), intent (in) :: umask, vmask -real, dimension (:,:), intent (in) :: hmask, nu_upper, nu_lower, beta_upper, beta_lower -real, dimension (:,:), intent (in) :: dxh, dyh, dxdyh -integer, intent(in) :: is, ie, js, je, isym - -! the linear action of the matrix on (u,v) with triangular finite elements -! as of now everything is passed in so no grid pointers or anything of the sort have to be dereferenced, -! but this may change pursuant to conversations with others -! -! is & ie are the cells over which the iteration is done; this may change between calls to this subroutine -! in order to make less frequent halo updates -! isym = 1 if grid is symmetric, 0 o.w. - - real :: ux, uy, vx, vy - integer :: i,j - - do i=is,ie - do j=js,je - - if (hmask(i,j) .eq. 1) then ! this cell's vertices contain degrees of freedom - - ux = (u(i,j-1)-u(i-1,j-1))/dxh(i,j) - vx = (v(i,j-1)-v(i-1,j-1))/dxh(i,j) - uy = (u(i-1,j)-u(i-1,j-1))/dyh(i,j) - vy = (v(i-1,j)-v(i-1,j-1))/dyh(i,j) - - if (umask(i,j-1) .eq. 1) then ! this (bot right) is a degree of freedom node - - uret(i,j-1) = uret(i,j-1) + & - .5 * dxdyh(i,j) * nu_lower (i,j) * ((4*ux+2*vy) * (1./dxh(i,j)) + (uy+vy) * (0./dyh(i,j))) - - vret(i,j-1) = vret(i,j-1) + & - .5 * dxdyh(i,j) * nu_lower (i,j) * ((uy+vx) * (1./dxh(i,j)) + (4*vy+2*ux) * (0./dyh(i,j))) - - uret(i,j-1) = uret(i,j-1) + & - beta_lower(i,j) * dxdyh(i,j) * 1./24 * (u(i-1,j-1) + & - u(i-1,j) + u(i,j-1)) - - vret(i,j-1) = vret(i,j-1) + & - beta_lower(i,j) * dxdyh(i,j) * 1./24 * (v(i-1,j-1) + & - v(i-1,j) + v(i,j-1)) - endif - - if (umask(i-1,j) .eq. 1) then ! this (top left) is a degree of freedom node - - uret(i-1,j) = uret(i-1,j) + & - .5 * dxdyh(i,j) * nu_lower (i,j) * ((4*ux+2*vy) * (0./dxh(i,j)) + (uy+vy) * (1./dyh(i,j))) - - vret(i-1,j) = vret(i-1,j) + & - .5 * dxdyh(i,j) * nu_lower (i,j) * ((uy+vx) * (0./dxh(i,j)) + (4*vy+2*ux) * (1./dyh(i,j))) - - uret(i,j-1) = uret(i,j-1) + & - beta_lower(i,j) * dxdyh(i,j) * 1./24 * (u(i-1,j-1) + & - u(i-1,j) + u(i,j-1)) - - vret(i,j-1) = vret(i,j-1) + & - beta_lower(i,j) * dxdyh(i,j) * 1./24 * (v(i-1,j-1) + & - v(i-1,j) + v(i,j-1)) - endif - - if (umask(i-1,j-1) .eq. 1) then ! this (bot left) is a degree of freedom node - - uret(i-1,j-1) = uret(i-1,j-1) + & - .5 * dxdyh(i,j) * nu_upper (i,j) * ((4*ux+2*vy) * (-1./dxh(i,j)) + (uy+vy) * (-1./dyh(i,j))) - - vret(i-1,j-1) = vret(i-1,j-1) + & - .5 * dxdyh(i,j) * nu_upper (i,j) * ((uy+vx) * (-1./dxh(i,j)) + (4*vy+2*ux) * (-1./dyh(i,j))) - - uret(i-1,j-1) = uret(i-1,j-1) + & - beta_lower(i,j) * dxdyh(i,j) * 1./24 * (u(i-1,j-1) + & - u(i-1,j) + u(i,j-1)) - - vret(i-1,j-1) = vret(i-1,j-1) + & - beta_lower(i,j) * dxdyh(i,j) * 1./24 * (v(i-1,j-1) + & - v(i-1,j) + v(i,j-1)) - endif - - - ux = (u(i,j)-u(i-1,j))/dxh(i,j) - vx = (v(i,j)-v(i-1,j))/dxh(i,j) - uy = (u(i,j)-u(i,j-1))/dyh(i,j) - vy = (v(i,j)-v(i,j-1))/dyh(i,j) - - if (umask(i,j-1) .eq. 1) then ! this (bot right) is a degree of freedom node - - uret(i,j-1) = uret(i,j-1) + & - .5 * dxdyh(i,j) * nu_upper (i,j) * ((4*ux+2*vy) * (0./dxh(i,j)) + (uy+vy) * (-1./dyh(i,j))) - - vret(i,j-1) = vret(i,j-1) + & - .5 * dxdyh(i,j) * nu_upper (i,j) * ((uy+vx) * (0./dxh(i,j)) + (4*vy+2*ux) * (-1./dyh(i,j))) - - uret(i,j-1) = uret(i,j-1) + & - beta_upper(i,j) * dxdyh(i,j) * 1./24 * (u(i,j) + & - u(i-1,j) + u(i,j-1)) - - vret(i,j-1) = vret(i,j-1) + & - beta_upper(i,j) * dxdyh(i,j) * 1./24 * (u(i,j) + & - u(i-1,j) + u(i,j-1)) - endif - - if (umask(i-1,j) .eq. 1) then ! this (top left) is a degree of freedom node - - uret(i-1,j) = uret(i-1,j) + & - .5 * dxdyh(i,j) * nu_upper (i,j) * ((4*ux+2*vy) * (-1./dxh(i,j)) + (uy+vy) * (0./dyh(i,j))) - - vret(i-1,j) = vret(i-1,j) + & - .5 * dxdyh(i,j) * nu_upper (i,j) * ((uy+vx) * (-1./dxh(i,j)) + (4*vy+2*ux) * (0./dyh(i,j))) - - uret(i,j-1) = uret(i,j-1) + & - beta_upper(i,j) * dxdyh(i,j) * 1./24 * (u(i,j) + & - u(i-1,j) + u(i,j-1)) - - vret(i,j-1) = vret(i,j-1) + & - beta_upper(i,j) * dxdyh(i,j) * 1./24 * (u(i,j) + & - u(i-1,j) + u(i,j-1)) - endif - - if (umask(i,j) .eq. 1) then ! this (top right) is a degree of freedom node - - uret(i,j) = uret(i,j) + & - .5 * dxdyh(i,j) * nu_upper (i,j) * ((4*ux+2*vy) * (1./dxh(i,j)) + (uy+vy) * (1./dyh(i,j))) - - vret(i,j) = vret(i,j) + & - .5 * dxdyh(i,j) * nu_upper (i,j) * ((uy+vx) * (1./dxh(i,j)) + (4*vy+2*ux) * (1./dyh(i,j))) - - uret(i,j) = uret(i,j) + & - beta_upper(i,j) * dxdyh(i,j) * 1./24 * (u(i,j) + & - u(i-1,j) + u(i,j-1)) - - vret(i,j) = vret(i,j) + & - beta_upper(i,j) * dxdyh(i,j) * 1./24 * (u(i,j) + & - u(i-1,j) + u(i,j-1)) - endif - - endif - - enddo - enddo - -end subroutine CG_action_triangular - -subroutine CG_action_bilinear (uret, vret, u, v, Phi, Phisub, umask, vmask, hmask, H_node, & - nu, float_cond, D, beta, dxdyh, is, ie, js, je, dens_ratio) - -real, dimension (NILIMB_SYM_,NJLIMB_SYM_), intent (inout) :: uret, vret -real, dimension (:,:,:,:), pointer :: Phi -real, dimension (:,:,:,:,:,:),pointer :: Phisub -real, dimension (NILIMB_SYM_,NJLIMB_SYM_), intent (in) :: u, v -real, dimension (NILIMB_SYM_,NJLIMB_SYM_), intent (in) :: umask, vmask, H_node -real, dimension (:,:), intent (in) :: hmask, nu, float_cond, D, beta, dxdyh -real, intent(in) :: dens_ratio -integer, intent(in) :: is, ie, js, je - -! the linear action of the matrix on (u,v) with triangular finite elements -! as of now everything is passed in so no grid pointers or anything of the sort have to be dereferenced, -! but this may change pursuant to conversations with others -! -! is & ie are the cells over which the iteration is done; this may change between calls to this subroutine -! in order to make less frequent halo updates -! isym = 1 if grid is symmetric, 0 o.w. - -! the linear action of the matrix on (u,v) with triangular finite elements -! Phi has the form -! Phi (i,j,k,q) - applies to cell i,j - - ! 3 - 4 - ! | | - ! 1 - 2 - -! Phi (i,j,2*k-1,q) gives d(Phi_k)/dx at quadrature point q -! Phi (i,j,2*k,q) gives d(Phi_k)/dy at quadrature point q -! Phi_k is equal to 1 at vertex k, and 0 at vertex l .ne. k, and bilinear - - real :: ux, vx, uy, vy, uq, vq, area, basel - integer :: iq, jq, iphi, jphi, i, j, ilq, jlq - real, dimension(2) :: xquad - real, dimension(2,2) :: Ucell,Vcell,Hcell,Usubcontr,Vsubcontr,Ucontr - - xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) - - do j=js,je - do i=is,ie ; if (hmask(i,j) .eq. 1) then -! dxh = G%dxh(i,j) -! dyh = G%dyh(i,j) -! -! X(:,:) = geolonq (i-1:i,j-1:j) -! Y(:,:) = geolatq (i-1:i,j-1:j) -! -! call bilinear_shape_functions (X, Y, Phi, area) - - ! X and Y must be passed in the form - ! 3 - 4 - ! | | - ! 1 - 2 - ! Phi (2*i-1,j) gives d(Phi_i)/dx at quadrature point j - ! Phi (2*i,j) gives d(Phi_i)/dy at quadrature point j - - area = dxdyh(i,j) - - Ucontr=0 - do iq=1,2 ; do jq=1,2 - - - if (iq .eq. 2) then - ilq = 2 - else - ilq = 1 - endif - - if (jq .eq. 2) then - jlq = 2 - else - jlq = 1 - endif - - uq = u(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & - u(i,j-1) * xquad(iq) * xquad(3-jq) + & - u(i-1,j) * xquad(3-iq) * xquad(jq) + & - u(i,j) * xquad(iq) * xquad(jq) - - vq = v(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & - v(i,j-1) * xquad(iq) * xquad(3-jq) + & - v(i-1,j) * xquad(3-iq) * xquad(jq) + & - v(i,j) * xquad(iq) * xquad(jq) - - ux = u(i-1,j-1) * Phi(i,j,1,2*(jq-1)+iq) + & - u(i,j-1) * Phi(i,j,3,2*(jq-1)+iq) + & - u(i-1,j) * Phi(i,j,5,2*(jq-1)+iq) + & - u(i,j) * Phi(i,j,7,2*(jq-1)+iq) - - vx = v(i-1,j-1) * Phi(i,j,1,2*(jq-1)+iq) + & - v(i,j-1) * Phi(i,j,3,2*(jq-1)+iq) + & - v(i-1,j) * Phi(i,j,5,2*(jq-1)+iq) + & - v(i,j) * Phi(i,j,7,2*(jq-1)+iq) - - uy = u(i-1,j-1) * Phi(i,j,2,2*(jq-1)+iq) + & - u(i,j-1) * Phi(i,j,4,2*(jq-1)+iq) + & - u(i-1,j) * Phi(i,j,6,2*(jq-1)+iq) + & - u(i,j) * Phi(i,j,8,2*(jq-1)+iq) - - vy = v(i-1,j-1) * Phi(i,j,2,2*(jq-1)+iq) + & - v(i,j-1) * Phi(i,j,4,2*(jq-1)+iq) + & - v(i-1,j) * Phi(i,j,6,2*(jq-1)+iq) + & - v(i,j) * Phi(i,j,8,2*(jq-1)+iq) - - do iphi=1,2 ; do jphi=1,2 - if (umask (i-2+iphi,j-2+jphi) .eq. 1) then - - uret (i-2+iphi,j-2+jphi) = uret (i-2+iphi,j-2+jphi) + & - .25 * area * nu (i,j) * ((4*ux+2*vy) * Phi(i,j,2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & - (uy+vx) * Phi(i,j,2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) - endif - if (vmask (i-2+iphi,j-2+jphi) .eq. 1) then - - vret (i-2+iphi,j-2+jphi) = vret (i-2+iphi,j-2+jphi) + & - .25 * area * nu (i,j) * ((uy+vx) * Phi(i,j,2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & - (4*vy+2*ux) * Phi(i,j,2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) - endif - - if (iq .eq. iphi) then - ilq = 2 - else - ilq = 1 - endif - - if (jq .eq. jphi) then - jlq = 2 - else - jlq = 1 - endif - - if (float_cond(i,j) .eq. 0) then - - if (umask (i-2+iphi,j-2+jphi) .eq. 1) then - - uret (i-2+iphi,j-2+jphi) = uret (i-2+iphi,j-2+jphi) + & - .25 * beta(i,j) * area * uq * xquad(ilq) * xquad(jlq) - - endif - - if (vmask (i-2+iphi,j-2+jphi) .eq. 1) then - - vret (i-2+iphi,j-2+jphi) = vret (i-2+iphi,j-2+jphi) + & - .25 * beta(i,j) * area * vq * xquad(ilq) * xquad(jlq) - - endif - - endif - Ucontr(iphi,jphi) = Ucontr(iphi,jphi) + .25 * area * uq * xquad(ilq) * xquad(jlq) * beta(i,j) -! if((i.eq.27) .and. (j.eq.8) .and. (iphi.eq.1) .and. (jphi.eq.1)) print *, "grid", uq, .25 * area * uq * xquad(ilq) * xquad(jlq) - - !endif - enddo ; enddo - enddo ; enddo - - if (float_cond(i,j) .eq. 1) then - Usubcontr = 0.0 ; Vsubcontr = 0.0 ; basel = D(i,j) - Ucell(:,:) = u(i-1:i,j-1:j) ; Vcell(:,:) = v(i-1:i,j-1:j) ; Hcell(:,:) = H_node(i-1:i,j-1:j) - call CG_action_subgrid_basal_bilinear & - (Phisub, Hcell, Ucell, Vcell, area, basel, dens_ratio, Usubcontr, Vsubcontr, i, j) - do iphi=1,2 ; do jphi=1,2 - if (umask (i-2+iphi,j-2+jphi) .eq. 1) then - uret (i-2+iphi,j-2+jphi) = uret (i-2+iphi,j-2+jphi) + Usubcontr (iphi,jphi) * beta(i,j) - endif - if (vmask (i-2+iphi,j-2+jphi) .eq. 1) then - vret (i-2+iphi,j-2+jphi) = vret (i-2+iphi,j-2+jphi) + Vsubcontr (iphi,jphi) * beta(i,j) - !if ( (iphi.eq.1) .and. (jphi.eq.1)) print *, i,j, Usubcontr (iphi,jphi) * beta(i,j), " ", Ucontr(iphi,jphi) - endif - enddo ; enddo - endif - - endif - enddo ; enddo - -end subroutine CG_action_bilinear - -subroutine CG_action_subgrid_basal_bilinear (Phisub, H, U, V, DXDYH, D, dens_ratio, Ucontr, Vcontr, iin, jin) - real, pointer, dimension(:,:,:,:,:,:) :: Phisub - real, dimension(2,2), intent(in) :: H,U,V - real, intent(in) :: DXDYH, D, dens_ratio - real, dimension(2,2), intent(inout) :: Ucontr, Vcontr - integer, optional, intent(in) :: iin, jin - - ! D = cellwise-constant bed elevation - - integer :: nsub, i, j, k, l, qx, qy, m, n, i_m, j_m - real :: subarea, hloc, uq, vq - - nsub = size(Phisub,1) - subarea = DXDYH / (nsub**2) - - - if (.not. present(iin)) then - i_m = -1 - else - i_m = iin - endif - - if (.not. present(jin)) then - j_m = -1 - else - j_m = jin - endif - - - do m=1,2 - do n=1,2 - do j=1,nsub - do i=1,nsub - do qx=1,2 - do qy = 1,2 - - hloc = Phisub(i,j,1,1,qx,qy)*H(1,1)+Phisub(i,j,1,2,qx,qy)*H(1,2)+& - Phisub(i,j,2,1,qx,qy)*H(2,1)+Phisub(i,j,2,2,qx,qy)*H(2,2) - - if (dens_ratio * hloc - D .gt. 0) then - !if (.true.) then - uq = 0 ; vq = 0 - do k=1,2 - do l=1,2 - !Ucontr (m,n) = Ucontr (m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy) * Phisub(i,j,k,l,qx,qy) * U(k,l) - !Vcontr (m,n) = Vcontr (m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy) * Phisub(i,j,k,l,qx,qy) * V(k,l) - uq = uq + Phisub(i,j,k,l,qx,qy) * U(k,l) ; vq = vq + Phisub(i,j,k,l,qx,qy) * V(k,l) - enddo - enddo - - Ucontr (m,n) = Ucontr (m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy) * uq - Vcontr (m,n) = Vcontr (m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy) * vq - - ! if ((i_m .eq. 27) .and. (j_m .eq. 8) .and. (m.eq.1) .and. (n.eq.1)) print *, "in subgrid", uq, Phisub(i,j,m,n,qx,qy) - - endif - - enddo - enddo - enddo - enddo - enddo - enddo - -end subroutine CG_action_subgrid_basal_bilinear - -subroutine matrix_diagonal_triangle (CS, u_diagonal, v_diagonal) - - type(ice_shelf_CS), pointer :: CS - real, dimension (:,:), intent(inout) :: u_diagonal, v_diagonal - -! returns the diagonal entries of the matrix for a Jacobi preconditioning - - real, pointer, dimension (:,:) :: umask, vmask, & - nu_lower, nu_upper, beta_lower, beta_upper, hmask - type(ocean_grid_type), pointer :: G - integer :: isym, i, j, is, js, cnt, isc, jsc, iec, jec - real :: A, n, ux, uy, vx, vy, eps_min, domain_width, dxh, dyh, dxdyh - - G => CS%grid - -! if (G%symmetric) then -! isym=1 -! else -! isym=0 -! endif - - isym = 0 - - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - - umask => CS%umask ; vmask => CS%vmask ; hmask => CS%hmask - nu_lower => CS%ice_visc_lower_tri ; nu_upper => CS%ice_visc_upper_tri - beta_lower => CS%taub_beta_eff_lower_tri ; beta_upper => CS%taub_beta_eff_upper_tri - - do i=isc-1,iec+1 ; do j=jsc-1,jec+1 ; if (hmask(i,j) .eq. 1) then - dxh = G%dxT(i,j) - dyh = G%dyT(i,j) - dxdyh = G%areaT(i,j) - - if (umask (i,j-1) .eq. 1) then ! this (bot right) is a degree of freedom node - - ux = 1./dxh ; uy = 0./dyh - vx = 0. ; vy = 0. - - u_diagonal (i,j-1) = u_diagonal (i,j-1) + & - .5 * dxdyh * nu_lower (i,j) * ((4*ux+2*vy) * (1./dxh) + (uy+vy) * (0./dyh)) - - u_diagonal (i,j-1) = u_diagonal (i,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 - - ux = 0. ; uy = 0. - vx = 1./dxh ; vy = 0./dyh - - v_diagonal (i,j-1) = v_diagonal (i,j-1) + & - .5 * dxdyh * nu_lower (i,j) * ((uy+vx) * (1./dxh) + (4*vy+2*ux) * (0./dyh)) - - v_diagonal (i,j-1) = v_diagonal (i,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 - - ux = 0./dxh ; uy = -1./dyh - vx = 0. ; vy = 0. - - u_diagonal (i,j-1) = u_diagonal (i,j-1) + & - .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (0./dxh) + (uy+vy) * (-1./dyh)) - - u_diagonal (i,j-1) = u_diagonal (i,j-1) + & - beta_upper(i,j) * dxdyh * 1./24 - - vx = 0./dxh ; vy = -1./dyh - ux = 0. ; uy = 0. - - v_diagonal (i,j-1) = v_diagonal (i,j-1) + & - .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (0./dxh) + (4*vy+2*ux) * (-1./dyh)) - - v_diagonal (i,j-1) = v_diagonal (i,j-1) + & - beta_upper(i,j) * dxdyh * 1./24 - - endif - - if (umask (i-1,j) .eq. 1) then ! this (top left) is a degree of freedom node - - ux = 0./dxh ; uy = 1./dyh - vx = 0. ; vy = 0. - - u_diagonal (i-1,j) = u_diagonal (i-1,j) + & - .5 * dxdyh * nu_lower (i,j) * ((4*ux+2*vy) * (0./dxh) + (uy+vy) * (1./dyh)) - - u_diagonal (i,j-1) = u_diagonal (i,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 - - ux = 0. ; uy = 0. - vx = 0./dxh ; vy = 1./dyh - - v_diagonal (i-1,j) = v_diagonal (i-1,j) + & - .5 * dxdyh * nu_lower (i,j) * ((uy+vx) * (0./dxh) + (4*vy+2*ux) * (1./dyh)) - - v_diagonal (i,j-1) = v_diagonal (i,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 - - ux = -1./dxh ; uy = 0./dyh - vx = 0. ; vy = 0. - - u_diagonal (i-1,j) = u_diagonal (i-1,j) + & - .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (-1./dxh) + (uy+vy) * (0./dyh)) - - u_diagonal (i,j-1) = u_diagonal (i,j-1) + & - beta_upper(i,j) * dxdyh * 1./24 - - vx = -1./dxh ; vy = 0./dyh - ux = 0. ; uy = 0. - - v_diagonal (i-1,j) = v_diagonal (i-1,j) + & - .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (-1./dxh) + (4*vy+2*ux) * (0./dyh)) - - v_diagonal (i,j-1) = v_diagonal (i,j-1) + & - beta_upper(i,j) * dxdyh * 1./24 - - endif - - if (umask (i-1,j-1) .eq. 1) then ! this (bot left) is a degree of freedom node - - ux = -1./dxh ; uy = -1./dyh - vx = 0. ; vy = 0. - - u_diagonal (i-1,j-1) = u_diagonal (i-1,j-1) + & - .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (-1./dxh) + (uy+vy) * (-1./dyh)) - - u_diagonal (i-1,j-1) = u_diagonal (i-1,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 - - vx = -1./dxh ; vy = -1./dyh - ux = 0. ; uy = 0. - - v_diagonal (i-1,j-1) = v_diagonal (i-1,j-1) + & - .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (-1./dxh) + (4*vy+2*ux) * (-1./dyh)) - - v_diagonal (i-1,j-1) = v_diagonal (i-1,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 - endif - - if (umask (i,j) .eq. 1) then ! this (top right) is a degree of freedom node - - ux = 1./ dxh ; uy = 1./dyh - vx = 0. ; vy = 0. - - u_diagonal (i,j) = u_diagonal (i,j) + & - .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (1./dxh) + (uy+vy) * (1./dyh)) - - u_diagonal (i,j) = u_diagonal (i,j) + & - beta_upper(i,j) * dxdyh * 1./24 - - vx = 1./ dxh ; vy = 1./dyh - ux = 0. ; uy = 0. - - v_diagonal (i,j) = v_diagonal (i,j) + & - .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (1./dxh) + (4*vy+2*ux) * (1./dyh)) - - v_diagonal (i,j) = v_diagonal (i,j) + & - beta_upper(i,j) * dxdyh * 1./24 - - endif - endif ; enddo ; enddo - -end subroutine matrix_diagonal_triangle - -subroutine matrix_diagonal_bilinear(CS, float_cond, H_node, dens_ratio, Phisub, u_diagonal, v_diagonal) - - type(ice_shelf_CS), pointer :: CS - real, dimension (NILIMB_SYM_,NJLIMB_SYM_), intent(in) :: H_node - real :: dens_ratio - real, dimension (:,:), intent(in) :: float_cond - real, dimension (:,:,:,:,:,:),pointer :: Phisub - real, dimension (NILIMB_SYM_,NJLIMB_SYM_), intent(inout) :: u_diagonal, v_diagonal - - -! returns the diagonal entries of the matrix for a Jacobi preconditioning - - real, dimension (:,:), pointer :: umask, vmask, hmask, & - nu, beta - type(ocean_grid_type), pointer :: G - integer :: isym, i, j, is, js, cnt, isc, jsc, iec, jec, iphi, jphi, iq, jq, ilq, jlq - real :: A, n, ux, uy, vx, vy, eps_min, domain_width, dxh, dyh, dxdyh, area, uq, vq, basel - real, dimension(8,4) :: Phi - real, dimension(4) :: X, Y - real, dimension(2) :: xquad - real, dimension(2,2) :: Hcell,Usubcontr,Vsubcontr - - G => CS%grid - -! if (G%symmetric) then -! isym=1 -! else -! isym=0 -! endif - - isym = 0 - - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - - umask => CS%umask ; vmask => CS%vmask ; hmask => CS%hmask - nu => CS%ice_visc_bilinear - beta => CS%taub_beta_eff_bilinear - - xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) - -! X and Y must be passed in the form - ! 3 - 4 - ! | | - ! 1 - 2 -! Phi (2*i-1,j) gives d(Phi_i)/dx at quadrature point j -! Phi (2*i,j) gives d(Phi_i)/dy at quadrature point j - - do j=jsc-1,jec+1 ; do i=isc-1,iec+1 ; if (hmask(i,j) .eq. 1) then - - dxh = G%dxT(i,j) - dyh = G%dyT(i,j) - dxdyh = G%areaT(i,j) - - X(1:2) = G%geoLonBu (i-1:i,j-1)*1000 - X(3:4) = G%geoLonBu (i-1:i,j) *1000 - Y(1:2) = G%geoLatBu (i-1:i,j-1) *1000 - Y(3:4) = G%geoLatBu (i-1:i,j)*1000 - - call bilinear_shape_functions (X, Y, Phi, area) - - ! X and Y must be passed in the form - ! 3 - 4 - ! | | - ! 1 - 2 - ! Phi (2*i-1,j) gives d(Phi_i)/dx at quadrature point j - ! Phi (2*i,j) gives d(Phi_i)/dy at quadrature point j - - do iq=1,2 ; do jq=1,2 - - do iphi=1,2 ; do jphi=1,2 - - if (iq .eq. iphi) then - ilq = 2 - else - ilq = 1 - endif - - if (jq .eq. jphi) then - jlq = 2 - else - jlq = 1 - endif - - if (umask (i-2+iphi,j-2+jphi) .eq. 1) then - - ux = Phi (2*(2*(jphi-1)+iphi)-1, 2*(jq-1)+iq) - uy = Phi (2*(2*(jphi-1)+iphi), 2*(jq-1)+iq) - vx = 0. - vy = 0. - - u_diagonal (i-2+iphi,j-2+jphi) = u_diagonal (i-2+iphi,j-2+jphi) + & - .25 * dxdyh * nu (i,j) * ((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & - (uy+vy) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) - - uq = xquad(ilq) * xquad(jlq) - - if (float_cond(i,j) .eq. 0) then - u_diagonal (i-2+iphi,j-2+jphi) = u_diagonal (i-2+iphi,j-2+jphi) + & - .25 * beta(i,j) * dxdyh * uq * xquad(ilq) * xquad(jlq) - endif - - endif - - if (vmask (i-2+iphi,j-2+jphi) .eq. 1) then - - vx = Phi (2*(2*(jphi-1)+iphi)-1, 2*(jq-1)+iq) - vy = Phi (2*(2*(jphi-1)+iphi), 2*(jq-1)+iq) - ux = 0. - uy = 0. - - v_diagonal (i-2+iphi,j-2+jphi) = v_diagonal (i-2+iphi,j-2+jphi) + & - .25 * dxdyh * nu (i,j) * ((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & - (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) - - vq = xquad(ilq) * xquad(jlq) - - if (float_cond(i,j) .eq. 0) then - v_diagonal (i-2+iphi,j-2+jphi) = v_diagonal (i-2+iphi,j-2+jphi) + & - .25 * beta(i,j) * dxdyh * vq * xquad(ilq) * xquad(jlq) - endif - - endif - enddo ; enddo - enddo ; enddo - if (float_cond(i,j) .eq. 1) then - Usubcontr = 0.0 ; Vsubcontr = 0.0 ; basel = G%bathyT(i,j) - Hcell(:,:) = H_node(i-1:i,j-1:j) - call CG_diagonal_subgrid_basal_bilinear & - (Phisub, Hcell, dxdyh, basel, dens_ratio, Usubcontr, Vsubcontr) - do iphi=1,2 ; do jphi=1,2 - if (umask (i-2+iphi,j-2+jphi) .eq. 1) then - u_diagonal (i-2+iphi,j-2+jphi) = u_diagonal (i-2+iphi,j-2+jphi) + Usubcontr (iphi,jphi) * beta(i,j) - v_diagonal (i-2+iphi,j-2+jphi) = v_diagonal (i-2+iphi,j-2+jphi) + Vsubcontr (iphi,jphi) * beta(i,j) - endif - enddo ; enddo - endif - endif ; enddo ; enddo - -end subroutine matrix_diagonal_bilinear - -subroutine CG_diagonal_subgrid_basal_bilinear (Phisub, H, DXDYH, D, dens_ratio, Ucontr, Vcontr) - real, pointer, dimension(:,:,:,:,:,:) :: Phisub - real, dimension(2,2), intent(in) :: H - real, intent(in) :: DXDYH, D, dens_ratio - real, dimension(2,2), intent(inout) :: Ucontr, Vcontr - - ! D = cellwise-constant bed elevation - - integer :: nsub, i, j, k, l, qx, qy, m, n - real :: subarea, hloc - - nsub = size(Phisub,1) - subarea = DXDYH / (nsub**2) - - do m=1,2 - do n=1,2 - do j=1,nsub - do i=1,nsub - do qx=1,2 - do qy = 1,2 - - hloc = Phisub(i,j,1,1,qx,qy)*H(1,1)+Phisub(i,j,1,2,qx,qy)*H(1,2)+& - Phisub(i,j,2,1,qx,qy)*H(2,1)+Phisub(i,j,2,2,qx,qy)*H(2,2) - - if (dens_ratio * hloc - D .gt. 0) then - Ucontr (m,n) = Ucontr (m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy)**2 - Vcontr (m,n) = Vcontr (m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy)**2 - endif - - - enddo - enddo - enddo - enddo - enddo - enddo - -end subroutine CG_diagonal_subgrid_basal_bilinear - - -subroutine apply_boundary_values_triangle (CS, time, u_boundary_contr, v_boundary_contr) - - type(time_type), intent(in) :: Time - type(ice_shelf_CS), pointer :: CS - real, dimension (:,:), intent(inout) :: u_boundary_contr, v_boundary_contr - -! this will be a per-setup function. the boundary values of thickness and velocity -! (and possibly other variables) will be updated in this function - - real, pointer, dimension (:,:) :: u_boundary_values, & - v_boundary_values, & - umask, vmask, hmask, & - nu_lower, nu_upper, beta_lower, beta_upper - type(ocean_grid_type), pointer :: G - integer :: isym, i, j, cnt, isc, jsc, iec, jec - real :: A, n, ux, uy, vx, vy, eps_min, domain_width, dxh, dyh, dxdyh - - G => CS%grid - -! if (G%symmetric) then -! isym=1 -! else -! isym=0 -! endif - - isym = 0 - - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - - u_boundary_values => CS%u_boundary_values - v_boundary_values => CS%v_boundary_values - umask => CS%umask ; vmask => CS%vmask ; hmask => CS%hmask - nu_lower => CS%ice_visc_lower_tri ; nu_upper => CS%ice_visc_upper_tri - beta_lower => CS%taub_beta_eff_lower_tri ; beta_upper => CS%taub_beta_eff_upper_tri - - domain_width = CS%len_lat - - do i=isc-1,iec+1 ; do j=jsc-1,jec+1 ; if (hmask(i,j) .eq. 1) then - - if ((umask(i-1,j-1) .eq. 3) .OR. (umask(i,j-1) .eq. 3) .OR. (umask(i-1,j) .eq. 3)) then - - dxh = G%dxT(i,j) - dyh = G%dyT(i,j) - dxdyh = G%areaT(i,j) - - ux = (u_boundary_values(i,j-1)-u_boundary_values(i-1,j-1))/dxh - vx = (v_boundary_values(i,j-1)-v_boundary_values(i-1,j-1))/dxh - uy = (u_boundary_values(i-1,j)-u_boundary_values(i-1,j-1))/dyh - vy = (v_boundary_values(i-1,j)-v_boundary_values(i-1,j-1))/dyh - - if (umask (i,j-1) .eq. 1) then ! this (bot right) is a degree of freedom node - - u_boundary_contr (i,j-1) = u_boundary_contr (i,j-1) + & - .5 * dxdyh * nu_lower (i,j) * ((4*ux+2*vy) * (1./dxh) + (uy+vy) * (0./dyh)) - - v_boundary_contr (i,j-1) = v_boundary_contr (i,j-1) + & - .5 * dxdyh * nu_lower (i,j) * ((uy+vx) * (1./dxh) + (4*vy+2*ux) * (0./dyh)) - - u_boundary_contr (i,j-1) = u_boundary_contr (i,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 * (u_boundary_values(i-1,j-1) + & - u_boundary_values(i-1,j) + u_boundary_values(i,j-1)) - - v_boundary_contr (i,j-1) = v_boundary_contr (i,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 * (v_boundary_values(i-1,j-1) + & - v_boundary_values(i-1,j) + v_boundary_values(i,j-1)) - endif - - if (umask (i-1,j) .eq. 1) then ! this (top left) is a degree of freedom node - - u_boundary_contr (i-1,j) = u_boundary_contr (i-1,j) + & - .5 * dxdyh * nu_lower (i,j) * ((4*ux+2*vy) * (0./dxh) + (uy+vy) * (1./dyh)) - - v_boundary_contr (i-1,j) = v_boundary_contr (i-1,j) + & - .5 * dxdyh * nu_lower (i,j) * ((uy+vx) * (0./dxh) + (4*vy+2*ux) * (1./dyh)) - - u_boundary_contr (i,j-1) = u_boundary_contr (i,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 * (u_boundary_values(i-1,j-1) + & - u_boundary_values(i-1,j) + u_boundary_values(i,j-1)) - - v_boundary_contr (i,j-1) = v_boundary_contr (i,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 * (v_boundary_values(i-1,j-1) + & - v_boundary_values(i-1,j) + v_boundary_values(i,j-1)) - endif - - if (umask (i-1,j-1) .eq. 1) then ! this (bot left) is a degree of freedom node - - u_boundary_contr (i-1,j-1) = u_boundary_contr (i-1,j-1) + & - .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (-1./dxh) + (uy+vy) * (-1./dyh)) - - v_boundary_contr (i-1,j-1) = v_boundary_contr (i-1,j-1) + & - .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (-1./dxh) + (4*vy+2*ux) * (-1./dyh)) - - u_boundary_contr (i-1,j-1) = u_boundary_contr (i-1,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 * (u_boundary_values(i-1,j-1) + & - u_boundary_values(i-1,j) + u_boundary_values(i,j-1)) - - v_boundary_contr (i-1,j-1) = v_boundary_contr (i-1,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 * (v_boundary_values(i-1,j-1) + & - v_boundary_values(i-1,j) + v_boundary_values(i,j-1)) - endif - - endif - - if ((umask(i,j) .eq. 3) .OR. (umask(i,j-1) .eq. 3) .OR. (umask(i-1,j) .eq. 3)) then - - dxh = G%dxT(i,j) - dyh = G%dyT(i,j) - dxdyh = G%areaT(i,j) - - ux = (u_boundary_values(i,j)-u_boundary_values(i-1,j))/dxh - vx = (v_boundary_values(i,j)-v_boundary_values(i-1,j))/dxh - uy = (u_boundary_values(i,j)-u_boundary_values(i,j-1))/dyh - vy = (v_boundary_values(i,j)-v_boundary_values(i,j-1))/dyh - - if (umask (i,j-1) .eq. 1) then ! this (bot right) is a degree of freedom node - - u_boundary_contr (i,j-1) = u_boundary_contr (i,j-1) + & - .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (0./dxh) + (uy+vy) * (-1./dyh)) - - v_boundary_contr (i,j-1) = v_boundary_contr (i,j-1) + & - .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (0./dxh) + (4*vy+2*ux) * (-1./dyh)) - - u_boundary_contr (i,j-1) = u_boundary_contr (i,j-1) + & - beta_upper(i,j) * dxdyh * 1./24 * (u_boundary_values(i,j) + & - u_boundary_values(i-1,j) + & - u_boundary_values(i,j-1)) - - v_boundary_contr (i,j-1) = v_boundary_contr (i,j-1) + & - beta_upper(i,j) * dxdyh * 1./24 * (u_boundary_values(i,j) + & - u_boundary_values(i-1,j) + & - u_boundary_values(i,j-1)) - endif - - if (umask (i-1,j) .eq. 1) then ! this (top left) is a degree of freedom node - - u_boundary_contr (i-1,j) = u_boundary_contr (i-1,j) + & - .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (-1./dxh) + (uy+vy) * (0./dyh)) - - v_boundary_contr (i-1,j) = v_boundary_contr (i-1,j) + & - .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (-1./dxh) + (4*vy+2*ux) * (0./dyh)) - - u_boundary_contr (i,j-1) = u_boundary_contr (i,j-1) + & - beta_upper(i,j) * dxdyh * 1./24 * (u_boundary_values(i,j) + & - u_boundary_values(i-1,j) + & - u_boundary_values(i,j-1)) - - v_boundary_contr (i,j-1) = v_boundary_contr (i,j-1) + & - beta_upper(i,j) * dxdyh * 1./24 * (u_boundary_values(i,j) + & - u_boundary_values(i-1,j) + & - u_boundary_values(i,j-1)) - endif - - if (umask (i,j) .eq. 1) then ! this (top right) is a degree of freedom node - - u_boundary_contr (i,j) = u_boundary_contr (i,j) + & - .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (1./dxh) + (uy+vy) * (1./dyh)) - - v_boundary_contr (i,j) = v_boundary_contr (i,j) + & - .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (1./dxh) + (4*vy+2*ux) * (1./dyh)) - - u_boundary_contr (i,j) = u_boundary_contr (i,j) + & - beta_upper(i,j) * dxdyh * 1./24 * (u_boundary_values(i,j) + & - u_boundary_values(i-1,j) + & - u_boundary_values(i,j-1)) - - v_boundary_contr (i,j) = v_boundary_contr (i,j) + & - beta_upper(i,j) * dxdyh * 1./24 * (u_boundary_values(i,j) + & - u_boundary_values(i-1,j) + & - u_boundary_values(i,j-1)) - endif - - - endif - endif ; enddo ; enddo - -end subroutine apply_boundary_values_triangle - -subroutine apply_boundary_values_bilinear (CS, time, Phisub, H_node, float_cond, dens_ratio, u_boundary_contr, v_boundary_contr) - - type(time_type), intent(in) :: Time - real, dimension (:,:,:,:,:,:),pointer:: Phisub - type(ice_shelf_CS), pointer :: CS - real, dimension (NILIMB_SYM_,NJLIMB_SYM_), intent (in) :: H_node - real, dimension (:,:), intent (in) :: float_cond - real :: dens_ratio - real, dimension (NILIMB_SYM_,NJLIMB_SYM_), intent(inout) :: u_boundary_contr, v_boundary_contr - -! this will be a per-setup function. the boundary values of thickness and velocity -! (and possibly other variables) will be updated in this function - - real, pointer, dimension (:,:) :: u_boundary_values, & - v_boundary_values, & - umask, vmask, & - nu, beta, hmask - real, dimension(8,4) :: Phi - real, dimension(4) :: X, Y - real, dimension(2) :: xquad - type(ocean_grid_type), pointer :: G - integer :: isym, i, j, isc, jsc, iec, jec, iq, jq, iphi, jphi, ilq, jlq - real :: A, n, ux, uy, vx, vy, eps_min, domain_width, dxh, dyh, dxdyh, uq, vq, area, basel - real, dimension(2,2) :: Ucell,Vcell,Hcell,Usubcontr,Vsubcontr - - G => CS%grid - -! if (G%symmetric) then -! isym=1 -! else -! isym=0 -! endif - - isym = 0 - - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - - u_boundary_values => CS%u_boundary_values - v_boundary_values => CS%v_boundary_values - umask => CS%umask ; vmask => CS%vmask ; hmask => CS%hmask - nu => CS%ice_visc_bilinear - beta => CS%taub_beta_eff_bilinear - - xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) - -! X and Y must be passed in the form - ! 3 - 4 - ! | | - ! 1 - 2 -! Phi (2*i-1,j) gives d(Phi_i)/dx at quadrature point j -! Phi (2*i,j) gives d(Phi_i)/dy at quadrature point j - - do j=jsc-1,jec+1 ; do i=isc-1,iec+1 ; if (hmask(i,j) .eq. 1) then - - ! process this cell if any corners have umask set to non-dirichlet bdry. - ! NOTE: vmask not considered, probably should be - - if ((umask(i-1,j-1) .eq. 3) .OR. (umask(i,j-1) .eq. 3) .OR. & - (umask(i-1,j) .eq. 3) .OR. (umask(i,j) .eq. 3)) then - - - dxh = G%dxT(i,j) - dyh = G%dyT(i,j) - dxdyh = G%areaT(i,j) - - X(1:2) = G%geoLonBu (i-1:i,j-1)*1000 - X(3:4) = G%geoLonBu (i-1:i,j)*1000 - Y(1:2) = G%geoLatBu (i-1:i,j-1)*1000 - Y(3:4) = G%geoLatBu (i-1:i,j)*1000 - - call bilinear_shape_functions (X, Y, Phi, area) - - ! X and Y must be passed in the form - ! 3 - 4 - ! | | - ! 1 - 2 - ! Phi (2*i-1,j) gives d(Phi_i)/dx at quadrature point j - ! Phi (2*i,j) gives d(Phi_i)/dy at quadrature point j - - - - do iq=1,2 ; do jq=1,2 - - uq = u_boundary_values(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & - u_boundary_values(i,j-1) * xquad(iq) * xquad(3-jq) + & - u_boundary_values(i-1,j) * xquad(3-iq) * xquad(jq) + & - u_boundary_values(i,j) * xquad(iq) * xquad(jq) - - vq = v_boundary_values(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & - v_boundary_values(i,j-1) * xquad(iq) * xquad(3-jq) + & - v_boundary_values(i-1,j) * xquad(3-iq) * xquad(jq) + & - v_boundary_values(i,j) * xquad(iq) * xquad(jq) - - ux = u_boundary_values(i-1,j-1) * Phi(1,2*(jq-1)+iq) + & - u_boundary_values(i,j-1) * Phi(3,2*(jq-1)+iq) + & - u_boundary_values(i-1,j) * Phi(5,2*(jq-1)+iq) + & - u_boundary_values(i,j) * Phi(7,2*(jq-1)+iq) - - vx = v_boundary_values(i-1,j-1) * Phi(1,2*(jq-1)+iq) + & - v_boundary_values(i,j-1) * Phi(3,2*(jq-1)+iq) + & - v_boundary_values(i-1,j) * Phi(5,2*(jq-1)+iq) + & - v_boundary_values(i,j) * Phi(7,2*(jq-1)+iq) - - uy = u_boundary_values(i-1,j-1) * Phi(2,2*(jq-1)+iq) + & - u_boundary_values(i,j-1) * Phi(4,2*(jq-1)+iq) + & - u_boundary_values(i-1,j) * Phi(6,2*(jq-1)+iq) + & - u_boundary_values(i,j) * Phi(8,2*(jq-1)+iq) - - vy = v_boundary_values(i-1,j-1) * Phi(2,2*(jq-1)+iq) + & - v_boundary_values(i,j-1) * Phi(4,2*(jq-1)+iq) + & - v_boundary_values(i-1,j) * Phi(6,2*(jq-1)+iq) + & - v_boundary_values(i,j) * Phi(8,2*(jq-1)+iq) - - do iphi=1,2 ; do jphi=1,2 - - if (iq .eq. iphi) then - ilq = 2 - else - ilq = 1 - endif - - if (jq .eq. jphi) then - jlq = 2 - else - jlq = 1 - endif - - if (umask (i-2+iphi,j-2+jphi) .eq. 1) then - - - u_boundary_contr (i-2+iphi,j-2+jphi) = u_boundary_contr (i-2+iphi,j-2+jphi) + & - .25 * dxdyh * nu (i,j) * ( (4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & - (uy+vx) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq) ) - - if (float_cond(i,j) .eq. 0) then - u_boundary_contr (i-2+iphi,j-2+jphi) = u_boundary_contr (i-2+iphi,j-2+jphi) + & - .25 * beta(i,j) * dxdyh * uq * xquad(ilq) * xquad(jlq) - endif - - endif - - if (vmask (i-2+iphi,j-2+jphi) .eq. 1) then - - - v_boundary_contr (i-2+iphi,j-2+jphi) = v_boundary_contr (i-2+iphi,j-2+jphi) + & - .25 * dxdyh * nu (i,j) * ( (uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & - (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) - - if (float_cond(i,j) .eq. 0) then - v_boundary_contr (i-2+iphi,j-2+jphi) = v_boundary_contr (i-2+iphi,j-2+jphi) + & - .25 * beta(i,j) * dxdyh * vq * xquad(ilq) * xquad(jlq) - endif - - endif - enddo ; enddo - enddo ; enddo - - if (float_cond(i,j) .eq. 1) then - Usubcontr = 0.0 ; Vsubcontr = 0.0 ; basel = G%bathyT(i,j) - Ucell(:,:) = u_boundary_values(i-1:i,j-1:j) ; Vcell(:,:) = v_boundary_values(i-1:i,j-1:j) - Hcell(:,:) = H_node(i-1:i,j-1:j) - call CG_action_subgrid_basal_bilinear & - (Phisub, Hcell, Ucell, Vcell, dxdyh, basel, dens_ratio, Usubcontr, Vsubcontr) - do iphi=1,2 ; do jphi = 1,2 - if (umask (i-2+iphi,j-2+jphi) .eq. 1) then - u_boundary_contr (i-2+iphi,j-2+jphi) = u_boundary_contr (i-2+iphi,j-2+jphi) + & - Usubcontr(iphi,jphi) * beta (i,j) - endif - if (vmask (i-2+iphi,j-2+jphi) .eq. 1) then - v_boundary_contr (i-2+iphi,j-2+jphi) = v_boundary_contr (i-2+iphi,j-2+jphi) + & - Vsubcontr(iphi,jphi) * beta (i,j) - endif - enddo ; enddo - endif - endif - endif ; enddo ; enddo - -end subroutine apply_boundary_values_bilinear - -subroutine calc_shelf_visc_triangular (CS,u,v) - type(ice_shelf_CS), pointer :: CS - real, dimension(:,:), intent(inout) :: u, v - -! update DEPTH_INTEGRATED viscosity, based on horizontal strain rates - this is for triangle FEM solve so there is -! an "upper" and "lower" triangular viscosity - -! also this subroutine updates the nonlinear part of the basal traction - -! this may be subject to change later... to make it "hybrid" - - real, pointer, dimension (:,:) :: nu_lower , & - nu_upper, & - beta_eff_lower, & - beta_eff_upper - real, pointer, dimension (:,:) :: H, &! thickness - hmask - - type(ocean_grid_type), pointer :: G - integer :: isym, i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, iegq, jegq, giec, gjec, gisc, gjsc, cnt, isc, jsc, iec, jec, is, js - real :: A, n, ux, uy, vx, vy, eps_min, umid, vmid, unorm, C_basal_friction, n_basal_friction, dxh, dyh, dxdyh - - G => CS%grid - - if (G%symmetric) then - isym = 1 - else - isym = 0 - endif - - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB - isd = G%isd ; jsd = G%jsd ; ied = G%isd ; jed = G%jsd - iegq = G%iegB ; jegq = G%jegB - gisc = G%domain%nihalo+1 ; gjsc = G%domain%njhalo+1 - giec = G%domain%niglobal+gisc ; gjec = G%domain%njglobal+gjsc - is = iscq - (1-isym); js = jscq - (1-isym) - - A = CS%A_glen_isothermal ; n = CS%n_glen; eps_min = CS%eps_glen_min - - H => CS%h_shelf - hmask => CS%hmask - nu_upper => CS%ice_visc_upper_tri - nu_lower => CS%ice_visc_lower_tri - beta_eff_upper => CS%taub_beta_eff_upper_tri - beta_eff_lower => CS%taub_beta_eff_lower_tri - - C_basal_friction = CS%C_basal_friction ; n_basal_friction = CS%n_basal_friction - - do i=isd,ied - do j=jsd,jed - - dxh = G%dxT(i,j) - dyh = G%dyT(i,j) - dxdyh = G%areaT(i,j) - - if (hmask (i,j) .eq. 1) then - ux = (u(i,j-1)-u(i-1,j-1)) / dxh - vx = (v(i,j-1)-v(i-1,j-1)) / dxh - uy = (u(i-1,j)-u(i-1,j-1)) / dyh - vy = (v(i-1,j)-v(i-1,j-1)) / dyh - - nu_lower(i,j) = A**(-1/n) * (ux**2+vy**2+ux*vy+0.25*(uy+vx)**2+eps_min**2) ** ((1-n)/(2*n)) * H(i,j) - umid = 1./3 * (u(i-1,j-1)+u(i-1,j)+u(i,j-1)) - vmid = 1./3 * (v(i-1,j-1)+v(i-1,j)+v(i,j-1)) - unorm = sqrt (umid**2+vmid**2+(eps_min*dxh)**2) ; beta_eff_lower (i,j) = C_basal_friction * unorm ** (n_basal_friction-1) - - ux = (u(i,j)-u(i-1,j)) / dxh - vx = (v(i,j)-v(i-1,j)) / dxh - uy = (u(i,j)-u(i,j-1)) / dyh - vy = (u(i,j)-u(i,j-1)) / dyh - - nu_upper(i,j) = A**(-1/n) * (ux**2+vy**2+ux*vy+0.25*(uy+vx)**2+eps_min**2) ** ((1-n)/(2*n)) * H(i,j) - umid = 1./3 * (u(i,j)+u(i-1,j)+u(i,j-1)) - vmid = 1./3 * (v(i,j)+v(i-1,j)+v(i,j-1)) - unorm = sqrt (umid**2+vmid**2+(eps_min*dxh)**2) ; beta_eff_upper (i,j) = C_basal_friction * unorm ** (n_basal_friction-1) - - endif - enddo - enddo - -end subroutine calc_shelf_visc_triangular - -subroutine calc_shelf_visc_bilinear (CS, u, v) - type(ice_shelf_CS), pointer :: CS - real, dimension(NILIMB_SYM_,NJLIMB_SYM_), intent(inout) :: u, v - -! update DEPTH_INTEGRATED viscosity, based on horizontal strain rates - this is for triangle FEM solve so there is -! an "upper" and "lower" triangular viscosity - -! also this subroutine updates the nonlinear part of the basal traction - -! this may be subject to change later... to make it "hybrid" - - real, pointer, dimension (:,:) :: nu, & - beta - real, pointer, dimension (:,:) :: H, &! thickness - hmask - - type(ocean_grid_type), pointer :: G - integer :: isym, i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, iegq, jegq, giec, gjec, gisc, gjsc, cnt, isc, jsc, iec, jec, is, js - real :: A, n, ux, uy, vx, vy, eps_min, umid, vmid, unorm, C_basal_friction, n_basal_friction, dxh, dyh, dxdyh - - G => CS%grid - - isym=0 - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB - isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed - iegq = G%iegB ; jegq = G%jegB - gisc = G%domain%nihalo+1 ; gjsc = G%domain%njhalo+1 - giec = G%domain%niglobal+gisc ; gjec = G%domain%njglobal+gjsc - is = iscq - (1-isym); js = jscq - (1-isym) - - A = CS%A_glen_isothermal ; n = CS%n_glen; eps_min = CS%eps_glen_min - C_basal_friction = CS%C_basal_friction ; n_basal_friction = CS%n_basal_friction - - H => CS%h_shelf - hmask => CS%hmask - nu => CS%ice_visc_bilinear - beta => CS%taub_beta_eff_bilinear - - do j=jsd+1,jed-1 - do i=isd+1,ied-1 - - dxh = G%dxT(i,j) - dyh = G%dyT(i,j) - dxdyh = G%areaT(i,j) - - if (hmask (i,j) .eq. 1) then - ux = (u(i,j) + u(i,j-1) - u(i-1,j) - u(i-1,j-1)) / (2*dxh) - vx = (v(i,j) + v(i,j-1) - v(i-1,j) - v(i-1,j-1)) / (2*dxh) - uy = (u(i,j) - u(i,j-1) + u(i-1,j) - u(i-1,j-1)) / (2*dyh) - vy = (v(i,j) - v(i,j-1) + v(i-1,j) - v(i-1,j-1)) / (2*dyh) - - nu(i,j) = .5 * A**(-1/n) * (ux**2+vy**2+ux*vy+0.25*(uy+vx)**2+eps_min**2) ** ((1-n)/(2*n)) * H(i,j) - - umid = (u(i,j) + u(i,j-1) + u(i-1,j) + u(i-1,j-1))/4 - vmid = (v(i,j) + v(i,j-1) + v(i-1,j) + v(i-1,j-1))/4 - unorm = sqrt (umid**2+vmid**2+(eps_min*dxh)**2) ; beta (i,j) = C_basal_friction * unorm ** (n_basal_friction-1) - endif - enddo - enddo - -end subroutine calc_shelf_visc_bilinear - -subroutine update_OD_ffrac (CS, ocean_mass, counter, nstep_velocity, time_step, velocity_update_time_step) - type(ice_shelf_CS), pointer :: CS - real, dimension(CS%grid%isd:,CS%grid%jsd:) :: ocean_mass - integer,intent(in) :: counter - integer,intent(in) :: nstep_velocity - real,intent(in) :: time_step - real,intent(in) :: velocity_update_time_step - - type(ocean_grid_type), pointer :: G - integer :: isc, iec, jsc, jec, i, j - real :: threshold_col_depth, rho_ocean, inv_rho_ocean - - threshold_col_depth = CS%thresh_float_col_depth - - G=>CS%grid - - rho_ocean = CS%density_ocean_avg - inv_rho_ocean = 1./rho_ocean - - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - - do j=jsc,jec - do i=isc,iec - CS%OD_rt(i,j) = CS%OD_rt(i,j) + ocean_mass(i,j)*inv_rho_ocean - if (ocean_mass(i,j) > threshold_col_depth*rho_ocean) then - CS%float_frac_rt(i,j) = CS%float_frac_rt(i,j) + 1.0 - endif - enddo - enddo - - if (counter .eq. nstep_velocity) then - - do j=jsc,jec - do i=isc,iec - CS%float_frac(i,j) = 1.0 - (CS%float_frac_rt(i,j) / real(nstep_velocity)) -! if ((CS%float_frac(i,j) .gt. 0) .and. (CS%float_frac(i,j) .lt. 1)) then -! print *,"PARTLY GROUNDED", CS%float_frac(i,j),i,j,mpp_pe() -! endif - CS%OD_av(i,j) = CS%OD_rt(i,j) / real(nstep_velocity) - - CS%OD_rt(i,j) = 0.0 ; CS%float_frac_rt(i,j) = 0.0 - enddo - enddo - - call pass_var(CS%float_frac, G%domain) - call pass_var(CS%OD_av, G%domain) - - endif - -end subroutine update_OD_ffrac - -subroutine update_OD_ffrac_uncoupled (CS) - type(ice_shelf_CS), pointer :: CS - - type(ocean_grid_type), pointer :: G - integer :: i, j, iters, isd, ied, jsd, jed - real :: rhoi, rhow, OD - type(time_type) :: dummy_time - real,dimension(:,:),pointer :: OD_av, float_frac, h_shelf - - - G => CS%grid - rhoi = CS%density_ice - rhow = CS%density_ocean_avg - dummy_time = set_time (0,0) - OD_av => CS%OD_av - h_shelf => CS%h_shelf - float_frac => CS%float_frac - isd=G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - -! print *,"rhow",rhow,"rho",rhoi - - do j=jsd,jed - do i=isd,ied - OD = G%bathyT(i,j) - rhoi/rhow * h_shelf (i,j) - if (OD.ge.0) then - ! ice thickness does not take up whole ocean column -> floating - OD_av (i,j) = OD - float_frac(i,j) = 0. - else - OD_av (i,j) = 0. - float_frac(i,j) = 1. - endif - enddo - enddo - - -end subroutine update_OD_ffrac_uncoupled - -subroutine bilinear_shape_functions (X, Y, Phi, area) - real, dimension(4), intent(in) :: X, Y - real, dimension(8,4), intent (inout) :: Phi - real, intent (out) :: area - -! X and Y must be passed in the form - ! 3 - 4 - ! | | - ! 1 - 2 - -! this subroutine calculates the gradients of bilinear basis elements that -! that are centered at the vertices of the cell. values are calculated at -! points of gaussian quadrature. (in 1D: .5 * (1 +/- sqrt(1/3)) for [0,1]) -! (ordered in same way as vertices) -! -! Phi (2*i-1,j) gives d(Phi_i)/dx at quadrature point j -! Phi (2*i,j) gives d(Phi_i)/dy at quadrature point j -! Phi_i is equal to 1 at vertex i, and 0 at vertex k .ne. i, and bilinear -! -! This should be a one-off; once per nonlinear solve? once per lifetime? -! ... will all cells have the same shape and dimension? - - real, dimension (4) :: xquad, yquad - integer :: node, qpoint, xnode, xq, ynode, yq - real :: a,b,c,d,e,f,xexp,yexp - - xquad(1:3:2) = .5 * (1-sqrt(1./3)) ; yquad(1:2) = .5 * (1-sqrt(1./3)) - xquad(2:4:2) = .5 * (1+sqrt(1./3)) ; yquad(3:4) = .5 * (1+sqrt(1./3)) - - do qpoint=1,4 - - a = -X(1)*(1-yquad(qpoint)) + X(2)*(1-yquad(qpoint)) - X(3)*yquad(qpoint) + X(4)*yquad(qpoint) ! d(x)/d(x*) - b = -Y(1)*(1-yquad(qpoint)) + Y(2)*(1-yquad(qpoint)) - Y(3)*yquad(qpoint) + Y(4)*yquad(qpoint) ! d(y)/d(x*) - c = -X(1)*(1-xquad(qpoint)) - X(2)*(xquad(qpoint)) + X(3)*(1-xquad(qpoint)) + X(4)*(xquad(qpoint)) ! d(x)/d(y*) - d = -Y(1)*(1-xquad(qpoint)) - Y(2)*(xquad(qpoint)) + Y(3)*(1-xquad(qpoint)) + Y(4)*(xquad(qpoint)) ! d(y)/d(y*) - - do node=1,4 - - xnode = 2-mod(node,2) ; ynode = ceiling(REAL(node)/2) - - if (ynode .eq. 1) then - yexp = 1-yquad(qpoint) - else - yexp = yquad(qpoint) - endif - - if (1 .eq. xnode) then - xexp = 1-xquad(qpoint) - else - xexp = xquad(qpoint) - endif - - Phi (2*node-1,qpoint) = ( d * (2 * xnode - 3) * yexp - b * (2 * ynode - 3) * xexp) / (a*d-b*c) - Phi (2*node,qpoint) = ( -c * (2 * xnode - 3) * yexp + a * (2 * ynode - 3) * xexp) / (a*d-b*c) - - enddo - enddo - - area = quad_area (X,Y) - -end subroutine bilinear_shape_functions - - -subroutine bilinear_shape_functions_subgrid (Phisub, nsub) - real, dimension(nsub,nsub,2,2,2,2), intent(inout) :: Phisub - integer :: nsub - - ! this subroutine is a helper for interpolation of floatation condition - ! for the purposes of evaluating the terms \int (u,v) \phi_i dx dy in a cell that is - ! in partial floatation - ! the array Phisub contains the values of \phi_i (where i is a node of the cell) - ! at quad point j - ! i think this general approach may not work for nonrectangular elements... - ! - - ! Phisub (i,j,k,l,q1,q2) - ! i: subgrid index in x-direction - ! j: subgrid index in y-direction - ! k: basis function x-index - ! l: basis function y-index - ! q1: quad point x-index - ! q2: quad point y-index - - ! e.g. k=1,l=1 => node 1 - ! q1=2,q2=1 => quad point 2 - - ! 3 - 4 - ! | | - ! 1 - 2 - - - - integer :: i, j, k, l, qx, qy, indx, indy - real,dimension(2) :: xquad - real :: x0, y0, x, y, val, fracx - - xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) - fracx = 1.0/real(nsub) - - do j=1,nsub - do i=1,nsub - x0 = (i-1) * fracx ; y0 = (j-1) * fracx - do qx=1,2 - do qy=1,2 - x = x0 + fracx*xquad(qx) - y = y0 + fracx*xquad(qy) - do k=1,2 - do l=1,2 - val = 1.0 - if (k .eq. 1) then - val = val * (1.0-x) - else - val = val * x - endif - if (l .eq. 1) then - val = val * (1.0-y) - else - val = val * y - endif - Phisub (i,j,k,l,qx,qy) = val - enddo - enddo - enddo - enddo - enddo - enddo - -! print *, Phisub(1,1,2,2,1,1),Phisub(1,1,2,2,1,2),Phisub(1,1,2,2,2,1),Phisub(1,1,2,2,2,2) - - -end subroutine bilinear_shape_functions_subgrid - - -subroutine update_velocity_masks (CS) - type(ice_shelf_CS), pointer :: CS - - ! sets masks for velocity solve - ! ignores the fact that their might be ice-free cells - this only considers the computational boundary - - ! !!!!IMPORTANT!!!! relies on thickness mask - assumed that this is called after hmask has been updated (and halo-updated) - - integer :: isym, i, j, iscq, iecq, jscq, jecq, isd, jsd, is, js, iegq, jegq, giec, gjec, gisc, gjsc, isc, jsc, iec, jec, k - integer :: i_off, j_off - type(ocean_grid_type), pointer :: G - real, dimension(:,:), pointer :: umask, vmask, u_face_mask, v_face_mask, hmask, u_face_mask_boundary, v_face_mask_boundary - - G => CS%grid - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB - i_off = G%idg_offset ; j_off = G%jdg_offset - isd = G%isd ; jsd = G%jsd - iegq = G%iegB ; jegq = G%jegB - gisc = G%Domain%nihalo ; gjsc = G%Domain%njhalo - giec = G%Domain%niglobal+gisc ; gjec = G%Domain%njglobal+gjsc - - umask => CS%umask - vmask => CS%vmask - u_face_mask => CS%u_face_mask - v_face_mask => CS%v_face_mask - u_face_mask_boundary => CS%u_face_mask_boundary - v_face_mask_boundary => CS%v_face_mask_boundary - hmask => CS%hmask - - -! if (G%symmetric) then -! isym=1 -! else -! isym=0 -! endif - - isym = 0 - - umask (:,:) = 0 ; vmask (:,:) = 0 - u_face_mask (:,:) = 0 ; v_face_mask (:,:) = 0 - - if (G%symmetric) then - is = isd ; js = jsd - else - is = isd+1 ; js = jsd+1 - endif - - do j=js,G%jed - do i=is,G%ied - - if (hmask(i,j) .eq. 1) then - - umask(i-1:i,j-1:j) = 1. - vmask(i-1:i,j-1:j) = 1. - - do k=0,1 - - select case (int(u_face_mask_boundary(i-1+k,j))) - case (3) - umask(i-1+k,j-1:j)=3. - vmask(i-1+k,j-1:j)=0. - u_face_mask(i-1+k,j)=3. - case (2) - u_face_mask(i-1+k,j)=2. - case (4) - umask(i-1+k,j-1:j)=0. - vmask(i-1+k,j-1:j)=0. - u_face_mask(i-1+k,j)=4. - case (0) - umask(i-1+k,j-1:j)=0. - vmask(i-1+k,j-1:j)=0. - u_face_mask(i-1+k,j)=0. - case (1) ! stress free x-boundary - umask(i-1+k,j-1:j)=0. - case default - end select - enddo - - do k=0,1 - - select case (int(v_face_mask_boundary(i,j-1+k))) - case (3) - vmask(i-1:i,j-1+k)=3. - umask(i-1:i,j-1+k)=0. - v_face_mask(i,j-1+k)=3. - case (2) - v_face_mask(i,j-1+k)=2. - case (4) - umask(i-1:i,j-1+k)=0. - vmask(i-1:i,j-1+k)=0. - v_face_mask(i,j-1+k)=4. - case (0) - umask(i-1:i,j-1+k)=0. - vmask(i-1:i,j-1+k)=0. - u_face_mask(i,j-1+k)=0. - case (1) ! stress free y-boundary - vmask(i-1:i,j-1+k)=0. - case default - end select - enddo - - !if (u_face_mask_boundary(i-1,j).geq.0) then !left boundary - ! u_face_mask (i-1,j) = u_face_mask_boundary(i-1,j) - ! umask (i-1,j-1:j) = 3. - ! vmask (i-1,j-1:j) = 0. - !endif - - !if (j_off+j .eq. gjsc+1) then !bot boundary - ! v_face_mask (i,j-1) = 0. - ! umask (i-1:i,j-1) = 0. - ! vmask (i-1:i,j-1) = 0. - !elseif (j_off+j .eq. gjec) then !top boundary - ! v_face_mask (i,j) = 0. - ! umask (i-1:i,j) = 0. - ! vmask (i-1:i,j) = 0. - !endif - - if (i .lt. G%ied) then - if ((hmask(i+1,j) .eq. 0) & - .OR. (hmask(i+1,j) .eq. 2)) then - !right boundary or adjacent to unfilled cell - u_face_mask (i,j) = 2. - endif - endif - - if (i .gt. G%isd) then - if ((hmask(i-1,j) .eq. 0) .OR. (hmask(i-1,j) .eq. 2)) then - !adjacent to unfilled cell - u_face_mask (i-1,j) = 2. - endif - endif - - if (j .gt. G%jsd) then - if ((hmask(i,j-1) .eq. 0) .OR. (hmask(i,j-1) .eq. 2)) then - !adjacent to unfilled cell - v_face_mask (i,j-1) = 2. - endif - endif - - if (j .lt. G%jed) then - if ((hmask(i,j+1) .eq. 0) .OR. (hmask(i,j+1) .eq. 2)) then - !adjacent to unfilled cell - v_face_mask (i,j) = 2. - endif - endif - - - endif - - enddo - enddo - - ! note: if the grid is nonsymmetric, there is a part that will not be transferred with a halo update - ! so this subroutine must update its own symmetric part of the halo - - call pass_vector(u_face_mask, v_face_mask, G%domain, TO_ALL, CGRID_NE) - call pass_vector (umask,vmask,G%domain,TO_ALL,BGRID_NE) - -end subroutine update_velocity_masks - - -subroutine interpolate_H_to_B (CS, h_shelf, hmask, H_node) - type(ice_shelf_CS), pointer :: CS - real, dimension (:,:), intent(in) :: h_shelf, hmask - real, dimension (NILIMB_SYM_,NJLIMB_SYM_), intent(inout) :: H_node - - type(ocean_grid_type), pointer :: G - integer :: i, j, isc, iec, jsc, jec, num_h, k, l - real :: summ +!> This routine is for stepping a stand-alone ice shelf model without an ocean. +subroutine solo_time_step(CS, time_step, nsteps, Time, min_time_step_in) + type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + real, intent(in) :: time_step !< The time interval for this update [s]. + integer, intent(inout) :: nsteps !< The running number of ice shelf steps. + type(time_type), intent(inout) :: Time !< The current model time + real, optional, intent(in) :: min_time_step_in !< The minimum permitted time step [s]. + + type(ocean_grid_type), pointer :: G => NULL() + type(unit_scale_type), pointer :: US => NULL() ! Pointer to a structure containing + ! various unit conversion factors + type(ice_shelf_state), pointer :: ISS => NULL() !< A structure with elements that describe + !! the ice-shelf state + integer :: is, iec, js, jec, i, j + real :: time_step_remain + real :: time_step_int, min_time_step + character(len=240) :: mesg + logical :: update_ice_vel ! If true, it is time to update the ice shelf velocities. + logical :: coupled_GL ! If true the grouding line position is determined based on + ! coupled ice-ocean dynamics. G => CS%grid - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - - H_node(:,:) = 0.0 - - ! H_node is node-centered; average over all cells that share that node - ! if no (active) cells share the node then its value there is irrelevant - - do j=jsc-1,jec - do i=isc-1,iec - summ = 0.0 - num_h = 0 - do k=0,1 - do l=0,1 - if (hmask (i+k,j+l) .eq. 1.0) then - summ = summ + h_shelf (i+k,j+l) - num_h = num_h + 1 - endif - enddo - enddo - if (num_h .gt. 0) then - H_node(i,j) = summ / num_h - endif - enddo - enddo - - call pass_var(H_node, G%domain) - -end subroutine interpolate_H_to_B - -!> Deallocates all memory associated with this module -subroutine ice_shelf_end(CS) - type(ice_shelf_CS), pointer :: CS - - if (.not.associated(CS)) return - - deallocate(CS%mass_shelf) ; deallocate(CS%area_shelf_h) - deallocate(CS%t_flux) ; deallocate(CS%lprec) - deallocate(CS%salt_flux) - - deallocate(CS%tflux_shelf) ; deallocate(CS%tfreeze); - deallocate(CS%exch_vel_t) ; deallocate(CS%exch_vel_s) - - deallocate(CS%h_shelf) ; deallocate(CS%hmask) - - if (CS%shelf_mass_is_dynamic .and. .not.CS%override_shelf_movement) then - deallocate(CS%u_shelf) ; deallocate(CS%v_shelf) -!!! OVS !!! - deallocate(CS%t_shelf); deallocate(CS%tmask); - deallocate(CS%t_boundary_values) - deallocate(CS%u_boundary_values) ; deallocate(CS%v_boundary_values) - deallocate(CS%ice_visc_bilinear) - deallocate(CS%ice_visc_lower_tri) ; deallocate(CS%ice_visc_upper_tri) - deallocate(CS%u_face_mask) ; deallocate(CS%v_face_mask) - deallocate(CS%umask) ; deallocate(CS%vmask) - - deallocate(CS%taub_beta_eff_bilinear) - deallocate(CS%taub_beta_eff_upper_tri) - deallocate(CS%taub_beta_eff_lower_tri) - deallocate(CS%OD_rt) ; deallocate(CS%OD_av) - deallocate(CS%float_frac) ; deallocate(CS%float_frac_rt) - endif - - deallocate(CS) - -end subroutine ice_shelf_end - -subroutine savearray2(fname,A,flag) - -! print 2-D array to file - -! this is here strictly for debug purposes - -CHARACTER(*),intent(in) :: fname -! This change is to allow the code to compile with the GNU compiler. -! DOUBLE PRECISION,DIMENSION(:,:),intent(in) :: A -REAL, DIMENSION(:,:), intent(in) :: A -LOGICAL :: flag - -INTEGER :: M,N,i,j,iock,lh,FIN -CHARACTER(23000) :: ln -CHARACTER(17) :: sing -CHARACTER(9) :: STR -CHARACTER(7) :: FMT1 - -if (.NOT. flag) then - return -endif - -PRINT *,"WRITING ARRAY " // fname - -FIN=7 -M = size(A,1) -N = size(A,2) - -OPEN(unit=fin,FILE=fname,STATUS='REPLACE',ACCESS='SEQUENTIAL',& - ACTION='WRITE',IOSTAT=iock) - -IF(M .gt. 1300) THEN - WRITE(fin) 'SECOND DIMENSION TOO LARGE' - CLOSE(fin) - RETURN -END IF - -DO i=1,M - WRITE(ln,'(E17.9)') A(i,1) - DO j=2,N - WRITE(sing,'(E17.9)') A(i,j) - ln = TRIM(ln) // ' ' // TRIM(sing) - END DO - - - IF(i.eq.1) THEN - - lh = LEN(TRIM(ln)) - - FMT1 = '(A' - - SELECT CASE (lh) - CASE(1:9) - WRITE(FMT1(3:3),'(I1)') lh - - CASE(10:99) - WRITE(FMT1(3:4),'(I2)') lh - - CASE(100:999) - WRITE(FMT1(3:5),'(I3)') lh - - CASE(1000:9999) - WRITE(FMT1(3:6),'(I4)') lh - - END SELECT - - FMT1 = TRIM(FMT1) // ')' - - END IF - - WRITE(UNIT=fin,IOSTAT=iock,FMT=TRIM(FMT1)) TRIM(ln) - - IF(iock .ne. 0) THEN - PRINT*,iock - END IF -END DO - -CLOSE(FIN) - -end subroutine savearray2 - - -subroutine solo_time_step (CS, time_step, n, Time, min_time_step_in) - type(ice_shelf_CS), pointer :: CS - real,intent(in) :: time_step - integer, intent(inout) :: n - type(time_type) :: Time - real,optional,intent(in) :: min_time_step_in - - type(ocean_grid_type), pointer :: G - integer :: is, iec, js, jec, i, j, ki, kj, iters - real :: ratio, min_ratio, time_step_remain, local_u_max, & - local_v_max, time_step_int, min_time_step,spy,dumtimeprint - real, dimension(:,:), pointer :: u_shelf, v_shelf, hmask, umask, vmask - logical :: flag - type (time_type) :: dummy - character(2) :: procnum - character(4) :: stepnum + US => CS%US + ISS => CS%ISS + is = G%isc ; iec = G%iec ; js = G%jsc ; jec = G%jec - CS%velocity_update_sub_counter = CS%velocity_update_sub_counter + 1 - spy = 365 * 86400 - G => CS%grid - u_shelf => CS%u_shelf - v_shelf => CS%v_shelf - hmask => CS%hmask - umask => CS%umask - vmask => CS%vmask time_step_remain = time_step - if (.not. (present (min_time_step_in))) then - min_time_step = 1000 ! i think this is in seconds - this would imply ice is moving at ~1 meter per second + if (present (min_time_step_in)) then + min_time_step = min_time_step_in else - min_time_step=min_time_step_in - endif - is = G%isc ; iec = G%iec ; js = G%jsc ; jec = G%jec - - ! NOTE: this relies on NE grid indexing - ! dumtimeprint=time_type_to_real(Time)/spy - if (is_root_pe()) print *, "TIME in ice shelf call, yrs: ", time_type_to_real(Time)/spy - - do while (time_step_remain .gt. 0.0) - - min_ratio = 1.0e16 - n=n+1 - do j=js,jec - do i=is,iec - - local_u_max = 0 ; local_v_max = 0 - - if (hmask (i,j) .eq. 1.0) then - ! all 4 corners of the cell should have valid velocity values; otherwise something is wrong - ! this is done by checking that umask and vmask are nonzero at all 4 corners - do ki=1,2 ; do kj = 1,2 - - local_u_max = max (local_u_max, abs(u_shelf(i-1+ki,j-1+kj))) - local_v_max = max (local_v_max, abs(v_shelf(i-1+ki,j-1+kj))) - - enddo ; enddo - - ratio = min (G%areaT(i,j) / (local_u_max+1.0e-12), G%areaT(i,j) / (local_v_max+1.0e-12)) - min_ratio = min (min_ratio, ratio) - - endif - enddo ! j loop - enddo ! i loop - - ! solved velocities are in m/yr; we want m/s - - call mpp_min (min_ratio) - - time_step_int = min(CS%CFL_factor * min_ratio * (365*86400), time_step) - - if (time_step_int .lt. min_time_step) then - call MOM_error (FATAL, "MOM_ice_shelf:solo_time_step: abnormally small timestep") - else - if (is_root_pe()) then - write(*,*) "Ice model timestep: ", time_step_int, " seconds" - endif - endif - - if (time_step_int .ge. time_step_remain) then - time_step_int = time_step_remain - time_step_remain = 0.0 - else - time_step_remain = time_step_remain - time_step_int - endif - - write (stepnum,'(I4)') CS%velocity_update_sub_counter - - call ice_shelf_advect (CS, time_step_int, CS%lprec, Time) - - if (mpp_pe() .eq. 7) then - call savearray2 ("hmask",CS%hmask,CS%write_output_to_file) -!!! OVS!!! -! call savearray2 ("tshelf",CS%t_shelf,CS%write_output_to_file) - endif - - ! if the last mini-timestep is a day or less, we cannot expect velocities to change by much. - ! do not update them - if (time_step_int .gt. 1000) then - call update_velocity_masks (CS) - -! call savearray2 ("Umask"//"p"//trim(procnum)//"_"//trim(stepnum),CS%umask,CS%write_output_to_file) -! call savearray2 ("Vmask"//"p"//trim(procnum)//"_"//trim(stepnum),CS%vmask,CS%write_output_to_file) - - call update_OD_ffrac_uncoupled (CS) - call ice_shelf_solve_outer (CS, CS%u_shelf, CS%v_shelf, 1, iters, dummy) - endif - -!!! OVS!!! - call ice_shelf_temp (CS, time_step_int, CS%lprec, Time) - - call enable_averaging(time_step,Time,CS%diag) - if (CS%id_area_shelf_h > 0) call post_data(CS%id_area_shelf_h, CS%area_shelf_h, CS%diag) - if (CS%id_col_thick > 0) call post_data(CS%id_col_thick, CS%OD_av, CS%diag) - if (CS%id_h_shelf > 0) call post_data(CS%id_h_shelf,CS%h_shelf,CS%diag) - if (CS%id_h_mask > 0) call post_data(CS%id_h_mask,CS%hmask,CS%diag) - if (CS%id_u_mask > 0) call post_data(CS%id_u_mask,CS%umask,CS%diag) - if (CS%id_v_mask > 0) call post_data(CS%id_v_mask,CS%vmask,CS%diag) - if (CS%id_u_shelf > 0) call post_data(CS%id_u_shelf,CS%u_shelf,CS%diag) - if (CS%id_v_shelf > 0) call post_data(CS%id_v_shelf,CS%v_shelf,CS%diag) - if (CS%id_float_frac > 0) call post_data(CS%id_float_frac,CS%float_frac,CS%diag) - if (CS%id_OD_av >0) call post_data(CS%id_OD_av,CS%OD_av,CS%diag) - if (CS%id_float_frac_rt>0) call post_data(CS%id_float_frac_rt,CS%float_frac_rt,CS%diag) -!!! OVS!!! -! if (CS%id_t_mask > 0) - call post_data(CS%id_t_mask,CS%tmask,CS%diag) -! if (CS%id_t_shelf > 0) - call post_data(CS%id_t_shelf,CS%t_shelf,CS%diag) - - call disable_averaging(CS%diag) - - enddo - -end subroutine solo_time_step - -!!! OVS !!! -subroutine ice_shelf_temp(CS, time_step, melt_rate, Time) - type(ice_shelf_CS), pointer :: CS - real, intent(in) :: time_step - real, dimension(:,:), pointer :: melt_rate - type(time_type), intent(in) :: Time - -! time_step: time step in sec -! melt_rate: basal melt rate in kg/m^2/s - -! 5/23/12 OVS -! Arguments: -! CS - A structure containing the ice shelf state - including current velocities -! t0 - an array containing temperature at the beginning of the call -! t_after_uflux - an array containing the temperature after advection in u-direction -! t_after_vflux - similar -! -! This subroutine takes the velocity (on the Bgrid) and timesteps (HT)_t = - div (uHT) + (adot Tsurd -bdot Tbot) once and then calculates T=HT/H -! -! The flux overflows are included here. That is because they will be used to advect 3D scalars -! into partial cells - - ! - ! flux_enter: this is to capture flow into partially covered cells; it gives the mass flux into a given - ! cell across its boundaries. - ! ###Perhaps flux_enter should be changed into u-face and v-face - ! ###fluxes, which can then be used in halo updates, etc. - ! - ! from left neighbor: flux_enter (:,:,1) - ! from right neighbor: flux_enter (:,:,2) - ! from bottom neighbor: flux_enter (:,:,3) - ! from top neighbor: flux_enter (:,:,4) - ! - ! THESE ARE NOT CONSISTENT ==> FIND OUT WHAT YOU IMPLEMENTED - - ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary - ! - ! o--- (4) ---o - ! | | - ! (1) (2) - ! | | - ! o--- (3) ---o - ! - - type(ocean_grid_type), pointer :: G - real, dimension(size(CS%h_shelf,1),size(CS%h_shelf,2)) :: th_after_uflux, th_after_vflux, TH - real, dimension(size(CS%h_shelf,1),size(CS%h_shelf,2),4) :: flux_enter - integer :: isd, ied, jsd, jed, i, j, isc, iec, jsc, jec - real :: rho, spy, t_bd, Tsurf, adot - real, dimension(:,:), pointer :: hmask, Tbot - character(len=2) :: procnum - - hmask => CS%hmask - G => CS%grid - rho = CS%density_ice - spy = 365 * 86400 ! seconds per year; is there a global constant for this? No - it is dependent upon a calendar. - - adot = 0.1/spy ! for now adot and Tsurf are defined here adot=surf acc 0.1m/yr, Tsurf=-20oC, vary them later - Tbot =>CS%Tfreeze - Tsurf = -20.0 - - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec - flux_enter (:,:,:) = 0.0 - - th_after_uflux (:,:) = 0.0 - th_after_vflux (:,:) = 0.0 - - do j=jsd,jed - do i=isd,ied - t_bd = CS%t_boundary_values(i,j) -! if (CS%hmask(i,j) .gt. 1) then - if ((CS%hmask(i,j) .eq. 3) .or. (CS%hmask(i,j) .eq. -2)) then - CS%t_shelf(i,j) = CS%t_boundary_values(i,j) - endif - enddo - enddo - - do j=jsd,jed - do i=isd,ied - TH (i,j) = CS%t_shelf(i,j)*CS%h_shelf (i,j) - enddo - enddo - - -! call enable_averaging(time_step,Time,CS%diag) - ! call pass_var (h_after_uflux, G%domain) -! if (CS%id_h_after_uflux > 0) call post_data(CS%id_h_after_uflux, h_after_uflux, CS%diag) -! call disable_averaging(CS%diag) - - -! call enable_averaging(time_step,Time,CS%diag) -! call pass_var (h_after_vflux, G%domain) -! if (CS%id_h_after_vflux > 0) call post_data(CS%id_h_after_vflux, h_after_vflux, CS%diag) -! call disable_averaging(CS%diag) - - - - call ice_shelf_advect_temp_x (CS, time_step/spy, TH, th_after_uflux, flux_enter) - call ice_shelf_advect_temp_y (CS, time_step/spy, th_after_uflux, th_after_vflux, flux_enter) - - do j=jsd,jed - do i=isd,ied -! if (CS%hmask(i,j) .eq. 1) then - if (CS%h_shelf(i,j) .gt. 0.0) then - CS%t_shelf (i,j) = th_after_vflux(i,j)/CS%h_shelf (i,j) - else - CS%t_shelf(i,j) = -10.0 - endif - enddo - enddo - - do j=jsd,jed - do i=isd,ied - t_bd = CS%t_boundary_values(i,j) -! if (CS%hmask(i,j) .gt. 1) then - if ((CS%hmask(i,j) .eq. 3) .or. (CS%hmask(i,j) .eq. -2)) then - CS%t_shelf(i,j) = t_bd -! CS%t_shelf(i,j) = -15.0 - endif - enddo - enddo - - do j=jsc,jec - do i=isc,iec - if ((CS%hmask(i,j) .eq. 1) .or. (CS%hmask(i,j) .eq. 2)) then - if (CS%h_shelf(i,j) .gt. 0.0) then -! CS%t_shelf (i,j) = CS%t_shelf (i,j) + time_step*(adot*Tsurf -melt_rate (i,j)*Tbot(i,j))/CS%h_shelf (i,j) - CS%t_shelf (i,j) = CS%t_shelf (i,j) + time_step*(adot*Tsurf -3/spy*Tbot(i,j))/CS%h_shelf (i,j) - else - ! the ice is about to melt away - ! in this case set thickness, area, and mask to zero - ! NOTE: not mass conservative - ! should maybe scale salt & heat flux for this cell - - CS%t_shelf(i,j) = -10.0 - CS%tmask(i,j) = 0.0 - endif - endif - enddo - enddo - - call pass_var(CS%t_shelf, G%domain) - call pass_var(CS%tmask, G%domain) - - if (CS%DEBUG) then - call hchksum (CS%t_shelf, "temp after front", G%HI, haloshift=3) + min_time_step = 1000.0 ! This is in seconds - at 1 km resolution it would imply ice is moving at ~1 meter per second endif -end subroutine ice_shelf_temp - - -subroutine ice_shelf_advect_temp_x (CS, time_step, h0, h_after_uflux, flux_enter) - type(ice_shelf_CS), pointer :: CS - real, intent(in) :: time_step - real, dimension(:,:), intent(in) :: h0 - real, dimension(:,:), intent(inout) :: h_after_uflux - real, dimension(:,:,:), intent(inout) :: flux_enter - - ! use will be made of CS%hmask here - its value at the boundary will be zero, just like uncovered cells - - ! if there is an input bdry condition, the thickness there will be set in initialization - - ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary - ! - ! from left neighbor: flux_enter (:,:,1) - ! from right neighbor: flux_enter (:,:,2) - ! from bottom neighbor: flux_enter (:,:,3) - ! from top neighbor: flux_enter (:,:,4) - ! - ! o--- (4) ---o - ! | | - ! (1) (2) - ! | | - ! o--- (3) ---o - ! - - integer :: isym, i, j, is, ie, js, je, isd, ied, jsd, jed, gjed, gied - integer :: i_off, j_off - logical :: at_east_bdry, at_west_bdry, one_off_west_bdry, one_off_east_bdry - type(ocean_grid_type), pointer :: G - real, dimension(-2:2) :: stencil - real, dimension(:,:), pointer :: hmask, u_face_mask, u_flux_boundary_values,u_boundary_values,t_boundary - real :: u_face, & ! positive if out - flux_diff_cell, phi, dxh, dyh, dxdyh - - character (len=1) :: debug_str, procnum - -! if (CS%grid%symmetric) then -! isym = 1 -! else -! isym = 0 -! endif - - isym = 0 - - G => CS%grid - hmask => CS%hmask - u_face_mask => CS%u_face_mask - u_flux_boundary_values => CS%u_flux_boundary_values - u_boundary_values => CS%u_shelf -! h_boundaries => CS%h_shelf - t_boundary => CS%t_boundary_values - is = G%isc-2 ; ie = G%iec+2 ; js = G%jsc ; je = G%jec ; isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - i_off = G%idg_offset ; j_off = G%jdg_offset - - do j=jsd+1,jed-1 - if (((j+j_off) .le. G%domain%njglobal+G%domain%njhalo) .AND. & - ((j+j_off) .ge. G%domain%njhalo+1)) then ! based on mehmet's code - only if btw north & south boundaries - - stencil(:) = -1 -! if (i+i_off .eq. G%domain%nihalo+G%domain%nihalo) - do i=is,ie - - if (((i+i_off) .le. G%domain%niglobal+G%domain%nihalo) .AND. & - ((i+i_off) .ge. G%domain%nihalo+1)) then - - if (i+i_off .eq. G%domain%nihalo+1) then - at_west_bdry=.true. - else - at_west_bdry=.false. - endif - - if (i+i_off .eq. G%domain%niglobal+G%domain%nihalo) then - at_east_bdry=.true. - else - at_east_bdry=.false. - endif - - if (hmask(i,j) .eq. 1) then - - dxh = G%dxT(i,j) ; dyh = G%dyT(i,j) ; dxdyh = G%areaT(i,j) - - h_after_uflux(i,j) = h0(i,j) - - stencil(:) = h0(i-2:i+2,j) ! fine as long has nx_halo >= 2 - - flux_diff_cell = 0 - - ! 1ST DO LEFT FACE - - if (u_face_mask (i-1,j) .eq. 4.) then - - flux_diff_cell = flux_diff_cell + dyh * time_step * u_flux_boundary_values (i-1,j) * & - t_boundary(i-1,j) / dxdyh -! assume no flux bc for temp -! flux_diff_cell = flux_diff_cell + dyh * time_step * CS%u_shelf(i,j)*t_boundary(i-1,j) / dxdyh - - else - - ! get u-velocity at center of left face - u_face = 0.5 * (CS%u_shelf(i-1,j-1) + CS%u_shelf(i-1,j)) - - ! if (at_west_bdry .and. (i .eq. G%isc)) then - ! print *, j, u_face, stencil(-1) - ! endif - - if (u_face .gt. 0) then !flux is into cell - we need info from h(i-2), h(i-1) if available - - ! i may not cover all the cases.. but i cover the realistic ones - - if (at_west_bdry .AND. (hmask(i-1,j).eq.3)) then ! at western bdry but there is a thickness bdry condition, - ! and the stencil contains it - stencil (-1) = CS%t_boundary_values(i-1,j)*CS%h_shelf(i-1,j) - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step * stencil(-1) / dxdyh - - elseif (hmask(i-1,j) * hmask(i-2,j) .eq. 1) then ! h(i-2) and h(i-1) are valid - phi = slope_limiter (stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh* time_step / dxdyh * & - (stencil(-1) - phi * (stencil(-1)-stencil(0))/2) - - else ! h(i-1) is valid - ! (o.w. flux would most likely be out of cell) - ! but h(i-2) is not - - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step / dxdyh * stencil(-1) - - endif - - elseif (u_face .lt. 0) then !flux is out of cell - we need info from h(i-1), h(i+1) if available - if (hmask(i-1,j) * hmask(i+1,j) .eq. 1) then ! h(i-1) and h(i+1) are both valid - phi = slope_limiter (stencil(0)-stencil(1), stencil(-1)-stencil(0)) - flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * & - (stencil(0) - phi * (stencil(0)-stencil(-1))/2) - - else - flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * stencil(0) - - if ((hmask(i-1,j) .eq. 0) .OR. (hmask(i-1,j) .eq. 2)) then - flux_enter(i-1,j,2) = ABS(u_face) * dyh * time_step * stencil(0) - endif - endif - endif - endif - - ! NEXT DO RIGHT FACE - - ! get u-velocity at center of right face - - if (u_face_mask (i+1,j) .eq. 4.) then - - flux_diff_cell = flux_diff_cell + dyh * time_step * u_flux_boundary_values (i+1,j) *& - t_boundary(i+1,j)/ dxdyh -! assume no flux bc for temp -! flux_diff_cell = flux_diff_cell + dyh * time_step * CS%u_shelf(i,j)*t_boundary (i+1,j)/ dxdyh - - else - - u_face = 0.5 * (CS%u_shelf(i,j-1) + CS%u_shelf(i,j)) - - if (u_face .lt. 0) then !flux is into cell - we need info from h(i+2), h(i+1) if available - - if (at_east_bdry .AND. (hmask(i+1,j).eq.3)) then ! at eastern bdry but there is a thickness bdry condition, - ! and the stencil contains it - - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step * stencil(1) / dxdyh - - elseif (hmask(i+1,j) * hmask(i+2,j) .eq. 1) then ! h(i+2) and h(i+1) are valid - - phi = slope_limiter (stencil(1)-stencil(2), stencil(0)-stencil(1)) - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step / dxdyh * & - (stencil(1) - phi * (stencil(1)-stencil(0))/2) - - else ! h(i+1) is valid - ! (o.w. flux would most likely be out of cell) - ! but h(i+2) is not - - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step / dxdyh * stencil(1) - - endif - - elseif (u_face .gt. 0) then !flux is out of cell - we need info from h(i-1), h(i+1) if available - - if (hmask(i-1,j) * hmask(i+1,j) .eq. 1) then ! h(i-1) and h(i+1) are both valid - - phi = slope_limiter (stencil(0)-stencil(-1), stencil(1)-stencil(0)) - flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * & - (stencil(0) - phi * (stencil(0)-stencil(1))/2) - - else ! h(i+1) is valid - ! (o.w. flux would most likely be out of cell) - ! but h(i+2) is not - - flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * stencil(0) - - if ((hmask(i+1,j) .eq. 0) .OR. (hmask(i+1,j) .eq. 2)) then - - flux_enter(i+1,j,1) = ABS(u_face) * dyh * time_step * stencil(0) - endif - - endif - - endif - - h_after_uflux(i,j) = h_after_uflux(i,j) + flux_diff_cell - - endif - - elseif ((hmask(i,j) .eq. 0) .OR. (hmask(i,j) .eq. 2)) then + write (mesg,*) "TIME in ice shelf call, yrs: ", time_type_to_real(Time)/(365. * 86400.) + call MOM_mesg("solo_time_step: "//mesg) - if (at_west_bdry .AND. (hmask(i-1,j) .EQ. 3)) then - u_face = 0.5 * (CS%u_shelf(i-1,j-1) + CS%u_shelf(i-1,j)) - flux_enter (i,j,1) = ABS(u_face) * G%dyT(i,j) * time_step * t_boundary(i-1,j)*CS%thickness_boundary_values(i+1,j) - elseif (u_face_mask (i-1,j) .eq. 4.) then - flux_enter (i,j,1) = G%dyT(i,j) * time_step * u_flux_boundary_values (i-1,j)*t_boundary(i-1,j) -! flux_enter (i,j,1) = G%dyh(i,j) * time_step * CS%u_shelf(i,j)*t_boundary (i-1,j) -! assume no flux bc for temp - endif - - if (at_east_bdry .AND. (hmask(i+1,j) .EQ. 3)) then - u_face = 0.5 * (CS%u_shelf(i,j-1) + CS%u_shelf(i,j)) - flux_enter(i,j,2) = ABS(u_face) * G%dyT(i,j) * time_step * t_boundary(i+1,j)*CS%thickness_boundary_values(i+1,j) - elseif (u_face_mask (i+1,j) .eq. 4.) then - flux_enter (i,j,2) = G%dyT(i,j) * time_step * u_flux_boundary_values (i+1,j) * t_boundary(i+1,j) -! assume no flux bc for temp -! flux_enter (i,j,2) = G%dyh(i,j) * time_step * CS%u_shelf(i,j)*t_boundary (i+1,j) - endif - -! if ((i .eq. is) .AND. (hmask(i,j) .eq. 0) .AND. (hmask(i-1,j) .eq. 1)) then - ! this is solely for the purposes of keeping the mask consistent while advancing the front without having - ! to call pass_var - if cell is empty and cell to left is ice-covered then this cell will become partly covered - -! hmask(i,j) = 2 -! elseif ((i .eq. ie) .AND. (hmask(i,j) .eq. 0) .AND. (hmask(i+1,j) .eq. 1)) then - ! this is solely for the purposes of keeping the mask consistent while advancing the front without having - ! to call pass_var - if cell is empty and cell to left is ice-covered then this cell will become partly covered - -! hmask(i,j) = 2 - -! endif - - endif - - endif + do while (time_step_remain > 0.0) + nsteps = nsteps+1 - enddo ! i loop + ! If time_step is not too long, this is unnecessary. + time_step_int = min(ice_time_step_CFL(CS%dCS, ISS, G), time_step) + write (mesg,*) "Ice model timestep = ", time_step_int, " seconds" + if (time_step_int < min_time_step) then + call MOM_error(FATAL, "MOM_ice_shelf:solo_time_step: abnormally small timestep "//mesg) + else + call MOM_mesg("solo_time_step: "//mesg) endif - enddo ! j loop - -! write (procnum,'(I1)') mpp_pe() - -end subroutine ice_shelf_advect_temp_x - -subroutine ice_shelf_advect_temp_y (CS, time_step, h_after_uflux, h_after_vflux, flux_enter) - type(ice_shelf_CS), pointer :: CS - real, intent(in) :: time_step - real, dimension(:,:), intent(in) :: h_after_uflux - real, dimension(:,:), intent(inout) :: h_after_vflux - real, dimension(:,:,:), intent(inout) :: flux_enter - - ! use will be made of CS%hmask here - its value at the boundary will be zero, just like uncovered cells - - ! if there is an input bdry condition, the thickness there will be set in initialization - - ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary - ! - ! from left neighbor: flux_enter (:,:,1) - ! from right neighbor: flux_enter (:,:,2) - ! from bottom neighbor: flux_enter (:,:,3) - ! from top neighbor: flux_enter (:,:,4) - ! - ! o--- (4) ---o - ! | | - ! (1) (2) - ! | | - ! o--- (3) ---o - ! - - integer :: isym, i, j, is, ie, js, je, isd, ied, jsd, jed, gjed, gied - integer :: i_off, j_off - logical :: at_north_bdry, at_south_bdry, one_off_west_bdry, one_off_east_bdry - type(ocean_grid_type), pointer :: G - real, dimension(-2:2) :: stencil - real, dimension(:,:), pointer :: hmask, v_face_mask, v_flux_boundary_values,t_boundary,v_boundary_values - real :: v_face, & ! positive if out - flux_diff_cell, phi, dxh, dyh, dxdyh - character(len=1) :: debug_str, procnum - -! if (CS%grid%symmetric) then -! isym = 1 -! else -! isym = 0 -! endif - - isym = 0 - - G => CS%grid - hmask => CS%hmask - v_face_mask => CS%v_face_mask - v_flux_boundary_values => CS%v_flux_boundary_values - t_boundary => CS%t_boundary_values - v_boundary_values => CS%v_shelf - is = G%isc ; ie = G%iec ; js = G%jsc-1 ; je = G%jec+1 ; isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - i_off = G%idg_offset ; j_off = G%jdg_offset - - do i=isd+2,ied-2 - if (((i+i_off) .le. G%domain%niglobal+G%domain%nihalo) .AND. & - ((i+i_off) .ge. G%domain%nihalo+1)) then ! based on mehmet's code - only if btw east & west boundaries - - stencil(:) = -1 - - do j=js,je - - if (((j+j_off) .le. G%domain%njglobal+G%domain%njhalo) .AND. & - ((j+j_off) .ge. G%domain%njhalo+1)) then - - if (j+j_off .eq. G%domain%njhalo+1) then - at_south_bdry=.true. - else - at_south_bdry=.false. - endif - if (j+j_off .eq. G%domain%njglobal+G%domain%njhalo) then - at_north_bdry=.true. - else - at_north_bdry=.false. - endif - - if (hmask(i,j) .eq. 1) then - dxh = G%dxT(i,j) ; dyh = G%dyT(i,j) ; dxdyh = G%areaT(i,j) - h_after_vflux (i,j) = h_after_uflux (i,j) - - stencil (:) = h_after_uflux (i,j-2:j+2) ! fine as long has ny_halo >= 2 - flux_diff_cell = 0 - - ! 1ST DO south FACE - - if (v_face_mask (i,j-1) .eq. 4.) then - - flux_diff_cell = flux_diff_cell + dxh * time_step * v_flux_boundary_values (i,j-1) * t_boundary(i,j-1)/ dxdyh -! assume no flux bc for temp -! flux_diff_cell = flux_diff_cell + dxh * time_step * CS%v_shelf(i,j)*t_boundary (i,j-1) / dxdyh - - else - - ! get u-velocity at center of left face - v_face = 0.5 * (CS%v_shelf(i-1,j-1) + CS%v_shelf(i,j-1)) - - if (v_face .gt. 0) then !flux is into cell - we need info from h(j-2), h(j-1) if available - - ! i may not cover all the cases.. but i cover the realistic ones - - if (at_south_bdry .AND. (hmask(i,j-1).eq.3)) then ! at western bdry but there is a thickness bdry condition, - ! and the stencil contains it - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step * stencil(-1) / dxdyh - - elseif (hmask(i,j-1) * hmask(i,j-2) .eq. 1) then ! h(j-2) and h(j-1) are valid - - phi = slope_limiter (stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * & - (stencil(-1) - phi * (stencil(-1)-stencil(0))/2) - - else ! h(j-1) is valid - ! (o.w. flux would most likely be out of cell) - ! but h(j-2) is not - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * stencil(-1) - endif - - elseif (v_face .lt. 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available - - if (hmask(i,j-1) * hmask(i,j+1) .eq. 1) then ! h(j-1) and h(j+1) are both valid - phi = slope_limiter (stencil(0)-stencil(1), stencil(-1)-stencil(0)) - flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * & - (stencil(0) - phi * (stencil(0)-stencil(-1))/2) - else - flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * stencil(0) - - if ((hmask(i,j-1) .eq. 0) .OR. (hmask(i,j-1) .eq. 2)) then - flux_enter(i,j-1,4) = ABS(v_face) * dyh * time_step * stencil(0) - endif - - endif - - endif - - endif - - ! NEXT DO north FACE - - if (v_face_mask(i,j+1) .eq. 4.) then - - flux_diff_cell = flux_diff_cell + dxh * time_step * v_flux_boundary_values (i,j+1) *& - t_boundary(i,j+1)/ dxdyh -! assume no flux bc for temp -! flux_diff_cell = flux_diff_cell + dxh * time_step * CS%v_shelf(i,j)*t_boundary (i,j+1) / dxdyh - - else - - ! get u-velocity at center of right face - v_face = 0.5 * (CS%v_shelf(i-1,j) + CS%v_shelf(i,j)) - - if (v_face .lt. 0) then !flux is into cell - we need info from h(j+2), h(j+1) if available - - if (at_north_bdry .AND. (hmask(i,j+1).eq.3)) then ! at eastern bdry but there is a thickness bdry condition, - ! and the stencil contains it - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step * stencil(1) / dxdyh - elseif (hmask(i,j+1) * hmask(i,j+2) .eq. 1) then ! h(j+2) and h(j+1) are valid - phi = slope_limiter (stencil(1)-stencil(2), stencil(0)-stencil(1)) - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * & - (stencil(1) - phi * (stencil(1)-stencil(0))/2) - else ! h(j+1) is valid - ! (o.w. flux would most likely be out of cell) - ! but h(j+2) is not - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * stencil(1) - endif - - elseif (v_face .gt. 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available - - if (hmask(i,j-1) * hmask(i,j+1) .eq. 1) then ! h(j-1) and h(j+1) are both valid - phi = slope_limiter (stencil(0)-stencil(-1), stencil(1)-stencil(0)) - flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * & - (stencil(0) - phi * (stencil(0)-stencil(1))/2) - else ! h(j+1) is valid - ! (o.w. flux would most likely be out of cell) - ! but h(j+2) is not - flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * stencil(0) - if ((hmask(i,j+1) .eq. 0) .OR. (hmask(i,j+1) .eq. 2)) then - flux_enter(i,j+1,3) = ABS(v_face) * dxh * time_step * stencil(0) - endif - endif - - endif - - endif - - h_after_vflux (i,j) = h_after_vflux (i,j) + flux_diff_cell - - elseif ((hmask(i,j) .eq. 0) .OR. (hmask(i,j) .eq. 2)) then - - if (at_south_bdry .AND. (hmask(i,j-1) .EQ. 3)) then - v_face = 0.5 * (CS%v_shelf(i-1,j-1) + CS%v_shelf(i,j-1)) - flux_enter (i,j,3) = ABS(v_face) * G%dxT(i,j) * time_step * t_boundary(i,j-1)*CS%thickness_boundary_values(i,j-1) - elseif (v_face_mask(i,j-1) .eq. 4.) then - flux_enter (i,j,3) = G%dxT(i,j) * time_step * v_flux_boundary_values (i,j-1)*t_boundary(i,j-1) -! assume no flux bc for temp -! flux_enter (i,j,3) = G%dxh(i,j) * time_step * CS%v_shelf(i,j)*t_boundary (i,j-1) - - endif + if (time_step_int >= time_step_remain) then + time_step_int = time_step_remain + time_step_remain = 0.0 + else + time_step_remain = time_step_remain - time_step_int + endif - if (at_north_bdry .AND. (hmask(i,j+1) .EQ. 3)) then - v_face = 0.5 * (CS%v_shelf(i-1,j) + CS%v_shelf(i,j)) - flux_enter (i,j,4) = ABS(v_face) * G%dxT(i,j) * time_step * t_boundary(i,j+1)*CS%thickness_boundary_values(i,j+1) - elseif (v_face_mask(i,j+1) .eq. 4.) then - flux_enter (i,j,4) = G%dxT(i,j) * time_step * v_flux_boundary_values (i,j+1)*t_boundary(i,j+1) -! assume no flux bc for temp -! flux_enter (i,j,4) = G%dxh(i,j) * time_step * CS%v_shelf(i,j)*t_boundary (i,j+1) - endif + ! If the last mini-timestep is a day or less, we cannot expect velocities to change by much. + ! Do not update the velocities if the last step is very short. + update_ice_vel = ((time_step_int > min_time_step) .or. (time_step_int >= time_step)) + coupled_GL = .false. -! if ((j .eq. js) .AND. (hmask(i,j) .eq. 0) .AND. (hmask(i,j-1) .eq. 1)) then - ! this is solely for the purposes of keeping the mask consistent while advancing the front without having - ! to call pass_var - if cell is empty and cell to left is ice-covered then this cell will become partly covered - ! hmask (i,j) = 2 - ! elseif ((j .eq. je) .AND. (hmask(i,j) .eq. 0) .AND. (hmask(i,j+1) .eq. 1)) then - ! this is solely for the purposes of keeping the mask consistent while advancing the front without having - ! to call pass_var - if cell is empty and cell to left is ice-covered then this cell will become partly covered -! hmask (i,j) = 2 -! endif + call update_ice_shelf(CS%dCS, ISS, G, US, time_step_int, Time, must_update_vel=update_ice_vel) - endif - endif - enddo ! j loop - endif - enddo ! i loop + call enable_averaging(time_step,Time,CS%diag) + if (CS%id_area_shelf_h > 0) call post_data(CS%id_area_shelf_h, ISS%area_shelf_h, CS%diag) + if (CS%id_h_shelf > 0) call post_data(CS%id_h_shelf, ISS%h_shelf, CS%diag) + if (CS%id_h_mask > 0) call post_data(CS%id_h_mask, ISS%hmask, CS%diag) + call disable_averaging(CS%diag) - !write (procnum,'(I1)') mpp_pe() + enddo -end subroutine ice_shelf_advect_temp_y +end subroutine solo_time_step !> \namespace mom_ice_shelf !! !! \section section_ICE_SHELF !! !! This module implements the thermodynamic aspects of ocean/ice-shelf -!! inter-actions, along with a crude placeholder for a later implementation of full -!! ice shelf dynamics, all using the MOM framework and coding style. +!! inter-actions using the MOM framework and coding style. !! !! Derived from code by Chris Little, early 2010. !! -!! NOTE: THERE ARE A NUMBER OF SUBROUTINES WITH "TRIANGLE" IN THE NAME; THESE -!! HAVE NOT BEEN TESTED AND SHOULD PROBABLY BE PHASED OUT -!! !! The ice-sheet dynamics subroutines do the following: !! initialize_shelf_mass - Initializes the ice shelf mass distribution. !! - Initializes h_shelf, h_mask, area_shelf_h @@ -6687,48 +1831,9 @@ end subroutine ice_shelf_advect_temp_y !! h_shelf and density_ice immediately afterwards. Possibly subroutine should be renamed !! update_shelf_mass - updates ice shelf mass via netCDF file !! USER_update_shelf_mass (TODO). -!! ice_shelf_solve_outer - Orchestrates the calls to calculate the shelf -!! - outer loop calls ice_shelf_solve_inner -!! stresses and checks for error tolerances. -!! Max iteration count for outer loop currently fixed at 100 iteration -!! - tolerance (and error evaluation) can be set through input file -!! - updates u_shelf, v_shelf, ice_visc_bilinear, taub_beta_eff_bilinear -!! ice_shelf_solve_inner - Conjugate Gradient solve of matrix solve for ice_shelf_solve_outer -!! - Jacobi Preconditioner - basically diagonal of matrix (not sure if it is effective at all) -!! - modifies u_shelf and v_shelf only -!! - max iteration count can be set through input file -!! - tolerance (and error evaluation) can be set through input file -!! (ISSUE: Too many mpp_sum calls?) -!! calc_shelf_driving_stress - Determine the driving stresses using h_shelf, (water) column thickness, bathymetry -!! - does not modify any permanent arrays -!! init_boundary_values - -!! bilinear_shape_functions - shape function for FEM solve using (convex) quadrilateral elements and bilinear nodal basis -!! calc_shelf_visc_bilinear - Glen's law viscosity and nonlinear sliding law (called by ice_shelf_solve_outer) -!! calc_shelf_visc_triangular - LET'S TAKE THIS OUT -!! apply_boundary_values_bilinear - same as CG_action_bilinear, but input is zero except for dirichlet bdry conds -!! apply_boundary_values_triangle - LET'S TAKE THIS OUT -!! CG_action_bilinear - Effect of matrix (that is never explicitly constructed) -!! on vector space of Degrees of Freedom (DoFs) in velocity solve -!! CG_action_triangular -LET'S TAKE THIS OUT -!! matrix_diagonal_bilinear - Returns the diagonal entries of a matrix for preconditioning. -!! (ISSUE: No need to use control structure - add arguments. -!! matrix_diagonal_triangle - LET'S TAKE THIS OUT -!! ice_shelf_advect - Given the melt rate and velocities, it advects the ice shelf THICKNESS -!! - modified h_shelf, area_shelf_h, hmask -!! (maybe should updater mass_shelf as well ???) -!! ice_shelf_advect_thickness_x, ice_shelf_advect_thickness_y - These -!! subroutines determine the mass fluxes through the faces. -!! (ISSUE: duplicative flux calls for shared faces?) -!! ice_shelf_advance_front - Iteratively determine the ice-shelf front location. -!! - IF ice_shelf_advect_thickness_x,y are modified to avoid -!! dupe face processing, THIS NEEDS TO BE MODIFIED TOO -!! as it depends on arrays modified in those functions -!! (if in doubt consult DNG) -!! update_velocity_masks - Controls which elements of u_shelf and v_shelf are considered DoFs in linear solve !! solo_time_step - called only in ice-only mode. !! shelf_calc_flux - after melt rate & fluxes are calculated, ice dynamics are done. currently mass_shelf is -!! updated immediately after ice_shelf_advect. -!! +!! updated immediately after ice_shelf_advect in fully dynamic mode. !! !! NOTES: be aware that hmask(:,:) has a number of functions; it is used for front advancement, !! for subroutines in the velocity solve, and for thickness boundary conditions (this last one may be removed). @@ -6737,11 +1842,6 @@ end subroutine ice_shelf_advect_temp_y !! Overall issues: Many variables need better documentation and units and the !! subgrid on which they are discretized. !! -!! DNG 4/09/11 : due to a misunderstanding (i confused a SYMMETRIC GRID -!! a SOUTHWEST GRID there is a variable called "isym" that appears -!! throughout in array loops. i am leaving it in for now, -!!though uniformly setting it to zero -!! !! \subsection section_ICE_SHELF_equations ICE_SHELF equations !! !! The three fundamental equations are: @@ -6770,134 +1870,4 @@ end subroutine ice_shelf_advect_temp_y !! Holland, David M., and Adrian Jenkins. Modeling thermodynamic ice-ocean interactions at the base of an ice shelf. !! Journal of Physical Oceanography 29.8 (1999): 1787-1800. - - -! GMM, I am putting all the commented functions below - -! subroutine add_shelf_flux_IOB(CS, state, forces, fluxes) -! ! type(ice_ocean_boundary_type), intent(inout) :: IOB -! type(ice_shelf_CS), intent(in) :: CS -! type(surface), intent(inout) :: state -! type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces -! type(forcing), intent(inout) :: fluxes - -! ! Arguments: -! ! (in) fluxes - A structure of surface fluxes that may be used. -! ! (in) visc - A structure containing vertical viscosities, bottom boundary -! ! layer properies, and related fields. -! ! (in) G - The ocean's grid structure. -! ! (in) CS - This module's control structure. -! !need to use visc variables -! !time step therm v. dynamic? -! real :: Irho0 ! The inverse of the mean density in m3 kg-1. -! real :: frac_area ! The fractional area covered by the ice shelf, nondim. -! real :: taux2, tauy2 ! The squared surface stresses, in Pa. -! real :: asu1, asu2 ! Ocean areas covered by ice shelves at neighboring u- -! real :: asv1, asv2 ! and v-points, in m2. -! integer :: i, j, is, ie, js, je, isd, ied, jsd, jed -! type(ocean_grid_type), pointer :: G - -! G=>CS%grid -! is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec -! isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed - -! Irho0 = 1.0 / CS%Rho0 -! ! Determine ustar and the square magnitude of the velocity in the -! ! bottom boundary layer. Together these give the TKE source and -! ! vertical decay scale. -! if (CS%shelf_mass_is_dynamic) then -! do j=jsd,jed ; do i=isd,ied -! if (G%areaT(i,j) > 0.0) & -! fluxes%frac_shelf_h(i,j) = CS%area_shelf_h(i,j) / G%areaT(i,j) -! enddo ; enddo -! !do I=isd,ied-1 ; do j=isd,jed -! do j=jsd,jed ; do i=isd,ied-1 ! ### changed stride order; i->ied-1? -! forces%frac_shelf_u(I,j) = 0.0 -! if ((G%areaT(i,j) + G%areaT(i+1,j) > 0.0)) & ! .and. (G%dxdy_u(I,j) > 0.0)) & -! forces%frac_shelf_u(I,j) = ((CS%area_shelf_h(i,j) + CS%area_shelf_h(i+1,j)) / & -! (G%areaT(i,j) + G%areaT(i+1,j))) -! forces%rigidity_ice_u(I,j) = (CS%kv_ice / CS%density_ice) * & -! min(CS%mass_shelf(i,j), CS%mass_shelf(i+1,j)) -! enddo ; enddo -! do j=jsd,jed-1 ; do i=isd,ied ! ### change stride order; j->jed-1? -! !do i=isd,ied ; do J=isd,jed-1 -! forces%frac_shelf_v(i,J) = 0.0 -! if ((G%areaT(i,j) + G%areaT(i,j+1) > 0.0)) & ! .and. (G%dxdy_v(i,J) > 0.0)) & -! forces%frac_shelf_v(i,J) = ((CS%area_shelf_h(i,j) + CS%area_shelf_h(i,j+1)) / & -! (G%areaT(i,j) + G%areaT(i,j+1))) -! forces%rigidity_ice_v(i,J) = (CS%kv_ice / CS%density_ice) * & -! min(CS%mass_shelf(i,j), CS%mass_shelf(i,j+1)) -! enddo ; enddo -! call pass_vector(forces%frac_shelf_u, forces%frac_shelf_v, G%domain, TO_ALL, CGRID_NE) -! endif - -! if (CS%debug) then -! if (associated(state%taux_shelf)) then -! call uchksum(state%taux_shelf, "taux_shelf", G%HI, haloshift=0) -! endif -! if (associated(state%tauy_shelf)) then -! call vchksum(state%tauy_shelf, "tauy_shelf", G%HI, haloshift=0) -! endif -! endif - -! if (associated(state%taux_shelf) .and. associated(state%tauy_shelf)) then -! call pass_vector(state%taux_shelf, state%tauy_shelf, G%domain, TO_ALL, CGRID_NE) -! endif - -! do j=G%jsc,G%jec ; do i=G%isc,G%iec -! frac_area = fluxes%frac_shelf_h(i,j) -! if (frac_area > 0.0) then -! ! ### THIS SHOULD BE AN AREA WEIGHTED AVERAGE OF THE ustar_shelf POINTS. -! taux2 = 0.0 ; tauy2 = 0.0 -! asu1 = forces%frac_shelf_u(i-1,j) * (G%areaT(i-1,j) + G%areaT(i,j)) ! G%dxdy_u(i-1,j) -! asu2 = forces%frac_shelf_u(i,j) * (G%areaT(i,j) + G%areaT(i+1,j)) ! G%dxdy_u(i,j) -! asv1 = forces%frac_shelf_v(i,j-1) * (G%areaT(i,j-1) + G%areaT(i,j)) ! G%dxdy_v(i,j-1) -! asv2 = forces%frac_shelf_v(i,j) * (G%areaT(i,j) + G%areaT(i,j+1)) ! G%dxdy_v(i,j) -! if ((asu1 + asu2 > 0.0) .and. associated(state%taux_shelf)) & -! taux2 = (asu1 * state%taux_shelf(i-1,j)**2 + & -! asu2 * state%taux_shelf(i,j)**2 ) / (asu1 + asu2) -! if ((asv1 + asv2 > 0.0) .and. associated(state%tauy_shelf)) & -! tauy2 = (asv1 * state%tauy_shelf(i,j-1)**2 + & -! asv2 * state%tauy_shelf(i,j)**2 ) / (asv1 + asv2) -! fluxes%ustar_shelf(i,j) = MAX(CS%ustar_bg, sqrt(Irho0 * sqrt(taux2 + tauy2))) - -! if (CS%lprec(i,j) > 0.0) then -! fluxes%lprec(i,j) = fluxes%lprec(i,j) + frac_area*CS%lprec(i,j) -! ! Same for IOB%lprec -! else -! fluxes%evap(i,j) = fluxes%evap(i,j) + frac_area*CS%lprec(i,j) -! ! Same for -1*IOB%q_flux -! endif -! fluxes%sens(i,j) = fluxes%sens(i,j) - frac_area*CS%t_flux(i,j) -! ! Same for -1*IOB%t_flux -! ! fluxes%salt_flux(i,j) = fluxes%salt_flux(i,j) + frac_area * CS%salt_flux(i,j) -! ! ! Same for IOB%salt_flux. -! fluxes%p_surf(i,j) = fluxes%p_surf(i,j) + & -! frac_area * CS%g_Earth * CS%mass_shelf(i,j) -! ! Same for IOB%p -! if (associated(fluxes%p_surf_full)) fluxes%p_surf_full(i,j) = & -! fluxes%p_surf_full(i,j) + frac_area * CS%g_Earth * CS%mass_shelf(i,j) -! endif -! enddo ; enddo - -! if (CS%debug) then -! call hchksum(fluxes%ustar_shelf, "ustar_shelf", G%HI, haloshift=0) -! endif - -! ! If the shelf mass is changing, the forces%rigidity_ice_[uv] needs to be -! ! updated here. - -! if (CS%shelf_mass_is_dynamic) then -! do j=G%jsc,G%jec ; do i=G%isc-1,G%iec -! forces%rigidity_ice_u(I,j) = (CS%kv_ice / CS%density_ice) * & -! min(CS%mass_shelf(i,j), CS%mass_shelf(i+1,j)) -! enddo ; enddo - -! do j=G%jsc-1,G%jec ; do i=G%isc,G%iec -! forces%rigidity_ice_v(i,J) = (CS%kv_ice / CS%density_ice) * & -! min(CS%mass_shelf(i,j), CS%mass_shelf(i,j+1)) -! enddo ; enddo -! endif -! end subroutine add_shelf_flux_IOB - end module MOM_ice_shelf diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 new file mode 100644 index 0000000000..b53021bbb2 --- /dev/null +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -0,0 +1,4051 @@ +!> Implements a crude placeholder for a later implementation of full +!! ice shelf dynamics. +module MOM_ice_shelf_dynamics + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_COMPONENT, CLOCK_ROUTINE +use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr +use MOM_diag_mediator, only : diag_mediator_init, set_diag_mediator_grid +use MOM_diag_mediator, only : diag_ctrl, time_type, enable_averaging, disable_averaging +use MOM_domains, only : MOM_domains_init, clone_MOM_domain +use MOM_domains, only : pass_var, pass_vector, TO_ALL, CGRID_NE, BGRID_NE, CORNER +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe +use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type +use MOM_grid, only : MOM_grid_init, ocean_grid_type +use MOM_io, only : file_exists, slasher, MOM_read_data +use MOM_restart, only : register_restart_field, query_initialized +use MOM_restart, only : MOM_restart_CS +use MOM_time_manager, only : time_type, set_time +use MOM_unit_scaling, only : unit_scale_type, unit_scaling_init +!MJH use MOM_ice_shelf_initialize, only : initialize_ice_shelf_boundary +use MOM_ice_shelf_state, only : ice_shelf_state +use MOM_coms, only : reproducing_sum, sum_across_PEs, max_across_PEs, min_across_PEs +use MOM_checksums, only : hchksum, qchksum + +implicit none ; private + +#include + +public register_ice_shelf_dyn_restarts, initialize_ice_shelf_dyn, update_ice_shelf +public ice_time_step_CFL, ice_shelf_dyn_end +public shelf_advance_front, ice_shelf_min_thickness_calve, calve_to_mask + +! 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 ice shelf dynamics. +type, public :: ice_shelf_dyn_CS ; private + real, pointer, dimension(:,:) :: u_shelf => NULL() !< the zonal (?) velocity of the ice shelf/sheet + !! on q-points (B grid) [m s-1]?? + real, pointer, dimension(:,:) :: v_shelf => NULL() !< the meridional velocity of the ice shelf/sheet + !! on q-points (B grid) [m s-1]?? + + real, pointer, dimension(:,:) :: u_face_mask => NULL() !< mask for velocity boundary conditions on the C-grid + !! u-face - this is because the FEM cares about FACES THAT GET INTEGRATED OVER, + !! not vertices. Will represent boundary conditions on computational boundary + !! (or permanent boundary between fast-moving and near-stagnant ice + !! FOR NOW: 1=interior bdry, 0=no-flow boundary, 2=stress bdry condition, + !! 3=inhomogeneous dirichlet boundary, 4=flux boundary: at these faces a flux + !! will be specified which will override velocities; a homogeneous velocity + !! condition will be specified (this seems to give the solver less difficulty) + real, pointer, dimension(:,:) :: v_face_mask => NULL() !< A mask for velocity boundary conditions on the C-grid + !! v-face, with valued defined similarly to u_face_mask. + real, pointer, dimension(:,:) :: u_face_mask_bdry => NULL() !< A duplicate copy of u_face_mask? + real, pointer, dimension(:,:) :: v_face_mask_bdry => NULL() !< A duplicate copy of v_face_mask? + real, pointer, dimension(:,:) :: u_flux_bdry_val => NULL() !< The ice volume flux into the cell through open boundary + !! u-faces (where u_face_mask=4) [Z m2 s-1 ~> m3 s-1]?? + real, pointer, dimension(:,:) :: v_flux_bdry_val => NULL() !< The ice volume flux into the cell through open boundary + !! v-faces (where v_face_mask=4) [Z m2 s-1 ~> m3 s-1]?? + ! needed where u_face_mask is equal to 4, similary for v_face_mask + real, pointer, dimension(:,:) :: umask => NULL() !< u-mask on the actual degrees of freedom (B grid) + !! 1=normal node, 3=inhomogeneous boundary node, + !! 0 - no flow node (will also get ice-free nodes) + real, pointer, dimension(:,:) :: vmask => NULL() !< v-mask on the actual degrees of freedom (B grid) + !! 1=normal node, 3=inhomogeneous boundary node, + !! 0 - no flow node (will also get ice-free nodes) + real, pointer, dimension(:,:) :: calve_mask => NULL() !< a mask to prevent the ice shelf front from + !! advancing past its initial position (but it may retreat) + real, pointer, dimension(:,:) :: t_shelf => NULL() !< Veritcally integrated temperature in the ice shelf/stream, + !! on corner-points (B grid) [degC] + real, pointer, dimension(:,:) :: tmask => NULL() !< A mask on tracer points that is 1 where there is ice. + real, pointer, dimension(:,:) :: ice_visc => NULL() !< Glen's law ice viscosity, perhaps in [m]. + real, pointer, dimension(:,:) :: thickness_bdry_val => NULL() !< The ice thickness at an inflowing boundary [Z ~> m]. + real, pointer, dimension(:,:) :: u_bdry_val => NULL() !< The zonal ice velocity at inflowing boundaries [m s-1]?? + real, pointer, dimension(:,:) :: v_bdry_val => NULL() !< The meridional ice velocity at inflowing boundaries [m s-1]?? + real, pointer, dimension(:,:) :: h_bdry_val => NULL() !< The ice thickness at inflowing boundaries [m]. + real, pointer, dimension(:,:) :: t_bdry_val => NULL() !< The ice temperature at inflowing boundaries [degC]. + + real, pointer, dimension(:,:) :: taub_beta_eff => NULL() !< nonlinear part of "linearized" basal stress. + !! The exact form depends on basal law exponent and/or whether flow is "hybridized" a la Goldberg 2011 + + real, pointer, dimension(:,:) :: OD_rt => NULL() !< A running total for calculating OD_av. + real, pointer, dimension(:,:) :: float_frac_rt => NULL() !< A running total for calculating float_frac. + real, pointer, dimension(:,:) :: OD_av => NULL() !< The time average open ocean depth [Z ~> m]. + real, pointer, dimension(:,:) :: float_frac => NULL() !< Fraction of the time a cell is "exposed", i.e. the column + !! thickness is below a threshold. + !### [if float_frac = 1 ==> grounded; obviously counterintuitive; might fix] + integer :: OD_rt_counter = 0 !< A counter of the number of contributions to OD_rt. + + real :: velocity_update_time_step !< The time interval over which to update the ice shelf velocity + !! using the nonlinear elliptic equation, or 0 to update every timestep [s]. + ! DNGoldberg thinks this should be done no more often than about once a day + ! (maybe longer) because it will depend on ocean values that are averaged over + ! this time interval, and solving for the equiliabrated flow will begin to lose + ! meaning if it is done too frequently. + real :: elapsed_velocity_time !< The elapsed time since the ice velocies were last udated [s]. + + real :: g_Earth !< The gravitational acceleration [m s-2]. + real :: density_ice !< A typical density of ice [kg m-3]. + + logical :: GL_regularize !< Specifies whether to regularize the floatation condition + !! at the grounding line as in Goldberg Holland Schoof 2009 + integer :: n_sub_regularize + !< partition of cell over which to integrate for + !! interpolated grounding line the (rectangular) is + !! divided into nxn equally-sized rectangles, over which + !! basal contribution is integrated (iterative quadrature) + logical :: GL_couple !< whether to let the floatation condition be + !! determined by ocean column thickness means update_OD_ffrac + !! will be called (note: GL_regularize and GL_couple + !! should be exclusive) + + real :: CFL_factor !< A factor used to limit subcycled advective timestep in uncoupled runs + !! i.e. dt <= CFL_factor * min(dx / u) + + real :: A_glen_isothermal !< Ice viscosity parameter in Glen's Lawa, [Pa-1/3 year]. + real :: n_glen !< Nonlinearity exponent in Glen's Law + real :: eps_glen_min !< Min. strain rate to avoid infinite Glen's law viscosity, [year-1]. + real :: C_basal_friction !< Ceofficient in sliding law tau_b = C u^(n_basal_friction), in + !! units="Pa (m-a)-(n_basal_friction) + real :: n_basal_friction !< Exponent in sliding law tau_b = C u^(m_slide) + real :: density_ocean_avg !< This does not affect ocean circulation or thermodynamics. + !! It is used to estimate the gravitational driving force at the + !! shelf front (until we think of a better way to do it, + !! but any difference will be negligible). + real :: thresh_float_col_depth !< The water column depth over which the shelf if considered to be floating + logical :: moving_shelf_front !< Specify whether to advance shelf front (and calve). + logical :: calve_to_mask !< If true, calve off the ice shelf when it passes the edge of a mask. + real :: min_thickness_simple_calve !< min. ice shelf thickness criteria for calving [Z ~> m]. + + real :: cg_tolerance !< The tolerance in the CG solver, relative to initial residual, that + !! deterimnes when to stop the conguage gradient iterations. + real :: nonlinear_tolerance !< The fractional nonlinear tolerance, relative to the initial error, + !! that sets when to stop the iterative velocity solver + integer :: cg_max_iterations !< The maximum number of iterations that can be used in the CG solver + integer :: nonlin_solve_err_mode !< 1: exit vel solve based on nonlin residual + !! 2: exit based on "fixed point" metric (|u - u_last| / |u| < tol where | | is infty-norm + logical :: use_reproducing_sums !< Use reproducing global sums. + + ! ids for outputting intermediate thickness in advection subroutine (debugging) + !integer :: id_h_after_uflux = -1, id_h_after_vflux = -1, id_h_after_adv = -1 + + logical :: debug !< If true, write verbose checksums for debugging purposes + !! and use reproducible sums + logical :: module_is_initialized = .false. !< True if this module has been initialized. + + !>@{ Diagnostic handles + integer :: id_u_shelf = -1, id_v_shelf = -1, id_t_shelf = -1, & + id_float_frac = -1, id_col_thick = -1, id_OD_av = -1, & + id_u_mask = -1, id_v_mask = -1, id_t_mask = -1 + !!@} + ! ids for outputting intermediate thickness in advection subroutine (debugging) + !integer :: id_h_after_uflux = -1, id_h_after_vflux = -1, id_h_after_adv = -1 + + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to control diagnostic output. + +end type ice_shelf_dyn_CS + +contains + +!> used for flux limiting in advective subroutines Van Leer limiter (source: Wikipedia) +function slope_limiter(num, denom) + real, intent(in) :: num !< The numerator of the ratio used in the Van Leer slope limiter + real, intent(in) :: denom !< The denominator of the ratio used in the Van Leer slope limiter + real :: slope_limiter + real :: r + + if (denom == 0) then + slope_limiter = 0 + elseif (num*denom <= 0) then + slope_limiter = 0 + else + r = num/denom + slope_limiter = (r+abs(r))/(1+abs(r)) + endif + +end function slope_limiter + +!> Calculate area of quadrilateral. +function quad_area (X, Y) + real, dimension(4), intent(in) :: X !< The x-positions of the vertices of the quadrilateral. + real, dimension(4), intent(in) :: Y !< The y-positions of the vertices of the quadrilateral. + real :: quad_area, p2, q2, a2, c2, b2, d2 + +! X and Y must be passed in the form + ! 3 - 4 + ! | | + ! 1 - 2 + + p2 = (X(4)-X(1))**2 + (Y(4)-Y(1))**2 ; q2 = (X(3)-X(2))**2 + (Y(3)-Y(2))**2 + a2 = (X(3)-X(4))**2 + (Y(3)-Y(4))**2 ; c2 = (X(1)-X(2))**2 + (Y(1)-Y(2))**2 + b2 = (X(2)-X(4))**2 + (Y(2)-Y(4))**2 ; d2 = (X(3)-X(1))**2 + (Y(3)-Y(1))**2 + quad_area = .25 * sqrt(4*P2*Q2-(B2+D2-A2-C2)**2) + +end function quad_area + +!> This subroutine is used to register any fields related to the ice shelf +!! dynamics that should be written to or read from the restart file. +subroutine register_ice_shelf_dyn_restarts(G, param_file, CS, restart_CS) + type(ocean_grid_type), intent(inout) :: G !< The grid type describing the ice shelf grid. + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(ice_shelf_dyn_CS), pointer :: CS !< A pointer to the ice shelf dynamics control structure + type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure. + + logical :: shelf_mass_is_dynamic, override_shelf_movement, active_shelf_dynamics + character(len=40) :: mdl = "MOM_ice_shelf_dyn" ! This module's name. + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + if (associated(CS)) then + call MOM_error(FATAL, "MOM_ice_shelf_dyn.F90, register_ice_shelf_dyn_restarts: "// & + "called with an associated control structure.") + return + endif + allocate(CS) + + override_shelf_movement = .false. ; active_shelf_dynamics = .false. + call get_param(param_file, mdl, "DYNAMIC_SHELF_MASS", shelf_mass_is_dynamic, & + "If true, the ice sheet mass can evolve with time.", & + 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"//& + "movement instead of the dynamic ice model.", default=.false., do_not_log=.true.) + active_shelf_dynamics = .not.override_shelf_movement + endif + + if (active_shelf_dynamics) then + allocate( CS%u_shelf(IsdB:IedB,JsdB:JedB) ) ; CS%u_shelf(:,:) = 0.0 + allocate( CS%v_shelf(IsdB:IedB,JsdB:JedB) ) ; CS%v_shelf(:,:) = 0.0 + allocate( CS%t_shelf(isd:ied,jsd:jed) ) ; CS%t_shelf(:,:) = -10.0 + allocate( CS%ice_visc(isd:ied,jsd:jed) ) ; CS%ice_visc(:,:) = 0.0 + allocate( CS%taub_beta_eff(isd:ied,jsd:jed) ) ; CS%taub_beta_eff(:,:) = 0.0 + allocate( CS%OD_av(isd:ied,jsd:jed) ) ; CS%OD_av(:,:) = 0.0 + allocate( CS%float_frac(isd:ied,jsd:jed) ) ; CS%float_frac(:,:) = 0.0 + + ! additional restarts for ice shelf state + call register_restart_field(CS%u_shelf, "u_shelf", .false., restart_CS, & + "ice sheet/shelf u-velocity", "m s-1", hor_grid='Bu') + call register_restart_field(CS%v_shelf, "v_shelf", .false., restart_CS, & + "ice sheet/shelf v-velocity", "m s-1", hor_grid='Bu') + call register_restart_field(CS%t_shelf, "t_shelf", .true., restart_CS, & + "ice sheet/shelf vertically averaged temperature", "deg C") + call register_restart_field(CS%OD_av, "OD_av", .true., restart_CS, & + "Average open ocean depth in a cell","m") + call register_restart_field(CS%float_frac, "float_frac", .true., restart_CS, & + "fractional degree of grounding", "nondim") + call register_restart_field(CS%ice_visc, "viscosity", .true., restart_CS, & + "Glens law ice viscosity", "m (seems wrong)") + call register_restart_field(CS%taub_beta_eff, "tau_b_beta", .true., restart_CS, & + "Coefficient of basal traction", "m (seems wrong)") + endif + +end subroutine register_ice_shelf_dyn_restarts + +!> Initializes shelf model data, parameters and diagnostics +subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_sim, solo_ice_sheet_in) + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(ocean_grid_type), pointer :: ocn_grid !< The calling ocean model's horizontal grid structure + type(time_type), intent(inout) :: Time !< The clock that that will indicate the model time + type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ice_shelf_dyn_CS), pointer :: CS !< A pointer to the ice shelf dynamics control structure + type(ocean_grid_type), intent(inout) :: G !< The grid type describing the ice shelf grid. + type(unit_scale_type), intent(in) :: US !< Pointer to a structure containing unit conversion factors + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate the diagnostic output. + logical, intent(in) :: new_sim !< If true this is a new simulation, otherwise + !! has been started from a restart file. + logical, optional, intent(in) :: solo_ice_sheet_in !< If present, this indicates whether + !! a solo ice-sheet driver. + + ! Local variables + real :: Z_rescale ! A rescaling factor for heights from the representation in + ! a reastart fole to the internal representation in this run. + !This include declares and sets the variable "version". +# include "version_variable.h" + character(len=200) :: config + character(len=200) :: IC_file,filename,inputdir + character(len=40) :: var_name + character(len=40) :: mdl = "MOM_ice_shelf_dyn" ! This module's name. + logical :: shelf_mass_is_dynamic, override_shelf_movement, active_shelf_dynamics + logical :: debug + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, Isdq, Iedq, Jsdq, Jedq, iters + + if (.not.associated(CS)) then + call MOM_error(FATAL, "MOM_ice_shelf_dyn.F90, initialize_ice_shelf_dyn: "// & + "called with an associated control structure.") + return + endif + if (CS%module_is_initialized) then + call MOM_error(WARNING, "MOM_ice_shelf_dyn.F90, initialize_ice_shelf_dyn was "//& + "called with a control structure that has already been initialized.") + endif + CS%module_is_initialized = .true. + + CS%diag => diag ! ; CS%Time => Time + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "DEBUG", debug, default=.false.) + call get_param(param_file, mdl, "DEBUG_IS", CS%debug, & + "If true, write verbose debugging messages for the ice shelf.", & + default=debug) + call get_param(param_file, mdl, "DYNAMIC_SHELF_MASS", shelf_mass_is_dynamic, & + "If true, the ice sheet mass can evolve with time.", & + default=.false.) + 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"//& + "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"//& + "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"//& + "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"//& + "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"// & + "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, & + "avg ocean density used in floatation cond", & + units="kg m-3", default=1035.) + if (active_shelf_dynamics) then + call get_param(param_file, mdl, "ICE_VELOCITY_TIMESTEP", CS%velocity_update_time_step, & + "seconds between ice velocity calcs", units="s", & + fail_if_missing=.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, "A_GLEN_ISOTHERM", CS%A_glen_isothermal, & + "Ice viscosity parameter in Glen's Law", & + units="Pa -1/3 a", default=9.461e-18) + call get_param(param_file, mdl, "GLEN_EXPONENT", CS%n_glen, & + "nonlinearity exponent in Glen's Law", & + units="none", default=3.) + call get_param(param_file, mdl, "MIN_STRAIN_RATE_GLEN", CS%eps_glen_min, & + "min. strain rate to avoid infinite Glen's law viscosity", & + units="a-1", default=1.e-12) + call get_param(param_file, mdl, "BASAL_FRICTION_COEFF", CS%C_basal_friction, & + "ceofficient in sliding law \tau_b = C u^(n_basal_friction)", & + units="Pa (m-a)-(n_basal_friction)", fail_if_missing=.true.) + call get_param(param_file, mdl, "BASAL_FRICTION_EXP", CS%n_basal_friction, & + "exponent in sliding law \tau_b = C u^(m_slide)", & + units="none", fail_if_missing=.true.) + call get_param(param_file, mdl, "DENSITY_ICE", CS%density_ice, & + "A typical density of ice.", units="kg m-3", default=917.0) + call get_param(param_file, mdl, "CONJUGATE_GRADIENT_TOLERANCE", CS%cg_tolerance, & + "tolerance in CG solver, relative to initial residual", default=1.e-6) + call get_param(param_file, mdl, "ICE_NONLINEAR_TOLERANCE", CS%nonlinear_tolerance, & + "nonlin tolerance in iterative velocity solve",default=1.e-6) + 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"// & + "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"// & + "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"//& + "the ice shelf dynamics solvers.", default=.true.) + + call get_param(param_file, mdl, "SHELF_MOVING_FRONT", CS%moving_shelf_front, & + "Specify whether to advance shelf front (and calve).", & + default=.true.) + call get_param(param_file, mdl, "CALVE_TO_MASK", CS%calve_to_mask, & + "If true, do not allow an ice shelf where prohibited by a mask.", & + default=.false.) + endif + call get_param(param_file, mdl, "MIN_THICKNESS_SIMPLE_CALVE", & + CS%min_thickness_simple_calve, & + "Min thickness rule for the VERY simple calving law",& + units="m", default=0.0, scale=US%m_to_Z) + + ! Allocate memory in the ice shelf dynamics control structure that was not + ! previously allocated for registration for restarts. + ! OVS vertically integrated Temperature + + if (active_shelf_dynamics) then + ! DNG + allocate( CS%u_bdry_val(Isdq:Iedq,Jsdq:Jedq) ) ; CS%u_bdry_val(:,:) = 0.0 + allocate( CS%v_bdry_val(Isdq:Iedq,Jsdq:Jedq) ) ; CS%v_bdry_val(:,:) = 0.0 + allocate( CS%t_bdry_val(isd:ied,jsd:jed) ) ; CS%t_bdry_val(:,:) = -15.0 + allocate( CS%h_bdry_val(isd:ied,jsd:jed) ) ; CS%h_bdry_val(:,:) = 0.0 + allocate( CS%thickness_bdry_val(isd:ied,jsd:jed) ) ; CS%thickness_bdry_val(:,:) = 0.0 + allocate( CS%u_face_mask(Isdq:Iedq,jsd:jed) ) ; CS%u_face_mask(:,:) = 0.0 + allocate( CS%v_face_mask(isd:ied,Jsdq:Jedq) ) ; CS%v_face_mask(:,:) = 0.0 + allocate( CS%u_face_mask_bdry(Isdq:Iedq,jsd:jed) ) ; CS%u_face_mask_bdry(:,:) = -2.0 + allocate( CS%v_face_mask_bdry(isd:ied,Jsdq:Jedq) ) ; CS%v_face_mask_bdry(:,:) = -2.0 + allocate( CS%u_flux_bdry_val(Isdq:Iedq,jsd:jed) ) ; CS%u_flux_bdry_val(:,:) = 0.0 + allocate( CS%v_flux_bdry_val(isd:ied,Jsdq:Jedq) ) ; CS%v_flux_bdry_val(:,:) = 0.0 + allocate( CS%umask(Isdq:Iedq,Jsdq:Jedq) ) ; CS%umask(:,:) = -1.0 + allocate( CS%vmask(Isdq:Iedq,Jsdq:Jedq) ) ; CS%vmask(:,:) = -1.0 + allocate( CS%tmask(Isdq:Iedq,Jsdq:Jedq) ) ; CS%tmask(:,:) = -1.0 + + CS%OD_rt_counter = 0 + allocate( CS%OD_rt(isd:ied,jsd:jed) ) ; CS%OD_rt(:,:) = 0.0 + allocate( CS%float_frac_rt(isd:ied,jsd:jed) ) ; CS%float_frac_rt(:,:) = 0.0 + + if (CS%calve_to_mask) then + allocate( CS%calve_mask(isd:ied,jsd:jed) ) ; CS%calve_mask(:,:) = 0.0 + endif + + CS%elapsed_velocity_time = 0.0 + + call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) + endif + + ! Take additional initialization steps, for example of dependent variables. + if (active_shelf_dynamics .and. .not.new_sim) then + if ((US%m_to_Z_restart /= 0.0) .and. (US%m_to_Z_restart /= US%m_to_Z)) then + Z_rescale = US%m_to_Z / US%m_to_Z_restart + do j=G%jsc,G%jec ; do i=G%isc,G%iec + CS%OD_av(i,j) = Z_rescale * CS%OD_av(i,j) + enddo ; enddo + endif + + ! this is unfortunately necessary; if grid is not symmetric the boundary values + ! of u and v are otherwise not set till the end of the first linear solve, and so + ! viscosity is not calculated correctly. + ! This has to occur after init_boundary_values or some of the arrays on the + ! right hand side have not been set up yet. + if (.not. G%symmetric) then + do j=G%jsd,G%jed ; do i=G%isd,G%ied + if (((i+G%idg_offset) == (G%domain%nihalo+1)).and.(CS%u_face_mask(i-1,j) == 3)) then + CS%u_shelf(i-1,j-1) = CS%u_bdry_val(i-1,j-1) + CS%u_shelf(i-1,j) = CS%u_bdry_val(i-1,j) + endif + if (((j+G%jdg_offset) == (G%domain%njhalo+1)).and.(CS%v_face_mask(i,j-1) == 3)) then + CS%u_shelf(i-1,j-1) = CS%u_bdry_val(i-1,j-1) + CS%u_shelf(i,j-1) = CS%u_bdry_val(i,j-1) + endif + enddo ; enddo + endif + + call pass_var(CS%OD_av,G%domain) + call pass_var(CS%float_frac,G%domain) + call pass_var(CS%ice_visc,G%domain) + call pass_var(CS%taub_beta_eff,G%domain) + call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE) + endif + + if (active_shelf_dynamics) then + ! If we are calving to a mask, i.e. if a mask exists where a shelf cannot, read the mask from a file. + if (CS%calve_to_mask) then + call MOM_mesg(" MOM_ice_shelf.F90, initialize_ice_shelf: reading calving_mask") + + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + call get_param(param_file, mdl, "CALVING_MASK_FILE", IC_file, & + "The file with a mask for where calving might occur.", & + default="ice_shelf_h.nc") + call get_param(param_file, mdl, "CALVING_MASK_VARNAME", var_name, & + "The variable to use in masking calving.", & + default="area_shelf_h") + + filename = trim(inputdir)//trim(IC_file) + call log_param(param_file, mdl, "INPUTDIR/CALVING_MASK_FILE", filename) + if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & + " calving mask file: Unable to open "//trim(filename)) + + call MOM_read_data(filename,trim(var_name),CS%calve_mask,G%Domain) + do j=G%jsc,G%jec ; do i=G%isc,G%iec + if (CS%calve_mask(i,j) > 0.0) CS%calve_mask(i,j) = 1.0 + enddo ; enddo + call pass_var(CS%calve_mask,G%domain) + endif + +! call init_boundary_values(CS, G, time, ISS%hmask, CS%input_flux, CS%input_thickness, new_sim) + + if (new_sim) then + call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: initialize ice velocity.") + call update_OD_ffrac_uncoupled(CS, G, ISS%h_shelf(:,:)) + call ice_shelf_solve_outer(CS, ISS, G, US, CS%u_shelf, CS%v_shelf, iters, Time) + + if (CS%id_u_shelf > 0) call post_data(CS%id_u_shelf,CS%u_shelf,CS%diag) + if (CS%id_v_shelf > 0) call post_data(CS%id_v_shelf,CS%v_shelf,CS%diag) + endif + + ! Register diagnostics. + CS%id_u_shelf = register_diag_field('ocean_model','u_shelf',CS%diag%axesCu1, Time, & + 'x-velocity of ice', 'm yr-1') + CS%id_v_shelf = register_diag_field('ocean_model','v_shelf',CS%diag%axesCv1, Time, & + 'y-velocity of ice', 'm yr-1') + CS%id_u_mask = register_diag_field('ocean_model','u_mask',CS%diag%axesCu1, Time, & + 'mask for u-nodes', 'none') + CS%id_v_mask = register_diag_field('ocean_model','v_mask',CS%diag%axesCv1, Time, & + 'mask for v-nodes', 'none') +! CS%id_surf_elev = register_diag_field('ocean_model','ice_surf',CS%diag%axesT1, Time, & +! 'ice surf elev', 'm') + CS%id_float_frac = register_diag_field('ocean_model','ice_float_frac',CS%diag%axesT1, Time, & + 'fraction of cell that is floating (sort of)', 'none') + CS%id_col_thick = register_diag_field('ocean_model','col_thick',CS%diag%axesT1, Time, & + 'ocean column thickness passed to ice model', 'm', conversion=US%Z_to_m) + CS%id_OD_av = register_diag_field('ocean_model','OD_av',CS%diag%axesT1, Time, & + 'intermediate ocean column thickness passed to ice model', 'm', conversion=US%Z_to_m) + !CS%id_h_after_uflux = register_diag_field('ocean_model','h_after_uflux',CS%diag%axesh1, Time, & + ! 'thickness after u flux ', 'none') + !CS%id_h_after_vflux = register_diag_field('ocean_model','h_after_vflux',CS%diag%axesh1, Time, & + ! 'thickness after v flux ', 'none') + !CS%id_h_after_adv = register_diag_field('ocean_model','h_after_adv',CS%diag%axesh1, Time, & + ! 'thickness after front adv ', 'none') + +!!! OVS vertically integrated temperature + CS%id_t_shelf = register_diag_field('ocean_model','t_shelf',CS%diag%axesT1, Time, & + 'T of ice', 'oC') + CS%id_t_mask = register_diag_field('ocean_model','tmask',CS%diag%axesT1, Time, & + 'mask for T-nodes', 'none') + endif + +end subroutine initialize_ice_shelf_dyn + + +subroutine initialize_diagnostic_fields(CS, ISS, G, US, Time) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + type(unit_scale_type), intent(in) :: US !< Pointer to a structure containing unit conversion factors + type(time_type), intent(in) :: Time !< The current model time + + integer :: i, j, iters, isd, ied, jsd, jed + real :: rhoi_rhow, OD + type(time_type) :: dummy_time + + rhoi_rhow = CS%density_ice / CS%density_ocean_avg + dummy_time = set_time(0,0) + isd=G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + do j=jsd,jed + do i=isd,ied + OD = G%bathyT(i,j) - rhoi_rhow * ISS%h_shelf(i,j) + if (OD >= 0) then + ! ice thickness does not take up whole ocean column -> floating + CS%OD_av(i,j) = OD + CS%float_frac(i,j) = 0. + else + CS%OD_av(i,j) = 0. + CS%float_frac(i,j) = 1. + endif + enddo + enddo + + call ice_shelf_solve_outer(CS, ISS, G, US, CS%u_shelf, CS%v_shelf, iters, dummy_time) + +end subroutine initialize_diagnostic_fields + +!> This function returns the global maximum timestep that can be taken based on the current +!! ice velocities. Because it involves finding a global minimum, it can be suprisingly expensive. +function ice_time_step_CFL(CS, ISS, G) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< The ice shelf dynamics control structure + type(ice_shelf_state), intent(inout) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + real :: ice_time_step_CFL !< The maximum permitted timestep based on the ice velocities [s]. + + real :: ratio, min_ratio + real :: local_u_max, local_v_max + integer :: i, j + + min_ratio = 1.0e16 ! This is just an arbitrary large value. + do j=G%jsc,G%jec ; do i=G%isc,G%iec ; if (ISS%hmask(i,j) == 1.0) then + local_u_max = max(abs(CS%u_shelf(i,j)), abs(CS%u_shelf(i+1,j+1)), & + abs(CS%u_shelf(i+1,j)), abs(CS%u_shelf(i,j+1))) + local_v_max = max(abs(CS%v_shelf(i,j)), abs(CS%v_shelf(i+1,j+1)), & + abs(CS%v_shelf(i+1,j)), abs(CS%v_shelf(i,j+1))) + + ratio = min(G%areaT(i,j) / (local_u_max+1.0e-12), G%areaT(i,j) / (local_v_max+1.0e-12)) + min_ratio = min(min_ratio, ratio) + endif ; enddo ; enddo ! i- and j- loops + + call min_across_PEs(min_ratio) + + ! solved velocities are in m/yr; we want time_step_int in seconds + ice_time_step_CFL = CS%CFL_factor * min_ratio * (365*86400) + +end function ice_time_step_CFL + +!> This subroutine updates the ice shelf velocities, mass, stresses and properties due to the +!! ice shelf dynamics. +subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled_grounding, must_update_vel) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< The ice shelf dynamics control structure + type(ice_shelf_state), intent(inout) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + type(unit_scale_type), intent(in) :: US !< Pointer to a structure containing unit conversion factors + real, intent(in) :: time_step !< time step [s] + type(time_type), intent(in) :: Time !< The current model time + real, dimension(SZDI_(G),SZDJ_(G)), & + optional, intent(in) :: ocean_mass !< If present this is the mass per unit area + !! of the ocean [kg m-2]. + logical, optional, intent(in) :: coupled_grounding !< If true, the grounding line is + !! determined by coupled ice-ocean dynamics + logical, optional, intent(in) :: must_update_vel !< Always update the ice velocities if true. + + integer :: iters + logical :: update_ice_vel, coupled_GL + + update_ice_vel = .false. + if (present(must_update_vel)) update_ice_vel = must_update_vel + + coupled_GL = .false. + if (present(ocean_mass) .and. present(coupled_grounding)) coupled_GL = coupled_grounding + + call ice_shelf_advect(CS, ISS, G, time_step, Time) + CS%elapsed_velocity_time = CS%elapsed_velocity_time + time_step + if (CS%elapsed_velocity_time >= CS%velocity_update_time_step) update_ice_vel = .true. + + if (coupled_GL) then + call update_OD_ffrac(CS, G, US, ocean_mass, update_ice_vel) + elseif (update_ice_vel) then + call update_OD_ffrac_uncoupled(CS, G, ISS%h_shelf(:,:)) + endif + + if (update_ice_vel) then + call ice_shelf_solve_outer(CS, ISS, G, US, CS%u_shelf, CS%v_shelf, iters, Time) + endif + + call ice_shelf_temp(CS, ISS, G, US, time_step, ISS%water_flux, Time) + + if (update_ice_vel) then + call enable_averaging(CS%elapsed_velocity_time, Time, CS%diag) + if (CS%id_col_thick > 0) call post_data(CS%id_col_thick, CS%OD_av, CS%diag) + if (CS%id_u_shelf > 0) call post_data(CS%id_u_shelf,CS%u_shelf,CS%diag) + if (CS%id_v_shelf > 0) call post_data(CS%id_v_shelf,CS%v_shelf,CS%diag) + if (CS%id_t_shelf > 0) call post_data(CS%id_t_shelf,CS%t_shelf,CS%diag) + if (CS%id_float_frac > 0) call post_data(CS%id_float_frac,CS%float_frac,CS%diag) + if (CS%id_OD_av >0) call post_data(CS%id_OD_av, CS%OD_av,CS%diag) + + if (CS%id_u_mask > 0) call post_data(CS%id_u_mask,CS%umask,CS%diag) + if (CS%id_v_mask > 0) call post_data(CS%id_v_mask,CS%vmask,CS%diag) + if (CS%id_t_mask > 0) call post_data(CS%id_t_mask,CS%tmask,CS%diag) + + call disable_averaging(CS%diag) + + CS%elapsed_velocity_time = 0.0 + endif + +end subroutine update_ice_shelf + +!> This subroutine takes the velocity (on the Bgrid) and timesteps h_t = - div (uh) once. +!! Additionally, it will update the volume of ice in partially-filled cells, and update +!! hmask accordingly +subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< The ice shelf dynamics control structure + type(ice_shelf_state), intent(inout) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + real, intent(in) :: time_step !< time step [s] + type(time_type), intent(in) :: Time !< The current model time + + +! 3/8/11 DNG +! +! This subroutine takes the velocity (on the Bgrid) and timesteps h_t = - div (uh) once. +! ADDITIONALLY, it will update the volume of ice in partially-filled cells, and update +! hmask accordingly +! +! The flux overflows are included here. That is because they will be used to advect 3D scalars +! into partial cells + + ! + ! flux_enter: this is to capture flow into partially covered cells; it gives the mass flux into a given + ! cell across its boundaries. + ! ###Perhaps flux_enter should be changed into u-face and v-face + ! ###fluxes, which can then be used in halo updates, etc. + ! + ! from left neighbor: flux_enter(:,:,1) + ! from right neighbor: flux_enter(:,:,2) + ! from bottom neighbor: flux_enter(:,:,3) + ! from top neighbor: flux_enter(:,:,4) + ! + ! THESE ARE NOT CONSISTENT ==> FIND OUT WHAT YOU IMPLEMENTED + + ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary + ! + ! o--- (4) ---o + ! | | + ! (1) (2) + ! | | + ! o--- (3) ---o + ! + + real, dimension(SZDI_(G),SZDJ_(G)) :: h_after_uflux, h_after_vflux ! Ice thicknesses [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G),4) :: flux_enter + integer :: isd, ied, jsd, jed, i, j, isc, iec, jsc, jec + real :: rho, spy + + rho = CS%density_ice + spy = 365 * 86400 ! seconds per year; is there a global constant for this? No - it is dependent upon a calendar. + + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec + flux_enter(:,:,:) = 0.0 + + h_after_uflux(:,:) = 0.0 + h_after_vflux(:,:) = 0.0 + ! call MOM_mesg("MOM_ice_shelf.F90: ice_shelf_advect called") + + do j=jsd,jed ; do i=isd,ied ; if (CS%thickness_bdry_val(i,j) /= 0.0) then + ISS%h_shelf(i,j) = CS%thickness_bdry_val(i,j) + endif ; enddo ; enddo + + call ice_shelf_advect_thickness_x(CS, G, time_step/spy, ISS%hmask, ISS%h_shelf, h_after_uflux, flux_enter) + +! call enable_averaging(time_step,Time,CS%diag) + ! call pass_var(h_after_uflux, G%domain) +! if (CS%id_h_after_uflux > 0) call post_data(CS%id_h_after_uflux, h_after_uflux, CS%diag) +! call disable_averaging(CS%diag) + + call ice_shelf_advect_thickness_y(CS, G, time_step/spy, ISS%hmask, h_after_uflux, h_after_vflux, flux_enter) + +! call enable_averaging(time_step,Time,CS%diag) +! call pass_var(h_after_vflux, G%domain) +! if (CS%id_h_after_vflux > 0) call post_data(CS%id_h_after_vflux, h_after_vflux, CS%diag) +! call disable_averaging(CS%diag) + + do j=jsd,jed + do i=isd,ied + if (ISS%hmask(i,j) == 1) ISS%h_shelf(i,j) = h_after_vflux(i,j) + enddo + enddo + + if (CS%moving_shelf_front) then + call shelf_advance_front(CS, ISS, G, flux_enter) + if (CS%min_thickness_simple_calve > 0.0) then + call ice_shelf_min_thickness_calve(G, ISS%h_shelf, ISS%area_shelf_h, ISS%hmask, & + CS%min_thickness_simple_calve) + endif + if (CS%calve_to_mask) then + call calve_to_mask(G, ISS%h_shelf, ISS%area_shelf_h, ISS%hmask, CS%calve_mask) + endif + endif + + !call enable_averaging(time_step,Time,CS%diag) + !if (CS%id_h_after_adv > 0) call post_data(CS%id_h_after_adv, ISS%h_shelf, CS%diag) + !call disable_averaging(CS%diag) + + !call change_thickness_using_melt(ISS, G, time_step, fluxes, CS%density_ice) + + call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) + +end subroutine ice_shelf_advect + +subroutine ice_shelf_solve_outer(CS, ISS, G, US, u, v, iters, time) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< The ice shelf dynamics control structure + type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + type(unit_scale_type), intent(in) :: US !< Pointer to a structure containing unit conversion factors + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: u !< The zonal ice shelf velocity at vertices [m year-1] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: v !< The meridional ice shelf velocity at vertices [m year-1] + integer, intent(out) :: iters !< The number of iterations used in the solver. + type(time_type), intent(in) :: Time !< The current model time + + real, dimension(SZDIB_(G),SZDJB_(G)) :: TAUDX, TAUDY, u_prev_iterate, v_prev_iterate, & + u_bdry_cont, v_bdry_cont, Au, Av, err_u, err_v, & + u_last, v_last + real, dimension(SZDIB_(G),SZDJB_(G)) :: H_node ! Ice shelf thickness at corners [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)) :: float_cond ! An array indicating where the ice + ! shelf is floating: 0 if floating, 1 if not. + character(len=160) :: mesg ! The text of an error message + integer :: conv_flag, i, j, k,l, iter + integer :: isdq, iedq, jsdq, jedq, isd, ied, jsd, jed, isumstart, jsumstart, nodefloat, nsub + real :: err_max, err_tempu, err_tempv, err_init, area, max_vel, tempu, tempv, rhoi_rhow + real, pointer, dimension(:,:,:,:) :: Phi => NULL() + real, pointer, dimension(:,:,:,:,:,:) :: Phisub => NULL() + real, dimension(8,4) :: Phi_temp + real, dimension(2,2) :: X,Y + character(2) :: iternum + character(2) :: numproc + + ! for GL interpolation - need to make this a readable parameter + nsub = CS%n_sub_regularize + + isdq = G%isdB ; iedq = G%iedB ; jsdq = G%jsdB ; jedq = G%jedB + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + rhoi_rhow = CS%density_ice / CS%density_ocean_avg + + TAUDX(:,:) = 0.0 ; TAUDY(:,:) = 0.0 + u_bdry_cont(:,:) = 0.0 ; v_bdry_cont(:,:) = 0.0 + Au(:,:) = 0.0 ; Av(:,:) = 0.0 + + ! need to make these conditional on GL interpolation + float_cond(:,:) = 0.0 ; H_node(:,:)=0 + allocate(Phisub (nsub,nsub,2,2,2,2)) ; Phisub = 0.0 + + isumstart = G%isc + ! Include the edge if tile is at the western bdry; Should add a test to avoid this if reentrant. + if (G%isc+G%idg_offset==G%isg) isumstart = G%iscB + + jsumstart = G%jsc + ! Include the edge if tile is at the southern bdry; Should add a test to avoid this if reentrant. + if (G%jsc+G%jdg_offset==G%jsg) jsumstart = G%jscB + + call calc_shelf_driving_stress(CS, ISS, G, US, TAUDX, TAUDY, CS%OD_av) + + ! this is to determine which cells contain the grounding line, + ! the criterion being that the cell is ice-covered, with some nodes + ! floating and some grounded + ! floatation condition is estimated by assuming topography is cellwise constant + ! and H is bilinear in a cell; floating where rho_i/rho_w * H_node + D is nonpositive + + ! need to make this conditional on GL interp + + if (CS%GL_regularize) then + + call interpolate_H_to_B(G, ISS%h_shelf, ISS%hmask, H_node) + + do j=G%jsc,G%jec + do i=G%isc,G%iec + nodefloat = 0 + do k=0,1 + do l=0,1 + if ((ISS%hmask(i,j) == 1) .and. & + (rhoi_rhow * H_node(i-1+k,j-1+l) - G%bathyT(i,j) <= 0)) then + nodefloat = nodefloat + 1 + endif + enddo + enddo + if ((nodefloat > 0) .and. (nodefloat < 4)) then + float_cond(i,j) = 1.0 + CS%float_frac(i,j) = 1.0 + endif + enddo + enddo + + call pass_var(float_cond, G%Domain) + + call bilinear_shape_functions_subgrid(Phisub, nsub) + + endif + + ! make above conditional + + u_prev_iterate(:,:) = u(:,:) + v_prev_iterate(:,:) = v(:,:) + + ! must prepare phi + allocate(Phi(isd:ied,jsd:jed,1:8,1:4)) ; Phi(:,:,:,:) = 0.0 + + do j=jsd,jed ; do i=isd,ied + if (((i > isd) .and. (j > jsd))) then + X(:,:) = G%geoLonBu(i-1:i,j-1:j)*1000 + Y(:,:) = G%geoLatBu(i-1:i,j-1:j)*1000 + else + X(2,:) = G%geoLonBu(i,j)*1000 + X(1,:) = G%geoLonBu(i,j)*1000-G%dxT(i,j) + Y(:,2) = G%geoLatBu(i,j)*1000 + Y(:,1) = G%geoLatBu(i,j)*1000-G%dyT(i,j) + endif + + call bilinear_shape_functions(X, Y, Phi_temp, area) + Phi(i,j,:,:) = Phi_temp + enddo ; enddo + + call calc_shelf_visc(CS, ISS, G, US, u, v) + + call pass_var(CS%ice_visc, G%domain) + call pass_var(CS%taub_beta_eff, G%domain) + + ! makes sure basal stress is only applied when it is supposed to be + + do j=G%jsd,G%jed ; do i=G%isd,G%ied + CS%taub_beta_eff(i,j) = CS%taub_beta_eff(i,j) * CS%float_frac(i,j) + enddo ; enddo + + call apply_boundary_values(CS, ISS, G, time, Phisub, H_node, CS%ice_visc, & + CS%taub_beta_eff, float_cond, & + rhoi_rhow, u_bdry_cont, v_bdry_cont) + + Au(:,:) = 0.0 ; Av(:,:) = 0.0 + + call CG_action(Au, Av, u, v, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & + CS%ice_visc, float_cond, G%bathyT(:,:), CS%taub_beta_eff, G%areaT, & + G, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow) + + err_init = 0 ; err_tempu = 0; err_tempv = 0 + do j=jsumstart,G%jecB + do i=isumstart,G%iecB + if (CS%umask(i,j) == 1) then + err_tempu = ABS (Au(i,j) + u_bdry_cont(i,j) - TAUDX(i,j)) + endif + if (CS%vmask(i,j) == 1) then + err_tempv = MAX(ABS (Av(i,j) + v_bdry_cont(i,j) - TAUDY(i,j)), err_tempu) + endif + if (err_tempv >= err_init) then + err_init = err_tempv + endif + enddo + enddo + + call max_across_PEs(err_init) + + write(mesg,*) "ice_shelf_solve_outer: INITIAL nonlinear residual = ",err_init + call MOM_mesg(mesg, 5) + + u_last(:,:) = u(:,:) ; v_last(:,:) = v(:,:) + + !! begin loop + + do iter=1,100 + + call ice_shelf_solve_inner(CS, ISS, G, u, v, TAUDX, TAUDY, H_node, float_cond, & + ISS%hmask, conv_flag, iters, time, Phi, Phisub) + + if (CS%DEBUG) then + call qchksum(u, "u shelf", G%HI, haloshift=2) + call qchksum(v, "v shelf", G%HI, haloshift=2) + endif + + write(mesg,*) "ice_shelf_solve_outer: linear solve done in ",iters," iterations" + call MOM_mesg(mesg, 5) + + call calc_shelf_visc(CS, ISS, G, US, u, v) + call pass_var(CS%ice_visc, G%domain) + call pass_var(CS%taub_beta_eff, G%domain) + + ! makes sure basal stress is only applied when it is supposed to be + + do j=G%jsd,G%jed ; do i=G%isd,G%ied + CS%taub_beta_eff(i,j) = CS%taub_beta_eff(i,j) * CS%float_frac(i,j) + enddo ; enddo + + u_bdry_cont(:,:) = 0 ; v_bdry_cont(:,:) = 0 + + call apply_boundary_values(CS, ISS, G, time, Phisub, H_node, CS%ice_visc, & + CS%taub_beta_eff, float_cond, & + rhoi_rhow, u_bdry_cont, v_bdry_cont) + + Au(:,:) = 0 ; Av(:,:) = 0 + + call CG_action(Au, Av, u, v, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & + CS%ice_visc, float_cond, G%bathyT(:,:), CS%taub_beta_eff, G%areaT, & + G, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow) + + err_max = 0 + + if (CS%nonlin_solve_err_mode == 1) then + + do j=jsumstart,G%jecB + do i=isumstart,G%iecB + if (CS%umask(i,j) == 1) then + err_tempu = ABS (Au(i,j) + u_bdry_cont(i,j) - TAUDX(i,j)) + endif + if (CS%vmask(i,j) == 1) then + err_tempv = MAX(ABS (Av(i,j) + v_bdry_cont(i,j) - TAUDY(i,j)), err_tempu) + endif + if (err_tempv >= err_max) then + err_max = err_tempv + endif + enddo + enddo + + call max_across_PEs(err_max) + + elseif (CS%nonlin_solve_err_mode == 2) then + + max_vel = 0 ; tempu = 0 ; tempv = 0 + + do j=jsumstart,G%jecB + do i=isumstart,G%iecB + if (CS%umask(i,j) == 1) then + err_tempu = ABS (u_last(i,j)-u(i,j)) + tempu = u(i,j) + endif + if (CS%vmask(i,j) == 1) then + err_tempv = MAX(ABS (v_last(i,j)- v(i,j)), err_tempu) + tempv = SQRT(v(i,j)**2+tempu**2) + endif + if (err_tempv >= err_max) then + err_max = err_tempv + endif + if (tempv >= max_vel) then + max_vel = tempv + endif + enddo + enddo + + u_last(:,:) = u(:,:) + v_last(:,:) = v(:,:) + + call max_across_PEs(max_vel) + call max_across_PEs(err_max) + err_init = max_vel + + endif + + write(mesg,*) "ice_shelf_solve_outer: nonlinear residual = ",err_max/err_init + call MOM_mesg(mesg, 5) + + if (err_max <= CS%nonlinear_tolerance * err_init) then + write(mesg,*) "ice_shelf_solve_outer: exiting nonlinear solve after ",iter," iterations" + call MOM_mesg(mesg, 5) + exit + endif + + enddo + + deallocate(Phi) + deallocate(Phisub) + +end subroutine ice_shelf_solve_outer + +subroutine ice_shelf_solve_inner(CS, ISS, G, u, v, taudx, taudy, H_node, float_cond, & + hmask, conv_flag, iters, time, Phi, Phisub) + type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: u !< The zonal ice shelf velocity at vertices [m year-1] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: v !< The meridional ice shelf velocity at vertices [m year-1] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: taudx !< The x-direction driving stress, in ??? + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: taudy !< The y-direction driving stress, in ??? + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: H_node !< The ice shelf thickness at nodal (corner) + !! points [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: float_cond !< An array indicating where the ice + !! shelf is floating: 0 if floating, 1 if not. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + integer, intent(out) :: conv_flag !< A flag indicating whether (1) or not (0) the + !! iterations have converged to the specified tolerence + integer, intent(out) :: iters !< The number of iterations used in the solver. + type(time_type), intent(in) :: Time !< The current model time + real, dimension(SZDI_(G),SZDJ_(G),8,4), & + intent(in) :: Phi !< The gradients of bilinear basis elements at Gaussian + !! quadrature points surrounding the cell verticies. + real, dimension(:,:,:,:,:,:), & + intent(in) :: Phisub !< Quadrature structure weights at subgridscale + !! locations for finite element calculations +! one linear solve (nonlinear iteration) of the solution for velocity + +! in this subroutine: +! boundary contributions are added to taud to get the RHS +! diagonal of matrix is found (for Jacobi precondition) +! CG iteration is carried out for max. iterations or until convergence + +! assumed - u, v, taud, visc, beta_eff are valid on the halo + + real, dimension(SZDIB_(G),SZDJB_(G)) :: & + Ru, Rv, Zu, Zv, DIAGu, DIAGv, RHSu, RHSv, & + ubd, vbd, Au, Av, Du, Dv, & + Zu_old, Zv_old, Ru_old, Rv_old, & + sum_vec, sum_vec_2 + integer :: iter, i, j, isd, ied, jsd, jed, & + isc, iec, jsc, jec, is, js, ie, je, isumstart, jsumstart, & + isdq, iedq, jsdq, jedq, iscq, iecq, jscq, jecq, nx_halo, ny_halo + real :: tol, beta_k, alpha_k, area, dot_p1, dot_p2, resid0, cg_halo, dot_p1a, dot_p2a + character(2) :: gridsize + + real, dimension(8,4) :: Phi_temp + real, dimension(2,2) :: X,Y + + isdq = G%isdB ; iedq = G%iedB ; jsdq = G%jsdB ; jedq = G%jedB + iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB + ny_halo = G%domain%njhalo ; nx_halo = G%domain%nihalo + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec + + Zu(:,:) = 0 ; Zv(:,:) = 0 ; DIAGu(:,:) = 0 ; DIAGv(:,:) = 0 + Ru(:,:) = 0 ; Rv(:,:) = 0 ; Au(:,:) = 0 ; Av(:,:) = 0 + Du(:,:) = 0 ; Dv(:,:) = 0 ; ubd(:,:) = 0 ; vbd(:,:) = 0 + dot_p1 = 0 ; dot_p2 = 0 + + isumstart = G%isc + ! Include the edge if tile is at the western bdry; Should add a test to avoid this if reentrant. + if (G%isc+G%idg_offset==G%isg) isumstart = G%iscB + + jsumstart = G%jsc + ! Include the edge if tile is at the southern bdry; Should add a test to avoid this if reentrant. + if (G%jsc+G%jdg_offset==G%jsg) jsumstart = G%jscB + + call apply_boundary_values(CS, ISS, G, time, Phisub, H_node, CS%ice_visc, & + CS%taub_beta_eff, float_cond, & + CS%density_ice/CS%density_ocean_avg, ubd, vbd) + + RHSu(:,:) = taudx(:,:) - ubd(:,:) + RHSv(:,:) = taudy(:,:) - vbd(:,:) + + + call pass_vector(RHSu, RHSv, G%domain, TO_ALL, BGRID_NE) + + call matrix_diagonal(CS, G, float_cond, H_node, CS%ice_visc, & + CS%taub_beta_eff, hmask, & + CS%density_ice/CS%density_ocean_avg, Phisub, DIAGu, DIAGv) +! DIAGu(:,:) = 1 ; DIAGv(:,:) = 1 + + call pass_vector(DIAGu, DIAGv, G%domain, TO_ALL, BGRID_NE) + + call CG_action(Au, Av, u, v, Phi, Phisub, CS%umask, CS%vmask, hmask, & + H_node, CS%ice_visc, float_cond, G%bathyT(:,:), CS%taub_beta_eff, & + G%areaT, G, isc-1, iec+1, jsc-1, jec+1, CS%density_ice/CS%density_ocean_avg) + + call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) + + Ru(:,:) = RHSu(:,:) - Au(:,:) ; Rv(:,:) = RHSv(:,:) - Av(:,:) + + if (.not. CS%use_reproducing_sums) then + + do j=jsumstart,jecq + do i=isumstart,iecq + if (CS%umask(i,j) == 1) dot_p1 = dot_p1 + Ru(i,j)**2 + if (CS%vmask(i,j) == 1) dot_p1 = dot_p1 + Rv(i,j)**2 + enddo + enddo + + call sum_across_PEs(dot_p1) + + else + + sum_vec(:,:) = 0.0 + + do j=jsumstart,jecq + do i=isumstart,iecq + if (CS%umask(i,j) == 1) sum_vec(i,j) = Ru(i,j)**2 + if (CS%vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + Rv(i,j)**2 + enddo + enddo + + dot_p1 = reproducing_sum( sum_vec, isumstart+(1-G%IsdB), Iecq+(1-G%IsdB), & + jsumstart+(1-G%JsdB), jecq+(1-G%JsdB) ) + + endif + + resid0 = sqrt (dot_p1) + + do j=jsdq,jedq + do i=isdq,iedq + if (CS%umask(i,j) == 1) Zu(i,j) = Ru(i,j) / DIAGu(i,j) + if (CS%vmask(i,j) == 1) Zv(i,j) = Rv(i,j) / DIAGv(i,j) + enddo + enddo + + Du(:,:) = Zu(:,:) ; Dv(:,:) = Zv(:,:) + + cg_halo = 3 + conv_flag = 0 + + !!!!!!!!!!!!!!!!!! + !! !! + !! MAIN CG LOOP !! + !! !! + !!!!!!!!!!!!!!!!!! + + + + ! initially, c-grid data is valid up to 3 halo nodes out + + do iter = 1,CS%cg_max_iterations + + ! assume asymmetry + ! thus we can never assume that any arrays are legit more than 3 vertices past + ! the computational domain - this is their state in the initial iteration + + + is = isc - cg_halo ; ie = iecq + cg_halo + js = jscq - cg_halo ; je = jecq + cg_halo + + Au(:,:) = 0 ; Av(:,:) = 0 + + call CG_action(Au, Av, Du, Dv, Phi, Phisub, CS%umask, CS%vmask, hmask, & + H_node, CS%ice_visc, float_cond, G%bathyT(:,:), CS%taub_beta_eff, & + G%areaT, G, is, ie, js, je, CS%density_ice/CS%density_ocean_avg) + + ! Au, Av valid region moves in by 1 + + if ( .not. CS%use_reproducing_sums) then + + + ! alpha_k = (Z \dot R) / (D \dot AD} + dot_p1 = 0 ; dot_p2 = 0 + do j=jsumstart,jecq + do i=isumstart,iecq + if (CS%umask(i,j) == 1) then + dot_p1 = dot_p1 + Zu(i,j)*Ru(i,j) + dot_p2 = dot_p2 + Du(i,j)*Au(i,j) + endif + if (CS%vmask(i,j) == 1) then + dot_p1 = dot_p1 + Zv(i,j)*Rv(i,j) + dot_p2 = dot_p2 + Dv(i,j)*Av(i,j) + endif + enddo + enddo + call sum_across_PEs(dot_p1) ; call sum_across_PEs(dot_p2) + else + + sum_vec(:,:) = 0.0 ; sum_vec_2(:,:) = 0.0 + + do j=jscq,jecq + do i=iscq,iecq + if (CS%umask(i,j) == 1) sum_vec(i,j) = Zu(i,j) * Ru(i,j) + if (CS%vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + Zv(i,j) * Rv(i,j) + + if (CS%umask(i,j) == 1) sum_vec_2(i,j) = Du(i,j) * Au(i,j) + if (CS%vmask(i,j) == 1) sum_vec_2(i,j) = sum_vec_2(i,j) + Dv(i,j) * Av(i,j) + enddo + enddo + + dot_p1 = reproducing_sum( sum_vec, isumstart+(1-G%IsdB), Iecq+(1-G%IsdB), & + jsumstart+(1-G%JsdB), jecq+(1-G%JsdB) ) + + dot_p2 = reproducing_sum( sum_vec_2, isumstart+(1-G%IsdB), Iecq+(1-G%IsdB), & + jsumstart+(1-G%JsdB), jecq+(1-G%JsdB) ) + endif + + alpha_k = dot_p1/dot_p2 + + do j=jsd,jed + do i=isd,ied + if (CS%umask(i,j) == 1) u(i,j) = u(i,j) + alpha_k * Du(i,j) + if (CS%vmask(i,j) == 1) v(i,j) = v(i,j) + alpha_k * Dv(i,j) + enddo + enddo + + do j=jsd,jed + do i=isd,ied + if (CS%umask(i,j) == 1) then + Ru_old(i,j) = Ru(i,j) ; Zu_old(i,j) = Zu(i,j) + endif + if (CS%vmask(i,j) == 1) then + Rv_old(i,j) = Rv(i,j) ; Zv_old(i,j) = Zv(i,j) + endif + enddo + enddo + +! Ru(:,:) = Ru(:,:) - alpha_k * Au(:,:) +! Rv(:,:) = Rv(:,:) - alpha_k * Av(:,:) + + do j=jsd,jed + do i=isd,ied + if (CS%umask(i,j) == 1) Ru(i,j) = Ru(i,j) - alpha_k * Au(i,j) + if (CS%vmask(i,j) == 1) Rv(i,j) = Rv(i,j) - alpha_k * Av(i,j) + enddo + enddo + + + do j=jsdq,jedq + do i=isdq,iedq + if (CS%umask(i,j) == 1) then + Zu(i,j) = Ru(i,j) / DIAGu(i,j) + endif + if (CS%vmask(i,j) == 1) then + Zv(i,j) = Rv(i,j) / DIAGv(i,j) + endif + enddo + enddo + + ! R,u,v,Z valid region moves in by 1 + + if (.not. CS%use_reproducing_sums) then + + ! beta_k = (Z \dot R) / (Zold \dot Rold} + dot_p1 = 0 ; dot_p2 = 0 + do j=jsumstart,jecq + do i=isumstart,iecq + if (CS%umask(i,j) == 1) then + dot_p1 = dot_p1 + Zu(i,j)*Ru(i,j) + dot_p2 = dot_p2 + Zu_old(i,j)*Ru_old(i,j) + endif + if (CS%vmask(i,j) == 1) then + dot_p1 = dot_p1 + Zv(i,j)*Rv(i,j) + dot_p2 = dot_p2 + Zv_old(i,j)*Rv_old(i,j) + endif + enddo + enddo + call sum_across_PEs(dot_p1) ; call sum_across_PEs(dot_p2) + + + else + + sum_vec(:,:) = 0.0 ; sum_vec_2(:,:) = 0.0 + + do j=jsumstart,jecq + do i=isumstart,iecq + if (CS%umask(i,j) == 1) sum_vec(i,j) = Zu(i,j) * Ru(i,j) + if (CS%vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + & + Zv(i,j) * Rv(i,j) + + if (CS%umask(i,j) == 1) sum_vec_2(i,j) = Zu_old(i,j) * Ru_old(i,j) + if (CS%vmask(i,j) == 1) sum_vec_2(i,j) = sum_vec_2(i,j) + & + Zv_old(i,j) * Rv_old(i,j) + enddo + enddo + + + dot_p1 = reproducing_sum(sum_vec, isumstart+(1-G%IsdB), Iecq+(1-G%IsdB), & + jsumstart+(1-G%JsdB), Jecq+(1-G%JsdB) ) + + dot_p2 = reproducing_sum(sum_vec_2, isumstart+(1-G%IsdB), Iecq+(1-G%IsdB), & + jsumstart+(1-G%JsdB), Jecq+(1-G%JsdB) ) + + endif + + beta_k = dot_p1/dot_p2 + + +! Du(:,:) = Zu(:,:) + beta_k * Du(:,:) +! Dv(:,:) = Zv(:,:) + beta_k * Dv(:,:) + + do j=jsd,jed + do i=isd,ied + if (CS%umask(i,j) == 1) Du(i,j) = Zu(i,j) + beta_k * Du(i,j) + if (CS%vmask(i,j) == 1) Dv(i,j) = Zv(i,j) + beta_k * Dv(i,j) + enddo + enddo + + ! D valid region moves in by 1 + + dot_p1 = 0 + + if (.not. CS%use_reproducing_sums) then + + do j=jsumstart,jecq + do i=isumstart,iecq + if (CS%umask(i,j) == 1) then + dot_p1 = dot_p1 + Ru(i,j)**2 + endif + if (CS%vmask(i,j) == 1) then + dot_p1 = dot_p1 + Rv(i,j)**2 + endif + enddo + enddo + call sum_across_PEs(dot_p1) + + else + + sum_vec(:,:) = 0.0 + + do j=jsumstart,jecq + do i=isumstart,iecq + if (CS%umask(i,j) == 1) sum_vec(i,j) = Ru(i,j)**2 + if (CS%vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + Rv(i,j)**2 + enddo + enddo + + dot_p1 = reproducing_sum( sum_vec, isumstart+(1-G%IsdB), Iecq+(1-G%IsdB), & + jsumstart+(1-G%JsdB), jecq+(1-G%JsdB) ) + endif + + dot_p1 = sqrt (dot_p1) + + if (dot_p1 <= CS%cg_tolerance * resid0) then + iters = iter + conv_flag = 1 + exit + endif + + cg_halo = cg_halo - 1 + + if (cg_halo == 0) then + ! pass vectors + call pass_vector(Du, Dv, G%domain, TO_ALL, BGRID_NE) + call pass_vector(u, v, G%domain, TO_ALL, BGRID_NE) + call pass_vector(Ru, Rv, G%domain, TO_ALL, BGRID_NE) + cg_halo = 3 + endif + + enddo ! end of CG loop + + do j=jsdq,jedq + do i=isdq,iedq + if (CS%umask(i,j) == 3) then + u(i,j) = CS%u_bdry_val(i,j) + elseif (CS%umask(i,j) == 0) then + u(i,j) = 0 + endif + + if (CS%vmask(i,j) == 3) then + v(i,j) = CS%v_bdry_val(i,j) + elseif (CS%vmask(i,j) == 0) then + v(i,j) = 0 + endif + enddo + enddo + + call pass_vector(u,v, G%domain, TO_ALL, BGRID_NE) + + if (conv_flag == 0) then + iters = CS%cg_max_iterations + endif + +end subroutine ice_shelf_solve_inner + +subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_uflux, flux_enter) + type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, intent(in) :: time_step !< The time step for this update [s]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: h0 !< The initial ice shelf thicknesses [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_after_uflux !< The ice shelf thicknesses after + !! the zonal mass fluxes [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G),4), & + intent(inout) :: flux_enter !< The ice volume flux into the cell + !! through the 4 cell boundaries [Z m2 ~> m3]. + + ! use will be made of ISS%hmask here - its value at the boundary will be zero, just like uncovered cells + + ! if there is an input bdry condition, the thickness there will be set in initialization + + ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary + ! + ! from left neighbor: flux_enter(:,:,1) + ! from right neighbor: flux_enter(:,:,2) + ! from bottom neighbor: flux_enter(:,:,3) + ! from top neighbor: flux_enter(:,:,4) + ! + ! o--- (4) ---o + ! | | + ! (1) (2) + ! | | + ! o--- (3) ---o + ! + + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, gjed, gied + integer :: i_off, j_off + logical :: at_east_bdry, at_west_bdry, one_off_west_bdry, one_off_east_bdry + real, dimension(-2:2) :: stencil ! Thicknesses [Z ~> m]. + real :: u_face, & ! positive if out + flux_diff_cell, phi, dxh, dyh, dxdyh + character (len=1) :: debug_str + + is = G%isc-2 ; ie = G%iec+2 ; js = G%jsc ; je = G%jec + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + i_off = G%idg_offset ; j_off = G%jdg_offset + + do j=jsd+1,jed-1 + if (((j+j_off) <= G%domain%njglobal+G%domain%njhalo) .AND. & + ((j+j_off) >= G%domain%njhalo+1)) then ! based on mehmet's code - only if btw north & south boundaries + + stencil(:) = -1. +! if (i+i_off == G%domain%nihalo+G%domain%nihalo) + do i=is,ie + + if (((i+i_off) <= G%domain%niglobal+G%domain%nihalo) .AND. & + ((i+i_off) >= G%domain%nihalo+1)) then + + if (i+i_off == G%domain%nihalo+1) then + at_west_bdry=.true. + else + at_west_bdry=.false. + endif + + if (i+i_off == G%domain%niglobal+G%domain%nihalo) then + at_east_bdry=.true. + else + at_east_bdry=.false. + endif + + if (hmask(i,j) == 1) then + + dxh = G%dxT(i,j) ; dyh = G%dyT(i,j) ; dxdyh = G%areaT(i,j) + + h_after_uflux(i,j) = h0(i,j) + + stencil(:) = h0(i-2:i+2,j) ! fine as long has nx_halo >= 2 + + flux_diff_cell = 0 + + ! 1ST DO LEFT FACE + + if (CS%u_face_mask(i-1,j) == 4.) then + + flux_diff_cell = flux_diff_cell + dyh * time_step * CS%u_flux_bdry_val(i-1,j) / dxdyh + + else + + ! get u-velocity at center of left face + u_face = 0.5 * (CS%u_shelf(i-1,j-1) + CS%u_shelf(i-1,j)) + + if (u_face > 0) then !flux is into cell - we need info from h(i-2), h(i-1) if available + + ! i may not cover all the cases.. but i cover the realistic ones + + if (at_west_bdry .AND. (hmask(i-1,j) == 3)) then ! at western bdry but there is a + ! thickness bdry condition, and the stencil contains it + stencil (-1) = CS%thickness_bdry_val(i-1,j) + flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step * stencil(-1) / dxdyh + + elseif (hmask(i-1,j) * hmask(i-2,j) == 1) then ! h(i-2) and h(i-1) are valid + phi = slope_limiter(stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) + flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh* time_step / dxdyh * & + (stencil(-1) - phi * (stencil(-1)-stencil(0))/2) + + else ! h(i-1) is valid + ! (o.w. flux would most likely be out of cell) + ! but h(i-2) is not + + flux_diff_cell = flux_diff_cell + ABS(u_face) * (dyh * time_step / dxdyh) * stencil(-1) + + endif + + elseif (u_face < 0) then !flux is out of cell - we need info from h(i-1), h(i+1) if available + if (hmask(i-1,j) * hmask(i+1,j) == 1) then ! h(i-1) and h(i+1) are both valid + phi = slope_limiter(stencil(0)-stencil(1), stencil(-1)-stencil(0)) + flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * & + (stencil(0) - phi * (stencil(0)-stencil(-1))/2) + + else + flux_diff_cell = flux_diff_cell - ABS(u_face) * (dyh * time_step / dxdyh) * stencil(0) + + if ((hmask(i-1,j) == 0) .OR. (hmask(i-1,j) == 2)) then + flux_enter(i-1,j,2) = ABS(u_face) * dyh * time_step * stencil(0) + endif + endif + endif + endif + + ! NEXT DO RIGHT FACE + + ! get u-velocity at center of right face + + if (CS%u_face_mask(i+1,j) == 4.) then + + flux_diff_cell = flux_diff_cell + dyh * time_step * CS%u_flux_bdry_val(i+1,j) / dxdyh + + else + + u_face = 0.5 * (CS%u_shelf(i,j-1) + CS%u_shelf(i,j)) + + if (u_face < 0) then !flux is into cell - we need info from h(i+2), h(i+1) if available + + if (at_east_bdry .AND. (hmask(i+1,j) == 3)) then ! at eastern bdry but there is a + ! thickness bdry condition, and the stencil contains it + + flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step * stencil(1) / dxdyh + + elseif (hmask(i+1,j) * hmask(i+2,j) == 1) then ! h(i+2) and h(i+1) are valid + + phi = slope_limiter(stencil(1)-stencil(2), stencil(0)-stencil(1)) + flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step / dxdyh * & + (stencil(1) - phi * (stencil(1)-stencil(0))/2) + + else ! h(i+1) is valid + ! (o.w. flux would most likely be out of cell) + ! but h(i+2) is not + + flux_diff_cell = flux_diff_cell + ABS(u_face) * (dyh * time_step / dxdyh) * stencil(1) + + endif + + elseif (u_face > 0) then !flux is out of cell - we need info from h(i-1), h(i+1) if available + + if (hmask(i-1,j) * hmask(i+1,j) == 1) then ! h(i-1) and h(i+1) are both valid + + phi = slope_limiter(stencil(0)-stencil(-1), stencil(1)-stencil(0)) + flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * & + (stencil(0) - phi * (stencil(0)-stencil(1))/2) + + else ! h(i+1) is valid + ! (o.w. flux would most likely be out of cell) + ! but h(i+2) is not + + flux_diff_cell = flux_diff_cell - ABS(u_face) * (dyh * time_step / dxdyh) * stencil(0) + + if ((hmask(i+1,j) == 0) .OR. (hmask(i+1,j) == 2)) then + flux_enter(i+1,j,1) = ABS(u_face) * dyh * time_step * stencil(0) + endif + + endif + + endif + + h_after_uflux(i,j) = h_after_uflux(i,j) + flux_diff_cell + + endif + + elseif ((hmask(i,j) == 0) .OR. (hmask(i,j) == 2)) then + + if (at_west_bdry .AND. (hmask(i-1,j) == 3)) then + u_face = 0.5 * (CS%u_shelf(i-1,j-1) + CS%u_shelf(i-1,j)) + flux_enter(i,j,1) = ABS(u_face) * G%dyT(i,j) * time_step * CS%thickness_bdry_val(i-1,j) + elseif (CS%u_face_mask(i-1,j) == 4.) then + flux_enter(i,j,1) = G%dyT(i,j) * time_step * CS%u_flux_bdry_val(i-1,j) + endif + + if (at_east_bdry .AND. (hmask(i+1,j) == 3)) then + u_face = 0.5 * (CS%u_shelf(i,j-1) + CS%u_shelf(i,j)) + flux_enter(i,j,2) = ABS(u_face) * G%dyT(i,j) * time_step * CS%thickness_bdry_val(i+1,j) + elseif (CS%u_face_mask(i+1,j) == 4.) then + flux_enter(i,j,2) = G%dyT(i,j) * time_step * CS%u_flux_bdry_val(i+1,j) + endif + + if ((i == is) .AND. (hmask(i,j) == 0) .AND. (hmask(i-1,j) == 1)) then + ! this is solely for the purposes of keeping the mask consistent while advancing + ! the front without having to call pass_var - if cell is empty and cell to left + ! is ice-covered then this cell will become partly covered + + hmask(i,j) = 2 + elseif ((i == ie) .AND. (hmask(i,j) == 0) .AND. (hmask(i+1,j) == 1)) then + ! this is solely for the purposes of keeping the mask consistent while advancing + ! the front without having to call pass_var - if cell is empty and cell to left + ! is ice-covered then this cell will become partly covered + + hmask(i,j) = 2 + + endif + + endif + + endif + + enddo ! i loop + + endif + + enddo ! j loop + +end subroutine ice_shelf_advect_thickness_x + +subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, h_after_vflux, flux_enter) + type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, intent(in) :: time_step !< The time step for this update [s]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: h_after_uflux !< The ice shelf thicknesses after + !! the zonal mass fluxes [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_after_vflux !< The ice shelf thicknesses after + !! the meridional mass fluxes [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G),4), & + intent(inout) :: flux_enter !< The ice volume flux into the cell + !! through the 4 cell boundaries [Z m2 ~> m3]. + + ! use will be made of ISS%hmask here - its value at the boundary will be zero, just like uncovered cells + + ! if there is an input bdry condition, the thickness there will be set in initialization + + ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary + ! + ! from left neighbor: flux_enter(:,:,1) + ! from right neighbor: flux_enter(:,:,2) + ! from bottom neighbor: flux_enter(:,:,3) + ! from top neighbor: flux_enter(:,:,4) + ! + ! o--- (4) ---o + ! | | + ! (1) (2) + ! | | + ! o--- (3) ---o + ! + + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, gjed, gied + integer :: i_off, j_off + logical :: at_north_bdry, at_south_bdry, one_off_west_bdry, one_off_east_bdry + real, dimension(-2:2) :: stencil ! Thicknesses [Z ~> m]. + real :: v_face, & ! positive if out + flux_diff_cell, phi, dxh, dyh, dxdyh + character(len=1) :: debug_str + + is = G%isc ; ie = G%iec ; js = G%jsc-1 ; je = G%jec+1 ; isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + i_off = G%idg_offset ; j_off = G%jdg_offset + + do i=isd+2,ied-2 + if (((i+i_off) <= G%domain%niglobal+G%domain%nihalo) .AND. & + ((i+i_off) >= G%domain%nihalo+1)) then ! based on Mehmet's code - only if btw east & west boundaries + + stencil(:) = -1 + + do j=js,je + + if (((j+j_off) <= G%domain%njglobal+G%domain%njhalo) .AND. & + ((j+j_off) >= G%domain%njhalo+1)) then + + if (j+j_off == G%domain%njhalo+1) then + at_south_bdry=.true. + else + at_south_bdry=.false. + endif + + if (j+j_off == G%domain%njglobal+G%domain%njhalo) then + at_north_bdry=.true. + else + at_north_bdry=.false. + endif + + if (hmask(i,j) == 1) then + dxh = G%dxT(i,j) ; dyh = G%dyT(i,j) ; dxdyh = G%areaT(i,j) + h_after_vflux(i,j) = h_after_uflux(i,j) + + stencil(:) = h_after_uflux(i,j-2:j+2) ! fine as long has ny_halo >= 2 + flux_diff_cell = 0 + + ! 1ST DO south FACE + + if (CS%v_face_mask(i,j-1) == 4.) then + + flux_diff_cell = flux_diff_cell + dxh * time_step * CS%v_flux_bdry_val(i,j-1) / dxdyh + + else + + ! get u-velocity at center of left face + v_face = 0.5 * (CS%v_shelf(i-1,j-1) + CS%v_shelf(i,j-1)) + + if (v_face > 0) then !flux is into cell - we need info from h(j-2), h(j-1) if available + + ! i may not cover all the cases.. but i cover the realistic ones + + if (at_south_bdry .AND. (hmask(i,j-1) == 3)) then ! at western bdry but there is a + ! thickness bdry condition, and the stencil contains it + flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step * stencil(-1) / dxdyh + + elseif (hmask(i,j-1) * hmask(i,j-2) == 1) then ! h(j-2) and h(j-1) are valid + + phi = slope_limiter(stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) + flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * & + (stencil(-1) - phi * (stencil(-1)-stencil(0))/2) + + else ! h(j-1) is valid + ! (o.w. flux would most likely be out of cell) + ! but h(j-2) is not + flux_diff_cell = flux_diff_cell + ABS(v_face) * (dxh * time_step / dxdyh) * stencil(-1) + endif + + elseif (v_face < 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available + + if (hmask(i,j-1) * hmask(i,j+1) == 1) then ! h(j-1) and h(j+1) are both valid + phi = slope_limiter(stencil(0)-stencil(1), stencil(-1)-stencil(0)) + flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * & + (stencil(0) - phi * (stencil(0)-stencil(-1))/2) + else + flux_diff_cell = flux_diff_cell - ABS(v_face) * (dxh * time_step / dxdyh) * stencil(0) + + if ((hmask(i,j-1) == 0) .OR. (hmask(i,j-1) == 2)) then + flux_enter(i,j-1,4) = ABS(v_face) * dyh * time_step * stencil(0) + endif + + endif + + endif + + endif + + ! NEXT DO north FACE + + if (CS%v_face_mask(i,j+1) == 4.) then + + flux_diff_cell = flux_diff_cell + dxh * time_step * CS%v_flux_bdry_val(i,j+1) / dxdyh + + else + + ! get u-velocity at center of right face + v_face = 0.5 * (CS%v_shelf(i-1,j) + CS%v_shelf(i,j)) + + if (v_face < 0) then !flux is into cell - we need info from h(j+2), h(j+1) if available + + if (at_north_bdry .AND. (hmask(i,j+1) == 3)) then ! at eastern bdry but there is a + ! thickness bdry condition, and the stencil contains it + flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step * stencil(1) / dxdyh + elseif (hmask(i,j+1) * hmask(i,j+2) == 1) then ! h(j+2) and h(j+1) are valid + phi = slope_limiter(stencil(1)-stencil(2), stencil(0)-stencil(1)) + flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * & + (stencil(1) - phi * (stencil(1)-stencil(0))/2) + else ! h(j+1) is valid + ! (o.w. flux would most likely be out of cell) + ! but h(j+2) is not + flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * stencil(1) + endif + + elseif (v_face > 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available + + if (hmask(i,j-1) * hmask(i,j+1) == 1) then ! h(j-1) and h(j+1) are both valid + phi = slope_limiter(stencil(0)-stencil(-1), stencil(1)-stencil(0)) + flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * & + (stencil(0) - phi * (stencil(0)-stencil(1))/2) + else ! h(j+1) is valid + ! (o.w. flux would most likely be out of cell) + ! but h(j+2) is not + flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * stencil(0) + if ((hmask(i,j+1) == 0) .OR. (hmask(i,j+1) == 2)) then + flux_enter(i,j+1,3) = ABS(v_face) * dxh * time_step * stencil(0) + endif + endif + + endif + + endif + + h_after_vflux(i,j) = h_after_vflux(i,j) + flux_diff_cell + + elseif ((hmask(i,j) == 0) .OR. (hmask(i,j) == 2)) then + + if (at_south_bdry .AND. (hmask(i,j-1) == 3)) then + v_face = 0.5 * (CS%u_shelf(i-1,j-1) + CS%u_shelf(i,j-1)) + flux_enter(i,j,3) = ABS(v_face) * G%dxT(i,j) * time_step * CS%thickness_bdry_val(i,j-1) + elseif (CS%v_face_mask(i,j-1) == 4.) then + flux_enter(i,j,3) = G%dxT(i,j) * time_step * CS%v_flux_bdry_val(i,j-1) + endif + + if (at_north_bdry .AND. (hmask(i,j+1) == 3)) then + v_face = 0.5 * (CS%u_shelf(i-1,j) + CS%u_shelf(i,j)) + flux_enter(i,j,4) = ABS(v_face) * G%dxT(i,j) * time_step * CS%thickness_bdry_val(i,j+1) + elseif (CS%v_face_mask(i,j+1) == 4.) then + flux_enter(i,j,4) = G%dxT(i,j) * time_step * CS%v_flux_bdry_val(i,j+1) + endif + + if ((j == js) .AND. (hmask(i,j) == 0) .AND. (hmask(i,j-1) == 1)) then + ! this is solely for the purposes of keeping the mask consistent while advancing + ! the front without having to call pass_var - if cell is empty and cell to left + ! is ice-covered then this cell will become partly covered + hmask(i,j) = 2 + elseif ((j == je) .AND. (hmask(i,j) == 0) .AND. (hmask(i,j+1) == 1)) then + ! this is solely for the purposes of keeping the mask consistent while advancing + ! the front without having to call pass_var - if cell is empty and cell to left + ! is ice-covered then this cell will become partly covered + hmask(i,j) = 2 + endif + + endif + endif + enddo ! j loop + endif + enddo ! i loop + +end subroutine ice_shelf_advect_thickness_y + +subroutine shelf_advance_front(CS, ISS, G, flux_enter) + type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), intent(inout) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDI_(G),SZDJ_(G),4), & + intent(inout) :: flux_enter !< The ice volume flux into the cell + !! through the 4 cell boundaries [Z m2 ~> m3]. + + ! in this subroutine we go through the computational cells only and, if they are empty or partial cells, + ! we find the reference thickness and update the shelf mass and partial area fraction and the hmask if necessary + + ! if any cells go from partial to complete, we then must set the thickness, update hmask accordingly, + ! and divide the overflow across the adjacent EMPTY (not partly-covered) cells. + ! (it is highly unlikely there will not be any; in which case this will need to be rethought.) + + ! most likely there will only be one "overflow". if not, though, a pass_var of all relevant variables + ! is done; there will therefore be a loop which, in practice, will hopefully not have to go through + ! many iterations + + ! when 3d advected scalars are introduced, they will be impacted by what is done here + + ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary + ! + ! from left neighbor: flux_enter(:,:,1) + ! from right neighbor: flux_enter(:,:,2) + ! from bottom neighbor: flux_enter(:,:,3) + ! from top neighbor: flux_enter(:,:,4) + ! + ! o--- (4) ---o + ! | | + ! (1) (2) + ! | | + ! o--- (3) ---o + ! + + integer :: i, j, isc, iec, jsc, jec, n_flux, k, l, iter_count + integer :: i_off, j_off + integer :: iter_flag + + real :: h_reference, dxh, dyh, dxdyh, rho, partial_vol, tot_flux + character(len=160) :: mesg ! The text of an error message + integer, dimension(4) :: mapi, mapj, new_partial +! real, dimension(size(flux_enter,1),size(flux_enter,2),size(flux_enter,2)) :: flux_enter_replace + real, dimension(SZDI_(G),SZDJ_(G),4) :: flux_enter_replace + + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec + i_off = G%idg_offset ; j_off = G%jdg_offset + rho = CS%density_ice + iter_count = 0 ; iter_flag = 1 + + + mapi(1) = -1 ; mapi(2) = 1 ; mapi(3:4) = 0 + mapj(3) = -1 ; mapj(4) = 1 ; mapj(1:2) = 0 + + do while (iter_flag == 1) + + iter_flag = 0 + + if (iter_count > 0) then + flux_enter(:,:,:) = flux_enter_replace(:,:,:) + endif + flux_enter_replace(:,:,:) = 0.0 + + iter_count = iter_count + 1 + + ! if iter_count >= 3 then some halo updates need to be done... + + do j=jsc-1,jec+1 + + if (((j+j_off) <= G%domain%njglobal+G%domain%njhalo) .AND. & + ((j+j_off) >= G%domain%njhalo+1)) then + + do i=isc-1,iec+1 + + if (((i+i_off) <= G%domain%niglobal+G%domain%nihalo) .AND. & + ((i+i_off) >= G%domain%nihalo+1)) then + ! first get reference thickness by averaging over cells that are fluxing into this cell + n_flux = 0 + h_reference = 0.0 + tot_flux = 0.0 + + do k=1,2 + if (flux_enter(i,j,k) > 0) then + n_flux = n_flux + 1 + h_reference = h_reference + ISS%h_shelf(i+2*k-3,j) + tot_flux = tot_flux + flux_enter(i,j,k) + flux_enter(i,j,k) = 0.0 + endif + enddo + + do k=1,2 + if (flux_enter(i,j,k+2) > 0) then + n_flux = n_flux + 1 + h_reference = h_reference + ISS%h_shelf(i,j+2*k-3) + tot_flux = tot_flux + flux_enter(i,j,k+2) + flux_enter(i,j,k+2) = 0.0 + endif + enddo + + if (n_flux > 0) then + dxdyh = G%areaT(i,j) + h_reference = h_reference / real(n_flux) + partial_vol = ISS%h_shelf(i,j) * ISS%area_shelf_h(i,j) + tot_flux + + if ((partial_vol / dxdyh) == h_reference) then ! cell is exactly covered, no overflow + ISS%hmask(i,j) = 1 + ISS%h_shelf(i,j) = h_reference + ISS%area_shelf_h(i,j) = dxdyh + elseif ((partial_vol / dxdyh) < h_reference) then + ISS%hmask(i,j) = 2 + ! ISS%mass_shelf(i,j) = partial_vol * rho + ISS%area_shelf_h(i,j) = partial_vol / h_reference + ISS%h_shelf(i,j) = h_reference + else + + ISS%hmask(i,j) = 1 + ISS%area_shelf_h(i,j) = dxdyh + !h_temp(i,j) = h_reference + partial_vol = partial_vol - h_reference * dxdyh + + iter_flag = 1 + + n_flux = 0 ; new_partial(:) = 0 + + do k=1,2 + if (CS%u_face_mask(i-2+k,j) == 2) then + n_flux = n_flux + 1 + elseif (ISS%hmask(i+2*k-3,j) == 0) then + n_flux = n_flux + 1 + new_partial(k) = 1 + endif + enddo + do k=1,2 + if (CS%v_face_mask(i,j-2+k) == 2) then + n_flux = n_flux + 1 + elseif (ISS%hmask(i,j+2*k-3) == 0) then + n_flux = n_flux + 1 + new_partial(k+2) = 1 + endif + enddo + + if (n_flux == 0) then ! there is nowhere to put the extra ice! + ISS%h_shelf(i,j) = h_reference + partial_vol / dxdyh + else + ISS%h_shelf(i,j) = h_reference + + do k=1,2 + if (new_partial(k) == 1) & + flux_enter_replace(i+2*k-3,j,3-k) = partial_vol / real(n_flux) + enddo + do k=1,2 ! ### Combine these two loops? + if (new_partial(k+2) == 1) & + flux_enter_replace(i,j+2*k-3,5-k) = partial_vol / real(n_flux) + enddo + endif + + endif ! Parital_vol test. + endif ! n_flux gt 0 test. + + endif + enddo ! j-loop + endif + enddo + + ! call max_across_PEs(iter_flag) + + enddo ! End of do while(iter_flag) loop + + call max_across_PEs(iter_count) + + if (is_root_pe() .and. (iter_count > 1)) then + write(mesg,*) "shelf_advance_front: ", iter_count, " max iterations" + call MOM_mesg(mesg, 5) + endif + +end subroutine shelf_advance_front + +!> Apply a very simple calving law using a minimum thickness rule +subroutine ice_shelf_min_thickness_calve(G, h_shelf, area_shelf_h, hmask, thickness_calve) + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_shelf !< The ice shelf thickness [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf [m2]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + real, intent(in) :: thickness_calve !< The thickness at which to trigger calving [Z ~> m]. + + integer :: i,j + + do j=G%jsd,G%jed + do i=G%isd,G%ied +! if ((h_shelf(i,j) < CS%thickness_calve) .and. (hmask(i,j) == 1) .and. & +! (CS%float_frac(i,j) == 0.0)) then + if ((h_shelf(i,j) < thickness_calve) .and. (area_shelf_h(i,j) > 0.)) then + h_shelf(i,j) = 0.0 + area_shelf_h(i,j) = 0.0 + hmask(i,j) = 0.0 + endif + enddo + enddo + +end subroutine ice_shelf_min_thickness_calve + +subroutine calve_to_mask(G, h_shelf, area_shelf_h, hmask, calve_mask) + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_shelf !< The ice shelf thickness [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf [m2]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: calve_mask !< A mask that indicates where the ice shelf + !! can exist, and where it will calve. + + integer :: i,j + + do j=G%jsc,G%jec ; do i=G%isc,G%iec + if ((calve_mask(i,j) == 0.0) .and. (hmask(i,j) /= 0.0)) then + h_shelf(i,j) = 0.0 + area_shelf_h(i,j) = 0.0 + hmask(i,j) = 0.0 + endif + enddo ; enddo + +end subroutine calve_to_mask + +subroutine calc_shelf_driving_stress(CS, ISS, G, US, TAUD_X, TAUD_Y, OD) + type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + type(unit_scale_type), intent(in) :: US !< Pointer to a structure containing unit conversion factors + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: OD !< ocean floor depth at tracer points [Z ~> m]. + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: TAUD_X !< X-direction driving stress at q-points + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: TAUD_Y !< Y-direction driving stress at q-points + +! driving stress! + +! ! TAUD_X and TAUD_Y will hold driving stress in the x- and y- directions when done. +! they will sit on the BGrid, and so their size depends on whether the grid is symmetric +! +! Since this is a finite element solve, they will actually have the form \int \phi_i rho g h \nabla s +! +! OD -this is important and we do not yet know where (in MOM) it will come from. It represents +! "average" ocean depth -- and is needed to find surface elevation +! (it is assumed that base_ice = bed + OD) + + real, dimension(SIZE(OD,1),SIZE(OD,2)) :: S, & ! surface elevation [Z ~> m]. + BASE ! basal elevation of shelf/stream [Z ~> m]. + + + real :: rho, rhow, sx, sy, neumann_val, dxh, dyh, dxdyh, grav + + integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, is, js, iegq, jegq + integer :: giec, gjec, gisc, gjsc, cnt, isc, jsc, iec, jec + integer :: i_off, j_off + + isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec + iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB + isd = G%isd ; jsd = G%jsd + iegq = G%iegB ; jegq = G%jegB + gisc = G%domain%nihalo+1 ; gjsc = G%domain%njhalo+1 + giec = G%domain%niglobal+G%domain%nihalo ; gjec = G%domain%njglobal+G%domain%njhalo + is = iscq - 1; js = jscq - 1 + i_off = G%idg_offset ; j_off = G%jdg_offset + + rho = CS%density_ice + rhow = CS%density_ocean_avg + grav = US%Z_to_m**2 * CS%g_Earth + + ! prelim - go through and calculate S + + ! or is this faster? + BASE(:,:) = -G%bathyT(:,:) + OD(:,:) + S(:,:) = BASE(:,:) + ISS%h_shelf(:,:) + + do j=jsc-1,jec+1 + do i=isc-1,iec+1 + cnt = 0 + sx = 0 + sy = 0 + dxh = G%dxT(i,j) + dyh = G%dyT(i,j) + dxdyh = G%areaT(i,j) + + if (ISS%hmask(i,j) == 1) then ! we are inside the global computational bdry, at an ice-filled cell + + ! calculate sx + if ((i+i_off) == gisc) then ! at left computational bdry + if (ISS%hmask(i+1,j) == 1) then + sx = (S(i+1,j)-S(i,j))/dxh + else + sx = 0 + endif + elseif ((i+i_off) == giec) then ! at right computational bdry + if (ISS%hmask(i-1,j) == 1) then + sx = (S(i,j)-S(i-1,j))/dxh + else + sx = 0 + endif + else ! interior + if (ISS%hmask(i+1,j) == 1) then + cnt = cnt+1 + sx = S(i+1,j) + else + sx = S(i,j) + endif + if (ISS%hmask(i-1,j) == 1) then + cnt = cnt+1 + sx = sx - S(i-1,j) + else + sx = sx - S(i,j) + endif + if (cnt == 0) then + sx = 0 + else + sx = sx / (cnt * dxh) + endif + endif + + cnt = 0 + + ! calculate sy, similarly + if ((j+j_off) == gjsc) then ! at south computational bdry + if (ISS%hmask(i,j+1) == 1) then + sy = (S(i,j+1)-S(i,j))/dyh + else + sy = 0 + endif + elseif ((j+j_off) == gjec) then ! at nprth computational bdry + if (ISS%hmask(i,j-1) == 1) then + sy = (S(i,j)-S(i,j-1))/dyh + else + sy = 0 + endif + else ! interior + if (ISS%hmask(i,j+1) == 1) then + cnt = cnt+1 + sy = S(i,j+1) + else + sy = S(i,j) + endif + if (ISS%hmask(i,j-1) == 1) then + cnt = cnt+1 + sy = sy - S(i,j-1) + else + sy = sy - S(i,j) + endif + if (cnt == 0) then + sy = 0 + else + sy = sy / (cnt * dyh) + endif + endif + + ! SW vertex + taud_x(I-1,J-1) = taud_x(I-1,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * dxdyh + taud_y(I-1,J-1) = taud_y(I-1,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * dxdyh + + ! SE vertex + taud_x(I,J-1) = taud_x(I,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * dxdyh + taud_y(I,J-1) = taud_y(I,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * dxdyh + + ! NW vertex + taud_x(I-1,J) = taud_x(I-1,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * dxdyh + taud_y(I-1,J) = taud_y(I-1,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * dxdyh + + ! NE vertex + taud_x(I,J) = taud_x(I,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * dxdyh + taud_y(I,J) = taud_y(I,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * dxdyh + + if (CS%float_frac(i,j) == 1) then + neumann_val = .5 * grav * (rho * ISS%h_shelf(i,j)**2 - rhow * G%bathyT(i,j)**2) + else + neumann_val = .5 * grav * (1-rho/rhow) * rho * ISS%h_shelf(i,j)**2 + endif + + + if ((CS%u_face_mask(i-1,j) == 2) .OR. (ISS%hmask(i-1,j) == 0) .OR. (ISS%hmask(i-1,j) == 2) ) then + ! left face of the cell is at a stress boundary + ! the depth-integrated longitudinal stress is equal to the difference of depth-integrated + ! pressure on either side of the face + ! on the ice side, it is rho g h^2 / 2 + ! on the ocean side, it is rhow g (delta OD)^2 / 2 + ! OD can be zero under the ice; but it is ASSUMED on the ice-free side of the face, topography elevation + ! is not above the base of the ice in the current cell + + ! note negative sign due to direction of normal vector + taud_x(i-1,j-1) = taud_x(i-1,j-1) - .5 * dyh * neumann_val + taud_x(i-1,j) = taud_x(i-1,j) - .5 * dyh * neumann_val + endif + + if ((CS%u_face_mask(i,j) == 2) .OR. (ISS%hmask(i+1,j) == 0) .OR. (ISS%hmask(i+1,j) == 2) ) then + ! right face of the cell is at a stress boundary + taud_x(i,j-1) = taud_x(i,j-1) + .5 * dyh * neumann_val + taud_x(i,j) = taud_x(i,j) + .5 * dyh * neumann_val + endif + + if ((CS%v_face_mask(i,j-1) == 2) .OR. (ISS%hmask(i,j-1) == 0) .OR. (ISS%hmask(i,j-1) == 2) ) then + ! south face of the cell is at a stress boundary + taud_y(i-1,j-1) = taud_y(i-1,j-1) - .5 * dxh * neumann_val + taud_y(i,j-1) = taud_y(i,j-1) - .5 * dxh * neumann_val + endif + + if ((CS%v_face_mask(i,j) == 2) .OR. (ISS%hmask(i,j+1) == 0) .OR. (ISS%hmask(i,j+1) == 2) ) then + ! north face of the cell is at a stress boundary + taud_y(i-1,j) = taud_y(i-1,j) + .5 * dxh * neumann_val ! note negative sign due to direction of normal vector + taud_y(i,j) = taud_y(i,j) + .5 * dxh * neumann_val + endif + + endif + enddo + enddo + +end subroutine calc_shelf_driving_stress + +subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new_sim) + type(ice_shelf_dyn_CS),intent(inout) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + type(time_type), intent(in) :: Time !< The current model time + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + real, intent(in) :: input_flux !< The integrated inward ice thickness flux [Z m2 s-1 ~> m3 s-1] + real, intent(in) :: input_thick !< The ice thickness at boundaries [Z ~> m]. + logical, optional, intent(in) :: new_sim !< If present and false, this run is being restarted + +! this will be a per-setup function. the boundary values of thickness and velocity +! (and possibly other variables) will be updated in this function + +! FOR RESTARTING PURPOSES: if grid is not symmetric and the model is restarted, we will +! need to update those velocity points not *technically* in any +! computational domain -- if this function gets moves to another module, +! DO NOT TAKE THE RESTARTING BIT WITH IT + integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, iegq, jegq + integer :: gjec, gisc, gjsc, cnt, isc, jsc, iec, jec + integer :: i_off, j_off + real :: A, n, ux, uy, vx, vy, eps_min, domain_width + + + isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec +! iscq = G%iscq ; iecq = G%iecq ; jscq = G%jscq ; jecq = G%jecq + isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed +! iegq = G%iegq ; jegq = G%jegq + i_off = G%idg_offset ; j_off = G%jdg_offset + + domain_width = G%len_lat + + ! this loop results in some values being set twice but... eh. + + do j=jsd,jed + do i=isd,ied + + if (hmask(i,j) == 3) then + CS%thickness_bdry_val(i,j) = input_thick + endif + + if ((hmask(i,j) == 0) .or. (hmask(i,j) == 1) .or. (hmask(i,j) == 2)) then + if ((i <= iec).and.(i >= isc)) then + if (CS%u_face_mask(i-1,j) == 3) then + CS%u_bdry_val(i-1,j-1) = (1 - ((G%geoLatBu(i-1,j-1) - 0.5*G%len_lat)*2./G%len_lat)**2) * & + 1.5 * input_flux / input_thick + CS%u_bdry_val(i-1,j) = (1 - ((G%geoLatBu(i-1,j) - 0.5*G%len_lat)*2./G%len_lat)**2) * & + 1.5 * input_flux / input_thick + endif + endif + endif + + if (.not.(new_sim)) then + if (.not. G%symmetric) then + if (((i+i_off) == (G%domain%nihalo+1)).and.(CS%u_face_mask(i-1,j) == 3)) then + CS%u_shelf(i-1,j-1) = CS%u_bdry_val(i-1,j-1) + CS%u_shelf(i-1,j) = CS%u_bdry_val(i-1,j) + endif + if (((j+j_off) == (G%domain%njhalo+1)).and.(CS%v_face_mask(i,j-1) == 3)) then + CS%u_shelf(i-1,j-1) = CS%u_bdry_val(i-1,j-1) + CS%u_shelf(i,j-1) = CS%u_bdry_val(i,j-1) + endif + endif + endif + enddo + enddo + +end subroutine init_boundary_values + + +subroutine CG_action(uret, vret, u, v, Phi, Phisub, umask, vmask, hmask, H_node, & + nu, float_cond, bathyT, beta, dxdyh, G, is, ie, js, je, dens_ratio) + + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & + intent(inout) :: uret !< The retarding stresses working at u-points. + real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & + intent(inout) :: vret !< The retarding stresses working at v-points. + real, dimension(SZDI_(G),SZDJ_(G),8,4), & + intent(in) :: Phi !< The gradients of bilinear basis elements at Gaussian + !! quadrature points surrounding the cell verticies. + real, dimension(:,:,:,:,:,:), & + intent(in) :: Phisub !< Quadrature structure weights at subgridscale + !! locations for finite element calculations + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: u !< The zonal ice shelf velocity at vertices [m year-1] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: v !< The meridional ice shelf velocity at vertices [m year-1] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: umask !< A coded mask indicating the nature of the + !! zonal flow at the corner point + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: vmask !< A coded mask indicating the nature of the + !! meridional flow at the corner point + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: H_node !< The ice shelf thickness at nodal (corner) + !! points [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: nu !< A field related to the ice viscosity from Glen's + !! flow law. The exact form and units depend on the + !! basal law exponent. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: float_cond !< An array indicating where the ice + !! shelf is floating: 0 if floating, 1 if not. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: bathyT !< The depth of ocean bathymetry at tracer points [Z ~> m]. + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: beta !< A field related to the nonlinear part of the + !! "linearized" basal stress. The exact form and + !! units depend on the basal law exponent. + ! and/or whether flow is "hybridized" + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: dxdyh !< The tracer cell area [m2] + real, intent(in) :: dens_ratio !< The density of ice divided by the density + !! of seawater, nondimensional + integer, intent(in) :: is !< The starting i-index to work on + integer, intent(in) :: ie !< The ending i-index to work on + integer, intent(in) :: js !< The starting j-index to work on + integer, intent(in) :: je !< The ending j-index to work on + +! the linear action of the matrix on (u,v) with bilinear finite elements +! as of now everything is passed in so no grid pointers or anything of the sort have to be dereferenced, +! but this may change pursuant to conversations with others +! +! is & ie are the cells over which the iteration is done; this may change between calls to this subroutine +! in order to make less frequent halo updates + +! the linear action of the matrix on (u,v) with bilinear finite elements +! Phi has the form +! Phi(i,j,k,q) - applies to cell i,j + + ! 3 - 4 + ! | | + ! 1 - 2 + +! Phi(i,j,2*k-1,q) gives d(Phi_k)/dx at quadrature point q +! Phi(i,j,2*k,q) gives d(Phi_k)/dy at quadrature point q +! Phi_k is equal to 1 at vertex k, and 0 at vertex l /= k, and bilinear + + real :: ux, vx, uy, vy, uq, vq, area, basel + integer :: iq, jq, iphi, jphi, i, j, ilq, jlq + real, dimension(2) :: xquad + real, dimension(2,2) :: Ucell,Vcell,Hcell,Usubcontr,Vsubcontr,Ucontr + + xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) + + do j=js,je + do i=is,ie ; if (hmask(i,j) == 1) then +! dxh = G%dxh(i,j) +! dyh = G%dyh(i,j) +! +! X(:,:) = G%geoLonBu(i-1:i,j-1:j) +! Y(:,:) = G%geoLatBu(i-1:i,j-1:j) +! +! call bilinear_shape_functions (X, Y, Phi, area) + + ! X and Y must be passed in the form + ! 3 - 4 + ! | | + ! 1 - 2 + ! Phi (2*i-1,j) gives d(Phi_i)/dx at quadrature point j + ! Phi (2*i,j) gives d(Phi_i)/dy at quadrature point j + + area = dxdyh(i,j) + + Ucontr=0 + do iq=1,2 ; do jq=1,2 + + + if (iq == 2) then + ilq = 2 + else + ilq = 1 + endif + + if (jq == 2) then + jlq = 2 + else + jlq = 1 + endif + + uq = u(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & + u(i,j-1) * xquad(iq) * xquad(3-jq) + & + u(i-1,j) * xquad(3-iq) * xquad(jq) + & + u(i,j) * xquad(iq) * xquad(jq) + + vq = v(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & + v(i,j-1) * xquad(iq) * xquad(3-jq) + & + v(i-1,j) * xquad(3-iq) * xquad(jq) + & + v(i,j) * xquad(iq) * xquad(jq) + + ux = u(i-1,j-1) * Phi(i,j,1,2*(jq-1)+iq) + & + u(i,j-1) * Phi(i,j,3,2*(jq-1)+iq) + & + u(i-1,j) * Phi(i,j,5,2*(jq-1)+iq) + & + u(i,j) * Phi(i,j,7,2*(jq-1)+iq) + + vx = v(i-1,j-1) * Phi(i,j,1,2*(jq-1)+iq) + & + v(i,j-1) * Phi(i,j,3,2*(jq-1)+iq) + & + v(i-1,j) * Phi(i,j,5,2*(jq-1)+iq) + & + v(i,j) * Phi(i,j,7,2*(jq-1)+iq) + + uy = u(i-1,j-1) * Phi(i,j,2,2*(jq-1)+iq) + & + u(i,j-1) * Phi(i,j,4,2*(jq-1)+iq) + & + u(i-1,j) * Phi(i,j,6,2*(jq-1)+iq) + & + u(i,j) * Phi(i,j,8,2*(jq-1)+iq) + + vy = v(i-1,j-1) * Phi(i,j,2,2*(jq-1)+iq) + & + v(i,j-1) * Phi(i,j,4,2*(jq-1)+iq) + & + v(i-1,j) * Phi(i,j,6,2*(jq-1)+iq) + & + v(i,j) * Phi(i,j,8,2*(jq-1)+iq) + + do iphi=1,2 ; do jphi=1,2 + if (umask(i-2+iphi,j-2+jphi) == 1) then + + uret(i-2+iphi,j-2+jphi) = uret(i-2+iphi,j-2+jphi) + & + .25 * area * nu(i,j) * ((4*ux+2*vy) * Phi(i,j,2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + (uy+vx) * Phi(i,j,2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) + endif + if (vmask(i-2+iphi,j-2+jphi) == 1) then + + vret(i-2+iphi,j-2+jphi) = vret(i-2+iphi,j-2+jphi) + & + .25 * area * nu(i,j) * ((uy+vx) * Phi(i,j,2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + (4*vy+2*ux) * Phi(i,j,2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) + endif + + if (iq == iphi) then + ilq = 2 + else + ilq = 1 + endif + + if (jq == jphi) then + jlq = 2 + else + jlq = 1 + endif + + if (float_cond(i,j) == 0) then + + if (umask(i-2+iphi,j-2+jphi) == 1) then + + uret(i-2+iphi,j-2+jphi) = uret(i-2+iphi,j-2+jphi) + & + .25 * beta(i,j) * area * uq * xquad(ilq) * xquad(jlq) + + endif + + if (vmask(i-2+iphi,j-2+jphi) == 1) then + + vret(i-2+iphi,j-2+jphi) = vret(i-2+iphi,j-2+jphi) + & + .25 * beta(i,j) * area * vq * xquad(ilq) * xquad(jlq) + + endif + + endif + Ucontr(iphi,jphi) = Ucontr(iphi,jphi) + .25 * area * uq * xquad(ilq) * xquad(jlq) * beta(i,j) + enddo ; enddo + enddo ; enddo + + if (float_cond(i,j) == 1) then + Usubcontr = 0.0 ; Vsubcontr = 0.0 ; basel = bathyT(i,j) + Ucell(:,:) = u(i-1:i,j-1:j) ; Vcell(:,:) = v(i-1:i,j-1:j) ; Hcell(:,:) = H_node(i-1:i,j-1:j) + call CG_action_subgrid_basal(Phisub, Hcell, Ucell, Vcell, area, basel, & + dens_ratio, Usubcontr, Vsubcontr) + do iphi=1,2 ; do jphi=1,2 + if (umask(i-2+iphi,j-2+jphi) == 1) then + uret(i-2+iphi,j-2+jphi) = uret(i-2+iphi,j-2+jphi) + Usubcontr (iphi,jphi) * beta(i,j) + endif + if (vmask(i-2+iphi,j-2+jphi) == 1) then + vret(i-2+iphi,j-2+jphi) = vret(i-2+iphi,j-2+jphi) + Vsubcontr (iphi,jphi) * beta(i,j) + endif + enddo ; enddo + endif + + endif + enddo ; enddo + +end subroutine CG_action + +subroutine CG_action_subgrid_basal(Phisub, H, U, V, DXDYH, bathyT, dens_ratio, Ucontr, Vcontr) + real, dimension(:,:,:,:,:,:), & + intent(in) :: Phisub !< Quadrature structure weights at subgridscale + !! locations for finite element calculations + real, dimension(2,2), intent(in) :: H !< The ice shelf thickness at nodal (corner) points [Z ~> m]. + real, dimension(2,2), intent(in) :: U !< The zonal ice shelf velocity at vertices [m year-1] + real, dimension(2,2), intent(in) :: V !< The meridional ice shelf velocity at vertices [m year-1] + real, intent(in) :: DXDYH !< The tracer cell area [m2] + real, intent(in) :: bathyT !< The depth of ocean bathymetry at tracer points [Z ~> m]. + real, intent(in) :: dens_ratio !< The density of ice divided by the density + !! of seawater, nondimensional + real, dimension(2,2), intent(inout) :: Ucontr !< A field related to the subgridscale contributions to + !! the u-direction basal stress. + real, dimension(2,2), intent(inout) :: Vcontr !< A field related to the subgridscale contributions to + !! the v-direction basal stress. + + integer :: nsub, i, j, k, l, qx, qy, m, n + real :: subarea, hloc, uq, vq + + nsub = size(Phisub,1) + subarea = DXDYH / (nsub**2) + + do m=1,2 + do n=1,2 + do j=1,nsub + do i=1,nsub + do qx=1,2 + do qy = 1,2 + + hloc = Phisub(i,j,1,1,qx,qy)*H(1,1) + Phisub(i,j,1,2,qx,qy)*H(1,2) + & + Phisub(i,j,2,1,qx,qy)*H(2,1) + Phisub(i,j,2,2,qx,qy)*H(2,2) + + if (dens_ratio * hloc - bathyT > 0) then + !if (.true.) then + uq = 0 ; vq = 0 + do k=1,2 + do l=1,2 + !Ucontr(m,n) = Ucontr(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy) * Phisub(i,j,k,l,qx,qy) * U(k,l) + !Vcontr(m,n) = Vcontr(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy) * Phisub(i,j,k,l,qx,qy) * V(k,l) + uq = uq + Phisub(i,j,k,l,qx,qy) * U(k,l) ; vq = vq + Phisub(i,j,k,l,qx,qy) * V(k,l) + enddo + enddo + + Ucontr(m,n) = Ucontr(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy) * uq + Vcontr(m,n) = Vcontr(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy) * vq + + endif + + enddo + enddo + enddo + enddo + enddo + enddo + +end subroutine CG_action_subgrid_basal + +!> returns the diagonal entries of the matrix for a Jacobi preconditioning +subroutine matrix_diagonal(CS, G, float_cond, H_node, nu, beta, hmask, dens_ratio, & + Phisub, u_diagonal, v_diagonal) + + type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: float_cond !< An array indicating where the ice + !! shelf is floating: 0 if floating, 1 if not. + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: H_node !< The ice shelf thickness at nodal + !! (corner) points [Z ~> m]. + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: nu !< A field related to the ice viscosity from Glen's + !! flow law. The exact form and units depend on the + !! basal law exponent. + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: beta !< A field related to the nonlinear part of the + !! "linearized" basal stress. The exact form and + !! units depend on the basal law exponent + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + real, intent(in) :: dens_ratio !< The density of ice divided by the density + !! of seawater, nondimensional + real, dimension(:,:,:,:,:,:), intent(in) :: Phisub !< Quadrature structure weights at subgridscale + !! locations for finite element calculations + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: u_diagonal !< The diagonal elements of the u-velocity + !! matrix from the left-hand side of the solver. + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: v_diagonal !< The diagonal elements of the v-velocity + !! matrix from the left-hand side of the solver. + + +! returns the diagonal entries of the matrix for a Jacobi preconditioning + + integer :: i, j, is, js, cnt, isc, jsc, iec, jec, iphi, jphi, iq, jq, ilq, jlq + real :: A, n, ux, uy, vx, vy, eps_min, domain_width, dxh, dyh, dxdyh, area, uq, vq, basel + real, dimension(8,4) :: Phi + real, dimension(4) :: X, Y + real, dimension(2) :: xquad + real, dimension(2,2) :: Hcell,Usubcontr,Vsubcontr + + + isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec + + xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) + +! X and Y must be passed in the form + ! 3 - 4 + ! | | + ! 1 - 2 +! Phi (2*i-1,j) gives d(Phi_i)/dx at quadrature point j +! Phi (2*i,j) gives d(Phi_i)/dy at quadrature point j + + do j=jsc-1,jec+1 ; do i=isc-1,iec+1 ; if (hmask(i,j) == 1) then + + dxh = G%dxT(i,j) + dyh = G%dyT(i,j) + dxdyh = G%areaT(i,j) + + X(1:2) = G%geoLonBu(i-1:i,j-1)*1000 + X(3:4) = G%geoLonBu(i-1:i,j) *1000 + Y(1:2) = G%geoLatBu(i-1:i,j-1) *1000 + Y(3:4) = G%geoLatBu(i-1:i,j)*1000 + + call bilinear_shape_functions(X, Y, Phi, area) + + ! X and Y must be passed in the form + ! 3 - 4 + ! | | + ! 1 - 2 + ! Phi (2*i-1,j) gives d(Phi_i)/dx at quadrature point j + ! Phi (2*i,j) gives d(Phi_i)/dy at quadrature point j + + do iq=1,2 ; do jq=1,2 + + do iphi=1,2 ; do jphi=1,2 + + if (iq == iphi) then + ilq = 2 + else + ilq = 1 + endif + + if (jq == jphi) then + jlq = 2 + else + jlq = 1 + endif + + if (CS%umask(i-2+iphi,j-2+jphi) == 1) then + + ux = Phi (2*(2*(jphi-1)+iphi)-1, 2*(jq-1)+iq) + uy = Phi (2*(2*(jphi-1)+iphi), 2*(jq-1)+iq) + vx = 0. + vy = 0. + + u_diagonal(i-2+iphi,j-2+jphi) = u_diagonal(i-2+iphi,j-2+jphi) + & + .25 * dxdyh * nu(i,j) * ((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + (uy+vy) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) + + uq = xquad(ilq) * xquad(jlq) + + if (float_cond(i,j) == 0) then + u_diagonal(i-2+iphi,j-2+jphi) = u_diagonal(i-2+iphi,j-2+jphi) + & + .25 * beta(i,j) * dxdyh * uq * xquad(ilq) * xquad(jlq) + endif + + endif + + if (CS%vmask(i-2+iphi,j-2+jphi) == 1) then + + vx = Phi (2*(2*(jphi-1)+iphi)-1, 2*(jq-1)+iq) + vy = Phi (2*(2*(jphi-1)+iphi), 2*(jq-1)+iq) + ux = 0. + uy = 0. + + v_diagonal(i-2+iphi,j-2+jphi) = v_diagonal(i-2+iphi,j-2+jphi) + & + .25 * dxdyh * nu(i,j) * ((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) + + vq = xquad(ilq) * xquad(jlq) + + if (float_cond(i,j) == 0) then + v_diagonal(i-2+iphi,j-2+jphi) = v_diagonal(i-2+iphi,j-2+jphi) + & + .25 * beta(i,j) * dxdyh * vq * xquad(ilq) * xquad(jlq) + endif + + endif + enddo ; enddo + enddo ; enddo + if (float_cond(i,j) == 1) then + Usubcontr = 0.0 ; Vsubcontr = 0.0 ; basel = G%bathyT(i,j) + Hcell(:,:) = H_node(i-1:i,j-1:j) + call CG_diagonal_subgrid_basal(Phisub, Hcell, dxdyh, basel, dens_ratio, Usubcontr, Vsubcontr) + do iphi=1,2 ; do jphi=1,2 + if (CS%umask(i-2+iphi,j-2+jphi) == 1) then + u_diagonal(i-2+iphi,j-2+jphi) = u_diagonal(i-2+iphi,j-2+jphi) + Usubcontr(iphi,jphi) * beta(i,j) + v_diagonal(i-2+iphi,j-2+jphi) = v_diagonal(i-2+iphi,j-2+jphi) + Vsubcontr(iphi,jphi) * beta(i,j) + endif + enddo ; enddo + endif + endif ; enddo ; enddo + +end subroutine matrix_diagonal + +subroutine CG_diagonal_subgrid_basal (Phisub, H_node, DXDYH, bathyT, dens_ratio, Ucontr, Vcontr) + real, dimension(:,:,:,:,:,:), & + intent(in) :: Phisub !< Quadrature structure weights at subgridscale + !! locations for finite element calculations + real, dimension(2,2), intent(in) :: H_node !< The ice shelf thickness at nodal (corner) + !! points [Z ~> m]. + real, intent(in) :: DXDYH !< The tracer cell area [m2] + real, intent(in) :: bathyT !< The depth of ocean bathymetry at tracer points [Z ~> m]. + real, intent(in) :: dens_ratio !< The density of ice divided by the density + !! of seawater, nondimensional + real, dimension(2,2), intent(inout) :: Ucontr !< A field related to the subgridscale contributions to + !! the u-direction diagonal elements from basal stress. + real, dimension(2,2), intent(inout) :: Vcontr !< A field related to the subgridscale contributions to + !! the v-direction diagonal elements from basal stress. + + ! bathyT = cellwise-constant bed elevation + + integer :: nsub, i, j, k, l, qx, qy, m, n + real :: subarea, hloc + + nsub = size(Phisub,1) + subarea = DXDYH / (nsub**2) + + do m=1,2 ; do n=1,2 ; do j=1,nsub ; do i=1,nsub ; do qx=1,2 ; do qy = 1,2 + + hloc = Phisub(i,j,1,1,qx,qy)*H_node(1,1) + Phisub(i,j,1,2,qx,qy)*H_node(1,2) + & + Phisub(i,j,2,1,qx,qy)*H_node(2,1) + Phisub(i,j,2,2,qx,qy)*H_node(2,2) + + if (dens_ratio * hloc - bathyT > 0) then + Ucontr(m,n) = Ucontr(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy)**2 + Vcontr(m,n) = Vcontr(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy)**2 + endif + + enddo ; enddo ; enddo ; enddo ; enddo ; enddo + +end subroutine CG_diagonal_subgrid_basal + + +subroutine apply_boundary_values(CS, ISS, G, time, Phisub, H_node, nu, beta, float_cond, & + dens_ratio, u_bdry_contr, v_bdry_contr) + + type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + type(time_type), intent(in) :: Time !< The current model time + real, dimension(:,:,:,:,:,:), & + intent(in) :: Phisub !< Quadrature structure weights at subgridscale + !! locations for finite element calculations + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: H_node !< The ice shelf thickness at nodal + !! (corner) points [Z ~> m]. + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: nu !< A field related to the ice viscosity from Glen's + !! flow law. The exact form and units depend on the + !! basal law exponent. + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: beta !< A field related to the nonlinear part of the + !! "linearized" basal stress. The exact form and + !! units depend on the basal law exponent + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: float_cond !< An array indicating where the ice + !! shelf is floating: 0 if floating, 1 if not. + real, intent(in) :: dens_ratio !< The density of ice divided by the density + !! of seawater, nondimensional + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: u_bdry_contr !< Contributions to the zonal ice + !! velocities due to the open boundaries + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: v_bdry_contr !< Contributions to the zonal ice + !! velocities due to the open boundaries + +! this will be a per-setup function. the boundary values of thickness and velocity +! (and possibly other variables) will be updated in this function + + real, dimension(8,4) :: Phi + real, dimension(4) :: X, Y + real, dimension(2) :: xquad + integer :: i, j, isc, jsc, iec, jec, iq, jq, iphi, jphi, ilq, jlq + real :: A, n, ux, uy, vx, vy, eps_min, domain_width, dxh, dyh, dxdyh, uq, vq, area, basel + real, dimension(2,2) :: Ucell,Vcell,Hcell,Usubcontr,Vsubcontr + + + isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec + + xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) + +! X and Y must be passed in the form + ! 3 - 4 + ! | | + ! 1 - 2 +! Phi (2*i-1,j) gives d(Phi_i)/dx at quadrature point j +! Phi (2*i,j) gives d(Phi_i)/dy at quadrature point j + + do j=jsc-1,jec+1 ; do i=isc-1,iec+1 ; if (ISS%hmask(i,j) == 1) then + + ! process this cell if any corners have umask set to non-dirichlet bdry. + ! NOTE: vmask not considered, probably should be + + if ((CS%umask(i-1,j-1) == 3) .OR. (CS%umask(i,j-1) == 3) .OR. & + (CS%umask(i-1,j) == 3) .OR. (CS%umask(i,j) == 3)) then + + + dxh = G%dxT(i,j) + dyh = G%dyT(i,j) + dxdyh = G%areaT(i,j) + + X(1:2) = G%geoLonBu(i-1:i,j-1)*1000 + X(3:4) = G%geoLonBu(i-1:i,j)*1000 + Y(1:2) = G%geoLatBu(i-1:i,j-1)*1000 + Y(3:4) = G%geoLatBu(i-1:i,j)*1000 + + call bilinear_shape_functions(X, Y, Phi, area) + + ! X and Y must be passed in the form + ! 3 - 4 + ! | | + ! 1 - 2 + ! Phi (2*i-1,j) gives d(Phi_i)/dx at quadrature point j + ! Phi (2*i,j) gives d(Phi_i)/dy at quadrature point j + + + + do iq=1,2 ; do jq=1,2 + + uq = CS%u_bdry_val(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & + CS%u_bdry_val(i,j-1) * xquad(iq) * xquad(3-jq) + & + CS%u_bdry_val(i-1,j) * xquad(3-iq) * xquad(jq) + & + CS%u_bdry_val(i,j) * xquad(iq) * xquad(jq) + + vq = CS%v_bdry_val(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & + CS%v_bdry_val(i,j-1) * xquad(iq) * xquad(3-jq) + & + CS%v_bdry_val(i-1,j) * xquad(3-iq) * xquad(jq) + & + CS%v_bdry_val(i,j) * xquad(iq) * xquad(jq) + + ux = CS%u_bdry_val(i-1,j-1) * Phi(1,2*(jq-1)+iq) + & + CS%u_bdry_val(i,j-1) * Phi(3,2*(jq-1)+iq) + & + CS%u_bdry_val(i-1,j) * Phi(5,2*(jq-1)+iq) + & + CS%u_bdry_val(i,j) * Phi(7,2*(jq-1)+iq) + + vx = CS%v_bdry_val(i-1,j-1) * Phi(1,2*(jq-1)+iq) + & + CS%v_bdry_val(i,j-1) * Phi(3,2*(jq-1)+iq) + & + CS%v_bdry_val(i-1,j) * Phi(5,2*(jq-1)+iq) + & + CS%v_bdry_val(i,j) * Phi(7,2*(jq-1)+iq) + + uy = CS%u_bdry_val(i-1,j-1) * Phi(2,2*(jq-1)+iq) + & + CS%u_bdry_val(i,j-1) * Phi(4,2*(jq-1)+iq) + & + CS%u_bdry_val(i-1,j) * Phi(6,2*(jq-1)+iq) + & + CS%u_bdry_val(i,j) * Phi(8,2*(jq-1)+iq) + + vy = CS%v_bdry_val(i-1,j-1) * Phi(2,2*(jq-1)+iq) + & + CS%v_bdry_val(i,j-1) * Phi(4,2*(jq-1)+iq) + & + CS%v_bdry_val(i-1,j) * Phi(6,2*(jq-1)+iq) + & + CS%v_bdry_val(i,j) * Phi(8,2*(jq-1)+iq) + + do iphi=1,2 ; do jphi=1,2 + + if (iq == iphi) then + ilq = 2 + else + ilq = 1 + endif + + if (jq == jphi) then + jlq = 2 + else + jlq = 1 + endif + + if (CS%umask(i-2+iphi,j-2+jphi) == 1) then + + + u_bdry_contr(i-2+iphi,j-2+jphi) = u_bdry_contr(i-2+iphi,j-2+jphi) + & + .25 * dxdyh * nu(i,j) * ( (4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + (uy+vx) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq) ) + + if (float_cond(i,j) == 0) then + u_bdry_contr(i-2+iphi,j-2+jphi) = u_bdry_contr(i-2+iphi,j-2+jphi) + & + .25 * beta(i,j) * dxdyh * uq * xquad(ilq) * xquad(jlq) + endif + + endif + + if (CS%vmask(i-2+iphi,j-2+jphi) == 1) then + + + v_bdry_contr(i-2+iphi,j-2+jphi) = v_bdry_contr(i-2+iphi,j-2+jphi) + & + .25 * dxdyh * nu(i,j) * ( (uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) + + if (float_cond(i,j) == 0) then + v_bdry_contr(i-2+iphi,j-2+jphi) = v_bdry_contr(i-2+iphi,j-2+jphi) + & + .25 * beta(i,j) * dxdyh * vq * xquad(ilq) * xquad(jlq) + endif + + endif + enddo ; enddo + enddo ; enddo + + if (float_cond(i,j) == 1) then + Usubcontr = 0.0 ; Vsubcontr = 0.0 ; basel = G%bathyT(i,j) + Ucell(:,:) = CS%u_bdry_val(i-1:i,j-1:j) ; Vcell(:,:) = CS%v_bdry_val(i-1:i,j-1:j) + Hcell(:,:) = H_node(i-1:i,j-1:j) + call CG_action_subgrid_basal(Phisub, Hcell, Ucell, Vcell, dxdyh, basel, & + dens_ratio, Usubcontr, Vsubcontr) + do iphi=1,2 ; do jphi = 1,2 + if (CS%umask(i-2+iphi,j-2+jphi) == 1) then + u_bdry_contr(i-2+iphi,j-2+jphi) = u_bdry_contr(i-2+iphi,j-2+jphi) + & + Usubcontr(iphi,jphi) * beta(i,j) + endif + if (CS%vmask(i-2+iphi,j-2+jphi) == 1) then + v_bdry_contr(i-2+iphi,j-2+jphi) = v_bdry_contr(i-2+iphi,j-2+jphi) + & + Vsubcontr(iphi,jphi) * beta(i,j) + endif + enddo ; enddo + endif + endif + endif ; enddo ; enddo + +end subroutine apply_boundary_values + +!> Update depth integrated viscosity, based on horizontal strain rates, and also update the +!! nonlinear part of the basal traction. +subroutine calc_shelf_visc(CS, ISS, G, US, u, v) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + type(unit_scale_type), intent(in) :: US !< Pointer to a structure containing unit conversion factors + real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & + intent(inout) :: u !< The zonal ice shelf velocity [m year-1]. + real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & + intent(inout) :: v !< The meridional ice shelf velocity [m year-1]. + +! update DEPTH_INTEGRATED viscosity, based on horizontal strain rates - this is for bilinear FEM solve +! so there is an "upper" and "lower" bilinear viscosity + +! also this subroutine updates the nonlinear part of the basal traction + +! this may be subject to change later... to make it "hybrid" + + integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, iegq, jegq + integer :: giec, gjec, gisc, gjsc, cnt, isc, jsc, iec, jec, is, js + real :: A, n, ux, uy, vx, vy, eps_min, umid, vmid, unorm, C_basal_friction, n_basal_friction, dxh, dyh, dxdyh + + isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec + iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB + isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed + iegq = G%iegB ; jegq = G%jegB + gisc = G%domain%nihalo+1 ; gjsc = G%domain%njhalo+1 + giec = G%domain%niglobal+gisc ; gjec = G%domain%njglobal+gjsc + is = iscq - 1; js = jscq - 1 + + A = CS%A_glen_isothermal ; n = CS%n_glen; eps_min = CS%eps_glen_min + C_basal_friction = CS%C_basal_friction ; n_basal_friction = CS%n_basal_friction + + do j=jsd+1,jed-1 + do i=isd+1,ied-1 + + dxh = G%dxT(i,j) + dyh = G%dyT(i,j) + dxdyh = G%areaT(i,j) + + if (ISS%hmask(i,j) == 1) then + ux = (u(i,j) + u(i,j-1) - u(i-1,j) - u(i-1,j-1)) / (2*dxh) + vx = (v(i,j) + v(i,j-1) - v(i-1,j) - v(i-1,j-1)) / (2*dxh) + uy = (u(i,j) - u(i,j-1) + u(i-1,j) - u(i-1,j-1)) / (2*dyh) + vy = (v(i,j) - v(i,j-1) + v(i-1,j) - v(i-1,j-1)) / (2*dyh) + + CS%ice_visc(i,j) = .5 * A**(-1/n) * & + (ux**2+vy**2+ux*vy+0.25*(uy+vx)**2+eps_min**2) ** ((1-n)/(2*n)) * & + US%Z_to_m*ISS%h_shelf(i,j) + + umid = (u(i,j) + u(i,j-1) + u(i-1,j) + u(i-1,j-1))/4 + vmid = (v(i,j) + v(i,j-1) + v(i-1,j) + v(i-1,j-1))/4 + unorm = sqrt (umid**2+vmid**2+(eps_min*dxh)**2) + CS%taub_beta_eff(i,j) = C_basal_friction * unorm ** (n_basal_friction-1) + endif + enddo + enddo + +end subroutine calc_shelf_visc + +subroutine update_OD_ffrac(CS, G, US, ocean_mass, find_avg) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + type(unit_scale_type), intent(in) :: US !< Pointer to a structure containing unit conversion factors + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: ocean_mass !< The mass per unit area of the ocean [kg m-2]. + logical, intent(in) :: find_avg !< If true, find the average of OD and ffrac, and + !! reset the underlying running sums to 0. + + integer :: isc, iec, jsc, jec, i, j + real :: I_rho_ocean + real :: I_counter + + I_rho_ocean = 1.0 / (US%Z_to_m*CS%density_ocean_avg) + + isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec + + do j=jsc,jec ; do i=isc,iec + CS%OD_rt(i,j) = CS%OD_rt(i,j) + ocean_mass(i,j)*I_rho_ocean + if (ocean_mass(i,j)*I_rho_ocean > CS%thresh_float_col_depth) then + CS%float_frac_rt(i,j) = CS%float_frac_rt(i,j) + 1.0 + endif + enddo ; enddo + CS%OD_rt_counter = CS%OD_rt_counter + 1 + + if (find_avg) then + I_counter = 1.0 / real(CS%OD_rt_counter) + do j=jsc,jec ; do i=isc,iec + CS%float_frac(i,j) = 1.0 - (CS%float_frac_rt(i,j) * I_counter) + CS%OD_av(i,j) = CS%OD_rt(i,j) * I_counter + + CS%OD_rt(i,j) = 0.0 ; CS%float_frac_rt(i,j) = 0.0 + enddo ; enddo + + call pass_var(CS%float_frac, G%domain) + call pass_var(CS%OD_av, G%domain) + endif + +end subroutine update_OD_ffrac + +subroutine update_OD_ffrac_uncoupled(CS, G, h_shelf) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: h_shelf !< the thickness of the ice shelf [Z ~> m]. + + integer :: i, j, iters, isd, ied, jsd, jed + real :: rhoi_rhow, OD + + rhoi_rhow = CS%density_ice / CS%density_ocean_avg + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + do j=jsd,jed + do i=isd,ied + OD = G%bathyT(i,j) - rhoi_rhow * h_shelf(i,j) + if (OD >= 0) then + ! ice thickness does not take up whole ocean column -> floating + CS%OD_av(i,j) = OD + CS%float_frac(i,j) = 0. + else + CS%OD_av(i,j) = 0. + CS%float_frac(i,j) = 1. + endif + enddo + enddo + +end subroutine update_OD_ffrac_uncoupled + +!> This subroutine calculates the gradients of bilinear basis elements that +!! that are centered at the vertices of the cell. values are calculated at +!! points of gaussian quadrature. +subroutine bilinear_shape_functions (X, Y, Phi, area) + real, dimension(4), intent(in) :: X !< The x-positions of the vertices of the quadrilateral. + real, dimension(4), intent(in) :: Y !< The y-positions of the vertices of the quadrilateral. + real, dimension(8,4), intent(inout) :: Phi !< The gradients of bilinear basis elements at Gaussian + !! quadrature points surrounding the cell verticies. + real, intent(out) :: area !< The quadrilateral cell area [m2]. + +! X and Y must be passed in the form + ! 3 - 4 + ! | | + ! 1 - 2 + +! this subroutine calculates the gradients of bilinear basis elements that +! that are centered at the vertices of the cell. values are calculated at +! points of gaussian quadrature. (in 1D: .5 * (1 +/- sqrt(1/3)) for [0,1]) +! (ordered in same way as vertices) +! +! Phi (2*i-1,j) gives d(Phi_i)/dx at quadrature point j +! Phi (2*i,j) gives d(Phi_i)/dy at quadrature point j +! Phi_i is equal to 1 at vertex i, and 0 at vertex k /= i, and bilinear +! +! This should be a one-off; once per nonlinear solve? once per lifetime? +! ... will all cells have the same shape and dimension? + + real, dimension(4) :: xquad, yquad + integer :: node, qpoint, xnode, xq, ynode, yq + real :: a,b,c,d,e,f,xexp,yexp + + xquad(1:3:2) = .5 * (1-sqrt(1./3)) ; yquad(1:2) = .5 * (1-sqrt(1./3)) + xquad(2:4:2) = .5 * (1+sqrt(1./3)) ; yquad(3:4) = .5 * (1+sqrt(1./3)) + + do qpoint=1,4 + + a = -X(1)*(1-yquad(qpoint)) + X(2)*(1-yquad(qpoint)) - X(3)*yquad(qpoint) + X(4)*yquad(qpoint) ! d(x)/d(x*) + b = -Y(1)*(1-yquad(qpoint)) + Y(2)*(1-yquad(qpoint)) - Y(3)*yquad(qpoint) + Y(4)*yquad(qpoint) ! d(y)/d(x*) + c = -X(1)*(1-xquad(qpoint)) - X(2)*(xquad(qpoint)) + X(3)*(1-xquad(qpoint)) + X(4)*(xquad(qpoint)) ! d(x)/d(y*) + d = -Y(1)*(1-xquad(qpoint)) - Y(2)*(xquad(qpoint)) + Y(3)*(1-xquad(qpoint)) + Y(4)*(xquad(qpoint)) ! d(y)/d(y*) + + do node=1,4 + + xnode = 2-mod(node,2) ; ynode = ceiling(REAL(node)/2) + + if (ynode == 1) then + yexp = 1-yquad(qpoint) + else + yexp = yquad(qpoint) + endif + + if (1 == xnode) then + xexp = 1-xquad(qpoint) + else + xexp = xquad(qpoint) + endif + + Phi (2*node-1,qpoint) = ( d * (2 * xnode - 3) * yexp - b * (2 * ynode - 3) * xexp) / (a*d-b*c) + Phi (2*node,qpoint) = ( -c * (2 * xnode - 3) * yexp + a * (2 * ynode - 3) * xexp) / (a*d-b*c) + + enddo + enddo + + area = quad_area(X, Y) + +end subroutine bilinear_shape_functions + + +subroutine bilinear_shape_functions_subgrid(Phisub, nsub) + real, dimension(nsub,nsub,2,2,2,2), & + intent(inout) :: Phisub !< Quadrature structure weights at subgridscale + !! locations for finite element calculations + integer, intent(in) :: nsub !< The nubmer of subgridscale quadrature locations in each direction + + ! this subroutine is a helper for interpolation of floatation condition + ! for the purposes of evaluating the terms \int (u,v) \phi_i dx dy in a cell that is + ! in partial floatation + ! the array Phisub contains the values of \phi_i (where i is a node of the cell) + ! at quad point j + ! i think this general approach may not work for nonrectangular elements... + ! + + ! Phisub(i,j,k,l,q1,q2) + ! i: subgrid index in x-direction + ! j: subgrid index in y-direction + ! k: basis function x-index + ! l: basis function y-index + ! q1: quad point x-index + ! q2: quad point y-index + + ! e.g. k=1,l=1 => node 1 + ! q1=2,q2=1 => quad point 2 + + ! 3 - 4 + ! | | + ! 1 - 2 + + integer :: i, j, k, l, qx, qy, indx, indy + real,dimension(2) :: xquad + real :: x0, y0, x, y, val, fracx + + xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) + fracx = 1.0/real(nsub) + + do j=1,nsub + do i=1,nsub + x0 = (i-1) * fracx ; y0 = (j-1) * fracx + do qx=1,2 + do qy=1,2 + x = x0 + fracx*xquad(qx) + y = y0 + fracx*xquad(qy) + do k=1,2 + do l=1,2 + val = 1.0 + if (k == 1) then + val = val * (1.0-x) + else + val = val * x + endif + if (l == 1) then + val = val * (1.0-y) + else + val = val * y + endif + Phisub(i,j,k,l,qx,qy) = val + enddo + enddo + enddo + enddo + enddo + enddo + +end subroutine bilinear_shape_functions_subgrid + + +subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face_mask) + type(ice_shelf_dyn_CS),intent(in) :: CS !< A pointer to the ice shelf dynamics control structure + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(out) :: umask !< A coded mask indicating the nature of the + !! zonal flow at the corner point + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(out) :: vmask !< A coded mask indicating the nature of the + !! meridional flow at the corner point + real, dimension(SZDIB_(G),SZDJ_(G)), & + intent(out) :: u_face_mask !< A coded mask for velocities at the C-grid u-face + real, dimension(SZDI_(G),SZDJB_(G)), & + intent(out) :: v_face_mask !< A coded mask for velocities at the C-grid v-face + ! sets masks for velocity solve + ! ignores the fact that their might be ice-free cells - this only considers the computational boundary + + ! !!!IMPORTANT!!! relies on thickness mask - assumed that this is called after hmask has been updated & halo-updated + + integer :: i, j, k, iscq, iecq, jscq, jecq, isd, jsd, is, js, iegq, jegq + integer :: giec, gjec, gisc, gjsc, isc, jsc, iec, jec + integer :: i_off, j_off + + isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec + iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB + i_off = G%idg_offset ; j_off = G%jdg_offset + isd = G%isd ; jsd = G%jsd + iegq = G%iegB ; jegq = G%jegB + gisc = G%Domain%nihalo ; gjsc = G%Domain%njhalo + giec = G%Domain%niglobal+gisc ; gjec = G%Domain%njglobal+gjsc + + umask(:,:) = 0 ; vmask(:,:) = 0 + u_face_mask(:,:) = 0 ; v_face_mask(:,:) = 0 + + if (G%symmetric) then + is = isd ; js = jsd + else + is = isd+1 ; js = jsd+1 + endif + + do j=js,G%jed + do i=is,G%ied + + if (hmask(i,j) == 1) then + + umask(i-1:i,j-1:j) = 1. + vmask(i-1:i,j-1:j) = 1. + + do k=0,1 + + select case (int(CS%u_face_mask_bdry(i-1+k,j))) + case (3) + umask(i-1+k,j-1:j)=3. + vmask(i-1+k,j-1:j)=0. + u_face_mask(i-1+k,j)=3. + case (2) + u_face_mask(i-1+k,j)=2. + case (4) + umask(i-1+k,j-1:j)=0. + vmask(i-1+k,j-1:j)=0. + u_face_mask(i-1+k,j)=4. + case (0) + umask(i-1+k,j-1:j)=0. + vmask(i-1+k,j-1:j)=0. + u_face_mask(i-1+k,j)=0. + case (1) ! stress free x-boundary + umask(i-1+k,j-1:j)=0. + case default + end select + enddo + + do k=0,1 + + select case (int(CS%v_face_mask_bdry(i,j-1+k))) + case (3) + vmask(i-1:i,j-1+k)=3. + umask(i-1:i,j-1+k)=0. + v_face_mask(i,j-1+k)=3. + case (2) + v_face_mask(i,j-1+k)=2. + case (4) + umask(i-1:i,j-1+k)=0. + vmask(i-1:i,j-1+k)=0. + v_face_mask(i,j-1+k)=4. + case (0) + umask(i-1:i,j-1+k)=0. + vmask(i-1:i,j-1+k)=0. + u_face_mask(i,j-1+k)=0. + case (1) ! stress free y-boundary + vmask(i-1:i,j-1+k)=0. + case default + end select + enddo + + !if (CS%u_face_mask_bdry(i-1,j) >= 0) then !left boundary + ! u_face_mask(i-1,j) = CS%u_face_mask_bdry(i-1,j) + ! umask(i-1,j-1:j) = 3. + ! vmask(i-1,j-1:j) = 0. + !endif + + !if (j_off+j == gjsc+1) then !bot boundary + ! v_face_mask(i,j-1) = 0. + ! umask (i-1:i,j-1) = 0. + ! vmask (i-1:i,j-1) = 0. + !elseif (j_off+j == gjec) then !top boundary + ! v_face_mask(i,j) = 0. + ! umask (i-1:i,j) = 0. + ! vmask (i-1:i,j) = 0. + !endif + + if (i < G%ied) then + if ((hmask(i+1,j) == 0) & + .OR. (hmask(i+1,j) == 2)) then + !right boundary or adjacent to unfilled cell + u_face_mask(i,j) = 2. + endif + endif + + if (i > G%isd) then + if ((hmask(i-1,j) == 0) .OR. (hmask(i-1,j) == 2)) then + !adjacent to unfilled cell + u_face_mask(i-1,j) = 2. + endif + endif + + if (j > G%jsd) then + if ((hmask(i,j-1) == 0) .OR. (hmask(i,j-1) == 2)) then + !adjacent to unfilled cell + v_face_mask(i,j-1) = 2. + endif + endif + + if (j < G%jed) then + if ((hmask(i,j+1) == 0) .OR. (hmask(i,j+1) == 2)) then + !adjacent to unfilled cell + v_face_mask(i,j) = 2. + endif + endif + + + endif + + enddo + enddo + + ! note: if the grid is nonsymmetric, there is a part that will not be transferred with a halo update + ! so this subroutine must update its own symmetric part of the halo + + call pass_vector(u_face_mask, v_face_mask, G%domain, TO_ALL, CGRID_NE) + call pass_vector(umask, vmask, G%domain, TO_ALL, BGRID_NE) + +end subroutine update_velocity_masks + +!> Interpolate the ice shelf thickness from tracer point to nodal points, +!! subject to a mask. +subroutine interpolate_H_to_B(G, h_shelf, hmask, H_node) + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: h_shelf !< The ice shelf thickness at tracer points [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: H_node !< The ice shelf thickness at nodal (corner) + !! points [Z ~> m]. + + integer :: i, j, isc, iec, jsc, jec, num_h, k, l + real :: summ + + isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec + + H_node(:,:) = 0.0 + + ! H_node is node-centered; average over all cells that share that node + ! if no (active) cells share the node then its value there is irrelevant + + do j=jsc-1,jec + do i=isc-1,iec + summ = 0.0 + num_h = 0 + do k=0,1 + do l=0,1 + if (hmask(i+k,j+l) == 1.0) then + summ = summ + h_shelf(i+k,j+l) + num_h = num_h + 1 + endif + enddo + enddo + if (num_h > 0) then + H_node(i,j) = summ / num_h + endif + enddo + enddo + + call pass_var(H_node, G%domain, position=CORNER) + +end subroutine interpolate_H_to_B + +!> Deallocates all memory associated with the ice shelf dynamics module +subroutine ice_shelf_dyn_end(CS) + type(ice_shelf_dyn_CS), pointer :: CS !< A pointer to the ice shelf dynamics control structure + + if (.not.associated(CS)) return + + deallocate(CS%u_shelf, CS%v_shelf) + deallocate(CS%t_shelf, CS%tmask) + deallocate(CS%u_bdry_val, CS%v_bdry_val, CS%t_bdry_val) + deallocate(CS%u_face_mask, CS%v_face_mask) + deallocate(CS%umask, CS%vmask) + + deallocate(CS%ice_visc, CS%taub_beta_eff) + deallocate(CS%OD_rt, CS%OD_av) + deallocate(CS%float_frac, CS%float_frac_rt) + + deallocate(CS) + +end subroutine ice_shelf_dyn_end + + +!> This subroutine updates the vertically averaged ice shelf temperature. +subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + type(unit_scale_type), intent(in) :: US !< Pointer to a structure containing unit conversion factors + real, intent(in) :: time_step !< The time step for this update [s]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: melt_rate !< basal melt rate [kg m-2 s-1] + type(time_type), intent(in) :: Time !< The current model time + +! 5/23/12 OVS +! This subroutine takes the velocity (on the Bgrid) and timesteps +! (HT)_t = - div (uHT) + (adot Tsurf -bdot Tbot) once and then calculates T=HT/H +! +! The flux overflows are included here. That is because they will be used to advect 3D scalars +! into partial cells + + ! + ! flux_enter: this is to capture flow into partially covered cells; it gives the mass flux into a given + ! cell across its boundaries. + ! ###Perhaps flux_enter should be changed into u-face and v-face + ! ###fluxes, which can then be used in halo updates, etc. + ! + ! from left neighbor: flux_enter(:,:,1) + ! from right neighbor: flux_enter(:,:,2) + ! from bottom neighbor: flux_enter(:,:,3) + ! from top neighbor: flux_enter(:,:,4) + ! + ! THESE ARE NOT CONSISTENT ==> FIND OUT WHAT YOU IMPLEMENTED + + ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary + ! + ! o--- (4) ---o + ! | | + ! (1) (2) + ! | | + ! o--- (3) ---o + ! + + real, dimension(SZDI_(G),SZDJ_(G)) :: th_after_uflux, th_after_vflux, TH + real, dimension(SZDI_(G),SZDJ_(G),4) :: flux_enter + integer :: isd, ied, jsd, jed, i, j, isc, iec, jsc, jec + real :: rho, spy, t_bd, Tsurf, adot + + rho = CS%density_ice + spy = 365 * 86400 ! seconds per year; is there a global constant for this? No - it is dependent upon a calendar. + + adot = 0.1*US%m_to_Z/spy ! for now adot and Tsurf are defined here adot=surf acc 0.1m/yr, Tsurf=-20oC, vary them later + Tsurf = -20.0 + + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec + flux_enter(:,:,:) = 0.0 + + th_after_uflux(:,:) = 0.0 + th_after_vflux(:,:) = 0.0 + + do j=jsd,jed + do i=isd,ied + t_bd = CS%t_bdry_val(i,j) +! if (ISS%hmask(i,j) > 1) then + if ((ISS%hmask(i,j) == 3) .or. (ISS%hmask(i,j) == -2)) then + CS%t_shelf(i,j) = CS%t_bdry_val(i,j) + endif + enddo + enddo + + do j=jsd,jed + do i=isd,ied + TH(i,j) = CS%t_shelf(i,j)*ISS%h_shelf(i,j) + enddo + enddo + + +! call enable_averaging(time_step,Time,CS%diag) +! call pass_var(h_after_uflux, G%domain) +! call pass_var(h_after_vflux, G%domain) +! if (CS%id_h_after_uflux > 0) call post_data(CS%id_h_after_uflux, h_after_uflux, CS%diag) +! if (CS%id_h_after_vflux > 0) call post_data(CS%id_h_after_vflux, h_after_vflux, CS%diag) +! call disable_averaging(CS%diag) + + call ice_shelf_advect_temp_x(CS, G, time_step/spy, ISS%hmask, TH, th_after_uflux, flux_enter) + call ice_shelf_advect_temp_y(CS, G, time_step/spy, ISS%hmask, th_after_uflux, th_after_vflux, flux_enter) + + do j=jsd,jed + do i=isd,ied +! if (ISS%hmask(i,j) == 1) then + if (ISS%h_shelf(i,j) > 0.0) then + CS%t_shelf(i,j) = th_after_vflux(i,j)/(ISS%h_shelf(i,j)) + else + CS%t_shelf(i,j) = -10.0 + endif + enddo + enddo + + do j=jsd,jed + do i=isd,ied + t_bd = CS%t_bdry_val(i,j) +! if (ISS%hmask(i,j) > 1) then + if ((ISS%hmask(i,j) == 3) .or. (ISS%hmask(i,j) == -2)) then + CS%t_shelf(i,j) = t_bd +! CS%t_shelf(i,j) = -15.0 + endif + enddo + enddo + + do j=jsc,jec + do i=isc,iec + if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2)) then + if (ISS%h_shelf(i,j) > 0.0) then +! CS%t_shelf(i,j) = CS%t_shelf(i,j) + & +! time_step*(adot*Tsurf - US%m_to_Z*melt_rate(i,j)*ISS%tfreeze(i,j))/(ISS%h_shelf(i,j)) + CS%t_shelf(i,j) = CS%t_shelf(i,j) + & + time_step*(adot*Tsurf - (3.0*US%m_to_Z/spy)*ISS%tfreeze(i,j)) / ISS%h_shelf(i,j) + else + ! the ice is about to melt away + ! in this case set thickness, area, and mask to zero + ! NOTE: not mass conservative + ! should maybe scale salt & heat flux for this cell + + CS%t_shelf(i,j) = -10.0 + CS%tmask(i,j) = 0.0 + endif + endif + enddo + enddo + + call pass_var(CS%t_shelf, G%domain) + call pass_var(CS%tmask, G%domain) + + if (CS%DEBUG) then + call hchksum(CS%t_shelf, "temp after front", G%HI, haloshift=3) + endif + +end subroutine ice_shelf_temp + + +subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, flux_enter) + type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + real, intent(in) :: time_step !< The time step for this update [s]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: h0 !< The initial ice shelf thicknesses [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_after_uflux !< The ice shelf thicknesses after + !! the zonal mass fluxes [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G),4), & + intent(inout) :: flux_enter !< The integrated temperature flux into + !! the cell through the 4 cell boundaries [degC Z m2 ~> degC m3] + + ! use will be made of ISS%hmask here - its value at the boundary will be zero, just like uncovered cells + + ! if there is an input bdry condition, the thickness there will be set in initialization + + ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary + ! + ! from left neighbor: flux_enter(:,:,1) + ! from right neighbor: flux_enter(:,:,2) + ! from bottom neighbor: flux_enter(:,:,3) + ! from top neighbor: flux_enter(:,:,4) + ! + ! o--- (4) ---o + ! | | + ! (1) (2) + ! | | + ! o--- (3) ---o + ! + + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, gjed, gied + integer :: i_off, j_off + logical :: at_east_bdry, at_west_bdry, one_off_west_bdry, one_off_east_bdry + real, dimension(-2:2) :: stencil + real :: u_face, & ! positive if out + flux_diff_cell, phi, dxh, dyh, dxdyh + + character (len=1) :: debug_str + + + is = G%isc-2 ; ie = G%iec+2 ; js = G%jsc ; je = G%jec ; isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + i_off = G%idg_offset ; j_off = G%jdg_offset + + do j=jsd+1,jed-1 + if (((j+j_off) <= G%domain%njglobal+G%domain%njhalo) .AND. & + ((j+j_off) >= G%domain%njhalo+1)) then ! based on mehmet's code - only if btw north & south boundaries + + stencil(:) = -1 +! if (i+i_off == G%domain%nihalo+G%domain%nihalo) + do i=is,ie + + if (((i+i_off) <= G%domain%niglobal+G%domain%nihalo) .AND. & + ((i+i_off) >= G%domain%nihalo+1)) then + + if (i+i_off == G%domain%nihalo+1) then + at_west_bdry=.true. + else + at_west_bdry=.false. + endif + + if (i+i_off == G%domain%niglobal+G%domain%nihalo) then + at_east_bdry=.true. + else + at_east_bdry=.false. + endif + + if (hmask(i,j) == 1) then + + dxh = G%dxT(i,j) ; dyh = G%dyT(i,j) ; dxdyh = G%areaT(i,j) + + h_after_uflux(i,j) = h0(i,j) + + stencil(:) = h0(i-2:i+2,j) ! fine as long has nx_halo >= 2 + + flux_diff_cell = 0 + + ! 1ST DO LEFT FACE + + if (CS%u_face_mask(i-1,j) == 4.) then + + flux_diff_cell = flux_diff_cell + dyh * time_step * CS%u_flux_bdry_val(i-1,j) * & + CS%t_bdry_val(i-1,j) / dxdyh + else + + ! get u-velocity at center of left face + u_face = 0.5 * (CS%u_shelf(i-1,j-1) + CS%u_shelf(i-1,j)) + + if (u_face > 0) then !flux is into cell - we need info from h(i-2), h(i-1) if available + + ! i may not cover all the cases.. but i cover the realistic ones + + if (at_west_bdry .AND. (hmask(i-1,j) == 3)) then ! at western bdry but there is a + ! thickness bdry condition, and the stencil contains it + flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step * stencil(-1) / dxdyh + + elseif (hmask(i-1,j) * hmask(i-2,j) == 1) then ! h(i-2) and h(i-1) are valid + phi = slope_limiter(stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) + flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh* time_step / dxdyh * & + (stencil(-1) - phi * (stencil(-1)-stencil(0))/2) + + else ! h(i-1) is valid + ! (o.w. flux would most likely be out of cell) + ! but h(i-2) is not + + flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step / dxdyh * stencil(-1) + + endif + + elseif (u_face < 0) then !flux is out of cell - we need info from h(i-1), h(i+1) if available + if (hmask(i-1,j) * hmask(i+1,j) == 1) then ! h(i-1) and h(i+1) are both valid + phi = slope_limiter(stencil(0)-stencil(1), stencil(-1)-stencil(0)) + flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * & + (stencil(0) - phi * (stencil(0)-stencil(-1))/2) + + else + flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * stencil(0) + + if ((hmask(i-1,j) == 0) .OR. (hmask(i-1,j) == 2)) then + flux_enter(i-1,j,2) = ABS(u_face) * dyh * time_step * stencil(0) + endif + endif + endif + endif + + ! NEXT DO RIGHT FACE + + ! get u-velocity at center of right face + + if (CS%u_face_mask(i+1,j) == 4.) then + + flux_diff_cell = flux_diff_cell + dyh * time_step * CS%u_flux_bdry_val(i+1,j) *& + CS%t_bdry_val(i+1,j)/ dxdyh + else + + u_face = 0.5 * (CS%u_shelf(i,j-1) + CS%u_shelf(i,j)) + + if (u_face < 0) then !flux is into cell - we need info from h(i+2), h(i+1) if available + + if (at_east_bdry .AND. (hmask(i+1,j) == 3)) then ! at eastern bdry but there is a + ! thickness bdry condition, and the stencil contains it + + flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step * stencil(1) / dxdyh + + elseif (hmask(i+1,j) * hmask(i+2,j) == 1) then ! h(i+2) and h(i+1) are valid + + phi = slope_limiter(stencil(1)-stencil(2), stencil(0)-stencil(1)) + flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step / dxdyh * & + (stencil(1) - phi * (stencil(1)-stencil(0))/2) + + else ! h(i+1) is valid + ! (o.w. flux would most likely be out of cell) + ! but h(i+2) is not + + flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step / dxdyh * stencil(1) + + endif + + elseif (u_face > 0) then !flux is out of cell - we need info from h(i-1), h(i+1) if available + + if (hmask(i-1,j) * hmask(i+1,j) == 1) then ! h(i-1) and h(i+1) are both valid + + phi = slope_limiter(stencil(0)-stencil(-1), stencil(1)-stencil(0)) + flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * & + (stencil(0) - phi * (stencil(0)-stencil(1))/2) + + else ! h(i+1) is valid + ! (o.w. flux would most likely be out of cell) + ! but h(i+2) is not + + flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * stencil(0) + + if ((hmask(i+1,j) == 0) .OR. (hmask(i+1,j) == 2)) then + + flux_enter(i+1,j,1) = ABS(u_face) * dyh * time_step * stencil(0) + endif + + endif + + endif + + h_after_uflux(i,j) = h_after_uflux(i,j) + flux_diff_cell + + endif + + elseif ((hmask(i,j) == 0) .OR. (hmask(i,j) == 2)) then + + if (at_west_bdry .AND. (hmask(i-1,j) == 3)) then + u_face = 0.5 * (CS%u_shelf(i-1,j-1) + CS%u_shelf(i-1,j)) + flux_enter(i,j,1) = ABS(u_face) * G%dyT(i,j) * time_step * CS%t_bdry_val(i-1,j)* & + CS%thickness_bdry_val(i+1,j) + elseif (CS%u_face_mask(i-1,j) == 4.) then + flux_enter(i,j,1) = G%dyT(i,j) * time_step * CS%u_flux_bdry_val(i-1,j)*CS%t_bdry_val(i-1,j) + endif + + if (at_east_bdry .AND. (hmask(i+1,j) == 3)) then + u_face = 0.5 * (CS%u_shelf(i,j-1) + CS%u_shelf(i,j)) + flux_enter(i,j,2) = ABS(u_face) * G%dyT(i,j) * time_step * CS%t_bdry_val(i+1,j)* & + CS%thickness_bdry_val(i+1,j) + elseif (CS%u_face_mask(i+1,j) == 4.) then + flux_enter(i,j,2) = G%dyT(i,j) * time_step * CS%u_flux_bdry_val(i+1,j) * CS%t_bdry_val(i+1,j) + endif + +! if ((i == is) .AND. (hmask(i,j) == 0) .AND. (hmask(i-1,j) == 1)) then + ! this is solely for the purposes of keeping the mask consistent while advancing + ! the front without having to call pass_var - if cell is empty and cell to left + ! is ice-covered then this cell will become partly covered +! hmask(i,j) = 2 +! elseif ((i == ie) .AND. (hmask(i,j) == 0) .AND. (hmask(i+1,j) == 1)) then + ! this is solely for the purposes of keeping the mask consistent while advancing + ! the front without having to call pass_var - if cell is empty and cell to left + ! is ice-covered then this cell will become partly covered +! hmask(i,j) = 2 + +! endif + + endif + + endif + + enddo ! i loop + + endif + + enddo ! j loop + +end subroutine ice_shelf_advect_temp_x + +subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_after_vflux, flux_enter) + type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, intent(in) :: time_step !< The time step for this update [s]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: h_after_uflux !< The ice shelf thicknesses after + !! the zonal mass fluxes [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_after_vflux !< The ice shelf thicknesses after + !! the meridional mass fluxes [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G),4), & + intent(inout) :: flux_enter !< The integrated temperature flux into + !! the cell through the 4 cell boundaries [degC Z m2 ~> degC m3] + + ! use will be made of ISS%hmask here - its value at the boundary will be zero, just like uncovered cells + + ! if there is an input bdry condition, the thickness there will be set in initialization + + ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary + ! + ! from left neighbor: flux_enter(:,:,1) + ! from right neighbor: flux_enter(:,:,2) + ! from bottom neighbor: flux_enter(:,:,3) + ! from top neighbor: flux_enter(:,:,4) + ! + ! o--- (4) ---o + ! | | + ! (1) (2) + ! | | + ! o--- (3) ---o + ! + + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, gjed, gied + integer :: i_off, j_off + logical :: at_north_bdry, at_south_bdry, one_off_west_bdry, one_off_east_bdry + real, dimension(-2:2) :: stencil + real :: v_face, & ! positive if out + flux_diff_cell, phi, dxh, dyh, dxdyh + character(len=1) :: debug_str + + is = G%isc ; ie = G%iec ; js = G%jsc-1 ; je = G%jec+1 ; isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + i_off = G%idg_offset ; j_off = G%jdg_offset + + do i=isd+2,ied-2 + if (((i+i_off) <= G%domain%niglobal+G%domain%nihalo) .AND. & + ((i+i_off) >= G%domain%nihalo+1)) then ! based on mehmet's code - only if btw east & west boundaries + + stencil(:) = -1 + + do j=js,je + + if (((j+j_off) <= G%domain%njglobal+G%domain%njhalo) .AND. & + ((j+j_off) >= G%domain%njhalo+1)) then + + if (j+j_off == G%domain%njhalo+1) then + at_south_bdry=.true. + else + at_south_bdry=.false. + endif + if (j+j_off == G%domain%njglobal+G%domain%njhalo) then + at_north_bdry=.true. + else + at_north_bdry=.false. + endif + + if (hmask(i,j) == 1) then + dxh = G%dxT(i,j) ; dyh = G%dyT(i,j) ; dxdyh = G%areaT(i,j) + h_after_vflux(i,j) = h_after_uflux(i,j) + + stencil(:) = h_after_uflux(i,j-2:j+2) ! fine as long has ny_halo >= 2 + flux_diff_cell = 0 + + ! 1ST DO south FACE + + if (CS%v_face_mask(i,j-1) == 4.) then + + flux_diff_cell = flux_diff_cell + dxh * time_step * CS%v_flux_bdry_val(i,j-1) * & + CS%t_bdry_val(i,j-1)/ dxdyh + else + + ! get u-velocity at center of left face + v_face = 0.5 * (CS%v_shelf(i-1,j-1) + CS%v_shelf(i,j-1)) + + if (v_face > 0) then !flux is into cell - we need info from h(j-2), h(j-1) if available + + ! i may not cover all the cases.. but i cover the realistic ones + + if (at_south_bdry .AND. (hmask(i,j-1) == 3)) then ! at western bdry but there is a + ! thickness bdry condition, and the stencil contains it + flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step * stencil(-1) / dxdyh + + elseif (hmask(i,j-1) * hmask(i,j-2) == 1) then ! h(j-2) and h(j-1) are valid + + phi = slope_limiter(stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) + flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * & + (stencil(-1) - phi * (stencil(-1)-stencil(0))/2) + + else ! h(j-1) is valid + ! (o.w. flux would most likely be out of cell) + ! but h(j-2) is not + flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * stencil(-1) + endif + + elseif (v_face < 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available + + if (hmask(i,j-1) * hmask(i,j+1) == 1) then ! h(j-1) and h(j+1) are both valid + phi = slope_limiter(stencil(0)-stencil(1), stencil(-1)-stencil(0)) + flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * & + (stencil(0) - phi * (stencil(0)-stencil(-1))/2) + else + flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * stencil(0) + + if ((hmask(i,j-1) == 0) .OR. (hmask(i,j-1) == 2)) then + flux_enter(i,j-1,4) = ABS(v_face) * dyh * time_step * stencil(0) + endif + + endif + + endif + + endif + + ! NEXT DO north FACE + + if (CS%v_face_mask(i,j+1) == 4.) then + + flux_diff_cell = flux_diff_cell + dxh * time_step * CS%v_flux_bdry_val(i,j+1) *& + CS%t_bdry_val(i,j+1)/ dxdyh + else + + ! get u-velocity at center of right face + v_face = 0.5 * (CS%v_shelf(i-1,j) + CS%v_shelf(i,j)) + + if (v_face < 0) then !flux is into cell - we need info from h(j+2), h(j+1) if available + + if (at_north_bdry .AND. (hmask(i,j+1) == 3)) then ! at eastern bdry but there is a + ! thickness bdry condition, and the stencil contains it + flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step * stencil(1) / dxdyh + elseif (hmask(i,j+1) * hmask(i,j+2) == 1) then ! h(j+2) and h(j+1) are valid + phi = slope_limiter (stencil(1)-stencil(2), stencil(0)-stencil(1)) + flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * & + (stencil(1) - phi * (stencil(1)-stencil(0))/2) + else ! h(j+1) is valid + ! (o.w. flux would most likely be out of cell) + ! but h(j+2) is not + flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * stencil(1) + endif + + elseif (v_face > 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available + + if (hmask(i,j-1) * hmask(i,j+1) == 1) then ! h(j-1) and h(j+1) are both valid + phi = slope_limiter (stencil(0)-stencil(-1), stencil(1)-stencil(0)) + flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * & + (stencil(0) - phi * (stencil(0)-stencil(1))/2) + else ! h(j+1) is valid + ! (o.w. flux would most likely be out of cell) + ! but h(j+2) is not + flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * stencil(0) + if ((hmask(i,j+1) == 0) .OR. (hmask(i,j+1) == 2)) then + flux_enter(i,j+1,3) = ABS(v_face) * dxh * time_step * stencil(0) + endif + endif + + endif + + endif + + h_after_vflux(i,j) = h_after_vflux(i,j) + flux_diff_cell + + elseif ((hmask(i,j) == 0) .OR. (hmask(i,j) == 2)) then + + if (at_south_bdry .AND. (hmask(i,j-1) == 3)) then + v_face = 0.5 * (CS%v_shelf(i-1,j-1) + CS%v_shelf(i,j-1)) + flux_enter(i,j,3) = ABS(v_face) * G%dxT(i,j) * time_step * CS%t_bdry_val(i,j-1)* & + CS%thickness_bdry_val(i,j-1) + elseif (CS%v_face_mask(i,j-1) == 4.) then + flux_enter(i,j,3) = G%dxT(i,j) * time_step * CS%v_flux_bdry_val(i,j-1)*CS%t_bdry_val(i,j-1) + endif + + if (at_north_bdry .AND. (hmask(i,j+1) == 3)) then + v_face = 0.5 * (CS%v_shelf(i-1,j) + CS%v_shelf(i,j)) + flux_enter(i,j,4) = ABS(v_face) * G%dxT(i,j) * time_step * CS%t_bdry_val(i,j+1)* & + CS%thickness_bdry_val(i,j+1) + elseif (CS%v_face_mask(i,j+1) == 4.) then + flux_enter(i,j,4) = G%dxT(i,j) * time_step * CS%v_flux_bdry_val(i,j+1)*CS%t_bdry_val(i,j+1) + endif + +! if ((j == js) .AND. (hmask(i,j) == 0) .AND. (hmask(i,j-1) == 1)) then + ! this is solely for the purposes of keeping the mask consistent while advancing + ! the front without having to call pass_var - if cell is empty and cell to left + ! is ice-covered then this cell will become partly covered + ! hmask(i,j) = 2 + ! elseif ((j == je) .AND. (hmask(i,j) == 0) .AND. (hmask(i,j+1) == 1)) then + ! this is solely for the purposes of keeping the mask consistent while advancing the + ! front without having to call pass_var - if cell is empty and cell to left is + ! ice-covered then this cell will become partly covered +! hmask(i,j) = 2 +! endif + + endif + endif + enddo ! j loop + endif + enddo ! i loop + +end subroutine ice_shelf_advect_temp_y + +end module MOM_ice_shelf_dynamics diff --git a/src/ice_shelf/MOM_ice_shelf_initialize.F90 b/src/ice_shelf/MOM_ice_shelf_initialize.F90 index bc12e77679..945b634e91 100644 --- a/src/ice_shelf/MOM_ice_shelf_initialize.F90 +++ b/src/ice_shelf/MOM_ice_shelf_initialize.F90 @@ -1,3 +1,4 @@ +!> Initialize ice shelf variables module MOM_ice_shelf_initialize ! This file is part of MOM6. See LICENSE.md for the license. @@ -6,37 +7,37 @@ module MOM_ice_shelf_initialize use MOM_file_parser, only : get_param, read_param, log_param, param_file_type use MOM_io, only: MOM_read_data, file_exists, slasher use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe +use MOM_unit_scaling, only : unit_scale_type use user_shelf_init, only: USER_init_ice_thickness implicit none ; private #include -#ifdef SYMMETRIC_LAND_ICE -# define GRID_SYM_ .true. -# define NIMEMQ_IS_ NIMEMQS_ -# define NJMEMQ_IS_ NJMEMQS_ -# define ISUMSTART_INT_ CS%grid%iscq+1 -# define JSUMSTART_INT_ CS%grid%jscq+1 -#else -# define GRID_SYM_ .false. -# define NIMEMQ_IS_ NIMEMQ_ -# define NJMEMQ_IS_ NJMEMQ_ -# define ISUMSTART_INT_ CS%grid%iscq -# define JSUMSTART_INT_ CS%grid%jscq -#endif - !MJHpublic initialize_ice_shelf_boundary, initialize_ice_thickness public initialize_ice_thickness -contains - -subroutine initialize_ice_thickness (h_shelf, area_shelf_h, hmask, G, PF) +! 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. - real, intent(inout), dimension(:,:) :: h_shelf, area_shelf_h, hmask - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(param_file_type), intent(in) :: PF +contains +!> Initialize ice shelf thickness +subroutine initialize_ice_thickness(h_shelf, area_shelf_h, hmask, G, US, PF) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_shelf !< The ice shelf thickness [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf [m2]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters + + integer :: i, j character(len=40) :: mdl = "initialize_ice_thickness" ! This subroutine's name. character(len=200) :: config @@ -46,26 +47,32 @@ subroutine initialize_ice_thickness (h_shelf, area_shelf_h, hmask, G, PF) fail_if_missing=.true.) select case ( trim(config) ) - case ("CHANNEL"); call initialize_ice_thickness_channel (h_shelf, area_shelf_h, hmask, G, PF) - case ("FILE"); call initialize_ice_thickness_from_file (h_shelf, area_shelf_h, hmask, G, PF) - case ("USER"); call USER_init_ice_thickness (h_shelf, area_shelf_h, hmask, G, PF) + case ("CHANNEL"); call initialize_ice_thickness_channel (h_shelf, area_shelf_h, hmask, G, US, PF) + case ("FILE"); call initialize_ice_thickness_from_file (h_shelf, area_shelf_h, hmask, G, US, PF) + case ("USER"); call USER_init_ice_thickness (h_shelf, area_shelf_h, hmask, G, US, PF) case default ; call MOM_error(FATAL,"MOM_initialize: "// & "Unrecognized ice profile setup "//trim(config)) end select end subroutine initialize_ice_thickness - -subroutine initialize_ice_thickness_from_file (h_shelf, area_shelf_h, hmask, G, PF) - - real, intent(inout), dimension(:,:) :: h_shelf, area_shelf_h, hmask - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(param_file_type), intent(in) :: PF +!> Initialize ice shelf thickness from file +subroutine initialize_ice_thickness_from_file(h_shelf, area_shelf_h, hmask, G, US, PF) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_shelf !< The ice shelf thickness [m]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf [m2]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters ! This subroutine reads ice thickness and area from a file and puts it into ! h_shelf and area_shelf_h in m (and dimensionless) and updates hmask character(len=200) :: filename,thickness_file,inputdir ! Strings for file/path - character(len=200) :: thickness_varname, area_varname! Variable name in file + character(len=200) :: thickness_varname, area_varname ! Variable name in file character(len=40) :: mdl = "initialize_ice_thickness_from_file" ! This subroutine's name. integer :: i, j, isc, jsc, iec, jec real :: len_sidestress, mask, udh @@ -93,7 +100,7 @@ subroutine initialize_ice_thickness_from_file (h_shelf, area_shelf_h, hmask, G, if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & " initialize_topography_from_file: Unable to open "//trim(filename)) - call MOM_read_data(filename,trim(thickness_varname),h_shelf,G%Domain) + call MOM_read_data(filename, trim(thickness_varname), h_shelf, G%Domain, scale=US%m_to_Z) call MOM_read_data(filename,trim(area_varname),area_shelf_h,G%Domain) ! call get_param(PF, mdl, "ICE_BOUNDARY_CONFIG", config, & @@ -108,10 +115,10 @@ subroutine initialize_ice_thickness_from_file (h_shelf, area_shelf_h, hmask, G, ! taper ice shelf in area where there is no sidestress - ! but do not interfere with hmask - if ((G%geoLonCv(i,j) .gt. len_sidestress).and. & - (len_sidestress .gt. 0.)) then - udh = exp (-(G%geoLonCv(i,j)-len_sidestress)/5.0) * h_shelf(i,j) - if (udh .le. 25.0) then + if ((G%geoLonCv(i,j) > len_sidestress).and. & + (len_sidestress > 0.)) then + udh = exp(-(G%geoLonCv(i,j)-len_sidestress)/5.0) * h_shelf(i,j) + if (udh <= 25.0) then h_shelf(i,j) = 0.0 area_shelf_h (i,j) = 0.0 else @@ -121,11 +128,11 @@ subroutine initialize_ice_thickness_from_file (h_shelf, area_shelf_h, hmask, G, ! update thickness mask - if (area_shelf_h (i,j) .ge. G%areaT(i,j)) then + if (area_shelf_h (i,j) >= G%areaT(i,j)) then hmask(i,j) = 1. - elseif (area_shelf_h (i,j) .eq. 0.0) then + elseif (area_shelf_h (i,j) == 0.0) then hmask(i,j) = 0. - elseif ((area_shelf_h(i,j) .gt. 0) .and. (area_shelf_h(i,j) .le. G%areaT(i,j))) then + elseif ((area_shelf_h(i,j) > 0) .and. (area_shelf_h(i,j) <= G%areaT(i,j))) then hmask(i,j) = 2. else call MOM_error(FATAL,mdl// " AREA IN CELL OUT OF RANGE") @@ -136,12 +143,18 @@ subroutine initialize_ice_thickness_from_file (h_shelf, area_shelf_h, hmask, G, end subroutine initialize_ice_thickness_from_file - -subroutine initialize_ice_thickness_channel (h_shelf, area_shelf_h, hmask, G, PF) - - real, intent(inout), dimension(:,:) :: h_shelf, area_shelf_h, hmask - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(param_file_type), intent(in) :: PF +!> Initialize ice shelf thickness for a channel configuration +subroutine initialize_ice_thickness_channel(h_shelf, area_shelf_h, hmask, G, US, PF) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_shelf !< The ice shelf thickness [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf [m2]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters character(len=40) :: mdl = "initialize_ice_shelf_thickness_channel" ! This subroutine's name. real :: max_draft, min_draft, flat_shelf_width, c1, slope_pos @@ -157,26 +170,33 @@ subroutine initialize_ice_thickness_channel (h_shelf, area_shelf_h, hmask, G, PF call MOM_mesg(mdl//": setting thickness") call get_param(PF, mdl, "SHELF_MAX_DRAFT", max_draft, & - units="m", default=1.0) + units="m", default=1.0, scale=US%m_to_Z) call get_param(PF, mdl, "SHELF_MIN_DRAFT", min_draft, & - units="m", default=1.0) + units="m", default=1.0, scale=US%m_to_Z) call get_param(PF, mdl, "FLAT_SHELF_WIDTH", flat_shelf_width, & units="axis_units", default=0.0) call get_param(PF, mdl, "SHELF_SLOPE_SCALE", shelf_slope_scale, & units="axis_units", default=0.0) 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"//& +! "parameters from vertical units of m to kg m-2.", & +! units="kg m-3", default=1035.0, scale=US%Z_to_m) slope_pos = edge_pos - flat_shelf_width c1 = 0.0 ; if (shelf_slope_scale > 0.0) c1 = 1.0 / shelf_slope_scale + do j=G%jsd,G%jed if (((j+j_off) <= jedg) .AND. ((j+j_off) >= nyh+1)) then do i=G%isc,G%iec - if ((j.ge.jsc) .and. (j.le.jec)) then + if ((j >= jsc) .and. (j <= jec)) then if (G%geoLonCu(i-1,j) >= edge_pos) then ! Everything past the edge is open ocean. @@ -195,7 +215,7 @@ subroutine initialize_ice_thickness_channel (h_shelf, area_shelf_h, hmask, G, PF endif if (G%geoLonT(i,j) > slope_pos) then - h_shelf (i,j) = min_draft + h_shelf(i,j) = min_draft ! mass_shelf(i,j) = Rho_ocean * min_draft else ! mass_shelf(i,j) = Rho_ocean * (min_draft + & @@ -209,7 +229,7 @@ subroutine initialize_ice_thickness_channel (h_shelf, area_shelf_h, hmask, G, PF endif endif - if ((i+G%idg_offset) .eq. G%domain%nihalo+1) then + if ((i+G%idg_offset) == G%domain%nihalo+1) then hmask(i-1,j) = 3.0 endif @@ -218,22 +238,34 @@ subroutine initialize_ice_thickness_channel (h_shelf, area_shelf_h, hmask, G, PF end subroutine initialize_ice_thickness_channel -!BEGIN MJH subroutine initialize_ice_shelf_boundary ( & -! u_face_mask_boundary, & -! v_face_mask_boundary, & -! u_flux_boundary_values, & -! v_flux_boundary_values, & -! u_boundary_values, & -! v_boundary_values, & -! h_boundary_values, & -! hmask, G, PF) - -! type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure -! real, intent(inout), dimension(SZIB_(G),SZJ_(G)) :: u_face_mask_boundary, u_flux_boundary_values -! real, intent(inout), dimension(SZI_(G),SZJB_(G)) :: v_face_mask_boundary, v_flux_boundary_values -! real, intent(inout), dimension(SZIB_(G),SZJB_(G)) :: u_boundary_values, v_boundary_values -! real, intent(inout), dimension(:,:) :: hmask, h_boundary_values -! type(param_file_type), intent(in) :: PF +!BEGIN MJH +! subroutine initialize_ice_shelf_boundary(u_face_mask_bdry, v_face_mask_bdry, & +! u_flux_bdry_val, v_flux_bdry_val, u_bdry_val, v_bdry_val, h_bdry_val, & +! hmask, G, PF ) + +! type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure +! real, dimension(SZIB_(G),SZJ_(G)), & +! intent(inout) :: u_face_mask_bdry !< A boundary-type mask at C-grid u faces +! real, dimension(SZIB_(G),SZJ_(G)), & +! intent(inout) :: u_flux_bdry_val !< The boundary thickness flux through + !! C-grid u faces [m2 s-1]. +! real, dimension(SZI_(G),SZJB_(G)), & +! intent(inout) :: v_face_mask_bdry !< A boundary-type mask at C-grid v faces +! real, dimension(SZI_(G),SZJB_(G)), & +! intent(inout) :: v_flux_bdry_val !< The boundary thickness flux through + !! C-grid v faces [m2 s-1]. +! real, dimension(SZIB_(G),SZJB_(G)), & +! intent(inout) :: u_bdry_val !< The zonal ice shelf velocity at open + !! boundary vertices [m yr-1]. +! real, dimension(SZIB_(G),SZJB_(G)), & +! intent(inout) :: v_bdry_val !< The meridional ice shelf velocity at open + !! boundary vertices [m yr-1]. +! real, dimension(SZDI_(G),SZDJ_(G)), & +! intent(inout) :: h_bdry_val !< The ice shelf thickness at open boundaries +! real, dimension(SZDI_(G),SZDJ_(G)), & +! intent(inout) :: hmask !< A mask indicating which tracer points are +! !! partly or fully covered by an ice-shelf +! type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters ! character(len=40) :: mdl = "initialize_ice_shelf_boundary" ! This subroutine's name. ! character(len=200) :: config @@ -248,10 +280,10 @@ end subroutine initialize_ice_thickness_channel ! "flux condition", default=.true.) ! select case ( trim(config) ) -! case ("CHANNEL"); -! call initialize_ice_shelf_boundary_channel(u_face_mask_boundary, & -! v_face_mask_boundary, u_flux_boundary_values, v_flux_boundary_values, & -! u_boundary_values, v_boundary_values, h_boundary_values, hmask, G, & +! case ("CHANNEL") +! call initialize_ice_shelf_boundary_channel(u_face_mask_bdry, & +! v_face_mask_bdry, u_flux_bdry_val, v_flux_bdry_val, & +! u_bdry_val, v_bdry_val, h_bdry_val, hmask, G, & ! flux_bdry, PF) ! case ("FILE"); call MOM_error(FATAL,"MOM_initialize: "// & ! "Unrecognized topography setup "//trim(config)) @@ -263,24 +295,34 @@ end subroutine initialize_ice_thickness_channel ! end subroutine initialize_ice_shelf_boundary -! subroutine initialize_ice_shelf_boundary_channel ( & -! u_face_mask_boundary, & -! v_face_mask_boundary, & -! u_flux_boundary_values, & -! v_flux_boundary_values, & -! u_boundary_values, & -! v_boundary_values, & -! h_boundary_values, & -! hmask, & -! G, flux_bdry, PF ) - -! type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure -! real, dimension(SZIB_(G),SZJ_(G)), intent(inout) :: u_face_mask_boundary, u_flux_boundary_values -! real, dimension(SZI_(G),SZJB_(G)), intent(inout) :: v_face_mask_boundary, v_flux_boundary_values -! real, dimension(SZIB_(G),SZJB_(G)), intent(inout) :: u_boundary_values, v_boundary_values -! real, dimension(:,:), intent(inout) :: h_boundary_values, hmask -! logical, intent(in) :: flux_bdry -! type (param_file_type), intent(in) :: PF +! subroutine initialize_ice_shelf_boundary_channel(u_face_mask_bdry, v_face_mask_bdry, & +! u_flux_bdry_val, v_flux_bdry_val, u_bdry_val, v_bdry_val, h_bdry_val, & +! hmask, G, flux_bdry, PF ) + +! type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure +! real, dimension(SZIB_(G),SZJ_(G)), & +! intent(inout) :: u_face_mask_bdry !< A boundary-type mask at C-grid u faces +! real, dimension(SZIB_(G),SZJ_(G)), & +! intent(inout) :: u_flux_bdry_val !< The boundary thickness flux through + !! C-grid u faces [m2 s-1]. +! real, dimension(SZI_(G),SZJB_(G)), & +! intent(inout) :: v_face_mask_bdry !< A boundary-type mask at C-grid v faces +! real, dimension(SZI_(G),SZJB_(G)), & +! intent(inout) :: v_flux_bdry_val !< The boundary thickness flux through + !! C-grid v faces [m2 s-1]. +! real, dimension(SZIB_(G),SZJB_(G)), & +! intent(inout) :: u_bdry_val !< The zonal ice shelf velocity at open + !! boundary vertices [m yr-1]. +! real, dimension(SZIB_(G),SZJB_(G)), & +! intent(inout) :: v_bdry_val !< The meridional ice shelf velocity at open + !! boundary vertices [m yr-1]. +! real, dimension(SZDI_(G),SZDJ_(G)), & +! intent(inout) :: h_bdry_val !< The ice shelf thickness at open boundaries +! real, dimension(SZDI_(G),SZDJ_(G)), & +! intent(inout) :: hmask !< A mask indicating which tracer points are +! !! partly or fully covered by an ice-shelf +! logical, intent(in) :: flux_bdry !< If true, use mass fluxes as the boundary value. +! type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters ! character(len=40) :: mdl = "initialize_ice_shelf_boundary_channel" ! This subroutine's name. ! integer :: i, j, isd, jsd, is, js, iegq, jegq, giec, gjec, gisc, gjsc, isc, jsc, iec, jec, ied, jed @@ -311,41 +353,41 @@ end subroutine initialize_ice_thickness_channel ! ! upstream boundary - set either dirichlet or flux condition -! if ((i+G%idg_offset) .eq. G%domain%nihalo+1) then +! if ((i+G%idg_offset) == G%domain%nihalo+1) then ! if (flux_bdry) then -! u_face_mask_boundary (i-1,j) = 4.0 -! u_flux_boundary_values (i-1,j) = input_flux +! u_face_mask_bdry(i-1,j) = 4.0 +! u_flux_bdry_val(i-1,j) = input_flux ! else ! hmask(i-1,j) = 3.0 -! h_boundary_values (i-1,j) = input_thick -! u_face_mask_boundary (i-1,j) = 3.0 -! u_boundary_values (i-1,j-1) = (1 - ((G%geoLatBu(i-1,j-1) - 0.5*lenlat)*2./lenlat)**2) * & +! h_bdry_val(i-1,j) = input_thick +! u_face_mask_bdry(i-1,j) = 3.0 +! u_bdry_val(i-1,j-1) = (1 - ((G%geoLatBu(i-1,j-1) - 0.5*lenlat)*2./lenlat)**2) * & ! 1.5 * input_flux / input_thick -! u_boundary_values (i-1,j) = (1 - ((G%geoLatBu(i-1,j) - 0.5*lenlat)*2./lenlat)**2) * & +! u_bdry_val(i-1,j) = (1 - ((G%geoLatBu(i-1,j) - 0.5*lenlat)*2./lenlat)**2) * & ! 1.5 * input_flux / input_thick ! endif ! endif ! ! side boundaries: no flow -! if (G%jdg_offset+j .eq. gjsc+1) then !bot boundary -! if (len_stress .eq. 0. .OR. G%geoLonCv(i,j-1) .le. len_stress) then -! v_face_mask_boundary (i,j-1) = 0. +! if (G%jdg_offset+j == gjsc+1) then !bot boundary +! if (len_stress == 0. .OR. G%geoLonCv(i,j-1) <= len_stress) then +! v_face_mask_bdry(i,j-1) = 0. ! else -! v_face_mask_boundary (i,j-1) = 1. +! v_face_mask_bdry(i,j-1) = 1. ! endif -! elseif (G%jdg_offset+j .eq. gjec) then !top boundary -! if (len_stress .eq. 0. .OR. G%geoLonCv(i,j-1) .le. len_stress) then -! v_face_mask_boundary (i,j) = 0. +! elseif (G%jdg_offset+j == gjec) then !top boundary +! if (len_stress == 0. .OR. G%geoLonCv(i,j-1) <= len_stress) then +! v_face_mask_bdry(i,j) = 0. ! else -! v_face_mask_boundary (i,j) = 1. +! v_face_mask_bdry(i,j) = 1. ! endif ! endif ! ! downstream boundary - CFBC -! if (i+G%idg_offset .eq. giec) then -! u_face_mask_boundary(i,j) = 2.0 +! if (i+G%idg_offset == giec) then +! u_face_mask_bdry(i,j) = 2.0 ! endif ! enddo diff --git a/src/ice_shelf/MOM_ice_shelf_state.F90 b/src/ice_shelf/MOM_ice_shelf_state.F90 new file mode 100644 index 0000000000..414a3389d6 --- /dev/null +++ b/src/ice_shelf/MOM_ice_shelf_state.F90 @@ -0,0 +1,101 @@ +!> Implements the thermodynamic aspects of ocean / ice-shelf interactions, +!! along with a crude placeholder for a later implementation of full +!! ice shelf dynamics, all using the MOM framework and coding style. +module MOM_ice_shelf_state + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_COMPONENT, CLOCK_ROUTINE +use MOM_dyn_horgrid, only : dyn_horgrid_type, create_dyn_horgrid, destroy_dyn_horgrid +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe +use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type +use MOM_grid, only : MOM_grid_init, ocean_grid_type +use MOM_get_input, only : directories, Get_MOM_input +use mpp_mod, only : mpp_sum, mpp_max, mpp_min, mpp_pe, mpp_npes, mpp_sync +use MOM_coms, only : reproducing_sum +use MOM_checksums, only : hchksum, qchksum, chksum, uchksum, vchksum, uvchksum + +implicit none ; private + +public ice_shelf_state_end, ice_shelf_state_init + +!> Structure that describes the ice shelf state +type, public :: ice_shelf_state + real, pointer, dimension(:,:) :: & + mass_shelf => NULL(), & !< The mass per unit area of the ice shelf or sheet [kg m-2]. + area_shelf_h => NULL(), & !< The area per cell covered by the ice shelf [m2]. + h_shelf => NULL(), & !< the thickness of the shelf [m], redundant with mass but may + !! make the code more readable + hmask => NULL(),& !< Mask used to indicate ice-covered or partiall-covered cells + !! 1: fully covered, solve for velocity here (for now all + !! ice-covered cells are treated the same, this may change) + !! 2: partially covered, do not solve for velocity + !! 0: no ice in cell. + !! 3: bdry condition on thickness set - not in computational domain + !! -2 : default (out of computational boundary, and) not = 3 + !! NOTE: hmask will change over time and NEEDS TO BE MAINTAINED + !! otherwise the wrong nodes will be included in velocity calcs. + + tflux_ocn => NULL(), & !< The UPWARD sensible ocean heat flux at the + !! ocean-ice interface [m-2]. + salt_flux => NULL(), & !< The downward salt flux at the ocean-ice + !! interface [kg m-2 s-1]. + water_flux => NULL(), & !< The net downward liquid water flux at the + !! ocean-ice interface [kg m-2 s-1]. + tflux_shelf => NULL(), & !< The UPWARD diffusive heat flux in the ice + !! shelf at the ice-ocean interface [W m-2]. + + tfreeze => NULL() !< The freezing point potential temperature + !! an the ice-ocean interface [degC]. + +end type ice_shelf_state + +contains + +!> Deallocates all memory associated with this module +subroutine ice_shelf_state_init(ISS, G) + type(ice_shelf_state), pointer :: ISS !< A pointer to the ice shelf state structure + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + + integer :: isd, ied, jsd, jed + isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed + + if (associated(ISS)) then + call MOM_error(FATAL, "MOM_ice_shelf_state.F90, ice_shelf_state_init: "// & + "called with an associated ice_shelf_state pointer.") + return + endif + allocate(ISS) + + allocate(ISS%mass_shelf(isd:ied,jsd:jed) ) ; ISS%mass_shelf(:,:) = 0.0 + allocate(ISS%area_shelf_h(isd:ied,jsd:jed) ) ; ISS%area_shelf_h(:,:) = 0.0 + allocate(ISS%h_shelf(isd:ied,jsd:jed) ) ; ISS%h_shelf(:,:) = 0.0 + allocate(ISS%hmask(isd:ied,jsd:jed) ) ; ISS%hmask(:,:) = -2.0 + + allocate(ISS%tflux_ocn(isd:ied,jsd:jed) ) ; ISS%tflux_ocn(:,:) = 0.0 + allocate(ISS%water_flux(isd:ied,jsd:jed) ) ; ISS%water_flux(:,:) = 0.0 + allocate(ISS%salt_flux(isd:ied,jsd:jed) ) ; ISS%salt_flux(:,:) = 0.0 + allocate(ISS%tflux_shelf(isd:ied,jsd:jed) ) ; ISS%tflux_shelf(:,:) = 0.0 + allocate(ISS%tfreeze(isd:ied,jsd:jed) ) ; ISS%tfreeze(:,:) = 0.0 + +end subroutine ice_shelf_state_init + + +!> Deallocates all memory associated with this module +subroutine ice_shelf_state_end(ISS) + type(ice_shelf_state), pointer :: ISS !< A pointer to the ice shelf state structure + + if (.not.associated(ISS)) return + + deallocate(ISS%mass_shelf, ISS%area_shelf_h, ISS%h_shelf, ISS%hmask) + + deallocate(ISS%tflux_ocn, ISS%water_flux, ISS%salt_flux, ISS%tflux_shelf) + deallocate(ISS%tfreeze) + + deallocate(ISS) + +end subroutine ice_shelf_state_end + + +end module MOM_ice_shelf_state diff --git a/src/ice_shelf/MOM_marine_ice.F90 b/src/ice_shelf/MOM_marine_ice.F90 new file mode 100644 index 0000000000..d4e83561a7 --- /dev/null +++ b/src/ice_shelf/MOM_marine_ice.F90 @@ -0,0 +1,209 @@ +!> Routines incorporating the effects of marine ice (sea-ice and icebergs) into +!! the ocean model dynamics and thermodynamics. +module MOM_marine_ice + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_constants, only : hlf +use MOM_diag_mediator, only : post_data, query_averaging_enabled, diag_ctrl +use MOM_domains, only : pass_var, pass_vector, AGRID, BGRID_NE, CGRID_NE +use MOM_domains, only : TO_ALL, Omit_Corners +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_forcing_type, only : allocate_forcing_type +use MOM_forcing_type, only : forcing, mech_forcing +use MOM_grid, only : ocean_grid_type +use MOM_time_manager, only : time_type +use MOM_variables, only : surface + +implicit none ; private + +#include + +public iceberg_forces, iceberg_fluxes, marine_ice_init + +!> Control structure for MOM_marine_ice +type, public :: marine_ice_CS ; private + real :: kv_iceberg !< The viscosity of the icebergs [m2 s-1] (for ice rigidity) + real :: berg_area_threshold !< Fraction of grid cell which iceberg must occupy + !! so that fluxes below are set to zero. (0.5 is a + !! good value to use.) Not applied for negative values. + real :: latent_heat_fusion !< Latent heat of fusion [J kg-1] + real :: density_iceberg !< A typical density of icebergs [kg m-3] (for ice rigidity) + + type(time_type), pointer :: Time !< A pointer to the ocean model's clock. + type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the timing of diagnostic output. +end type marine_ice_CS + +contains + +!> add_berg_flux_to_shelf adds rigidity and ice-area coverage due to icebergs +!! to the forces type fields, and adds ice-areal coverage and modifies various +!! thermodynamic fluxes due to the presence of icebergs. +subroutine iceberg_forces(G, forces, use_ice_shelf, sfc_state, & + time_step, CS) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces + type(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + logical, intent(in) :: use_ice_shelf !< If true, this configuration uses ice shelves. + real, intent(in) :: time_step !< The coupling time step [s]. + type(marine_ice_CS), pointer :: CS !< Pointer to the control structure for MOM_marine_ice + + real :: kv_rho_ice ! The viscosity of ice divided by its density [m5 kg-1 s-1]. + integer :: i, j, is, ie, js, je + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + !This routine adds iceberg data to the ice shelf data (if ice shelf is used) + !which can then be used to change the top of ocean boundary condition used in + !the ocean model. This routine is taken from the add_shelf_flux subroutine + !within the ice shelf model. + + if (.not.associated(CS)) return + + if (.not.(associated(forces%area_berg) .and. associated(forces%mass_berg) ) ) return + + if (.not.(associated(forces%frac_shelf_u) .and. associated(forces%frac_shelf_v) .and. & + associated(forces%rigidity_ice_u) .and. associated(forces%rigidity_ice_v)) ) return + + ! This section sets or augments the values of fields in forces. + if (.not. use_ice_shelf) then + forces%frac_shelf_u(:,:) = 0.0 ; forces%frac_shelf_v(:,:) = 0.0 + endif + if (.not. forces%accumulate_rigidity) then + forces%rigidity_ice_u(:,:) = 0.0 ; forces%rigidity_ice_v(:,:) = 0.0 + endif + + call pass_var(forces%area_berg, G%domain, TO_ALL+Omit_corners, halo=1, complete=.false.) + call pass_var(forces%mass_berg, G%domain, TO_ALL+Omit_corners, halo=1, complete=.true.) + kv_rho_ice = CS%kv_iceberg / CS%density_iceberg + do j=js,je ; do I=is-1,ie + if ((G%areaT(i,j) + G%areaT(i+1,j) > 0.0)) & ! .and. (G%dxdy_u(I,j) > 0.0)) & + forces%frac_shelf_u(I,j) = forces%frac_shelf_u(I,j) + & + (((forces%area_berg(i,j)*G%areaT(i,j)) + & + (forces%area_berg(i+1,j)*G%areaT(i+1,j))) / & + (G%areaT(i,j) + G%areaT(i+1,j)) ) + forces%rigidity_ice_u(I,j) = forces%rigidity_ice_u(I,j) + kv_rho_ice * & + min(forces%mass_berg(i,j), forces%mass_berg(i+1,j)) + enddo ; enddo + do J=js-1,je ; do i=is,ie + if ((G%areaT(i,j) + G%areaT(i,j+1) > 0.0)) & ! .and. (G%dxdy_v(i,J) > 0.0)) & + forces%frac_shelf_v(i,J) = forces%frac_shelf_v(i,J) + & + (((forces%area_berg(i,j)*G%areaT(i,j)) + & + (forces%area_berg(i,j+1)*G%areaT(i,j+1))) / & + (G%areaT(i,j) + G%areaT(i,j+1)) ) + forces%rigidity_ice_v(i,J) = forces%rigidity_ice_v(i,J) + kv_rho_ice * & + min(forces%mass_berg(i,j), forces%mass_berg(i,j+1)) + enddo ; enddo + !### This halo update may be unnecessary. Test it. -RWH + call pass_vector(forces%frac_shelf_u, forces%frac_shelf_v, G%domain, TO_ALL, CGRID_NE) + +end subroutine iceberg_forces + +!> iceberg_fluxes adds ice-area-coverage and modifies various +!! thermodynamic fluxes due to the presence of icebergs. +subroutine iceberg_fluxes(G, fluxes, use_ice_shelf, sfc_state, & + time_step, CS) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(forcing), intent(inout) :: fluxes !< A structure with pointers to themodynamic, + !! tracer and mass exchange forcing fields + type(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + logical, intent(in) :: use_ice_shelf !< If true, this configuration uses ice shelves. + real, intent(in) :: time_step !< The coupling time step [s]. + type(marine_ice_CS), pointer :: CS !< Pointer to the control structure for MOM_marine_ice + + real :: fraz ! refreezing rate [kg m-2 s-1] + real :: I_dt_LHF ! The inverse of the timestep times the latent heat of fusion [kg J-1 s-1]. + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed + !This routine adds iceberg data to the ice shelf data (if ice shelf is used) + !which can then be used to change the top of ocean boundary condition used in + !the ocean model. This routine is taken from the add_shelf_flux subroutine + !within the ice shelf model. + + if (.not.associated(CS)) return + if (.not.(associated(fluxes%area_berg) .and. associated(fluxes%ustar_berg) .and. & + associated(fluxes%mass_berg) ) ) return + if (.not.(associated(fluxes%frac_shelf_h) .and. associated(fluxes%ustar_shelf)) ) return + + + if (.not.(associated(fluxes%area_berg) .and. associated(fluxes%ustar_berg) .and. & + associated(fluxes%mass_berg) ) ) return + if (.not. use_ice_shelf) then + fluxes%frac_shelf_h(:,:) = 0. + fluxes%ustar_shelf(:,:) = 0. + endif + do j=jsd,jed ; do i=isd,ied ; if (G%areaT(i,j) > 0.0) then + fluxes%frac_shelf_h(i,j) = fluxes%frac_shelf_h(i,j) + fluxes%area_berg(i,j) + fluxes%ustar_shelf(i,j) = fluxes%ustar_shelf(i,j) + fluxes%ustar_berg(i,j) + endif ; enddo ; enddo + + !Zero'ing out other fluxes under the tabular icebergs + if (CS%berg_area_threshold >= 0.) then + I_dt_LHF = 1.0 / (time_step * CS%latent_heat_fusion) + do j=jsd,jed ; do i=isd,ied + if (fluxes%frac_shelf_h(i,j) > CS%berg_area_threshold) then + ! Only applying for ice shelf covering most of cell. + + if (associated(fluxes%sw)) fluxes%sw(i,j) = 0.0 + if (associated(fluxes%lw)) fluxes%lw(i,j) = 0.0 + if (associated(fluxes%latent)) fluxes%latent(i,j) = 0.0 + if (associated(fluxes%evap)) fluxes%evap(i,j) = 0.0 + + ! Add frazil formation diagnosed by the ocean model [J m-2] in the + ! form of surface layer evaporation [kg m-2 s-1]. Update lprec in the + ! control structure for diagnostic purposes. + + if (associated(sfc_state%frazil)) then + fraz = sfc_state%frazil(i,j) * I_dt_LHF + if (associated(fluxes%evap)) fluxes%evap(i,j) = fluxes%evap(i,j) - fraz + !CS%lprec(i,j)=CS%lprec(i,j) - fraz + sfc_state%frazil(i,j) = 0.0 + endif + + !Alon: Should these be set to zero too? + if (associated(fluxes%sens)) fluxes%sens(i,j) = 0.0 + if (associated(fluxes%salt_flux)) fluxes%salt_flux(i,j) = 0.0 + if (associated(fluxes%lprec)) fluxes%lprec(i,j) = 0.0 + endif + enddo ; enddo + endif + +end subroutine iceberg_fluxes + +!> Initialize control structure for MOM_marine_ice +subroutine marine_ice_init(Time, G, param_file, diag, CS) + type(time_type), target, intent(in) :: Time !< Current model time + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(param_file_type), intent(in) :: param_file !< Runtime parameter handles + type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure + type(marine_ice_CS), pointer :: CS !< Pointer to the control structure for MOM_marine_ice +! This include declares and sets the variable "version". +#include "version_variable.h" + 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.") + return + else ; allocate(CS) ; endif + + ! Write all relevant parameters to the model log. + call log_version(mdl, version) + + call get_param(param_file, mdl, "KV_ICEBERG", CS%kv_iceberg, & + "The viscosity of the icebergs", units="m2 s-1",default=1.0e10) + call get_param(param_file, mdl, "DENSITY_ICEBERGS", CS%density_iceberg, & + "A typical density of icebergs.", units="kg m-3", default=917.0) + 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"//& + "values.", units="non-dim", default=-1.0) + +end subroutine marine_ice_init + +end module MOM_marine_ice diff --git a/src/ice_shelf/shelf_triangular_FEstuff.F90 b/src/ice_shelf/shelf_triangular_FEstuff.F90 deleted file mode 100644 index 72c0043ebf..0000000000 --- a/src/ice_shelf/shelf_triangular_FEstuff.F90 +++ /dev/null @@ -1,727 +0,0 @@ -module shelf_triangular_FEstuff - -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_diag_mediator, only : diag_ctrl, time_type, enable_averaging, disable_averaging -use MOM_grid, only : ocean_grid_type -use MOM_time_manager, only : time_type, set_time, time_type_to_real -use MOM_restart, only : restart_init, restore_state, MOM_restart_CS -use MOM_EOS, only : EOS_type -use user_shelf_init, only : user_ice_shelf_CS - -implicit none ; private - -#include -type, public :: ice_shelf_CS ; private - type(MOM_restart_CS), pointer :: restart_CSp => NULL() - type(ocean_grid_type) :: grid ! A structure containing metrics, etc. - ! The rest is private - character(len=128) :: restart_output_dir = ' ' - real, pointer, dimension(:,:) :: & - mass_shelf => NULL(), & ! The mass per unit area of the ice shelf or sheet, in kg m-2. - area_shelf_h => NULL(), & ! The area per cell covered by the ice shelf, in m2. - - t_flux => NULL(), & ! The UPWARD sensible ocean heat flux at the ocean-ice - ! interface, in W m-2. - salt_flux => NULL(), & ! The downward salt flux at the ocean-ice interface, in kg m-2 s-1. - lprec => NULL(), & ! The downward liquid water flux at the ocean-ice interface, - ! in kg m-2 s-1. - ! Perhaps these diagnostics should only be kept with the call? - exch_vel_t => NULL(), & - exch_vel_s => NULL(), & - tfreeze => NULL(), & ! The freezing point potential temperature an the ice-ocean - ! interface, in deg C. - tflux_shelf => NULL(), & ! The UPWARD diffusive heat flux in the ice shelf at the - ! ice-ocean interface, in W m-2. -!!! DNG !!! - u_shelf => NULL(), & ! the zonal (?) velocity of the ice shelf/sheet... in meters per second??? - ! on q-points (B grid) - v_shelf => NULL(), & ! the meridional velocity of the ice shelf/sheet... m/s ?? - ! on q-points (B grid) - h_shelf => NULL(), & ! the thickness of the shelf in m... redundant with mass - ! but may make code more readable - hmask => NULL(),& ! used to indicate ice-covered cells, as well as partially-covered - ! 1: fully covered, solve for velocity here - ! (for now all ice-covered cells are treated the same, this may change) - ! 2: partially covered, do not solve for velocity - ! 0: no ice in cell. - ! 3: bdry condition on thickness set - not in computational domain - ! -2 : default (out of computational boundary, and not = 3 - - ! NOTE: hmask will change over time and NEEDS TO BE MAINTAINED - ! otherwise the wrong nodes will be included in velocity calcs. - u_face_mask => NULL(), v_face_mask => NULL(), & - ! masks for velocity boundary conditions - on *C GRID* - this is because the FEM solution - ! cares about FACES THAT GET INTEGRATED OVER, not vertices - ! Will represent boundary conditions on computational boundary (or permanent boundary - ! between fast-moving and near-stagnant ice - ! FOR NOW: 1=interior bdry, 0=no-flow boundary, 2=stress bdry condition, 3=inhomogeneous dirichlet boundary - umask => NULL(), vmask => NULL(), & - ! masks on the actual degrees of freedom (B grid) - - ! 1=normal node, 3=inhomogeneous boundary node, 0 - no flow node (will also get ice-free nodes) - ice_visc_bilinear => NULL(), & - ice_visc_lower_tri => NULL(), & - ice_visc_upper_tri => NULL(), & - thickness_boundary_values => NULL(), & - u_boundary_values => NULL(), & - v_boundary_values => NULL(), & - - - taub_beta_eff_bilinear => NULL(), & ! nonlinear part of "linearized" basal stress - exact form depends on basal law exponent - ! and/or whether flow is "hybridized" a la Goldberg 2011 - taub_beta_eff_lower_tri => NULL(), & - taub_beta_eff_upper_tri => NULL(), & - - OD_rt => NULL(), float_frac_rt => NULL(), & - OD_av => NULL(), float_frac => NULL() !! two arrays that represent averages of ocean values that are maintained - !! within the ice shelf module and updated based on the "ocean state". - !! OD_av is ocean depth, and float_frac is the average amount of time - !! a cell is "exposed", i.e. the column thickness is below a threshold. - !! both are averaged over the time of a diagnostic (ice velocity) - - !! [if float_frac = 1 ==> grounded; obv. counterintuitive; might fix] - - real :: ustar_bg ! A minimum value for ustar under ice shelves, in m s-1. - real :: Cp ! The heat capacity of sea water, in J kg-1 K-1. - real :: Cp_ice ! The heat capacity of fresh ice, in J kg-1 K-1. - real :: gamma_t ! The (fixed) turbulent exchange velocity in the - ! 2-equation formulation, in m s-1. - real :: Salin_ice ! The salinity of shelf ice, in PSU. - real :: Temp_ice ! The core temperature of shelf ice, in C. - real :: kv_ice ! The viscosity of ice, in m2 s-1. - real :: density_ice ! A typical density of ice, in kg m-3. - real :: kv_molec ! The molecular kinematic viscosity of sea water, m2 s-1. - real :: kd_molec_salt ! The molecular diffusivity of salt, in m2 s-1. - real :: kd_molec_temp ! The molecular diffusivity of heat, in m2 s-1. - real :: Lat_fusion ! The latent heat of fusion, in J kg-1. - -!!!! PHYSICAL AND NUMERICAL PARAMETERS FOR ICE DYNAMICS !!!!!! - - real :: time_step ! this is the shortest timestep that the ice shelf sees, and - ! is equal to the forcing timestep (it is passed in when the shelf - ! is initialized - so need to reorganize MOM driver. - ! it will be the prognistic timestep ... maybe. - -!!! all need to be initialized - - real :: A_glen_isothermal - real :: n_glen - real :: eps_glen_min - real :: C_basal_friction - real :: n_basal_friction - real :: density_ocean_avg ! this does not affect ocean circulation OR thermodynamics - ! it is to estimate the gravitational driving force at the shelf front - ! (until we think of a better way to do it- but any difference will be negligible) - real :: thresh_float_col_depth ! the water column depth over which the shelf if considered to be floating - real :: input_flux - real :: input_thickness - - real :: len_lat ! this really should be a Grid or Domain field - - - real :: velocity_update_time_step ! the time to update the velocity through the nonlinear - ! elliptic equation. i think this should be done no more often than - ! ~ once a day (maybe longer) because it will depend on ocean values - ! that are averaged over this time interval, and the solve will begin - ! to lose meaning if it is done too frequently - integer :: velocity_update_sub_counter ! there is no outer loop for the velocity solve; the counter will have to be stored - integer :: velocity_update_counter ! the "outer" timestep number - integer :: nstep_velocity ! ~ (velocity_update_time_step / time_step) - - real :: cg_tolerance, nonlinear_tolerance - integer :: cg_max_iterations - integer :: nonlin_solve_err_mode ! 1: exit vel solve based on nonlin residual - ! 2: exit based on "fixed point" metric (|u - u_last| / |u| < tol where | | is infty-norm - real :: CFL_factor ! in uncoupled run, how to limit subcycled advective timestep - ! i.e. dt = CFL_factor * min (dx / u) - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - type(time_type) :: Time ! The component's time. - type(EOS_type), pointer :: eqn_of_state => NULL() ! Type that indicates the - ! equation of state to use. - logical :: isshelf ! True if a shelf model is to be used. - logical :: shelf_mass_is_dynamic ! True if the ice shelf mass changes with - ! time. - logical :: override_shelf_movement ! If true, user code specifies the shelf - ! movement instead of using the dynamic ice-shelf mode. - logical :: isthermo ! True if the ice shelf can exchange heat and mass with - ! the underlying ocean. - logical :: threeeq ! If true, the 3 equation consistency equations are - ! used to calculate the flux at the ocean-ice interface. - integer :: id_melt = -1, id_exch_vel_s = -1, id_exch_vel_t = -1, & - id_tfreeze = -1, id_tfl_shelf = -1, & - id_u_shelf = -1, id_v_shelf = -1, id_h_shelf = -1, id_h_mask = -1, & - id_u_mask = -1, id_v_mask = -1, & - id_surf_elev = -1, id_bathym = -1, id_float_frac = -1, id_col_thick = -1, & - id_area_shelf_h = -1, id_OD_rt = -1, id_float_frac_rt = -1 - type(diag_ctrl) :: diag ! A structure that is used to control diagnostic - ! output. - type(user_ice_shelf_CS), pointer :: user_CS => NULL() - - logical :: write_output_to_file ! this is for seeing arrays w/out netcdf capability -end type ice_shelf_CS -contains - -subroutine matrix_diagonal_triangle (CS, u_diagonal, v_diagonal) - - type(ice_shelf_CS), pointer :: CS - real, dimension (:,:), intent(inout) :: u_diagonal, v_diagonal - -! returns the diagonal entries of the matrix for a Jacobi preconditioning - - real, pointer, dimension (:,:) :: umask, vmask, & - nu_lower, nu_upper, beta_lower, beta_upper, hmask - type(ocean_grid_type), pointer :: G - integer :: i, j, is, js, cnt, isc, jsc, iec, jec - real :: A, n, ux, uy, vx, vy, eps_min, domain_width, dxh, dyh, dxdyh - - G => CS%grid - -! if (G%symmetric) then -! isym=1 -! else -! isym=0 -! endif - - - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - - umask => CS%umask ; vmask => CS%vmask ; hmask => CS%hmask - nu_lower => CS%ice_visc_lower_tri ; nu_upper => CS%ice_visc_upper_tri - beta_lower => CS%taub_beta_eff_lower_tri ; beta_upper => CS%taub_beta_eff_upper_tri - - do i=isc-1,iec+1 ; do j=jsc-1,jec+1 ; if (hmask(i,j) .eq. 1) then - dxh = G%dxT(i,j) - dyh = G%dyT(i,j) - dxdyh = G%areaT(i,j) - - if (umask (i,j-1) .eq. 1) then ! this (bot right) is a degree of freedom node - - ux = 1./dxh ; uy = 0./dyh - vx = 0. ; vy = 0. - - u_diagonal (i,j-1) = u_diagonal (i,j-1) + & - .5 * dxdyh * nu_lower (i,j) * ((4*ux+2*vy) * (1./dxh) + (uy+vy) * (0./dyh)) - - u_diagonal (i,j-1) = u_diagonal (i,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 - - ux = 0. ; uy = 0. - vx = 1./dxh ; vy = 0./dyh - - v_diagonal (i,j-1) = v_diagonal (i,j-1) + & - .5 * dxdyh * nu_lower (i,j) * ((uy+vx) * (1./dxh) + (4*vy+2*ux) * (0./dyh)) - - v_diagonal (i,j-1) = v_diagonal (i,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 - - ux = 0./dxh ; uy = -1./dyh - vx = 0. ; vy = 0. - - u_diagonal (i,j-1) = u_diagonal (i,j-1) + & - .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (0./dxh) + (uy+vy) * (-1./dyh)) - - u_diagonal (i,j-1) = u_diagonal (i,j-1) + & - beta_upper(i,j) * dxdyh * 1./24 - - vx = 0./dxh ; vy = -1./dyh - ux = 0. ; uy = 0. - - v_diagonal (i,j-1) = v_diagonal (i,j-1) + & - .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (0./dxh) + (4*vy+2*ux) * (-1./dyh)) - - v_diagonal (i,j-1) = v_diagonal (i,j-1) + & - beta_upper(i,j) * dxdyh * 1./24 - - endif - - if (umask (i-1,j) .eq. 1) then ! this (top left) is a degree of freedom node - - ux = 0./dxh ; uy = 1./dyh - vx = 0. ; vy = 0. - - u_diagonal (i-1,j) = u_diagonal (i-1,j) + & - .5 * dxdyh * nu_lower (i,j) * ((4*ux+2*vy) * (0./dxh) + (uy+vy) * (1./dyh)) - - u_diagonal (i,j-1) = u_diagonal (i,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 - - ux = 0. ; uy = 0. - vx = 0./dxh ; vy = 1./dyh - - v_diagonal (i-1,j) = v_diagonal (i-1,j) + & - .5 * dxdyh * nu_lower (i,j) * ((uy+vx) * (0./dxh) + (4*vy+2*ux) * (1./dyh)) - - v_diagonal (i,j-1) = v_diagonal (i,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 - - ux = -1./dxh ; uy = 0./dyh - vx = 0. ; vy = 0. - - u_diagonal (i-1,j) = u_diagonal (i-1,j) + & - .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (-1./dxh) + (uy+vy) * (0./dyh)) - - u_diagonal (i,j-1) = u_diagonal (i,j-1) + & - beta_upper(i,j) * dxdyh * 1./24 - - vx = -1./dxh ; vy = 0./dyh - ux = 0. ; uy = 0. - - v_diagonal (i-1,j) = v_diagonal (i-1,j) + & - .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (-1./dxh) + (4*vy+2*ux) * (0./dyh)) - - v_diagonal (i,j-1) = v_diagonal (i,j-1) + & - beta_upper(i,j) * dxdyh * 1./24 - - endif - - if (umask (i-1,j-1) .eq. 1) then ! this (bot left) is a degree of freedom node - - ux = -1./dxh ; uy = -1./dyh - vx = 0. ; vy = 0. - - u_diagonal (i-1,j-1) = u_diagonal (i-1,j-1) + & - .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (-1./dxh) + (uy+vy) * (-1./dyh)) - - u_diagonal (i-1,j-1) = u_diagonal (i-1,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 - - vx = -1./dxh ; vy = -1./dyh - ux = 0. ; uy = 0. - - v_diagonal (i-1,j-1) = v_diagonal (i-1,j-1) + & - .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (-1./dxh) + (4*vy+2*ux) * (-1./dyh)) - - v_diagonal (i-1,j-1) = v_diagonal (i-1,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 - endif - - if (umask (i,j) .eq. 1) then ! this (top right) is a degree of freedom node - - ux = 1./ dxh ; uy = 1./dyh - vx = 0. ; vy = 0. - - u_diagonal (i,j) = u_diagonal (i,j) + & - .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (1./dxh) + (uy+vy) * (1./dyh)) - - u_diagonal (i,j) = u_diagonal (i,j) + & - beta_upper(i,j) * dxdyh * 1./24 - - vx = 1./ dxh ; vy = 1./dyh - ux = 0. ; uy = 0. - - v_diagonal (i,j) = v_diagonal (i,j) + & - .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (1./dxh) + (4*vy+2*ux) * (1./dyh)) - - v_diagonal (i,j) = v_diagonal (i,j) + & - beta_upper(i,j) * dxdyh * 1./24 - - endif - endif ; enddo ; enddo - -end subroutine matrix_diagonal_triangle - -!~ subroutine apply_boundary_values_triangle (CS, time, u_boundary_contr, v_boundary_contr) - - !~ type(time_type), intent(in) :: Time - !~ type(ice_shelf_CS), pointer :: CS - !~ real, dimension (:,:), intent(inout) :: u_boundary_contr, v_boundary_contr - -!~ ! this will be a per-setup function. the boundary values of thickness and velocity -!~ ! (and possibly other variables) will be updated in this function - - !~ real, pointer, dimension (:,:) :: u_boundary_values, & - !~ v_boundary_values, & - !~ umask, vmask, hmask, & - !~ nu_lower, nu_upper, beta_lower, beta_upper - !~ type(ocean_grid_type), pointer :: G - !~ integer :: 0, i, j, cnt, isc, jsc, iec, jec - !~ real :: A, n, ux, uy, vx, vy, eps_min, domain_width, dxh, dyh, dxdyh - - !~ G => CS%grid - -!~ ! if (G%symmetric) then -!~ ! isym=1 -!~ ! else -!~ ! isym=0 -!~ ! endif - - - - !~ isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - - !~ u_boundary_values => CS%u_boundary_values - !~ v_boundary_values => CS%v_boundary_values - !~ umask => CS%umask ; vmask => CS%vmask ; hmask => CS%hmask - !~ nu_lower => CS%ice_visc_lower_tri ; nu_upper => CS%ice_visc_upper_tri - !~ beta_lower => CS%taub_beta_eff_lower_tri ; beta_upper => CS%taub_beta_eff_upper_tri - - !~ domain_width = CS%len_lat - - !~ do i=isc-1,iec+1 ; do j=jsc-1,jec+1 ; if (hmask(i,j) .eq. 1) then - - !~ if ((umask(i-1,j-1) .eq. 3) .OR. (umask(i,j-1) .eq. 3) .OR. (umask(i-1,j) .eq. 3)) then - - !~ dxh = G%dxh(i,j) - !~ dyh = G%dyh(i,j) - !~ dxdyh = G%dxdyh(i,j) - - !~ ux = (u_boundary_values(i,j-1)-u_boundary_values(i-1,j-1))/dxh - !~ vx = (v_boundary_values(i,j-1)-v_boundary_values(i-1,j-1))/dxh - !~ uy = (u_boundary_values(i-1,j)-u_boundary_values(i-1,j-1))/dyh - !~ vy = (v_boundary_values(i-1,j)-v_boundary_values(i-1,j-1))/dyh - - !~ if (umask (i,j-1) .eq. 1) then ! this (bot right) is a degree of freedom node - - !~ u_boundary_contr (i,j-1) = u_boundary_contr (i,j-1) + & - !~ .5 * dxdyh * nu_lower (i,j) * ((4*ux+2*vy) * (1./dxh) + (uy+vy) * (0./dyh)) - - !~ v_boundary_contr (i,j-1) = v_boundary_contr (i,j-1) + & - !~ .5 * dxdyh * nu_lower (i,j) * ((uy+vx) * (1./dxh) + (4*vy+2*ux) * (0./dyh)) - - !~ u_boundary_contr (i,j-1) = u_boundary_contr (i,j-1) + & - !~ beta_lower(i,j) * dxdyh * 1./24 * (u_boundary_values(i-1,j-1) + & - !~ u_boundary_values(i-1,j) + u_boundary_values(i,j-1)) - - !~ v_boundary_contr (i,j-1) = v_boundary_contr (i,j-1) + & - !~ beta_lower(i,j) * dxdyh * 1./24 * (v_boundary_values(i-1,j-1) + & - !~ v_boundary_values(i-1,j) + v_boundary_values(i,j-1)) - !~ endif - - !~ if (umask (i-1,j) .eq. 1) then ! this (top left) is a degree of freedom node - - !~ u_boundary_contr (i-1,j) = u_boundary_contr (i-1,j) + & - !~ .5 * dxdyh * nu_lower (i,j) * ((4*ux+2*vy) * (0./dxh) + (uy+vy) * (1./dyh)) - - !~ v_boundary_contr (i-1,j) = v_boundary_contr (i-1,j) + & - !~ .5 * dxdyh * nu_lower (i,j) * ((uy+vx) * (0./dxh) + (4*vy+2*ux) * (1./dyh)) - - !~ u_boundary_contr (i,j-1) = u_boundary_contr (i,j-1) + & - !~ beta_lower(i,j) * dxdyh * 1./24 * (u_boundary_values(i-1,j-1) + & - !~ u_boundary_values(i-1,j) + u_boundary_values(i,j-1)) - - !~ v_boundary_contr (i,j-1) = v_boundary_contr (i,j-1) + & - !~ beta_lower(i,j) * dxdyh * 1./24 * (v_boundary_values(i-1,j-1) + & - !~ v_boundary_values(i-1,j) + v_boundary_values(i,j-1)) - !~ endif - - !~ if (umask (i-1,j-1) .eq. 1) then ! this (bot left) is a degree of freedom node - - !~ u_boundary_contr (i-1,j-1) = u_boundary_contr (i-1,j-1) + & - !~ .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (-1./dxh) + (uy+vy) * (-1./dyh)) - - !~ v_boundary_contr (i-1,j-1) = v_boundary_contr (i-1,j-1) + & - !~ .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (-1./dxh) + (4*vy+2*ux) * (-1./dyh)) - - !~ u_boundary_contr (i-1,j-1) = u_boundary_contr (i-1,j-1) + & - !~ beta_lower(i,j) * dxdyh * 1./24 * (u_boundary_values(i-1,j-1) + & - !~ u_boundary_values(i-1,j) + u_boundary_values(i,j-1)) - - !~ v_boundary_contr (i-1,j-1) = v_boundary_contr (i-1,j-1) + & - !~ beta_lower(i,j) * dxdyh * 1./24 * (v_boundary_values(i-1,j-1) + & - !~ v_boundary_values(i-1,j) + v_boundary_values(i,j-1)) - !~ endif - - !~ endif - - !~ if ((umask(i,j) .eq. 3) .OR. (umask(i,j-1) .eq. 3) .OR. (umask(i-1,j) .eq. 3)) then - - !~ dxh = G%dxh(i,j) - !~ dyh = G%dyh(i,j) - !~ dxdyh = G%dxdyh(i,j) - - !~ ux = (u_boundary_values(i,j)-u_boundary_values(i-1,j))/dxh - !~ vx = (v_boundary_values(i,j)-v_boundary_values(i-1,j))/dxh - !~ uy = (u_boundary_values(i,j)-u_boundary_values(i,j-1))/dyh - !~ vy = (v_boundary_values(i,j)-v_boundary_values(i,j-1))/dyh - - !~ if (umask (i,j-1) .eq. 1) then ! this (bot right) is a degree of freedom node - - !~ u_boundary_contr (i,j-1) = u_boundary_contr (i,j-1) + & - !~ .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (0./dxh) + (uy+vy) * (-1./dyh)) - - !~ v_boundary_contr (i,j-1) = v_boundary_contr (i,j-1) + & - !~ .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (0./dxh) + (4*vy+2*ux) * (-1./dyh)) - - !~ u_boundary_contr (i,j-1) = u_boundary_contr (i,j-1) + & - !~ beta_upper(i,j) * dxdyh * 1./24 * (u_boundary_values(i,j) + & - !~ u_boundary_values(i-1,j) + & - !~ u_boundary_values(i,j-1)) - - !~ v_boundary_contr (i,j-1) = v_boundary_contr (i,j-1) + & - !~ beta_upper(i,j) * dxdyh * 1./24 * (u_boundary_values(i,j) + & - !~ u_boundary_values(i-1,j) + & - !~ u_boundary_values(i,j-1)) - !~ endif - - !~ if (umask (i-1,j) .eq. 1) then ! this (top left) is a degree of freedom node - - !~ u_boundary_contr (i-1,j) = u_boundary_contr (i-1,j) + & - !~ .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (-1./dxh) + (uy+vy) * (0./dyh)) - - !~ v_boundary_contr (i-1,j) = v_boundary_contr (i-1,j) + & - !~ .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (-1./dxh) + (4*vy+2*ux) * (0./dyh)) - - !~ u_boundary_contr (i,j-1) = u_boundary_contr (i,j-1) + & - !~ beta_upper(i,j) * dxdyh * 1./24 * (u_boundary_values(i,j) + & - !~ u_boundary_values(i-1,j) + & - !~ u_boundary_values(i,j-1)) - - !~ v_boundary_contr (i,j-1) = v_boundary_contr (i,j-1) + & - !~ beta_upper(i,j) * dxdyh * 1./24 * (u_boundary_values(i,j) + & - !~ u_boundary_values(i-1,j) + & - !~ u_boundary_values(i,j-1)) - !~ endif - - !~ if (umask (i,j) .eq. 1) then ! this (top right) is a degree of freedom node - - !~ u_boundary_contr (i,j) = u_boundary_contr (i,j) + & - !~ .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (1./dxh) + (uy+vy) * (1./dyh)) - - !~ v_boundary_contr (i,j) = v_boundary_contr (i,j) + & - !~ .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (1./dxh) + (4*vy+2*ux) * (1./dyh)) - - !~ u_boundary_contr (i,j) = u_boundary_contr (i,j) + & - !~ beta_upper(i,j) * dxdyh * 1./24 * (u_boundary_values(i,j) + & - !~ u_boundary_values(i-1,j) + & - !~ u_boundary_values(i,j-1)) - - !~ v_boundary_contr (i,j) = v_boundary_contr (i,j) + & - !~ beta_upper(i,j) * dxdyh * 1./24 * (u_boundary_values(i,j) + & - !~ u_boundary_values(i-1,j) + & - !~ u_boundary_values(i,j-1)) - !~ endif - - - !~ endif - !~ endif ; enddo ; enddo - -!~ end subroutine apply_boundary_values_triangle - -!~ subroutine calc_shelf_visc_triangular (CS,u,v) - !~ type(ice_shelf_CS), pointer :: CS - !~ real, dimension(:,:), intent(inout) :: u, v - -!~ ! update DEPTH_INTEGRATED viscosity, based on horizontal strain rates - this is for triangle FEM solve so there is -!~ ! an "upper" and "lower" triangular viscosity - -!~ ! also this subroutine updates the nonlinear part of the basal traction - -!~ ! this may be subject to change later... to make it "hybrid" - - !~ real, pointer, dimension (:,:) :: nu_lower , & - !~ nu_upper, & - !~ beta_eff_lower, & - !~ beta_eff_upper - !~ real, pointer, dimension (:,:) :: H, &! thickness - !~ hmask - - !~ type(ocean_grid_type), pointer :: G - !~ integer :: 0, i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, iegq, jegq, giec, gjec, gisc, gjsc, cnt, isc, jsc, iec, jec, is, js - !~ real :: A, n, ux, uy, vx, vy, eps_min, umid, vmid, unorm, C_basal_friction, n_basal_friction, dxh, dyh, dxdyh - - !~ G => CS%grid - - !~ isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - !~ iscq = G%iscq ; iecq = G%iecq ; jscq = G%jscq ; jecq = G%jecq - !~ isd = G%isd ; jsd = G%jsd ; ied = G%isd ; jed = G%jsd - !~ iegq = G%iegq ; jegq = G%jegq - !~ gisc = G%domain%nx_halo+1 ; gjsc = G%domain%ny_halo+1 - !~ giec = G%domain%nxtot+gisc ; gjec = G%domain%nytot+gjsc - !~ is = iscq - (1-0); js = jscq - (1-0) - - !~ A = CS%A_glen_isothermal ; n = CS%n_glen; eps_min = CS%eps_glen_min - - !~ H => CS%h_shelf - !~ hmask => CS%hmask - !~ nu_upper => CS%ice_visc_upper_tri - !~ nu_lower => CS%ice_visc_lower_tri - !~ beta_eff_upper => CS%taub_beta_eff_upper_tri - !~ beta_eff_lower => CS%taub_beta_eff_lower_tri - - !~ C_basal_friction = CS%C_basal_friction ; n_basal_friction = CS%n_basal_friction - - !~ do i=isd,ied - !~ do j=jsd,jed - - !~ dxh = G%dxh(i,j) - !~ dyh = G%dyh(i,j) - !~ dxdyh = G%dxdyh(i,j) - - !~ if (hmask (i,j) .eq. 1) then - !~ ux = (u(i,j-1)-u(i-1,j-1)) / dxh - !~ vx = (v(i,j-1)-v(i-1,j-1)) / dxh - !~ uy = (u(i-1,j)-u(i-1,j-1)) / dyh - !~ vy = (v(i-1,j)-v(i-1,j-1)) / dyh - - !~ nu_lower(i,j) = A**(-1/n) * (ux**2+vy**2+ux*vy.25*(uy+vx)**2+eps_min**2) ** ((1-n)/(2*n)) * H(i,j) - !~ umid = 1./3 * (u(i-1,j-1)+u(i-1,j)+u(i,j-1)) - !~ vmid = 1./3 * (v(i-1,j-1)+v(i-1,j)+v(i,j-1)) - !~ unorm = sqrt (umid**2+vmid**2+(eps_min*dxh)**2) ; beta_eff_lower (i,j) = C_basal_friction * unorm ** (n_basal_friction-1) - - !~ ux = (u(i,j)-u(i-1,j)) / dxh - !~ vx = (v(i,j)-v(i-1,j)) / dxh - !~ uy = (u(i,j)-u(i,j-1)) / dyh - !~ vy = (u(i,j)-u(i,j-1)) / dyh - - !~ nu_upper(i,j) = A**(-1/n) * (ux**2+vy**2+ux*vy.25*(uy+vx)**2+eps_min**2) ** ((1-n)/(2*n)) * H(i,j) - !~ umid = 1./3 * (u(i,j)+u(i-1,j)+u(i,j-1)) - !~ vmid = 1./3 * (v(i,j)+v(i-1,j)+v(i,j-1)) - !~ unorm = sqrt (umid**2+vmid**2+(eps_min*dxh)**2) ; beta_eff_upper (i,j) = C_basal_friction * unorm ** (n_basal_friction-1) - - !~ endif - !~ enddo - !~ enddo - -!~ end subroutine calc_shelf_visc_triangular - - -!~ subroutine CG_action_triangular (uret, vret, u, v, umask, vmask, hmask, nu_upper, nu_lower, & - !~ beta_upper, beta_lower, dxh, dyh, dxdyh, is, ie, js, je, 0) - -!~ real, dimension (:,:), intent (inout) :: uret, vret -!~ real, dimension (:,:), intent (in) :: u, v -!~ real, dimension (:,:), intent (in) :: umask, vmask -!~ real, dimension (:,:), intent (in) :: hmask, nu_upper, nu_lower, beta_upper, beta_lower -!~ real, dimension (:,:), intent (in) :: dxh, dyh, dxdyh -!~ integer, intent(in) :: is, ie, js, je, 0 - -!~ ! the linear action of the matrix on (u,v) with triangular finite elements -!~ ! as of now everything is passed in so no grid pointers or anything of the sort have to be dereferenced, -!~ ! but this may change pursuant to conversations with others -!~ ! -!~ ! is & ie are the cells over which the iteration is done; this may change between calls to this subroutine -!~ ! in order to make less frequent halo updates -!~ ! isym = 1 if grid is symmetric, 0 o.w. - - !~ real :: ux, uy, vx, vy - !~ integer :: i,j - - !~ do i=is,ie - !~ do j=js,je - - !~ if (hmask(i,j) .eq. 1) then ! this cell's vertices contain degrees of freedom - - !~ ux = (u(i,j-1)-u(i-1,j-1))/dxh(i,j) - !~ vx = (v(i,j-1)-v(i-1,j-1))/dxh(i,j) - !~ uy = (u(i-1,j)-u(i-1,j-1))/dyh(i,j) - !~ vy = (v(i-1,j)-v(i-1,j-1))/dyh(i,j) - - !~ if (umask(i,j-1) .eq. 1) then ! this (bot right) is a degree of freedom node - - !~ uret(i,j-1) = uret(i,j-1) + & - !~ .5 * dxdyh(i,j) * nu_lower (i,j) * ((4*ux+2*vy) * (1./dxh(i,j)) + (uy+vy) * (0./dyh(i,j))) - - !~ vret(i,j-1) = vret(i,j-1) + & - !~ .5 * dxdyh(i,j) * nu_lower (i,j) * ((uy+vx) * (1./dxh(i,j)) + (4*vy+2*ux) * (0./dyh(i,j))) - - !~ uret(i,j-1) = uret(i,j-1) + & - !~ beta_lower(i,j) * dxdyh(i,j) * 1./24 * (u(i-1,j-1) + & - !~ u(i-1,j) + u(i,j-1)) - - !~ vret(i,j-1) = vret(i,j-1) + & - !~ beta_lower(i,j) * dxdyh(i,j) * 1./24 * (v(i-1,j-1) + & - !~ v(i-1,j) + v(i,j-1)) - !~ endif - - !~ if (umask(i-1,j) .eq. 1) then ! this (top left) is a degree of freedom node - - !~ uret(i-1,j) = uret(i-1,j) + & - !~ .5 * dxdyh(i,j) * nu_lower (i,j) * ((4*ux+2*vy) * (0./dxh(i,j)) + (uy+vy) * (1./dyh(i,j))) - - !~ vret(i-1,j) = vret(i-1,j) + & - !~ .5 * dxdyh(i,j) * nu_lower (i,j) * ((uy+vx) * (0./dxh(i,j)) + (4*vy+2*ux) * (1./dyh(i,j))) - - !~ uret(i,j-1) = uret(i,j-1) + & - !~ beta_lower(i,j) * dxdyh(i,j) * 1./24 * (u(i-1,j-1) + & - !~ u(i-1,j) + u(i,j-1)) - - !~ vret(i,j-1) = vret(i,j-1) + & - !~ beta_lower(i,j) * dxdyh(i,j) * 1./24 * (v(i-1,j-1) + & - !~ v(i-1,j) + v(i,j-1)) - !~ endif - - !~ if (umask(i-1,j-1) .eq. 1) then ! this (bot left) is a degree of freedom node - - !~ uret(i-1,j-1) = uret(i-1,j-1) + & - !~ .5 * dxdyh(i,j) * nu_upper (i,j) * ((4*ux+2*vy) * (-1./dxh(i,j)) + (uy+vy) * (-1./dyh(i,j))) - - !~ vret(i-1,j-1) = vret(i-1,j-1) + & - !~ .5 * dxdyh(i,j) * nu_upper (i,j) * ((uy+vx) * (-1./dxh(i,j)) + (4*vy+2*ux) * (-1./dyh(i,j))) - - !~ uret(i-1,j-1) = uret(i-1,j-1) + & - !~ beta_lower(i,j) * dxdyh(i,j) * 1./24 * (u(i-1,j-1) + & - !~ u(i-1,j) + u(i,j-1)) - - !~ vret(i-1,j-1) = vret(i-1,j-1) + & - !~ beta_lower(i,j) * dxdyh(i,j) * 1./24 * (v(i-1,j-1) + & - !~ v(i-1,j) + v(i,j-1)) - !~ endif - - - !~ ux = (u(i,j)-u(i-1,j))/dxh(i,j) - !~ vx = (v(i,j)-v(i-1,j))/dxh(i,j) - !~ uy = (u(i,j)-u(i,j-1))/dyh(i,j) - !~ vy = (v(i,j)-v(i,j-1))/dyh(i,j) - - !~ if (umask(i,j-1) .eq. 1) then ! this (bot right) is a degree of freedom node - - !~ uret(i,j-1) = uret(i,j-1) + & - !~ .5 * dxdyh(i,j) * nu_upper (i,j) * ((4*ux+2*vy) * (0./dxh(i,j)) + (uy+vy) * (-1./dyh(i,j))) - - !~ vret(i,j-1) = vret(i,j-1) + & - !~ .5 * dxdyh(i,j) * nu_upper (i,j) * ((uy+vx) * (0./dxh(i,j)) + (4*vy+2*ux) * (-1./dyh(i,j))) - - !~ uret(i,j-1) = uret(i,j-1) + & - !~ beta_upper(i,j) * dxdyh(i,j) * 1./24 * (u(i,j) + & - !~ u(i-1,j) + u(i,j-1)) - - !~ vret(i,j-1) = vret(i,j-1) + & - !~ beta_upper(i,j) * dxdyh(i,j) * 1./24 * (u(i,j) + & - !~ u(i-1,j) + u(i,j-1)) - !~ endif - - !~ if (umask(i-1,j) .eq. 1) then ! this (top left) is a degree of freedom node - - !~ uret(i-1,j) = uret(i-1,j) + & - !~ .5 * dxdyh(i,j) * nu_upper (i,j) * ((4*ux+2*vy) * (-1./dxh(i,j)) + (uy+vy) * (0./dyh(i,j))) - - !~ vret(i-1,j) = vret(i-1,j) + & - !~ .5 * dxdyh(i,j) * nu_upper (i,j) * ((uy+vx) * (-1./dxh(i,j)) + (4*vy+2*ux) * (0./dyh(i,j))) - - !~ uret(i,j-1) = uret(i,j-1) + & - !~ beta_upper(i,j) * dxdyh(i,j) * 1./24 * (u(i,j) + & - !~ u(i-1,j) + u(i,j-1)) - - !~ vret(i,j-1) = vret(i,j-1) + & - !~ beta_upper(i,j) * dxdyh(i,j) * 1./24 * (u(i,j) + & - !~ u(i-1,j) + u(i,j-1)) - !~ endif - - !~ if (umask(i,j) .eq. 1) then ! this (top right) is a degree of freedom node - - !~ uret(i,j) = uret(i,j) + & - !~ .5 * dxdyh(i,j) * nu_upper (i,j) * ((4*ux+2*vy) * (1./dxh(i,j)) + (uy+vy) * (1./dyh(i,j))) - - !~ vret(i,j) = vret(i,j) + & - !~ .5 * dxdyh(i,j) * nu_upper (i,j) * ((uy+vx) * (1./dxh(i,j)) + (4*vy+2*ux) * (1./dyh(i,j))) - - !~ uret(i,j) = uret(i,j) + & - !~ beta_upper(i,j) * dxdyh(i,j) * 1./24 * (u(i,j) + & - !~ u(i-1,j) + u(i,j-1)) - - !~ vret(i,j) = vret(i,j) + & - !~ beta_upper(i,j) * dxdyh(i,j) * 1./24 * (u(i,j) + & - !~ u(i-1,j) + u(i,j-1)) - !~ endif - - !~ endif - - !~ enddo - !~ enddo - -!~ end subroutine CG_action_triangular - - -END MODULE shelf_triangular_FEstuff diff --git a/src/ice_shelf/user_shelf_init.F90 b/src/ice_shelf/user_shelf_init.F90 index 24afa9026b..2829f712e0 100644 --- a/src/ice_shelf/user_shelf_init.F90 +++ b/src/ice_shelf/user_shelf_init.F90 @@ -1,76 +1,15 @@ +!> This module specifies the initial values and evolving properties of the +!! MOM6 ice shelf, using user-provided code. module user_shelf_init ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Robert Hallberg, April 1994 - June 2002 * -!* * -!* This subroutine initializes the fields for the simulations. * -!* The one argument passed to initialize, Time, is set to the * -!* current time of the simulation. The fields which are initialized * -!* here are: * -!* u - Zonal velocity in m s-1. * -!* v - Meridional velocity in m s-1. * -!* h - Layer thickness in m. (Must be positive.) * -!* D - Basin depth in m. (Must be positive.) * -!* f - The Coriolis parameter, in s-1. * -!* g - The reduced gravity at each interface, in m s-2. * -!* Rlay - Layer potential density (coordinate variable) in kg m-3. * -!* If TEMPERATURE is defined: * -!* T - Temperature in C. * -!* S - Salinity in psu. * -!* If BULKMIXEDLAYER is defined: * -!* Rml - Mixed layer and buffer layer potential densities in * -!* units of kg m-3. * -!* If SPONGE is defined: * -!* A series of subroutine calls are made to set up the damping * -!* rates and reference profiles for all variables that are damped * -!* in the sponge. * -!* Any user provided tracer code is also first linked through this * -!* subroutine. * -!* * -!* Forcing-related fields (taux, tauy, buoy, ustar, etc.) are set * -!* in MOM_surface_forcing.F90. * -!* * -!* These variables are all set in the set of subroutines (in this * -!* file) USER_initialize_bottom_depth, USER_initialize_thickness, * -!* USER_initialize_velocity, USER_initialize_temperature_salinity, * -!* USER_initialize_mixed_layer_density, USER_initialize_sponges, * -!* USER_set_coord, and USER_set_ref_profile. * -!* * -!* The names of these subroutines should be self-explanatory. They * -!* start with "USER_" to indicate that they will likely have to be * -!* modified for each simulation to set the initial conditions and * -!* boundary conditions. Most of these take two arguments: an integer * -!* argument specifying whether the fields are to be calculated * -!* internally or read from a NetCDF file; and a string giving the * -!* path to that file. If the field is initialized internally, the * -!* path is ignored. * -!* * -!* Macros written all in capital letters are defined in MOM_memory.h.* -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q, f * -!* j+1 > o > o > At ^: v, tauy * -!* j x ^ x ^ x At >: u, taux * -!* j > o > o > At o: h, D, buoy, tr, T, S, Rml, ustar * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** - ! use MOM_domains, only : sum_across_PEs use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type use MOM_time_manager, only : time_type, set_time, time_type_to_real - -use mpp_mod, only : mpp_pe, mpp_sync +use MOM_unit_scaling, only : unit_scale_type ! use MOM_io, only : close_file, fieldtype, file_exists ! use MOM_io, only : open_file, read_data, read_axis_data, SINGLE_FILE ! use MOM_io, only : write_field, slasher @@ -80,42 +19,50 @@ module user_shelf_init public USER_initialize_shelf_mass, USER_update_shelf_mass public USER_init_ice_thickness -logical :: first_call = .true. +! 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 user_ice_shelf module type, public :: user_ice_shelf_CS ; private - real :: Rho_ocean ! The ocean's typical density, in kg m-3. - real :: max_draft ! The maximum ocean draft of the ice shelf, in m. - real :: min_draft ! The minimum ocean draft of the ice shelf, in m. - real :: flat_shelf_width ! The range over which the shelf is min_draft thick. - real :: shelf_slope_scale ! The range over which the shelf slopes. - real :: pos_shelf_edge_0 - real :: shelf_speed + real :: Rho_ocean !< The ocean's typical density [kg m-2 Z-1]. + real :: max_draft !< The maximum ocean draft of the ice shelf [Z ~> m]. + real :: min_draft !< The minimum ocean draft of the ice shelf [Z ~> m]. + real :: flat_shelf_width !< The range over which the shelf is min_draft thick [km]. + real :: shelf_slope_scale !< The range over which the shelf slopes [km]. + real :: pos_shelf_edge_0 !< The x-position of the shelf edge at time 0 [km]. + real :: shelf_speed !< The ice shelf speed of translation [km day-1] + logical :: first_call = .true. !< If true, this module has not been called before. end type user_ice_shelf_CS contains -subroutine USER_initialize_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, G, CS, param_file, new_sim) - - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: mass_shelf, area_shelf_h, hmask, h_shelf - type(user_ice_shelf_CS), pointer :: CS - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - logical :: new_sim +!> This subroutine sets up the initial mass and area covered by the ice shelf, based on user-provided code. +subroutine USER_initialize_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, G, US, CS, param_file, new_sim) + + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(out) :: mass_shelf !< The ice shelf mass per unit area averaged + !! over the full ocean cell [kg m-2]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(out) :: h_shelf !< The ice shelf thickness [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(out) :: area_shelf_h !< The area per cell covered by the ice shelf [m2]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(out) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + type(user_ice_shelf_CS), pointer :: CS !< A pointer to the user ice shelf control structure + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + logical, intent(in) :: new_sim !< If true, this is a new run; otherwise it is + !! being started from a restart file. -! Arguments: mass_shelf - The mass per unit area averaged over the full ocean -! cell, in kg m-2. (Intent out) -! (out) area_shelf_h - The area of the ocean cell that is covered by the -! rigid ice shelf, in m2. -! (in) G - The ocean's grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. - - -! just check for cvs ! This subroutine sets up the initial mass and area covered by the ice shelf. - real :: Rho_ocean ! The ocean's typical density, in kg m-3. - real :: max_draft ! The maximum ocean draft of the ice shelf, in m. - real :: min_draft ! The minimum ocean draft of the ice shelf, in m. + real :: Rho_ocean ! The ocean's typical density [kg m-3]. + real :: max_draft ! The maximum ocean draft of the ice shelf [Z ~> m]. + real :: min_draft ! The minimum ocean draft of the ice shelf [Z ~> m]. real :: flat_shelf_width ! The range over which the shelf is min_draft thick. real :: c1 ! The maximum depths in m. character(len=40) :: mdl = "USER_initialize_shelf_mass" ! This subroutine's name. @@ -127,17 +74,18 @@ subroutine USER_initialize_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, if (.not.associated(CS)) allocate(CS) ! Read all relevant parameters and write them to the model log. - if (first_call) call write_user_log(param_file) + 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"//& "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0) + units="kg m-3", default=1035.0, scale=US%Z_to_m) call get_param(param_file, mdl, "SHELF_MAX_DRAFT", CS%max_draft, & - units="m", default=1.0) + units="m", default=1.0, scale=US%m_to_Z) call get_param(param_file, mdl, "SHELF_MIN_DRAFT", CS%min_draft, & - units="m", default=1.0) + units="m", default=1.0, scale=US%m_to_Z) call get_param(param_file, mdl, "FLAT_SHELF_WIDTH", CS%flat_shelf_width, & units="axis_units", default=0.0) call get_param(param_file, mdl, "SHELF_SLOPE_SCALE", CS%shelf_slope_scale, & @@ -149,37 +97,47 @@ subroutine USER_initialize_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, call USER_update_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, G, CS, set_time(0,0), new_sim) - end subroutine USER_initialize_shelf_mass -subroutine USER_init_ice_thickness(h_shelf, area_shelf_h, hmask, G, param_file) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: area_shelf_h, hmask, h_shelf - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters +!> This subroutine updates the ice shelf thickness, as specified by user-provided code. +subroutine USER_init_ice_thickness(h_shelf, area_shelf_h, hmask, G, US, param_file) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(out) :: h_shelf !< The ice shelf thickness [m]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(out) :: area_shelf_h !< The area per cell covered by the ice shelf [m2]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(out) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters ! This subroutine initializes the ice shelf thickness. Currently it does so ! calling USER_initialize_shelf_mass, but this can be revised as needed. real, dimension(SZI_(G),SZJ_(G)) :: mass_shelf type(user_ice_shelf_CS), pointer :: CS => NULL() - call USER_initialize_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, G, CS, param_file, .true.) + call USER_initialize_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, G, US, CS, param_file, .true.) end subroutine USER_init_ice_thickness +!> This subroutine updates the ice shelf mass, as specified by user-provided code. subroutine USER_update_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, G, CS, Time, new_sim) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: mass_shelf, area_shelf_h, hmask, h_shelf - type(user_ice_shelf_CS), pointer :: CS - type(time_type), intent(in) :: Time - logical, intent(in) :: new_sim - -! Arguments: mass_shelf - The mass per unit area averaged over the full ocean -! cell, in kg m-2. (Intent out) -! (out) area_shelf_h - The area of the ocean cell that is covered by the -! rigid ice shelf, in m2. -! (in) G - The ocean's grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: mass_shelf !< The ice shelf mass per unit area averaged + !! over the full ocean cell [kg m-2]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf [m2]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_shelf !< The ice shelf thickness [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + type(user_ice_shelf_CS), pointer :: CS !< A pointer to the user ice shelf control structure + type(time_type), intent(in) :: Time !< The current model time + logical, intent(in) :: new_sim !< If true, this the start of a new run. + real :: c1, edge_pos, slope_pos integer :: i, j @@ -190,17 +148,17 @@ subroutine USER_update_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, G, C c1 = 0.0 ; if (CS%shelf_slope_scale > 0.0) c1 = 1.0 / CS%shelf_slope_scale - do j=G%jsd,G%jed ; + do j=G%jsd,G%jed - if (((j+G%jdg_offset) .le. G%domain%njglobal+G%domain%njhalo) .AND. & - ((j+G%jdg_offset) .ge. G%domain%njhalo+1)) then + if (((j+G%jdg_offset) <= G%domain%njglobal+G%domain%njhalo) .AND. & + ((j+G%jdg_offset) >= G%domain%njhalo+1)) then do i=G%isc,G%iec ! if (((i+G%idg_offset) <= G%domain%niglobal+G%domain%nihalo) .AND. & ! ((i+G%idg_offset) >= G%domain%nihalo+1)) then - if ((j.ge.G%jsc) .and. (j.le.G%jec)) then + if ((j >= G%jsc) .and. (j <= G%jec)) then if (new_sim) then ; if (G%geoLonCu(i-1,j) >= edge_pos) then ! Everything past the edge is open ocean. @@ -232,7 +190,7 @@ subroutine USER_update_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, G, C endif ; endif ; endif - if ((i+G%idg_offset) .eq. G%domain%nihalo+1) then + if ((i+G%idg_offset) == G%domain%nihalo+1) then hmask(i-1,j) = 3.0 endif @@ -240,6 +198,7 @@ subroutine USER_update_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, G, C end subroutine USER_update_shelf_mass +!> This subroutine writes out the user ice shelf code version number to the model log. subroutine write_user_log(param_file) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters @@ -248,7 +207,6 @@ subroutine write_user_log(param_file) character(len=40) :: mdl = "user_shelf_init" ! This module's name. call log_version(param_file, mdl, version, tagname) - first_call = .false. end subroutine write_user_log diff --git a/src/initialization/MOM_coord_initialization.F90 b/src/initialization/MOM_coord_initialization.F90 index 5b4c497bcb..8899627cc7 100644 --- a/src/initialization/MOM_coord_initialization.F90 +++ b/src/initialization/MOM_coord_initialization.F90 @@ -13,6 +13,7 @@ module MOM_coord_initialization use MOM_io, only : open_file, MOM_read_data, read_axis_data, SINGLE_FILE, MULTIPLE use MOM_io, only : slasher, vardesc, write_field, var_desc use MOM_string_functions, only : uppercase +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type, setVerticalGridAxes use user_initialization, only : user_set_coord @@ -24,21 +25,26 @@ module MOM_coord_initialization public MOM_initialize_coord -character(len=40) :: mdl = "MOM_coord_initialization" ! This module's name. +! 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. + +character(len=40) :: mdl = "MOM_coord_initialization" !< This module's name. contains -! ----------------------------------------------------------------------------- !> MOM_initialize_coord sets up time-invariant quantities related to MOM6's !! vertical coordinate. -subroutine MOM_initialize_coord(GV, PF, write_geom, output_dir, tv, max_depth) +subroutine MOM_initialize_coord(GV, US, PF, write_geom, output_dir, tv, max_depth) type(verticalGrid_type), intent(inout) :: GV !< Ocean vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: PF !< A structure indicating the open file !! to parse for model parameter values. logical, intent(in) :: write_geom !< If true, write grid geometry files. character(len=*), intent(in) :: output_dir !< The directory into which to write files. type(thermo_var_ptrs), intent(inout) :: tv !< The thermodynamic variable structure. - real, intent(in) :: max_depth !< The ocean's maximum depth, in m. + real, intent(in) :: max_depth !< The ocean's maximum depth [Z ~> m]. ! Local character(len=200) :: config logical :: debug @@ -77,30 +83,30 @@ subroutine MOM_initialize_coord(GV, PF, write_geom, output_dir, tv, max_depth) fail_if_missing=.true.) select case ( trim(config) ) case ("gprime") - call set_coord_from_gprime(GV%Rlay, GV%g_prime, GV, PF) + call set_coord_from_gprime(GV%Rlay, GV%g_prime, GV, US, PF) case ("layer_ref") - call set_coord_from_layer_density(GV%Rlay, GV%g_prime, GV, PF) + call set_coord_from_layer_density(GV%Rlay, GV%g_prime, GV, US, PF) case ("linear") - call set_coord_linear(GV%Rlay, GV%g_prime, GV, PF) + call set_coord_linear(GV%Rlay, GV%g_prime, GV, US, PF) case ("ts_ref") - call set_coord_from_ts_ref(GV%Rlay, GV%g_prime, GV, PF, eos, tv%P_Ref) + call set_coord_from_ts_ref(GV%Rlay, GV%g_prime, GV, US, PF, eos, tv%P_Ref) case ("ts_profile") - call set_coord_from_TS_profile(GV%Rlay, GV%g_prime, GV, PF, eos, tv%P_Ref) + call set_coord_from_TS_profile(GV%Rlay, GV%g_prime, GV, US, PF, eos, tv%P_Ref) case ("ts_range") - call set_coord_from_TS_range(GV%Rlay, GV%g_prime, GV, PF, eos, tv%P_Ref) + call set_coord_from_TS_range(GV%Rlay, GV%g_prime, GV, US, PF, eos, tv%P_Ref) case ("file") - call set_coord_from_file(GV%Rlay, GV%g_prime, GV, PF) + call set_coord_from_file(GV%Rlay, GV%g_prime, GV, US, PF) case ("USER") call user_set_coord(GV%Rlay, GV%g_prime, GV, PF, eos) case ("BFB") call BFB_set_coord(GV%Rlay, GV%g_prime, GV, PF, eos) case ("none", "ALE") - call set_coord_to_none(GV%Rlay, GV%g_prime, GV, PF) + call set_coord_to_none(GV%Rlay, GV%g_prime, GV, US, PF) case default ; call MOM_error(FATAL,"MOM_initialize_coord: "// & "Unrecognized coordinate setup"//trim(config)) end select if (debug) call chksum(GV%Rlay, "MOM_initialize_coord: Rlay ", 1, nz) - if (debug) call chksum(GV%g_prime, "MOM_initialize_coord: g_prime ", 1, nz) + if (debug) call chksum(US%m_to_Z*GV%g_prime(:), "MOM_initialize_coord: g_prime ", 1, nz) call setVerticalGridAxes( GV%Rlay, GV ) ! Copy the maximum depth across from the input argument @@ -112,27 +118,21 @@ subroutine MOM_initialize_coord(GV, PF, write_geom, output_dir, tv, max_depth) call callTree_leave('MOM_initialize_coord()') end subroutine MOM_initialize_coord -! ----------------------------------------------------------------------------- -! The set_coord routines deal with initializing aspects of the vertical grid. -! ----------------------------------------------------------------------------- -subroutine set_coord_from_gprime(Rlay, g_prime, GV, param_file) +! The set_coord routines deal with initializing aspects of the vertical grid. + +!> Sets the layer densities (Rlay) and the interface reduced gravities (g). +subroutine set_coord_from_gprime(Rlay, g_prime, GV, US, param_file) real, dimension(:), intent(out) :: Rlay !< The layers' target coordinate values - !! (potential density). - real, dimension(:), intent(out) :: g_prime !< A structure indicating the open file to - !! parse for model parameter values. + !! (potential density) [kg m-3]. + real, dimension(:), intent(out) :: g_prime !< The reduced gravity across the interfaces + !! [m2 Z-1 s-2 ~> m s-2]. 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 -! Arguments: Rlay - the layers' target coordinate values (potential density). -! (out) g_prime - the reduced gravity across the interfaces, in m s-2. -! (in) GV - The ocean's vertical grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. - -! This subroutine sets the layer densities (Rlay) and the interface ! -! reduced gravities (g). ! - real :: g_int ! Reduced gravities across the internal interfaces, in m s-2. - real :: g_fs ! Reduced gravity across the free surface, in m s-2. + ! Local variables + real :: g_int ! Reduced gravities across the internal interfaces [m s-2]. + real :: g_fs ! Reduced gravity across the free surface [m s-2]. character(len=40) :: mdl = "set_coord_from_gprime" ! This subroutine's name. integer :: k, nz nz = GV%ke @@ -141,10 +141,10 @@ subroutine set_coord_from_gprime(Rlay, g_prime, GV, param_file) call get_param(param_file, mdl, "GFS" , g_fs, & "The reduced gravity at the free surface.", units="m s-2", & - default=GV%g_Earth) + default=(GV%g_Earth*US%m_to_Z), scale=US%Z_to_m) call get_param(param_file, mdl, "GINT", g_int, & "The reduced gravity across internal interfaces.", & - units="m s-2", fail_if_missing=.true.) + units="m s-2", fail_if_missing=.true., scale=US%Z_to_m) g_prime(1) = g_fs do k=2,nz ; g_prime(k) = g_int ; enddo @@ -154,27 +154,20 @@ subroutine set_coord_from_gprime(Rlay, g_prime, GV, param_file) call callTree_leave(trim(mdl)//'()') end subroutine set_coord_from_gprime -! ----------------------------------------------------------------------------- -! ----------------------------------------------------------------------------- -subroutine set_coord_from_layer_density(Rlay, g_prime, GV, param_file) +!> Sets the layer densities (Rlay) and the interface reduced gravities (g). +subroutine set_coord_from_layer_density(Rlay, g_prime, GV, US, param_file) real, dimension(:), intent(out) :: Rlay !< The layers' target coordinate values - !! (potential density). - real, dimension(:), intent(out) :: g_prime !< The reduced gravity across the interfaces, - !! in m s-2. + !! (potential density) [kg m-3]. + real, dimension(:), intent(out) :: g_prime !< The reduced gravity across the interfaces + !! [m2 Z-1 s-2 ~> m s-2]. 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 -! Arguments: Rlay - the layers' target coordinate values (potential density). -! (out) g_prime - the reduced gravity across the interfaces, in m s-2. -! (in) GV - The ocean's vertical grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. - -! This subroutine sets the layer densities (Rlay) and the interface ! -! reduced gravities (g). ! - real :: g_fs ! Reduced gravity across the free surface, in m s-2. - real :: Rlay_Ref! The surface layer's target density, in kg m-3. - real :: RLay_range ! The range of densities, in kg m-3. + ! Local variables + real :: g_fs ! Reduced gravity across the free surface [m s-2]. + real :: Rlay_Ref! The surface layer's target density [kg m-3]. + real :: RLay_range ! The range of densities [kg m-3]. character(len=40) :: mdl = "set_coord_from_layer_density" ! This subroutine's name. integer :: k, nz nz = GV%ke @@ -183,7 +176,7 @@ subroutine set_coord_from_layer_density(Rlay, g_prime, GV, param_file) call get_param(param_file, mdl, "GFS", g_fs, & "The reduced gravity at the free surface.", units="m s-2", & - default=GV%g_Earth) + default=(GV%g_Earth*US%m_to_Z), scale=US%Z_to_m) call get_param(param_file, mdl, "LIGHTEST_DENSITY", Rlay_Ref, & "The reference potential density used for layer 1.", & units="kg m-3", default=GV%Rho0) @@ -203,35 +196,25 @@ subroutine set_coord_from_layer_density(Rlay, g_prime, GV, param_file) call callTree_leave(trim(mdl)//'()') end subroutine set_coord_from_layer_density -! ----------------------------------------------------------------------------- -! ----------------------------------------------------------------------------- -subroutine set_coord_from_TS_ref(Rlay, g_prime, GV, param_file, eqn_of_state, & +!> Sets the layer densities (Rlay) and the interface reduced gravities (g) from a profile of g'. +subroutine set_coord_from_TS_ref(Rlay, g_prime, GV, US, param_file, eqn_of_state, & P_Ref) real, dimension(:), intent(out) :: Rlay !< The layers' target coordinate values - !! (potential density). - real, dimension(:), intent(out) :: g_prime !< the reduced gravity across the interfaces, - !! in m s-2. + !! (potential density) [kg m-3]. + real, dimension(:), intent(out) :: g_prime !< The reduced gravity across the interfaces + !! [m2 Z-1 s-2 ~> m s-2]. 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(EOS_type), pointer :: eqn_of_state !< integer selecting the equation of state. - real, intent(in) :: P_Ref !< The coordinate-density reference pressure - !! in Pa. -! Arguments: Rlay - the layers' target coordinate values (potential density). -! (out) g_prime - the reduced gravity across the interfaces, in m s-2. -! (in) GV - The ocean's vertical grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in) eqn_of_state - integer selecting the equation of state -! (in) P_Ref - The coordinate-density reference pressure in Pa. - -! This subroutine sets the layer densities (Rlay) and the interface ! -! reduced gravities (g). ! + real, intent(in) :: P_Ref !< The coordinate-density reference pressure [Pa]. + ! Local variables real :: T_ref ! Reference temperature real :: S_ref ! Reference salinity - real :: g_int ! Reduced gravities across the internal interfaces, in m s-2. - real :: g_fs ! Reduced gravity across the free surface, in m s-2. + real :: g_int ! Reduced gravities across the internal interfaces [m s-2]. + real :: g_fs ! Reduced gravity across the free surface [m s-2]. character(len=40) :: mdl = "set_coord_from_TS_ref" ! This subroutine's name. integer :: k, nz nz = GV%ke @@ -245,10 +228,10 @@ subroutine set_coord_from_TS_ref(Rlay, g_prime, GV, param_file, eqn_of_state, & "The initial salinities.", units="PSU", default=35.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) + default=(GV%g_Earth*US%m_to_Z), scale=US%Z_to_m) call get_param(param_file, mdl, "GINT", g_int, & "The reduced gravity across internal interfaces.", & - units="m s-2", fail_if_missing=.true.) + units="m s-2", fail_if_missing=.true., scale=US%Z_to_m) ! ! These statements set the interface reduced gravities. ! g_prime(1) = g_fs @@ -264,33 +247,23 @@ subroutine set_coord_from_TS_ref(Rlay, g_prime, GV, param_file, eqn_of_state, & call callTree_leave(trim(mdl)//'()') end subroutine set_coord_from_TS_ref -! ----------------------------------------------------------------------------- -! ----------------------------------------------------------------------------- -subroutine set_coord_from_TS_profile(Rlay, g_prime, GV, param_file, & +!> Sets the layer densities (Rlay) and the interface reduced gravities (g) from a T-S profile. +subroutine set_coord_from_TS_profile(Rlay, g_prime, GV, US, param_file, & eqn_of_state, P_Ref) real, dimension(:), intent(out) :: Rlay !< The layers' target coordinate values - !! (potential density). - real, dimension(:), intent(out) :: g_prime !< The reduced gravity across the interfaces, - !! in m s-2. + !! (potential density) [kg m-3]. + real, dimension(:), intent(out) :: g_prime !< The reduced gravity across the interfaces + !! [m2 Z-1 s-2 ~> m s-2]. 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(EOS_type), pointer :: eqn_of_state !< integer that selects equation of state. - real, intent(in) :: P_Ref !< The coordinate-density reference pressure - !! in Pa. -! Arguments: Rlay - the layers' target coordinate values (potential density). -! (out) g_prime - the reduced gravity across the interfaces, in m s-2. -! (in) GV - The ocean's vertical grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in) eqn_of_state - integer that selects equation of state -! (in) P_Ref - The coordinate-density reference pressure in Pa. - -! This subroutine sets the layer densities (Rlay) and the interface ! -! reduced gravities (g). ! + real, intent(in) :: P_Ref !< The coordinate-density reference pressure [Pa]. + ! Local variables real, dimension(GV%ke) :: T0, S0, Pref - real :: g_fs ! Reduced gravity across the free surface, in m s-2. + real :: g_fs ! Reduced gravity across the free surface [m s-2]. integer :: k, nz character(len=40) :: mdl = "set_coord_from_TS_profile" ! This subroutine's name. character(len=200) :: filename, coord_file, inputdir ! Strings for file/path @@ -300,7 +273,7 @@ subroutine set_coord_from_TS_profile(Rlay, g_prime, GV, param_file, & call get_param(param_file, mdl, "GFS", g_fs, & "The reduced gravity at the free surface.", units="m s-2", & - default=GV%g_Earth) + 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"//& "salinities are read.", fail_if_missing=.true.) @@ -318,43 +291,34 @@ subroutine set_coord_from_TS_profile(Rlay, g_prime, GV, param_file, & g_prime(1) = g_fs do k=1,nz ; Pref(k) = P_ref ; enddo call calculate_density(T0, S0, Pref, Rlay, 1,nz,eqn_of_state) - do k=2,nz; g_prime(k) = (GV%g_Earth/GV%Rho0) * (Rlay(k) - Rlay(k-1)); enddo + do k=2,nz; g_prime(k) = (GV%g_Earth/GV%Rho0) * (Rlay(k) - Rlay(k-1)) ; enddo call callTree_leave(trim(mdl)//'()') end subroutine set_coord_from_TS_profile -! ----------------------------------------------------------------------------- -! ----------------------------------------------------------------------------- -subroutine set_coord_from_TS_range(Rlay, g_prime, GV, param_file, & +!> Sets the layer densities (Rlay) and the interface reduced gravities (g) from a linear T-S profile. +subroutine set_coord_from_TS_range(Rlay, g_prime, GV, US, param_file, & eqn_of_state, P_Ref) real, dimension(:), intent(out) :: Rlay !< The layers' target coordinate values - !! (potential density). - real, dimension(:), intent(out) :: g_prime !< The reduced gravity across the interfaces, - !! in m s-2. + !! (potential density) [kg m-3]. + real, dimension(:), intent(out) :: g_prime !< The reduced gravity across the interfaces + !! [m2 Z-1 s-2 ~> m s-2]. 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(EOS_type), pointer :: eqn_of_state !< integer that selects equation of state - real, intent(in) :: P_Ref !< The coordinate-density reference pressure - !! in Pa. -! Arguments: Rlay - the layers' target coordinate values (potential density). -! (out) g_prime - the reduced gravity across the interfaces, in m s-2. -! (in) GV - The ocean's vertical grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in) eqn_of_state - integer that selects equation of state -! (in) P_Ref - The coordinate-density reference pressure in Pa. - -! This subroutine sets the layer densities (Rlay) and the interface ! -! reduced gravities (g). ! + real, intent(in) :: P_Ref !< The coordinate-density reference pressure [Pa] + + ! Local variables real, dimension(GV%ke) :: T0, S0, Pref - real :: S_Ref, S_Light, S_Dense ! Salinity range parameters in PSU. - real :: T_Ref, T_Light, T_Dense ! Temperature range parameters in dec C. + real :: S_Ref, S_Light, S_Dense ! Salinity range parameters [ppt]. + real :: T_Ref, T_Light, T_Dense ! Temperature range parameters [decC]. real :: res_rat ! The ratio of density space resolution in the denser part ! of the range to that in the lighter part of the range. ! Setting this greater than 1 increases the resolution for ! the denser water. - real :: g_fs ! Reduced gravity across the free surface, in m s-2. + real :: g_fs ! Reduced gravity across the free surface [m s-2]. real :: a1, frac_dense, k_frac integer :: k, nz, k_light character(len=40) :: mdl = "set_coord_from_TS_range" ! This subroutine's name. @@ -390,7 +354,7 @@ subroutine set_coord_from_TS_range(Rlay, g_prime, GV, param_file, & call get_param(param_file, mdl, "GFS", g_fs, & "The reduced gravity at the free surface.", units="m s-2", & - default=GV%g_Earth) + default=(GV%g_Earth*US%m_to_Z), scale=US%Z_to_m) k_light = GV%nk_rho_varies + 1 @@ -415,25 +379,18 @@ subroutine set_coord_from_TS_range(Rlay, g_prime, GV, param_file, & call callTree_leave(trim(mdl)//'()') end subroutine set_coord_from_TS_range -! ----------------------------------------------------------------------------- -! ----------------------------------------------------------------------------- -subroutine set_coord_from_file(Rlay, g_prime, GV, param_file) +! Sets the layer densities (Rlay) and the interface reduced gravities (g) from data in file. +subroutine set_coord_from_file(Rlay, g_prime, GV, US, param_file) real, dimension(:), intent(out) :: Rlay !< The layers' target coordinate values - !! (potential density). - real, dimension(:), intent(out) :: g_prime !< The reduced gravity across the interfaces, - !! in m s-2. + !! (potential density) [kg m-3]. + real, dimension(:), intent(out) :: g_prime !< The reduced gravity across the interfaces + !! [m2 Z-1 s-2 ~> m s-2]. 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 -! Arguments: Rlay - the layers' target coordinate values (potential density). -! (out) g_prime - the reduced gravity across the interfaces, in m s-2. -! (in) GV - The ocean's vertical grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. - -! This subroutine sets the layer densities (Rlay) and the interface ! -! reduced gravities (g). ! - real :: g_fs ! Reduced gravity across the free surface, in m s-2. + ! Local variables + real :: g_fs ! Reduced gravity across the free surface [m s-2]. integer :: k, nz character(len=40) :: mdl = "set_coord_from_file" ! This subroutine's name. character(len=40) :: coord_var @@ -444,7 +401,7 @@ subroutine set_coord_from_file(Rlay, g_prime, GV, param_file) call get_param(param_file, mdl, "GFS", g_fs, & "The reduced gravity at the free surface.", units="m s-2", & - default=GV%g_Earth) + default=(GV%g_Earth*US%m_to_Z), scale=US%Z_to_m) call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") inputdir = slasher(inputdir) call get_param(param_file, mdl, "COORD_FILE", coord_file, & @@ -469,27 +426,21 @@ subroutine set_coord_from_file(Rlay, g_prime, GV, param_file) call callTree_leave(trim(mdl)//'()') end subroutine set_coord_from_file -! ----------------------------------------------------------------------------- -! ----------------------------------------------------------------------------- -subroutine set_coord_linear(Rlay, g_prime, GV, param_file) +!> Sets the layer densities (Rlay) and the interface +!! reduced gravities (g) according to a linear profile starting at a +!! reference surface layer density and spanning a range of densities +!! to the bottom defined by the parameter RLAY_RANGE +!! (defaulting to 2.0 if not defined) +subroutine set_coord_linear(Rlay, g_prime, GV, US, param_file) real, dimension(:), intent(out) :: Rlay !< The layers' target coordinate values - !! (potential density). - real, dimension(:), intent(out) :: g_prime !< The reduced gravity across the interfaces, - !! in m s-2. + !! (potential density) [kg m-3]. + real, dimension(:), intent(out) :: g_prime !< The reduced gravity across the interfaces + !! [m2 Z-1 s-2 ~> m s-2]. 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 -! Arguments: Rlay - the layers' target coordinate values (potential density). -! (out) g_prime - the reduced gravity across the interfaces, in m s-2. -! (in) GV - The ocean's vertical grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. - -! This subroutine sets the layer densities (Rlay) and the interface -! reduced gravities (g) according to a linear profile starting at a -! reference surface layer density and spanning a range of densities -! to the bottom defined by the parameter RLAY_RANGE -! (defaulting to 2.0 if not defined) + ! Local variables character(len=40) :: mdl = "set_coord_linear" ! This subroutine real :: Rlay_ref, Rlay_range, g_fs integer :: k, nz @@ -505,7 +456,7 @@ subroutine set_coord_linear(Rlay, g_prime, GV, param_file) "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) + default=(GV%g_Earth*US%m_to_Z), scale=US%Z_to_m) ! This following sets the target layer densities such that a the ! surface interface has density Rlay_ref and the bottom @@ -525,14 +476,16 @@ end subroutine set_coord_linear !> Sets Rlay to Rho0 and g_prime to zero except for the free surface. !! This is for use only in ALE mode where Rlay should not be used and g_prime(1) alone !! might be used. -subroutine set_coord_to_none(Rlay, g_prime, GV, param_file) +subroutine set_coord_to_none(Rlay, g_prime, GV, US, param_file) real, dimension(:), intent(out) :: Rlay !< The layers' target coordinate values - !! (potential density). - real, dimension(:), intent(out) :: g_prime !< A structure indicating the open file to - !! parse for model parameter values. + !! (potential density) [kg m-3]. + real, dimension(:), intent(out) :: g_prime !< The reduced gravity across the interfaces, + !! [m2 Z-1 s-2 ~> m s-2]. 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 - real :: g_fs ! Reduced gravity across the free surface, in m s-2. + ! Local variables + real :: g_fs ! Reduced gravity across the free surface [m s-2]. character(len=40) :: mdl = "set_coord_to_none" ! This subroutine's name. integer :: k, nz nz = GV%ke @@ -541,7 +494,7 @@ subroutine set_coord_to_none(Rlay, g_prime, GV, param_file) call get_param(param_file, mdl, "GFS" , g_fs, & "The reduced gravity at the free surface.", units="m s-2", & - default=GV%g_Earth) + default=(GV%g_Earth*US%m_to_Z), scale=US%Z_to_m) g_prime(1) = g_fs do k=2,nz ; g_prime(k) = 0. ; enddo @@ -552,18 +505,13 @@ subroutine set_coord_to_none(Rlay, g_prime, GV, param_file) end subroutine set_coord_to_none -!> This subroutine writes out a file containing any available data related +!> Writes out a file containing any available data related !! to the vertical grid used by the MOM ocean model. subroutine write_vertgrid_file(GV, param_file, directory) type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters character(len=*), intent(in) :: directory !< The directory into which to place the file. -! This subroutine writes out a file containing any available data related -! to the vertical grid used by the MOM ocean model. -! Arguments: GV - The container for the vertical grid data. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in) directory - The directory into which to place the file. + ! Local variables character(len=240) :: filepath type(vardesc) :: vars(2) type(fieldtype) :: fields(2) @@ -577,11 +525,10 @@ subroutine write_vertgrid_file(GV, param_file, directory) call create_file(unit, trim(filepath), vars, 2, fields, SINGLE_FILE, GV=GV) call write_field(unit, fields(1), GV%Rlay) - call write_field(unit, fields(2), GV%g_prime) + call write_field(unit, fields(2), GV%g_prime) !### RESCALE THIS? call close_file(unit) end subroutine write_vertgrid_file -! ----------------------------------------------------------------------------- end module MOM_coord_initialization diff --git a/src/initialization/MOM_fixed_initialization.F90 b/src/initialization/MOM_fixed_initialization.F90 index 7aff08540a..c2f188bc6f 100644 --- a/src/initialization/MOM_fixed_initialization.F90 +++ b/src/initialization/MOM_fixed_initialization.F90 @@ -6,7 +6,7 @@ module MOM_fixed_initialization use MOM_debugging, only : hchksum, qchksum, uvchksum use MOM_domains, only : pass_var -use MOM_dyn_horgrid, only : dyn_horgrid_type +use MOM_dyn_horgrid, only : dyn_horgrid_type, rescale_dyn_horgrid_bathymetry use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint use MOM_file_parser, only : get_param, read_param, log_param, param_file_type @@ -25,6 +25,7 @@ module MOM_fixed_initialization use MOM_shared_initialization, only : reset_face_lengths_named, reset_face_lengths_file, reset_face_lengths_list use MOM_shared_initialization, only : read_face_length_list, set_velocity_depth_max, set_velocity_depth_min use MOM_shared_initialization, only : compute_global_grid_integrals, write_ocean_geometry_file +use MOM_unit_scaling, only : unit_scale_type use user_initialization, only : user_initialize_topography use DOME_initialization, only : DOME_initialize_topography @@ -37,7 +38,6 @@ module MOM_fixed_initialization use seamount_initialization, only : seamount_initialize_topography use dumbbell_initialization, only : dumbbell_initialize_topography use shelfwave_initialization, only : shelfwave_initialize_topography -use supercritical_initialization, only : supercritical_initialize_topography use Phillips_initialization, only : Phillips_initialize_topography use dense_water_initialization, only : dense_water_initialize_topography @@ -52,8 +52,9 @@ module MOM_fixed_initialization ! ----------------------------------------------------------------------------- !> MOM_initialize_fixed sets up time-invariant quantities related to MOM6's !! horizontal grid, bathymetry, and the Coriolis parameter. -subroutine MOM_initialize_fixed(G, OBC, PF, write_geom, output_dir) +subroutine MOM_initialize_fixed(G, US, OBC, PF, write_geom, output_dir) type(dyn_horgrid_type), intent(inout) :: G !< The ocean's grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(ocean_OBC_type), pointer :: OBC !< Open boundary structure. type(param_file_type), intent(in) :: PF !< A structure indicating the open file !! to parse for model parameter values. @@ -76,38 +77,39 @@ subroutine MOM_initialize_fixed(G, OBC, PF, write_geom, output_dir) "The directory in which input files are found.", default=".") inputdir = slasher(inputdir) -! Set up the parameters of the physical domain (i.e. the grid), G + ! Set up the parameters of the physical domain (i.e. the grid), G call set_grid_metrics(G, PF) -! Set up the bottom depth, G%bathyT either analytically or from file -! This also sets G%max_depth based on the input parameter MAXIMUM_DEPTH, -! or, if absent, is diagnosed as G%max_depth = max( G%D(:,:) ) - call MOM_initialize_topography(G%bathyT, G%max_depth, G, PF) + ! Set up the bottom depth, G%bathyT either analytically or from file + ! This also sets G%max_depth based on the input parameter MAXIMUM_DEPTH, + ! or, if absent, is diagnosed as G%max_depth = max( G%D(:,:) ) + call MOM_initialize_topography(G%bathyT, G%max_depth, G, PF, US) +! call rescale_dyn_horgrid_bathymetry(G, US%Z_to_m) ! To initialize masks, the bathymetry in halo regions must be filled in call pass_var(G%bathyT, G%Domain) -! Determine the position of any open boundaries - call open_boundary_config(G, PF, OBC) + ! Determine the position of any open boundaries + call open_boundary_config(G, US, PF, OBC) ! Make bathymetry consistent with open boundaries call open_boundary_impose_normal_slope(OBC, G, G%bathyT) ! This call sets masks that prohibit flow over any point interpreted as land - call initialize_masks(G, PF) + call initialize_masks(G, PF, US) ! Make OBC mask consistent with land mask call open_boundary_impose_land_mask(OBC, G, G%areaCu, G%areaCv) if (debug) then - call hchksum(G%bathyT, 'MOM_initialize_fixed: depth ', G%HI, haloshift=1) + call hchksum(G%bathyT, 'MOM_initialize_fixed: depth ', G%HI, haloshift=1, scale=US%Z_to_m) call hchksum(G%mask2dT, 'MOM_initialize_fixed: mask2dT ', G%HI) call uvchksum('MOM_initialize_fixed: mask2dC[uv]', G%mask2dCu, & G%mask2dCv, G%HI) call qchksum(G%mask2dBu, 'MOM_initialize_fixed: mask2dBu ', G%HI) endif -! Modulate geometric scales according to geography. + ! Modulate geometric scales according to geography. call get_param(PF, mdl, "CHANNEL_CONFIG", config, & "A parameter that determines which set of channels are \n"//& "restricted to specific widths. Options are:\n"//& @@ -129,7 +131,7 @@ subroutine MOM_initialize_fixed(G, OBC, PF, write_geom, output_dir) "Unrecognized channel configuration "//trim(config)) end select -! This call sets the topography at velocity points. + ! 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"//& @@ -144,7 +146,7 @@ subroutine MOM_initialize_fixed(G, OBC, PF, write_geom, output_dir) endif ! Calculate the value of the Coriolis parameter at the latitude ! -! of the q grid points, in s-1. +! of the q grid points [s-1]. call MOM_initialize_rotation(G%CoriolisBu, G, PF) ! Calculate the components of grad f (beta) call MOM_calculate_grad_Coriolis(G%dF_dx, G%dF_dy, G) @@ -160,27 +162,34 @@ subroutine MOM_initialize_fixed(G, OBC, PF, write_geom, output_dir) call compute_global_grid_integrals(G) ! Write out all of the grid data used by this run. - if (write_geom) call write_ocean_geometry_file(G, PF, output_dir) + if (write_geom) call write_ocean_geometry_file(G, PF, output_dir, US=US) call callTree_leave('MOM_initialize_fixed()') end subroutine MOM_initialize_fixed -!> MOM_initialize_topography makes the appropriate call to set up the bathymetry. -subroutine MOM_initialize_topography(D, max_depth, G, PF) +!> MOM_initialize_topography makes the appropriate call to set up the bathymetry. At this +!! point the topography is in units of [m], but this can be changed later. +subroutine MOM_initialize_topography(D, max_depth, G, PF, US) type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(out) :: D !< Ocean bottom depth in m + intent(out) :: D !< Ocean bottom depth [m] type(param_file_type), intent(in) :: PF !< Parameter file structure - real, intent(out) :: max_depth !< Maximum depth of model in m + real, intent(out) :: max_depth !< Maximum depth of model [m] + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type -! This subroutine makes the appropriate call to set up the bottom depth. -! This is a separate subroutine so that it can be made public and shared with -! the ice-sheet code or other components. -! Set up the bottom depth, G%bathyT either analytically or from file + ! This subroutine makes the appropriate call to set up the bottom depth. + ! This is a separate subroutine so that it can be made public and shared with + ! the ice-sheet code or other components. + + ! Local variables + real :: m_to_Z, Z_to_m ! Dimensional rescaling factors character(len=40) :: mdl = "MOM_initialize_topography" ! This subroutine's name. character(len=200) :: config + m_to_Z = 1.0 ; if (present(US)) m_to_Z = US%m_to_Z + Z_to_m = 1.0 ; if (present(US)) Z_to_m = US%Z_to_m + call get_param(PF, mdl, "TOPO_CONFIG", config, & "This specifies how bathymetry is specified: \n"//& " \t file - read bathymetric information from the file \n"//& @@ -204,45 +213,43 @@ subroutine MOM_initialize_topography(D, max_depth, G, PF) " \t seamount - Gaussian bump for spontaneous motion test case.\n"//& " \t dumbbell - Sloshing channel with reservoirs on both ends.\n"//& " \t shelfwave - exponential slope for shelfwave test case.\n"//& - " \t supercritical - flat but with 8.95 degree land mask.\n"//& " \t Phillips - ACC-like idealized topography used in the Phillips config.\n"//& " \t dense - Denmark Strait-like dense water formation and overflow.\n"//& " \t USER - call a user modified routine.", & fail_if_missing=.true.) - max_depth = -1.e9; call read_param(PF, "MAXIMUM_DEPTH", max_depth) + max_depth = -1.e9*m_to_Z ; call read_param(PF, "MAXIMUM_DEPTH", max_depth, scale=m_to_Z) select case ( trim(config) ) - case ("file"); call initialize_topography_from_file(D, G, PF) - case ("flat"); call initialize_topography_named(D, G, PF, config, max_depth) - case ("spoon"); call initialize_topography_named(D, G, PF, config, max_depth) - case ("bowl"); call initialize_topography_named(D, G, PF, config, max_depth) - case ("halfpipe"); call initialize_topography_named(D, G, PF, config, max_depth) - case ("DOME"); call DOME_initialize_topography(D, G, PF, max_depth) - case ("ISOMIP"); call ISOMIP_initialize_topography(D, G, PF, max_depth) - case ("benchmark"); call benchmark_initialize_topography(D, G, PF, max_depth) + case ("file"); call initialize_topography_from_file(D, G, PF, US) + case ("flat"); call initialize_topography_named(D, G, PF, config, max_depth, US) + case ("spoon"); call initialize_topography_named(D, G, PF, config, max_depth, US) + case ("bowl"); call initialize_topography_named(D, G, PF, config, max_depth, US) + case ("halfpipe"); call initialize_topography_named(D, G, PF, config, max_depth, US) + case ("DOME"); call DOME_initialize_topography(D, G, PF, max_depth, US) + case ("ISOMIP"); call ISOMIP_initialize_topography(D, G, PF, max_depth, US) + case ("benchmark"); call benchmark_initialize_topography(D, G, PF, max_depth, US) case ("Neverland"); call Neverland_initialize_topography(D, G, PF, max_depth) case ("DOME2D"); call DOME2d_initialize_topography(D, G, PF, max_depth) - case ("Kelvin"); call Kelvin_initialize_topography(D, G, PF, max_depth) + case ("Kelvin"); call Kelvin_initialize_topography(D, G, PF, max_depth, US) case ("sloshing"); call sloshing_initialize_topography(D, G, PF, max_depth) case ("seamount"); call seamount_initialize_topography(D, G, PF, max_depth) - case ("dumbbell"); call dumbbell_initialize_topography(D, G, PF, max_depth) - case ("shelfwave"); call shelfwave_initialize_topography(D, G, PF, max_depth) - case ("supercritical"); call supercritical_initialize_topography(D, G, PF, max_depth) - case ("Phillips"); call Phillips_initialize_topography(D, G, PF, max_depth) + case ("dumbbell"); call dumbbell_initialize_topography(D, G, PF, max_depth) + case ("shelfwave"); call shelfwave_initialize_topography(D, G, PF, max_depth, US) + case ("Phillips"); call Phillips_initialize_topography(D, G, PF, max_depth, US) case ("dense"); call dense_water_initialize_topography(D, G, PF, max_depth) - case ("USER"); call user_initialize_topography(D, G, PF, max_depth) + case ("USER"); call user_initialize_topography(D, G, PF, max_depth, US) case default ; call MOM_error(FATAL,"MOM_initialize_topography: "// & "Unrecognized topography setup '"//trim(config)//"'") end select if (max_depth>0.) then - call log_param(PF, mdl, "MAXIMUM_DEPTH", max_depth, & + call log_param(PF, mdl, "MAXIMUM_DEPTH", max_depth*Z_to_m, & "The maximum depth of the ocean.", units="m") else max_depth = diagnoseMaximumDepth(D,G) - call log_param(PF, mdl, "!MAXIMUM_DEPTH", max_depth, & + call log_param(PF, mdl, "!MAXIMUM_DEPTH", max_depth*Z_to_m, & "The (diagnosed) maximum depth of the ocean.", units="m") endif - if (trim(config) .ne. "DOME") then - call limit_topography(D, G, PF, max_depth) + if (trim(config) /= "DOME") then + call limit_topography(D, G, PF, max_depth, US) endif end subroutine MOM_initialize_topography diff --git a/src/initialization/MOM_grid_initialize.F90 b/src/initialization/MOM_grid_initialize.F90 index 7709af5d0e..3da13a3063 100644 --- a/src/initialization/MOM_grid_initialize.F90 +++ b/src/initialization/MOM_grid_initialize.F90 @@ -1,54 +1,8 @@ +!> Initializes horizontal grid module MOM_grid_initialize ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Robert Hallberg, November 1998 - June 2002 * -!* * -!* This program contains 2 externally callable subroutines. * -!* set_grid_metrics calculates the various metric terms that are used * -!* by MOM. This routine is intended to be modified by the user to * -!* enable the use of any general orthogonal grid. initialize_masks * -!* initializes the land masks; it is in this file because it a key * -!* part of the physical grid description. * -!* * -!* This subroutine is also used by MOM-related preprocessing and * -!* postprocessing codes. * -!* * -!* The metric terms have the form Dzp, IDzp, or DXDYp, where z can * -!* be X or Y, and p can be q, u, v, or h. z describes the direction * -!* of the metric, while p describes the location. IDzp is the * -!* inverse of Dzp, while DXDYp is the product of DXp and DYp except * -!* that areaT is calculated analytically from the latitudes and * -!* longitudes of the surrounding q points. * -!* * -!* On a sphere, a variety of grids can be implemented by defining * -!* analytic expressions for dx_di, dy_dj (where x and y are latitude * -!* and longitude, and i and j are grid indices) and the expressions * -!* for the integrals of their inverses in the four subroutines * -!* dy_dj, Int_dj_dy, dx_di, and Int_di_dx. * -!* * -!* initialize_masks sets up land masks based on the depth field. * -!* The one argument is the minimum ocean depth. Depths that are * -!* less than this are interpreted as land points. * -!* * -!* Macros written all in capital letters are from MOM_memory.h. * -!* * -!* A small fragment of the C-grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q, dxBu, IdxBu, dyBu, IdyBu, etc. * -!* j+1 > o > o > At ^: v, dxCv, IdxCv, dyCv, IdyCv, etc. * -!* j x ^ x ^ x At >: u, dxCu, IdxCu, dyCu, IdyCu, etc. * -!* j > o > o > At o: h, dxT, IdxT, dyT, IdyT, areaT, etc. * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** - use MOM_checksums, only : hchksum, Bchksum use MOM_checksums, only : uvchksum, hchksum_pair, Bchksum_pair use MOM_domains, only : pass_var, pass_vector, pe_here, root_PE, broadcast @@ -62,6 +16,7 @@ module MOM_grid_initialize use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_io, only : MOM_read_data, read_data, slasher, file_exists use MOM_io, only : CORNER, NORTH_FACE, EAST_FACE +use MOM_unit_scaling, only : unit_scale_type use mpp_domains_mod, only : mpp_get_domain_extents, mpp_deallocate_domain @@ -69,39 +24,46 @@ module MOM_grid_initialize public set_grid_metrics, initialize_masks, Adcroft_reciprocal +! 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. + +!> Global positioning system (aka container for information to describe the grid) type, public :: GPS ; private - real :: len_lon - real :: len_lat - real :: west_lon - real :: south_lat - real :: Rad_Earth - real :: Lat_enhance_factor - real :: Lat_eq_enhance - logical :: isotropic - logical :: equator_reference - integer :: niglobal, njglobal ! Duplicates of niglobal and njglobal from MOM_dom + real :: len_lon !< The longitudinal or x-direction length of the domain. + real :: len_lat !< The latitudinal or y-direction length of the domain. + real :: west_lon !< The western longitude of the domain or the equivalent + !! starting value for the x-axis. + real :: south_lat !< The southern latitude of the domain or the equivalent + !! starting value for the y-axis. + real :: Rad_Earth !< The radius of the Earth [m]. + real :: Lat_enhance_factor !< The amount by which the meridional resolution + !! is enhanced within LAT_EQ_ENHANCE of the equator. + real :: Lat_eq_enhance !< The latitude range to the north and south of the equator + !! over which the resolution is enhanced, in degrees. + logical :: isotropic !< 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. + logical :: equator_reference !< If true, the grid is defined to have the equator at the + !! nearest q- or h- grid point to (-LOWLAT*NJGLOBAL/LENLAT). + integer :: niglobal !< The number of i-points in the global grid computational domain + integer :: njglobal !< The number of j-points in the global grid computational domain end type GPS contains - !> set_grid_metrics is used to set the primary values in the model's horizontal -!! grid. The bathymetry, land-sea mask and any restricted channel widths are -!! not known yet, so these are set later. -subroutine set_grid_metrics(G, param_file) - type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid type - type(param_file_type), intent(in) :: param_file !< Parameter file structure -! Arguments: -! (inout) G - The ocean's grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. - -! Calculate the values of the metric terms that might be used -! and save them in arrays. -! Within this subroutine, the x- and y- grid spacings and their -! inverses and the cell areas centered on h, q, u, and v points are -! calculated, as are the geographic locations of each of these 4 -! sets of points. +!! grid. The bathymetry, land-sea mask and any restricted channel widths are +!! not known yet, so these are set later. +subroutine set_grid_metrics(G, param_file, US) + type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid type + type(param_file_type), intent(in) :: param_file !< Parameter file structure + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type + ! Local variables ! This include declares and sets the variable "version". #include "version_variable.h" logical :: debug @@ -136,7 +98,7 @@ subroutine set_grid_metrics(G, param_file) "Unrecognized grid configuration "//trim(config)) end select -! Calculate derived metrics (i.e. reciprocals and products) + ! Calculate derived metrics (i.e. reciprocals and products) call callTree_enter("set_derived_metrics(), MOM_grid_initialize.F90") call set_derived_dyn_horgrid(G) call callTree_leave("set_derived_metrics()") @@ -149,7 +111,7 @@ end subroutine set_grid_metrics ! ------------------------------------------------------------------------------ !> grid_metrics_chksum performs a set of checksums on metrics on the grid for -!! debugging. +!! debugging. subroutine grid_metrics_chksum(parent, G) character(len=*), intent(in) :: parent !< A string identifying the caller type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type @@ -203,17 +165,11 @@ end subroutine grid_metrics_chksum ! ------------------------------------------------------------------------------ -!> set_grid_metrics_from_mosaic sets the grid metrics from a mosaic file. +!> Sets the grid metrics from a mosaic file. subroutine set_grid_metrics_from_mosaic(G, param_file) type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid type type(param_file_type), intent(in) :: param_file !< Parameter file structure -! This subroutine sets the grid metrics from a mosaic file. -! -! Arguments: -! (inout) G - The ocean's grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. - + ! Local variables real, dimension(G%isd :G%ied ,G%jsd :G%jed ) :: tempH1, tempH2, tempH3, tempH4 real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB) :: tempQ1, tempQ2, tempQ3, tempQ4 real, dimension(G%IsdB:G%IedB,G%jsd :G%jed ) :: tempE1, tempE2 @@ -234,6 +190,7 @@ subroutine set_grid_metrics_from_mosaic(G, param_file) character(len=64) :: mdl = "MOM_grid_init set_grid_metrics_from_mosaic" integer :: err=0, ni, nj, global_indices(4) type(MOM_domain_type) :: SGdom ! Supergrid domain + logical :: lon_bug ! If true use an older buggy answer in the tripolar longitude. integer :: i, j, i2, j2 integer :: npei,npej integer, dimension(:), allocatable :: exni,exnj @@ -244,6 +201,10 @@ subroutine set_grid_metrics_from_mosaic(G, param_file) call get_param(param_file, mdl, "GRID_FILE", grid_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"//& + "in some points along the tripolar fold to be off by 360 degrees.", & + default=.true.) call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") inputdir = slasher(inputdir) filename = trim(adjustl(inputdir)) // trim(adjustl(grid_file)) @@ -252,16 +213,16 @@ subroutine set_grid_metrics_from_mosaic(G, param_file) call MOM_error(FATAL," set_grid_metrics_from_mosaic: Unable to open "//& trim(filename)) -! Initialize everything to 0. + ! Initialize everything to 0. dxCu(:,:) = 0.0 ; dyCu(:,:) = 0.0 dxCv(:,:) = 0.0 ; dyCv(:,:) = 0.0 dxBu(:,:) = 0.0 ; dyBu(:,:) = 0.0 ; areaBu(:,:) = 0.0 -! + ! ni = 2*(G%iec-G%isc+1) ! i size of supergrid nj = 2*(G%jec-G%jsc+1) ! j size of supergrid -! Define a domain for the supergrid (SGdom) + ! Define a domain for the supergrid (SGdom) npei = G%domain%layout(1) ; npej = G%domain%layout(2) allocate(exni(npei)) ; allocate(exnj(npej)) call mpp_get_domain_extents(G%domain%mpp_domain, exni, exnj) @@ -271,14 +232,13 @@ subroutine set_grid_metrics_from_mosaic(G, param_file) SGdom%niglobal = 2*G%domain%niglobal SGdom%njglobal = 2*G%domain%njglobal SGdom%layout(:) = G%domain%layout(:) - SGdom%use_io_layout = G%domain%use_io_layout SGdom%io_layout(:) = G%domain%io_layout(:) global_indices(1) = 1+SGdom%nihalo global_indices(2) = SGdom%niglobal+SGdom%nihalo global_indices(3) = 1+SGdom%njhalo global_indices(4) = SGdom%njglobal+SGdom%njhalo exni(:) = 2*exni(:) ; exnj(:) = 2*exnj(:) - if(associated(G%domain%maskmap)) then + if (associated(G%domain%maskmap)) then call MOM_define_domain(global_indices, SGdom%layout, SGdom%mpp_domain, & xflags=G%domain%X_FLAGS, yflags=G%domain%Y_FLAGS, & xhalo=SGdom%nihalo, yhalo=SGdom%njhalo, & @@ -292,16 +252,19 @@ subroutine set_grid_metrics_from_mosaic(G, param_file) symmetry=.true., name="MOM_MOSAIC") endif - if (SGdom%use_io_layout) & - call MOM_define_IO_domain(SGdom%mpp_domain, SGdom%io_layout) + call MOM_define_IO_domain(SGdom%mpp_domain, SGdom%io_layout) deallocate(exni) deallocate(exnj) -! Read X from the supergrid + ! Read X from the supergrid tmpZ(:,:) = 999. call MOM_read_data(filename, 'x', tmpZ, SGdom, position=CORNER) - call pass_var(tmpZ, SGdom, position=CORNER) + if (lon_bug) then + call pass_var(tmpZ, SGdom, position=CORNER) + else + call pass_var(tmpZ, SGdom, position=CORNER, inner_halo=0) + endif call extrapolate_metric(tmpZ, 2*(G%jsc-G%jsd)+2, missing=999.) do j=G%jsd,G%jed ; do i=G%isd,G%ied ; i2 = 2*i ; j2 = 2*j G%geoLonT(i,j) = tmpZ(i2-1,j2-1) @@ -315,10 +278,10 @@ subroutine set_grid_metrics_from_mosaic(G, param_file) do J=G%JsdB,G%JedB ; do i=G%isd,G%ied ; i2 = 2*i ; j2 = 2*J G%geoLonCv(i,J) = tmpZ(i2-1,j2) enddo ; enddo - ! For some reason, this messes up the solution... - ! call pass_var(G%geoLonBu, G%domain, position=CORNER) + ! For some reason, this messes up the solution... + ! call pass_var(G%geoLonBu, G%domain, position=CORNER) -! Read Y from the supergrid + ! Read Y from the supergrid tmpZ(:,:) = 999. call MOM_read_data(filename, 'y', tmpZ, SGdom, position=CORNER) @@ -337,7 +300,7 @@ subroutine set_grid_metrics_from_mosaic(G, param_file) G%geoLatCv(i,J) = tmpZ(i2-1,j2) enddo ; enddo -! Read DX,DY from the supergrid + ! Read DX,DY from the supergrid tmpU(:,:) = 0. ; tmpV(:,:) = 0. call MOM_read_data(filename,'dx',tmpV,SGdom,position=NORTH_FACE) call MOM_read_data(filename,'dy',tmpU,SGdom,position=EAST_FACE) @@ -365,7 +328,7 @@ subroutine set_grid_metrics_from_mosaic(G, param_file) dyBu(I,J) = tmpU(i2,j2) + tmpU(i2,j2+1) enddo ; enddo -! Read AREA from the supergrid + ! Read AREA from the supergrid tmpT(:,:) = 0. call MOM_read_data(filename, 'area', tmpT, SGdom) call pass_var(tmpT, SGdom) @@ -445,21 +408,17 @@ end subroutine set_grid_metrics_from_mosaic ! ------------------------------------------------------------------------------ +!> Calculate the values of the metric terms for a Cartesian grid that +!! might be used and save them in arrays. +!! +!! Within this subroutine, the x- and y- grid spacings and their +!! inverses and the cell areas centered on h, q, u, and v points are +!! calculated, as are the geographic locations of each of these 4 +!! sets of points. subroutine set_grid_metrics_cartesian(G, param_file) type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid type type(param_file_type), intent(in) :: param_file !< Parameter file structure - -! Arguments: -! (inout) G - The ocean's grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. - -! Calculate the values of the metric terms for a Cartesian grid that -! might be used and save them in arrays. -! Within this subroutine, the x- and y- grid spacings and their -! inverses and the cell areas centered on h, q, u, and v points are -! calculated, as are the geographic locations of each of these 4 -! sets of points. + ! Local variables integer :: i, j, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, I1off, J1off integer :: niglobal, njglobal real :: grid_latT(G%jsd:G%jed), grid_latB(G%JsdB:G%JedB) @@ -477,7 +436,7 @@ subroutine set_grid_metrics_cartesian(G, param_file) call callTree_enter("set_grid_metrics_cartesian(), MOM_grid_initialize.F90") - PI = 4.0*atan(1.0) ; + PI = 4.0*atan(1.0) call get_param(param_file, mdl, "AXIS_UNITS", units_temp, & "The units for the Cartesian axes. Valid entries are: \n"//& @@ -538,7 +497,7 @@ subroutine set_grid_metrics_cartesian(G, param_file) if (units_temp(1:1) == 'k') then ! Axes are measured in km. dx_everywhere = 1000.0 * G%len_lon / (REAL(niglobal)) dy_everywhere = 1000.0 * G%len_lat / (REAL(njglobal)) - else if (units_temp(1:1) == 'm') then ! Axes are measured in m. + elseif (units_temp(1:1) == 'm') then ! Axes are measured in m. dx_everywhere = G%len_lon / (REAL(niglobal)) dy_everywhere = G%len_lat / (REAL(njglobal)) else ! Axes are measured in degrees of latitude and longitude. @@ -582,21 +541,17 @@ end subroutine set_grid_metrics_cartesian ! ------------------------------------------------------------------------------ +!> Calculate the values of the metric terms that might be used +!! and save them in arrays. +!! +!! Within this subroutine, the x- and y- grid spacings and their +!! inverses and the cell areas centered on h, q, u, and v points are +!! calculated, as are the geographic locations of each of these 4 +!! sets of points. subroutine set_grid_metrics_spherical(G, param_file) type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid type type(param_file_type), intent(in) :: param_file !< Parameter file structure - -! Arguments: -! (inout) G - The ocean's grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. - -! Calculate the values of the metric terms that might be used -! and save them in arrays. -! Within this subroutine, the x- and y- grid spacings and their -! inverses and the cell areas centered on h, q, u, and v points are -! calculated, as are the geographic locations of each of these 4 -! sets of points. + ! Local variables real :: PI, PI_180! PI = 3.1415926... as 4*atan(1) integer :: i, j, isd, ied, jsd, jed integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, IsdB, IedB, JsdB, JedB @@ -673,42 +628,42 @@ subroutine set_grid_metrics_spherical(G, param_file) G%geoLonBu(I,J) = grid_lonB(I) G%geoLatBu(I,J) = grid_latB(J) -! The following line is needed to reproduce the solution from -! set_grid_metrics_mercator when used to generate a simple spherical grid. + ! The following line is needed to reproduce the solution from + ! set_grid_metrics_mercator when used to generate a simple spherical grid. G%dxBu(I,J) = G%Rad_Earth * COS( G%geoLatBu(I,J)*PI_180 ) * dL_di ! G%dxBu(I,J) = G%Rad_Earth * dLon*PI_180 * COS( G%geoLatBu(I,J)*PI_180 ) G%dyBu(I,J) = G%Rad_Earth * dLat*PI_180 G%areaBu(I,J) = G%dxBu(I,J) * G%dyBu(I,J) - enddo; enddo + enddo ; enddo do J=JsdB,JedB ; do i=isd,ied G%geoLonCv(i,J) = grid_LonT(i) G%geoLatCv(i,J) = grid_latB(J) -! The following line is needed to reproduce the solution from -! set_grid_metrics_mercator when used to generate a simple spherical grid. + ! The following line is needed to reproduce the solution from + ! set_grid_metrics_mercator when used to generate a simple spherical grid. G%dxCv(i,J) = G%Rad_Earth * COS( G%geoLatCv(i,J)*PI_180 ) * dL_di ! G%dxCv(i,J) = G%Rad_Earth * (dLon*PI_180) * COS( G%geoLatCv(i,J)*PI_180 ) G%dyCv(i,J) = G%Rad_Earth * dLat*PI_180 - enddo; enddo + enddo ; enddo do j=jsd,jed ; do I=IsdB,IedB G%geoLonCu(I,j) = grid_lonB(I) G%geoLatCu(I,j) = grid_LatT(j) -! The following line is needed to reproduce the solution from -! set_grid_metrics_mercator when used to generate a simple spherical grid. + ! The following line is needed to reproduce the solution from + ! set_grid_metrics_mercator when used to generate a simple spherical grid. G%dxCu(I,j) = G%Rad_Earth * COS( G%geoLatCu(I,j)*PI_180 ) * dL_di ! G%dxCu(I,j) = G%Rad_Earth * dLon*PI_180 * COS( latitude ) G%dyCu(I,j) = G%Rad_Earth * dLat*PI_180 - enddo; enddo + enddo ; enddo do j=jsd,jed ; do i=isd,ied G%geoLonT(i,j) = grid_LonT(i) G%geoLatT(i,j) = grid_LatT(j) -! The following line is needed to reproduce the solution from -! set_grid_metrics_mercator when used to generate a simple spherical grid. + ! The following line is needed to reproduce the solution from + ! set_grid_metrics_mercator when used to generate a simple spherical grid. G%dxT(i,j) = G%Rad_Earth * COS( G%geoLatT(i,j)*PI_180 ) * dL_di ! G%dxT(i,j) = G%Rad_Earth * dLon*PI_180 * COS( latitude ) G%dyT(i,j) = G%Rad_Earth * dLat*PI_180 @@ -717,41 +672,28 @@ subroutine set_grid_metrics_spherical(G, param_file) ! dL_di = G%geoLatCv(i,max(jsd,J-1))*PI_180 ! In radians ! G%areaT(i,j) = Rad_Earth**2*dLon*dLat*ABS(SIN(latitude)-SIN(dL_di)) G%areaT(i,j) = G%dxT(i,j) * G%dyT(i,j) - enddo; enddo + enddo ; enddo call callTree_leave("set_grid_metrics_spherical()") end subroutine set_grid_metrics_spherical -! ------------------------------------------------------------------------------ - +!> Calculate the values of the metric terms that might be used +!! and save them in arrays. +!! +!! Within this subroutine, the x- and y- grid spacings and their +!! inverses and the cell areas centered on h, q, u, and v points are +!! calculated, as are the geographic locations of each of these 4 +!! sets of points. subroutine set_grid_metrics_mercator(G, param_file) type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid type type(param_file_type), intent(in) :: param_file !< Parameter file structure - -! Arguments: -! (inout) G - The ocean's grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. - -! Calculate the values of the metric terms that might be used -! and save them in arrays. -! Within this subroutine, the x- and y- grid spacings and their -! inverses and the cell areas centered on h, q, u, and v points are -! calculated, as are the geographic locations of each of these 4 -! sets of points. + ! Local variables integer :: i, j, isd, ied, jsd, jed integer :: I_off, J_off type(GPS) :: GP character(len=128) :: warnmesg character(len=48) :: mdl = "MOM_grid_init set_grid_metrics_mercator" real :: PI, PI_2! PI = 3.1415926... as 4*atan(1), PI_2 = (PI) /2.0 - - -! All of the metric terms should be defined over the domain from -! isd to ied. Outside of the physical domain, both the metrics -! and their inverses may be set to zero. - -! The metric terms within the computational domain are set here. real :: y_q, y_h, jd, x_q, x_h, id real, dimension(G%isd:G%ied,G%jsd:G%jed) :: & xh, yh ! Latitude and longitude of h points in radians. @@ -768,6 +710,9 @@ subroutine set_grid_metrics_mercator(G, param_file) logical :: debug = .FALSE., simple_area = .true. integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, IsdB, IedB, JsdB, JedB + ! All of the metric terms should be defined over the domain from + ! isd to ied. Outside of the physical domain, both the metrics + ! and their inverses may be set to zero. is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB @@ -779,8 +724,8 @@ subroutine set_grid_metrics_mercator(G, param_file) call callTree_enter("set_grid_metrics_mercator(), MOM_grid_initialize.F90") -! Calculate the values of the metric terms that might be used -! and save them in arrays. + ! Calculate the values of the metric terms that might be used + ! and save them in arrays. PI = 4.0*atan(1.0) ; PI_2 = 0.5*PI call get_param(param_file, mdl, "SOUTHLAT", GP%south_lat, & @@ -822,19 +767,19 @@ subroutine set_grid_metrics_mercator(G, param_file) "over which the resolution is enhanced.", units="degrees", & default=0.0) -! With an isotropic grid, the north-south extent of the domain, -! the east-west extent, and the number of grid points in each -! direction are _not_ independent. Here the north-south extent -! will be determined to fit the east-west extent and the number of -! grid points. The grid is perfectly isotropic. + ! With an isotropic grid, the north-south extent of the domain, + ! the east-west extent, and the number of grid points in each + ! direction are _not_ independent. Here the north-south extent + ! will be determined to fit the east-west extent and the number of + ! grid points. The grid is perfectly isotropic. if (GP%equator_reference) then -! With the following expression, the equator will always be placed -! on either h or q points, in a position consistent with the ratio -! GP%south_lat to GP%len_lat. + ! With the following expression, the equator will always be placed + ! on either h or q points, in a position consistent with the ratio + ! GP%south_lat to GP%len_lat. jRef = (G%jsg-1) + 0.5*FLOOR(GP%njglobal*((-1.0*GP%south_lat*2.0)/GP%len_lat)+0.5) fnRef = Int_dj_dy(0.0, GP) else -! The following line sets the reference latitude GP%south_lat at j=js-1 (or -2?) + ! The following line sets the reference latitude GP%south_lat at j=js-1 (or -2?) jRef = (G%jsg-1) fnRef = Int_dj_dy((GP%south_lat*PI/180.0), GP) endif @@ -873,9 +818,9 @@ subroutine set_grid_metrics_mercator(G, param_file) endif enddo -! Determine the longitudes of the various points. + ! Determine the longitudes of the various points. -! These two lines place the western edge of the domain at GP%west_lon. + ! These two lines place the western edge of the domain at GP%west_lon. iRef = (G%isg-1) + GP%niglobal fnRef = Int_di_dx(((GP%west_lon+GP%len_lon)*PI/180.0), GP) @@ -966,44 +911,44 @@ subroutine set_grid_metrics_mercator(G, param_file) end subroutine set_grid_metrics_mercator +!> This function returns the grid spacing in the logical x direction. function ds_di(x, y, GP) - real, intent(in) :: x, y - type(GPS), intent(in) :: GP + real, intent(in) :: x !< The longitude in question + real, intent(in) :: y !< The latitude in question + type(GPS), intent(in) :: GP !< A structure of grid parameters real :: ds_di -! This function returns the grid spacing in the logical x direction. -! Arguments: x - The latitude in question. -! (in) y - The longitude in question. + ! Local variables + ds_di = GP%Rad_Earth * cos(y) * dx_di(x,GP) -! In general, this might be... -! ds_di = GP%Rad_Earth * sqrt( cos(y)*cos(y) * dx_di(x,y,GP)*dx_di(x,y,GP) + & -! dy_di(x,y,GP)*dy_di(x,y,GP)) + ! In general, this might be... + ! ds_di = GP%Rad_Earth * sqrt( cos(y)*cos(y) * dx_di(x,y,GP)*dx_di(x,y,GP) + & + ! dy_di(x,y,GP)*dy_di(x,y,GP)) end function ds_di +!> This function returns the grid spacing in the logical y direction. function ds_dj(x, y, GP) - real, intent(in) :: x, y - type(GPS), intent(in) :: GP + real, intent(in) :: x !< The longitude in question + real, intent(in) :: y !< The latitude in question + type(GPS), intent(in) :: GP !< A structure of grid parameters + ! Local variables real :: ds_dj -! This function returns the grid spacing in the logical y direction. -! Arguments: x - The latitude in question. -! (in) y - The longitude in question. + ds_dj = GP%Rad_Earth * dy_dj(y,GP) -! In general, this might be... -! ds_dj = GP%Rad_Earth * sqrt( cos(y)*cos(y) * dx_dj(x,y,GP)*dx_dj(x,y,GP) + & -! dy_dj(x,y,GP)*dy_dj(x,y,GP)) + ! In general, this might be... + ! ds_dj = GP%Rad_Earth * sqrt( cos(y)*cos(y) * dx_dj(x,y,GP)*dx_dj(x,y,GP) + & + ! dy_dj(x,y,GP)*dy_dj(x,y,GP)) end function ds_dj - +!> This function returns the contribution from the line integral along one of the four sides of a +!! cell face to the area of a cell, assuming that the sides follow a linear path in latitude and +!! longitude (i.e., on a Mercator grid). function dL(x1, x2, y1, y2) - real, intent(in) :: x1, x2, y1, y2 + real, intent(in) :: x1 !< Segment starting longitude, in degrees E. + real, intent(in) :: x2 !< Segment ending longitude, in degrees E. + real, intent(in) :: y1 !< Segment ending latitude, in degrees N. + real, intent(in) :: y2 !< Segment ending latitude, in degrees N. + ! Local variables real :: dL -! This subroutine calculates the contribution from the line integral -! along one of the four sides of a cell face to the area of a cell, -! assuming that the sides follow a linear path in latitude and long- -! itude (i.e., on a Mercator grid). -! Argumnts: x1 - Segment starting longitude. -! (in) x2 - Segment ending longitude. -! (in) y1 - Segment ending latitude. -! (in) y2 - Segment ending latitude. real :: r, dy dy = y2 - y1 @@ -1017,17 +962,21 @@ function dL(x1, x2, y1, y2) end function dL +!> This subroutine finds and returns the value of y at which the monotonically increasing +!! function fn takes the value fnval, also returning in ittmax the number of iterations of +!! Newton's method that were used to polish the root. function find_root( fn, dy_df, GP, fnval, y1, ymin, ymax, ittmax) - real :: find_root - real, external :: fn, dy_df - type(GPS), intent(in) :: GP - real, intent(in) :: fnval, y1, ymin, ymax - integer, intent(out) :: ittmax + real :: find_root !< The value of y where fn(y) = fnval that will be returned + real, external :: fn !< The external function whose root is being sought + real, external :: dy_df !< The inverse of the derivative of that function + type(GPS), intent(in) :: GP !< A structure of grid parameters + real, intent(in) :: fnval !< The value of fn being sought + real, intent(in) :: y1 !< A first guess for y + real, intent(in) :: ymin !< The minimum permitted value of y + real, intent(in) :: ymax !< The maximum permitted value of y + integer, intent(out) :: ittmax !< The number of iterations used to polish the root + ! Local variables real :: y, y_next -! This subroutine finds and returns the value of y at which the -! monotonically increasing function fn takes the value fnval, also returning -! in ittmax the number of iterations of Newton's method that were -! used to polish the root. real :: ybot, ytop, fnbot, fntop integer :: itt character(len=256) :: warnmesg @@ -1126,36 +1075,35 @@ function find_root( fn, dy_df, GP, fnval, y1, ymin, ymax, ittmax) find_root = y end function find_root +!> This function calculates and returns the value of dx/di, where x is the +!! longitude in Radians, and i is the integral north-south grid index. function dx_di(x, GP) - real, intent(in) :: x - type(GPS), intent(in) :: GP + real, intent(in) :: x !< The longitude in question + type(GPS), intent(in) :: GP !< A structure of grid parameters real :: dx_di -! This subroutine calculates and returns the value of dx/di, where -! x is the longitude in Radians, and i is the integral north-south -! grid index. dx_di = (GP%len_lon * 4.0*atan(1.0)) / (180.0 * GP%niglobal) end function dx_di +!> This function calculates and returns the integral of the inverse +!! of dx/di to the point x, in radians. function Int_di_dx(x, GP) - real, intent(in) :: x - type(GPS), intent(in) :: GP + real, intent(in) :: x !< The longitude in question + type(GPS), intent(in) :: GP !< A structure of grid parameters real :: Int_di_dx -! This subroutine calculates and returns the integral of the inverse -! of dx/di to the point x, in radians. Int_di_dx = x * ((180.0 * GP%niglobal) / (GP%len_lon * 4.0*atan(1.0))) end function Int_di_dx +!> This subroutine calculates and returns the value of dy/dj, where y is the +!! latitude in Radians, and j is the integral north-south grid index. function dy_dj(y, GP) - real, intent(in) :: y - type(GPS), intent(in) :: GP + real, intent(in) :: y !< The latitude in question + type(GPS), intent(in) :: GP !< A structure of grid parameters real :: dy_dj -! This subroutine calculates and returns the value of dy/dj, where -! y is the latitude in Radians, and j is the integral north-south -! grid index. + ! Local variables real :: PI ! 3.1415926... calculated as 4*atan(1) real :: C0 ! The constant that converts the nominal y-spacing in ! gridpoints to the nominal spacing in Radians. @@ -1178,12 +1126,13 @@ function dy_dj(y, GP) end function dy_dj +!> This subroutine calculates and returns the integral of the inverse +!! of dy/dj to the point y, in radians. function Int_dj_dy(y, GP) - real, intent(in) :: y - type(GPS), intent(in) :: GP + real, intent(in) :: y !< The latitude in question + type(GPS), intent(in) :: GP !< A structure of grid parameters real :: Int_dj_dy -! This subroutine calculates and returns the integral of the inverse -! of dy/dj to the point y, in radians. + ! Local variables real :: I_C0 = 0.0 ! The inverse of the constant that converts the ! nominal spacing in gridpoints to the nominal ! spacing in Radians. @@ -1207,7 +1156,7 @@ function Int_dj_dy(y, GP) if (y >= y_eq_enhance) then r = r + I_C0*0.5*(GP%lat_enhance_factor - 1.0)*y_eq_enhance - else if (y <= -y_eq_enhance) then + elseif (y <= -y_eq_enhance) then r = r - I_C0*0.5*(GP%lat_enhance_factor - 1.0)*y_eq_enhance else r = r + I_C0*0.5*(GP%lat_enhance_factor - 1.0) * & @@ -1221,15 +1170,12 @@ function Int_dj_dy(y, GP) Int_dj_dy = r end function Int_dj_dy -! ------------------------------------------------------------------------------ - -! ------------------------------------------------------------------------------ - -!> extrapolate_metric extrapolates missing metric data into all the halo regions. +!> Extrapolates missing metric data into all the halo regions. subroutine extrapolate_metric(var, jh, missing) real, dimension(:,:), intent(inout) :: var !< The array in which to fill in halos integer, intent(in) :: jh !< The size of the halos to be filled real, optional, intent(in) :: missing !< The missing data fill value, 0 by default. + ! Local variables real :: badval integer :: i,j @@ -1267,34 +1213,38 @@ function Adcroft_reciprocal(val) result(I_val) if (val /= 0.0) I_val = 1.0/val end function Adcroft_reciprocal -!> initialize_masks initializes the grid masks and any metrics that come -!! with masks already applied. -subroutine initialize_masks(G, PF) - type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid type - type(param_file_type), intent(in) :: PF !< Parameter file structure - -! Initialize_masks sets mask2dT, mask2dCu, mask2dCv, and mask2dBu to mask out -! flow over any points which are shallower than Dmin and permit an -! appropriate treatment of the boundary conditions. mask2dCu and mask2dCv -! are 0.0 at any points adjacent to a land point. mask2dBu is 0.0 at -! any land or boundary point. For points in the interior, mask2dCu, -! mask2dCv, and mask2dBu are all 1.0. - - real :: Dmin, min_depth, mask_depth +!> Initializes the grid masks and any metrics that come with masks already applied. +!! +!! Initialize_masks sets mask2dT, mask2dCu, mask2dCv, and mask2dBu to mask out +!! flow over any points which are shallower than Dmin and permit an +!! appropriate treatment of the boundary conditions. mask2dCu and mask2dCv +!! are 0.0 at any points adjacent to a land point. mask2dBu is 0.0 at +!! any land or boundary point. For points in the interior, mask2dCu, +!! mask2dCv, and mask2dBu are all 1.0. +subroutine initialize_masks(G, PF, US) + type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid type + type(param_file_type), intent(in) :: PF !< Parameter file structure + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type + ! Local variables + real :: m_to_Z_scale ! A unit conversion factor from m to Z. + real :: Dmin ! The depth for masking in the same units as G%bathyT [Z ~> m]. + real :: min_depth ! The minimum ocean depth in the same units as G%bathyT [Z ~> m]. + real :: mask_depth ! The depth shallower than which to mask a point as land [Z ~> m]. character(len=40) :: mdl = "MOM_grid_init initialize_masks" integer :: i, j 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"//& "MINIMUM_DEPTH but deeper than MASKING_DEPTH are rounded to MINIMUM_DEPTH.", & - units="m", default=0.0) + 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"//& "fluxes are zeroed out. MASKING_DEPTH is ignored if negative.", & - units="m", default=-9999.0) + units="m", default=-9999.0, scale=m_to_Z_scale) Dmin = min_depth if (mask_depth>=0.) Dmin = mask_depth @@ -1353,4 +1303,23 @@ subroutine initialize_masks(G, PF) call callTree_leave("initialize_masks()") end subroutine initialize_masks +!> \namespace mom_grid_initialize +!! +!! The metric terms have the form Dzp, IDzp, or DXDYp, where z can +!! be X or Y, and p can be q, u, v, or h. z describes the direction +!! of the metric, while p describes the location. IDzp is the +!! inverse of Dzp, while DXDYp is the product of DXp and DYp except +!! that areaT is calculated analytically from the latitudes and +!! longitudes of the surrounding q points. +!! +!! On a sphere, a variety of grids can be implemented by defining +!! analytic expressions for dx_di, dy_dj (where x and y are latitude +!! and longitude, and i and j are grid indices) and the expressions +!! for the integrals of their inverses in the four subroutines +!! dy_dj, Int_dj_dy, dx_di, and Int_di_dx. +!! +!! initialize_masks sets up land masks based on the depth field. +!! The one argument is the minimum ocean depth. Depths that are +!! less than this are interpreted as land points. + end module MOM_grid_initialize diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index 8bb7a290ee..7613eae6b0 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -15,6 +15,7 @@ module MOM_shared_initialization use MOM_io, only : MOM_read_data, MOM_read_vector, SINGLE_FILE, MULTIPLE use MOM_io, only : slasher, vardesc, write_field, var_desc use MOM_string_functions, only : uppercase +use MOM_unit_scaling, only : unit_scale_type use netcdf @@ -29,6 +30,11 @@ module MOM_shared_initialization public read_face_length_list, set_velocity_depth_max, set_velocity_depth_min public compute_global_grid_integrals, write_ocean_geometry_file +! 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. + contains ! ----------------------------------------------------------------------------- @@ -48,10 +54,11 @@ end subroutine MOM_shared_init_init ! ----------------------------------------------------------------------------- !> MOM_initialize_rotation makes the appropriate call to set up the Coriolis parameter. -subroutine MOM_initialize_rotation(f, G, PF) +subroutine MOM_initialize_rotation(f, G, PF, US) type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type - real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), intent(out) :: f !< The Coriolis parameter in s-1 + real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), intent(out) :: f !< The Coriolis parameter [s-1] type(param_file_type), intent(in) :: PF !< Parameter file structure + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type ! This subroutine makes the appropriate call to set up the Coriolis parameter. ! This is a separate subroutine so that it can be made public and shared with @@ -80,12 +87,13 @@ subroutine MOM_initialize_rotation(f, G, PF) end subroutine MOM_initialize_rotation !> Calculates the components of grad f (Coriolis parameter) -subroutine MOM_calculate_grad_Coriolis(dF_dx, dF_dy, G) +subroutine MOM_calculate_grad_Coriolis(dF_dx, dF_dy, G, US) type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid type real, dimension(G%isd:G%ied,G%jsd:G%jed), & intent(out) :: dF_dx !< x-component of grad f real, dimension(G%isd:G%ied,G%jsd:G%jed), & intent(out) :: dF_dy !< y-component of grad f + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type ! Local variables integer :: i,j real :: f1, f2 @@ -108,37 +116,39 @@ subroutine MOM_calculate_grad_Coriolis(dF_dx, dF_dy, G) call pass_vector(dF_dx, dF_dy, G%Domain, stagger=AGRID) end subroutine MOM_calculate_grad_Coriolis -!> Return the global maximum ocean bottom depth in m. -function diagnoseMaximumDepth(D,G) +!> Return the global maximum ocean bottom depth in the same units as the input depth. +function diagnoseMaximumDepth(D, G) type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(in) :: D !< Ocean bottom depth in m - real :: diagnoseMaximumDepth !< The global maximum ocean bottom depth in m + intent(in) :: D !< Ocean bottom depth in m or Z + real :: diagnoseMaximumDepth !< The global maximum ocean bottom depth in m or Z ! Local variables integer :: i,j - diagnoseMaximumDepth=D(G%isc,G%jsc) - do j=G%jsc, G%jec - do i=G%isc, G%iec - diagnoseMaximumDepth=max(diagnoseMaximumDepth,D(i,j)) - enddo - enddo + diagnoseMaximumDepth = D(G%isc,G%jsc) + do j=G%jsc, G%jec ; do i=G%isc, G%iec + diagnoseMaximumDepth = max(diagnoseMaximumDepth,D(i,j)) + enddo ; enddo call max_across_PEs(diagnoseMaximumDepth) end function diagnoseMaximumDepth !> Read gridded depths from file -subroutine initialize_topography_from_file(D, G, param_file) +subroutine initialize_topography_from_file(D, G, param_file, US) type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(out) :: D !< Ocean bottom depth in m + intent(out) :: D !< Ocean bottom depth in m or Z if US is present type(param_file_type), intent(in) :: param_file !< Parameter file structure + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type ! Local variables + real :: m_to_Z ! A dimensional rescaling factor. character(len=200) :: filename, topo_file, inputdir ! Strings for file/path character(len=200) :: topo_varname ! Variable name in file character(len=40) :: mdl = "initialize_topography_from_file" ! This subroutine's name. call callTree_enter(trim(mdl)//"(), MOM_shared_initialization.F90") + m_to_Z = 1.0 ; if (present(US)) m_to_Z = US%m_to_Z + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") inputdir = slasher(inputdir) call get_param(param_file, mdl, "TOPO_FILE", topo_file, & @@ -154,28 +164,29 @@ subroutine initialize_topography_from_file(D, G, param_file) if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & " initialize_topography_from_file: Unable to open "//trim(filename)) - D(:,:) = -9.E30 ! Initializing to a very large negative depth (tall mountains) - ! everywhere before reading from a file should do nothing. - ! However, in the instance of masked-out PEs, halo regions - ! are not updated when a processor does not exist. We need to - ! ensure the depth in masked-out PEs appears to be that of land - ! so this line does that in the halo regions. For non-masked PEs - ! the halo region is filled properly with a later pass_var(). - call MOM_read_data(filename, trim(topo_varname), D, G%Domain) + D(:,:) = -9.e30*m_to_Z ! Initializing to a very large negative depth (tall mountains) everywhere + ! before reading from a file should do nothing. However, in the instance of + ! masked-out PEs, halo regions are not updated when a processor does not + ! exist. We need to ensure the depth in masked-out PEs appears to be that + ! of land so this line does that in the halo regions. For non-masked PEs + ! the halo region is filled properly with a later pass_var(). + call MOM_read_data(filename, trim(topo_varname), D, G%Domain, scale=m_to_Z) - call apply_topography_edits_from_file(D, G, param_file) + call apply_topography_edits_from_file(D, G, param_file, US) call callTree_leave(trim(mdl)//'()') end subroutine initialize_topography_from_file !> Applies a list of topography overrides read from a netcdf file -subroutine apply_topography_edits_from_file(D, G, param_file) +subroutine apply_topography_edits_from_file(D, G, param_file, US) type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(inout) :: D !< Ocean bottom depth in m + intent(inout) :: D !< Ocean bottom depth in m or Z if US is present type(param_file_type), intent(in) :: param_file !< Parameter file structure + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type ! Local variables + real :: m_to_Z ! A dimensional rescaling factor. character(len=200) :: topo_edits_file, inputdir ! Strings for file/path character(len=40) :: mdl = "apply_topography_edits_from_file" ! This subroutine's name. integer :: n_edits, n, ashape(5), i, j, ncid, id, ncstatus, iid, jid, zid @@ -184,6 +195,8 @@ subroutine apply_topography_edits_from_file(D, G, param_file) call callTree_enter(trim(mdl)//"(), MOM_shared_initialization.F90") + m_to_Z = 1.0 ; if (present(US)) m_to_Z = US%m_to_Z + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") inputdir = slasher(inputdir) call get_param(param_file, mdl, "TOPO_EDITS_FILE", topo_edits_file, & @@ -265,8 +278,9 @@ subroutine apply_topography_edits_from_file(D, G, param_file) j = jg(n) - G%jsd_global + 2 if (i>=G%isc .and. i<=G%iec .and. j>=G%jsc .and. j<=G%jec) then if (new_depth(n)/=0.) then - write(*,'(a,3i5,f8.2,a,f8.2,2i4)') 'Ocean topography edit: ',n,ig(n),jg(n),D(i,j),'->',abs(new_depth(n)),i,j - D(i,j) = abs(new_depth(n)) ! Allows for height-file edits (i.e. converts negatives) + write(*,'(a,3i5,f8.2,a,f8.2,2i4)') & + 'Ocean topography edit: ',n,ig(n),jg(n),D(i,j)/m_to_Z,'->',abs(new_depth(n)),i,j + D(i,j) = abs(m_to_Z*new_depth(n)) ! Allows for height-file edits (i.e. converts negatives) else call MOM_error(FATAL, ' apply_topography_edits_from_file: '//& "A zero depth edit would change the land mask and is not allowed in"//trim(topo_edits_file)) @@ -280,30 +294,25 @@ subroutine apply_topography_edits_from_file(D, G, param_file) end subroutine apply_topography_edits_from_file !> initialize the bathymetry based on one of several named idealized configurations -subroutine initialize_topography_named(D, G, param_file, topog_config, max_depth) +subroutine initialize_topography_named(D, G, param_file, topog_config, max_depth, US) type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(out) :: D !< Ocean bottom depth in m + intent(out) :: D !< Ocean bottom depth in m or Z if US is present type(param_file_type), intent(in) :: param_file !< Parameter file structure character(len=*), intent(in) :: topog_config !< The name of an idealized !! topographic configuration - real, intent(in) :: max_depth !< Maximum depth of model in m + real, intent(in) :: max_depth !< Maximum depth of model in the units of D + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type -! Arguments: D - the bottom depth in m. Intent out. -! (in) G - The ocean's grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in) topog_config - The name of an idealized topographic configuration. -! (in) max_depth - The maximum depth in m. + ! This subroutine places the bottom depth in m into D(:,:), shaped according to the named config. -! This subroutine places the bottom depth in m into D(:,:), shaped in a spoon - real :: min_depth ! The minimum depth in m. + ! Local variables + real :: m_to_Z ! A dimensional rescaling factor. + real :: min_depth ! The minimum depth [Z ~> m]. real :: PI ! 3.1415926... calculated as 4*atan(1) - real :: D0 ! A constant to make the maximum ! - ! basin depth MAXIMUM_DEPTH. ! - real :: expdecay ! A decay scale of associated with ! - ! the sloping boundaries, in m. ! - real :: Dedge ! The depth in m at the basin edge. ! + real :: D0 ! A constant to make the maximum basin depth MAXIMUM_DEPTH. + real :: expdecay ! A decay scale of associated with the sloping boundaries [m]. + real :: Dedge ! The depth [Z ~> m], at the basin edge ! real :: south_lat, west_lon, len_lon, len_lat, Rad_earth integer :: i, j, is, ie, js, je, isd, ied, jsd, jed character(len=40) :: mdl = "initialize_topography_named" ! This subroutine's name. @@ -314,15 +323,17 @@ subroutine initialize_topography_named(D, G, param_file, topog_config, max_depth call MOM_mesg(" MOM_shared_initialization.F90, initialize_topography_named: "//& "TOPO_CONFIG = "//trim(topog_config), 5) + 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, & - "The minimum depth of the ocean.", units="m", default=0.0) + "The minimum depth of the ocean.", units="m", default=0.0, scale=m_to_Z) if (max_depth<=0.) call MOM_error(FATAL,"initialize_topography_named: "// & "MAXIMUM_DEPTH has a non-sensical value! Was it set?") if (trim(topog_config) /= "flat") then call get_param(param_file, mdl, "EDGE_DEPTH", Dedge, & "The depth at the edge of one of the named topographies.", & - units="m", default=100.0) + units="m", default=100.0, scale=m_to_Z) ! call get_param(param_file, mdl, "SOUTHLAT", south_lat, & ! "The southern latitude of the domain.", units="degrees", & ! fail_if_missing=.true.) @@ -396,37 +407,36 @@ end subroutine initialize_topography_named ! ----------------------------------------------------------------------------- !> limit_topography ensures that min_depth < D(x,y) < max_depth -subroutine limit_topography(D, G, param_file, max_depth) +subroutine limit_topography(D, G, param_file, max_depth, US) type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(inout) :: D !< Ocean bottom depth in m + intent(inout) :: D !< Ocean bottom depth in m or Z if US is present type(param_file_type), intent(in) :: param_file !< Parameter file structure - real, intent(in) :: max_depth !< Maximum depth of model in m -! Arguments: D - the bottom depth in m. Intent in/out. -! (in) G - The ocean's grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in) max_depth - The maximum depth in m. - -! This subroutine ensures that min_depth < D(x,y) < max_depth + real, intent(in) :: max_depth !< Maximum depth of model in the units of D + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type + + ! Local variables + real :: m_to_Z ! A dimensional rescaling factor. integer :: i, j character(len=40) :: mdl = "limit_topography" ! This subroutine's name. real :: min_depth, mask_depth call callTree_enter(trim(mdl)//"(), MOM_shared_initialization.F90") + 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"//& "MINIMUM_DEPTH but deeper than MASKING_DEPTH are rounded to MINIMUM_DEPTH.", & - units="m", default=0.0) + units="m", default=0.0, scale=m_to_Z) call get_param(param_file, mdl, "MASKING_DEPTH", mask_depth, & - "The depth below which to mask the ocean as land.", units="m", & - default=-9999.0, do_not_log=.true.) + "The depth below which to mask the ocean as land.", & + units="m", default=-9999.0, scale=m_to_Z, do_not_log=.true.) ! Make sure that min_depth < D(x,y) < max_depth - if (mask_depth<-9990.) then + if (mask_depth < -9990.*m_to_Z) then do j=G%jsd,G%jed ; do i=G%isd,G%ied D(i,j) = min( max( D(i,j), 0.5*min_depth ), max_depth ) enddo ; enddo @@ -445,13 +455,13 @@ end subroutine limit_topography ! ----------------------------------------------------------------------------- ! ----------------------------------------------------------------------------- -subroutine set_rotation_planetary(f, G, param_file) - type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid - real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), intent(out) :: f - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters -! Arguments: f - Coriolis parameter (vertical component) in s^-1 -! (in) G - grid type -! (in) param_file - parameter file type +!> This subroutine sets up the Coriolis parameter for a sphere +subroutine set_rotation_planetary(f, G, param_file, US) + type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid + real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & + intent(out) :: f !< Coriolis parameter (vertical component) in s^-1 + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type ! This subroutine sets up the Coriolis parameter for a sphere character(len=30) :: mdl = "set_rotation_planetary" ! This subroutine's name. @@ -474,13 +484,13 @@ end subroutine set_rotation_planetary ! ----------------------------------------------------------------------------- ! ----------------------------------------------------------------------------- -subroutine set_rotation_beta_plane(f, G, param_file) - type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid - real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), intent(out) :: f - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters -! Arguments: f - Coriolis parameter (vertical component) in s^-1 -! (in) G - grid type -! (in) param_file - parameter file type +!> This subroutine sets up the Coriolis parameter for a beta-plane or f-plane +subroutine set_rotation_beta_plane(f, G, param_file, US) + type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid + real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & + intent(out) :: f !< Coriolis parameter (vertical component) in s^-1 + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type ! This subroutine sets up the Coriolis parameter for a beta-plane integer :: I, J @@ -526,37 +536,82 @@ subroutine initialize_grid_rotation_angle(G, PF) !! to parse for model parameter values. real :: angle, lon_scale - integer :: i, j + real :: len_lon ! The periodic range of longitudes, usually 360 degrees. + real :: pi_720deg ! One quarter the conversion factor from degrees to radians. + real :: lonB(2,2) ! The longitude of a point, shifted to have about the same value. + character(len=40) :: mdl = "initialize_grid_rotation_angle" ! This subroutine's name. + logical :: use_bugs + 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"//& + "true north and east. Differences arise at the tripolar fold.", & + default=.True.) + + if (use_bugs) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec + lon_scale = cos((G%geoLatBu(I-1,J-1) + G%geoLatBu(I,J-1 ) + & + G%geoLatBu(I-1,J) + G%geoLatBu(I,J)) * atan(1.0)/180) + angle = atan2((G%geoLonBu(I-1,J) + G%geoLonBu(I,J) - & + G%geoLonBu(I-1,J-1) - G%geoLonBu(I,J-1))*lon_scale, & + G%geoLatBu(I-1,J) + G%geoLatBu(I,J) - & + G%geoLatBu(I-1,J-1) - G%geoLatBu(I,J-1) ) + G%sin_rot(i,j) = sin(angle) ! angle is the clockwise angle from lat/lon to ocean + G%cos_rot(i,j) = cos(angle) ! grid (e.g. angle of ocean "north" from true north) + enddo ; enddo - do j=G%jsc,G%jec ; do i=G%isc,G%iec - lon_scale = cos((G%geoLatBu(I-1,J-1) + G%geoLatBu(I,J-1 ) + & - G%geoLatBu(I-1,J) + G%geoLatBu(I,J)) * atan(1.0)/180) - angle = atan2((G%geoLonBu(I-1,J) + G%geoLonBu(I,J) - & - G%geoLonBu(I-1,J-1) - G%geoLonBu(I,J-1))*lon_scale, & - G%geoLatBu(I-1,J) + G%geoLatBu(I,J) - & - G%geoLatBu(I-1,J-1) - G%geoLatBu(I,J-1) ) - G%sin_rot(i,j) = sin(angle) ! angle is the clockwise angle from lat/lon to ocean - G%cos_rot(i,j) = cos(angle) ! grid (e.g. angle of ocean "north" from true north) - enddo ; enddo + ! This is not right at a tripolar or cubed-sphere fold. + call pass_var(G%cos_rot, G%Domain) + call pass_var(G%sin_rot, G%Domain) + else + pi_720deg = atan(1.0) / 180.0 + len_lon = 360.0 ; if (G%len_lon > 0.0) len_lon = G%len_lon + do j=G%jsc,G%jec ; do i=G%isc,G%iec + do n=1,2 ; do m=1,2 + lonB(m,n) = modulo_around_point(G%geoLonBu(I+m-2,J+n-2), G%geoLonT(i,j), len_lon) + enddo ; enddo + lon_scale = cos(pi_720deg*((G%geoLatBu(I-1,J-1) + G%geoLatBu(I,J)) + & + (G%geoLatBu(I,J-1) + G%geoLatBu(I-1,J)) ) ) + angle = atan2(lon_scale*((lonB(1,2) - lonB(2,1)) + (lonB(2,2) - lonB(1,1))), & + (G%geoLatBu(I-1,J) - G%geoLatBu(I,J-1)) + & + (G%geoLatBu(I,J) - G%geoLatBu(I-1,J-1)) ) + G%sin_rot(i,j) = sin(angle) ! angle is the clockwise angle from lat/lon to ocean + G%cos_rot(i,j) = cos(angle) ! grid (e.g. angle of ocean "north" from true north) + enddo ; enddo - ! ### THIS DOESN'T SEEM RIGHT AT A CUBED-SPHERE FOLD -RWH - call pass_var(G%cos_rot, G%Domain) - call pass_var(G%sin_rot, G%Domain) + call pass_vector(G%cos_rot, G%sin_rot, G%Domain, stagger=AGRID) + endif end subroutine initialize_grid_rotation_angle ! ----------------------------------------------------------------------------- -subroutine reset_face_lengths_named(G, param_file, name) +!> Return the modulo value of x in an interval [xc-(Lx/2) xc+(Lx/2)] +!! If Lx<=0, then it returns x without applying modulo arithmetic. +function modulo_around_point(x, xc, Lx) result(x_mod) + real, intent(in) :: x !< Value to which to apply modulo arithmetic + real, intent(in) :: xc !< Center of modulo range + real, intent(in) :: Lx !< Modulo range width + real :: x_mod !< x shifted by an integer multiple of Lx to be close to xc. + + if (Lx > 0.0) then + x_mod = modulo(x - (xc - 0.5*Lx), Lx) + (xc - 0.5*Lx) + else + x_mod = x + endif +end function modulo_around_point + +! ----------------------------------------------------------------------------- +!> This subroutine sets the open face lengths at selected points to restrict +!! passages to their observed widths based on a named set of sizes. +subroutine reset_face_lengths_named(G, param_file, name, US) type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - character(len=*), intent(in) :: name -! This subroutine sets the open face lengths at selected points to restrict -! passages to their observed widths. - -! Arguments: G - The ocean's grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in) name - The name for the set of face lengths. + character(len=*), intent(in) :: name !< The name for the set of face lengths. Only "global_1deg" + !! is currently implemented. + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type + + ! Local variables character(len=256) :: mesg ! Message for error messages. real :: dx_2 = -1.0, dy_2 = -1.0 real :: pi_180 @@ -671,15 +726,14 @@ end subroutine reset_face_lengths_named ! ----------------------------------------------------------------------------- ! ----------------------------------------------------------------------------- -subroutine reset_face_lengths_file(G, param_file) +!> This subroutine sets the open face lengths at selected points to restrict +!! passages to their observed widths from a arrays read from a file. +subroutine reset_face_lengths_file(G, param_file, US) type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters -! This subroutine sets the open face lengths at selected points to restrict -! passages to their observed widths. + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type -! Arguments: G - The ocean's grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. + ! Local variables character(len=40) :: mdl = "reset_face_lengths_file" ! This subroutine's name. character(len=256) :: mesg ! Message for error messages. character(len=200) :: filename, chan_file, inputdir ! Strings for file/path @@ -738,15 +792,14 @@ end subroutine reset_face_lengths_file ! ----------------------------------------------------------------------------- ! ----------------------------------------------------------------------------- -subroutine reset_face_lengths_list(G, param_file) +!> This subroutine sets the open face lengths at selected points to restrict +!! passages to their observed widths from a list read from a file. +subroutine reset_face_lengths_list(G, param_file, US) type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters -! This subroutine sets the open face lengths at selected points to restrict -! passages to their observed widths. + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type -! Arguments: G - The ocean's grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. + ! Local variables character(len=120), pointer, dimension(:) :: lines => NULL() character(len=120) :: line character(len=200) :: filename, chan_file, inputdir, mesg ! Strings for file/path @@ -756,6 +809,8 @@ subroutine reset_face_lengths_list(G, param_file) real, pointer, dimension(:) :: & u_width => NULL(), v_width => NULL() real :: lat, lon ! The latitude and longitude of a point. + real :: len_lon ! The periodic range of longitudes, usually 360 degrees. + real :: len_lat ! The range of latitudes, usually 180 degrees. real :: lon_p, lon_m ! The longitude of a point shifted by 360 degrees. logical :: check_360 ! If true, check for longitudes that are shifted by ! +/- 360 degrees from the specified range of values. @@ -802,6 +857,8 @@ subroutine reset_face_lengths_list(G, param_file) call read_face_length_list(iounit, filename, num_lines, lines) endif + len_lon = 360.0 ; if (G%len_lon > 0.0) len_lon = G%len_lon + len_lat = 180.0 ; if (G%len_lat > 0.0) len_lat = G%len_lat ! Broadcast the number of lines and allocate the required space. call broadcast(num_lines, root_PE()) u_pt = 0 ; v_pt = 0 @@ -843,11 +900,11 @@ subroutine reset_face_lengths_list(G, param_file) read(line(isu+8:),*) u_lon(1:2,u_pt), u_lat(1:2,u_pt), u_width(u_pt) if (is_root_PE()) then if (check_360) then - if ((abs(u_lon(1,u_pt)) > 360.0) .or. (abs(u_lon(2,u_pt)) > 360.0)) & + if ((abs(u_lon(1,u_pt)) > len_lon) .or. (abs(u_lon(2,u_pt)) > len_lon)) & call MOM_error(WARNING, "reset_face_lengths_list : Out-of-bounds "//& "u-longitude found when reading line "//trim(line)//" from file "//& trim(filename)) - if ((abs(u_lat(1,u_pt)) > 180.0) .or. (abs(u_lat(2,u_pt)) > 180.0)) & + if ((abs(u_lat(1,u_pt)) > len_lat) .or. (abs(u_lat(2,u_pt)) > len_lat)) & call MOM_error(WARNING, "reset_face_lengths_list : Out-of-bounds "//& "u-latitude found when reading line "//trim(line)//" from file "//& trim(filename)) @@ -870,11 +927,11 @@ subroutine reset_face_lengths_list(G, param_file) read(line(isv+8:),*) v_lon(1:2,v_pt), v_lat(1:2,v_pt), v_width(v_pt) if (is_root_PE()) then if (check_360) then - if ((abs(v_lon(1,v_pt)) > 360.0) .or. (abs(v_lon(2,v_pt)) > 360.0)) & + if ((abs(v_lon(1,v_pt)) > len_lon) .or. (abs(v_lon(2,v_pt)) > len_lon)) & call MOM_error(WARNING, "reset_face_lengths_list : Out-of-bounds "//& "v-longitude found when reading line "//trim(line)//" from file "//& trim(filename)) - if ((abs(v_lat(1,v_pt)) > 180.0) .or. (abs(v_lat(2,v_pt)) > 180.0)) & + if ((abs(v_lat(1,v_pt)) > len_lat) .or. (abs(v_lat(2,v_pt)) > len_lat)) & call MOM_error(WARNING, "reset_face_lengths_list : Out-of-bounds "//& "v-latitude found when reading line "//trim(line)//" from file "//& trim(filename)) @@ -900,7 +957,7 @@ subroutine reset_face_lengths_list(G, param_file) do j=jsd,jed ; do I=IsdB,IedB lat = G%geoLatCu(I,j) ; lon = G%geoLonCu(I,j) - if (check_360) then ; lon_p = lon+360.0 ; lon_m = lon-360.0 + if (check_360) then ; lon_p = lon+len_lon ; lon_m = lon-len_lon else ; lon_p = lon ; lon_m = lon ; endif do npt=1,u_pt @@ -915,7 +972,8 @@ subroutine reset_face_lengths_list(G, param_file) write(*,'(A,2F8.2,A,4F8.2,A)') "read_face_lengths_list : G%mask2dCu=0 at ",lat,lon," (",& u_lat(1,npt), u_lat(2,npt), u_lon(1,npt), u_lon(2,npt),") so grid metric is unmodified." else - write(*,'(A,2F8.2,A,4F8.2,A5,F9.2,A1)') "read_face_lengths_list : Modifying dy_Cu gridpoint at ",lat,lon," (",& + write(*,'(A,2F8.2,A,4F8.2,A5,F9.2,A1)') & + "read_face_lengths_list : Modifying dy_Cu gridpoint at ",lat,lon," (",& u_lat(1,npt), u_lat(2,npt), u_lon(1,npt), u_lon(2,npt),") to ",G%dy_Cu(I,j),"m" endif endif @@ -929,7 +987,7 @@ subroutine reset_face_lengths_list(G, param_file) do J=JsdB,JedB ; do i=isd,ied lat = G%geoLatCv(i,J) ; lon = G%geoLonCv(i,J) - if (check_360) then ; lon_p = lon+360.0 ; lon_m = lon-360.0 + if (check_360) then ; lon_p = lon+len_lon ; lon_m = lon-len_lon else ; lon_p = lon ; lon_m = lon ; endif do npt=1,v_pt @@ -943,7 +1001,8 @@ subroutine reset_face_lengths_list(G, param_file) write(*,'(A,2F8.2,A,4F8.2,A)') "read_face_lengths_list : G%mask2dCv=0 at ",lat,lon," (",& v_lat(1,npt), v_lat(2,npt), v_lon(1,npt), v_lon(2,npt),") so grid metric is unmodified." else - write(*,'(A,2F8.2,A,4F8.2,A5,F9.2,A1)') "read_face_lengths_list : Modifying dx_Cv gridpoint at ",lat,lon," (",& + write(*,'(A,2F8.2,A,4F8.2,A5,F9.2,A1)') & + "read_face_lengths_list : Modifying dx_Cv gridpoint at ",lat,lon," (",& v_lat(1,npt), v_lat(2,npt), v_lon(1,npt), v_lon(2,npt),") to ",G%dx_Cv(I,j),"m" endif endif @@ -965,11 +1024,12 @@ end subroutine reset_face_lengths_list ! ----------------------------------------------------------------------------- ! ----------------------------------------------------------------------------- +!> This subroutine reads and counts the non-blank lines in the face length list file, after removing comments. subroutine read_face_length_list(iounit, filename, num_lines, lines) - integer, intent(in) :: iounit - character(len=*), intent(in) :: filename - integer, intent(out) :: num_lines - character(len=120), dimension(:), pointer :: lines + integer, intent(in) :: iounit !< An open I/O unit number for the file + character(len=*), intent(in) :: filename !< The name of the face-length file to read + integer, intent(out) :: num_lines !< The number of non-blank lines in the file + character(len=120), dimension(:), pointer :: lines !< The non-blank lines, after removing comments ! This subroutine reads and counts the non-blank lines in the face length ! list file, after removing comments. @@ -1061,8 +1121,8 @@ end subroutine set_velocity_depth_min !! later use in reporting diagnostics subroutine compute_global_grid_integrals(G) type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid - ! Subroutine to pre-compute global integrals of grid quantities for - ! later use in reporting diagnostics + + ! Local variables real, dimension(G%isc:G%iec, G%jsc:G%jec) :: tmpForSumming integer :: i,j @@ -1084,23 +1144,21 @@ end subroutine compute_global_grid_integrals ! ----------------------------------------------------------------------------- !> Write out a file describing the topography, Coriolis parameter, grid locations !! and various other fixed fields from the grid. -subroutine write_ocean_geometry_file(G, param_file, directory, geom_file) - type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid - type(param_file_type), intent(in) :: param_file !< Parameter file structure - character(len=*), intent(in) :: directory !< The directory into which to place the geometry file. - character(len=*), optional, intent(in) :: geom_file !< If present, the name of the geometry file - !! (otherwise the file is "ocean_geometry") -! This subroutine writes out a file containing all of the ocean geometry -! and grid data uses by the MOM ocean model. -! Arguments: G - The ocean's grid structure. Effectively intent in. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in) directory - The directory into which to place the file. +subroutine write_ocean_geometry_file(G, param_file, directory, geom_file, US) + type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid + type(param_file_type), intent(in) :: param_file !< Parameter file structure + character(len=*), intent(in) :: directory !< The directory into which to place the geometry file. + character(len=*), optional, intent(in) :: geom_file !< If present, the name of the geometry file + !! (otherwise the file is "ocean_geometry") + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type + + ! Local variables. character(len=240) :: filepath character(len=40) :: mdl = "write_ocean_geometry_file" integer, parameter :: nFlds=23 type(vardesc) :: vars(nFlds) type(fieldtype) :: fields(nFlds) + real :: Z_to_m_scale ! A unit conversion factor from Z to m. integer :: unit integer :: file_threading integer :: nFlds_used @@ -1117,6 +1175,8 @@ subroutine write_ocean_geometry_file(G, param_file, directory, geom_file) isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + Z_to_m_scale = 1.0 ; if (present(US)) Z_to_m_scale = US%Z_to_m + ! vardesc is a structure defined in MOM_io.F90. The elements of ! this structure, in order, are: ! (1) the variable name for the NetCDF file @@ -1178,14 +1238,15 @@ subroutine write_ocean_geometry_file(G, param_file, directory, geom_file) call create_file(unit, trim(filepath), vars, nFlds_used, fields, & file_threading, dG=G) - do J=Jsq,Jeq; do I=Isq,Ieq; out_q(I,J) = G%geoLatBu(I,J); enddo; enddo + do J=Jsq,Jeq; do I=Isq,Ieq; out_q(I,J) = G%geoLatBu(I,J); enddo ; enddo call write_field(unit, fields(1), G%Domain%mpp_domain, out_q) - do J=Jsq,Jeq; do I=Isq,Ieq; out_q(I,J) = G%geoLonBu(I,J); enddo; enddo + do J=Jsq,Jeq; do I=Isq,Ieq; out_q(I,J) = G%geoLonBu(I,J); enddo ; enddo call write_field(unit, fields(2), G%Domain%mpp_domain, out_q) call write_field(unit, fields(3), G%Domain%mpp_domain, G%geoLatT) call write_field(unit, fields(4), G%Domain%mpp_domain, G%geoLonT) - call write_field(unit, fields(5), G%Domain%mpp_domain, G%bathyT) + do j=js,je ; do i=is,ie ; out_h(i,j) = Z_to_m_scale*G%bathyT(i,j) ; enddo ; enddo + call write_field(unit, fields(5), G%Domain%mpp_domain, out_h) call write_field(unit, fields(6), G%Domain%mpp_domain, G%CoriolisBu) ! I think that all of these copies are holdovers from a much earlier @@ -1201,7 +1262,7 @@ subroutine write_ocean_geometry_file(G, param_file, directory, geom_file) do J=Jsq,Jeq ; do i=is,ie ; out_v(i,J) = G%dyCv(i,J) ; enddo ; enddo call write_field(unit, fields(10), G%Domain%mpp_domain, out_v) - do j=js,je ; do i=is,ie ; out_h(i,j) = G%dxT(i,j); enddo; enddo + do j=js,je ; do i=is,ie ; out_h(i,j) = G%dxT(i,j); enddo ; enddo call write_field(unit, fields(11), G%Domain%mpp_domain, out_h) do j=js,je ; do i=is,ie ; out_h(i,j) = G%dyT(i,j) ; enddo ; enddo call write_field(unit, fields(12), G%Domain%mpp_domain, out_h) @@ -1221,10 +1282,14 @@ subroutine write_ocean_geometry_file(G, param_file, directory, geom_file) call write_field(unit, fields(19), G%Domain%mpp_domain, G%mask2dT) if (G%bathymetry_at_vel) then - call write_field(unit, fields(20), G%Domain%mpp_domain, G%Dblock_u) - call write_field(unit, fields(21), G%Domain%mpp_domain, G%Dopen_u) - call write_field(unit, fields(22), G%Domain%mpp_domain, G%Dblock_v) - call write_field(unit, fields(23), G%Domain%mpp_domain, G%Dopen_v) + do j=js,je ; do I=Isq,Ieq ; out_u(I,j) = Z_to_m_scale*G%Dblock_u(I,j) ; enddo ; enddo + call write_field(unit, fields(20), G%Domain%mpp_domain, out_u) + do j=js,je ; do I=Isq,Ieq ; out_u(I,j) = Z_to_m_scale*G%Dopen_u(I,j) ; enddo ; enddo + call write_field(unit, fields(21), G%Domain%mpp_domain, out_u) + do J=Jsq,Jeq ; do i=is,ie ; out_v(i,J) = Z_to_m_scale*G%Dblock_v(i,J) ; enddo ; enddo + call write_field(unit, fields(22), G%Domain%mpp_domain, out_v) + do J=Jsq,Jeq ; do i=is,ie ; out_v(i,J) = Z_to_m_scale*G%Dopen_v(i,J) ; enddo ; enddo + call write_field(unit, fields(23), G%Domain%mpp_domain, out_v) endif call close_file(unit) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 4ef3af5949..4c7b720f67 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -1,4 +1,4 @@ -!> Initialize state variables, u, v, h, T and S. +!> Initialization functions for state variables, u, v, h, T and S. module MOM_state_initialization ! This file is part of MOM6. See LICENSE.md for the license. @@ -34,8 +34,9 @@ module MOM_state_initialization use MOM_ALE_sponge, only : set_up_ALE_sponge_field, initialize_ALE_sponge use MOM_ALE_sponge, only : ALE_sponge_CS use MOM_string_functions, only : uppercase, lowercase -use MOM_time_manager, only : time_type, set_time +use MOM_time_manager, only : time_type use MOM_tracer_registry, only : tracer_registry_type +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : setVerticalGridAxes, verticalGrid_type use MOM_ALE, only : pressure_gradient_plm @@ -75,7 +76,6 @@ module MOM_state_initialization use Rossby_front_2d_initialization, only : Rossby_front_initialize_thickness use Rossby_front_2d_initialization, only : Rossby_front_initialize_temperature_salinity use Rossby_front_2d_initialization, only : Rossby_front_initialize_velocity -use SCM_idealized_hurricane, only : SCM_idealized_hurricane_TS_init use SCM_CVMix_tests, only: SCM_CVMix_tests_TS_init use dyed_channel_initialization, only : dyed_channel_set_OBC_tracer_data use dyed_obcs_initialization, only : dyed_obcs_set_OBC_data @@ -106,27 +106,31 @@ module MOM_state_initialization public MOM_initialize_state -character(len=40) :: mdl = "MOM_state_initialization" ! This module's name. +! 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. + +character(len=40) :: mdl = "MOM_state_initialization" !< This module's name. contains -! ----------------------------------------------------------------------------- !> Initialize temporally evolving fields, either as initial !! conditions or by reading them from a restart (or saves) file. -subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & +subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & restart_CS, ALE_CSp, tracer_Reg, sponge_CSp, & ALE_sponge_CSp, OBC, Time_in) 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(out) :: u !< The zonal velocity that is being initialized, - !! in m s-1 + intent(out) :: u !< The zonal velocity that is being + !! initialized [m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & intent(out) :: v !< The meridional velocity that is being - !! initialized, in m s-1 + !! initialized [m s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(out) :: h !< Layer thicknesses, in H (usually m or - !! kg m-2) + intent(out) :: h !< Layer thicknesses [H ~> m or kg m-2] type(thermo_var_ptrs), intent(inout) :: tv !< A structure pointing to various thermodynamic !! variables type(time_type), intent(inout) :: Time !< Time at the start of the run segment. @@ -136,32 +140,33 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & !! directory paths. type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control !! structure. - type(ALE_CS), pointer :: ALE_CSp - type(tracer_registry_type), pointer :: tracer_Reg - type(sponge_CS), pointer :: sponge_CSp - type(ALE_sponge_CS), pointer :: ALE_sponge_CSp - type(ocean_OBC_type), pointer :: OBC + type(ALE_CS), pointer :: ALE_CSp !< The ALE control structure for remapping + type(tracer_registry_type), pointer :: tracer_Reg !< A pointer to the tracer registry + type(sponge_CS), pointer :: sponge_CSp !< The layerwise sponge control structure. + type(ALE_sponge_CS), pointer :: ALE_sponge_CSp !< The ALE sponge control structure. + type(ocean_OBC_type), pointer :: OBC !< The open boundary condition control structure. type(time_type), optional, intent(in) :: Time_in !< Time at the start of the run segment. !! Time_in overrides any value set for Time. - -! Local variables + ! Local variables character(len=200) :: filename ! The name of an input file. character(len=200) :: filename2 ! The name of an input files. character(len=200) :: inputdir ! The directory where NetCDF input files are. character(len=200) :: config + real :: H_rescale ! A rescaling factor for thicknesses from the representation in + ! a restart file to the internal representation in this run. + real :: dt ! The baroclinic dynamics timestep for this run [s]. logical :: from_Z_file, useALE logical :: new_sim integer :: write_geom logical :: use_temperature, use_sponge, use_OBC - logical :: use_EOS ! If true, density is calculated from T & S using an - ! equation of state. + logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. logical :: depress_sfc ! If true, remove the mass that would be displaced ! by a large surface pressure by squeezing the column. logical :: trim_ic_for_p_surf ! If true, remove the mass that would be displaced ! by a large surface pressure, such as with an ice sheet. logical :: regrid_accelerate integer :: regrid_iterations - logical :: Analytic_FV_PGF, obsol_test +! logical :: Analytic_FV_PGF, obsol_test logical :: convert logical :: just_read ! If true, only read the parameters because this ! is a run from a restart file; this option @@ -176,8 +181,6 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - real :: dt - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -202,10 +205,10 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & use_OBC = associated(OBC) if (use_EOS) eos => tv%eqn_of_state -!==================================================================== -! Initialize temporally evolving fields, either as initial -! conditions or by reading them from a restart (or saves) file. -!==================================================================== + !==================================================================== + ! Initialize temporally evolving fields, either as initial + ! conditions or by reading them from a restart (or saves) file. + !==================================================================== if (new_sim) then call MOM_mesg("Run initialized internally.", 3) @@ -231,14 +234,14 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & "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. + ! Initialize thickness and T/S from z-coordinate data in a file. if (.NOT.use_temperature) call MOM_error(FATAL,"MOM_initialize_state : "//& "use_temperature must be true if INIT_LAYERS_FROM_Z_FILE is true") - call MOM_temp_salt_initialize_from_Z(h, tv, G, GV, PF, just_read_params=just_read) + call MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_params=just_read) else -! Initialize thickness, h. + ! Initialize thickness, h. call get_param(PF, mdl, "THICKNESS_CONFIG", config, & "A string that determines how the initial layer \n"//& "thicknesses are specified for a new run: \n"//& @@ -268,8 +271,10 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & " \t USER - call a user modified routine.", & fail_if_missing=new_sim, do_not_log=just_read) select case (trim(config)) - case ("file"); call initialize_thickness_from_file(h, G, GV, PF, .false., just_read_params=just_read) - case ("thickness_file"); call initialize_thickness_from_file(h, G, GV, PF, .true., just_read_params=just_read) + case ("file") + call initialize_thickness_from_file(h, G, GV, US, PF, .false., just_read_params=just_read) + case ("thickness_file") + call initialize_thickness_from_file(h, G, GV, US, PF, .true., just_read_params=just_read) case ("coord") if (new_sim .and. useALE) then call ALE_initThicknessToCoord( ALE_CSp, G, GV, h ) @@ -279,35 +284,35 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & endif case ("uniform"); call initialize_thickness_uniform(h, G, GV, PF, & just_read_params=just_read) - case ("list"); call initialize_thickness_list(h, G, GV, PF, & + case ("list"); call initialize_thickness_list(h, G, GV, US, PF, & just_read_params=just_read) case ("DOME"); call DOME_initialize_thickness(h, G, GV, PF, & just_read_params=just_read) - case ("ISOMIP"); call ISOMIP_initialize_thickness(h, G, GV, PF, tv, & + case ("ISOMIP"); call ISOMIP_initialize_thickness(h, G, GV, US, PF, tv, & just_read_params=just_read) - case ("benchmark"); call benchmark_initialize_thickness(h, G, GV, PF, & + case ("benchmark"); call benchmark_initialize_thickness(h, G, GV, US, PF, & tv%eqn_of_state, tv%P_Ref, just_read_params=just_read) - case ("Neverland"); call Neverland_initialize_thickness(h, G, GV, PF, & + case ("Neverland"); call Neverland_initialize_thickness(h, G, GV, US, PF, & tv%eqn_of_state, tv%P_Ref) case ("search"); call initialize_thickness_search case ("circle_obcs"); call circle_obcs_initialize_thickness(h, G, GV, PF, & just_read_params=just_read) - case ("lock_exchange"); call lock_exchange_initialize_thickness(h, G, GV, & + case ("lock_exchange"); call lock_exchange_initialize_thickness(h, G, GV, US, & PF, just_read_params=just_read) - case ("external_gwave"); call external_gwave_initialize_thickness(h, G, GV, & + case ("external_gwave"); call external_gwave_initialize_thickness(h, G, GV, US, & PF, just_read_params=just_read) - case ("DOME2D"); call DOME2d_initialize_thickness(h, G, GV, PF, & + case ("DOME2D"); call DOME2d_initialize_thickness(h, G, GV, US, PF, & just_read_params=just_read) - case ("adjustment2d"); call adjustment_initialize_thickness(h, G, GV, & + case ("adjustment2d"); call adjustment_initialize_thickness(h, G, GV, US, & PF, just_read_params=just_read) - case ("sloshing"); call sloshing_initialize_thickness(h, G, GV, PF, & + case ("sloshing"); call sloshing_initialize_thickness(h, G, GV, US, PF, & just_read_params=just_read) - case ("seamount"); call seamount_initialize_thickness(h, G, GV, PF, & + case ("seamount"); call seamount_initialize_thickness(h, G, GV, US, PF, & just_read_params=just_read) - case ("dumbbell"); call dumbbell_initialize_thickness(h, G, GV, PF, & + case ("dumbbell"); call dumbbell_initialize_thickness(h, G, GV, US, PF, & just_read_params=just_read) - case ("soliton"); call soliton_initialize_thickness(h, G, GV) - case ("phillips"); call Phillips_initialize_thickness(h, G, GV, PF, & + case ("soliton"); call soliton_initialize_thickness(h, G, GV, US) + case ("phillips"); call Phillips_initialize_thickness(h, G, GV, US, PF, & just_read_params=just_read) case ("rossby_front"); call Rossby_front_initialize_thickness(h, G, GV, & PF, just_read_params=just_read) @@ -317,7 +322,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & "Unrecognized layer thickness configuration "//trim(config)) end select -! Initialize temperature and salinity (T and S). + ! 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"//& @@ -337,11 +342,10 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & " \t seamount - no motion test with seamount ICs. \n"//& " \t dumbbell - sloshing channel ICs. \n"//& " \t rossby_front - a mixed layer front in thermal wind balance.\n"//& - " \t SCM_ideal_hurr - used in the SCM idealized hurricane test.\n"//& " \t SCM_CVMix_tests - used in the SCM CVMix tests.\n"//& " \t USER - call a user modified routine.", & fail_if_missing=new_sim, do_not_log=just_read) -! " \t baroclinic_zone - an analytic baroclinic zone. \n"//& +! " \t baroclinic_zone - an analytic baroclinic zone. \n"//& select case (trim(config)) case ("fit"); call initialize_temp_salt_fit(tv%T, tv%S, G, GV, PF, & eos, tv%P_Ref, just_read_params=just_read) @@ -360,7 +364,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & case ("adjustment2d"); call adjustment_initialize_temperature_salinity ( tv%T, & tv%S, h, G, GV, PF, eos, just_read_params=just_read) case ("baroclinic_zone"); call baroclinic_zone_init_temperature_salinity( tv%T, & - tv%S, h, G, GV, PF, just_read_params=just_read) + tv%S, h, G, GV, US, PF, just_read_params=just_read) case ("sloshing"); call sloshing_initialize_temperature_salinity(tv%T, & tv%S, h, G, GV, PF, eos, just_read_params=just_read) case ("seamount"); call seamount_initialize_temperature_salinity(tv%T, & @@ -369,10 +373,8 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & tv%S, h, G, GV, PF, eos, just_read_params=just_read) case ("rossby_front"); call Rossby_front_initialize_temperature_salinity ( tv%T, & tv%S, h, G, GV, PF, eos, just_read_params=just_read) - case ("SCM_ideal_hurr"); call SCM_idealized_hurricane_TS_init ( tv%T, & - tv%S, h, G, GV, PF, just_read_params=just_read) - case ("SCM_CVMix_tests"); call SCM_CVMix_tests_TS_init (tv%T, & - tv%S, h, G, GV, PF, just_read_params=just_read) + case ("SCM_CVMix_tests"); call SCM_CVMix_tests_TS_init(tv%T, tv%S, h, & + G, GV, US, PF, just_read_params=just_read) case ("dense"); call dense_water_initialize_TS(G, GV, PF, eos, tv%T, tv%S, & h, just_read_params=just_read) case ("USER"); call user_init_temperature_salinity(tv%T, tv%S, G, PF, eos, & @@ -388,7 +390,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & ! The thicknesses in halo points might be needed to initialize the velocities. if (new_sim) call pass_var(h, G%Domain) -! Initialize velocity components, u and v + ! Initialize velocity components, u and v call get_param(PF, mdl, "VELOCITY_CONFIG", config, & "A string that determines how the initial velocities \n"//& "are specified for a new run: \n"//& @@ -410,7 +412,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & just_read_params=just_read) case ("circular"); call initialize_velocity_circular(u, v, G, PF, & just_read_params=just_read) - case ("phillips"); call Phillips_initialize_velocity(u, v, G, GV, PF, & + case ("phillips"); call Phillips_initialize_velocity(u, v, G, GV, US, PF, & just_read_params=just_read) case ("rossby_front"); call Rossby_front_initialize_velocity(u, v, h, & G, GV, PF, just_read_params=just_read) @@ -426,8 +428,8 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & call uvchksum("MOM_initialize_state [uv]", u, v, G%HI, haloshift=1) endif -! Optionally convert the thicknesses from m to kg m-2. This is particularly -! useful in a non-Boussinesq model. + ! 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"//& @@ -436,9 +438,9 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & if (new_sim .and. convert .and. .not.GV%Boussinesq) & ! Convert thicknesses from geomtric distances to mass-per-unit-area. - call convert_thickness(h, G, GV, tv) + call convert_thickness(h, G, GV, US, tv) -! Remove the mass that would be displaced by an ice shelf or inverse barometer. + ! 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"//& "tsunamis when a large surface pressure is applied.", & @@ -450,8 +452,10 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & do_not_log=just_read) if (depress_sfc .and. trim_ic_for_p_surf) call MOM_error(FATAL, "MOM_initialize_state: "//& "DEPRESS_INITIAL_SURFACE and TRIM_IC_FOR_P_SURF are exclusive and cannot both be True") - if (depress_sfc) call depress_surface(h, G, GV, PF, tv, just_read_params=just_read) - if (trim_ic_for_p_surf) call trim_for_ice(PF, G, GV, ALE_CSp, tv, h, just_read_params=just_read) + if (new_sim .and. debug .and. (depress_sfc .or. trim_ic_for_p_surf)) & + call hchksum(h, "Pre-depress: h ", G%HI, haloshift=1, scale=GV%H_to_m) + if (depress_sfc) call depress_surface(h, G, GV, US, PF, tv, just_read_params=just_read) + if (trim_ic_for_p_surf) call trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read_params=just_read) ! Perhaps we want to run the regridding coordinate generator for multiple ! iterations here so the initial grid is consistent with the coordinate @@ -469,18 +473,25 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & call get_param(PF, mdl, "DT", dt, "Timestep", fail_if_missing=.true.) - call ALE_regrid_accelerated(ALE_CSp, G, GV, h, tv, regrid_iterations, u, v, tracer_Reg, dt=dt, initial=.true.) + if (new_sim .and. debug) & + call hchksum(h, "Pre-ALE_regrid: h ", G%HI, haloshift=1, scale=GV%H_to_m) + call ALE_regrid_accelerated(ALE_CSp, G, GV, h, tv, regrid_iterations, u, v, tracer_Reg, & + dt=dt, initial=.true.) endif endif ! This is the end of the block of code that might have initialized fields ! internally at the start of a new run. if (.not.new_sim) then ! This block restores the state from a restart file. - ! This line calls a subroutine that reads the initial conditions ! - ! from a previously generated file. ! + ! This line calls a subroutine that reads the initial conditions + ! from a previously generated file. call restore_state(dirs%input_filename, dirs%restart_input_dir, Time, & G, restart_CS) if (present(Time_in)) Time = Time_in + if ((GV%m_to_H_restart /= 0.0) .and. (GV%m_to_H_restart /= GV%m_to_H)) then + H_rescale = GV%m_to_H / GV%m_to_H_restart + do k=1,nz ; do j=js,je ; do i=is,ie ; h(i,j,k) = H_rescale * h(i,j,k) ; enddo ; enddo ; enddo + endif endif if ( use_temperature ) then @@ -499,7 +510,6 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & write(mesg,'("MOM_IS: S[",I2,"]")') k call hchksum(tv%S(:,:,k), mesg, G%HI, haloshift=1) enddo ; endif - endif call get_param(PF, mdl, "SPONGE", use_sponge, & @@ -518,23 +528,21 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & " \t\t for buoyancy-forced basin case.\n"//& " \t USER - call a user modified routine.", default="file") select case (trim(config)) - case ("DOME"); call DOME_initialize_sponges(G, GV, tv, PF, sponge_CSp) + case ("DOME"); call DOME_initialize_sponges(G, GV, US, tv, PF, sponge_CSp) case ("DOME2D"); call DOME2d_initialize_sponges(G, GV, tv, PF, useALE, & sponge_CSp, ALE_sponge_CSp) - case ("ISOMIP"); call ISOMIP_initialize_sponges(G, GV, tv, PF, useALE, & - sponge_CSp, ALE_sponge_CSp) - case ("USER"); call user_initialize_sponges(G, use_temperature, tv, & - PF, sponge_CSp, h) - case ("BFB"); call BFB_initialize_sponges_southonly(G, use_temperature, tv, & - PF, sponge_CSp, h) - case ("DUMBBELL"); call dumbbell_initialize_sponges(G, GV, tv, & - PF, useALE, sponge_CSp, ALE_sponge_CSp) - case ("phillips"); call Phillips_initialize_sponges(G, use_temperature, tv, & - PF, sponge_CSp, h) + case ("ISOMIP"); call ISOMIP_initialize_sponges(G, GV, US, tv, 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) + case ("DUMBBELL"); call dumbbell_initialize_sponges(G, GV, US, tv, PF, useALE, & + sponge_CSp, ALE_sponge_CSp) + case ("phillips"); call Phillips_initialize_sponges(G, GV, US, tv, PF, sponge_CSp, h) case ("dense"); call dense_water_initialize_sponges(G, GV, tv, PF, useALE, & - sponge_CSp, ALE_sponge_CSp) - case ("file"); call initialize_sponges_file(G, GV, use_temperature, tv, & - PF, sponge_CSp, ALE_sponge_CSp, Time) + sponge_CSp, ALE_sponge_CSp) + case ("file"); call initialize_sponges_file(G, GV, US, use_temperature, tv, PF, & + sponge_CSp, ALE_sponge_CSp, Time) case default ; call MOM_error(FATAL, "MOM_initialize_state: "//& "Unrecognized sponge configuration "//trim(config)) end select @@ -557,7 +565,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & " tidal_bay - Flather with tidal forcing on eastern boundary\n"//& " USER - user specified", default="none") if (trim(config) == "DOME") then - call DOME_set_OBC_data(OBC, tv, G, GV, PF, tracer_Reg) + call DOME_set_OBC_data(OBC, tv, G, GV, US, PF, tracer_Reg) elseif (trim(config) == "dyed_channel") then call dyed_channel_set_OBC_tracer_data(OBC, G, GV, PF, tracer_Reg) OBC%update_OBC = .true. @@ -596,36 +604,28 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & call callTree_leave('MOM_initialize_state()') end subroutine MOM_initialize_state -! ----------------------------------------------------------------------------- -! ----------------------------------------------------------------------------- -!> This subroutine reads the layer thicknesses or interface heights from a file. -subroutine initialize_thickness_from_file(h, G, GV, param_file, file_has_thickness, just_read_params) +!> Reads the layer thicknesses or interface heights from a file. +subroutine initialize_thickness_from_file(h, G, GV, US, param_file, file_has_thickness, & + just_read_params) 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 real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized, in m. + intent(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2]. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file - !! to parse for model parameter values. + !! to parse for model parameter values. logical, intent(in) :: file_has_thickness !< If true, this file contains layer - !! thicknesses; otherwise it contains - !! interface heights. + !! thicknesses; otherwise it contains + !! interface heights. logical, optional, intent(in) :: just_read_params !< If present and true, this call will - !! only read parameters without changing h. + !! only read parameters without changing h. -! Arguments: h - The thickness that is being initialized. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in) file_has_thickness - If true, this file contains thicknesses; -! otherwise it contains interface heights. - -! This subroutine reads the layer thicknesses from file. - real :: eta(SZI_(G),SZJ_(G),SZK_(G)+1) + ! Local variables + real :: eta(SZI_(G),SZJ_(G),SZK_(G)+1) ! Interface heights, in depth units. integer :: inconsistent = 0 logical :: correct_thickness - logical :: just_read ! If true, just read parameters but set nothing. character(len=20) :: verticalCoordinate + logical :: just_read ! If true, just read parameters but set nothing. character(len=40) :: mdl = "initialize_thickness_from_file" ! This subroutine's name. character(len=200) :: filename, thickness_file, inputdir, mesg ! Strings for file/path integer :: i, j, k, is, ie, js, je, nz @@ -652,10 +652,7 @@ subroutine initialize_thickness_from_file(h, G, GV, param_file, file_has_thickne if (file_has_thickness) then !### Consider adding a parameter to use to rescale h. if (just_read) return ! All run-time parameters have been read, so return. - call MOM_read_data(filename, "h", h(:,:,:), G%Domain) - do k=1,nz ; do j=js,je ; do i=is,ie - h(i,j,k) = GV%m_to_H * h(i,j,k) - enddo ; enddo ; enddo + 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"//& @@ -663,22 +660,22 @@ subroutine initialize_thickness_from_file(h, G, GV, param_file, file_has_thickne "would indicate.", default=.false., do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. - call MOM_read_data(filename, "eta", eta(:,:,:), G%Domain) + call MOM_read_data(filename, "eta", eta(:,:,:), G%Domain, scale=US%m_to_Z) if (correct_thickness) then - call adjustEtaToFitBathymetry(G, GV, eta, h) + call adjustEtaToFitBathymetry(G, GV, US, eta, h) else do k=nz,1,-1 ; do j=js,je ; do i=is,ie - if (eta(i,j,K) < (eta(i,j,K+1) + GV%Angstrom_z)) then - eta(i,j,K) = eta(i,j,K+1) + GV%Angstrom_z - h(i,j,k) = GV%Angstrom + if (eta(i,j,K) < (eta(i,j,K+1) + GV%Angstrom_Z)) then + eta(i,j,K) = eta(i,j,K+1) + GV%Angstrom_Z + h(i,j,k) = GV%Angstrom_H else - h(i,j,k) = GV%m_to_H * (eta(i,j,K) - eta(i,j,K+1)) + h(i,j,k) = GV%Z_to_H * (eta(i,j,K) - eta(i,j,K+1)) endif enddo ; enddo ; enddo do j=js,je ; do i=is,ie - if (abs(eta(i,j,nz+1) + G%bathyT(i,j)) > 1.0) & + if (abs(eta(i,j,nz+1) + G%bathyT(i,j)) > 1.0*US%m_to_Z) & inconsistent = inconsistent + 1 enddo ; enddo call sum_across_PEs(inconsistent) @@ -693,31 +690,29 @@ subroutine initialize_thickness_from_file(h, G, GV, param_file, file_has_thickne endif call callTree_leave(trim(mdl)//'()') end subroutine initialize_thickness_from_file -! ----------------------------------------------------------------------------- -! ----------------------------------------------------------------------------- !> Adjust interface heights to fit the bathymetry and diagnose layer thickness. +!! !! If the bottom most interface is below the topography then the bottom-most -!! layers are contracted to GV%Angstrom_z. +!! layers are contracted to GV%Angstrom_m. !! If the bottom most interface is above the topography then the entire column !! is dilated (expanded) to fill the void. !! @remark{There is a (hard-wired) "tolerance" parameter such that the !! criteria for adjustment must equal or exceed 10cm.} -!! @param[in] G Grid type -!! @param[in,out] eta Interface heights -!! @param[out] h Layer thicknesses -subroutine adjustEtaToFitBathymetry(G, GV, eta, h) - 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)+1), intent(inout) :: eta !< Interface heights, in m - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(inout) :: h !< Layer thicknesses, in H +subroutine adjustEtaToFitBathymetry(G, GV, US, eta, h) + 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 + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: eta !< Interface heights [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] ! Local variables integer :: i, j, k, is, ie, js, je, nz, contractions, dilations - real, parameter :: hTolerance = 0.1 !< Tolerance to exceed adjustment criteria (m) + real :: hTolerance = 0.1 !< Tolerance to exceed adjustment criteria [Z ~> m] real :: hTmp, eTmp, dilate character(len=100) :: mesg is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + hTolerance = 0.1*US%m_to_Z contractions = 0 do j=js,je ; do i=is,ie @@ -733,14 +728,14 @@ subroutine adjustEtaToFitBathymetry(G, GV, eta, h) call MOM_error(WARNING, 'adjustEtaToFitBathymetry: '//mesg) endif - ! To preserve previous answers, delay converting thicknesses to units of H - ! until the end of this routine. + ! To preserve previous answers in non-Boussinesq cases, delay converting + ! thicknesses to units of H until the end of this routine. do k=nz,1,-1 ; do j=js,je ; do i=is,ie ! Collapse layers to thinnest possible if the thickness less than ! the thinnest possible (or negative). - if (eta(i,j,K) < (eta(i,j,K+1) + GV%Angstrom_z)) then - eta(i,j,K) = eta(i,j,K+1) + GV%Angstrom_z - h(i,j,k) = GV%Angstrom_z + if (eta(i,j,K) < (eta(i,j,K+1) + GV%Angstrom_Z)) then + eta(i,j,K) = eta(i,j,K+1) + GV%Angstrom_Z + h(i,j,k) = GV%Angstrom_Z else h(i,j,k) = (eta(i,j,K) - eta(i,j,K+1)) endif @@ -754,9 +749,9 @@ subroutine adjustEtaToFitBathymetry(G, GV, eta, h) if (-eta(i,j,nz+1) < G%bathyT(i,j) - hTolerance) then dilations = dilations + 1 if (eta(i,j,1) <= eta(i,j,nz+1)) then - do k=1,nz ; h(i,j,k) = (eta(i,j,1)+G%bathyT(i,j)) / real(nz) ; enddo + do k=1,nz ; h(i,j,k) = (eta(i,j,1) + G%bathyT(i,j)) / real(nz) ; enddo else - dilate = (eta(i,j,1)+G%bathyT(i,j)) / (eta(i,j,1)-eta(i,j,nz+1)) + dilate = (eta(i,j,1) + G%bathyT(i,j)) / (eta(i,j,1) - eta(i,j,nz+1)) do k=1,nz ; h(i,j,k) = h(i,j,k) * dilate ; enddo endif do k=nz,2,-1 ; eta(i,j,K) = eta(i,j,K+1) + h(i,j,k) ; enddo @@ -765,7 +760,7 @@ subroutine adjustEtaToFitBathymetry(G, GV, eta, h) ! Now convert thicknesses to units of H. do k=1,nz ; do j=js,je ; do i=is,ie - h(i,j,k) = h(i,j,k)*GV%m_to_H + h(i,j,k) = h(i,j,k)*GV%Z_to_H enddo ; enddo ; enddo call sum_across_PEs(dilations) @@ -776,32 +771,24 @@ subroutine adjustEtaToFitBathymetry(G, GV, eta, h) endif end subroutine adjustEtaToFitBathymetry -! ----------------------------------------------------------------------------- -! ----------------------------------------------------------------------------- +!> Initializes thickness to be uniform subroutine initialize_thickness_uniform(h, G, GV, param_file, just_read_params) 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_(GV)), & - intent(out) :: h !< The thickness that is being initialized, in H. + intent(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2]. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. logical, optional, intent(in) :: just_read_params !< If present and true, this call will !! only read parameters without changing h. - -! Arguments: h - The thickness that is being initialized. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. - -! This subroutine initializes the layer thicknesses to be uniform. + ! Local variables character(len=40) :: mdl = "initialize_thickness_uniform" ! This subroutine's name. - real :: e0(SZK_(G)+1) ! The resting interface heights, in m, usually ! - ! negative because it is positive upward. ! - real :: eta1D(SZK_(G)+1)! Interface height relative to the sea surface ! - ! positive upward, in m. ! - logical :: just_read ! If true, just read parameters but set nothing. character(len=20) :: verticalCoordinate + real :: e0(SZK_(G)+1) ! The resting interface heights, in depth units, usually + ! negative because it is positive upward. + real :: eta1D(SZK_(G)+1)! Interface height relative to the sea surface + ! positive upward, in depth units. + logical :: just_read ! If true, just read parameters but set nothing. integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -820,51 +807,44 @@ subroutine initialize_thickness_uniform(h, G, GV, param_file, just_read_params) enddo do j=js,je ; do i=is,ie -! This sets the initial thickness (in m) of the layers. The ! -! thicknesses are set to insure that: 1. each layer is at least an ! -! Angstrom thick, and 2. the interfaces are where they should be ! -! based on the resting depths and interface height perturbations, ! -! as long at this doesn't interfere with 1. ! - eta1D(nz+1) = -1.0*G%bathyT(i,j) + ! This sets the initial thickness (in m) of the layers. The + ! thicknesses are set to insure that: 1. each layer is at least an + ! Angstrom thick, and 2. the interfaces are where they should be + ! based on the resting depths and interface height perturbations, + ! as long at this doesn't interfere with 1. + eta1D(nz+1) = -G%bathyT(i,j) do k=nz,1,-1 eta1D(K) = e0(K) - if (eta1D(K) < (eta1D(K+1) + GV%Angstrom_z)) then - eta1D(K) = eta1D(K+1) + GV%Angstrom_z - h(i,j,k) = GV%Angstrom + if (eta1D(K) < (eta1D(K+1) + GV%Angstrom_Z)) then + eta1D(K) = eta1D(K+1) + GV%Angstrom_Z + h(i,j,k) = GV%Angstrom_H else - h(i,j,k) = GV%m_to_H * (eta1D(K) - eta1D(K+1)) + h(i,j,k) = GV%Z_to_H * (eta1D(K) - eta1D(K+1)) endif enddo enddo ; enddo call callTree_leave(trim(mdl)//'()') end subroutine initialize_thickness_uniform -! ----------------------------------------------------------------------------- -! ----------------------------------------------------------------------------- -subroutine initialize_thickness_list(h, G, GV, param_file, just_read_params) +!> Initialize thickness from a 1D list +subroutine initialize_thickness_list(h, G, GV, US, param_file, just_read_params) 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 real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized, in H. + intent(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2]. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. logical, optional, intent(in) :: just_read_params !< If present and true, this call will !! only read parameters without changing h. - -! Arguments: h - The thickness that is being initialized. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. - -! This subroutine initializes the layer thicknesses to be uniform. + ! Local variables character(len=40) :: mdl = "initialize_thickness_list" ! This subroutine's name. - real :: e0(SZK_(G)+1) ! The resting interface heights, in m, usually ! - ! negative because it is positive upward. ! - real :: eta1D(SZK_(G)+1)! Interface height relative to the sea surface ! - ! positive upward, in m. ! - logical :: just_read ! If true, just read parameters but set nothing. character(len=20) :: verticalCoordinate + real :: e0(SZK_(G)+1) ! The resting interface heights, in depth units [Z ~> m], + ! usually negative because it is positive upward. + real :: eta1D(SZK_(G)+1)! Interface height relative to the sea surface + ! positive upward, in depth units [Z ~> m]. + logical :: just_read ! If true, just read parameters but set nothing. character(len=200) :: filename, eta_file, inputdir ! Strings for file/path character(len=72) :: eta_var integer :: i, j, k, is, ie, js, je, nz @@ -890,7 +870,7 @@ subroutine initialize_thickness_list(h, G, GV, param_file, just_read_params) call log_param(param_file, mdl, "INPUTDIR/INTERFACE_IC_FILE", filename) e0(:) = 0.0 - call MOM_read_data(filename, eta_var, e0(:)) + call MOM_read_data(filename, eta_var, e0(:), scale=US%m_to_Z) if ((abs(e0(1)) - 0.0) > 0.001) then ! This list probably starts with the interior interface, so shift it up. @@ -898,62 +878,55 @@ subroutine initialize_thickness_list(h, G, GV, param_file, just_read_params) e0(1) = 0.0 endif - if (e0(2) > e0(1)) then - ! Switch to the convention for interface heights increasing upward. - do k=1,nz - e0(K) = -e0(K) - enddo + if (e0(2) > e0(1)) then ! Switch to the convention for interface heights increasing upward. + do k=1,nz ; e0(K) = -e0(K) ; enddo endif do j=js,je ; do i=is,ie -! This sets the initial thickness (in m) of the layers. The ! -! thicknesses are set to insure that: 1. each layer is at least an ! -! Angstrom thick, and 2. the interfaces are where they should be ! -! based on the resting depths and interface height perturbations, ! -! as long at this doesn't interfere with 1. ! - eta1D(nz+1) = -1.0*G%bathyT(i,j) + ! This sets the initial thickness (in m) of the layers. The + ! thicknesses are set to insure that: 1. each layer is at least an + ! Angstrom thick, and 2. the interfaces are where they should be + ! based on the resting depths and interface height perturbations, + ! as long at this doesn't interfere with 1. + eta1D(nz+1) = -G%bathyT(i,j) do k=nz,1,-1 eta1D(K) = e0(K) - if (eta1D(K) < (eta1D(K+1) + GV%Angstrom_z)) then - eta1D(K) = eta1D(K+1) + GV%Angstrom_z - h(i,j,k) = GV%Angstrom + if (eta1D(K) < (eta1D(K+1) + GV%Angstrom_Z)) then + eta1D(K) = eta1D(K+1) + GV%Angstrom_Z + h(i,j,k) = GV%Angstrom_H else - h(i,j,k) = GV%m_to_H * (eta1D(K) - eta1D(K+1)) + h(i,j,k) = GV%Z_to_H * (eta1D(K) - eta1D(K+1)) endif enddo enddo ; enddo call callTree_leave(trim(mdl)//'()') end subroutine initialize_thickness_list -! ----------------------------------------------------------------------------- -! ----------------------------------------------------------------------------- +!> Search density space for location of layers (not implemented!) subroutine initialize_thickness_search -! search density space for location of layers call MOM_error(FATAL," MOM_state_initialization.F90, initialize_thickness_search: NOT IMPLEMENTED") end subroutine initialize_thickness_search -! ----------------------------------------------------------------------------- -subroutine convert_thickness(h, G, GV, tv) - 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(inout) :: h !< Input eometric layer thicknesses (in H units), - !! being converted to layer pressure - !! thicknesses (also in H units). - type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various - !! thermodynamic variables -! Arguments: h - The thickness that is being initialized. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. +!> Converts thickness from geometric to pressure units +subroutine convert_thickness(h, G, GV, US, tv) + 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 + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(inout) :: h !< Input geometric layer thicknesses being converted + !! to layer pressure [H ~> m or kg m-2]. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables + ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & p_top, p_bot real :: dz_geo(SZI_(G),SZJ_(G)) ! The change in geopotential height - ! across a layer, in m2 s-2. + ! across a layer [m2 s-2]. real :: rho(SZI_(G)) real :: I_gEarth - real :: Hm_rho_to_Pa ! A conversion factor from the input geometric thicknesses - ! times the layer densities into Pa, in Pa m3 / H kg. + real :: Hm_rho_to_Pa ! A conversion factor from the input geometric thicknesses times the + ! layer densities into Pa [Pa m3 H-1 kg-1 ~> s-2 m2 or s-2 m5 kg-1]. logical :: Boussinesq integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz integer :: itt, max_itt @@ -962,8 +935,8 @@ subroutine convert_thickness(h, G, GV, tv) Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB max_itt = 10 Boussinesq = GV%Boussinesq - I_gEarth = 1.0 / GV%g_Earth - Hm_rho_to_Pa = (GV%g_Earth * GV%H_to_m) ! = GV%H_to_Pa / GV%Rho0 + I_gEarth = 1.0 / (GV%g_Earth*US%m_to_Z) + Hm_rho_to_Pa = GV%g_Earth * GV%H_to_Z ! = GV%H_to_Pa / GV%Rho0 if (Boussinesq) then call MOM_error(FATAL,"Not yet converting thickness with Boussinesq approx.") @@ -1013,26 +986,23 @@ subroutine convert_thickness(h, G, GV, tv) end subroutine convert_thickness -subroutine depress_surface(h, G, GV, param_file, tv, just_read_params) +!> Depress the sea-surface based on an initial condition file +subroutine depress_surface(h, G, GV, US, param_file, tv, just_read_params) 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(inout) :: h !< Layer thicknesses, in H (usually m or kg m-2) + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables logical, optional, intent(in) :: just_read_params !< If present and true, this call will !! only read parameters without changing h. -! Arguments: h - The thickness that is being initialized. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. - + ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & - eta_sfc ! The free surface height that the model should use, in m. + eta_sfc ! The free surface height that the model should use [m]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: & - eta ! The free surface height that the model should use, in m. - real :: dilate ! A ratio by which layers are dilated, nondim. + eta ! The free surface height that the model should use [m]. + real :: dilate ! A ratio by which layers are dilated [nondim]. real :: scale_factor ! A scaling factor for the eta_sfc values that are read ! in, which can be used to change units, for example. character(len=40) :: mdl = "depress_surface" ! This subroutine's name. @@ -1064,14 +1034,10 @@ subroutine depress_surface(h, G, GV, param_file, tv, just_read_params) if (just_read) return ! All run-time parameters have been read, so return. - call MOM_read_data(filename, eta_srf_var, eta_sfc, G%Domain) - - if (scale_factor /= 1.0) then ; do j=js,je ; do i=is,ie - eta_sfc(i,j) = eta_sfc(i,j) * scale_factor - enddo ; enddo ; endif + call MOM_read_data(filename, eta_srf_var, eta_sfc, G%Domain, scale=scale_factor) ! Convert thicknesses to interface heights. - call find_eta(h, tv, GV%g_Earth, G, GV, eta) + call find_eta(h, tv, G, GV, US, eta, eta_to_m=1.0) do j=js,je ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then ! if (eta_sfc(i,j) < eta(i,j,nz+1)) then @@ -1092,9 +1058,9 @@ subroutine depress_surface(h, G, GV, param_file, tv, just_read_params) do k=1,nz if (eta(i,j,K) <= eta_sfc(i,j)) exit if (eta(i,j,K+1) >= eta_sfc(i,j)) then - h(i,j,k) = GV%Angstrom + h(i,j,k) = GV%Angstrom_H else - h(i,j,k) = max(GV%Angstrom, h(i,j,k) * & + h(i,j,k) = max(GV%Angstrom_H, h(i,j,k) * & (eta_sfc(i,j) - eta(i,j,K+1)) / (eta(i,j,K) - eta(i,j,K+1)) ) endif enddo @@ -1105,27 +1071,28 @@ end subroutine depress_surface !> Adjust the layer thicknesses by cutting away the top of each model column at the depth !! where the hydrostatic pressure matches an imposed surface pressure read from file. -subroutine trim_for_ice(PF, G, GV, ALE_CSp, tv, h, just_read_params) +subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read_params) type(param_file_type), intent(in) :: PF !< Parameter file structure - 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 !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(ALE_CS), pointer :: ALE_CSp !< ALE control structure type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamics structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(inout) :: h !< Layer thickness (H units, m or Pa) + intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] logical, optional, intent(in) :: just_read_params !< If present and true, this call will !! only read parameters without changing h. - ! Local variables character(len=200) :: mdl = "trim_for_ice" - real, dimension(SZI_(G),SZJ_(G)) :: p_surf ! Imposed pressure on ocean at surface (Pa) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: S_t, S_b, T_t, T_b ! Top and bottom edge values for reconstructions - ! of salinity and temperature within each layer. + real, dimension(SZI_(G),SZJ_(G)) :: p_surf ! Imposed pressure on ocean at surface [Pa] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: S_t, S_b ! Top and bottom edge values for reconstructions + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: T_t, T_b ! of salinity and temperature within each layer. character(len=200) :: inputdir, filename, p_surf_file, p_surf_var ! Strings for file/path - real :: scale_factor, min_thickness + real :: scale_factor ! A file-dependent scaling vactor for the input pressurs. + real :: min_thickness ! The minimum layer thickness, recast into Z units. integer :: i, j, k logical :: just_read ! If true, just read parameters but set nothing. - logical :: use_remapping + logical :: use_remapping ! If true, remap the initial conditions. type(remapping_CS), pointer :: remap_CS => NULL() just_read = .false. ; if (present(just_read_params)) just_read = just_read_params @@ -1145,15 +1112,14 @@ subroutine trim_for_ice(PF, G, GV, ALE_CSp, tv, h, just_read_params) "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', & - units='m', default=1.e-3, do_not_log=just_read) + units='m', default=1.e-3, do_not_log=just_read, scale=US%m_to_Z) call get_param(PF, mdl, "TRIMMING_USES_REMAPPING", use_remapping, & 'When trimming the column, also remap T and S.', & default=.false., do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. - call MOM_read_data(filename, p_surf_var, p_surf, G%Domain) - if (scale_factor /= 1.) p_surf(:,:) = scale_factor * p_surf(:,:) + call MOM_read_data(filename, p_surf_var, p_surf, G%Domain, scale=scale_factor) if (use_remapping) then allocate(remap_CS) @@ -1172,32 +1138,38 @@ subroutine trim_for_ice(PF, G, GV, ALE_CSp, tv, h, just_read_params) endif do j=G%jsc,G%jec ; do i=G%isc,G%iec - call cut_off_column_top(GV%ke, tv, GV%Rho0, GV%g_Earth, G%bathyT(i,j), min_thickness, & - tv%T(i,j,:), T_t(i,j,:), T_b(i,j,:), tv%S(i,j,:), S_t(i,j,:), S_b(i,j,:), & - p_surf(i,j), h(i,j,:), remap_CS) + call cut_off_column_top(GV%ke, tv, GV, GV%g_Earth, G%bathyT(i,j), & + min_thickness, tv%T(i,j,:), T_t(i,j,:), T_b(i,j,:), & + tv%S(i,j,:), S_t(i,j,:), S_b(i,j,:), p_surf(i,j), h(i,j,:), remap_CS, & + z_tol=1.0e-5*US%m_to_Z) enddo ; enddo end subroutine trim_for_ice -!> Adjust the layer thicknesses by cutting away the top at the depth where the hydrostatic -!! pressure matches p_surf -subroutine cut_off_column_top(nk, tv, Rho0, G_earth, depth, min_thickness, & - T, T_t, T_b, S, S_t, S_b, p_surf, h, remap_CS) - integer, intent(in) :: nk !< Number of layers - type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure - real, intent(in) :: Rho0 !< Reference density (kg/m3) - real, intent(in) :: G_earth !< Gravitational acceleration (m/s2) - real, intent(in) :: depth !< Depth of ocean column (m) - real, intent(in) :: min_thickness !< Smallest thickness allowed (m) - real, dimension(nk), intent(inout) :: T !< Layer mean temperature - real, dimension(nk), intent(in) :: T_t !< Temperature at top of layer - real, dimension(nk), intent(in) :: T_b !< Temperature at bottom of layer - real, dimension(nk), intent(inout) :: S !< Layer mean salinity - real, dimension(nk), intent(in) :: S_t !< Salinity at top of layer - real, dimension(nk), intent(in) :: S_b !< Salinity at bottom of layer - real, intent(in) :: p_surf !< Imposed pressure on ocean at surface (Pa) - real, dimension(nk), intent(inout) :: h !< Layer thickness (H units, m or Pa) - type(remapping_CS), pointer :: remap_CS ! Remapping structure for remapping T and S, if associated + +!> Adjust the layer thicknesses by removing the top of the water column above the +!! depth where the hydrostatic pressure matches p_surf +subroutine cut_off_column_top(nk, tv, GV, G_earth, depth, min_thickness, & + T, T_t, T_b, S, S_t, S_b, p_surf, h, remap_CS, z_tol) + integer, intent(in) :: nk !< Number of layers + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, intent(in) :: G_earth !< Gravitational acceleration [m2 Z-1 s-2 ~> m s-2] + real, intent(in) :: depth !< Depth of ocean column [Z ~> m]. + real, intent(in) :: min_thickness !< Smallest thickness allowed [Z ~> m]. + real, dimension(nk), intent(inout) :: T !< Layer mean temperature [degC] + real, dimension(nk), intent(in) :: T_t !< Temperature at top of layer [degC] + real, dimension(nk), intent(in) :: T_b !< Temperature at bottom of layer [degC] + real, dimension(nk), intent(inout) :: S !< Layer mean salinity [ppt] + real, dimension(nk), intent(in) :: S_t !< Salinity at top of layer [ppt] + real, dimension(nk), intent(in) :: S_b !< Salinity at bottom of layer [ppt] + real, intent(in) :: p_surf !< Imposed pressure on ocean at surface [Pa] + real, dimension(nk), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] + type(remapping_CS), pointer :: remap_CS !< Remapping structure for remapping T and S, + !! if associated + real, optional, intent(in) :: z_tol !< The tolerance with which to find the depth + !! matching the specified pressure [Z ~> m]. + ! Local variables real, dimension(nk+1) :: e ! Top and bottom edge values for reconstructions real, dimension(nk) :: h0, S0, T0, h1, S1, T1 @@ -1207,7 +1179,7 @@ subroutine cut_off_column_top(nk, tv, Rho0, G_earth, depth, min_thickness, & ! Calculate original interface positions e(nk+1) = -depth do k=nk,1,-1 - e(K) = e(K+1) + h(k) + e(K) = e(K+1) + GV%H_to_Z*h(k) h0(k) = h(nk+1-k) ! Keep a copy to use in remapping enddo @@ -1215,7 +1187,8 @@ subroutine cut_off_column_top(nk, tv, Rho0, G_earth, depth, min_thickness, & e_top = e(1) do k=1,nk call find_depth_of_pressure_in_cell(T_t(k), T_b(k), S_t(k), S_b(k), e(K), e(K+1), & - P_t, p_surf, Rho0, G_earth, tv%eqn_of_state, P_b, z_out) + P_t, p_surf, GV%Rho0, G_earth, tv%eqn_of_state, & + P_b, z_out, z_tol=z_tol) if (z_out>=e(K)) then ! Imposed pressure was less that pressure at top of cell exit @@ -1232,14 +1205,14 @@ subroutine cut_off_column_top(nk, tv, Rho0, G_earth, depth, min_thickness, & if (e_tope_top) then + if (e(K) > e_top) then ! Original e(K) is too high e(K) = e_top e_top = e_top - min_thickness ! Next interface must be at least this deep endif ! This layer needs trimming - h(k) = max( min_thickness, e(K) - e(K+1) ) - if (e(K) Initialize horizontal velocity components from file subroutine initialize_velocity_from_file(u, v, G, param_file, just_read_params) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZIB_(G),SZJ_(G), SZK_(G)), intent(out) :: u !< The zonal velocity that is being initialized, in m s-1 - real, dimension(SZI_(G),SZJB_(G), SZK_(G)), intent(out) :: v !< The meridional velocity that is being initialized, in m s-1 + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(out) :: u !< The zonal velocity that is being initialized [m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(out) :: v !< The meridional velocity that is being initialized [m s-1] type(param_file_type), intent(in) :: param_file !< A structure indicating the open file to !! parse for modelparameter values. logical, optional, intent(in) :: just_read_params !< If present and true, this call will !! only read parameters without changing h. -! Arguments: u - The zonal velocity that is being initialized. -! (out) v - The meridional velocity that is being initialized. -! (in) G - The ocean's grid structure. -! (in) param_file - parameter file type - -! This subroutine reads the initial velocity components from file + ! Local variables character(len=40) :: mdl = "initialize_velocity_from_file" ! This subroutine's name. character(len=200) :: filename,velocity_file,inputdir ! Strings for file/path logical :: just_read ! If true, just read parameters but set nothing. @@ -1303,23 +1273,19 @@ subroutine initialize_velocity_from_file(u, v, G, param_file, just_read_params) call callTree_leave(trim(mdl)//'()') end subroutine initialize_velocity_from_file -! ----------------------------------------------------------------------------- -! ----------------------------------------------------------------------------- +!> Initialize horizontal velocity components to zero. subroutine initialize_velocity_zero(u, v, G, param_file, just_read_params) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZIB_(G),SZJ_(G), SZK_(G)), intent(out) :: u !< The zonal velocity that is being initialized, in m s-1 - real, dimension(SZI_(G),SZJB_(G), SZK_(G)), intent(out) :: v !< The meridional velocity that is being initialized, in m s-1 + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(out) :: u !< The zonal velocity that is being initialized [m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(out) :: v !< The meridional velocity that is being initialized [m s-1] type(param_file_type), intent(in) :: param_file !< A structure indicating the open file to !! parse for modelparameter values. logical, optional, intent(in) :: just_read_params !< If present and true, this call will !! only read parameters without changing h. -! Arguments: u - The zonal velocity that is being initialized. -! (out) v - The meridional velocity that is being initialized. -! (in) G - The ocean's grid structure. -! (in) param_file - parameter file type - -! This subroutine sets the initial velocity components to zero + ! Local variables character(len=200) :: mdl = "initialize_velocity_zero" ! This subroutine's name. logical :: just_read ! If true, just read parameters but set nothing. integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz @@ -1341,23 +1307,19 @@ subroutine initialize_velocity_zero(u, v, G, param_file, just_read_params) call callTree_leave(trim(mdl)//'()') end subroutine initialize_velocity_zero -! ----------------------------------------------------------------------------- -! ----------------------------------------------------------------------------- +!> Sets the initial velocity components to uniform subroutine initialize_velocity_uniform(u, v, G, param_file, just_read_params) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZIB_(G),SZJ_(G), SZK_(G)), intent(out) :: u !< The zonal velocity that is being initialized, in m s-1 - real, dimension(SZI_(G),SZJB_(G), SZK_(G)), intent(out) :: v !< The meridional velocity that is being initialized, in m s-1 + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(out) :: u !< The zonal velocity that is being initialized [m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(out) :: v !< The meridional velocity that is being initialized [m s-1] type(param_file_type), intent(in) :: param_file !< A structure indicating the open file to !! parse for modelparameter values. logical, optional, intent(in) :: just_read_params !< If present and true, this call will !! only read parameters without changing h. -! Arguments: u - The zonal velocity that is being initialized. -! (out) v - The meridional velocity that is being initialized. -! (in) G - The ocean's grid structure. -! (in) param_file - parameter file type - -! This subroutine sets the initial velocity components to uniform + ! Local variables integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz real :: initial_u_const, initial_v_const logical :: just_read ! If true, just read parameters but set nothing. @@ -1384,24 +1346,20 @@ subroutine initialize_velocity_uniform(u, v, G, param_file, just_read_params) enddo ; enddo ; enddo end subroutine initialize_velocity_uniform -! ----------------------------------------------------------------------------- -! ----------------------------------------------------------------------------- +!> Sets the initial velocity components to be circular with +!! no flow at edges of domain and center. subroutine initialize_velocity_circular(u, v, G, param_file, just_read_params) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZIB_(G),SZJ_(G), SZK_(G)), intent(out) :: u !< The zonal velocity that is being initialized, in m s-1 - real, dimension(SZI_(G),SZJB_(G), SZK_(G)), intent(out) :: v !< The meridional velocity that is being initialized, in m s-1 + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(out) :: u !< The zonal velocity that is being initialized [m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(out) :: v !< The meridional velocity that is being initialized [m s-1] type(param_file_type), intent(in) :: param_file !< A structure indicating the open file to - !! parse for modelparameter values. + !! parse for model parameter values. logical, optional, intent(in) :: just_read_params !< If present and true, this call will !! only read parameters without changing h. -! Arguments: u - The zonal velocity that is being initialized. -! (out) v - The meridional velocity that is being initialized. -! (in) G - The ocean's grid structure. -! (in) param_file - parameter file type - -! This subroutine sets the initial velocity components to be circular with -! no flow at edges of domain and center. + ! Local variables character(len=200) :: mdl = "initialize_velocity_circular" real :: circular_max_u real :: dpi, psi1, psi2 @@ -1414,7 +1372,7 @@ subroutine initialize_velocity_circular(u, v, G, param_file, 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"// & - "circular stream function (m/s).", & + "circular stream function [m s-1].", & units="m s-1", default=0., do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. @@ -1434,9 +1392,13 @@ subroutine initialize_velocity_circular(u, v, G, param_file, just_read_params) contains - real function my_psi(ig,jg) ! in-line function - integer :: ig, jg + !> Returns the value of a circular stream function at (ig,jg) + real function my_psi(ig,jg) + integer :: ig !< Global i-index + integer :: jg !< Global j-index + ! Local variables real :: x, y, r + x = 2.0*(G%geoLonBu(ig,jg)-G%west_lon)/G%len_lon-1.0 ! -1 Initializes temperature and salinity from file subroutine initialize_temp_salt_from_file(T, S, G, param_file, just_read_params) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: T !< The potential temperature that is being initialized. - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: S !< The salinity that is being initialized. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: T !< The potential temperature that is + !! being initialized [degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: S !< The salinity that is + !! being initialized [ppt] type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters logical, optional, intent(in) :: just_read_params !< If present and true, this call will - !! only read parameters without changing h. -! This function puts the initial layer temperatures and salinities ! -! into T(:,:,:) and S(:,:,:). ! - -! Arguments: T - The potential temperature that is being initialized. -! (out) S - The salinity that is being initialized. -! (in) from_file - .true. if the variables that are set here are to -! be read from a file; .false. to be set internally. -! (in) filename - The name of the file to read. -! (in) G - The ocean's grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. + !! only read parameters without changing h. + ! Local variables logical :: just_read ! If true, just read parameters but set nothing. character(len=200) :: filename, salt_filename ! Full paths to input files character(len=200) :: ts_file, salt_file, inputdir ! Strings for file/path @@ -1500,7 +1453,7 @@ subroutine initialize_temp_salt_from_file(T, S, G, param_file, just_read_params) if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & " initialize_temp_salt_from_file: Unable to open "//trim(filename)) -! Read the temperatures and salinities from netcdf files. ! + ! Read the temperatures and salinities from netcdf files. call MOM_read_data(filename, temp_var, T(:,:,:), G%Domain) salt_filename = trim(inputdir)//trim(salt_file) @@ -1511,26 +1464,18 @@ subroutine initialize_temp_salt_from_file(T, S, G, param_file, just_read_params) call callTree_leave(trim(mdl)//'()') end subroutine initialize_temp_salt_from_file -! ----------------------------------------------------------------------------- -! ----------------------------------------------------------------------------- +!> Initializes temperature and salinity from a 1D profile subroutine initialize_temp_salt_from_profile(T, S, G, param_file, just_read_params) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: T, S - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: T !< The potential temperature that is + !! being initialized [degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: S !< The salinity that is + !! being initialized [ppt] + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters logical, optional, intent(in) :: just_read_params !< If present and true, this call will - !! only read parameters without changing h. -! This function puts the initial layer temperatures and salinities ! -! into T(:,:,:) and S(:,:,:). ! - -! Arguments: T - The potential temperature that is being initialized. -! (out) S - The salinity that is being initialized. -! (in) from_file - .true. if the variables that are set here are to -! be read from a file; .false. to be set internally. -! (in) filename - The name of the file to read. -! (in) G - The ocean's grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. + !! only read parameters without changing h. + ! Local variables real, dimension(SZK_(G)) :: T0, S0 integer :: i, j, k logical :: just_read ! If true, just read parameters but set nothing. @@ -1554,7 +1499,7 @@ subroutine initialize_temp_salt_from_profile(T, S, G, param_file, just_read_para if (.not.file_exists(filename)) call MOM_error(FATAL, & " initialize_temp_salt_from_profile: Unable to open "//trim(filename)) -! Read the temperatures and salinities from a netcdf file. ! + ! Read the temperatures and salinities from a netcdf file. call MOM_read_data(filename, "PTEMP", T0(:)) call MOM_read_data(filename, "SALT", S0(:)) @@ -1564,43 +1509,31 @@ subroutine initialize_temp_salt_from_profile(T, S, G, param_file, just_read_para call callTree_leave(trim(mdl)//'()') end subroutine initialize_temp_salt_from_profile -! ----------------------------------------------------------------------------- - -! ----------------------------------------------------------------------------- +!> Initializes temperature and salinity by fitting to density subroutine initialize_temp_salt_fit(T, S, G, GV, param_file, eqn_of_state, P_Ref, just_read_params) 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(out) :: T !< The potential temperature that is being - !! initialized. - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), & - intent(out) :: S !< The salinity that is being initialized. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: T !< The potential temperature that is + !! being initialized [degC]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: S !< The salinity that is being + !! initialized [ppt]. type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time !! parameters. type(EOS_type), pointer :: eqn_of_state !< Integer that selects the equatio of state. real, intent(in) :: P_Ref !< The coordinate-density reference pressure - !! in Pa. + !! [Pa]. logical, optional, intent(in) :: just_read_params !< If present and true, this call will !! only read parameters without changing h. -! This function puts the initial layer temperatures and salinities ! -! into T(:,:,:) and S(:,:,:). ! - -! Arguments: T - The potential temperature that is being initialized. -! (out) S - The salinity that is being initialized. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in) eqn_of_state - integer that selects the equatio of state -! (in) P_Ref - The coordinate-density reference pressure in Pa. - real :: T0(SZK_(G)), S0(SZK_(G)) - real :: T_Ref ! Reference Temperature - real :: S_Ref ! Reference Salinity - real :: pres(SZK_(G)) ! An array of the reference pressure in Pa. - real :: drho_dT(SZK_(G)) ! Derivative of density with temperature in kg m-3 K-1. ! - real :: drho_dS(SZK_(G)) ! Derivative of density with salinity in kg m-3 PSU-1. ! - real :: rho_guess(SZK_(G)) ! Potential density at T0 & S0 in kg m-3. + ! Local variables + real :: T0(SZK_(G)) ! Layer potential temperatures [degC] + real :: S0(SZK_(G)) ! Layer salinities [degC] + real :: T_Ref ! Reference Temperature [degC] + real :: S_Ref ! Reference Salinity [ppt] + real :: pres(SZK_(G)) ! An array of the reference pressure [Pa]. + real :: drho_dT(SZK_(G)) ! Derivative of density with temperature [kg m-3 degC-1]. + real :: drho_dS(SZK_(G)) ! Derivative of density with salinity [kg m-3 ppt-1]. + real :: rho_guess(SZK_(G)) ! Potential density at T0 & S0 [kg m-3]. logical :: fit_salin ! If true, accept the prescribed temperature and fit the salinity. logical :: just_read ! If true, just read parameters but set nothing. character(len=40) :: mdl = "initialize_temp_salt_fit" ! This subroutine's name. @@ -1633,11 +1566,11 @@ subroutine initialize_temp_salt_fit(T, S, G, GV, param_file, eqn_of_state, P_Ref call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,1,eqn_of_state) if (fit_salin) then -! A first guess of the layers' temperatures. + ! A first guess of the layers' temperatures. do k=nz,1,-1 S0(k) = max(0.0, S0(1) + (GV%Rlay(k) - rho_guess(1)) / drho_dS(1)) enddo -! Refine the guesses for each layer. + ! Refine the guesses for each layer. do itt=1,6 call calculate_density(T0,S0,pres,rho_guess,1,nz,eqn_of_state) call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,nz,eqn_of_state) @@ -1646,7 +1579,7 @@ subroutine initialize_temp_salt_fit(T, S, G, GV, param_file, eqn_of_state, P_Ref enddo enddo else -! A first guess of the layers' temperatures. + ! A first guess of the layers' temperatures. do k=nz,1,-1 T0(k) = T0(1) + (GV%Rlay(k) - rho_guess(1)) / drho_dT(1) enddo @@ -1665,24 +1598,26 @@ subroutine initialize_temp_salt_fit(T, S, G, GV, param_file, eqn_of_state, P_Ref call callTree_leave(trim(mdl)//'()') end subroutine initialize_temp_salt_fit -! ----------------------------------------------------------------------------- -! ----------------------------------------------------------------------------- +!> Initializes T and S with linear profiles according to reference surface +!! layer salinity and temperature and a specified range. +!! +!! \remark Note that the linear distribution is set up with respect to the layer +!! number, not the physical position). subroutine initialize_temp_salt_linear(T, S, G, param_file, just_read_params) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: T, S - type(param_file_type), intent(in) :: param_file !< A structure to parse for - !! run-time parameters - logical, optional, intent(in) :: just_read_params !< If present and true, - !! this call will only read - !! parameters without - !! changing h. - - ! This subroutine initializes linear profiles for T and S according to - ! reference surface layer salinity and temperature and a specified range. - ! Note that the linear distribution is set up with respect to the layer - ! number, not the physical position). - integer :: k; + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: T !< The potential temperature that is + !! being initialized [degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: S !< The salinity that is + !! being initialized [ppt] + type(param_file_type), intent(in) :: param_file !< A structure to parse for + !! run-time parameters + logical, optional, intent(in) :: just_read_params !< If present and true, + !! this call will only read + !! parameters without + !! changing h. + + integer :: k real :: delta_S, delta_T real :: S_top, T_top ! Reference salinity and temerature within surface layer real :: S_range, T_range ! Range of salinities and temperatures over the vertical @@ -1708,39 +1643,38 @@ subroutine initialize_temp_salt_linear(T, S, G, param_file, just_read_params) if (just_read) return ! All run-time parameters have been read, so return. -! ! Prescribe salinity -! delta_S = S_range / ( G%ke - 1.0 ); -! S(:,:,1) = S_top; + ! Prescribe salinity +! delta_S = S_range / ( G%ke - 1.0 ) +! S(:,:,1) = S_top ! do k = 2,G%ke -! S(:,:,k) = S(:,:,k-1) + delta_S; -! end do +! S(:,:,k) = S(:,:,k-1) + delta_S +! enddo do k = 1,G%ke S(:,:,k) = S_top - S_range*((real(k)-0.5)/real(G%ke)) T(:,:,k) = T_top - T_range*((real(k)-0.5)/real(G%ke)) - end do + enddo -! ! Prescribe temperature -! delta_T = T_range / ( G%ke - 1.0 ); -! T(:,:,1) = T_top; + ! Prescribe temperature +! delta_T = T_range / ( G%ke - 1.0 ) +! T(:,:,1) = T_top ! do k = 2,G%ke -! T(:,:,k) = T(:,:,k-1) + delta_T; -! end do -! delta = 1; -! T(:,:,G%ke/2 - (delta-1):G%ke/2 + delta) = 1.0; +! T(:,:,k) = T(:,:,k-1) + delta_T +! enddo +! delta = 1 +! T(:,:,G%ke/2 - (delta-1):G%ke/2 + delta) = 1.0 call callTree_leave(trim(mdl)//'()') end subroutine initialize_temp_salt_linear -! ----------------------------------------------------------------------------- -! ----------------------------------------------------------------------------- !> This subroutine sets 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. The -!!interface height is always subject to damping, and must always be +!! interface height is always subject to damping, and must always be !! the first registered field. -subroutine initialize_sponges_file(G, GV, use_temperature, tv, param_file, CSp, ALE_CSp, Time) +subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, param_file, CSp, ALE_CSp, 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 logical, intent(in) :: use_temperature !< If true, T & S are state variables. type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic !! variables. @@ -1751,18 +1685,17 @@ subroutine initialize_sponges_file(G, GV, use_temperature, tv, param_file, CSp, !! structure for this module (in ALE mode). type(time_type), intent(in) :: Time !< Time at the start of the run segment. Time_in !! overrides any value set for Time. - -! Local variables - real, allocatable, dimension(:,:,:) :: eta ! The target interface heights, in m. - real, allocatable, dimension(:,:,:) :: h ! The target interface thicknesses, in m. + ! Local variables + real, allocatable, dimension(:,:,:) :: eta ! The target interface heights [Z ~> m]. + real, allocatable, dimension(:,:,:) :: h ! The target interface thicknesses [H ~> m or kg m-2]. real, dimension (SZI_(G),SZJ_(G),SZK_(G)) :: & tmp, tmp2 ! A temporary array for tracers. real, dimension (SZI_(G),SZJ_(G)) :: & tmp_2d ! A temporary array for tracers. - real :: Idamp(SZI_(G),SZJ_(G)) ! The inverse damping rate, in s-1. - real :: pres(SZI_(G)) ! An array of the reference pressure, in Pa. + real :: Idamp(SZI_(G),SZJ_(G)) ! The inverse damping rate [s-1]. + real :: pres(SZI_(G)) ! An array of the reference pressure [Pa]. integer :: i, j, k, is, ie, js, je, nz integer :: isd, ied, jsd, jed @@ -1825,58 +1758,57 @@ subroutine initialize_sponges_file(G, GV, use_temperature, tv, param_file, CSp, call MOM_read_data(filename, "Idamp", Idamp(:,:), G%Domain) -! Now register all of the fields which are damped in the sponge. ! -! By default, momentum is advected vertically within the sponge, but ! -! momentum is typically not damped within the sponge. ! + ! Now register all of the fields which are damped in the sponge. + ! By default, momentum is advected vertically within the sponge, but + ! momentum is typically not damped within the sponge. filename = trim(inputdir)//trim(state_file) call log_param(param_file, mdl, "INPUTDIR/SPONGE_STATE_FILE", filename) if (.not.file_exists(filename, G%Domain)) & call MOM_error(FATAL, " initialize_sponges: Unable to open "//trim(filename)) - -! The first call to set_up_sponge_field is for the interface heights if in layered mode.! + ! The first call to set_up_sponge_field is for the interface heights if in layered mode.! if (.not. use_ALE) then allocate(eta(isd:ied,jsd:jed,nz+1)) - call MOM_read_data(filename, eta_var, eta(:,:,:), G%Domain) + call MOM_read_data(filename, eta_var, eta(:,:,:), G%Domain, scale=US%m_to_Z) do j=js,je ; do i=is,ie eta(i,j,nz+1) = -G%bathyT(i,j) enddo ; enddo do k=nz,1,-1 ; do j=js,je ; do i=is,ie - if (eta(i,j,K) < (eta(i,j,K+1) + GV%Angstrom_z)) & - eta(i,j,K) = eta(i,j,K+1) + GV%Angstrom_z + if (eta(i,j,K) < (eta(i,j,K+1) + GV%Angstrom_Z)) & + eta(i,j,K) = eta(i,j,K+1) + GV%Angstrom_Z enddo ; enddo ; enddo -! 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, param_file, CSp) + ! 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, param_file, CSp, GV) deallocate(eta) - else if (.not. new_sponges) then ! ALE mode + elseif (.not. new_sponges) then ! ALE mode call field_size(filename,eta_var,siz,no_domain=.true.) if (siz(1) /= G%ieg-G%isg+1 .or. siz(2) /= G%jeg-G%jsg+1) & call MOM_error(FATAL,"initialize_sponge_file: Array size mismatch for sponge data.") -! ALE_CSp%time_dependent_target = .false. -! if (siz(4) > 1) ALE_CSp%time_dependent_target = .true. +! ALE_CSp%time_dependent_target = .false. +! if (siz(4) > 1) ALE_CSp%time_dependent_target = .true. nz_data = siz(3)-1 allocate(eta(isd:ied,jsd:jed,nz_data+1)) allocate(h(isd:ied,jsd:jed,nz_data)) - call MOM_read_data(filename, eta_var, eta(:,:,:), G%Domain) + call MOM_read_data(filename, eta_var, eta(:,:,:), G%Domain, scale=US%m_to_Z) do j=js,je ; do i=is,ie eta(i,j,nz+1) = -G%bathyT(i,j) enddo ; enddo do k=nz,1,-1 ; do j=js,je ; do i=is,ie - if (eta(i,j,K) < (eta(i,j,K+1) + GV%Angstrom_z)) & - eta(i,j,K) = eta(i,j,K+1) + GV%Angstrom_z + if (eta(i,j,K) < (eta(i,j,K+1) + GV%Angstrom_Z)) & + eta(i,j,K) = eta(i,j,K+1) + GV%Angstrom_Z enddo ; enddo ; enddo do k=1,nz; do j=js,je ; do i=is,ie - h(i,j,k) = eta(i,j,k)-eta(i,j,k+1) - enddo ; enddo; enddo + h(i,j,k) = GV%Z_to_H*(eta(i,j,k)-eta(i,j,k+1)) + enddo ; enddo ; enddo call initialize_ALE_sponge(Idamp, G, param_file, ALE_CSp, h, nz_data) deallocate(eta) deallocate(h) @@ -1885,16 +1817,14 @@ subroutine initialize_sponges_file(G, GV, use_temperature, tv, param_file, CSp, call initialize_ALE_sponge(Idamp, G, param_file, ALE_CSp) endif - - -! Now register all of the tracer fields which are damped in the ! -! sponge. By default, momentum is advected vertically within the ! -! sponge, but momentum is typically not damped within the sponge. ! + ! Now register all of the tracer fields which are damped in the + ! sponge. By default, momentum is advected vertically within the + ! sponge, but momentum is typically not damped within the sponge. if ( GV%nkml>0 .and. .not. new_sponges) 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. + ! 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 call MOM_read_data(filename, potemp_var, tmp(:,:,:), G%Domain) @@ -1908,27 +1838,24 @@ subroutine initialize_sponges_file(G, GV, use_temperature, tv, param_file, CSp, call set_up_sponge_ML_density(tmp_2d, G, CSp) endif -! The remaining calls to set_up_sponge_field can be in any order. ! + ! The remaining calls to set_up_sponge_field can be in any order. if ( use_temperature .and. .not. new_sponges) then call MOM_read_data(filename, potemp_var, tmp(:,:,:), G%Domain) call set_up_sponge_field(tmp, tv%T, G, nz, CSp) call MOM_read_data(filename, salin_var, tmp(:,:,:), G%Domain) call set_up_sponge_field(tmp, tv%S, G, nz, CSp) - else if (use_temperature) then - call set_up_ALE_sponge_field(filename, potemp_var, Time, G, tv%T, ALE_CSp) - call set_up_ALE_sponge_field(filename, salin_var, Time, G, tv%S, ALE_CSp) + elseif (use_temperature) then + call set_up_ALE_sponge_field(filename, potemp_var, Time, G, GV, tv%T, ALE_CSp) + call set_up_ALE_sponge_field(filename, salin_var, Time, G, GV, tv%S, ALE_CSp) endif - - end subroutine initialize_sponges_file -! ----------------------------------------------------------------------------- -! ----------------------------------------------------------------------------- !> This subroutine sets the 4 bottom depths at velocity points to be the !! maximum of the adjacent depths. subroutine set_velocity_depth_max(G) - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + ! Local variables integer :: i, j do I=G%isd,G%ied-1 ; do j=G%jsd,G%jed @@ -1940,13 +1867,12 @@ subroutine set_velocity_depth_max(G) G%Dopen_v(I,J) = G%Dblock_v(I,J) enddo ; enddo end subroutine set_velocity_depth_max -! ----------------------------------------------------------------------------- -! ----------------------------------------------------------------------------- !> Subroutine to pre-compute global integrals of grid quantities for !! later use in reporting diagnostics subroutine compute_global_grid_integrals(G) - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + ! Local variables real, dimension(G%isc:G%iec, G%jsc:G%jec) :: tmpForSumming integer :: i,j @@ -1959,11 +1885,11 @@ subroutine compute_global_grid_integrals(G) G%IareaT_global = 1. / G%areaT_global end subroutine compute_global_grid_integrals -! ----------------------------------------------------------------------------- !> This subroutine sets the 4 bottom depths at velocity points to be the !! minimum of the adjacent depths. subroutine set_velocity_depth_min(G) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + ! Local variables integer :: i, j do I=G%isd,G%ied-1 ; do j=G%jsd,G%jed @@ -1975,26 +1901,24 @@ subroutine set_velocity_depth_min(G) G%Dopen_v(I,J) = G%Dblock_v(I,J) enddo ; enddo end subroutine set_velocity_depth_min -! ----------------------------------------------------------------------------- -! ----------------------------------------------------------------------------- !> This subroutine determines the isopycnal or other coordinate interfaces and !! layer potential temperatures and salinities directly from a z-space file on !! a latitude-longitude grid. -subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, PF, just_read_params) -! This subroutine was written by M. Harrison, with input from R. Hallberg & A. Adcroft. -! +subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, US, PF, just_read_params) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(out) :: h !< Layer thicknesses being initialized, in H + intent(out) :: h !< Layer thicknesses being initialized [H ~> m or kg m-2] type(thermo_var_ptrs), intent(inout) :: tv !< A structure pointing to various thermodynamic !! variables including temperature and salinity 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) :: PF !< A structure indicating the open file !! to parse for model parameter values. logical, optional, intent(in) :: just_read_params !< If present and true, this call will !! only read parameters without changing h. + ! Local variables character(len=200) :: filename !< The name of an input file containing temperature !! and salinity in z-space; also used for ice shelf area. character(len=200) :: tfilename !< The name of an input file containing only temperature @@ -2008,9 +1932,8 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, PF, just_read_params) type(EOS_type), pointer :: eos => NULL() type(thermo_var_ptrs) :: tv_loc ! A temporary thermo_var container type(verticalGrid_type) :: GV_loc ! A temporary vertical grid structure - -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "MOM_initialize_layers_from_Z" ! This module's name. integer :: is, ie, js, je, nz ! compute domain indices @@ -2023,11 +1946,12 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, PF, just_read_params) integer :: nkml, nkbl ! number of mixed and buffer layers integer :: kd, inconsistent - integer :: nkd ! number of levels to use for regridding input arrays + integer :: nkd ! number of levels to use for regridding input arrays + real :: eps_Z ! A negligibly thin layer thickness [Z ~> m]. real :: PI_180 ! for conversion from degrees to radians - real, dimension(:,:), pointer :: shelf_area - real :: min_depth + real, dimension(:,:), pointer :: shelf_area => NULL() + real :: min_depth ! The minimum depth [Z ~> m]. real :: dilate real :: missing_value_temp, missing_value_salt logical :: correct_thickness @@ -2042,24 +1966,23 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, PF, just_read_params) logical :: reentrant_x, tripolar_n,dbg logical :: debug = .false. ! manually set this to true for verbose output - !data arrays + ! data arrays real, dimension(:), allocatable :: z_edges_in, z_in, Rb real, dimension(:,:,:), allocatable, target :: temp_z, salt_z, mask_z real, dimension(:,:,:), allocatable :: rho_z - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: zi ! Interface heights in m. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: zi ! Interface heights [Z ~> m]. real, dimension(SZI_(G),SZJ_(G)) :: nlevs - real, dimension(SZI_(G)) :: press - + real, dimension(SZI_(G)) :: press ! Pressures [Pa]. ! Local variables for ALE remapping - real, dimension(:), allocatable :: hTarget + real, dimension(:), allocatable :: hTarget ! Target thicknesses [Z ~> m]. real, dimension(:,:), allocatable :: area_shelf_h real, dimension(:,:), allocatable, target :: frac_shelf_h real, dimension(:,:,:), allocatable, target :: tmpT1dIn, tmpS1dIn real, dimension(:,:,:), allocatable :: tmp_mask_in - real, dimension(:,:,:), allocatable :: h1 ! Thicknesses in H. + real, dimension(:,:,:), allocatable :: h1 ! Thicknesses [H ~> m or kg m-2]. real, dimension(:,:,:), allocatable :: dz_interface ! Change in position of interface due to regridding - real :: zTopOfCell, zBottomOfCell + real :: zTopOfCell, zBottomOfCell ! Heights in Z units [Z ~> m]. type(regridding_CS) :: regridCS ! Regridding parameters and work arrays type(remapping_CS) :: remapCS ! Remapping parameters and work arrays @@ -2095,7 +2018,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, PF, just_read_params) reentrant_x = .false. ; call get_param(PF, mdl, "REENTRANT_X", reentrant_x,default=.true.) tripolar_n = .false. ; call get_param(PF, mdl, "TRIPOLAR_N", tripolar_n, default=.false.) - call get_param(PF, mdl, "MINIMUM_DEPTH", min_depth, default=0.0) + call get_param(PF, mdl, "MINIMUM_DEPTH", min_depth, default=0.0, scale=US%m_to_Z) call get_param(PF, mdl, "NKML",nkml,default=0) call get_param(PF, mdl, "NKBL",nkbl,default=0) @@ -2169,43 +2092,49 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, PF, just_read_params) return ! All run-time parameters have been read, so return. endif -! Read input grid coordinates for temperature and salinity field -! in z-coordinate dataset. The file is REQUIRED to contain the -! following: -! -! dimension variables: -! lon (degrees_E), lat (degrees_N), depth(meters) -! variables: -! ptemp(lon,lat,depth) : degC, potential temperature -! salt (lon,lat,depth) : PSU, salinity -! -! The first record will be read if there are multiple time levels. -! The observation grid MUST tile the model grid. If the model grid extends -! to the North/South Pole past the limits of the input data, they are extrapolated using the average -! value at the northernmost/southernmost latitude. - - call horiz_interp_and_extrap_tracer(tfilename, potemp_var,1.0,1, & - G, temp_z, mask_z, z_in, z_edges_in, missing_value_temp, reentrant_x, tripolar_n, homogenize) - - call horiz_interp_and_extrap_tracer(sfilename, salin_var,1.0,1, & - G, salt_z, mask_z, z_in, z_edges_in, missing_value_salt, reentrant_x, tripolar_n, homogenize) + !### Change this to GV%Angstrom_Z + eps_z = 1.0e-10*US%m_to_Z + + ! Read input grid coordinates for temperature and salinity field + ! in z-coordinate dataset. The file is REQUIRED to contain the + ! following: + ! + ! dimension variables: + ! lon (degrees_E), lat (degrees_N), depth(meters) + ! variables: + ! ptemp(lon,lat,depth) : degC, potential temperature + ! salt (lon,lat,depth) : ppt, salinity + ! + ! The first record will be read if there are multiple time levels. + ! The observation grid MUST tile the model grid. If the model grid extends + ! to the North/South Pole past the limits of the input data, they are extrapolated using the average + ! value at the northernmost/southernmost latitude. + + call horiz_interp_and_extrap_tracer(tfilename, potemp_var, 1.0, 1, & + G, temp_z, mask_z, z_in, z_edges_in, missing_value_temp, reentrant_x, & + tripolar_n, homogenize, m_to_Z=US%m_to_Z) + + call horiz_interp_and_extrap_tracer(sfilename, salin_var, 1.0, 1, & + G, salt_z, mask_z, z_in, z_edges_in, missing_value_salt, reentrant_x, & + tripolar_n, homogenize, m_to_Z=US%m_to_Z) kd = size(z_in,1) + ! Convert the sign convention of Z_edges_in. + do k=1,size(Z_edges_in,1) ; Z_edges_in(k) = -Z_edges_in(k) ; enddo + allocate(rho_z(isd:ied,jsd:jed,kd)) allocate(area_shelf_h(isd:ied,jsd:jed)) allocate(frac_shelf_h(isd:ied,jsd:jed)) - press(:)=tv%p_ref + press(:) = tv%p_ref - !Convert T&S to Absolute Salinity and Conservative Temperature if using TEOS10 or NEMO - call convert_temp_salt_for_TEOS10(temp_z,salt_z, press, G, kd, mask_z, eos) + ! Convert T&S to Absolute Salinity and Conservative Temperature if using TEOS10 or NEMO + call convert_temp_salt_for_TEOS10(temp_z, salt_z, press, G, kd, mask_z, eos) - do k=1,kd - do j=js,je - call calculate_density(temp_z(:,j,k),salt_z(:,j,k), press, rho_z(:,j,k), is, ie, eos) - enddo - enddo ! kd + do k=1,kd ; do j=js,je + call calculate_density(temp_z(:,j,k), salt_z(:,j,k), press, rho_z(:,j,k), is, ie, eos) + enddo ; enddo call pass_var(temp_z,G%Domain) call pass_var(salt_z,G%Domain) @@ -2219,28 +2148,28 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, PF, just_read_params) call MOM_read_data(shelf_file, trim(area_varname), area_shelf_h, G%Domain) - ! initialize frac_shelf_h with zeros (open water everywhere) + ! Initialize frac_shelf_h with zeros (open water everywhere) frac_shelf_h(:,:) = 0.0 - ! compute fractional ice shelf coverage of h + ! Compute fractional ice shelf coverage of h do j=jsd,jed ; do i=isd,ied if (G%areaT(i,j) > 0.0) & frac_shelf_h(i,j) = area_shelf_h(i,j) / G%areaT(i,j) enddo ; enddo - ! pass to the pointer + ! Pass to the pointer for use as an argument to regridding_main shelf_area => frac_shelf_h endif -! Done with horizontal interpolation. -! Now remap to model coordinates + ! Done with horizontal interpolation. + ! Now remap to model coordinates if (useALEremapping) then call cpu_clock_begin(id_clock_ALE) nkd = max(GV%ke, kd) ! The regridding tools (grid generation) are coded to work on model arrays of the same ! vertical shape. We need to re-write the regridding if the model has fewer layers ! than the data. -AJA - !if (kd>nz) call MOM_error(FATAL,"MOM_initialize_state, MOM_temp_salt_initialize_from_Z(): "//& - ! "Data has more levels than the model - this has not been coded yet!") +! if (kd>nz) call MOM_error(FATAL,"MOM_initialize_state, MOM_temp_salt_initialize_from_Z(): "//& +! "Data has more levels than the model - this has not been coded yet!") ! Build the source grid and copy data onto model-shaped arrays with vanished layers allocate( tmp_mask_in(isd:ied,jsd:jed,nkd) ) ; tmp_mask_in(:,:,:) = 0. allocate( h1(isd:ied,jsd:jed,nkd) ) ; h1(:,:,:) = 0. @@ -2252,7 +2181,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, PF, just_read_params) tmp_mask_in(i,j,1:kd) = mask_z(i,j,:) do k = 1, nkd if (tmp_mask_in(i,j,k)>0. .and. k<=kd) then - zBottomOfCell = max( -z_edges_in(k+1), -G%bathyT(i,j) ) + zBottomOfCell = max( z_edges_in(k+1), -G%bathyT(i,j) ) tmpT1dIn(i,j,k) = temp_z(i,j,k) tmpS1dIn(i,j,k) = salt_z(i,j,k) elseif (k>1) then @@ -2263,10 +2192,11 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, PF, just_read_params) tmpT1dIn(i,j,k) = -99.9 tmpS1dIn(i,j,k) = -99.9 endif - h1(i,j,k) = GV%m_to_H * (zTopOfCell - zBottomOfCell) + h1(i,j,k) = GV%Z_to_H * (zTopOfCell - zBottomOfCell) zTopOfCell = zBottomOfCell ! Bottom becomes top for next value of k enddo - h1(i,j,kd) = h1(i,j,kd) + GV%m_to_H * max(0., zTopOfCell + G%bathyT(i,j) ) ! In case data is shallower than model + h1(i,j,kd) = h1(i,j,kd) + GV%Z_to_H * max(0., zTopOfCell + G%bathyT(i,j) ) + ! The max here is in case the data data is shallower than model endif ! mask2dT enddo ; enddo deallocate( tmp_mask_in ) @@ -2276,7 +2206,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, PF, just_read_params) ! Build the target grid (and set the model thickness to it) ! This call can be more general but is hard-coded for z* coordinates... ???? - call ALE_initRegridding( GV, G%max_depth, PF, mdl, regridCS ) ! sets regridCS + call ALE_initRegridding( GV, US, G%max_depth, PF, mdl, regridCS ) ! sets regridCS if (.not. remap_general) then ! This is the old way of initializing to z* coordinates only @@ -2289,7 +2219,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, PF, just_read_params) zTopOfCell = 0. ; zBottomOfCell = 0. do k = 1, nz zBottomOfCell = max( zTopOfCell - hTarget(k), -G%bathyT(i,j) ) - h(i,j,k) = GV%m_to_H * (zTopOfCell - zBottomOfCell) + h(i,j,k) = GV%Z_to_H * (zTopOfCell - zBottomOfCell) zTopOfCell = zBottomOfCell ! Bottom becomes top for next value of k enddo else @@ -2317,8 +2247,10 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, PF, just_read_params) endif deallocate( dz_interface ) endif - call ALE_remap_scalar( remapCS, G, GV, nkd, h1, tmpT1dIn, h, tv%T, all_cells=remap_full_column, old_remap=remap_old_alg ) - call ALE_remap_scalar( remapCS, G, GV, nkd, h1, tmpS1dIn, h, tv%S, all_cells=remap_full_column, old_remap=remap_old_alg ) + call ALE_remap_scalar(remapCS, G, GV, nkd, h1, tmpT1dIn, h, tv%T, all_cells=remap_full_column, & + old_remap=remap_old_alg ) + call ALE_remap_scalar(remapCS, G, GV, nkd, h1, tmpS1dIn, h, tv%S, all_cells=remap_full_column, & + old_remap=remap_old_alg ) deallocate( h1 ) deallocate( tmpT1dIn ) deallocate( tmpS1dIn ) @@ -2327,66 +2259,66 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, PF, just_read_params) else ! remap to isopycnal layer space -! next find interface positions using local arrays -! nlevs contains the number of valid data points in each column + ! Next find interface positions using local arrays + ! nlevs contains the number of valid data points in each column nlevs = sum(mask_z,dim=3) -! Rb contains the layer interface densities + ! Rb contains the layer interface densities allocate(Rb(nz+1)) do k=2,nz ; Rb(k)=0.5*(GV%Rlay(k-1)+GV%Rlay(k)) ; enddo Rb(1) = 0.0 ; Rb(nz+1) = 2.0*GV%Rlay(nz) - GV%Rlay(nz-1) zi(is:ie,js:je,:) = find_interfaces(rho_z(is:ie,js:je,:), z_in, Rb, G%bathyT(is:ie,js:je), & - nlevs(is:ie,js:je), nkml, nkbl, min_depth) + nlevs(is:ie,js:je), nkml, nkbl, min_depth, eps_z=eps_z) if (correct_thickness) then - call adjustEtaToFitBathymetry(G, GV, zi, h) + call adjustEtaToFitBathymetry(G, GV, US, zi, h) else do k=nz,1,-1 ; do j=js,je ; do i=is,ie - if (zi(i,j,K) < (zi(i,j,K+1) + GV%Angstrom_z)) then - zi(i,j,K) = zi(i,j,K+1) + GV%Angstrom_z - h(i,j,k) = GV%Angstrom + if (zi(i,j,K) < (zi(i,j,K+1) + GV%Angstrom_Z)) then + zi(i,j,K) = zi(i,j,K+1) + GV%Angstrom_Z + h(i,j,k) = GV%Angstrom_H else - h(i,j,k) = GV%m_to_H * (zi(i,j,K) - zi(i,j,K+1)) + h(i,j,k) = GV%Z_to_H * (zi(i,j,K) - zi(i,j,K+1)) endif enddo ; enddo ; enddo inconsistent=0 do j=js,je ; do i=is,ie - if (abs(zi(i,j,nz+1) + G%bathyT(i,j)) > 1.0) & + if (abs(zi(i,j,nz+1) + G%bathyT(i,j)) > 1.0*US%m_to_Z) & inconsistent = inconsistent + 1 enddo ; enddo call sum_across_PEs(inconsistent) if ((inconsistent > 0) .and. (is_root_pe())) then - write(mesg,'("Thickness initial conditions are inconsistent ",'// & - '"with topography in ",I5," places.")') inconsistent + write(mesg, '("Thickness initial conditions are inconsistent ",'// & + '"with topography in ",I5," places.")') inconsistent call MOM_error(WARNING, mesg) endif endif - tv%T(is:ie,js:je,:) = tracer_z_init(temp_z(is:ie,js:je,:),-1.0*z_edges_in,zi(is:ie,js:je,:), & - nkml,nkbl,missing_value,G%mask2dT(is:ie,js:je),nz, & - nlevs(is:ie,js:je),dbg,idbg,jdbg) - tv%S(is:ie,js:je,:) = tracer_z_init(salt_z(is:ie,js:je,:),-1.0*z_edges_in,zi(is:ie,js:je,:), & - nkml,nkbl,missing_value,G%mask2dT(is:ie,js:je),nz, & - nlevs(is:ie,js:je)) + tv%T(is:ie,js:je,:) = tracer_z_init(temp_z(is:ie,js:je,:), z_edges_in, zi(is:ie,js:je,:), & + nkml, nkbl, missing_value, G%mask2dT(is:ie,js:je), nz, & + nlevs(is:ie,js:je),dbg,idbg,jdbg, eps_z=eps_z) + tv%S(is:ie,js:je,:) = tracer_z_init(salt_z(is:ie,js:je,:), z_edges_in, zi(is:ie,js:je,:), & + nkml, nkbl, missing_value, G%mask2dT(is:ie,js:je), nz, & + nlevs(is:ie,js:je), eps_z=eps_z) do k=1,nz nPoints = 0 ; tempAvg = 0. ; saltAvg = 0. do j=js,je ; do i=is,ie ; if (G%mask2dT(i,j) >= 1.0) then nPoints = nPoints + 1 tempAvg = tempAvg + tv%T(i,j,k) - saltAvg =saltAvg + tv%S(i,j,k) + saltAvg = saltAvg + tv%S(i,j,k) endif ; enddo ; enddo - ! Horizontally homogenize data to produce perfectly "flat" initial conditions + ! Horizontally homogenize data to produce perfectly "flat" initial conditions if (homogenize) then call sum_across_PEs(nPoints) call sum_across_PEs(tempAvg) call sum_across_PEs(saltAvg) if (nPoints>0) then - tempAvg = tempAvg/real(nPoints) - saltAvg = saltAvg/real(nPoints) + tempAvg = tempAvg / real(nPoints) + saltAvg = saltAvg / real(nPoints) endif tv%T(:,:,k) = tempAvg tv%S(:,:,k) = saltAvg @@ -2395,16 +2327,16 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, PF, just_read_params) endif ! useALEremapping -! Fill land values + ! Fill land values do k=1,nz ; do j=js,je ; do i=is,ie if (tv%T(i,j,k) == missing_value) then - tv%T(i,j,k)=temp_land_fill - tv%S(i,j,k)=salt_land_fill + tv%T(i,j,k) = temp_land_fill + tv%S(i,j,k) = salt_land_fill endif enddo ; enddo ; enddo -! Finally adjust to target density - ks=max(0,nkml)+max(0,nkbl)+1 + ! Finally adjust to target density + ks = max(0,nkml)+max(0,nkbl)+1 if (adjust_temperature .and. .not. useALEremapping) then call determine_temperature(tv%T(is:ie,js:je,:), tv%S(is:ie,js:je,:), & @@ -2412,7 +2344,8 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, PF, just_read_params) endif - deallocate(z_in,z_edges_in,temp_z,salt_z,mask_z) + deallocate(z_in, z_edges_in, temp_z, salt_z, mask_z) + deallocate(rho_z, area_shelf_h, frac_shelf_h) call pass_var(h, G%Domain) call pass_var(tv%T, G%Domain) @@ -2424,9 +2357,10 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, PF, just_read_params) end subroutine MOM_temp_salt_initialize_from_Z !> Run simple unit tests -subroutine MOM_state_init_tests(G, GV, tv) +subroutine MOM_state_init_tests(G, GV, US, tv) 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 type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure. ! Local variables integer, parameter :: nk=5 @@ -2452,14 +2386,15 @@ subroutine MOM_state_init_tests(G, GV, tv) S_t(k) = 35.-(0./500.)*e(k) S(k) = 35.+(0./500.)*z(k) S_b(k) = 35.-(0./500.)*e(k+1) - call calculate_density(0.5*(T_t(k)+T_b(k)), 0.5*(S_t(k)+S_b(k)), -GV%Rho0*GV%g_Earth*z(k), rho(k), tv%eqn_of_state) - P_tot = P_tot + GV%g_Earth * rho(k) * h(k) + call calculate_density(0.5*(T_t(k)+T_b(k)), 0.5*(S_t(k)+S_b(k)), -GV%Rho0*(GV%g_Earth*US%m_to_Z)*z(k), & + rho(k), tv%eqn_of_state) + P_tot = P_tot + (GV%g_Earth*US%m_to_Z) * rho(k) * h(k) enddo P_t = 0. do k = 1, nk call find_depth_of_pressure_in_cell(T_t(k), T_b(k), S_t(k), S_b(k), e(K), e(K+1), & - P_t, 0.5*P_tot, GV%Rho0, GV%g_Earth, tv%eqn_of_state, P_b, z_out) + P_t, 0.5*P_tot, GV%Rho0, (GV%g_Earth*US%m_to_Z), tv%eqn_of_state, P_b, z_out) write(0,*) k,P_t,P_b,0.5*P_tot,e(K),e(K+1),z_out P_t = P_b enddo @@ -2469,7 +2404,7 @@ subroutine MOM_state_init_tests(G, GV, tv) write(0,*) ' ==================================================================== ' write(0,*) '' write(0,*) h - call cut_off_column_top(nk, tv, GV%Rho0, GV%g_Earth, -e(nk+1), GV%Angstrom, & + call cut_off_column_top(nk, tv, GV, (GV%g_Earth*US%m_to_Z), -e(nk+1), GV%Angstrom_H, & T, T_t, T_b, S, S_t, S_b, 0.5*P_tot, h, remap_CS) write(0,*) h diff --git a/src/initialization/MOM_tracer_initialization_from_Z.F90 b/src/initialization/MOM_tracer_initialization_from_Z.F90 index 71156c27b8..27511e1593 100644 --- a/src/initialization/MOM_tracer_initialization_from_Z.F90 +++ b/src/initialization/MOM_tracer_initialization_from_Z.F90 @@ -1,3 +1,4 @@ +!> Initializes hydrography from z-coordinate climatology files module MOM_tracer_initialization_from_Z ! This file is part of MOM6. See LICENSE.md for the license. @@ -14,49 +15,54 @@ module MOM_tracer_initialization_from_Z use MOM_file_parser, only : log_version use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type, isPointInCell +use MOM_horizontal_regridding, only : myStats, horiz_interp_and_extrap_tracer +use MOM_regridding, only : regridding_CS +use MOM_remapping, only : remapping_CS, initialize_remapping +use MOM_remapping, only : remapping_core_h use MOM_string_functions, only : uppercase -use MOM_time_manager, only : time_type, set_time +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs -use MOM_verticalGrid, only : setVerticalGridAxes +use MOM_verticalGrid, only : verticalGrid_type, setVerticalGridAxes use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_type use MOM_EOS, only : int_specific_vol_dp use MOM_ALE, only : ALE_remap_scalar -use MOM_regridding, only : regridding_CS -use MOM_remapping, only : remapping_CS, initialize_remapping -use MOM_remapping, only : remapping_core_h -use MOM_verticalGrid, only : verticalGrid_type -use MOM_horizontal_regridding, only : myStats, horiz_interp_and_extrap_tracer + implicit none ; private #include public :: MOM_initialize_tracer_from_Z -character(len=40) :: mdl = "MOM_tracer_initialization_from_Z" ! This module's name. +! 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. -real, parameter :: epsln=1.e-10 +character(len=40) :: mdl = "MOM_tracer_initialization_from_Z" !< This module's name. contains -!> MOM_initialize_tracer_from_Z initializes a tracer from a z-space data file. -subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, PF, src_file, src_var_nam, & +!> Initializes a tracer from a z-space data file. +subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_nam, & src_var_unit_conversion, src_var_record, homogenize, & useALEremapping, remappingScheme, src_var_gridspec ) - type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure. type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< Layer thickness, in m. + intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. real, dimension(:,:,:), pointer :: tr !< Pointer to array to be initialized type(param_file_type), intent(in) :: PF !< parameter file - character(len=*), intent(in) :: src_file, src_var_nam !< source filename and variable name on disk + character(len=*), intent(in) :: src_file !< source filename + character(len=*), intent(in) :: src_var_nam !< variable name in file real, optional, intent(in) :: src_var_unit_conversion !< optional multiplicative unit conversion integer, optional, intent(in) :: src_var_record !< record to read for multiple time-level files logical, optional, intent(in) :: homogenize !< optionally homogenize to mean value logical, optional, intent(in) :: useALEremapping !< to remap or not (optional) character(len=*), optional, intent(in) :: remappingScheme !< remapping scheme to use. - character(len=*), optional, intent(in) :: src_var_gridspec ! Not implemented yet. - + character(len=*), optional, intent(in) :: src_var_gridspec !< Source variable name in a gridspec file. + !! This is not implemented yet. + ! Local variables real :: land_fill = 0.0 character(len=200) :: inputdir ! The directory where NetCDF input files are. character(len=200) :: mesg @@ -65,31 +71,24 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, PF, src_file, src_var_nam, character(len=10) :: remapScheme logical :: homog,useALE -! This include declares and sets the variable "version". -#include "version_variable.h" - + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "MOM_initialize_tracers_from_Z" ! This module's name. integer :: is, ie, js, je, nz ! compute domain indices - integer :: isg, ieg, jsg, jeg ! global extent integer :: isd, ied, jsd, jed ! data domain indices - integer :: i, j, k, kd - - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: zi real, allocatable, dimension(:,:,:), target :: tr_z, mask_z real, allocatable, dimension(:), target :: z_edges_in, z_in ! Local variables for ALE remapping - real, dimension(:), allocatable :: h1, h2, hTarget, deltaE, tmpT1d - real, dimension(:), allocatable :: tmpT1dIn - real :: zTopOfCell, zBottomOfCell + real, dimension(:,:,:), allocatable :: hSrc ! Source thicknesses [H ~> m or kg m-2]. + real, dimension(:), allocatable :: h1 ! A 1-d column of source thicknesses [Z ~> m]. + real :: zTopOfCell, zBottomOfCell, z_bathy ! Heights [Z ~> m]. type(remapping_CS) :: remapCS ! Remapping parameters and work arrays - real, dimension(:,:,:), allocatable :: hSrc - - real :: tempAvg, missing_value - integer :: nPoints, ans + real :: missing_value + integer :: nPoints integer :: id_clock_routine, id_clock_ALE logical :: reentrant_x, tripolar_n @@ -100,7 +99,6 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, PF, src_file, src_var_nam, 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 - isg = G%isg ; ieg = G%ieg ; jsg = G%jsg ; jeg = G%jeg call callTree_enter(trim(mdl)//"(), MOM_state_initialization.F90") @@ -119,7 +117,6 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, PF, src_file, src_var_nam, reentrant_x = .false. ; call get_param(PF, mdl, "REENTRANT_X", reentrant_x,default=.true.) tripolar_n = .false. ; call get_param(PF, mdl, "TRIPOLAR_N", tripolar_n, default=.false.) - if (PRESENT(homogenize)) homog=homogenize if (PRESENT(useALEremapping)) useALE=useALEremapping if (PRESENT(remappingScheme)) remapScheme=remappingScheme @@ -128,9 +125,9 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, PF, src_file, src_var_nam, convert=1.0 if (PRESENT(src_var_unit_conversion)) convert = src_var_unit_conversion - call horiz_interp_and_extrap_tracer(src_file, src_var_nam, convert, recnum, & - G, tr_z, mask_z, z_in, z_edges_in, missing_value, reentrant_x, tripolar_n, homog) + G, tr_z, mask_z, z_in, z_edges_in, missing_value, reentrant_x, tripolar_n, & + homog, m_to_Z=US%m_to_Z) kd = size(z_edges_in,1)-1 call pass_var(tr_z,G%Domain) @@ -143,51 +140,38 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, PF, src_file, src_var_nam, ! First we reserve a work space for reconstructions of the source data allocate( h1(kd) ) allocate( hSrc(isd:ied,jsd:jed,kd) ) - allocate( tmpT1dIn(kd) ) call initialize_remapping( remapCS, remapScheme, boundary_extrapolation=.false. ) ! Data for reconstructions ! Next we initialize the regridding package so that it knows about the target grid - allocate( hTarget(nz) ) - allocate( h2(nz) ) - allocate( tmpT1d(nz) ) - allocate( deltaE(nz+1) ) do j = js, je ; do i = is, ie if (G%mask2dT(i,j)>0.) then ! Build the source grid zTopOfCell = 0. ; zBottomOfCell = 0. ; nPoints = 0 + z_bathy = G%bathyT(i,j) do k = 1, kd if (mask_z(i,j,k) > 0.) then - zBottomOfCell = -min( z_edges_in(k+1), G%bathyT(i,j) ) - tmpT1dIn(k) = tr_z(i,j,k) + zBottomOfCell = -min( z_edges_in(k+1), z_bathy ) elseif (k>1) then - zBottomOfCell = -G%bathyT(i,j) - tmpT1dIn(k) = tmpT1dIn(k-1) - else ! This next block should only ever be reached over land - tmpT1dIn(k) = -99.9 + zBottomOfCell = -z_bathy endif h1(k) = zTopOfCell - zBottomOfCell if (h1(k)>0.) nPoints = nPoints + 1 zTopOfCell = zBottomOfCell ! Bottom becomes top for next value of k enddo - h1(kd) = h1(kd) + ( zTopOfCell + G%bathyT(i,j) ) ! In case data is deeper than model + h1(kd) = h1(kd) + ( zTopOfCell + z_bathy ) ! In case data is deeper than model else tr(i,j,:) = 0. endif ! mask2dT - hSrc(i,j,:) = h1(:) + hSrc(i,j,:) = GV%Z_to_H * h1(:) enddo ; enddo call ALE_remap_scalar(remapCS, G, GV, kd, hSrc, tr_z, h, tr, all_cells=.false. ) deallocate( hSrc ) deallocate( h1 ) - deallocate( h2 ) - deallocate( hTarget ) - deallocate( tmpT1d ) - deallocate( tmpT1dIn ) - deallocate( deltaE ) do k=1,nz - call myStats(tr(:,:,k),missing_value,is,ie,js,je,k,'Tracer from ALE()') + call myStats(tr(:,:,k), missing_value, is, ie, js, je, k, 'Tracer from ALE()') enddo call cpu_clock_end(id_clock_ALE) endif ! useALEremapping @@ -204,5 +188,4 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, PF, src_file, src_var_nam, end subroutine MOM_initialize_tracer_from_Z - end module MOM_tracer_initialization_from_Z diff --git a/src/initialization/midas_vertmap.F90 b/src/initialization/midas_vertmap.F90 index c1ba6793b8..a985cf2982 100644 --- a/src/initialization/midas_vertmap.F90 +++ b/src/initialization/midas_vertmap.F90 @@ -1,89 +1,56 @@ -module midas_vertmap +!> Routines for initialization callable from MOM6 or Python (MIDAS) +module MIDAS_vertmap ! This file is part of MOM6. See LICENSE.md for the license. -!*********************************************************************** -!# -!# This module contains various subroutines related to -!# mapping a gridded field from z-space -!# into a Lagrangian vertical coordinate, such as potential -!# density and vice-versa. It was originally developed at NOAA/GFDL by -!# Matthew.Harrison@noaa.gov as part of his participation -!# in the development of the Generalized Ocean Layered Dynamics -!# (MOM) ocean model. -!# -!# These routines are callable from C/Python/F90 interfaces. -!# Python Usage example: -!# >python -!# from midas import * -!# grid=gold_grid('ocean_geometry.nc') -!# grid_obs=generic_grid('temp_salt_z.nc',var='PTEMP') -!# S=state(path='temp_salt_z.nc',grid=grid_obs, -!# fields=['PTEMP','SALT'],date_bounds=[datetime(1900,1,1,0,0,0), -!# datetime(1900,1,30,0,0,0)],default_calendar='noleap') -!# fvgrid=nc.Dataset('/net3/mjh/models/CM2G/Vertical_coordinate.nc') -!# R=fvgrid.variables['R'][:] -!# nkml=2;nkbl=2;min_depth=10.0;p_ref=2.e7;hml=5.0;fit_target=True -!# T=S.horiz_interp('PTEMP',target=grid,src_modulo=True,method='bilinear') -!# T=S.horiz_interp('SALT',target=grid,src_modulo=True,method='bilinear',PrevState=T) -!# T.remap_Z_to_layers('PTEMP','SALT',R,p_ref,grid.wet,nkml,nkbl,hml,fit_target) -!# -!# MIDAS === Modular Isosurface Data Analysis Software -!# ================================================================== - +! If calling from MOM6, use MOM6 interfaces for EOS functions #ifndef PY_SOLO - use MOM_EOS, only : EOS_type, calculate_density,calculate_density_derivs +use MOM_EOS, only : EOS_type, calculate_density,calculate_density_derivs - implicit none ; private +implicit none ; private - public tracer_z_init, determine_temperature, fill_boundaries - public find_interfaces, meshgrid +public tracer_z_init, determine_temperature, fill_boundaries +public find_interfaces, meshgrid #endif - interface fill_boundaries - module procedure fill_boundaries_real - module procedure fill_boundaries_int - end interface +! 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. - real, parameter :: epsln=1.e-10 +!> Fill grid edges +interface fill_boundaries + module procedure fill_boundaries_real + module procedure fill_boundaries_int +end interface +! real, parameter :: epsln=1.e-10 !< A hard-wired constant! + !! \todo Get rid of this constant contains - - - #ifdef PY_SOLO -!#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!# These EOS routines are needed only for the stand-alone version of the code - +!> Calculate seawater equation of state, given T[degC], S[PSU], and p[Pa] +!! Returns density [kg m-3] +!! +!! These EOS routines are needed only for the stand-alone version of the code +!! The subroutines in this file implement the equation of state for +!! sea water using the formulae given by Wright, 1997, J. Atmos. +!! Ocean. Tech., 14, 735-740. function wright_eos_2d(T,S,p) result(rho) -! -!********************************************************************** -! The subroutines in this file implement the equation of state for * -! sea water using the formulae given by Wright, 1997, J. Atmos. * -! Ocean. Tech., 14, 735-740. * -! *********************************************************************** -! - -! Calculate seawater equation of state, given T[degC],S[PSU],p[Pa] -! Returns density [kg m-3] - - real(kind=8), dimension(:,:), intent(in) :: T,S - real, intent(in) :: p - - real(kind=8), dimension(size(T,1),size(T,2)) :: rho - - + real(kind=8), dimension(:,:), intent(in) :: T,S !< temperature [degC] and Salinity [psu] + real, intent(in) :: p !< pressure [Pa] + real(kind=8), dimension(size(T,1),size(T,2)) :: rho !< potential density [kg m-3] + ! Local variables real(kind=8) :: a0,a1,a2,b0,b1,b2,b3,b4,b5,c0,c1,c2,c3,c4,c5 real(kind=8) :: al0,lam,p0,I_denom integer :: i,k - a0 = 7.057924e-4; a1 = 3.480336e-7; a2 = -1.112733e-7; - b0 = 5.790749e8; b1 = 3.516535e6; b2 = -4.002714e4; - b3 = 2.084372e2; b4 = 5.944068e5; b5 = -9.643486e3; - c0 = 1.704853e5; c1 = 7.904722e2; c2 = -7.984422; - c3 = 5.140652e-2; c4 = -2.302158e2; c5 = -3.079464; + a0 = 7.057924e-4; a1 = 3.480336e-7; a2 = -1.112733e-7 + b0 = 5.790749e8; b1 = 3.516535e6; b2 = -4.002714e4 + b3 = 2.084372e2; b4 = 5.944068e5; b5 = -9.643486e3 + c0 = 1.704853e5; c1 = 7.904722e2; c2 = -7.984422 + c3 = 5.140652e-2; c4 = -2.302158e2; c5 = -3.079464 do k=1,size(T,2) do i=1,size(T,1) @@ -97,919 +64,770 @@ function wright_eos_2d(T,S,p) result(rho) enddo enddo - return end function wright_eos_2d +!> Calculate seawater thermal expansion coefficient given T[degC],S[PSU],p[Pa] +!! Returns density [kg m-3 degC-1] +!! +!! The subroutines in this file implement the equation of state for +!! sea water using the formulae given by Wright, 1997, J. Atmos. +!! Ocean. Tech., 14, 735-740. function alpha_wright_eos_2d(T,S,p) result(drho_dT) + real(kind=8), dimension(:,:), intent(in) :: T,S !< temperature [degC] and Salinity [psu] + real, intent(in) :: p !< pressure [Pa] + real(kind=8), dimension(size(T,1),size(T,2)) :: drho_dT !< partial derivative of density with + !! respect to temperature [kg m-3 degC-1] + ! Local variables + real(kind=8) :: a0,a1,a2,b0,b1,b2,b3,b4,b5,c0,c1,c2,c3,c4,c5 + real(kind=8) :: al0,lam,p0,I_denom,I_denom2 + integer :: i,k -! ********************************************************************** -! The subroutines in this file implement the equation of state for * -! sea water using the formulae given by Wright, 1997, J. Atmos. * -! Ocean. Tech., 14, 735-740. * -! *********************************************************************** - -! Calculate seawater thermal expansion coefficient given T[degC],S[PSU],p[Pa] -! Returns density [kg m-3 C-1] - -real(kind=8), dimension(:,:), intent(in) :: T,S -real, intent(in) :: p -real(kind=8), dimension(size(T,1),size(T,2)) :: drho_dT - -real(kind=8) :: a0,a1,a2,b0,b1,b2,b3,b4,b5,c0,c1,c2,c3,c4,c5 -real(kind=8) :: al0,lam,p0,I_denom,I_denom2 -integer :: i,k - -a0 = 7.057924e-4; a1 = 3.480336e-7; a2 = -1.112733e-7; -b0 = 5.790749e8; b1 = 3.516535e6; b2 = -4.002714e4; -b3 = 2.084372e2; b4 = 5.944068e5; b5 = -9.643486e3; -c0 = 1.704853e5; c1 = 7.904722e2; c2 = -7.984422; -c3 = 5.140652e-2; c4 = -2.302158e2; c5 = -3.079464; - -do k=1,size(T,2) - do i=1,size(T,1) - al0 = a0 + a1*T(i,k) +a2*S(i,k) - p0 = b0 + b4*S(i,k) + T(i,k) * (b1 + T(i,k)*(b2 + & - b3*T(i,k)) + b5*S(i,k)) - lam = c0 +c4*S(i,k) + T(i,k) * (c1 + T(i,k)*(c2 + & - c3*T(i,k)) + c5*S(i,k)) - I_denom = 1.0 / (lam + al0*(p+p0)) - I_denom2 = I_denom*I_denom - drho_dT(i,k) = I_denom2*(lam*(b1+T(i,k)*(2*b2 + & - 3*b3*T(i,k)) + b5*S(i,k)) - (p+p0)*((p+p0)*a1 + & - (c1+T(i,k)*(2*c2 + 3*c3*T(i,k)) + c5*S(i,k)))) - enddo -enddo + a0 = 7.057924e-4; a1 = 3.480336e-7; a2 = -1.112733e-7 + b0 = 5.790749e8; b1 = 3.516535e6; b2 = -4.002714e4 + b3 = 2.084372e2; b4 = 5.944068e5; b5 = -9.643486e3 + c0 = 1.704853e5; c1 = 7.904722e2; c2 = -7.984422 + c3 = 5.140652e-2; c4 = -2.302158e2; c5 = -3.079464 + do k=1,size(T,2) + do i=1,size(T,1) + al0 = a0 + a1*T(i,k) +a2*S(i,k) + p0 = b0 + b4*S(i,k) + T(i,k) * (b1 + T(i,k)*(b2 + & + b3*T(i,k)) + b5*S(i,k)) + lam = c0 +c4*S(i,k) + T(i,k) * (c1 + T(i,k)*(c2 + & + c3*T(i,k)) + c5*S(i,k)) + I_denom = 1.0 / (lam + al0*(p+p0)) + I_denom2 = I_denom*I_denom + drho_dT(i,k) = I_denom2*(lam*(b1+T(i,k)*(2*b2 + & + 3*b3*T(i,k)) + b5*S(i,k)) - (p+p0)*((p+p0)*a1 + & + (c1+T(i,k)*(2*c2 + 3*c3*T(i,k)) + c5*S(i,k)))) + enddo + enddo -return + return end function alpha_wright_eos_2d +!> Calculate seawater haline expansion coefficient given T[degC],S[PSU],p[Pa] +!! Returns density [kg m-3 PSU-1] +!! +!! The subroutines in this file implement the equation of state for +!! sea water using the formulae given by Wright, 1997, J. Atmos. +!! Ocean. Tech., 14, 735-740. function beta_wright_eos_2d(T,S,p) result(drho_dS) + real(kind=8), dimension(:,:), intent(in) :: T,S !< temperature [degC] and salinity [psu] + real, intent(in) :: p !< pressure [Pa] + real(kind=8), dimension(size(T,1),size(T,2)) :: drho_dS !< partial derivative of density with + !! respect to salinity [kg m-3 PSU-1] + ! Local variables + real(kind=8) :: a0,a1,a2,b0,b1,b2,b3,b4,b5,c0,c1,c2,c3,c4,c5 + real(kind=8) :: al0,lam,p0,I_denom,I_denom2 + integer :: i,k -! ********************************************************************** -! The subroutines in this file implement the equation of state for * -! sea water using the formulae given by Wright, 1997, J. Atmos. * -! Ocean. Tech., 14, 735-740. * -! *********************************************************************** - -! Calculate seawater haline expansion coefficient given T[degC],S[PSU],p[Pa] -! Returns density [kg m-3 PSU-1] - -real(kind=8), dimension(:,:), intent(in) :: T,S -real, intent(in) :: p - -real(kind=8), dimension(size(T,1),size(T,2)) :: drho_dS - - - -real(kind=8) :: a0,a1,a2,b0,b1,b2,b3,b4,b5,c0,c1,c2,c3,c4,c5 -real(kind=8) :: al0,lam,p0,I_denom,I_denom2 -integer :: i,k - -a0 = 7.057924e-4; a1 = 3.480336e-7; a2 = -1.112733e-7; -b0 = 5.790749e8; b1 = 3.516535e6; b2 = -4.002714e4; -b3 = 2.084372e2; b4 = 5.944068e5; b5 = -9.643486e3; -c0 = 1.704853e5; c1 = 7.904722e2; c2 = -7.984422; -c3 = 5.140652e-2; c4 = -2.302158e2; c5 = -3.079464; + a0 = 7.057924e-4; a1 = 3.480336e-7; a2 = -1.112733e-7 + b0 = 5.790749e8; b1 = 3.516535e6; b2 = -4.002714e4 + b3 = 2.084372e2; b4 = 5.944068e5; b5 = -9.643486e3 + c0 = 1.704853e5; c1 = 7.904722e2; c2 = -7.984422 + c3 = 5.140652e-2; c4 = -2.302158e2; c5 = -3.079464 -do k=1,size(T,2) - do i=1,size(T,1) - al0 = a0 + a1*T(i,k) +a2*S(i,k) - p0 = b0 + b4*S(i,k) + T(i,k) * (b1 + T(i,k)*(b2 + & - b3*T(i,k)) + b5*S(i,k)) - lam = c0 +c4*S(i,k) + T(i,k) * (c1 + T(i,k)*(c2 + & - c3*T(i,k)) + c5*S(i,k)) - I_denom = 1.0 / (lam + al0*(p+p0)) - I_denom2 = I_denom*I_denom - drho_dS(i,k) = I_denom2*(lam*(b4+b5*T(i,k)) - & - (p+p0)*((p+p0)*a2 + (c4+c5*T(i,k)))) + do k=1,size(T,2) + do i=1,size(T,1) + al0 = a0 + a1*T(i,k) +a2*S(i,k) + p0 = b0 + b4*S(i,k) + T(i,k) * (b1 + T(i,k)*(b2 + & + b3*T(i,k)) + b5*S(i,k)) + lam = c0 +c4*S(i,k) + T(i,k) * (c1 + T(i,k)*(c2 + & + c3*T(i,k)) + c5*S(i,k)) + I_denom = 1.0 / (lam + al0*(p+p0)) + I_denom2 = I_denom*I_denom + drho_dS(i,k) = I_denom2*(lam*(b4+b5*T(i,k)) - & + (p+p0)*((p+p0)*a2 + (c4+c5*T(i,k)))) + enddo enddo -enddo - -return + return end function beta_wright_eos_2d - -!# END STAND-ALONE ROUTINES -!#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #endif -function tracer_z_init(tr_in,z_edges,e,nkml,nkbl,land_fill,wet,nlay,nlevs,debug,i_debug,j_debug) result(tr) -! -! Adopted from R. Hallberg -! Arguments: -! (in) tr_in - The z-space array of tracer concentrations that is read in. -! (in) z_edges - The depths of the cell edges in the input z* data (m) -! (in) e - The depths of the layer interfaces (m) -! (in) nkml - number of mixed layer pieces -! (in) nkbl - number of buffer layer pieces -! (in) land_fill - fill in data over land -! (in) wet - wet mask (1=ocean) -! (in) nlay - number of layers -! (in) nlevs - number of levels - -! (out) tr - tracers on layers - -! tr_1d ! A copy of the input tracer concentrations in a column. -! wt ! The fractional weight for each layer in the range between - ! k_top and k_bot, nondim. -! z1 ! z1 and z2 are the depths of the top and bottom limits of the part -! z2 ! of a z-cell that contributes to a layer, relative to the cell -! center and normalized by the cell thickness, nondim. -! Note that -1/2 <= z1 <= z2 <= 1/2. -! -real, dimension(:,:,:), intent(in) :: tr_in -real, dimension(size(tr_in,3)+1), intent(in) :: z_edges -integer, intent(in) :: nlay -real, dimension(size(tr_in,1),size(tr_in,2),nlay+1), intent(in) :: e -integer, intent(in) :: nkml,nkbl -real, intent(in) :: land_fill -real, dimension(size(tr_in,1),size(tr_in,2)), intent(in) :: wet -real, dimension(size(tr_in,1),size(tr_in,2)), optional, intent(in) ::nlevs -logical, intent(in), optional :: debug -integer, intent(in), optional :: i_debug, j_debug - -real, dimension(size(tr_in,1),size(tr_in,2),nlay) :: tr -real, dimension(size(tr_in,3)) :: tr_1d -real, dimension(nlay+1) :: e_1d -real, dimension(nlay) :: tr_ -integer, dimension(size(tr_in,1),size(tr_in,2)) :: nlevs_data - -integer :: n,i,j,k,l,nx,ny,nz,nt,kz -integer :: k_top,k_bot,k_bot_prev,kk,kstart -real :: sl_tr -real, dimension(size(tr_in,3)) :: wt,z1,z2 -logical :: debug_msg, debug_ - -nx = size(tr_in,1); ny=size(tr_in,2); nz = size(tr_in,3) - -nlevs_data = size(tr_in,3) -if (PRESENT(nlevs)) then - nlevs_data = anint(nlevs) -endif - -debug_=.false. -if (PRESENT(debug)) then - debug_=debug -endif - -debug_msg = .false. -if (debug_) then - debug_msg=.true. -endif - - -do j=1,ny - i_loop: do i=1,nx - if (nlevs_data(i,j) .eq. 0 .or. wet(i,j) .eq. 0.) then - tr(i,j,:) = land_fill - cycle i_loop - endif - - do k=1,nz - tr_1d(k) = tr_in(i,j,k) - enddo +!> Layer model routine for remapping tracers +function tracer_z_init(tr_in, z_edges, e, nkml, nkbl, land_fill, wet, nlay, nlevs, & + debug, i_debug, j_debug, eps_z) result(tr) + real, dimension(:,:,:), intent(in) :: tr_in !< The z-space array of tracer concentrations that is read in. + real, dimension(size(tr_in,3)+1), intent(in) :: z_edges !< The depths of the cell edges in the input z* data + !! [Z ~> m or m] + integer, intent(in) :: nlay !< The number of vertical layers in the target grid + real, dimension(size(tr_in,1),size(tr_in,2),nlay+1), & + intent(in) :: e !< The depths of the target layer interfaces [Z ~> m or m] + integer, intent(in) :: nkml !< The number of mixed layers + integer, intent(in) :: nkbl !< The number of buffer layers + real, intent(in) :: land_fill !< fill in data over land (1) + real, dimension(size(tr_in,1),size(tr_in,2)), & + intent(in) :: wet !< The wet mask for the source data (valid points) + real, dimension(size(tr_in,1),size(tr_in,2)), & + optional, intent(in) :: nlevs !< The number of input levels with valid data + logical, optional, intent(in) :: debug !< optional debug flag + integer, optional, intent(in) :: i_debug !< i-index of point for debugging + integer, optional, intent(in) :: j_debug !< j-index of point for debugging + real, optional, intent(in) :: eps_z !< A negligibly small layer thickness [Z ~> m or m]. + real, dimension(size(tr_in,1),size(tr_in,2),nlay) :: tr !< tracers in layer space + + ! Local variables + real, dimension(size(tr_in,3)) :: tr_1d !< a copy of the input tracer concentrations in a column. + real, dimension(nlay+1) :: e_1d ! A 1-d column of intreface heights, in the same units as e. + real, dimension(nlay) :: tr_ ! A 1-d column of tracer concentrations + integer, dimension(size(tr_in,1),size(tr_in,2)) :: nlevs_data !< number of valid levels in the input dataset + integer :: n,i,j,k,l,nx,ny,nz,nt,kz + integer :: k_top,k_bot,k_bot_prev,kk,kstart + real :: sl_tr ! The tracer concentration slope times the layer thickness, in tracer units. + real :: epsln_Z ! A negligibly thin layer thickness [Z ~> m]. + real, dimension(size(tr_in,3)) :: wt !< The fractional weight for each layer in the range between z1 and z2 + real, dimension(size(tr_in,3)) :: z1, z2 ! z1 and z2 are the fractional depths of the top and bottom + ! limits of the part of a z-cell that contributes to a layer, relative + ! to the cell center and normalized by the cell thickness [nondim]. + ! Note that -1/2 <= z1 <= z2 <= 1/2. + + logical :: debug_msg, debug_, debug_pt + + nx = size(tr_in,1); ny=size(tr_in,2); nz = size(tr_in,3) + + nlevs_data = size(tr_in,3) + if (PRESENT(nlevs)) nlevs_data = anint(nlevs) + epsln_Z = 1.0e-10 ; if (PRESENT(eps_z)) epsln_Z = eps_z + + debug_=.false. ; if (PRESENT(debug)) debug_ = debug + debug_msg = debug_ + debug_pt = debug_ ; if (PRESENT(i_debug) .and. PRESENT(j_debug)) debug_pt = debug_ + + do j=1,ny + i_loop: do i=1,nx + if (nlevs_data(i,j) == 0 .or. wet(i,j) == 0.) then + tr(i,j,:) = land_fill + cycle i_loop + endif - do k=1,nlay+1 - e_1d(k) = e(i,j,k) - enddo - k_bot = 1 ; k_bot_prev = -1 - do k=1,nlay - if (e_1d(k+1) > z_edges(1)) then - tr(i,j,k) = tr_1d(1) - elseif (e_1d(k) < z_edges(nlevs_data(i,j)+1)) then - if (debug_msg) then - print *,'*** WARNING : Found interface below valid range of z data ' - print *,'(i,j,z_bottom,interface)= ',& - i,j,z_edges(nlevs_data(i,j)+1),e_1d(k) - print *,'z_edges= ',z_edges - print *,'e=',e_1d - print *,'*** I will extrapolate below using the bottom-most valid values' - debug_msg = .false. - endif - tr(i,j,k) = tr_1d(nlevs_data(i,j)) + do k=1,nz + tr_1d(k) = tr_in(i,j,k) + enddo - else - kstart=k_bot - call find_overlap(z_edges, e_1d(k), e_1d(k+1), nlevs_data(i,j), & - kstart, k_top, k_bot, wt, z1, z2) - - if (debug_) then - if (PRESENT(i_debug)) then - if (i.eq.i_debug.and.j.eq.j_debug) then - print *,'0001 k,k_top,k_bot,sum(wt),sum(z2-z1) = ',k,k_top,k_bot,sum(wt),sum(z2-z1) - endif - endif - endif - kz = k_top - sl_tr=0.0; ! cur_tr=0.0 - if (kz /= k_bot_prev) then -! Calculate the intra-cell profile. - if ((kz < nlevs_data(i,j)) .and. (kz > 1)) then - sl_tr = find_limited_slope(tr_1d, z_edges, kz) + do k=1,nlay+1 + e_1d(k) = e(i,j,k) + enddo + k_bot = 1 ; k_bot_prev = -1 + do k=1,nlay + if (e_1d(k+1) > z_edges(1)) then + tr(i,j,k) = tr_1d(1) + elseif (e_1d(k) < z_edges(nlevs_data(i,j)+1)) then + if (debug_msg) then + print *,'*** WARNING : Found interface below valid range of z data ' + print *,'(i,j,z_bottom,interface)= ',& + i,j,z_edges(nlevs_data(i,j)+1),e_1d(k) + print *,'z_edges= ',z_edges + print *,'e=',e_1d + print *,'*** I will extrapolate below using the bottom-most valid values' + debug_msg = .false. endif - endif - if (kz > nlevs_data(i,j)) kz = nlevs_data(i,j) -! This is the piecewise linear form. - tr(i,j,k) = wt(kz) * & - (tr_1d(kz) + 0.5*sl_tr*(z2(kz) + z1(kz))) -! For the piecewise parabolic form add the following... -! + C1_3*cur_tr*(z2(kz)**2 + z2(kz)*z1(kz) + z1(kz)**2)) -! if (debug_) then -! print *,'k,k_top,k_bot= ',k,k_top,k_bot -! endif - if (debug_) then - if (PRESENT(i_debug)) then - if (i.eq.i_debug.and.j.eq.j_debug) then - print *,'0002 k,k_top,k_bot,k_bot_prev,sl_tr = ',k,k_top,k_bot,k_bot_prev,sl_tr - endif - endif - endif + tr(i,j,k) = tr_1d(nlevs_data(i,j)) + + else + kstart=k_bot + call find_overlap(z_edges, e_1d(k), e_1d(k+1), nlevs_data(i,j), & + kstart, k_top, k_bot, wt, z1, z2) + + if (debug_pt) then ; if ((i == i_debug) .and. (j == j_debug)) then + print *,'0001 k,k_top,k_bot,sum(wt),sum(z2-z1) = ',k,k_top,k_bot,sum(wt),sum(z2-z1) + endif ; endif + kz = k_top + sl_tr=0.0; ! cur_tr=0.0 + if (kz /= k_bot_prev) then + ! Calculate the intra-cell profile. + if ((kz < nlevs_data(i,j)) .and. (kz > 1)) then + sl_tr = find_limited_slope(tr_1d, z_edges, kz) + endif + endif + if (kz > nlevs_data(i,j)) kz = nlevs_data(i,j) + ! This is the piecewise linear form. + tr(i,j,k) = wt(kz) * (tr_1d(kz) + 0.5*sl_tr*(z2(kz) + z1(kz))) + ! For the piecewise parabolic form add the following... + ! + C1_3*wt(kz) * cur_tr*(z2(kz)**2 + z2(kz)*z1(kz) + z1(kz)**2)) + if (debug_pt) then ; if ((i == i_debug) .and. (j == j_debug)) then + print *,'0002 k,k_top,k_bot,k_bot_prev,sl_tr = ',k,k_top,k_bot,k_bot_prev,sl_tr + endif ; endif + + do kz=k_top+1,k_bot-1 + tr(i,j,k) = tr(i,j,k) + wt(kz)*tr_1d(kz) + enddo + + if (debug_pt) then ; if ((i == i_debug) .and. (j == j_debug)) then + print *,'0003 k,tr = ',k,tr(i,j,k) + endif ; endif + + if (k_bot > k_top) then + kz = k_bot + ! Calculate the intra-cell profile. + sl_tr = 0.0 ! ; cur_tr = 0.0 + if ((kz < nlevs_data(i,j)) .and. (kz > 1)) then + sl_tr = find_limited_slope(tr_1d, z_edges, kz) + endif + ! This is the piecewise linear form. + tr(i,j,k) = tr(i,j,k) + wt(kz) * & + (tr_1d(kz) + 0.5*sl_tr*(z2(kz) + z1(kz))) + ! For the piecewise parabolic form add the following... + ! + C1_3*cur_tr*(z2(kz)**2 + z2(kz)*z1(kz) + z1(kz)**2)) - do kz=k_top+1,k_bot-1 - tr(i,j,k) = tr(i,j,k) + wt(kz)*tr_1d(kz) - enddo + if (debug_pt) then ; if ((i == i_debug) .and. (j == j_debug)) then + print *,'0004 k,kz,nlevs,sl_tr,tr = ',k,kz,nlevs_data(i,j),sl_tr,tr(i,j,k) + print *,'0005 k,kz,tr(kz),tr(kz-1),tr(kz+1) = ',k,kz,tr_1d(kz),tr_1d(kz-1),tr_1d(kz+1),z_edges(kz+2) + endif ; endif - if (debug_) then - if (PRESENT(i_debug)) then - if (i.eq.i_debug.and.j.eq.j_debug) then - print *,'0003 k,tr = ',k,tr(i,j,k) - endif - endif - endif - - if (k_bot > k_top) then - kz = k_bot -! Calculate the intra-cell profile. - sl_tr = 0.0 ! ; cur_tr = 0.0 - if ((kz < nlevs_data(i,j)) .and. (kz > 1)) then - sl_tr = find_limited_slope(tr_1d, z_edges, kz) -! if (debug_) then -! print *,'002 sl_tr,k,kz,nlevs= ',sl_tr,k,kz,nlevs_data(i,j),nlevs(i,j) -! endif - endif -! This is the piecewise linear form. - tr(i,j,k) = tr(i,j,k) + wt(kz) * & - (tr_1d(kz) + 0.5*sl_tr*(z2(kz) + z1(kz))) -! For the piecewise parabolic form add the following... -! + C1_3*cur_tr*(z2(kz)**2 + z2(kz)*z1(kz) + z1(kz)**2)) - - if (debug_) then - if (PRESENT(i_debug)) then - if (i.eq.i_debug.and.j.eq.j_debug) then - print *,'0004 k,kz,nlevs,sl_tr,tr = ',k,kz,nlevs_data(i,j),sl_tr,tr(i,j,k) - print *,'0005 k,kz,tr(kz),tr(kz-1),tr(kz+1) = ',k,kz,tr_1d(kz),tr_1d(kz-1),tr_1d(kz+1),z_edges(kz+2) - endif - endif endif + k_bot_prev = k_bot endif - k_bot_prev = k_bot + enddo ! k-loop - endif - enddo ! k-loop + do k=2,nlay ! simply fill vanished layers with adjacent value + if (e_1d(k)-e_1d(k+1) <= epsln_Z) tr(i,j,k)=tr(i,j,k-1) + enddo - do k=2,nlay ! simply fill vanished layers with adjacent value - if (e_1d(k)-e_1d(k+1) .le. epsln) tr(i,j,k)=tr(i,j,k-1) - enddo + enddo i_loop + enddo - enddo i_loop -enddo +end function tracer_z_init -return +!> Return the index where to insert item x in list a, assuming a is sorted. +!! The return values [i] is such that all e in a[:i-1] have e <= x, and all e in +!! a[i:] have e > x. So if x already appears in the list, will +!! insert just after the rightmost x already there. +!! Optional args lo (default 1) and hi (default len(a)) bound the +!! slice of a to be searched. +function bisect_fast(a, x, lo, hi) result(bi_r) + real, dimension(:,:), intent(in) :: a !< Sorted list + real, dimension(:), intent(in) :: x !< Item to be inserted + integer, dimension(size(a,1)), optional, intent(in) :: lo !< Lower bracket of optional range to search + integer, dimension(size(a,1)), optional, intent(in) :: hi !< Upper bracket of optional range to search + integer, dimension(size(a,1),size(x,1)) :: bi_r -end function tracer_z_init + integer :: mid,num_x,num_a,i + integer, dimension(size(a,1)) :: lo_,hi_,lo0,hi0 + integer :: nprofs,j + lo_=1;hi_=size(a,2);num_x=size(x,1);bi_r=-1;nprofs=size(a,1) -function bisect_fast(a, x, lo, hi) result(bi_r) -! -! Return the index where to insert item x in list a, assuming a is sorted. -! The return values [i] is such that all e in a[:i-1] have e <= x, and all e in -! a[i:] have e > x. So if x already appears in the list, will -! insert just after the rightmost x already there. -! Optional args lo (default 1) and hi (default len(a)) bound the -! slice of a to be searched. -! -! (in) a - sorted list -! (in) x - item to be inserted -! (in) lo, hi - optional range to search - -real, dimension(:,:), intent(in) :: a -real, dimension(:), intent(in) :: x -integer, dimension(size(a,1)), intent(in), optional :: lo,hi -integer, dimension(size(a,1),size(x,1)) :: bi_r - -integer :: mid,num_x,num_a,i -integer, dimension(size(a,1)) :: lo_,hi_,lo0,hi0 -integer :: nprofs,j - -lo_=1;hi_=size(a,2);num_x=size(x,1);bi_r=-1;nprofs=size(a,1) - -if (PRESENT(lo)) then - where (lo>0) lo_=lo -end if -if (PRESENT(hi)) then - where (hi>0) hi_=hi -endif - -lo0=lo_;hi0=hi_ - -do j=1,nprofs - do i=1,num_x - lo_=lo0;hi_=hi0 - do while (lo_(j) < hi_(j)) - mid = (lo_(j)+hi_(j))/2 - if (x(i) < a(j,mid)) then - hi_(j) = mid - else - lo_(j) = mid+1 - endif + if (PRESENT(lo)) then + where (lo>0) lo_=lo + endif + if (PRESENT(hi)) then + where (hi>0) hi_=hi + endif + + lo0=lo_;hi0=hi_ + + do j=1,nprofs + do i=1,num_x + lo_=lo0;hi_=hi0 + do while (lo_(j) < hi_(j)) + mid = (lo_(j)+hi_(j))/2 + if (x(i) < a(j,mid)) then + hi_(j) = mid + else + lo_(j) = mid+1 + endif + enddo + bi_r(j,i)=lo_(j) enddo - bi_r(j,i)=lo_(j) enddo -enddo -return + return end function bisect_fast - #ifdef PY_SOLO -subroutine determine_temperature(temp,salt,R,p_ref,niter,land_fill,h,k_start) - -! # This subroutine determines the potential temperature and -! # salinity that is consistent with the target density -! # using provided initial guess -! # (inout) temp - potential temperature (degC) -! # (inout) salt - salinity (PSU) -! # (in) R - Desired potential density, in kg m-3. -! # (in) p_ref - Reference pressure, in Pa. -! # (in) niter - maximum number of iterations -! # (in) h - layer thickness . Do not iterate for massless layers -! # (in) k_start - starting index (i.e. below the buffer layer) -! # (in) land_fill - land fill value - -real(kind=8), dimension(:,:,:), intent(inout) :: temp,salt -real(kind=8), dimension(size(temp,3)), intent(in) :: R -real, intent(in) :: p_ref -integer, intent(in) :: niter -integer, intent(in) :: k_start -real, intent(in) :: land_fill -real(kind=8), dimension(:,:,:), intent(in) :: h - -real(kind=8), dimension(size(temp,1),size(temp,3)) :: T,S,dT,dS,rho,hin -real(kind=8), dimension(size(temp,1),size(temp,3)) :: drho_dT,drho_dS -real(kind=8), dimension(size(temp,1)) :: press - -integer :: nx,ny,nz,nt,i,j,k,n,itt -logical :: adjust_salt , old_fit -real :: dT_dS -real, parameter :: T_max = 35.0, T_min = -2.0 -real, parameter :: S_min = 0.5, S_max=65.0 -real, parameter :: tol=1.e-4, max_t_adj=1.0, max_s_adj = 0.5 - +! Only for stand-alone python + +!> This subroutine determines the potential temperature and salinity that +!! is consistent with the target density using provided initial guess +subroutine determine_temperature(temp, salt, R, p_ref, niter, land_fill, h, k_start) + real(kind=8), dimension(:,:,:), intent(inout) :: temp !< potential temperature [degC] + real(kind=8), dimension(:,:,:), intent(inout) :: salt !< salinity [PSU] + real(kind=8), dimension(size(temp,3)), intent(in) :: R !< desired potential density [kg m-3]. + real, intent(in) :: p_ref !< reference pressure [Pa]. + integer, intent(in) :: niter !< maximum number of iterations + integer, intent(in) :: k_start !< starting index (i.e. below the buffer layer) + real, intent(in) :: land_fill !< land fill value + real(kind=8), dimension(:,:,:), intent(in) :: h !< layer thickness . Do not iterate for massless layers + + ! Local variables + real, parameter :: T_max = 35.0, T_min = -2.0 #else - -subroutine determine_temperature(temp,salt,R,p_ref,niter,land_fill,h,k_start,eos) - -! # This subroutine determines the potential temperature and -! # salinity that is consistent with the target density -! # using provided initial guess -! # (inout) temp - potential temperature (degC) -! # (inout) salt - salinity (PSU) -! # (in) R - Desired potential density, in kg m-3. -! # (in) p_ref - Reference pressure, in Pa. -! # (in) niter - maximum number of iterations -! # (in) h - layer thickness . Do not iterate for massless layers -! # (in) k_start - starting index (i.e. below the buffer layer) -! # (in) land_fill - land fill value -! # (in) eos - seawater equation of state - -real, dimension(:,:,:), intent(inout) :: temp,salt -real, dimension(size(temp,3)), intent(in) :: R -real, intent(in) :: p_ref -integer, intent(in) :: niter -integer, intent(in) :: k_start -real, intent(in) :: land_fill -real, dimension(:,:,:), intent(in) :: h -type(eos_type), pointer, intent(in) :: eos - -real(kind=8), dimension(size(temp,1),size(temp,3)) :: T,S,dT,dS,rho,hin -real(kind=8), dimension(size(temp,1),size(temp,3)) :: drho_dT,drho_dS -real(kind=8), dimension(size(temp,1)) :: press - -integer :: nx,ny,nz,nt,i,j,k,n,itt -real :: dT_dS -logical :: adjust_salt , old_fit -real, parameter :: T_max = 31.0, T_min = -2.0 -real, parameter :: S_min = 0.5, S_max=65.0 -real, parameter :: tol=1.e-4, max_t_adj=1.0, max_s_adj = 0.5 - - +!> This subroutine determines the potential temperature and salinity that +!! is consistent with the target density using provided initial guess +subroutine determine_temperature(temp, salt, R, p_ref, niter, land_fill, h, k_start, eos) + real, dimension(:,:,:), intent(inout) :: temp !< potential temperature [degC] + real, dimension(:,:,:), intent(inout) :: salt !< salinity [PSU] + real, dimension(size(temp,3)), intent(in) :: R !< desired potential density [kg m-3]. + real, intent(in) :: p_ref !< reference pressure [Pa]. + integer, intent(in) :: niter !< maximum number of iterations + integer, intent(in) :: k_start !< starting index (i.e. below the buffer layer) + real, intent(in) :: land_fill !< land fill value + real, dimension(:,:,:), intent(in) :: h !< layer thickness, used only to avoid working on massless layers + type(eos_type), pointer :: eos !< seawater equation of state control structure + + real, parameter :: T_max = 31.0, T_min = -2.0 #endif - - -old_fit = .true. ! reproduces siena behavior - ! will switch to the newer - ! method which simultaneously adjusts - ! temp and salt based on the ratio - ! of the thermal and haline coefficients. - -nx=size(temp,1);ny=size(temp,2); nz=size(temp,3) - -press(:) = p_ref - -do j=1,ny - dS(:,:) = 0. ! Needs to be zero everywhere since there is a maxval(abs(dS)) later... - T=temp(:,j,:) - S=salt(:,j,:) - hin=h(:,j,:) - dT=0.0 - adjust_salt = .true. - iter_loop: do itt = 1,niter + ! Local variables (All of which need documentation!) + real(kind=8), dimension(size(temp,1),size(temp,3)) :: T, S, dT, dS, rho, hin + real(kind=8), dimension(size(temp,1),size(temp,3)) :: drho_dT, drho_dS + real(kind=8), dimension(size(temp,1)) :: press + integer :: nx, ny, nz, nt, i, j, k, n, itt + real :: dT_dS + logical :: adjust_salt, old_fit + real, parameter :: S_min = 0.5, S_max=65.0 + real, parameter :: tol=1.e-4, max_t_adj=1.0, max_s_adj = 0.5 + + old_fit = .true. ! reproduces siena behavior + ! will switch to the newer method which simultaneously adjusts + ! temp and salt based on the ratio of the thermal and haline coefficients. + + nx=size(temp,1) ; ny=size(temp,2) ; nz=size(temp,3) + + press(:) = p_ref + + do j=1,ny + dS(:,:) = 0. ! Needs to be zero everywhere since there is a maxval(abs(dS)) later... + T=temp(:,j,:) + S=salt(:,j,:) + hin=h(:,j,:) + dT=0.0 + adjust_salt = .true. + iter_loop: do itt = 1,niter #ifdef PY_SOLO - rho=wright_eos_2d(T,S,p_ref) - drho_dT=alpha_wright_eos_2d(T,S,p_ref) + rho=wright_eos_2d(T,S,p_ref) + drho_dT=alpha_wright_eos_2d(T,S,p_ref) #else - do k=1, nz - call calculate_density(T(:,k),S(:,k),press,rho(:,k),1,nx,eos) - call calculate_density_derivs(T(:,k),S(:,k),press,drho_dT(:,k),drho_dS(:,k),1,nx,eos) - enddo + do k=1, nz + call calculate_density(T(:,k), S(:,k), press, rho(:,k), 1, nx, eos) + call calculate_density_derivs(T(:,k), S(:,k), press, drho_dT(:,k), drho_dS(:,k), 1, nx, eos) + enddo #endif - do k=k_start,nz - do i=1,nx + do k=k_start,nz ; do i=1,nx -! if (abs(rho(i,k)-R(k))>tol .and. hin(i,k)>epsln .and. abs(T(i,k)-land_fill) < epsln) then +! if (abs(rho(i,k)-R(k))>tol .and. hin(i,k)>epsln .and. abs(T(i,k)-land_fill) < epsln) then if (abs(rho(i,k)-R(k))>tol) then - if (old_fit) then - dT(i,k)=(R(k)-rho(i,k))/drho_dT(i,k) - if (dT(i,k)>max_t_adj) dT(i,k)=max_t_adj - if (dT(i,k)<-1.0*max_t_adj) dT(i,k)=-1.0*max_t_adj - T(i,k)=max(min(T(i,k)+dT(i,k),T_max),T_min) - else - dT_dS = 10.0 - min(-drho_dT(i,k)/drho_dS(i,k),10.) - dS(i,k) = (R(k)-rho(i,k))/(drho_dS(i,k) - drho_dT(i,k)*dT_dS ) - dT(i,k)= -dT_dS*dS(i,k) - ! if (dT(i,k)>max_t_adj) dT(i,k)=max_t_adj - ! if (dT(i,k)<-1.0*max_t_adj) dT(i,k)=-1.0*max_t_adj - T(i,k)=max(min(T(i,k)+dT(i,k),T_max),T_min) - S(i,k)=max(min(S(i,k)+dS(i,k),S_max),S_min) - endif + if (old_fit) then + dT(i,k) = max(min((R(k)-rho(i,k)) / drho_dT(i,k), max_t_adj), -max_t_adj) + T(i,k) = max(min(T(i,k)+dT(i,k), T_max), T_min) + else + dT_dS = 10.0 - min(-drho_dT(i,k)/drho_dS(i,k),10.) + !### RWH: Based on the dimensions alone, the expression above should be: + ! dT_dS = 10.0 - min(-drho_dS(i,k)/drho_dT(i,k),10.) + dS(i,k) = (R(k)-rho(i,k)) / (drho_dS(i,k) - drho_dT(i,k)*dT_dS ) + dT(i,k) = -dT_dS*dS(i,k) + ! dT(i,k) = max(min(dT(i,k), max_t_adj), -max_t_adj) + T(i,k) = max(min(T(i,k)+dT(i,k), T_max), T_min) + S(i,k) = max(min(S(i,k)+dS(i,k), S_max), S_min) + endif endif - enddo - enddo - if (maxval(abs(dT)) < tol) then - adjust_salt = .false. - exit iter_loop - endif - enddo iter_loop + enddo ; enddo + if (maxval(abs(dT)) < tol) then + adjust_salt = .false. + exit iter_loop + endif + enddo iter_loop - if (adjust_salt .and. old_fit) then - iter_loop2: do itt = 1,niter + if (adjust_salt .and. old_fit) then ; do itt = 1,niter #ifdef PY_SOLO - rho=wright_eos_2d(T,S,p_ref) - drho_dS=beta_wright_eos_2d(T,S,p_ref) + rho = wright_eos_2d(T,S,p_ref) + drho_dS = beta_wright_eos_2d(T,S,p_ref) #else do k=1, nz call calculate_density(T(:,k),S(:,k),press,rho(:,k),1,nx,eos) call calculate_density_derivs(T(:,k),S(:,k),press,drho_dT(:,k),drho_dS(:,k),1,nx,eos) enddo #endif - do k=k_start,nz - do i=1,nx -! if (abs(rho(i,k)-R(k))>tol .and. hin(i,k)>epsln .and. abs(T(i,k)-land_fill) < epsln ) then - if (abs(rho(i,k)-R(k))>tol ) then - dS(i,k)=(R(k)-rho(i,k))/drho_dS(i,k) - if (dS(i,k)>max_s_adj) dS(i,k)=max_s_adj - if (dS(i,k)<-1.0*max_s_adj) dS(i,k)=-1.0*max_s_adj - S(i,k)=max(min(S(i,k)+dS(i,k),S_max),S_min) - endif - enddo - enddo - if (maxval(abs(dS)) < tol) then - exit iter_loop2 - endif - enddo iter_loop2 - endif - - temp(:,j,:)=T(:,:) - salt(:,j,:)=S(:,:) -enddo - + do k=k_start,nz ; do i=1,nx +! if (abs(rho(i,k)-R(k))>tol .and. hin(i,k)>epsln .and. abs(T(i,k)-land_fill) < epsln ) then + if (abs(rho(i,k)-R(k)) > tol) then + dS(i,k) = max(min((R(k)-rho(i,k)) / drho_dS(i,k), max_s_adj), -max_s_adj) + S(i,k) = max(min(S(i,k)+dS(i,k), S_max), S_min) + endif + enddo ; enddo + if (maxval(abs(dS)) < tol) exit + enddo ; endif -return + temp(:,j,:)=T(:,:) + salt(:,j,:)=S(:,:) + enddo end subroutine determine_temperature - +!> This subroutine determines the layers bounded by interfaces e that overlap +!! with the depth range between Z_top and Z_bot, and also the fractional weights +!! of each layer. It also calculates the normalized relative depths of the range +!! of each layer that overlaps that depth range. +!! Note that by convention, e decreases with increasing k and Z_top > Z_bot. subroutine find_overlap(e, Z_top, Z_bot, k_max, k_start, k_top, k_bot, wt, z1, z2) + real, dimension(:), intent(in) :: e !< The interface positions, [Z ~> m] or other units. + real, intent(in) :: Z_top !< The top of the range being mapped to, [Z ~> m] or other units. + real, intent(in) :: Z_bot !< The bottom of the range being mapped to, [Z ~> m] or other units. + integer, intent(in) :: k_max !< The number of valid layers. + integer, intent(in) :: k_start !< The layer at which to start searching. + integer, intent(out) :: k_top !< The index of the top layer that overlap with the depth range. + integer, intent(out) :: k_bot !< The index of the bottom layer that overlap with the depth range. + real, dimension(:), intent(out) :: wt !< The relative weights of each layer from k_top to k_bot [nondim]. + real, dimension(:), intent(out) :: z1 !< Depth of the top limit of layer that contributes to a level [nondim]. + real, dimension(:), intent(out) :: z2 !< Depth of the bottom limit of layer that contributes to a level [nondim]. + + ! Local variables + real :: Ih, e_c, tot_wt, I_totwt + integer :: k + + wt(:)=0.0 ; z1(:)=0.0 ; z2(:)=0.0 + k_top = k_start ; k_bot = k_start ; wt(1) = 1.0 ; z1(1) = -0.5 ; z2(1) = 0.5 + + do k=k_start,k_max ; if (e(K+1) < Z_top) exit ; enddo + k_top = k + + if (k>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. + ! Ih = 0.0 ; if (e(K) /= e(K+1)) Ih = 1.0 / (e(K)-e(K+1)) + 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 -! This subroutine determines the layers bounded by interfaces e that overlap -! with the depth range between Z_top and Z_bot, and also the fractional weights -! of each layer. It also calculates the normalized relative depths of the range -! of each layer that overlaps that depth range. -! Note that by convention, e decreases with increasing k and Z_top > Z_bot. -! -! Arguments: e - A column's interface heights, in m. -! (in) Z_top - The top of the range being mapped to, in m. -! (in) Z_bot - The bottom of the range being mapped to, in m. -! (in) k_max - The number of valid layers. -! (in) k_start - The layer at which to start searching. -! (out) k_top, k_bot - The indices of the top and bottom layers that -! overlap with the depth range. -! (out) wt - The relative weights of each layer from k_top to k_bot. -! (out) z1, z2 - z1 and z2 are the depths of the top and bottom 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(in) :: e -real, intent(in) :: Z_top, Z_bot -integer, intent(in) :: k_max, k_start -integer, intent(out) :: k_top, k_bot -real, dimension(:), intent(out) :: wt, z1, z2 - -real :: Ih, e_c, tot_wt, I_totwt -integer :: k - -wt(:)=0.0; z1(:)=0.0; z2(:)=0.0 -k_top = k_start; k_bot= k_start; wt(1) = 1.0; z1(1)=-0.5; z2(1) = 0.5 - -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 = 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. - z1(k) = (0.5*(e(k)+e(k+1)) - MIN(e(k),Z_top)) / (e(k)-e(k+1)) - 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 - z2(k) = (0.5*(e(k)+e(k+1)) - Z_bot) / (e(k)-e(k+1)) - 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 - -return + I_totwt = 0.0 ; if (tot_wt > 0.0) 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. function find_limited_slope(val, e, k) result(slope) - -! This subroutine determines a limited slope for val to be advected with -! a piecewise limited scheme. - -! Arguments: val - An column the values that are being interpolated. -! (in) e - A column's interface heights, in m. -! (in) slope - The normalized slope in the intracell distribution of val. -! (in) k - The layer whose slope is being determined. - - -real, dimension(:), intent(in) :: val -real, dimension(:), intent(in) :: e -integer, intent(in) :: k -real :: slope,amx,bmx,amn,bmn,cmn,dmn - -real :: d1, d2 - -if ((val(k)-val(k-1)) * (val(k)-val(k+1)) >= 0.0) then - slope = 0.0 ! ; curvature = 0.0 -else - d1 = 0.5*(e(k-1)-e(k+1)) ; d2 = 0.5*(e(k)-e(k+2)) - 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. - amx=max(val(k-1),val(k)) - bmx = max(amx,val(k+1)) - amn = min(abs(slope),2.0*(bmx-val(k))) - bmn = min(val(k-1),val(k)) - cmn = 2.0*(val(k)-min(bmn,val(k+1))) - dmn = min(amn,cmn) - slope = sign(1.0,slope) * dmn - -! 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 - -return + real, dimension(:), intent(in) :: val !< An column the values that are being interpolated. + real, dimension(:), intent(in) :: e !< A column's interface heights [Z ~> m] or other units. + integer, intent(in) :: k !< The layer whose slope is being determined. + real :: slope !< The normalized slope in the intracell distribution of val. + ! Local variables + real :: amn, cmn + real :: d1, d2 + + if ((val(k)-val(k-1)) * (val(k)-val(k+1)) >= 0.0) then + slope = 0.0 ! ; curvature = 0.0 + else + d1 = 0.5*(e(K-1)-e(K+1)) ; d2 = 0.5*(e(K)-e(K+2)) + if (d1*d2 > 0.0) then + 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. + amn = min(abs(slope), 2.0*(max(val(k-1), val(k), val(k+1)) - val(k))) + cmn = 2.0*(val(k) - min(val(k-1), val(k), val(k+1))) + slope = sign(1.0, slope) * min(amn, cmn) + + ! 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 + else + slope = 0.0 ! ; curvature = 0.0 + endif + endif end function find_limited_slope +!> Find interface positions corresponding to density profile +function find_interfaces(rho, zin, Rb, depth, nlevs, nkml, nkbl, hml, debug, eps_z) result(zi) + real, dimension(:,:,:), & + intent(in) :: rho !< potential density in z-space [kg m-3] + real, dimension(size(rho,3)), & + intent(in) :: zin !< Input data levels [Z ~> m or m]. + real, dimension(:), intent(in) :: Rb !< target interface densities [kg m-3] + real, dimension(size(rho,1),size(rho,2)), & + intent(in) :: depth !< ocean depth [Z ~> m]. + real, dimension(size(rho,1),size(rho,2)), & + optional, intent(in) :: nlevs !< number of valid points in each column + logical, optional, intent(in) :: debug !< optional debug flag + integer, optional, intent(in) :: nkml !< number of mixed layer pieces + integer, optional, intent(in) :: nkbl !< number of buffer layer pieces + real, optional, intent(in) :: hml !< mixed layer depth [Z ~> m]. + real, optional, intent(in) :: eps_z !< A negligibly small layer thickness [Z ~> m or m]. + real, dimension(size(rho,1),size(rho,2),size(Rb,1)) :: zi !< The returned interface, in the same units az zin. + + ! Local variables + real, dimension(size(rho,1),size(rho,3)) :: rho_ + real, dimension(size(rho,1)) :: depth_ + logical :: unstable + integer :: dir + integer, dimension(size(rho,1),size(Rb,1)) :: ki_ + real, dimension(size(rho,1),size(Rb,1)) :: zi_ + integer, dimension(size(rho,1),size(rho,2)) :: nlevs_data + integer, dimension(size(rho,1)) :: lo, hi + real :: slope,rsm,drhodz,hml_ + integer :: n,i,j,k,l,nx,ny,nz,nt + integer :: nlay,kk,nkml_,nkbl_ + logical :: debug_ = .false. + real :: epsln_Z ! A negligibly thin layer thickness [Z ~> m]. + real :: epsln_rho ! A negligibly small density change [kg m-3]. + real, parameter :: zoff=0.999 + + nlay=size(Rb)-1 + + zi(:,:,:) = 0.0 + + if (PRESENT(debug)) debug_=debug + + nx = size(rho,1); ny=size(rho,2); nz = size(rho,3) + nlevs_data(:,:) = size(rho,3) + + nkml_ = 0 ; if (PRESENT(nkml)) nkml_ = max(0, nkml) + nkbl_ = 0 ; if (PRESENT(nkbl)) nkbl_ = max(0, nkbl) + hml_ = 0.0 ; if (PRESENT(hml)) hml_ = hml + epsln_Z = 1.0e-10 ; if (PRESENT(eps_z)) epsln_Z = eps_z + epsln_rho = 1.0e-10 + + if (PRESENT(nlevs)) then + nlevs_data(:,:) = nlevs(:,:) + endif - -function find_interfaces(rho,zin,Rb,depth,nlevs,nkml,nkbl,hml,debug) result(zi) -! (in) rho : potential density in z-space (kg m-3) -! (in) zin : levels (m) -! (in) Rb : target interface densities (kg m-3) -! (in) depth: ocean depth (m) -! (in) nlevs: number of valid points in each column -! (in) nkml : number of mixed layer pieces -! (in) nkbl : number of buffer layer pieces -! (in) hml : mixed layer depth - -real, dimension(:,:,:), intent(in) :: rho -real, dimension(size(rho,3)), intent(in) :: zin -real, dimension(:), intent(in) :: Rb -real, dimension(size(rho,1),size(rho,2)), intent(in) :: depth -real, dimension(size(rho,1),size(rho,2)), optional, intent(in) ::nlevs -logical, optional, intent(in) :: debug -real, dimension(size(rho,1),size(rho,2),size(Rb,1)) :: zi -integer, intent(in), optional :: nkml, nkbl -real, intent(in), optional :: hml - -real, dimension(size(rho,1),size(rho,3)) :: rho_ -real, dimension(size(rho,1)) :: depth_ -logical :: unstable -integer :: dir -integer, dimension(size(rho,1),size(Rb,1)) :: ki_ -real, dimension(size(rho,1),size(Rb,1)) :: zi_ -integer, dimension(size(rho,1),size(rho,2)) :: nlevs_data -integer, dimension(size(rho,1)) :: lo,hi -real :: slope,rsm,drhodz,hml_ -integer :: n,i,j,k,l,nx,ny,nz,nt -integer :: nlay,kk,nkml_,nkbl_ -logical :: debug_ = .false. - -real, parameter :: zoff=0.999 - -nlay=size(Rb)-1 - -zi=0.0 - - -if (PRESENT(debug)) debug_=debug - -nx = size(rho,1); ny=size(rho,2); nz = size(rho,3) -nlevs_data(:,:) = size(rho,3) - -nkml_=0;nkbl_=0;hml_=0.0 -if (PRESENT(nkml)) nkml_=max(0,nkml) -if (PRESENT(nkbl)) nkbl_=max(0,nkbl) -if (PRESENT(hml)) hml_=hml - -if (PRESENT(nlevs)) then - nlevs_data(:,:) = nlevs(:,:) -endif - -do j=1,ny - rho_(:,:) = rho(:,j,:) - i_loop: do i=1,nx - if (debug_) then - print *,'looking for interfaces, i,j,nlevs= ',i,j,nlevs_data(i,j) - print *,'initial density profile= ', rho_(i,:) - endif - unstable=.true. - dir=1 - do while (unstable) - unstable=.false. - if (dir == 1) then - do k=2,nlevs_data(i,j)-1 - if (rho_(i,k) - rho_(i,k-1) < 0.0 ) then - if (k.eq.2) then - rho_(i,k-1)=rho_(i,k)-epsln - else - drhodz = (rho_(i,k+1)-rho_(i,k-1))/(zin(k+1)-zin(k-1)) - if (drhodz < 0.0) then - unstable=.true. + do j=1,ny + rho_(:,:) = rho(:,j,:) + i_loop: do i=1,nx + if (debug_) then + print *,'looking for interfaces, i,j,nlevs= ',i,j,nlevs_data(i,j) + print *,'initial density profile= ', rho_(i,:) + endif + unstable=.true. + dir=1 + do while (unstable) + unstable=.false. + if (dir == 1) then + do k=2,nlevs_data(i,j)-1 + if (rho_(i,k) - rho_(i,k-1) < 0.0 ) then + if (k == 2) then + rho_(i,k-1) = rho_(i,k)-epsln_rho + else + drhodz = (rho_(i,k+1)-rho_(i,k-1)) / (zin(k+1)-zin(k-1)) + if (drhodz < 0.0) unstable=.true. + rho_(i,k) = rho_(i,k-1) + drhodz*zoff*(zin(k)-zin(k-1)) endif - rho_(i,k) = rho_(i,k-1)+drhodz*zoff*(zin(k)-zin(k-1)) endif - endif - enddo - dir=-1*dir - else - do k=nlevs_data(i,j)-1,2,-1 - if (rho_(i,k+1) - rho_(i,k) < 0.0) then - if (k .eq. nlevs_data(i,j)-1) then - rho_(i,k+1)=rho_(i,k-1)+epsln - else - drhodz = (rho_(i,k+1)-rho_(i,k-1))/(zin(k+1)-zin(k-1)) - if (drhodz < 0.0) then - unstable=.true. + enddo + dir = -1*dir + else + do k=nlevs_data(i,j)-1,2,-1 + if (rho_(i,k+1) - rho_(i,k) < 0.0) then + if (k == nlevs_data(i,j)-1) then + rho_(i,k+1) = rho_(i,k-1)+epsln_rho + else + drhodz = (rho_(i,k+1)-rho_(i,k-1))/(zin(k+1)-zin(k-1)) + if (drhodz < 0.0) unstable=.true. + rho_(i,k) = rho_(i,k+1)-drhodz*(zin(k+1)-zin(k)) endif - rho_(i,k) = rho_(i,k+1)-drhodz*(zin(k+1)-zin(k)) endif - endif - enddo - dir=-1*dir - endif - enddo - if (debug_) then - print *,'final density profile= ', rho_(i,:) - endif - enddo i_loop - - ki_(:,:) = 0 - zi_(:,:) = 0.0 - depth_(:)=-1.0*depth(:,j) - lo(:)=1 - hi(:)=nlevs_data(:,j) - ki_ = bisect_fast(rho_,Rb,lo,hi) - ki_(:,:) = max(1,ki_(:,:)-1) - do i=1,nx - do l=2,nlay - slope = (zin(ki_(i,l)+1) - zin(ki_(i,l)))/max(rho_(i,ki_(i,l)+1) - rho_(i,ki_(i,l)),epsln) - zi_(i,l) = -1.0*(zin(ki_(i,l)) + slope*(Rb(l)-rho_(i,ki_(i,l)))) - zi_(i,l) = max(zi_(i,l),depth_(i)) - zi_(i,l) = min(zi_(i,l),-1.0*hml_) - enddo - zi_(i,nlay+1)=depth_(i) - do l=2,nkml_+1 - zi_(i,l)=max(((1.0-real(l))/real(nkml_))*hml_,depth_(i)) - enddo - do l=nlay,nkml_+2,-1 - if (zi_(i,l) < zi_(i,l+1)+epsln) then - zi_(i,l)=zi_(i,l+1)+epsln - endif - if (zi_(i,l)>-1.0*hml_) then - zi_(i,l)=max(-1.0*hml_,depth_(i)) + enddo + dir = -1*dir + endif + enddo + if (debug_) then + print *,'final density profile= ', rho_(i,:) endif + enddo i_loop + + ki_(:,:) = 0 + zi_(:,:) = 0.0 + depth_(:) = -1.0*depth(:,j) + lo(:) = 1 + hi(:) = nlevs_data(:,j) + ki_ = bisect_fast(rho_, Rb, lo, hi) + ki_(:,:) = max(1, ki_(:,:)-1) + do i=1,nx + do l=2,nlay + slope = (zin(ki_(i,l)+1) - zin(ki_(i,l))) / max(rho_(i,ki_(i,l)+1) - rho_(i,ki_(i,l)),epsln_rho) + zi_(i,l) = -1.0*(zin(ki_(i,l)) + slope*(Rb(l)-rho_(i,ki_(i,l)))) + zi_(i,l) = max(zi_(i,l), depth_(i)) + zi_(i,l) = min(zi_(i,l), -1.0*hml_) + enddo + zi_(i,nlay+1) = depth_(i) + do l=2,nkml_+1 + zi_(i,l) = max(hml_*((1.0-real(l))/real(nkml_)), depth_(i)) + enddo + do l=nlay,nkml_+2,-1 + if (zi_(i,l) < zi_(i,l+1) + epsln_Z) zi_(i,l) = zi_(i,l+1) + epsln_Z + if (zi_(i,l) > -1.0*hml_) zi_(i,l) = max(-1.0*hml_, depth_(i)) + enddo enddo + zi(:,j,:) = zi_(:,:) enddo - zi(:,j,:)=zi_(:,:) -enddo - -return - end function find_interfaces +!> Create a 2d-mesh of grid coordinates from 1-d arrays subroutine meshgrid(x,y,x_T,y_T) + real, dimension(:), intent(in) :: x !< input x coordinates + real, dimension(:), intent(in) :: y !< input y coordinates + real, dimension(size(x,1),size(y,1)), intent(inout) :: x_T !< output 2-d version + real, dimension(size(x,1),size(y,1)), intent(inout) :: y_T !< output 2-d version -! create a 2d-mesh of grid coordinates -! from 1-d arrays. - -real, dimension(:), intent(in) :: x,y -real, dimension(size(x,1),size(y,1)), intent(inout) :: x_T,y_T - -integer :: ni,nj,i,j + integer :: ni,nj,i,j -ni=size(x,1);nj=size(y,1) + ni=size(x,1);nj=size(y,1) -do j=1,nj - x_T(:,j)=x(:) -enddo + do j=1,nj + x_T(:,j)=x(:) + enddo -do i=1,ni - y_T(i,:)=y(:) -enddo + do i=1,ni + y_T(i,:)=y(:) + enddo -return + return end subroutine meshgrid +!> Solve del2 (zi) = 0 using successive iterations +!! with a 5 point stencil. Only points fill==1 are +!! modified. Except where bad==1, information propagates +!! isotropically in index space. The resulting solution +!! in each region is an approximation to del2(zi)=0 subject to +!! boundary conditions along the valid points curve bounding this region. subroutine smooth_heights(zi,fill,bad,sor,niter,cyclic_x, tripolar_n) -! -! Solve del2 (zi) = 0 using successive iterations -! with a 5 point stencil. Only points fill==1 are -! modified. Except where bad==1, information propagates -! isotropically in index space. The resulting solution -! in each region is an approximation to del2(zi)=0 subject to -! boundary conditions along the valid points curve bounding this region. - + real, dimension(:,:), intent(inout) :: zi !< interface positions [m] or arbitrary + integer, dimension(size(zi,1),size(zi,2)), intent(in) :: fill !< points to be smoothed + integer, dimension(size(zi,1),size(zi,2)), intent(in) :: bad !< ignore these points + real, intent(in) :: sor !< successive over-relaxation coefficient (typically 0.6) + integer, intent(in) :: niter !< maximum number of iterations + logical, intent(in) :: cyclic_x !< input grid cyclic condition in the zonal direction + logical, intent(in) :: tripolar_n !< tripolar Arctic fold flag -real, dimension(:,:), intent(inout) :: zi -integer, dimension(size(zi,1),size(zi,2)), intent(in) :: fill -integer, dimension(size(zi,1),size(zi,2)), intent(in) :: bad -real, intent(in) :: sor -integer, intent(in) :: niter -logical, intent(in) :: cyclic_x, tripolar_n + integer :: i,j,k,n + integer :: ni,nj -integer :: i,j,k,n -integer :: ni,nj + real, dimension(size(zi,1),size(zi,2)) :: res, m + integer, dimension(size(zi,1),size(zi,2),4) :: B + real, dimension(0:size(zi,1)+1,0:size(zi,2)+1) :: mp + integer, dimension(0:size(zi,1)+1,0:size(zi,2)+1) :: nm -real, dimension(size(zi,1),size(zi,2)) :: res, m -integer, dimension(size(zi,1),size(zi,2),4) :: B -real, dimension(0:size(zi,1)+1,0:size(zi,2)+1) :: mp -integer, dimension(0:size(zi,1)+1,0:size(zi,2)+1) :: nm + real :: Isum, bsum -real :: Isum, bsum + ni=size(zi,1); nj=size(zi,2) -ni=size(zi,1); nj=size(zi,2) + mp=fill_boundaries(zi,cyclic_x,tripolar_n) -mp=fill_boundaries(zi,cyclic_x,tripolar_n) + B(:,:,:)=0.0 + nm=fill_boundaries(bad,cyclic_x,tripolar_n) -B(:,:,:)=0.0 -nm=fill_boundaries(bad,cyclic_x,tripolar_n) - -do j=1,nj - do i=1,ni - if (fill(i,j) .eq. 1) then - B(i,j,1)=1-nm(i+1,j);B(i,j,2)=1-nm(i-1,j) - B(i,j,3)=1-nm(i,j+1);B(i,j,4)=1-nm(i,j-1) - endif - enddo -enddo - -do n=1,niter do j=1,nj do i=1,ni - if (fill(i,j) .eq. 1) then - bsum = real(B(i,j,1)+B(i,j,2)+B(i,j,3)+B(i,j,4)) - Isum = 1.0/bsum - res(i,j)=Isum*(B(i,j,1)*mp(i+1,j)+B(i,j,2)*mp(i-1,j)+& - B(i,j,3)*mp(i,j+1)+B(i,j,4)*mp(i,j-1)) - mp(i,j) + if (fill(i,j) == 1) then + B(i,j,1)=1-nm(i+1,j);B(i,j,2)=1-nm(i-1,j) + B(i,j,3)=1-nm(i,j+1);B(i,j,4)=1-nm(i,j-1) endif enddo enddo - res(:,:)=res(:,:)*sor - do j=1,nj - do i=1,ni - mp(i,j)=mp(i,j)+res(i,j) + do n=1,niter + do j=1,nj + do i=1,ni + if (fill(i,j) == 1) then + bsum = real(B(i,j,1)+B(i,j,2)+B(i,j,3)+B(i,j,4)) + Isum = 1.0/bsum + res(i,j)=Isum*(B(i,j,1)*mp(i+1,j)+B(i,j,2)*mp(i-1,j)+& + B(i,j,3)*mp(i,j+1)+B(i,j,4)*mp(i,j-1)) - mp(i,j) + endif + enddo enddo - enddo - - zi(:,:)=mp(1:ni,1:nj) - mp = fill_boundaries(zi,cyclic_x,tripolar_n) -end do + res(:,:)=res(:,:)*sor + do j=1,nj + do i=1,ni + mp(i,j)=mp(i,j)+res(i,j) + enddo + enddo + zi(:,:)=mp(1:ni,1:nj) + mp = fill_boundaries(zi,cyclic_x,tripolar_n) + enddo -return + return end subroutine smooth_heights +!> Fill grid edges function fill_boundaries_int(m,cyclic_x,tripolar_n) result(mp) -! -! fill grid edges -! -integer, dimension(:,:), intent(in) :: m -logical, intent(in) :: cyclic_x, tripolar_n -real, dimension(size(m,1),size(m,2)) :: m_real -real, dimension(0:size(m,1)+1,0:size(m,2)+1) :: mp_real -integer, dimension(0:size(m,1)+1,0:size(m,2)+1) :: mp + integer, dimension(:,:), intent(in) :: m !< input array + logical, intent(in) :: cyclic_x !< zonal cyclic condition + logical, intent(in) :: tripolar_n !< northern fold condition + integer, dimension(0:size(m,1)+1,0:size(m,2)+1) :: mp !< output filled array + ! Local variables + real, dimension(size(m,1),size(m,2)) :: m_real + real, dimension(0:size(m,1)+1,0:size(m,2)+1) :: mp_real -m_real = real(m) + m_real = real(m) -mp_real = fill_boundaries_real(m_real,cyclic_x,tripolar_n) + mp_real = fill_boundaries_real(m_real,cyclic_x,tripolar_n) -mp = int(mp_real) + mp = int(mp_real) -return + return end function fill_boundaries_int +!> fill grid edges function fill_boundaries_real(m,cyclic_x,tripolar_n) result(mp) -! -! fill grid edges -! -real, dimension(:,:), intent(in) :: m -logical, intent(in) :: cyclic_x, tripolar_n -real, dimension(0:size(m,1)+1,0:size(m,2)+1) :: mp + real, dimension(:,:), intent(in) :: m !< input array + logical, intent(in) :: cyclic_x !< zonal cyclic condition + logical, intent(in) :: tripolar_n !< northern fold condition + real, dimension(0:size(m,1)+1,0:size(m,2)+1) :: mp !< output filled array -integer :: ni,nj,i,j + integer :: ni,nj,i,j -ni=size(m,1); nj=size(m,2) + ni=size(m,1); nj=size(m,2) -mp(1:ni,1:nj)=m(:,:) + mp(1:ni,1:nj)=m(:,:) -if (cyclic_x) then - mp(0,1:nj)=m(ni,1:nj) - mp(ni+1,1:nj)=m(1,1:nj) -else - mp(0,1:nj)=m(1,1:nj) - mp(ni+1,1:nj)=m(ni,1:nj) -endif + if (cyclic_x) then + mp(0,1:nj)=m(ni,1:nj) + mp(ni+1,1:nj)=m(1,1:nj) + else + mp(0,1:nj)=m(1,1:nj) + mp(ni+1,1:nj)=m(ni,1:nj) + endif -mp(1:ni,0)=m(1:ni,1) -if (tripolar_n) then - do i=1,ni - mp(i,nj+1)=m(ni-i+1,nj) - enddo -else - mp(1:ni,nj+1)=m(1:ni,nj) -endif + mp(1:ni,0)=m(1:ni,1) + if (tripolar_n) then + do i=1,ni + mp(i,nj+1)=m(ni-i+1,nj) + enddo + else + mp(1:ni,nj+1)=m(1:ni,nj) + endif -return + return end function fill_boundaries_real - - -end module midas_vertmap +end module MIDAS_vertmap diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index d322e115c9..1a9bf92c57 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -1,569 +1,571 @@ +!> Interfaces for MOM6 ensembles and data assimilation. module MOM_oda_driver_mod -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! This is the top-level module for MOM6 ocean data assimilation. -! It can be used to gather an ensemble of ocean states -! before calling ensemble filter routines which calculate -! increments based on cross-ensemble co-variance. It can also -! be used to compare gridded model state variables to in-situ -! observations without applying DA incrementa. -! -! init_oda: Initialize the ODA module -! set_analysis_time : update time for performing next analysis -! set_prior: Store prior model state -! oda: call to filter -! get_posterior : returns posterior increments (or full state) for the current ensemble member -! -! Authors: Matthew.Harrison@noaa.gov -! Feiyu.Liu@noaa.gov and -! Tony.Rosati@noaa.gov -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - use fms_mod, only : open_namelist_file, close_file, check_nml_error - use fms_mod, only : error_mesg, FATAL - use mpp_mod, only : stdout, stdlog, mpp_error, npes=>mpp_npes,pe=>mpp_pe - use mpp_mod, only : set_current_pelist => mpp_set_current_pelist - use mpp_mod, only : set_root_pe => mpp_set_root_pe - use mpp_mod, only : mpp_sync_self, mpp_sum, get_pelist=>mpp_get_current_pelist, mpp_root_pe - use mpp_mod, only : set_stack_size=>mpp_set_stack_size, broadcast=>mpp_broadcast - use mpp_io_mod, only : io_set_stack_size=>mpp_io_set_stack_size - use mpp_io_mod, only : MPP_SINGLE,MPP_MULTI - use mpp_domains_mod, only : domain2d, mpp_global_field - use mpp_domains_mod, only : mpp_get_compute_domain, mpp_get_data_domain - use mpp_domains_mod, only : mpp_redistribute, mpp_broadcast_domain - use mpp_domains_mod, only : set_domains_stack_size=>mpp_domains_set_stack_size - use diag_manager_mod, only : register_diag_field, diag_axis_init, send_data - use ensemble_manager_mod, only : get_ensemble_id, get_ensemble_size - use ensemble_manager_mod, only : get_ensemble_pelist, get_ensemble_filter_pelist - use time_manager_mod, only : time_type, decrement_time, increment_time - use time_manager_mod, only : get_date, get_time, operator(>=),operator(/=),operator(==),operator(<) - use constants_mod, only : radius, epsln - ! ODA Modules - use ocean_da_types_mod, only : grid_type, ocean_profile_type, ocean_control_struct - use ocean_da_core_mod, only : ocean_da_core_init, get_profiles - !use eakf_oda_mod, only : ensemble_filter - use write_ocean_obs_mod, only : open_profile_file - use write_ocean_obs_mod, only : write_profile,close_profile_file - use kdtree, only : kd_root !# JEDI - ! MOM Modules - use MOM_io, only : slasher, MOM_read_data - use MOM_diag_mediator, only : diag_ctrl, set_axes_info - use MOM_error_handler, only : FATAL, WARNING, MOM_error, is_root_pe - use MOM_get_input, only : get_MOM_input, directories - use MOM_variables, only : thermo_var_ptrs - use MOM_grid, only : ocean_grid_type, MOM_grid_init - use MOM_grid_initialize, only : set_grid_metrics - use MOM_hor_index, only : hor_index_type, hor_index_init - use MOM_dyn_horgrid, only : dyn_horgrid_type, create_dyn_horgrid, destroy_dyn_horgrid - use MOM_transcribe_grid, only : copy_dyngrid_to_MOM_grid, copy_MOM_grid_to_dyngrid - use MOM_fixed_initialization, only : MOM_initialize_fixed, MOM_initialize_topography - use MOM_coord_initialization, only : MOM_initialize_coord - use MOM_verticalGrid, only : verticalGrid_type, verticalGridInit - use MOM_file_parser, only : read_param, get_param, param_file_type - use MOM_string_functions, only : lowercase - use MOM_ALE, only : ALE_CS, ALE_initThicknessToCoord, ALE_init, ALE_updateVerticalGridType - use MOM_domains, only : MOM_domains_init, MOM_domain_type, clone_MOM_domain - use MOM_remapping, only : remapping_CS, initialize_remapping, remapping_core_h - use MOM_regridding, only : regridding_CS, initialize_regridding - use MOM_regridding, only : regridding_main, set_regrid_params - - implicit none - private - - public :: init_oda, oda_end, set_prior_tracer, get_posterior_tracer - public :: set_analysis_time, oda, save_obs_diff, apply_oda_tracer_increments + +! This file is part of MOM6. see LICENSE.md for the license. +use fms_mod, only : open_namelist_file, close_file, check_nml_error +use fms_mod, only : error_mesg, FATAL +use mpp_mod, only : stdout, stdlog, mpp_error, npes=>mpp_npes,pe=>mpp_pe +use mpp_mod, only : set_current_pelist => mpp_set_current_pelist +use mpp_mod, only : set_root_pe => mpp_set_root_pe +use mpp_mod, only : mpp_sync_self, mpp_sum, get_pelist=>mpp_get_current_pelist, mpp_root_pe +use mpp_mod, only : set_stack_size=>mpp_set_stack_size, broadcast=>mpp_broadcast +use mpp_io_mod, only : io_set_stack_size=>mpp_io_set_stack_size +use mpp_io_mod, only : MPP_SINGLE,MPP_MULTI +use mpp_domains_mod, only : domain2d, mpp_global_field +use mpp_domains_mod, only : mpp_get_compute_domain, mpp_get_data_domain +use mpp_domains_mod, only : mpp_redistribute, mpp_broadcast_domain +use mpp_domains_mod, only : set_domains_stack_size=>mpp_domains_set_stack_size +use diag_manager_mod, only : register_diag_field, diag_axis_init, send_data +use ensemble_manager_mod, only : get_ensemble_id, get_ensemble_size +use ensemble_manager_mod, only : get_ensemble_pelist, get_ensemble_filter_pelist +use time_manager_mod, only : time_type, decrement_time, increment_time +use time_manager_mod, only : get_date, operator(>=),operator(/=),operator(==),operator(<) +use constants_mod, only : radius, epsln +! ODA Modules +use ocean_da_types_mod, only : grid_type, ocean_profile_type, ocean_control_struct +use ocean_da_core_mod, only : ocean_da_core_init, get_profiles +!use eakf_oda_mod, only : ensemble_filter +use write_ocean_obs_mod, only : open_profile_file +use write_ocean_obs_mod, only : write_profile,close_profile_file +use kdtree, only : kd_root !# JEDI +! MOM Modules +use MOM_io, only : slasher, MOM_read_data +use MOM_diag_mediator, only : diag_ctrl, set_axes_info +use MOM_error_handler, only : FATAL, WARNING, MOM_error, MOM_mesg, is_root_pe +use MOM_get_input, only : get_MOM_input, directories +use MOM_grid, only : ocean_grid_type, MOM_grid_init +use MOM_grid_initialize, only : set_grid_metrics +use MOM_hor_index, only : hor_index_type, hor_index_init +use MOM_dyn_horgrid, only : dyn_horgrid_type, create_dyn_horgrid, destroy_dyn_horgrid +use MOM_transcribe_grid, only : copy_dyngrid_to_MOM_grid, copy_MOM_grid_to_dyngrid +use MOM_fixed_initialization, only : MOM_initialize_fixed, MOM_initialize_topography +use MOM_coord_initialization, only : MOM_initialize_coord +use MOM_file_parser, only : read_param, get_param, param_file_type +use MOM_string_functions, only : lowercase +use MOM_ALE, only : ALE_CS, ALE_initThicknessToCoord, ALE_init, ALE_updateVerticalGridType +use MOM_domains, only : MOM_domains_init, MOM_domain_type, clone_MOM_domain +use MOM_remapping, only : remapping_CS, initialize_remapping, remapping_core_h +use MOM_regridding, only : regridding_CS, initialize_regridding +use MOM_regridding, only : regridding_main, set_regrid_params +use MOM_unit_scaling, only : unit_scale_type, unit_scaling_init +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type, verticalGridInit + +implicit none ; private + +public :: init_oda, oda_end, set_prior_tracer, get_posterior_tracer +public :: set_analysis_time, oda, save_obs_diff, apply_oda_tracer_increments #include - type, public :: ODA_CS; private - type(ocean_control_struct), pointer :: Ocean_prior=> NULL() !< ensemble ocean prior states in DA space - type(ocean_control_struct), pointer :: Ocean_posterior=> NULL() !< ensemble ocean posterior states - !! or increments to prior in DA space - integer :: nk !< number of vertical layers used for DA - type(ocean_grid_type), pointer :: Grid => NULL() !< MOM6 grid type and decomposition for the DA - type(pointer_mpp_domain), pointer, dimension(:) :: domains => NULL() !< Pointer to mpp_domain objects - !! for ensemble members - type(verticalGrid_type), pointer :: GV => NULL() !< vertical grid for DA - type(domain2d), pointer :: mpp_domain => NULL() !< Pointer to a mpp domain object for DA - type(grid_type), pointer :: oda_grid !< local tracer grid - real, pointer, dimension(:,:,:) :: h => NULL() ! NULL() !< pointer to thermodynamic variables - integer :: ni, nj !< global grid size - logical :: reentrant_x !< grid is reentrant in the x direction - logical :: reentrant_y !< grid is reentrant in the y direction - logical :: tripolar_N !< grid is folded at its north edge - logical :: symmetric !< Values at C-grid locations are symmetric - integer :: assim_method !< Method: NO_ASSIM,EAKF_ASSIM or OI_ASSIM - integer :: ensemble_size !< Size of the ensemble - integer :: ensemble_id = 0 !< id of the current ensemble member - integer, pointer, dimension(:,:) :: ensemble_pelist !< PE list for ensemble members - integer, pointer, dimension(:) :: filter_pelist !< PE list for ensemble members - integer :: assim_frequency !< analysis interval in hours - ! Profiles local to the analysis domain - type(ocean_profile_type), pointer :: Profiles => NULL() !< pointer to linked list of all available profiles - type(ocean_profile_type), pointer :: CProfiles => NULL()!< pointer to linked list of current profiles - type(kd_root), pointer :: kdroot - type(ALE_CS), pointer :: ALE_CS=>NULL() !< ALE control structure for DA - logical :: use_ALE_algorithm !< true is using ALE remapping - type(regridding_CS) :: regridCS !< ALE control structure for regridding - type(remapping_CS) :: remapCS !< ALE control structure for remapping - type(time_type) :: Time !< Current Analysis time - type(diag_ctrl) :: diag_cs ! NULL() - end type pointer_mpp_domain - - - integer, parameter :: NO_ASSIM = 0, OI_ASSIM=1, EAKF_ASSIM=2 +!> Control structure that contains a transpose of the ocean state across ensemble members. +type, public :: ODA_CS ; private + type(ocean_control_struct), pointer :: Ocean_prior=> NULL() !< ensemble ocean prior states in DA space + type(ocean_control_struct), pointer :: Ocean_posterior=> NULL() !< ensemble ocean posterior states + !! or increments to prior in DA space + integer :: nk !< number of vertical layers used for DA + type(ocean_grid_type), pointer :: Grid => NULL() !< MOM6 grid type and decomposition for the DA + type(ptr_mpp_domain), pointer, dimension(:) :: domains => NULL() !< Pointer to mpp_domain objects + !! for ensemble members + type(verticalGrid_type), pointer :: GV => NULL() !< vertical grid for DA + type(unit_scale_type), pointer :: & + US => NULL() !< structure containing various unit conversion factors for DA + + type(domain2d), pointer :: mpp_domain => NULL() !< Pointer to a mpp domain object for DA + type(grid_type), pointer :: oda_grid !< local tracer grid + real, pointer, dimension(:,:,:) :: h => NULL() ! m or kg m-2] for DA + type(thermo_var_ptrs), pointer :: tv => NULL() !< pointer to thermodynamic variables + integer :: ni !< global i-direction grid size + integer :: nj !< global j-direction grid size + logical :: reentrant_x !< grid is reentrant in the x direction + logical :: reentrant_y !< grid is reentrant in the y direction + logical :: tripolar_N !< grid is folded at its north edge + logical :: symmetric !< Values at C-grid locations are symmetric + integer :: assim_method !< Method: NO_ASSIM,EAKF_ASSIM or OI_ASSIM + integer :: ensemble_size !< Size of the ensemble + integer :: ensemble_id = 0 !< id of the current ensemble member + integer, pointer, dimension(:,:) :: ensemble_pelist !< PE list for ensemble members + integer, pointer, dimension(:) :: filter_pelist !< PE list for ensemble members + integer :: assim_frequency !< analysis interval in hours + ! Profiles local to the analysis domain + type(ocean_profile_type), pointer :: Profiles => NULL() !< pointer to linked list of all available profiles + type(ocean_profile_type), pointer :: CProfiles => NULL()!< pointer to linked list of current profiles + type(kd_root), pointer :: kdroot => NULL() !< A structure for storing nearest neighbors + type(ALE_CS), pointer :: ALE_CS=>NULL() !< ALE control structure for DA + logical :: use_ALE_algorithm !< true is using ALE remapping + type(regridding_CS) :: regridCS !< ALE control structure for regridding + type(remapping_CS) :: remapCS !< ALE control structure for remapping + type(time_type) :: Time !< Current Analysis time + type(diag_ctrl) :: diag_cs ! A structure with a pointer to a domain2d, to allow for the creation of arrays of pointers. +type :: ptr_mpp_domain + type(domain2d), pointer :: mpp_domain => NULL() !< pointer to an mpp domain2d +end type ptr_mpp_domain + +!>@{ DA parameters +integer, parameter :: NO_ASSIM = 0, OI_ASSIM=1, EAKF_ASSIM=2 +!!@} contains -!V initialize First_guess (prior) and Analysis grid +!> initialize First_guess (prior) and Analysis grid !! information for all ensemble members -!! - subroutine init_oda(Time, G, GV, CS) - - type(time_type), intent(in) :: Time !< The current model time. - type(ocean_grid_type), pointer :: G !< domain and grid information for ocean model - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - type(ODA_CS), pointer, intent(inout) :: CS - - ! Local variables - type(thermo_var_ptrs) :: tv_dummy - type(dyn_horgrid_type), pointer :: dG=> NULL() - type(hor_index_type), pointer :: HI=> NULL() - type(directories) :: dirs - - type(grid_type), pointer :: T_grid !< global tracer grid - real, dimension(:,:), allocatable :: global2D, global2D_old - real, dimension(:), allocatable :: lon1D, lat1D, glon1D, glat1D - type(param_file_type) :: PF - integer :: n, m, k, i, j, nk - integer :: is,ie,js,je,isd,ied,jsd,jed - integer :: stdout_unit - character(len=32) :: assim_method - integer :: npes_pm, ens_info(6), ni, nj - character(len=128) :: mesg - character(len=32) :: fldnam - character(len=30) :: coord_mode - character(len=200) :: inputdir, basin_file - logical :: reentrant_x, reentrant_y, tripolar_N, symmetric - - if (associated(CS)) call mpp_error(FATAL,'Calling oda_init with associated control structure') - allocate(CS) +subroutine init_oda(Time, G, GV, CS) + + type(time_type), intent(in) :: Time !< The current model time. + type(ocean_grid_type), pointer :: G !< domain and grid information for ocean model + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(ODA_CS), pointer, intent(inout) :: CS !< The DA control structure + +! Local variables + type(thermo_var_ptrs) :: tv_dummy + type(dyn_horgrid_type), pointer :: dG=> NULL() + type(hor_index_type), pointer :: HI=> NULL() + type(directories) :: dirs + + type(grid_type), pointer :: T_grid !< global tracer grid + real, dimension(:,:), allocatable :: global2D, global2D_old + real, dimension(:), allocatable :: lon1D, lat1D, glon1D, glat1D + type(param_file_type) :: PF + integer :: n, m, k, i, j, nk + integer :: is,ie,js,je,isd,ied,jsd,jed + integer :: stdout_unit + character(len=32) :: assim_method + integer :: npes_pm, ens_info(6), ni, nj + character(len=128) :: mesg + character(len=32) :: fldnam + character(len=30) :: coord_mode + character(len=200) :: inputdir, basin_file + logical :: reentrant_x, reentrant_y, tripolar_N, symmetric + + if (associated(CS)) call mpp_error(FATAL,'Calling oda_init with associated control structure') + allocate(CS) ! Use ens1 parameters , this could be changed at a later time ! if it were desirable to have alternate parameters, e.g. for the grid ! for the analysis - call get_MOM_input(PF,dirs,ensemble_num=0) - call get_param(PF, "MOM", "ASSIM_METHOD", assim_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") - call get_param(PF, "MOM", "USE_REGRIDDING", CS%use_ALE_algorithm , & - "If True, use the ALE algorithm (regridding/remapping).\n"//& - "If False, use the layered isopycnal algorithm.", default=.false. ) - call get_param(PF, "MOM", "REENTRANT_X", CS%reentrant_x, & - "If true, the domain is zonally reentrant.", default=.true.) - call get_param(PF, "MOM", "REENTRANT_Y", CS%reentrant_y, & - "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"//& - "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"//& - "x-direction in the physical domain.") - call get_param(PF,"MOM", "NJGLOBAL", CS%nj, & - "The total number of thickness grid points in the \n"//& - "y-direction in the physical domain.") - call get_param(PF, 'MOM', "INPUTDIR", inputdir) - inputdir = slasher(inputdir) - - select case(lowercase(trim(assim_method))) - case('eakf') - CS%assim_method = EAKF_ASSIM - case('oi') - CS%assim_method = OI_ASSIM - case('no_assim') - CS%assim_method = NO_ASSIM - case default - call mpp_error(FATAL,'Invalid assimilation method provided') - end select - - ens_info = get_ensemble_size() - CS%ensemble_size = ens_info(1) - npes_pm=ens_info(3) - CS%ensemble_id = get_ensemble_id() - !! Switch to global pelist - allocate(CS%ensemble_pelist(CS%ensemble_size,npes_pm)) - allocate(CS%filter_pelist(CS%ensemble_size*npes_pm)) - call get_ensemble_pelist(CS%ensemble_pelist,'ocean') - call get_ensemble_filter_pelist(CS%filter_pelist,'ocean') - - call set_current_pelist(CS%filter_pelist) - - allocate(CS%domains(CS%ensemble_size)) - CS%domains(CS%ensemble_id)%mpp_domain => G%Domain%mpp_domain - do n=1,CS%ensemble_size - if(.not. associated(CS%domains(n)%mpp_domain)) allocate(CS%domains(n)%mpp_domain) - call set_root_pe(CS%ensemble_pelist(n,1)) - call mpp_broadcast_domain(CS%domains(n)%mpp_domain) - enddo - call set_root_pe(CS%filter_pelist(1)) - allocate(CS%Grid) - ! params NIHALO_ODA, NJHALO_ODA set the DA halo size - call MOM_domains_init(CS%Grid%Domain,PF,param_suffix='_ODA') - allocate(HI) - call hor_index_init(CS%Grid%Domain, HI, PF, & - local_indexing=.false.) ! Use global indexing for DA - call verticalGridInit( PF, CS%GV ) - allocate(dG) - call create_dyn_horgrid(dG,HI) - call clone_MOM_domain(CS%Grid%Domain, dG%Domain,symmetric=.false.) - call set_grid_metrics(dG,PF) - call MOM_initialize_topography(dg%bathyT,dG%max_depth,dG,PF) - call MOM_initialize_coord(CS%GV, PF, .false., & - dirs%output_directory, tv_dummy, dG%max_depth) - call ALE_init(PF, CS%GV, dG%max_depth, CS%ALE_CS) - call MOM_grid_init(CS%Grid, PF, global_indexing=.true.) - call ALE_updateVerticalGridType(CS%ALE_CS,CS%GV) - call copy_dyngrid_to_MOM_grid(dG, CS%Grid) - CS%mpp_domain => CS%Grid%Domain%mpp_domain - CS%Grid%ke = CS%GV%ke - CS%nk = CS%GV%ke - ! initialize storage for prior and posterior - allocate(CS%Ocean_prior) - call init_ocean_ensemble(CS%Ocean_prior,CS%Grid,CS%GV,CS%ensemble_size) - allocate(CS%Ocean_posterior) - call init_ocean_ensemble(CS%Ocean_posterior,CS%Grid,CS%GV,CS%ensemble_size) - allocate(CS%tv) - - call get_param(PF, 'oda_driver', "REGRIDDING_COORDINATE_MODE", coord_mode, & - "Coordinate mode for vertical regridding.", & - default="ZSTAR", fail_if_missing=.false.) - call initialize_regridding(CS%regridCS, CS%GV, dG%max_depth,PF,'oda_driver',coord_mode,'','') - call initialize_remapping(CS%remapCS,'PLM') - call set_regrid_params(CS%regridCS, min_thickness=0.) - call mpp_get_data_domain(G%Domain%mpp_domain,isd,ied,jsd,jed) - if(.not. associated(CS%h)) then - allocate(CS%h(isd:ied,jsd:jed,CS%GV%ke)); CS%h(:,:,:)=0.0 -! assign thicknesses - call ALE_initThicknessToCoord(CS%ALE_CS,G,CS%GV,CS%h) - endif - allocate(CS%tv%T(isd:ied,jsd:jed,CS%GV%ke)); CS%tv%T(:,:,:)=0.0 - allocate(CS%tv%S(isd:ied,jsd:jed,CS%GV%ke)); CS%tv%S(:,:,:)=0.0 - - call set_axes_info(CS%Grid,CS%GV,PF,CS%diag_cs,set_vertical=.true.) - do n=1,CS%ensemble_size - write(fldnam,'(a,i2.2)') 'temp_prior_',n - CS%Ocean_prior%id_t(n)=register_diag_field('ODA',trim(fldnam),CS%diag_cs%axesTL%handles,Time,'ocean potential temperature','degC') - write(fldnam,'(a,i2.2)') 'salt_prior_',n - CS%Ocean_prior%id_s(n)=register_diag_field('ODA',trim(fldnam),CS%diag_cs%axesTL%handles,Time,'ocean salinity','psu') - write(fldnam,'(a,i2.2)') 'temp_posterior_',n - CS%Ocean_posterior%id_t(n)=register_diag_field('ODA',trim(fldnam),CS%diag_cs%axesTL%handles,Time,'ocean potential temperature','degC') - write(fldnam,'(a,i2.2)') 'salt_posterior_',n - CS%Ocean_posterior%id_s(n)=register_diag_field('ODA',trim(fldnam),CS%diag_cs%axesTL%handles,Time,'ocean salinity','psu') - enddo - - call mpp_get_data_domain(CS%mpp_domain,isd,ied,jsd,jed) - allocate(CS%oda_grid) - CS%oda_grid%x => CS%Grid%geolonT - CS%oda_grid%y => CS%Grid%geolatT - - call get_param(PF, 'oda_driver', "BASIN_FILE", basin_file, & - "A file in which to find the basin masks, in variable 'basin'.", & - default="basin.nc") - basin_file = trim(inputdir) // trim(basin_file) - allocate(CS%oda_grid%basin_mask(isd:ied,jsd:jed)) - CS%oda_grid%basin_mask(:,:) = 0.0 - call MOM_read_data(basin_file,'basin',CS%oda_grid%basin_mask,CS%Grid%domain, timelevel=1) + call get_MOM_input(PF,dirs,ensemble_num=0) + + call unit_scaling_init(PF, CS%US) + + call get_param(PF, "MOM", "ASSIM_METHOD", assim_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") + call get_param(PF, "MOM", "USE_REGRIDDING", CS%use_ALE_algorithm , & + "If True, use the ALE algorithm (regridding/remapping).\n"//& + "If False, use the layered isopycnal algorithm.", default=.false. ) + call get_param(PF, "MOM", "REENTRANT_X", CS%reentrant_x, & + "If true, the domain is zonally reentrant.", default=.true.) + call get_param(PF, "MOM", "REENTRANT_Y", CS%reentrant_y, & + "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"//& + "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"//& + "x-direction in the physical domain.") + call get_param(PF,"MOM", "NJGLOBAL", CS%nj, & + "The total number of thickness grid points in the \n"//& + "y-direction in the physical domain.") + call get_param(PF, 'MOM', "INPUTDIR", inputdir) + inputdir = slasher(inputdir) + + select case(lowercase(trim(assim_method))) + case('eakf') + CS%assim_method = EAKF_ASSIM + case('oi') + CS%assim_method = OI_ASSIM + case('no_assim') + CS%assim_method = NO_ASSIM + case default + call mpp_error(FATAL,'Invalid assimilation method provided') + end select + + ens_info = get_ensemble_size() + CS%ensemble_size = ens_info(1) + npes_pm=ens_info(3) + CS%ensemble_id = get_ensemble_id() + !! Switch to global pelist + allocate(CS%ensemble_pelist(CS%ensemble_size,npes_pm)) + allocate(CS%filter_pelist(CS%ensemble_size*npes_pm)) + call get_ensemble_pelist(CS%ensemble_pelist,'ocean') + call get_ensemble_filter_pelist(CS%filter_pelist,'ocean') + + call set_current_pelist(CS%filter_pelist) + + allocate(CS%domains(CS%ensemble_size)) + CS%domains(CS%ensemble_id)%mpp_domain => G%Domain%mpp_domain + do n=1,CS%ensemble_size + if (.not. associated(CS%domains(n)%mpp_domain)) allocate(CS%domains(n)%mpp_domain) + call set_root_pe(CS%ensemble_pelist(n,1)) + call mpp_broadcast_domain(CS%domains(n)%mpp_domain) + enddo + call set_root_pe(CS%filter_pelist(1)) + allocate(CS%Grid) + ! params NIHALO_ODA, NJHALO_ODA set the DA halo size + call MOM_domains_init(CS%Grid%Domain,PF,param_suffix='_ODA') + allocate(HI) + call hor_index_init(CS%Grid%Domain, HI, PF, & + local_indexing=.false.) ! Use global indexing for DA + call verticalGridInit( PF, CS%GV, CS%US ) + allocate(dG) + call create_dyn_horgrid(dG, HI) + call clone_MOM_domain(CS%Grid%Domain, dG%Domain,symmetric=.false.) + call set_grid_metrics(dG,PF) + call MOM_initialize_topography(dg%bathyT,dG%max_depth,dG,PF) + call MOM_initialize_coord(CS%GV, CS%US, PF, .false., & + dirs%output_directory, tv_dummy, dG%max_depth) + call ALE_init(PF, CS%GV, CS%US, dG%max_depth, CS%ALE_CS) + call MOM_grid_init(CS%Grid, PF, global_indexing=.true.) + call ALE_updateVerticalGridType(CS%ALE_CS,CS%GV) + call copy_dyngrid_to_MOM_grid(dG, CS%Grid) + CS%mpp_domain => CS%Grid%Domain%mpp_domain + CS%Grid%ke = CS%GV%ke + CS%nk = CS%GV%ke + ! initialize storage for prior and posterior + allocate(CS%Ocean_prior) + call init_ocean_ensemble(CS%Ocean_prior,CS%Grid,CS%GV,CS%ensemble_size) + allocate(CS%Ocean_posterior) + call init_ocean_ensemble(CS%Ocean_posterior,CS%Grid,CS%GV,CS%ensemble_size) + allocate(CS%tv) + + call get_param(PF, 'oda_driver', "REGRIDDING_COORDINATE_MODE", coord_mode, & + "Coordinate mode for vertical regridding.", & + default="ZSTAR", fail_if_missing=.false.) + call initialize_regridding(CS%regridCS, CS%GV, CS%US, dG%max_depth,PF,'oda_driver',coord_mode,'','') + call initialize_remapping(CS%remapCS,'PLM') + call set_regrid_params(CS%regridCS, min_thickness=0.) + call mpp_get_data_domain(G%Domain%mpp_domain,isd,ied,jsd,jed) + if (.not. associated(CS%h)) then + allocate(CS%h(isd:ied,jsd:jed,CS%GV%ke)); CS%h(:,:,:)=0.0 + ! assign thicknesses + call ALE_initThicknessToCoord(CS%ALE_CS,G,CS%GV,CS%h) + endif + allocate(CS%tv%T(isd:ied,jsd:jed,CS%GV%ke)); CS%tv%T(:,:,:)=0.0 + allocate(CS%tv%S(isd:ied,jsd:jed,CS%GV%ke)); CS%tv%S(:,:,:)=0.0 + + call set_axes_info(CS%Grid, CS%GV, CS%US, PF, CS%diag_cs, set_vertical=.true.) + do n=1,CS%ensemble_size + write(fldnam,'(a,i2.2)') 'temp_prior_',n + CS%Ocean_prior%id_t(n)=register_diag_field('ODA',trim(fldnam),CS%diag_cs%axesTL%handles,Time, & + 'ocean potential temperature','degC') + write(fldnam,'(a,i2.2)') 'salt_prior_',n + CS%Ocean_prior%id_s(n)=register_diag_field('ODA',trim(fldnam),CS%diag_cs%axesTL%handles,Time, & + 'ocean salinity','psu') + write(fldnam,'(a,i2.2)') 'temp_posterior_',n + CS%Ocean_posterior%id_t(n)=register_diag_field('ODA',trim(fldnam),CS%diag_cs%axesTL%handles,Time, & + 'ocean potential temperature','degC') + write(fldnam,'(a,i2.2)') 'salt_posterior_',n + CS%Ocean_posterior%id_s(n)=register_diag_field('ODA',trim(fldnam),CS%diag_cs%axesTL%handles,Time, & + 'ocean salinity','psu') + enddo + + call mpp_get_data_domain(CS%mpp_domain,isd,ied,jsd,jed) + allocate(CS%oda_grid) + CS%oda_grid%x => CS%Grid%geolonT + CS%oda_grid%y => CS%Grid%geolatT + + call get_param(PF, 'oda_driver', "BASIN_FILE", basin_file, & + "A file in which to find the basin masks, in variable 'basin'.", & + default="basin.nc") + basin_file = trim(inputdir) // trim(basin_file) + allocate(CS%oda_grid%basin_mask(isd:ied,jsd:jed)) + CS%oda_grid%basin_mask(:,:) = 0.0 + call MOM_read_data(basin_file,'basin',CS%oda_grid%basin_mask,CS%Grid%domain, timelevel=1) ! get global grid information from ocean_model - allocate(T_grid) - allocate(T_grid%x(CS%ni,CS%nj)) - allocate(T_grid%y(CS%ni,CS%nj)) - allocate(T_grid%basin_mask(CS%ni,CS%nj)) - call mpp_global_field(CS%mpp_domain, CS%Grid%geolonT, T_grid%x) - call mpp_global_field(CS%mpp_domain, CS%Grid%geolatT, T_grid%y) - call mpp_global_field(CS%mpp_domain, CS%oda_grid%basin_mask, T_grid%basin_mask) - T_grid%ni = CS%ni - T_grid%nj = CS%nj - T_grid%nk = CS%nk - allocate(T_grid%mask(CS%ni,CS%nj,CS%nk)) - allocate(T_grid%z(CS%ni,CS%nj,CS%nk)) - allocate(global2D(CS%ni,CS%nj)) - allocate(global2D_old(CS%ni,CS%nj)) - T_grid%mask(:,:,:) = 0.0 - T_grid%z(:,:,:) = 0.0 - - do k = 1, CS%nk - call mpp_global_field(G%Domain%mpp_domain, CS%h(:,:,k), global2D) - do i=1, CS%ni; do j=1, CS%nj - if ( global2D(i,j) > 1 ) then - T_grid%mask(i,j,k) = 1.0 - end if - end do; end do - if (k .eq. 1) then - T_grid%z(:,:,k) = global2D/2 - else - T_grid%z(:,:,k) = T_grid%z(:,:,k-1) + (global2D + global2D_old)/2 - end if - global2D_old = global2D - end do - - call ocean_da_core_init(CS%mpp_domain, T_grid, CS%Profiles, Time) - - CS%Time=Time - !! switch back to ensemble member pelist - call set_current_pelist(CS%ensemble_pelist(CS%ensemble_id,:)) - end subroutine init_oda - - subroutine set_prior_tracer(Time, G, GV, h, tv, CS) - type(time_type), intent(in) :: Time !< The current model time - type(ocean_grid_type), pointer :: G !< domain and grid information for ocean model - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables - - type(ODA_CS), pointer :: CS !< ocean DA control structure - real, dimension(:,:,:), allocatable :: T, S - type(ocean_grid_type), pointer :: Grid=>NULL() - integer :: i,j, m, n, ss - integer :: is, ie, js, je - integer :: isc, iec, jsc, jec - integer :: isd, ied, jsd, jed - integer :: id - logical :: used - - ! return if not time for analysis - if (Time < CS%Time) return - - if (.not. associated(CS%Grid)) call MOM_ERROR(FATAL,'ODA_CS ensemble horizontal grid not associated') - if (.not. associated(CS%GV)) call MOM_ERROR(FATAL,'ODA_CS ensemble vertical grid not associated') - - !! switch to global pelist - call set_current_pelist(CS%filter_pelist) - if(is_root_pe()) print *, 'Setting prior' - - isc=CS%Grid%isc;iec=CS%Grid%iec;jsc=CS%Grid%jsc;jec=CS%Grid%jec - call mpp_get_compute_domain(CS%domains(CS%ensemble_id)%mpp_domain,is,ie,js,je) - call mpp_get_data_domain(CS%domains(CS%ensemble_id)%mpp_domain,isd,ied,jsd,jed) - allocate(T(isd:ied,jsd:jed,CS%nk)) - allocate(S(isd:ied,jsd:jed,CS%nk)) - - do j=js,je; do i=is,ie - call remapping_core_h(CS%remapCS, GV%ke, h(i,j,:), tv%T(i,j,:), & - CS%nk, CS%h(i,j,:), T(i,j,:)) - call remapping_core_h(CS%remapCS, GV%ke, h(i,j,:), tv%S(i,j,:), & - CS%nk, CS%h(i,j,:), S(i,j,:)) - enddo; enddo - - do m=1,CS%ensemble_size - call mpp_redistribute(CS%domains(m)%mpp_domain, T,& - CS%mpp_domain, CS%Ocean_prior%T(:,:,:,m), complete=.true.) - call mpp_redistribute(CS%domains(m)%mpp_domain, S,& - CS%mpp_domain, CS%Ocean_prior%S(:,:,:,m), complete=.true.) - if (CS%Ocean_prior%id_t(m)>0) used=send_data(CS%Ocean_prior%id_t(m), CS%Ocean_prior%T(isc:iec,jsc:jec,:,m), CS%Time) - if (CS%Ocean_prior%id_s(m)>0) used=send_data(CS%Ocean_prior%id_s(m), CS%Ocean_prior%S(isc:iec,jsc:jec,:,m), CS%Time) - enddo - deallocate(T,S) - - !! switch back to ensemble member pelist - call set_current_pelist(CS%ensemble_pelist(CS%ensemble_id,:)) - - return - - end subroutine set_prior_tracer - - !> Returns posterior adjustments or full state - !!Note that only those PEs associated with an ensemble member receive data - subroutine get_posterior_tracer(Time, CS, G, GV, h, tv, increment) - type(time_type), intent(in) :: Time !< the current model time - type(ODA_CS), pointer :: CS !< ocean DA control structure - type(ocean_grid_type), pointer :: G !< domain and grid information for ocean model - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(:,:,:), pointer :: h !< Layer thicknesses, in H (usually m or kg m-2) - type(thermo_var_ptrs), pointer :: tv !< A structure pointing to various thermodynamic variables - - logical, optional, intent(in) :: increment - - type(ocean_grid_type), pointer :: Grid=>NULL() - type(ocean_control_struct), pointer :: Ocean_increment=>NULL() - integer :: is, ie, js, je - integer :: isd, ied, jsd, jed - integer :: isc, iec, jsc, jec - integer :: i, j, m - logical :: used, get_inc - - ! return if not analysis time (retain pointers for h and tv) - if (Time < CS%Time) return - - - !! switch to global pelist - call set_current_pelist(CS%filter_pelist) - if(is_root_pe()) print *, 'Getting posterior' - - get_inc = .true. - if(present(increment)) get_inc = increment - - if(get_inc) then - allocate(Ocean_increment) - call init_ocean_ensemble(Ocean_increment,CS%Grid,CS%GV,CS%ensemble_size) - Ocean_increment%T = CS%Ocean_posterior%T - CS%Ocean_prior%T - Ocean_increment%S = CS%Ocean_posterior%S - CS%Ocean_prior%S - endif - isc=CS%Grid%isc;iec=CS%Grid%iec;jsc=CS%Grid%jsc;jec=CS%Grid%jec - do m=1,CS%ensemble_size - if(get_inc) then - call mpp_redistribute(CS%mpp_domain, Ocean_increment%T(:,:,:,m), & - CS%domains(m)%mpp_domain, CS%tv%T, complete=.true.) - call mpp_redistribute(CS%mpp_domain, Ocean_increment%S(:,:,:,m), & - CS%domains(m)%mpp_domain, CS%tv%S, complete=.true.) - else - call mpp_redistribute(CS%mpp_domain, CS%Ocean_posterior%T(:,:,:,m), & - CS%domains(m)%mpp_domain, CS%tv%T, complete=.true.) - call mpp_redistribute(CS%mpp_domain, CS%Ocean_posterior%S(:,:,:,m), & - CS%domains(m)%mpp_domain, CS%tv%S, complete=.true.) - endif - - if (CS%Ocean_posterior%id_t(m)>0) then - if(get_inc) then - used=send_data(CS%Ocean_posterior%id_t(m), Ocean_increment%T(isc:iec,jsc:jec,:,m), CS%Time) - else - used=send_data(CS%Ocean_posterior%id_t(m), CS%Ocean_posterior%T(isc:iec,jsc:jec,:,m), CS%Time) - endif - endif - if (CS%Ocean_posterior%id_s(m)>0) then - if(get_inc) then - used=send_data(CS%Ocean_posterior%id_s(m), Ocean_increment%S(isc:iec,jsc:jec,:,m), CS%Time) - else - used=send_data(CS%Ocean_posterior%id_s(m), CS%Ocean_posterior%S(isc:iec,jsc:jec,:,m), CS%Time) - endif - endif - end do - - tv => CS%tv - h => CS%h - !! switch back to ensemble member pelist - call set_current_pelist(CS%ensemble_pelist(CS%ensemble_id,:)) - - end subroutine get_posterior_tracer - - subroutine oda(Time, CS) - type(time_type), intent(in) :: Time - type(oda_CS), intent(inout) :: CS - - integer :: i, j - integer :: m - integer :: yr, mon, day, hr, min, sec - - if ( Time >= CS%Time ) then - - !! switch to global pelist - call set_current_pelist(CS%filter_pelist) - - call get_profiles(Time, CS%Profiles, CS%CProfiles) -#ifdef ENABLE_ECDA - call ensemble_filter(CS%Ocean_prior, CS%Ocean_posterior, CS%CProfiles, CS%kdroot, CS%mpp_domain, CS%oda_grid) -#endif - - !! switch back to ensemble member pelist - call set_current_pelist(CS%ensemble_pelist(CS%ensemble_id,:)) - - end if - - return - end subroutine oda - - subroutine oda_end(CS) - type(ODA_CS), intent(inout) :: CS - - end subroutine oda_end - - subroutine init_ocean_ensemble(CS,Grid,GV,ens_size) - type(ocean_control_struct), pointer :: CS !< Pointer to ODA control structure - type(ocean_grid_type), pointer :: Grid !< Pointer to ocean analysis grid - type(verticalGrid_type), pointer :: GV !< Pointer to DA vertical grid - integer, intent(in) :: ens_size !< ensemble size - - integer :: n,is,ie,js,je,nk - - nk=GV%ke - is=Grid%isd;ie=Grid%ied - js=Grid%jsd;je=Grid%jed - CS%ensemble_size=ens_size - allocate(CS%T(is:ie,js:je,nk,ens_size)) - allocate(CS%S(is:ie,js:je,nk,ens_size)) - allocate(CS%SSH(is:ie,js:je,ens_size)) - allocate(CS%id_t(ens_size));CS%id_t(:)=-1 - allocate(CS%id_s(ens_size));CS%id_s(:)=-1 -! allocate(CS%U(is:ie,js:je,nk,ens_size)) -! allocate(CS%V(is:ie,js:je,nk,ens_size)) -! allocate(CS%id_u(ens_size));CS%id_u(:)=-1 -! allocate(CS%id_v(ens_size));CS%id_v(:)=-1 - allocate(CS%id_ssh(ens_size));CS%id_ssh(:)=-1 - - return - end subroutine init_ocean_ensemble - - subroutine set_analysis_time(Time,CS) - type(time_type), intent(in) :: Time - type(ODA_CS), pointer, intent(inout) :: CS - - integer :: yr, mon, day, hr, min, sec - - if (Time >= CS%Time) then - CS%Time=increment_time(CS%Time,CS%assim_frequency*3600) - - call get_date(Time, yr, mon, day, hr, min, sec) - if(pe() .eq. mpp_root_pe()) print *, 'Model Time: ', yr, mon, day, hr, min, sec - call get_date(CS%time, yr, mon, day, hr, min, sec) - if(pe() .eq. mpp_root_pe()) print *, 'Assimilation Time: ', yr, mon, day, hr, min, sec + allocate(T_grid) + allocate(T_grid%x(CS%ni,CS%nj)) + allocate(T_grid%y(CS%ni,CS%nj)) + allocate(T_grid%basin_mask(CS%ni,CS%nj)) + call mpp_global_field(CS%mpp_domain, CS%Grid%geolonT, T_grid%x) + call mpp_global_field(CS%mpp_domain, CS%Grid%geolatT, T_grid%y) + call mpp_global_field(CS%mpp_domain, CS%oda_grid%basin_mask, T_grid%basin_mask) + T_grid%ni = CS%ni + T_grid%nj = CS%nj + T_grid%nk = CS%nk + allocate(T_grid%mask(CS%ni,CS%nj,CS%nk)) + allocate(T_grid%z(CS%ni,CS%nj,CS%nk)) + allocate(global2D(CS%ni,CS%nj)) + allocate(global2D_old(CS%ni,CS%nj)) + T_grid%mask(:,:,:) = 0.0 + T_grid%z(:,:,:) = 0.0 + + do k = 1, CS%nk + call mpp_global_field(G%Domain%mpp_domain, CS%h(:,:,k), global2D) + do i=1, CS%ni; do j=1, CS%nj + if ( global2D(i,j) > 1 ) then + T_grid%mask(i,j,k) = 1.0 + endif + enddo ; enddo + if (k == 1) then + T_grid%z(:,:,k) = global2D/2 + else + T_grid%z(:,:,k) = T_grid%z(:,:,k-1) + (global2D + global2D_old)/2 endif - if (CS%Time < Time) then - call MOM_error(FATAL, " set_analysis_time: " // & - "assimilation interval appears to be shorter than " // & - "the model timestep") + global2D_old = global2D + enddo + + call ocean_da_core_init(CS%mpp_domain, T_grid, CS%Profiles, Time) + + CS%Time=Time + !! switch back to ensemble member pelist + call set_current_pelist(CS%ensemble_pelist(CS%ensemble_id,:)) +end subroutine init_oda + +!> Copy ensemble member tracers to ensemble vector. +subroutine set_prior_tracer(Time, G, GV, h, tv, CS) + type(time_type), intent(in) :: Time !< The current model time + type(ocean_grid_type), pointer :: G !< domain and grid information for ocean model + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + + type(ODA_CS), pointer :: CS !< ocean DA control structure + real, dimension(:,:,:), allocatable :: T, S + type(ocean_grid_type), pointer :: Grid=>NULL() + integer :: i,j, m, n, ss + integer :: is, ie, js, je + integer :: isc, iec, jsc, jec + integer :: isd, ied, jsd, jed + integer :: id + logical :: used + + ! return if not time for analysis + if (Time < CS%Time) return + + if (.not. associated(CS%Grid)) call MOM_ERROR(FATAL,'ODA_CS ensemble horizontal grid not associated') + if (.not. associated(CS%GV)) call MOM_ERROR(FATAL,'ODA_CS ensemble vertical grid not associated') + + !! switch to global pelist + call set_current_pelist(CS%filter_pelist) + call MOM_mesg('Setting prior') + + isc=CS%Grid%isc;iec=CS%Grid%iec;jsc=CS%Grid%jsc;jec=CS%Grid%jec + call mpp_get_compute_domain(CS%domains(CS%ensemble_id)%mpp_domain,is,ie,js,je) + call mpp_get_data_domain(CS%domains(CS%ensemble_id)%mpp_domain,isd,ied,jsd,jed) + allocate(T(isd:ied,jsd:jed,CS%nk)) + allocate(S(isd:ied,jsd:jed,CS%nk)) + + do j=js,je; do i=is,ie + call remapping_core_h(CS%remapCS, GV%ke, h(i,j,:), tv%T(i,j,:), & + CS%nk, CS%h(i,j,:), T(i,j,:)) + call remapping_core_h(CS%remapCS, GV%ke, h(i,j,:), tv%S(i,j,:), & + CS%nk, CS%h(i,j,:), S(i,j,:)) + enddo ; enddo + + do m=1,CS%ensemble_size + call mpp_redistribute(CS%domains(m)%mpp_domain, T,& + CS%mpp_domain, CS%Ocean_prior%T(:,:,:,m), complete=.true.) + call mpp_redistribute(CS%domains(m)%mpp_domain, S,& + CS%mpp_domain, CS%Ocean_prior%S(:,:,:,m), complete=.true.) + if (CS%Ocean_prior%id_t(m)>0) & + used=send_data(CS%Ocean_prior%id_t(m), CS%Ocean_prior%T(isc:iec,jsc:jec,:,m), CS%Time) + if (CS%Ocean_prior%id_s(m)>0) & + used=send_data(CS%Ocean_prior%id_s(m), CS%Ocean_prior%S(isc:iec,jsc:jec,:,m), CS%Time) + enddo + deallocate(T,S) + + !! switch back to ensemble member pelist + call set_current_pelist(CS%ensemble_pelist(CS%ensemble_id,:)) + + return + +end subroutine set_prior_tracer + +!> Returns posterior adjustments or full state +!!Note that only those PEs associated with an ensemble member receive data +subroutine get_posterior_tracer(Time, CS, h, tv, increment) + type(time_type), intent(in) :: Time !< the current model time + type(ODA_CS), pointer :: CS !< ocean DA control structure + real, dimension(:,:,:), pointer :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), pointer :: tv !< A structure pointing to various thermodynamic variables + logical, optional, intent(in) :: increment !< True if returning increment only + + type(ocean_control_struct), pointer :: Ocean_increment=>NULL() + integer :: i, j, m + logical :: used, get_inc + + ! return if not analysis time (retain pointers for h and tv) + if (Time < CS%Time) return + + + !! switch to global pelist + call set_current_pelist(CS%filter_pelist) + call MOM_mesg('Getting posterior') + + get_inc = .true. + if (present(increment)) get_inc = increment + + if (get_inc) then + allocate(Ocean_increment) + call init_ocean_ensemble(Ocean_increment,CS%Grid,CS%GV,CS%ensemble_size) + Ocean_increment%T = CS%Ocean_posterior%T - CS%Ocean_prior%T + Ocean_increment%S = CS%Ocean_posterior%S - CS%Ocean_prior%S + endif + do m=1,CS%ensemble_size + if (get_inc) then + call mpp_redistribute(CS%mpp_domain, Ocean_increment%T(:,:,:,m), & + CS%domains(m)%mpp_domain, CS%tv%T, complete=.true.) + call mpp_redistribute(CS%mpp_domain, Ocean_increment%S(:,:,:,m), & + CS%domains(m)%mpp_domain, CS%tv%S, complete=.true.) + else + call mpp_redistribute(CS%mpp_domain, CS%Ocean_posterior%T(:,:,:,m), & + CS%domains(m)%mpp_domain, CS%tv%T, complete=.true.) + call mpp_redistribute(CS%mpp_domain, CS%Ocean_posterior%S(:,:,:,m), & + CS%domains(m)%mpp_domain, CS%tv%S, complete=.true.) endif - return + enddo + + tv => CS%tv + h => CS%h + !! switch back to ensemble member pelist + call set_current_pelist(CS%ensemble_pelist(CS%ensemble_id,:)) - end subroutine set_analysis_time +end subroutine get_posterior_tracer - subroutine save_obs_diff(filename,CS) - character(len=*), intent(in) :: filename - type(ODA_CS), pointer, intent(in) :: CS +!> Gather observations and sall ODA routines +subroutine oda(Time, CS) + type(time_type), intent(in) :: Time !< the current model time + type(oda_CS), intent(inout) :: CS !< the ocean DA control structure - integer :: fid ! profile file handle - type(ocean_profile_type), pointer :: Prof=>NULL() + integer :: i, j + integer :: m + integer :: yr, mon, day, hr, min, sec - fid = open_profile_file(trim(filename), nvar=2, thread=MPP_SINGLE, fset=MPP_SINGLE) - Prof=>CS%CProfiles + if ( Time >= CS%Time ) then !! switch to global pelist - !call set_current_pelist(CS%filter_pelist) + call set_current_pelist(CS%filter_pelist) - do while (associated(Prof)) - call write_profile(fid,Prof) - Prof=>Prof%cnext - enddo - call close_profile_file(fid) + call get_profiles(Time, CS%Profiles, CS%CProfiles) +#ifdef ENABLE_ECDA + call ensemble_filter(CS%Ocean_prior, CS%Ocean_posterior, CS%CProfiles, CS%kdroot, CS%mpp_domain, CS%oda_grid) +#endif !! switch back to ensemble member pelist - !call set_current_pelist(CS%ensemble_pelist(CS%ensemble_id,:)) - - return - end subroutine save_obs_diff + call set_current_pelist(CS%ensemble_pelist(CS%ensemble_id,:)) - subroutine apply_oda_tracer_increments(dt,G,tv,h,CS) - real, intent(in) :: dt ! the tracer timestep (seconds) - type(ocean_grid_type), intent(in) :: G !< ocean grid structure - type(thermo_var_ptrs), intent(inout) :: tv !< A structure pointing to various thermodynamic variables - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< layer thickness (m or kg/m2) - type(ODA_CS), intent(inout) :: CS !< the data assimilation structure + endif + + return +end subroutine oda + +!> Finalize DA module +subroutine oda_end(CS) + type(ODA_CS), intent(inout) :: CS !< the ocean DA control structure + +end subroutine oda_end + +!> Initialize DA module +subroutine init_ocean_ensemble(CS,Grid,GV,ens_size) + type(ocean_control_struct), pointer :: CS !< Pointer to ODA control structure + type(ocean_grid_type), pointer :: Grid !< Pointer to ocean analysis grid + type(verticalGrid_type), pointer :: GV !< Pointer to DA vertical grid + integer, intent(in) :: ens_size !< ensemble size + + integer :: n,is,ie,js,je,nk + + nk=GV%ke + is=Grid%isd;ie=Grid%ied + js=Grid%jsd;je=Grid%jed + CS%ensemble_size=ens_size + allocate(CS%T(is:ie,js:je,nk,ens_size)) + allocate(CS%S(is:ie,js:je,nk,ens_size)) + allocate(CS%SSH(is:ie,js:je,ens_size)) + allocate(CS%id_t(ens_size));CS%id_t(:)=-1 + allocate(CS%id_s(ens_size));CS%id_s(:)=-1 +! allocate(CS%U(is:ie,js:je,nk,ens_size)) +! allocate(CS%V(is:ie,js:je,nk,ens_size)) +! allocate(CS%id_u(ens_size));CS%id_u(:)=-1 +! allocate(CS%id_v(ens_size));CS%id_v(:)=-1 + allocate(CS%id_ssh(ens_size));CS%id_ssh(:)=-1 + + return +end subroutine init_ocean_ensemble + +!> Set the next analysis time +subroutine set_analysis_time(Time,CS) + type(time_type), intent(in) :: Time !< the current model time + type(ODA_CS), pointer, intent(inout) :: CS !< the DA control structure + + character(len=160) :: mesg ! The text of an error message + integer :: yr, mon, day, hr, min, sec + + if (Time >= CS%Time) then + CS%Time=increment_time(CS%Time,CS%assim_frequency*3600) + + call get_date(Time, yr, mon, day, hr, min, sec) + write(mesg,*) 'Model Time: ', yr, mon, day, hr, min, sec + call MOM_mesg("set_analysis_time: "//trim(mesg)) + call get_date(CS%time, yr, mon, day, hr, min, sec) + write(mesg,*) 'Assimilation Time: ', yr, mon, day, hr, min, sec + call MOM_mesg("set_analysis_time: "//trim(mesg)) + endif + if (CS%Time < Time) then + call MOM_error(FATAL, " set_analysis_time: " // & + "assimilation interval appears to be shorter than " // & + "the model timestep") + endif + return + +end subroutine set_analysis_time + +!> Write observation differences to a file +subroutine save_obs_diff(filename,CS) + character(len=*), intent(in) :: filename !< name of output file + type(ODA_CS), pointer, intent(in) :: CS !< pointer to DA control structure + + integer :: fid ! profile file handle + type(ocean_profile_type), pointer :: Prof=>NULL() + + fid = open_profile_file(trim(filename), nvar=2, thread=MPP_SINGLE, fset=MPP_SINGLE) + Prof=>CS%CProfiles + + !! switch to global pelist + !call set_current_pelist(CS%filter_pelist) + + do while (associated(Prof)) + call write_profile(fid,Prof) + Prof=>Prof%cnext + enddo + call close_profile_file(fid) + + !! switch back to ensemble member pelist + !call set_current_pelist(CS%ensemble_pelist(CS%ensemble_id,:)) + + return +end subroutine save_obs_diff + + +!> Apply increments to tracers +subroutine apply_oda_tracer_increments(dt,G,tv,h,CS) + real, intent(in) :: dt !< The tracer timestep [s] + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(thermo_var_ptrs), intent(inout) :: tv !< A structure pointing to various thermodynamic variables + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< layer thickness [H ~> m or kg m-2] + type(ODA_CS), intent(inout) :: CS !< the data assimilation structure + +end subroutine apply_oda_tracer_increments + +!> \namespace MOM_oda_driver_mod +!! +!! \section section_ODA The Ocean data assimilation (DA) and Ensemble Framework +!! +!! The DA framework implements ensemble capability in MOM6. Currently, this framework +!! is enabled using the cpp directive ENSEMBLE_OCEAN. The ensembles need to be generated +!! at the level of the calling routine for oda_init or above. The ensemble instances may +!! exist on overlapping or non-overlapping processors. The ensemble information is accessed +!! via the FMS ensemble manager. An independent PE layout is used to gather (prior) ensemble +!! member information where this information is stored in the ODA control structure. This +!! module was developed in collaboration with Feiyu Lu and Tony Rosati in the GFDL prediction +!! group for use in their coupled ensemble framework. These interfaces should be suitable for +!! interfacing MOM6 to other data assimilation packages as well. - end subroutine apply_oda_tracer_increments end module MOM_oda_driver_mod diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 9ac56b03c6..21e06ebcef 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -1,4 +1,6 @@ !> Implements the Mesoscale Eddy Kinetic Energy framework +!! with topographic beta effect included in computing beta in Rhines scale + module MOM_MEKE ! This file is part of MOM6. See LICENSE.md for the license. @@ -15,6 +17,7 @@ module MOM_MEKE use MOM_hor_index, only : hor_index_type use MOM_io, only : vardesc, var_desc use MOM_restart, only : MOM_restart_CS, register_restart_field, query_initialized +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : vertvisc_type use MOM_verticalGrid, only : verticalGrid_type use MOM_MEKE_types, only : MEKE_type @@ -28,107 +31,115 @@ 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_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_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. - real :: MEKE_Cb !< Coefficient in the \f$\gamma_{bot}\f$ expression (non-dim) - real :: MEKE_min_gamma!< Minimum value of gamma_b^2 allowed (non-dim) - real :: MEKE_Ct !< Coefficient in the \f$\gamma_{bt}\f$ expression (non-dim) + real :: MEKE_Cb !< Coefficient in the \f$\gamma_{bot}\f$ expression [nondim] + real :: MEKE_min_gamma!< Minimum value of gamma_b^2 allowed [nondim] + real :: MEKE_Ct !< Coefficient in the \f$\gamma_{bt}\f$ expression [nondim] logical :: visc_drag !< If true use the vertvisc_type to calculate bottom drag. 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. - real :: cdrag !< The bottom drag coefficient for MEKE (non-dim). - real :: MEKE_BGsrc !< Background energy source for MEKE in W/kg (= m2 s-3). - real :: MEKE_dtScale !< Scale factor to accelerate time-stepping (non-dim.) - real :: MEKE_KhCoeff !< Scaling factor to convert MEKE into Kh (non-dim.) - real :: MEKE_Uscale !< MEKE velocity scale for bottom drag (m/s) - real :: MEKE_KH !< Background lateral diffusion of MEKE (m^2/s) - real :: MEKE_K4 !< Background bi-harmonic diffusivity (of MEKE) (m^4/s) + 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] + real :: MEKE_KhCoeff !< Scaling factor to convert MEKE into Kh [nondim] + real :: MEKE_Uscale !< MEKE velocity scale for bottom drag [m s-1] + real :: MEKE_KH !< Background lateral diffusion of MEKE [m2 s-1] + real :: MEKE_K4 !< Background bi-harmonic diffusivity (of MEKE) [m4 s-1] real :: KhMEKE_Fac !< A factor relating MEKE%Kh to the diffusivity used for - !! MEKE itself (nondimensional). + !! MEKE itself [nondim]. real :: viscosity_coeff !< The scaling coefficient in the expression for !! viscosity used to parameterize lateral momentum mixing !! by unresolved eddies represented by MEKE. - real :: Lfixed !< Fixed mixing length scale, in m. - real :: aDeform !< Weighting towards deformation scale of mixing length (non-dim.) - real :: aRhines !< Weighting towards Rhines scale of mixing length (non-dim.) - real :: aFrict !< Weighting towards frictional arrest scale of mixing length (non-dim.) - real :: aEady !< Weighting towards Eady scale of mixing length (non-dim.) - real :: aGrid !< Weighting towards grid scale of mixing length (non-dim.) - real :: MEKE_advection_factor !< A scaling in front of the advection of MEKE (non-dim.) + real :: Lfixed !< Fixed mixing length scale [m]. + real :: aDeform !< Weighting towards deformation scale of mixing length [nondim] + real :: aRhines !< Weighting towards Rhines scale of mixing length [nondim] + real :: aFrict !< Weighting towards frictional arrest scale of mixing length [nondim] + real :: aEady !< Weighting towards Eady scale of mixing length [nondim] + real :: aGrid !< Weighting towards grid scale of mixing length [nondim] + 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 :: initialize !< If True, invokes a steady state solver to calculate MEKE. logical :: debug !< If true, write out checksums of data for debugging ! Optional storage - real, dimension(:,:), allocatable :: del2MEKE ! Laplacian of MEKE, used for bi-harmonic diffusion. + real, dimension(:,:), allocatable :: del2MEKE !< Laplacian of MEKE, used for bi-harmonic diffusion. - ! Diagnostic handles - type(diag_ctrl), pointer :: diag !< A pointer to shared diagnostics data + type(diag_ctrl), pointer :: diag => NULL() !< A type that regulates diagnostics output + !>@{ Diagnostic handles integer :: id_MEKE = -1, id_Ue = -1, id_Kh = -1, id_src = -1 integer :: id_Ub = -1, id_Ut = -1 integer :: id_GM_src = -1, id_mom_src = -1, id_decay = -1 integer :: id_KhMEKE_u = -1, id_KhMEKE_v = -1, id_Ku = -1 integer :: id_Le = -1, id_gamma_b = -1, id_gamma_t = -1 integer :: id_Lrhines = -1, id_Leady = -1 + !!@} ! Infrastructure integer :: id_clock_pass !< Clock for group pass calls - type(group_pass_type) :: pass_MEKE, pass_Kh, pass_Ku, pass_del2MEKE !< Type for group-halo pass calls + type(group_pass_type) :: pass_MEKE !< Type for group halo pass calls + type(group_pass_type) :: pass_Kh !< Type for group halo pass calls + type(group_pass_type) :: pass_Ku !< Type for group halo pass calls + type(group_pass_type) :: pass_del2MEKE !< Type for group halo pass calls end type MEKE_CS contains !> Integrates forward-in-time the MEKE eddy energy equation. !! See \ref section_MEKE_equations. -subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, CS, hu, hv) +subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, hv) 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. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness in H (m or kg m-2). - 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 u-points (s-1). + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. + 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]. type(vertvisc_type), intent(in) :: visc !< The vertical viscosity type. - real, intent(in) :: dt !< Model(baroclinic) time-step (s). + real, intent(in) :: dt !< Model(baroclinic) time-step [s]. type(MEKE_CS), pointer :: CS !< MEKE control structure. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: hu !< Zonal flux flux (H m2 s-1). - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: hv !< Meridional mass flux (H m2 s-1). + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: hu !< Zonal mass flux [H m2 s-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: hv !< Meridional mass flux [H m2 s-1 ~> m3 s-1 or kg s-1] + ! 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. + 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]. 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, in kg m2 s-3. - Kh_u, & ! The zonal diffusivity that is actually used, in m2 s-1. - baroHu, & ! Depth integrated zonal mass flux (H m2 s-1). + MEKE_uflux, & ! The zonal diffusive flux of MEKE [kg m2 s-3]. + Kh_u, & ! The zonal diffusivity that is actually used [m2 s-1]. + baroHu, & ! Depth integrated zonal mass flux [H m2 s-1 ~> m3 s-1 or kg s-1]. drag_vel_u ! A (vertical) viscosity associated with bottom drag at - ! u-points, in m s-1. + ! u-points [m s-1]. real, dimension(SZI_(G),SZJB_(G)) :: & - MEKE_vflux, & ! The meridional diffusive flux of MEKE, in kg m2 s-3. - Kh_v, & ! The meridional diffusivity that is actually used, in m2 s-1. - baroHv, & ! Depth integrated meridional mass flux (H m2 s-1). + MEKE_vflux, & ! The meridional diffusive flux of MEKE [kg m2 s-3]. + Kh_v, & ! The meridional diffusivity that is actually used [m2 s-1]. + baroHv, & ! Depth integrated meridional mass flux [H m2 s-1 ~> m3 s-1 or kg s-1]. drag_vel_v ! A (vertical) viscosity associated with bottom drag at - ! v-points, in m s-1. + ! v-points [m s-1]. real :: Kh_here, Inv_Kh_max, K4_here real :: cdrag2 real :: advFac - real :: mass_neglect ! A negligible mass, in kg m-2. - real :: ldamping ! The MEKE damping rate in s-1. - real :: Rho0 ! A density used to convert mass to distance, in kg m-3. - real :: sdt ! dt to use locally (could be scaled to accelerate) - real :: sdt_damp ! dt for damping (sdt could be split). + real :: mass_neglect ! A negligible mass [kg m-2]. + real :: ldamping ! The MEKE damping rate [s-1]. + real :: Rho0 ! A density used to convert mass to distance [kg m-3]. + real :: sdt ! dt to use locally [s] (could be scaled to accelerate) + real :: sdt_damp ! dt for damping [s] (sdt could be split). logical :: use_drag_rate ! Flag to indicate drag_rate is finite integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz @@ -191,14 +202,8 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, CS, hu, hv) enddo endif -!$OMP parallel default(none) shared(MEKE,CS,is,ie,js,je,nz,src,mass,G,GV,h,I_mass, & -!$OMP sdt,drag_vel_u,visc,drag_vel_v,drag_rate_visc, & -!$OMP drag_rate,Rho0,MEKE_decay,sdt_damp,cdrag2, & -!$OMP bottomFac2) & -!$OMP private(ldamping) - if (CS%MEKE_Cd_scale == 0.0 .and. .not. CS%visc_drag) then -!$OMP do + !$OMP parallel do default(shared) private(ldamping) do j=js,je ; do i=is,ie drag_rate(i,j) = 0. enddo ; enddo @@ -206,20 +211,20 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, CS, hu, hv) ! Calculate drag_rate_visc(i,j) which accounts for the model bottom mean flow if (CS%visc_drag) then -!$OMP do + !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie drag_vel_u(I,j) = 0.0 if ((G%mask2dCu(I,j) > 0.0) .and. (visc%bbl_thick_u(I,j) > 0.0)) & - drag_vel_u(I,j) = visc%kv_bbl_u(I,j) / visc%bbl_thick_u(I,j) + drag_vel_u(I,j) = US%Z_to_m*visc%kv_bbl_u(I,j) / visc%bbl_thick_u(I,j) enddo ; enddo -!$OMP do + !$OMP parallel do default(shared) do J=js-1,je ; do i=is,ie drag_vel_v(i,J) = 0.0 if ((G%mask2dCv(i,J) > 0.0) .and. (visc%bbl_thick_v(i,J) > 0.0)) & - drag_vel_v(i,J) = visc%kv_bbl_v(i,J) / visc%bbl_thick_v(i,J) + drag_vel_v(i,J) = US%Z_to_m*visc%kv_bbl_v(i,J) / visc%bbl_thick_v(i,J) enddo ; enddo -!$OMP do + !$OMP parallel do default(shared) do j=js,je ; do i=is,ie drag_rate_visc(i,j) = (0.25*G%IareaT(i,j) * & ((G%areaCu(I-1,j)*drag_vel_u(I-1,j) + & @@ -228,13 +233,13 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, CS, hu, hv) G%areaCv(i,J)*drag_vel_v(i,J)) ) ) enddo ; enddo else -!$OMP do + !$OMP parallel do default(shared) do j=js,je ; do i=is,ie drag_rate_visc(i,j) = 0. enddo ; enddo endif -!$OMP do + !$OMP parallel do default(shared) do j=js-1,je+1 do i=is-1,ie+1 ; mass(i,j) = 0.0 ; enddo do k=1,nz ; do i=is-1,ie+1 @@ -245,15 +250,14 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, CS, hu, hv) if (mass(i,j) > 0.0) I_mass(i,j) = 1.0 / mass(i,j) enddo enddo -!$OMP end parallel if (CS%initialize) then - call MEKE_equilibrium(CS, MEKE, G, GV, SN_u, SN_v, drag_rate_visc, I_mass) + call MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_mass) CS%initialize = .false. endif ! Calculates bottomFac2, barotrFac2 and LmixScale - call MEKE_lengthScales(CS, MEKE, G, SN_u, SN_v, MEKE%MEKE, bottomFac2, barotrFac2, LmixScale) + call MEKE_lengthScales(CS, MEKE, G, 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) @@ -263,41 +267,35 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, CS, hu, hv) call hchksum(LmixScale, 'MEKE LmixScale',G%HI) endif -!$OMP parallel default(none) shared(MEKE,CS,is,ie,js,je,nz,src,mass,G,h,I_mass, & -!$OMP sdt,drag_vel_u,visc,drag_vel_v,drag_rate_visc, & -!$OMP drag_rate,Rho0,MEKE_decay,sdt_damp,cdrag2, & -!$OMP bottomFac2,barotrFac2,use_drag_rate) & -!$OMP private(ldamping) - ! Aggregate sources of MEKE (background, frictional and GM) -!$OMP do + !$OMP parallel do default(shared) do j=js,je ; do i=is,ie src(i,j) = CS%MEKE_BGsrc enddo ; enddo if (associated(MEKE%mom_src)) then -!$OMP do + !$OMP parallel do default(shared) do j=js,je ; do i=is,ie src(i,j) = src(i,j) - CS%MEKE_FrCoeff*I_mass(i,j)*MEKE%mom_src(i,j) enddo ; enddo endif if (associated(MEKE%GM_src)) then -!$OMP do + !$OMP parallel do default(shared) do j=js,je ; do i=is,ie src(i,j) = src(i,j) - CS%MEKE_GMcoeff*I_mass(i,j)*MEKE%GM_src(i,j) enddo ; enddo endif ! Increase EKE by a full time-steps worth of source -!$OMP do + !$OMP parallel do default(shared) do j=js,je ; do i=is,ie MEKE%MEKE(i,j) = (MEKE%MEKE(i,j) + sdt*src(i,j) )*G%mask2dT(i,j) enddo ; enddo if (use_drag_rate) then ! Calculate a viscous drag rate (includes BBL contributions from mean flow and eddies) -!$OMP do + !$OMP parallel do default(shared) do j=js,je ; do i=is,ie drag_rate(i,j) = (Rho0 * I_mass(i,j)) * sqrt( drag_rate_visc(i,j)**2 & + cdrag2 * ( max(0.0, 2.0*bottomFac2(i,j)*MEKE%MEKE(i,j)) + CS%MEKE_Uscale**2 ) ) @@ -305,7 +303,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, CS, hu, hv) endif ! First stage of Strang splitting -!$OMP do + !$OMP parallel do default(shared) private(ldamping) do j=js,je ; do i=is,ie ldamping = CS%MEKE_damping + drag_rate(i,j) * bottomFac2(i,j) if (MEKE%MEKE(i,j)<0.) ldamping = 0. @@ -314,7 +312,6 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, CS, hu, hv) MEKE%MEKE(i,j) = MEKE%MEKE(i,j) / (1.0 + sdt_damp*ldamping) MEKE_decay(i,j) = ldamping*G%mask2dT(i,j) enddo ; enddo -!$OMP end parallel if (CS%MEKE_KH >= 0.0 .or. CS%KhMEKE_FAC > 0.0 .or. CS%MEKE_K4 >= 0.0) then ! Update halos for lateral or bi-harmonic diffusion @@ -325,8 +322,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, CS, hu, hv) if (CS%MEKE_K4 >= 0.0) then ! Calculate Laplacian of MEKE -!$OMP parallel default(none) shared(is,ie,js,je,MEKE_uflux,G,MEKE,MEKE_vflux,CS) -!$OMP do + !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie MEKE_uflux(I,j) = ((G%dy_Cu(I,j)*G%IdxCu(I,j)) * G%mask2dCu(I,j)) * & (MEKE%MEKE(i+1,j) - MEKE%MEKE(i,j)) @@ -334,7 +330,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, CS, hu, hv) ! ((2.0*mass(i,j)*mass(i+1,j)) / ((mass(i,j)+mass(i+1,j)) + mass_neglect)) ) * & ! (MEKE%MEKE(i+1,j) - MEKE%MEKE(i,j)) enddo ; enddo -!$OMP do + !$OMP parallel do default(shared) do J=js-1,je ; do i=is,ie MEKE_vflux(i,J) = ((G%dx_Cv(i,J)*G%IdyCv(i,J)) * G%mask2dCv(i,J)) * & (MEKE%MEKE(i,j+1) - MEKE%MEKE(i,j)) @@ -342,23 +338,19 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, CS, hu, hv) ! ((2.0*mass(i,j)*mass(i,j+1)) / ((mass(i,j)+mass(i,j+1)) + mass_neglect)) ) * & ! (MEKE%MEKE(i,j+1) - MEKE%MEKE(i,j)) enddo ; enddo -!$OMP do + !$OMP parallel do default(shared) do j=js,je ; do i=is,ie CS%del2MEKE(i,j) = G%IareaT(i,j) * & ((MEKE_uflux(I,j) - MEKE_uflux(I-1,j)) + (MEKE_vflux(i,J) - MEKE_vflux(i,J-1))) ! CS%del2MEKE(i,j) = (G%IareaT(i,j)*I_mass(i,j)) * & ! ((MEKE_uflux(I,j) - MEKE_uflux(I-1,j)) + (MEKE_vflux(i,J) - MEKE_vflux(i,J-1))) enddo ; enddo -!$OMP end parallel call cpu_clock_begin(CS%id_clock_pass) call do_group_pass(CS%pass_del2MEKE, G%Domain) call cpu_clock_end(CS%id_clock_pass) ! Bi-harmonic diffusion of MEKE -!$OMP parallel default(none) shared(is,ie,js,je,MEKE_uflux,G,CS,sdt,mass, & -!$OMP mass_neglect,MEKE_vflux,I_mass) & -!$OMP private(K4_here,Inv_Kh_max) -!$OMP do + !$OMP parallel do default(shared) private(K4_here,Inv_Kh_max) do j=js,je ; do I=is-1,ie K4_here = CS%MEKE_K4 ! Limit Kh to avoid CFL violations. @@ -370,7 +362,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, CS, hu, hv) ((2.0*mass(i,j)*mass(i+1,j)) / ((mass(i,j)+mass(i+1,j)) + mass_neglect)) ) * & (CS%del2MEKE(i+1,j) - CS%del2MEKE(i,j)) enddo ; enddo -!$OMP do + !$OMP parallel do default(shared) private(K4_here,Inv_Kh_max) do J=js-1,je ; do i=is,ie K4_here = CS%MEKE_K4 Inv_Kh_max = 64.0*sdt * (((G%dx_Cv(i,J)*G%IdyCv(i,J)) * & @@ -381,26 +373,19 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, CS, hu, hv) ((2.0*mass(i,j)*mass(i,j+1)) / ((mass(i,j)+mass(i,j+1)) + mass_neglect)) ) * & (CS%del2MEKE(i,j+1) - CS%del2MEKE(i,j)) enddo ; enddo -!$OMP do + !$OMP parallel do default(shared) ! Store tendency of bi-harmonic in del2MEKE do j=js,je ; do i=is,ie CS%del2MEKE(i,j) = (sdt*(G%IareaT(i,j)*I_mass(i,j))) * & ((MEKE_uflux(I-1,j) - MEKE_uflux(I,j)) + & (MEKE_vflux(i,J-1) - MEKE_vflux(i,J))) enddo ; enddo -!$OMP end parallel endif ! -!$OMP parallel default(none) shared(is,ie,js,je,MEKE,CS,sdt,G,Kh_u,MEKE_uflux, & -!$OMP mass,mass_neglect,Kh_v,MEKE_vflux,I_mass, & -!$OMP sdt_damp,drag_rate,Rho0,drag_rate_visc, & -!$OMP cdrag2,bottomFac2,MEKE_decay,barotrFac2, & -!$OMP use_drag_rate,dt,baroHu,baroHv,GV) & -!$OMP private(Kh_here,Inv_Kh_max,ldamping,advFac) if (CS%MEKE_KH >= 0.0 .or. CS%KhMEKE_FAC > 0.0 .or. CS%MEKE_advection_factor >0.0) then ! Lateral diffusion of MEKE Kh_here = max(0.,CS%MEKE_Kh) -!$OMP do + !$OMP parallel do default(shared) firstprivate(Kh_here) private(Inv_Kh_max) do j=js,je ; do I=is-1,ie ! Limit Kh to avoid CFL violations. if (associated(MEKE%Kh)) & @@ -414,7 +399,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, CS, hu, hv) ((2.0*mass(i,j)*mass(i+1,j)) / ((mass(i,j)+mass(i+1,j)) + mass_neglect)) ) * & (MEKE%MEKE(i,j) - MEKE%MEKE(i+1,j)) enddo ; enddo -!$OMP do + !$OMP parallel do default(shared) firstprivate(Kh_here) private(Inv_Kh_max) do J=js-1,je ; do i=is,ie if (associated(MEKE%Kh)) & Kh_here = max(0.,CS%MEKE_Kh) + CS%KhMEKE_Fac*0.5*(MEKE%Kh(i,j)+MEKE%Kh(i,j+1)) @@ -429,7 +414,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, CS, hu, hv) enddo ; enddo if (CS%MEKE_advection_factor>0.) then advFac = GV%H_to_m * CS%MEKE_advection_factor / dt -!$OMP do + !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie if (baroHu(I,j)>0.) then MEKE_uflux(I,j) = MEKE_uflux(I,j) + baroHu(I,j)*MEKE%MEKE(i,j)*advFac @@ -437,7 +422,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, CS, hu, hv) MEKE_uflux(I,j) = MEKE_uflux(I,j) + baroHu(I,j)*MEKE%MEKE(i+1,j)*advFac endif enddo ; enddo -!$OMP do + !$OMP parallel do default(shared) do J=js-1,je ; do i=is,ie if (baroHv(i,J)>0.) then MEKE_vflux(i,J) = MEKE_vflux(i,J) + baroHv(i,J)*MEKE%MEKE(i,j)*advFac @@ -446,7 +431,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, CS, hu, hv) endif enddo ; enddo endif -!$OMP do + !$OMP parallel do default(shared) do j=js,je ; do i=is,ie MEKE%MEKE(i,j) = MEKE%MEKE(i,j) + (sdt*(G%IareaT(i,j)*I_mass(i,j))) * & ((MEKE_uflux(I-1,j) - MEKE_uflux(I,j)) + & @@ -456,7 +441,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, CS, hu, hv) ! Add on bi-harmonic tendency if (CS%MEKE_K4 >= 0.0) then -!$OMP do + !$OMP parallel do default(shared) do j=js,je ; do i=is,ie MEKE%MEKE(i,j) = MEKE%MEKE(i,j) + CS%del2MEKE(i,j) enddo ; enddo @@ -467,13 +452,13 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, CS, hu, hv) if (sdt>sdt_damp) then ! Recalculate the drag rate, since MEKE has changed. if (use_drag_rate) then -!$OMP do + !$OMP parallel do default(shared) do j=js,je ; do i=is,ie drag_rate(i,j) = (Rho0 * I_mass(i,j)) * sqrt( drag_rate_visc(i,j)**2 & + cdrag2 * ( max(0.0, 2.0*bottomFac2(i,j)*MEKE%MEKE(i,j)) + CS%MEKE_Uscale**2 ) ) enddo ; enddo endif -!$OMP do + !$OMP parallel do default(shared) private(ldamping) do j=js,je ; do i=is,ie ldamping = CS%MEKE_damping + drag_rate(i,j) * bottomFac2(i,j) if (MEKE%MEKE(i,j)<0.) ldamping = 0. @@ -484,7 +469,6 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, CS, hu, hv) enddo ; enddo endif endif ! MEKE_KH>=0 -!$OMP end parallel call cpu_clock_begin(CS%id_clock_pass) call do_group_pass(CS%pass_MEKE, G%Domain) @@ -494,20 +478,20 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, CS, hu, hv) if (CS%MEKE_KhCoeff>0.) then if (CS%use_old_lscale) then if (CS%Rd_as_max_scale) then -!$OMP parallel do default(none) shared(is,ie,js,je,MEKE,CS,G,barotrFac2) + !$OMP parallel do default(shared) do j=js,je ; do i=is,ie MEKE%Kh(i,j) = (CS%MEKE_KhCoeff & * sqrt(2.*max(0.,barotrFac2(i,j)*MEKE%MEKE(i,j))*G%areaT(i,j))) & * min(MEKE%Rd_dx_h(i,j), 1.0) enddo ; enddo else -!$OMP parallel do default(none) shared(is,ie,js,je,MEKE,CS,G,barotrFac2) + !$OMP parallel do default(shared) do j=js,je ; do i=is,ie MEKE%Kh(i,j) = CS%MEKE_KhCoeff*sqrt(2.*max(0.,barotrFac2(i,j)*MEKE%MEKE(i,j))*G%areaT(i,j)) enddo ; enddo endif else -!$OMP parallel do default(none) shared(is,ie,js,je,MEKE,LmixScale,CS,G,barotrFac2) + !$OMP parallel do default(shared) do j=js,je ; do i=is,ie MEKE%Kh(i,j) = (CS%MEKE_KhCoeff*sqrt(2.*max(0.,barotrFac2(i,j)*MEKE%MEKE(i,j)))*LmixScale(i,j)) enddo ; enddo @@ -527,7 +511,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, CS, hu, hv) call cpu_clock_end(CS%id_clock_pass) endif -! Offer fields for averaging. + ! Offer fields for averaging. if (CS%id_MEKE>0) call post_data(CS%id_MEKE, MEKE%MEKE, CS%diag) if (CS%id_Ue>0) call post_data(CS%id_Ue, sqrt(max(0.,2.0*MEKE%MEKE)), CS%diag) if (CS%id_Ub>0) call post_data(CS%id_Ub, sqrt(max(0.,2.0*MEKE%MEKE*bottomFac2)), CS%diag) @@ -563,21 +547,23 @@ end subroutine step_forward_MEKE !> Calculates the equilibrium solutino where the source depends only on MEKE diffusivity !! and there is no lateral diffusion of MEKE. !! Results is in MEKE%MEKE. -subroutine MEKE_equilibrium(CS, MEKE, G, GV, SN_u, SN_v, drag_rate_visc, I_mass) +subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_mass) 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 type(MEKE_CS), pointer :: CS !< MEKE control structure. type(MEKE_type), pointer :: MEKE !< MEKE data. - 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 u-points (s-1). - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: drag_rate_visc !< Mean flow contrib. to drag rate + 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]. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: drag_rate_visc !< Mean flow contrib. to drag rate real, dimension(SZI_(G),SZJ_(G)), intent(in) :: I_mass !< Inverse of column mass. ! Local variables real :: beta, SN, bottomFac2, barotrFac2, LmixScale, Lrhines, Leady 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 integer :: i, j, is, ie, js, je, n1, n2 - real, parameter :: tolerance = 1.e-12 ! Width of EKE bracket in m^2 s^-2. + real, parameter :: tolerance = 1.e-12 ! Width of EKE bracket [m2 s-2]. logical :: useSecant, debugIteration is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -592,7 +578,14 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, SN_u, SN_v, drag_rate_visc, I_mass) !SN = 0.25*max( (SN_u(I,j) + SN_u(I-1,j)) + (SN_v(i,J) + SN_v(i,J-1)), 0.) ! This avoids extremes values in equilibrium solution due to bad values in SN_u, SN_v SN = min( min(SN_u(I,j) , SN_u(I-1,j)) , min(SN_v(i,J), SN_v(i,J-1)) ) - beta = sqrt( G%dF_dx(i,j)**2 + G%dF_dy(i,j)**2 ) + + FatH = 0.25*((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 + beta = sqrt( ( 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. & + + ( 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. ) + I_H = GV%Rho0 * I_mass(i,j) if (KhCoeff*SN*I_H>0.) then @@ -608,7 +601,7 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, SN_u, SN_v, drag_rate_visc, I_mass) n1 = n1 + 1 EKE = EKEmax call MEKE_lengthScales_0d(CS, G%areaT(i,j), beta, G%bathyT(i,j), & - MEKE%Rd_dx_h(i,j), SN, EKE, & + MEKE%Rd_dx_h(i,j), SN, EKE, US%Z_to_m, & bottomFac2, barotrFac2, LmixScale, & Lrhines, Leady) ! TODO: Should include resolution function in Kh @@ -683,20 +676,21 @@ 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, SN_u, SN_v, & +subroutine MEKE_lengthScales(CS, MEKE, G, 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. - 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 u-points (s-1). - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: EKE !< Eddy kinetic energy (m2/s2). + 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]. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: EKE !< Eddy kinetic energy [m2 s-2]. real, dimension(SZI_(G),SZJ_(G)), intent(out) :: bottomFac2 !< gamma_b^2 real, dimension(SZI_(G),SZJ_(G)), intent(out) :: barotrFac2 !< gamma_t^2 - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: LmixScale !< Eddy mixing length (m). + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: LmixScale !< Eddy mixing length [m]. ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: Lrhines, Leady - real :: beta, SN + real :: beta, SN, FatH integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -709,11 +703,16 @@ subroutine MEKE_lengthScales(CS, MEKE, G, SN_u, SN_v, & else SN = 0. endif - beta = sqrt( G%dF_dx(i,j)**2 + G%dF_dy(i,j)**2 ) + FatH = 0.25*( ( 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 + beta = sqrt( ( 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. & + + ( 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. ) endif ! Returns bottomFac2, barotrFac2 and LmixScale - call MEKE_lengthScales_0d(CS, G%areaT(i,j), beta, G%bathyT(i,j), & - MEKE%Rd_dx_h(i,j), SN, MEKE%MEKE(i,j), & + call MEKE_lengthScales_0d(CS, G%areaT(i,j), beta, G%bathyT(i,j), & + MEKE%Rd_dx_h(i,j), SN, MEKE%MEKE(i,j), US%Z_to_m, & bottomFac2(i,j), barotrFac2(i,j), LmixScale(i,j), & Lrhines(i,j), Leady(i,j)) enddo ; enddo @@ -725,27 +724,29 @@ end subroutine MEKE_lengthScales !> 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_0d(CS, area, beta, depth, Rd_dx, SN, & - EKE, bottomFac2, barotrFac2, LmixScale, Lrhines, Leady) +subroutine MEKE_lengthScales_0d(CS, area, beta, depth, Rd_dx, SN, EKE, Z_to_L, & + bottomFac2, barotrFac2, LmixScale, Lrhines, Leady) type(MEKE_CS), pointer :: CS !< MEKE control structure. - real, intent(in) :: area !< Grid cell area (m2) - real, intent(in) :: beta !< Planetary beta = |grad F| (s-1 m-1) - real, intent(in) :: depth !< Ocean depth (m) - real, intent(in) :: Rd_dx !< Resolution Ld/dx (nondim). - real, intent(in) :: SN !< Eady growth rate (s-1). - real, intent(in) :: EKE !< Eddy kinetic energy (m s-1). + real, intent(in) :: area !< Grid cell area [m2] + real, intent(in) :: beta !< Planetary beta = |grad F| [s-1 m-1] + real, intent(in) :: depth !< Ocean depth [Z ~> m] + real, intent(in) :: Rd_dx !< Resolution Ld/dx [nondim]. + real, intent(in) :: SN !< Eady growth rate [s-1]. + real, intent(in) :: EKE !< Eddy kinetic energy [m s-1]. + real, intent(in) :: Z_to_L !< A conversion factor from depth units (Z) to + !! the units for lateral distances (L). real, intent(out) :: bottomFac2 !< gamma_b^2 real, intent(out) :: barotrFac2 !< gamma_t^2 - real, intent(out) :: LmixScale !< Eddy mixing length (m). - real, intent(out) :: Lrhines !< Rhines length scale (m). - real, intent(out) :: Leady !< Eady length scale (m). + real, intent(out) :: LmixScale !< Eddy mixing length [m]. + real, intent(out) :: Lrhines !< Rhines length scale [m]. + real, intent(out) :: Leady !< Eady length scale [m]. ! Local variables real :: Lgrid, Ldeform, LdeformLim, Ue, Lfrict ! Length scale for MEKE derived diffusivity Lgrid = sqrt(area) ! Grid scale Ldeform = Lgrid * Rd_dx ! Deformation scale - Lfrict = depth / CS%cdrag ! Frictional arrest scale + Lfrict = (Z_to_L * depth) / CS%cdrag ! Frictional arrest scale ! gamma_b^2 is the ratio of bottom eddy energy to mean column eddy energy ! used in calculating bottom drag bottomFac2 = CS%MEKE_CD_SCALE**2 @@ -942,6 +943,11 @@ logical function MEKE_init(Time, G, param_file, diag, CS, MEKE, restart_CS) "Using unity would be normal but other values could accomodate a mismatch\n"//& "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"//& + "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, & @@ -1250,7 +1256,7 @@ end subroutine MEKE_end !! !! \f{eqnarray*}{ !! L_d & = & \sqrt{\frac{c_g^2}{f^2+2\beta c_g}} \sim \frac{ c_g }{f} \\\\ -!! L_R & = & \sqrt{\frac{U_e}{\beta}} \\\\ +!! L_R & = & \sqrt{\frac{U_e}{\beta^*}} \\\\ !! L_e & = & \frac{U_e}{|S| N} \\\\ !! L_f & = & \frac{H}{c_d} \\\\ !! L_\Delta & = & \sqrt{A_\Delta} . @@ -1258,7 +1264,20 @@ end subroutine MEKE_end !! !! \f$L_c\f$ is a constant and \f$\delta[L_c]\f$ is the impulse function so that the term !! \f$\frac{\delta[L_c]}{L_c}\f$ evaluates to \f$\frac{1}{L_c}\f$ when \f$L_c\f$ is non-zero -!! but is dropped if \f$L_c=0\f$. +!! but is dropped if \f$L_c=0\fi$. +!! +!! \f$\beta^*\f$ is the effective \f$\beta\f$ that combines both the planetary vorticity +!! gradient (i.e. \f$\beta=\nabla f\f$) and the topographic \f$\beta\f$ effect, +!! with the latter weighed by a weighting constant, \f$c_\beta\f$, that varies +!! from 0 to 1, so that \f$c_\beta=0\f$ means the topographic \f$\beta\f$ effect is ignored, +!! while \f$c_\beta=1\f$ means it is fully considered. The new \f$\beta^*\f$ therefore +!! takes the form of +!! +!! \f[ +!! \beta^* = \sqrt{( \partial_xf - c_\beta\frac{f}{D}\partial_xD )^2 + +!! ( \partial_yf - c_\beta\frac{f}{D}\partial_yD )^2} +!! \f] +!! where \f$D\f$ is water column depth at T points. !! !! \subsection section_MEKE_viscosity Viscosity derived from MEKE !! @@ -1310,6 +1329,7 @@ end subroutine MEKE_end !! | \f$ \alpha_e \f$ | MEKE_ALPHA_EADY | !! | \f$ \alpha_\Delta \f$ | MEKE_ALPHA_GRID | !! | \f$ L_c \f$ | MEKE_FIXED_MIXING_LENGTH | +!! | \f$ c_\beta \f$ | MEKE_TOPOGRAPHIC_BETA | !! | - | MEKE_KHTH_FAC | !! | - | MEKE_KHTR_FAC | !! @@ -1319,11 +1339,11 @@ end subroutine MEKE_end !! !! \subsection section_MEKE_references References !! -!! Jansen, M. F., A. J. Adcroft, R. Hallberg, and I. M. Held, 2015: Parameterization of eddy fluxes based on a mesoscale energy -!! budget. Ocean Modelling, 92, 28--41, http://doi.org/10.1016/j.ocemod.2015.05.007 . +!! Jansen, M. F., A. J. Adcroft, R. Hallberg, and I. M. Held, 2015: Parameterization of eddy fluxes based on a +!! mesoscale energy budget. Ocean Modelling, 92, 28--41, http://doi.org/10.1016/j.ocemod.2015.05.007 . !! -!! Marshall, D. P., and A. J. Adcroft, 2010: Parameterization of ocean eddies: Potential vorticity mixing, energetics and Arnold -!! first stability theorem. Ocean Modelling, 32, 188--204, http://doi.org/10.1016/j.ocemod.2010.02.001 . +!! Marshall, D. P., and A. J. Adcroft, 2010: Parameterization of ocean eddies: Potential vorticity mixing, energetics +!! and Arnold first stability theorem. Ocean Modelling, 32, 188--204, http://doi.org/10.1016/j.ocemod.2010.02.001 . end module MOM_MEKE diff --git a/src/parameterizations/lateral/MOM_MEKE_types.F90 b/src/parameterizations/lateral/MOM_MEKE_types.F90 index 834a265edd..22ed34c6c2 100644 --- a/src/parameterizations/lateral/MOM_MEKE_types.F90 +++ b/src/parameterizations/lateral/MOM_MEKE_types.F90 @@ -2,35 +2,26 @@ module MOM_MEKE_types ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* This program contains the subroutine that calculates the * -!* effects of horizontal viscosity, including parameterizations of * -!* the value of the viscosity itself. mesosclae_EKE calculates * -!* the evolution of sub-grid scale mesoscale EKE. * -!* * -!********+*********+*********+*********+*********+*********+*********+** - implicit none ; private +!> This type is used to exchange information related to the MEKE calculations. 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. - Kh => NULL(), & ! The MEKE-derived lateral mixing coefficient in m2 s-1. - Rd_dx_h => NULL(), &! The deformation radius compared with the grid - ! spacing, copied from VarMix_CS, nondim. - Ku => NULL() ! The MEKE-derived lateral viscosity coefficient in m2 s-1. - ! This viscosity can be negative when representing backscatter - ! from unresolved eddies (see Jansen and Held, 2014). + 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]. + Kh => NULL(), & !< The MEKE-derived lateral mixing coefficient [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). ! 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. - real :: backscatter_Ro_pow = 0.0 ! Power in Rossby number function for backscatter. - real :: backscatter_Ro_c = 0.0 ! Coefficient in Rossby number function for backscatter. + 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]. + real :: backscatter_Ro_pow = 0.0 !< Power in Rossby number function for backscatter. + real :: backscatter_Ro_c = 0.0 !< Coefficient in Rossby number function for backscatter. end type MEKE_type end module MOM_MEKE_types diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 0e02cefba2..a980704d21 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -1,74 +1,8 @@ +!> Calculates horizontal viscosity and viscous stresses module MOM_hor_visc ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Robert Hallberg, April 1994 - June 2002. * -!* * -!* This program contains the subroutine that calculates the * -!* effects of horizontal viscosity, including parameterizations of * -!* the value of the viscosity itself. horizontal_viscosity calc- * -!* ulates the acceleration due to some combination of a biharmonic * -!* viscosity and a Laplacian viscosity. Either or both may use a * -!* coefficient that depends on the shear and strain of the flow. * -!* All metric terms are retained. The Laplacian is calculated as * -!* the divergence of a stress tensor, using the form suggested by * -!* Smagorinsky (1993). The biharmonic is calculated by twice * -!* applying the divergence of the stress tensor that is used to * -!* calculate the Laplacian, but without the dependence on thickness * -!* in the first pass. This form permits a variable viscosity, and * -!* indicates no acceleration for either resting fluid or solid body * -!* rotation. * -!* * -!* set_up_hor_visc calculates and stores the values of a number of * -!* metric functions that are used in horizontal_viscosity. It is * -!* called by horizontal_viscosity the first time that the latter is * -!* called. * -!* * -!* The form of the Laplacian viscosity is: * -!* * -!* diffu = 1/h * {d/dx[KH*h*sh_xx] + d/dy[KH*h*sh_xy]} * -!* diffv = 1/h * {d/dx[KH*h*sh_xy] - d/dy[KH*h*sh_xx]} * -!* * -!* sh_xx = du/dx - dv/dy sh_xy = du/dy + dv/dx * -!* * -!* with appropriate metric terms thrown in. KH may either be a * -!* constant or may vary with the shear, as proposed by Smagorinsky. * -!* The form of this term is discussed extensively in Griffies and * -!* Hallberg (MWR, 2000), and the implementation here follows that * -!* discussion closely. * -!* * -!* Only free slip boundary conditions have been coded, although * -!* no slip boundary conditions could be used with the Laplacian * -!* viscosity. For a western boundary, for example, the boundary * -!* conditions with the biharmonic operator would be written as: * -!* dv/dx = 0, d^3v/dx^3 = 0, u = 0, d^2u/dx^2 = 0 , * -!* while for a Laplacian operator, they are simply: * -!* dv/dx = 0, u = 0 . * -!* These boundary conditions are largely dictated by the use of * -!* a an Arakawa C-grid and by the varying layer thickness. * -!* * -!* * -!* * -!* * -!* * -!* Macros written all in capital letters are defined in MOM_memory.h. * -!* * -!* A small fragment of the C-grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q, CoriolisBu, hq, str_xy, sh_xy * -!* j+1 > o > o > At ^: v, diffv, v0 * -!* j x ^ x ^ x At >: u, diffu, u0 * -!* j > o > o > At o: h, str_xx, sh_xx * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** - use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : diag_ctrl, time_type use MOM_domains, only : pass_var @@ -88,255 +22,251 @@ module MOM_hor_visc public horizontal_viscosity, hor_visc_init, hor_visc_end +!> Control structure for horizontal viscosity type, public :: hor_visc_CS ; private - logical :: Laplacian ! Use a Laplacian horizontal viscosity if true. - logical :: biharmonic ! Use a biharmonic horizontal viscosity if true. - logical :: no_slip ! If true, no slip boundary conditions are used. - ! Otherwise free slip boundary conditions are assumed. - ! The implementation of the free slip boundary - ! conditions on a C-grid is much cleaner than the - ! no slip boundary conditions. The use of free slip - ! b.c.s is strongly encouraged. The no slip b.c.s - ! are not implemented with the biharmonic viscosity. - logical :: bound_Kh ! If true, the Laplacian coefficient is locally - ! limited to guarantee stability. - logical :: better_bound_Kh ! If true, use a more careful bounding of the - ! Laplacian viscosity to guarantee stability. - logical :: bound_Ah ! If true, the biharmonic coefficient is locally - ! limited to guarantee stability. - logical :: better_bound_Ah ! If true, use a more careful bounding of the - ! biharmonic viscosity to guarantee stability. - real :: bound_coef ! The nondimensional coefficient of the ratio of - ! the viscosity bounds to the theoretical maximum - ! for stability without considering other terms. - ! The default is 0.8. - logical :: Smagorinsky_Kh ! If true, use Smagorinsky nonlinear eddy - ! viscosity. KH is the background value. - logical :: Smagorinsky_Ah ! If true, use a biharmonic form of Smagorinsky - ! nonlinear eddy viscosity. AH is the background. - logical :: Leith_Kh ! If true, use 2D Leith nonlinear eddy - ! viscosity. KH is the background value. - logical :: Modified_Leith ! If true, use extra component of Leith viscosity - ! to damp divergent flow. To use, still set Leith_Kh=.TRUE. - logical :: Leith_Ah ! If true, use a biharmonic form of 2D Leith - ! nonlinear eddy viscosity. AH is the background. - logical :: bound_Coriolis ! If true & SMAGORINSKY_AH is used, the biharmonic - ! viscosity is modified to include a term that - ! scales quadratically with the velocity shears. - logical :: use_Kh_bg_2d ! Read 2d background viscosity from a file. - real :: Kh_bg_min ! The minimum value allowed for Laplacian horizontal - ! viscosity. The default is 0.0 - logical :: use_land_mask ! 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 to maintain answers with legacy experiments - ! but should be changed to True for new experiments. + logical :: Laplacian !< Use a Laplacian horizontal viscosity if true. + logical :: biharmonic !< Use a biharmonic horizontal viscosity if true. + logical :: no_slip !< If true, no slip boundary conditions are used. + !! Otherwise free slip boundary conditions are assumed. + !! The implementation of the free slip boundary + !! conditions on a C-grid is much cleaner than the + !! no slip boundary conditions. The use of free slip + !! b.c.s is strongly encouraged. The no slip b.c.s + !! are not implemented with the biharmonic viscosity. + logical :: bound_Kh !< If true, the Laplacian coefficient is locally + !! limited to guarantee stability. + logical :: better_bound_Kh !< If true, use a more careful bounding of the + !! Laplacian viscosity to guarantee stability. + logical :: bound_Ah !< If true, the biharmonic coefficient is locally + !! limited to guarantee stability. + logical :: better_bound_Ah !< If true, use a more careful bounding of the + !! biharmonic viscosity to guarantee stability. + real :: bound_coef !< The nondimensional coefficient of the ratio of + !! the viscosity bounds to the theoretical maximum + !! for stability without considering other terms. + !! The default is 0.8. + logical :: Smagorinsky_Kh !< If true, use Smagorinsky nonlinear eddy + !! viscosity. KH is the background value. + logical :: Smagorinsky_Ah !< If true, use a biharmonic form of Smagorinsky + !! nonlinear eddy viscosity. AH is the background. + logical :: Leith_Kh !< If true, use 2D Leith nonlinear eddy + !! viscosity. KH is the background value. + logical :: Modified_Leith !< If true, use extra component of Leith viscosity + !! to damp divergent flow. To use, still set Leith_Kh=.TRUE. + logical :: Leith_Ah !< If true, use a biharmonic form of 2D Leith + !! nonlinear eddy viscosity. AH is the background. + logical :: bound_Coriolis !< If true & SMAGORINSKY_AH is used, the biharmonic + !! viscosity is modified to include a term that + !! scales quadratically with the velocity shears. + logical :: use_Kh_bg_2d !< Read 2d background viscosity from a file. + real :: Kh_bg_min !< The minimum value allowed for Laplacian horizontal + !! viscosity [m2 s-1]. The default is 0.0 + logical :: use_land_mask !< 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 to maintain answers with legacy experiments + !! but should be changed to True for new experiments. + logical :: anisotropic !< If true, allow anisotropic component to the viscosity. + 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. + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: Kh_bg_xx + !< The background Laplacian viscosity at h points [m2 s-1]. + !! The actual viscosity may be the larger of this + !! viscosity and the Smagorinsky and Leith viscosities. + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: Kh_bg_2d + !< The background Laplacian viscosity at h points [m2 s-1]. + !! The actual viscosity may be the larger of this + !! viscosity and the Smagorinsky and Leith viscosities. + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: Ah_bg_xx + !< The background biharmonic viscosity at h points [m4 s-1]. + !! The actual viscosity may be the larger of this + !! viscosity and the Smagorinsky and Leith viscosities. + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: Biharm_Const2_xx + !< A constant relating the biharmonic viscosity to the + !! square of the velocity shear [m4 s]. This value is + !! set to be the magnitude of the Coriolis terms once the + !! velocity differences reach a value of order 1/2 MAXVEL. + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: reduction_xx + !< The amount by which stresses through h points are reduced + !! due to partial barriers. Nondimensional. real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: & - Kh_bg_xx, &! The background Laplacian viscosity at h points, in units - ! of m2 s-1. The actual viscosity may be the larger of this - ! viscosity and the Smagorinsky and Leith viscosities. - Kh_bg_2d, &! The background Laplacian viscosity at h points, in units - ! of m2 s-1. The actual viscosity may be the larger of this - ! viscosity and the Smagorinsky and Leith viscosities. - Ah_bg_xx, &! The background biharmonic viscosity at h points, in units - ! of m4 s-1. The actual viscosity may be the larger of this - ! viscosity and the Smagorinsky and Leith viscosities. - Kh_Max_xx, &! The maximum permitted Laplacian viscosity, m2 s-1. - Ah_Max_xx, &! The maximum permitted biharmonic viscosity, m4 s-1. - Biharm_Const2_xx,&! A constant relating the biharmonic viscosity to the - ! square of the velocity shear, in m4 s. This value is - ! set to be the magnitude of the Coriolis terms once the - ! velocity differences reach a value of order 1/2 MAXVEL. - - reduction_xx ! The amount by which stresses through h points are reduced - ! due to partial barriers. Nondimensional. - + Kh_Max_xx, & !< The maximum permitted Laplacian viscosity [m2 s-1]. + Ah_Max_xx, & !< The maximum permitted biharmonic viscosity [m4 s-1]. + n1n2_h, & !< Factor n1*n2 in the anisotropic direction tensor at h-points + n1n1_m_n2n2_h !< Factor n1**2-n2**2 in the anisotropic direction tensor at h-points + + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: Kh_bg_xy + !< The background Laplacian viscosity at q points [m2 s-1]. + !! The actual viscosity may be the larger of this + !! viscosity and the Smagorinsky and Leith viscosities. + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: Ah_bg_xy + !< The background biharmonic viscosity at q points [m4 s-1]. + !! The actual viscosity may be the larger of this + !! viscosity and the Smagorinsky and Leith viscosities. + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: Biharm_Const2_xy + !< A constant relating the biharmonic viscosity to the + !! square of the velocity shear [m4 s]. This value is + !! set to be the magnitude of the Coriolis terms once the + !! velocity differences reach a value of order 1/2 MAXVEL. + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: reduction_xy + !< The amount by which stresses through q points are reduced + !! due to partial barriers [nondim]. real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: & - Kh_bg_xy, &! The background Laplacian viscosity at q points, in units - ! of m2 s-1. The actual viscosity may be the larger of this - ! viscosity and the Smagorinsky and Leith viscosities. - Ah_bg_xy, &! The background biharmonic viscosity at q points, in units - ! of m4 s-1. The actual viscosity may be the larger of this - ! viscosity and the Smagorinsky and Leith viscosities. - Kh_Max_xy, &! The maximum permitted Laplacian viscosity, m2 s-1. - Ah_Max_xy, &! The maximum permitted biharmonic viscosity, m4 s-1. - Biharm_Const2_xy,&! A constant relating the biharmonic viscosity to the - ! square of the velocity shear, in m4 s. This value is - ! set to be the magnitude of the Coriolis terms once the - ! velocity differences reach a value of order 1/2 MAXVEL. - reduction_xy ! The amount by which stresses through q points are reduced - ! due to partial barriers. Nondimensional. - -! The following variables are precalculated combinations of metric terms. + Kh_Max_xy, & !< The maximum permitted Laplacian viscosity [m2 s-1]. + Ah_Max_xy, & !< The maximum permitted biharmonic viscosity [m4 s-1]. + n1n2_q, & !< Factor n1*n2 in the anisotropic direction tensor at q-points + n1n1_m_n2n2_q !< Factor n1**2-n2**2 in the anisotropic direction tensor at q-points + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: & - dx2h, dy2h, & ! dx^2 and dy^2 at h points, in m2 - dx_dyT, dy_dxT ! dx/dy and dy/dx at h points, nondim + dx2h, & !< Pre-calculated dx^2 at h points [m2] + dy2h, & !< Pre-calculated dy^2 at h points [m2] + dx_dyT, & !< Pre-calculated dx/dy at h points [nondim] + dy_dxT !< Pre-calculated dy/dx at h points [nondim] real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: & - dx2q, dy2q, & ! dx^2 and dy^2 at q points, in m2 - dx_dyBu, dy_dxBu ! dx/dy and dy/dx at q points, nondim + dx2q, & !< Pre-calculated dx^2 at q points [m2] + dy2q, & !< Pre-calculated dy^2 at q points [m2] + dx_dyBu, & !< Pre-calculated dx/dy at q points [nondim] + dy_dxBu !< Pre-calculated dy/dx at q points [nondim] real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: & - Idx2dyCu, Idxdy2u ! 1/(dx^2 dy) and 1/(dx dy^2) at u points, in m-3 + Idx2dyCu, & !< 1/(dx^2 dy) at u points [m-3] + Idxdy2u !< 1/(dx dy^2) at u points [m-3] real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: & - Idx2dyCv, Idxdy2v ! 1/(dx^2 dy) and 1/(dx dy^2) at v points, in m-3 + Idx2dyCv, & !< 1/(dx^2 dy) at v points [m-3] + Idxdy2v !< 1/(dx dy^2) at v points [m-3] -! The following variables are precalculated time-invariant combinations of -! parameters and metric terms. + ! The following variables are precalculated time-invariant combinations of + ! parameters and metric terms. real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: & - Laplac_Const_xx, & ! Laplacian metric-dependent constants (nondim) - Biharm_Const_xx, & ! Biharmonic metric-dependent constants (nondim) - Laplac3_Const_xx, & ! Laplacian metric-dependent constants (nondim) - Biharm5_Const_xx ! Biharmonic metric-dependent constants (nondim) + Laplac_Const_xx, & !< Laplacian metric-dependent constants [nondim] + Biharm_Const_xx, & !< Biharmonic metric-dependent constants [nondim] + Laplac3_Const_xx, & !< Laplacian metric-dependent constants [nondim] + Biharm5_Const_xx !< Biharmonic metric-dependent constants [nondim] real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: & - Laplac_Const_xy, & ! Laplacian metric-dependent constants (nondim) - Biharm_Const_xy, & ! Biharmonic metric-dependent constants (nondim) - Laplac3_Const_xy, & ! Laplacian metric-dependent constants (nondim) - Biharm5_Const_xy ! Biharmonic metric-dependent constants (nondim) + Laplac_Const_xy, & !< Laplacian metric-dependent constants [nondim] + Biharm_Const_xy, & !< Biharmonic metric-dependent constants [nondim] + Laplac3_Const_xy, & !< Laplacian metric-dependent constants [nondim] + Biharm5_Const_xy !< Biharmonic metric-dependent constants [nondim] - type(diag_ctrl), pointer :: diag ! structure to regulate diagnostic timing + type(diag_ctrl), pointer :: diag => NULL() !< structure to regulate diagnostics - ! diagnostic ids + !>@{ + !! Diagnostic id integer :: id_diffu = -1, id_diffv = -1 integer :: id_Ah_h = -1, id_Ah_q = -1 integer :: id_Kh_h = -1, id_Kh_q = -1 integer :: id_FrictWork = -1, id_FrictWorkIntz = -1 + !!@} end type hor_visc_CS contains -!> This subroutine determines the acceleration due to the -!! horizontal viscosity. A combination of biharmonic and Laplacian -!! forms can be used. The coefficient may either be a constant or -!! a shear-dependent form. The biharmonic is determined by twice -!! taking the divergence of an appropriately defined stress tensor. -!! The Laplacian is determined by doing so once. -!! To work, the following fields must be set outside of the usual -!! is to ie range before this subroutine is called: -!! v[is-2,is-1,ie+1,ie+2], u[is-2,is-1,ie+1,ie+2], and h[is-1,ie+1], -!! with a similarly sized halo in the y-direction. +!> Calculates the acceleration due to the horizontal viscosity. +!! +!! A combination of biharmonic and Laplacian forms can be used. The coefficient +!! may either be a constant or a shear-dependent form. The biharmonic is +!! determined by twice taking the divergence of an appropriately defined stress +!! tensor. The Laplacian is determined by doing so once. +!! +!! To work, the following fields must be set outside of the usual +!! is:ie range before this subroutine is called: +!! u[is-2:ie+2,js-2:je+2] +!! v[is-2:ie+2,js-2:je+2] +!! h[is-1:ie+1,js-1:je+1] subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, CS, OBC) 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(SZIB_(G),SZJ_(G),SZK_(G)), & - intent(in) :: u !< The zonal velocity, in m s-1. + intent(in) :: u !< The zonal velocity [m s-1]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & - intent(in) :: v !< The meridional velocity, in m s-1. + intent(in) :: v !< The meridional velocity [m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< Layer thicknesses, in H - !! (usually m or kg m-2). + intent(in) :: 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/s2) + !! along-coordinate stress tensor [m s-2] real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & intent(out) :: diffv !< Meridional acceleration due to convergence - !! of along-coordinate stress tensor (m/s2). + !! of along-coordinate stress tensor [m s-2]. type(MEKE_type), pointer :: MEKE !< Pointer to a structure containing fields !! 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 !< Pontrol structure returned by a previous !! call to hor_visc_init. - type(ocean_OBC_type), pointer, optional :: OBC !< Pointer to an open boundary condition type - -! Arguments: -! (in) u - zonal velocity (m/s) -! (in) v - meridional velocity (m/s) -! (in) h - layer thickness (m or kg m-2); h units are referred to as H. -! (out) diffu - zonal acceleration due to convergence of -! along-coordinate stress tensor (m/s2) -! (out) diffv - meridional acceleration due to convergence of -! along-coordinate stress tensor (m/s2) -! (inout) MEKE - pointer to a structure containing fields related to -! Mesoscale Eddy Kinetic Energy -! (in) VarMix - pointer to a structure with fields that specify the -! spatially variable viscosities -! (in) G - ocean grid structure -! (in) GV - The ocean's vertical grid structure. -! (in) CS - control structure returned by a previous call to -! hor_visc_init -! (in) OBC - pointer to an open boundary condition type - -! By R. Hallberg, August 1998 - November 1998. -! This subroutine determines the acceleration due to the -! horizontal viscosity. A combination of biharmonic and Laplacian -! forms can be used. The coefficient may either be a constant or -! a shear-dependent form. The biharmonic is determined by twice -! taking the divergence of an appropriately defined stress tensor. -! The Laplacian is determined by doing so once. -! To work, the following fields must be set outside of the usual -! is to ie range before this subroutine is called: -! v[is-2,is-1,ie+1,ie+2], u[is-2,is-1,ie+1,ie+2], and h[is-1,ie+1], -! with a similarly sized halo in the y-direction. - + type(ocean_OBC_type), optional, pointer :: OBC !< Pointer to an open boundary condition type + ! 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. + u0, & ! Laplacian of u [m-1 s-1] + h_u ! Thickness interpolated to u points [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJB_(G)) :: & - v0, & ! Laplacian of v (m-1 s-1) - h_v ! Thickness interpolated to v points, in H. + v0, & ! Laplacian of v [m-1 s-1] + h_v ! Thickness interpolated to v points [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G)) :: & - sh_xx, & ! 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) - bhstr_xx,& ! A copy of str_xx that only contains the biharmonic contribution (H m2 s-2) - div_xx, & ! horizontal divergence (du/dx + dv/dy) (1/sec) including metric terms - FrictWorkIntz ! depth integrated energy dissipated by lateral friction (W/m2) + sh_xx, & ! 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] + bhstr_xx,& ! A copy of str_xx that only contains the biharmonic contribution [H m2 s-2 ~> m3 s-2 or kg s-2] + div_xx, & ! horizontal divergence (du/dx + dv/dy) including metric terms [s-1] + FrictWorkIntz ! depth integrated energy dissipated by lateral friction [W m-2] real, dimension(SZIB_(G),SZJB_(G)) :: & - dvdx, dudy, & ! components in the shearing strain (s-1) - sh_xy, & ! horizontal shearing strain (du/dy + dv/dx) (1/sec) including metric terms - str_xy, & ! str_xy is the cross term in the stress tensor (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) (1/sec) including metric terms + dvdx, dudy, & ! components in the shearing strain [s-1] + sh_xy, & ! horizontal shearing strain (du/dy + dv/dx) including 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] + 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] real, dimension(SZI_(G),SZJB_(G)) :: & - vort_xy_dx, & ! x-derivative of vertical vorticity (d/dx(dv/dx - du/dy)) (m-1 sec-1) including metric terms - div_xx_dy ! y-derivative of horizontal divergence (d/dy(du/dx + dv/dy)) (m-1 sec-1) including metric terms + vort_xy_dx, & ! x-derivative of vertical vorticity (d/dx(dv/dx - du/dy)) including metric terms [m-1 s-1] + div_xx_dy ! y-derivative of horizontal divergence (d/dy(du/dx + dv/dy)) including metric terms [m-1 s-1] real, dimension(SZIB_(G),SZJ_(G)) :: & - vort_xy_dy, & ! y-derivative of vertical vorticity (d/dy(dv/dx - du/dy)) (m-1 sec-1) including metric terms - div_xx_dx ! x-derivative of horizontal divergence (d/dx(du/dx + dv/dy)) (m-1 sec-1) including metric terms + vort_xy_dy, & ! y-derivative of vertical vorticity (d/dy(dv/dx - du/dy)) including metric terms [m-1 s-1] + div_xx_dx ! x-derivative of horizontal divergence (d/dx(du/dx + dv/dy)) including metric terms [m-1 s-1] 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) + Ah_q, & ! biharmonic viscosity at corner points [m4 s-1] + Kh_q ! Laplacian viscosity at corner points [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) - FrictWork ! energy dissipated by lateral friction (W/m2) - - 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) + Ah_h, & ! biharmonic viscosity at thickness points [m4 s-1] + Kh_h, & ! Laplacian viscosity at thickness points [m2 s-1] + FrictWork ! energy dissipated by lateral friction [W m-2] + + 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 :: Vort_mag ! magnitude of the vorticity (1/s) - 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 :: Vort_mag ! magnitude of the vorticity [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). - 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 + ! points where masks are applied [H ~> m or kg m-2]. + real :: hq ! harmonic mean of the harmonic means of the u- & v- poing thicknesses, + ! [H ~> m or kg m-2]; This form guarantees that hq/hu < 4. + 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) (nondimensional) + ! point (h or q point) [nondim] real :: visc_bound_rem ! fraction of overall viscous bounds that - ! remain to be applied (nondim) + ! 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) + ! 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]. - logical :: rescale_Kh + logical :: rescale_Kh, legacy_bound logical :: find_FrictWork logical :: apply_OBC = .false. logical :: use_MEKE_Ku @@ -372,46 +302,44 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, CS, call MOM_error(FATAL, "MOM_hor_visc: VarMix%Res_fn_h and " //& "VarMix%Res_fn_q both need to be associated with Resoln_scaled_Kh.") endif + legacy_bound = (CS%Smagorinsky_Kh .or. CS%Leith_Kh) .and. & + (CS%bound_Kh .and. .not.CS%better_bound_Kh) + + ! Coefficient for modified Leith + if (CS%Modified_Leith) then + mod_Leith = 1.0 + else + mod_Leith = 0.0 + endif ! Toggle whether to use a Laplacian viscosity derived from MEKE use_MEKE_Ku = associated(MEKE%Ku) -!$OMP parallel do default(none) shared(Isq,Ieq,Jsq,Jeq,nz,CS,G,GV,u,v,is,js,ie,je,h, & -!$OMP rescale_Kh,VarMix,h_neglect,h_neglect3, & -!$OMP Kh_h,Ah_h,Kh_q,Ah_q,diffu,apply_OBC,OBC,diffv, & -!$OMP find_FrictWork,FrictWork,use_MEKE_Ku,MEKE) & -!$OMP private(u0, v0, sh_xx, str_xx, visc_bound_rem, & -!$OMP sh_xy, str_xy, Ah, Kh, AhSm, KhSm, dvdx, dudy, & -!$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, mod_Leith, & -!$OMP Shear_mag, h2uq, h2vq, hq, Kh_scale, hrat_min) + !$OMP parallel do default(none) shared(Isq,Ieq,Jsq,Jeq,nz,CS,G,GV,u,v,is,js,ie,je,h, & + !$OMP rescale_Kh,VarMix,h_neglect,h_neglect3, & + !$OMP Kh_h,Ah_h,Kh_q,Ah_q,diffu,apply_OBC,OBC,diffv, & + !$OMP find_FrictWork,FrictWork,use_MEKE_Ku,MEKE, & + !$OMP mod_Leith, legacy_bound) & + !$OMP private(u0, v0, sh_xx, str_xx, visc_bound_rem, & + !$OMP sh_xy, str_xy, Ah, Kh, AhSm, KhSm, dvdx, dudy, & + !$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, hq, Kh_scale, hrat_min) do k=1,nz -! This code uses boundary conditions that are consistent with -! free slip and no normal flow boundary conditions. The boundary -! conditions for the western boundary, for example, are: -! dv/dx = 0, d^3v/dx^3 = 0, u = 0, d^2u/dx^2 = 0 . -! The overall scheme is second order accurate. -! All of the metric terms are retained, and the repeated use of -! the symmetric stress tensor insures that no stress is applied with -! no flow or solid-body rotation, even with non-constant values of -! of the biharmonic viscosity. - -! The following are the forms of the horizontal tension and hori- -! shearing strain advocated by Smagorinsky (1993) and discussed in -! Griffies and Hallberg (MWR, 2000). + ! The following are the forms of the horizontal tension and horizontal + ! shearing strain advocated by Smagorinsky (1993) and discussed in + ! Griffies and Hallberg (2000). + + ! Calculate horizontal tension do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 sh_xx(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)) - & CS%DX_dyT(i,j)*(G%IdxCv(i,J) * v(i,J,k) - & G%IdxCv(i,J-1)*v(i,J-1,k))) - div_xx(i,j) = 0.5*((G%dyCu(I,j) * u(I,j,k) * (h(i+1,j,k)+h(i,j,k)) - & - G%dyCu(I-1,j) * u(I-1,j,k) * (h(i-1,j,k)+h(i,j,k)) ) + & - (G%dxCv(i,J) * v(i,J,k) * (h(i,j,k)+h(i,j+1,k)) - & - G%dxCv(i,J-1)*v(i,J-1,k)*(h(i,j,k)+h(i,j-1,k))))*G%IareaT(i,j)/ & - (h(i,j,k) + h_neglect) enddo ; enddo + ! Components for the shearing strain do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 dvdx(I,J) = CS%DY_dxBu(I,J)*(v(i+1,J,k)*G%IdyCv(i+1,J) - v(i,J,k)*G%IdyCv(i,J)) @@ -419,7 +347,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, CS, enddo ; enddo ! Interpolate the thicknesses to velocity points. - ! The extra wide halos are to accomodate the cross-corner-point projections + ! The extra wide halos are to accommodate the cross-corner-point projections ! in OBCs, which are not ordinarily be necessary, and might not be necessary ! even with OBCs if the accelerations are zeroed at OBC points, in which ! case the j-loop for h_u could collapse to j=js=1,je+1. -RWH @@ -433,7 +361,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, CS, else do j=js-2,je+2 ; do I=Isq-1,Ieq+1 h_u(I,j) = 0.5 * (h(i,j,k) + h(i+1,j,k)) - enddo; enddo + enddo ; enddo do J=Jsq-1,Jeq+1 ; do i=is-2,ie+2 h_v(i,J) = 0.5 * (h(i,j,k) + h(i,j+1,k)) enddo ; enddo @@ -443,13 +371,25 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, CS, ! thicknesses on open boundaries. if (apply_OBC) then ; do n=1,OBC%number_of_segments J = OBC%segment(n)%HI%JsdB ; I = OBC%segment(n)%HI%IsdB - if (OBC%zero_strain .or. OBC%freeslip_strain) then + if (OBC%zero_strain .or. OBC%freeslip_strain .or. OBC%computed_strain) then if (OBC%segment(n)%is_N_or_S .and. (J >= js-2) .and. (J <= Jeq+1)) then do I=OBC%segment(n)%HI%IsdB,OBC%segment(n)%HI%IedB if (OBC%zero_strain) then dvdx(I,J) = 0. ; dudy(I,J) = 0. elseif (OBC%freeslip_strain) then dudy(I,J) = 0. + elseif (OBC%computed_strain) then + if (OBC%segment(n)%direction == OBC_DIRECTION_N) then + dudy(I,J) = 2.0*CS%DX_dyBu(I,J)*(OBC%segment(n)%tangential_vel(I,J,k) - u(I,j,k))*G%IdxCu(I,j) + else + dudy(I,J) = 2.0*CS%DX_dyBu(I,J)*(u(I,j+1,k) - OBC%segment(n)%tangential_vel(I,J,k))*G%IdxCu(I,j+1) + endif + elseif (OBC%specified_strain) then + if (OBC%segment(n)%direction == OBC_DIRECTION_N) then + dudy(I,J) = CS%DX_dyBu(I,J)*OBC%segment(n)%tangential_grad(I,J,k)*G%IdxCu(I,j)*G%dxBu(I,J) + else + dudy(I,J) = CS%DX_dyBu(I,J)*OBC%segment(n)%tangential_grad(I,J,k)*G%IdxCu(I,j+1)*G%dxBu(I,J) + endif endif enddo elseif (OBC%segment(n)%is_E_or_W .and. (I >= is-2) .and. (I <= Ieq+1)) then @@ -458,6 +398,18 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, CS, dvdx(I,J) = 0. ; dudy(I,J) = 0. elseif (OBC%freeslip_strain) then dvdx(I,J) = 0. + elseif (OBC%computed_strain) then + if (OBC%segment(n)%direction == OBC_DIRECTION_E) then + dvdx(I,J) = 2.0*CS%DY_dxBu(I,J)*(OBC%segment(n)%tangential_vel(I,J,k) - v(i,J,k))*G%IdyCv(i,J) + else + dvdx(I,J) = 2.0*CS%DY_dxBu(I,J)*(v(i+1,J,k) - OBC%segment(n)%tangential_vel(I,J,k))*G%IdyCv(i+1,J) + endif + elseif (OBC%specified_strain) then + if (OBC%segment(n)%direction == OBC_DIRECTION_E) then + dvdx(I,J) = CS%DY_dxBu(I,J)*OBC%segment(n)%tangential_grad(I,J,k)*G%IdyCv(i,J)*G%dxBu(I,J) + else + dvdx(I,J) = CS%DY_dxBu(I,J)*OBC%segment(n)%tangential_grad(I,J,k)*G%IdyCv(i+1,J)*G%dxBu(I,J) + endif endif enddo endif @@ -522,37 +474,53 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, CS, endif enddo ; endif - if (CS%no_slip) then - do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 - sh_xy(I,J) = (2.0-G%mask2dBu(I,J)) * ( dvdx(I,J) + dudy(I,J) ) - enddo ; enddo - else - do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 - sh_xy(I,J) = G%mask2dBu(I,J) * ( dvdx(I,J) + dudy(I,J) ) + ! Calculate horizontal divergence (not from continuity) if needed. + ! h_u and h_v include modifications at OBCs from above. + if ((CS%Leith_Kh) .or. (CS%Leith_Ah)) then + do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 + div_xx(i,j) = ((G%dyCu(I ,j) * u(I ,j,k) * h_u(I ,j) - & + G%dyCu(I-1,j) * u(I-1,j,k) * h_u(I-1,j) ) + & + (G%dxCv(i,J ) * v(i,J ,k) * h_v(i,J ) - & + G%dxCv(i,J-1) * v(i,J-1,k) * h_v(i,J-1) ) )*G%IareaT(i,j)/ & + (h(i,j,k) + h_neglect) enddo ; enddo endif + ! Shearing strain (including no-slip boundary conditions at the 2-D land-sea mask). + ! dudy and dvdx include modifications at OBCs from above. if (CS%no_slip) then do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 - vort_xy(I,J) = (2.0-G%mask2dBu(I,J)) * ( dvdx(I,J) - dudy(I,J) ) + sh_xy(I,J) = (2.0-G%mask2dBu(I,J)) * ( dvdx(I,J) + dudy(I,J) ) enddo ; enddo else do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 - vort_xy(I,J) = G%mask2dBu(I,J) * ( dvdx(I,J) - dudy(I,J) ) + sh_xy(I,J) = G%mask2dBu(I,J) * ( dvdx(I,J) + dudy(I,J) ) enddo ; enddo endif -! Vorticity gradient - do J=js-2,Jeq+1 ; do I=is-1,Ieq+1 - vort_xy_dx(i,J) = CS%DY_dxBu(I,J)*(vort_xy(I,J)*G%IdyCu(I,j) - vort_xy(I-1,J)*G%IdyCu(I-1,j)) - enddo ; enddo + if ((CS%Leith_Kh) .or. (CS%Leith_Ah)) then + ! Calculate relative vorticity (including no-slip boundary conditions at the 2-D land-sea mask). + ! dudy and dvdx include modifications at OBCs from above. + if (CS%no_slip) then + do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 + vort_xy(I,J) = (2.0-G%mask2dBu(I,J)) * ( dvdx(I,J) - dudy(I,J) ) + enddo ; enddo + else + do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 + vort_xy(I,J) = G%mask2dBu(I,J) * ( dvdx(I,J) - dudy(I,J) ) + enddo ; enddo + endif - do J=js-1,Jeq+1 ; do I=is-2,Ieq+1 - vort_xy_dy(I,j) = CS%DX_dyBu(I,J)*(vort_xy(I,J)*G%IdxCv(i,J) - vort_xy(I,J-1)*G%IdxCv(i,J-1)) - enddo ; enddo + ! Vorticity gradient + do J=js-2,Jeq+1 ; do I=is-1,Ieq+1 + vort_xy_dx(i,J) = CS%DY_dxBu(I,J)*(vort_xy(I,J)*G%IdyCu(I,j) - vort_xy(I-1,J)*G%IdyCu(I-1,j)) + enddo ; enddo -! Divergence gradient - if ((CS%Leith_Kh) .or. (CS%Leith_Ah)) then + do J=js-1,Jeq+1 ; do I=is-2,Ieq+1 + vort_xy_dy(I,j) = CS%DX_dyBu(I,J)*(vort_xy(I,J)*G%IdxCv(i,J) - vort_xy(I,J-1)*G%IdxCv(i,J-1)) + enddo ; enddo + + ! Divergence gradient do j=js-1,Jeq+1 ; do I=Isq-1,Ieq+1 div_xx_dx(I,j) = G%IdxCu(I,j)*(div_xx(i+1,j) - div_xx(i,j)) enddo ; enddo @@ -562,14 +530,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, CS, enddo ; enddo endif -! Coefficient for modified Leith - if (CS%Modified_Leith) then - mod_Leith = 1.0 - else - mod_Leith = 0.0 - endif - -! Evaluate u0 = x.Div(Grad u) and v0 = y.Div( Grad u) + ! Evaluate u0 = x.Div(Grad u) and v0 = y.Div( Grad u) if (CS%biharmonic) then do j=js-1,Jeq+1 ; do I=Isq-1,Ieq+1 u0(I,j) = CS%IDXDY2u(I,j)*(CS%DY2h(i+1,j)*sh_xx(i+1,j) - CS%DY2h(i,j)*sh_xx(i,j)) + & @@ -617,23 +578,19 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, CS, if (CS%Laplacian) then ! Determine the Laplacian viscosity at h points, using the ! largest value from several parameterizations. - Kh_scale = 1.0 ; if (rescale_Kh) Kh_scale = VarMix%Res_fn_h(i,j) - KhSm = 0.0; KhLth = 0.0 - if ((CS%Smagorinsky_Kh) .or. (CS%Leith_Kh)) then - if (CS%Smagorinsky_Kh) & - KhSm = CS%LAPLAC_CONST_xx(i,j) * Shear_mag - if (CS%Leith_Kh) & - KhLth = CS%LAPLAC3_CONST_xx(i,j) * Vort_mag - Kh = Kh_scale * MAX(KhLth, MAX(CS%Kh_bg_xx(i,j), KhSm)) - if (CS%bound_Kh .and. .not.CS%better_bound_Kh) & - Kh = MIN(Kh, CS%Kh_Max_xx(i,j)) - else - Kh = Kh_scale * CS%Kh_bg_xx(i,j) - endif - - if (use_MEKE_Ku) then - Kh = Kh + MEKE%Ku(i,j) - endif + Kh = CS%Kh_bg_xx(i,j) ! Static (pre-computed) background viscosity + if (CS%Smagorinsky_Kh) Kh = max( Kh, CS%LAPLAC_CONST_xx(i,j) * Shear_mag ) + if (CS%Leith_Kh) Kh = max( Kh, CS%LAPLAC3_CONST_xx(i,j) * Vort_mag ) + ! All viscosity contributions above are subject to resolution scaling + if (rescale_Kh) Kh = VarMix%Res_fn_h(i,j) * Kh + ! 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 (CS%anisotropic) Kh = Kh + CS%Kh_aniso * ( 1. - CS%n1n2_h(i,j)**2 ) ! *Add* the tension component + ! of anisotropic viscosity + + ! Newer method of bounding for stability if (CS%better_bound_Kh) then if (Kh >= hrat_min*CS%Kh_Max_xx(i,j)) then visc_bound_rem = 0.0 @@ -651,9 +608,16 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, CS, str_xx(i,j) = 0.0 endif ! Laplacian + if (CS%anisotropic) then + ! Shearing-strain averaged to h-points + local_strain = 0.25 * ( (sh_xy(I,J) + sh_xy(I-1,J-1)) + (sh_xy(I-1,J) + sh_xy(I,J-1)) ) + ! *Add* the shear-strain contribution to the xx-component of stress + str_xx(i,j) = str_xx(i,j) - CS%Kh_aniso * CS%n1n2_h(i,j) * CS%n1n1_m_n2n2_h(i,j) * local_strain + endif + if (CS%biharmonic) then -! Determine the biharmonic viscosity at h points, using the -! largest value from several parameterizations. + ! Determine the biharmonic viscosity at h points, using the + ! largest value from several parameterizations. AhSm = 0.0; AhLth = 0.0 if ((CS%Smagorinsky_Ah) .or. (CS%Leith_Ah)) then if (CS%Smagorinsky_Ah) then @@ -669,9 +633,9 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, CS, 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)) - else - Ah = CS%Ah_bg_xx(i,j) - endif ! Smagorinsky_Ah or Leith_Ah + else + Ah = CS%Ah_bg_xx(i,j) + endif ! Smagorinsky_Ah or Leith_Ah if (CS%better_bound_Ah) then Ah = MIN(Ah, visc_bound_rem*hrat_min*CS%Ah_Max_xx(i,j)) @@ -740,8 +704,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, CS, h2uq = 4.0 * h_u(I,j) * h_u(I,j+1) h2vq = 4.0 * h_v(i,J) * h_v(i+1,J) -! hq = 2.0 * h2uq * h2vq / (h_neglect3 + (h2uq + h2vq) * & -! ((h(i,j,k) + h(i+1,j+1,k)) + (h(i,j+1,k) + h(i+1,j,k)))) + !hq = 2.0 * h2uq * h2vq / (h_neglect3 + (h2uq + h2vq) * & + ! ((h(i,j,k) + h(i+1,j+1,k)) + (h(i,j+1,k) + h(i+1,j,k)))) hq = 2.0 * h2uq * h2vq / (h_neglect3 + (h2uq + h2vq) * & ((h_u(I,j) + h_u(I,j+1)) + (h_v(i,J) + h_v(i+1,J)))) @@ -774,26 +738,22 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, CS, if (CS%Laplacian) then ! Determine the Laplacian viscosity at q points, using the ! largest value from several parameterizations. - Kh_scale = 1.0 ; if (rescale_Kh) Kh_scale = VarMix%Res_fn_q(I,J) - KhSm = 0.0; KhLth = 0.0 - if ((CS%Smagorinsky_Kh) .or. (CS%Leith_Kh)) then - if (CS%Smagorinsky_Kh) & - KhSm = CS%LAPLAC_CONST_xy(I,J) * Shear_mag - if (CS%Leith_Kh) & - KhLth = CS%LAPLAC3_CONST_xy(I,J) * Vort_mag - Kh = Kh_scale * MAX(MAX(CS%Kh_bg_xy(I,J), KhSm), KhLth) - if (CS%bound_Kh .and. .not.CS%better_bound_Kh) & - Kh = MIN(Kh, CS%Kh_Max_xy(I,J)) - else - Kh = Kh_scale * CS%Kh_bg_xy(I,J) - endif - if (use_MEKE_Ku) then + Kh = CS%Kh_bg_xy(i,j) ! Static (pre-computed) background viscosity + if (CS%Smagorinsky_Kh) Kh = max( Kh, CS%LAPLAC_CONST_xy(I,J) * Shear_mag ) + if (CS%Leith_Kh) Kh = max( Kh, CS%LAPLAC3_CONST_xy(I,J) * Vort_mag) + ! All viscosity contributions above are subject to resolution scaling + if (rescale_Kh) Kh = VarMix%Res_fn_q(i,j) * Kh + ! 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)) ) endif - ! Place a floor on the viscosity, if desired. - Kh = MAX(Kh,CS%Kh_bg_min) + if (CS%anisotropic) Kh = Kh + CS%Kh_aniso * CS%n1n2_q(I,J)**2 ! *Add* the shear component + ! of anisotropic viscosity + ! Newer method of bounding for stability if (CS%better_bound_Kh) then if (Kh >= hrat_min*CS%Kh_Max_xy(I,J)) then visc_bound_rem = 0.0 @@ -811,10 +771,17 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, CS, str_xy(I,J) = 0.0 endif ! Laplacian + if (CS%anisotropic) then + ! Horizontal-tension averaged to q-points + local_strain = 0.25 * ( (sh_xx(i,j) + sh_xx(i+1,j+1)) + (sh_xx(i+1,j) + sh_xx(i,j+1)) ) + ! *Add* the tension contribution to the xy-component of stress + str_xy(I,J) = str_xy(I,J) - CS%Kh_aniso * CS%n1n2_q(i,j) * CS%n1n1_m_n2n2_q(i,j) * local_strain + endif + if (CS%biharmonic) then ! Determine the biharmonic viscosity at q points, using the ! largest value from several parameterizations. - AhSm = 0.0; AhLth = 0.0 + AhSm = 0.0 ; AhLth = 0.0 if (CS%Smagorinsky_Ah .or. CS%Leith_Ah) then if (CS%Smagorinsky_Ah) then if (CS%bound_Coriolis) then @@ -853,8 +820,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, CS, endif enddo ; enddo + ! Evaluate 1/h x.Div(h Grad u) or the biharmonic equivalent. do j=js,je ; do I=Isq,Ieq -! Evaluate 1/h x.Div(h Grad u) or the biharmonic equivalent. diffu(I,j,k) = ((G%IdyCu(I,j)*(CS%DY2h(i,j) *str_xx(i,j) - & CS%DY2h(i+1,j)*str_xx(i+1,j)) + & G%IdxCu(I,j)*(CS%DX2q(I,J-1)*str_xy(I,J-1) - & @@ -875,7 +842,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, CS, enddo endif -! Evaluate 1/h y.Div(h Grad u) or the biharmonic equivalent. + ! Evaluate 1/h y.Div(h Grad u) or the biharmonic equivalent. do J=Jsq,Jeq ; do i=is,ie diffv(i,J,k) = ((G%IdyCv(i,J)*(CS%DY2q(I-1,J)*str_xy(I-1,J) - & CS%DY2q(I,J) *str_xy(I,J)) - & @@ -897,7 +864,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, CS, endif if (find_FrictWork) then ; do j=js,je ; do i=is,ie - ! Diagnose str_xx*d_x u - str_yy*d_y v + str_xy*(d_y u + d_x v) + ! Diagnose str_xx*d_x u - str_yy*d_y v + str_xy*(d_y u + d_x v) FrictWork(i,j,k) = GV%H_to_kg_m2 * ( & (str_xx(i,j)*(u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j) & -str_xx(i,j)*(v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j)) & @@ -962,7 +929,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, CS, enddo ! end of k loop -! Offer fields for diagnostic averaging. + ! Offer fields for diagnostic averaging. if (CS%id_diffu>0) call post_data(CS%id_diffu, diffu, CS%diag) if (CS%id_diffv>0) call post_data(CS%id_diffv, diffv, CS%diag) if (CS%id_FrictWork>0) call post_data(CS%id_FrictWork, FrictWork, CS%diag) @@ -981,66 +948,50 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, CS, call post_data(CS%id_FrictWorkIntz, FrictWorkIntz, CS%diag) endif - end subroutine horizontal_viscosity -!> This subroutine allocates space for and calculates static variables -!! used by this module. The metrics may be 0, 1, or 2-D arrays, -!! while fields like the background viscosities are 2-D arrays. -!! ALLOC is a macro defined in MOM_memory.h to either allocate -!! for dynamic memory, or do nothing when using static memory. +!> Allocates space for and calculates static variables used by horizontal_viscosity(). +!! hor_visc_init calculates and stores the values of a number of metric functions that +!! are used in horizontal_viscosity(). subroutine hor_visc_init(Time, G, param_file, diag, CS) - type(time_type), intent(in) :: Time !< current model time. + type(time_type), intent(in) :: Time !< Current model time. type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time !! parameters. - type(diag_ctrl), target, intent(inout) :: diag !< structure to regulate diagnostic output. - type(hor_visc_CS), pointer :: CS !< pointer to the control structure for this module - -! This subroutine allocates space for and calculates static variables -! used by this module. The metrics may be 0, 1, or 2-D arrays, -! while fields like the background viscosities are 2-D arrays. -! ALLOC is a macro defined in MOM_memory.h to either allocate -! for dynamic memory, or do nothing when using static memory. -! -! Arguments: -! (in) Time - current model time -! (in) G - ocean grid structure -! (in) param_file - structure to parse for model parameter values -! (in) diag - structure to regulate diagnostic output -! (in/out) CS - pointer to the control structure for this module - + type(diag_ctrl), target, intent(inout) :: diag !< Structure to regulate diagnostic output. + type(hor_visc_CS), pointer :: CS !< Pointer to the control structure for this module + ! Local variables real, dimension(SZIB_(G),SZJ_(G)) :: u0u, u0v real, dimension(SZI_(G),SZJB_(G)) :: v0u, v0v ! u0v is the Laplacian sensitivities to the v velocities - ! at u points, in m-2, with u0u, v0u, and v0v defined similarly. - real :: grid_sp_h2 ! Harmonic mean of the squares of the grid - real :: grid_sp_h3 ! Harmonic mean of the squares of the grid^(3/2) - real :: grid_sp_q2 ! spacings at h and q points (m2) - real :: grid_sp_q3 ! spacings at h and q points^(3/2) (m3) - real :: Kh_Limit ! A coefficient (1/s) used, along with the + ! at u points [m-2], with u0u, v0u, and v0v defined similarly. + real :: grid_sp_h2 ! Harmonic mean of the squares of the grid [m2] + real :: grid_sp_h3 ! Harmonic mean of the squares of the grid^(3/2) [m3] + real :: grid_sp_q2 ! spacings at h and q points [m2] + real :: grid_sp_q3 ! spacings at h and q points^(3/2) [m3] + real :: Kh_Limit ! A coefficient [s-1] used, along with the ! grid spacing, to limit Laplacian viscosity. real :: fmax ! maximum absolute value of f at the four - ! vorticity points around a thickness point (1/s) - real :: BoundCorConst ! constant (s2/m2) - real :: Ah_Limit ! coefficient (1/s) used, along with the + ! vorticity points around a thickness point [s-1] + real :: BoundCorConst ! A constant used when using viscosity to bound the Coriolis accelerations [s2 m-2] + real :: Ah_Limit ! coefficient [s-1] used, along with the ! grid spacing, to limit biharmonic viscosity - real :: Kh ! Lapacian horizontal viscosity (m2/s) - real :: Ah ! biharmonic horizontal viscosity (m4/s) - real :: Kh_vel_scale ! this speed (m/s) times grid spacing gives Lap visc - real :: Ah_vel_scale ! this speed (m/s) times grid spacing cubed gives bih visc + real :: Kh ! Lapacian horizontal viscosity [m2 s-1] + 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 :: Smag_Lap_const ! nondimensional Laplacian Smagorinsky constant real :: Smag_bi_const ! nondimensional biharmonic Smagorinsky constant real :: Leith_Lap_const ! nondimensional Laplacian Leith constant real :: Leith_bi_const ! nondimensional biharmonic Leith constant - real :: dt ! dynamics time step (sec) - real :: Idt ! inverse of dt (1/s) + real :: dt ! dynamics time step [s] + real :: Idt ! inverse of dt [s-1] real :: denom ! work variable; the denominator of a fraction - real :: maxvel ! largest permitted velocity components (m/s) + real :: maxvel ! largest permitted velocity components [m s-1] real :: bound_Cor_vel ! grid-scale velocity variations at which value ! the quadratically varying biharmonic viscosity - ! balances Coriolis acceleration (m/s) - real :: Kh_sin_lat ! Amplitude of latitudinally dependent viscosity (m2/s) + ! balances Coriolis acceleration [m s-1] + real :: Kh_sin_lat ! Amplitude of latitudinally dependent viscosity [m2 s-1] real :: Kh_pwr_of_sine ! Power used to raise sin(lat) when using Kh_sin_lat logical :: bound_Cor_def ! parameter setting of BOUND_CORIOLIS logical :: get_all ! If true, read and log all parameters, regardless of @@ -1049,6 +1000,8 @@ subroutine hor_visc_init(Time, G, param_file, diag, CS) character(len=64) :: inputdir, filename real :: deg2rad ! Converts degrees to radians real :: slat_fn ! sin(lat)**Kh_pwr_of_sine + real :: aniso_grid_dir(2) ! Vector (n1,n2) for anisotropic direction + integer :: aniso_mode ! Selects the mode for setting the anisotropic direction integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB integer :: i, j @@ -1080,6 +1033,8 @@ subroutine hor_visc_init(Time, G, param_file, diag, CS) CS%bound_Ah = .false. ; CS%better_bound_Ah = .false. ; CS%Smagorinsky_Ah = .false. ; CS%Leith_Ah = .false. CS%bound_Coriolis = .false. CS%Modified_Leith = .false. + CS%anisotropic = .false. + CS%dynamic_aniso = .false. Kh = 0.0 ; Ah = 0.0 @@ -1144,6 +1099,32 @@ subroutine hor_visc_init(Time, G, param_file, diag, CS) "If true, the Laplacian coefficient is locally limited \n"//& "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"//& + "horizontal viscosity.", default=.false.) + endif + if (CS%anisotropic .or. get_all) then + call get_param(param_file, mdl, "KH_ANISO", CS%Kh_aniso, & + "The background Laplacian anisotropic horizontal viscosity.", & + units = "m2 s-1", default=0.0) + call get_param(param_file, mdl, "ANISOTROPIC_MODE", aniso_mode, & + "Selects the mode for setting the direction of anistropy.\n"//& + "\t 0 - Points along the grid i-direction.\n"//& + "\t 1 - Points towards East.\n"//& + "\t 2 - Points along the flow direction, U/|U|.", & + default=0) + 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"//& + "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"//& + "to the spherical coordinates.", units = "nondim", fail_if_missing=.true.) + end select endif call get_param(param_file, mdl, "BIHARMONIC", CS%biharmonic, & @@ -1285,6 +1266,24 @@ subroutine hor_visc_init(Time, G, param_file, diag, CS) ALLOC_(CS%reduction_xx(isd:ied,jsd:jed)) ; CS%reduction_xx(:,:) = 0.0 ALLOC_(CS%reduction_xy(IsdB:IedB,JsdB:JedB)) ; CS%reduction_xy(:,:) = 0.0 + if (CS%anisotropic) then + ALLOC_(CS%n1n2_h(isd:ied,jsd:jed)) ; CS%n1n2_h(:,:) = 0.0 + ALLOC_(CS%n1n1_m_n2n2_h(isd:ied,jsd:jed)) ; CS%n1n1_m_n2n2_h(:,:) = 0.0 + ALLOC_(CS%n1n2_q(IsdB:IedB,JsdB:JedB)) ; CS%n1n2_q(:,:) = 0.0 + ALLOC_(CS%n1n1_m_n2n2_q(IsdB:IedB,JsdB:JedB)) ; CS%n1n1_m_n2n2_q(:,:) = 0.0 + select case (aniso_mode) + case (0) + call align_aniso_tensor_to_grid(CS, aniso_grid_dir(1), aniso_grid_dir(2)) + case (1) + ! call align_aniso_tensor_to_grid(CS, aniso_grid_dir(1), aniso_grid_dir(2)) + case (2) + CS%dynamic_aniso = .true. + case default + call MOM_error(FATAL, "MOM_hor_visc: "//& + "Runtime parameter ANISOTROPIC_MODE is out of range.") + end select + endif + if (CS%use_Kh_bg_2d) then ALLOC_(CS%Kh_bg_2d(isd:ied,jsd:jed)) ; CS%Kh_bg_2d(:,:) = 0.0 call get_param(param_file, mdl, "KH_BG_2D_FILENAME", filename, & @@ -1615,11 +1614,30 @@ subroutine hor_visc_init(Time, G, param_file, diag, CS) end subroutine hor_visc_init +!> Calculates factors in the anisotropic orientation tensor to be align with the grid. +!! With n1=1 and n2=0, this recovers the approach of Large et al, 2001. +subroutine align_aniso_tensor_to_grid(CS, n1, n2) + type(hor_visc_CS), pointer :: CS !< Control structure for horizontal viscosity + real, intent(in) :: n1 !< i-component of direction vector [nondim] + real, intent(in) :: n2 !< j-component of direction vector [nondim] + ! Local variables + real :: recip_n2_norm + + ! For normalizing n=(n1,n2) in case arguments are not a unit vector + recip_n2_norm = n1**2 + n2**2 + if (recip_n2_norm > 0.) recip_n2_norm = 1./recip_n2_norm + + CS%n1n2_h(:,:) = 2. * ( n1 * n2 ) * recip_n2_norm + CS%n1n2_q(:,:) = 2. * ( n1 * n2 ) * recip_n2_norm + CS%n1n1_m_n2n2_h(:,:) = ( n1 * n1 - n2 * n2 ) * recip_n2_norm + CS%n1n1_m_n2n2_q(:,:) = ( n1 * n1 - n2 * n2 ) * recip_n2_norm + +end subroutine align_aniso_tensor_to_grid + +!> Deallocates any variables allocated in hor_visc_init. subroutine hor_visc_end(CS) -! This subroutine deallocates any variables allocated in hor_visc_init. -! Argument: CS - The control structure returned by a previous call to -! hor_visc_init. - type(hor_visc_CS), pointer :: CS + type(hor_visc_CS), pointer :: CS !< The control structure returned by a + !! previous call to hor_visc_init. if (CS%Laplacian .or. CS%biharmonic) then DEALLOC_(CS%dx2h) ; DEALLOC_(CS%dx2q) ; DEALLOC_(CS%dy2h) ; DEALLOC_(CS%dy2q) @@ -1657,8 +1675,316 @@ subroutine hor_visc_end(CS) DEALLOC_(CS%Biharm5_Const_xx) ; DEALLOC_(CS%Biharm5_Const_xy) endif endif + if (CS%anisotropic) then + DEALLOC_(CS%n1n2_h) + DEALLOC_(CS%n1n2_q) + DEALLOC_(CS%n1n1_m_n2n2_h) + DEALLOC_(CS%n1n1_m_n2n2_q) + endif deallocate(CS) end subroutine hor_visc_end + +!> \namespace mom_hor_visc +!! +!! This module contains the subroutine horizontal_viscosity() that calculates the +!! effects of horizontal viscosity, including parameterizations of the value of +!! the viscosity itself. horizontal_viscosity() calculates the acceleration due to +!! some combination of a biharmonic viscosity and a Laplacian viscosity. Either or +!! both may use a coefficient that depends on the shear and strain of the flow. +!! All metric terms are retained. The Laplacian is calculated as the divergence of +!! a stress tensor, using the form suggested by Smagorinsky (1993). The biharmonic +!! is calculated by twice applying the divergence of the stress tensor that is +!! used to calculate the Laplacian, but without the dependence on thickness in the +!! first pass. This form permits a variable viscosity, and indicates no +!! acceleration for either resting fluid or solid body rotation. +!! +!! The form of the viscous accelerations is discussed extensively in Griffies and +!! Hallberg (2000), and the implementation here follows that discussion closely. +!! We use the notation of Smith and McWilliams (2003) with the exception that the +!! isotropic viscosity is \f$\kappa_h\f$. +!! +!! \section section_horizontal_viscosity Horizontal viscosity in MOM +!! +!! In general, the horizontal stress tensor can be written as +!! \f[ +!! {\bf \sigma} = +!! \begin{pmatrix} +!! \frac{1}{2} \left( \sigma_D + \sigma_T \right) & \frac{1}{2} \sigma_S \\\\ +!! \frac{1}{2} \sigma_S & \frac{1}{2} \left( \sigma_D - \sigma_T \right) +!! \end{pmatrix} +!! \f] +!! where \f$\sigma_D\f$, \f$\sigma_T\f$ and \f$\sigma_S\f$ are stresses associated with +!! invariant factors in the strain-rate tensor. For a Newtonian fluid, the stress +!! tensor is usually linearly related to the strain-rate tensor. The horizontal +!! strain-rate tensor is +!! \f[ +!! \dot{\bf e} = +!! \begin{pmatrix} +!! \frac{1}{2} \left( \dot{e}_D + \dot{e}_T \right) & \frac{1}{2} \dot{e}_S \\\\ +!! \frac{1}{2} \dot{e}_S & \frac{1}{2} \left( \dot{e}_D - \dot{e}_T \right) +!! \end{pmatrix} +!! \f] +!! where \f$\dot{e}_D = \partial_x u + \partial_y v\f$ is the horizontal divergence, +!! \f$\dot{e}_T = \partial_x u - \partial_y v\f$ is the horizontal tension, and +!! \f$\dot{e}_S = \partial_y u + \partial_x v\f$ is the horizontal shear strain. +!! +!! The trace of the stress tensor, \f$tr(\bf \sigma) = \sigma_D\f$, is usually +!! absorbed into the pressure and only the deviatoric stress tensor considered. +!! From here on, we drop \f$\sigma_D\f$. The trace of the strain tensor, \f$tr(\bf e) = +!! \dot{e}_D\f$ is non-zero for horizontally divergent flow but only enters the +!! stress tensor through \f$\sigma_D\f$ and so we will drop \f$\sigma_D\f$ from +!! calculations of the strain tensor in the code. Therefore the horizontal stress +!! tensor can be considered to be +!! \f[ +!! {\bf \sigma} = +!! \begin{pmatrix} +!! \frac{1}{2} \sigma_T & \frac{1}{2} \sigma_S \\\\ +!! \frac{1}{2} \sigma_S & - \frac{1}{2} \sigma_T +!! \end{pmatrix} +!! .\f] +!! +!! The stresses above are linearly related to the strain through a viscosity +!! coefficient, \f$\kappa_h\f$: +!! \f{eqnarray*}{ +!! \sigma_T & = & 2 \kappa_h \dot{e}_T \\\\ +!! \sigma_S & = & 2 \kappa_h \dot{e}_S +!! . +!! \f} +!! +!! The viscosity \f$\kappa_h\f$ may either be a constant or variable. For example, +!! \f$\kappa_h\f$ may vary with the shear, as proposed by Smagorinsky (1993). +!! +!! The accelerations resulting form the divergence of the stress tensor are +!! \f{eqnarray*}{ +!! \hat{\bf x} \cdot \left( \nabla \cdot {\bf \sigma} \right) +!! & = & +!! \partial_x \left( \frac{1}{2} \sigma_T \right) +!! + \partial_y \left( \frac{1}{2} \sigma_S \right) +!! \\\\ +!! & = & +!! \partial_x \left( \kappa_h \dot{e}_T \right) +!! + \partial_y \left( \kappa_h \dot{e}_S \right) +!! \\\\ +!! \hat{\bf y} \cdot \left( \nabla \cdot {\bf \sigma} \right) +!! & = & +!! \partial_x \left( \frac{1}{2} \sigma_S \right) +!! + \partial_y \left( \frac{1}{2} \sigma_T \right) +!! \\\\ +!! & = & +!! \partial_x \left( \kappa_h \dot{e}_S \right) +!! + \partial_y \left( - \kappa_h \dot{e}_T \right) +!! . +!! \f} +!! +!! The form of the Laplacian viscosity in general coordinates is: +!! \f{eqnarray*}{ +!! \hat{\bf x} \cdot \left( \nabla \cdot \sigma \right) +!! & = & +!! \frac{1}{h} \left[ \partial_x \left( \kappa_h h \dot{e}_T \right) +!! + \partial_y \left( \kappa_h h \dot{e}_S \right) \right] +!! \\\\ +!! \hat{\bf y} \cdot \left( \nabla \cdot \sigma \right) +!! & = & +!! \frac{1}{h} \left[ \partial_x \left( \kappa_h h \dot{e}_S \right) +!! - \partial_y \left( \kappa_h h \dot{e}_T \right) \right] +!! . +!! \f} +!! +!! \subsection section_laplacian_viscosity_coefficient Laplacian viscosity coefficient +!! +!! The horizontal viscosity coefficient, \f$\kappa_h\f$, can have multiple components. +!! The isotropic components are: +!! - A uniform background component, \f$\kappa_{bg}\f$. +!! - A constant but spatially variable 2D map, \f$\kappa_{2d}(x,y)\f$. +!! - A ''MICOM'' viscosity, \f$U_\nu \Delta(x,y)\f$, which uses a constant +!! velocity scale, \f$U_\nu\f$ and a measure of the grid-spacing \f$\Delta(x,y)^2 = +!! \frac{2 \Delta x^2 \Delta y^2}{\Delta x^2 + \Delta y^2}\f$. +!! - A function of +!! latitude, \f$\kappa_{\phi}(x,y) = \kappa_{\pi/2} |\sin(\phi)|^n\f$. +!! - A dynamic Smagorinsky viscosity, \f$\kappa_{Sm}(x,y,t) = C_{Sm} \Delta^2 \sqrt{\dot{e}_T^2 + \dot{e}_S^2}\f$. +!! - A dynamic Leith viscosity, \f$\kappa_{Lth}(x,y,t) = +!! C_{Lth} \Delta^3 \sqrt{|\nabla \zeta|^2 + |\nabla \dot{e}_D|^2}\f$. +!! +!! A maximum stable viscosity, \f$\kappa_{max}(x,y)\f$ is calculated based on the +!! grid-spacing and time-step and used to clip calculated viscosities. +!! +!! The static components of \f$\kappa_h\f$ are first combined as follows: +!! \f[ +!! \kappa_{static} = \min \left[ \max\left( +!! \kappa_{bg}, +!! U_\nu \Delta(x,y), +!! \kappa_{2d}(x,y), +!! \kappa_\phi(x,y) +!! \right) +!! , \kappa_{max}(x,y) \right] +!! \f] +!! and stored in the module control structure as variables Kh_bg_xx and +!! Kh_bg_xy for the tension (h-points) and shear (q-points) components +!! respectively. +!! +!! The full viscosity includes the dynamic components as follows: +!! \f[ +!! \kappa_h(x,y,t) = r(\Delta,L_d) +!! \max \left( \kappa_{static}, \kappa_{Sm}, \kappa_{Lth} \right) +!! \f] +!! where \f$r(\Delta,L_d)\f$ is a resolution function. +!! +!! The dynamic Smagorinsky and Leith viscosity schemes are exclusive with each +!! other. +!! +!! \subsection section_viscous_boundary_conditions Viscous boundary conditions +!! +!! Free slip boundary conditions have been coded, although no slip boundary +!! conditions can be used with the Laplacian viscosity based on the 2D land-sea +!! mask. For a western boundary, for example, the boundary conditions with the +!! biharmonic operator would be written as: +!! \f[ +!! \partial_x v = 0 ; \partial_x^3 v = 0 ; u = 0 ; \partial_x^2 u = 0 , +!! \f] +!! while for a Laplacian operator, they are simply +!! \f[ +!! \partial_x v = 0 ; u = 0 . +!! \f] +!! These boundary conditions are largely dictated by the use of an Arakawa +!! C-grid and by the varying layer thickness. +!! +!! \subsection section_anisotropic_viscosity Anisotropic viscosity +!! +!! Large et al., 2001, proposed enhancing viscosity in a particular direction and the +!! approach was generalized in Smith and McWilliams, 2003. We use the second form of their +!! two coefficient anisotropic viscosity (section 4.3). We also replace their +!! \f$A^\prime\f$ nd $D$ such that \f$2A^\prime = 2 \kappa_h + D\f$ and +!! \f$\kappa_a = D\f$ so that \f$\kappa_h\f$ can be considered the isotropic +!! viscosity and \f$\kappa_a=D\f$ can be consider the anisotropic viscosity. The +!! direction of anisotropy is defined by a unit vector \f$\hat{\bf +!! n}=(n_1,n_2)\f$. +!! +!! The contributions to the stress tensor are +!! \f[ +!! \begin{pmatrix} +!! \sigma_T \\\\ \sigma_S +!! \end{pmatrix} +!! = +!! \left[ +!! \begin{pmatrix} +!! 2 \kappa_h + \kappa_a & 0 \\\\ +!! 0 & 2 \kappa_h +!! \end{pmatrix} +!! + 2 \kappa_a n_1 n_2 +!! \begin{pmatrix} +!! - 2 n_1 n_2 & n_1^2 - n_2^2 \\\\ +!! n_1^2 - n_2^2 & 2 n_1 n_2 +!! \end{pmatrix} +!! \right] +!! \begin{pmatrix} +!! \dot{e}_T \\\\ \dot{e}_S +!! \end{pmatrix} +!! \f] +!! Dissipation of kinetic energy requires \f$\kappa_h \geq 0\f$ and \f$2 \kappa_h + \kappa_a \geq 0\f$. +!! Note that when anisotropy is aligned with the x-direction, \f$n_1 = \pm 1\f$, then +!! \f$n_2 = 0\f$ and the cross terms vanish. The accelerations in this aligned limit +!! with constant coefficients become +!! \f{eqnarray*}{ +!! \hat{\bf x} \cdot \nabla \cdot {\bf \sigma} +!! & = & +!! \partial_x \left( \left( \kappa_h + \frac{1}{2} \kappa_a \right) \dot{e}_T \right) +!! + \partial_y \left( \kappa_h \dot{e}_S \right) +!! \\\\ +!! & = & +!! \left( \kappa_h + \kappa_a \right) \partial_{xx} u +!! + \kappa_h \partial_{yy} u +!! - \frac{1}{2} \kappa_a \partial_x \left( \partial_x u + \partial_y v \right) +!! \\\\ +!! \hat{\bf y} \cdot \nabla \cdot {\bf \sigma} +!! & = & +!! \partial_x \left( \kappa_h \dot{e}_S \right) +!! - \partial_y \left( \left( \kappa_h + \frac{1}{2} \kappa_a \right) \dot{e}_T \right) +!! \\\\ +!! & = & +!! \kappa_h \partial_{xx} v +!! + \left( \kappa_h + \kappa_a \right) \partial_{yy} v +!! - \frac{1}{2} \kappa_a \partial_y \left( \partial_x u + \partial_y v \right) +!! \f} +!! which has contributions akin to a negative divergence damping (a divergence +!! enhancement?) but which is weaker than the enhanced tension terms by half. +!! +!! \subsection section_viscous_discretization Discretization +!! +!! The horizontal tension, \f$\dot{e}_T\f$, is stored in variable sh_xx and +!! discretized as +!! \f[ +!! \dot{e}_T +!! = \frac{\Delta y}{\Delta x} \delta_i \left( \frac{1}{\Delta y} u \right) +!! - \frac{\Delta x}{\Delta y} \delta_j \left( \frac{1}{\Delta x} v \right) +!! . +!! \f] +!! The horizontal divergent strain, \f$\dot{e}_D\f$, is stored in variable +!! div_xx and discretized as +!! \f[ +!! \dot{e}_D +!! = \frac{1}{h A} \left( \delta_i \left( \overline{h}^i \Delta y \, u \right) +!! + \delta_j \left( \overline{h}^j\Delta x \, v \right) \right) +!! . +!! \f] +!! Note that for expediency this is the exact discretization used in the +!! continuity equation. +!! +!! The horizontal shear strain, \f$\dot{e}_S\f$, is stored in variable sh_xy +!! and discretized as +!! \f[ +!! \dot{e}_S = v_x + u_y +!! \f] +!! where +!! \f{align*}{ +!! v_x &= \frac{\Delta y}{\Delta x} \delta_i \left( \frac{1}{\Delta y} v \right) \\\\ +!! u_y &= \frac{\Delta x}{\Delta y} \delta_j \left( \frac{1}{\Delta x} u \right) +!! \f} +!! which are calculated separately so that no-slip or free-slip boundary +!! conditions can be applied to \f$v_x\f$ and \f$u_y\f$ where appropriate. +!! +!! The tendency for the x-component of the divergence of stress is stored in +!! variable diffu and discretized as +!! \f[ +!! \hat{\bf x} \cdot \left( \nabla \cdot {\bf \sigma} \right) = +!! \frac{1}{A \overline{h}^i} \left( +!! \frac{1}{\Delta y} \delta_i \left( h \Delta y^2 \kappa_h \dot{e}_T \right) + +!! \frac{1}{\Delta x} \delta_j \left( \tilde{h}^{ij} \Delta x^2 \kappa_h \dot{e}_S \right) +!! \right) +!! . +!! \f] +!! +!! The tendency for the y-component of the divergence of stress is stored in +!! variable diffv and discretized as +!! \f[ +!! \hat{\bf y} \cdot \left( \nabla \cdot {\bf \sigma} \right) = +!! \frac{1}{A \overline{h}^j} \left( +!! \frac{1}{\Delta y} \delta_i \left( \tilde{h}^{ij} \Delta y^2 A_M \dot{e}_S \right) +!! - \frac{1}{\Delta x} \delta_j \left( h \Delta x^2 A_M \dot{e}_T \right) +!! \right) +!! . +!! \f] +!! +!! \subsection section_viscous_refs References +!! +!! Griffies, S.M., and Hallberg, R.W., 2000: Biharmonic friction with a +!! Smagorinsky-like viscosity for use in large-scale eddy-permitting ocean models. +!! Monthly Weather Review, 128(8), 2935-2946. +!! https://doi.org/10.1175/1520-0493(2000)128%3C2935:BFWASL%3E2.0.CO;2 +!! +!! Large, W.G., Danabasoglu, G., McWilliams, J.C., Gent, P.R. and Bryan, F.O., +!! 2001: Equatorial circulation of a global ocean climate model with +!! anisotropic horizontal viscosity. +!! Journal of Physical Oceanography, 31(2), pp.518-536. +!! https://doi.org/10.1175/1520-0485(2001)031%3C0518:ECOAGO%3E2.0.CO;2 +!! +!! Smagorinsky, J., 1993: Some historical remarks on the use of nonlinear +!! viscosities. Large eddy simulation of complex engineering and geophysical +!! flows, 1, 69-106. +!! +!! Smith, R.D., and McWilliams, J.C., 2003: Anisotropic horizontal viscosity for +!! ocean models. Ocean Modelling, 5(2), 129-156. +!! https://doi.org/10.1016/S1463-5003(02)00016-1 + end module MOM_hor_visc diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index fe91d988ac..4052f948a3 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -1,30 +1,10 @@ +!> Subroutines that use the ray-tracing equations to propagate the internal tide energy density. +!! +!! \author Benjamin Mater & Robert Hallberg, 2015 module MOM_internal_tides ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Benjamin Mater & Robert Hallberg, 2015 * -!* * -!* This program contains the subroutines that use the ray-tracing * -!* equations to propagate the internal tide energy density. * -!* * -!* Macros written all in capital letters are defined in MOM_memory.h. * -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q * -!* j+1 > o > o > At ^: v, tauy * -!* j x ^ x ^ x At >: u, taux * -!* j > o > o > At o: h, fluxes. * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** - use MOM_debugging, only : is_NaN use MOM_diag_mediator, only : post_data, query_averaging_enabled, diag_axis_init use MOM_diag_mediator, only : register_diag_field, diag_ctrl, safe_alloc_ptr @@ -38,18 +18,12 @@ module MOM_internal_tides use MOM_io, only : slasher, vardesc, MOM_read_data use MOM_restart, only : register_restart_field, MOM_restart_CS, restart_init, save_restart use MOM_spatial_means, only : global_area_mean -use MOM_time_manager, only : time_type, operator(+), operator(/), operator(-) -use MOM_time_manager, only : get_time, get_date, set_time, set_date -use MOM_time_manager, only : time_type_to_real +use MOM_time_manager, only : time_type, time_type_to_real, operator(+), operator(/), operator(-) +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface, thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use MOM_wave_structure, only: wave_structure_init, wave_structure, wave_structure_CS -! Forcing is a structure containing pointers to the forcing fields -! which may be used to drive MOM. All fluxes are positive downward. -! Surface is a structure containing pointers to various fields that -! may be used describe the surface state of MOM. - !use, intrinsic :: IEEE_ARITHMETIC implicit none ; private @@ -60,105 +34,97 @@ module MOM_internal_tides public internal_tides_init, internal_tides_end public get_lowmode_loss +!> This control structure has parameters for the MOM_internal_tides module type, public :: int_tide_CS ; private - logical :: do_int_tides ! If true, use the internal tide code. - integer :: nFreq = 0 - integer :: nMode = 1 - integer :: nAngle = 24 - integer :: energized_angle = -1 - logical :: corner_adv ! If true, use a corner advection rather than PPM. - logical :: upwind_1st ! If true, use a first-order upwind scheme. - logical :: simple_2nd ! If true, use a simple second order (arithmetic - ! mean) interpolation of the edge values instead - ! of the higher order interpolation. - logical :: vol_CFL ! If true, use the ratio of the open face lengths - ! to the tracer cell areas when estimating CFL - ! numbers. Without aggress_adjust, the default is - ! false; it is always true with. - logical :: use_PPMang ! If true, use PPM for advection of energy in - ! angular space. + logical :: do_int_tides !< If true, use the internal tide code. + integer :: nFreq = 0 !< The number of internal tide frequency bands + integer :: nMode = 1 !< The number of internal tide vertical modes + integer :: nAngle = 24 !< The number of internal tide angular orientations + integer :: energized_angle = -1 !< If positive, only this angular band is energized for debugging purposes + logical :: corner_adv !< If true, use a corner advection rather than PPM. + logical :: upwind_1st !< If true, use a first-order upwind scheme. + logical :: simple_2nd !< If true, use a simple second order (arithmetic mean) interpolation + !! of the edge values instead of the higher order interpolation. + logical :: vol_CFL !< If true, use the ratio of the open face lengths to the tracer cell + !! areas when estimating CFL numbers. Without aggress_adjust, + !! the default is false; it is always true with aggress_adjust. + logical :: use_PPMang !< If true, use PPM for advection of energy in angular space. real, allocatable, dimension(:,:) :: refl_angle - ! local coastline/ridge/shelf angles read from file + !< local coastline/ridge/shelf angles read from file ! (could be in G control structure) - real :: nullangle = -999.9 ! placeholder value in cell with no reflection + real :: nullangle = -999.9 !< placeholder value in cells with no reflection real, allocatable, dimension(:,:) :: refl_pref - ! partial reflection coeff for each ``coast cell" + !< partial reflection coeff for each "coast cell" ! (could be in G control structure) logical, allocatable, dimension(:,:) :: refl_pref_logical - ! true if reflecting cell with partial reflection + !< true if reflecting cell with partial reflection ! (could be in G control structure) logical, allocatable, dimension(:,:) :: refl_dbl - ! identifies reflection cells where double reflection - ! is possible (i.e. ridge cells) + !< identifies reflection cells where double reflection + !! is possible (i.e. ridge cells) ! (could be in G control structure) real, allocatable, dimension(:,:,:,:) :: cp - ! horizontal phase speed [m s-1] + !< horizontal phase speed [m s-1] real, allocatable, dimension(:,:,:,:,:) :: TKE_leak_loss - ! energy lost due to misc background processes [W m-2] + !< energy lost due to misc background processes [W m-2] real, allocatable, dimension(:,:,:,:,:) :: TKE_quad_loss - ! energy lost due to quadratic bottom drag [W m-2] + !< energy lost due to quadratic bottom drag [W m-2] real, allocatable, dimension(:,:,:,:,:) :: TKE_Froude_loss - ! energy lost due to wave breaking [W m-2] + !< energy lost due to wave breaking [W m-2] real, allocatable, dimension(:,:) :: TKE_itidal_loss_fixed - ! fixed part of the energy lost due to small-scale drag - ! [kg m-2] here; will be multiplied by N and En to get - ! into [W m-2] + !< fixed part of the energy lost due to small-scale drag + !! [kg Z-2 ~> kg m-2] here; will be multiplied by N and En to get into [W m-2] real, allocatable, dimension(:,:,:,:,:) :: TKE_itidal_loss - ! energy lost due to small-scale wave drag [W m-2] - real, allocatable, dimension(:,:) :: tot_leak_loss, tot_quad_loss, & - tot_itidal_loss, tot_Froude_loss, tot_allprocesses_loss - ! energy loss rates summed over angle, freq, and mode - real :: q_itides ! fraction of local dissipation (nondimensional) - real :: En_sum ! global sum of energy for use in debugging - type(time_type),pointer :: Time - ! The current model time - character(len=200) :: inputdir - ! directory to look for coastline angle file - real :: decay_rate ! A constant rate at which internal tide energy is - ! lost to the interior ocean internal wave field. - real :: cdrag ! The bottom drag coefficient for MEKE (non-dim). + !< energy lost due to small-scale wave drag [W m-2] + real, allocatable, dimension(:,:) :: tot_leak_loss !< Energy loss rates due to misc bakground processes, + !! summed over angle, frequency and mode [W m-2] + real, allocatable, dimension(:,:) :: tot_quad_loss !< Energy loss rates due to quadratic bottom drag, + !! summed over angle, frequency and mode [W m-2] + real, allocatable, dimension(:,:) :: tot_itidal_loss !< Energy loss rates due to small-scale drag, + !! summed over angle, frequency and mode [W m-2] + real, allocatable, dimension(:,:) :: tot_Froude_loss !< Energy loss rates due to wave breaking, + !! summed over angle, frequency and mode [W m-2] + real, allocatable, dimension(:,:) :: tot_allprocesses_loss !< Energy loss rates due to all processes, + !! summed over angle, frequency and mode [W m-2] + real :: q_itides !< fraction of local dissipation [nondim] + real :: En_sum !< global sum of energy for use in debugging + type(time_type), pointer :: Time => NULL() !< A pointer to the model's clock. + character(len=200) :: inputdir !< directory to look for coastline angle file + real :: decay_rate !< A constant rate at which internal tide energy is + !! lost to the interior ocean internal wave field. + real :: cdrag !< The bottom drag coefficient [nondim]. logical :: apply_background_drag - ! If true, apply a drag due to background processes as a sink. + !< If true, apply a drag due to background processes as a sink. logical :: apply_bottom_drag - ! If true, apply a quadratic bottom drag as a sink. + !< If true, apply a quadratic bottom drag as a sink. logical :: apply_wave_drag - ! If true, apply scattering due to small-scale - ! roughness as a sink. + !< If true, apply scattering due to small-scale roughness as a sink. logical :: apply_Froude_drag - ! If true, apply wave breaking as a sink. - real, dimension(:,:,:,:,:), pointer :: & - En ! The internal wave energy density as a function of - ! (i,j,angle,frequency,mode) - real, dimension(:,:,:), pointer :: & - En_restart ! The internal wave energy density as a function of - ! (i,j,angle); temporary for restart - real, allocatable, dimension(:) :: & - frequency ! The frequency of each band. - - real :: int_tide_source_x ! delete later - ! X Location of generation site - ! for internal tide for testing - real :: int_tide_source_y ! delete later - ! Y Location of generation site - ! for internal tide for testing - - type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the - ! timing of diagnostic output. - type(wave_structure_CS), pointer :: wave_structure_CSp => NULL() - + !< If true, apply wave breaking as a sink. + real, dimension(:,:,:,:,:), pointer :: En => NULL() + !< The internal wave energy density as a function of (i,j,angle,frequency,mode) + real, dimension(:,:,:), pointer :: En_restart => NULL() + !< 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() + !< A pointer to the wave_structure module control structure + + !>@{ Diag handles ! Diag handles relevant to all modes, frequencies, and angles - integer :: id_itide_drag = -1 + integer :: id_tot_En = -1, id_TKE_itidal_input = -1, id_itide_drag = -1 integer :: id_refl_pref = -1, id_refl_ang = -1, id_land_mask = -1 integer :: id_dx_Cv = -1, id_dy_Cu = -1 - integer :: id_TKE_itidal_input = -1 ! Diag handles considering: sums over all modes, frequencies, and angles - integer :: id_tot_En = -1, & - id_tot_leak_loss = -1, & - id_tot_quad_loss = -1, & - id_tot_itidal_loss = -1, & - id_tot_Froude_loss = -1, & - id_tot_allprocesses_loss = -1 + integer :: id_tot_leak_loss = -1, id_tot_quad_loss = -1, id_tot_itidal_loss = -1 + integer :: id_tot_Froude_loss = -1, id_tot_allprocesses_loss = -1 ! Diag handles considering: all modes & freqs; summed over angles integer, allocatable, dimension(:,:) :: & id_En_mode, & @@ -170,54 +136,42 @@ module MOM_internal_tides integer, allocatable, dimension(:,:) :: & id_En_ang_mode, & id_itidal_loss_ang_mode + !!@} end type int_tide_CS +!> A structure with the active energy loop bounds. type :: loop_bounds_type ; private + !>@{ The active loop bounds integer :: ish, ieh, jsh, jeh + !!@} end type loop_bounds_type contains -!> This subroutine calls other subroutines in this file that are needed to -!! refract, propagate, and dissipate energy density of the internal tide. +!> Calls subroutines in this file that are needed to refract, propagate, +!! and dissipate energy density of the internal tide. subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & - G, GV, CS) + 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(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< Layer thicknesses, in H - !! (usually m or kg m-2). + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< Pointer to thermodynamic variables !! (needed for wave structure). real, dimension(SZI_(G),SZJ_(G)), intent(in) :: TKE_itidal_input !< The energy input to the - !! internal waves, in W m-2. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: vel_btTide !< Barotropic velocity read - !! from file, in m s-1. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Nb !< Near-bottom buoyancy frequency, in s-1. + !! internal waves [W m-2]. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: vel_btTide !< Barotropic velocity read + !! from file [m s-1]. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Nb !< Near-bottom buoyancy frequency [s-1]. real, intent(in) :: dt !< Length of time over which these fluxes - !! will be applied, in s. - type(int_tide_CS), pointer :: CS !< A pointer to the control structure - !! returned by a previous call to - !! int_tide_init. + !! will be applied [s]. + type(int_tide_CS), pointer :: CS !< The control structure returned by a + !! previous call to int_tide_init. real, dimension(SZI_(G),SZJ_(G),CS%nMode), & - intent(in) :: cn - - ! This subroutine calls other subroutines in this file that are needed to - ! refract, propagate, and dissipate energy density of the internal tide. - ! - ! Arguments: - ! (in) h - Layer thickness, in m or kg m-2 (needed for wave structure). - ! (in) tv - Pointer to thermodynamic variables (needed for wave structure). - ! (in) cn - Internal gravity wave speeds of modes, in m s-1. - ! (in) TKE_itidal_input - The energy input to the internal waves, in W m-2. - ! (in) vel_btTide - Barotropic velocity read from file, in m s-1 - ! (in) Nb - Near-bottom buoyancy frequency, in s-1 - ! (in) dt - Length of time over which these fluxes will be applied, in s. - ! (in) G - The ocean's grid structure. - ! (in) GV - The ocean's vertical grid structure. - ! (in) CS - A pointer to the control structure returned by a previous - ! call to int_tide_init. + intent(in) :: cn !< The internal wave speeds of each mode [m s-1]. + ! Local variables real, dimension(SZI_(G),SZJ_(G),2) :: & test real, dimension(SZI_(G),SZJ_(G),CS%nFreq,CS%nMode) :: & @@ -239,6 +193,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & real :: En_new, En_check ! for debugging real :: En_initial, Delta_E_check ! for debugging real :: TKE_Froude_loss_check, TKE_Froude_loss_tot ! for debugging + character(len=160) :: mesg ! The text of an error message integer :: a, m, fr, i, j, is, ie, js, je, isd, ied, jsd, jed, nAngle, nzm integer :: id_g, jd_g ! global (decomp-invar) indices (for debugging) type(group_pass_type), save :: pass_test, pass_En @@ -284,11 +239,11 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & do j=jsd,jed ; do i=isd,ied ; test(i,j,1) = 1.0 ; test(i,j,2) = 0.0 ; enddo ; enddo do m=1,CS%nMode ; do fr=1,CS%nFreq call create_group_pass(pass_En, CS%En(:,:,:,fr,m), G%domain) - enddo; enddo + enddo ; enddo call create_group_pass(pass_test, test(:,:,1), test(:,:,2), G%domain, stagger=AGRID) call start_group_pass(pass_test, G%domain) - ! Apply half the refraction.***************************************************** + ! Apply half the refraction. do m=1,CS%nMode ; do fr=1,CS%nFreq call refract(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), 0.5*dt, G, CS%nAngle, CS%use_PPMang) enddo ; enddo @@ -298,10 +253,11 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & do j=js,je ; do i=is,ie if (CS%En(i,j,a,fr,m)<0.0) then id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging - print *, 'After first refraction: En<0.0 at ig=', id_g, ', jg=', jd_g - print *, 'En=',CS%En(i,j,a,fr,m) - print *, 'Setting En to zero'; CS%En(i,j,a,fr,m) = 0.0 - !stop + write(mesg,*) 'After first refraction: En<0.0 at ig=', id_g, ', jg=', jd_g, & + 'En=',CS%En(i,j,a,fr,m) + call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg)) + CS%En(i,j,a,fr,m) = 0.0 +! call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") endif enddo ; enddo enddo ; enddo ; enddo @@ -313,7 +269,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & ! Rotate points in the halos as necessary. call correct_halo_rotation(CS%En, test, G, CS%nAngle) - ! Propagate the waves.*********************************************************** + ! Propagate the waves. do m=1,CS%NMode ; do fr=1,CS%Nfreq call propagate(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), dt, G, CS, CS%NAngle) enddo ; enddo @@ -323,34 +279,18 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & do j=js,je ; do i=is,ie if (CS%En(i,j,a,fr,m)<0.0) then id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset - CS%En(i,j,a,fr,m) = 0.0 - if(abs(CS%En(i,j,a,fr,m))>1.0)then! only print if large - print *, 'After propagation: En<0.0 at ig=', id_g, ', jg=', jd_g - print *, 'En=',CS%En(i,j,a,fr,m) - print *, 'Setting En to zero' - !stop + if (abs(CS%En(i,j,a,fr,m))>1.0) then ! only print if large + write(mesg,*) 'After propagation: En<0.0 at ig=', id_g, ', jg=', jd_g, & + 'En=', CS%En(i,j,a,fr,m) + call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg)) +! call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") endif + CS%En(i,j,a,fr,m) = 0.0 endif enddo ; enddo enddo ; enddo ; enddo - !! Test if energy has passed coast for debugging only; delete later - !do j=js,je - ! do i=is,ie - ! id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset - ! if (id_g == 106 .and. jd_g == 55 ) then - !print *, 'After propagation:' - !print *, 'En_O =', CS%En(i,j,:,1,1), 'refl_angle=', CS%refl_angle(i,j) - !print *, 'En_W =', CS%En(i-1,j,:,1,1), 'refl_angle=', CS%refl_angle(i-1,j) - !print *, 'En_NW =', CS%En(i-1,j+1,:,1,1), 'refl_angle=', CS%refl_angle(i-1,j+1) - !print *, 'En_N =', CS%En(i,j+1,:,1,1), 'refl_angle=', CS%refl_angle(i,j+1) - !print *, 'En_NE =', CS%En(i+1,j+1,:,1,1), 'refl_angle=', CS%refl_angle(i+1,j+1) - !print *, 'En_E =', CS%En(i+1,j,:,1,1), 'refl_angle=', CS%refl_angle(i+1,j) - ! endif - ! enddo - ! enddo - - ! Apply the other half of the refraction.**************************************** + ! Apply the other half of the refraction. do m=1,CS%NMode ; do fr=1,CS%Nfreq call refract(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), 0.5*dt, G, CS%NAngle, CS%use_PPMang) enddo ; enddo @@ -360,13 +300,16 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & do j=js,je ; do i=is,ie if (CS%En(i,j,a,fr,m)<0.0) then id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging - print *, 'After second refraction: En<0.0 at ig=', id_g, ', jg=', jd_g - !stop + write(mesg,*) 'After second refraction: En<0.0 at ig=', id_g, ', jg=', jd_g, & + 'En=',CS%En(i,j,a,fr,m) + call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg)) + CS%En(i,j,a,fr,m) = 0.0 +! call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") endif enddo ; enddo enddo ; enddo ; enddo - ! Apply various dissipation mechanisms.****************************************** + ! Apply various dissipation mechanisms. if (CS%apply_background_drag .or. CS%apply_bottom_drag & .or. CS%apply_wave_drag .or. CS%apply_Froude_drag & .or. (CS%id_tot_En > 0)) then @@ -394,8 +337,11 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & do j=js,je ; do i=is,ie if (CS%En(i,j,a,fr,m)<0.0) then id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging - print *, 'After leak loss: En<0.0 at ig=', id_g, ', jg=', jd_g - !stop + write(mesg,*) 'After leak loss: En<0.0 at ig=', id_g, ', jg=', jd_g, & + 'En=',CS%En(i,j,a,fr,m) + call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg), all_print=.true.) + CS%En(i,j,a,fr,m) = 0.0 +! call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") endif enddo ; enddo enddo ; enddo ; enddo @@ -403,7 +349,8 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & ! Extract the energy for mixing due to bottom drag------------------------------- if (CS%apply_bottom_drag) then do j=jsd,jed ; do i=isd,ied - I_D_here = 1.0 / max(G%bathyT(i,j), 1.0) + ! Note the 1 m dimensional scale here. Should this be a parameter? + I_D_here = 1.0 / (US%Z_to_m*max(G%bathyT(i,j), 1.0*US%m_to_Z)) drag_scale(i,j) = CS%cdrag * sqrt(max(0.0, vel_btTide(i,j)**2 + & tot_En(i,j) * I_rho0 * I_D_here)) * I_D_here enddo ; enddo @@ -419,7 +366,11 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & do j=js,je ; do i=is,ie if (CS%En(i,j,a,fr,m)<0.0) then id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging - print *, 'After bottom loss: En<0.0 at ig=', id_g, ', jg=', jd_g + write(mesg,*) 'After bottom loss: En<0.0 at ig=', id_g, ', jg=', jd_g, & + 'En=',CS%En(i,j,a,fr,m) + call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg), all_print=.true.) + CS%En(i,j,a,fr,m) = 0.0 +! call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") !stop endif enddo ; enddo @@ -431,7 +382,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & if (CS%apply_wave_drag .or. CS%apply_Froude_drag) then do m=1,CS%NMode ; do fr=1,CS%Nfreq ! Calculate modal structure for given mode and frequency - call wave_structure(h, tv, G, GV, cn(:,:,m), m, CS%frequency(fr), & + call wave_structure(h, tv, G, GV, US, cn(:,:,m), m, CS%frequency(fr), & CS%wave_structure_CSp, tot_En_mode(:,:,fr,m), full_halos=.true.) ! Pick out near-bottom and max horizontal baroclinic velocity values at each point do j=jsd,jed ; do i=isd,ied @@ -439,30 +390,13 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & nzm = CS%wave_structure_CSp%num_intfaces(i,j) Ub(i,j,fr,m) = CS%wave_structure_CSp%Uavg_profile(i,j,nzm) Umax(i,j,fr,m) = maxval(CS%wave_structure_CSp%Uavg_profile(i,j,1:nzm)) - !! for debugging print profile, etc. Delete later - !if(id_g .eq. 260 .and. & - ! jd_g .eq. 50 .and. & - ! tot_En_mode(i,j,1,1)>500.0) then - ! print *, 'Profiles for mode ',m,' and frequency ',fr - ! print *, 'id_g=', id_g, 'jd_g=', jd_g - ! print *, 'c',m,'=', cn(i,j,m) - ! print *, 'nzm=', nzm - ! print *, 'z=', CS%wave_structure_CSp%z_depths(i,j,1:nzm) - ! print *, 'N2=', CS%wave_structure_CSp%N2(i,j,1:nzm) - ! print *, 'Ub=', Ub(i,j,fr,m) - ! print *, 'Umax=', Umax(i,j,fr,m) - ! print *, 'Upro=', CS%wave_structure_CSp%Uavg_profile(i,j,1:nzm) - ! print *, 'Wpro=', CS%wave_structure_CSp%W_profile(i,j,1:nzm) - ! print *, 'En',m,'=', tot_En_mode(i,j,fr,m) - ! if (m==3) stop - !endif ! for debug - delete later enddo ; enddo ! i-loop, j-loop enddo ; enddo ! fr-loop, m-loop endif ! apply_wave or _Froude_drag (Ub or Umax needed) ! Finally, apply loss if (CS%apply_wave_drag) then ! Calculate loss rate and apply loss over the time step - call itidal_lowmode_loss(G, CS, Nb, Ub, CS%En, CS%TKE_itidal_loss_fixed, & + call itidal_lowmode_loss(G, US, CS, Nb, Ub, CS%En, CS%TKE_itidal_loss_fixed, & CS%TKE_itidal_loss, dt, full_halos=.false.) endif ! Check for En<0 - for debugging, delete later @@ -470,8 +404,11 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & do j=js,je ; do i=is,ie if (CS%En(i,j,a,fr,m)<0.0) then id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging - print *, 'After wave drag loss: En<0.0 at ig=', id_g, ', jg=', jd_g - !stop + write(mesg,*) 'After wave drag loss: En<0.0 at ig=', id_g, ', jg=', jd_g, & + 'En=',CS%En(i,j,a,fr,m) + call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg), all_print=.true.) + CS%En(i,j,a,fr,m) = 0.0 +! call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") endif enddo ; enddo enddo ; enddo ; enddo @@ -495,7 +432,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & ! Dissipate energy if Fr>1; done here with an arbitrary time scale if (Fr2_max > 1.0) then En_initial = sum(CS%En(i,j,:,fr,m)) ! for debugging - ! Calculate effective decay rate (s-1) if breaking occurs over a time step + ! Calculate effective decay rate [s-1] if breaking occurs over a time step loss_rate = (1/Fr2_max - 1.0)/dt do a=1,CS%nAngle ! Determine effective dissipation rate (Wm-2) @@ -506,10 +443,11 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & ! Re-scale (reduce) energy due to breaking CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m)/Fr2_max ! Check (for debugging only) - if (abs(En_new - En_check) > 1e-10) then - call MOM_error(WARNING, "MOM_internal_tides: something's wrong with Fr-breaking.") - print *, "En_new=", En_new - print *, "En_check=", En_check + if (abs(En_new - En_check) > 1e-10) then + call MOM_error(WARNING, "MOM_internal_tides: something is wrong with Fr-breaking.", & + all_print=.true.) + write(mesg,*) "En_new=", En_new , "En_check=", En_check + call MOM_error(WARNING, "MOM_internal_tides: "//trim(mesg), all_print=.true.) endif enddo ! Check (for debugging) @@ -517,9 +455,11 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & TKE_Froude_loss_check = abs(Delta_E_check)/dt TKE_Froude_loss_tot = sum(CS%TKE_Froude_loss(i,j,:,fr,m)) if (abs(TKE_Froude_loss_check - TKE_Froude_loss_tot) > 1e-10) then - call MOM_error(WARNING, "MOM_internal_tides: something's wrong with Fr energy update.") - print *, "TKE_Froude_loss_check=", TKE_Froude_loss_check - print *, "TKE_Froude_loss_tot=", TKE_Froude_loss_tot + call MOM_error(WARNING, "MOM_internal_tides: something is wrong with Fr energy update.", & + all_print=.true.) + write(mesg,*) "TKE_Froude_loss_check=", TKE_Froude_loss_check, & + "TKE_Froude_loss_tot=", TKE_Froude_loss_tot + call MOM_error(WARNING, "MOM_internal_tides: "//trim(mesg), all_print=.true.) endif endif ! Fr2>1 endif ! Kmag2>0 @@ -532,7 +472,11 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & do j=js,je ; do i=is,ie if (CS%En(i,j,a,fr,m)<0.0) then id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset - print *, 'After Froude loss: En<0.0 at ig=', id_g, ', jg=', jd_g + write(mesg,*) 'After Froude loss: En<0.0 at ig=', id_g, ', jg=', jd_g, & + 'En=',CS%En(i,j,a,fr,m) + call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg), all_print=.true.) + CS%En(i,j,a,fr,m) = 0.0 +! call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") !stop endif enddo ; enddo @@ -540,7 +484,6 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & ! Check for energy conservation on computational domain.************************* do m=1,CS%NMode ; do fr=1,CS%Nfreq - !print *, 'sum_En: mode(',m,'), freq(',fr,'):' call sum_En(G,CS,CS%En(:,:,:,fr,m),'prop_int_tide') enddo ; enddo @@ -637,82 +580,69 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & end subroutine propagate_int_tide -!> This subroutine checks for energy conservation on computational domain +!> Checks for energy conservation on computational domain subroutine sum_En(G, CS, En, label) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(int_tide_CS), pointer :: CS - real, dimension(G%isd:G%ied,G%jsd:G%jed,CS%NAngle), intent(in) :: En - character(len=*), intent(in) :: label - - ! This subroutine checks for energy conservation on computational domain + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(int_tide_CS), pointer :: CS !< The control structure returned by a + !! previous call to int_tide_init. + real, dimension(G%isd:G%ied,G%jsd:G%jed,CS%NAngle), & + intent(in) :: En !< The energy density of the internal tides [J m-2]. + character(len=*), intent(in) :: label !< A label to use in error messages + ! Local variables integer :: m,fr,a real :: En_sum, tmpForSumming, En_sum_diff, En_sum_pdiff - integer :: seconds - real :: Isecs_per_day = 1.0 / 86400.0 + character(len=160) :: mesg ! The text of an error message real :: days - call get_time(CS%Time, seconds) - days = real(seconds) * Isecs_per_day - - En_sum = 0.0; + En_sum = 0.0 tmpForSumming = 0.0 do a=1,CS%nAngle tmpForSumming = global_area_mean(En(:,:,a),G)*G%areaT_global En_sum = En_sum + tmpForSumming enddo En_sum_diff = En_sum - CS%En_sum - if (CS%En_sum .ne. 0.0) then + if (CS%En_sum /= 0.0) then En_sum_pdiff= (En_sum_diff/CS%En_sum)*100.0 else - En_sum_pdiff= 0.0; + En_sum_pdiff= 0.0 endif CS%En_sum = En_sum !! Print to screen !if (is_root_pe()) then - ! print *, label,':','days =', days - ! print *, 'En_sum=', En_sum - ! print *, 'En_sum_diff=', En_sum_diff - ! print *, 'Percent change=', En_sum_pdiff, '%' - ! !if (abs(En_sum_pdiff) > 1.0) then ; stop ; endif + ! days = time_type_to_real(CS%Time) / 86400.0 + ! write(mesg,*) trim(label)//': days =', days, ', En_sum=', En_sum, & + ! ', En_sum_diff=', En_sum_diff, ', Percent change=', En_sum_pdiff, '%' + ! call MOM_mesg(mesg) + !if (is_root_pe() .and. (abs(En_sum_pdiff) > 1.0)) & + ! call MOM_error(FATAL, "Run stopped due to excessive internal tide energy change.") !endif end subroutine sum_En -!> This subroutine calculates the energy lost from the propagating internal tide due to +!> Calculates the energy lost from the propagating internal tide due to !! scattering over small-scale roughness along the lines of Jayne & St. Laurent (2001). -subroutine itidal_lowmode_loss(G, CS, Nb, Ub, En, TKE_loss_fixed, TKE_loss, dt, full_halos) +subroutine itidal_lowmode_loss(G, US, CS, Nb, Ub, En, TKE_loss_fixed, TKE_loss, dt, full_halos) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(int_tide_CS), pointer :: CS + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(int_tide_CS), pointer :: CS !< The control structure returned by a + !! previous call to int_tide_init. real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(in) :: Nb !< Near-bottom stratification, in s-1. + intent(in) :: Nb !< Near-bottom stratification [s-1]. real, dimension(G%isd:G%ied,G%jsd:G%jed,CS%nFreq,CS%nMode), & - intent(inout) :: Ub !< Rms (over one period) near-bottom horizontal - !! mode velocity , in m s-1. + intent(inout) :: Ub !< RMS (over one period) near-bottom horizontal + !! mode velocity [m s-1]. real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(in) :: TKE_loss_fixed !< Fixed part of energy loss, - !! in kg m-2 (rho*kappa*h^2). + intent(in) :: TKE_loss_fixed !< Fixed part of energy loss [kg Z-2 ~> kg m-2] + !! (rho*kappa*h^2). real, dimension(G%isd:G%ied,G%jsd:G%jed,CS%NAngle,CS%nFreq,CS%nMode), & - intent(inout) :: En !< Energy density of the internal waves, in J m-2. + intent(inout) :: En !< Energy density of the internal waves [J m-2]. real, dimension(G%isd:G%ied,G%jsd:G%jed,CS%NAngle,CS%nFreq,CS%nMode), & - intent(out) :: TKE_loss !< Energy loss rate, in W m-2 + intent(out) :: TKE_loss !< Energy loss rate [W m-2] !! (q*rho*kappa*h^2*N*U^2). - real, intent(in) :: dt !< Time increment, in s. + real, intent(in) :: dt !< Time increment [s]. logical,optional, intent(in) :: full_halos !< If true, do the calculation over the !! entirecomputational domain. - - ! This subroutine calculates the energy lost from the propagating internal tide due to - ! scattering over small-scale roughness along the lines of Jayne & St. Laurent (2001). - ! - ! Arguments: - ! (in) Nb - near-bottom stratification, in s-1. - ! (in) Ub - rms (over one period) near-bottom horizontal mode velocity , in m s-1. - ! (inout) En - energy density of the internal waves, in J m-2. - ! (in) TKE_loss_fixed - fixed part of energy loss, in kg m-2 (rho*kappa*h^2) - ! (out) TKE_loss - energy loss rate, in W m-2 (q*rho*kappa*h^2*N*U^2) - ! (in) dt - time increment, in s - ! (in,opt) full_halos - If true, do the calculation over the entire - ! computational domain. - + ! Local variables integer :: j,i,m,fr,a, is, ie, js, je real :: En_tot ! energy for a given mode, frequency, and point summed over angles real :: TKE_loss_tot ! dissipation for a given mode, frequency, and point summed over angles @@ -720,7 +650,7 @@ subroutine itidal_lowmode_loss(G, CS, Nb, Ub, En, TKE_loss_fixed, TKE_loss, dt, real :: frac_per_sector ! fraction of energy in each wedge real :: q_itides ! fraction of energy actually lost to mixing (remainder, 1-q, is ! assumed to stay in propagating mode for now - BDM) - real :: loss_rate ! approximate loss rate for implicit calc, s-1 + real :: loss_rate ! approximate loss rate for implicit calc [s-1] real, parameter :: En_negl = 1e-30 ! negilibly small number to prevent division by zero is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -740,7 +670,7 @@ subroutine itidal_lowmode_loss(G, CS, Nb, Ub, En, TKE_loss_fixed, TKE_loss, dt, enddo ! Calculate TKE loss rate; units of [W m-2] here. - TKE_loss_tot = q_itides * TKE_loss_fixed(i,j) * Nb(i,j) * Ub(i,j,fr,m)**2 + TKE_loss_tot = q_itides * US%Z_to_m**2 * TKE_loss_fixed(i,j) * Nb(i,j) * Ub(i,j,fr,m)**2 ! Update energy remaining (this is a pseudo implicit calc) ! (E(t+1)-E(t))/dt = -TKE_loss(E(t+1)/E(t)), which goes to zero as E(t+1) goes to zero @@ -761,11 +691,11 @@ subroutine itidal_lowmode_loss(G, CS, Nb, Ub, En, TKE_loss_fixed, TKE_loss, dt, ! do a=1,CS%nAngle ! frac_per_sector = En(i,j,a,fr,m)/En_tot ! TKE_loss(i,j,a,fr,m) = frac_per_sector*TKE_loss_tot - ! if(TKE_loss(i,j,a,fr,m)*dt <= En(i,j,a,fr,m))then + ! if (TKE_loss(i,j,a,fr,m)*dt <= En(i,j,a,fr,m))then ! En(i,j,a,fr,m) = En(i,j,a,fr,m) - TKE_loss(i,j,a,fr,m)*dt ! else ! call MOM_error(WARNING, "itidal_lowmode_loss: energy loss greater than avalable, "// & - ! " setting En to zero.") + ! " setting En to zero.", all_print=.true.) ! En(i,j,a,fr,m) = 0.0 ! endif ! enddo @@ -780,53 +710,41 @@ end subroutine itidal_lowmode_loss !> This subroutine extracts the energy lost from the propagating internal which has !> been summed across all angles, frequencies, and modes for a given mechanism and location. +!! !> It can be called from another module to get values from this module's (private) CS. subroutine get_lowmode_loss(i,j,G,CS,mechanism,TKE_loss_sum) - integer, intent(in) :: i,j - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(int_tide_CS), pointer :: CS - character(len=*), intent(in) :: mechanism - real, intent(out) :: TKE_loss_sum !< Total energy loss rate due to specified - !! mechanism, in W m-2. - - ! This subroutine extracts the energy lost from the propagating internal which has - ! been summed across all angles, frequencies, and modes for a given mechanism and location. - ! It can be called from another module to get values from this module's (private) CS. - ! - ! Arguments: - ! (out) TKE_loss_sum - total energy loss rate due to specified mechanism, in W m-2. - - if(mechanism == 'LeakDrag') TKE_loss_sum = CS%tot_leak_loss(i,j) ! not used for mixing yet - if(mechanism == 'QuadDrag') TKE_loss_sum = CS%tot_quad_loss(i,j) ! not used for mixing yet - if(mechanism == 'WaveDrag') TKE_loss_sum = CS%tot_itidal_loss(i,j) ! currently used for mixing - if(mechanism == 'Froude') TKE_loss_sum = CS%tot_Froude_loss(i,j) ! not used for mixing yet + integer, intent(in) :: i !< The i-index of the value to be reported. + integer, intent(in) :: j !< The j-index of the value to be reported. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(int_tide_CS), pointer :: CS !< The control structure returned by a + !! previous call to int_tide_init. + character(len=*), intent(in) :: mechanism !< The named mechanism of loss to return + real, intent(out) :: TKE_loss_sum !< Total energy loss rate due to specified + !! mechanism [W m-2]. + + if (mechanism == 'LeakDrag') TKE_loss_sum = CS%tot_leak_loss(i,j) ! not used for mixing yet + if (mechanism == 'QuadDrag') TKE_loss_sum = CS%tot_quad_loss(i,j) ! not used for mixing yet + if (mechanism == 'WaveDrag') TKE_loss_sum = CS%tot_itidal_loss(i,j) ! currently used for mixing + if (mechanism == 'Froude') TKE_loss_sum = CS%tot_Froude_loss(i,j) ! not used for mixing yet end subroutine get_lowmode_loss -!> This subroutine does refraction on the internal waves at a single frequency. +!> Implements refraction on the internal waves at a single frequency. subroutine refract(En, cn, freq, dt, G, NAngle, use_PPMang) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - integer, intent(in) :: NAngle + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + integer, intent(in) :: NAngle !< The number of wave orientations in the + !! discretized wave energy spectrum. real, dimension(G%isd:G%ied,G%jsd:G%jed,NAngle), & - intent(inout) :: En !< The internal gravity wave energy density as a - !! function of space and angular resolution, - !! in J m-2 radian-1. + intent(inout) :: En !< The internal gravity wave energy density as a + !! function of space and angular resolution, + !! [J m-2 radian-1]. real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(in) :: cn !< Baroclinic mode speed, in m s-1. - real, intent(in) :: freq !< Wave frequency, in s-1. - real, intent(in) :: dt !< Time step, in s. - logical, intent(in) :: use_PPMang !< If true, use PPM for advection rather - !! than upwind. - ! This subroutine does refraction on the internal waves at a single frequency. - - ! Arguments: - ! (inout) En - the internal gravity wave energy density as a function of space - ! and angular resolution, in J m-2 radian-1. - ! (in) cn - baroclinic mode speed, in m s-1 - ! (in) freq - wave frequency, in s-1 - ! (in) dt - time step, in s - ! (in) use_PPMang - if true, use PPM for advection rather than upwind - + intent(in) :: cn !< Baroclinic mode speed [m s-1]. + real, intent(in) :: freq !< Wave frequency [s-1]. + real, intent(in) :: dt !< Time step [s]. + logical, intent(in) :: use_PPMang !< If true, use PPM for advection rather + !! than upwind. + ! Local variables integer, parameter :: stencil = 2 real, dimension(SZI_(G),1-stencil:NAngle+stencil) :: & En2d @@ -838,12 +756,12 @@ subroutine refract(En, cn, freq, dt, G, NAngle, use_PPMang) Flux_E real, dimension(SZI_(G),SZJ_(G),1-stencil:NAngle+stencil) :: & CFL_ang - real :: f2 ! The squared Coriolis parameter, in s-2. - real :: favg ! The average Coriolis parameter at a point, in s-1. - real :: df2_dy, df2_dx ! The x- and y- gradients of the squared Coriolis parameter, in s-2 m-1. - real :: df_dy, df_dx ! The x- and y- gradients of the Coriolis parameter, in s-1 m-1. - real :: dlnCn_dx ! The x-gradient of the wave speed divided by itself in m-1. - real :: dlnCn_dy ! The y-gradient of the wave speed divided by itself in m-1. + real :: f2 ! The squared Coriolis parameter [s-2]. + real :: favg ! The average Coriolis parameter at a point [s-1]. + real :: df2_dy, df2_dx ! The x- and y- gradients of the squared Coriolis parameter [s-2 m-1]. + real :: df_dy, df_dx ! The x- and y- gradients of the Coriolis parameter [s-1 m-1]. + real :: dlnCn_dx ! The x-gradient of the wave speed divided by itself [m-1]. + real :: dlnCn_dy ! The y-gradient of the wave speed divided by itself [m-1]. real :: Angle_size, dt_Angle_size, angle real :: Ifreq, Kmag2, I_Kmag real, parameter :: cn_subRO = 1e-100 @@ -864,7 +782,7 @@ subroutine refract(En, cn, freq, dt, G, NAngle, use_PPMang) enddo !### There should also be refraction due to cn.grad(grid_orientation). - CFL_ang(:,:,:) = 0.0; + CFL_ang(:,:,:) = 0.0 do j=js,je ! Copy En into angle space with halos. do a=1,na ; do i=is,ie @@ -920,10 +838,10 @@ subroutine refract(En, cn, freq, dt, G, NAngle, use_PPMang) call MOM_error(WARNING, "refract: CFL exceeds 1.", .true.) if (CFL_ang(i,j,A) > 0.0) then ; CFL_ang(i,j,A) = 1.0 ; else ; CFL_ang(i,j,A) = -1.0 ; endif endif - enddo; enddo + enddo ; enddo ! Advect in angular space - if(.not.use_PPMang) then + if (.not.use_PPMang) then ! Use simple upwind do A=0,na ; do i=is,ie if (CFL_ang(i,j,A) > 0.0) then @@ -931,7 +849,7 @@ subroutine refract(En, cn, freq, dt, G, NAngle, use_PPMang) else Flux_E(i,A) = CFL_ang(i,j,A) * En2d(i,A+1) endif - enddo; enddo + enddo ; enddo else ! Use PPM do i=is,ie @@ -941,30 +859,29 @@ subroutine refract(En, cn, freq, dt, G, NAngle, use_PPMang) ! Update and copy back to En. do a=1,na ; do i=is,ie - !if(En2d(i,a)+(Flux_E(i,A-1)-Flux_E(i,A)) < 0.0)then ! for debugging - ! print *,"refract: OutFlux>Available" ; !stop + !if (En2d(i,a)+(Flux_E(i,A-1)-Flux_E(i,A)) < 0.0) then ! for debugging + ! call MOM_error(FATAL, "refract: OutFlux>Available") !endif En(i,j,a) = En2d(i,a) + (Flux_E(i,A-1) - Flux_E(i,A)) enddo ; enddo enddo ! j-loop end subroutine refract -!> This subroutine calculates the 1-d flux for advection in angular space -!! using a monotonic piecewise parabolic scheme. Should be within i and j spatial -!! loops. +!> This subroutine calculates the 1-d flux for advection in angular space using a monotonic +!! piecewise parabolic scheme. This needs to be called from within i and j spatial loops. subroutine PPM_angular_advect(En2d, CFL_ang, Flux_En, NAngle, dt, halo_ang) - integer, intent(in) :: NAngle - real, intent(in) :: dt - integer, intent(in) :: halo_ang + integer, intent(in) :: NAngle !< The number of wave orientations in the + !! discretized wave energy spectrum. + real, intent(in) :: dt !< Time increment [s]. + integer, intent(in) :: halo_ang !< The halo size in angular space real, dimension(1-halo_ang:NAngle+halo_ang), & - intent(in) :: En2d + intent(in) :: En2d !< The internal gravity wave energy density as a + !! function of angular resolution [J m-2 radian-1]. real, dimension(1-halo_ang:NAngle+halo_ang), & - intent(in) :: CFL_ang - real, dimension(0:NAngle), intent(out) :: Flux_En - - ! This subroutine calculates the 1-d flux for advection in angular space - ! using a monotonic piecewise parabolic scheme. Should be within i and j spatial - ! loops + intent(in) :: CFL_ang !< The CFL number of the energy advection across angles + real, dimension(0:NAngle), intent(out) :: Flux_En !< The time integrated internal wave energy flux + !! across angles [J m-2 radian-1]. + ! Local variables real :: flux real :: u_ang real :: Angle_size @@ -1032,40 +949,34 @@ subroutine PPM_angular_advect(En2d, CFL_ang, Flux_En, NAngle, dt, halo_ang) enddo end subroutine PPM_angular_advect -!> This subroutine does refraction on the internal waves at a single frequency. +!> Propagates internal waves at a single frequency. subroutine propagate(En, cn, freq, dt, G, CS, NAngle) - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. - integer, intent(in) :: NAngle + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + integer, intent(in) :: NAngle !< The number of wave orientations in the + !! discretized wave energy spectrum. real, dimension(G%isd:G%ied,G%jsd:G%jed,NAngle), & - intent(inout) :: En !< The internal gravity wave energy density as a - !! function of space and angular resolution, - !! in J m-2 radian-1. + intent(inout) :: En !< The internal gravity wave energy density as a + !! function of space and angular resolution, + !! [J m-2 radian-1]. real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(in) :: cn !< Baroclinic mode speed, in m s-1. - real, intent(in) :: freq !< Wave frequency, in s-1. - real, intent(in) :: dt !< Time step, in s. - type(int_tide_CS), pointer :: CS - ! This subroutine does refraction on the internal waves at a single frequency. - - ! Arguments: - ! (inout) En - the internal gravity wave energy density as a function of space - ! and angular resolution, in J m-2 radian-1. - ! (in) cn - baroclinic mode speed, in m s-1 - ! (in) freq - wave frequency, in s-1 - ! (in) dt - time step, in s - + intent(in) :: cn !< Baroclinic mode speed [m s-1]. + real, intent(in) :: freq !< Wave frequency [s-1]. + real, intent(in) :: dt !< Time step [s]. + type(int_tide_CS), pointer :: CS !< The control structure returned by a + !! previous call to int_tide_init. + ! Local variables real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB) :: & - speed ! The magnitude of the group velocity at the q points for corner adv, in m s-1. + speed ! The magnitude of the group velocity at the q points for corner adv [m s-1]. integer, parameter :: stencil = 2 real, dimension(SZIB_(G),SZJ_(G)) :: & - speed_x ! The magnitude of the group velocity at the Cu points, in m s-1. + speed_x ! The magnitude of the group velocity at the Cu points [m s-1]. real, dimension(SZI_(G),SZJB_(G)) :: & - speed_y ! The magnitude of the group velocity at the Cv points, in m s-1. + speed_y ! The magnitude of the group velocity at the Cv points [m s-1]. real, dimension(0:NAngle) :: & cos_angle, sin_angle real, dimension(NAngle) :: & Cgx_av, Cgy_av, dCgx, dCgy - real :: f2 ! The squared Coriolis parameter, in s-2. + real :: f2 ! The squared Coriolis parameter [s-2]. real :: Angle_size, I_Angle_size, angle real :: Ifreq, freq2 real, parameter :: cn_subRO = 1e-100 @@ -1096,10 +1007,10 @@ subroutine propagate(En, cn, freq, dt, G, CS, NAngle) if (CS%corner_adv) then ! IMPLEMENT CORNER ADVECTION IN HORIZONTAL-------------------- - ! FIND AVERAGE GROUP VELOCITY (SPEED) AT CELL CORNERS; + ! FIND AVERAGE GROUP VELOCITY (SPEED) AT CELL CORNERS ! NOTE: THIS HAS NOT BE ADAPTED FOR REFLECTION YET (BDM)!! ! Fix indexing here later - speed(:,:) = 0; + speed(:,:) = 0 do J=jsh-1,jeh ; do I=ish-1,ieh f2 = G%CoriolisBu(I,J)**2 speed(I,J) = 0.25*(cn(i,j) + cn(i+1,j) + cn(i+1,j+1) + cn(i,j+1)) * & @@ -1109,7 +1020,7 @@ subroutine propagate(En, cn, freq, dt, G, CS, NAngle) ! Apply the propagation WITH CORNER ADVECTION/FINITE VOLUME APPROACH. LB%jsh = js ; LB%jeh = je ; LB%ish = is ; LB%ieh = ie call propagate_corner_spread(En(:,:,a), a, NAngle, speed, dt, G, CS, LB) - end do ! a-loop + enddo ! a-loop else ! IMPLEMENT PPM ADVECTION IN HORIZONTAL----------------------- ! These could be in the control structure, as they do not vary. @@ -1169,37 +1080,23 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. real, dimension(G%isd:G%ied,G%jsd:G%jed), & intent(inout) :: En !< The energy density integrated over an angular - !! band, in W m-2, intent in/out. + !! band [W m-2], intent in/out. real, dimension(G%IsdB:G%IedB,G%Jsd:G%Jed), & intent(in) :: speed !< The magnitude of the group velocity at the cell - !! corner points, in m s-1. + !! corner points [m s-1]. integer, intent(in) :: energized_wedge !< Index of current ray direction. - integer, intent(in) :: NAngle - real, intent(in) :: dt !< Time increment in s. + integer, intent(in) :: NAngle !< The number of wave orientations in the + !! discretized wave energy spectrum. + real, intent(in) :: dt !< Time increment [s]. type(int_tide_CS), pointer :: CS !< The control structure returned by a previous !! call to continuity_PPM_init. type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. - - ! This subroutine does first-order corner advection. It was written with the hopes - ! of smoothing out the garden sprinkler effect, but is too numerically diffusive to - ! be of much use as of yet. It is not yet compatible with reflection schemes (BDM). - - ! Arguments: En - The energy density integrated over an angular band, in W m-2, - ! intent in/out. - ! (in) energized_wedge - index of current ray direction - ! (in) speed - The magnitude of the group velocity at the cell corner - ! points, in m s-1. - ! (in) dt - Time increment in s. - ! (in) G - The ocean's grid structure. - ! (in) CS - The control structure returned by a previous call to - ! continuity_PPM_init. - ! (in) LB - A structure with the active energy loop bounds. - + ! Local variables integer :: i, j, k, ish, ieh, jsh, jeh, m real :: TwoPi, Angle_size real :: energized_angle ! angle through center of current wedge real :: theta ! angle at edge of wedge - real :: Nsubrays ! number of sub-rays for averaging; + real :: Nsubrays ! number of sub-rays for averaging ! count includes the two rays that bound the current wedge, ! i.e. those at -dtheta/2 and +dtheta/2 from energized angle real :: I_Nsubwedges ! inverse of number of sub-wedges @@ -1323,7 +1220,7 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS aW = 0.0; aSW = 0.0; aS = 0.0; ! initialize areas aSE = 0.0; aE = 0.0; aC = 0.0; ! initialize areas if (0.0 <= theta .and. theta < 0.25*TwoPi) then - xCrn = x(I-1,J-1); yCrn = y(I-1,J-1); + xCrn = x(I-1,J-1); yCrn = y(I-1,J-1) ! west area a1 = (yN - yCrn)*(0.5*(xN + xCrn)) a2 = (yCrn - yW)*(0.5*(xCrn + xW)) @@ -1349,7 +1246,7 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS a4 = (yN - yNE)*(0.5*(xN + xNE)) aC = a1 + a2 + a3 + a4 elseif (0.25*TwoPi <= theta .and. theta < 0.5*TwoPi) then - xCrn = x(I,J-1); yCrn = y(I,J-1); + xCrn = x(I,J-1); yCrn = y(I,J-1) ! south area a1 = (yCrn - yS)*(0.5*(xCrn + xS)) a2 = (yS - ySW)*(0.5*(xS + xSW)) @@ -1375,7 +1272,7 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS a4 = (yNW - yN)*(0.5*(xNW + xN)) aC = a1 + a2 + a3 + a4 elseif (0.5*TwoPi <= theta .and. theta < 0.75*TwoPi) then - xCrn = x(I,J); yCrn = y(I,J); + xCrn = x(I,J); yCrn = y(I,J) ! east area a1 = (yE - ySE)*(0.5*(xE + xSE)) a2 = (ySE - yS)*(0.5*(xSE + xS)) @@ -1401,7 +1298,7 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS a4 = (yW - yCrn)*(0.5*(xW + xCrn)) aC = a1 + a2 + a3 + a4 elseif (0.75*TwoPi <= theta .and. theta <= 1.00*TwoPi) then - xCrn = x(I-1,J); yCrn = y(I-1,J); + xCrn = x(I-1,J); yCrn = y(I-1,J) ! north area a1 = (yNE - yE)*(0.5*(xNE + xE)) a2 = (yE - yCrn)*(0.5*(xE + xCrn)) @@ -1413,7 +1310,7 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS a2 = (yCrn - yW)*(0.5*(xCrn + xW)) a3 = (yW - yNW)*(0.5*(xW + xNW)) a4 = (yNW - yN)*(0.5*(xNW + xN)) - aNW = a1 + a2 + a3 + a4; + aNW = a1 + a2 + a3 + a4 ! west area a1 = (yCrn - yS)*(0.5*(xCrn + xS)) a2 = (yS - ySW)*(0.5*(xS + xSW)) @@ -1436,43 +1333,37 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS enddo ! m-loop ! update energy in cell En(i,j) = sum(E_new)/Nsubrays - enddo; enddo + enddo ; enddo end subroutine propagate_corner_spread -! #@# This subroutine needs a doxygen description +!> Propagates the internal wave energy in the logical x-direction. subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, Nangle, CS, LB) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - integer, intent(in) :: NAngle + integer, intent(in) :: NAngle !< The number of wave orientations in the + !! discretized wave energy spectrum. real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle), & intent(inout) :: En !< The energy density integrated over an angular - !! band, in J m-2, intent in/out. + !! band [J m-2], intent in/out. real, dimension(G%IsdB:G%IedB,G%jsd:G%jed), & intent(in) :: speed_x !< The magnitude of the group velocity at the - !! Cu points, in m s-1. - real, dimension(Nangle), intent(in) :: Cgx_av, dCgx - real, intent(in) :: dt !< Time increment in s. + !! Cu points [m s-1]. + real, dimension(Nangle), intent(in) :: Cgx_av !< The average x-projection in each angular band. + real, dimension(Nangle), intent(in) :: dCgx !< The difference in x-projections between the + !! edges of each angular band. + real, intent(in) :: dt !< Time increment [s]. type(int_tide_CS), pointer :: CS !< The control structure returned by a previous call !! to continuity_PPM_init. type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. - - ! Arguments: En - The energy density integrated over an angular band, in J m-2, - ! intent in/out. - ! (in) speed_x - The magnitude of the group velocity at the Cu - ! points, in m s-1. - ! (in) dt - Time increment in s. - ! (in) G - The ocean's grid structure. - ! (in) CS - The control structure returned by a previous call to - ! continuity_PPM_init. - ! (in) LB - A structure with the active energy loop bounds. + ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & - EnL, EnR ! Left and right face energy densities, in J m-2. + EnL, EnR ! Left and right face energy densities [J m-2]. real, dimension(SZIB_(G),SZJ_(G)) :: & - flux_x ! The internal wave energy flux, in J s-1. + flux_x ! The internal wave energy flux [J s-1]. real, dimension(SZIB_(G)) :: & cg_p, cg_m, flux1, flux2 !real, dimension(SZI_(G),SZJB_(G),Nangle) :: En_m, En_p real, dimension(SZI_(G),SZJB_(G),Nangle) :: & - Fdt_m, Fdt_p! Left and right energy fluxes, in J + Fdt_m, Fdt_p! Left and right energy fluxes [J] integer :: i, j, k, ish, ieh, jsh, jeh, a ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh @@ -1519,8 +1410,8 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, Nangle, CS, LB) ! Update reflected energy (Jm-2) do j=jsh,jeh ; do i=ish,ieh !do a=1,CS%nAngle - ! if((En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a))) < 0.0)then ! for debugging - ! print *,"propagate_x: OutFlux>Available" ; !stop + ! if ((En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a))) < 0.0) then ! for debugging + ! call MOM_error(FATAL, "propagate_x: OutFlux>Available") ! endif !enddo En(i,j,:) = En(i,j,:) + G%IareaT(i,j)*(Fdt_m(i,j,:) + Fdt_p(i,j,:)) @@ -1528,40 +1419,35 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, Nangle, CS, LB) end subroutine propagate_x -! #@# This subroutine needs a doxygen description. +!> Propagates the internal wave energy in the logical y-direction. subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, Nangle, CS, LB) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - integer, intent(in) :: NAngle + integer, intent(in) :: NAngle !< The number of wave orientations in the + !! discretized wave energy spectrum. real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle), & intent(inout) :: En !< The energy density integrated over an angular - !! band, in J m-2, intent in/out. + !! band [J m-2], intent in/out. real, dimension(G%isd:G%ied,G%JsdB:G%JedB), & intent(in) :: speed_y !< The magnitude of the group velocity at the - !! Cv points, in m s-1. - real, dimension(Nangle), intent(in) :: Cgy_av, dCgy - real, intent(in) :: dt !< Time increment in s. + !! Cv points [m s-1]. + real, dimension(Nangle), intent(in) :: Cgy_av !< The average y-projection in each angular band. + real, dimension(Nangle), intent(in) :: dCgy !< The difference in y-projections between the + !! edges of each angular band. + real, intent(in) :: dt !< Time increment [s]. type(int_tide_CS), pointer :: CS !< The control structure returned by a previous call !! to continuity_PPM_init. type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. - - ! Arguments: En - The energy density integrated over an angular band, in J m-2, - ! intent in/out. - ! (in) speed_y - The magnitude of the group velocity at the Cv - ! points, in m s-1. - ! (in) dt - Time increment in s. - ! (in) G - The ocean's grid structure. - ! (in) CS - The control structure returned by a previous call to - ! continuity_PPM_init. - ! (in) LB - A structure with the active energy loop bounds. + ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & - EnL, EnR ! South and north face energy densities, in J m-2. + EnL, EnR ! South and north face energy densities [J m-2]. real, dimension(SZI_(G),SZJB_(G)) :: & - flux_y ! The internal wave energy flux, in J s-1. + flux_y ! The internal wave energy flux [J s-1]. real, dimension(SZI_(G)) :: & cg_p, cg_m, flux1, flux2 !real, dimension(SZI_(G),SZJB_(G),Nangle) :: En_m, En_p real, dimension(SZI_(G),SZJB_(G),Nangle) :: & - Fdt_m, Fdt_p! South and north energy fluxes, in J + Fdt_m, Fdt_p! South and north energy fluxes [J] + character(len=160) :: mesg ! The text of an error message integer :: i, j, k, ish, ieh, jsh, jeh, a ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh @@ -1588,13 +1474,11 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, Nangle, CS, LB) do j=jsh,jeh ; do i=ish,ieh Fdt_m(i,j,a) = dt*flux_y(i,J-1) ! south face influx (J) Fdt_p(i,j,a) = -dt*flux_y(i,J) ! north face influx (J) - !if((En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a))) < 0.0)then ! for debugging - ! print *,"propagate_y: OutFlux>Available prior to reflection" ; !stop - ! print *,"flux_y_south=",flux_y(i,J-1) - ! print *,"flux_y_north=",flux_y(i,J) - ! print *,"En=",En(i,j,a) - ! print *,"cn_south=", speed_y(i,J-1) * (Cgy_av(a)) - ! print *,"cn_north=", speed_y(i,J) * (Cgy_av(a)) + !if ((En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a))) < 0.0)then ! for debugging + ! call MOM_error(WARNING, "propagate_y: OutFlux>Available prior to reflection", .true.) + ! write(mesg,*) "flux_y_south=",flux_y(i,J-1),"flux_y_north=",flux_y(i,J),"En=",En(i,j,a), & + ! "cn_south=", speed_y(i,J-1) * (Cgy_av(a)), "cn_north=", speed_y(i,J) * (Cgy_av(a)) + ! call MOM_error(WARNING, mesg, .true.) !endif enddo ; enddo @@ -1616,8 +1500,8 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, Nangle, CS, LB) ! Update reflected energy (Jm-2) do j=jsh,jeh ; do i=ish,ieh !do a=1,CS%nAngle - ! if((En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a))) < 0.0)then ! for debugging - ! print *,"propagate_y: OutFlux>Available" ; !stop + ! if ((En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a))) < 0.0)then ! for debugging + ! call MOM_error(FATAL, "propagate_y: OutFlux>Available", .true.) ! endif !enddo En(i,j,:) = En(i,j,:) + G%IareaT(i,j)*(Fdt_m(i,j,:) + Fdt_p(i,j,:)) @@ -1625,35 +1509,25 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, Nangle, CS, LB) end subroutine propagate_y -!> This subroutines evaluates the zonal mass or volume fluxes in a layer. +!> Evaluates the zonal mass or volume fluxes in a layer. subroutine zonal_flux_En(u, h, hL, hR, uh, dt, G, j, ish, ieh, vol_CFL) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - real, dimension(SZIB_(G)), intent(in) :: u !< The zonal velocity, in m s-1. - real, dimension(SZI_(G)), intent(in) :: h !< Energy density used to calculate the fluxes, - !! in J m-2. - real, dimension(SZI_(G)), intent(in) :: hL !< Left- Energy densities in the reconstruction, - !! in J m-2. - real, dimension(SZI_(G)), intent(in) :: hR !< Right- Energy densities in the reconstruction, - !! in J m-2. - real, dimension(SZIB_(G)), intent(inout) :: uh !< The zonal energy transport, - !! in J s-1. - real, intent(in) :: dt !< Time increment in s. - integer, intent(in) :: j, ish, ieh !< The index range to work on. + real, dimension(SZIB_(G)), intent(in) :: u !< The zonal velocity [m s-1]. + real, dimension(SZI_(G)), intent(in) :: h !< Energy density used to calculate the fluxes + !! [J m-2]. + real, dimension(SZI_(G)), intent(in) :: hL !< Left- Energy densities in the reconstruction + !! [J m-2]. + real, dimension(SZI_(G)), intent(in) :: hR !< Right- Energy densities in the reconstruction + !! [J m-2]. + real, dimension(SZIB_(G)), intent(inout) :: uh !< The zonal energy transport [J s-1]. + real, intent(in) :: dt !< Time increment [s]. + integer, intent(in) :: j !< The j-index to work on. + integer, intent(in) :: ish !< The start i-index range to work on. + integer, intent(in) :: ieh !< The end i-index range to work on. logical, intent(in) :: vol_CFL !< If true, rescale the ratio of face areas to !! the cell areas when estimating the CFL number. - - ! This subroutines evaluates the zonal mass or volume fluxes in a layer. - ! - ! Arguments: u - Zonal velocity, in m s-1. - ! (in) h - Energy density used to calculate the fluxes, in J m-2. - ! (in) hL, hR - Left- and right- Energy densities in the reconstruction, in J m-2. - ! (out) uh - The zonal energy transport, in J s-1. - ! (in) dt - Time increment in s. - ! (in) G - The ocean's grid structure. - ! (in) j, ish, ieh - The index range to work on. - ! (in) vol_CFL - If true, rescale the ratio of face areas to the cell - ! areas when estimating the CFL number. - real :: CFL ! The CFL number based on the local velocity and grid spacing, ND. + ! Local variables + real :: CFL ! The CFL number based on the local velocity and grid spacing [nondim]. real :: curv_3 ! A measure of the thickness curvature over a grid length, ! with the same units as h_in. integer :: i @@ -1678,35 +1552,26 @@ subroutine zonal_flux_En(u, h, hL, hR, uh, dt, G, j, ish, ieh, vol_CFL) enddo end subroutine zonal_flux_En -!> This subroutines evaluates the meridional mass or volume fluxes in a layer. +!> Evaluates the meridional mass or volume fluxes in a layer. subroutine merid_flux_En(v, h, hL, hR, vh, dt, G, J, ish, ieh, vol_CFL) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - real, dimension(SZI_(G)), intent(in) :: v !< The meridional velocity, in m s-1. + real, dimension(SZI_(G)), intent(in) :: v !< The meridional velocity [m s-1]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h !< Energy density used to calculate the - !! fluxes, in J m-2. + !! fluxes [J m-2]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: hL !< Left- Energy densities in the - !! reconstruction, in J m-2. + !! reconstruction [J m-2]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: hR !< Right- Energy densities in the - !! reconstruction, in J m-2. - real, dimension(SZI_(G)), intent(inout) :: vh !< The meridional energy transport, - !! in J s-1. - real, intent(in) :: dt !< Time increment in s. - integer, intent(in) :: J, ish, ieh !< The index range to work on. + !! reconstruction [J m-2]. + real, dimension(SZI_(G)), intent(inout) :: vh !< The meridional energy transport [J s-1]. + real, intent(in) :: dt !< Time increment [s]. + integer, intent(in) :: J !< The j-index to work on. + integer, intent(in) :: ish !< The start i-index range to work on. + integer, intent(in) :: ieh !< The end i-index range to work on. logical, intent(in) :: vol_CFL !< If true, rescale the ratio of face !! areas to the cell areas when estimating !! the CFL number. - ! This subroutines evaluates the meridional mass or volume fluxes in a layer. - ! - ! Arguments: v - Meridional velocity, in m s-1. - ! (in) h - Energy density used to calculate the fluxes, in J m-2. - ! (in) hL, hR - Left- and right- Energy densities in the reconstruction, in J m-2. - ! (out) vh - The meridional energy transport, in J s-1. - ! (in) dt - Time increment in s. - ! (in) G - The ocean's grid structure. - ! (in) J, ish, ieh - The index range to work on. - ! (in) vol_CFL - If true, rescale the ratio of face areas to the cell - ! areas when estimating the CFL number. - real :: CFL ! The CFL number based on the local velocity and grid spacing, ND. + ! Local variables + real :: CFL ! The CFL number based on the local velocity and grid spacing [nondim]. real :: curv_3 ! A measure of the thickness curvature over a grid length, ! with the same units as h_in. integer :: i @@ -1730,17 +1595,19 @@ subroutine merid_flux_En(v, h, hL, hR, vh, dt, G, J, ish, ieh, vol_CFL) enddo end subroutine merid_flux_En -!> This subroutine does reflection of the internal waves at a single frequency. +!> Reflection of the internal waves at a single frequency. subroutine reflect(En, NAngle, CS, G, LB) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - integer, intent(in) :: NAngle + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + integer, intent(in) :: NAngle !< The number of wave orientations in the + !! discretized wave energy spectrum. real, dimension(G%isd:G%ied,G%jsd:G%jed,NAngle), & - intent(inout) :: En - type(int_tide_CS), pointer :: CS - type(loop_bounds_type), intent(in) :: LB - - ! This subroutine does reflection of the internal waves at a single frequency. - + intent(inout) :: En !< The internal gravity wave energy density as a + !! function of space and angular resolution + !! [J m-2 radian-1]. + type(int_tide_CS), pointer :: CS !< The control structure returned by a + !! previous call to int_tide_init. + type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. + ! Local variables real, dimension(G%isd:G%ied,G%jsd:G%jed) :: angle_c ! angle of boudary wrt equator real, dimension(G%isd:G%ied,G%jsd:G%jed) :: part_refl @@ -1768,7 +1635,7 @@ subroutine reflect(En, NAngle, CS, G, LB) isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh - TwoPi = 8.0*atan(1.0); + TwoPi = 8.0*atan(1.0) Angle_size = TwoPi / (real(NAngle)) do a=1,NAngle @@ -1784,13 +1651,12 @@ subroutine reflect(En, NAngle, CS, G, LB) !do j=jsc-1,jec+1 do j=jsh,jeh - jd_g = j + G%jdg_offset !do i=isc-1,iec+1 do i=ish,ieh - id_g = i + G%idg_offset + ! jd_g = j + G%jdg_offset ; id_g = i + G%idg_offset ! redistribute energy in angular space if ray will hit boundary ! i.e., if energy is in a reflecting cell - if (angle_c(i,j) .ne. CS%nullangle) then + if (angle_c(i,j) /= CS%nullangle) then do a=1,NAngle if (En(i,j,a) > 0.0) then ! if ray is incident, keep specified boundary angle @@ -1818,7 +1684,7 @@ subroutine reflect(En, NAngle, CS, G, LB) endif a_r = nint(angle_r/Angle_size) + 1 do while (a_r > Nangle) ; a_r = a_r - Nangle ; enddo - if (a .ne. a_r) then + if (a /= a_r) then En_reflected(a_r) = part_refl(i,j)*En(i,j,a) En(i,j,a) = (1.0-part_refl(i,j))*En(i,j,a) endif @@ -1832,34 +1698,30 @@ subroutine reflect(En, NAngle, CS, G, LB) enddo ! j-loop ! Check to make sure no energy gets onto land (only run for debugging) - !do j=jsc,jec - ! jd_g = j + G%jdg_offset - ! do i=isc,iec - ! id_g = i + G%idg_offset - ! do a=1,NAngle - ! if (En(i,j,a) > 0.001 .and. G%mask2dT(i,j) == 0) then - ! print *, 'En=', En(i,j,a), 'a=', a, 'ig_g=',id_g, 'jg_g=',jd_g - ! !stop 'Energy detected out of bounds!' - ! endif - ! enddo ! a-loop - ! enddo ! i-loop - !enddo ! j-loop + ! do a=1,NAngle ; do j=jsc,jec ; do i=isc,iec + ! if (En(i,j,a) > 0.001 .and. G%mask2dT(i,j) == 0) then + ! jd_g = j + G%jdg_offset ; id_g = i + G%idg_offset + ! write (mesg,*) 'En=', En(i,j,a), 'a=', a, 'ig_g=',id_g, 'jg_g=',jd_g + ! call MOM_error(FATAL, "reflect: Energy detected out of bounds: "//trim(mesg), .true.) + ! endif + ! enddo ; enddo ; enddo end subroutine reflect -!> This subroutine moves energy across lines of partial reflection to prevent +!> Moves energy across lines of partial reflection to prevent !! reflection of energy that is supposed to get across. subroutine teleport(En, NAngle, CS, G, LB) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - integer, intent(in) :: NAngle + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + integer, intent(in) :: NAngle !< The number of wave orientations in the + !! discretized wave energy spectrum. real, dimension(G%isd:G%ied,G%jsd:G%jed,NAngle), & - intent(inout) :: En - type(int_tide_CS), pointer :: CS - type(loop_bounds_type), intent(in) :: LB - - ! This subroutine moves energy across lines of partial reflection to prevent - ! reflection of energy that is supposed to get across. - + intent(inout) :: En !< The internal gravity wave energy density as a + !! function of space and angular resolution + !! [J m-2 radian-1]. + type(int_tide_CS), pointer :: CS !< The control structure returned by a + !! previous call to int_tide_init. + type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. + ! Local variables real, dimension(G%isd:G%ied,G%jsd:G%jed) :: angle_c ! angle of boudary wrt equator real, dimension(G%isd:G%ied,G%jsd:G%jed) :: part_refl @@ -1874,6 +1736,7 @@ subroutine teleport(En, NAngle, CS, G, LB) real, dimension(1:NAngle) :: angle_i ! angle of incident ray wrt equator real, dimension(1:NAngle) :: cos_angle, sin_angle real :: En_tele ! energy to be "teleported" + character(len=160) :: mesg ! The text of an error message integer :: i, j, a !integer :: isd, ied, jsd, jed ! start and end local indices on data domain ! ! (values include halos) @@ -1935,9 +1798,8 @@ subroutine teleport(En, NAngle, CS, G, LB) En(i,j,a) = En(i,j,a) - En_tele En(i+ios,j+jos,a) = En(i+ios,j+jos,a) + En_tele else - call MOM_error(WARNING, "teleport: no receptive ocean cell", .true.) - print *, 'idg=',id_g,'jd_g=',jd_g,'a=',a - stop + write(mesg,*) 'idg=',id_g,'jd_g=',jd_g,'a=',a + call MOM_error(FATAL, "teleport: no receptive ocean cell at "//trim(mesg), .true.) endif endif ! incidence check endif ! energy check @@ -1948,21 +1810,25 @@ subroutine teleport(En, NAngle, CS, G, LB) end subroutine teleport -!> This subroutine rotates points in the halos where required to accomodate +!> Rotates points in the halos where required to accomodate !! 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 - real, dimension(:,:,:,:,:), intent(inout) :: En - real, dimension(SZI_(G),SZJ_(G),2), intent(in) :: test - integer, intent(in) :: NAngle - ! This subroutine rotates points in the halos where required to accomodate - ! changes in grid orientation, such as at the tripolar fold. - + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(:,:,:,:,:), intent(inout) :: En !< The internal gravity wave energy density as a + !! function of space, angular orientation, frequency, + !! and vertical mode [J m-2 radian-1]. + real, dimension(SZI_(G),SZJ_(G),2), & + intent(in) :: test !< An x-unit vector that has been passed through + !! the halo updates, to enable the rotation of the + !! wave energies in the halo region to be corrected. + integer, intent(in) :: NAngle !< The number of wave orientations in the + !! discretized wave energy spectrum. + ! Local variables real, dimension(G%isd:G%ied,NAngle) :: En2d integer, dimension(G%isd:G%ied) :: a_shift integer :: i_first, i_last, a_new integer :: a, i, j, isd, ied, jsd, jed, m, fr - character(len=80) :: mesg + character(len=160) :: mesg ! The text of an error message isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed do j=jsd,jed @@ -2002,7 +1868,7 @@ subroutine correct_halo_rotation(En, test, G, NAngle) enddo end subroutine correct_halo_rotation -!> This subroutine calculates left/right edge values for PPM reconstruction. +!> Calculates left/right edge values for PPM reconstruction in x-direction. subroutine PPM_reconstruction_x(h_in, h_l, h_r, G, LB, simple_2nd) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Energy density in a sector (2D). @@ -2012,22 +1878,13 @@ subroutine PPM_reconstruction_x(h_in, h_l, h_r, G, LB, simple_2nd) logical, optional, intent(in) :: simple_2nd !< If true, use the arithmetic mean !! energy densities as default edge values !! for a simple 2nd order scheme. - - ! This subroutine calculates left/right edge values for PPM reconstruction. - ! Arguments: h_in - Energy density in a sector (2D) - ! (out) h_l,h_r - left/right edge value of reconstruction (2D) - ! (in) G - The ocean's grid structure. - ! (in) LB - A structure with the active loop bounds. - ! (in, opt) simple_2nd - If true, use the arithmetic mean energy densities as - ! default edge values for a simple 2nd order scheme. - - ! Local variables with useful mnemonic names. + ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: slp ! The slopes. real, parameter :: oneSixth = 1./6. real :: h_ip1, h_im1 real :: dMx, dMn logical :: use_CW84, use_2nd - character(len=256) :: mesg + character(len=256) :: mesg ! The text of an error message integer :: i, j, isl, iel, jsl, jel, stencil use_2nd = .false. ; if (present(simple_2nd)) use_2nd = simple_2nd @@ -2069,7 +1926,7 @@ subroutine PPM_reconstruction_x(h_in, h_l, h_r, G, LB, simple_2nd) slp(i,j) = sign(1.,slp(i,j)) * min(abs(slp(i,j)), 2. * min(dMx, dMn)) ! * (G%mask2dT(i-1,j) * G%mask2dT(i,j) * G%mask2dT(i+1,j)) endif - enddo; enddo + enddo ; enddo do j=jsl,jel ; do i=isl,iel ! Neighboring values should take into account any boundaries. The 3 @@ -2081,13 +1938,13 @@ subroutine PPM_reconstruction_x(h_in, h_l, h_r, G, LB, simple_2nd) ! Left/right values following Eq. B2 in Lin 1994, MWR (132) h_l(i,j) = 0.5*( h_im1 + h_in(i,j) ) + oneSixth*( slp(i-1,j) - slp(i,j) ) h_r(i,j) = 0.5*( h_ip1 + h_in(i,j) ) + oneSixth*( slp(i,j) - slp(i+1,j) ) - enddo; enddo + enddo ; enddo endif call PPM_limit_pos(h_in, h_l, h_r, 0.0, G, isl, iel, jsl, jel) end subroutine PPM_reconstruction_x -!> This subroutine calculates left/right edge valus for PPM reconstruction. +!> Calculates left/right edge valus for PPM reconstruction in y-direction. subroutine PPM_reconstruction_y(h_in, h_l, h_r, G, LB, simple_2nd) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Energy density in a sector (2D). @@ -2097,22 +1954,13 @@ subroutine PPM_reconstruction_y(h_in, h_l, h_r, G, LB, simple_2nd) logical, optional, intent(in) :: simple_2nd !< If true, use the arithmetic mean !! energy densities as default edge values !! for a simple 2nd order scheme. - - ! This subroutine calculates left/right edge valus for PPM reconstruction. - ! Arguments: h_in - Energy density in a sector (2D) - ! (out) h_l,h_r - left/right edge value of reconstruction (2D) - ! (in) G - The ocean's grid structure. - ! (in) LB - A structure with the active loop bounds. - ! (in, opt) simple_2nd - If true, use the arithmetic mean energy densities as - ! default edge values for a simple 2nd order scheme. - - ! Local variables with useful mnemonic names. + ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: slp ! The slopes. real, parameter :: oneSixth = 1./6. real :: h_jp1, h_jm1 real :: dMx, dMn logical :: use_2nd - character(len=256) :: mesg + character(len=256) :: mesg ! The text of an error message integer :: i, j, isl, iel, jsl, jel, stencil use_2nd = .false. ; if (present(simple_2nd)) use_2nd = simple_2nd @@ -2170,7 +2018,7 @@ subroutine PPM_reconstruction_y(h_in, h_l, h_r, G, LB, simple_2nd) call PPM_limit_pos(h_in, h_l, h_r, 0.0, G, isl, iel, jsl, jel) end subroutine PPM_reconstruction_y -!> This subroutine limits the left/right edge values of the PPM reconstruction +!> Limits the left/right edge values of the PPM reconstruction !! to give a reconstruction that is positive-definite. Here this is !! reinterpreted as giving a constant thickness if the mean thickness is less !! than h_min, with a minimum of h_min otherwise. @@ -2181,24 +2029,13 @@ subroutine PPM_limit_pos(h_in, h_L, h_R, h_min, G, iis, iie, jis, jie) real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_R !< Right edge value (2D). real, intent(in) :: h_min !< The minimum thickness that can be !! obtained by a concave parabolic fit. - integer, intent(in) :: iis, iie, jis, jie !< Index range for - !! computation. - - ! This subroutine limits the left/right edge values of the PPM reconstruction - ! to give a reconstruction that is positive-definite. Here this is - ! reinterpreted as giving a constant thickness if the mean thickness is less - ! than h_min, with a minimum of h_min otherwise. - ! Arguments: h_in - thickness of layer (2D) - ! (inout) h_L - left edge value (2D) - ! (inout) h_R - right edge value (2D) - ! (in) h_min - The minimum thickness that can be obtained by a - ! concave parabolic fit. - ! (in) iis, iie, jis, jie - Index range for computation. - ! (in) G - The ocean's grid structure. - + integer, intent(in) :: iis !< Start i-index for computations + integer, intent(in) :: iie !< End i-index for computations + integer, intent(in) :: jis !< Start j-index for computations + integer, intent(in) :: jie !< End j-index for computations ! Local variables real :: curv, dh, scale - character(len=256) :: mesg + character(len=256) :: mesg ! The text of an error message integer :: i,j do j=jis,jie ; do i=iis,iie @@ -2225,17 +2062,12 @@ end subroutine PPM_limit_pos ! subroutine register_int_tide_restarts(G, param_file, CS, restart_CS) ! type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure ! type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters -! type(int_tide_CS), pointer :: CS -! type(MOM_restart_CS), pointer :: restart_CS +! type(int_tide_CS), pointer :: CS !< The control structure returned by a +! !! previous call to int_tide_init. +! type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure. ! ! This subroutine is not currently in use!! -! ! Arguments: G - The ocean's grid structure. -! ! (in) param_file - A structure indicating the open file to parse for -! ! model parameter values. -! ! (in/out) CS - A pointer that is set to point to the control structure -! ! for this module. -! ! (in) restart_CS - A pointer to the restart control structure. ! ! This subroutine is used to allocate and register any fields in this module ! ! that should be written to or read from the restart file. ! logical :: use_int_tides @@ -2267,36 +2099,21 @@ end subroutine PPM_limit_pos ! 'h','1','1',"J m-2") ! call register_restart_field(CS%En_restart, vd, .false., restart_CS) -! !--------------------check---------------------------------------------- -! if (is_root_pe()) then -! print *,'register_int_tide_restarts: CS and CS%En_restart allocated!' -! print *,'register_int_tide_restarts: CS%En_restart registered!' -! print *,'register_int_tide_restarts: done!' -! endif -! !----------------------------------------------------------------------- - ! end subroutine register_int_tide_restarts -! #@# This subroutine needs a doxygen comment. -subroutine internal_tides_init(Time, G, GV, param_file, diag, CS) +!> This subroutine initializes the internal tides module. +subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) type(time_type), target, intent(in) :: Time !< The current model time. 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 type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time !! parameters. type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate !! diagnostic output. type(int_tide_CS),pointer :: CS !< A pointer that is set to point to the control !! structure for this module. - - ! Arguments: Time - The current model time. - ! (in) G - The ocean's grid structure. - ! (in) GV - The ocean's vertical grid structure. - ! (in) param_file - A structure indicating the open file to parse for - ! model parameter values. - ! (in) diag - A structure that is used to regulate diagnostic output. - ! (in/out) CS - A pointer that is set to point to the control structure - ! for this module + ! Local variables real :: Angle_size ! size of wedges, rad real, allocatable :: angles(:) ! orientations of wedge centers, rad real, allocatable, dimension(:,:) :: h2 ! topographic roughness scale, m^2 @@ -2462,7 +2279,7 @@ subroutine internal_tides_init(Time, G, GV, param_file, diag, CS) "dissipated locally with INT_TIDE_DISSIPATION. \n"//& "THIS NAME COULD BE BETTER.", & units="nondim", default=0.3333) - call get_param(param_file, mdl, "KAPPA_ITIDES", kappa_itides, & + call get_param(param_file, mdl, "KAPPA_ITIDES", kappa_itides, & "A topographic wavenumber used with INT_TIDE_DISSIPATION. \n"//& "The default is 2pi/10 km, as in St.Laurent et al. 2002.", & units="m-1", default=8.e-4*atan(1.0)) @@ -2494,15 +2311,17 @@ subroutine internal_tides_init(Time, G, GV, param_file, diag, CS) fail_if_missing=.true.) filename = trim(CS%inputdir) // trim(h2_file) call log_param(param_file, mdl, "INPUTDIR/H2_FILE", filename) - call MOM_read_data(filename, 'h2', h2, G%domain, timelevel=1) + call MOM_read_data(filename, 'h2', h2, G%domain, timelevel=1, scale=US%m_to_Z) do j=G%jsc,G%jec ; do i=G%isc,G%iec ! Restrict rms topo to 10 percent of column depth. - h2(i,j) = min(0.01*G%bathyT(i,j)**2, h2(i,j)) - ! Compute the fixed part; units are [kg m-2] here; + h2(i,j) = min(0.01*(G%bathyT(i,j))**2, h2(i,j)) + ! Compute the fixed part; units are [kg m-2] here ! will be multiplied by N and En to get into [W m-2] CS%TKE_itidal_loss_fixed(i,j) = 0.5*kappa_h2_factor*GV%Rho0*& kappa_itides * h2(i,j) - enddo; enddo + enddo ; enddo + + deallocate(h2) ! Read in prescribed coast/ridge/shelf angles from file call get_param(param_file, mdl, "REFL_ANGLE_FILE", refl_angle_file, & @@ -2516,7 +2335,7 @@ subroutine internal_tides_init(Time, G, GV, param_file, diag, CS) G%domain, timelevel=1) ! replace NANs with null value do j=G%jsc,G%jec ; do i=G%isc,G%iec - if(is_NaN(CS%refl_angle(i,j))) CS%refl_angle(i,j) = CS%nullangle + if (is_NaN(CS%refl_angle(i,j))) CS%refl_angle(i,j) = CS%nullangle enddo ; enddo call pass_var(CS%refl_angle,G%domain) @@ -2536,7 +2355,7 @@ subroutine internal_tides_init(Time, G, GV, param_file, diag, CS) do j=jsd,jed do i=isd,ied ! flag cells with partial reflection - if (CS%refl_angle(i,j) .ne. CS%nullangle .and. & + if (CS%refl_angle(i,j) /= CS%nullangle .and. & CS%refl_pref(i,j) < 1.0 .and. CS%refl_pref(i,j) > 0.0) then CS%refl_pref_logical(i,j) = .true. endif @@ -2556,7 +2375,7 @@ subroutine internal_tides_init(Time, G, GV, param_file, diag, CS) do i=isd,ied; do j=jsd,jed if (ridge_temp(i,j) == 1) then; CS%refl_dbl(i,j) = .true. else ; CS%refl_dbl(i,j) = .false. ; endif - enddo; enddo + enddo ; enddo ! Read in prescribed land mask from file (if overwriting -BDM). ! This should be done in MOM_initialize_topography subroutine @@ -2714,11 +2533,10 @@ subroutine internal_tides_init(Time, G, GV, param_file, diag, CS) end subroutine internal_tides_init - +!> This subroutine deallocates the memory associated with the internal tides control structure subroutine internal_tides_end(CS) - type(int_tide_CS), pointer :: CS - ! Arguments: CS - A pointer to the control structure returned by a previous - ! call to internal_tides_init, it will be deallocated here. + type(int_tide_CS), pointer :: CS !< A pointer to the control structure returned by a previous + !! call to internal_tides_init, it will be deallocated here. if (associated(CS)) then if (associated(CS%En)) deallocate(CS%En) @@ -2731,5 +2549,4 @@ subroutine internal_tides_end(CS) CS => NULL() end subroutine internal_tides_end - end module MOM_internal_tides diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index fbc78f3bdd..3f250bc935 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -13,6 +13,7 @@ module MOM_lateral_mixing_coeffs use MOM_interface_heights, only : find_eta use MOM_isopycnal_slopes, only : calc_isoneutral_slopes use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use MOM_wave_speed, only : wave_speed, wave_speed_CS, wave_speed_init @@ -22,7 +23,7 @@ module MOM_lateral_mixing_coeffs #include !> Variable mixing coefficients -type, public :: VarMix_CS ; +type, public :: VarMix_CS logical :: use_variable_mixing !< If true, use the variable mixing. logical :: Resoln_scaled_Kh !< If true, scale away the Laplacian viscosity !! when the deformation radius is well resolved. @@ -55,11 +56,11 @@ module MOM_lateral_mixing_coeffs logical :: calculate_Eady_growth_rate !< If true, calculate all the Eady growth rate. !! This parameter is set depending on other parameters. real, dimension(:,:), pointer :: & - SN_u => NULL(), & !< S*N at u-points (s^-1) - SN_v => NULL(), & !< S*N at v-points (s^-1) - L2u => NULL(), & !< Length scale^2 at u-points (m^2) - L2v => NULL(), & !< Length scale^2 at v-points (m^2) - cg1 => NULL(), & !< The first baroclinic gravity wave speed in m s-1. + SN_u => NULL(), & !< S*N at u-points [s-1] + SN_v => NULL(), & !< S*N at v-points [s-1] + L2u => NULL(), & !< Length scale^2 at u-points [m2] + L2v => NULL(), & !< Length scale^2 at v-points [m2] + cg1 => NULL(), & !< The first baroclinic gravity wave speed [m s-1]. Res_fn_h => NULL(), & !< Non-dimensional function of the ratio the first baroclinic !! deformation radius to the grid spacing at h points. Res_fn_q => NULL(), & !< Non-dimensional function of the ratio the first baroclinic @@ -77,19 +78,19 @@ module MOM_lateral_mixing_coeffs beta_dx2_v => NULL(), & !< The magnitude of the gradient of the Coriolis parameter !! times the grid spacing squared at v points. f2_dx2_h => NULL(), & !< The Coriolis parameter squared times the grid - !! spacing squared at h, in m2 s-2. + !! spacing squared at h [m-2 s-2]. f2_dx2_q => NULL(), & !< The Coriolis parameter squared times the grid - !! spacing squared at q, in m2 s-2. + !! spacing squared at q [m-2 s-2]. f2_dx2_u => NULL(), & !< The Coriolis parameter squared times the grid - !! spacing squared at u, in m2 s-2. + !! spacing squared at u [m-2 s-2]. f2_dx2_v => NULL(), & !< The Coriolis parameter squared times the grid - !! spacing squared at v, in m2 s-2. - Rd_dx_h => NULL() !< Deformation radius over grid spacing (non-dim.) + !! spacing squared at v [m-2 s-2]. + 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) - 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] + ebt_struct => NULL() !< Vertical structure function to scale diffusivities with [nondim] ! Parameters integer :: VarMix_Ktop !< Top layer to start downward integrals @@ -100,14 +101,14 @@ module MOM_lateral_mixing_coeffs real :: Res_coef_visc !< A non-dimensional number that determines the function !! of resolution, used for lateral viscosity, as: !! F = 1 / (1 + (Res_coef_visc*Ld/dx)^Res_fn_power) - real :: kappa_smooth !< A diffusivity for smoothing T/S in vanished layers (m2/s) + real :: kappa_smooth !< A diffusivity for smoothing T/S in vanished layers [m2 s-1] integer :: Res_fn_power_khth !< The power of dx/Ld in the KhTh resolution function. Any !! positive integer power may be used, but even powers !! and especially 2 are coded to be more efficient. integer :: Res_fn_power_visc !< The power of dx/Ld in the Kh resolution function. Any !! positive integer power may be used, but even powers !! and especially 2 are coded to be more efficient. - real :: Visbeck_S_max !< Upper bound on slope used in Eady growth rate (nondim). + real :: Visbeck_S_max !< Upper bound on slope used in Eady growth rate [nondim]. ! Diagnostics !>@{ @@ -129,16 +130,17 @@ module MOM_lateral_mixing_coeffs contains !> Calculates and stores the non-dimensional resolution functions -subroutine calc_resoln_function(h, tv, G, GV, CS) +subroutine calc_resoln_function(h, tv, G, GV, US, CS) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness (m or kg/m2) + 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 !< Thermodynamic variables type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(VarMix_CS), pointer :: CS !< Variable mixing coefficients ! Local variables - real :: cg1_q ! The gravity wave speed interpolated to q points, in m s-1. - real :: cg1_u ! The gravity wave speed interpolated to u points, in m s-1. - real :: cg1_v ! The gravity wave speed interpolated to v points, in m s-1. + real :: cg1_q ! The gravity wave speed interpolated to q points [m s-1]. + real :: cg1_u ! The gravity wave speed interpolated to u points [m s-1]. + real :: cg1_v ! The gravity wave speed interpolated to v points [m s-1]. real :: dx_term integer :: power_2 integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz @@ -156,15 +158,15 @@ subroutine calc_resoln_function(h, tv, G, GV, CS) "calc_resoln_function: %ebt_struct is not associated with RESOLN_USE_EBT.") if (CS%Resoln_use_ebt) then ! Both resolution fn and vertical structure are using EBT - call wave_speed(h, tv, G, GV, CS%cg1, CS%wave_speed_CSp, modal_structure=CS%ebt_struct) + 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, CS%cg1, CS%wave_speed_CSp, modal_structure=CS%ebt_struct, use_ebt_mode=.true.) - call wave_speed(h, tv, G, GV, CS%cg1, CS%wave_speed_CSp) + 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) else - call wave_speed(h, tv, G, GV, CS%cg1, CS%wave_speed_CSp) + call wave_speed(h, tv, G, GV, US, CS%cg1, CS%wave_speed_CSp) endif call create_group_pass(CS%pass_cg1, CS%cg1, G%Domain) @@ -172,7 +174,7 @@ subroutine calc_resoln_function(h, tv, G, GV, CS) endif ! Calculate and store the ratio between deformation radius and grid-spacing - ! at h-points (non-dimensional). + ! at h-points [nondim]. if (CS%calculate_rd_dx) then if (.not. associated(CS%Rd_dx_h)) call MOM_error(FATAL, & "calc_resoln_function: %Rd_dx_h is not associated with calculate_rd_dx.") @@ -376,32 +378,33 @@ end subroutine calc_resoln_function !> Calculates and stores functions of isopycnal slopes, e.g. Sx, Sy, S*N, mostly used in the Visbeck et al. !! style scaling of diffusivity -subroutine calc_slope_functions(h, tv, dt, G, GV, CS) +subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thickness (m or kg/m2) + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables - real, intent(in) :: dt !< Time increment (s) + real, intent(in) :: dt !< Time increment [s] type(VarMix_CS), pointer :: CS !< Variable mixing coefficients ! Local variables real, dimension(SZI_(G), SZJ_(G), SZK_(G)+1) :: & - e ! The interface heights relative to mean sea level, in m. - real, dimension(SZIB_(G), SZJ_(G), SZK_(G)+1) :: N2_u ! Square of Brunt-Vaisala freq at u-points - real, dimension(SZI_(G), SZJB_(G), SZK_(G)+1) :: N2_v ! Square of Brunt-Vaisala freq at u-points + e ! The interface heights relative to mean sea level [Z ~> m]. + real, dimension(SZIB_(G), SZJ_(G), SZK_(G)+1) :: N2_u ! Square of Brunt-Vaisala freq at u-points [s-2] + real, dimension(SZI_(G), SZJB_(G), SZK_(G)+1) :: N2_v ! Square of Brunt-Vaisala freq at v-points [s-2] if (.not. associated(CS)) call MOM_error(FATAL, "MOM_lateral_mixing_coeffs.F90, calc_slope_functions:"//& "Module must be initialized before it is used.") if (CS%calculate_Eady_growth_rate) then - call find_eta(h, tv, GV%g_Earth, G, GV, e, halo_size=2) + call find_eta(h, tv, G, GV, US, e, halo_size=2) if (CS%use_stored_slopes) then - call calc_isoneutral_slopes(G, GV, h, e, tv, dt*CS%kappa_smooth, & + call calc_isoneutral_slopes(G, GV, US, h, e, tv, dt*CS%kappa_smooth, & CS%slope_x, CS%slope_y, N2_u, N2_v, 1) - call calc_Visbeck_coeffs(h, e, CS%slope_x, CS%slope_y, N2_u, N2_v, G, GV, CS) + call calc_Visbeck_coeffs(h, CS%slope_x, CS%slope_y, N2_u, N2_v, G, GV, CS) ! call calc_slope_functions_using_just_e(h, G, CS, e, .false.) else !call calc_isoneutral_slopes(G, GV, h, e, tv, dt*CS%kappa_smooth, CS%slope_x, CS%slope_y) - call calc_slope_functions_using_just_e(h, G, GV, CS, e, .true.) + call calc_slope_functions_using_just_e(h, G, GV, US, CS, e, .true.) endif endif @@ -417,29 +420,24 @@ subroutine calc_slope_functions(h, tv, dt, G, GV, CS) end subroutine calc_slope_functions !> Calculates factors used when setting diffusivity coefficients similar to Visbeck et al. -subroutine calc_Visbeck_coeffs(h, e, slope_x, slope_y, N2_u, N2_v, G, GV, CS) +subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, CS) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness (m or kg/m2) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: e !< Interface position (m) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] real, dimension(SZIB_(G),SZJ_(G),SZK_(G)+1), intent(in) :: slope_x !< Zonal isoneutral slope - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)+1), intent(in) :: N2_u !< Brunt-Vaisala frequency at u-points (1/s2) + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)+1), intent(in) :: N2_u !< Brunt-Vaisala frequency at u-points [s-2] real, dimension(SZI_(G),SZJB_(G),SZK_(G)+1), intent(in) :: slope_y !< Meridional isoneutral slope - real, dimension(SZI_(G),SZJB_(G),SZK_(G)+1), intent(in) :: N2_v !< Brunt-Vaisala frequency at v-points (1/s2) + real, dimension(SZI_(G),SZJB_(G),SZK_(G)+1), intent(in) :: N2_v !< Brunt-Vaisala frequency at v-points [s-2] type(VarMix_CS), pointer :: CS !< Variable mixing coefficients + ! Local variables - real :: E_x(SZIB_(G), SZJ_(G)) ! X-slope of interface at u points (for diagnostics) - real :: E_y(SZI_(G), SZJB_(G)) ! Y-slope of interface at u points (for diagnostics) - real :: Khth_Loc ! Locally calculated thickness mixing coefficient (m2/s) - real :: S2 ! Interface slope squared (non-dim) - real :: N2 ! Brunt-Vaisala frequency (1/s) - real :: Hup, Hdn ! Thickness from above, below (m or kg m-2) - real :: H_geom ! The geometric mean of Hup*Hdn, in m or kg m-2. + real :: S2 ! Interface slope squared [nondim] + real :: N2 ! Brunt-Vaisala frequency [s-1] + real :: Hup, Hdn ! Thickness from above, below [H ~> m or kg m-2] + real :: H_geom ! The geometric mean of Hup*Hdn [H ~> m or kg m-2]. integer :: is, ie, js, je, nz integer :: i, j, k, kb_max real :: S2max, wNE, wSE, wSW, wNW - real :: SN_u_local(SZIB_(G), SZJ_(G),SZK_(G)) - real :: SN_v_local(SZI_(G), SZJB_(G),SZK_(G)) real :: H_u(SZIB_(G)), H_v(SZI_(G)) real :: S2_u(SZIB_(G), SZJ_(G)) real :: S2_v(SZI_(G), SZJB_(G)) @@ -456,12 +454,7 @@ subroutine calc_Visbeck_coeffs(h, e, slope_x, slope_y, N2_u, N2_v, G, GV, CS) S2max = CS%Visbeck_S_max**2 -!$OMP parallel default(none) shared(is,ie,js,je,CS,nz,e,G,GV,h, & -!$OMP S2_u,S2_v,slope_x,slope_y, & -!$OMP SN_u_local,SN_v_local,N2_u,N2_v, S2max) & -!$OMP private(E_x,E_y,S2,H_u,H_v,Hdn,Hup,H_geom,N2, & -!$OMP wNE, wSE, wSW, wNW) -!$OMP do + !$OMP parallel do default(shared) do j=js-1,je+1 ; do i=is-1,ie+1 CS%SN_u(i,j) = 0.0 CS%SN_v(i,j) = 0.0 @@ -471,7 +464,7 @@ subroutine calc_Visbeck_coeffs(h, e, slope_x, slope_y, N2_u, N2_v, G, GV, CS) ! calculate the first-mode gravity wave speed and then blend the equatorial ! and midlatitude deformation radii, using calc_resoln_function as a template. -!$OMP do + !$OMP parallel do default(shared) private(S2,H_u,Hdn,Hup,H_geom,N2,wNE,wSE,wSW,wNW) do j = js,je do I=is-1,ie CS%SN_u(I,j) = 0. ; H_u(I) = 0. ; S2_u(I,j) = 0. @@ -517,7 +510,7 @@ subroutine calc_Visbeck_coeffs(h, e, slope_x, slope_y, N2_u, N2_v, G, GV, CS) enddo enddo -!$OMP do + !$OMP parallel do default(shared) private(S2,H_v,Hdn,Hup,H_geom,N2,wNE,wSE,wSW,wNW) do J = js-1,je do i=is,ie CS%SN_v(i,J) = 0. ; H_v(i) = 0. ; S2_v(i,J) = 0. @@ -563,8 +556,6 @@ subroutine calc_Visbeck_coeffs(h, e, slope_x, slope_y, N2_u, N2_v, G, GV, CS) enddo enddo -!$OMP end parallel - ! Offer diagnostic fields for averaging. if (query_averaging_enabled(CS%diag)) then if (CS%id_S2_u > 0) call post_data(CS%id_S2_u, S2_u, CS%diag) @@ -581,26 +572,28 @@ end subroutine calc_Visbeck_coeffs !> The original calc_slope_function() that calculated slopes using !! interface positions only, not accounting for density variations. -subroutine calc_slope_functions_using_just_e(h, G, GV, CS, e, calculate_slopes) +subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slopes) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thickness (m or kg/m2) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(VarMix_CS), pointer :: CS !< Variable mixing coefficients - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: e !< Interface position (m) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: e !< Interface position [Z ~> m] logical, intent(in) :: calculate_slopes !< If true, calculate slopes internally !! otherwise use slopes stored in CS ! Local variables - real :: E_x(SZIB_(G), SZJ_(G)) ! X-slope of interface at u points (for diagnostics) - real :: E_y(SZI_(G), SZJB_(G)) ! Y-slope of interface at u points (for diagnostics) - real :: Khth_Loc ! Locally calculated thickness mixing coefficient (m2/s) - real :: H_cutoff ! Local estimate of a minimum thickness for masking (m) + real :: E_x(SZIB_(G), SZJ_(G)) ! X-slope of interface at u points [nondim] (for diagnostics) + real :: E_y(SZI_(G), SZJB_(G)) ! Y-slope of interface at v points [nondim] (for diagnostics) + real :: H_cutoff ! Local estimate of a minimum thickness for masking [H ~> m or kg m-2] real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected, in H. - real :: S2 ! Interface slope squared (non-dim) - real :: N2 ! Brunt-Vaisala frequency (1/s) - real :: Hup, Hdn ! Thickness from above, below (m or kg m-2) - real :: H_geom ! The geometric mean of Hup*Hdn, in m or kg m-2. - real :: one_meter ! One meter in thickness units of m or kg m-2. + ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: S2 ! Interface slope squared [nondim] + real :: N2 ! Brunt-Vaisala frequency [s-1] + real :: Hup, Hdn ! Thickness from above, below [H ~> m or kg m-2] + real :: H_geom ! The geometric mean of Hup*Hdn [H ~> m or kg m-2]. + real :: Z_to_L ! A conversion factor between from units for e to the + ! units for lateral distances. + real :: one_meter ! One meter in thickness units [H ~> m or kg m-2]. integer :: is, ie, js, je, nz integer :: i, j, k, kb_max real :: SN_u_local(SZIB_(G), SZJ_(G),SZK_(G)) @@ -618,33 +611,25 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, CS, e, calculate_slopes) one_meter = 1.0 * GV%m_to_H h_neglect = GV%H_subroundoff - H_cutoff = real(2*nz) * (GV%Angstrom + h_neglect) - -!$OMP parallel default(none) shared(is,ie,js,je,CS,nz,e,G,GV,h,H_cutoff,h_neglect, & -!$OMP one_meter,SN_u_local,SN_v_local,calculate_slopes) & -!$OMP private(E_x,E_y,S2,Hdn,Hup,H_geom,N2) -!$OMP do - do j=js-1,je+1 ; do i=is-1,ie+1 - CS%SN_u(i,j) = 0.0 - CS%SN_v(i,j) = 0.0 - enddo ; enddo + H_cutoff = real(2*nz) * (GV%Angstrom_H + h_neglect) + Z_to_L = US%Z_to_m ! To set the length scale based on the deformation radius, use wave_speed to ! calculate the first-mode gravity wave speed and then blend the equatorial ! and midlatitude deformation radii, using calc_resoln_function as a template. -!$OMP do + !$OMP parallel do default(shared) private(E_x,E_y,S2,Hdn,Hup,H_geom,N2) do k=nz,CS%VarMix_Ktop,-1 if (calculate_slopes) then ! Calculate the interface slopes E_x and E_y and u- and v- points respectively do j=js-1,je+1 ; do I=is-1,ie - E_x(I,j) = (e(i+1,j,K)-e(i,j,K))*G%IdxCu(I,j) + E_x(I,j) = Z_to_L*(e(i+1,j,K)-e(i,j,K))*G%IdxCu(I,j) ! Mask slopes where interface intersects topography if (min(h(I,j,k),h(I+1,j,k)) < H_cutoff) E_x(I,j) = 0. enddo ; enddo do J=js-1,je ; do i=is-1,ie+1 - E_y(i,J) = (e(i,j+1,K)-e(i,j,K))*G%IdyCv(i,J) + E_y(i,J) = Z_to_L*(e(i,j+1,K)-e(i,j,K))*G%IdyCv(i,J) ! Mask slopes where interface intersects topography if (min(h(i,J,k),h(i,J+1,k)) < H_cutoff) E_y(I,j) = 0. enddo ; enddo @@ -666,10 +651,10 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, CS, e, calculate_slopes) Hdn = 2.*h(i,j,k)*h(i,j,k-1) / (h(i,j,k) + h(i,j,k-1) + h_neglect) Hup = 2.*h(i+1,j,k)*h(i+1,j,k-1) / (h(i+1,j,k) + h(i+1,j,k-1) + h_neglect) H_geom = sqrt(Hdn*Hup) - N2 = GV%g_prime(k) / (GV%H_to_m * max(Hdn,Hup,one_meter)) + N2 = GV%g_prime(k)*US%m_to_Z**2 / (GV%H_to_Z * max(Hdn,Hup,one_meter)) if (min(h(i,j,k-1), h(i+1,j,k-1), h(i,j,k), h(i+1,j,k)) < H_cutoff) & S2 = 0.0 - SN_u_local(I,j,k) = (H_geom * GV%H_to_m) * S2 * N2 + SN_u_local(I,j,k) = (H_geom * GV%H_to_Z) * S2 * N2 enddo ; enddo do J=js-1,je ; do i=is,ie S2 = ( E_y(i,J)**2 + 0.25*( & @@ -677,52 +662,57 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, CS, e, calculate_slopes) Hdn = 2.*h(i,j,k)*h(i,j,k-1) / (h(i,j,k) + h(i,j,k-1) + h_neglect) Hup = 2.*h(i,j+1,k)*h(i,j+1,k-1) / (h(i,j+1,k) + h(i,j+1,k-1) + h_neglect) H_geom = sqrt(Hdn*Hup) - N2 = GV%g_prime(k) / (GV%H_to_m * max(Hdn,Hup,one_meter)) + N2 = GV%g_prime(k)*US%m_to_Z**2 / (GV%H_to_Z * max(Hdn,Hup,one_meter)) if (min(h(i,j,k-1), h(i,j+1,k-1), h(i,j,k), h(i,j+1,k)) < H_cutoff) & S2 = 0.0 - SN_v_local(i,J,k) = (H_geom * GV%H_to_m) * S2 * N2 + SN_v_local(i,J,k) = (H_geom * GV%H_to_Z) * S2 * N2 enddo ; enddo enddo ! k -!$OMP do - do j = js,je; + !$OMP parallel do default(shared) + do j=js,je + do I=is-1,ie ; CS%SN_u(I,j) = 0.0 ; enddo do k=nz,CS%VarMix_Ktop,-1 ; do I=is-1,ie CS%SN_u(I,j) = CS%SN_u(I,j) + SN_u_local(I,j,k) enddo ; enddo ! SN above contains S^2*N^2*H, convert to vertical average of S*N do I=is-1,ie - !SN_u(I,j) = sqrt( SN_u(I,j) / ( max(G%bathyT(I,j), G%bathyT(I+1,j)) + GV%Angstrom ) ) + !SN_u(I,j) = sqrt( SN_u(I,j) / ( max(G%bathyT(I,j), G%bathyT(I+1,j)) + GV%Angstrom_Z ) )) !The code below behaves better than the line above. Not sure why? AJA - if ( min(G%bathyT(I,j), G%bathyT(I+1,j)) > H_cutoff*GV%H_to_m ) then - CS%SN_u(I,j) = G%mask2dCu(I,j) * sqrt( CS%SN_u(I,j) / max(G%bathyT(I,j), G%bathyT(I+1,j)) ) + if ( min(G%bathyT(I,j), G%bathyT(I+1,j)) > H_cutoff*GV%H_to_Z ) then + CS%SN_u(I,j) = G%mask2dCu(I,j) * sqrt( CS%SN_u(I,j) / & + (max(G%bathyT(I,j), G%bathyT(I+1,j))) ) else CS%SN_u(I,j) = 0.0 endif enddo enddo -!$OMP do + !$OMP parallel do default(shared) do J=js-1,je - do k=nz,CS%VarMix_Ktop,-1 ; do I=is,ie + do i=is,ie ; CS%SN_v(i,J) = 0.0 ; enddo + do k=nz,CS%VarMix_Ktop,-1 ; do i=is,ie CS%SN_v(i,J) = CS%SN_v(i,J) + SN_v_local(i,J,k) enddo ; enddo do i=is,ie - !SN_v(i,J) = sqrt( SN_v(i,J) / ( max(G%bathyT(i,J), G%bathyT(i,J+1)) + GV%Angstrom ) ) + !SN_v(i,J) = sqrt( SN_v(i,J) / ( max(G%bathyT(i,J), G%bathyT(i,J+1)) + GV%Angstrom_Z ) )) !The code below behaves better than the line above. Not sure why? AJA - if ( min(G%bathyT(I,j), G%bathyT(I+1,j)) > H_cutoff*GV%H_to_m ) then - CS%SN_v(i,J) = G%mask2dCv(i,J) * sqrt( CS%SN_v(i,J) / max(G%bathyT(i,J), G%bathyT(i,J+1)) ) + if ( min(G%bathyT(I,j), G%bathyT(I+1,j)) > H_cutoff*GV%H_to_Z ) then + CS%SN_v(i,J) = G%mask2dCv(i,J) * sqrt( CS%SN_v(i,J) / & + (max(G%bathyT(i,J), G%bathyT(i,J+1))) ) else CS%SN_v(I,j) = 0.0 endif enddo enddo -!$OMP end parallel end subroutine calc_slope_functions_using_just_e !> Initializes the variables mixing coefficients container -subroutine VarMix_init(Time, G, param_file, diag, CS) +subroutine VarMix_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 !< Ocean 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 !< Parameter file handles type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure type(VarMix_CS), pointer :: CS !< Variable mixing coefficients @@ -730,7 +720,7 @@ subroutine VarMix_init(Time, G, param_file, diag, CS) real :: KhTr_Slope_Cff, KhTh_Slope_Cff, oneOrTwo, N2_filter_depth real :: KhTr_passivity_coeff real, parameter :: absurdly_small_freq2 = 1e-34 ! A miniscule frequency - ! squared that is used to avoid division by 0, in s-2. This + ! squared that is used to avoid division by 0 [s-2]. This ! value is roughly (pi / (the age of the universe) )^2. logical :: Gill_equatorial_Ld, use_FGNV_streamfn, use_MEKE, in_use real :: MLE_front_length @@ -804,6 +794,7 @@ subroutine VarMix_init(Time, G, param_file, diag, CS) CS%calculate_cg1 = CS%calculate_cg1 .or. use_FGNV_streamfn call get_param(param_file, mdl, "USE_MEKE", use_MEKE, & default=.false., do_not_log=.true.) + CS%calculate_Rd_dx = CS%calculate_Rd_dx .or. use_MEKE CS%calculate_Eady_growth_rate = CS%calculate_Eady_growth_rate .or. use_MEKE call get_param(param_file, mdl, "KHTR_PASSIVITY_COEFF", KhTr_passivity_coeff, & default=0., do_not_log=.true.) @@ -839,7 +830,7 @@ subroutine VarMix_init(Time, G, param_file, diag, CS) call get_param(param_file, mdl, "KD_SMOOTH", CS%kappa_smooth, & "A diapycnal diffusivity that is used to interpolate \n"//& "more sensible values of T & S into thin layers.", & - default=1.0e-6) + default=1.0e-6, scale=US%m_to_Z**2) !### Add units argument. endif if (CS%calculate_Eady_growth_rate) then @@ -934,10 +925,10 @@ subroutine VarMix_init(Time, G, param_file, diag, CS) "used which introduced potential restart issues. This flag will be \n"//& "deprecated in a future release.", default=.false.) if (CS%interpolate_Res_fn) then - if (CS%Res_coef_visc .ne. CS%Res_coef_khth) call MOM_error(FATAL, & + if (CS%Res_coef_visc /= CS%Res_coef_khth) call MOM_error(FATAL, & "MOM_lateral_mixing_coeffs.F90, VarMix_init:"//& "When INTERPOLATE_RES_FN=True, VISC_RES_FN_POWER must equal KH_RES_SCALE_COEF.") - if (CS%Res_fn_power_visc .ne. CS%Res_fn_power_khth) call MOM_error(FATAL, & + if (CS%Res_fn_power_visc /= CS%Res_fn_power_khth) call MOM_error(FATAL, & "MOM_lateral_mixing_coeffs.F90, VarMix_init:"//& "When INTERPOLATE_RES_FN=True, VISC_RES_FN_POWER must equal KH_RES_FN_POWER.") endif @@ -1053,8 +1044,8 @@ end subroutine VarMix_init !! r(\Delta,L_d) = \frac{1}{1+(\alpha R)^p} !! \f] !! -!! The resolution function can be applied independently to thickness diffusion (module mom_thickness_diffuse), tracer diffusion (mom_tracer_hordiff) -!! lateral viscosity (mom_hor_visc). +!! The resolution function can be applied independently to thickness diffusion (module mom_thickness_diffuse), +!! tracer diffusion (mom_tracer_hordiff) lateral viscosity (mom_hor_visc). !! !! Robert Hallberg, 2013: Using a resolution function to regulate parameterizations of oceanic mesoscale eddy effects. !! Ocean Modelling, 71, pp 92-103. http://dx.doi.org/10.1016/j.ocemod.2013.08.007 @@ -1075,8 +1066,8 @@ end subroutine VarMix_init !! !! \section section_Vicbeck Visbeck diffusivity !! -!! This module also calculates factors used in setting the thickness diffusivity similar to a Visbeck et al., 1997, scheme. -!! The factors are combined in mom_thickness_diffuse::thickness_diffuse() but calculated in this module. +!! This module also calculates factors used in setting the thickness diffusivity similar to a Visbeck et al., 1997, +!! scheme. The factors are combined in mom_thickness_diffuse::thickness_diffuse() but calculated in this module. !! !! \f[ !! \kappa_h = \alpha_s L_s^2 S N @@ -1098,9 +1089,9 @@ end subroutine VarMix_init !! !! \section section_vertical_structure_khth Vertical structure function for KhTh !! -!! The thickness diffusivity can be prescribed a vertical distribution with the shape of the equivalent barotropic velocity mode. -!! The structure function is stored in the control structure for thie module (varmix_cs) but is calculated use subroutines in -!! mom_wave_speed. +!! The thickness diffusivity can be prescribed a vertical distribution with the shape of the equivalent barotropic +!! velocity mode. The structure function is stored in the control structure for thie module (varmix_cs) but is +!! calculated using subroutines in mom_wave_speed. !! !! | Symbol | Module parameter | !! | ------ | --------------- | diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 840a0c3373..d2a1abb730 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -15,7 +15,8 @@ module MOM_mixed_layer_restrat use MOM_hor_index, only : hor_index_type use MOM_io, only : vardesc, var_desc use MOM_lateral_mixing_coeffs, only : VarMix_CS -use MOM_restart, only : register_restart_field, MOM_restart_CS +use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use MOM_EOS, only : calculate_density @@ -28,38 +29,41 @@ module MOM_mixed_layer_restrat public mixedlayer_restrat_init public mixedlayer_restrat_register_restarts +! 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. + !> Control structure for mom_mixed_layer_restrat type, public :: mixedlayer_restrat_CS ; private - real :: ml_restrat_coef !< A non-dimensional factor by which the - !! instability is enhanced over what would be - !! predicted based on the resolved gradients. This - !! increases with grid spacing^2, up to something + real :: ml_restrat_coef !< A non-dimensional factor by which the instability is enhanced + !! over what would be predicted based on the resolved gradients + !! [nondim]. This increases with grid spacing^2, up to something !! of order 500. - real :: ml_restrat_coef2 !< As for ml_restrat_coef but using the slow filtered MLD. - real :: front_length !< If non-zero, is the frontal-length scale used to calculate the + real :: ml_restrat_coef2 !< As for ml_restrat_coef but using the slow filtered MLD [nondim]. + real :: front_length !< If non-zero, is the frontal-length scale [m] 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. logical :: MLE_use_PBL_MLD !< If true, use the MLD provided by the PBL parameterization. !! if false, MLE will calculate a MLD based on a density difference !! based on the parameter MLE_DENSITY_DIFF. - real :: MLE_MLD_decay_time !< Time-scale to use in a running-mean when MLD is retreating (s). - real :: MLE_MLD_decay_time2 !< Time-scale to use in a running-mean when filtered MLD is retreating (s). - real :: MLE_density_diff !< Density difference used in detecting mixed-layer - !! depth (kg/m3). + real :: MLE_MLD_decay_time !< Time-scale to use in a running-mean when MLD is retreating [s]. + real :: MLE_MLD_decay_time2 !< Time-scale to use in a running-mean when filtered MLD is retreating [s]. + real :: MLE_density_diff !< Density difference used in detecting mixed-layer depth [kgm-3]. real :: MLE_tail_dh !< Fraction by which to extend the mixed-layer restratification !! depth used for a smoother stream function at the base of - !! the mixed-layer. - real :: MLE_MLD_stretch !< A scaling coefficient for stretching/shrinking the MLD - !! used in the MLE scheme. This simply multiplies MLD wherever used. + !! the mixed-layer [nondim]. + real :: MLE_MLD_stretch !< A scaling coefficient for stretching/shrinking the MLD used in + !! the MLE scheme [nondim]. This simply multiplies MLD wherever used. logical :: MLE_use_MLD_ave_bug !< If true, do not account for MLD mismatch to interface positions. logical :: debug = .false. !< If true, calculate checksums of fields for debugging. type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the !! timing of diagnostic output. real, dimension(:,:), pointer :: & - MLD_filtered => NULL(), & !< Time-filtered MLD (H units) - MLD_filtered_slow => NULL() !< Slower time-filtered MLD (H units) + MLD_filtered => NULL(), & !< Time-filtered MLD [H ~> m or kg m-2] + MLD_filtered_slow => NULL() !< Slower time-filtered MLD [H ~> m or kg m-2] !>@{ !! Diagnostic identifier @@ -84,16 +88,20 @@ module MOM_mixed_layer_restrat !> Driver for the mixed-layer restratification parameterization. !! The code branches between two different implementations depending !! on whether the bulk-mixed layer or a general coordinate are in use. -subroutine mixedlayer_restrat(h, uhtr, vhtr, tv, forces, dt, MLD, VarMix, G, GV, CS) +subroutine mixedlayer_restrat(h, uhtr, vhtr, tv, forces, dt, MLD, VarMix, G, GV, US, CS) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thickness (H units = m or kg/m2) - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: uhtr !< Accumulated zonal mass flux (m3 or kg) - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: vhtr !< Accumulated meridional mass flux (m3 or kg) + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: uhtr !< Accumulated zonal mass flux + !! [H m2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: vhtr !< Accumulated meridional mass flux + !! [H m2 ~> m3 or kg] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables structure type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces - real, intent(in) :: dt !< Time increment (sec) - real, dimension(:,:), pointer :: MLD !< Mixed layer depth provided by PBL scheme (H units) + real, intent(in) :: dt !< Time increment [s] + real, dimension(:,:), pointer :: MLD !< Mixed layer depth provided by the + !! PBL scheme [H ~> m or kg m-2] type(VarMix_CS), pointer :: VarMix !< Container for derived fields type(mixedlayer_restrat_CS), pointer :: CS !< Module control structure @@ -101,72 +109,74 @@ subroutine mixedlayer_restrat(h, uhtr, vhtr, tv, forces, dt, MLD, VarMix, G, GV, "Module must be initialized before it is used.") if (GV%nkml>0) then - call mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, CS) + call mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) else - call mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD, VarMix, G, GV, CS) + call mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD, VarMix, G, GV, US, CS) endif end subroutine mixedlayer_restrat !> Calculates a restratifying flow in the mixed layer. -subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, G, GV, CS) +subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, G, GV, US, CS) ! Arguments type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thickness (H units = m or kg/m2) - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: uhtr !< Accumulated zonal mass flux (m3 or kg) - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: vhtr !< Accumulated meridional mass flux (m3 or kg) + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: uhtr !< Accumulated zonal mass flux + !! [H m2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: vhtr !< Accumulated meridional mass flux + !! [H m2 ~> m3 or kg] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables structure type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces - real, intent(in) :: dt !< Time increment (sec) - real, dimension(:,:), pointer :: MLD_in !< Mixed layer depth provided by PBL scheme, in m (not H) + real, intent(in) :: dt !< Time increment [s] + real, dimension(:,:), pointer :: MLD_in !< Mixed layer depth provided by the + !! PBL scheme [m] (not H) type(VarMix_CS), pointer :: VarMix !< Container for derived fields type(mixedlayer_restrat_CS), pointer :: CS !< Module control structure ! Local variables - real :: uhml(SZIB_(G),SZJ_(G),SZK_(G)) ! zonal mixed layer transport (m3/s or kg/s) - real :: vhml(SZI_(G),SZJB_(G),SZK_(G)) ! merid mixed layer transport (m3/s or kg/s) + real :: uhml(SZIB_(G),SZJ_(G),SZK_(G)) ! zonal mixed layer transport [H m2 s-1 ~> m3 s-1 or kg s-1] + real :: vhml(SZI_(G),SZJB_(G),SZK_(G)) ! merid mixed layer transport [H m2 s-1 ~> m3 s-1 or kg s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & h_avail ! The volume available for diffusion out of each face of each - ! sublayer of the mixed layer, divided by dt, in units - ! of H * m2 s-1 (i.e., m3 s-1 or kg s-1). + ! sublayer of the mixed layer, divided by dt [H m2 s-1 ~> m3 s-1 or kg s-1]. real, dimension(SZI_(G),SZJ_(G)) :: & - MLD_fast, & ! Mixed layer depth actually used in MLE restratification parameterization (H units) - htot_fast, & ! The sum of the thicknesses of layers in the mixed layer (H units) - Rml_av_fast, & ! g_Rho0 times the average mixed layer density (m s-2) - MLD_slow, & ! Mixed layer depth actually used in MLE restratification parameterization (H units) - htot_slow, & ! The sum of the thicknesses of layers in the mixed layer (H units) - Rml_av_slow ! g_Rho0 times the average mixed layer density (m s-2) - real :: g_Rho0 ! G_Earth/Rho0 (m4 s-2 kg-1) - real :: rho_ml(SZI_(G)) ! Potential density relative to the surface (kg m-3) - real :: p0(SZI_(G)) ! A pressure of 0 (Pa) - - real :: h_vel ! htot interpolated onto velocity points in metre (not H). - real :: absf ! absolute value of f, interpolated to velocity points (s-1) - real :: u_star ! surface friction velocity, interpolated to velocity points (m s-1) - real :: mom_mixrate ! rate at which momentum is homogenized within mixed layer (s-1) - real :: timescale ! mixing growth timescale (sec) - real :: h_neglect ! tiny thickness usually lost in roundoff so can be neglected (H units) - real :: dz_neglect ! A tiny thickness (in m) that is usually lost in roundoff so can be neglected - real :: I4dt ! 1/(4 dt) (sec-1) - real :: Ihtot,Ihtot_slow! total mixed layer thickness + MLD_fast, & ! Mixed layer depth actually used in MLE restratification parameterization [H ~> m or kg m-2] + htot_fast, & ! The sum of the thicknesses of layers in the mixed layer [H ~> m or kg m-2] + Rml_av_fast, & ! g_Rho0 times the average mixed layer density [m s-2] + MLD_slow, & ! Mixed layer depth actually used in MLE restratification parameterization [H ~> m or kg m-2] + htot_slow, & ! The sum of the thicknesses of layers in the mixed layer [H ~> m or kg m-2] + Rml_av_slow ! g_Rho0 times the average mixed layer density [m s-2] + real :: g_Rho0 ! G_Earth/Rho0 [m5 Z-1 s-2 kg-1 ~> m4 s-2 kg-1] + real :: rho_ml(SZI_(G)) ! Potential density relative to the surface [kg m-3] + real :: p0(SZI_(G)) ! A pressure of 0 [Pa] + + real :: h_vel ! htot interpolated onto velocity points [Z ~> m] (not H). + real :: absf ! absolute value of f, interpolated to velocity points [s-1] + real :: u_star ! surface friction velocity, interpolated to velocity points [Z s-1 ~> m s-1]. + real :: mom_mixrate ! rate at which momentum is homogenized within mixed layer [s-1] + real :: timescale ! mixing growth timescale [s] + real :: h_neglect ! tiny thickness usually lost in roundoff so can be neglected [H ~> m or kg m-2] + real :: dz_neglect ! A tiny thickness that is usually lost in roundoff so can be neglected [Z ~> m] + real :: I4dt ! 1/(4 dt) [s-1] + real :: Ihtot,Ihtot_slow! Inverses of the total mixed layer thickness [H-1 ~> m-1 or m2 kg-1] real :: a(SZK_(G)) ! A non-dimensional value relating the overall flux ! magnitudes (uDml & vDml) to the realized flux in a ! layer. The vertical sum of a() through the pieces of ! the mixed layer must be 0. real :: b(SZK_(G)) ! As for a(k) but for the slow-filtered MLD real :: uDml(SZIB_(G)) ! The zonal and meridional volume fluxes in the upper - real :: vDml(SZI_(G)) ! half of the mixed layer in H m2 s-1 (m3 s-1 or kg s-1). + real :: vDml(SZI_(G)) ! half of the mixed layer [H m2 s-1 ~> m3 s-1 or kg s-1]. real :: uDml_slow(SZIB_(G)) ! The zonal and meridional volume fluxes in the upper - real :: vDml_slow(SZI_(G)) ! half of the mixed layer in H m2 s-1 (m3 s-1 or kg s-1). - real :: utimescale_diag(SZIB_(G),SZJ_(G)) ! restratification timescales - real :: vtimescale_diag(SZI_(G),SZJB_(G)) ! in the zonal and meridional - ! directions, in s, stored in 2-D - ! arrays for diagnostic purposes. + real :: vDml_slow(SZI_(G)) ! half of the mixed layer [H m2 s-1 ~> m3 s-1 or kg s-1]. + real :: utimescale_diag(SZIB_(G),SZJ_(G)) ! restratification timescales in the zonal and + real :: vtimescale_diag(SZI_(G),SZJB_(G)) ! meridional directions [s], stored in 2-D arrays + ! for diagnostic purposes. real :: uDml_diag(SZIB_(G),SZJ_(G)), vDml_diag(SZI_(G),SZJB_(G)) integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz real, dimension(SZI_(G)) :: rhoSurf, deltaRhoAtKm1, deltaRhoAtK - real, dimension(SZI_(G)) :: dK, dKm1 ! Depths of layer centers, in H. - real, dimension(SZI_(G)) :: pRef_MLD ! A reference pressure for calculating the mixed layer densities, in Pa. + real, dimension(SZI_(G)) :: dK, dKm1 ! Depths of layer centers [H ~> m or kg m-2]. + real, dimension(SZI_(G)) :: pRef_MLD ! A reference pressure for calculating the mixed layer densities [Pa]. real, dimension(SZI_(G)) :: rhoAtK, rho1, d1, pRef_N2 ! Used for N2 real :: aFac, bFac, ddRho real :: hAtVel, zpa, zpb, dh, res_scaling_fac, I_l_f @@ -215,7 +225,8 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var enddo ! k-loop do i = is-1, ie+1 MLD_fast(i,j) = CS%MLE_MLD_stretch * MLD_fast(i,j) - if ((MLD_fast(i,j)==0.) .and. (deltaRhoAtK(i)0.) then res_upscale = .true. @@ -282,10 +293,10 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var endif p0(:) = 0.0 -!$OMP parallel default(none) shared(is,ie,js,je,G,GV,htot_fast,Rml_av_fast,tv,p0,h,h_avail,& +!$OMP parallel default(none) shared(is,ie,js,je,G,GV,US,htot_fast,Rml_av_fast,tv,p0,h,h_avail,& !$OMP h_neglect,g_Rho0,I4dt,CS,uhml,uhtr,dt,vhml,vhtr, & !$OMP utimescale_diag,vtimescale_diag,forces,dz_neglect, & -!$OMP htot_slow,MLD_slow,Rml_av_slow,VarMix,I_l_f, & +!$OMP htot_slow,MLD_slow,Rml_av_slow,VarMix,I_l_f, & !$OMP res_upscale, & !$OMP nz,MLD_fast,uDml_diag,vDml_diag,proper_averaging) & !$OMP private(rho_ml,h_vel,u_star,absf,mom_mixrate,timescale, & @@ -301,7 +312,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var keep_going = .true. do k=1,nz do i=is-1,ie+1 - h_avail(i,j,k) = max(I4dt*G%areaT(i,j)*(h(i,j,k)-GV%Angstrom),0.0) + h_avail(i,j,k) = max(I4dt*G%areaT(i,j)*(h(i,j,k)-GV%Angstrom_H),0.0) enddo if (keep_going) then call calculate_density(tv%T(:,j,k),tv%S(:,j,k),p0,rho_ml(:),is-1,ie-is+3,tv%eqn_of_state) @@ -333,9 +344,9 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var if (CS%debug) then call hchksum(h,'mixed_layer_restrat: h',G%HI,haloshift=1,scale=GV%H_to_m) - call hchksum(forces%ustar,'mixed_layer_restrat: u*',G%HI,haloshift=1) + call hchksum(forces%ustar,'mixed_layer_restrat: u*',G%HI,haloshift=1,scale=US%Z_to_m) call hchksum(MLD_fast,'mixed_layer_restrat: MLD',G%HI,haloshift=1,scale=GV%H_to_m) - call hchksum(Rml_av_fast,'mixed_layer_restrat: rml',G%HI,haloshift=1) + call hchksum(Rml_av_fast,'mixed_layer_restrat: rml',G%HI,haloshift=1, scale=US%m_to_Z) endif ! TO DO: @@ -355,23 +366,23 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var ! 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. - h_vel = 0.5*((htot_fast(i,j) + htot_fast(i+1,j)) + h_neglect) * GV%H_to_m + h_vel = 0.5*((htot_fast(i,j) + htot_fast(i+1,j)) + h_neglect) * GV%H_to_Z 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 if (res_upscale) timescale = timescale * res_scaling_fac uDml(I) = timescale * G%mask2dCu(I,j)*G%dyCu(I,j)* & - G%IdxCu(I,j)*(Rml_av_fast(i+1,j)-Rml_av_fast(i,j)) * (h_vel**2 * GV%m_to_H) + G%IdxCu(I,j)*(Rml_av_fast(i+1,j)-Rml_av_fast(i,j)) * (h_vel**2 * GV%Z_to_H) ! As above but using the slow filtered MLD - h_vel = 0.5*((htot_slow(i,j) + htot_slow(i+1,j)) + h_neglect) * GV%H_to_m + h_vel = 0.5*((htot_slow(i,j) + htot_slow(i+1,j)) + h_neglect) * GV%H_to_Z 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_coef2 if (res_upscale) timescale = timescale * res_scaling_fac uDml_slow(I) = timescale * G%mask2dCu(I,j)*G%dyCu(I,j)* & - G%IdxCu(I,j)*(Rml_av_slow(i+1,j)-Rml_av_slow(i,j)) * (h_vel**2 * GV%m_to_H) + G%IdxCu(I,j)*(Rml_av_slow(i+1,j)-Rml_av_slow(i,j)) * (h_vel**2 * GV%Z_to_H) if (uDml(I) + uDml_slow(I) == 0.) then do k=1,nz ; uhml(I,j,k) = 0.0 ; enddo @@ -431,23 +442,23 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var ! 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. - h_vel = 0.5*((htot_fast(i,j) + htot_fast(i,j+1)) + h_neglect) * GV%H_to_m + h_vel = 0.5*((htot_fast(i,j) + htot_fast(i,j+1)) + h_neglect) * GV%H_to_Z 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 if (res_upscale) timescale = timescale * res_scaling_fac vDml(i) = timescale * G%mask2dCv(i,J)*G%dxCv(i,J)* & - G%IdyCv(i,J)*(Rml_av_fast(i,j+1)-Rml_av_fast(i,j)) * (h_vel**2 * GV%m_to_H) + G%IdyCv(i,J)*(Rml_av_fast(i,j+1)-Rml_av_fast(i,j)) * (h_vel**2 * GV%Z_to_H) ! As above but using the slow filtered MLD - h_vel = 0.5*((htot_slow(i,j) + htot_slow(i,j+1)) + h_neglect) * GV%H_to_m + h_vel = 0.5*((htot_slow(i,j) + htot_slow(i,j+1)) + h_neglect) * GV%H_to_Z 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_coef2 if (res_upscale) timescale = timescale * res_scaling_fac vDml_slow(i) = timescale * G%mask2dCv(i,J)*G%dxCv(i,J)* & - G%IdyCv(i,J)*(Rml_av_slow(i,j+1)-Rml_av_slow(i,j)) * (h_vel**2 * GV%m_to_H) + G%IdyCv(i,J)*(Rml_av_slow(i,j+1)-Rml_av_slow(i,j)) * (h_vel**2 * GV%Z_to_H) if (vDml(i) + vDml_slow(i) == 0.) then do k=1,nz ; vhml(i,J,k) = 0.0 ; enddo @@ -536,50 +547,52 @@ end subroutine mixedlayer_restrat_general !> Calculates a restratifying flow assuming a 2-layer bulk mixed layer. -subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, CS) +subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thickness (H units = m or kg/m2) - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: uhtr !< Accumulated zonal mass flux (m3 or kg) - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: vhtr !< Accumulated meridional mass flux (m3 or kg) + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: uhtr !< Accumulated zonal mass flux + !! [H m2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: vhtr !< Accumulated meridional mass flux + !! [H m2 ~> m3 or kg] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables structure type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces - real, intent(in) :: dt !< Time increment (sec) + real, intent(in) :: dt !< Time increment [s] type(mixedlayer_restrat_CS), pointer :: CS !< Module control structure ! Local variables - real :: uhml(SZIB_(G),SZJ_(G),SZK_(G)) ! zonal mixed layer transport (m3/s or kg/s) - real :: vhml(SZI_(G),SZJB_(G),SZK_(G)) ! merid mixed layer transport (m3/s or kg/s) + real :: uhml(SZIB_(G),SZJ_(G),SZK_(G)) ! zonal mixed layer transport [H m2 s-1 ~> m3 s-1 or kg s-1] + real :: vhml(SZI_(G),SZJB_(G),SZK_(G)) ! merid mixed layer transport [H m2 s-1 ~> m3 s-1 or kg s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & h_avail ! The volume available for diffusion out of each face of each - ! sublayer of the mixed layer, divided by dt, in units - ! of H m2 s-1 (i.e., m3 s-1 or kg s-1). + ! sublayer of the mixed layer, divided by dt [H m2 s-1 ~> m3 s-1 or kg s-1]. real, dimension(SZI_(G),SZJ_(G)) :: & - htot, & ! The sum of the thicknesses of layers in the mixed layer (H units) - Rml_av ! g_Rho0 times the average mixed layer density (m s-2) - real :: g_Rho0 ! G_Earth/Rho0 (m4 s-2 kg-1) - real :: Rho0(SZI_(G)) ! Potential density relative to the surface (kg m-3) - real :: p0(SZI_(G)) ! A pressure of 0 (Pa) - - real :: h_vel ! htot interpolated onto velocity points (meter; not H) - real :: absf ! absolute value of f, interpolated to velocity points (s-1) - real :: u_star ! surface friction velocity, interpolated to velocity points (m s-1) - real :: mom_mixrate ! rate at which momentum is homogenized within mixed layer (s-1) - real :: timescale ! mixing growth timescale (sec) - real :: h_neglect ! tiny thickness usually lost in roundoff and can be neglected (H units) - real :: dz_neglect ! tiny thickness (in m) that usually lost in roundoff and can be neglected (meter) + htot, & ! The sum of the thicknesses of layers in the mixed layer [H ~> m or kg m-2] + Rml_av ! g_Rho0 times the average mixed layer density [m s-2] + real :: g_Rho0 ! G_Earth/Rho0 [m5 Z-1 s-2 kg-1 ~> m4 s-2 kg-1] + real :: Rho0(SZI_(G)) ! Potential density relative to the surface [kg m-3] + real :: p0(SZI_(G)) ! A pressure of 0 [Pa] + + real :: h_vel ! htot interpolated onto velocity points [Z ~> m]. (The units are not H.) + real :: absf ! absolute value of f, interpolated to velocity points [s-1] + real :: u_star ! surface friction velocity, interpolated to velocity points [Z s-1 ~> m s-1]. + real :: mom_mixrate ! rate at which momentum is homogenized within mixed layer [s-1] + real :: timescale ! mixing growth timescale [s] + real :: h_neglect ! tiny thickness usually lost in roundoff and can be neglected [H ~> m or kg m-2] + real :: dz_neglect ! tiny thickness that usually lost in roundoff and can be neglected [Z ~> m] real :: I4dt ! 1/(4 dt) - real :: I2htot ! Twice the total mixed layer thickness at velocity points (H units) - real :: z_topx2 ! depth of the top of a layer at velocity points (H units) - real :: hx2 ! layer thickness at velocity points (H units) + real :: I2htot ! Twice the total mixed layer thickness at velocity points [H ~> m or kg m-2] + real :: z_topx2 ! depth of the top of a layer at velocity points [H ~> m or kg m-2] + real :: hx2 ! layer thickness at velocity points [H ~> m or kg m-2] real :: a(SZK_(G)) ! A non-dimensional value relating the overall flux ! magnitudes (uDml & vDml) to the realized flux in a ! layer. The vertical sum of a() through the pieces of ! the mixed layer must be 0. real :: uDml(SZIB_(G)) ! The zonal and meridional volume fluxes in the upper - real :: vDml(SZI_(G)) ! half of the mixed layer in H m2 s-1 (m3 s-1 or kg s-1). + real :: vDml(SZI_(G)) ! half of the mixed layer [H m2 s-1 ~> m3 s-1 or kg s-1]. real :: utimescale_diag(SZIB_(G),SZJ_(G)) ! The restratification timescales real :: vtimescale_diag(SZI_(G),SZJB_(G)) ! in the zonal and meridional - ! directions (sec), stored in 2-D + ! directions [s], stored in 2-D ! arrays for diagnostic purposes. real :: uDml_diag(SZIB_(G),SZJ_(G)), vDml_diag(SZI_(G),SZJB_(G)) logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. @@ -594,10 +607,10 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, CS) uDml(:) = 0.0 ; vDml(:) = 0.0 I4dt = 0.25 / dt - g_Rho0 = GV%g_Earth/GV%Rho0 + g_Rho0 = GV%g_Earth / GV%Rho0 use_EOS = associated(tv%eqn_of_state) h_neglect = GV%H_subroundoff - dz_neglect = GV%H_subroundoff*GV%H_to_m + dz_neglect = GV%H_subroundoff*GV%H_to_Z if (.not.use_EOS) call MOM_error(FATAL, "MOM_mixedlayer_restrat: "// & "An equation of state must be used with this module.") @@ -605,7 +618,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, CS) ! Fix this later for nkml >= 3. p0(:) = 0.0 -!$OMP parallel default(none) shared(is,ie,js,je,G,GV,htot,Rml_av,tv,p0,h,h_avail, & +!$OMP parallel default(none) shared(is,ie,js,je,G,GV,US,htot,Rml_av,tv,p0,h,h_avail, & !$OMP h_neglect,g_Rho0,I4dt,CS,uhml,uhtr,dt,vhml,vhtr, & !$OMP utimescale_diag,vtimescale_diag,forces,dz_neglect, & !$OMP uDml_diag,vDml_diag,nkml) & @@ -622,7 +635,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, CS) do i=is-1,ie+1 Rml_av(i,j) = Rml_av(i,j) + h(i,j,k)*Rho0(i) htot(i,j) = htot(i,j) + h(i,j,k) - h_avail(i,j,k) = max(I4dt*G%areaT(i,j)*(h(i,j,k)-GV%Angstrom),0.0) + h_avail(i,j,k) = max(I4dt*G%areaT(i,j)*(h(i,j,k)-GV%Angstrom_H),0.0) enddo enddo @@ -641,7 +654,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, CS) 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_m + 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*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) @@ -658,7 +671,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, CS) 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%m_to_H) + 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 @@ -689,7 +702,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, CS) ! V- component !$OMP do do J=js-1,je ; do i=is,ie - h_vel = 0.5*(htot(i,j) + htot(i,j+1)) * GV%H_to_m + h_vel = 0.5*(htot(i,j) + htot(i,j+1)) * GV%H_to_Z u_star = 0.5*(forces%ustar(i,j) + forces%ustar(i,j+1)) absf = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) @@ -706,7 +719,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, CS) 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%m_to_H) + 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 do k=1,nkml ; vhml(i,J,k) = 0.0 ; enddo else @@ -768,17 +781,23 @@ end subroutine mixedlayer_restrat_BML !> Initialize the mixed layer restratification module -logical function mixedlayer_restrat_init(Time, G, GV, param_file, diag, CS) +logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, restart_CS) type(time_type), intent(in) :: Time !< Current model time type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< Parameter file to parse type(diag_ctrl), target, intent(inout) :: diag !< Regulate diagnostics type(mixedlayer_restrat_CS), pointer :: CS !< Module control structure + type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure + ! Local variables -! This include declares and sets the variable "version". -#include "version_variable.h" - real :: flux_to_kg_per_s + real :: H_rescale ! A rescaling factor for thicknesses from the representation in + ! a restart file to the internal representation in this run. + real :: flux_to_kg_per_s ! A unit conversion factor for fluxes. + ! This include declares and sets the variable "version". +# include "version_variable.h" + integer :: i, j ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") @@ -875,7 +894,8 @@ logical function mixedlayer_restrat_init(Time, G, GV, param_file, diag, CS) CS%id_MLD = register_diag_field('ocean_model', 'MLD_restrat', diag%axesT1, Time, & 'Mixed Layer Depth as used in the mixed-layer restratification parameterization', 'm') CS%id_Rml = register_diag_field('ocean_model', 'ML_buoy_restrat', diag%axesT1, Time, & - 'Mixed Layer Buoyancy as used in the mixed-layer restratification parameterization', 'm s2') + 'Mixed Layer Buoyancy as used in the mixed-layer restratification parameterization', & + 'm s2', conversion=US%m_to_Z) CS%id_uDml = register_diag_field('ocean_model', 'udml_restrat', diag%axesCu1, Time, & 'Transport stream function amplitude for zonal restratification of mixed layer', 'm3 s-1') CS%id_vDml = register_diag_field('ocean_model', 'vdml_restrat', diag%axesCv1, Time, & @@ -885,6 +905,26 @@ logical function mixedlayer_restrat_init(Time, G, GV, param_file, diag, CS) CS%id_vml = register_diag_field('ocean_model', 'vml_restrat', diag%axesCv1, Time, & 'Surface meridional velocity component of mixed layer restratification', 'm s-1') + ! Rescale variables from restart files if the internal dimensional scalings have changed. + if (CS%MLE_MLD_decay_time>0. .or. CS%MLE_MLD_decay_time2>0.) then + if (query_initialized(CS%MLD_filtered, "MLD_MLE_filtered", restart_CS) .and. & + (GV%m_to_H_restart /= 0.0) .and. (GV%m_to_H_restart /= GV%m_to_H)) then + H_rescale = GV%m_to_H / GV%m_to_H_restart + do j=G%jsc,G%jec ; do i=G%isc,G%iec + CS%MLD_filtered(i,j) = H_rescale * CS%MLD_filtered(i,j) + enddo ; enddo + endif + endif + if (CS%MLE_MLD_decay_time2>0.) then + if (query_initialized(CS%MLD_filtered_slow, "MLD_MLE_filtered_slow", restart_CS) .and. & + (GV%m_to_H_restart /= 0.0) .and. (GV%m_to_H_restart /= GV%m_to_H)) then + H_rescale = GV%m_to_H / GV%m_to_H_restart + do j=G%jsc,G%jec ; do i=G%isc,G%iec + CS%MLD_filtered_slow(i,j) = H_rescale * CS%MLD_filtered_slow(i,j) + enddo ; enddo + endif + endif + ! If MLD_filtered is being used, we need to update halo regions after a restart if (associated(CS%MLD_filtered)) call pass_var(CS%MLD_filtered, G%domain) @@ -896,7 +936,7 @@ subroutine mixedlayer_restrat_register_restarts(HI, param_file, CS, restart_CS) type(hor_index_type), intent(in) :: HI !< Horizontal index structure type(param_file_type), intent(in) :: param_file !< Parameter file to parse type(mixedlayer_restrat_CS), pointer :: CS !< Module control structure - type(MOM_restart_CS), pointer :: restart_CS !< Restart structure + type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure ! Local variables type(vardesc) :: vd logical :: mixedlayer_restrat_init @@ -934,7 +974,7 @@ end subroutine mixedlayer_restrat_register_restarts !> \namespace mom_mixed_layer_restrat !! -!! \section mle-module Mixed-layer eddy parameterization module +!! \section section_mle Mixed-layer eddy parameterization module !! !! The subroutines in this file implement a parameterization of unresolved viscous !! mixed layer restratification of the mixed layer as described in Fox-Kemper et @@ -953,7 +993,7 @@ end subroutine mixedlayer_restrat_register_restarts !! grid scale (whichever is smaller to the dominant horizontal length-scale of the !! sub-meso-scale mixed layer instabilities. !! -!! \subsection section-submeso-nutshell "Sub-meso" in a nutshell +!! \subsection section_mle_nutshell "Sub-meso" in a nutshell !! !! The parameterization is colloquially referred to as "sub-meso". !! @@ -974,7 +1014,8 @@ end subroutine mixedlayer_restrat_register_restarts !! For use in coarse-resolution models, an upscaling of the buoyancy gradients and adaption for the equator !! leads to the following parameterization (eq. 6 of Fox-Kemper et al., 2011): !! \f[ -!! {\bf \Psi} = C_e \Gamma_\Delta \frac{\Delta s}{l_f} \frac{ H^2 \nabla \bar{b} \times \hat{\bf z} }{ \sqrt{ f^2 + \tau^{-2}} } \mu(z) +!! {\bf \Psi} = C_e \Gamma_\Delta \frac{\Delta s}{l_f} \frac{ H^2 \nabla \bar{b} \times \hat{\bf z} } +!! { \sqrt{ f^2 + \tau^{-2}} } \mu(z) !! \f] !! where \f$ \Delta s \f$ is the minimum of grid-scale and deformation radius, !! \f$ l_f \f$ is the width of the mixed-layer fronts, and \f$ \Gamma_\Delta=1 \f$. @@ -991,7 +1032,7 @@ end subroutine mixedlayer_restrat_register_restarts !! \f$ C_e \f$ is hard-coded as 0.0625. \f$ \tau \f$ is calculated from the surface friction velocity \f$ u^* \f$. !! \todo Explain expression for momentum mixing time-scale. !! -!! \subsection section-mle-filtering Time-filtering of mixed-layer depth +!! \subsection section_mle_filtering Time-filtering of mixed-layer depth !! !! Using the instantaneous mixed-layer depth is inconsistent with the finite life-time of !! mixed-layer instabilities. We provide a one-sided running-mean filter of mixed-layer depth, \f$ H \f$, of the form: @@ -1002,7 +1043,7 @@ end subroutine mixedlayer_restrat_register_restarts !! but to decay with time-scale \f$ \tau_h \f$. !! \f$ \bar{H} \f$ is substituted for \f$ H \f$ in the above equations. !! -!! \subsection section-mle-mld Defining the mixed-layer-depth +!! \subsection section_mle_mld Defining the mixed-layer-depth !! !! If the parameter MLE_USE_PBL_MLD=True then the mixed-layer depth is defined/diagnosed by the !! boundary-layer parameterization (e.g. ePBL, KPP, etc.). @@ -1011,7 +1052,7 @@ end subroutine mixedlayer_restrat_register_restarts !! as the depth of a given density difference, \f$ \Delta \rho \f$, with the surface where the !! density difference is the parameter MLE_DENSITY_DIFF. !! -!! \subsection section-mle-ref References +!! \subsection section_mle_ref References !! !! Fox-Kemper, B., Ferrari, R. and Hallberg, R., 2008: !! Parameterization of Mixed Layer Eddies. Part I: Theory and Diagnosis @@ -1023,9 +1064,9 @@ end subroutine mixedlayer_restrat_register_restarts !! J. Phys. Oceangraphy, 38 (6), p1166-1179. !! https://doi.org/10.1175/2007JPO3788.1 !! -!! B. Fox-Kemper, G. Danabasoglu, R. Ferrari, S.M. Griffies, R.W. Hallberg, M.M. Holland, M.E. Maltrud, S. Peacock, and B.L. Samuels, 2011: -!! Parameterization of mixed layer eddies. III: Implementation and impact in global ocean climate simulations. -!! Ocean Modell., 39(1), p61-78. +!! B. Fox-Kemper, G. Danabasoglu, R. Ferrari, S.M. Griffies, R.W. Hallberg, M.M. Holland, M.E. Maltrud, +!! S. Peacock, and B.L. Samuels, 2011: Parameterization of mixed layer eddies. III: Implementation and impact +!! in global ocean climate simulations. Ocean Modell., 39(1), p61-78. !! https://doi.org/10.1016/j.ocemod.2010.09.002 !! !! | Symbol | Module parameter | diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 0a4f444240..802e26a404 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -14,48 +14,54 @@ module MOM_thickness_diffuse use MOM_interface_heights, only : find_eta use MOM_lateral_mixing_coeffs, only : VarMix_CS use MOM_MEKE_types, only : MEKE_type +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs, cont_diag_ptrs use MOM_verticalGrid, only : verticalGrid_type implicit none ; private +#include + public thickness_diffuse, thickness_diffuse_init, thickness_diffuse_end public vert_fill_TS -#include +! 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. !> Control structure for thickness diffusion type, public :: thickness_diffuse_CS ; private - real :: Khth !< Background interface depth diffusivity (m2 s-1) - real :: Khth_Slope_Cff !< Slope dependence coefficient of Khth (m2 s-1) + real :: Khth !< Background interface depth diffusivity [m2 s-1] + real :: Khth_Slope_Cff !< Slope dependence coefficient of Khth [m2 s-1] real :: max_Khth_CFL !< Maximum value of the diffusive CFL for thickness diffusion - real :: Khth_Min !< Minimum value of Khth (m2 s-1) - real :: Khth_Max !< Maximum value of Khth (m2 s-1), or 0 for no max - real :: slope_max !< Slopes steeper than slope_max are limited in some way. + real :: Khth_Min !< Minimum value of Khth [m2 s-1] + real :: Khth_Max !< Maximum value of Khth [m2 s-1], or 0 for no max + real :: slope_max !< Slopes steeper than slope_max are limited in some way [nondim]. real :: kappa_smooth !< Vertical diffusivity used to interpolate more - !! sensible values of T & S into thin layers. + !! sensible values of T & S into thin layers [Z2 s-1 ~> m2 s-1]. logical :: thickness_diffuse !< If true, interfaces heights are diffused. logical :: use_FGNV_streamfn !< If true, use the streamfunction formulation of !! Ferrari et al., 2010, which effectively emphasizes !! graver vertical modes by smoothing in the vertical. real :: FGNV_scale !< A coefficient scaling the vertical smoothing term in the - !! Ferrari et al., 2010, streamfunction formulation. - real :: FGNV_c_min !< A minium wave speed used in the Ferrari et al., 2010, - !! streamfunction formulation (m s-1). + !! Ferrari et al., 2010, streamfunction formulation [nondim]. + real :: FGNV_c_min !< A minimum wave speed used in the Ferrari et al., 2010, + !! streamfunction formulation [m s-1]. real :: N2_floor !< A floor for Brunt-Vasaila frequency in the Ferrari et al., 2010, - !! streamfunction formulation (s-2). + !! streamfunction formulation [s-2]. logical :: detangle_interfaces !< If true, add 3-d structured interface height !! diffusivities to horizontally smooth jagged layers. real :: detangle_time !< If detangle_interfaces is true, this is the !! timescale over which maximally jagged grid-scale - !! thickness variations are suppressed. This must be + !! thickness variations are suppressed [s]. This must be !! longer than DT, or 0 (the default) to use DT. integer :: nkml !< number of layers within mixed layer logical :: debug !< write verbose checksums for debugging purposes - type(diag_ctrl), pointer :: diag ! structure used to regulate timing of diagnostics - real, pointer :: GMwork(:,:) => NULL() !< Work by thickness diffusivity (W m-2) - real, pointer :: diagSlopeX(:,:,:) => NULL() !< Diagnostic: zonal neutral slope (nondim) - real, pointer :: diagSlopeY(:,:,:) => NULL() !< Diagnostic: zonal neutral slope (nondim) + type(diag_ctrl), pointer :: diag => NULL() !< structure used to regulate timing of diagnostics + real, pointer :: GMwork(:,:) => NULL() !< Work by thickness diffusivity [W m-2] + real, pointer :: diagSlopeX(:,:,:) => NULL() !< Diagnostic: zonal neutral slope [nondim] + real, pointer :: diagSlopeY(:,:,:) => NULL() !< Diagnostic: zonal neutral slope [nondim] !>@{ !! Diagnostic identifier @@ -72,55 +78,57 @@ module MOM_thickness_diffuse !> Calculates thickness diffusion coefficients and applies thickness diffusion to layer !! thicknesses, h. Diffusivities are limited to ensure stability. !! Also returns along-layer mass fluxes used in the continuity equation. -subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, MEKE, VarMix, CDp, CS) +subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp, CS) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thickness (m or kg/m2) - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: uhtr !< Accumulated zonal mass flux (m2 H) - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: vhtr !< Accumulated meridional mass flux (m2 H) + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: uhtr !< Accumulated zonal mass flux + !! [m2 H ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: vhtr !< Accumulated meridional mass flux + !! [m2 H ~> m3 or kg] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure - real, intent(in) :: dt !< Time increment (s) + real, intent(in) :: dt !< Time increment [s] type(MEKE_type), pointer :: MEKE !< MEKE control structure type(VarMix_CS), pointer :: VarMix !< Variable mixing coefficients type(cont_diag_ptrs), intent(inout) :: CDp !< Diagnostics for the continuity equation type(thickness_diffuse_CS), pointer :: CS !< Control structure for thickness diffusion ! Local variables real :: e(SZI_(G), SZJ_(G), SZK_(G)+1) ! heights of interfaces, relative to mean - ! sea level,in H units, positive up. - real :: uhD(SZIB_(G), SZJ_(G), SZK_(G)) ! uhD & vhD are the diffusive u*h & - real :: vhD(SZI_(G), SZJB_(G), SZK_(G)) ! v*h fluxes (m2 H s-1) + ! sea level [Z ~> m], positive up. + real :: uhD(SZIB_(G), SZJ_(G), SZK_(G)) ! Diffusive u*h fluxes [m2 H s-1 ~> m3 s-1 or kg s-1] + real :: vhD(SZI_(G), SZJB_(G), SZK_(G)) ! Diffusive v*h fluxes [m2 H s-1 ~> m3 s-1 or kg s-1] real, dimension(SZIB_(G), SZJ_(G), SZK_(G)+1) :: & - KH_u, & ! interface height diffusivities in u-columns (m2 s-1) + KH_u, & ! interface height diffusivities in u-columns [m2 s-1] int_slope_u ! A nondimensional ratio from 0 to 1 that gives the relative ! weighting of the interface slopes to that calculated also ! using density gradients at u points. The physically correct ! slopes occur at 0, while 1 is used for numerical closures. real, dimension(SZI_(G), SZJB_(G), SZK_(G)+1) :: & - KH_v, & ! interface height diffusivities in v-columns (m2 s-1) + KH_v, & ! interface height diffusivities in v-columns [m2 s-1] int_slope_v ! A nondimensional ratio from 0 to 1 that gives the relative ! weighting of the interface slopes to that calculated also ! using density gradients at v points. The physically correct ! slopes occur at 0, while 1 is used for numerical closures. real, dimension(SZI_(G), SZJ_(G), SZK_(G)) :: & - KH_t ! diagnosed diffusivity at tracer points (m^2/s) + KH_t ! diagnosed diffusivity at tracer points [m2 s-1] real, dimension(SZIB_(G), SZJ_(G)) :: & - KH_u_CFL ! The maximum stable interface height diffusivity at u grid points (m2 s-1) + KH_u_CFL ! The maximum stable interface height diffusivity at u grid points [m2 s-1] real, dimension(SZI_(G), SZJB_(G)) :: & - KH_v_CFL ! The maximum stable interface height diffusivity at v grid points (m2 s-1) + KH_v_CFL ! The maximum stable interface height diffusivity at v grid points [m2 s-1] real :: Khth_Loc_u(SZIB_(G), SZJ_(G)) - real :: Khth_Loc(SZIB_(G), SZJB_(G)) ! locally calculated thickness diffusivity (m2/s) - real :: H_to_m, m_to_H ! Local copies of unit conversion factors. + 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 integer :: i, j, k, is, ie, js, je, nz - real :: hu(SZI_(G), SZJ_(G)) ! u-thickness (H) - real :: hv(SZI_(G), SZJ_(G)) ! v-thickness (H) - real :: KH_u_lay(SZI_(G), SZJ_(G)) ! layer ave thickness diffusivities (m2/sec) - real :: KH_v_lay(SZI_(G), SZJ_(G)) ! layer ave thickness diffusivities (m2/sec) + real :: hu(SZI_(G), SZJ_(G)) ! u-thickness [H ~> m or kg m-2] + real :: hv(SZI_(G), SZJ_(G)) ! v-thickness [H ~> m or kg m-2] + real :: KH_u_lay(SZI_(G), SZJ_(G)) ! layer ave thickness diffusivities [m2 s-1] + real :: KH_v_lay(SZI_(G), SZJ_(G)) ! layer ave thickness diffusivities [m2 s-1] if (.not. associated(CS)) call MOM_error(FATAL, "MOM_thickness_diffuse:"// & "Module must be initialized before it is used.") @@ -130,7 +138,6 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, MEKE, VarMix, CDp, CS is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke h_neglect = GV%H_subroundoff - H_to_m = GV%H_to_m ; m_to_H = GV%m_to_H if (associated(MEKE)) then if (associated(MEKE%GM_src)) then @@ -161,8 +168,8 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, MEKE, VarMix, CDp, CS (dt*(G%IdxCv(i,J)*G%IdxCv(i,J) + G%IdyCv(i,J)*G%IdyCv(i,J))) enddo ; enddo - ! Calculates interface heights, e, in m. - call find_eta(h, tv, GV%g_Earth, G, GV, e, halo_size=1) + ! Calculates interface heights, e, in [Z ~> m]. + call find_eta(h, tv, G, GV, US, e, halo_size=1) ! Set the diffusivities. !$OMP parallel default(none) shared(is,ie,js,je,Khth_Loc_u,CS,use_VarMix,VarMix, & @@ -284,7 +291,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, MEKE, VarMix, CDp, CS !$OMP end parallel if (CS%detangle_interfaces) then - call add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV, & + call add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV, US, & CS, int_slope_u, int_slope_v) endif @@ -292,7 +299,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, MEKE, VarMix, CDp, CS call uvchksum("Kh_[uv]", Kh_u, Kh_v, G%HI,haloshift=0) call uvchksum("int_slope_[uv]", int_slope_u, int_slope_v, G%HI, haloshift=0) call hchksum(h, "thickness_diffuse_1 h", G%HI, haloshift=1, scale=GV%H_to_m) - call hchksum(e, "thickness_diffuse_1 e", G%HI, haloshift=1) + call hchksum(e, "thickness_diffuse_1 e", G%HI, haloshift=1, scale=US%Z_to_m) if (use_stored_slopes) then call uvchksum("VarMix%slope_[xy]", VarMix%slope_x, VarMix%slope_y, & G%HI, haloshift=0) @@ -305,10 +312,10 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, MEKE, VarMix, CDp, CS ! Calculate uhD, vhD from h, e, KH_u, KH_v, tv%T/S if (use_stored_slopes) then - call thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV, MEKE, CS, & + call thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV, US, MEKE, CS, & int_slope_u, int_slope_v, VarMix%slope_x, VarMix%slope_y) else - call thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV, MEKE, CS, & + call thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV, US, MEKE, CS, & int_slope_u, int_slope_v) endif @@ -334,20 +341,20 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, MEKE, VarMix, CDp, CS ! Diagnose diffusivity at T-cell point. Do simple average, rather than ! thickness-weighted average, in order that KH_t is depth-independent ! in the case where KH_u and KH_v are depth independent. Otherwise, - ! if use thickess weighted average, the variations of thickness with + ! if use thickness weighted average, the variations of thickness with ! depth will place a spurious depth dependence to the diagnosed KH_t. if (CS%id_KH_t > 0 .or. CS%id_KH_t1 > 0) then do k=1,nz - ! thicknesses across u and v faces, converted to 0/1 mask; + ! thicknesses across u and v faces, converted to 0/1 mask ! layer average of the interface diffusivities KH_u and KH_v do j=js,je ; do I=is-1,ie hu(I,j) = 2.0*h(i,j,k)*h(i+1,j,k)/(h(i,j,k)+h(i+1,j,k)+h_neglect) - if(hu(I,j) /= 0.0) hu(I,j) = 1.0 + if (hu(I,j) /= 0.0) hu(I,j) = 1.0 KH_u_lay(I,j) = 0.5*(KH_u(I,j,k)+KH_u(I,j,k+1)) enddo ; enddo do J=js-1,je ; do i=is,ie hv(i,J) = 2.0*h(i,j,k)*h(i,j+1,k)/(h(i,j,k)+h(i,j+1,k)+h_neglect) - if(hv(i,J) /= 0.0) hv(i,J) = 1.0 + if (hv(i,J) /= 0.0) hv(i,J) = 1.0 KH_v_lay(i,J) = 0.5*(KH_v(i,J,k)+KH_v(i,J,k+1)) enddo ; enddo ! diagnose diffusivity at T-point @@ -357,8 +364,8 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, MEKE, VarMix, CDp, CS / (hu(I-1,j)+hu(I,j)+hv(i,J-1)+hv(i,J)+h_neglect) enddo ; enddo enddo - if(CS%id_KH_t > 0) call post_data(CS%id_KH_t, KH_t, CS%diag) - if(CS%id_KH_t1 > 0) call post_data(CS%id_KH_t1, KH_t(:,:,1), CS%diag) + if (CS%id_KH_t > 0) call post_data(CS%id_KH_t, KH_t, CS%diag) + if (CS%id_KH_t1 > 0) call post_data(CS%id_KH_t1, KH_t(:,:,1), CS%diag) endif endif @@ -376,7 +383,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, MEKE, VarMix, CDp, CS do j=js,je ; do i=is,ie h(i,j,k) = h(i,j,k) - dt * G%IareaT(i,j) * & ((uhD(I,j,k) - uhD(I-1,j,k)) + (vhD(i,J,k) - vhD(i,J-1,k))) - if (h(i,j,k) < GV%Angstrom) h(i,j,k) = GV%Angstrom + if (h(i,j,k) < GV%Angstrom_H) h(i,j,k) = GV%Angstrom_H enddo ; enddo enddo @@ -398,111 +405,121 @@ end subroutine thickness_diffuse !> Calculates parameterized layer transports for use in the continuity equation. !! Fluxes are limited to give positive definite thicknesses. !! Called by thickness_diffuse(). -subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV, MEKE, & +subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV, US, MEKE, & CS, int_slope_u, int_slope_v, slope_x, slope_y) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness (m or kg/m2) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: e !< Interface positions (m) - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)+1), intent(in) :: Kh_u !< Thickness diffusivity on interfaces at u points (m2/s) - real, dimension(SZI_(G),SZJB_(G),SZK_(G)+1), intent(in) :: Kh_v !< Thickness diffusivity on interfaces at v points (m2/s) + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: e !< Interface positions [Z ~> m] + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)+1), intent(in) :: Kh_u !< Thickness diffusivity on interfaces + !! at u points [m2 s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)+1), intent(in) :: Kh_v !< Thickness diffusivity on interfaces + !! at v points [m2 s-1] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: uhD !< Zonal mass fluxes (m3/s) - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: vhD !< Meridional mass fluxes (m3/s) - real, dimension(:,:), pointer :: cg1 !< Wave speed (m/s) - real, intent(in) :: dt !< Time increment (s) - type(MEKE_type), pointer :: MEKE !< MEKE control structue + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: uhD !< Zonal mass fluxes + !! [H m2 s-1 ~> m3 s-1 or kg s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: vhD !< Meridional mass fluxes + !! [H m2 s-1 ~> m3 s-1 or kg s-1] + real, dimension(:,:), pointer :: cg1 !< Wave speed [m s-1] + real, intent(in) :: dt !< Time increment [s] + 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 density gradients. + !! 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 density gradients. + !! 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 + ! Local variables real, dimension(SZI_(G), SZJ_(G), SZK_(G)) :: & - T, & ! The temperature (or density) in C, with the values in + T, & ! The temperature (or density) [degC], with the values in ! in massless layers filled vertically by diffusion. - S, & ! The filled salinity, in PSU, with the values in + S, & ! The filled salinity [ppt], with the values in ! in massless layers filled vertically by diffusion. - Rho, & ! Density itself, when a nonlinear equation of state is + Rho, & ! Density itself [kg m-3], when a nonlinear equation of state is ! not in use. h_avail, & ! The mass available for diffusion out of each face, divided - ! by dt, in m3 s-1. + ! 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 m3 s-1 or kg s-1]. real, dimension(SZIB_(G)) :: & - drho_dT_u, & ! The derivatives of density with temperature and - drho_dS_u ! salinity at u points, in kg m-3 K-1 and kg m-3 psu-1. + drho_dT_u, & ! The derivative of density with temperature at u points [kg m-3 degC-1] + drho_dS_u ! The derivative of density with salinity at u points [kg m-3 ppt-1]. real, dimension(SZI_(G)) :: & - drho_dT_v, & ! The derivatives of density with temperature and - drho_dS_v ! salinity at v points, in kg m-3 K-1 and kg m-3 psu-1. - real :: uhtot(SZIB_(G), SZJ_(G)) ! The vertical sum of uhD, in m3 s-1. - real :: vhtot(SZI_(G), SZJB_(G)) ! The vertical sum of vhD, in m3 s-1. + drho_dT_v, & ! The derivative of density with temperature at v points [kg m-3 degC-1] + drho_dS_v ! The derivative of density with salinity at v points [kg m-3 ppt-1]. + real :: uhtot(SZIB_(G), SZJ_(G)) ! The vertical sum of uhD [H m2 s-1 ~> m3 s-1 or kg s-1]. + real :: vhtot(SZI_(G), SZJB_(G)) ! The vertical sum of vhD [H m2 s-1 ~> m3 s-1 or kg s-1]. real, dimension(SZIB_(G)) :: & - T_u, S_u, & ! Temperature, salinity, and pressure on the interface at - pres_u ! the u-point in the horizontal. + T_u, & ! Temperature on the interface at the u-point [degC]. + S_u, & ! Salinity on the interface at the u-point [ppt]. + pres_u ! Pressure on the interface at the u-point [Pa]. real, dimension(SZI_(G)) :: & - T_v, S_v, & ! Temperature, salinity, and pressure on the interface at - pres_v ! the v-point in the horizontal. + T_v, & ! Temperature on the interface at the v-point [degC]. + S_v, & ! Salinity on the interface at the v-point [ppt]. + pres_v ! Pressure on the interface at the v-point [Pa]. real :: Work_u(SZIB_(G), SZJ_(G)) ! The work being done by the thickness - real :: Work_v(SZI_(G), SZJB_(G)) ! diffusion integrated over a cell, in W. - real :: Work_h ! The work averaged over an h-cell in W m-2. - real :: I4dt ! 1 / 4 dt + real :: Work_v(SZI_(G), SZJB_(G)) ! diffusion integrated over a cell [W]. + real :: Work_h ! The work averaged over an h-cell [W m-2]. + real :: I4dt ! 1 / 4 dt [s-1]. real :: drdiA, drdiB ! Along layer zonal- and meridional- potential density real :: drdjA, drdjB ! gradients in the layers above (A) and below(B) the - ! interface times the grid spacing, in kg m-3. - real :: drdkL, drdkR ! Vertical density differences across an interface, - ! in kg m-3. - real :: drdi_u(SZIB_(G), SZK_(G)+1) ! Copy of drdiB in kg m-3. - real :: drdj_v(SZI_(G), SZK_(G)+1) ! Copy of drdjB in kg m-3. - real :: drdkDe_u(SZIB_(G), SZK_(G)+1) ! Lateral difference of product of drdkR*e, in kg -3 * H. - real :: drdkDe_v(SZI_(G), SZK_(G)+1) ! Lateral difference of product of drdkR*e, in kg -3 * H. - real :: hg2A, hg2B, hg2L, hg2R - real :: haA, haB, haL, haR - real :: dzaL, dzaR - real :: wtA, wtB, wtL, wtR - real :: drdx, drdy, drdz ! Zonal, meridional, and vertical density gradients, - ! in units of kg m-4. - real :: h_harm ! Harmonic mean layer thickness, in H. - real :: c2_h_u(SZIB_(G), SZK_(G)+1) ! Wave speed squared divided by h at u-points, m s-2. - real :: c2_h_v(SZI_(G), SZK_(G)+1) ! Wave speed squared divided by h at v-points, m s-2. - real :: hN2_u(SZIB_(G), SZK_(G)+1) ! Thickness in m times N2 at interfaces above u-points, m s-2. - real :: hN2_v(SZI_(G), SZK_(G)+1) ! Thickness in m times N2 at interfaces above v-points, m s-2. - real :: Sfn_est ! Two preliminary estimates (before limiting) of the - ! overturning streamfunction, both in m3 s-1. - real :: Sfn_unlim_u(SZIB_(G), SZK_(G)+1) ! Streamfunction for u-points (m3 s-1) - real :: Sfn_unlim_v(SZI_(G), SZK_(G)+1) ! Streamfunction for v-points (m3 s-1) + ! interface times the grid spacing [kg m-3]. + real :: drdkL, drdkR ! Vertical density differences across an interface [kg m-3]. + real :: drdi_u(SZIB_(G), SZK_(G)+1) ! Copy of drdi at u-points [kg m-3]. + real :: drdj_v(SZI_(G), SZK_(G)+1) ! Copy of drdj at v-points [kg m-3]. + real :: drdkDe_u(SZIB_(G),SZK_(G)+1) ! Lateral difference of product of drdk and e at u-points + ! [Z kg m-3 ~> kg m-2]. + real :: drdkDe_v(SZI_(G),SZK_(G)+1) ! Lateral difference of product of drdk and e at v-points + ! [Z kg m-3 ~> kg m-2]. + real :: hg2A, hg2B, hg2L, hg2R ! Squares of geometric mean thicknesses [H2 ~> m2 or kg2 m-4]. + real :: haA, haB, haL, haR ! Arithmetic mean thicknesses [H ~> m or kg m-2]. + real :: dzaL, dzaR ! Temporary thicknesses [Z ~> m]. + real :: wtA, wtB, wtL, wtR ! Unscaled weights, with various units. + real :: drdx, drdy ! Zonal and meridional density gradients [kg m-4]. + real :: drdz ! Vertical density gradient [kg m-3 Z-1 ~> kg m-4]. + real :: h_harm ! Harmonic mean layer thickness [H ~> m or kg m-2]. + real :: c2_h_u(SZIB_(G), SZK_(G)+1) ! Wave speed squared divided by h at u-points [m2 Z-1 s-2 ~> m s-2]. + real :: c2_h_v(SZI_(G), SZK_(G)+1) ! Wave speed squared divided by h at v-points [m2 Z-1 s-2 ~> m s-2]. + real :: hN2_u(SZIB_(G), SZK_(G)+1) ! Thickness in m times N2 at interfaces above u-points [m2 Z-1 s-2 ~> m s-2]. + real :: hN2_v(SZI_(G), SZK_(G)+1) ! Thickness in m times N2 at interfaces above v-points [m2 Z-1 s-2 ~> m s-2]. + real :: Sfn_est ! A preliminary estimate (before limiting) of the overturning + ! streamfunction [Z m2 s-1 ~> m3 s-1]. + real :: Sfn_unlim_u(SZIB_(G), SZK_(G)+1) ! Streamfunction for u-points [Z m2 s-1 ~> m3 s-1]. + real :: Sfn_unlim_v(SZI_(G), SZK_(G)+1) ! Streamfunction for v-points [Z m2 s-1 ~> m3 s-1]. real :: slope2_Ratio_u(SZIB_(G), SZK_(G)+1) ! The ratio of the slope squared to slope_max squared. real :: slope2_Ratio_v(SZI_(G), SZK_(G)+1) ! The ratio of the slope squared to slope_max squared. - real :: Sfn_in_h ! The overturning streamfunction, in H m2 s-1 (note units different from other Sfn vars). - real :: Sfn_safe ! The streamfunction that goes linearly back to 0 at the - ! top. This is a good thing to use when the slope is - ! so large as to be meaningless (m3 s-1). + real :: Sfn_in_h ! The overturning streamfunction [H m2 s-1 ~> m3 s-1 or kg s-1] (note that + ! the units are different from other Sfn vars). + real :: Sfn_safe ! The streamfunction that goes linearly back to 0 at the surface. This is a + ! good thing to use when the slope is so large as to be meaningless [Z m2 s-1 ~> m3 s-1]. real :: Slope ! The slope of density surfaces, calculated in a way - ! that is always between -1 and 1. - real :: mag_grad2 ! The squared magnitude of the 3-d density gradient, in kg2 m-8. + ! that is always between -1 and 1, nondimensional. + real :: mag_grad2 ! The squared magnitude of the 3-d density gradient [kg2 m-8]. real :: I_slope_max2 ! The inverse of slope_max squared, nondimensional. real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected, in H. - real :: h_neglect2 ! h_neglect^2, in H2. - real :: dz_neglect ! A thickness in m that is so small it is usually lost - ! in roundoff and can be neglected, in m. - real :: G_scale ! The gravitational accerlation times the conversion - ! factor from thickness to m, in m s-2 or m4 s-2 kg-1. + ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: h_neglect2 ! h_neglect^2 [H2 ~> m2 or kg2 m-4]. + real :: dz_neglect ! A thickness [Z ~> m], that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m]. + real :: G_scale ! The gravitational acceleration times some unit conversion + ! factors [m3 Z-1 H-1 s-2 ~> m s-2 or m4 kg-1 s-2]. logical :: use_EOS ! If true, density is calculated from T & S using an ! equation of state. logical :: find_work ! If true, find the change in energy due to the fluxes. - integer :: nk_linear ! The number of layers over which the streamfunction - ! goes to 0. - real :: H_to_m, m_to_H ! Local copies of unit conversion factors. - real :: G_rho0 ! g/Rho0 - real :: N2_floor ! A floor for N2 to avoid degeneracy in the elliptic solver (s-2) + integer :: nk_linear ! The number of layers over which the streamfunction goes to 0. + real :: G_rho0 ! g/Rho0 [m5 Z-1 s-2 ~> m4 s-2]. + real :: N2_floor ! A floor for N2 to avoid degeneracy in the elliptic solver + ! times unit conversion factors [s-2 m2 Z-2 ~> s-2] real, dimension(SZIB_(G), SZJ_(G), SZK_(G)+1) :: diag_sfn_x, diag_sfn_unlim_x ! Diagnostics real, dimension(SZI_(G), SZJB_(G), SZK_(G)+1) :: diag_sfn_y, diag_sfn_unlim_y ! Diagnostics logical :: present_int_slope_u, present_int_slope_v @@ -511,14 +528,13 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV integer :: i, j, k is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke ; IsdB = G%IsdB - H_to_m = GV%H_to_m ; m_to_H = GV%m_to_H I4dt = 0.25 / dt I_slope_max2 = 1.0 / (CS%slope_max**2) - G_scale = GV%g_Earth + G_scale = GV%g_Earth * GV%H_to_m h_neglect = GV%H_subroundoff ; h_neglect2 = h_neglect**2 - dz_neglect = GV%H_subroundoff*H_to_m + dz_neglect = GV%H_subroundoff*GV%H_to_Z G_rho0 = GV%g_Earth / GV%Rho0 - N2_floor = CS%N2_floor + N2_floor = CS%N2_floor*US%Z_to_m**2 use_EOS = associated(tv%eqn_of_state) present_int_slope_u = PRESENT(int_slope_u) @@ -548,7 +564,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV h_avail_rsum(i,j,1) = 0.0 pres(i,j,1) = 0.0 ! ### This should be atmospheric pressure. - h_avail(i,j,1) = max(I4dt*G%areaT(i,j)*(h(i,j,1)-GV%Angstrom),0.0) + h_avail(i,j,1) = max(I4dt*G%areaT(i,j)*(h(i,j,1)-GV%Angstrom_H),0.0) h_avail_rsum(i,j,2) = h_avail(i,j,1) h_frac(i,j,1) = 1.0 pres(i,j,2) = pres(i,j,1) + GV%H_to_Pa*h(i,j,1) @@ -556,7 +572,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV !$OMP do do j=js-1,je+1 do k=2,nz ; do i=is-1,ie+1 - h_avail(i,j,k) = max(I4dt*G%areaT(i,j)*(h(i,j,k)-GV%Angstrom),0.0) + h_avail(i,j,k) = max(I4dt*G%areaT(i,j)*(h(i,j,k)-GV%Angstrom_H),0.0) h_avail_rsum(i,j,k+1) = h_avail_rsum(i,j,k) + h_avail(i,j,k) h_frac(i,j,k) = 0.0 ; if (h_avail(i,j,k) > 0.0) & h_frac(i,j,k) = h_avail(i,j,k) / h_avail_rsum(i,j,k+1) @@ -577,13 +593,13 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV enddo ; enddo !$OMP end parallel -!$OMP parallel do default(none) shared(nz,is,ie,js,je,find_work,use_EOS,G,GV,pres,T,S, & +!$OMP parallel do default(none) shared(nz,is,ie,js,je,find_work,use_EOS,G,GV,US,pres,T,S, & !$OMP nk_linear,IsdB,tv,h,h_neglect,e,dz_neglect, & !$OMP I_slope_max2,h_neglect2,present_int_slope_u, & !$OMP int_slope_u,KH_u,uhtot,h_frac,h_avail_rsum, & !$OMP uhD,h_avail,G_scale,work_u,CS,slope_x,cg1, & !$OMP diag_sfn_x, diag_sfn_unlim_x,N2_floor, & -!$OMP present_slope_x,H_to_m,m_to_H,G_rho0) & +!$OMP present_slope_x,G_rho0) & !$OMP private(drdiA,drdiB,drdkL,drdkR,pres_u,T_u,S_u, & !$OMP drho_dT_u,drho_dS_u,hg2A,hg2B,hg2L,hg2R,haA, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & @@ -640,7 +656,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV haL = 0.5*(h(i,j,k-1) + h(i,j,k)) + h_neglect haR = 0.5*(h(i+1,j,k-1) + h(i+1,j,k)) + h_neglect if (GV%Boussinesq) then - dzaL = haL * H_to_m ; dzaR = haR * H_to_m + dzaL = haL * GV%H_to_Z ; dzaR = haR * GV%H_to_Z else dzaL = 0.5*(e(i,j,K-1) - e(i,j,K+1)) + dz_neglect dzaR = 0.5*(e(i+1,j,K-1) - e(i+1,j,K+1)) + dz_neglect @@ -659,8 +675,8 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV haB = 0.5*(h(i,j,k) + h(i+1,j,k)) + h_neglect ! hN2_u is used with the FGNV streamfunction formulation - hN2_u(I,K) = (0.5 * H_to_m * ( hg2A / haA + hg2B / haB )) * & - max(drdz*G_rho0 , N2_floor) + hN2_u(I,K) = (0.5 * GV%H_to_Z * ( hg2A / haA + hg2B / haB )) * & + max(drdz*G_rho0, N2_floor) endif if (present_slope_x) then Slope = slope_x(I,j,k) @@ -675,7 +691,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! This estimate of slope is accurate for small slopes, but bounded ! to be between -1 and 1. - mag_grad2 = drdx**2 + drdz**2 + mag_grad2 = drdx**2 + (US%m_to_Z*drdz)**2 if (mag_grad2 > 0.0) then Slope = drdx / sqrt(mag_grad2) slope2_Ratio_u(I,K) = Slope**2 * I_slope_max2 @@ -689,13 +705,13 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! that ignore density gradients along layers. if (present_int_slope_u) then Slope = (1.0 - int_slope_u(I,j,K)) * Slope + & - int_slope_u(I,j,K) * ((e(i+1,j,K)-e(i,j,K)) * G%IdxCu(I,j)) + int_slope_u(I,j,K) * US%Z_to_m*((e(i+1,j,K)-e(i,j,K)) * G%IdxCu(I,j)) slope2_Ratio_u(I,K) = (1.0 - int_slope_u(I,j,K)) * slope2_Ratio_u(I,K) endif if (CS%id_slope_x > 0) CS%diagSlopeX(I,j,k) = Slope - ! Estimate the streamfunction at each interface (m3 s-1). - Sfn_unlim_u(I,K) = -((KH_u(I,j,K)*G%dy_Cu(I,j))*Slope) + ! Estimate the streamfunction at each interface [m3 s-1]. + Sfn_unlim_u(I,K) = -((KH_u(I,j,K)*G%dy_Cu(I,j))*US%m_to_Z*Slope) ! Avoid moving dense water upslope from below the level of ! the bottom on the receiving side. @@ -721,10 +737,10 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV if (present_slope_x) then Slope = slope_x(I,j,k) else - Slope = ((e(i,j,K)-e(i+1,j,K))*G%IdxCu(I,j)) * G%mask2dCu(I,j) + Slope = US%Z_to_m*((e(i,j,K)-e(i+1,j,K))*G%IdxCu(I,j)) * G%mask2dCu(I,j) endif if (CS%id_slope_x > 0) CS%diagSlopeX(I,j,k) = Slope - Sfn_unlim_u(I,K) = ((KH_u(I,j,K)*G%dy_Cu(I,j))*Slope) + Sfn_unlim_u(I,K) = ((KH_u(I,j,K)*G%dy_Cu(I,j))*US%m_to_Z*Slope) hN2_u(I,K) = GV%g_prime(K) endif ! if (use_EOS) else ! if (k > nk_linear) @@ -737,9 +753,9 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV if (CS%use_FGNV_streamfn) then do k=1,nz ; do I=is-1,ie ; if (G%mask2dCu(I,j)>0.) then - h_harm = H_to_m * max( h_neglect, & + h_harm = max( h_neglect, & 2. * h(i,j,k) * h(i+1,j,k) / ( ( h(i,j,k) + h(i+1,j,k) ) + h_neglect ) ) - c2_h_u(I,k) = CS%FGNV_scale * ( 0.5*( cg1(i,j) + cg1(i+1,j) ) )**2 / h_harm + c2_h_u(I,k) = CS%FGNV_scale * ( 0.5*( cg1(i,j) + cg1(i+1,j) ) )**2 / (GV%H_to_Z*h_harm) endif ; enddo ; enddo ! Solve an elliptic equation for the streamfunction following Ferrari et al., 2010. @@ -760,9 +776,9 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV if (uhtot(I,j) <= 0.0) then ! The transport that must balance the transport below is positive. - Sfn_safe = uhtot(I,j) * (1.0 - h_frac(i,j,k)) * H_to_m + Sfn_safe = uhtot(I,j) * (1.0 - h_frac(i,j,k)) * GV%H_to_Z else ! (uhtot(I,j) > 0.0) - Sfn_safe = uhtot(I,j) * (1.0 - h_frac(i+1,j,k)) * H_to_m + Sfn_safe = uhtot(I,j) * (1.0 - h_frac(i+1,j,k)) * GV%H_to_Z endif ! The actual streamfunction at each interface. @@ -773,7 +789,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! Make sure that there is enough mass above to allow the streamfunction ! to satisfy the boundary condition of 0 at the surface. - Sfn_in_h = min(max(Sfn_est * m_to_H, -h_avail_rsum(i,j,K)), h_avail_rsum(i+1,j,K)) + Sfn_in_h = min(max(Sfn_est * GV%Z_to_H, -h_avail_rsum(i,j,K)), h_avail_rsum(i+1,j,K)) ! The actual transport is limited by the mass available in the two ! neighboring grid cells. @@ -815,7 +831,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! A second order centered estimate is used for the density transfered ! between water columns. - Work_u(I,j) = Work_u(I,j) + ( G_scale * H_to_m ) * & + Work_u(I,j) = Work_u(I,j) + G_scale * & ( uhtot(I,j) * drdkDe_u(I,K) - & (uhD(I,j,K) * drdi_u(I,K)) * 0.25 * & ((e(i,j,K) + e(i,j,K+1)) + (e(i+1,j,K) + e(i+1,j,K+1))) ) @@ -826,13 +842,13 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV enddo ! end of j-loop ! Calculate the meridional fluxes and gradients. -!$OMP parallel do default(none) shared(nz,is,ie,js,je,find_work,use_EOS,G,GV,pres,T,S, & +!$OMP parallel do default(none) shared(nz,is,ie,js,je,find_work,use_EOS,G,GV,US,pres,T,S, & !$OMP nk_linear,IsdB,tv,h,h_neglect,e,dz_neglect, & !$OMP I_slope_max2,h_neglect2,present_int_slope_v, & !$OMP int_slope_v,KH_v,vhtot,h_frac,h_avail_rsum, & !$OMP vhD,h_avail,G_scale,Work_v,CS,slope_y,cg1, & !$OMP diag_sfn_y, diag_sfn_unlim_y,N2_floor, & -!$OMP present_slope_y,m_to_H,H_to_m,G_rho0) & +!$OMP present_slope_y,G_rho0) & !$OMP private(drdjA,drdjB,drdkL,drdkR,pres_v,T_v,S_v, & !$OMP drho_dT_v,drho_dS_v,hg2A,hg2B,hg2L,hg2R,haA, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & @@ -886,7 +902,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV haL = 0.5*(h(i,j,k-1) + h(i,j,k)) + h_neglect haR = 0.5*(h(i,j+1,k-1) + h(i,j+1,k)) + h_neglect if (GV%Boussinesq) then - dzaL = haL * H_to_m ; dzaR = haR * H_to_m + dzaL = haL * GV%H_to_Z ; dzaR = haR * GV%H_to_Z else dzaL = 0.5*(e(i,j,K-1) - e(i,j,K+1)) + dz_neglect dzaR = 0.5*(e(i,j+1,K-1) - e(i,j+1,K+1)) + dz_neglect @@ -905,8 +921,8 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV haB = 0.5*(h(i,j,k) + h(i,j+1,k)) + h_neglect ! hN2_v is used with the FGNV streamfunction formulation - hN2_v(i,K) = (0.5 * H_to_m * ( hg2A / haA + hg2B / haB )) * & - max(drdz*G_rho0 , N2_floor) + hN2_v(i,K) = (0.5 * GV%H_to_Z * ( hg2A / haA + hg2B / haB )) * & + max(drdz*G_rho0, N2_floor) endif if (present_slope_y) then Slope = slope_y(i,J,k) @@ -921,7 +937,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! This estimate of slope is accurate for small slopes, but bounded ! to be between -1 and 1. - mag_grad2 = drdy**2 + drdz**2 + mag_grad2 = drdy**2 + (US%m_to_Z*drdz)**2 if (mag_grad2 > 0.0) then Slope = drdy / sqrt(mag_grad2) slope2_Ratio_v(i,K) = Slope**2 * I_slope_max2 @@ -935,13 +951,13 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! that ignore density gradients along layers. if (present_int_slope_v) then Slope = (1.0 - int_slope_v(i,J,K)) * Slope + & - int_slope_v(i,J,K) * ((e(i,j+1,K)-e(i,j,K)) * G%IdyCv(i,J)) + int_slope_v(i,J,K) * US%Z_to_m*((e(i,j+1,K)-e(i,j,K)) * G%IdyCv(i,J)) slope2_Ratio_v(i,K) = (1.0 - int_slope_v(i,J,K)) * slope2_Ratio_v(i,K) endif if (CS%id_slope_y > 0) CS%diagSlopeY(I,j,k) = Slope - ! Estimate the streamfunction at each interface (m3 s-1). - Sfn_unlim_v(i,K) = -((KH_v(i,J,K)*G%dx_Cv(i,J))*Slope) + ! Estimate the streamfunction at each interface [m3 s-1]. + Sfn_unlim_v(i,K) = -((KH_v(i,J,K)*G%dx_Cv(i,J))*US%m_to_Z*Slope) ! Avoid moving dense water upslope from below the level of ! the bottom on the receiving side. @@ -967,10 +983,10 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV if (present_slope_y) then Slope = slope_y(i,J,k) else - Slope = ((e(i,j,K)-e(i,j+1,K))*G%IdyCv(i,J)) * G%mask2dCv(i,J) + Slope = US%Z_to_m*((e(i,j,K)-e(i,j+1,K))*G%IdyCv(i,J)) * G%mask2dCv(i,J) endif if (CS%id_slope_y > 0) CS%diagSlopeY(I,j,k) = Slope - Sfn_unlim_v(i,K) = ((KH_v(i,J,K)*G%dx_Cv(i,J))*Slope) + Sfn_unlim_v(i,K) = ((KH_v(i,J,K)*G%dx_Cv(i,J))*US%m_to_Z*Slope) hN2_v(i,K) = GV%g_prime(K) endif ! if (use_EOS) else ! if (k > nk_linear) @@ -983,9 +999,9 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV if (CS%use_FGNV_streamfn) then do k=1,nz ; do i=is,ie ; if (G%mask2dCv(i,J)>0.) then - h_harm = H_to_m * max( h_neglect, & + h_harm = max( h_neglect, & 2. * h(i,j,k) * h(i,j+1,k) / ( ( h(i,j,k) + h(i,j+1,k) ) + h_neglect ) ) - c2_h_v(i,k) = CS%FGNV_scale * ( 0.5*( cg1(i,j) + cg1(i,j+1) ) )**2 / h_harm + c2_h_v(i,k) = CS%FGNV_scale * ( 0.5*( cg1(i,j) + cg1(i,j+1) ) )**2 / (GV%H_to_Z*h_harm) endif ; enddo ; enddo ! Solve an elliptic equation for the streamfunction following Ferrari et al., 2010. @@ -1006,9 +1022,9 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV if (vhtot(i,J) <= 0.0) then ! The transport that must balance the transport below is positive. - Sfn_safe = vhtot(i,J) * (1.0 - h_frac(i,j,k)) * H_to_m + Sfn_safe = vhtot(i,J) * (1.0 - h_frac(i,j,k)) * GV%H_to_Z else ! (vhtot(I,j) > 0.0) - Sfn_safe = vhtot(i,J) * (1.0 - h_frac(i,j+1,k)) * H_to_m + Sfn_safe = vhtot(i,J) * (1.0 - h_frac(i,j+1,k)) * GV%H_to_Z endif ! The actual streamfunction at each interface. @@ -1019,7 +1035,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! Make sure that there is enough mass above to allow the streamfunction ! to satisfy the boundary condition of 0 at the surface. - Sfn_in_h = min(max(Sfn_est * m_to_H, -h_avail_rsum(i,j,K)), h_avail_rsum(i,j+1,K)) + Sfn_in_h = min(max(Sfn_est * GV%Z_to_H, -h_avail_rsum(i,j,K)), h_avail_rsum(i,j+1,K)) ! The actual transport is limited by the mass available in the two ! neighboring grid cells. @@ -1061,7 +1077,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! A second order centered estimate is used for the density transfered ! between water columns. - Work_v(i,J) = Work_v(i,J) + ( G_scale * H_to_m ) * & + Work_v(i,J) = Work_v(i,J) + G_scale * & ( vhtot(i,J) * drdkDe_v(i,K) - & (vhD(i,J,K) * drdj_v(i,K)) * 0.25 * & ((e(i,j,K) + e(i,j,K+1)) + (e(i,j+1,K) + e(i,j+1,K+1))) ) @@ -1094,7 +1110,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV drdiB = drho_dT_u(I) * (T(i+1,j,1)-T(i,j,1)) + & drho_dS_u(I) * (S(i+1,j,1)-S(i,j,1)) endif - Work_u(I,j) = Work_u(I,j) + ( G_scale * H_to_m ) * & + Work_u(I,j) = Work_u(I,j) + G_scale * & ( (uhD(I,j,1) * drdiB) * 0.25 * & ((e(i,j,1) + e(i,j,2)) + (e(i+1,j,1) + e(i+1,j,2))) ) @@ -1119,7 +1135,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV drdjB = drho_dT_v(i) * (T(i,j+1,1)-T(i,j,1)) + & drho_dS_v(i) * (S(i,j+1,1)-S(i,j,1)) endif - Work_v(i,J) = Work_v(i,J) - ( G_scale * H_to_m ) * & + Work_v(i,J) = Work_v(i,J) - G_scale * & ( (vhD(i,J,1) * drdjB) * 0.25 * & ((e(i,j,1) + e(i,j,2)) + (e(i,j+1,1) + e(i,j+1,2))) ) enddo @@ -1148,9 +1164,9 @@ end subroutine thickness_diffuse_full !> Tridiagonal solver for streamfunction at interfaces subroutine streamfn_solver(nk, c2_h, hN2, sfn) integer, intent(in) :: nk !< Number of layers - real, dimension(nk), intent(in) :: c2_h !< Wave speed squared over thickness in layers (m s-2) - real, dimension(nk+1), intent(in) :: hN2 !< Thickness times N2 at interfaces (m s-2) - real, dimension(nk+1), intent(inout) :: sfn !< Streamfunction (m3 s-1) + real, dimension(nk), intent(in) :: c2_h !< Wave speed squared over thickness in layers [m s-2] + real, dimension(nk+1), intent(in) :: hN2 !< Thickness times N2 at interfaces [m s-2] + real, dimension(nk+1), intent(inout) :: sfn !< Streamfunction [Z m2 s-1 ~> m3 s-1] or arbitrary units !! On entry, equals diffusivity times slope. !! On exit, equals the streamfunction. ! Local variables @@ -1179,39 +1195,46 @@ subroutine streamfn_solver(nk, c2_h, hN2, sfn) end subroutine streamfn_solver !> Modifies thickness diffusivities to untangle layer structures -subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV, CS, & +subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV, US, CS, & int_slope_u, int_slope_v) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness (H) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: e !< Interface positions (m) - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: Kh_u !< Thickness diffusivity on interfaces at u points (m2/s) - real, dimension(SZI_(G),SZJB_(G),SZK_(G)+1), intent(inout) :: Kh_v !< Thickness diffusivity on interfaces at u points (m2/s) - real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: Kh_u_CFL !< Maximum stable thickness diffusivity at u points (m2/s) - real, dimension(SZI_(G),SZJB_(G)), intent(in) :: Kh_v_CFL !< Maximum stable thickness diffusivity at v points (m2/s) + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: e !< Interface positions [Z ~> m] + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: Kh_u !< Thickness diffusivity on interfaces + !! at u points [m2 s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)+1), intent(inout) :: Kh_v !< Thickness diffusivity on interfaces + !! at v points [m2 s-1] + real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: Kh_u_CFL !< Maximum stable thickness diffusivity + !! at u points [m2 s-1] + real, dimension(SZI_(G),SZJB_(G)), intent(in) :: Kh_v_CFL !< Maximum stable thickness diffusivity + !! at v points [m2 s-1] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure - real, intent(in) :: dt !< Time increment (s) + real, intent(in) :: dt !< Time increment [s] type(thickness_diffuse_CS), pointer :: CS !< Control structure for thickness diffusion real, dimension(SZIB_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: int_slope_u !< Ratio that determine how much of !! the isopycnal slopes are taken directly from the - !! interface slopes without consideration of density gradients. + !! interface slopes without consideration of + !! density gradients. real, dimension(SZI_(G),SZJB_(G),SZK_(G)+1), intent(inout) :: int_slope_v !< Ratio that determine how much of !! the isopycnal slopes are taken directly from the - !! interface slopes without consideration of density gradients. + !! interface slopes without consideration of + !! density gradients. ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & de_top ! The distances between the top of a layer and the top of the - ! region where the detangling is applied, in H. + ! region where the detangling is applied [H ~> m or kg m-2]. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: & Kh_lay_u ! The tentative interface height diffusivity for each layer at - ! u points, in m2 s-1. + ! u points [m2 s-1]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: & Kh_lay_v ! The tentative interface height diffusivity for each layer at - ! v points, in m2 s-1. + ! v points [m2 s-1]. real, dimension(SZI_(G),SZJ_(G)) :: & de_bot ! The distances from the bottom of the region where the - ! detangling is applied, in H. - real :: h1, h2 ! The thinner and thicker surrounding thicknesses, in H, + ! detangling is applied [H ~> m or kg m-2]. + real :: h1, h2 ! The thinner and thicker surrounding thicknesses [H ~> m or kg m-2], ! with the thinner modified near the boundaries to mask out ! thickness variations due to topography, etc. real :: jag_Rat ! The nondimensional jaggedness ratio for a layer, going @@ -1219,44 +1242,45 @@ subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV ! between the arithmetic and harmonic mean thicknesses ! normalized by the arithmetic mean thickness. real :: Kh_scale ! A ratio by which Kh_u_CFL is scaled for maximally jagged - ! layers, nondim. - real :: Kh_det ! The detangling diffusivity, in m2 s-1. + ! layers [nondim]. + real :: Kh_det ! The detangling 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. + ! in roundoff and can be neglected [H ~> m or kg m-2]. real :: I_sl ! The absolute value of the larger in magnitude of the slopes ! above and below. real :: Rsl ! The ratio of the smaller magnitude slope to the larger - ! magnitude one, ND. 0 <= Rsl <1. - real :: IRsl ! The (limited) inverse of Rsl, ND. 1 < IRsl <= 1e9. + ! magnitude one [nondim]. 0 <= Rsl <1. + real :: IRsl ! The (limited) inverse of Rsl [nondim]. 1 < IRsl <= 1e9. real :: dH ! The thickness gradient divided by the damping timescale ! and the ratio of the face length to the adjacent cell - ! areas for comparability with the diffusivities, in m2 s-1. - real :: adH ! The absolute value of dH, in m2 s-1. + ! areas for comparability with the diffusivities [m2 s-1]. + real :: adH ! The absolute value of dH [m2 s-1]. real :: sign ! 1 or -1, with the same sign as the layer thickness gradient. - real :: sl_K ! The sign-corrected slope of the interface above, ND. - real :: sl_Kp1 ! The sign-corrected slope of the interface below, ND. - real :: I_sl_K ! The (limited) inverse of sl_K, ND. - real :: I_sl_Kp1 ! The (limited) inverse of sl_Kp1, ND. - real :: I_4t ! A quarter of inverse of the damping timescale, in s-1. + real :: sl_K ! The sign-corrected slope of the interface above [nondim]. + real :: sl_Kp1 ! The sign-corrected slope of the interface below [nondim]. + real :: I_sl_K ! The (limited) inverse of sl_K [nondim]. + real :: I_sl_Kp1 ! The (limited) inverse of sl_Kp1 [nondim]. + real :: I_4t ! A quarter of a unit conversion factor divided by + ! the damping timescale [s-1]. real :: Fn_R ! A function of Rsl, such that Rsl < Fn_R < 1. real :: denom, I_denom ! A denominator and its inverse, various units. - real :: Kh_min ! A local floor on the diffusivity, in m2 s-1. - real :: Kh_max ! A local ceiling on the diffusivity, in m2 s-1. + real :: Kh_min ! A local floor on the diffusivity [m2 s-1]. + real :: Kh_max ! A local ceiling on the diffusivity [m2 s-1]. real :: wt1, wt2 ! Nondimensional weights. ! Variables used only in testing code. ! real, dimension(SZK_(G)) :: uh_here ! real, dimension(SZK_(G)+1) :: Sfn - real :: dKh ! An increment in the diffusivity, in m2 s-1. + real :: dKh ! An increment in the diffusivity [m2 s-1]. real, dimension(SZIB_(G),SZK_(G)+1) :: & - Kh_bg, & ! The background (floor) value of Kh, in m2 s-1. - Kh, & ! The tentative value of Kh, in m2 s-1. - Kh_detangle, & ! The detangling diffusivity that could be used, in m2 s-1. + Kh_bg, & ! The background (floor) value of Kh [m2 s-1]. + Kh, & ! The tentative value of Kh [m2 s-1]. + Kh_detangle, & ! The detangling diffusivity that could be used [m2 s-1]. Kh_min_max_p, & ! The smallest ceiling that can be placed on Kh(I,K) - ! based on the value of Kh(I,K+1), in m2 s-1. + ! based on the value of Kh(I,K+1) [m2 s-1]. Kh_min_max_m, & ! The smallest ceiling that can be placed on Kh(I,K) - ! based on the value of Kh(I,K-1), in m2 s-1. + ! based on the value of Kh(I,K-1) [m2 s-1]. ! The following are variables that define the relationships between ! successive values of Kh. ! Search for Kh that satisfy... @@ -1264,14 +1288,14 @@ subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV ! Kh(I,K) >= Kh_min_p(I,K)*Kh(I,K+1) + Kh0_min_p(I,K) ! Kh(I,K) <= Kh_max_m(I,K)*Kh(I,K-1) + Kh0_max_m(I,K) ! Kh(I,K) <= Kh_max_p(I,K)*Kh(I,K+1) + Kh0_max_p(I,K) - Kh_min_m , & ! See above, ND. - Kh0_min_m , & ! See above, in m2 s-1. - Kh_max_m , & ! See above, ND. - Kh0_max_m, & ! See above, in m2 s-1. - Kh_min_p , & ! See above, ND. - Kh0_min_p , & ! See above, in m2 s-1. - Kh_max_p , & ! See above, ND. - Kh0_max_p ! See above, in m2 s-1. + Kh_min_m , & ! See above [nondim]. + Kh0_min_m , & ! See above [m2 s-1]. + Kh_max_m , & ! See above [nondim]. + Kh0_max_m, & ! See above [m2 s-1]. + Kh_min_p , & ! See above [nondim]. + Kh0_min_p , & ! See above [m2 s-1]. + Kh_max_p , & ! See above [nondim]. + Kh0_max_p ! See above [m2 s-1]. real, dimension(SZIB_(G)) :: & Kh_max_max ! The maximum diffusivity permitted in a column. logical, dimension(SZIB_(G)) :: & @@ -1334,7 +1358,7 @@ subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV ! Limit the diffusivities - I_4t = Kh_scale / (4.0*dt) + I_4t = US%Z_to_m*Kh_scale / (4.0*dt) do n=1,2 if (n==1) then ; jsh = js ; ish = is-1 @@ -1377,7 +1401,7 @@ subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV ! dH = I_4t * (h(i+1,j,k) - h(i,j,k)) / denom adH = abs(dH) - sign = 1.0 ; if (dH < 0) sign = -1.0 + sign = 1.0*US%Z_to_m ; if (dH < 0) sign = -1.0*US%Z_to_m sl_K = sign * (e(i+1,j,K)-e(i,j,K)) * G%IdxCu(I,j) sl_Kp1 = sign * (e(i+1,j,K+1)-e(i,j,K+1)) * G%IdxCu(I,j) @@ -1400,7 +1424,7 @@ subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV ! dH = I_4t * (h(i,j+1,k) - h(i,j,k)) / denom adH = abs(dH) - sign = 1.0 ; if (dH < 0) sign = -1.0 + sign = 1.0*US%Z_to_m ; if (dH < 0) sign = -1.0*US%Z_to_m sl_K = sign * (e(i,j+1,K)-e(i,j,K)) * G%IdyCv(i,J) sl_Kp1 = sign * (e(i,j+1,K+1)-e(i,j,K+1)) * G%IdyCv(i,J) @@ -1594,31 +1618,27 @@ end subroutine add_detangling_Kh subroutine vert_fill_TS(h, T_in, S_in, kappa, dt, T_f, S_f, G, GV, halo_here) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness (m or kg/m2) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: T_in !< Input temperature (C) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: S_in !< Input salinity (ppt) - real, intent(in) :: kappa !< Constant diffusivity to use (m2/s) - real, intent(in) :: dt !< Time increment (s) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: T_f !< Filled temperature (C) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: S_f !< Filled salinity (ppt) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness [H ~> 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, 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, !! 0 by default ! Local variables real :: ent(SZI_(G),SZK_(G)+1) ! The diffusive entrainment (kappa*dt)/dz - ! between layers in a timestep in m or kg m-2. + ! between layers in a timestep [H ~> m or kg m-2]. real :: b1(SZI_(G)), d1(SZI_(G)) ! b1, c1, and d1 are variables used by the real :: c1(SZI_(G),SZK_(G)) ! tridiagonal solver. - real :: kap_dt_x2 ! The product of 2*kappa*dt, converted to - ! the same units as h, in m2 or kg2 m-4. - real :: h0 ! A negligible thickness, in m or kg m-2, to - ! allow for zero thicknesses. - real :: h_neglect ! A thickness that is so small it is usually - ! lost in roundoff and can be neglected - ! (m for Bouss and kg/m^2 for non-Bouss). - ! 0 < h_neglect << h0. + real :: kap_dt_x2 ! The product of 2*kappa*dt [H2 ~> m2 or kg2 m-4]. + real :: h0 ! A negligible thickness to allow for zero + ! thicknesses [H ~> m or kg m-2]. + real :: h_neglect ! A thickness that is so small it is usually lost in roundoff + ! and can be neglected [H ~> m or kg m-2]. 0 < h_neglect << h0. real :: h_tr ! h_tr is h at tracer points with a tiny thickness - ! added to ensure positive definiteness - ! (m for Bouss, kg/m^2 for non-Bouss) + ! added to ensure positive definiteness [H ~> m or kg m-2]. integer :: i, j, k, is, ie, js, je, nz, halo halo=0 ; if (present(halo_here)) halo = max(halo_here,0) @@ -1626,8 +1646,8 @@ subroutine vert_fill_TS(h, T_in, S_in, kappa, dt, T_f, S_f, G, GV, halo_here) is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo nz = G%ke h_neglect = GV%H_subroundoff - kap_dt_x2 = (2.0*kappa*dt)*GV%m_to_H**2 - h0 = 1.0e-16*sqrt(kappa*dt)*GV%m_to_H + kap_dt_x2 = (2.0*kappa*dt)*GV%Z_to_H**2 + h0 = 1.0e-16*sqrt(kappa*dt)*GV%Z_to_H if (kap_dt_x2 <= 0.0) then !$OMP parallel do default(none) shared(is,ie,js,je,nz,T_f,T_in,S_f,S_in) @@ -1672,10 +1692,11 @@ subroutine vert_fill_TS(h, T_in, S_in, kappa, dt, T_f, S_f, G, GV, halo_here) end subroutine vert_fill_TS !> Initialize the thickness diffusion module/structure -subroutine thickness_diffuse_init(Time, G, GV, param_file, diag, CDp, CS) +subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) type(time_type), intent(in) :: Time !< Current model time type(ocean_grid_type), intent(in) :: G !< Ocean 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 !< Parameter file handles type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure type(cont_diag_ptrs), intent(inout) :: CDp !< Continuity equation diagnostics @@ -1735,7 +1756,7 @@ subroutine thickness_diffuse_init(Time, G, GV, param_file, diag, CDp, CS) call get_param(param_file, mdl, "KD_SMOOTH", CS%kappa_smooth, & "A diapycnal diffusivity that is used to interpolate \n"//& "more sensible values of T & S into thin layers.", & - default=1.0e-6) + 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"//& @@ -1811,16 +1832,19 @@ subroutine thickness_diffuse_init(Time, G, GV, param_file, diag, CDp, CS) CS%id_sfn_y = register_diag_field('ocean_model', 'GM_sfn_y', diag%axesCvi, Time, & 'Parameterized Meridional Overturning Streamfunction', 'm3 s-1') CS%id_sfn_unlim_x = register_diag_field('ocean_model', 'GM_sfn_unlim_x', diag%axesCui, Time, & - 'Parameterized Zonal Overturning Streamfunction before limiting/smoothing', 'm3 s-1') + 'Parameterized Zonal Overturning Streamfunction before limiting/smoothing', & + 'm3 s-1', conversion=US%Z_to_m) CS%id_sfn_unlim_y = register_diag_field('ocean_model', 'GM_sfn_unlim_y', diag%axesCvi, Time, & - 'Parameterized Meridional Overturning Streamfunction before limiting/smoothing', 'm3 s-1') + 'Parameterized Meridional Overturning Streamfunction before limiting/smoothing', & + 'm3 s-1', conversion=US%Z_to_m) end subroutine thickness_diffuse_init !> Deallocate the thickness diffusion control structure subroutine thickness_diffuse_end(CS) - type(thickness_diffuse_CS), pointer :: CS !< Control structure for thickness diffusion - if(associated(CS)) deallocate(CS) + type(thickness_diffuse_CS), pointer :: CS !< Control structure for thickness diffusion + + if (associated(CS)) deallocate(CS) end subroutine thickness_diffuse_end !> \namespace mom_thickness_diffuse @@ -1846,10 +1870,11 @@ end subroutine thickness_diffuse_end !! \f[ !! \vec{\psi} = \kappa_h \frac{M^2}{\sqrt{N^4 + M^4}} !! \f] -!! since the quantity \f$\frac{M^2}{\sqrt{N^2 + M^2}}\f$ is bounded between $-1$ and $1$ and does not change sign if \f$N^2<0\f$. +!! since the quantity \f$\frac{M^2}{\sqrt{N^2 + M^2}}\f$ is bounded between $-1$ and $1$ and does not change sign +!! if \f$N^2<0\f$. !! -!! Optionally, the method of Ferrari et al, 2010, can be used to obtain the streamfunction which solves the vertically elliptic -!! equation: +!! Optionally, the method of Ferrari et al, 2010, can be used to obtain the streamfunction which solves the +!! vertically elliptic equation: !! \f[ !! \gamma_F \partial_z c^2 \partial_z \psi - N_*^2 \psi = ( 1 + \gamma_F ) \kappa_h N_*^2 \frac{M^2}{\sqrt{N^4+M^4}} !! \f] @@ -1865,22 +1890,23 @@ end subroutine thickness_diffuse_end !! \kappa_h = \left( \kappa_o + \alpha_{s} L_{s}^2 < S N > + \alpha_{M} \kappa_{M} \right) r(\Delta x,L_d) !! \f] !! where \f$ S \f$ is the isoneutral slope magnitude, \f$ N \f$ is the square root of Brunt-Vaisala frequency, -!! \f$\kappa_{M}\f$ is the diffusivity calculated by the MEKE parameterization (mom_meke module) and \f$ r(\Delta x,L_d) \f$ is -!! a function of the local resolution (ratio of grid-spacing, \f$\Delta x\f$, to deformation radius, \f$L_d\f$). -!! The length \f$L_s\f$ is provided by the mom_lateral_mixing_coeffs module (enabled with -!! USE_VARIABLE_MIXING=True and the term \f$\f$ is the vertical average slope times Brunt-Vaisala frequency -!! prescribed by Visbeck et al., 1996. +!! \f$\kappa_{M}\f$ is the diffusivity calculated by the MEKE parameterization (mom_meke module) and +!! \f$ r(\Delta x,L_d) \f$ is a function of the local resolution (ratio of grid-spacing, \f$\Delta x\f$, +!! to deformation radius, \f$L_d\f$). The length \f$L_s\f$ is provided by the mom_lateral_mixing_coeffs module +!! (enabled with USE_VARIABLE_MIXING=True and the term \f$\f$ is the vertical average slope +!! times the Brunt-Vaisala frequency prescribed by Visbeck et al., 1996. !! !! The result of the above expression is subsequently bounded by minimum and maximum values, including an upper !! diffusivity consistent with numerical stability (\f$ \kappa_{cfl} \f$ is calculated internally). !! \f[ -!! \kappa_h \leftarrow \min{\left( \kappa_{max}, \kappa_{cfl}, \max{\left( \kappa_{min}, \kappa_h \right)} \right)} f(c_g,z) +!! \kappa_h \leftarrow \min{\left( \kappa_{max}, \kappa_{cfl}, \max{\left( \kappa_{min}, \kappa_h \right)} \right)} +!! f(c_g,z) !! \f] !! !! where \f$f(c_g,z)\f$ is a vertical structure function. !! \f$f(c_g,z)\f$ is calculated in module mom_lateral_mixing_coeffs. -!! If KHTH_USE_EBT_STRUCT=True then \f$f(c_g,z)\f$ is set to look like the equivalent barotropic modal velocity structure. -!! Otherwise \f$f(c_g,z)=1\f$ and the diffusivity is independent of depth. +!! If KHTH_USE_EBT_STRUCT=True then \f$f(c_g,z)\f$ is set to look like the equivalent barotropic +!! modal velocity structure. Otherwise \f$f(c_g,z)=1\f$ and the diffusivity is independent of depth. !! !! In order to calculate meaningful slopes in vanished layers, temporary copies of the thermodynamic variables !! are passed through a vertical smoother, function vert_fill_ts(): diff --git a/src/parameterizations/lateral/MOM_tidal_forcing.F90 b/src/parameterizations/lateral/MOM_tidal_forcing.F90 index c9b0c96da2..075c69ed65 100644 --- a/src/parameterizations/lateral/MOM_tidal_forcing.F90 +++ b/src/parameterizations/lateral/MOM_tidal_forcing.F90 @@ -1,38 +1,8 @@ +!> Tidal contributions to geopotential module MOM_tidal_forcing ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* Code by Robert Hallberg, August 2005, based on C-code by Harper * -!* Simmons, February, 2003, in turn based on code by Brian Arbic. * -!* * -!* The main subroutine in this file calculates the total tidal * -!* contribution to the geopotential, including self-attraction and * -!* loading terms and the astronomical contributions. All options * -!* are selected with entries in a file that is parsed at run-time. * -!* Overall tides are enabled with a line '#define TIDES' in that file.* -!* Tidal constituents must be individually enabled with lines like * -!* '#define TIDE_M2'. This file has default values of amplitude, * -!* frequency, Love number, and phase at time 0 for the Earth's M2, * -!* S2, N2, K2, K1, O1, P1, Q1, MF, and MM tidal constituents, but * -!* the frequency, amplitude and phase ant time 0 for each constituent * -!* can be changed at run time by setting variables like TIDE_M2_FREQ, * -!* TIDE_M2_AMP and TIDE_M2_PHASE_T0 (for M2). * -!* * -!* In addition, the approach to calculating self-attraction and * -!* loading is set at run time. The default is to use the scalar * -!* approximation, with a coefficient TIDE_SAL_SCALAR_VALUE that must * -!* be set in the run-time file (for global runs, 0.094 is typical). * -!* Alternately, TIDAL_SAL_FROM_FILE can be set to read the SAL from * -!* a file containing the results of a previous simulation. To iterate * -!* the SAL to convergence, USE_PREVIOUS_TIDES may be useful (for * -!* details, see Arbic et al., 2004, DSR II). With TIDAL_SAL_FROM_FILE * -!* or USE_PREVIOUS_TIDES,a list of input files must be provided to * -!* describe each constituent's properties from a previous solution. * -!* * -!*********************************************************************** - use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, & CLOCK_MODULE use MOM_domains, only : pass_var @@ -49,41 +19,42 @@ module MOM_tidal_forcing #include -integer, parameter :: MAX_CONSTITUENTS = 10 ! The maximum number of tidal - ! constituents that could be used. +integer, parameter :: MAX_CONSTITUENTS = 10 !< The maximum number of tidal + !! constituents that could be used. +!> The control structure for the MOM_tidal_forcing module type, public :: tidal_forcing_CS ; private - logical :: use_sal_scalar ! If true, use the scalar approximation when - ! calculating self-attraction and loading. - logical :: tidal_sal_from_file ! If true, Read the tidal self-attraction - ! and loading from input files, specified - ! by TIDAL_INPUT_FILE. - logical :: use_prev_tides ! If true, use the SAL from the previous - ! iteration of the tides to facilitate convergence. - real :: sal_scalar ! The constant of proportionality between sea surface - ! height (really it should be bottom pressure) anomalies - ! and bottom geopotential anomalies. - integer :: nc ! The number of tidal constituents in use. + logical :: use_sal_scalar !< If true, use the scalar approximation when + !! calculating self-attraction and loading. + logical :: tidal_sal_from_file !< If true, Read the tidal self-attraction + !! and loading from input files, specified + !! by TIDAL_INPUT_FILE. + logical :: use_prev_tides !< If true, use the SAL from the previous + !! iteration of the tides to facilitate convergence. + real :: sal_scalar !< The constant of proportionality between sea surface + !! height (really it should be bottom pressure) anomalies + !! and bottom geopotential anomalies. + integer :: nc !< The number of tidal constituents in use. real, dimension(MAX_CONSTITUENTS) :: & - freq, & ! The frequency of a tidal constituent, in s-1. - phase0, & ! The phase of a tidal constituent at time 0, in radians. - amp, & ! The amplitude of a tidal constituent at time 0, in m. - love_no ! The Love number of a tidal constituent at time 0, ND. - integer :: struct(MAX_CONSTITUENTS) - character (len=16) :: const_name(MAX_CONSTITUENTS) + freq, & !< The frequency of a tidal constituent [s-1]. + phase0, & !< The phase of a tidal constituent at time 0, in radians. + amp, & !< The amplitude of a tidal constituent at time 0 [m]. + love_no !< The Love number of a tidal constituent at time 0 [nondim]. + integer :: struct(MAX_CONSTITUENTS) !< An encoded spatial structure for each constituent + character (len=16) :: const_name(MAX_CONSTITUENTS) !< The name of each constituent real, pointer, dimension(:,:,:) :: & - sin_struct => NULL(), & ! The sine and cosine based structures that can - cos_struct => NULL(), & ! be associated with the astronomical forcing. - cosphasesal => NULL(), & ! The cosine and sine of the phase of the - sinphasesal => NULL(), & ! self-attraction and loading amphidromes. - ampsal => NULL(), & ! The amplitude of the SAL, in m. - cosphase_prev => NULL(), & ! The cosine and sine of the phase of the - sinphase_prev => NULL(), & ! amphidromes in the previous tidal solutions. - amp_prev => NULL() ! The amplitude of the previous tidal solution, in m. + sin_struct => NULL(), & !< The sine and cosine based structures that can + cos_struct => NULL(), & !< be associated with the astronomical forcing. + cosphasesal => NULL(), & !< The cosine and sine of the phase of the + sinphasesal => NULL(), & !< self-attraction and loading amphidromes. + ampsal => NULL(), & !< The amplitude of the SAL [m]. + cosphase_prev => NULL(), & !< The cosine and sine of the phase of the + sinphase_prev => NULL(), & !< amphidromes in the previous tidal solutions. + amp_prev => NULL() !< The amplitude of the previous tidal solution [m]. end type tidal_forcing_CS -integer :: id_clock_tides +integer :: id_clock_tides !< CPU clock for tides contains @@ -95,23 +66,10 @@ module MOM_tidal_forcing subroutine tidal_forcing_init(Time, G, param_file, CS) type(time_type), intent(in) :: Time !< The current model time. type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time - !! parameters. + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters. type(tidal_forcing_CS), pointer :: CS !< A pointer that is set to point to the control !! structure for this module. - -! This subroutine allocates space for the static variables used -! by this module. The metrics may be effectively 0, 1, or 2-D arrays, -! while fields like the background viscosities are 2-D arrays. -! ALLOC is a macro defined in MOM_memory.h for allocate or nothing with -! static memory. -! -! Arguments: Time - The current model time. -! (in) G - The ocean's grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in/out) CS - A pointer that is set to point to the control structure -! for this module. + ! Local variables real, dimension(SZI_(G), SZJ_(G)) :: & phase, & ! The phase of some tidal constituent. lat_rad, lon_rad ! Latitudes and longitudes of h-points in radians. @@ -383,33 +341,34 @@ subroutine tidal_forcing_init(Time, G, param_file, CS) end subroutine tidal_forcing_init -! #@# This subroutine needs a doxygen description. -subroutine find_in_files(tidal_input_files,varname,array,G) - character(len=*), intent(in) :: tidal_input_files(:) - character(len=*), intent(in) :: varname - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: array - +!> This subroutine finds a named variable in a list of files and reads its +!! values into a domain-decomposed 2-d array +subroutine find_in_files(filenames, varname, array, G) + character(len=*), dimension(:), intent(in) :: filenames !< The names of the files to search for the named variable + character(len=*), intent(in) :: varname !< The name of the variable to read + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: array !< The array to fill with the data + ! Local variables integer :: nf - do nf=1,size(tidal_input_files) - if (LEN_TRIM(tidal_input_files(nf)) == 0) cycle - if (field_exists(tidal_input_files(nf), varname, G%Domain%mpp_domain)) then - call MOM_read_data(tidal_input_files(nf), varname, array, G%Domain) + do nf=1,size(filenames) + if (LEN_TRIM(filenames(nf)) == 0) cycle + if (field_exists(filenames(nf), varname, G%Domain%mpp_domain)) then + call MOM_read_data(filenames(nf), varname, array, G%Domain) return endif enddo - do nf=size(tidal_input_files),1,-1 - if (file_exists(tidal_input_files(nf), G%Domain)) then + do nf=size(filenames),1,-1 + if (file_exists(filenames(nf), G%Domain)) then call MOM_error(FATAL, "MOM_tidal_forcing.F90: Unable to find "// & trim(varname)//" in any of the tidal input files, last tried "// & - trim(tidal_input_files(nf))) + trim(filenames(nf))) endif enddo call MOM_error(FATAL, "MOM_tidal_forcing.F90: Unable to find any of the "// & - "tidal input files, including "//trim(tidal_input_files(1))) + "tidal input files, including "//trim(filenames(1))) end subroutine find_in_files @@ -418,18 +377,9 @@ end subroutine find_in_files !! and loading. subroutine tidal_forcing_sensitivity(G, CS, deta_tidal_deta) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(tidal_forcing_CS), pointer :: CS !< The control structure returned by a previous call to - !! tidal_forcing_init. + type(tidal_forcing_CS), pointer :: CS !< The control structure returned by a previous call to tidal_forcing_init. real, intent(out) :: deta_tidal_deta !< The partial derivative of eta_tidal with - !! the local value of eta, nondim. -! This subroutine calculates returns the partial derivative of the local -! geopotential height with the input sea surface height due to self-attraction -! and loading. -! (in) G - The ocean's grid structure. -! (in) CS - The control structure returned by a previous call to -! tidal_forcing_init. -! (out) deta_tidal_deta - the partial derivative of eta_tidal with the -! local value of eta, nondim. + !! the local value of eta [nondim]. if (CS%USE_SAL_SCALAR .and. CS%USE_PREV_TIDES) then deta_tidal_deta = 2.0*CS%SAL_SCALAR @@ -443,44 +393,31 @@ end subroutine tidal_forcing_sensitivity !> This subroutine calculates the geopotential anomalies that drive the tides, !! including self-attraction and loading. Optionally, it also returns the !! partial derivative of the local geopotential height with the input sea surface -!! height. For now, eta and eta_tidal are both geopotential heights in m, but -!! probably the input for eta should really be replaced with the column mass -!! anomalies. -subroutine calc_tidal_forcing(Time, eta, eta_tidal, G, CS, deta_tidal_deta) +!! height. For now, eta and eta_tidal are both geopotential heights in depth +!! units, but probably the input for eta should really be replaced with the +!! column mass anomalies. +subroutine calc_tidal_forcing(Time, eta, eta_tidal, G, CS, deta_tidal_deta, m_to_Z) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(time_type), intent(in) :: Time !< The time for the caluculation. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: eta !< The sea surface height anomaly from - !! a time-mean geoid in m. - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: eta_tidal !< The tidal forcing geopotential - !! anomalies, in m. + !! a time-mean geoid [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: eta_tidal !< The tidal forcing geopotential height + !! anomalies [Z ~> m]. type(tidal_forcing_CS), pointer :: CS !< The control structure returned by a !! previous call to tidal_forcing_init. real, optional, intent(out) :: deta_tidal_deta !< The partial derivative of !! eta_tidal with the local value of - !! eta, nondim. - -! This subroutine calculates the geopotential anomalies that drive the tides, -! including self-attraction and loading. Optionally, it also returns the -! partial derivative of the local geopotential height with the input sea surface -! height. For now, eta and eta_tidal are both geopotential heights in m, but -! probably the input for eta should really be replaced with the column mass -! anomalies. -! -! Arguments: Time - The time for the caluculation. -! (in) eta - The sea surface height anomaly from a time-mean geoid in m. -! (out) eta_tidal - The tidal forcing geopotential anomalies, in m. -! (in) G - The ocean's grid structure. -! (in) CS - The control structure returned by a previous call to -! tidal_forcing_init. -! (out) deta_tidal_deta - the partial derivative of eta_tidal with the -! local value of eta, nondim. + !! eta [nondim]. + real, optional, intent(in) :: m_to_Z !< A scaling factor from m to the units of eta. + ! Local variables real :: eta_astro(SZI_(G),SZJ_(G)) real :: eta_SAL(SZI_(G),SZJ_(G)) real :: now ! The relative time in seconds. real :: amp_cosomegat, amp_sinomegat real :: cosomegat, sinomegat - real :: eta_prop + real :: m_Z ! A scaling factor from m to depth units. + real :: eta_prop ! The nondimenional constant of proportionality beteen eta and eta_tidal. integer :: i, j, c, m, is, ie, js, je, Isq, Ieq, Jsq, Jeq is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB @@ -513,10 +450,12 @@ subroutine calc_tidal_forcing(Time, eta, eta_tidal, G, CS, deta_tidal_deta) enddo ; enddo endif + m_Z = 1.0 ; if (present(m_to_Z)) m_Z = m_to_Z + do c=1,CS%nc m = CS%struct(c) - amp_cosomegat = CS%amp(c)*CS%love_no(c)*cos(CS%freq(c)*now + CS%phase0(c)) - amp_sinomegat = CS%amp(c)*CS%love_no(c)*sin(CS%freq(c)*now + CS%phase0(c)) + amp_cosomegat = m_Z*CS%amp(c)*CS%love_no(c) * cos(CS%freq(c)*now + CS%phase0(c)) + amp_sinomegat = m_Z*CS%amp(c)*CS%love_no(c) * sin(CS%freq(c)*now + CS%phase0(c)) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 eta_tidal(i,j) = eta_tidal(i,j) + (amp_cosomegat*CS%cos_struct(i,j,m) + & amp_sinomegat*CS%sin_struct(i,j,m)) @@ -527,7 +466,7 @@ subroutine calc_tidal_forcing(Time, eta, eta_tidal, G, CS, deta_tidal_deta) cosomegat = cos(CS%freq(c)*now) sinomegat = sin(CS%freq(c)*now) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta_tidal(i,j) = eta_tidal(i,j) + CS%ampsal(i,j,c) * & + eta_tidal(i,j) = eta_tidal(i,j) + m_Z*CS%ampsal(i,j,c) * & (cosomegat*CS%cosphasesal(i,j,c) + sinomegat*CS%sinphasesal(i,j,c)) enddo ; enddo enddo ; endif @@ -536,8 +475,8 @@ subroutine calc_tidal_forcing(Time, eta, eta_tidal, G, CS, deta_tidal_deta) cosomegat = cos(CS%freq(c)*now) sinomegat = sin(CS%freq(c)*now) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta_tidal(i,j) = eta_tidal(i,j) - CS%SAL_SCALAR*CS%amp_prev(i,j,c) * & - (cosomegat*CS%cosphase_prev(i,j,c)+sinomegat*CS%sinphase_prev(i,j,c)) + eta_tidal(i,j) = eta_tidal(i,j) - m_Z*CS%SAL_SCALAR*CS%amp_prev(i,j,c) * & + (cosomegat*CS%cosphase_prev(i,j,c) + sinomegat*CS%sinphase_prev(i,j,c)) enddo ; enddo enddo ; endif @@ -545,8 +484,10 @@ subroutine calc_tidal_forcing(Time, eta, eta_tidal, G, CS, deta_tidal_deta) end subroutine calc_tidal_forcing +!> This subroutine deallocates memory associated with the tidal forcing module. subroutine tidal_forcing_end(CS) - type(tidal_forcing_CS), pointer :: CS + type(tidal_forcing_CS), pointer :: CS !< The control structure returned by a previous call + !! to tidal_forcing_init; it is deallocated here. if (associated(CS%sin_struct)) deallocate(CS%sin_struct) if (associated(CS%cos_struct)) deallocate(CS%cos_struct) @@ -563,4 +504,33 @@ subroutine tidal_forcing_end(CS) end subroutine tidal_forcing_end +!> \namespace tidal_forcing +!! +!! Code by Robert Hallberg, August 2005, based on C-code by Harper +!! Simmons, February, 2003, in turn based on code by Brian Arbic. +!! +!! The main subroutine in this file calculates the total tidal +!! contribution to the geopotential, including self-attraction and +!! loading terms and the astronomical contributions. All options +!! are selected with entries in a file that is parsed at run-time. +!! Overall tides are enabled with the run-time parameter 'TIDES=True'. +!! Tidal constituents must be individually enabled with lines like +!! 'TIDE_M2=True'. This file has default values of amplitude, +!! frequency, Love number, and phase at time 0 for the Earth's M2, +!! S2, N2, K2, K1, O1, P1, Q1, MF, and MM tidal constituents, but +!! the frequency, amplitude and phase ant time 0 for each constituent +!! can be changed at run time by setting variables like TIDE_M2_FREQ, +!! TIDE_M2_AMP and TIDE_M2_PHASE_T0 (for M2). +!! +!! In addition, the approach to calculating self-attraction and +!! loading is set at run time. The default is to use the scalar +!! approximation, with a coefficient TIDE_SAL_SCALAR_VALUE that must +!! be set in the run-time file (for global runs, 0.094 is typical). +!! Alternately, TIDAL_SAL_FROM_FILE can be set to read the SAL from +!! a file containing the results of a previous simulation. To iterate +!! the SAL to convergence, USE_PREVIOUS_TIDES may be useful (for +!! details, see Arbic et al., 2004, DSR II). With TIDAL_SAL_FROM_FILE +!! or USE_PREVIOUS_TIDES,a list of input files must be provided to +!! describe each constituent's properties from a previous solution. + end module MOM_tidal_forcing diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index f615e988cf..7678a4b799 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -1,11 +1,12 @@ !> This module contains the routines used to apply sponge layers when using !! the ALE mode. +!! !! Applying sponges requires the following: -!! (1) initialize_ALE_sponge -!! (2) set_up_ALE_sponge_field (tracers) and set_up_ALE_sponge_vel_field (vel) -!! (3) apply_ALE_sponge -!! (4) init_ALE_sponge_diags (not being used for now) -!! (5) ALE_sponge_end (not being used for now) +!! 1. initialize_ALE_sponge +!! 2. set_up_ALE_sponge_field (tracers) and set_up_ALE_sponge_vel_field (vel) +!! 3. apply_ALE_sponge +!! 4. init_ALE_sponge_diags (not being used for now) +!! 5. ALE_sponge_end (not being used for now) module MOM_ALE_sponge @@ -17,35 +18,50 @@ module MOM_ALE_sponge use MOM_error_handler, only : MOM_error, FATAL, NOTE, WARNING, is_root_pe use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type +use MOM_horizontal_regridding, only : horiz_interp_and_extrap_tracer use MOM_spatial_means, only : global_i_mean use MOM_time_manager, only : time_type, init_external_field, get_external_field_size, time_interp_external_init use MOM_remapping, only : remapping_cs, remapping_core_h, initialize_remapping -use MOM_horizontal_regridding, only : horiz_interp_and_extrap_tracer - +use MOM_unit_scaling, only : unit_scale_type +use MOM_verticalGrid, only : verticalGrid_type ! GMM - Planned extension: Support for time varying sponge targets. implicit none ; private #include +!> Store the reference profile at h points for a variable interface set_up_ALE_sponge_field module procedure set_up_ALE_sponge_field_fixed module procedure set_up_ALE_sponge_field_varying end interface +!> This subroutine stores the reference profile at u and v points for a vector interface set_up_ALE_sponge_vel_field module procedure set_up_ALE_sponge_vel_field_fixed module procedure set_up_ALE_sponge_vel_field_varying end interface +!> Ddetermine the number of points which are within sponges in this computational domain. +!! +!! Only points that have positive values of Iresttime and which mask2dT indicates are ocean +!! points are included in the sponges. It also stores the target interface heights. interface initialize_ALE_sponge module procedure initialize_ALE_sponge_fixed module procedure initialize_ALE_sponge_varying end interface -!< Publicly available functions + +! Publicly available functions public set_up_ALE_sponge_field, set_up_ALE_sponge_vel_field +public get_ALE_sponge_thicknesses, get_ALE_sponge_nz_data public initialize_ALE_sponge, apply_ALE_sponge, ALE_sponge_end, init_ALE_sponge_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. + +!> A structure for creating arrays of pointers to 3D arrays with extra gridding information type :: p3d integer :: id !< id for FMS external time interpolator integer :: nz_data !< The number of vertical levels in the input field. @@ -54,6 +70,8 @@ module MOM_ALE_sponge real, dimension(:,:,:), pointer :: p => NULL() !< pointer to the data. real, dimension(:,:,:), pointer :: h => NULL() !< pointer to the data grid. end type p3d + +!> A structure for creating arrays of pointers to 2D arrays with extra gridding information type :: p2d integer :: id !< id for FMS external time interpolator integer :: nz_data !< The number of vertical levels in the input field @@ -63,39 +81,48 @@ module MOM_ALE_sponge real, dimension(:,:), pointer :: h => NULL() !< pointer the data grid. end type p2d -!> SPONGE control structure +!> ALE sponge control structure type, public :: ALE_sponge_CS ; private - integer :: nz !< The total number of layers. - integer :: nz_data !< The total number of arbritary layers (used by older code). - integer :: isc, iec, jsc, jec !< The index ranges of the computational domain at h. - integer :: iscB, iecB, jscB, jecB !< The index ranges of the computational domain at u/v. - integer :: isd, ied, jsd, jed !< The index ranges of the data domain. - integer :: num_col, num_col_u, num_col_v !< The number of sponge points within the - !! computational domain. - integer :: fldno = 0 !< The number of fields which have already been - !! registered by calls to set_up_sponge_field - logical :: sponge_uv !< Control whether u and v are included in sponge - integer, pointer :: col_i(:) => NULL() !< Arrays containing the i- and j- indicies - integer, pointer :: col_j(:) => NULL() !! of each of the columns being damped. - integer, pointer :: col_i_u(:) => NULL() !< Same as above for u points - integer, pointer :: col_j_u(:) => NULL() - integer, pointer :: col_i_v(:) => NULL() !< Same as above for v points - integer, pointer :: col_j_v(:) => NULL() - - real, pointer :: Iresttime_col(:) => NULL() !< The inverse restoring time of - !! each column. - real, pointer :: Iresttime_col_u(:) => NULL() !< Same as above for u points - real, pointer :: Iresttime_col_v(:) => NULL() !< Same as above for v points + integer :: nz !< The total number of layers. + integer :: nz_data !< The total number of arbritary layers (used by older code). + integer :: isc !< The starting i-index of the computational domain at h. + integer :: iec !< The ending i-index of the computational domain at h. + integer :: jsc !< The starting j-index of the computational domain at h. + integer :: jec !< The ending j-index of the computational domain at h. + integer :: IscB !< The starting I-index of the computational domain at u/v. + integer :: IecB !< The ending I-index of the computational domain at u/v. + integer :: JscB !< The starting J-index of the computational domain at u/v. + integer :: JecB !< The ending J-index of the computational domain at h. + integer :: isd !< The starting i-index of the data domain at h. + integer :: ied !< The ending i-index of the data domain at h. + integer :: jsd !< The starting j-index of the data domain at h. + integer :: jed !< The ending j-index of the data domain at h. + integer :: num_col !< The number of sponge tracer points within the computational domain. + integer :: num_col_u !< The number of sponge u-points within the computational domain. + integer :: num_col_v !< The number of sponge v-points within the computational domain. + integer :: fldno = 0 !< The number of fields which have already been + !! registered by calls to set_up_sponge_field + logical :: sponge_uv !< Control whether u and v are included in sponge + integer, pointer :: col_i(:) => NULL() !< Array of the i-indicies of each tracer columns being damped. + integer, pointer :: col_j(:) => NULL() !< Array of the j-indicies of each tracer columns being damped. + integer, pointer :: col_i_u(:) => NULL() !< Array of the i-indicies of each u-columns being damped. + integer, pointer :: col_j_u(:) => NULL() !< Array of the j-indicies of each u-columns being damped. + integer, pointer :: col_i_v(:) => NULL() !< Array of the i-indicies of each v-columns being damped. + integer, pointer :: col_j_v(:) => NULL() !< Array of the j-indicies of each v-columns being damped. + + real, pointer :: Iresttime_col(:) => NULL() !< The inverse restoring time of each tracer column [s-1]. + real, pointer :: Iresttime_col_u(:) => NULL() !< The inverse restoring time of each u-column [s-1]. + real, pointer :: Iresttime_col_v(:) => NULL() !< The inverse restoring time of each v-column [s-1]. type(p3d) :: var(MAX_FIELDS_) !< Pointers to the fields that are being damped. - type(p2d) :: Ref_val(MAX_FIELDS_) !< The values to which the fields are damped. - type(p2d) :: Ref_val_u !< Same as above for u points. - type(p2d) :: Ref_val_v !< Same as above for v points. - type(p3d) :: var_u !< Pointers to the u vel. that are being damped. - type(p3d) :: var_v !< Pointers to the v vel. that are being damped. + type(p2d) :: Ref_val(MAX_FIELDS_) !< The values to which the fields are damped. + type(p2d) :: Ref_val_u !< The values to which the u-velocities are damped. + type(p2d) :: Ref_val_v !< The values to which the v-velocities are damped. + type(p3d) :: var_u !< Pointer to the u velocities. that are being damped. + type(p3d) :: var_v !< Pointer to the v velocities. that are being damped. type(p2d) :: Ref_h !< Grid on which reference data is provided (older code). - type(p2d) :: Ref_hu !< Same as above for u points. - type(p2d) :: Ref_hv !< Same as above for v points. + type(p2d) :: Ref_hu !< u-point grid on which reference data is provided (older code). + type(p2d) :: Ref_hv !< v-point grid on which reference data is provided (older code). type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the !! timing of diagnostic output. @@ -107,29 +134,30 @@ module MOM_ALE_sponge contains -!> This subroutine determines the number of points which are within -! sponges in this computational domain. Only points that have -! positive values of Iresttime and which mask2dT indicates are ocean -! points are included in the sponges. It also stores the target interface -! heights. +!> This subroutine determines the number of points which are within sponges in this computational +!! domain. Only points that have positive values of Iresttime and which mask2dT indicates are ocean +!! points are included in the sponges. It also stores the target interface heights. subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_data) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure (in). - integer, intent(in) :: nz_data !< The total number of sponge input layers (in). - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Iresttime !< The inverse of the restoring time, in s-1 (in). - type(param_file_type), intent(in) :: param_file !< A structure indicating the open file to parse for model parameter values (in). - type(ALE_sponge_CS), pointer :: CS !< A pointer that is set to point to the control structure for this module (in/out). - real, dimension(SZI_(G),SZJ_(G),nz_data), intent(in) :: data_h !< The thicknesses of the sponge input layers. (in). + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + integer, intent(in) :: nz_data !< The total number of sponge input layers. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Iresttime !< The inverse of the restoring time [s-1]. + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file + !! to parse for model parameter values. + type(ALE_sponge_CS), pointer :: CS !< A pointer that is set to point to the control + !! structure for this module (in/out). + real, dimension(SZI_(G),SZJ_(G),nz_data), intent(in) :: data_h !< The thicknesses of the sponge + !! input layers [H ~> m or kg m-2]. ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "MOM_sponge" ! This module's name. logical :: use_sponge - real, allocatable, dimension(:,:,:) :: data_hu !< thickness at u points - real, allocatable, dimension(:,:,:) :: data_hv !< thickness at v points - real, allocatable, dimension(:,:) :: Iresttime_u !< inverse of the restoring time at u points, s-1 - real, allocatable, dimension(:,:) :: Iresttime_v !< inverse of the restoring time at v points, s-1 + real, allocatable, dimension(:,:,:) :: data_hu !< thickness at u points [H ~> m or kg m-2] + real, allocatable, dimension(:,:,:) :: data_hv !< thickness at v points [H ~> m or kg m-2] + real, allocatable, dimension(:,:) :: Iresttime_u !< inverse of the restoring time at u points [s-1] + real, allocatable, dimension(:,:) :: Iresttime_v !< inverse of the restoring time at v points [s-1] logical :: bndExtrapolation = .true. ! If true, extrapolate boundaries integer :: i, j, k, col, total_sponge_cols, total_sponge_cols_u, total_sponge_cols_v character(len=10) :: remapScheme @@ -166,6 +194,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ "PPM reconstruction will also be used within boundary cells.", & default=.false., do_not_log=.true.) + CS%new_sponges = .false. CS%nz = G%ke CS%isc = G%isc ; CS%iec = G%iec ; CS%jsc = G%jsc ; CS%jec = G%jec CS%isd = G%isd ; CS%ied = G%ied ; CS%jsd = G%jsd ; CS%jed = G%jed @@ -178,13 +207,10 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ CS%num_col = CS%num_col + 1 enddo ; enddo - if (CS%num_col > 0) then - allocate(CS%Iresttime_col(CS%num_col)) ; CS%Iresttime_col = 0.0 allocate(CS%col_i(CS%num_col)) ; CS%col_i = 0 allocate(CS%col_j(CS%num_col)) ; CS%col_j = 0 - ! pass indices, restoring time to the CS structure col = 1 do j=G%jsc,G%jec ; do i=G%isc,G%iec @@ -194,16 +220,12 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ col = col +1 endif enddo ; enddo - ! same for total number of arbritary layers and correspondent data CS%nz_data = nz_data allocate(CS%Ref_h%p(CS%nz_data,CS%num_col)) do col=1,CS%num_col ; do K=1,CS%nz_data CS%Ref_h%p(K,col) = data_h(CS%col_i(col),CS%col_j(col),K) - enddo; enddo - CS%new_sponges = .false. - - + enddo ; enddo endif total_sponge_cols = CS%num_col @@ -217,98 +239,147 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ if (CS%sponge_uv) then - allocate(data_hu(G%isdB:G%iedB,G%jsd:G%jed,nz_data)); data_hu(:,:,:)=0.0 - allocate(data_hv(G%isd:G%ied,G%jsdB:G%jedB,nz_data)); data_hv(:,:,:)=0.0 - allocate(Iresttime_u(G%isdB:G%iedB,G%jsd:G%jed)); Iresttime_u(:,:)=0.0 - allocate(Iresttime_v(G%isd:G%ied,G%jsdB:G%jedB)); Iresttime_v(:,:)=0.0 + allocate(data_hu(G%isdB:G%iedB,G%jsd:G%jed,nz_data)); data_hu(:,:,:)=0.0 + allocate(data_hv(G%isd:G%ied,G%jsdB:G%jedB,nz_data)); data_hv(:,:,:)=0.0 + allocate(Iresttime_u(G%isdB:G%iedB,G%jsd:G%jed)); Iresttime_u(:,:)=0.0 + allocate(Iresttime_v(G%isd:G%ied,G%jsdB:G%jedB)); Iresttime_v(:,:)=0.0 - ! u points - CS%num_col_u = 0 ; !CS%fldno_u = 0 - do j=CS%jsc,CS%jec; do I=CS%iscB,CS%iecB - data_hu(I,j,:) = 0.5 * (data_h(i,j,:) + data_h(i+1,j,:)) - Iresttime_u(I,j) = 0.5 * (Iresttime(i,j) + Iresttime(i+1,j)) - if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>0)) & - CS%num_col_u = CS%num_col_u + 1 - enddo; enddo + ! u points + CS%num_col_u = 0 ; !CS%fldno_u = 0 + do j=CS%jsc,CS%jec; do I=CS%iscB,CS%iecB + data_hu(I,j,:) = 0.5 * (data_h(i,j,:) + data_h(i+1,j,:)) + Iresttime_u(I,j) = 0.5 * (Iresttime(i,j) + Iresttime(i+1,j)) + if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>0)) & + CS%num_col_u = CS%num_col_u + 1 + enddo ; enddo - if (CS%num_col_u > 0) then + if (CS%num_col_u > 0) then - allocate(CS%Iresttime_col_u(CS%num_col_u)) ; CS%Iresttime_col_u = 0.0 - allocate(CS%col_i_u(CS%num_col_u)) ; CS%col_i_u = 0 - allocate(CS%col_j_u(CS%num_col_u)) ; CS%col_j_u = 0 + allocate(CS%Iresttime_col_u(CS%num_col_u)) ; CS%Iresttime_col_u = 0.0 + allocate(CS%col_i_u(CS%num_col_u)) ; CS%col_i_u = 0 + allocate(CS%col_j_u(CS%num_col_u)) ; CS%col_j_u = 0 - ! pass indices, restoring time to the CS structure - col = 1 - do j=CS%jsc,CS%jec ; do I=CS%iscB,CS%iecB - if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>0)) then - CS%col_i_u(col) = i ; CS%col_j_u(col) = j - CS%Iresttime_col_u(col) = Iresttime_u(i,j) - col = col +1 - endif - enddo ; enddo + ! pass indices, restoring time to the CS structure + col = 1 + do j=CS%jsc,CS%jec ; do I=CS%iscB,CS%iecB + if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>0)) then + CS%col_i_u(col) = i ; CS%col_j_u(col) = j + CS%Iresttime_col_u(col) = Iresttime_u(i,j) + col = col +1 + endif + enddo ; enddo - ! same for total number of arbritary layers and correspondent data + ! same for total number of arbritary layers and correspondent data - allocate(CS%Ref_hu%p(CS%nz_data,CS%num_col_u)) - do col=1,CS%num_col_u ; do K=1,CS%nz_data - CS%Ref_hu%p(K,col) = data_hu(CS%col_i_u(col),CS%col_j_u(col),K) - enddo; enddo - endif - total_sponge_cols_u = CS%num_col_u - call sum_across_PEs(total_sponge_cols_u) - call log_param(param_file, mdl, "!Total sponge columns at u points", total_sponge_cols_u, & - "The total number of columns where sponges are applied at u points.") + allocate(CS%Ref_hu%p(CS%nz_data,CS%num_col_u)) + do col=1,CS%num_col_u ; do K=1,CS%nz_data + CS%Ref_hu%p(K,col) = data_hu(CS%col_i_u(col),CS%col_j_u(col),K) + enddo ; enddo + endif + total_sponge_cols_u = CS%num_col_u + call sum_across_PEs(total_sponge_cols_u) + call log_param(param_file, mdl, "!Total sponge columns at u points", total_sponge_cols_u, & + "The total number of columns where sponges are applied at u points.") - ! v points - CS%num_col_v = 0 ; !CS%fldno_v = 0 - do J=CS%jscB,CS%jecB; do i=CS%isc,CS%iec - data_hv(i,J,:) = 0.5 * (data_h(i,j,:) + data_h(i,j+1,:)) - Iresttime_v(i,J) = 0.5 * (Iresttime(i,j) + Iresttime(i,j+1)) - if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>0)) & - CS%num_col_v = CS%num_col_v + 1 - enddo; enddo + ! v points + CS%num_col_v = 0 ; !CS%fldno_v = 0 + do J=CS%jscB,CS%jecB; do i=CS%isc,CS%iec + data_hv(i,J,:) = 0.5 * (data_h(i,j,:) + data_h(i,j+1,:)) + Iresttime_v(i,J) = 0.5 * (Iresttime(i,j) + Iresttime(i,j+1)) + if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>0)) & + CS%num_col_v = CS%num_col_v + 1 + enddo ; enddo - if (CS%num_col_v > 0) then + if (CS%num_col_v > 0) then + + allocate(CS%Iresttime_col_v(CS%num_col_v)) ; CS%Iresttime_col_v = 0.0 + allocate(CS%col_i_v(CS%num_col_v)) ; CS%col_i_v = 0 + allocate(CS%col_j_v(CS%num_col_v)) ; CS%col_j_v = 0 + + ! pass indices, restoring time to the CS structure + col = 1 + do J=CS%jscB,CS%jecB ; do i=CS%isc,CS%iec + if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>0)) then + CS%col_i_v(col) = i ; CS%col_j_v(col) = j + CS%Iresttime_col_v(col) = Iresttime_v(i,j) + col = col +1 + endif + enddo ; enddo + + ! same for total number of arbritary layers and correspondent data + allocate(CS%Ref_hv%p(CS%nz_data,CS%num_col_v)) + do col=1,CS%num_col_v ; do K=1,CS%nz_data + CS%Ref_hv%p(K,col) = data_hv(CS%col_i_v(col),CS%col_j_v(col),K) + enddo ; enddo + endif + total_sponge_cols_v = CS%num_col_v + call sum_across_PEs(total_sponge_cols_v) + call log_param(param_file, mdl, "!Total sponge columns at v points", total_sponge_cols_v, & + "The total number of columns where sponges are applied at v points.") + endif - allocate(CS%Iresttime_col_v(CS%num_col_v)) ; CS%Iresttime_col_v = 0.0 - allocate(CS%col_i_v(CS%num_col_v)) ; CS%col_i_v = 0 - allocate(CS%col_j_v(CS%num_col_v)) ; CS%col_j_v = 0 +end subroutine initialize_ALE_sponge_fixed - ! pass indices, restoring time to the CS structure - col = 1 - do J=CS%jscB,CS%jecB ; do i=CS%isc,CS%iec - if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>0)) then - CS%col_i_v(col) = i ; CS%col_j_v(col) = j - CS%Iresttime_col_v(col) = Iresttime_v(i,j) - col = col +1 - endif - enddo ; enddo +!> Return the number of layers in the data with a fixed ALE sponge, or 0 if there are +!! no sponge columns on this PE. +function get_ALE_sponge_nz_data(CS) + type(ALE_sponge_CS), pointer :: CS !< A pointer that is set to point to the control + !! structure for the ALE_sponge module. + integer :: get_ALE_sponge_nz_data !< The number of layers in the fixed sponge data. - ! same for total number of arbritary layers and correspondent data - allocate(CS%Ref_hv%p(CS%nz_data,CS%num_col_v)) - do col=1,CS%num_col_v ; do K=1,CS%nz_data - CS%Ref_hv%p(K,col) = data_hv(CS%col_i_v(col),CS%col_j_v(col),K) - enddo ; enddo - endif - total_sponge_cols_v = CS%num_col_v - call sum_across_PEs(total_sponge_cols_v) - call log_param(param_file, mdl, "!Total sponge columns at v points", total_sponge_cols_v, & - "The total number of columns where sponges are applied at v points.") + if (associated(CS)) then + get_ALE_sponge_nz_data = CS%nz_data + else + get_ALE_sponge_nz_data = 0 + endif +end function get_ALE_sponge_nz_data + +!> Return the thicknesses used for the data with a fixed ALE sponge +subroutine get_ALE_sponge_thicknesses(G, data_h, sponge_mask, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure (in). + real, allocatable, dimension(:,:,:), & + intent(inout) :: data_h !< The thicknesses of the sponge input layers [H ~> m or kg m-2]. + logical, dimension(SZI_(G),SZJ_(G)), & + intent(out) :: sponge_mask !< A logical mask that is true where + !! sponges are being applied. + type(ALE_sponge_CS), pointer :: CS !< A pointer that is set to point to the control + !! structure for the ALE_sponge module. + integer :: c, i, j, k + + if (allocated(data_h)) call MOM_error(FATAL, & + "get_ALE_sponge_thicknesses called with an allocated data_h.") + + if (.not.associated(CS)) then + ! There are no sponge points on this PE. + allocate(data_h(G%isd:G%ied,G%jsd:G%jed,1)) ; data_h(:,:,:) = -1.0 + sponge_mask(:,:) = .false. + return endif -end subroutine initialize_ALE_sponge_fixed + allocate(data_h(G%isd:G%ied,G%jsd:G%jed,CS%nz_data)) ; data_h(:,:,:) = -1.0 + sponge_mask(:,:) = .false. -!> This subroutine determines the number of points which are within -! sponges in this computational domain. Only points that have -! positive values of Iresttime and which mask2dT indicates are ocean -! points are included in the sponges. It also stores the target interface -! heights. + do c=1,CS%num_col + i = CS%col_i(c) ; j = CS%col_j(c) + sponge_mask(i,j) = .true. + do k=1,CS%nz_data + data_h(i,j,k) = CS%Ref_h%p(k,c) + enddo + enddo + +end subroutine get_ALE_sponge_thicknesses + +!> This subroutine determines the number of points which are within sponges in this computational +!! domain. Only points that have positive values of Iresttime and which mask2dT indicates are ocean +!! points are included in the sponges. subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure (in). - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Iresttime !< The inverse of the restoring time, in s-1 (in). - type(param_file_type), intent(in) :: param_file !< A structure indicating the open file to parse for model parameter values (in). - type(ALE_sponge_CS), pointer :: CS !< A pointer that is set to point to the control structure for this module (in/out). + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Iresttime !< The inverse of the restoring time [s-1]. + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file to parse + !! for model parameter values. + type(ALE_sponge_CS), pointer :: CS !< A pointer that is set to point to the control + !! structure for this module (in/out). @@ -316,8 +387,8 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) #include "version_variable.h" character(len=40) :: mdl = "MOM_sponge" ! This module's name. logical :: use_sponge - real, allocatable, dimension(:,:) :: Iresttime_u !< inverse of the restoring time at u points, s-1 - real, allocatable, dimension(:,:) :: Iresttime_v !< inverse of the restoring time at v points, s-1 + real, allocatable, dimension(:,:) :: Iresttime_u !< inverse of the restoring time at u points [s-1] + real, allocatable, dimension(:,:) :: Iresttime_v !< inverse of the restoring time at v points [s-1] logical :: bndExtrapolation = .true. ! If true, extrapolate boundaries integer :: i, j, k, col, total_sponge_cols, total_sponge_cols_u, total_sponge_cols_v character(len=10) :: remapScheme @@ -354,6 +425,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) "PPM reconstruction will also be used within boundary cells.", & default=.false., do_not_log=.true.) + CS%new_sponges = .true. CS%nz = G%ke CS%isc = G%isc ; CS%iec = G%iec ; CS%jsc = G%jsc ; CS%jec = G%jec CS%isd = G%isd ; CS%ied = G%ied ; CS%jsd = G%jsd ; CS%jed = G%jed @@ -368,11 +440,9 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) if (CS%num_col > 0) then - allocate(CS%Iresttime_col(CS%num_col)) ; CS%Iresttime_col = 0.0 allocate(CS%col_i(CS%num_col)) ; CS%col_i = 0 allocate(CS%col_j(CS%num_col)) ; CS%col_j = 0 - ! pass indices, restoring time to the CS structure col = 1 do j=G%jsc,G%jec ; do i=G%isc,G%iec @@ -382,9 +452,6 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) col = col +1 endif enddo ; enddo - - CS%new_sponges = .true. - endif total_sponge_cols = CS%num_col @@ -407,7 +474,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) Iresttime_u(I,j) = 0.5 * (Iresttime(i,j) + Iresttime(i+1,j)) if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>0)) & CS%num_col_u = CS%num_col_u + 1 - enddo; enddo + enddo ; enddo if (CS%num_col_u > 0) then @@ -439,7 +506,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) Iresttime_v(i,J) = 0.5 * (Iresttime(i,j) + Iresttime(i,j+1)) if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>0)) & CS%num_col_v = CS%num_col_v + 1 - enddo; enddo + enddo ; enddo if (CS%num_col_v > 0) then @@ -469,10 +536,11 @@ end subroutine initialize_ALE_sponge_varying !> Initialize diagnostics for the ALE_sponge module. ! GMM: this routine is not being used for now. subroutine init_ALE_sponge_diags(Time, G, diag, CS) - type(time_type), target, intent(in) :: Time - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(diag_ctrl), target, intent(inout) :: diag - type(ALE_sponge_CS), pointer :: CS + type(time_type), target, intent(in) :: Time !< The current model time + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to regulate diagnostic + !! output. + type(ALE_sponge_CS), pointer :: CS !< ALE sponge control structure if (.not.associated(CS)) return @@ -481,12 +549,14 @@ subroutine init_ALE_sponge_diags(Time, G, diag, CS) end subroutine init_ALE_sponge_diags !> This subroutine stores the reference profile at h points for the variable -! whose address is given by f_ptr. +!! whose address is given by f_ptr. subroutine set_up_ALE_sponge_field_fixed(sp_val, G, f_ptr, CS) - type(ocean_grid_type), intent(in) :: G !< Grid structure (in). - type(ALE_sponge_CS), pointer :: CS !< Sponge structure (in/out). - real, dimension(SZI_(G),SZJ_(G),CS%nz_data), intent(in) :: sp_val !< Field to be used in the sponge, it has arbritary number of layers (in). - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), target, intent(in) :: f_ptr !< Pointer to the field to be damped (in). + type(ocean_grid_type), intent(in) :: G !< Grid structure + type(ALE_sponge_CS), pointer :: CS !< ALE sponge control structure (in/out). + real, dimension(SZI_(G),SZJ_(G),CS%nz_data), & + intent(in) :: sp_val !< Field to be used in the sponge, it has arbritary number of layers. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + target, intent(in) :: f_ptr !< Pointer to the field to be damped integer :: j, k, col character(len=256) :: mesg ! String for error messages @@ -516,18 +586,23 @@ subroutine set_up_ALE_sponge_field_fixed(sp_val, G, f_ptr, CS) end subroutine set_up_ALE_sponge_field_fixed !> This subroutine stores the reference profile at h points for the variable -! whose address is given by filename and fieldname. -subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, f_ptr, CS) - character(len=*), intent(in) :: filename - character(len=*), intent(in) :: fieldname - type(time_type), intent(in) :: Time - type(ocean_grid_type), intent(in) :: G !< Grid structure (in). - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), target, intent(in) :: f_ptr !< Pointer to the field to be damped (in). - type(ALE_sponge_CS), pointer :: CS !< Sponge structure (in/out). +!! whose address is given by filename and fieldname. +subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, GV, f_ptr, CS) + character(len=*), intent(in) :: filename !< The name of the file with the + !! time varying field data + character(len=*), intent(in) :: fieldname !< The name of the field in the file + !! with the time varying field data + type(time_type), intent(in) :: Time !< The current model time + type(ocean_grid_type), intent(in) :: G !< Grid structure (in). + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + target, intent(in) :: f_ptr !< Pointer to the field to be damped (in). + type(ALE_sponge_CS), pointer :: CS !< Sponge control structure (in/out). + ! Local variables real, allocatable, dimension(:,:,:) :: sp_val !< Field to be used in the sponge real, allocatable, dimension(:,:,:) :: mask_z !< Field mask for the sponge data - real, allocatable, dimension(:), target :: z_in, z_edges_in + real, allocatable, dimension(:), target :: z_in, z_edges_in ! Heights [Z ~> m]. real :: missing_value integer :: j, k, col integer :: isd,ied,jsd,jed @@ -537,9 +612,9 @@ subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, f_ptr, character(len=256) :: mesg ! String for error messages ! Local variables for ALE remapping - real, dimension(:), allocatable :: hsrc + real, dimension(:), allocatable :: hsrc ! Source thicknesses [Z ~> m]. real, dimension(:), allocatable :: tmpT1d - real :: zTopOfCell, zBottomOfCell + real :: zTopOfCell, zBottomOfCell ! Heights [Z ~> m]. type(remapping_CS) :: remapCS ! Remapping parameters and work arrays if (.not.associated(CS)) return @@ -582,9 +657,8 @@ subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, f_ptr, ! In the future, this should be generalized using an interface to return the ! modulo attribute of the zonal axis (mjh). - ! call horiz_interp_and_extrap_tracer(CS%Ref_val(CS%fldno)%id,Time, 1.0,G,sp_val,mask_z,z_in,z_edges_in,& - ! missing_value,.true.,& - ! .false.,.false.) + ! call horiz_interp_and_extrap_tracer(CS%Ref_val(CS%fldno)%id,Time, 1.0,G,sp_val,mask_z,z_in,z_edges_in, & + ! missing_value, .true., .false., .false., m_to_Z=US%m_to_Z) ! Do not think halo updates are needed (mjh) ! call pass_var(sp_val,G%Domain) @@ -613,10 +687,11 @@ subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, f_ptr, if (hsrc(k)>0.) nPoints = nPoints + 1 zTopOfCell = zBottomOfCell ! Bottom becomes top for next value of k enddo - hsrc(nz_data) = hsrc(nz_data) + ( zTopOfCell + G%bathyT(CS%col_i(col),CS%col_j(col)) ) ! In case data is deeper than model + ! In case data is deeper than model + hsrc(nz_data) = hsrc(nz_data) + ( zTopOfCell + G%bathyT(CS%col_i(col),CS%col_j(col)) ) CS%Ref_val(CS%fldno)%h(1:nz_data,col) = 0. CS%Ref_val(CS%fldno)%p(1:nz_data,col) = -1.e24 - CS%Ref_val(CS%fldno)%h(1:nz_data,col) = hsrc(1:nz_data) + CS%Ref_val(CS%fldno)%h(1:nz_data,col) = GV%Z_to_H*hsrc(1:nz_data) ! CS%Ref_val(CS%fldno)%p(1:nz_data,col) = tmpT1d(1:nz_data) enddo @@ -628,15 +703,17 @@ subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, f_ptr, end subroutine set_up_ALE_sponge_field_varying -!> This subroutine stores the reference profile at uand v points for the variable -! whose address is given by u_ptr and v_ptr. +!> This subroutine stores the reference profile at u and v points for the variable +!! whose address is given by u_ptr and v_ptr. subroutine set_up_ALE_sponge_vel_field_fixed(u_val, v_val, G, u_ptr, v_ptr, CS) - type(ocean_grid_type), intent(in) :: G !< Grid structure (in). - type(ALE_sponge_CS), pointer :: CS !< Sponge structure (in/out). - real, dimension(SZIB_(G),SZJ_(G),CS%nz_data), intent(in) :: u_val !< u field to be used in the sponge, it has arbritary number of layers (in). - real, dimension(SZI_(G),SZJB_(G),CS%nz_data), intent(in) :: v_val !< u field to be used in the sponge, it has arbritary number of layers (in). - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), target, intent(in) :: u_ptr !< u pointer to the field to be damped (in). - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), target, intent(in) :: v_ptr !< v pointer to the field to be damped (in). + type(ocean_grid_type), intent(in) :: G !< Grid structure (in). + type(ALE_sponge_CS), pointer :: CS !< Sponge structure (in/out). + real, dimension(SZIB_(G),SZJ_(G),CS%nz_data), & + intent(in) :: u_val !< u field to be used in the sponge, it has arbritary number of layers. + real, dimension(SZI_(G),SZJB_(G),CS%nz_data), & + intent(in) :: v_val !< v field to be used in the sponge, it has arbritary number of layers. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), target, intent(in) :: u_ptr !< u pointer to the field to be damped + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), target, intent(in) :: v_ptr !< v pointer to the field to be damped integer :: j, k, col character(len=256) :: mesg ! String for error messages @@ -667,14 +744,16 @@ subroutine set_up_ALE_sponge_vel_field_fixed(u_val, v_val, G, u_ptr, v_ptr, CS) end subroutine set_up_ALE_sponge_vel_field_fixed !> This subroutine stores the reference profile at uand v points for the variable -! whose address is given by u_ptr and v_ptr. -subroutine set_up_ALE_sponge_vel_field_varying(filename_u,fieldname_u,filename_v,fieldname_v, Time, G, CS, u_ptr, v_ptr) +!! whose address is given by u_ptr and v_ptr. +subroutine set_up_ALE_sponge_vel_field_varying(filename_u, fieldname_u, filename_v, fieldname_v, & + Time, G, US, CS, u_ptr, v_ptr) character(len=*), intent(in) :: filename_u !< File name for u field character(len=*), intent(in) :: fieldname_u !< Name of u variable in file character(len=*), intent(in) :: filename_v !< File name for v field character(len=*), intent(in) :: fieldname_v !< Name of v variable in file type(time_type), intent(in) :: Time !< Model time type(ocean_grid_type), intent(inout) :: G !< Ocean grid (in) + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(ALE_sponge_CS), pointer :: CS !< Sponge structure (in/out). real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), target, intent(in) :: u_ptr !< u pointer to the field to be damped (in). real, dimension(SZI_(G),SZJB_(G),SZK_(G)), target, intent(in) :: v_ptr !< v pointer to the field to be damped (in). @@ -725,8 +804,7 @@ subroutine set_up_ALE_sponge_vel_field_varying(filename_u,fieldname_u,filename_v ! modulo attribute of the zonal axis (mjh). call horiz_interp_and_extrap_tracer(CS%Ref_val_u%id,Time, 1.0,G,u_val,mask_u,z_in,z_edges_in,& - missing_value,.true.,& - .false.,.false.) + missing_value,.true.,.false.,.false., m_to_Z=US%m_to_Z) !!! TODO: add a velocity interface! (mjh) @@ -735,9 +813,8 @@ subroutine set_up_ALE_sponge_vel_field_varying(filename_u,fieldname_u,filename_v ! In the future, this should be generalized using an interface to return the ! modulo attribute of the zonal axis (mjh). - call horiz_interp_and_extrap_tracer(CS%Ref_val_v%id,Time, 1.0,G,v_val,mask_v,z_in,z_edges_in,& - missing_value,.true.,& - .false.,.false.) + call horiz_interp_and_extrap_tracer(CS%Ref_val_v%id,Time, 1.0,G,v_val,mask_v,z_in,z_edges_in, & + missing_value,.true.,.false.,.false., m_to_Z=US%m_to_Z) ! stores the reference profile allocate(CS%Ref_val_u%p(fld_sz(3),CS%num_col_u)) @@ -762,18 +839,23 @@ subroutine set_up_ALE_sponge_vel_field_varying(filename_u,fieldname_u,filename_v end subroutine set_up_ALE_sponge_vel_field_varying -!> This subroutine applies damping to the layers thicknesses, temp, salt and a variety of tracers for every column where there is damping. -subroutine apply_ALE_sponge(h, dt, G, CS, Time) +!> This subroutine applies damping to the layers thicknesses, temp, salt and a variety of tracers +!! for every column where there is damping. +subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure (in). + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(inout) :: h !< Layer thickness, in m (in) - real, intent(in) :: dt !< The amount of time covered by this call, in s (in). - type(ALE_sponge_CS), pointer :: CS ! m or kg m-2] (in) + real, intent(in) :: dt !< The amount of time covered by this call [s]. + type(ALE_sponge_CS), pointer :: CS !< A pointer to the control structure for this module + !! that is set by a previous call to initialize_sponge (in). type(time_type), optional, intent(in) :: Time !< The current model date - real :: damp ! The timestep times the local damping coefficient. ND. - real :: I1pdamp ! I1pdamp is 1/(1 + damp). Nondimensional. - real :: Idt ! 1.0/dt, in s-1. + real :: damp ! The timestep times the local damping coefficient [nondim]. + real :: I1pdamp ! I1pdamp is 1/(1 + damp). [nondim]. + real :: Idt ! 1.0/dt [s-1]. + real :: m_to_Z ! A unit conversion factor from m to Z. real, allocatable, dimension(:) :: tmp_val2 ! data values on the original grid real, dimension(SZK_(G)) :: tmp_val1 ! data values remapped to model grid real :: hu(SZIB_(G), SZJ_(G), SZK_(G)) ! A temporary array for h at u pts @@ -783,11 +865,18 @@ subroutine apply_ALE_sponge(h, dt, G, CS, Time) integer :: c, m, nkmb, i, j, k, is, ie, js, je, nz, nz_data real, allocatable, dimension(:), target :: z_in, z_edges_in real :: missing_value + real :: h_neglect, h_neglect_edge is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke if (.not.associated(CS)) return + if (GV%Boussinesq) then + h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 + else + h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 + endif + if (CS%new_sponges) then if (.not. present(Time)) & call MOM_error(FATAL,"apply_ALE_sponge: No time information provided") @@ -801,9 +890,8 @@ subroutine apply_ALE_sponge(h, dt, G, CS, Time) sp_val(:,:,:)=0.0 mask_z(:,:,:)=0.0 - call horiz_interp_and_extrap_tracer(CS%Ref_val(CS%fldno)%id,Time, 1.0,G,sp_val,mask_z,z_in,z_edges_in,& - missing_value,.true.,& - .false.,.false.) + call horiz_interp_and_extrap_tracer(CS%Ref_val(CS%fldno)%id,Time, 1.0,G,sp_val,mask_z,z_in,z_edges_in, & + missing_value,.true., .false.,.false., m_to_Z=US%m_to_Z) ! call pass_var(sp_val,G%Domain) ! call pass_var(mask_z,G%Domain) @@ -814,9 +902,10 @@ subroutine apply_ALE_sponge(h, dt, G, CS, Time) CS%Ref_val(m)%p(1:nz_data,c) = sp_val(i,j,1:nz_data) do k=2,nz_data ! if (mask_z(i,j,k)==0.) & - if (CS%Ref_val(m)%h(k,c) <= 0.001) & ! some confusion here about why the masks are not correct returning from horiz_interp - ! reverting to using a minimum thickness criteria - CS%Ref_val(m)%p(k,c)=CS%Ref_val(m)%p(k-1,c) + if (CS%Ref_val(m)%h(k,c) <= 0.001*GV%m_to_H) & + ! some confusion here about why the masks are not correct returning from horiz_interp + ! reverting to using a minimum thickness criteria + CS%Ref_val(m)%p(k,c) = CS%Ref_val(m)%p(k-1,c) enddo enddo @@ -837,13 +926,11 @@ subroutine apply_ALE_sponge(h, dt, G, CS, Time) I1pdamp = 1.0 / (1.0 + damp) tmp_val2(1:nz_data) = CS%Ref_val(m)%p(1:nz_data,c) if (CS%new_sponges) then - call remapping_core_h(CS%remap_cs, & - nz_data, CS%Ref_val(m)%h(1:nz_data,c), tmp_val2, & - CS%nz, h(i,j,:), tmp_val1) + call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_val(m)%h(1:nz_data,c), tmp_val2, & + CS%nz, h(i,j,:), tmp_val1, h_neglect, h_neglect_edge) else - call remapping_core_h(CS%remap_cs, & - nz_data, CS%Ref_h%p(1:nz_data,c), tmp_val2, & - CS%nz, h(i,j,:), tmp_val1) + call remapping_core_h(CS%remap_cs,nz_data, CS%Ref_h%p(1:nz_data,c), tmp_val2, & + CS%nz, h(i,j,:), tmp_val1, h_neglect, h_neglect_edge) endif !Backward Euler method CS%var(m)%p(i,j,1:CS%nz) = I1pdamp * (CS%var(m)%p(i,j,1:CS%nz) + tmp_val1 * damp) @@ -854,7 +941,8 @@ subroutine apply_ALE_sponge(h, dt, G, CS, Time) ! for debugging !c=CS%num_col !do m=1,CS%fldno - ! write(*,*)'APPLY SPONGE,m,CS%Ref_h(:,c),h(i,j,:),tmp_val2,tmp_val1',m,CS%Ref_h(:,c),h(i,j,:),tmp_val2,tmp_val1 + ! write(*,*) 'APPLY SPONGE,m,CS%Ref_h(:,c),h(i,j,:),tmp_val2,tmp_val1',& + ! m,CS%Ref_h(:,c),h(i,j,:),tmp_val2,tmp_val1 !enddo if (CS%sponge_uv) then @@ -862,7 +950,7 @@ subroutine apply_ALE_sponge(h, dt, G, CS, Time) ! u points do j=CS%jsc,CS%jec; do I=CS%iscB,CS%iecB; do k=1,nz hu(I,j,k) = 0.5 * (h(i,j,k) + h(i+1,j,k)) - enddo; enddo; enddo + enddo ; enddo ; enddo if (CS%new_sponges) then if (.not. present(Time)) & @@ -872,9 +960,8 @@ subroutine apply_ALE_sponge(h, dt, G, CS, Time) allocate(sp_val(G%isdB:G%iedB,G%jsd:G%jed,1:nz_data)) allocate(mask_z(G%isdB:G%iedB,G%jsd:G%jed,1:nz_data)) ! Interpolate from the external horizontal grid and in time - call horiz_interp_and_extrap_tracer(CS%Ref_val_u%id,Time, 1.0,G,sp_val,mask_z,z_in,z_edges_in,& - missing_value,.true.,& - .false.,.false.) + call horiz_interp_and_extrap_tracer(CS%Ref_val_u%id,Time, 1.0,G,sp_val,mask_z,z_in,z_edges_in, & + missing_value, .true., .false., .false., m_to_Z=US%m_to_Z) ! call pass_var(sp_val,G%Domain) ! call pass_var(mask_z,G%Domain) @@ -892,9 +979,8 @@ subroutine apply_ALE_sponge(h, dt, G, CS, Time) allocate(sp_val(G%isd:G%ied,G%jsdB:G%jedB,1:nz_data)) allocate(mask_z(G%isd:G%ied,G%jsdB:G%jedB,1:nz_data)) ! Interpolate from the external horizontal grid and in time - call horiz_interp_and_extrap_tracer(CS%Ref_val_v%id,Time, 1.0,G,sp_val,mask_z,z_in,z_edges_in,& - missing_value,.true.,& - .false.,.false.) + call horiz_interp_and_extrap_tracer(CS%Ref_val_v%id,Time, 1.0,G,sp_val,mask_z,z_in,z_edges_in, & + missing_value, .true., .false., .false., m_to_Z=US%m_to_Z) ! call pass_var(sp_val,G%Domain) ! call pass_var(mask_z,G%Domain) @@ -919,13 +1005,11 @@ subroutine apply_ALE_sponge(h, dt, G, CS, Time) if (CS%new_sponges) nz_data = CS%Ref_val(m)%nz_data tmp_val2(1:nz_data) = CS%Ref_val_u%p(1:nz_data,c) if (CS%new_sponges) then - call remapping_core_h(CS%remap_cs, & - nz_data, CS%Ref_val_u%h(:,c), tmp_val2, & - CS%nz, hu(i,j,:), tmp_val1) + call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_val_u%h(:,c), tmp_val2, & + CS%nz, hu(i,j,:), tmp_val1, h_neglect, h_neglect_edge) else - call remapping_core_h(CS%remap_cs, & - nz_data, CS%Ref_hu%p(:,c), tmp_val2, & - CS%nz, hu(i,j,:), tmp_val1) + call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_hu%p(:,c), tmp_val2, & + CS%nz, hu(i,j,:), tmp_val1, h_neglect, h_neglect_edge) endif !Backward Euler method CS%var_u%p(i,j,:) = I1pdamp * (CS%var_u%p(i,j,:) + tmp_val1 * damp) @@ -934,7 +1018,7 @@ subroutine apply_ALE_sponge(h, dt, G, CS, Time) ! v points do J=CS%jscB,CS%jecB; do i=CS%isc,CS%iec; do k=1,nz hv(i,J,k) = 0.5 * (h(i,j,k) + h(i,j+1,k)) - enddo; enddo; enddo + enddo ; enddo ; enddo do c=1,CS%num_col_v i = CS%col_i_v(c) ; j = CS%col_j_v(c) @@ -942,13 +1026,11 @@ subroutine apply_ALE_sponge(h, dt, G, CS, Time) I1pdamp = 1.0 / (1.0 + damp) tmp_val2(1:nz_data) = CS%Ref_val_v%p(1:nz_data,c) if (CS%new_sponges) then - call remapping_core_h(CS%remap_cs, & - CS%nz_data, CS%Ref_val_v%h(:,c), tmp_val2, & - CS%nz, hv(i,j,:), tmp_val1) + call remapping_core_h(CS%remap_cs, CS%nz_data, CS%Ref_val_v%h(:,c), tmp_val2, & + CS%nz, hv(i,j,:), tmp_val1, h_neglect, h_neglect_edge) else - call remapping_core_h(CS%remap_cs, & - CS%nz_data, CS%Ref_hv%p(:,c), tmp_val2, & - CS%nz, hv(i,j,:), tmp_val1) + call remapping_core_h(CS%remap_cs, CS%nz_data, CS%Ref_hv%p(:,c), tmp_val2, & + CS%nz, hv(i,j,:), tmp_val1, h_neglect, h_neglect_edge) endif !Backward Euler method CS%var_v%p(i,j,:) = I1pdamp * (CS%var_v%p(i,j,:) + tmp_val1 * damp) @@ -960,12 +1042,13 @@ subroutine apply_ALE_sponge(h, dt, G, CS, Time) end subroutine apply_ALE_sponge -!> GMM: I could not find where sponge_end is being called, but I am keeping +! GMM: I could not find where sponge_end is being called, but I am keeping ! ALE_sponge_end here so we can add that if needed. +!> This subroutine deallocates any memory associated with the ALE_sponge module. subroutine ALE_sponge_end(CS) - type(ALE_sponge_CS), pointer :: CS -! (in) CS - A pointer to the control structure for this module that is -! set by a previous call to initialize_sponge. + type(ALE_sponge_CS), pointer :: CS !< A pointer to the control structure that is + !! set by a previous call to initialize_sponge. + integer :: m if (.not.associated(CS)) return diff --git a/src/parameterizations/vertical/MOM_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 similarity index 71% rename from src/parameterizations/vertical/MOM_KPP.F90 rename to src/parameterizations/vertical/MOM_CVMix_KPP.F90 index 7da817c906..ef0e9504ac 100644 --- a/src/parameterizations/vertical/MOM_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -1,5 +1,5 @@ !> Provides the K-Profile Parameterization (KPP) of Large et al., 1994, via CVMix. -module MOM_KPP +module MOM_CVMix_KPP ! This file is part of MOM6. See LICENSE.md for the license. @@ -12,8 +12,10 @@ module MOM_KPP use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_file_parser, only : openParameterBlock, closeParameterBlock use MOM_grid, only : ocean_grid_type, isPointInCell +use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type use MOM_wave_interface, only : wave_parameters_CS, Get_Langmuir_Number +use MOM_domains, only : pass_var use CVMix_kpp, only : CVMix_init_kpp, CVMix_put_kpp, CVMix_get_kpp_real use CVMix_kpp, only : CVMix_coeffs_kpp @@ -29,6 +31,7 @@ module MOM_KPP #include "MOM_memory.h" public :: KPP_init +public :: KPP_compute_BLD public :: KPP_calculate public :: KPP_end public :: KPP_NonLocalTransport_temp @@ -40,7 +43,8 @@ module MOM_KPP integer, private, parameter :: NLT_SHAPE_LINEAR = 1 !< Linear, \f$ G(\sigma) = 1-\sigma \f$ integer, private, parameter :: NLT_SHAPE_PARABOLIC = 2 !< Parabolic, \f$ G(\sigma) = (1-\sigma)^2 \f$ integer, private, parameter :: NLT_SHAPE_CUBIC = 3 !< Cubic, \f$ G(\sigma) = 1 + (2\sigma-3) \sigma^2\f$ -integer, private, parameter :: NLT_SHAPE_CUBIC_LMD = 4 !< Original shape, \f$ G(\sigma) = \frac{27}{4} \sigma (1-\sigma)^2 \f$ +integer, private, parameter :: NLT_SHAPE_CUBIC_LMD = 4 !< Original shape, + !! \f$ G(\sigma) = \frac{27}{4} \sigma (1-\sigma)^2 \f$ integer, private, parameter :: SW_METHOD_ALL_SW = 0 !< Use all shortwave radiation integer, private, parameter :: SW_METHOD_MXL_SW = 1 !< Use shortwave radiation absorbed in mixing layer @@ -70,27 +74,34 @@ module MOM_KPP real :: cs2 !< Parameter for multiplying by non-local term ! This is active for NLT_SHAPE_CUBIC_LMD only logical :: enhance_diffusion !< If True, add enhanced diffusivity at base of boundary layer. - character(len=10) :: interpType !< Type of interpolation in determining OBL depth + character(len=10) :: interpType !< Type of interpolation to compute bulk Richardson number + character(len=10) :: interpType2 !< Type of interpolation to compute diff and visc at OBL_depth logical :: computeEkman !< If True, compute Ekman depth limit for OBLdepth logical :: computeMoninObukhov !< If True, compute Monin-Obukhov limit for OBLdepth logical :: passiveMode !< If True, makes KPP passive meaning it does NOT alter the diffusivity - real :: deepOBLoffset !< If non-zero, is a distance from the bottom that the OBL can not penetrate through (m) - real :: minOBLdepth !< If non-zero, is a minimum depth for the OBL (m) - real :: surf_layer_ext !< Fraction of OBL depth considered in the surface layer (nondim) - real :: minVtsqr !< Min for the squared unresolved velocity used in Rib CVMix calculation (m2/s2) + real :: deepOBLoffset !< If non-zero, is a distance from the bottom that the OBL can not + !! penetrate through [m] + real :: minOBLdepth !< If non-zero, is a minimum depth for the OBL [m] + real :: surf_layer_ext !< Fraction of OBL depth considered in the surface layer [nondim] + real :: minVtsqr !< Min for the squared unresolved velocity used in Rib CVMix calculation [m2 s-2] logical :: fixedOBLdepth !< If True, will fix the OBL depth at fixedOBLdepth_value real :: fixedOBLdepth_value !< value for the fixed OBL depth when fixedOBLdepth==True. logical :: debug !< If True, calculate checksums and write debugging information character(len=30) :: MatchTechnique !< Method used in CVMix for setting diffusivity and NLT profile functions integer :: NLT_shape !< MOM6 over-ride of CVMix NLT shape function logical :: applyNonLocalTrans !< If True, apply non-local transport to heat and scalars - logical :: KPPzeroDiffusivity !< If True, will set diffusivity and viscosity from KPP to zero; for testing purposes. + integer :: n_smooth !< Number of times smoothing operator is applied on OBLdepth. + logical :: deepen_only !< If true, apply OBLdepth smoothing at a cell only if the OBLdepth gets deeper. + logical :: KPPzeroDiffusivity !< If True, will set diffusivity and viscosity from KPP to zero + !! for testing purposes. logical :: KPPisAdditive !< If True, will add KPP diffusivity to initial diffusivity. - !! If False, will replace initial diffusivity wherever KPP diffusivity is non-zero. - real :: min_thickness !< A minimum thickness used to avoid division by small numbers in the vicinity of vanished layers. + !! If False, will replace initial diffusivity wherever KPP diffusivity + !! is non-zero. + real :: min_thickness !< A minimum thickness used to avoid division by small numbers + !! in the vicinity of vanished layers. ! smg: obsolete below logical :: correctSurfLayerAvg !< If true, applies a correction to the averaging of surface layer properties - real :: surfLayerDepth !< A guess at the depth of the surface layer (which should 0.1 of OBLdepth) (m) + real :: surfLayerDepth !< A guess at the depth of the surface layer (which should 0.1 of OBLdepth) [m] ! smg: obsolete above integer :: SW_METHOD !< Sets method for using shortwave radiation in surface buoyancy flux logical :: LT_K_Enhancement !< Flags if enhancing mixing coefficients due to LT @@ -106,8 +117,8 @@ module MOM_KPP !> CVMix parameters type(CVMix_kpp_params_type), pointer :: KPP_params => NULL() - ! Diagnostic handles and pointers - type(diag_ctrl), pointer :: diag => NULL() + type(diag_ctrl), pointer :: diag => NULL() !< Pointer to diagnostics control structure + !>@{ Diagnostic handles integer :: id_OBLdepth = -1, id_BulkRi = -1 integer :: id_N = -1, id_N2 = -1 integer :: id_Ws = -1, id_Vt2 = -1 @@ -125,60 +136,64 @@ module MOM_KPP integer :: id_NLT_dTdt = -1 integer :: id_NLT_temp_budget = -1 integer :: id_NLT_saln_budget = -1 - integer :: id_EnhK = -1, id_EnhW = -1, id_EnhVt2 = -1 - + integer :: id_EnhK = -1, id_EnhVt2 = -1 + integer :: id_EnhW = -1 + integer :: id_La_SL = -1 + integer :: id_OBLdepth_original = -1 + !!@} ! Diagnostics arrays - real, allocatable, dimension(:,:) :: OBLdepth !< Depth (positive) of OBL (m) - real, allocatable, dimension(:,:) :: OBLdepthprev !< previous Depth (positive) of OBL (m) - real, allocatable, dimension(:,:,:) :: dRho !< Bulk difference in density (kg/m3) - real, allocatable, dimension(:,:,:) :: Uz2 !< Square of bulk difference in resolved velocity (m2/s2) + real, allocatable, dimension(:,:) :: OBLdepth !< Depth (positive) of OBL [m] + 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(:,:,:) :: 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) real, allocatable, dimension(:,:,:) :: sigma !< Sigma coordinate (dimensionless) - real, allocatable, dimension(:,:,:) :: Ws !< Turbulent velocity scale for scalars (m/s) - real, allocatable, dimension(:,:,:) :: N !< Brunt-Vaisala frequency (1/s) - real, allocatable, dimension(:,:,:) :: N2 !< Squared Brunt-Vaisala frequency (1/s2) - real, allocatable, dimension(:,:,:) :: Vt2 !< Unresolved squared turbulence velocity for bulk Ri (m2/s2) - real, allocatable, dimension(:,:,:) :: Kt_KPP !< Temp diffusivity from KPP (m2/s) - real, allocatable, dimension(:,:,:) :: Ks_KPP !< Scalar diffusivity from KPP (m2/s) - real, allocatable, dimension(:,:,:) :: Kv_KPP !< Viscosity due to KPP (m2/s) - real, allocatable, dimension(:,:) :: Tsurf !< Temperature of surface layer (C) - real, allocatable, dimension(:,:) :: Ssurf !< Salinity of surface layer (ppt) - real, allocatable, dimension(:,:) :: Usurf !< i-velocity of surface layer (m/s) - real, allocatable, dimension(:,:) :: Vsurf !< j-velocity of surface layer (m/s) - real, allocatable, dimension(:,:,:) :: EnhK !< Enhancement for mixing coefficient - real, allocatable, dimension(:,:,:) :: EnhVt2 !< Enhancement for Vt2 - - + real, allocatable, dimension(:,:,:) :: Ws !< Turbulent velocity scale for scalars [m s-1] + real, allocatable, dimension(:,:,:) :: N !< Brunt-Vaisala frequency [s-1] + real, allocatable, dimension(:,:,:) :: N2 !< Squared Brunt-Vaisala frequency [s-2] + real, allocatable, dimension(:,:,:) :: Vt2 !< Unresolved squared turbulence velocity for bulk Ri [m2 s-2] + real, allocatable, dimension(:,:,:) :: Kt_KPP !< Temp diffusivity from KPP [m2 s-1] + real, allocatable, dimension(:,:,:) :: Ks_KPP !< Scalar diffusivity from KPP [m2 s-1] + real, allocatable, dimension(:,:,:) :: Kv_KPP !< Viscosity due to KPP [m2 s-1] + real, allocatable, dimension(:,:) :: Tsurf !< Temperature of surface layer [degC] + real, allocatable, dimension(:,:) :: Ssurf !< Salinity of surface layer [ppt] + real, allocatable, dimension(:,:) :: Usurf !< i-velocity of surface layer [m s-1] + real, allocatable, dimension(:,:) :: Vsurf !< j-velocity of surface layer [m s-1] + real, allocatable, dimension(:,:,:) :: EnhK !< Enhancement for mixing coefficient + real, allocatable, dimension(:,:,:) :: EnhVt2 !< Enhancement for Vt2 end type KPP_CS -! Module data used for debugging only -logical, parameter :: verbose = .False. #define __DO_SAFETY_CHECKS__ contains !> Initialize the CVMix KPP module and set up diagnostics !! Returns True if KPP is to be used, False otherwise. -logical function KPP_init(paramFile, G, diag, Time, CS, passive, Waves) +logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive, Waves) ! Arguments type(param_file_type), intent(in) :: paramFile !< File parser type(ocean_grid_type), intent(in) :: G !< Ocean grid + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(diag_ctrl), target, intent(in) :: diag !< Diagnostics - type(time_type), intent(in) :: Time !< Time + type(time_type), intent(in) :: Time !< Model time type(KPP_CS), pointer :: CS !< Control structure - logical, optional, intent(out) :: passive !< Copy of %passiveMode - type(wave_parameters_CS), pointer, optional :: Waves ! G'(1) = 0 (shape function) + !! False => compute G'(1) as in LMD94 + if (associated(CS)) call MOM_error(FATAL, 'MOM_CVMix_KPP, KPP_init: '// & 'Control structure has already been initialized') allocate(CS) @@ -205,6 +220,16 @@ logical function KPP_init(paramFile, G, diag, Time, CS, passive, Waves) 'If False, calculates the non-local transport and tendencies but\n'//& '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'// & + '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'// & + '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'// & 'surface Ocean Boundary Layer (OBL).', & @@ -218,7 +243,11 @@ logical function KPP_init(paramFile, G, diag, Time, CS, passive, Waves) call get_param(paramFile, mdl, 'INTERP_TYPE', CS%interpType, & 'Type of interpolation to determine the OBL depth.\n'// & 'Allowed types are: linear, quadratic, cubic.', & - default='cubic') + default='quadratic') + call get_param(paramFile, mdl, 'INTERP_TYPE2', CS%interpType2, & + 'Type of interpolation to compute diff and visc at OBL_depth.\n'// & + 'Allowed types are: linear, quadratic, cubic or LMD94.', & + default='LMD94') call get_param(paramFile, mdl, 'COMPUTE_EKMAN', CS%computeEkman, & 'If True, limit OBL depth to be no deeper than Ekman depth.', & default=.False.) @@ -298,11 +327,24 @@ logical function KPP_init(paramFile, G, diag, Time, CS, passive, Waves) '\t MatchBoth = match gradient for both diffusivity and NLT\n'// & '\t ParabolicNonLocal = sigma*(1-sigma)^2 for diffusivity; (1-sigma)^2 for NLT', & default='SimpleShapes') - if (CS%MatchTechnique.eq.'ParabolicNonLocal') then + 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. endif + if (CS%MatchTechnique == 'ParabolicNonLocal' .or. CS%MatchTechnique == 'SimpleShapes') then + ! 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"//& + "linear or LMD94 (recommended) to avoid negative viscosity and diffusivity.\n"//& + "Please select one of these valid options." ) + endif + call get_param(paramFile, mdl, 'KPP_ZERO_DIFFUSIVITY', CS%KPPzeroDiffusivity, & 'If True, zeroes the KPP diffusivity and viscosity; for testing purpose.',& default=.False.) @@ -396,7 +438,7 @@ logical function KPP_init(paramFile, G, diag, Time, CS, passive, Waves) 'Constant value to enhance VT2 in KPP.', & default=1.0) endif - end if + endif call closeParameterBlock(paramFile) call get_param(paramFile, mdl, 'DEBUG', CS%debug, default=.False., do_not_log=.True.) @@ -407,12 +449,13 @@ logical function KPP_init(paramFile, G, diag, Time, CS, passive, Waves) vonKarman=CS%vonKarman, & surf_layer_ext=CS%surf_layer_ext, & interp_type=CS%interpType, & - interp_type2=CS%interpType, & + interp_type2=CS%interpType2, & lEkman=CS%computeEkman, & lMonOb=CS%computeMoninObukhov, & MatchTechnique=CS%MatchTechnique, & lenhanced_diff=CS%enhance_diffusion,& lnonzero_surf_nonlocal=Cs_is_one ,& + lnoDGat1=lnoDGat1 ,& CVMix_kpp_params_user=CS%KPP_params ) ! Register diagnostics @@ -424,6 +467,10 @@ logical function KPP_init(paramFile, G, diag, Time, CS, passive, Waves) ! CMOR names are placeholders; must be modified by time period ! for CMOR compliance. Diag manager will be used for omlmax and ! omldamax. + CS%id_OBLdepth_original = register_diag_field('ocean_model', 'KPP_OBLdepth_original', diag%axesT1, Time, & + 'Thickness of the surface Ocean Boundary Layer without smoothing calculated by [CVMix] KPP', 'meter', & + cmor_field_name='oml', cmor_long_name='ocean_mixed_layer_thickness_defined_by_mixing_scheme', & + cmor_units='m', cmor_standard_name='Ocean Mixed Layer Thickness Defined by Mixing Scheme') CS%id_BulkDrho = register_diag_field('ocean_model', 'KPP_BulkDrho', diag%axesTL, Time, & 'Bulk difference in density used in Bulk Richardson number, as used by [CVMix] KPP', 'kg/m3') CS%id_BulkUz2 = register_diag_field('ocean_model', 'KPP_BulkUz2', diag%axesTL, Time, & @@ -441,7 +488,7 @@ logical function KPP_init(paramFile, G, diag, Time, CS, passive, Waves) CS%id_Vt2 = register_diag_field('ocean_model', 'KPP_Vt2', diag%axesTL, Time, & 'Unresolved shear turbulence used by [CVMix] KPP', 'm2/s2') CS%id_uStar = register_diag_field('ocean_model', 'KPP_uStar', diag%axesT1, Time, & - 'Friction velocity, u*, as used by [CVMix] KPP', 'm/s') + 'Friction velocity, u*, as used by [CVMix] KPP', 'm/s', conversion=US%Z_to_m) CS%id_buoyFlux = register_diag_field('ocean_model', 'KPP_buoyFlux', diag%axesTi, Time, & 'Surface (and penetrating) buoyancy flux, as used by [CVMix] KPP', 'm2/s3') CS%id_QminusSW = register_diag_field('ocean_model', 'KPP_QminusSW', diag%axesT1, Time, & @@ -451,7 +498,7 @@ logical function KPP_init(paramFile, G, diag, Time, CS, passive, Waves) CS%id_Kt_KPP = register_diag_field('ocean_model', 'KPP_Kheat', diag%axesTi, Time, & 'Heat diffusivity due to KPP, as calculated by [CVMix] KPP', 'm2/s') CS%id_Kd_in = register_diag_field('ocean_model', 'KPP_Kd_in', diag%axesTi, Time, & - 'Diffusivity passed to KPP', 'm2/s') + 'Diffusivity passed to KPP', 'm2/s', conversion=US%Z_to_m**2) CS%id_Ks_KPP = register_diag_field('ocean_model', 'KPP_Ksalt', diag%axesTi, Time, & 'Salt diffusivity due to KPP, as calculated by [CVMix] KPP', 'm2/s') CS%id_Kv_KPP = register_diag_field('ocean_model', 'KPP_Kv', diag%axesTi, Time, & @@ -480,10 +527,20 @@ logical function KPP_init(paramFile, G, diag, Time, CS, passive, Waves) 'Langmuir number enhancement to K as used by [CVMix] KPP','nondim') CS%id_EnhVt2 = register_diag_field('ocean_model', 'EnhVt2', diag%axesTL, Time, & 'Langmuir number enhancement to Vt2 as used by [CVMix] KPP','nondim') - - allocate( CS%OBLdepthprev( SZI_(G), SZJ_(G) ) );CS%OBLdepthprev(:,:)=0.0; - if (CS%id_OBLdepth > 0) allocate( CS%OBLdepth( SZI_(G), SZJ_(G) ) ) - if (CS%id_OBLdepth > 0) CS%OBLdepth(:,:) = 0. + CS%id_La_SL = register_diag_field('ocean_model', 'KPP_La_SL', diag%axesT1, Time, & + 'Surface-layer Langmuir number computed in [CVMix] KPP','nondim') + + allocate( CS%N( SZI_(G), SZJ_(G), SZK_(G)+1 ) ) + CS%N(:,:,:) = 0. + allocate( CS%OBLdepth( SZI_(G), SZJ_(G) ) ) + CS%OBLdepth(:,:) = 0. + allocate( CS%kOBL( SZI_(G), SZJ_(G) ) ) + CS%kOBL(:,:) = 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) ) ) + + allocate( CS%OBLdepthprev( SZI_(G), SZJ_(G) ) ) ; CS%OBLdepthprev(:,:) = 0.0 if (CS%id_BulkDrho > 0) allocate( CS%dRho( SZI_(G), SZJ_(G), SZK_(G) ) ) if (CS%id_BulkDrho > 0) CS%dRho(:,:,:) = 0. if (CS%id_BulkUz2 > 0) allocate( CS%Uz2( SZI_(G), SZJ_(G), SZK_(G) ) ) @@ -494,12 +551,8 @@ logical function KPP_init(paramFile, G, diag, Time, CS, passive, Waves) if (CS%id_Sigma > 0) CS%sigma(:,:,:) = 0. if (CS%id_Ws > 0) allocate( CS%Ws( SZI_(G), SZJ_(G), SZK_(G) ) ) if (CS%id_Ws > 0) CS%Ws(:,:,:) = 0. - if (CS%id_N > 0) allocate( CS%N( SZI_(G), SZJ_(G), SZK_(G)+1 ) ) - if (CS%id_N > 0) CS%N(:,:,:) = 0. if (CS%id_N2 > 0) allocate( CS%N2( SZI_(G), SZJ_(G), SZK_(G)+1 ) ) if (CS%id_N2 > 0) CS%N2(:,:,:) = 0. - if (CS%id_Vt2 > 0) allocate( CS%Vt2( SZI_(G), SZJ_(G), SZK_(G) ) ) - if (CS%id_Vt2 > 0) CS%Vt2(:,:,:) = 0. if (CS%id_Kt_KPP > 0) allocate( CS%Kt_KPP( SZI_(G), SZJ_(G), SZK_(G)+1 ) ) if (CS%id_Kt_KPP > 0) CS%Kt_KPP(:,:,:) = 0. if (CS%id_Ks_KPP > 0) allocate( CS%Ks_KPP( SZI_(G), SZJ_(G), SZK_(G)+1 ) ) @@ -522,51 +575,330 @@ logical function KPP_init(paramFile, G, diag, Time, CS, passive, Waves) end function KPP_init - - !> KPP vertical diffusivity/viscosity and non-local tracer transport -subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & +subroutine KPP_calculate(CS, G, GV, US, h, uStar, & buoyFlux, Kt, Ks, Kv, nonLocalTransHeat,& nonLocalTransScalar, Waves) ! Arguments - type(KPP_CS), pointer :: CS !< Control structure - type(ocean_grid_type), intent(in) :: G !< Ocean grid - type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid - type(wave_parameters_CS), pointer, optional :: Waves ! m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: uStar !< Surface friction velocity [Z s-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: buoyFlux !< Surface buoyancy flux [m2 s-3] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: Kt !< (in) Vertical diffusivity of heat w/o KPP + !! (out) Vertical diffusivity including KPP + !! [Z2 s-1 ~> m2 s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: Ks !< (in) Vertical diffusivity of salt w/o KPP + !! (out) Vertical diffusivity including KPP + !! [Z2 s-1 ~> m2 s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: Kv !< (in) Vertical viscosity w/o KPP + !! (out) Vertical viscosity including KPP + !! [Z2 s-1 ~> m2 s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: nonLocalTransHeat !< Temp non-local transport [m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: nonLocalTransScalar !< scalar non-local transport [m s-1] + +! Local variables + integer :: i, j, k ! Loop indices + real, dimension( G%ke ) :: cellHeight ! Cell center heights referenced to surface [m] (negative in ocean) + real, dimension( G%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface [m] (negative in ocean) + real, dimension( G%ke+1, 2) :: Kdiffusivity ! Vertical diffusivity at interfaces [m2 s-1] + real, dimension( G%ke+1 ) :: Kviscosity ! Vertical viscosity at interfaces [m2 s-1] + real, dimension( G%ke+1, 2) :: nonLocalTrans ! Non-local transport for heat/salt at interfaces [nondim] + + real :: surfFricVel, surfBuoyFlux + real :: sigma, sigmaRatio + real :: dh ! The local thickness used for calculating interface positions [m] + real :: hcorr ! A cumulative correction arising from inflation of vanished layers [m] + + ! For Langmuir Calculations + real :: LangEnhK ! Langmuir enhancement for mixing coefficient + + +#ifdef __DO_SAFETY_CHECKS__ + if (CS%debug) then + call hchksum(h, "KPP in: h",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(uStar, "KPP in: uStar",G%HI,haloshift=0, scale=US%Z_to_m) + call hchksum(buoyFlux, "KPP in: buoyFlux",G%HI,haloshift=0) + call hchksum(Kt, "KPP in: Kt",G%HI,haloshift=0, scale=US%Z_to_m**2) + call hchksum(Ks, "KPP in: Ks",G%HI,haloshift=0, scale=US%Z_to_m**2) + endif +#endif + + nonLocalTrans(:,:) = 0.0 + + if (CS%id_Kd_in > 0) call post_data(CS%id_Kd_in, Kt, CS%diag) + + !$OMP parallel do default(shared) firstprivate(nonLocalTrans) + ! loop over horizontal points on processor + do j = G%jsc, G%jec + do i = G%isc, G%iec + + ! skip calling KPP for land points + if (G%mask2dT(i,j)==0.) cycle + + ! things independent of position within the column + surfFricVel = US%Z_to_m * uStar(i,j) + + iFaceHeight(1) = 0.0 ! BBL is all relative to the surface + hcorr = 0. + do k=1,G%ke + + ! cell center and cell bottom in meters (negative values in the ocean) + dh = h(i,j,k) * GV%H_to_m ! Nominal thickness to use for increment + dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) + hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 + dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness + cellHeight(k) = iFaceHeight(k) - 0.5 * dh + iFaceHeight(k+1) = iFaceHeight(k) - dh + + enddo ! k-loop finishes + + surfBuoyFlux = buoyFlux(i,j,1) ! This is only used in kpp_compute_OBL_depth to limit + ! h to Monin-Obukov (default is false, ie. not used) + + ! Call CVMix/KPP to obtain OBL diffusivities, viscosities and non-local transports + + ! Unlike LMD94, we do not match to interior diffusivities. If using the original + ! LMD94 shape function, not matching is equivalent to matching to a zero diffusivity. + + !BGR/ Add option for use of surface buoyancy flux with total sw flux. + if (CS%SW_METHOD == SW_METHOD_ALL_SW) then + surfBuoyFlux = buoyFlux(i,j,1) + elseif (CS%SW_METHOD == SW_METHOD_MXL_SW) then + ! We know the actual buoyancy flux into the OBL + surfBuoyFlux = buoyFlux(i,j,1) - buoyFlux(i,j,int(CS%kOBL(i,j))+1) + elseif (CS%SW_METHOD == SW_METHOD_LV1_SW) then + surfBuoyFlux = buoyFlux(i,j,1) - buoyFlux(i,j,2) + endif + + ! If option "MatchBoth" is selected in CVMix, MOM should be capable of matching. + if (.not. (CS%MatchTechnique == 'MatchBoth')) then + Kdiffusivity(:,:) = 0. ! Diffusivities for heat and salt [m2 s-1] + Kviscosity(:) = 0. ! Viscosity [m2 s-1] + else + Kdiffusivity(:,1) = US%Z_to_m**2 * Kt(i,j,:) + Kdiffusivity(:,2) = US%Z_to_m**2 * Ks(i,j,:) + Kviscosity(:) = US%Z_to_m**2 * Kv(i,j,:) + endif + + call CVMix_coeffs_kpp(Kviscosity(:), & ! (inout) Total viscosity [m2 s-1] + Kdiffusivity(:,1), & ! (inout) Total heat diffusivity [m2 s-1] + Kdiffusivity(:,2), & ! (inout) Total salt diffusivity [m2 s-1] + iFaceHeight, & ! (in) Height of interfaces [m] + cellHeight, & ! (in) Height of level centers [m] + Kviscosity(:), & ! (in) Original viscosity [m2 s-1] + Kdiffusivity(:,1), & ! (in) Original heat diffusivity [m2 s-1] + Kdiffusivity(:,2), & ! (in) Original salt diffusivity [m2 s-1] + CS%OBLdepth(i,j), & ! (in) OBL depth [m] + CS%kOBL(i,j), & ! (in) level (+fraction) of OBL extent + nonLocalTrans(:,1),& ! (out) Non-local heat transport [nondim] + nonLocalTrans(:,2),& ! (out) Non-local salt transport [nondim] + surfFricVel, & ! (in) Turbulent friction velocity at surface [m s-1] + surfBuoyFlux, & ! (in) Buoyancy flux at surface [m2 s-3] + G%ke, & ! (in) Number of levels to compute coeffs for + G%ke, & ! (in) Number of levels in array shape + CVMix_kpp_params_user=CS%KPP_params ) + + ! safety check, Kviscosity and Kdiffusivity must be >= 0 + do k=1, G%ke+1 + if (Kviscosity(k) < 0. .or. Kdiffusivity(k,1) < 0.) then + call MOM_error(FATAL,"KPP_calculate, after CVMix_coeffs_kpp: "// & + "Negative vertical viscosity or diffusivity has been detected. " // & + "This is likely related to the choice of MATCH_TECHNIQUE and INTERP_TYPE2." //& + "You might consider using the default options for these parameters." ) + endif + enddo + + IF (CS%LT_K_ENHANCEMENT) then + if (CS%LT_K_METHOD==LT_K_MODE_CONSTANT) then + 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)) + 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)) + else + !This shouldn't be reached. + !call MOM_error(WARNING,"Unexpected behavior in MOM_CVMix_KPP, see error in LT_K_ENHANCEMENT") + LangEnhK = 1.0 + endif + do k=1,G%ke + if (CS%LT_K_SHAPE== LT_K_CONSTANT) then + if (CS%id_EnhK > 0) CS%EnhK(i,j,:) = LangEnhK + Kdiffusivity(k,1) = Kdiffusivity(k,1) * LangEnhK + Kdiffusivity(k,2) = Kdiffusivity(k,2) * LangEnhK + Kviscosity(k) = Kviscosity(k) * LangEnhK + elseif (CS%LT_K_SHAPE == LT_K_SCALED) then + sigma = min(1.0,-iFaceHeight(k)/CS%OBLdepth(i,j)) + SigmaRatio = sigma * (1. - sigma)**2. / 0.148148037 + if (CS%id_EnhK > 0) CS%EnhK(i,j,k) = (1.0 + (LangEnhK - 1.)*sigmaRatio) + Kdiffusivity(k,1) = Kdiffusivity(k,1) * ( 1. + & + ( LangEnhK - 1.)*sigmaRatio) + Kdiffusivity(k,2) = Kdiffusivity(k,2) * ( 1. + & + ( LangEnhK - 1.)*sigmaRatio) + Kviscosity(k) = Kviscosity(k) * ( 1. + & + ( LangEnhK - 1.)*sigmaRatio) + endif + enddo + endif + + ! Over-write CVMix NLT shape function with one of the following choices. + ! The CVMix code has yet to update for thse options, so we compute in MOM6. + ! Note that nonLocalTrans = Cs * G(sigma) (LMD94 notation), with + ! Cs = 6.32739901508. + ! Start do-loop at k=2, since k=1 is ocean surface (sigma=0) + ! and we do not wish to double-count the surface forcing. + ! Only compute nonlocal transport for 0 <= sigma <= 1. + ! MOM6 recommended shape is the parabolic; it gives deeper boundary layer + ! and no spurious extrema. + if (surfBuoyFlux < 0.0) then + if (CS%NLT_shape == NLT_SHAPE_CUBIC) then + do k = 2, G%ke + sigma = min(1.0,-iFaceHeight(k)/CS%OBLdepth(i,j)) + nonLocalTrans(k,1) = (1.0 - sigma)**2 * (1.0 + 2.0*sigma) !* + nonLocalTrans(k,2) = nonLocalTrans(k,1) + enddo + elseif (CS%NLT_shape == NLT_SHAPE_PARABOLIC) then + do k = 2, G%ke + sigma = min(1.0,-iFaceHeight(k)/CS%OBLdepth(i,j)) + nonLocalTrans(k,1) = (1.0 - sigma)**2 !*CS%CS2 + nonLocalTrans(k,2) = nonLocalTrans(k,1) + enddo + elseif (CS%NLT_shape == NLT_SHAPE_LINEAR) then + do k = 2, G%ke + sigma = min(1.0,-iFaceHeight(k)/CS%OBLdepth(i,j)) + nonLocalTrans(k,1) = (1.0 - sigma)!*CS%CS2 + nonLocalTrans(k,2) = nonLocalTrans(k,1) + enddo + elseif (CS%NLT_shape == NLT_SHAPE_CUBIC_LMD) then + ! Sanity check (should agree with CVMix result using simple matching) + do k = 2, G%ke + sigma = min(1.0,-iFaceHeight(k)/CS%OBLdepth(i,j)) + nonLocalTrans(k,1) = CS%CS2 * sigma*(1.0 -sigma)**2 + nonLocalTrans(k,2) = nonLocalTrans(k,1) + enddo + endif + endif + + ! we apply nonLocalTrans in subroutines + ! KPP_NonLocalTransport_temp and KPP_NonLocalTransport_saln + nonLocalTransHeat(i,j,:) = nonLocalTrans(:,1) ! temp + nonLocalTransScalar(i,j,:) = nonLocalTrans(:,2) ! saln + + ! set the KPP diffusivity and viscosity to zero for testing purposes + if (CS%KPPzeroDiffusivity) then + Kdiffusivity(:,1) = 0.0 + Kdiffusivity(:,2) = 0.0 + Kviscosity(:) = 0.0 + endif + + + ! compute unresolved squared velocity for diagnostics + if (CS%id_Vt2 > 0) then +!BGR Now computing VT2 above so can modify for LT +! therefore, don't repeat this operation here +! CS%Vt2(i,j,:) = CVmix_kpp_compute_unresolved_shear( & +! cellHeight(1:G%ke), & ! Depth of cell center [m] +! ws_cntr=Ws_1d, & ! Turbulent velocity scale profile, at centers [m s-1] +! N_iface=CS%N(i,j,:), & ! Buoyancy frequency at interface [s-1] +! CVmix_kpp_params_user=CS%KPP_params ) ! KPP parameters + endif + + ! Copy 1d data into 3d diagnostic arrays + !/ grabbing obldepth_0d for next time step. + CS%OBLdepthprev(i,j)=CS%OBLdepth(i,j) + if (CS%id_sigma > 0) then + CS%sigma(i,j,:) = 0. + if (CS%OBLdepth(i,j)>0.) CS%sigma(i,j,:) = -iFaceHeight/CS%OBLdepth(i,j) + endif + if (CS%id_Kt_KPP > 0) CS%Kt_KPP(i,j,:) = Kdiffusivity(:,1) + if (CS%id_Ks_KPP > 0) CS%Ks_KPP(i,j,:) = Kdiffusivity(:,2) + if (CS%id_Kv_KPP > 0) CS%Kv_KPP(i,j,:) = Kviscosity(:) + + ! Update output of routine + if (.not. CS%passiveMode) then + if (CS%KPPisAdditive) then + do k=1, G%ke+1 + Kt(i,j,k) = Kt(i,j,k) + US%m_to_Z**2 * Kdiffusivity(k,1) + Ks(i,j,k) = Ks(i,j,k) + US%m_to_Z**2 * Kdiffusivity(k,2) + Kv(i,j,k) = Kv(i,j,k) + US%m_to_Z**2 * Kviscosity(k) + if (CS%Stokes_Mixing) Waves%KvS(i,j,k) = US%Z_to_m**2 * Kv(i,j,k) + enddo + else ! KPP replaces prior diffusivity when former is non-zero + do k=1, G%ke+1 + if (Kdiffusivity(k,1) /= 0.) Kt(i,j,k) = US%m_to_Z**2 * Kdiffusivity(k,1) + if (Kdiffusivity(k,2) /= 0.) Ks(i,j,k) = US%m_to_Z**2 * Kdiffusivity(k,2) + if (Kviscosity(k) /= 0.) Kv(i,j,k) = US%m_to_Z**2 * Kviscosity(k) + if (CS%Stokes_Mixing) Waves%KvS(i,j,k) = US%Z_to_m**2 * Kv(i,j,k) + enddo + endif + endif + + + ! end of the horizontal do-loops over the vertical columns + enddo ! i + enddo ! j + + +#ifdef __DO_SAFETY_CHECKS__ + if (CS%debug) then + call hchksum(Kt, "KPP out: Kt", G%HI, haloshift=0, scale=US%Z_to_m**2) + call hchksum(Ks, "KPP out: Ks", G%HI, haloshift=0, scale=US%Z_to_m**2) + endif +#endif + + ! send diagnostics to post_data + if (CS%id_OBLdepth > 0) call post_data(CS%id_OBLdepth, CS%OBLdepth, CS%diag) + if (CS%id_OBLdepth_original > 0) call post_data(CS%id_OBLdepth_original,CS%OBLdepth_original,CS%diag) + if (CS%id_sigma > 0) call post_data(CS%id_sigma, CS%sigma, CS%diag) + if (CS%id_Ws > 0) call post_data(CS%id_Ws, CS%Ws, CS%diag) + if (CS%id_Vt2 > 0) call post_data(CS%id_Vt2, CS%Vt2, CS%diag) + if (CS%id_uStar > 0) call post_data(CS%id_uStar, uStar, CS%diag) + if (CS%id_buoyFlux > 0) call post_data(CS%id_buoyFlux, buoyFlux, CS%diag) + if (CS%id_Kt_KPP > 0) call post_data(CS%id_Kt_KPP, CS%Kt_KPP, CS%diag) + if (CS%id_Ks_KPP > 0) call post_data(CS%id_Ks_KPP, CS%Ks_KPP, CS%diag) + if (CS%id_Kv_KPP > 0) call post_data(CS%id_Kv_KPP, CS%Kv_KPP, CS%diag) + if (CS%id_NLTt > 0) call post_data(CS%id_NLTt, nonLocalTransHeat, CS%diag) + if (CS%id_NLTs > 0) call post_data(CS%id_NLTs, nonLocalTransScalar,CS%diag) + + +end subroutine KPP_calculate + + +!> Compute OBL depth +subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, EOS, uStar, buoyFlux, Waves) + + ! Arguments + type(KPP_CS), pointer :: CS !< Control structure + type(ocean_grid_type), intent(inout) :: G !< Ocean grid + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer/level thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: Temp !< potential/cons temp [degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: Salt !< Salinity [ppt] + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Velocity i-component [m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< Velocity j-component [m s-1] + type(EOS_type), pointer :: EOS !< Equation of state + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: uStar !< Surface friction velocity [Z s-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: buoyFlux !< Surface buoyancy flux [m2 s-3] + type(wave_parameters_CS), optional, pointer :: Waves !< Wave CS ! Local variables - integer :: i, j, k, km1,kp1 ! Loop indices - real, dimension( G%ke ) :: cellHeight ! Cell center heights referenced to surface (m) (negative in ocean) - real, dimension( G%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface (m) (negative in ocean) - real, dimension( G%ke+1 ) :: N2_1d ! Brunt-Vaisala frequency squared, at interfaces (1/s2) - real, dimension( G%ke+1 ) :: N_1d ! Brunt-Vaisala frequency at interfaces (1/s) (floored at 0) - real, dimension( G%ke ) :: Ws_1d ! Profile of vertical velocity scale for scalars (m/s) - real, dimension( G%ke ) :: Wm_1d ! Profile of vertical velocity scale for momentum (m/s) - real, dimension( G%ke ) :: Vt2_1d ! Unresolved velocity for bulk Ri calculation/diagnostic (m2/s2) - real, dimension( G%ke ) :: BulkRi_1d ! Bulk Richardson number for each layer + integer :: i, j, k, km1 ! Loop indices + real, dimension( G%ke ) :: cellHeight ! Cell center heights referenced to surface [m] (negative in ocean) + real, dimension( G%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface [m] (negative in ocean) + real, dimension( G%ke+1 ) :: N2_1d ! Brunt-Vaisala frequency squared, at interfaces [s-2] + real, dimension( G%ke ) :: Ws_1d ! Profile of vertical velocity scale for scalars [m s-1] real, dimension( G%ke ) :: deltaRho ! delta Rho in numerator of Bulk Ri number - real, dimension( G%ke ) :: deltaU2 ! square of delta U (shear) in denominator of Bulk Ri (m2/s2) - real, dimension( G%ke+1, 2) :: Kdiffusivity ! Vertical diffusivity at interfaces (m2/s) - real, dimension( G%ke+1 ) :: Kviscosity ! Vertical viscosity at interfaces (m2/s) - real, dimension( G%ke+1, 2) :: nonLocalTrans ! Non-local transport for heat/salt at interfaces (non-dimensional) + real, dimension( G%ke ) :: deltaU2 ! square of delta U (shear) in denominator of Bulk Ri [m2 s-2] real, dimension( G%ke ) :: surfBuoyFlux2 + real, dimension( G%ke ) :: BulkRi_1d ! Bulk Richardson number for each layer ! for EOS calculation real, dimension( 3*G%ke ) :: rho_1D @@ -574,19 +906,19 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & real, dimension( 3*G%ke ) :: Temp_1D real, dimension( 3*G%ke ) :: Salt_1D - real :: kOBL, OBLdepth_0d, surfFricVel, surfBuoyFlux, Coriolis - real :: GoRho, pRef, rho1, rhoK, rhoKm1, Uk, Vk, sigma, sigmaRatio + real :: surfFricVel, surfBuoyFlux, Coriolis + real :: GoRho, pRef, rho1, rhoK, Uk, Vk, sigma, sigmaRatio - real :: zBottomMinusOffset ! Height of bottom plus a little bit (m) + real :: zBottomMinusOffset ! Height of bottom plus a little bit [m] real :: SLdepth_0d ! Surface layer depth = surf_layer_ext*OBLdepth. - real :: hTot ! Running sum of thickness used in the surface layer average (m) - real :: delH ! Thickness of a layer (m) + real :: hTot ! Running sum of thickness used in the surface layer average [m] + real :: delH ! Thickness of a layer [m] real :: surfHtemp, surfTemp ! Integral and average of temp over the surface layer real :: surfHsalt, surfSalt ! Integral and average of saln over the surface layer real :: surfHu, surfU ! Integral and average of u over the surface layer real :: surfHv, surfV ! Integral and average of v over the surface layer - real :: dh ! The local thickness used for calculating interface positions (m) - real :: hcorr ! A cumulative correction arising from inflation of vanished layers (m) + real :: dh ! The local thickness used for calculating interface positions [m] + real :: hcorr ! A cumulative correction arising from inflation of vanished layers [m] integer :: kk, ksfc, ktmp ! For Langmuir Calculations @@ -594,38 +926,27 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & real, dimension(G%ke) :: LangEnhVt2 ! Langmuir enhancement for unresolved shear real, dimension(G%ke) :: U_H, V_H real :: MLD_GUESS, LA - real :: LangEnhK ! Langmuir enhancement for mixing coefficient real :: surfHuS, surfHvS, surfUs, surfVs, wavedir, currentdir real :: VarUp, VarDn, M, VarLo, VarAvg - real :: H10pct, H20pct,CMNFACT, USx20pct, USy20pct + real :: H10pct, H20pct,CMNFACT, USx20pct, USy20pct, enhvt2 integer :: B real :: WST #ifdef __DO_SAFETY_CHECKS__ if (CS%debug) then - call hchksum(h, "KPP in: h",G%HI,haloshift=0, scale=GV%H_to_m) - call hchksum(Temp, "KPP in: T",G%HI,haloshift=0) call hchksum(Salt, "KPP in: S",G%HI,haloshift=0) + call hchksum(Temp, "KPP in: T",G%HI,haloshift=0) call hchksum(u, "KPP in: u",G%HI,haloshift=0) call hchksum(v, "KPP in: v",G%HI,haloshift=0) - call hchksum(uStar, "KPP in: uStar",G%HI,haloshift=0) - call hchksum(buoyFlux, "KPP in: buoyFlux",G%HI,haloshift=0) - call hchksum(Kt, "KPP in: Kt",G%HI,haloshift=0) - call hchksum(Ks, "KPP in: Ks",G%HI,haloshift=0) endif #endif ! some constants - GoRho = GV%g_Earth / GV%Rho0 - nonLocalTrans(:,:) = 0.0 - - if (CS%id_Kd_in > 0) call post_data(CS%id_Kd_in, Kt, CS%diag) + GoRho = (GV%g_Earth*US%m_to_Z) / GV%Rho0 - !$OMP parallel do default(private) firstprivate(nonLocalTrans) & - !$OMP shared(G,GV,CS,EOS,uStar,Temp,Salt,u,v,h,GoRho,Waves,& - !$OMP buoyFlux,nonLocalTransHeat,nonLocalTransScalar,Kt,Ks,Kv) ! loop over horizontal points on processor + !$OMP parallel do default(shared) do j = G%jsc, G%jec do i = G%isc, G%iec @@ -640,7 +961,7 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & ! things independent of position within the column Coriolis = 0.25*( (G%CoriolisBu(i,j) + G%CoriolisBu(i-1,j-1)) & +(G%CoriolisBu(i-1,j) + G%CoriolisBu(i,j-1)) ) - surfFricVel = uStar(i,j) + surfFricVel = US%Z_to_m * uStar(i,j) ! Bullk Richardson number computed for each cell in a column, ! assuming OBLdepth = grid cell depth. After Rib(k) is @@ -697,8 +1018,8 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & surfHus = surfHus + 0.5*(WAVES%US_x(i,j,ktmp)+WAVES%US_x(i-1,j,ktmp)) * delH surfHvs = surfHvs + 0.5*(WAVES%US_y(i,j,ktmp)+WAVES%US_y(i,j-1,ktmp)) * delH endif - enddo + enddo surfTemp = surfHtemp / hTot surfSalt = surfHsalt / hTot surfU = surfHu / hTot @@ -753,10 +1074,10 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & "without activating USEWAVES") endif !For now get Langmuir number based on prev. MLD (otherwise must compute 3d LA) - MLD_GUESS = max( 1., abs(CS%OBLdepthprev(i,j) ) ) - call get_Langmuir_Number( LA, G, GV, MLD_guess, surfFricVel, I, J, & + 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, & H=H(i,j,:), U_H=U_H, V_H=V_H, WAVES=WAVES) - WAVES%LangNum(i,j)=LA + WAVES%La_SL(i,j)=LA endif @@ -765,17 +1086,17 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & ! N2 (can be negative) and N (non-negative) on interfaces. ! deltaRho is non-local rho difference used for bulk Richardson number. - ! N_1d is local N (with floor) used for unresolved shear calculation. + ! CS%N is local N (with floor) used for unresolved shear calculation. do k = 1, G%ke km1 = max(1, k-1) kk = 3*(k-1) deltaRho(k) = rho_1D(kk+2) - rho_1D(kk+1) N2_1d(k) = (GoRho * (rho_1D(kk+2) - rho_1D(kk+3)) ) / & ((0.5*(h(i,j,km1) + h(i,j,k))+GV%H_subroundoff)*GV%H_to_m) - N_1d(k) = sqrt( max( N2_1d(k), 0.) ) + CS%N(i,j,k) = sqrt( max( N2_1d(k), 0.) ) enddo N2_1d(G%ke+1 ) = 0.0 - N_1d(G%ke+1 ) = 0.0 + CS%N(i,j,G%ke+1 ) = 0.0 ! turbulent velocity scales w_s and w_m computed at the cell centers. ! Note that if sigma > CS%surf_layer_ext, then CVMix_kpp_compute_turbulent_scales @@ -783,18 +1104,18 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & ! sigma=CS%surf_layer_ext for this calculation. call CVMix_kpp_compute_turbulent_scales( & CS%surf_layer_ext, & ! (in) Normalized surface layer depth; sigma = CS%surf_layer_ext - -cellHeight, & ! (in) Assume here that OBL depth (m) = -cellHeight(k) - surfBuoyFlux2, & ! (in) Buoyancy flux at surface (m2/s3) - surfFricVel, & ! (in) Turbulent friction velocity at surface (m/s) - w_s=Ws_1d, & ! (out) Turbulent velocity scale profile (m/s) + -cellHeight, & ! (in) Assume here that OBL depth [m] = -cellHeight(k) + surfBuoyFlux2, & ! (in) Buoyancy flux at surface [m2 s-3] + surfFricVel, & ! (in) Turbulent friction velocity at surface [m s-1] + w_s=Ws_1d, & ! (out) Turbulent velocity scale profile [m s-1] CVMix_kpp_params_user=CS%KPP_params ) !Compute CVMix VT2 - Vt2_1d(:) = CVmix_kpp_compute_unresolved_shear( & - zt_cntr=cellHeight(1:G%ke), & ! Depth of cell center (m) - ws_cntr=Ws_1d, & ! Turbulent velocity scale profile, at centers (m/s) - N_iface=N_1d, & ! Buoyancy frequency at interface (1/s) - CVmix_kpp_params_user=CS%KPP_params ) ! KPP parameters + CS%Vt2(i,j,:) = CVmix_kpp_compute_unresolved_shear( & + zt_cntr=cellHeight(1:G%ke), & ! Depth of cell center [m] + ws_cntr=Ws_1d, & ! Turbulent velocity scale profile, at centers [m s-1] + N_iface=CS%N(i,j,:), & ! Buoyancy frequency at interface [s-1] + CVmix_kpp_params_user=CS%KPP_params ) ! KPP parameters !Modify CVMix VT2 IF (CS%LT_VT2_ENHANCEMENT) then @@ -803,25 +1124,29 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & LangEnhVT2(k) = CS%KPP_VT2_ENH_FAC 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)) do k=1,G%ke - LangEnhVT2(k) = min(10.,sqrt(1.+(1.5*WAVES%LangNum(i,j))**(-2) + & - (5.4*WAVES%LangNum(i,j))**(-4))) + 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) do k=1,G%ke - LangEnhVT2(k) = min(2.25, 1. + 1./WAVES%LangNum(i,j)) + LangEnhVT2(k) = enhvt2 enddo elseif (CS%LT_VT2_METHOD==LT_VT2_MODE_LF17) then CS%CS=cvmix_get_kpp_real('c_s',CS%KPP_params) 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%LangNum(i,j)**(-2.))) / & + (1.+0.49*WAVES%La_SL(i,j)**(-2.))) / & (0.2*ws_1d(k)**3/(CS%cs*CS%surf_layer_ext*CS%vonKarman**4.))) enddo else !This shouldn't be reached. - !call MOM_error(WARNING,"Unexpected behavior in MOM_KPP, see error in Vt2") + !call MOM_error(WARNING,"Unexpected behavior in MOM_CVMix_KPP, see error in Vt2") LangEnhVT2(:) = 1.0 endif else @@ -829,18 +1154,18 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & endif do k=1,G%ke - Vt2_1d(k)=Vt2_1d(k)*LangEnhVT2(k) + CS%Vt2(i,j,k)=CS%Vt2(i,j,k)*LangEnhVT2(k) if (CS%id_EnhVt2 > 0) CS%EnhVt2(i,j,k)=LangEnhVT2(k) enddo ! Calculate Bulk Richardson number from eq (21) of LMD94 BulkRi_1d = CVmix_kpp_compute_bulk_Richardson( & - zt_cntr = cellHeight(1:G%ke), & ! Depth of cell center (m) - delta_buoy_cntr=GoRho*deltaRho, & ! Bulk buoyancy difference, Br-B(z) (1/s) - delta_Vsqr_cntr=deltaU2, & ! Square of resolved velocity difference (m2/s2) - Vt_sqr_cntr=Vt2_1d, & - ws_cntr=Ws_1d, & ! Turbulent velocity scale profile (m/s) - N_iface=N_1d) ! Buoyancy frequency (1/s) + zt_cntr = cellHeight(1:G%ke), & ! Depth of cell center [m] + delta_buoy_cntr=GoRho*deltaRho, & ! Bulk buoyancy difference, Br-B(z) [s-1] + delta_Vsqr_cntr=deltaU2, & ! Square of resolved velocity difference [m2 s-2] + Vt_sqr_cntr=CS%Vt2(i,j,:), & + ws_cntr=Ws_1d, & ! Turbulent velocity scale profile [m s-1] + N_iface=CS%N(i,j,:)) ! Buoyancy frequency [s-1] surfBuoyFlux = buoyFlux(i,j,1) ! This is only used in kpp_compute_OBL_depth to limit @@ -848,40 +1173,41 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & call CVMix_kpp_compute_OBL_depth( & BulkRi_1d, & ! (in) Bulk Richardson number - iFaceHeight, & ! (in) Height of interfaces (m) - OBLdepth_0d, & ! (out) OBL depth (m) - kOBL, & ! (out) level (+fraction) of OBL extent - zt_cntr=cellHeight, & ! (in) Height of cell centers (m) - surf_fric=surfFricVel, & ! (in) Turbulent friction velocity at surface (m/s) - surf_buoy=surfBuoyFlux, & ! (in) Buoyancy flux at surface (m2/s3) - Coriolis=Coriolis, & ! (in) Coriolis parameter (1/s) + iFaceHeight, & ! (in) Height of interfaces [m] + CS%OBLdepth(i,j), & ! (out) OBL depth [m] + CS%kOBL(i,j), & ! (out) level (+fraction) of OBL extent + zt_cntr=cellHeight, & ! (in) Height of cell centers [m] + surf_fric=surfFricVel, & ! (in) Turbulent friction velocity at surface [m s-1] + surf_buoy=surfBuoyFlux, & ! (in) Buoyancy flux at surface [m2 s-3] + Coriolis=Coriolis, & ! (in) Coriolis parameter [s-1] CVMix_kpp_params_user=CS%KPP_params ) ! KPP parameters ! A hack to avoid KPP reaching the bottom. It was needed during development ! because KPP was unable to handle vanishingly small layers near the bottom. if (CS%deepOBLoffset>0.) then zBottomMinusOffset = iFaceHeight(G%ke+1) + min(CS%deepOBLoffset,-0.1*iFaceHeight(G%ke+1)) - OBLdepth_0d = min( OBLdepth_0d, -zBottomMinusOffset ) + CS%OBLdepth(i,j) = min( CS%OBLdepth(i,j), -zBottomMinusOffset ) endif ! apply some constraints on OBLdepth - if(CS%fixedOBLdepth) OBLdepth_0d = CS%fixedOBLdepth_value - OBLdepth_0d = max( OBLdepth_0d, -iFaceHeight(2) ) ! no shallower than top layer - OBLdepth_0d = min( OBLdepth_0d, -iFaceHeight(G%ke+1) ) ! no deeper than bottom - kOBL = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, OBLdepth_0d ) + if(CS%fixedOBLdepth) CS%OBLdepth(i,j) = CS%fixedOBLdepth_value + CS%OBLdepth(i,j) = max( CS%OBLdepth(i,j), -iFaceHeight(2) ) ! no shallower than top layer + CS%OBLdepth(i,j) = min( CS%OBLdepth(i,j), -iFaceHeight(G%ke+1) ) ! no deeper than bottom + CS%kOBL(i,j) = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, CS%OBLdepth(i,j) ) !************************************************************************* ! smg: remove code below ! Following "correction" step has been found to be unnecessary. ! Code should be removed after further testing. -! BGR: 03/15/2018-> Restructured code (Vt2 changed to compute from call in MOM_KPP now) +! BGR: 03/15/2018-> Restructured code (Vt2 changed to compute from call in MOM_CVMix_KPP now) ! I have not taken this restructuring into account here. ! Do we ever run with correctSurfLayerAvg? ! smg's suggested testing and removal is advised, in the meantime ! I have added warning if correctSurfLayerAvg is attempted. ! if (CS%correctSurfLayerAvg) then - ! SLdepth_0d = CS%surf_layer_ext * OBLdepth_0d + + ! SLdepth_0d = CS%surf_layer_ext * CS%OBLdepth(i,j) ! hTot = h(i,j,1) ! surfTemp = Temp(i,j,1) ; surfHtemp = surfTemp * hTot ! surfSalt = Salt(i,j,1) ; surfHsalt = surfSalt * hTot @@ -912,280 +1238,202 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & ! enddo - ! BulkRi_1d = CVmix_kpp_compute_bulk_Richardson( & - ! cellHeight(1:G%ke), & ! Depth of cell center (m) - ! GoRho*deltaRho, & ! Bulk buoyancy difference, Br-B(z) (1/s) - ! deltaU2, & ! Square of resolved velocity difference (m2/s2) - ! ws_cntr=Ws_1d, & ! Turbulent velocity scale profile (m/s) - ! N_iface=N_1d ) ! Buoyancy frequency (1/s) + ! BulkRi_1d = CVMix_kpp_compute_bulk_Richardson( & + ! cellHeight(1:G%ke), & ! Depth of cell center [m] + ! GoRho*deltaRho, & ! Bulk buoyancy difference, Br-B(z) [s-1] + ! deltaU2, & ! Square of resolved velocity difference [m2 s-2] + ! ws_cntr=Ws_1d, & ! Turbulent velocity scale profile [m s-1] + ! N_iface=CS%N ) ! Buoyancy frequency [s-1] ! surfBuoyFlux = buoyFlux(i,j,1) ! This is only used in kpp_compute_OBL_depth to limit ! ! h to Monin-Obukov (default is false, ie. not used) - ! call CVmix_kpp_compute_OBL_depth( & + ! call CVMix_kpp_compute_OBL_depth( & ! BulkRi_1d, & ! (in) Bulk Richardson number - ! iFaceHeight, & ! (in) Height of interfaces (m) - ! OBLdepth_0d, & ! (out) OBL depth (m) - ! kOBL, & ! (out) level (+fraction) of OBL extent - ! zt_cntr=cellHeight, & ! (in) Height of cell centers (m) - ! surf_fric=surfFricVel, & ! (in) Turbulent friction velocity at surface (m/s) - ! surf_buoy=surfBuoyFlux, & ! (in) Buoyancy flux at surface (m2/s3) - ! Coriolis=Coriolis, & ! (in) Coriolis parameter (1/s) - ! CVmix_kpp_params_user=CS%KPP_params ) ! KPP parameters + ! iFaceHeight, & ! (in) Height of interfaces [m] + ! CS%OBLdepth(i,j), & ! (out) OBL depth [m] + ! CS%kOBL(i,j), & ! (out) level (+fraction) of OBL extent + ! zt_cntr=cellHeight, & ! (in) Height of cell centers [m] + ! surf_fric=surfFricVel, & ! (in) Turbulent friction velocity at surface [m s-1] + ! surf_buoy=surfBuoyFlux, & ! (in) Buoyancy flux at surface [m2 s-3] + ! Coriolis=Coriolis, & ! (in) Coriolis parameter [s-1] + ! CVMix_kpp_params_user=CS%KPP_params ) ! KPP parameters ! if (CS%deepOBLoffset>0.) then ! zBottomMinusOffset = iFaceHeight(G%ke+1) + min(CS%deepOBLoffset,-0.1*iFaceHeight(G%ke+1)) - ! OBLdepth_0d = min( OBLdepth_0d, -zBottomMinusOffset ) - ! kOBL = CVmix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, OBLdepth_0d ) + ! CS%OBLdepth(i,j) = min( CS%OBLdepth(i,j), -zBottomMinusOffset ) + ! CS%kOBL(i,j) = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, CS%OBLdepth(i,j) ) ! endif ! ! apply some constraints on OBLdepth - ! if(CS%fixedOBLdepth) OBLdepth_0d = CS%fixedOBLdepth_value - ! OBLdepth_0d = max( OBLdepth_0d, -iFaceHeight(2) ) ! no shallower than top layer - ! OBLdepth_0d = min( OBLdepth_0d, -iFaceHeight(G%ke+1) ) ! no deep than bottom - ! kOBL = CVmix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, OBLdepth_0d ) + ! if(CS%fixedOBLdepth) CS%OBLdepth(i,j) = CS%fixedOBLdepth_value + ! CS%OBLdepth(i,j) = max( CS%OBLdepth(i,j), -iFaceHeight(2) ) ! no shallower than top layer + ! CS%OBLdepth(i,j) = min( CS%OBLdepth(i,j), -iFaceHeight(G%ke+1) ) ! no deep than bottom + ! CS%kOBL(i,j) = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, CS%OBLdepth(i,j) ) ! endif ! endif for "correction" step + ! smg: remove code above ! ********************************************************************** - ! Call CVMix/KPP to obtain OBL diffusivities, viscosities and non-local transports - - ! Unlike LMD94, we do not match to interior diffusivities. If using the original - ! LMD94 shape function, not matching is equivalent to matching to a zero diffusivity. - - !BGR/ Add option for use of surface buoyancy flux with total sw flux. - if (CS%SW_METHOD .eq. SW_METHOD_ALL_SW) then - surfBuoyFlux = buoyFlux(i,j,1) - elseif (CS%SW_METHOD .eq. SW_METHOD_MXL_SW) then - surfBuoyFlux = buoyFlux(i,j,1) - buoyFlux(i,j,int(kOBL)+1) ! We know the actual buoyancy flux into the OBL - elseif (CS%SW_METHOD .eq. SW_METHOD_LV1_SW) then - surfBuoyFlux = buoyFlux(i,j,1) - buoyFlux(i,j,2) - endif - - ! If option "MatchBoth" is selected in CVMix, MOM should be capable of matching. - if (.not. (CS%MatchTechnique.eq.'MatchBoth')) then - Kdiffusivity(:,:) = 0. ! Diffusivities for heat and salt (m2/s) - Kviscosity(:) = 0. ! Viscosity (m2/s) - else - Kdiffusivity(:,1) = Kt(i,j,:) - Kdiffusivity(:,2) = Ks(i,j,:) - Kviscosity(:)=Kv(i,j,:) - endif - - call CVMix_coeffs_kpp(Kviscosity, & ! (inout) Total viscosity (m2/s) - Kdiffusivity(:,1), & ! (inout) Total heat diffusivity (m2/s) - Kdiffusivity(:,2), & ! (inout) Total salt diffusivity (m2/s) - iFaceHeight, & ! (in) Height of interfaces (m) - cellHeight, & ! (in) Height of level centers (m) - Kviscosity, & ! (in) Original viscosity (m2/s) - Kdiffusivity(:,1), & ! (in) Original heat diffusivity (m2/s) - Kdiffusivity(:,2), & ! (in) Original salt diffusivity (m2/s) - OBLdepth_0d, & ! (in) OBL depth (m) - kOBL, & ! (in) level (+fraction) of OBL extent - nonLocalTrans(:,1),& ! (out) Non-local heat transport (non-dimensional) - nonLocalTrans(:,2),& ! (out) Non-local salt transport (non-dimensional) - surfFricVel, & ! (in) Turbulent friction velocity at surface (m/s) - surfBuoyFlux, & ! (in) Buoyancy flux at surface (m2/s3) - G%ke, & ! (in) Number of levels to compute coeffs for - G%ke, & ! (in) Number of levels in array shape - CVMix_kpp_params_user=CS%KPP_params ) - - IF (CS%LT_K_ENHANCEMENT) then - if (CS%LT_K_METHOD==LT_K_MODE_CONSTANT) then - LangEnhK = CS%KPP_K_ENH_FAC - elseif (CS%LT_K_METHOD==LT_K_MODE_VR12) then - LangEnhK = min(10.,sqrt(1.+(1.5*WAVES%LangNum(i,j))**(-2) + & - (5.4*WAVES%LangNum(i,j))**(-4))) - elseif (CS%LT_K_METHOD==LT_K_MODE_RW16) then - LangEnhK = min(2.25, 1. + 1./WAVES%LangNum(i,j)) - else - !This shouldn't be reached. - !call MOM_error(WARNING,"Unexpected behavior in MOM_KPP, see error in LT_K_ENHANCEMENT") - LangEnhK = 1.0 - endif - do k=1,G%ke - if (CS%LT_K_SHAPE== LT_K_CONSTANT) then - if (CS%id_EnhK > 0) CS%EnhK(i,j,:) = LangEnhK - Kdiffusivity(k,1) = Kdiffusivity(k,1) * LangEnhK - Kdiffusivity(k,2) = Kdiffusivity(k,2) * LangEnhK - Kviscosity(k) = Kviscosity(k) * LangEnhK - elseif (CS%LT_K_SHAPE == LT_K_SCALED) then - sigma = min(1.0,-iFaceHeight(k)/OBLdepth_0d) - SigmaRatio = sigma * (1. - sigma)**2. / 0.148148037 - if (CS%id_EnhK > 0) CS%EnhK(i,j,k) = (1.0 + (LangEnhK - 1.)*sigmaRatio) - Kdiffusivity(k,1) = Kdiffusivity(k,1) * ( 1. + & - ( LangEnhK - 1.)*sigmaRatio) - Kdiffusivity(k,2) = Kdiffusivity(k,2) * ( 1. + & - ( LangEnhK - 1.)*sigmaRatio) - Kviscosity(k) = Kviscosity(k) * ( 1. + & - ( LangEnhK - 1.)*sigmaRatio) - endif - enddo - endif - - ! Over-write CVMix NLT shape function with one of the following choices. - ! The CVMix code has yet to update for thse options, so we compute in MOM6. - ! Note that nonLocalTrans = Cs * G(sigma) (LMD94 notation), with - ! Cs = 6.32739901508. - ! Start do-loop at k=2, since k=1 is ocean surface (sigma=0) - ! and we do not wish to double-count the surface forcing. - ! Only compute nonlocal transport for 0 <= sigma <= 1. - ! MOM6 recommended shape is the parabolic; it gives deeper boundary layer - ! and no spurious extrema. - if (surfBuoyFlux < 0.0) then - if (CS%NLT_shape == NLT_SHAPE_CUBIC) then - do k = 2, G%ke - sigma = min(1.0,-iFaceHeight(k)/OBLdepth_0d) - nonLocalTrans(k,1) = (1.0 - sigma)**2 * (1.0 + 2.0*sigma) !* - nonLocalTrans(k,2) = nonLocalTrans(k,1) - enddo - elseif (CS%NLT_shape == NLT_SHAPE_PARABOLIC) then - do k = 2, G%ke - sigma = min(1.0,-iFaceHeight(k)/OBLdepth_0d) - nonLocalTrans(k,1) = (1.0 - sigma)**2 !*CS%CS2 - nonLocalTrans(k,2) = nonLocalTrans(k,1) - enddo - elseif (CS%NLT_shape == NLT_SHAPE_LINEAR) then - do k = 2, G%ke - sigma = min(1.0,-iFaceHeight(k)/OBLdepth_0d) - nonLocalTrans(k,1) = (1.0 - sigma)!*CS%CS2 - nonLocalTrans(k,2) = nonLocalTrans(k,1) - enddo - elseif (CS%NLT_shape == NLT_SHAPE_CUBIC_LMD) then - ! Sanity check (should agree with CVMix result using simple matching) - do k = 2, G%ke - sigma = min(1.0,-iFaceHeight(k)/OBLdepth_0d) - nonLocalTrans(k,1) = CS%CS2 * sigma*(1.0 -sigma)**2 - nonLocalTrans(k,2) = nonLocalTrans(k,1) - enddo - endif - endif - - ! we apply nonLocalTrans in subroutines - ! KPP_NonLocalTransport_temp and KPP_NonLocalTransport_saln - nonLocalTransHeat(i,j,:) = nonLocalTrans(:,1) ! temp - nonLocalTransScalar(i,j,:) = nonLocalTrans(:,2) ! saln - - ! set the KPP diffusivity and viscosity to zero for testing purposes - if(CS%KPPzeroDiffusivity) then - Kdiffusivity(:,1) = 0.0 - Kdiffusivity(:,2) = 0.0 - Kviscosity(:) = 0.0 - endif - ! recompute wscale for diagnostics, now that we in fact know boundary layer depth !BGR consider if LTEnhancement is wanted for diagnostics if (CS%id_Ws > 0) then - call CVmix_kpp_compute_turbulent_scales( & - -CellHeight/OBLdepth_0d, & ! (in) Normalized boundary layer coordinate - OBLdepth_0d, & ! (in) OBL depth (m) - surfBuoyFlux, & ! (in) Buoyancy flux at surface (m2/s3) - surfFricVel, & ! (in) Turbulent friction velocity at surface (m/s) - w_s=Ws_1d, & ! (out) Turbulent velocity scale profile (m/s) - CVmix_kpp_params_user=CS%KPP_params) ! KPP parameters + call CVMix_kpp_compute_turbulent_scales( & + -CellHeight/CS%OBLdepth(i,j), & ! (in) Normalized boundary layer coordinate + CS%OBLdepth(i,j), & ! (in) OBL depth [m] + surfBuoyFlux, & ! (in) Buoyancy flux at surface [m2 s-3] + surfFricVel, & ! (in) Turbulent friction velocity at surface [m s-1] + w_s=Ws_1d, & ! (out) Turbulent velocity scale profile [m s-1] + CVMix_kpp_params_user=CS%KPP_params) ! KPP parameters CS%Ws(i,j,:) = Ws_1d(:) endif - ! compute unresolved squared velocity for diagnostics - if (CS%id_Vt2 > 0) then -!BGR Now computing VT2 above so can modify for LT -! therefore, don't repeat this operation here -! Vt2_1d(:) = CVmix_kpp_compute_unresolved_shear( & -! cellHeight(1:G%ke), & ! Depth of cell center (m) -! ws_cntr=Ws_1d, & ! Turbulent velocity scale profile, at centers (m/s) -! N_iface=N_1d, & ! Buoyancy frequency at interface (1/s) -! CVmix_kpp_params_user=CS%KPP_params ) ! KPP parameters - CS%Vt2(i,j,:) = Vt2_1d(:) - endif - - ! Copy 1d data into 3d diagnostic arrays - !/ grabbing obldepth_0d for next time step. - CS%OBLdepthprev(i,j)=OBLdepth_0d - !\ this can replace the other and be allocated independent of diagnostic output - if (CS%id_OBLdepth > 0) CS%OBLdepth(i,j) = OBLdepth_0d + ! Diagnostics + if (CS%id_N2 > 0) CS%N2(i,j,:) = N2_1d(:) if (CS%id_BulkDrho > 0) CS%dRho(i,j,:) = deltaRho(:) - if (CS%id_BulkUz2 > 0) CS%Uz2(i,j,:) = deltaU2(:) if (CS%id_BulkRi > 0) CS%BulkRi(i,j,:) = BulkRi_1d(:) - if (CS%id_sigma > 0) then - CS%sigma(i,j,:) = 0. - if (OBLdepth_0d>0.) CS%sigma(i,j,:) = -iFaceHeight/OBLdepth_0d - endif - if (CS%id_N > 0) CS%N(i,j,:) = N_1d(:) - if (CS%id_N2 > 0) CS%N2(i,j,:) = N2_1d(:) - if (CS%id_Kt_KPP > 0) CS%Kt_KPP(i,j,:) = Kdiffusivity(:,1) - if (CS%id_Ks_KPP > 0) CS%Ks_KPP(i,j,:) = Kdiffusivity(:,2) - if (CS%id_Kv_KPP > 0) CS%Kv_KPP(i,j,:) = Kviscosity(:) + if (CS%id_BulkUz2 > 0) CS%Uz2(i,j,:) = deltaU2(:) if (CS%id_Tsurf > 0) CS%Tsurf(i,j) = surfTemp if (CS%id_Ssurf > 0) CS%Ssurf(i,j) = surfSalt if (CS%id_Usurf > 0) CS%Usurf(i,j) = surfU if (CS%id_Vsurf > 0) CS%Vsurf(i,j) = surfv - ! Update output of routine - if (.not. CS%passiveMode) then - if (CS%KPPisAdditive) then - do k=1, G%ke+1 - Kt(i,j,k) = Kt(i,j,k) + Kdiffusivity(k,1) - Ks(i,j,k) = Ks(i,j,k) + Kdiffusivity(k,2) - Kv(i,j,k) = Kv(i,j,k) + Kviscosity(k) - if (CS%Stokes_Mixing) Waves%KvS(i,j,k)=Kv(i,j,k) - enddo - else ! KPP replaces prior diffusivity when former is non-zero - do k=1, G%ke+1 - if (Kdiffusivity(k,1) /= 0.) Kt(i,j,k) = Kdiffusivity(k,1) - if (Kdiffusivity(k,2) /= 0.) Ks(i,j,k) = Kdiffusivity(k,2) - if (Kviscosity(k) /= 0.) Kv(i,j,k) = Kviscosity(k) - if (CS%Stokes_Mixing) Waves%KvS(i,j,k)=Kv(i,j,k) - enddo - endif - endif - - - ! end of the horizontal do-loops over the vertical columns - enddo ! i - enddo ! j - - -#ifdef __DO_SAFETY_CHECKS__ - if (CS%debug) then - call hchksum(Kt, "KPP out: Kt",G%HI,haloshift=0) - call hchksum(Ks, "KPP out: Ks",G%HI,haloshift=0) - endif -#endif + enddo + enddo ! send diagnostics to post_data - if (CS%id_OBLdepth > 0) call post_data(CS%id_OBLdepth, CS%OBLdepth, CS%diag) - if (CS%id_BulkDrho > 0) call post_data(CS%id_BulkDrho, CS%dRho, CS%diag) - if (CS%id_BulkUz2 > 0) call post_data(CS%id_BulkUz2, CS%Uz2, CS%diag) if (CS%id_BulkRi > 0) call post_data(CS%id_BulkRi, CS%BulkRi, CS%diag) - if (CS%id_sigma > 0) call post_data(CS%id_sigma, CS%sigma, CS%diag) - if (CS%id_Ws > 0) call post_data(CS%id_Ws, CS%Ws, CS%diag) if (CS%id_N > 0) call post_data(CS%id_N, CS%N, CS%diag) if (CS%id_N2 > 0) call post_data(CS%id_N2, CS%N2, CS%diag) - if (CS%id_Vt2 > 0) call post_data(CS%id_Vt2, CS%Vt2, CS%diag) - if (CS%id_uStar > 0) call post_data(CS%id_uStar, uStar, CS%diag) - if (CS%id_buoyFlux > 0) call post_data(CS%id_buoyFlux, buoyFlux, CS%diag) - if (CS%id_Kt_KPP > 0) call post_data(CS%id_Kt_KPP, CS%Kt_KPP, CS%diag) - if (CS%id_Ks_KPP > 0) call post_data(CS%id_Ks_KPP, CS%Ks_KPP, CS%diag) - if (CS%id_Kv_KPP > 0) call post_data(CS%id_Kv_KPP, CS%Kv_KPP, CS%diag) - if (CS%id_NLTt > 0) call post_data(CS%id_NLTt, nonLocalTransHeat, CS%diag) - if (CS%id_NLTs > 0) call post_data(CS%id_NLTs, nonLocalTransScalar,CS%diag) if (CS%id_Tsurf > 0) call post_data(CS%id_Tsurf, CS%Tsurf, CS%diag) if (CS%id_Ssurf > 0) call post_data(CS%id_Ssurf, CS%Ssurf, CS%diag) if (CS%id_Usurf > 0) call post_data(CS%id_Usurf, CS%Usurf, CS%diag) if (CS%id_Vsurf > 0) call post_data(CS%id_Vsurf, CS%Vsurf, CS%diag) + if (CS%id_BulkDrho > 0) call post_data(CS%id_BulkDrho, CS%dRho, CS%diag) + 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 + + ! BLD smoothing: + if (CS%n_smooth > 0) call KPP_smooth_BLD(CS,G,GV,h) + +end subroutine KPP_compute_BLD + + +!> Apply a 1-1-4-1-1 Laplacian filter one time on BLD to reduce any horizontal two-grid-point noise +subroutine KPP_smooth_BLD(CS,G,GV,h) + ! Arguments + type(KPP_CS), pointer :: CS !< Control structure + type(ocean_grid_type), intent(inout) :: G !< Ocean grid + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer/level thicknesses [H ~> m or kg m-2] + + ! local + real, dimension(SZI_(G),SZJ_(G)) :: OBLdepth_original ! Original OBL depths computed by CVMix + real, dimension( G%ke ) :: cellHeight ! Cell center heights referenced to surface [m] + ! (negative in the ocean) + real, dimension( G%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface [m] + ! (negative in the ocean) + real :: wc, ww, we, wn, ws ! averaging weights for smoothing + real :: dh ! The local thickness used for calculating interface positions [m] + real :: hcorr ! A cumulative correction arising from inflation of vanished layers [m] + real :: pref + integer :: i, j, k, s + + do s=1,CS%n_smooth + + ! Update halos + call pass_var(CS%OBLdepth, G%Domain) + + OBLdepth_original = CS%OBLdepth + if (CS%id_OBLdepth_original > 0) CS%OBLdepth_original = OBLdepth_original + + ! apply smoothing on OBL depth + do j = G%jsc, G%jec + do i = G%isc, G%iec + + ! skip land points + if (G%mask2dT(i,j)==0.) cycle + + iFaceHeight(1) = 0.0 ! BBL is all relative to the surface + pRef = 0. + hcorr = 0. + do k=1,G%ke + + ! cell center and cell bottom in meters (negative values in the ocean) + dh = h(i,j,k) * GV%H_to_m ! Nominal thickness to use for increment + dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) + hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 + dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness + cellHeight(k) = iFaceHeight(k) - 0.5 * dh + iFaceHeight(k+1) = iFaceHeight(k) - dh + enddo + + ! compute weights + ww = 0.125 * G%mask2dT(i-1,j) + we = 0.125 * G%mask2dT(i+1,j) + ws = 0.125 * G%mask2dT(i,j-1) + wn = 0.125 * G%mask2dT(i,j+1) + wc = 1.0 - (ww+we+wn+ws) + + CS%OBLdepth(i,j) = wc * OBLdepth_original(i,j) & + + ww * OBLdepth_original(i-1,j) & + + we * OBLdepth_original(i+1,j) & + + ws * OBLdepth_original(i,j-1) & + + wn * OBLdepth_original(i,j+1) + + ! Apply OBLdepth smoothing at a cell only if the OBLdepth gets deeper via smoothing. + if (CS%deepen_only) CS%OBLdepth(i,j) = max(CS%OBLdepth(i,j),CS%OBLdepth_original(i,j)) + + ! prevent OBL depths deeper than the bathymetric depth + CS%OBLdepth(i,j) = min( CS%OBLdepth(i,j), -iFaceHeight(G%ke+1) ) ! no deeper than bottom + CS%kOBL(i,j) = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, CS%OBLdepth(i,j) ) + enddo + enddo + + enddo ! s-loop + + ! Update kOBL for smoothed OBL depths + do j = G%jsc, G%jec + do i = G%isc, G%iec + + ! skip land points + if (G%mask2dT(i,j)==0.) cycle + + iFaceHeight(1) = 0.0 ! BBL is all relative to the surface + hcorr = 0. + do k=1,G%ke + + ! cell center and cell bottom in meters (negative values in the ocean) + dh = h(i,j,k) * GV%H_to_m ! Nominal thickness to use for increment + dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) + hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 + dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness + cellHeight(k) = iFaceHeight(k) - 0.5 * dh + iFaceHeight(k+1) = iFaceHeight(k) - dh + enddo + + CS%kOBL(i,j) = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, CS%OBLdepth(i,j) ) + + enddo + enddo + +end subroutine KPP_smooth_BLD -end subroutine KPP_calculate !> Copies KPP surface boundary layer depth into BLD subroutine KPP_get_BLD(CS, BLD, G) type(KPP_CS), pointer :: CS !< Control structure for !! this module type(ocean_grid_type), intent(in) :: G !< Grid structure - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: BLD!< bnd. layer depth (m) + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: BLD!< bnd. layer depth [m] ! Local variables integer :: i,j do j = G%jsc, G%jec ; do i = G%isc, G%iec @@ -1197,15 +1445,16 @@ end subroutine KPP_get_BLD subroutine KPP_NonLocalTransport_temp(CS, G, GV, h, nonLocalTrans, surfFlux, & dt, scalar, C_p) - type(KPP_CS), intent(in) :: CS !< Control structure - type(ocean_grid_type), intent(in) :: G !< Ocean grid - type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer/level thickness (units of H) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: nonLocalTrans !< Non-local transport (non-dimensional) - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: surfFlux !< Surface flux of scalar (H/s * scalar) - real, intent(in) :: dt !< Time-step (s) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: scalar !< temperature - real, intent(in) :: C_p !< Seawater specific heat capacity (J/(kg*K)) + type(KPP_CS), intent(in) :: CS !< Control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer/level thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: nonLocalTrans !< Non-local transport [nondim] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: surfFlux !< Surface flux of scalar + !! [conc H s-1 ~> conc m s-1 or conc kg m-2 s-1] + real, intent(in) :: dt !< Time-step [s] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: scalar !< temperature + real, intent(in) :: C_p !< Seawater specific heat capacity [J kg-1 degC-1] integer :: i, j, k real, dimension( SZI_(G), SZJ_(G), SZK_(G) ) :: dtracer @@ -1259,11 +1508,12 @@ subroutine KPP_NonLocalTransport_saln(CS, G, GV, h, nonLocalTrans, surfFlux, dt, type(KPP_CS), intent(in) :: CS !< Control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer/level thickness (units of H) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: nonLocalTrans !< Non-local transport (non-dimensional) - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: surfFlux !< Surface flux of scalar (H/s * scalar) - real, intent(in) :: dt !< Time-step (s) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: scalar !< Scalar (scalar units) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer/level thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: nonLocalTrans !< Non-local transport [nondim] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: surfFlux !< Surface flux of scalar + !! [conc H s-1 ~> conc m s-1 or conc kg m-2 s-1] + real, intent(in) :: dt !< Time-step [s] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: scalar !< Scalar (scalar units [conc]) integer :: i, j, k real, dimension( SZI_(G), SZJ_(G), SZK_(G) ) :: dtracer @@ -1322,7 +1572,7 @@ subroutine KPP_end(CS) end subroutine KPP_end -!> \namespace mom_kpp +!> \namespace mom_cvmix_kpp !! !! \section section_KPP The K-Profile Parameterization !! @@ -1331,7 +1581,7 @@ end subroutine KPP_end !! which is called directly by this module. !! !! The formulation and implementation of KPP is described in great detail in the -!! [CVMix manual](https://github.com/CVMix/CVMix-description/raw/master/cvmix.pdf) (written by our own Stephen Griffies). +!! [CVMix manual](https://github.com/CVMix/CVMix-description/raw/master/cvmix.pdf) (written by our own Steve Griffies). !! !! \subsection section_KPP_nutshell KPP in a nutshell !! @@ -1348,11 +1598,13 @@ end subroutine KPP_end !! Instead, the entire non-local transport term can be equivalently written !! \f[ K \gamma_s(\sigma) = C_s G(\sigma) Q_s \f] !! where \f$ Q_s \f$ is the surface flux of \f$ s \f$ and \f$ C_s \f$ is a constant. -!! The vertical structure of the redistribution (non-local) term is solely due to the shape function, \f$ G(\sigma) \f$. +!! The vertical structure of the redistribution (non-local) term is solely due to the shape function, +!! \f$ G(\sigma) \f$. !! In our implementation of KPP, we allow the shape functions used for \f$ K \f$ and for the non-local transport !! to be chosen independently. !! -!! [google_thread_NLT]: https://groups.google.com/forum/#!msg/CVMix-dev/i6rF-eHOtKI/Ti8BeyksrhAJ "Extreme values of non-local transport" +!! [google_thread_NLT]: https://groups.google.com/forum/#!msg/CVMix-dev/i6rF-eHOtKI/Ti8BeyksrhAJ +!! "Extreme values of non-local transport" !! !! The particular shape function most widely used in the atmospheric community is !! \f[ G(\sigma) = \sigma (1-\sigma)^2 \f] @@ -1362,7 +1614,8 @@ end subroutine KPP_end !! \f$ G^\prime(0) = 1 \f$, and !! \f$ G^\prime(1) = 0 \f$. !! Large et al, 1994, alter the function so as to match interior diffusivities but we have found that this leads -!! to inconsistencies within the formulation (see google groups thread [Extreme values of non-local transport][google_thread_NLT]). +!! to inconsistencies within the formulation (see google groups thread +!! [Extreme values of non-local transport][google_thread_NLT]). !! Instead, we use either the above form, or even simpler forms that use alternative upper boundary conditions. !! !! The KPP boundary layer depth is a function of the bulk Richardson number, Rib. @@ -1376,4 +1629,4 @@ end subroutine KPP_end !! !! \sa !! kpp_calculate(), kpp_applynonlocaltransport() -end module MOM_KPP +end module MOM_CVMix_KPP diff --git a/src/parameterizations/vertical/MOM_CVMix_conv.F90 b/src/parameterizations/vertical/MOM_CVMix_conv.F90 index 4b422ccf9a..19327cd007 100644 --- a/src/parameterizations/vertical/MOM_CVMix_conv.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_conv.F90 @@ -3,16 +3,17 @@ module MOM_CVMix_conv ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_debugging, only : hchksum use MOM_diag_mediator, only : diag_ctrl, time_type, register_diag_field use MOM_diag_mediator, only : post_data use MOM_EOS, only : calculate_density -use MOM_variables, only : thermo_var_ptrs use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE use MOM_file_parser, only : openParameterBlock, closeParameterBlock -use MOM_debugging, only : hchksum +use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use MOM_file_parser, only : get_param, log_version, param_file_type use CVMix_convection, only : CVMix_init_conv, CVMix_coeffs_conv use CVMix_kpp, only : CVMix_kpp_compute_kOBL_depth @@ -26,21 +27,23 @@ module MOM_CVMix_conv type, public :: CVMix_conv_cs ! Parameters - real :: kd_conv_const !< diffusivity constant used in convective regime (m2/s) - real :: kv_conv_const !< viscosity constant used in convective regime (m2/s) + real :: kd_conv_const !< diffusivity constant used in convective regime [m2 s-1] + real :: kv_conv_const !< viscosity constant used in convective regime [m2 s-1] real :: bv_sqr_conv !< Threshold for squared buoyancy frequency - !! needed to trigger Brunt-Vaisala parameterization (1/s^2) - real :: min_thickness !< Minimum thickness allowed (m) + !! needed to trigger Brunt-Vaisala parameterization [s-2] + real :: min_thickness !< Minimum thickness allowed [m] logical :: debug !< If true, turn on debugging ! Daignostic handles and pointers - type(diag_ctrl), pointer :: diag => NULL() + type(diag_ctrl), pointer :: diag => NULL() !< Pointer to diagnostics control structure + !>@{ Diagnostics handles integer :: id_N2 = -1, id_kd_conv = -1, id_kv_conv = -1 + !!@} ! Diagnostics arrays - real, allocatable, dimension(:,:,:) :: N2 !< Squared Brunt-Vaisala frequency (1/s2) - real, allocatable, dimension(:,:,:) :: kd_conv !< Diffusivity added by convection (m2/s) - real, allocatable, dimension(:,:,:) :: kv_conv !< Viscosity added by convection (m2/s) + real, allocatable, dimension(:,:,:) :: N2 !< Squared Brunt-Vaisala frequency [s-2] + real, allocatable, dimension(:,:,:) :: kd_conv !< Diffusivity added by convection [m2 s-1] + real, allocatable, dimension(:,:,:) :: kv_conv !< Viscosity added by convection [m2 s-1] end type CVMix_conv_cs @@ -49,15 +52,15 @@ module MOM_CVMix_conv contains !> Initialized the CVMix convection mixing routine. -logical function CVMix_conv_init(Time, G, GV, param_file, diag, CS) +logical function CVMix_conv_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(CVMix_conv_cs), pointer :: CS !< This module's control structure. - + type(CVMix_conv_cs), pointer :: CS !< This module's control structure. ! Local variables real :: prandtl_conv !< Turbulent Prandtl number used in convective instabilities. logical :: useEPBL !< If True, use the ePBL boundary layer scheme. @@ -131,9 +134,9 @@ logical function CVMix_conv_init(Time, G, GV, param_file, diag, CS) CS%id_N2 = register_diag_field('ocean_model', 'N2_conv', diag%axesTi, Time, & 'Square of Brunt-Vaisala frequency used by MOM_CVMix_conv module', '1/s2') CS%id_kd_conv = register_diag_field('ocean_model', 'kd_conv', diag%axesTi, Time, & - 'Additional diffusivity added by MOM_CVMix_conv module', 'm2/s') + 'Additional diffusivity added by MOM_CVMix_conv module', 'm2/s', conversion=US%Z_to_m**2) CS%id_kv_conv = register_diag_field('ocean_model', 'kv_conv', diag%axesTi, Time, & - 'Additional viscosity added by MOM_CVMix_conv module', 'm2/s') + 'Additional viscosity added by MOM_CVMix_conv module', 'm2/s', conversion=US%Z_to_m**2) call CVMix_init_conv(convect_diff=CS%kd_conv_const, & convect_visc=CS%kv_conv_const, & @@ -144,35 +147,37 @@ end function CVMix_conv_init !> Subroutine for calculating enhanced diffusivity/viscosity !! due to convection via CVMix -subroutine calculate_CVMix_conv(h, tv, G, GV, CS, hbl) +subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl) type(ocean_grid_type), intent(in) :: G !< Grid structure. type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness, in m or kg m-2. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + 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. type(CVMix_conv_cs), pointer :: CS !< The control structure returned !! by a previous call to CVMix_conv_init. - real, dimension(:,:), optional, pointer :: hbl!< Depth of ocean boundary layer (m) - + real, dimension(:,:), optional, pointer :: hbl!< Depth of ocean boundary layer [m] ! local variables real, dimension(SZK_(G)) :: rho_lwr !< Adiabatic Water Density, this is a dummy !! variable since here convection is always !! computed based on Brunt Vaisala. real, dimension(SZK_(G)) :: rho_1d !< water density in a column, this is also !! a dummy variable, same reason as above. - real, dimension(SZK_(G)+1) :: iFaceHeight !< Height of interfaces (m) - real, dimension(SZK_(G)) :: cellHeight !< Height of cell centers (m) + real, dimension(SZK_(G)+1) :: kv_col !< Viscosities at interfaces in the column [m2 s-1] + real, dimension(SZK_(G)+1) :: kd_col !< Diffusivities at interfaces in the column [m2 s-1] + real, dimension(SZK_(G)+1) :: iFaceHeight !< Height of interfaces [m] + real, dimension(SZK_(G)) :: cellHeight !< Height of cell centers [m] integer :: kOBL !< level of OBL extent real :: pref, g_o_rho0, rhok, rhokm1, dz, dh, hcorr integer :: i, j, k - g_o_rho0 = GV%g_Earth / GV%Rho0 + g_o_rho0 = (GV%g_Earth*US%m_to_Z) / GV%Rho0 ! initialize dummy variables rho_lwr(:) = 0.0; rho_1d(:) = 0.0 if (.not. associated(hbl)) then - allocate(hbl(SZI_(G), SZJ_(G))); + allocate(hbl(SZI_(G), SZJ_(G))) hbl(:,:) = 0.0 endif @@ -212,10 +217,12 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, CS, hbl) iFaceHeight(k+1) = iFaceHeight(k) - dh enddo + ! gets index of the level and interface above hbl kOBL = CVMix_kpp_compute_kOBL_depth(iFaceHeight, cellHeight,hbl(i,j)) - call CVMix_coeffs_conv(Mdiff_out=CS%kv_conv(i,j,:), & - Tdiff_out=CS%kd_conv(i,j,:), & + kv_col(:) = 0.0 ; kd_col(:) = 0.0 + call CVMix_coeffs_conv(Mdiff_out=kv_col(:), & + Tdiff_out=kd_col(:), & Nsqr=CS%N2(i,j,:), & dens=rho_1d(:), & dens_lwr=rho_lwr(:), & @@ -223,11 +230,15 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, CS, hbl) max_nlev=G%ke, & OBL_ind=kOBL) - ! Do not apply mixing due to convection within the boundary layer - do k=1,kOBL - CS%kv_conv(i,j,k) = 0.0 - CS%kd_conv(i,j,k) = 0.0 - enddo + do K=1,G%ke+1 + CS%kv_conv(i,j,K) = US%m_to_Z**2 * kv_col(K) + CS%kd_conv(i,j,K) = US%m_to_Z**2 * kd_col(K) + enddo + ! Do not apply mixing due to convection within the boundary layer + do k=1,kOBL + CS%kv_conv(i,j,k) = 0.0 + CS%kd_conv(i,j,k) = 0.0 + enddo enddo enddo @@ -257,7 +268,10 @@ end function CVMix_conv_is_used !> Clear pointers and dealocate memory subroutine CVMix_conv_end(CS) - type(CVMix_conv_cs), pointer :: CS ! Control structure + type(CVMix_conv_cs), pointer :: CS !< Control structure for this module that + !! will be deallocated in this subroutine + + if (.not. associated(CS)) return deallocate(CS%N2) deallocate(CS%kd_conv) @@ -266,5 +280,4 @@ subroutine CVMix_conv_end(CS) end subroutine CVMix_conv_end - end module MOM_CVMix_conv diff --git a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 new file mode 100644 index 0000000000..0e80f166c5 --- /dev/null +++ b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 @@ -0,0 +1,311 @@ +!> Interface to CVMix double diffusion scheme. +module MOM_CVMix_ddiff + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_diag_mediator, only : diag_ctrl, time_type, register_diag_field +use MOM_diag_mediator, only : post_data +use MOM_EOS, only : calculate_density_derivs +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_version, param_file_type +use MOM_debugging, only : hchksum +use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use cvmix_ddiff, only : cvmix_init_ddiff, CVMix_coeffs_ddiff +use cvmix_kpp, only : CVmix_kpp_compute_kOBL_depth +implicit none ; private + +#include + +public CVMix_ddiff_init, CVMix_ddiff_end, CVMix_ddiff_is_used, compute_ddiff_coeffs + +!> Control structure including parameters for CVMix double diffusion. +type, public :: CVMix_ddiff_cs + + ! Parameters + real :: strat_param_max !< maximum value for the stratification parameter [nondim] + real :: kappa_ddiff_s !< leading coefficient in formula for salt-fingering regime + !! for salinity diffusion [m2 s-1] + real :: ddiff_exp1 !< interior exponent in salt-fingering regime formula [nondim] + real :: ddiff_exp2 !< exterior exponent in salt-fingering regime formula [nondim] + real :: mol_diff !< molecular diffusivity [m2 s-1] + real :: kappa_ddiff_param1 !< exterior coefficient in diffusive convection regime [nondim] + real :: kappa_ddiff_param2 !< middle coefficient in diffusive convection regime [nondim] + real :: kappa_ddiff_param3 !< interior coefficient in diffusive convection regime [nondim] + real :: min_thickness !< Minimum thickness allowed [m] + character(len=4) :: diff_conv_type !< type of diffusive convection to use. Options are Marmorino & + !! Caldwell 1976 ("MC76"; default) and Kelley 1988, 1990 ("K90") + logical :: debug !< If true, turn on debugging + + ! Daignostic handles and pointers + type(diag_ctrl), pointer :: diag => NULL() !< Pointer to diagnostics control structure + !>@{ Diagnostics handles + integer :: id_KT_extra = -1, id_KS_extra = -1, id_R_rho = -1 + !!@} + + ! Diagnostics arrays +! real, allocatable, dimension(:,:,:) :: KT_extra !< Double diffusion diffusivity for temp [Z2 s-1 ~> m2 s-1] +! real, allocatable, dimension(:,:,:) :: KS_extra !< Double diffusion diffusivity for salt [Z2 s-1 ~> m2 s-1] + real, allocatable, dimension(:,:,:) :: R_rho !< Double-diffusion density ratio [nondim] + +end type CVMix_ddiff_cs + +character(len=40) :: mdl = "MOM_CVMix_ddiff" !< This module's name. + +contains + +!> Initialized the CVMix double diffusion module. +logical function CVMix_ddiff_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(CVMix_ddiff_cs), pointer :: CS !< This module's control structure. + +! This include declares and sets the variable "version". +#include "version_variable.h" + + if (associated(CS)) then + call MOM_error(WARNING, "CVMix_ddiff_init called with an associated "// & + "control structure.") + return + endif + allocate(CS) + + ! Read parameters + 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.",& + default=.false.) + + if (.not. CVMix_ddiff_init) return + + call get_param(param_file, mdl, 'DEBUG', CS%debug, default=.False., do_not_log=.True.) + + call get_param(param_file, mdl, 'MIN_THICKNESS', CS%min_thickness, default=0.001, do_not_log=.True.) + + call openParameterBlock(param_file,'CVMIX_DDIFF') + + call get_param(param_file, mdl, "STRAT_PARAM_MAX", CS%strat_param_max, & + "The maximum value for the double dissusion stratification parameter", & + 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"// & + "for salinity diffusion.", units="m2 s-1", default=1.0e-4) + + call get_param(param_file, mdl, "DDIFF_EXP1", CS%ddiff_exp1, & + "Interior exponent in salt-fingering regime formula.", & + units="nondim", default=1.0) + + call get_param(param_file, mdl, "DDIFF_EXP2", CS%ddiff_exp2, & + "Exterior exponent in salt-fingering regime formula.", & + units="nondim", default=3.0) + + call get_param(param_file, mdl, "KAPPA_DDIFF_PARAM1", CS%kappa_ddiff_param1, & + "Exterior coefficient in diffusive convection regime.", & + units="nondim", default=0.909) + + call get_param(param_file, mdl, "KAPPA_DDIFF_PARAM2", CS%kappa_ddiff_param2, & + "Middle coefficient in diffusive convection regime.", & + units="nondim", default=4.6) + + call get_param(param_file, mdl, "KAPPA_DDIFF_PARAM3", CS%kappa_ddiff_param3, & + "Interior coefficient in diffusive convection regime.", & + units="nondim", default=-0.54) + + call get_param(param_file, mdl, "MOL_DIFF", CS%mol_diff, & + "Molecular diffusivity used in CVMix double diffusion.", & + units="m2 s-1", default=1.5e-6) + + call get_param(param_file, mdl, "DIFF_CONV_TYPE", CS%diff_conv_type, & + "type of diffusive convection to use. Options are Marmorino \n" //& + "and Caldwell 1976 (MC76) and Kelley 1988, 1990 (K90).", & + default="MC76") + + call closeParameterBlock(param_file) + + ! Register diagnostics + CS%diag => diag + + 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) + + 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) + + CS%id_R_rho = register_diag_field('ocean_model','R_rho',diag%axesTi,Time, & + 'Double-diffusion density ratio', 'nondim') + if (CS%id_R_rho > 0) & + allocate(CS%R_rho( SZI_(G), SZJ_(G), SZK_(G)+1)); CS%R_rho(:,:,:) = 0.0 + + call cvmix_init_ddiff(strat_param_max=CS%strat_param_max, & + kappa_ddiff_s=CS%kappa_ddiff_s, & + ddiff_exp1=CS%ddiff_exp1, & + ddiff_exp2=CS%ddiff_exp2, & + mol_diff=CS%mol_diff, & + kappa_ddiff_param1=CS%kappa_ddiff_param1, & + kappa_ddiff_param2=CS%kappa_ddiff_param2, & + kappa_ddiff_param3=CS%kappa_ddiff_param3, & + diff_conv_type=CS%diff_conv_type) + +end function CVMix_ddiff_init + +!> Subroutine for computing vertical diffusion coefficients for the +!! double diffusion mixing parameterization. +subroutine compute_ddiff_coeffs(h, tv, G, GV, US, j, Kd_T, Kd_S, CS) + + 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 + 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),SZJ_(G),SZK_(G)+1), intent(out) :: Kd_T !< Interface double diffusion diapycnal + !! diffusivity for temp [Z2 s-1 ~> m2 s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(out) :: Kd_S !< Interface double diffusion diapycnal + !! diffusivity for salt [Z2 s-1 ~> m2 s-1]. + type(CVMix_ddiff_cs), pointer :: CS !< The control structure returned + !! by a previous call to CVMix_ddiff_init. + integer, intent(in) :: j !< Meridional grid indice. + ! Local variables + real, dimension(SZK_(G)) :: & + cellHeight, & !< Height of cell centers [m] + dRho_dT, & !< partial derivatives of density wrt temp [kg m-3 degC-1] + dRho_dS, & !< partial derivatives of density wrt saln [kg m-3 ppt-1] + pres_int, & !< pressure at each interface [Pa] + temp_int, & !< temp and at interfaces [degC] + salt_int, & !< salt at at interfaces [ppt] + alpha_dT, & !< alpha*dT across interfaces + beta_dS, & !< beta*dS across interfaces + dT, & !< temp. difference between adjacent layers [degC] + dS !< salt difference between adjacent layers [ppt] + real, dimension(SZK_(G)+1) :: & + Kd1_T, & !< Diapycanal diffusivity of temperature [m2 s-1]. + Kd1_S !< Diapycanal diffusivity of salinity [m2 s-1]. + + real, dimension(SZK_(G)+1) :: iFaceHeight !< Height of interfaces [m] + integer :: kOBL !< level of OBL extent + real :: pref, g_o_rho0, rhok, rhokm1, dz, dh, hcorr + integer :: i, k + + ! initialize dummy variables + pres_int(:) = 0.0; temp_int(:) = 0.0; salt_int(:) = 0.0 + alpha_dT(:) = 0.0; beta_dS(:) = 0.0; dRho_dT(:) = 0.0 + dRho_dS(:) = 0.0; dT(:) = 0.0; dS(:) = 0.0 + + + ! GMM, I am leaving some code commented below. We need to pass BLD to + ! this soubroutine to avoid adding diffusivity above that. This needs + ! to be done once we re-structure the order of the calls. + !if (.not. associated(hbl)) then + ! allocate(hbl(SZI_(G), SZJ_(G))); + ! hbl(:,:) = 0.0 + !endif + + do i = G%isc, G%iec + + ! skip calling at land points + if (G%mask2dT(i,j) == 0.) cycle + + pRef = 0. + pres_int(1) = pRef + ! we don't have SST and SSS, so let's use values at top-most layer + temp_int(1) = TV%T(i,j,1); salt_int(1) = TV%S(i,j,1) + do k=2,G%ke + ! pressure at interface + pres_int(k) = pRef + GV%H_to_Pa * h(i,j,k-1) + ! temp and salt at interface + ! for temp: (t1*h1 + t2*h2)/(h1+h2) + temp_int(k) = (TV%T(i,j,k-1)*h(i,j,k-1) + TV%T(i,j,k)*h(i,j,k))/(h(i,j,k-1)+h(i,j,k)) + salt_int(k) = (TV%S(i,j,k-1)*h(i,j,k-1) + TV%S(i,j,k)*h(i,j,k))/(h(i,j,k-1)+h(i,j,k)) + ! dT and dS + dT(k) = (TV%T(i,j,k-1)-TV%T(i,j,k)) + dS(k) = (TV%S(i,j,k-1)-TV%S(i,j,k)) + pRef = pRef + GV%H_to_Pa * h(i,j,k-1) + enddo ! k-loop finishes + + call calculate_density_derivs(temp_int(:), salt_int(:), pres_int(:), drho_dT(:), drho_dS(:), 1, & + G%ke, TV%EQN_OF_STATE) + + ! The "-1.0" below is needed so that the following criteria is satisfied: + ! if ((alpha_dT > beta_dS) .and. (beta_dS > 0.0)) then "salt finger" + ! if ((alpha_dT < 0.) .and. (beta_dS < 0.) .and. (alpha_dT > beta_dS)) then "diffusive convection" + do k=1,G%ke + alpha_dT(k) = -1.0*drho_dT(k) * dT(k) + beta_dS(k) = drho_dS(k) * dS(k) + enddo + + if (CS%id_R_rho > 0.0) then + do k=1,G%ke + CS%R_rho(i,j,k) = alpha_dT(k)/beta_dS(k) + ! avoid NaN's + if(CS%R_rho(i,j,k) /= CS%R_rho(i,j,k)) CS%R_rho(i,j,k) = 0.0 + enddo + endif + + iFaceHeight(1) = 0.0 ! BBL is all relative to the surface + hcorr = 0.0 + ! compute heights at cell center and interfaces + do k=1,G%ke + dh = h(i,j,k) * GV%H_to_m ! Nominal thickness to use for increment + dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) + hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 + dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness + cellHeight(k) = iFaceHeight(k) - 0.5 * dh + iFaceHeight(k+1) = iFaceHeight(k) - dh + enddo + + ! gets index of the level and interface above hbl + !kOBL = CVmix_kpp_compute_kOBL_depth(iFaceHeight, cellHeight,hbl(i,j)) + + Kd1_T(:) = 0.0 ; Kd1_S(:) = 0.0 + call CVMix_coeffs_ddiff(Tdiff_out=Kd1_T(:), & + Sdiff_out=Kd1_S(:), & + strat_param_num=alpha_dT(:), & + strat_param_denom=beta_dS(:), & + nlev=G%ke, & + max_nlev=G%ke) + do K=1,G%ke+1 + Kd_T(i,j,K) = US%m_to_Z**2 * Kd1_T(K) + Kd_S(i,j,K) = US%m_to_Z**2 * Kd1_S(K) + enddo + + ! Do not apply mixing due to convection within the boundary layer + !do k=1,kOBL + ! Kd_T(i,j,k) = 0.0 + ! Kd_S(i,j,k) = 0.0 + !enddo + + enddo ! i-loop + +end subroutine compute_ddiff_coeffs + +!> Reads the parameter "USE_CVMIX_DDIFF" and returns state. +!! This function allows other modules to know whether this parameterization will +!! be used without needing to duplicate the log entry. +logical function CVMix_ddiff_is_used(param_file) + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + call get_param(param_file, mdl, "USE_CVMIX_DDIFF", CVMix_ddiff_is_used, & + default=.false., do_not_log = .true.) + +end function CVMix_ddiff_is_used + +!> Clear pointers and dealocate memory +subroutine CVMix_ddiff_end(CS) + type(CVMix_ddiff_cs), pointer :: CS !< Control structure for this module that + !! will be deallocated in this subroutine + + deallocate(CS) + +end subroutine CVMix_ddiff_end + +end module MOM_CVMix_ddiff diff --git a/src/parameterizations/vertical/MOM_CVMix_shear.F90 b/src/parameterizations/vertical/MOM_CVMix_shear.F90 index f99a0d4dcb..06fa74bdc7 100644 --- a/src/parameterizations/vertical/MOM_CVMix_shear.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_shear.F90 @@ -3,19 +3,14 @@ module MOM_CVMix_shear ! This file is part of MOM6. See LICENSE.md for the license. -!--------------------------------------------------- -! module MOM_CVMix_shear -! Author: Brandon Reichl -! Date: Aug 31, 2016 -! Purpose: Interface to CVMix interior shear schemes -! Further information to be added at a later time. -!--------------------------------------------------- +!> \author Brandon Reichl use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : diag_ctrl, time_type use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use MOM_EOS, only : calculate_density, EOS_type @@ -27,21 +22,32 @@ module MOM_CVMix_shear public calculate_CVMix_shear, CVMix_shear_init, CVMix_shear_is_used, CVMix_shear_end +! 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. + !> Control structure including parameters for CVMix interior shear schemes. -type, public :: CVMix_shear_cs - logical :: use_LMD94, use_PP81 !< Flags for various schemes +type, public :: CVMix_shear_cs ! TODO: private + logical :: use_LMD94 !< Flags to use the LMD94 scheme + logical :: use_PP81 !< Flags to use Pacanowski and Philander (JPO 1981) + logical :: smooth_ri !< If true, smooth Ri using a 1-2-1 filter real :: Ri_zero !< LMD94 critical Richardson number real :: Nu_zero !< LMD94 maximum interior diffusivity - real :: KPP_exp !< - real, allocatable, dimension(:,:,:) :: N2 !< Squared Brunt-Vaisala frequency (1/s2) - real, allocatable, dimension(:,:,:) :: S2 !< Squared shear frequency (1/s2) + real :: KPP_exp !< Exponent of unitless factor of diff. + !! for KPP internal shear mixing scheme. + real, allocatable, dimension(:,:,:) :: N2 !< Squared Brunt-Vaisala frequency [s-2] + real, allocatable, dimension(:,:,:) :: S2 !< Squared shear frequency [s-2] real, allocatable, dimension(:,:,:) :: ri_grad !< Gradient Richardson number -! real, allocatable, dimension(:,:,:) :: kv !< vertical viscosity at interface (m2/s) -! real, allocatable, dimension(:,:,:) :: kd !< vertical diffusivity at interface (m2/s) + real, allocatable, dimension(:,:,:) :: ri_grad_smooth !< Gradient Richardson number + !! after smoothing character(10) :: Mix_Scheme !< Mixing scheme name (string) - ! Daignostic handles and pointers - type(diag_ctrl), pointer :: diag => NULL() + + type(diag_ctrl), pointer :: diag => NULL() !< Pointer to the diagnostics control structure + !>@{ Diagnostic handles integer :: id_N2 = -1, id_S2 = -1, id_ri_grad = -1, id_kv = -1, id_kd = -1 + integer :: id_ri_grad_smooth = -1 + !!@} end type CVMix_shear_cs @@ -50,29 +56,32 @@ module MOM_CVMix_shear contains !> Subroutine for calculating (internal) vertical diffusivities/viscosities -subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, & - kv, G, GV, CS ) - type(ocean_grid_type), intent(in) :: G !< Grid structure. - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: u_H !< Initial zonal velocity on T points, in m s-1. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: v_H !< Initial meridional velocity on T points, in m s-1. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness, in m or kg m-2. - type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(out) :: kd !< The vertical diffusivity at each interface - !! (not layer!) in m2 s-1. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(out) :: kv !< The vertical viscosity at each interface - !! (not layer!) in m2 s-1. - type(CVMix_shear_cs), pointer :: CS !< The control structure returned by a previous call to - !! CVMix_shear_init. +subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) + 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 + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: u_H !< Initial zonal velocity on T points [m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: v_H !< Initial meridional velocity on T points [m s-1]. + 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),SZJ_(G),SZK_(G)+1), intent(out) :: kd !< The vertical diffusivity at each interface + !! (not layer!) [Z2 s-1 ~> m2 s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(out) :: kv !< The vertical viscosity at each interface + !! (not layer!) [Z2 s-1 ~> m2 s-1]. + type(CVMix_shear_cs), pointer :: CS !< The control structure returned by a previous call to + !! CVMix_shear_init. ! Local variables integer :: i, j, k, kk, km1 - real :: gorho - real :: pref, DU, DV, DRHO, DZ, N2, S2 + real :: GoRho + real :: pref, DU, DV, DRHO, DZ, N2, S2, dummy real, dimension(2*(G%ke)) :: pres_1d, temp_1d, salt_1d, rho_1d - real, dimension(G%ke+1) :: Ri_Grad !< Gradient Richardson number + real, dimension(G%ke+1) :: Ri_Grad !< Gradient Richardson number + real, dimension(G%ke+1) :: Kvisc !< Vertical viscosity at interfaces [m2 s-1] + real, dimension(G%ke+1) :: Kdiff !< Diapycnal diffusivity at interfaces [m2 s-1] + real, parameter :: epsln = 1.e-10 !< Threshold to identify vanished layers ! some constants - GoRho = GV%g_Earth / GV%Rho0 + GoRho = (GV%g_Earth*US%m_to_Z) / GV%Rho0 do j = G%jsc, G%jec do i = G%isc, G%iec @@ -115,30 +124,62 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, & DZ = ((0.5*(h(i,j,km1) + h(i,j,k))+GV%H_subroundoff)*GV%H_to_m) N2 = DRHO/DZ S2 = (DU*DU+DV*DV)/(DZ*DZ) - Ri_Grad(k) = max(0.,N2)/max(S2,1.e-16) + Ri_Grad(k) = max(0.,N2)/max(S2,1.e-10) ! fill 3d arrays, if user asks for diagsnostics if (CS%id_N2 > 0) CS%N2(i,j,k) = N2 if (CS%id_S2 > 0) CS%S2(i,j,k) = S2 - if (CS%id_ri_grad > 0) CS%ri_grad(i,j,k) = Ri_Grad(k) enddo + Ri_grad(G%ke+1) = Ri_grad(G%ke) + + if (CS%id_ri_grad > 0) CS%ri_grad(i,j,:) = Ri_Grad(:) + + if (CS%smooth_ri) then + ! 1) fill Ri_grad in vanished layers with adjacent value + do k = 2, G%ke + if (h(i,j,k) .le. epsln) Ri_grad(k) = Ri_grad(k-1) + enddo + + Ri_grad(G%ke+1) = Ri_grad(G%ke) + + ! 2) vertically smooth Ri with 1-2-1 filter + dummy = 0.25 * Ri_grad(2) + Ri_grad(G%ke+1) = Ri_grad(G%ke) + do k = 3, G%ke + Ri_Grad(k) = dummy + 0.5 * Ri_Grad(k) + 0.25 * Ri_grad(k+1) + dummy = 0.25 * Ri_grad(k) + enddo + + if (CS%id_ri_grad_smooth > 0) CS%ri_grad_smooth(i,j,:) = Ri_Grad(:) + endif + + do K=1,G%ke+1 + Kvisc(K) = US%Z_to_m**2 * kv(i,j,K) + Kdiff(K) = US%Z_to_m**2 * kd(i,j,K) + enddo + ! Call to CVMix wrapper for computing interior mixing coefficients. - call CVMix_coeffs_shear(Mdiff_out=kv(i,j,:), & - Tdiff_out=kd(i,j,:), & - RICH=Ri_Grad, & + call CVMix_coeffs_shear(Mdiff_out=Kvisc(:), & + Tdiff_out=Kdiff(:), & + RICH=Ri_Grad(:), & nlev=G%ke, & max_nlev=G%ke) + do K=1,G%ke+1 + kv(i,j,K) = US%m_to_Z**2 * Kvisc(K) + kd(i,j,K) = US%m_to_Z**2 * Kdiff(K) + enddo enddo enddo ! write diagnostics - if (CS%id_kd > 0) call post_data(CS%id_kd,kd, CS%diag) - if (CS%id_kv > 0) call post_data(CS%id_kv,kv, CS%diag) - if (CS%id_N2 > 0) call post_data(CS%id_N2,CS%N2, CS%diag) - if (CS%id_S2 > 0) call post_data(CS%id_S2,CS%S2, CS%diag) - if (CS%id_ri_grad > 0) call post_data(CS%id_ri_grad,CS%ri_grad, CS%diag) + if (CS%id_kd > 0) call post_data(CS%id_kd, kd, CS%diag) + if (CS%id_kv > 0) call post_data(CS%id_kv, kv, CS%diag) + if (CS%id_N2 > 0) call post_data(CS%id_N2, CS%N2, CS%diag) + if (CS%id_S2 > 0) call post_data(CS%id_S2, CS%S2, CS%diag) + if (CS%id_ri_grad > 0) call post_data(CS%id_ri_grad, CS%ri_grad, CS%diag) + if (CS%id_ri_grad_smooth > 0) call post_data(CS%id_ri_grad_smooth ,CS%ri_grad_smooth, CS%diag) end subroutine calculate_CVMix_shear @@ -147,10 +188,11 @@ end subroutine calculate_CVMix_shear !! \note *This is where we test to make sure multiple internal shear !! mixing routines (including JHL) are not enabled at the same time. !! (returns) CVMix_shear_init - True if module is to be used, False otherwise -logical function CVMix_shear_init(Time, G, GV, param_file, diag, CS) +logical function CVMix_shear_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(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(CVMix_shear_cs), pointer :: CS !< This module's control structure. @@ -188,7 +230,7 @@ logical function CVMix_shear_init(Time, G, GV, param_file, diag, CS) if (use_JHL) NumberTrue = NumberTrue + 1 ! After testing for interior schemes, make sure only 0 or 1 are enabled. ! Otherwise, warn user and kill job. - if ((NumberTrue).gt.1) then + if ((NumberTrue) > 1) then call MOM_error(FATAL, 'MOM_CVMix_shear_init: '// & 'Multiple shear driven internal mixing schemes selected,'//& ' please disable all but one scheme to proceed.') @@ -204,12 +246,16 @@ logical function CVMix_shear_init(Time, G, GV, param_file, diag, CS) "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.7) + ,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." & ,units="nondim", default=3.0) - call CVMix_init_shear(mix_scheme=CS%mix_scheme, & + call get_param(param_file, mdl, "SMOOTH_RI", CS%smooth_ri, & + "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, & KPP_nu_zero=CS%Nu_Zero, & KPP_Ri_zero=CS%Ri_zero, & KPP_exp=CS%KPP_exp) @@ -219,23 +265,33 @@ logical function CVMix_shear_init(Time, G, GV, param_file, diag, CS) CS%id_N2 = register_diag_field('ocean_model', 'N2_shear', diag%axesTi, Time, & 'Square of Brunt-Vaisala frequency used by MOM_CVMix_shear module', '1/s2') - if (CS%id_N2 > 0) & - allocate( CS%N2( SZI_(G), SZJ_(G), SZK_(G)+1 ) );CS%N2(:,:,:) = 0. + if (CS%id_N2 > 0) then + allocate( CS%N2( SZI_(G), SZJ_(G), SZK_(G)+1 ) ) ; CS%N2(:,:,:) = 0. + endif CS%id_S2 = register_diag_field('ocean_model', 'S2_shear', diag%axesTi, Time, & 'Square of vertical shear used by MOM_CVMix_shear module','1/s2') - if (CS%id_S2 > 0) & - allocate( CS%S2( SZI_(G), SZJ_(G), SZK_(G)+1 ) );CS%S2(:,:,:) = 0. + if (CS%id_S2 > 0) then + allocate( CS%S2( SZI_(G), SZJ_(G), SZK_(G)+1 ) ) ; CS%S2(:,:,:) = 0. + endif CS%id_ri_grad = register_diag_field('ocean_model', 'ri_grad_shear', diag%axesTi, Time, & 'Gradient Richarson number used by MOM_CVMix_shear module','nondim') - if (CS%id_ri_grad > 0) & !Initialize w/ large Richardson value - allocate( CS%ri_grad( SZI_(G), SZJ_(G), SZK_(G)+1 ));CS%ri_grad(:,:,:) = 1.e8 + if (CS%id_ri_grad > 0) then !Initialize w/ large Richardson value + allocate( CS%ri_grad( SZI_(G), SZJ_(G), SZK_(G)+1 )) ; CS%ri_grad(:,:,:) = 1.e8 + endif + + CS%id_ri_grad_smooth = register_diag_field('ocean_model', 'ri_grad_shear_smooth', & + diag%axesTi, Time, & + 'Smoothed gradient Richarson number used by MOM_CVMix_shear module','nondim') + if (CS%id_ri_grad_smooth > 0) then !Initialize w/ large Richardson value + allocate( CS%ri_grad_smooth( SZI_(G), SZJ_(G), SZK_(G)+1 )) ; CS%ri_grad_smooth(:,:,:) = 1.e8 + endif CS%id_kd = register_diag_field('ocean_model', 'kd_shear_CVMix', diag%axesTi, Time, & - 'Vertical diffusivity added by MOM_CVMix_shear module', 'm2/s') + 'Vertical diffusivity added by MOM_CVMix_shear module', 'm2/s', conversion=US%Z_to_m**2) CS%id_kv = register_diag_field('ocean_model', 'kv_shear_CVMix', diag%axesTi, Time, & - 'Vertical viscosity added by MOM_CVMix_shear module', 'm2/s') + 'Vertical viscosity added by MOM_CVMix_shear module', 'm2/s', conversion=US%Z_to_m**2) end function CVMix_shear_init @@ -255,7 +311,10 @@ end function CVMix_shear_is_used !> Clear pointers and dealocate memory subroutine CVMix_shear_end(CS) - type(CVMix_shear_cs), pointer :: CS ! Control structure + type(CVMix_shear_cs), pointer :: CS !< Control structure for this module that + !! will be deallocated in this subroutine + + if (.not. associated(CS)) return if (CS%id_N2 > 0) deallocate(CS%N2) if (CS%id_S2 > 0) deallocate(CS%S2) diff --git a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 index 61c212db8b..7d683944a2 100644 --- a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 +++ b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 @@ -5,21 +5,20 @@ module MOM_bkgnd_mixing ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_debugging, only : hchksum use MOM_diag_mediator, only : diag_ctrl, time_type, register_diag_field use MOM_diag_mediator, only : post_data use MOM_EOS, only : calculate_density, calculate_density_derivs -use MOM_variables, only : thermo_var_ptrs -use MOM_forcing_type, only : forcing -use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE -use MOM_error_handler, only : is_root_pe +use MOM_error_handler, only : MOM_error, FATAL, WARNING, NOTE +use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_file_parser, only : openParameterBlock, closeParameterBlock -use MOM_debugging, only : hchksum +use MOM_forcing_type, only : forcing use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type -use MOM_file_parser, only : get_param, log_version, param_file_type -use CVMix_background, only : CVMix_init_bkgnd, CVMix_coeffs_bkgnd -use MOM_variables, only : vertvisc_type +use MOM_variables, only : thermo_var_ptrs, vertvisc_type use MOM_intrinsic_functions, only : invcosh +use CVMix_background, only : CVMix_init_bkgnd, CVMix_coeffs_bkgnd implicit none ; private @@ -30,20 +29,33 @@ module MOM_bkgnd_mixing public calculate_bkgnd_mixing public sfc_bkgnd_mixing +! 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. + !> Control structure including parameters for this module. -type, public :: bkgnd_mixing_cs +type, public :: bkgnd_mixing_cs ! TODO: private ! Parameters real :: Bryan_Lewis_c1 !< The vertical diffusivity values for Bryan-Lewis profile - !! at |z|=D (m2/s) + !! at |z|=D [m2 s-1] real :: Bryan_Lewis_c2 !< The amplitude of variation in diffusivity for the - !! Bryan-Lewis diffusivity profile (m2/s) + !! Bryan-Lewis diffusivity profile [m2 s-1] real :: Bryan_Lewis_c3 !< The inverse length scale for transition region in the - !! Bryan-Lewis diffusivity profile (1/m) + !! Bryan-Lewis diffusivity profile [m-1] real :: Bryan_Lewis_c4 !< The depth where diffusivity is Bryan_Lewis_bl1 in the - !! Bryan-Lewis profile (m) - real :: Kd_min !< minimum diapycnal diffusivity (m2/s) - real :: Kd !< interior diapycnal diffusivity (m2/s) + !! Bryan-Lewis profile [m] + real :: bckgrnd_vdc1 !< Background diffusivity (Ledwell) when + !! horiz_varying_background=.true. + real :: bckgrnd_vdc_eq !! Equatorial diffusivity (Gregg) when + !! horiz_varying_background=.true. + real :: bckgrnd_vdc_psim !< Max. PSI induced diffusivity (MacKinnon) when + !! horiz_varying_background=.true. + real :: bckgrnd_vdc_ban !< Banda Sea diffusivity (Gordon) when + !! horiz_varying_background=.true. + real :: Kd_min !< minimum diapycnal diffusivity [Z2 s-1 ~> m2 s-1] + real :: Kd !< interior diapycnal diffusivity [Z2 s-1 ~> m2 s-1] real :: N0_2Omega !< ratio of the typical Buoyancy frequency to !! twice the Earth's rotation period, used with the !! Henyey scaling from the mixing @@ -52,16 +64,17 @@ module MOM_bkgnd_mixing real :: Kd_tanh_lat_scale !< A nondimensional scaling for the range of !! diffusivities with Kd_tanh_lat_fn. Valid values !! are in the range of -2 to 2; 0.4 reproduces CM2M. - real :: Kdml !< mixed layer diapycnal diffusivity (m2/s) + real :: Kdml !< mixed layer diapycnal diffusivity [Z2 s-1 ~> m2 s-1] !! when bulkmixedlayer==.false. - real :: Hmix !< mixed layer thickness (meter) when - !! bulkmixedlayer==.false. + real :: Hmix !< mixed layer thickness [Z ~> m] when bulkmixedlayer==.false. logical :: Kd_tanh_lat_fn !< If true, use the tanh dependence of Kd_sfc on !! latitude, like GFDL CM2.1/CM2M. There is no !! physical justification for this form, and it can !! not be used with Henyey_IGW_background. logical :: Bryan_Lewis_diffusivity!< If true, background vertical diffusivity !! uses Bryan-Lewis (1979) like tanh profile. + logical :: horiz_varying_background !< If true, apply vertically uniform, latitude-dependent + !! background diffusivity, as described in Danabasoglu et al., 2012 logical :: Henyey_IGW_background !< If true, use a simplified variant of the !! Henyey et al, JGR (1986) latitudinal scaling for the background diapycnal diffusivity, !! which gives a marked decrease in the diffusivity near the equator. The simplification @@ -83,13 +96,16 @@ module MOM_bkgnd_mixing logical :: bulkmixedlayer !< If true, a refined bulk mixed layer scheme is used logical :: debug !< If true, turn on debugging in this module ! Daignostic handles and pointers - type(diag_ctrl), pointer :: diag => NULL() - integer :: id_kd_bkgnd = -1, id_kv_bkgnd = -1 + type(diag_ctrl), pointer :: diag => NULL() !< A structure that regulates diagnostic output + integer :: id_kd_bkgnd = -1 !< Diagnotic IDs + integer :: id_kv_bkgnd = -1 !< Diagnostic IDs - real, allocatable, dimension(:,:) :: Kd_sfc !< surface value of the diffusivity (m2/s) + real, allocatable, dimension(:,:) :: Kd_sfc !< surface value of the diffusivity [Z2 s-1 ~> m2 s-1] ! Diagnostics arrays - real, allocatable, dimension(:,:,:) :: kd_bkgnd !< Background diffusivity (m2/s) - real, allocatable, dimension(:,:,:) :: kv_bkgnd !< Background viscosity (m2/s) + real, allocatable, dimension(:,:,:) :: kd_bkgnd !< Background diffusivity [Z2 s-1 ~> m2 s-1] + real, allocatable, dimension(:,:,:) :: kv_bkgnd !< Background viscosity [Z2 s-1 ~> m2 s-1] + + character(len=40) :: bkgnd_scheme_str = "none" !< Background scheme identifier end type bkgnd_mixing_cs @@ -98,16 +114,20 @@ module MOM_bkgnd_mixing contains !> Initialize the background mixing routine. -subroutine bkgnd_mixing_init(Time, G, GV, param_file, diag, CS) +subroutine bkgnd_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(bkgnd_mixing_cs), pointer :: CS !< This module's control structure. + type(bkgnd_mixing_cs), pointer :: CS !< This module's control structure. ! Local variables + real :: Kv ! The interior vertical viscosity [m2 s-1] - read to set prandtl + ! number unless it is provided as a parameter + real :: prandtl_bkgnd_comp ! Kv/CS%Kd. Gets compared with user-specified prandtl_bkgnd. ! This include declares and sets the variable "version". #include "version_variable.h" @@ -126,11 +146,16 @@ subroutine bkgnd_mixing_init(Time, G, GV, param_file, diag, CS) 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", fail_if_missing=.true.) + "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 molecular value, ~1e-6 m2 s-1, may be used.", & + units="m2 s-1", 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) + units="m2 s-1", default=0.01*CS%Kd*US%Z_to_m**2, scale=US%m_to_Z**2) ! The following is needed to set one of the choices of vertical background mixing @@ -150,20 +175,15 @@ subroutine bkgnd_mixing_init(Time, G, GV, param_file, diag, CS) "If BULKMIXEDLAYER is false, KDML is the elevated \n"//& "diapycnal diffusivity in the topmost HMIX of fluid. \n"//& "KDML is only used if BULKMIXEDLAYER is false.", & - units="m2 s-1", default=CS%Kd) + 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"//& - "mixed layer is not used.", units="m", fail_if_missing=.true.) + "mixed layer is not used.", units="m", scale=US%m_to_Z, fail_if_missing=.true.) endif call get_param(param_file, mdl, 'DEBUG', CS%debug, default=.False., do_not_log=.True.) - call get_param(param_file, mdl, "PRANDTL_BKGND", CS%prandtl_bkgnd, & - "Turbulent Prandtl number used to convert vertical \n"//& - "background diffusivities into viscosities.", & - units="nondim", default=1.0) - ! call openParameterBlock(param_file,'MOM_BACKGROUND_MIXING') call get_param(param_file, mdl, "BRYAN_LEWIS_DIFFUSIVITY", & @@ -173,6 +193,7 @@ subroutine bkgnd_mixing_init(Time, G, GV, param_file, diag, CS) "This is done via CVMix.", default=.false.) if (CS%Bryan_Lewis_diffusivity) then + call check_bkgnd_scheme(CS, "BRYAN_LEWIS_DIFFUSIVITY") call get_param(param_file, mdl, "BRYAN_LEWIS_C1", & CS%Bryan_Lewis_c1, & @@ -196,21 +217,74 @@ subroutine bkgnd_mixing_init(Time, G, GV, param_file, diag, CS) endif ! CS%Bryan_Lewis_diffusivity + call get_param(param_file, mdl, "HORIZ_VARYING_BACKGROUND", & + CS%horiz_varying_background, & + "If true, apply vertically uniform, latitude-dependent background\n"//& + "diffusivity, as described in Danabasoglu et al., 2012", & + default=.false.) + + if (CS%horiz_varying_background) then + call check_bkgnd_scheme(CS, "HORIZ_VARYING_BACKGROUND") + + call get_param(param_file, mdl, "BCKGRND_VDC1", & + CS%bckgrnd_vdc1, & + "Background diffusivity (Ledwell) when HORIZ_VARYING_BACKGROUND=True", & + units="m2 s-1",default = 0.16e-04, scale=US%m_to_Z**2) + + call get_param(param_file, mdl, "BCKGRND_VDC_EQ", & + CS%bckgrnd_vdc_eq, & + "Equatorial diffusivity (Gregg) when HORIZ_VARYING_BACKGROUND=True", & + units="m2 s-1",default = 0.01e-04, scale=US%m_to_Z**2) + + call get_param(param_file, mdl, "BCKGRND_VDC_PSIM", & + CS%bckgrnd_vdc_psim, & + "Max. PSI induced diffusivity (MacKinnon) when HORIZ_VARYING_BACKGROUND=True", & + units="m2 s-1",default = 0.13e-4, scale=US%m_to_Z**2) + + call get_param(param_file, mdl, "BCKGRND_VDC_BAN", & + CS%bckgrnd_vdc_ban, & + "Banda Sea diffusivity (Gordon) when HORIZ_VARYING_BACKGROUND=True", & + units="m2 s-1",default = 1.0e-4, scale=US%m_to_Z**2) + endif + + call get_param(param_file, mdl, "PRANDTL_BKGND", CS%prandtl_bkgnd, & + "Turbulent Prandtl number used to convert vertical \n"//& + "background diffusivities into viscosities.", & + units="nondim", default=1.0) + + if (CS%Bryan_Lewis_diffusivity .or. CS%horiz_varying_background) then + + prandtl_bkgnd_comp = CS%prandtl_bkgnd + if (CS%Kd /= 0.0) prandtl_bkgnd_comp = Kv/CS%Kd + + if ( abs(CS%prandtl_bkgnd - prandtl_bkgnd_comp)>1.e-14) then + call MOM_error(FATAL,"set_diffusivity_init: The provided KD, KV,"//& + "and PRANDTL_BKGND values are incompatible. The following "//& + "must hold: KD*PRANDTL_BKGND==KV") + endif + + 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"//& "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"//& "Harrison & Hallberg, JPO 2008.", default=.false.) + if (CS%Henyey_IGW_background_new) call check_bkgnd_scheme(CS, "HENYEY_IGW_BACKGROUND_NEW") - if (CS%Henyey_IGW_background .and. CS%Henyey_IGW_background_new) & - call MOM_error(FATAL, "set_diffusivity_init: HENYEY_IGW_BACKGROUND and \n"//& - "HENYEY_IGW_BACKGROUND_NEW are mutually exclusive. Set only one or none.") + if (CS%Kd>0.0 .and. (trim(CS%bkgnd_scheme_str)=="BRYAN_LEWIS_DIFFUSIVITY" .or.& + trim(CS%bkgnd_scheme_str)=="HORIZ_VARYING_BACKGROUND" )) then + call MOM_error(WARNING, "set_diffusivity_init: a nonzero constant background "//& + "diffusivity (KD) is specified along with "//trim(CS%bkgnd_scheme_str)) + endif if (CS%Henyey_IGW_background) & call get_param(param_file, mdl, "HENYEY_N0_2OMEGA", CS%N0_2Omega, & @@ -245,22 +319,23 @@ subroutine bkgnd_mixing_init(Time, G, GV, param_file, diag, CS) ! Register diagnostics CS%diag => diag CS%id_kd_bkgnd = register_diag_field('ocean_model', 'Kd_bkgnd', diag%axesTi, Time, & - 'Background diffusivity added by MOM_bkgnd_mixing module', 'm2/s') + 'Background diffusivity added by MOM_bkgnd_mixing module', 'm2/s', conversion=US%Z_to_m**2) CS%id_kv_bkgnd = register_diag_field('ocean_model', 'Kv_bkgnd', diag%axesTi, Time, & - 'Background viscosity added by MOM_bkgnd_mixing module', 'm2/s') + 'Background viscosity added by MOM_bkgnd_mixing module', 'm2/s', conversion=US%Z_to_m**2) end subroutine bkgnd_mixing_init !> Get surface vertical background diffusivities/viscosities. -subroutine sfc_bkgnd_mixing(G, CS) +subroutine sfc_bkgnd_mixing(G, US, CS) - type(ocean_grid_type), intent(in) :: G !< Grid structure. - type(bkgnd_mixing_cs), pointer, intent(inout) :: CS !< The control structure returned by - !! a previous call to bkgnd_mixing_init. + type(ocean_grid_type), intent(in) :: G !< Grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(bkgnd_mixing_cs), pointer, intent(inout) :: CS !< The control structure returned by + !! a previous call to bkgnd_mixing_init. ! local variables real :: I_x30 !< 2/acos(2) = 1/(sin(30 deg) * acosh(1/sin(30 deg))) real :: deg_to_rad !< factor converting degrees to radians, pi/180. - real :: abs_sin !< absolute value of sine of latitude (nondim) + real :: abs_sin !< absolute value of sine of latitude [nondim] real :: epsilon integer :: i, j, k, is, ie, js, je @@ -271,7 +346,7 @@ subroutine sfc_bkgnd_mixing(G, CS) epsilon = 1.e-10 - if (.not. CS%Bryan_Lewis_diffusivity) then + if (.not. (CS%Bryan_Lewis_diffusivity .or. CS%horiz_varying_background)) then !$OMP parallel do default(none) shared(is,ie,js,je,CS) do j=js,je ; do i=is,ie CS%Kd_sfc(i,j) = CS%Kd @@ -299,40 +374,45 @@ subroutine sfc_bkgnd_mixing(G, CS) enddo ; enddo endif - if (CS%debug) call hchksum(CS%Kd_sfc,"After sfc_bkgnd_mixing: Kd_sfc",G%HI,haloshift=0) + if (CS%debug) call hchksum(CS%Kd_sfc,"After sfc_bkgnd_mixing: Kd_sfc",G%HI,haloshift=0, scale=US%Z_to_m**2) 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, CS) - - type(ocean_grid_type), intent(in) :: G !< Grid structure. - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness, in 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 (1/s2) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: kd_lay!< Diapycnal diffusivity of each layer m2 s-1. - real, dimension(:,:,:), pointer :: kv !< The "slow" vertical viscosity at each interface - !! (not layer!) in m2 s-1. - integer, intent(in) :: j !< Meridional grid indice. - type(bkgnd_mixing_cs), pointer :: CS !< The control structure returned by +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. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + 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]. + 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 + type(bkgnd_mixing_cs), pointer :: CS !< The control structure returned by !! a previous call to bkgnd_mixing_init. ! local variables - real, dimension(SZI_(G), SZK_(G)+1) :: depth_2d !< distance from surface of an interface (m) - real, dimension(SZI_(G)) :: & - depth !< distance from surface of an interface (meter) - real :: depth_c !< depth of the center of a layer (meter) - real :: I_Hmix !< inverse of fixed mixed layer thickness (1/m) - real :: I_2Omega !< 1/(2 Omega) (sec) + real, dimension(SZK_(G)+1) :: depth_int !< distance from surface of the interfaces [m] + real, dimension(SZK_(G)+1) :: Kd_col !< Diffusivities at the interfaces [m2 s-1] + real, dimension(SZK_(G)+1) :: Kv_col !< Viscosities at the interfaces [m2 s-1] + real, dimension(SZI_(G)) :: depth !< distance from surface of an interface [Z ~> m] + real :: depth_c !< depth of the center of a layer [Z ~> m] + real :: I_Hmix !< inverse of fixed mixed layer thickness [Z-1 ~> m-1] + real :: I_2Omega !< 1/(2 Omega) [s] real :: N_2Omega real :: N02_N2 real :: I_x30 !< 2/acos(2) = 1/(sin(30 deg) * acosh(1/sin(30 deg))) real :: deg_to_rad !< factor converting degrees to radians, pi/180. - real :: abs_sin !< absolute value of sine of latitude (nondim) + real :: abs_sin !< absolute value of sine of latitude [nondim] real :: epsilon + real :: bckgrnd_vdc_psin !< PSI diffusivity in northern hemisphere + real :: bckgrnd_vdc_psis !< PSI diffusivity in southern hemisphere integer :: i, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -341,88 +421,133 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, kd_lay, kv, j, G, GV, CS) deg_to_rad = atan(1.0)/45.0 ! = PI/180 epsilon = 1.e-10 - depth_2d(:,:) = 0.0 ! Set up the background diffusivity. if (CS%Bryan_Lewis_diffusivity) then do i=is,ie + depth_int(1) = 0.0 do k=2,nz+1 - depth_2d(i,k) = depth_2d(i,k-1) + GV%H_to_m*h(i,j,k-1) + depth_int(k) = depth_int(k-1) + GV%H_to_m*h(i,j,k-1) enddo - ! if (is_root_pe()) write(*,*)'depth_3d(i,j,:)',depth_3d(i,j,:) call CVMix_init_bkgnd(max_nlev=nz, & - zw = depth_2d(i,:), & !< interface depth, must bepositive. + zw = depth_int(:), & !< interface depths relative to the surface in m, must be positive. bl1 = CS%Bryan_Lewis_c1, & bl2 = CS%Bryan_Lewis_c2, & bl3 = CS%Bryan_Lewis_c3, & bl4 = CS%Bryan_Lewis_c4, & prandtl = CS%prandtl_bkgnd) - call CVMix_coeffs_bkgnd(Mdiff_out=CS%kv_bkgnd(i,j,:), & - Tdiff_out=CS%kd_bkgnd(i,j,:), & - nlev=nz, & - max_nlev=nz) + Kd_col(:) = 0.0 ; Kv_col(:) = 0.0 ! Is this line necessary? + call CVMix_coeffs_bkgnd(Mdiff_out=Kv_col, Tdiff_out=Kd_col, nlev=nz, max_nlev=nz) - ! Update Kd + ! Update Kd and Kv. + do K=1,nz+1 + CS%Kv_bkgnd(i,j,K) = US%m_to_Z**2*Kv_col(K) + 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*(CS%kd_bkgnd(i,j,K) + CS%kd_bkgnd(i,j,K+1)) + Kd_lay(i,j,k) = Kd_lay(i,j,k) + 0.5*US%m_to_Z**2*(Kd_col(K) + Kd_col(K+1)) enddo enddo ! i loop elseif ((.not. CS%Bryan_Lewis_diffusivity) .and. (.not.CS%bulkmixedlayer) .and. & - (CS%Kd/= CS%Kdml)) then + (.not. CS%horiz_varying_background) .and. (CS%Kd /= CS%Kdml)) then I_Hmix = 1.0 / CS%Hmix do i=is,ie ; depth(i) = 0.0 ; enddo do k=1,nz ; do i=is,ie - depth_c = depth(i) + 0.5*GV%H_to_m*h(i,j,k) - 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) + depth_c = depth(i) + 0.5*GV%H_to_Z*h(i,j,k) + 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 + & - (2.0*CS%Kdml - CS%Kd_sfc(i,j)) + Kd_lay(i,j,k) = ((CS%Kd_sfc(i,j) - CS%Kdml) * I_Hmix) * depth_c + & + (2.0*CS%Kdml - CS%Kd_sfc(i,j)) endif - depth(i) = depth(i) + GV%H_to_m*h(i,j,k) + depth(i) = depth(i) + GV%H_to_Z*h(i,j,k) enddo ; enddo + elseif (CS%horiz_varying_background) then + do i=is,ie + bckgrnd_vdc_psis= CS%bckgrnd_vdc_psim*exp(-(0.4*(G%geoLatT(i,j)+28.9))**2.0) + bckgrnd_vdc_psin= CS%bckgrnd_vdc_psim*exp(-(0.4*(G%geoLatT(i,j)-28.9))**2.0) + CS%kd_bkgnd(i,j,:) = CS%bckgrnd_vdc_eq + bckgrnd_vdc_psin + bckgrnd_vdc_psis + + if (G%geoLatT(i,j) < -10.0) then + CS%kd_bkgnd(i,j,:) = CS%kd_bkgnd(i,j,:) + CS%bckgrnd_vdc1 + elseif (G%geoLatT(i,j) <= 10.0) then + CS%kd_bkgnd(i,j,:) = CS%kd_bkgnd(i,j,:) + CS%bckgrnd_vdc1 * (G%geoLatT(i,j)/10.0)**2.0 + else + CS%kd_bkgnd(i,j,:) = CS%kd_bkgnd(i,j,:) + CS%bckgrnd_vdc1 + endif + + ! North Banda Sea + if ( (G%geoLatT(i,j) < -1.0) .and. (G%geoLatT(i,j) > -4.0) .and. & + ( mod(G%geoLonT(i,j)+360.0,360.0) > 103.0) .and. & + ( mod(G%geoLonT(i,j)+360.0,360.0) < 134.0) ) then + CS%kd_bkgnd(i,j,:) = CS%bckgrnd_vdc_ban + endif + + ! Middle Banda Sea + if ( (G%geoLatT(i,j) <= -4.0) .and. (G%geoLatT(i,j) > -7.0) .and. & + ( mod(G%geoLonT(i,j)+360.0,360.0) > 106.0) .and. & + ( mod(G%geoLonT(i,j)+360.0,360.0) < 140.0) ) then + CS%kd_bkgnd(i,j,:) = CS%bckgrnd_vdc_ban + endif + + ! South Banda Sea + if ( (G%geoLatT(i,j) <= -7.0) .and. (G%geoLatT(i,j) > -8.3) .and. & + ( mod(G%geoLonT(i,j)+360.0,360.0) > 111.0) .and. & + ( mod(G%geoLonT(i,j)+360.0,360.0) < 142.0) ) then + CS%kd_bkgnd(i,j,:) = CS%bckgrnd_vdc_ban + endif + + ! Compute kv_bkgnd + 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) + + enddo + elseif (CS%Henyey_IGW_background_new) then 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) 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) = 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) = CS%Kd_sfc(i,j) enddo ; enddo endif ! Update CS%kd_bkgnd and CS%kv_bkgnd for diagnostic purposes - if (.not. CS%Bryan_Lewis_diffusivity) then + if (.not. (CS%Bryan_Lewis_diffusivity .or. CS%horiz_varying_background)) then do i=is,ie 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) = CS%kd_bkgnd(i,j,k) + 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 + CS%Kd_bkgnd(i,j,k) = 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 endif - ! Update kv + ! Update Kv if (associated(kv)) then - do i=is,ie - do k=1,nz+1 - kv(i,j,k) = kv(i,j,k) + CS%kv_bkgnd(i,j,k) - enddo - enddo + do k=1,nz+1 ; do i=is,ie + Kv(i,j,k) = Kv(i,j,k) + CS%Kv_bkgnd(i,j,k) + enddo ; enddo endif + ! TODO: In both CS%Bryan_Lewis_diffusivity and CS%horiz_varying_background, KV and KD at surface + ! and bottom interfaces are set to be nonzero. Make sure this is not problematic. + end subroutine calculate_bkgnd_mixing !> Reads the parameter "USE_CVMix_BACKGROUND" and returns state. @@ -435,9 +560,28 @@ logical function CVMix_bkgnd_is_used(param_file) end function CVMix_bkgnd_is_used +!> Sets CS%bkgnd_scheme_str to check whether multiple background diffusivity schemes are activated. +!! The string is also for error/log messages. +subroutine check_bkgnd_scheme(CS,str) + type(bkgnd_mixing_cs), pointer :: CS !< Control structure + character(len=*), intent(in) :: str !< Background scheme identifier deducted from MOM_input + !! parameters + + if (trim(CS%bkgnd_scheme_str)=="none") then + CS%bkgnd_scheme_str = str + else + call MOM_error(FATAL, "set_diffusivity_init: Cannot activate both "//trim(str)//" and "//& + trim(CS%bkgnd_scheme_str)//".") + endif + +end subroutine + !> Clear pointers and dealocate memory subroutine bkgnd_mixing_end(CS) - type(bkgnd_mixing_cs), pointer :: CS ! Control structure + type(bkgnd_mixing_cs), pointer :: CS !< Control structure for this module that + !! will be deallocated in this subroutine + + if (.not. associated(CS)) return deallocate(CS%kd_bkgnd) deallocate(CS%kv_bkgnd) diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index c2631cff36..9b3aee8e7d 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -1,41 +1,8 @@ +!> Build mixed layer parameterization module MOM_bulk_mixed_layer ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Robert Hallberg, 1997 - 2005. * -!* * -!* This file contains the subroutine (bulkmixedlayer) that * -!* implements a Kraus-Turner-like bulk mixed layer, based on the work * -!* of various people, as described in the review paper by Niiler and * -!* Kraus (1979), with particular attention to the form proposed by * -!* Oberhuber (JPO, 1993, 808-829), with an extension to a refied bulk * -!* mixed layer as described in Hallberg (Aha Huliko'a, 2003). The * -!* physical processes portrayed in this subroutine include convective * -!* adjustment and mixed layer entrainment and detrainment. * -!* Penetrating shortwave radiation and an exponential decay of TKE * -!* fluxes are also supported by this subroutine. Several constants * -!* can alternately be set to give a traditional Kraus-Turner mixed * -!* layer scheme, although that is not the preferred option. The * -!* physical processes and arguments are described in detail below. * -!* * -!* Macros written all in capital letters are defined in MOM_memory.h. * -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q * -!* j+1 > o > o > At ^: v * -!* j x ^ x ^ x At >: u * -!* j > o > o > At o: h, buoy, T, S, eaml, ebml, etc. * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** - use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_alloc use MOM_diag_mediator, only : time_type, diag_ctrl, diag_update_remap_grids @@ -45,6 +12,7 @@ module MOM_bulk_mixed_layer use MOM_forcing_type, only : extractFluxes1d, forcing use MOM_grid, only : ocean_grid_type use MOM_shortwave_abs, only : absorbRemainingSW, optics_type +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use MOM_EOS, only : calculate_density, calculate_density_derivs @@ -55,123 +23,123 @@ module MOM_bulk_mixed_layer public bulkmixedlayer, bulkmixedlayer_init +! 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 with parameters for the MOM_bulk_mixed_layer module type, public :: bulkmixedlayer_CS ; private - integer :: nkml ! The number of layers in the mixed layer. - integer :: nkbl ! The number of buffer layers. - integer :: nsw ! The number of bands of penetrating shortwave radiation. - real :: mstar ! The ratio of the friction velocity cubed to the - ! TKE input to the mixed layer, nondimensional. - real :: nstar ! The fraction of the TKE input to the mixed layer - ! available to drive entrainment, nondim. - real :: nstar2 ! The fraction of potential energy released by - ! convective adjustment that drives entrainment, ND. - logical :: absorb_all_SW ! If true, all shortwave radiation is absorbed by the - ! ocean, instead of passing through to the bottom mud. - real :: TKE_decay ! The ratio of the natural Ekman depth to the TKE - ! decay scale, nondimensional. - real :: bulk_Ri_ML ! The efficiency with which mean kinetic energy - ! released by mechanically forced entrainment of - ! the mixed layer is converted to TKE, nondim. - real :: bulk_Ri_convective ! The efficiency with which convectively - ! released mean kinetic energy becomes TKE, nondim. - real :: Hmix_min ! The minimum mixed layer thickness in m. - real :: H_limit_fluxes ! When the total ocean depth is less than this - ! value, in m, scale away all surface forcing to - ! avoid boiling the ocean. - real :: ustar_min ! A minimum value of ustar to avoid numerical - ! problems, in m s-1. If the value is small enough, - ! this should not affect the solution. - real :: omega ! The Earth's rotation rate, in s-1. - real :: dT_dS_wt ! 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 determines what direction is orthogonal to - ! density contours. It should be a typical value of - ! (dR/dS) / (dR/dT) in oceanic profiles. - ! 6 K psu-1 might be reasonable. - real :: BL_extrap_lim ! 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. - logical :: ML_resort ! If true, resort the layers by density, rather than - ! doing convective adjustment. - integer :: ML_presort_nz_conv_adj ! If ML_resort is true, do convective - ! adjustment on this many layers (starting from the - ! top) before sorting the remaining layers. - real :: omega_frac ! 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). - logical :: correct_absorption ! If true, the depth at which penetrating - ! shortwave radiation is absorbed is corrected by - ! moving some of the heating upward in the water - ! column. The default is false. - logical :: Resolve_Ekman ! If true, the nkml layers in the mixed layer are - ! chosen to optimally represent the impact of the - ! Ekman transport on the mixed layer TKE budget. - type(time_type), pointer :: Time ! A pointer to the ocean model's clock. - logical :: TKE_diagnostics = .false. - logical :: do_rivermix = .false. ! Provide additional TKE to mix river runoff - ! at the river mouths to "rivermix_depth" meters - real :: rivermix_depth = 0.0 ! Used if "do_rivermix" = T - logical :: limit_det ! If true, limit the extent of buffer layer - ! detrainment to be consistent with neighbors. - real :: lim_det_dH_sfc ! The fractional limit in the change between grid - ! points of the surface region (mixed & buffer - ! layer) thickness, nondim. 0.5 by default. - real :: lim_det_dH_bathy ! The fraction of the total depth by which the - ! thickness of the surface region (mixed & buffer - ! layer) is allowed to change between grid points. - ! Nondimensional, 0.2 by default. - logical :: use_river_heat_content ! If true, use the fluxes%runoff_Hflx field - ! to set the heat carried by runoff, instead of - ! using SST for temperature of liq_runoff - logical :: use_calving_heat_content ! Use SST for temperature of froz_runoff - logical :: salt_reject_below_ML ! It true, add salt below mixed layer (layer mode only) - - type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the - ! timing of diagnostic output. - real :: Allowed_T_chg ! The amount by which temperature is allowed - ! to exceed previous values during detrainment, K. - real :: Allowed_S_chg ! The amount by which salinity is allowed - ! to exceed previous values during detrainment, PSU. - -! These are terms in the mixed layer TKE budget, all in m3 s-2. + integer :: nkml !< The number of layers in the mixed layer. + integer :: nkbl !< The number of buffer layers. + integer :: nsw !< The number of bands of penetrating shortwave radiation. + real :: mstar !< The ratio of the friction velocity cubed to the + !! TKE input to the mixed layer, nondimensional. + real :: nstar !< The fraction of the TKE input to the mixed layer + !! available to drive entrainment [nondim]. + real :: nstar2 !< The fraction of potential energy released by + !! convective adjustment that drives entrainment [nondim]. + logical :: absorb_all_SW !< If true, all shortwave radiation is absorbed by the + !! ocean, instead of passing through to the bottom mud. + real :: TKE_decay !< The ratio of the natural Ekman depth to the TKE + !! decay scale, nondimensional. + real :: bulk_Ri_ML !< The efficiency with which mean kinetic energy + !! released by mechanically forced entrainment of + !! the mixed layer is converted to TKE [nondim]. + real :: bulk_Ri_convective !< The efficiency with which convectively + !! released mean kinetic energy becomes TKE [nondim]. + real :: Hmix_min !< The minimum mixed layer thickness [H ~> m or kg m-2]. + real :: H_limit_fluxes !< When the total ocean depth is less than this + !! value [H ~> m or kg m-2], scale away all surface forcing to + !! avoid boiling the ocean. + real :: ustar_min !< A minimum value of ustar to avoid numerical problems [Z s-1 ~> m s-1]. + !! If the value is small enough, this should not affect the solution. + real :: omega !< The Earth's rotation rate [s-1]. + real :: dT_dS_wt !< When forced to extrapolate T & S to match the + !! layer densities, this factor (in degC / ppt) is + !! combined with the derivatives of density with T & S + !! to determines what direction is orthogonal to + !! density contours. It should be a typical value of + !! (dR/dS) / (dR/dT) in oceanic profiles. + !! 6 degC ppt-1 might be reasonable. + real :: BL_extrap_lim !< 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. + logical :: ML_resort !< If true, resort the layers by density, rather than + !! doing convective adjustment. + integer :: ML_presort_nz_conv_adj !< If ML_resort is true, do convective + !! adjustment on this many layers (starting from the + !! top) before sorting the remaining layers. + real :: omega_frac !< 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). + logical :: correct_absorption !< If true, the depth at which penetrating + !! shortwave radiation is absorbed is corrected by + !! moving some of the heating upward in the water + !! column. The default is false. + logical :: Resolve_Ekman !< If true, the nkml layers in the mixed layer are + !! chosen to optimally represent the impact of the + !! Ekman transport on the mixed layer TKE budget. + type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. + logical :: TKE_diagnostics = .false. !< If true, calculate extensive diagnostics of the TKE budget + logical :: do_rivermix = .false. !< Provide additional TKE to mix river runoff + !! at the river mouths to rivermix_depth + real :: rivermix_depth = 0.0 !< The depth of mixing if do_rivermix is true [Z ~> m]. + logical :: limit_det !< If true, limit the extent of buffer layer + !! detrainment to be consistent with neighbors. + real :: lim_det_dH_sfc !< The fractional limit in the change between grid + !! points of the surface region (mixed & buffer + !! layer) thickness [nondim]. 0.5 by default. + real :: lim_det_dH_bathy !< The fraction of the total depth by which the + !! thickness of the surface region (mixed & buffer + !! layer) is allowed to change between grid points. + !! Nondimensional, 0.2 by default. + logical :: use_river_heat_content !< If true, use the fluxes%runoff_Hflx field + !! to set the heat carried by runoff, instead of + !! using SST for temperature of liq_runoff + logical :: use_calving_heat_content !< Use SST for temperature of froz_runoff + logical :: salt_reject_below_ML !< It true, add salt below mixed layer (layer mode only) + + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate the + !! timing of diagnostic output. + real :: Allowed_T_chg !< The amount by which temperature is allowed + !! to exceed previous values during detrainment, K. + real :: Allowed_S_chg !< The amount by which salinity is allowed + !! to exceed previous values during detrainment, ppt. + + ! These are terms in the mixed layer TKE budget, all in [Z m2 s-3 ~> m3 s-3]. real, allocatable, dimension(:,:) :: & - ML_depth, & ! The mixed layer depth in m. - diag_TKE_wind, & ! The wind source of TKE. - diag_TKE_RiBulk, & ! The resolved KE source of TKE. - diag_TKE_conv, & ! The convective source of TKE. - diag_TKE_pen_SW, & ! The TKE sink required to mix - ! penetrating shortwave heating. - diag_TKE_mech_decay, & ! The decay of mechanical TKE. - diag_TKE_conv_decay, & ! The decay of convective TKE. - diag_TKE_mixing, & ! The work done by TKE to deepen - ! the mixed layer. - diag_TKE_conv_s2, &! The convective source of TKE due to - ! to mixing in sigma2. - diag_PE_detrain, & ! The spurious source of potential - ! energy due to mixed layer - ! detrainment, W m-2. - diag_PE_detrain2 ! The spurious source of potential - ! energy due to mixed layer only - ! detrainment, W m-2. - logical :: 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. - type(group_pass_type) :: pass_h_sum_hmbl_prev ! For group halo pass + ML_depth, & !< The mixed layer depth [H ~> m or kg m-2]. + diag_TKE_wind, & !< The wind source of TKE. + diag_TKE_RiBulk, & !< The resolved KE source of TKE. + diag_TKE_conv, & !< The convective source of TKE. + diag_TKE_pen_SW, & !< The TKE sink required to mix penetrating shortwave heating. + diag_TKE_mech_decay, & !< The decay of mechanical TKE. + diag_TKE_conv_decay, & !< The decay of convective TKE. + diag_TKE_mixing, & !< The work done by TKE to deepen the mixed layer. + diag_TKE_conv_s2, & !< The convective source of TKE due to to mixing in sigma2. + diag_PE_detrain, & !< The spurious source of potential energy due to mixed layer detrainment, W Z m-3. + diag_PE_detrain2 !< The spurious source of potential energy due to mixed layer only detrainment, W Z m-3. + logical :: 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. + type(group_pass_type) :: pass_h_sum_hmbl_prev !< For group halo pass + + !>@{ Diagnostic IDs integer :: id_ML_depth = -1, id_TKE_wind = -1, id_TKE_mixing = -1 integer :: id_TKE_RiBulk = -1, id_TKE_conv = -1, id_TKE_pen_SW = -1 integer :: id_TKE_mech_decay = -1, id_TKE_conv_decay = -1, id_TKE_conv_s2 = -1 integer :: id_PE_detrain = -1, id_PE_detrain2 = -1, id_h_mismatch = -1 integer :: id_Hsfc_used = -1, id_Hsfc_max = -1, id_Hsfc_min = -1 + !!@} end type bulkmixedlayer_CS +!>@{ CPU clock IDs integer :: id_clock_detrain=0, id_clock_mech=0, id_clock_conv=0, id_clock_adjustment=0 integer :: id_clock_EOS=0, id_clock_resort=0, id_clock_pass=0 - -integer :: num_msg = 0, max_msg = 2 +!!@} contains @@ -205,236 +173,176 @@ module MOM_bulk_mixed_layer !! For a traditional Kraus-Turner mixed layer, the values are: !! pen_SW_frac = 0.0, pen_SW_scale = 0.0 m, mstar = 1.25, !! nstar = 0.4, TKE_decay = 0.0, conv_decay = 0.0 -subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & +subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, CS, & optics, Hml, aggregate_FW_forcing, dt_diag, last_call) 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(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(inout) :: h_3d !< Layer thickness, in m or kg m-2. - !! (Intent in/out) The units of h are - !! referred to as H below. + intent(inout) :: h_3d !< Layer thickness [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: u_3d !< Zonal velocities interpolated to h points, - !! m s-1. + intent(in) :: u_3d !< Zonal velocities interpolated to h points + !! [m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: v_3d !< Zonal velocities interpolated to h points, - !! m s-1. + intent(in) :: v_3d !< Zonal velocities interpolated to h points + !! [m s-1]. type(thermo_var_ptrs), intent(inout) :: tv !< A structure containing pointers to any !! available thermodynamic fields. Absent !! fields have NULL ptrs. type(forcing), intent(inout) :: fluxes !< A structure containing pointers to any !! possible forcing fields. Unused fields !! have NULL ptrs. - real, intent(in) :: dt !< Time increment, in s. + real, intent(in) :: dt !< Time increment [s]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: ea !< The amount of fluid moved downward into a !! layer; this should be increased due to - !! mixed layer detrainment, in the same units - !! as h - usually m or kg m-2 (i.e., H). + !! mixed layer detrainment [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: eb !< The amount of fluid moved upward into a !! layer; this should be increased due to - !! mixed layer entrainment, in the same units - !! as h - usually m or kg m-2 (i.e., H). + !! mixed layer entrainment [H ~> m or kg m-2]. type(bulkmixedlayer_CS), pointer :: CS !< The control structure returned by a !! previous call to mixedlayer_init. type(optics_type), pointer :: optics !< The structure containing the inverse of the !! vertical absorption decay scale for - !! penetrating shortwave radiation, in m-1. - real, dimension(:,:), pointer :: Hml !< active mixed layer depth - logical, intent(in) :: aggregate_FW_forcing - real, optional, intent(in) :: dt_diag !< The diagnostic time step, + !! penetrating shortwave radiation [m-1]. + real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [m]. + logical, intent(in) :: aggregate_FW_forcing !< If true, the net incoming and + !! outgoing surface freshwater fluxes are + !! combined before being applied, instead of + !! being applied separately. + real, optional, intent(in) :: dt_diag !< The diagnostic time step, !! which may be less than dt if there are - !! two callse to mixedlayer, in s. - logical, optional, intent(in) :: last_call !< if true, this is the last call + !! two callse to mixedlayer [s]. + logical, optional, intent(in) :: last_call !< if true, this is the last call !! to mixedlayer in the current time step, so !! diagnostics will be written. The default is !! .true. -! This subroutine partially steps the bulk mixed layer model. -! The following processes are executed, in the order listed. -! 1. Undergo convective adjustment into mixed layer. -! 2. Apply surface heating and cooling. -! 3. Starting from the top, entrain whatever fluid the TKE budget -! permits. Penetrating shortwave radiation is also applied at -! this point. -! 4. If there is any unentrained fluid that was formerly in the -! mixed layer, detrain this fluid into the buffer layer. This -! is equivalent to the mixed layer detraining to the Monin- -! Obukhov depth. -! 5. Divide the fluid in the mixed layer evenly into CS%nkml pieces. -! 6. Split the buffer layer if appropriate. -! Layers 1 to nkml are the mixed layer, nkml+1 to nkml+nkbl are the -! buffer layers. The results of this subroutine are mathematically -! identical if there are multiple pieces of the mixed layer with -! the same density or if there is just a single layer. There is no -! stability limit on the time step. -! -! The key parameters for the mixed layer are found in the control structure. -! These include mstar, nstar, nstar2, pen_SW_frac, pen_SW_scale, and TKE_decay. -! For the Oberhuber (1993) mixed layer, the values of these are: -! pen_SW_frac = 0.42, pen_SW_scale = 15.0 m, mstar = 1.25, -! nstar = 1, TKE_decay = 2.5, conv_decay = 0.5 -! TKE_decay is 1/kappa in eq. 28 of Oberhuber (1993), while conv_decay is 1/mu. -! Conv_decay has been eliminated in favor of the well-calibrated form for the -! efficiency of penetrating convection from Wang (2003). -! For a traditional Kraus-Turner mixed layer, the values are: -! pen_SW_frac = 0.0, pen_SW_scale = 0.0 m, mstar = 1.25, -! nstar = 0.4, TKE_decay = 0.0, conv_decay = 0.0 - -! Arguments: h_3d - Layer thickness, in m or kg m-2. (Intent in/out) -! The units of h are referred to as H below. -! (in) u_3d - Zonal velocities interpolated to h points, m s-1. -! (in) v_3d - Zonal velocities interpolated to h points, m s-1. -! (in/out) tv - A structure containing pointers to any available -! thermodynamic fields. Absent fields have NULL ptrs. -! (in) fluxes - A structure containing pointers to any possible -! forcing fields. Unused fields have NULL ptrs. -! (in) dt - Time increment, in s. -! (in/out) ea - The amount of fluid moved downward into a layer; this should -! be increased due to mixed layer detrainment, in the same units -! as h - usually m or kg m-2 (i.e., H). -! (in/out) eb - The amount of fluid moved upward into a layer; this should -! be increased due to mixed layer entrainment, in the same units -! as h - usually m or kg m-2 (i.e., H). -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - The control structure returned by a previous call to -! mixedlayer_init. -! (in) optics - The structure containing the inverse of the vertical -! absorption decay scale for penetrating shortwave -! radiation, in m-1. -! (in,opt) dt_diag - The diagnostic time step, which may be less than dt -! if there are two callse to mixedlayer, in s. -! (in,opt) last_call - if true, this is the last call to mixedlayer in the -! current time step, so diagnostics will be written. -! The default is .true. - + ! Local variables real, dimension(SZI_(G),SZK_(GV)) :: & eaml, & ! The amount of fluid moved downward into a layer due to mixed - ! mixed layer detrainment, in m. (I.e. entrainment from above.) + ! layer detrainment [H ~> m or kg m-2]. (I.e. entrainment from above.) ebml ! The amount of fluid moved upward into a layer due to mixed - ! mixed layer detrainment, in m. (I.e. entrainment from below.) + ! layer detrainment [H ~> m or kg m-2]. (I.e. entrainment from below.) ! If there is resorting, the vertical coordinate for these variables is the ! new, sorted index space. Here layer 0 is an initially massless layer that ! will be used to hold the new mixed layer properties. real, dimension(SZI_(G),SZK0_(GV)) :: & - h, & ! The layer thickness, in m or kg m-2. - T, & ! The layer temperatures, in deg C. - S, & ! The layer salinities, in psu. - R0, & ! The potential density referenced to the surface, in kg m-3. - Rcv ! The coordinate variable potential density, in kg m-3. + h, & ! The layer thickness [H ~> m or kg m-2]. + T, & ! The layer temperatures [degC]. + S, & ! The layer salinities [ppt]. + R0, & ! The potential density referenced to the surface [kg m-3]. + Rcv ! The coordinate variable potential density [kg m-3]. real, dimension(SZI_(G),SZK_(GV)) :: & - u, & ! The zonal velocity, in m s-1. - v, & ! The meridional velocity, in m s-1. - h_orig, & ! The original thickness in m or kg m-2. + u, & ! The zonal velocity [m s-1]. + v, & ! The meridional velocity [m s-1]. + h_orig, & ! The original thickness [H ~> m or kg m-2]. d_eb, & ! The downward increase across a layer in the entrainment from - ! below, in H. The sign convention is that positive values of + ! below [H ~> m or kg m-2]. The sign convention is that positive values of ! d_eb correspond to a gain in mass by a layer by upward motion. d_ea, & ! The upward increase across a layer in the entrainment from - ! above, in H. The sign convention is that positive values of + ! above [H ~> m or kg m-2]. The sign convention is that positive values of ! d_ea mean a net gain in mass by a layer from downward motion. - eps ! The (small) thickness that must remain in a layer, in H. + eps ! The (small) thickness that must remain in a layer [H ~> m or kg m-2]. integer, dimension(SZI_(G),SZK_(GV)) :: & ksort ! The sorted k-index that each original layer goes to. real, dimension(SZI_(G),SZJ_(G)) :: & - h_miss ! The summed absolute mismatch, in m. + h_miss ! The summed absolute mismatch [Z ~> m]. real, dimension(SZI_(G)) :: & TKE, & ! The turbulent kinetic energy available for mixing over a - ! time step, in m3 s-2. + ! time step [Z m2 s-2 ~> m3 s-2]. Conv_En, & ! The turbulent kinetic energy source due to mixing down to - ! the depth of free convection, in m3 s-2. + ! the depth of free convection [Z m2 s-2 ~> m3 s-2]. htot, & ! The total depth of the layers being considered for - ! entrainment, in H. + ! entrainment [H ~> m or kg m-2]. R0_tot, & ! The integrated potential density referenced to the surface - ! of the layers which are fully entrained, in H kg m-3. + ! of the layers which are fully entrained [H kg m-3 ~> kg m-2 or kg2 m-5]. Rcv_tot, & ! The integrated coordinate value potential density of the - ! layers that are fully entrained, in H kg m-3. + ! layers that are fully entrained [H kg m-3 ~> kg m-2 or kg2 m-5]. Ttot, & ! The integrated temperature of layers which are fully - ! entrained, in H K. - Stot, & ! The integrated salt of layers which are fully entrained, - ! in H PSU. + ! entrained [degC H ~> degC m or degC kg m-2]. + Stot, & ! The integrated salt of layers which are fully entrained + ! [H ppt ~> m ppt or ppt kg m-2]. uhtot, & ! The depth integrated zonal and meridional velocities in the - vhtot, & ! mixed layer, in H m s-1. + vhtot, & ! mixed layer [H m s-1 ~> m2 s-1 or kg m-1 s-1]. netMassInOut, & ! The net mass flux (if non-Boussinsq) or volume flux (if ! Boussinesq - i.e. the fresh water flux (P+R-E)) into the - ! ocean over a time step, in H. - NetMassOut, & ! The mass flux (if non-Boussinsq) or volume flux (if - ! Boussinesq) over a time step from evaporating fresh water (H) - Net_heat, & ! The net heating at the surface over a time step in K H. Any - ! penetrating shortwave radiation is not included in Net_heat. - Net_salt, & ! The surface salt flux into the ocean over a time step, psu H. - Idecay_len_TKE, & ! The inverse of a turbulence decay length scale, in H-1. + ! ocean over a time step [H ~> m or kg m-2]. + NetMassOut, & ! The mass flux (if non-Boussinesq) or volume flux (if Boussinesq) + ! over a time step from evaporating fresh water [H ~> m or kg m-2] + Net_heat, & ! The net heating at the surface over a time step [degC H ~> degC m or degC kg m-2]. + ! Any penetrating shortwave radiation is not included in Net_heat. + Net_salt, & ! The surface salt flux into the ocean over a time step, ppt H. + Idecay_len_TKE, & ! The inverse of a turbulence decay length scale [H-1 ~> m-1 or m2 kg-1]. p_ref, & ! Reference pressure for the potential density governing mixed ! layer dynamics, almost always 0 (or 1e5) Pa. p_ref_cv, & ! Reference pressure for the potential density which defines - ! the coordinate variable, set to P_Ref, in Pa. + ! the coordinate variable, set to P_Ref [Pa]. dR0_dT, & ! Partial derivative of the mixed layer potential density with - ! temperature, in units of kg m-3 K-1. + ! temperature [kg m-3 degC-1]. dRcv_dT, & ! Partial derivative of the coordinate variable potential - ! density in the mixed layer with temperature, in kg m-3 K-1. + ! density in the mixed layer with temperature [kg m-3 degC-1]. dR0_dS, & ! Partial derivative of the mixed layer potential density with - ! salinity, in units of kg m-3 psu-1. + ! salinity [kg m-3 ppt-1]. dRcv_dS, & ! Partial derivative of the coordinate variable potential - ! density in the mixed layer with salinity, in kg m-3 psu-1. + ! density in the mixed layer with salinity [kg m-3 ppt-1]. TKE_river ! The turbulent kinetic energy available for mixing at rivermouths over a - ! time step, in m3 s-2. + ! time step [Z m2 s-2 ~> m3 s-2]. real, dimension(max(CS%nsw,1),SZI_(G)) :: & Pen_SW_bnd ! The penetrating fraction of the shortwave heating integrated - ! over a time step in each band, in K H. + ! over a time step in each band [degC H ~> degC m or degC kg m-2]. real, dimension(max(CS%nsw,1),SZI_(G),SZK_(GV)) :: & - opacity_band ! The opacity in each band, in H-1. The indicies are band, i, k. + opacity_band ! The opacity in each band [H-1 ~> m-1 or m2 kg-1]. The indicies are band, i, k. - real :: cMKE(2,SZI_(G)) ! Coefficients of HpE and HpE^2 in calculating the - ! denominator of MKE_rate, in m-1 and m-2. - real :: Irho0 ! 1.0 / rho_0 + real :: cMKE(2,SZI_(G)) ! Coefficients of HpE and HpE^2 used in calculating the + ! denominator of MKE_rate; the two elements have differing + ! units of [H-1 ~> m-1 or m2 kg-1] and [H-2 ~> m-2 or m4 kg-2]. + real :: Irho0 ! 1.0 / rho_0 [m3 kg-1] real :: Inkml, Inkmlm1! 1.0 / REAL(nkml) and 1.0 / REAL(nkml-1) - real :: Ih ! The inverse of a thickness, in H-1. - real :: Idt ! The inverse of the timestep in s-1. - real :: Idt_diag ! The inverse of the timestep used for diagnostics in s-1. + real :: Ih ! The inverse of a thickness [H-1 ~> m-1 or m2 kg-1]. + real :: Idt ! The inverse of the timestep [s-1]. + real :: Idt_diag ! The inverse of the timestep used for diagnostics [s-1]. real :: RmixConst real, dimension(SZI_(G)) :: & - dKE_FC, & ! The change in mean kinetic energy due to free convection, - ! in m3 s-2. - h_CA ! The depth to which convective adjustment has gone in H. + dKE_FC, & ! The change in mean kinetic energy due to free convection + ! [Z m2 s-2 ~> m3 s-2]. + h_CA ! The depth to which convective adjustment has gone [H ~> m or kg m-2]. real, dimension(SZI_(G),SZK_(GV)) :: & dKE_CA, & ! The change in mean kinetic energy due to convective - ! adjustment, in m3 s-2. + ! adjustment [Z m2 s-2 ~> m3 s-2]. cTKE ! The turbulent kinetic energy source due to convective - ! adjustment, m3 s-2. + ! adjustment [Z m2 s-2 ~> m3 s-2]. real, dimension(SZI_(G),SZJ_(G)) :: & Hsfc_max, & ! The thickness of the surface region (mixed and buffer layers) - ! after entrainment but before any buffer layer detrainment, m. + ! after entrainment but before any buffer layer detrainment [Z ~> m]. Hsfc_used, & ! The thickness of the surface region after buffer layer - ! detrainment, in units of m. + ! detrainment [Z ~> m]. Hsfc_min, & ! The minimum thickness of the surface region based on the ! new mixed layer depth and the previous thickness of the - ! neighboring water columns, in m. - h_sum, & ! The total thickness of the water column, in H. - hmbl_prev ! The previous thickness of the mixed and buffer layers, in H. + ! neighboring water columns [Z ~> m]. + h_sum, & ! The total thickness of the water column [H ~> m or kg m-2]. + hmbl_prev ! The previous thickness of the mixed and buffer layers [H ~> m or kg m-2]. real, dimension(SZI_(G)) :: & Hsfc, & ! The thickness of the surface region (mixed and buffer - ! layers before detrainment in to the interior, in H. + ! layers before detrainment in to the interior [H ~> m or kg m-2]. max_BL_det ! If non-negative, the maximum amount of entrainment from - ! the buffer layers that will be allowed this time step, in H. + ! the buffer layers that will be allowed this time step [H ~> m or kg m-2]. real :: dHsfc, dHD ! Local copies of nondimensional parameters. - real :: H_nbr ! A minimum thickness based on neighboring thicknesses, in H. + real :: H_nbr ! A minimum thickness based on neighboring thicknesses [H ~> m or kg m-2]. - real :: absf_x_H ! The absolute value of f times the mixed layer thickness, - ! in units of m s-1. - real :: kU_star ! Ustar times the Von Karmen constant, in m s-1. - real :: dt__diag ! A copy of dt_diag (if present) or dt, in s. + real :: absf_x_H ! The absolute value of f times the mixed layer thickness [Z s-1 ~> m s-1]. + real :: kU_star ! Ustar times the Von Karmen constant [Z s-1 ~> m s-1]. + real :: dt__diag ! A copy of dt_diag (if present) or dt [s]. logical :: write_diags ! If true, write out diagnostics with this step. logical :: reset_diags ! If true, zero out the accumulated diagnostics. integer :: i, j, k, is, ie, js, je, nz, nkmb, n integer :: nsw ! The number of bands of penetrating shortwave radiation. - real :: H_limit_fluxes ! CS%H_limit fluxes converted to units of H. - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (.not. associated(CS)) call MOM_error(FATAL, "MOM_mixed_layer: "//& @@ -456,19 +364,17 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & Idt = 1.0 / dt Idt_diag = 1.0 / dt__diag write_diags = .true. ; if (present(last_call)) write_diags = last_call - H_limit_fluxes = CS%H_limit_fluxes * GV%m_to_H p_ref(:) = 0.0 ; p_ref_cv(:) = tv%P_Ref nsw = CS%nsw if (CS%limit_det .or. (CS%id_Hsfc_min > 0)) then -!$OMP parallel default(none) shared(is,ie,js,je,nkmb,h_sum,hmbl_prev,h_3d,nz) -!$OMP do + !$OMP parallel do default(shared) do j=js-1,je+1 ; do i=is-1,ie+1 h_sum(i,j) = 0.0 ; hmbl_prev(i,j) = 0.0 enddo ; enddo -!$OMP do + !$OMP parallel do default(shared) do j=js-1,je+1 do k=1,nkmb ; do i=is-1,ie+1 h_sum(i,j) = h_sum(i,j) + h_3d(i,j,k) @@ -478,7 +384,6 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & h_sum(i,j) = h_sum(i,j) + h_3d(i,j,k) enddo ; enddo enddo -!$OMP end parallel call cpu_clock_begin(id_clock_pass) call create_group_pass(CS%pass_h_sum_hmbl_prev, h_sum,G%Domain) @@ -493,9 +398,8 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & reset_diags = .false. ! This is the second call to mixedlayer. if (reset_diags) then -!$OMP parallel default(none) shared(is,ie,js,je,CS) if (CS%TKE_diagnostics) then -!$OMP do + !$OMP parallel do default(shared) do j=js,je ; do i=is,ie CS%diag_TKE_wind(i,j) = 0.0 ; CS%diag_TKE_RiBulk(i,j) = 0.0 CS%diag_TKE_conv(i,j) = 0.0 ; CS%diag_TKE_pen_SW(i,j) = 0.0 @@ -504,18 +408,17 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & enddo ; enddo endif if (allocated(CS%diag_PE_detrain)) then -!$OMP do + !$OMP parallel do default(shared) do j=js,je ; do i=is,ie CS%diag_PE_detrain(i,j) = 0.0 enddo ; enddo endif if (allocated(CS%diag_PE_detrain2)) then -!$OMP do + !$OMP parallel do default(shared) do j=js,je ; do i=is,ie CS%diag_PE_detrain2(i,j) = 0.0 enddo ; enddo endif -!$OMP end parallel endif if (CS%ML_resort) then @@ -537,7 +440,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & do k=1,nz ; do i=is,ie h(i,k) = h_3d(i,j,k) ; u(i,k) = u_3d(i,j,k) ; v(i,k) = v_3d(i,j,k) h_orig(i,k) = h_3d(i,j,k) - eps(i,k) = 0.0 ; if (k > nkmb) eps(i,k) = GV%Angstrom + eps(i,k) = 0.0 ; if (k > nkmb) eps(i,k) = GV%Angstrom_H T(i,k) = tv%T(i,j,k) ; S(i,k) = tv%S(i,j,k) do n=1,nsw opacity_band(n,i,k) = GV%H_to_m*optics%opacity_band(n,i,j,k) @@ -548,8 +451,8 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & d_ea(i,k) = 0.0 ; d_eb(i,k) = 0.0 enddo ; enddo - if(id_clock_EOS>0) call cpu_clock_begin(id_clock_EOS) - ! Calculate an estimate of the mid-mixed layer pressure (in Pa) + if (id_clock_EOS>0) call cpu_clock_begin(id_clock_EOS) + ! Calculate an estimate of the mid-mixed layer pressure [Pa] do i=is,ie ; p_ref(i) = 0.0 ; enddo do k=1,CS%nkml ; do i=is,ie p_ref(i) = p_ref(i) + 0.5*GV%H_to_Pa*h(i,k) @@ -564,21 +467,21 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & call calculate_density(T(:,k), S(:,k), p_ref_cv, Rcv(:,k), is, & ie-is+1, tv%eqn_of_state) enddo - if(id_clock_EOS>0) call cpu_clock_end(id_clock_EOS) + if (id_clock_EOS>0) call cpu_clock_end(id_clock_EOS) if (CS%ML_resort) then - if(id_clock_resort>0) call cpu_clock_begin(id_clock_resort) + if (id_clock_resort>0) call cpu_clock_begin(id_clock_resort) if (CS%ML_presort_nz_conv_adj > 0) & call convective_adjustment(h(:,1:), u, v, R0(:,1:), Rcv(:,1:), T(:,1:), & S(:,1:), eps, d_eb, dKE_CA, cTKE, j, G, GV, CS, & CS%ML_presort_nz_conv_adj) call sort_ML(h(:,1:), R0(:,1:), eps, G, GV, CS, ksort) - if(id_clock_resort>0) call cpu_clock_end(id_clock_resort) + if (id_clock_resort>0) call cpu_clock_end(id_clock_resort) else do k=1,nz ; do i=is,ie ; ksort(i,k) = k ; enddo ; enddo - if(id_clock_adjustment>0) call cpu_clock_begin(id_clock_adjustment) + if (id_clock_adjustment>0) call cpu_clock_begin(id_clock_adjustment) ! Undergo instantaneous entrainment into the buffer layers and mixed layers ! to remove hydrostatic instabilities. Any water that is lighter than ! currently in the mixed or buffer layer is entrained. @@ -586,7 +489,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & S(:,1:), eps, d_eb, dKE_CA, cTKE, j, G, GV, CS) do i=is,ie ; h_CA(i) = h(i,1) ; enddo - if(id_clock_adjustment>0) call cpu_clock_end(id_clock_adjustment) + if (id_clock_adjustment>0) call cpu_clock_end(id_clock_adjustment) endif if (associated(fluxes%lrunoff) .and. CS%do_rivermix) then @@ -596,12 +499,12 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & ! as follows: ! TKE_river[m3 s-3] = 0.5*rivermix_depth*g*Irho0*drho_ds* ! River*(Samb - Sriver) = CS%mstar*U_star^3 - ! where River is in units of m s-1. + ! where River is in units of [m s-1]. ! Samb = Ambient salinity at the mouth of the estuary ! rivermix_depth = The prescribed depth over which to mix river inflow ! drho_ds = The gradient of density wrt salt at the ambient surface salinity. ! Sriver = 0 (i.e. rivers are assumed to be pure freshwater) - RmixConst = 0.5*CS%rivermix_depth*GV%g_Earth*Irho0**2 + RmixConst = 0.5*CS%rivermix_depth * (GV%g_Earth*US%m_to_Z) * Irho0**2 do i=is,ie TKE_river(i) = max(0.0, RmixConst*dR0_dS(i)* & (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j)) * S(i,1)) @@ -611,17 +514,17 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & endif - if(id_clock_conv>0) call cpu_clock_begin(id_clock_conv) + if (id_clock_conv>0) call cpu_clock_begin(id_clock_conv) ! The surface forcing is contained in the fluxes type. ! We aggregate the thermodynamic forcing for a time step into the following: - ! netMassInOut = water (H units) added/removed via surface fluxes - ! netMassOut = water (H units) removed via evaporating surface fluxes - ! net_heat = heat (degC * H) via surface fluxes - ! net_salt = salt ( g(salt)/m2 for non-Bouss and ppt*m/s for Bouss ) via surface fluxes + ! netMassInOut = water [H ~> m or kg m-2] added/removed via surface fluxes + ! netMassOut = water [H ~> m or kg m-2] removed via evaporating surface fluxes + ! net_heat = heat via surface fluxes [degC H ~> degC m or degC kg m-2] + ! net_salt = salt via surface fluxes [ppt H ~> dppt m or gSalt m-2] ! Pen_SW_bnd = components to penetrative shortwave radiation call extractFluxes1d(G, GV, fluxes, optics, nsw, j, dt, & - H_limit_fluxes, CS%use_river_heat_content, CS%use_calving_heat_content, & + CS%H_limit_fluxes, CS%use_river_heat_content, CS%use_calving_heat_content, & h(:,1:), T(:,1:), netMassInOut, netMassOut, Net_heat, Net_salt, Pen_SW_bnd,& tv, aggregate_FW_forcing) @@ -635,7 +538,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & dKE_FC, j, ksort, G, GV, CS, tv, fluxes, dt, & aggregate_FW_forcing) - if(id_clock_conv>0) call cpu_clock_end(id_clock_conv) + if (id_clock_conv>0) call cpu_clock_end(id_clock_conv) ! Now the mixed layer undergoes mechanically forced entrainment. ! The mixed layer may entrain down to the Monin-Obukhov depth if the @@ -643,26 +546,26 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & ! First the TKE at the depth of free convection that is available ! to drive mixing is calculated. - if(id_clock_mech>0) call cpu_clock_begin(id_clock_mech) + if (id_clock_mech>0) call cpu_clock_begin(id_clock_mech) call find_starting_TKE(htot, h_CA, fluxes, Conv_En, cTKE, dKE_FC, dKE_CA, & TKE, TKE_river, Idecay_len_TKE, cMKE, dt, Idt_diag, & - j, ksort, G, GV, CS) + j, ksort, G, GV, US, CS) ! Here the mechanically driven entrainment occurs. call mechanical_entrainment(h(:,1:), d_eb, htot, Ttot, Stot, uhtot, vhtot, & R0_tot, Rcv_tot, u, v, T(:,1:), S(:,1:), R0(:,1:), Rcv(:,1:), eps, dR0_dT, dRcv_dT, & cMKE, Idt_diag, nsw, Pen_SW_bnd, opacity_band, TKE, & - Idecay_len_TKE, j, ksort, G, GV, CS) + Idecay_len_TKE, j, ksort, G, GV, US, CS) - call absorbRemainingSW(G, GV, h(:,1:), opacity_band, nsw, j, dt, H_limit_fluxes, & + call absorbRemainingSW(G, GV, h(:,1:), opacity_band, nsw, j, dt, CS%H_limit_fluxes, & CS%correct_absorption, CS%absorb_all_SW, & T(:,1:), Pen_SW_bnd, eps, ksort, htot, Ttot) if (CS%TKE_diagnostics) then ; do i=is,ie CS%diag_TKE_mech_decay(i,j) = CS%diag_TKE_mech_decay(i,j) - Idt_diag*TKE(i) enddo ; endif - if(id_clock_mech>0) call cpu_clock_end(id_clock_mech) + if (id_clock_mech>0) call cpu_clock_end(id_clock_mech) ! Calculate the homogeneous mixed layer properties and store them in layer 0. do i=is,ie ; if (htot(i) > 0.0) then @@ -675,10 +578,10 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & h(i,0) = htot(i) endif ; enddo if (write_diags .and. allocated(CS%ML_depth)) then ; do i=is,ie - CS%ML_depth(i,j) = h(i,0) * GV%H_to_m + CS%ML_depth(i,j) = h(i,0) * GV%H_to_m ! Rescale the diagnostic. enddo ; endif if (associated(Hml)) then ; do i=is,ie - Hml(i,j) = G%mask2dT(i,j) * (h(i,0) * GV%H_to_m) + Hml(i,j) = G%mask2dT(i,j) * (h(i,0) * GV%H_to_m) ! Rescale the diagnostic for output. enddo ; endif ! At this point, return water to the original layers, but constrained to @@ -692,10 +595,10 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & ! these unused layers (but not currently in the code). if (CS%ML_resort) then - if(id_clock_resort>0) call cpu_clock_begin(id_clock_resort) + if (id_clock_resort>0) call cpu_clock_begin(id_clock_resort) call resort_ML(h(:,0:), T(:,0:), S(:,0:), R0(:,0:), Rcv(:,0:), GV%Rlay, eps, & d_ea, d_eb, ksort, G, GV, CS, dR0_dT, dR0_dS, dRcv_dT, dRcv_dS) - if(id_clock_resort>0) call cpu_clock_end(id_clock_resort) + if (id_clock_resort>0) call cpu_clock_end(id_clock_resort) endif if (CS%limit_det .or. (CS%id_Hsfc_max > 0) .or. (CS%id_Hsfc_min > 0)) then @@ -712,21 +615,21 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & hmbl_prev(i,j-1) - dHD*min(h_sum(i,j),h_sum(i,j-1)), & hmbl_prev(i,j+1) - dHD*min(h_sum(i,j),h_sum(i,j+1))) ) - Hsfc_min(i,j) = GV%H_to_m*max(h(i,0), min(Hsfc(i), H_nbr)) + Hsfc_min(i,j) = GV%H_to_Z * max(h(i,0), min(Hsfc(i), H_nbr)) if (CS%limit_det) max_BL_det(i) = max(0.0, Hsfc(i)-H_nbr) enddo endif if (CS%id_Hsfc_max > 0) then ; do i=is,ie - Hsfc_max(i,j) = Hsfc(i)*GV%H_to_m + Hsfc_max(i,j) = GV%H_to_Z * Hsfc(i) enddo ; endif endif ! Move water left in the former mixed layer into the buffer layer and ! from the buffer layer into the interior. These steps might best be ! treated in conjuction. - if(id_clock_detrain>0) call cpu_clock_begin(id_clock_detrain) + if (id_clock_detrain>0) call cpu_clock_begin(id_clock_detrain) if (CS%nkbl == 1) then call mixedlayer_detrain_1(h(:,0:), T(:,0:), S(:,0:), R0(:,0:), Rcv(:,0:), & GV%Rlay, dt, dt__diag, d_ea, d_eb, j, G, GV, CS, & @@ -739,13 +642,13 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & ! This code only works with 1 or 2 buffer layers. call MOM_error(FATAL, "MOM_mixed_layer: CS%nkbl must be 1 or 2 for now.") endif - if(id_clock_detrain>0) call cpu_clock_end(id_clock_detrain) + if (id_clock_detrain>0) call cpu_clock_end(id_clock_detrain) if (CS%id_Hsfc_used > 0) then - do i=is,ie ; Hsfc_used(i,j) = h(i,0)*GV%H_to_m ; enddo + do i=is,ie ; Hsfc_used(i,j) = GV%H_to_Z * h(i,0) ; enddo do k=CS%nkml+1,nkmb ; do i=is,ie - Hsfc_used(i,j) = Hsfc_used(i,j) + h(i,k)*GV%H_to_m + Hsfc_used(i,j) = Hsfc_used(i,j) + GV%H_to_Z * h(i,k) enddo ; enddo endif @@ -767,13 +670,13 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & kU_Star = (1.0 - fluxes%frac_shelf_h(i,j)) * kU_star + & fluxes%frac_shelf_h(i,j) * (0.41*fluxes%ustar_shelf(i,j)) endif - absf_x_H = 0.25 * h(i,0) * & + absf_x_H = 0.25 * US%m_to_Z * h(i,0) * & !### I think this should be H_to_Z -RWH ((abs(G%CoriolisBu(I,J)) + abs(G%CoriolisBu(I-1,J-1))) + & (abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I-1,J)))) ! If the mixed layer vertical viscosity specification is changed in ! MOM_vert_friction.F90, this line will have to be modified accordingly. h_3d(i,j,1) = h(i,0) / (3.0 + sqrt(absf_x_H*(absf_x_H + 2.0*kU_star) / & - (kU_star**2)) ) + (kU_star**2)) ) do k=2,CS%nkml ! The other layers are evenly distributed through the mixed layer. h_3d(i,j,k) = (h(i,0)-h_3d(i,j,1)) * Inkmlm1 @@ -829,28 +732,27 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & if (CS%id_h_mismatch > 0) then do i=is,ie - h_miss(i,j) = abs(h_3d(i,j,1) - (h_orig(i,1) + & + h_miss(i,j) = GV%H_to_Z * abs(h_3d(i,j,1) - (h_orig(i,1) + & (eaml(i,1) + (ebml(i,1) - eaml(i,1+1))))) enddo do k=2,nz-1 ; do i=is,ie - h_miss(i,j) = h_miss(i,j) + abs(h_3d(i,j,k) - (h_orig(i,k) + & + h_miss(i,j) = h_miss(i,j) + GV%H_to_Z * abs(h_3d(i,j,k) - (h_orig(i,k) + & ((eaml(i,k) - ebml(i,k-1)) + (ebml(i,k) - eaml(i,k+1))))) enddo ; enddo do i=is,ie - h_miss(i,j) = h_miss(i,j) + abs(h_3d(i,j,nz) - (h_orig(i,nz) + & + h_miss(i,j) = h_miss(i,j) + GV%H_to_Z * abs(h_3d(i,j,nz) - (h_orig(i,nz) + & ((eaml(i,nz) - ebml(i,nz-1)) + ebml(i,nz)))) - h_miss(i,j) = GV%H_to_m * h_miss(i,j) enddo endif enddo ! j loop + !$OMP end parallel ! Whenever thickness changes let the diag manager know, target grids ! for vertical remapping may need to be regenerated. ! This needs to happen after the H update and before the next post_data. call diag_update_remap_grids(CS%diag) -!$OMP end parallel if (write_diags) then if (CS%id_ML_depth > 0) & @@ -894,30 +796,30 @@ subroutine convective_adjustment(h, u, v, R0, Rcv, T, S, eps, d_eb, & dKE_CA, cTKE, j, G, GV, CS, nz_conv) 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),SZK_(GV)), intent(inout) :: h !< Layer thickness, in m or kg m-2. - !! (Intent in/out) The units of h are - !! referred to as H below. + real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2]. + !! The units of h are referred to as H below. real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: u !< Zonal velocities interpolated to h !! points, m s-1. real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: v !< Zonal velocities interpolated to h !! points, m s-1. - real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: T !< Layer temperatures, in deg C. - real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: S + real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: T !< Layer temperatures [degC]. + real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: S !< Layer salinities [ppt]. real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: R0 !< Potential density referenced to - !! surface pressure, in kg m-3. + !! surface pressure [kg m-3]. real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: Rcv !< The coordinate defining potential - !! density, in kg m-3. + !! density [kg m-3]. real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: d_eb !< The downward increase across a layer - !! in the entrainment from below, in H. + !! in the entrainment from below [H ~> m or kg m-2]. !! Positive values go with mass gain by !! a layer. - real, dimension(SZI_(G),SZK_(GV)), intent(in) :: eps + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: eps !< The negligibly small amount of water + !! that will be left in each layer [H ~> m or kg m-2]. real, dimension(SZI_(G),SZK_(GV)), intent(out) :: dKE_CA !< The vertically integrated change in !! kinetic energy due to convective - !! adjustment, in m3 s-2. + !! adjustment [Z m2 s-2 ~> m3 s-2]. real, dimension(SZI_(G),SZK_(GV)), intent(out) :: cTKE !< The buoyant turbulent kinetic energy - !! source due to convective adjustment, - !! in m3 s-2. + !! source due to convective adjustment + !! [Z m2 s-2 ~> m3 s-2]. integer, intent(in) :: j !< The j-index to work on. type(bulkmixedlayer_CS), pointer :: CS !< The control structure for this module. integer, optional, intent(in) :: nz_conv !< If present, the number of layers @@ -928,52 +830,32 @@ subroutine convective_adjustment(h, u, v, R0, Rcv, T, S, eps, d_eb, & ! layers and mixed layers to remove hydrostatic instabilities. Any water that ! is lighter than currently in the mixed- or buffer- layer is entrained. -! Arguments: h - Layer thickness, in m or kg m-2. (Intent in/out) The units -! of h are referred to as H below. -! (in/out) u - Zonal velocities interpolated to h points, m s-1. -! (in/out) v - Zonal velocities interpolated to h points, m s-1. -! (in/out) R0 - Potential density referenced to surface pressure, in kg m-3. -! (in/out) Rcv - The coordinate defining potential density, in kg m-3. -! (in/out) T - Layer temperatures, in deg C. -! (in/out) S - Layer salinities, in psu. -! (in/out) d_eb - The downward increase across a layer in the entrainment from -! below, in H. Positive values go with mass gain by a layer. -! (out) dKE_CA - The vertically integrated change in kinetic energy due -! to convective adjustment, in m3 s-2. -! (out) cTKE - The buoyant turbulent kinetic energy source due to -! convective adjustment, in m3 s-2. -! (in) j - The j-index to work on. -! (in) ksort - The density-sorted k-indicies. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - The control structure for this module. -! (in,opt) nz_conv - If present, the number of layers over which to do -! convective adjustment (perhaps CS%nkml). + ! Local variables real, dimension(SZI_(G)) :: & htot, & ! The total depth of the layers being considered for - ! entrainment, in H. + ! entrainment [H ~> m or kg m-2]. R0_tot, & ! The integrated potential density referenced to the surface - ! of the layers which are fully entrained, in H kg m-3. + ! of the layers which are fully entrained [H kg m-3 ~> kg m-2 or kg2 m-5]. Rcv_tot, & ! The integrated coordinate value potential density of the - ! layers that are fully entrained, in H kg m-3. + ! layers that are fully entrained [H kg m-3 ~> kg m-2 or kg2 m-5]. Ttot, & ! The integrated temperature of layers which are fully - ! entrained, in H K. - Stot, & ! The integrated salt of layers which are fully entrained, - ! in H PSU. + ! entrained [degC H ~> degC m or degC kg m-2]. + Stot, & ! The integrated salt of layers which are fully entrained + ! [H ppt ~> m ppt or ppt kg m-2]. uhtot, & ! The depth integrated zonal and meridional velocities in - vhtot, & ! the mixed layer, in H m s-1. + vhtot, & ! the mixed layer [H m s-1 ~> m2 s-1 or kg m-1 s-1]. KE_orig, & ! The total mean kinetic energy in the mixed layer before ! convection, H m2 s-2. - h_orig_k1 ! The depth of layer k1 before convective adjustment, in H. - real :: h_ent ! The thickness from a layer that is entrained, in H. - real :: Ih ! The inverse of a thickness, in H-1. - real :: g_H2_2Rho0 ! Half the gravitational acceleration times the - ! square of the conversion from H to m divided - ! by the mean density, in m6 s-2 H-2 kg-1. + h_orig_k1 ! The depth of layer k1 before convective adjustment [H ~> m or kg m-2]. + real :: h_ent ! The thickness from a layer that is entrained [H ~> m or kg m-2]. + real :: Ih ! The inverse of a thickness [H-1 ~> m-1 or m2 kg-1]. + real :: g_H2_2Rho0 ! Half the gravitational acceleration times the square of + ! the conversion from H to Z divided by the mean density, + ! in m7 s-2 Z-1 H-2 kg-1. !### CHECK UNITS integer :: is, ie, nz, i, k, k1, nzc, nkmb is = G%isc ; ie = G%iec ; nz = GV%ke - g_H2_2Rho0 = (GV%g_Earth * GV%H_to_m**2) / (2.0 * GV%Rho0) + g_H2_2Rho0 = (GV%g_Earth * GV%H_to_Z**2) / (2.0 * GV%Rho0) nzc = nz ; if (present(nz_conv)) nzc = nz_conv nkmb = CS%nkml+CS%nkbl @@ -995,8 +877,8 @@ subroutine convective_adjustment(h, u, v, R0, Rcv, T, S, eps, d_eb, & do i=is,ie if ((h(i,k) > eps(i,k)) .and. (R0_tot(i) > h(i,k1)*R0(i,k))) then h_ent = h(i,k)-eps(i,k) - cTKE(i,k1) = cTKE(i,k1) + (h_ent * g_H2_2Rho0 * & - (R0_tot(i) - h(i,k1)*R0(i,k)) * CS%nstar2) + cTKE(i,k1) = cTKE(i,k1) + h_ent * g_H2_2Rho0 * & + (R0_tot(i) - h(i,k1)*R0(i,k)) * CS%nstar2 if (k < nkmb) then cTKE(i,k1) = cTKE(i,k1) + cTKE(i,k) dKE_CA(i,k1) = dKE_CA(i,k1) + dKE_CA(i,k) @@ -1023,7 +905,7 @@ subroutine convective_adjustment(h, u, v, R0, Rcv, T, S, eps, d_eb, & Ih = 1.0 / h(i,k1) R0(i,k1) = R0_tot(i) * Ih u(i,k1) = uhtot(i) * Ih ; v(i,k1) = vhtot(i) * Ih - dKE_CA(i,k1) = dKE_CA(i,k1) + GV%H_to_m * (CS%bulk_Ri_convective * & + dKE_CA(i,k1) = dKE_CA(i,k1) + GV%H_to_Z * (CS%bulk_Ri_convective * & (KE_orig(i) - 0.5*h(i,k1)*(u(i,k1)**2 + v(i,k1)**2))) Rcv(i,k1) = Rcv_tot(i) * Ih T(i,k1) = Ttot(i) * Ih ; S(i,k1) = Stot(i) * Ih @@ -1048,127 +930,137 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & nsw, Pen_SW_bnd, opacity_band, Conv_en, & dKE_FC, j, ksort, G, GV, CS, tv, fluxes, dt, & aggregate_FW_forcing) - 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),SZK_(GV)), intent(inout) :: h !< Layer thickness, in m or kg m-2. - !! (Intent in/out) The units of h are - !! referred to as H below. - real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: d_eb !< The downward increase across a - !! layer in the entrainment from below - !! , in H. Positive values go with - !! mass gain by a layer. - real, dimension(SZI_(G)), intent(out) :: htot !< The accumulated mixed layer - !! thickness, in H. - real, dimension(SZI_(G)), intent(out) :: Ttot !< The depth integrated mixed layer - !! temperature, in deg C H. - real, dimension(SZI_(G)), intent(out) :: Stot !< The depth integrated mixed layer - !! salinity, in psu H. - real, dimension(SZI_(G)), intent(out) :: uhtot !< The depth integrated mixed layer - !! zonal velocity, H m s-1. - real, dimension(SZI_(G)), intent(out) :: vhtot !< The integrated mixed layer - !! meridional velocity, H m s-1. - real, dimension(SZI_(G)), intent(out) :: R0_tot !< The integrated mixed layer - !! potential density referenced to 0 - !! pressure, in kg m-2. - real, dimension(SZI_(G)), intent(out) :: Rcv_tot !< The integrated mixed layer - !! coordinate variable potential - !! density, in kg m-2. - real, dimension(SZI_(G),SZK_(GV)), intent(in) :: u, v, T, S, R0, Rcv, eps - real, dimension(SZI_(G)), intent(in) :: dR0_dT, dRcv_dT, dR0_dS, dRcv_dS - real, dimension(SZI_(G)), intent(in) :: netMassInOut, netMassOut - real, dimension(SZI_(G)), intent(in) :: Net_heat, Net_salt - integer, intent(in) :: nsw !< The number of bands of penetrating - !! shortwave radiation. - real, dimension(:,:), intent(inout) :: Pen_SW_bnd !< The penetrating shortwave - !! heating at the sea surface in each - !! penetrating band, in K H, - !! size nsw x SZI_(G). - real, dimension(:,:,:), intent(in) :: opacity_band - real, dimension(SZI_(G)), intent(out) :: Conv_en !< The buoyant turbulent kinetic - !! energy source due to free - !! convection, in m3 s-2. - real, dimension(SZI_(G)), intent(out) :: dKE_FC !< The vertically integrated change - !! in kinetic energy due to free - !! convection, in m3 s-2. - integer, intent(in) :: j !< The j-index to work on. + 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),SZK_(GV)), & + intent(inout) :: h !< Layer thickness [H ~> m or kg m-2]. + !! The units of h are referred to as H below. + real, dimension(SZI_(G),SZK_(GV)), & + intent(inout) :: d_eb !< The downward increase across a layer in the + !! layer in the entrainment from below [H ~> m or kg m-2]. + !! Positive values go with mass gain by a layer. + real, dimension(SZI_(G)), intent(out) :: htot !< The accumulated mixed layer thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G)), intent(out) :: Ttot !< The depth integrated mixed layer temperature + !! [degC H ~> degC m or degC kg m-2]. + real, dimension(SZI_(G)), intent(out) :: Stot !< The depth integrated mixed layer salinity + !! [ppt H ~> ppt m or ppt kg m-2]. + real, dimension(SZI_(G)), intent(out) :: uhtot !< The depth integrated mixed layer zonal + !! velocity, H m s-1. + real, dimension(SZI_(G)), intent(out) :: vhtot !< The integrated mixed layer meridional + !! velocity, H m s-1. + real, dimension(SZI_(G)), intent(out) :: R0_tot !< The integrated mixed layer potential density referenced + !! to 0 pressure [H kg m-2 ~> kg m-1 or kg2 m-4]. + real, dimension(SZI_(G)), intent(out) :: Rcv_tot !< The integrated mixed layer coordinate + !! variable potential density [H kg m-2 ~> kg m-1 or kg2 m-4]. + real, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: u !< Zonal velocities interpolated to h points, m s-1. + real, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: v !< Zonal velocities interpolated to h points, m s-1. + real, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: T !< Layer temperatures [degC]. + real, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: S !< Layer salinities [ppt]. + real, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: R0 !< Potential density referenced to + !! surface pressure [kg m-3]. + real, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: Rcv !< The coordinate defining potential + !! density [kg m-3]. + real, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: eps !< The negligibly small amount of water + !! that will be left in each layer [H ~> m or kg m-2]. + real, dimension(SZI_(G)), intent(in) :: dR0_dT !< The partial derivative of R0 with respect to + !! temperature [kg m-3 degC-1]. + real, dimension(SZI_(G)), intent(in) :: dRcv_dT !< The partial derivative of Rcv with respect to + !! temperature [kg m-3 degC-1]. + real, dimension(SZI_(G)), intent(in) :: dR0_dS !< The partial derivative of R0 with respect to + !! salinity [kg m-3 ppt-1]. + real, dimension(SZI_(G)), intent(in) :: dRcv_dS !< The partial derivative of Rcv with respect to + !! salinity [kg m-3 ppt-1]. + real, dimension(SZI_(G)), intent(in) :: netMassInOut !< The net mass flux (if non-Boussinesq) + !! or volume flux (if Boussinesq) into the ocean + !! within a time step [H ~> m or kg m-2]. (I.e. P+R-E.) + real, dimension(SZI_(G)), intent(in) :: netMassOut !< The mass or volume flux out of the ocean + !! within a time step [H ~> m or kg m-2]. + real, dimension(SZI_(G)), intent(in) :: Net_heat !< The net heating at the surface over a time + !! step [degC H ~> degC m or degC kg m-2]. Any penetrating + !! shortwave radiation is not included in Net_heat. + real, dimension(SZI_(G)), intent(in) :: Net_salt !< The net surface salt flux into the ocean + !! over a time step [ppt H ~> ppt m or ppt kg m-2]. + integer, intent(in) :: nsw !< The number of bands of penetrating + !! shortwave radiation. + real, dimension(:,:), intent(inout) :: Pen_SW_bnd !< The penetrating shortwave + !! heating at the sea surface in each + !! penetrating band [degC H ~> degC m or degC kg m-2], + !! size nsw x SZI_(G). + real, dimension(:,:,:), intent(in) :: opacity_band !< The opacity in each band of penetrating + !! shortwave radiation [H-1 ~> m-1 or m2 kg-1]. + !! The indicies of opacity_band are band, i, k. + real, dimension(SZI_(G)), intent(out) :: Conv_en !< The buoyant turbulent kinetic energy source + !! due to free convection [Z m2 s-2 ~> m3 s-2]. + real, dimension(SZI_(G)), intent(out) :: dKE_FC !< The vertically integrated change in kinetic + !! energy due to free convection [Z m2 s-2 ~> m3 s-2]. + integer, intent(in) :: j !< The j-index to work on. integer, dimension(SZI_(G),SZK_(GV)), & - intent(in) :: ksort !< The density-sorted k-indices. - type(bulkmixedlayer_CS), pointer :: CS !< The control structure for this - !! module. - type(thermo_var_ptrs), intent(inout) :: tv - type(forcing), intent(inout) :: fluxes - real, intent(in) :: dt - logical, intent(in) :: aggregate_FW_forcing + intent(in) :: ksort !< The density-sorted k-indices. + type(bulkmixedlayer_CS), pointer :: CS !< The control structure for this + !! module. + type(thermo_var_ptrs), intent(inout) :: tv !< A structure containing pointers to any + !! available thermodynamic fields. Absent + !! fields have NULL ptrs. + type(forcing), intent(inout) :: fluxes !< A structure containing pointers to any + !! possible forcing fields. Unused fields + !! have NULL ptrs. + real, intent(in) :: dt !< Time increment [s]. + logical, intent(in) :: aggregate_FW_forcing !< If true, the net incoming and + !! outgoing surface freshwater fluxes are + !! combined before being applied, instead of + !! being applied separately. ! This subroutine causes the mixed layer to entrain to the depth of free ! convection. The depth of free convection is the shallowest depth at which the ! fluid is denser than the average of the fluid above. -! Arguments: h - Layer thickness, in m or kg m-2. (Intent in/out) The units -! of h are referred to as H below. -! (in/out) d_eb - The downward increase across a layer in the entrainment from -! below, in H. Positive values go with mass gain by a layer. -! (out) htot - The accumulated mixed layer thickness, in H. -! (out) Ttot - The depth integrated mixed layer temperature, in deg C H. -! (out) Stot - The depth integrated mixed layer salinity, in psu H. -! (out) uhtot - The depth integrated mixed layer zonal velocity, H m s-1. -! (out) vhtot - The integrated mixed layer meridional velocity, H m s-1. -! (out) R0_tot - The integrated mixed layer potential density referenced -! to 0 pressure, in kg m-2. -! (out) Rcv_tot - The integrated mixed layer coordinate variable -! potential density, in kg m-2. -! (in) nsw - The number of bands of penetrating shortwave radiation. -! (out) Pen_SW_bnd - The penetrating shortwave heating at the sea surface -! in each penetrating band, in K H, size nsw x SZI_(G). -! (out) Conv_en - The buoyant turbulent kinetic energy source due to -! free convection, in m3 s-2. -! (out) dKE_FC - The vertically integrated change in kinetic energy due -! to free convection, in m3 s-2. -! (in) j - The j-index to work on. -! (in) ksort - The density-sorted k-indices. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - The control structure for this module. + ! Local variables real, dimension(SZI_(G)) :: & - massOutRem, & ! Evaporation that remains to be supplied, in H. - netMassIn ! mass entering through ocean surface (H) + massOutRem, & ! Evaporation that remains to be supplied [H ~> m or kg m-2]. + netMassIn ! mass entering through ocean surface [H ~> m or kg m-2] real :: SW_trans ! The fraction of shortwave radiation - ! that is not absorbed in a layer, ND. + ! that is not absorbed in a layer [nondim]. real :: Pen_absorbed ! The amount of penetrative shortwave radiation - ! that is absorbed in a layer, in units of K H. + ! that is absorbed in a layer [degC H ~> degC m or degC kg m-2]. real :: h_avail ! The thickness in a layer available for - ! entrainment, in H. - real :: h_ent ! The thickness from a layer that is entrained, in H. - real :: T_precip ! The temperature of the precipitation, in deg C. + ! entrainment [H ~> m or kg m-2]. + real :: h_ent ! The thickness from a layer that is entrained [H ~> m or kg m-2]. + real :: T_precip ! The temperature of the precipitation [degC]. real :: C1_3, C1_6 ! 1/3 and 1/6. real :: En_fn, Frac, x1 ! Nondimensional temporary variables. - real :: dr, dr0 ! Temporary variables with units of kg m-3 H. - real :: dr_ent, dr_comp ! Temporary variables with units of kg m-3 H. - real :: dr_dh ! The partial derivative of dr_ent with h_ent, in kg m-3. + real :: dr, dr0 ! Temporary variables [kg m-3 H ~> kg m-2 or kg2 m-5]. + real :: dr_ent, dr_comp ! Temporary variables [kg m-3 H ~> kg m-2 or kg2 m-5]. + real :: dr_dh ! The partial derivative of dr_ent with h_ent [kg m-3]. real :: h_min, h_max ! The minimum, maximum, and previous estimates for - real :: h_prev ! h_ent, in H. - real :: h_evap ! The thickness that is evaporated, in H. + real :: h_prev ! h_ent [H ~> m or kg m-2]. + real :: h_evap ! The thickness that is evaporated [H ~> m or kg m-2]. real :: dh_Newt ! The Newton's method estimate of the change in - ! h_ent between iterations, in H. - real :: g_H2_2Rho0 ! Half the gravitational acceleration times the - ! square of the conversion from H to m divided - ! by the mean density, in m6 s-2 H-2 kg-1. - real :: Angstrom ! The minimum layer thickness, in H. - real :: opacity ! The opacity converted to units of H-1. + ! h_ent between iterations [H ~> m or kg m-2]. + real :: g_H2_2Rho0 ! Half the gravitational acceleration times the square of + ! the conversion from H to Z divided by the mean density, + ! [m7 s-2 Z-1 H-2 kg-1 ~> m4 s-2 kg-1 or m10 s-2 kg-3]. + real :: Angstrom ! The minimum layer thickness [H ~> m or kg m-2]. + real :: opacity ! The opacity converted to inverse thickness units [H-1 ~> m-1 or m2 kg-1] real :: sum_Pen_En ! The potential energy change due to penetrating - ! shortwave radiation, integrated over a layer, in - ! H kg m-3. - real :: Idt ! 1.0/dt + ! shortwave radiation, integrated over a layer + ! [H kg m-3 ~> kg m-2 or kg2 m-5]. + real :: Idt ! 1.0/dt [s-1] real :: netHeatOut ! accumulated heat content of mass leaving ocean integer :: is, ie, nz, i, k, ks, itt, n real, dimension(max(nsw,1)) :: & - C2, & ! Temporary variable with units of kg m-3 H-1. - r_SW_top ! Temporary variables with units of H kg m-3. + C2, & ! Temporary variable [kg m-3 H-1 ~> kg m-4 or m-1]. + r_SW_top ! Temporary variables [H kg m-3 ~> kg m-2 or kg2 m-5]. - Angstrom = GV%Angstrom + Angstrom = GV%Angstrom_H C1_3 = 1.0/3.0 ; C1_6 = 1.0/6.0 - g_H2_2Rho0 = (GV%g_Earth * GV%H_to_m**2) / (2.0 * GV%Rho0) + g_H2_2Rho0 = (GV%g_Earth * GV%H_to_Z**2) / (2.0 * GV%Rho0) Idt = 1.0/dt is = G%isc ; ie = G%iec ; nz = GV%ke @@ -1221,7 +1113,7 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & (dRcv_dT(i)*(Net_heat(i) + Pen_absorbed) - & dRcv_dS(i) * (netMassIn(i) * S(i,1) - Net_salt(i))) Conv_En(i) = 0.0 ; dKE_FC(i) = 0.0 - if(associated(fluxes%heat_content_massin)) & + if (associated(fluxes%heat_content_massin)) & fluxes%heat_content_massin(i,j) = fluxes%heat_content_massin(i,j) & + T_precip * netMassIn(i) * GV%H_to_kg_m2 * fluxes%C_p * Idt if (associated(tv%TempxPmE)) tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + & @@ -1274,7 +1166,7 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & ! heat_content_massout = heat_content_massout - T(i,k)*h_evap*GV%H_to_kg_m2*fluxes%C_p*Idt ! by uncommenting the lines here. ! we will also then completely remove TempXpme from the model. - if(associated(fluxes%heat_content_massout)) & + if (associated(fluxes%heat_content_massout)) & fluxes%heat_content_massout(i,j) = fluxes%heat_content_massout(i,j) & - T(i,k)*h_evap*GV%H_to_kg_m2 * fluxes%C_p * Idt if (associated(tv%TempxPmE)) tv%TempxPmE(i,j) = tv%TempxPmE(i,j) - & @@ -1343,7 +1235,7 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & h_prev = h_ent ; h_ent = h_prev+dh_Newt if (h_ent > h_max) then h_ent = 0.5*(h_prev+h_max) - else if (h_ent < h_min) then + elseif (h_ent < h_min) then h_ent = 0.5*(h_prev+h_min) endif @@ -1385,7 +1277,7 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & if (h_ent > 0.0) then if (htot(i) > 0.0) & dKE_FC(i) = dKE_FC(i) + CS%bulk_Ri_convective * 0.5 * & - ((GV%H_to_m*h_ent) / (htot(i)*(h_ent+htot(i)))) * & + ((GV%H_to_Z*h_ent) / (htot(i)*(h_ent+htot(i)))) * & ((uhtot(i)-u(i,k)*htot(i))**2 + (vhtot(i)-v(i,k)*htot(i))**2) htot(i) = htot(i) + h_ent @@ -1405,40 +1297,43 @@ end subroutine mixedlayer_convection !! convection to drive mechanical entrainment. subroutine find_starting_TKE(htot, h_CA, fluxes, Conv_En, cTKE, dKE_FC, dKE_CA, & TKE, TKE_river, Idecay_len_TKE, cMKE, dt, Idt_diag, & - j, ksort, G, GV, CS) + j, ksort, G, GV, US, 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. - real, dimension(SZI_(G)), intent(in) :: htot !< The accumlated mixed layer thickness, in m - !! or kg m-2. (Intent in). + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G)), intent(in) :: htot !< The accumulated mixed layer thickness + !! [H ~> m or kg m-2] real, dimension(SZI_(G)), intent(in) :: h_CA !< The mixed layer depth after convective - !! adjustment, in H. + !! adjustment [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, dimension(SZI_(G)), intent(inout) :: Conv_En !< The buoyant turbulent kinetic energy - !! source due to free convection, - !! in m3 s-2. + real, dimension(SZI_(G)), intent(inout) :: Conv_En !< The buoyant turbulent kinetic energy source + !! due to free convection [Z m2 s-2 ~> m3 s-2]. real, dimension(SZI_(G)), intent(in) :: dKE_FC !< The vertically integrated change in - !! kinetic energy due to free convection, - !! in m3 s-2. + !! kinetic energy due to free convection + !! [Z m2 s-2 ~> m3 s-2]. real, dimension(SZI_(G),SZK_(GV)), & intent(in) :: cTKE !< The buoyant turbulent kinetic energy - !! source due to convective adjustment, - !! in m3 s-2. + !! source due to convective adjustment + !! [Z m2 s-2 ~> m3 s-2]. real, dimension(SZI_(G),SZK_(GV)), & intent(in) :: dKE_CA !< The vertically integrated change in !! kinetic energy due to convective - !! adjustment, in m3 s-2. + !! adjustment [Z m2 s-2 ~> m3 s-2]. real, dimension(SZI_(G)), intent(out) :: TKE !< The turbulent kinetic energy available for - !! mixing over a time step, in m3 s-2. + !! mixing over a time step [Z m2 s-2 ~> m3 s-2]. real, dimension(SZI_(G)), intent(out) :: Idecay_len_TKE !< The inverse of the vertical decay - !! scale for TKE, in H-1. - real, dimension(SZI_(G)), intent(in) :: TKE_river + !! scale for TKE [H-1 ~> m-1 or m2 kg-1]. + real, dimension(SZI_(G)), intent(in) :: TKE_river !< The turbulent kinetic energy available + !! for driving mixing at river mouths + !! integrated over a time step [Z m2 s-2 ~> m3 s-2]. real, dimension(2,SZI_(G)), intent(out) :: cMKE !< Coefficients of HpE and HpE^2 in !! calculating the denominator of MKE_rate, - !! in H-1 and H-2. - real, intent(in) :: dt !< The time step in s. - real, intent(in) :: Idt_diag + !! [H-1 ~> m-1 or m2 kg-1] and [H-2 ~> m-2 or m4 kg-2]. + real, intent(in) :: dt !< The time step [s]. + real, intent(in) :: Idt_diag !< The inverse of the accumulated diagnostic + !! time interval [s-1]. integer, intent(in) :: j !< The j-index to work on. integer, dimension(SZI_(G),SZK_(GV)), & intent(in) :: ksort !< The density-sorted k-indicies. @@ -1447,50 +1342,25 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, Conv_En, cTKE, dKE_FC, dKE_CA, ! This subroutine determines the TKE available at the depth of free ! convection to drive mechanical entrainment. -! Arguments: htot - The accumlated mixed layer thickness, in m or kg m-2. (Intent in) -! The units of htot are referred to as H below. -! (in) h_CA - The mixed layer depth after convective adjustment, in H. -! (in) fluxes - A structure containing pointers to any possible -! forcing fields. Unused fields have NULL ptrs. -! (in) Conv_en - The buoyant turbulent kinetic energy source due to -! free convection, in m3 s-2. -! (in) cTKE - The buoyant turbulent kinetic energy source due to -! convective adjustment, in m3 s-2. -! (in) dKE_FC - The vertically integrated change in kinetic energy due -! to free convection, in m3 s-2. -! (in) dKE_CA - The vertically integrated change in kinetic energy due -! to convective adjustment, in m3 s-2. -! (out) TKE - The turbulent kinetic energy available for mixing over a -! time step, in m3 s-2. -! (out) Idecay_len_TKE - The inverse of the vertical decay scale for -! TKE, in H-1. -! (out) cMKE - Coefficients of HpE and HpE^2 in calculating the -! denominator of MKE_rate, in H-1 and H-2. -! (in) dt - The time step in s. -! (in) j - The j-index to work on. -! (in) ksort - The density-sorted k-indicies. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - The control structure for this module. - real :: dKE_conv ! The change in mean kinetic energy due - ! to all convection, in m3 s-2. + ! Local variables + real :: dKE_conv ! The change in mean kinetic energy due to all convection [Z m2 s-2 ~> m3 s-2]. real :: nstar_FC ! The effective efficiency with which the energy released by - ! free convection is converted to TKE, often ~0.2, ND. + ! free convection is converted to TKE, often ~0.2 [nondim]. real :: nstar_CA ! The effective efficiency with which the energy released by - ! convective adjustment is converted to TKE, often ~0.2, ND. + ! convective adjustment is converted to TKE, often ~0.2 [nondim]. real :: TKE_CA ! The potential energy released by convective adjustment if - ! that release is positive, in m3 s2. - real :: MKE_rate_CA ! MKE_rate for convective adjustment, ND, 0 to 1. - real :: MKE_rate_FC ! MKE_rate for free convection, ND, 0 to 1. - real :: totEn ! The total potential energy released by convection, m3 s-2. - real :: Ih ! The inverse of a thickness, in H-1. - real :: exp_kh ! The nondimensional decay of TKE across a layer, ND. + ! that release is positive [Z m2 s-2 ~> m3 s-2]. + real :: MKE_rate_CA ! MKE_rate for convective adjustment [nondim], 0 to 1. + real :: MKE_rate_FC ! MKE_rate for free convection [nondim], 0 to 1. + real :: totEn_Z ! The total potential energy released by convection, [Z3 s-2 ~> m3 s-2]. + real :: Ih ! The inverse of a thickness [H-1 ~> m-1 or m2 kg-1]. + real :: exp_kh ! The nondimensional decay of TKE across a layer [nondim]. real :: absf ! The absolute value of f averaged to thickness points, s-1. - real :: U_star ! The friction velocity in m s-1. - real :: absf_Ustar ! The absolute value of f divided by U_star, in m-1. - real :: wind_TKE_src ! The surface wind source of TKE, in m3 s-3. + real :: U_star ! The friction velocity [Z s-1 ~> m s-1]. + real :: absf_Ustar ! The absolute value of f divided by U_star [Z-1 ~> m-1]. + real :: wind_TKE_src ! The surface wind source of TKE [Z m2 s-3 ~> m3 s-3]. real :: diag_wt ! The ratio of the current timestep to the diagnostic - ! timestep (which may include 2 calls), ND. + ! timestep (which may include 2 calls) [nondim]. integer :: is, ie, nz, i is = G%isc ; ie = G%iec ; nz = GV%ke @@ -1513,7 +1383,7 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, Conv_En, cTKE, dKE_FC, dKE_CA, absf = sqrt(CS%omega_frac*4.0*CS%omega**2 + (1.0-CS%omega_frac)*absf**2) endif absf_Ustar = absf / U_Star - Idecay_len_TKE(i) = (absf_Ustar * CS%TKE_decay) * GV%H_to_m + Idecay_len_TKE(i) = (absf_Ustar * CS%TKE_decay) * GV%H_to_Z ! The first number in the denominator could be anywhere up to 16. The ! value of 3 was chosen to minimize the time-step dependence of the amount @@ -1525,8 +1395,8 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, Conv_En, cTKE, dKE_FC, dKE_CA, ! scales contribute to mixed layer deepening at similar rates, even though ! small scales are dissipated more rapidly (implying they are less efficient). ! Ih = 1.0/(16.0*0.41*U_star*dt) - Ih = GV%H_to_m/(3.0*0.41*U_star*dt) - cMKE(1,i) = 4.0 * Ih ; cMKE(2,i) = (absf_Ustar*GV%H_to_m) * Ih + Ih = GV%H_to_Z/(3.0*0.41*U_star*dt) + cMKE(1,i) = 4.0 * Ih ; cMKE(2,i) = (absf_Ustar*GV%H_to_Z) * Ih if (Idecay_len_TKE(i) > 0.0) then exp_kh = exp(-htot(i)*Idecay_len_TKE(i)) @@ -1540,11 +1410,11 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, Conv_En, cTKE, dKE_FC, dKE_CA, if (Conv_En(i) < 0.0) Conv_En(i) = 0.0 if (cTKE(i,1) > 0.0) then ; TKE_CA = cTKE(i,1) ; else ; TKE_CA = 0.0 ; endif if ((htot(i) >= h_CA(i)) .or. (TKE_CA == 0.0)) then - totEn = Conv_En(i) + TKE_CA + totEn_Z = US%m_to_Z**2 * (Conv_En(i) + TKE_CA) - if (totEn > 0.0) then - nstar_FC = CS%nstar * totEn / (totEn + 0.2 * & - sqrt(0.5 * dt * (absf*(htot(i)*GV%H_to_m))**3 * totEn)) + if (totEn_Z > 0.0) then + nstar_FC = CS%nstar * totEn_Z / (totEn_Z + 0.2 * & + sqrt(0.5 * dt * (absf*(htot(i)*GV%H_to_Z))**3 * totEn_Z)) else nstar_FC = CS%nstar endif @@ -1552,17 +1422,17 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, Conv_En, cTKE, dKE_FC, dKE_CA, else ! This reconstructs the Buoyancy flux within the topmost htot of water. if (Conv_En(i) > 0.0) then - totEn = Conv_En(i) + TKE_CA * (htot(i) / h_CA(i)) - nstar_FC = CS%nstar * totEn / (totEn + 0.2 * & - sqrt(0.5 * dt * (absf*(htot(i)*GV%H_to_m))**3 * totEn)) + totEn_Z = US%m_to_Z**2 * (Conv_En(i) + TKE_CA * (htot(i) / h_CA(i)) ) + nstar_FC = CS%nstar * totEn_Z / (totEn_Z + 0.2 * & + sqrt(0.5 * dt * (absf*(htot(i)*GV%H_to_Z))**3 * totEn_Z)) else nstar_FC = CS%nstar endif - totEn = Conv_En(i) + TKE_CA + totEn_Z = US%m_to_Z**2 * (Conv_En(i) + TKE_CA) if (TKE_CA > 0.0) then - nstar_CA = CS%nstar * totEn / (totEn + 0.2 * & - sqrt(0.5 * dt * (absf*(h_CA(i)*GV%H_to_m))**3 * totEn)) + nstar_CA = CS%nstar * totEn_Z / (totEn_Z + 0.2 * & + sqrt(0.5 * dt * (absf*(h_CA(i)*GV%H_to_Z))**3 * totEn_Z)) else nstar_CA = CS%nstar endif @@ -1584,27 +1454,26 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, Conv_En, cTKE, dKE_FC, dKE_CA, dKE_conv = dKE_CA(i,1) * MKE_rate_CA + dKE_FC(i) * MKE_rate_FC ! At this point, it is assumed that cTKE is positive and stored in TKE_CA! ! Note: Removed factor of 2 in u*^3 terms. - TKE(i) = (dt*CS%mstar)*((U_Star*U_Star*U_Star)*exp_kh) + & - (exp_kh * dKE_conv + nstar_FC*Conv_En(i) + nstar_CA*TKE_CA) -! Add additional TKE at river mouths + TKE(i) = (dt*CS%mstar)*((US%Z_to_m**2*(U_Star*U_Star*U_Star))*exp_kh) + & + (exp_kh * dKE_conv + nstar_FC*Conv_En(i) + nstar_CA * TKE_CA) - if (CS%do_rivermix) then + if (CS%do_rivermix) then ! Add additional TKE at river mouths TKE(i) = TKE(i) + TKE_river(i)*dt*exp_kh endif if (CS%TKE_diagnostics) then - wind_TKE_src = CS%mstar*(U_Star*U_Star*U_Star) * diag_wt + wind_TKE_src = CS%mstar*(US%Z_to_m**2*U_Star*U_Star*U_Star) * diag_wt CS%diag_TKE_wind(i,j) = CS%diag_TKE_wind(i,j) + & - wind_TKE_src + TKE_river(i) * diag_wt + ( wind_TKE_src + TKE_river(i) * diag_wt ) CS%diag_TKE_RiBulk(i,j) = CS%diag_TKE_RiBulk(i,j) + dKE_conv*Idt_diag CS%diag_TKE_mech_decay(i,j) = CS%diag_TKE_mech_decay(i,j) + & (exp_kh-1.0)*(wind_TKE_src + dKE_conv*Idt_diag) CS%diag_TKE_conv(i,j) = CS%diag_TKE_conv(i,j) + & - Idt_diag*(nstar_FC*Conv_En(i) + nstar_CA*TKE_CA) + Idt_diag * (nstar_FC*Conv_En(i) + nstar_CA*TKE_CA) CS%diag_TKE_conv_decay(i,j) = CS%diag_TKE_conv_decay(i,j) + & - Idt_diag*((CS%nstar-nstar_FC)*Conv_En(i) + (CS%nstar-nstar_CA)*TKE_CA) + Idt_diag * ((CS%nstar-nstar_FC)*Conv_En(i) + (CS%nstar-nstar_CA)*TKE_CA) CS%diag_TKE_conv_s2(i,j) = CS%diag_TKE_conv_s2(i,j) + & - Idt_diag*(cTKE(i,1)-TKE_CA) + Idt_diag * (cTKE(i,1)-TKE_CA) endif enddo @@ -1615,132 +1484,127 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & R0_tot, Rcv_tot, u, v, T, S, R0, Rcv, eps, & dR0_dT, dRcv_dT, cMKE, Idt_diag, nsw, & Pen_SW_bnd, opacity_band, TKE, & - Idecay_len_TKE, j, ksort, G, GV, 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. - real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: h !< Layer thickness, in m or kg m-2. - !! (Intent in/out) The units of h are - !! referred to as H below. - real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: d_eb !< The downward increase across a - !! layer in the entrainment from - !! below, in H. Positive values go - !! with mass gain by a layer. - real, dimension(SZI_(G)), intent(inout) :: htot !< The accumlated mixed layer - !! thickness, in H. - real, dimension(SZI_(G)), intent(inout) :: Ttot !< The depth integrated mixed layer - !! temperature, in deg C H. - real, dimension(SZI_(G)), intent(inout) :: Stot !< The depth integrated mixed layer - !! salinity, in psu H. - real, dimension(SZI_(G)), intent(inout) :: uhtot !< The depth integrated mixed layer - !! zonal velocity, H m s-1. - real, dimension(SZI_(G)), intent(inout) :: vhtot !< The integrated mixed layer - !! meridional velocity, H m s-1. - real, dimension(SZI_(G)), intent(inout) :: R0_tot !< The integrated mixed layer - !! potential density referenced to 0 - !! pressure, in H kg m-3. - real, dimension(SZI_(G)), intent(inout) :: Rcv_tot !< The integrated mixed layer - !! coordinate variable potential - !! density, in H kg m-3. - real, dimension(SZI_(G),SZK_(GV)), intent(in) :: u, v, T, S, R0, Rcv, eps - real, dimension(SZI_(G)), intent(in) :: dR0_dT, dRcv_dT - real, dimension(2,SZI_(G)), intent(in) :: cMKE - real, intent(in) :: Idt_diag - integer, intent(in) :: nsw !< The number of bands of penetrating - !! shortwave radiation. - real, dimension(:,:), intent(inout) :: Pen_SW_bnd !< The penetrating shortwave - !! heating at the sea surface in each - !! penetrating band, in K H, - !! size nsw x SZI_(G). - real, dimension(:,:,:), intent(in) :: opacity_band - real, dimension(SZI_(G)), intent(inout) :: TKE !< The turbulent kinetic energy - !! available for mixing over a time - !! step, in m3 s-2. - real, dimension(SZI_(G)), intent(inout) :: Idecay_len_TKE - integer, intent(in) :: j !< The j-index to work on. + Idecay_len_TKE, j, ksort, G, GV, US, 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. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZK_(GV)), & + intent(inout) :: h !< Layer thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZK_(GV)), & + intent(inout) :: d_eb !< The downward increase across a layer in the + !! layer in the entrainment from below [H ~> m or kg m-2]. + !! Positive values go with mass gain by a layer. + real, dimension(SZI_(G)), intent(inout) :: htot !< The accumlated mixed layer thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G)), intent(inout) :: Ttot !< The depth integrated mixed layer temperature + !! [degC H ~> degC m or degC kg m-2]. + real, dimension(SZI_(G)), intent(inout) :: Stot !< The depth integrated mixed layer salinity + !! [ppt H ~> ppt m or ppt kg m-2]. + real, dimension(SZI_(G)), intent(inout) :: uhtot !< The depth integrated mixed layer zonal + !! velocity, H m s-1. + real, dimension(SZI_(G)), intent(inout) :: vhtot !< The integrated mixed layer meridional + !! velocity, H m s-1. + real, dimension(SZI_(G)), intent(inout) :: R0_tot !< The integrated mixed layer potential density + !! referenced to 0 pressure [H kg m-3 ~> kg m-2 or kg2 m-5]. + real, dimension(SZI_(G)), intent(inout) :: Rcv_tot !< The integrated mixed layer coordinate variable + !! potential density [H kg m-3 ~> kg m-2 or kg2 m-5]. + real, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: u !< Zonal velocities interpolated to h points, m s-1. + real, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: v !< Zonal velocities interpolated to h points, m s-1. + real, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: T !< Layer temperatures [degC]. + real, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: S !< Layer salinities [ppt]. + real, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: R0 !< Potential density referenced to + !! surface pressure [kg m-3]. + real, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: Rcv !< The coordinate defining potential + !! density [kg m-3]. + real, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: eps !< The negligibly small amount of water + !! that will be left in each layer [H ~> m or kg m-2]. + real, dimension(SZI_(G)), intent(in) :: dR0_dT !< The partial derivative of R0 with respect to + !! temperature [kg m-3 degC-1]. + real, dimension(SZI_(G)), intent(in) :: dRcv_dT !< The partial derivative of Rcv with respect to + !! temperature [kg m-3 degC-1]. + real, dimension(2,SZI_(G)), intent(in) :: cMKE !< Coefficients of HpE and HpE^2 used in calculating the + !! denominator of MKE_rate; the two elements have differing + !! units of [H-1 ~> m-1 or m2 kg-1] and [H-2 ~> m-2 or m4 kg-2]. + real, intent(in) :: Idt_diag !< The inverse of the accumulated diagnostic + !! time interval [s-1]. + integer, intent(in) :: nsw !< The number of bands of penetrating + !! shortwave radiation. + real, dimension(:,:), intent(inout) :: Pen_SW_bnd !< The penetrating shortwave heating at the + !! sea surface in each penetrating band + !! [degC H ~> degC m or degC kg m-2], + !! size nsw x SZI_(G). + real, dimension(:,:,:), intent(in) :: opacity_band !< The opacity in each band of penetrating + !! shortwave radiation [H-1 ~> m-1 or m2 kg-1]. + !! The indicies of opacity_band are (band, i, k). + real, dimension(SZI_(G)), intent(inout) :: TKE !< The turbulent kinetic energy + !! available for mixing over a time + !! step [Z m2 s-2 ~> m3 s-2]. + real, dimension(SZI_(G)), intent(inout) :: Idecay_len_TKE !< The vertical TKE decay rate [H-1 ~> m-1 or m2 kg-1]. + integer, intent(in) :: j !< The j-index to work on. integer, dimension(SZI_(G),SZK_(GV)), & - intent(in) :: ksort !< The density-sorted k-indicies. - type(bulkmixedlayer_CS), pointer :: CS !< The control structure for this - !! module. + intent(in) :: ksort !< The density-sorted k-indicies. + type(bulkmixedlayer_CS), pointer :: CS !< The control structure for this module. ! This subroutine calculates mechanically driven entrainment. -! Arguments: h - Layer thickness, in m or kg m-2. (Intent in/out) The units -! of h are referred to as H below. -! (in/out) d_eb - The downward increase across a layer in the entrainment from -! below, in H. Positive values go with mass gain by a layer. -! (in/out) htot - The accumlated mixed layer thickness, in H. -! (in/out) Ttot - The depth integrated mixed layer temperature, in deg C H. -! (in/out) Stot - The depth integrated mixed layer salinity, in psu H. -! (in/out) uhtot - The depth integrated mixed layer zonal velocity, H m s-1. -! (in/out) vhtot - The integrated mixed layer meridional velocity, H m s-1. -! (in/out) R0_tot - The integrated mixed layer potential density referenced -! to 0 pressure, in H kg m-3. -! (in/out) Rcv_tot - The integrated mixed layer coordinate variable -! potential density, in H kg m-3. -! (in) nsw - The number of bands of penetrating shortwave radiation. -! (in/out) Pen_SW_bnd - The penetrating shortwave heating at the sea surface -! in each penetrating band, in K H, size nsw x SZI_(G). -! (in/out) TKE - The turbulent kinetic energy available for mixing over a -! time step, in m3 s-2. -! (in) j - The j-index to work on. -! (in) ksort - The density-sorted k-indicies. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - The control structure for this module. + ! Local variables real :: SW_trans ! The fraction of shortwave radiation that is not ! absorbed in a layer, nondimensional. real :: Pen_absorbed ! The amount of penetrative shortwave radiation - ! that is absorbed in a layer, in units of K m. - real :: h_avail ! The thickness in a layer available for entrainment in H. - real :: h_ent ! The thickness from a layer that is entrained, in H. - real :: h_min, h_max ! Limits on the solution for h_ent, in H. + ! that is absorbed in a layer [degC H ~> degC m or degC kg m-2]. + real :: h_avail ! The thickness in a layer available for entrainment [H ~> m or kg m-2]. + real :: h_ent ! The thickness from a layer that is entrained [H ~> m or kg m-2]. + real :: h_min, h_max ! Limits on the solution for h_ent [H ~> m or kg m-2]. real :: dh_Newt ! The Newton's method estimate of the change in - ! h_ent between iterations, in H. + ! h_ent between iterations [H ~> m or kg m-2]. real :: MKE_rate ! The fraction of the energy in resolved shears ! within the mixed layer that will be eliminated ! within a timestep, nondim, 0 to 1. - real :: HpE ! The current thickness plus entrainment, H. + real :: HpE ! The current thickness plus entrainment [H ~> m or kg m-2]. real :: g_H_2Rho0 ! Half the gravitational acceleration times the ! conversion from H to m divided by the mean density, ! in m5 s-2 H-1 kg-1. - real :: TKE_full_ent ! The TKE remaining if a layer is fully entrained, - ! in units of m3 s-2. + real :: TKE_full_ent ! The TKE remaining if a layer is fully entrained + ! [Z m2 s-2 ~> m3 s-2]. real :: dRL ! Work required to mix water from the next layer - ! across the mixed layer, in m2 s-2. + ! across the mixed layer [m2 s-2]. real :: Pen_En_Contrib ! Penetrating SW contributions to the changes in - ! TKE, divided by layer thickness in m, in m2 s-2. - real :: C1 ! A temporary variable in units of m2 s-2. + ! TKE, divided by layer thickness in m [m2 s-2]. + real :: C1 ! A temporary variable [m2 s-2]. real :: dMKE ! A temporary variable related to the release of mean - ! kinetic energy, with units of H m3 s-2. - real :: TKE_ent ! The TKE that remains if h_ent were entrained, in m3 s-2. + ! kinetic energy, with units of H Z m2 s-2. + real :: TKE_ent ! The TKE that remains if h_ent were entrained [Z m2 s-2 ~> m3 s-2]. real :: TKE_ent1 ! The TKE that would remain, without considering the - ! release of mean kinetic energy, in m3 s2. - real :: dTKE_dh ! The partial derivative of TKE with h_ent, in m3 s-2 H-1. + ! release of mean kinetic energy [Z m2 s-2 ~> m3 s-2]. + real :: dTKE_dh ! The partial derivative of TKE with h_ent [Z m2 s-2 H-1 ~> m2 s-2 or m5 s-2 kg-1]. real :: Pen_dTKE_dh_Contrib ! The penetrating shortwave contribution to - ! dTKE_dh, in m2 s-2. - real :: EF4_val ! The result of EF4() (see later), in H-1. + ! dTKE_dh [m2 s-2]. + real :: EF4_val ! The result of EF4() (see later) [H-1 ~> m-1 or m2 kg-1]. real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected, in H. - real :: dEF4_dh ! The partial derivative of EF4 with h, in H-2. + ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: dEF4_dh ! The partial derivative of EF4 with h [H-2 ~> m-2 or m4 kg-2]. real :: Pen_En1 ! A nondimensional temporary variable. - real :: kh, exp_kh ! Nondimensional temporary variables related to the. + real :: kh, exp_kh ! Nondimensional temporary variables related to the real :: f1_kh ! fractional decay of TKE across a layer. real :: x1, e_x1 ! Nondimensional temporary variables related to real :: f1_x1, f2_x1 ! the relative decay of TKE and SW radiation across real :: f3_x1 ! a layer, and exponential-related functions of x1. real :: E_HxHpE ! Entrainment divided by the product of the new and old - ! thicknesses, in H-1. - real :: Hmix_min ! The minimum mixed layer depth in H. - real :: H_to_m ! Local copies of unit conversion factors. + ! thicknesses [H-1 ~> m-1 or m2 kg-1]. + real :: Hmix_min ! The minimum mixed layer depth [H ~> m or kg m-2]. real :: opacity real :: C1_3, C1_6, C1_24 ! 1/3, 1/6, and 1/24. integer :: is, ie, nz, i, k, ks, itt, n C1_3 = 1.0/3.0 ; C1_6 = 1.0/6.0 ; C1_24 = 1.0/24.0 - H_to_m = GV%H_to_m - g_H_2Rho0 = (GV%g_Earth * H_to_m) / (2.0 * GV%Rho0) - Hmix_min = CS%Hmix_min * GV%m_to_H + g_H_2Rho0 = (GV%g_Earth * GV%H_to_Z) / (2.0 * GV%Rho0) + Hmix_min = CS%Hmix_min h_neglect = GV%H_subroundoff is = G%isc ; ie = G%iec ; nz = GV%ke @@ -1752,7 +1616,7 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & h_avail = h(i,k) - eps(i,k) if ((h_avail > 0.) .and. ((TKE(i) > 0.) .or. (htot(i) < Hmix_min))) then dRL = g_H_2Rho0 * (R0(i,k)*htot(i) - R0_tot(i) ) - dMKE = (H_to_m * CS%bulk_Ri_ML) * 0.5 * & + dMKE = (GV%H_to_Z * CS%bulk_Ri_ML) * 0.5 * & ((uhtot(i)-u(i,k)*htot(i))**2 + (vhtot(i)-v(i,k)*htot(i))**2) ! Find the TKE that would remain if the entire layer were entrained. @@ -1798,7 +1662,7 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & HpE = htot(i)+h_avail MKE_rate = 1.0/(1.0 + (cMKE(1,i)*HpE + cMKE(2,i)*HpE**2)) EF4_val = EF4(htot(i)+h_neglect,h_avail,Idecay_len_TKE(i)) - TKE_full_ent = (exp_kh*TKE(i) - (h_avail*H_to_m)*(dRL*f1_kh + Pen_En_Contrib)) + & + TKE_full_ent = (exp_kh*TKE(i) - (h_avail*GV%H_to_Z)*(dRL*f1_kh + Pen_En_Contrib)) + & MKE_rate*dMKE*EF4_val if ((TKE_full_ent >= 0.0) .or. (h_avail+htot(i) <= Hmix_min)) then ! The layer will be fully entrained. @@ -1808,18 +1672,18 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & E_HxHpE = h_ent / ((htot(i)+h_neglect)*(htot(i)+h_ent+h_neglect)) CS%diag_TKE_mech_decay(i,j) = CS%diag_TKE_mech_decay(i,j) + & Idt_diag * ((exp_kh-1.0)*TKE(i) + & - (h_ent*H_to_m)*dRL*(1.0-f1_kh) + & + (h_ent*GV%H_to_Z)*dRL*(1.0-f1_kh) + & MKE_rate*dMKE*(EF4_val-E_HxHpE)) CS%diag_TKE_mixing(i,j) = CS%diag_TKE_mixing(i,j) - & - Idt_diag*(H_to_m*h_ent)*dRL + Idt_diag*(GV%H_to_Z*h_ent)*dRL CS%diag_TKE_pen_SW(i,j) = CS%diag_TKE_pen_SW(i,j) - & - Idt_diag*(H_to_m*h_ent)*Pen_En_Contrib + Idt_diag*(GV%H_to_Z*h_ent)*Pen_En_Contrib CS%diag_TKE_RiBulk(i,j) = CS%diag_TKE_RiBulk(i,j) + & Idt_diag*MKE_rate*dMKE*E_HxHpE endif TKE(i) = TKE_full_ent - if (TKE(i) <= 0.0) TKE(i) = 1.0e-150 + if (TKE(i) <= 0.0) TKE(i) = 1.0e-150*US%m_to_Z else ! The layer is only partially entrained. The amount that will be ! entrained is determined iteratively. No further layers will be @@ -1878,16 +1742,16 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & C1*((1.0-SW_trans) - opacity*(htot(i) + h_ent)*SW_trans) endif ; enddo ! (Pen_SW_bnd(n,i) > 0.0) - TKE_ent1 = exp_kh*TKE(i) - (h_ent*H_to_m)*(dRL*f1_kh + Pen_En_Contrib) + TKE_ent1 = exp_kh*TKE(i) - (h_ent*GV%H_to_Z)*(dRL*f1_kh + Pen_En_Contrib) EF4_val = EF4(htot(i)+h_neglect,h_ent,Idecay_len_TKE(i),dEF4_dh) HpE = htot(i)+h_ent MKE_rate = 1.0/(1.0 + (cMKE(1,i)*HpE + cMKE(2,i)*HpE**2)) TKE_ent = TKE_ent1 + dMKE*EF4_val*MKE_rate ! TKE_ent is the TKE that would remain if h_ent were entrained. - dTKE_dh = ((-Idecay_len_TKE(i)*TKE_ent1 - dRL*H_to_m) + & - Pen_dTKE_dh_Contrib*H_to_m) + dMKE * MKE_rate* & - (dEF4_dh - EF4_val*MKE_rate*(cMKE(1,i)+2.0*cMKE(2,i)*HpE)) + dTKE_dh = ((-Idecay_len_TKE(i)*TKE_ent1 - dRL*GV%H_to_Z) + & + Pen_dTKE_dh_Contrib*GV%H_to_Z) + dMKE * MKE_rate* & + (dEF4_dh - EF4_val*MKE_rate*(cMKE(1,i)+2.0*cMKE(2,i)*HpE)) ! dh_Newt = -TKE_ent / dTKE_dh ! Bisect if the Newton's method prediction is outside of the bounded range. if (TKE_ent > 0.0) then @@ -1907,7 +1771,7 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & endif h_ent = h_ent + dh_Newt - if (ABS(dh_Newt) < 0.2*GV%Angstrom) exit + if (ABS(dh_Newt) < 0.2*GV%Angstrom_H) exit enddo endif @@ -1921,12 +1785,12 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & E_HxHpE = h_ent / ((htot(i)+h_neglect)*(HpE+h_neglect)) CS%diag_TKE_mech_decay(i,j) = CS%diag_TKE_mech_decay(i,j) + & Idt_diag * ((exp_kh-1.0)*TKE(i) + & - (h_ent*H_to_m)*dRL*(1.0-f1_kh) + & + (h_ent*GV%H_to_Z)*dRL*(1.0-f1_kh) + & dMKE*MKE_rate*(EF4_val-E_HxHpE)) CS%diag_TKE_mixing(i,j) = CS%diag_TKE_mixing(i,j) - & - Idt_diag*(h_ent*H_to_m)*dRL + Idt_diag*(h_ent*GV%H_to_Z)*dRL CS%diag_TKE_pen_SW(i,j) = CS%diag_TKE_pen_SW(i,j) - & - Idt_diag*(h_ent*H_to_m)*Pen_En_Contrib + Idt_diag*(h_ent*GV%H_to_Z)*Pen_En_Contrib CS%diag_TKE_RiBulk(i,j) = CS%diag_TKE_RiBulk(i,j) + & Idt_diag*dMKE*MKE_rate*E_HxHpE endif @@ -1964,32 +1828,16 @@ end subroutine mechanical_entrainment subroutine sort_ML(h, R0, eps, G, GV, CS, ksort) 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),SZK_(GV)), intent(in) :: h !< Layer thickness, in m or kg m-2. - !! (Intent in/out) The units of h are - !! referred to as H below. + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. real, dimension(SZI_(G),SZK_(GV)), intent(in) :: R0 !< The potential density used to sort - !! the layers, in kg m-3. + !! the layers [kg m-3]. real, dimension(SZI_(G),SZK_(GV)), intent(in) :: eps !< The (small) thickness that must - !! remain in each layer, in H. + !! remain in each layer [H ~> m or kg m-2]. type(bulkmixedlayer_CS), pointer :: CS !< The control structure returned by a !! previous call to mixedlayer_init. integer, dimension(SZI_(G),SZK_(GV)), intent(out) :: ksort !< The k-index to use in the sort. -! This subroutine generates an array of indices that are sorted by layer -! density. - -! Arguments: h - Layer thickness, in m or kg m-2. (Intent in/out) The units -! of h are referred to as H below. -! (in) R0 - The potential density used to sort the layers, in kg m-3. -! (in) eps - The (small) thickness that must remain in each layer, in H. -! (in) tv - A structure containing pointers to any available -! thermodynamic fields. Absent fields have NULL ptrs. -! (in) j - The meridional row to work on. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - The control structure returned by a previous call to -! mixedlayer_init. -! (out) ksort - The k-index to use in the sort. + ! Local variables real :: R0sort(SZI_(G),SZK_(GV)) integer :: nsort(SZI_(G)) logical :: done_sorting(SZI_(G)) @@ -2033,28 +1881,26 @@ subroutine resort_ML(h, T, S, R0, Rcv, RcvTgt, eps, d_ea, d_eb, ksort, G, GV, 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. - real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: h !< Layer thickness, in m or kg m-2. - !! (Intent in/out) The units of h - !! are referred to as H below. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2]. !! Layer 0 is the new mixed layer. - real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: T !< Layer temperatures, in deg C. - real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: S !< Layer salinities, in psu. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: T !< Layer temperatures [degC]. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: S !< Layer salinities [ppt]. real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: R0 !< Potential density referenced to - !! surface pressure, in kg m-3. + !! surface pressure [kg m-3]. real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: Rcv !< The coordinate defining - !! potential density, in kg m-3. + !! potential density [kg m-3]. real, dimension(SZK_(GV)), intent(in) :: RcvTgt !< The target value of Rcv for each - !! layer, in kg m-3. + !! layer [kg m-3]. real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: eps !< The (small) thickness that must - !! remain in each layer, in H. + !! remain in each layer [H ~> m or kg m-2]. real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: d_ea !< The upward increase across a !! layer in the entrainment from - !! above, in m or kg m-2 (H). + !! above [H ~> m or kg m-2]. !! Positive d_ea goes with layer !! thickness increases. real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: d_eb !< The downward increase across a !! layer in the entrainment from - !! below, in H. Positive values go + !! below [H ~> m or kg m-2]. Positive values go !! with mass gain by a layer. integer, dimension(SZI_(G),SZK_(GV)), intent(in) :: ksort !< The density-sorted k-indicies. type(bulkmixedlayer_CS), pointer :: CS !< The control structure for this @@ -2062,49 +1908,19 @@ subroutine resort_ML(h, T, S, R0, Rcv, RcvTgt, eps, d_ea, d_eb, ksort, G, GV, CS real, dimension(SZI_(G)), intent(in) :: dR0_dT !< The partial derivative of !! potential density referenced !! to the surface with potential - !! temperature, in kg m-3 K-1. + !! temperature [kg m-3 degC-1]. real, dimension(SZI_(G)), intent(in) :: dR0_dS !< The partial derivative of !! cpotential density referenced !! to the surface with salinity, - !! in kg m-3 psu-1. + !! [kg m-3 ppt-1]. real, dimension(SZI_(G)), intent(in) :: dRcv_dT !< The partial derivative of !! coordinate defining potential !! density with potential - !! temperature, in kg m-3 K-1. + !! temperature [kg m-3 degC-1]. real, dimension(SZI_(G)), intent(in) :: dRcv_dS !< The partial derivative of !! coordinate defining potential !! density with salinity, - !! in kg m-3 psu-1. - -! This subroutine actually moves properties between layers to achieve a -! resorted state, with all of the resorted water either moved into the correct -! interior layers or in the top nkmb layers. -! -! Arguments: h - Layer thickness, in m or kg m-2. (Intent in/out) The units of -! h are referred to as H below. Layer 0 is the new mixed layer. -! (in/out) T - Layer temperatures, in deg C. -! (in/out) S - Layer salinities, in psu. -! (in/out) R0 - Potential density referenced to surface pressure, in kg m-3. -! (in/out) Rcv - The coordinate defining potential density, in kg m-3. -! (in) RcvTgt - The target value of Rcv for each layer, in kg m-3. -! (in) eps - The (small) thickness that must remain in each layer, in H. -! (in/out) d_ea - The upward increase across a layer in the entrainment from -! above, in m or kg m-2 (H). Positive d_ea goes with layer -! thickness increases. -! (in/out) d_eb - The downward increase across a layer in the entrainment from -! below, in H. Positive values go with mass gain by a layer. -! (in) ksort - The density-sorted k-indicies. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - The control structure for this module. -! (in/out) dR0_dT - The partial derivative of potential density referenced -! to the surface with potential temperature, in kg m-3 K-1. -! (in/out) dR0_dS - The partial derivative of cpotential density referenced -! to the surface with salinity, in kg m-3 psu-1. -! (in/out) dRcv_dT - The partial derivative of coordinate defining potential -! density with potential temperature, in kg m-3 K-1. -! (in/out) dRcv_dS - The partial derivative of coordinate defining potential -! density with salinity, in kg m-3 psu-1. + !! [kg m-3 ppt-1]. ! If there are no massive light layers above the deepest of the mixed- and ! buffer layers, do nothing (except perhaps to reshuffle these layers). @@ -2118,6 +1934,8 @@ subroutine resort_ML(h, T, S, R0, Rcv, RcvTgt, eps, d_ea, d_eb, ksort, G, GV, CS ! those buffer layers into peices that match the target density of the two ! nearest interior layers. ! Otherwise, if there are more than nkbl+1 remaining massive layers + + ! Local variables real :: h_move, h_tgt_old, I_hnew real :: dT_dS_wt2, dT_dR, dS_dR, I_denom real :: Rcv_int @@ -2385,146 +2203,122 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, dR0_dT, dR0_dS, dRcv_dT, dRcv_dS, max_BL_det) 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),SZK0_(GV)), intent(inout) :: h !< Layer thickness, in m or kg m-2. - !! (Intent in/out) The units of h are - !! referred to as H below. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2]. !! Layer 0 is the new mixed layer. - real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: T !< Potential temperature, in C. - real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: S !< Salinity, in psu. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: T !< Potential temperature [degC]. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: S !< Salinity [ppt]. real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: R0 !< Potential density referenced to - !! surface pressure, in kg m-3. + !! surface pressure [kg m-3]. real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: Rcv !< The coordinate defining potential - !! density, in kg m-3. + !! density [kg m-3]. real, dimension(SZK_(GV)), intent(in) :: RcvTgt !< The target value of Rcv for each - !! layer, in kg m-3. - real, intent(in) :: dt !< Time increment, in s. - real, intent(in) :: dt_diag !< The diagnostic time step, in s. + !! layer [kg m-3]. + real, intent(in) :: dt !< Time increment [s]. + real, intent(in) :: dt_diag !< The diagnostic time step [s]. real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: d_ea !< The upward increase across a layer in - !! the entrainment from above, in m or - !! kg m-2 (H). Positive d_ea goes with - !! layer thickness increases. + !! the entrainment from above + !! [H ~> m or kg m-2]. Positive d_ea + !! goes with layer thickness increases. integer, intent(in) :: j !< The meridional row to work on. type(bulkmixedlayer_CS), pointer :: CS !< The control structure returned by a !! previous call to mixedlayer_init. real, dimension(SZI_(G)), intent(in) :: dR0_dT !< The partial derivative of !! potential density referenced to the !! surface with potential temperature, - !! in kg m-3 K-1. + !! [kg m-3 degC-1]. real, dimension(SZI_(G)), intent(in) :: dR0_dS !< The partial derivative of !! cpotential density referenced to the - !! surface with salinity, - !! in kg m-3 psu-1. + !! surface with salinity + !! [kg m-3 ppt-1]. real, dimension(SZI_(G)), intent(in) :: dRcv_dT !< The partial derivative of !! coordinate defining potential density !! with potential temperature, - !! in kg m-3 K-1. + !! [kg m-3 degC-1]. real, dimension(SZI_(G)), intent(in) :: dRcv_dS !< The partial derivative of !! coordinate defining potential density - !! with salinity, in kg m-3 psu-1. + !! with salinity [kg m-3 ppt-1]. real, dimension(SZI_(G)), intent(in) :: max_BL_det !< If non-negative, the maximum !! detrainment permitted from the buffer - !! layers, in H. + !! layers [H ~> m or kg m-2]. ! This subroutine moves any water left in the former mixed layers into the ! two buffer layers and may also move buffer layer water into the interior ! isopycnal layers. -! Arguments: h - Layer thickness, in m or kg m-2. (Intent in/out) The units of -! h are referred to as H below. Layer 0 is the new mixed layer. -! (in/out) T - Potential temperature, in C. -! (in/out) S - Salinity, in psu. -! (in/out) R0 - Potential density referenced to surface pressure, in kg m-3. -! (in/out) Rcv - The coordinate defining potential density, in kg m-3. -! (in) RcvTgt - The target value of Rcv for each layer, in kg m-3. -! (in) dt - Time increment, in s. -! (in) dt_diag - The diagnostic time step, in s. -! (in/out) d_ea - The upward increase across a layer in the entrainment from -! above, in m or kg m-2 (H). Positive d_ea goes with layer -! thickness increases. -! (in) j - The meridional row to work on. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - The control structure returned by a previous call to -! mixedlayer_init. -! (in) max_BL_det - If non-negative, the maximum detrainment permitted -! from the buffer layers, in H. -! (in) dR0_dT - The partial derivative of potential density referenced -! to the surface with potential temperature, in kg m-3 K-1. -! (in) dR0_dS - The partial derivative of cpotential density referenced -! to the surface with salinity, in kg m-3 psu-1. -! (in) dRcv_dT - The partial derivative of coordinate defining potential -! density with potential temperature, in kg m-3 K-1. -! (in) dRcv_dS - The partial derivative of coordinate defining potential -! density with salinity, in kg m-3 psu-1. + ! Local variables real :: h_to_bl ! The total thickness detrained to the buffer - ! layers, in H (the units of h). - real :: R0_to_bl, Rcv_to_bl ! The depth integrated amount of R0, Rcv, T - real :: T_to_bl, S_to_bl ! and S that is detrained to the buffer layer, - ! in H kg m-3, H kg m-3, K H, and psu H. - - real :: h_min_bl ! The minimum buffer layer thickness, in H. + ! layers [H ~> m or kg m-2]. + real :: R0_to_bl ! The depth integrated amount of R0 that is detrained to the + ! buffer layer [H kg m-3 ~> kg m-2 or kg2 m-5] + real :: Rcv_to_bl ! The depth integrated amount of Rcv that is detrained to the + ! buffer layer [H kg m-3 ~> kg m-2 or kg2 m-5] + real :: T_to_bl ! The depth integrated amount of T that is detrained to the + ! buffer layer [degC H ~> degC m or degC kg m-2] + real :: S_to_bl ! The depth integrated amount of S that is detrained to the + ! buffer layer [ppt H ~> ppt m or ppt kg m-2] + real :: h_min_bl ! The minimum buffer layer thickness [H ~> m or kg m-2]. real :: h_min_bl_thick ! The minimum buffer layer thickness when the - ! mixed layer is very large, in H. + ! mixed layer is very large [H ~> m or kg m-2]. real :: h_min_bl_frac_ml = 0.05 ! The minimum buffer layer thickness relative ! to the total mixed layer thickness for thin - ! mixed layers, nondim., maybe 0.1/CS%nkbl. + ! mixed layers [nondim], maybe 0.1/CS%nkbl. real :: h1, h2 ! Scalar variables holding the values of - ! h(i,CS%nkml+1) and h(i,CS%nkml+2), in H. - real :: h1_avail ! The thickess of the upper buffer layer + ! h(i,CS%nkml+1) and h(i,CS%nkml+2) [H ~> m or kg m-2]. + real :: h1_avail ! The thickness of the upper buffer layer ! available to move into the lower buffer - ! layer, in H. + ! layer [H ~> m or kg m-2]. real :: stays ! stays is the thickness of the upper buffer - ! layer that remains there, in units of H. + ! layer that remains there [H ~> m or kg m-2]. real :: stays_min, stays_max ! The minimum and maximum permitted values of - ! stays, in units of H. + ! stays [H ~> m or kg m-2]. logical :: mergeable_bl ! If true, it is an option to combine the two ! buffer layers and create water that matches ! the target density of an interior layer. real :: stays_merge ! If the two buffer layers can be combined ! stays_merge is the thickness of the upper - ! layer that remains, in units of H. - real :: stays_min_merge ! The minimum allowed value of stays_merge in H. + ! layer that remains [H ~> m or kg m-2]. + real :: stays_min_merge ! The minimum allowed value of stays_merge [H ~> m or kg m-2]. - real :: dR0_2dz, dRcv_2dz ! Half the vertical gradients of R0, Rcv, T, and -! real :: dT_2dz, dS_2dz ! S, in kg m-4, kg m-4, K m-1, and psu m-1. + real :: dR0_2dz, dRcv_2dz ! Half the vertical gradients of R0 and Rcv [kg m-3 H-1 ~> kg m-4 or m-1] +! real :: dT_2dz, dS_2dz ! Half the vertical gradients of T and S, in degC H-1, and ppt H-1. real :: scale_slope ! A nondimensional number < 1 used to scale down ! the slope within the upper buffer layer when ! water MUST be detrained to the lower layer. real :: dPE_extrap ! The potential energy change due to dispersive ! advection or mixing layers, divided by - ! rho_0*g, in units of H2. + ! rho_0*g [H2 ~> m2 or kg2 m-4]. real :: dPE_det, dPE_merge ! The energy required to mix the detrained water ! into the buffer layer or the merge the two - ! buffer layers, both in units of J H2 m-4. + ! buffer layers [J H2 Z m-5 ~> J m-2 or J kg2 m-8]. real :: h_from_ml ! The amount of additional water that must be - ! drawn from the mixed layer, in H. + ! drawn from the mixed layer [H ~> m or kg m-2]. real :: h_det_h2 ! The amount of detrained water and mixed layer ! water that will go directly into the lower - ! buffer layer, in H. - real :: h_det_to_h2, h_ml_to_h2 ! All of the variables hA_to_hB are the - real :: h_det_to_h1, h_ml_to_h1 ! thickess fluxes from one layer to another, - real :: h1_to_h2, h1_to_k0 ! in H, with h_det the detrained water, h_ml + ! buffer layer [H ~> m or kg m-2]. + real :: h_det_to_h2, h_ml_to_h2 ! All of the variables hA_to_hB are the thickness fluxes + real :: h_det_to_h1, h_ml_to_h1 ! from one layer to another [H ~> m or kg m-2], + real :: h1_to_h2, h1_to_k0 ! with h_det the detrained water, h_ml real :: h2_to_k1, h2_to_k1_rem ! the actively mixed layer, h1 and h2 the upper ! and lower buffer layers, and k0 and k1 the ! interior layers that are just lighter and ! just denser than the lower buffer layer. - real :: R0_det, T_det, S_det ! Detrained values of R0, T, and S. + real :: R0_det, T_det, S_det ! Detrained values of R0 [kg m-3], T [degC], and S [ppt]. real :: Rcv_stays, R0_stays ! Values of Rcv and R0 that stay in a layer. real :: T_stays, S_stays ! Values of T and S that stay in a layer. real :: dSpice_det, dSpice_stays! The spiciness difference between an original ! buffer layer and the water that moves into ! an interior layer or that stays in that - ! layer, in kg m-3. + ! layer [kg m-3]. real :: dSpice_lim, dSpice_lim2 ! Limits to the spiciness difference between ! the lower buffer layer and the water that - ! moves into an interior layer, in kg m-3. + ! moves into an interior layer [kg m-3]. real :: dSpice_2dz ! The vertical gradient of spiciness used for - ! advection, in kg m-4. + ! advection [kg m-3 H-1 ~> kg m-4 or m-1]. real :: dPE_ratio ! Multiplier of dPE_det at which merging is ! permitted - here (detrainment_per_day/dt)*30 @@ -2532,34 +2326,34 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, real :: num_events ! The number of detrainment events over which ! to prefer merging the buffer layers. real :: detrainment_timescale ! The typical timescale for a detrainment - ! event, in s. + ! event [s]. real :: dPE_time_ratio ! Larger of 1 and the detrainment_timescale ! over dt, nondimensional. real :: dT_dS_gauge, dS_dT_gauge ! The relative scales of temperature and ! salinity changes in defining spiciness, in - ! K psu-1 and psu K-1. - real :: I_denom ! A work variable with units of psu2 m6 kg-2. - - real :: G_2 ! 1/2 G_Earth, in m s-2. - real :: Rho0xG ! Rho0 times G_Earth, in kg m-2 s-2. - real :: I2Rho0 ! 1 / (2 Rho0), in m3 kg-1. - real :: Idt_H2 ! The square of the conversion from thickness - ! to m divided by the time step in m2 H-2 s-1. + ! [degC ppt-1] and [ppt degC-1]. + real :: I_denom ! A work variable with units of [ppt2 m6 kg-2]. + + real :: G_2 ! 1/2 G_Earth [m2 Z-1 s-2 ~> m s-2]. + real :: Rho0xG ! Rho0 times G_Earth [kg m-1 Z-1 s-2 ~> kg m-2 s-2]. + real :: I2Rho0 ! 1 / (2 Rho0) [m3 kg-1]. + real :: Idt_H2 ! The square of the conversion from thickness to Z + ! divided by the time step [Z2 H-2 s-1 ~> s-1 or m6 kg-2 s-1]. logical :: stable_Rcv ! If true, the buffer layers are stable with ! respect to the coordinate potential density. real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected, in H. + ! in roundoff and can be neglected [H ~> m or kg m-2]. - real :: s1en ! A work variable with units of H2 kg m s-3. - real :: s1, s2, bh0 ! Work variables with units of H. - real :: s3sq ! A work variable with units of H2. + real :: s1en ! A work variable [H2 kg m s-3 ~> kg m3 s-3 or kg3 m-3 s-3]. + real :: s1, s2, bh0 ! Work variables [H ~> m or kg m-2]. + real :: s3sq ! A work variable [H2 ~> m2 or kg2 m-4]. real :: I_ya, b1 ! Nondimensional work variables. real :: Ih, Ihdet, Ih1f, Ih2f ! Assorted inverse thickness work variables, - real :: Ihk0, Ihk1, Ih12 ! all with units of H-1. + real :: Ihk0, Ihk1, Ih12 ! all in [H-1 ~> m-1 or m2 kg-1]. real :: dR1, dR2, dR2b, dRk1 ! Assorted density difference work variables, - real :: dR0, dR21, dRcv ! all with units of kg m-3. + real :: dR0, dR21, dRcv ! all in [kg m-3]. real :: dRcv_stays, dRcv_det, dRcv_lim - real :: Angstrom ! The minumum layer thickness, in H. + real :: Angstrom ! The minumum layer thickness [H ~> m or kg m-2]. real :: h2_to_k1_lim, T_new, S_new, T_max, T_min, S_max, S_min character(len=200) :: mesg @@ -2571,15 +2365,15 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, h_neglect = GV%H_subroundoff G_2 = 0.5*GV%g_Earth Rho0xG = GV%Rho0 * GV%g_Earth - Idt_H2 = GV%H_to_m**2 / dt_diag + Idt_H2 = GV%H_to_Z**2 / dt_diag I2Rho0 = 0.5 / GV%Rho0 - Angstrom = GV%Angstrom + Angstrom = GV%Angstrom_H ! This is hard coding of arbitrary and dimensional numbers. - h_min_bl_thick = 5.0 * GV%m_to_H + h_min_bl_thick = 5.0 * GV%m_to_H !### DIMENSIONAL CONSTANT dT_dS_gauge = CS%dT_dS_wt ; dS_dT_gauge = 1.0 /dT_dS_gauge num_events = 10.0 - detrainment_timescale = 4.0*3600.0 + detrainment_timescale = 4.0*3600.0 !### DIMENSIONAL CONSTANT if (CS%nkbl /= 2) call MOM_error(FATAL, "MOM_mixed_layer"// & "CS%nkbl must be 2 in mixedlayer_detrain_2.") @@ -2977,7 +2771,7 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, h_det_to_h1 = h_to_bl - h_det_to_h2 h_ml_to_h1 = MAX(h_min_bl-h_det_to_h1,0.0) - Ih = 1.0/h_min_bl; + Ih = 1.0/h_min_bl Ihdet = 0.0 ; if (h_to_bl > 0.0) Ihdet = 1.0 / h_to_bl Ih1f = 1.0 / (h_det_to_h1 + h_ml_to_h1) @@ -3218,7 +3012,7 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, if (allocated(CS%diag_PE_detrain)) & CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + Idt_H2*dPE_merge if (allocated(CS%diag_PE_detrain2)) CS%diag_PE_detrain2(i,j) = & - CS%diag_PE_detrain2(i,j) + Idt_H2*(dPE_det+Rho0xG*dPE_extrap) + CS%diag_PE_detrain2(i,j) + Idt_H2*(dPE_det + Rho0xG*dPE_extrap) else ! Not mergeable_bl. ! There is no further detrainment from the buffer layers, and the ! upper buffer layer water is distributed optimally between the @@ -3294,7 +3088,7 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, if (allocated(CS%diag_PE_detrain)) & CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + Idt_H2*dPE_det if (allocated(CS%diag_PE_detrain2)) CS%diag_PE_detrain2(i,j) = & - CS%diag_PE_detrain2(i,j) + Idt_H2*(dPE_det+Rho0xG*dPE_extrap) + CS%diag_PE_detrain2(i,j) + Idt_H2*(dPE_det + Rho0xG*dPE_extrap) endif endif ! End of detrainment... @@ -3309,26 +3103,25 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_e j, G, GV, CS, dRcv_dT, dRcv_dS, max_BL_det) 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),SZK0_(GV)), intent(inout) :: h !< Layer thickness, in m or kg m-2. - !! (Intent in/out) The units of h are - !! referred to as H below. Layer 0 is - !! the new mixed layer. - real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: T !< Potential temperature, in C. - real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: S !< Salinity, in psu. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2]. + !! Layer 0 is the new mixed layer. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: T !< Potential temperature [degC]. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: S !< Salinity [ppt]. real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: R0 !< Potential density referenced to - !! surface pressure, in kg m-3. + !! surface pressure [kg m-3]. real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: Rcv !< The coordinate defining potential - !! density, in kg m-3. + !! density [kg m-3]. real, dimension(SZK_(GV)), intent(in) :: RcvTgt !< The target value of Rcv for each - !! layer, in kg m-3. - real, intent(in) :: dt !< Time increment, in s. - real, intent(in) :: dt_diag + !! layer [kg m-3]. + real, intent(in) :: dt !< Time increment [s]. + real, intent(in) :: dt_diag !< The accumulated time interval for + !! diagnostics [s]. real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: d_ea !< The upward increase across a layer in - !! the entrainment from above, in m or - !! kg m-2 (H). Positive d_ea goes with - !! layer thickness increases. + !! the entrainment from above + !! [H ~> m or kg m-2]. Positive d_ea + !! goes with layer thickness increases. real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: d_eb !< The downward increase across a layer - !! in the entrainment from below, in H. + !! in the entrainment from below [H ~> m or kg m-2]. !! Positive values go with mass gain by !! a layer. integer, intent(in) :: j !< The meridional row to work on. @@ -3336,60 +3129,33 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_e !! previous call to mixedlayer_init. real, dimension(SZI_(G)), intent(in) :: dRcv_dT !< The partial derivative of !! coordinate defining potential density - !! with potential temperature, - !! in kg m-3 K-1. + !! with potential temperature + !! [kg m-3 degC-1]. real, dimension(SZI_(G)), intent(in) :: dRcv_dS !< The partial derivative of !! coordinate defining potential density - !! with salinity, in kg m-3 psu-1. + !! with salinity [kg m-3 ppt-1]. real, dimension(SZI_(G)), intent(in) :: max_BL_det !< If non-negative, the maximum !! detrainment permitted from the buffer - !! layers, in H. - -! This subroutine moves any water left in the former mixed layers into the -! single buffer layers and may also move buffer layer water into the interior -! isopycnal layers. + !! layers [H ~> m or kg m-2]. -! Arguments: h - Layer thickness, in m or kg m-2. (Intent in/out) The units of -! h are referred to as H below. Layer 0 is the new mixed layer. -! (in/out) T - Potential temperature, in C. -! (in/out) S - Salinity, in psu. -! (in/out) R0 - Potential density referenced to surface pressure, in kg m-3. -! (in/out) Rcv - The coordinate defining potential density, in kg m-3. -! (in) RcvTgt - The target value of Rcv for each layer, in kg m-3. -! (in) dt - Time increment, in s. -! (in/out) d_ea - The upward increase across a layer in the entrainment from -! above, in m or kg m-2 (H). Positive d_ea goes with layer -! thickness increases. -! (in/out) d_eb - The downward increase across a layer in the entrainment from -! below, in H. Positive values go with mass gain by a layer. -! (in) j - The meridional row to work on. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - The control structure returned by a previous call to -! mixedlayer_init. -! (in) max_BL_det - If non-negative, the maximum detrainment permitted -! from the buffer layers, in H. -! (in/out) dRcv_dT - The partial derivative of coordinate defining potential -! density with potential temperature, in kg m-3 K-1. -! (in/out) dRcv_dS - The partial derivative of coordinate defining potential -! density with salinity, in kg m-3 psu-1. - real :: Ih ! The inverse of a thickness, in H-1. + ! Local variables + real :: Ih ! The inverse of a thickness [H-1 ~> m-1 or m2 kg-1]. real :: h_ent ! The thickness from a layer that is - ! entrained, in H. - real :: max_det_rem(SZI_(G)) ! Remaining permitted detrainment, in H. + ! entrained [H ~> m or kg m-2]. + real :: max_det_rem(SZI_(G)) ! Remaining permitted detrainment [H ~> m or kg m-2]. real :: detrain(SZI_(G)) ! The thickness of fluid to detrain - ! from the mixed layer, in H. - real :: Idt ! The inverse of the timestep in s-1. + ! from the mixed layer [H ~> m or kg m-2]. + real :: Idt ! The inverse of the timestep [s-1]. real :: dT_dR, dS_dR, dRml, dR0_dRcv, dT_dS_wt2 - real :: I_denom ! A work variable with units of psu2 m6 kg-2. + real :: I_denom ! A work variable [ppt2 m6 kg-2]. real :: Sdown, Tdown real :: dt_Time, Timescale = 86400.0*30.0! *365.0/12.0 - real :: g_H2_2Rho0dt ! Half the gravitational acceleration times the - ! square of the conversion from H to m divided - ! by the mean density times the time step, in m6 s-3 H-2 kg-1. - real :: g_H2_2dt ! Half the gravitational acceleration times the - ! square of the conversion from H to m divided - ! by the diagnostic time step, in m3 H-2 s-3. + real :: g_H2_2Rho0dt ! Half the gravitational acceleration times the square of the + ! conversion from H to m divided by the mean density times the time + ! step [m7 s-3 Z-1 H-2 kg-1 ~> m4 s-3 kg-1 or m10 s-3 kg-3]. + real :: g_H2_2dt ! Half the gravitational acceleration times the square of the + ! conversion from H to m divided by the diagnostic time step + ! [m4 Z-1 H-2 s-3 ~> m s-3 or m7 kg-2 s-3]. logical :: splittable_BL(SZI_(G)), orthogonal_extrap real :: x1 @@ -3401,17 +3167,16 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_e "CS%nkbl must be 1 in mixedlayer_detrain_1.") Idt = 1.0/dt dt_Time = dt/Timescale - g_H2_2Rho0dt = (GV%g_Earth * GV%H_to_m**2) / (2.0 * GV%Rho0 * dt_diag) - g_H2_2dt = (GV%g_Earth * GV%H_to_m**2) / (2.0 * dt_diag) + g_H2_2Rho0dt = (GV%g_Earth * GV%H_to_Z**2) / (2.0 * GV%Rho0 * dt_diag) + g_H2_2dt = (GV%g_Earth * GV%H_to_Z**2) / (2.0 * dt_diag) ! Move detrained water into the buffer layer. do k=1,CS%nkml do i=is,ie ; if (h(i,k) > 0.0) then Ih = 1.0 / (h(i,nkmb) + h(i,k)) if (CS%TKE_diagnostics) & - CS%diag_TKE_conv_s2(i,j) = CS%diag_TKE_conv_s2(i,j) + & - g_H2_2Rho0dt * h(i,k) * h(i,nkmb) * & - (R0(i,nkmb) - R0(i,k)) + CS%diag_TKE_conv_s2(i,j) = CS%diag_TKE_conv_s2(i,j) + & + g_H2_2Rho0dt * h(i,k) * h(i,nkmb) * (R0(i,nkmb) - R0(i,k)) if (allocated(CS%diag_PE_detrain)) & CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + & g_H2_2dt * h(i,k) * h(i,nkmb) * (R0(i,nkmb) - R0(i,k)) @@ -3507,10 +3272,10 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_e ! temperature and salinity. If none is available a pseudo-orthogonal ! extrapolation is used. The 10.0 and 0.9 in the following are ! arbitrary but probably about right. - if ((h(i,k+1) < 10.0*GV%Angstrom) .or. & + if ((h(i,k+1) < 10.0*GV%Angstrom_H) .or. & ((RcvTgt(k+1)-Rcv(i,nkmb)) >= 0.9*(Rcv(i,k1) - Rcv(i,0)))) then if (k>=nz-1) then ; orthogonal_extrap = .true. - elseif ((h(i,k+2) <= 10.0*GV%Angstrom) .and. & + elseif ((h(i,k+2) <= 10.0*GV%Angstrom_H) .and. & ((RcvTgt(k+1)-Rcv(i,nkmb)) < 0.9*(Rcv(i,k+2)-Rcv(i,0)))) then k1 = k+2 else ; orthogonal_extrap = .true. ; endif @@ -3620,11 +3385,12 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_e end subroutine mixedlayer_detrain_1 -! #@# This subroutine needs a doxygen description. -subroutine bulkmixedlayer_init(Time, G, GV, param_file, diag, CS) - type(time_type), target, intent(in) :: Time +!> This subroutine initializes the MOM bulk mixed layer module. +subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) + type(time_type), target, intent(in) :: Time !< The model's clock with the current 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 !< A structure that is used to regulate diagnostic @@ -3642,7 +3408,7 @@ subroutine bulkmixedlayer_init(Time, G, GV, param_file, diag, CS) ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "MOM_mixed_layer" ! This module's name. - real :: omega_frac_dflt, ustar_min_dflt + real :: omega_frac_dflt, ustar_min_dflt, Hmix_min_m integer :: isd, ied, jsd, jed logical :: use_temperature, use_omega isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -3702,7 +3468,8 @@ subroutine bulkmixedlayer_init(Time, G, GV, param_file, diag, CS) 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"//& - "is determined dynamically.", units="m", default=0.0) + "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"//& @@ -3730,7 +3497,7 @@ subroutine bulkmixedlayer_init(Time, G, GV, param_file, diag, CS) call get_param(param_file, mdl, "DEPTH_LIMIT_FLUXES", CS%H_limit_fluxes, & "The surface fluxes are scaled away when the total ocean \n"//& "depth is less than DEPTH_LIMIT_FLUXES.", & - units="m", default=0.1*CS%Hmix_min) + 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) @@ -3757,12 +3524,12 @@ subroutine bulkmixedlayer_init(Time, G, GV, param_file, diag, CS) "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_z + GV%H_to_m*GV%H_subroundoff) + 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"//& "scales. This must be greater than 0.", units="m s-1", & - default=ustar_min_dflt) + 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, & @@ -3783,7 +3550,7 @@ subroutine bulkmixedlayer_init(Time, G, GV, param_file, diag, CS) 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"//& - "defined.", units="m", default=0.0) + "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"//& "heat carried by runoff, instead of using SST*CP*liq_runoff.", & @@ -3802,33 +3569,36 @@ subroutine bulkmixedlayer_init(Time, G, GV, param_file, diag, CS) CS%id_ML_depth = register_diag_field('ocean_model', 'h_ML', diag%axesT1, & Time, 'Surface mixed layer depth', 'm') CS%id_TKE_wind = register_diag_field('ocean_model', 'TKE_wind', diag%axesT1, & - Time, 'Wind-stirring source of mixed layer TKE', 'm3 s-3') + Time, 'Wind-stirring source of mixed layer TKE', 'm3 s-3', conversion=US%Z_to_m) CS%id_TKE_RiBulk = register_diag_field('ocean_model', 'TKE_RiBulk', diag%axesT1, & - Time, 'Mean kinetic energy source of mixed layer TKE', 'm3 s-3') + Time, 'Mean kinetic energy source of mixed layer TKE', 'm3 s-3', conversion=US%Z_to_m) CS%id_TKE_conv = register_diag_field('ocean_model', 'TKE_conv', diag%axesT1, & - Time, 'Convective source of mixed layer TKE', 'm3 s-3') + Time, 'Convective source of mixed layer TKE', 'm3 s-3', conversion=US%Z_to_m) CS%id_TKE_pen_SW = register_diag_field('ocean_model', 'TKE_pen_SW', diag%axesT1, & - Time, 'TKE consumed by mixing penetrative shortwave radation through the mixed layer', 'm3 s-3') + Time, 'TKE consumed by mixing penetrative shortwave radation through the mixed layer', & + 'm3 s-3', conversion=US%Z_to_m) CS%id_TKE_mixing = register_diag_field('ocean_model', 'TKE_mixing', diag%axesT1, & - Time, 'TKE consumed by mixing that deepens the mixed layer', 'm3 s-3') + Time, 'TKE consumed by mixing that deepens the mixed layer', 'm3 s-3', conversion=US%Z_to_m) CS%id_TKE_mech_decay = register_diag_field('ocean_model', 'TKE_mech_decay', diag%axesT1, & - Time, 'Mechanical energy decay sink of mixed layer TKE', 'm3 s-3') + Time, 'Mechanical energy decay sink of mixed layer TKE', 'm3 s-3', conversion=US%Z_to_m) CS%id_TKE_conv_decay = register_diag_field('ocean_model', 'TKE_conv_decay', diag%axesT1, & - Time, 'Convective energy decay sink of mixed layer TKE', 'm3 s-3') + Time, 'Convective energy decay sink of mixed layer TKE', 'm3 s-3', conversion=US%Z_to_m) CS%id_TKE_conv_s2 = register_diag_field('ocean_model', 'TKE_conv_s2', diag%axesT1, & - Time, 'Spurious source of mixed layer TKE from sigma2', 'm3 s-3') + Time, 'Spurious source of mixed layer TKE from sigma2', 'm3 s-3', conversion=US%Z_to_m) CS%id_PE_detrain = register_diag_field('ocean_model', 'PE_detrain', diag%axesT1, & - Time, 'Spurious source of potential energy from mixed layer detrainment', 'W m-2') + Time, 'Spurious source of potential energy from mixed layer detrainment', & + 'W m-2', conversion=US%Z_to_m) CS%id_PE_detrain2 = register_diag_field('ocean_model', 'PE_detrain2', diag%axesT1, & - Time, 'Spurious source of potential energy from mixed layer only detrainment', 'W m-2') + Time, 'Spurious source of potential energy from mixed layer only detrainment', & + 'W m-2', conversion=US%Z_to_m) CS%id_h_mismatch = register_diag_field('ocean_model', 'h_miss_ML', diag%axesT1, & - Time, 'Summed absolute mismatch in entrainment terms', 'm') + Time, 'Summed absolute mismatch in entrainment terms', 'm', conversion=US%Z_to_m) CS%id_Hsfc_used = register_diag_field('ocean_model', 'Hs_used', diag%axesT1, & - Time, 'Surface region thickness that is used', 'm') + Time, 'Surface region thickness that is used', 'm', conversion=US%Z_to_m) CS%id_Hsfc_max = register_diag_field('ocean_model', 'Hs_max', diag%axesT1, & - Time, 'Maximum surface region thickness', 'm') + Time, 'Maximum surface region thickness', 'm', conversion=US%Z_to_m) CS%id_Hsfc_min = register_diag_field('ocean_model', 'Hs_min', diag%axesT1, & - Time, 'Minimum surface region thickness', 'm') + Time, 'Minimum surface region thickness', 'm', conversion=US%Z_to_m) !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, & @@ -3850,9 +3620,8 @@ subroutine bulkmixedlayer_init(Time, G, GV, param_file, diag, CS) endif - if (max(CS%id_TKE_wind, CS%id_TKE_RiBulk, CS%id_TKE_conv, & - CS%id_TKE_mixing, CS%id_TKE_pen_SW, CS%id_TKE_mech_decay, & - CS%id_TKE_conv_decay) > 0) then + if (max(CS%id_TKE_wind, CS%id_TKE_RiBulk, CS%id_TKE_conv, CS%id_TKE_mixing, & + CS%id_TKE_pen_SW, CS%id_TKE_mech_decay, CS%id_TKE_conv_decay) > 0) then call safe_alloc_alloc(CS%diag_TKE_wind, isd, ied, jsd, jed) call safe_alloc_alloc(CS%diag_TKE_RiBulk, isd, ied, jsd, jed) call safe_alloc_alloc(CS%diag_TKE_conv, isd, ied, jsd, jed) @@ -3868,7 +3637,7 @@ subroutine bulkmixedlayer_init(Time, G, GV, param_file, diag, CS) if (CS%id_PE_detrain2 > 0) call safe_alloc_alloc(CS%diag_PE_detrain2, isd, ied, jsd, jed) if (CS%id_ML_depth > 0) call safe_alloc_alloc(CS%ML_depth, isd, ied, jsd, jed) - if(CS%allow_clocks_in_omp_loops) then + if (CS%allow_clocks_in_omp_loops) then id_clock_detrain = cpu_clock_id('(Ocean mixed layer detrain)', grain=CLOCK_ROUTINE) id_clock_mech = cpu_clock_id('(Ocean mixed layer mechanical entrainment)', grain=CLOCK_ROUTINE) id_clock_conv = cpu_clock_id('(Ocean mixed layer convection)', grain=CLOCK_ROUTINE) @@ -3893,37 +3662,44 @@ end subroutine bulkmixedlayer_init !! R = exp(-L*(H+E)) integral(LH to L(H+E)) L/(1-(1+x)exp(-x)) dx. !! The approximation to the integrand is good to within -2% at x~.3 !! and +25% at x~3.5, but the exponential deemphasizes the importance of -!! large x. When L=0, EF4 returns E/((H+E)*H). -function EF4(H, E, L, dR_de) -real, intent(in) :: H !< Total thickness, in m or kg m-2. (Intent in) The units of h - !! are referred to as H below. -real, intent(in) :: E !< Entrainment, in units of H. -real, intent(in) :: L !< The e-folding scale in H-1. -real, intent(inout), optional :: dR_de !< The partial derivative of the result R with E, in H-2. -real :: EF4 -! This subroutine returns an approximation to the integral -! R = exp(-L*(H+E)) integral(LH to L(H+E)) L/(1-(1+x)exp(-x)) dx. -! The approximation to the integrand is good to within -2% at x~.3 -! and +25% at x~3.5, but the exponential deemphasizes the importance of -! large x. When L=0, EF4 returns E/((H+E)*H). -! -! Arguments: h - Total thickness, in m or kg m-2. (Intent in) The units -! of h are referred to as H below. -! (in) E - Entrainment, in units of H. -! (in) L - The e-folding scale in H-1. -! (out) dR_de - the partial derivative of the result R with E, in H-2. -! (return value) R - The integral, in units of H-1. +!! large x. When L=0, EF4 returns E/((Ht+E)*Ht). +function EF4(Ht, En, I_L, dR_de) + real, intent(in) :: Ht !< Total thickness [H ~> m or kg m-2]. + real, intent(in) :: En !< Entrainment [H ~> m or kg m-2]. + real, intent(in) :: I_L !< The e-folding scale [H-1 ~> m-1 or m2 kg-1] + real, optional, intent(inout) :: dR_de !< The partial derivative of the result R with E [H-2 ~> m-2 or m4 kg-2]. + real :: EF4 !< The integral [H-1 ~> m-1 or m2 kg-1]. + + ! Local variables real :: exp_LHpE ! A nondimensional exponential decay. - real :: I_HpE ! An inverse thickness plus entrainment, in H-1. - real :: R ! The result of the integral above, in H-1. + real :: I_HpE ! An inverse thickness plus entrainment [H-1 ~> m-1 or m2 kg-1]. + real :: Res ! The result of the integral above [H-1 ~> m-1 or m2 kg-1]. - exp_LHpE = exp(-L*(E+H)) - I_HpE = 1.0/(H+E) - R = exp_LHpE * (E*I_HpE/H - 0.5*L*log(H*I_HpE) + 0.5*L*L*E) + exp_LHpE = exp(-I_L*(En+Ht)) + I_HpE = 1.0/(Ht+En) + Res = exp_LHpE * (En*I_HpE/Ht - 0.5*I_L*log(Ht*I_HpE) + 0.5*I_L*I_L*En) if (PRESENT(dR_de)) & - dR_de = -L*R + exp_LHpE*(I_HpE*I_HpE + 0.5*L*I_HpE + 0.5*L*L) - EF4 = R + dR_de = -I_L*Res + exp_LHpE*(I_HpE*I_HpE + 0.5*I_L*I_HpE + 0.5*I_L*I_L) + EF4 = Res end function EF4 +!> \namespace mom_bulk_mixed_layer +!! +!! By Robert Hallberg, 1997 - 2005. +!! +!! This file contains the subroutine (bulkmixedlayer) that +!! implements a Kraus-Turner-like bulk mixed layer, based on the work +!! of various people, as described in the review paper by Niiler and +!! Kraus (1979), with particular attention to the form proposed by +!! Oberhuber (JPO, 1993, 808-829), with an extension to a refied bulk +!! mixed layer as described in Hallberg (Aha Huliko'a, 2003). The +!! physical processes portrayed in this subroutine include convective +!! adjustment and mixed layer entrainment and detrainment. +!! Penetrating shortwave radiation and an exponential decay of TKE +!! fluxes are also supported by this subroutine. Several constants +!! can alternately be set to give a traditional Kraus-Turner mixed +!! layer scheme, although that is not the preferred option. The +!! physical processes and arguments are described in detail below. + end module MOM_bulk_mixed_layer diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 52338fcb40..e8b4500bbc 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -1,54 +1,9 @@ +!> Provides functions for some diabatic processes such as fraxil, brine rejection, +!! tendency due to surface flux divergence. module MOM_diabatic_aux ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Robert Hallberg, April 1994 - July 2000 * -!* Alistair Adcroft, and Stephen Griffies * -!* * -!* This program contains the subroutine that, along with the * -!* subroutines that it calls, implements diapycnal mass and momentum * -!* fluxes and a bulk mixed layer. The diapycnal diffusion can be * -!* used without the bulk mixed layer. * -!* * -!* diabatic first determines the (diffusive) diapycnal mass fluxes * -!* based on the convergence of the buoyancy fluxes within each layer. * -!* The dual-stream entrainment scheme of MacDougall and Dewar (JPO, * -!* 1997) is used for combined diapycnal advection and diffusion, * -!* calculated implicitly and potentially with the Richardson number * -!* dependent mixing, as described by Hallberg (MWR, 2000). Diapycnal * -!* advection is fundamentally the residual of diapycnal diffusion, * -!* so the fully implicit upwind differencing scheme that is used is * -!* entirely appropriate. The downward buoyancy flux in each layer * -!* is determined from an implicit calculation based on the previously * -!* calculated flux of the layer above and an estimated flux in the * -!* layer below. This flux is subject to the following conditions: * -!* (1) the flux in the top and bottom layers are set by the boundary * -!* conditions, and (2) no layer may be driven below an Angstrom thick-* -!* ness. If there is a bulk mixed layer, the buffer layer is treat- * -!* ed as a fixed density layer with vanishingly small diffusivity. * -!* * -!* diabatic takes 5 arguments: the two velocities (u and v), the * -!* thicknesses (h), a structure containing the forcing fields, and * -!* the length of time over which to act (dt). The velocities and * -!* thickness are taken as inputs and modified within the subroutine. * -!* There is no limit on the time step. * -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q * -!* j+1 > o > o > At ^: v * -!* j x ^ x ^ x At >: u * -!* j > o > o > At o: h, T, S, buoy, ustar, ea, eb, etc. * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** - use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr @@ -60,8 +15,8 @@ module MOM_diabatic_aux use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_forcing_type, only : forcing, extractFluxes1d, forcing_SinglePointPrint use MOM_grid, only : ocean_grid_type -use MOM_io, only : vardesc use MOM_shortwave_abs, only : absorbRemainingSW, optics_type, sumSWoverBands +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs, vertvisc_type! , accel_diag_ptrs use MOM_verticalGrid, only : verticalGrid_type @@ -72,12 +27,17 @@ module MOM_diabatic_aux public diabatic_aux_init, diabatic_aux_end public make_frazil, adjust_salt, insert_brine, differential_diffuse_T_S, triDiagTS public find_uv_at_h, diagnoseMLDbyDensityDifference, applyBoundaryFluxesInOut + +! 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. + !> Control structure for diabatic_aux type, public :: diabatic_aux_CS ; private - logical :: do_rivermix = .false. !< Provide additional TKE to mix river runoff - !! at the river mouths to "rivermix_depth" meters - real :: rivermix_depth = 0.0 !< The depth to which rivers are mixed if - !! do_rivermix = T, in m. + logical :: do_rivermix = .false. !< Provide additional TKE to mix river runoff at the + !! river mouths to a depth of "rivermix_depth" + real :: rivermix_depth = 0.0 !< The depth to which rivers are mixed if do_rivermix = T [Z ~> m]. logical :: reclaim_frazil !< If true, try to use any frazil heat deficit to !! to cool the topmost layer down to the freezing !! point. The default is false. @@ -99,57 +59,63 @@ module MOM_diabatic_aux type(diag_ctrl), pointer :: diag !< Structure used to regulate timing of diagnostic output ! Diagnostic handles - integer :: id_createdH = -1 - integer :: id_brine_lay = -1 - integer :: id_penSW_diag = -1 !< Penetrative shortwave heating (flux convergence) diagnostic - integer :: id_penSWflux_diag = -1 !< Penetrative shortwave flux diagnostic - integer :: id_nonpenSW_diag = -1 !< Non-penetrative shortwave heating diagnostic + integer :: id_createdH = -1 !< Diagnostic ID of mass added to avoid grounding + integer :: id_brine_lay = -1 !< Diagnostic ID of which layer receives the brine + integer :: id_penSW_diag = -1 !< Diagnostic ID of Penetrative shortwave heating (flux convergence) + integer :: id_penSWflux_diag = -1 !< Diagnostic ID of Penetrative shortwave flux + integer :: id_nonpenSW_diag = -1 !< Diagnostic ID of Non-penetrative shortwave heating ! Optional diagnostic arrays - real, allocatable, dimension(:,:) :: createdH !< The amount of volume added in order to avoid grounding (m/s) - real, allocatable, dimension(:,:,:) :: penSW_diag !< Heating in a layer from convergence of penetrative SW (W/m2) - real, allocatable, dimension(:,:,:) :: penSWflux_diag !< Penetrative SW flux at base of grid layer (W/m2) - real, allocatable, dimension(:,:) :: nonpenSW_diag !< Non-downwelling SW radiation (W/m2) at ocean surface + real, allocatable, dimension(:,:) :: createdH !< The amount of volume added in order to + !! avoid grounding [m s-1] + real, allocatable, dimension(:,:,:) :: penSW_diag !< Heating in a layer from convergence of + !! penetrative SW [W m-2] + real, allocatable, dimension(:,:,:) :: penSWflux_diag !< Penetrative SW flux at base of grid + !! layer [W m-2] + real, allocatable, dimension(:,:) :: nonpenSW_diag !< Non-downwelling SW radiation at ocean + !! surface [W m-2] end type diabatic_aux_CS +!>@{ CPU time clock IDs integer :: id_clock_uv_at_h, id_clock_frazil +!!@} contains -subroutine make_frazil(h, tv, G, GV, CS, p_surf) - 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 !< Layer thicknesses, in H (usually m or kg m-2) - type(thermo_var_ptrs), intent(inout) :: tv - type(diabatic_aux_CS), intent(in) :: CS - real, dimension(SZI_(G),SZJ_(G)), intent(in), optional :: p_surf - -! Frazil formation keeps the temperature above the freezing point. -! This subroutine warms any water that is colder than the (currently -! surface) freezing point up to the freezing point and accumulates -! the required heat (in J m-2) in tv%frazil. -! The expression, below, for the freezing point of sea water comes -! from Millero (1978) via Appendix A of Gill, 1982. - -! Arguments: h - Layer thickness, in m or kg m-2. -! (in/out) tv - A structure containing pointers to any available -! thermodynamic fields. Absent fields have NULL ptrs. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - The control structure returned by a previous call to -! diabatic_driver_init. +!> Frazil formation keeps the temperature above the freezing point. +!! This subroutine warms any water that is colder than the (currently +!! surface) freezing point up to the freezing point and accumulates +!! the required heat (in J m-2) in tv%frazil. +subroutine make_frazil(h, tv, G, GV, CS, p_surf, halo) + 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 !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(inout) :: tv !< Structure containing pointers to any available + !! thermodynamic fields. + type(diabatic_aux_CS), intent(in) :: CS !< The control structure returned by a previous + !! call to diabatic_aux_init. + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(in) :: p_surf !< The pressure at the ocean surface [Pa]. + integer, optional, intent(in) :: halo !< Halo width over which to calculate frazil + + ! Local variables real, dimension(SZI_(G)) :: & - fraz_col, & ! The accumulated heat requirement due to frazil, in J. - T_freeze, & ! The freezing potential temperature at the current salinity, C. + fraz_col, & ! The accumulated heat requirement due to frazil [J]. + T_freeze, & ! The freezing potential temperature at the current salinity [degC]. ps ! pressure real, dimension(SZI_(G),SZK_(G)) :: & - pressure ! The pressure at the middle of each layer in Pa. - real :: hc ! A layer's heat capacity in J m-2 K-1. + pressure ! The pressure at the middle of each layer [Pa]. + real :: hc ! A layer's heat capacity [J m-2 degC-1]. logical :: T_fr_set ! True if the freezing point has been calculated for a ! row of points. 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 + endif call cpu_clock_begin(id_clock_frazil) @@ -213,7 +179,7 @@ subroutine make_frazil(h, tv, G, GV, CS, p_surf) endif hc = (tv%C_p*GV%H_to_kg_m2) * h(i,j,k) - if (h(i,j,k) <= 10.0*GV%Angstrom) then + if (h(i,j,k) <= 10.0*GV%Angstrom_H) then ! Very thin layers should not be cooled by the frazil flux. if (tv%T(i,j,k) < T_freeze(i)) then fraz_col(i) = fraz_col(i) + hc * (T_freeze(i) - tv%T(i,j,k)) @@ -239,45 +205,39 @@ subroutine make_frazil(h, tv, G, GV, CS, p_surf) end subroutine make_frazil +!> This subroutine applies double diffusion to T & S, assuming no diapycal mass +!! fluxes, using a simple triadiagonal solver. subroutine differential_diffuse_T_S(h, tv, visc, dt, G, GV) - 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 !< Layer thicknesses, in H (usually m or kg m-2) - type(thermo_var_ptrs), intent(inout) :: tv - type(vertvisc_type), intent(in) :: visc - real, intent(in) :: dt - -! This subroutine applies double diffusion to T & S, assuming no diapycal mass -! fluxes, using a simple triadiagonal solver. - -! Arguments: h - Layer thickness, in m or kg m-2. -! (in) tv - A structure containing pointers to any available -! thermodynamic fields. Absent fields have NULL ptrs. -! (in) visc - A structure containing vertical viscosities, bottom boundary -! layer properies, and related fields. -! (in) dt - Time increment, in s. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. - + 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 !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(inout) :: tv !< Structure containing pointers to any + !! available thermodynamic fields. + type(vertvisc_type), intent(in) :: visc !< Structure containing vertical viscosities, bottom + !! boundary layer properies, and related fields. + real, intent(in) :: dt !< Time increment [s]. + + ! local variables real, dimension(SZI_(G)) :: & - b1_T, b1_S, & ! Variables used by the tridiagonal solvers of T & S, in H. - d1_T, d1_S ! Variables used by the tridiagonal solvers, nondim. + b1_T, b1_S, & ! Variables used by the tridiagonal solvers of T & S [H ~> m or kg m-2]. + d1_T, d1_S ! Variables used by the tridiagonal solvers [nondim]. real, dimension(SZI_(G),SZK_(G)) :: & - c1_T, c1_S ! Variables used by the tridiagonal solvers, in m or kg m-2. + c1_T, c1_S ! Variables used by the tridiagonal solvers [H ~> m or kg m-2]. real, dimension(SZI_(G),SZK_(G)+1) :: & - mix_T, mix_S ! Mixing distances in both directions across each - ! interface, in m or kg m-2. + mix_T, mix_S ! Mixing distances in both directions across each interface [H ~> m or kg m-2]. real :: h_tr ! h_tr is h at tracer points with a tiny thickness - ! added to ensure positive definiteness, in m or kg m-2. + ! added to ensure positive definiteness [H ~> m or kg m-2]. real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected, in m or kg m-2. + ! in roundoff and can be neglected [H ~> m or kg m-2]. real :: I_h_int ! The inverse of the thickness associated with an - ! interface, in m-1 or m2 kg-1. + ! interface [H-1 ~> m-1 or m2 kg-1]. real :: b_denom_T ! The first term in the denominators for the expressions - real :: b_denom_S ! for b1_T and b1_S, both in m or kg m-2. - + real :: b_denom_S ! for b1_T and b1_S, both [H ~> m or kg m-2]. + real, dimension(:,:,:), pointer :: T=>NULL(), S=>NULL() + real, dimension(:,:,:), pointer :: Kd_T=>NULL(), Kd_S=>NULL() ! Diffusivities [Z2 s-1 ~> m2 s-1]. integer :: i, j, k, is, ie, js, je, nz - real, pointer :: T(:,:,:), S(:,:,:), Kd_T(:,:,:), Kd_S(:,:,:) + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke h_neglect = GV%H_subroundoff @@ -298,8 +258,8 @@ subroutine differential_diffuse_T_S(h, tv, visc, dt, G, GV) do j=js,je do i=is,ie I_h_int = 1.0 / (0.5 * (h(i,j,1) + h(i,j,2)) + h_neglect) - mix_T(i,2) = ((dt * Kd_T(i,j,2)) * GV%m_to_H**2) * I_h_int - mix_S(i,2) = ((dt * Kd_S(i,j,2)) * GV%m_to_H**2) * I_h_int + mix_T(i,2) = ((dt * Kd_T(i,j,2)) * GV%Z_to_H**2) * I_h_int + mix_S(i,2) = ((dt * Kd_S(i,j,2)) * GV%Z_to_H**2) * I_h_int h_tr = h(i,j,1) + h_neglect b1_T(i) = 1.0 / (h_tr + mix_T(i,2)) @@ -312,8 +272,8 @@ subroutine differential_diffuse_T_S(h, tv, visc, dt, G, GV) do k=2,nz-1 ; do i=is,ie ! Calculate the mixing across the interface below this layer. I_h_int = 1.0 / (0.5 * (h(i,j,k) + h(i,j,k+1)) + h_neglect) - mix_T(i,K+1) = ((dt * Kd_T(i,j,K+1)) * GV%m_to_H**2) * I_h_int - mix_S(i,K+1) = ((dt * Kd_S(i,j,K+1)) * GV%m_to_H**2) * I_h_int + mix_T(i,K+1) = ((dt * Kd_T(i,j,K+1)) * GV%Z_to_H**2) * I_h_int + mix_S(i,K+1) = ((dt * Kd_S(i,j,K+1)) * GV%Z_to_H**2) * I_h_int c1_T(i,k) = mix_T(i,K) * b1_T(i) c1_S(i,k) = mix_S(i,K) * b1_S(i) @@ -345,35 +305,35 @@ subroutine differential_diffuse_T_S(h, tv, visc, dt, G, GV) S(i,j,k) = S(i,j,k) + c1_S(i,k+1)*S(i,j,k+1) enddo ; enddo enddo - end subroutine differential_diffuse_T_S -subroutine adjust_salt(h, tv, G, GV, 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 - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - type(thermo_var_ptrs), intent(inout) :: tv - type(diabatic_aux_CS), intent(in) :: CS - -! Keep salinity from falling below a small but positive threshold -! This occurs when the ice model attempts to extract more salt then -! is actually available to it from the ocean. - -! Arguments: h - Layer thickness, in m. -! (in/out) tv - A structure containing pointers to any available -! thermodynamic fields. Absent fields have NULL ptrs. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - The control structure returned by a previous call to -! diabatic_driver_init. - 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 . +!> This subroutine keeps salinity from falling below a small but positive threshold. +!! This usually occurs when the ice model attempts to extract more salt then +!! is actually available to it from the ocean. +subroutine adjust_salt(h, tv, G, GV, CS, halo) + 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 !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(inout) :: tv !< Structure containing pointers to any + !! available thermodynamic fields. + type(diabatic_aux_CS), intent(in) :: CS !< The control structure returned by a previous + !! call to diabatic_aux_init. + 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 . 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 + endif ! call cpu_clock_begin(id_clock_adjust_salt) +!### MAKE THIS A RUN_TIME PARAMETER. COULD IT BE 0? S_min = 0.01 salt_add_col(:,:) = 0.0 @@ -385,7 +345,7 @@ subroutine adjust_salt(h, tv, G, GV, CS) 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) then + if (h(i,j,k) <= 10.0*GV%Angstrom_H) then ! Very thin layers should not be adjusted by the salt flux if (tv%S(i,j,k) < S_min) then salt_add_col(i,j) = salt_add_col(i,j) + mc * (S_min - tv%S(i,j,k)) @@ -410,33 +370,25 @@ subroutine adjust_salt(h, tv, G, GV, CS) end subroutine adjust_salt +!> Insert salt from brine rejection into the first layer below the mixed layer +!! which both contains mass and in which the change in layer density remains +!! stable after the addition of salt via brine rejection. subroutine insert_brine(h, tv, G, GV, fluxes, nkmb, CS, dt, id_brine_lay) - 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 !< Layer thicknesses, in H (usually m or kg m-2) - type(thermo_var_ptrs), intent(inout) :: tv - type(forcing), intent(in) :: fluxes - integer, intent(in) :: nkmb - type(diabatic_aux_CS), intent(in) :: CS - real, intent(in) :: dt - integer, intent(in) :: id_brine_lay - -! Insert salt from brine rejection into the first layer below -! the mixed layer which both contains mass and in which the -! change in layer density remains stable after the addition -! of salt via brine rejection. - -! Arguments: h - Layer thickness, in m. -! (in/out) tv - A structure containing pointers to any available -! thermodynamic fields. Absent fields have NULL ptrs. -! (in) fluxes = A structure containing pointers to any possible -! forcing fields; unused fields have NULL ptrs. -! (in) nkmb - The number of layers in the mixed and buffer layers. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - The control structure returned by a previous call to -! diabatic_driver_init. - + 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 !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(inout) :: tv !< Structure containing pointers to any + !! available thermodynamic fields + type(forcing), intent(in) :: fluxes !< A structure of thermodynamic surface fluxes + integer, intent(in) :: nkmb !< The number of layers in the mixed and buffer layers + type(diabatic_aux_CS), intent(in) :: CS !< The control structure returned by a previous + !! call to diabatic_aux_init + real, intent(in) :: dt !< The thermodyanmic time step [s]. + integer, intent(in) :: id_brine_lay !< The handle for a diagnostic + !! which layer receivees the brine. + + ! local variables real :: salt(SZI_(G)) ! The amount of salt rejected from ! sea ice. [grams] real :: dzbr(SZI_(G)) ! cumulative depth over which brine is distributed @@ -447,7 +399,7 @@ subroutine insert_brine(h, tv, G, GV, fluxes, nkmb, CS, dt, id_brine_lay) real :: S(SZI_(G),SZK_(G)) real :: h_2d(SZI_(G),SZK_(G)) real :: Rcv(SZI_(G),SZK_(G)) - real :: mc ! A layer's mass in kg m-2 . + real :: mc ! A layer's mass [kg m-2]. real :: s_new,R_new,t0,scale, cdz integer :: i, j, k, is, ie, js, je, nz, ks @@ -460,7 +412,7 @@ subroutine insert_brine(h, tv, G, GV, fluxes, nkmb, CS, dt, id_brine_lay) p_ref_cv(:) = tv%P_ref - inject_layer = nz + inject_layer(:,:) = nz do j=js,je @@ -474,7 +426,7 @@ subroutine insert_brine(h, tv, G, GV, fluxes, nkmb, CS, dt, id_brine_lay) do i=is,ie T(i,k)=tv%T(i,j,k); S(i,k)=tv%S(i,j,k) ! avoid very small thickness - h_2d(i,k)=MAX(h(i,j,k), GV%Angstrom) + h_2d(i,k)=MAX(h(i,j,k), GV%Angstrom_H) enddo call calculate_density(T(:,k), S(:,k), p_ref_cv, Rcv(:,k), is, & @@ -535,26 +487,35 @@ subroutine insert_brine(h, tv, G, GV, fluxes, nkmb, CS, dt, id_brine_lay) enddo - if (CS%id_brine_lay > 0) call post_data(CS%id_brine_lay,inject_layer,CS%diag) + if (CS%id_brine_lay > 0) call post_data(CS%id_brine_lay, inject_layer, CS%diag) end subroutine insert_brine +!> This is a simple tri-diagonal solver for T and S. +!! "Simple" means it only uses arrays hold, ea and eb. subroutine triDiagTS(G, GV, is, ie, js, je, hold, ea, eb, T, S) -! Simple tri-diagnonal solver for T and S -! "Simple" means it only uses arrays hold, ea and eb - ! Arguments type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - integer, intent(in) :: is, ie, js, je - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: hold, ea, eb - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: T, S + integer, intent(in) :: is !< The start i-index to work on. + integer, intent(in) :: ie !< The end i-index to work on. + integer, intent(in) :: js !< The start j-index to work on. + integer, intent(in) :: je !< The end j-index to work on. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: hold !< The layer thicknesses before entrainment, + !! [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: ea !< The amount of fluid entrained from the layer + !! above within this time step [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: eb !< The amount of fluid entrained from the layer + !! below within this time step [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: T !< Layer potential temperatures [degC]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: S !< Layer salinities [ppt]. + ! Local variables real :: b1(SZIB_(G)), d1(SZIB_(G)) ! b1, c1, and d1 are variables used by the real :: c1(SZIB_(G),SZK_(G)) ! tridiagonal solver. real :: h_tr, b_denom_1 integer :: i, j, k -!$OMP parallel do default(none) shared(is,ie,js,je,G,GV,hold,eb,T,S,ea) & -!$OMP private(h_tr,b1,d1,c1,b_denom_1) + + !$OMP parallel do default(shared) private(h_tr,b1,d1,c1,b_denom_1) do j=js,je do i=is,ie h_tr = hold(i,j,1) + GV%H_subroundoff @@ -579,38 +540,34 @@ subroutine triDiagTS(G, GV, is, ie, js, je, hold, ea, eb, T, S) enddo end subroutine triDiagTS - +!> This subroutine calculates u_h and v_h (velocities at thickness +!! points), optionally using the entrainment amounts passed in as arguments. subroutine find_uv_at_h(u, v, h, u_h, v_h, G, GV, ea, eb) - 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(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< The zonal velocity, in m s-1 - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< The meridional velocity, in m s-1 - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: u_h, v_h - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in), optional :: ea, eb -! This subroutine calculates u_h and v_h (velocities at thickness -! points), optionally using the entrainments (in m) passed in as arguments. - -! Arguments: u - Zonal velocity, in m s-1. -! (in) v - Meridional velocity, in m s-1. -! (in) h - Layer thickness, in m or kg m-2. -! (out) u_h - The zonal velocity at thickness points after -! entrainment, in m s-1. -! (out) v_h - The meridional velocity at thickness points after -! entrainment, in m s-1. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in, opt) ea - The amount of fluid entrained from the layer above within -! this time step, in units of m or kg m-2. Omitting ea is the -! same as setting it to 0. -! (in, opt) eb - The amount of fluid entrained from the layer below within -! this time step, in units of m or kg m-2. Omitting eb is the -! same as setting it to 0. ea and eb must either be both -! present or both absent. - - real :: b_denom_1 ! The first term in the denominator of b1 in m or kg m-2. + 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(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),SZK_(G)), & + intent(out) :: u_h !< Zonal velocity interpolated to h points [m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(out) :: v_h !< Meridional velocity interpolated to h points [m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + optional, intent(in) :: ea !< The amount of fluid entrained from the layer + !! above within this time step [H ~> m or kg m-2]. + !! Omitting ea is the same as setting it to 0. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + optional, intent(in) :: eb !< The amount of fluid entrained from the layer + !! below within this time step [H ~> m or kg m-2]. + !! Omitting eb is the same as setting it to 0. + + ! local variables + real :: b_denom_1 ! The first term in the denominator of b1 [H ~> m or kg m-2]. real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected, in m or kg m-2. + ! in roundoff and can be neglected [H ~> m or kg m-2]. real :: b1(SZI_(G)), d1(SZI_(G)), c1(SZI_(G),SZK_(G)) real :: a_n(SZI_(G)), a_s(SZI_(G)) ! Fractional weights of the neighboring real :: a_e(SZI_(G)), a_w(SZI_(G)) ! velocity points, ~1/2 in the open @@ -686,37 +643,47 @@ 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, diagPtr, id_N2subML, id_MLDsq) - type(ocean_grid_type), intent(in) :: G !< Grid type - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - integer, intent(in) :: id_MLD !< Handle (ID) of MLD diagnostic - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness - type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics type - real, intent(in) :: densityDiff !< Density difference to determine MLD (kg/m3) - 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 +subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, diagPtr, id_N2subML, id_MLDsq) + 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 + integer, intent(in) :: id_MLD !< Handle (ID) of MLD diagnostic + 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 !< Structure containing pointers to any + !! available thermodynamic fields. + real, intent(in) :: densityDiff !< Density difference to determine MLD [kg m-3] + 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 ! Local variables - real, dimension(SZI_(G)) :: rhoSurf, deltaRhoAtKm1, deltaRhoAtK, dK, dKm1, pRef_MLD - real, dimension(SZI_(G)) :: rhoAtK, rho1, d1, pRef_N2 ! Used for N2 - real, dimension(SZI_(G), SZJ_(G)) :: MLD ! Diagnosed mixed layer depth - real, dimension(SZI_(G), SZJ_(G)) :: subMLN2 ! Diagnosed stratification below ML - real, dimension(SZI_(G), SZJ_(G)) :: MLD2 ! Diagnosed MLD^2 - real, parameter :: dz_subML = 50. ! Depth below ML over which to diagnose stratification (m) + 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), 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]. + 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]. integer :: i, j, is, ie, js, je, k, nz, id_N2, id_SQ real :: aFac, ddRho - id_N2 = -1 - if (PRESENT(id_N2subML)) id_N2 = id_N2subML + id_N2 = -1 ; if (PRESENT(id_N2subML)) id_N2 = id_N2subML + + id_SQ = -1 ; if (PRESENT(id_N2subML)) id_SQ = id_MLDsq - 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 is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke pRef_MLD(:) = 0. ; pRef_N2(:) = 0. do j=js,je - do i=is,ie ; dK(i) = 0.5 * h(i,j,1) * GV%H_to_m ; enddo ! Depth of center of surface layer + 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) do i=is,ie deltaRhoAtK(i) = 0. @@ -725,21 +692,22 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, dia subMLN2(i,j) = 0. rho1(i) = 0. d1(i) = 0. - pRef_N2(i) = GV%g_Earth * GV%Rho0 * h(i,j,1) * GV%H_to_m ! Boussinesq approximation!!!! ????? - !### This should be: pRef_N2(i) = GV%g_Earth * GV%H_to_kg_m2 * h(i,j,1) ! This might change answers at roundoff. + 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. endif enddo do k=2,nz do i=is,ie dKm1(i) = dK(i) ! Depth of center of layer K-1 - dK(i) = dK(i) + 0.5 * ( h(i,j,k) + h(i,j,k-1) ) * GV%H_to_m ! Depth of center of layer K + 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. if (id_N2>0) then do i=is,ie - pRef_N2(i) = pRef_N2(i) + GV%g_Earth * GV%Rho0 * h(i,j,k) * GV%H_to_m ! Boussinesq approximation!!!! ????? - !### This should be: pRef_N2(i) = pRev_N2(i) + GV%g_Earth * GV%H_to_kg_m2 * h(i,j,k) ! This might change answers at roundoff. + 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 @@ -749,11 +717,12 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, dia 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) + GV%g_Earth * GV%Rho0 * h(i,j,k) * GV%H_to_m ! Boussinesq approximation!!!! ????? - !### This line should be: pRef_N2(i) = pRev_N2(i) + GV%g_Earth * GV%H_to_kg_m2 * h(i,j,k) ! This might change answers at roundoff. + 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) = GV%g_Earth/ GV%Rho0 * (rho1(i)-rhoAtK(i)) / (d1(i) - dK(i)) + subMLN2(i,j) = gE_rho0 * (rho1(i)-rhoAtK(i)) / (d1(i) - dK(i)) endif endif enddo ! i-loop @@ -777,7 +746,7 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, dia 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) = GV%g_Earth/ GV%Rho0 * (rho1(i)-rhoAtK(i)) / (d1(i) - dK(i)) + ! subMLN2(i,j) = gE_rho0 * (rho1(i)-rhoAtK(i)) / (d1(i) - dK(i)) ! endif enddo enddo ! j-loop @@ -791,32 +760,37 @@ end subroutine diagnoseMLDbyDensityDifference !> Update the thickness, temperature, and salinity due to thermodynamic !! boundary forcing (contained in fluxes type) applied to h, tv%T and tv%S, !! and calculate the TKE implications of this heating. -subroutine applyBoundaryFluxesInOut(CS, G, GV, dt, fluxes, optics, h, tv, & +subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, h, tv, & aggregate_FW_forcing, evap_CFL_limit, & minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, & SkinBuoyFlux ) - type(diabatic_aux_CS), pointer :: CS !< Control structure for diabatic_aux - type(ocean_grid_type), intent(in) :: G !< Grid structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - real, intent(in) :: dt !< Time-step over which forcing is applied (s) - type(forcing), intent(inout) :: fluxes !< Surface fluxes container - type(optics_type), pointer :: optics !< Optical properties container - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thickness in H units - type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamics container - !> If False, treat in/out fluxes separately. - logical, intent(in) :: aggregate_FW_forcing - !> The largest fraction of a layer that can be evaporated in one time-step (non-dim). - real, intent(in) :: evap_CFL_limit - !> The smallest depth over which heat and freshwater fluxes is applied, in m. - real, intent(in) :: minimum_forcing_depth - !> Turbulent kinetic energy requirement to mix forcing through each layer, in W m-2 - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: cTKE - !> Partial derivative of specific volume with potential temperature, in m3 kg-1 K-1. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: dSV_dT - !> Partial derivative of specific a volume with potential salinity, in m3 kg-1 / (g kg-1). - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: dSV_dS - !> Buoyancy flux at surface in m2 s-3 - real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: SkinBuoyFlux + type(diabatic_aux_CS), pointer :: CS !< Control structure for diabatic_aux + type(ocean_grid_type), intent(in) :: G !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(in) :: dt !< Time-step over which forcing is applied [s] + type(forcing), intent(inout) :: fluxes !< Surface fluxes container + type(optics_type), pointer :: optics !< Optical properties container + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(inout) :: tv !< Structure containing pointers to any + !! available thermodynamic fields. + logical, intent(in) :: aggregate_FW_forcing !< If False, treat in/out fluxes separately. + real, intent(in) :: evap_CFL_limit !< The largest fraction of a layer that + !! can be evaporated in one time-step [nondim]. + real, intent(in) :: minimum_forcing_depth !< The smallest depth over which + !! heat and freshwater fluxes is applied [m]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + optional, intent(out) :: cTKE !< Turbulent kinetic energy requirement to mix + !! forcing through each layer [W m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + optional, intent(out) :: dSV_dT !< Partial derivative of specific volume with + !! potential temperature [m3 kg-1 degC-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + optional, intent(out) :: dSV_dS !< Partial derivative of specific volume with + !! salinity [m3 kg-1 ppt-1]. + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(out) :: SkinBuoyFlux !< Buoyancy flux at surface [Z2 s-3 ~> m2 s-3]. ! Local variables integer, parameter :: maxGroundings = 5 @@ -824,24 +798,27 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, dt, fluxes, optics, h, tv, & real :: H_limit_fluxes, IforcingDepthScale, Idt real :: dThickness, dTemp, dSalt real :: fractionOfForcing, hOld, Ithickness - real :: RivermixConst ! A constant used in implementing river mixing, in Pa s. + real :: RivermixConst ! A constant used in implementing river mixing [Pa s]. real, dimension(SZI_(G)) :: & - d_pres, & ! pressure change across a layer (Pa) - p_lay, & ! average pressure in a layer (Pa) - pres, & ! pressure at an interface (Pa) - netMassInOut, & ! surface water fluxes (H units) over time step - netMassIn, & ! mass entering ocean surface (H units) over a time step - netMassOut, & ! mass leaving ocean surface (H units) over a time step - netHeat, & ! heat (degC * H) via surface fluxes, excluding - ! Pen_SW_bnd and netMassOut + d_pres, & ! pressure change across a layer [Pa] + p_lay, & ! average pressure in a layer [Pa] + pres, & ! pressure at an interface [Pa] + netMassInOut, & ! surface water fluxes [H ~> m or kg m-2] over time step + netMassIn, & ! mass entering ocean surface [H ~> m or kg m-2] over a time step + netMassOut, & ! mass leaving ocean surface [H ~> m or kg m-2] over a time step + netHeat, & ! heat via surface fluxes excluding Pen_SW_bnd and netMassOut + ! [degC H ~> degC m or degC kg m-2] netSalt, & ! surface salt flux ( g(salt)/m2 for non-Bouss and ppt*H for Bouss ) + ! [ppt H ~> ppt m or ppt kg m-2] nonpenSW, & ! non-downwelling SW, which is absorbed at ocean surface - SurfPressure, & ! Surface pressure (approximated as 0.0) - dRhodT, & ! change in density per change in temperature - dRhodS, & ! change in density per change in salinity - netheat_rate, & ! netheat but for dt=1 (e.g. returns a rate) + ! [degC H ~> degC m or degC kg m-2] + SurfPressure, & ! Surface pressure (approximated as 0.0) [Pa] + dRhodT, & ! change in density per change in temperature [kg m-3 degC-1] + dRhodS, & ! change in density per change in salinity [kg m-3 ppt-1] + netheat_rate, & ! netheat but for dt=1 [degC H s-1 ~> degC m s-1 or degC kg m-2 s-1] netsalt_rate, & ! netsalt but for dt=1 (e.g. returns a rate) - netMassInOut_rate! netmassinout but for dt=1 (e.g. returns a rate) + ! [ppt H s-1 ~> ppt m s-1 or ppt kg m-2 s-1] + netMassInOut_rate! netmassinout but for dt=1 [H s-1 ~> m s-1 or kg m-2 s-1] real, dimension(SZI_(G), SZK_(G)) :: h2d, T2d real, dimension(SZI_(G), SZK_(G)) :: pen_TKE_2d, dSV_dT_2d real, dimension(SZI_(G),SZK_(G)+1) :: netPen @@ -850,8 +827,10 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, dt, fluxes, optics, h, tv, & real, dimension(max(optics%nbands,1),SZI_(G),SZK_(G)) :: opacityBand real :: hGrounding(maxGroundings) real :: Temp_in, Salin_in - real :: I_G_Earth, g_Hconv2 - real :: GoRho +! real :: I_G_Earth + real :: g_Hconv2 + real :: GoRho ! g_Earth times a unit conversion factor divided by density + ! [Z m3 s-2 kg-1 ~> m4 s-2 kg-1] logical :: calculate_energetics logical :: calculate_buoyancy integer :: i, j, is, ie, js, je, k, nz, n, nsw @@ -870,8 +849,8 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, dt, fluxes, optics, h, tv, & calculate_energetics = (present(cTKE) .and. present(dSV_dT) .and. present(dSV_dS)) calculate_buoyancy = present(SkinBuoyFlux) if (calculate_buoyancy) SkinBuoyFlux(:,:) = 0.0 - I_G_Earth = 1.0 / GV%g_Earth - g_Hconv2 = GV%g_Earth * GV%H_to_kg_m2**2 +! I_G_Earth = 1.0 / GV%g_Earth + g_Hconv2 = GV%H_to_Pa * GV%H_to_kg_m2 if (present(cTKE)) cTKE(:,:,:) = 0.0 if (calculate_buoyancy) then @@ -886,32 +865,29 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, dt, fluxes, optics, h, tv, & ! To accommodate vanishing upper layers, we need to allow for an instantaneous ! distribution of forcing over some finite vertical extent. The bulk mixed layer ! code handles this issue properly. - H_limit_fluxes = max(GV%Angstrom, 1.E-30*GV%m_to_H) + H_limit_fluxes = max(GV%Angstrom_H, 1.E-30*GV%m_to_H) ! diagnostic to see if need to create mass to avoid grounding if (CS%id_createdH>0) CS%createdH(:,:) = 0. numberOfGroundings = 0 -!$OMP parallel do default(none) shared(is,ie,js,je,nz,h,tv,nsw,G,GV,optics,fluxes,dt, & -!$OMP H_limit_fluxes, & -!$OMP numberOfGroundings,iGround,jGround,nonPenSW, & -!$OMP hGrounding,CS,Idt,aggregate_FW_forcing, & -!$OMP minimum_forcing_depth,evap_CFL_limit, & -!$OMP calculate_buoyancy,netPen,SkinBuoyFlux,GoRho, & -!$OMP calculate_energetics,dSV_dT,dSV_dS,cTKE,g_Hconv2) & -!$OMP private(opacityBand,h2d,T2d,netMassInOut,netMassOut, & -!$OMP netHeat,netSalt,Pen_SW_bnd,fractionOfForcing, & -!$OMP IforcingDepthScale, & -!$OMP dThickness,dTemp,dSalt,hOld,Ithickness, & -!$OMP netMassIn,pres,d_pres,p_lay,dSV_dT_2d, & -!$OMP netmassinout_rate,netheat_rate,netsalt_rate, & -!$OMP drhodt,drhods,pen_sw_bnd_rate,SurfPressure, & -!$OMP pen_TKE_2d,Temp_in,Salin_in,RivermixConst) & -!$OMP firstprivate(start,npts) - - - ! Work in vertical slices for efficiency + !$OMP parallel do default(none) shared(is,ie,js,je,nz,h,tv,nsw,G,GV,US,optics,fluxes,dt, & + !$OMP H_limit_fluxes,numberOfGroundings,iGround,jGround,& + !$OMP nonPenSW,hGrounding,CS,Idt,aggregate_FW_forcing, & + !$OMP minimum_forcing_depth,evap_CFL_limit, & + !$OMP calculate_buoyancy,netPen,SkinBuoyFlux,GoRho, & + !$OMP calculate_energetics,dSV_dT,dSV_dS,cTKE,g_Hconv2) & + !$OMP private(opacityBand,h2d,T2d,netMassInOut,netMassOut, & + !$OMP netHeat,netSalt,Pen_SW_bnd,fractionOfForcing, & + !$OMP IforcingDepthScale, & + !$OMP dThickness,dTemp,dSalt,hOld,Ithickness, & + !$OMP netMassIn,pres,d_pres,p_lay,dSV_dT_2d, & + !$OMP netmassinout_rate,netheat_rate,netsalt_rate, & + !$OMP drhodt,drhods,pen_sw_bnd_rate,SurfPressure, & + !$OMP pen_TKE_2d,Temp_in,Salin_in,RivermixConst) & + !$OMP firstprivate(start,npts) do j=js,je + ! Work in vertical slices for efficiency ! Copy state into 2D-slice arrays do k=1,nz ; do i=is,ie @@ -929,7 +905,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, dt, fluxes, optics, h, tv, & do i=is,ie ; pres(i) = 0.0 ; enddo ! Add surface pressure? do k=1,nz do i=is,ie - d_pres(i) = GV%g_Earth * GV%H_to_kg_m2 * h2d(i,k) + d_pres(i) = GV%H_to_Pa * h2d(i,k) p_lay(i) = pres(i) + 0.5*d_pres(i) pres(i) = pres(i) + d_pres(i) enddo @@ -937,8 +913,8 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, dt, fluxes, optics, h, tv, & dSV_dT(:,j,k), dSV_dS(:,j,k), is, ie-is+1, tv%eqn_of_state) do i=is,ie ; dSV_dT_2d(i,k) = dSV_dT(i,j,k) ; enddo ! do i=is,ie -! dT_to_dPE(i,k) = I_G_Earth * d_pres(i) * p_lay(i) * dSV_dT(i,j,k) -! dS_to_dPE(i,k) = I_G_Earth * d_pres(i) * p_lay(i) * dSV_dS(i,j,k) +! dT_to_dPE(i,k) = I_G_Earth * US%Z_to_m * d_pres(i) * p_lay(i) * dSV_dT(i,j,k) +! dS_to_dPE(i,k) = I_G_Earth * US%Z_to_m * d_pres(i) * p_lay(i) * dSV_dS(i,j,k) ! enddo enddo pen_TKE_2d(:,:) = 0.0 @@ -946,14 +922,14 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, dt, fluxes, optics, h, tv, & ! The surface forcing is contained in the fluxes type. ! We aggregate the thermodynamic forcing for a time step into the following: - ! netMassInOut = surface water fluxes (H units) over time step + ! netMassInOut = surface water fluxes [H ~> m or kg m-2] over time step ! = lprec + fprec + vprec + evap + lrunoff + frunoff ! note that lprec generally has sea ice melt/form included. - ! netMassOut = net mass leaving ocean surface (H units) over a time step. + ! netMassOut = net mass leaving ocean surface [H ~> m or kg m-2] over a time step. ! netMassOut < 0 means mass leaves ocean. - ! netHeat = heat (degC * H) via surface fluxes, excluding the part + ! netHeat = heat via surface fluxes [degC H ~> degC m or degC kg m-2], excluding the part ! contained in Pen_SW_bnd; and excluding heat_content of netMassOut < 0. - ! netSalt = surface salt fluxes ( g(salt)/m2 for non-Bouss and ppt*H for Bouss ) + ! netSalt = surface salt fluxes [ppt H ~> dppt m or gSalt m-2] ! Pen_SW_bnd = components to penetrative shortwave radiation split according to bands. ! This field provides that portion of SW from atmosphere that in fact ! enters to the ocean and participates in pentrative SW heating. @@ -1059,12 +1035,12 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, dt, fluxes, optics, h, tv, & ! as follows: ! TKE_river[m3 s-3] = 0.5*rivermix_depth*g*(1/rho)*drho_ds* ! River*(Samb - Sriver) = CS%mstar*U_star^3 - ! where River is in units of m s-1. + ! where River is in units of [m s-1]. ! Samb = Ambient salinity at the mouth of the estuary ! rivermix_depth = The prescribed depth over which to mix river inflow ! drho_ds = The gradient of density wrt salt at the ambient surface salinity. ! Sriver = 0 (i.e. rivers are assumed to be pure freshwater) - RivermixConst = -0.5*(CS%rivermix_depth*dt)*GV%m_to_H*GV%H_to_Pa + RivermixConst = -0.5*(CS%rivermix_depth*dt)*GV%Z_to_H*GV%H_to_Pa cTKE(i,j,k) = cTKE(i,j,k) + max(0.0, RivermixConst*dSV_dS(i,j,1) * & (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j)) * tv%S(i,j,1)) @@ -1131,7 +1107,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, dt, fluxes, optics, h, tv, & tv%T(i,j,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 +!### NOTE: tv%T should be T2d in the expressions above. ! Update state by the appropriate increment. hOld = h2d(i,k) ! Keep original thickness in hand @@ -1164,7 +1140,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, dt, fluxes, optics, h, tv, & enddo ! k ! Check if trying to apply fluxes over land points - elseif((abs(netHeat(i))+abs(netSalt(i))+abs(netMassIn(i))+abs(netMassOut(i)))>0.) then + elseif ((abs(netHeat(i))+abs(netSalt(i))+abs(netMassIn(i))+abs(netMassOut(i)))>0.) then if (.not. CS%ignore_fluxes_over_land) then call forcing_SinglePointPrint(fluxes,G,i,j,'applyBoundaryFluxesInOut (land)') @@ -1199,7 +1175,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, dt, fluxes, optics, h, tv, & ! Save temperature before increment with SW heating ! and initialize CS%penSWflux_diag to zero. - if(CS%id_penSW_diag > 0 .or. CS%id_penSWflux_diag > 0) then + if (CS%id_penSW_diag > 0 .or. CS%id_penSWflux_diag > 0) then do k=1,nz ; do i=is,ie CS%penSW_diag(i,j,k) = T2d(i,k) CS%penSWflux_diag(i,j,k) = 0.0 @@ -1229,9 +1205,9 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, dt, fluxes, optics, h, tv, & tv%T(i,j,k) = T2d(i,k) enddo ; enddo - ! Diagnose heating (W/m2) applied to a grid cell from SW penetration + ! Diagnose heating [W m-2] applied to a grid cell from SW penetration ! Also diagnose the penetrative SW heat flux at base of layer. - if(CS%id_penSW_diag > 0 .or. CS%id_penSWflux_diag > 0) then + if (CS%id_penSW_diag > 0 .or. CS%id_penSWflux_diag > 0) then ! convergence of SW into a layer do k=1,nz ; do i=is,ie @@ -1244,7 +1220,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, dt, fluxes, optics, h, tv, & ! CS%penSWflux_diag(i,j,k=kbot+1) is zero, since assume no SW penetrates rock. ! CS%penSWflux_diag = rsdo and CS%penSW_diag = rsdoabsorb ! rsdoabsorb(k) = rsdo(k) - rsdo(k+1), so that rsdo(k) = rsdo(k+1) + rsdoabsorb(k) - if(CS%id_penSWflux_diag > 0) then + if (CS%id_penSWflux_diag > 0) then do k=nz,1,-1 ; do i=is,ie CS%penSWflux_diag(i,j,k) = CS%penSW_diag(i,j,k) + CS%penSWflux_diag(i,j,k+1) enddo ; enddo @@ -1253,7 +1229,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, dt, fluxes, optics, h, tv, & endif ! Fill CS%nonpenSW_diag - if(CS%id_nonpenSW_diag > 0) then + if (CS%id_nonpenSW_diag > 0) then do i=is,ie CS%nonpenSW_diag(i,j) = nonpenSW(i) enddo @@ -1281,7 +1257,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, dt, fluxes, optics, h, tv, & ! 3. Convert to a buoyancy flux, excluding penetrating SW heating ! BGR-Jul 5, 2017: The contribution of SW heating here needs investigated for ePBL. do i=is,ie - SkinBuoyFlux(i,j) = - GoRho * GV%H_to_m * ( & + SkinBuoyFlux(i,j) = - GoRho * GV%H_to_Z * US%m_to_Z**2 * ( & dRhodS(i) * (netSalt_rate(i) - tv%S(i,j,1)*netMassInOut_rate(i)) + & dRhodT(i) * ( netHeat_rate(i) + netPen(i,1)) ) ! m^2/s^3 enddo @@ -1314,31 +1290,25 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, dt, fluxes, optics, h, tv, & end subroutine applyBoundaryFluxesInOut -subroutine diabatic_aux_init(Time, G, GV, param_file, diag, CS, useALEalgorithm, use_ePBL) - type(time_type), intent(in) :: Time +!> This subroutine initializes the parameters and control structure of the diabatic_aux module. +subroutine diabatic_aux_init(Time, G, GV, US, param_file, diag, CS, useALEalgorithm, use_ePBL) + type(time_type), intent(in) :: Time !< The 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 - type(diabatic_aux_CS), pointer :: CS - logical, intent(in) :: useALEalgorithm - logical, intent(in) :: use_ePBL - -! Arguments: -! (in) Time = current model time -! (in) G = ocean grid structure -! (in) GV - The ocean's vertical grid structure. -! (in) param_file = structure indicating the open file to parse for parameter values -! (in) diag = structure used to regulate diagnostic output -! (in/out) CS = pointer set to point to the control structure for this module -! (in) use_ePBL = If true, use the implicit energetics planetary boundary -! layer scheme to determine the diffusivity in the -! surface boundary layer. - type(vardesc) :: vd + type(diag_ctrl), target, intent(inout) :: diag !< A structure used to regulate diagnostic output + type(diabatic_aux_CS), pointer :: CS !< A pointer to the control structure for the + !! diabatic_aux module, which is initialized here. + logical, intent(in) :: useALEalgorithm !< If true, use the ALE algorithm rather + !! than layered mode. + logical, intent(in) :: use_ePBL !< If true, use the implicit energetics planetary + !! boundary layer scheme to determine the diffusivity + !! in the surface boundary layer. ! This "include" declares and sets the variable "version". #include "version_variable.h" - character(len=40) :: mod = "MOM_diabatic_aux" ! This module's name. + character(len=40) :: mdl = "MOM_diabatic_aux" ! This module's name. character(len=48) :: thickness_units integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz, nbands isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = G%ke @@ -1355,15 +1325,15 @@ subroutine diabatic_aux_init(Time, G, GV, param_file, diag, CS, useALEalgorithm, CS%diag => diag ! Set default, read and log parameters - call log_version(param_file, mod, version, & + call log_version(param_file, mdl, version, & "The following parameters are used for auxiliary diabatic processes.") - call get_param(param_file, mod, "RECLAIM_FRAZIL", CS%reclaim_frazil, & + 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"//& "the freezing point.", default=.true.) - call get_param(param_file, mod, "PRESSURE_DEPENDENT_FRAZIL", & + 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"//& @@ -1371,27 +1341,30 @@ subroutine diabatic_aux_init(Time, G, GV, param_file, diag, CS, useALEalgorithm, default=.false.) if (use_ePBL) then - call get_param(param_file, mod, "IGNORE_FLUXES_OVER_LAND", CS%ignore_fluxes_over_land,& + 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"//& "under ice shelves. This flag only works when use_ePBL = True.", default=.false.) - call get_param(param_file, mod, "DO_RIVERMIX", CS%do_rivermix, & + 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 the ocean is that deep.", default=.false.) if (CS%do_rivermix) & - call get_param(param_file, mod, "RIVERMIX_DEPTH", CS%rivermix_depth, & + call get_param(param_file, mdl, "RIVERMIX_DEPTH", CS%rivermix_depth, & "The depth to which rivers are mixed if DO_RIVERMIX is \n"//& - "defined.", units="m", default=0.0) - else ; CS%do_rivermix = .false. ; CS%rivermix_depth = 0.0 ; endif + "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. + endif + if (GV%nkml == 0) then - call get_param(param_file, mod, "USE_RIVER_HEAT_CONTENT", CS%use_river_heat_content, & + 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"//& "heat carried by runoff, instead of using SST*CP*liq_runoff.", & default=.false.) - call get_param(param_file, mod, "USE_CALVING_HEAT_CONTENT", CS%use_calving_heat_content, & + 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"//& "heat carried by runoff, instead of using SST*CP*froz_runoff.", & default=.false.) @@ -1441,9 +1414,11 @@ subroutine diabatic_aux_init(Time, G, GV, param_file, diag, CS, useALEalgorithm, end subroutine diabatic_aux_init - +!> This subroutine initializes the control structure and any related memory +!! for the diabatic_aux module. subroutine diabatic_aux_end(CS) - type(diabatic_aux_CS), pointer :: CS + type(diabatic_aux_CS), pointer :: CS !< The control structure returned by a previous + !! call to diabatic_aux_init; it is deallocated here. if (.not.associated(CS)) return @@ -1456,4 +1431,34 @@ subroutine diabatic_aux_end(CS) end subroutine diabatic_aux_end +!> \namespace mom_diabatic_aux +!! +!! This module contains the subroutines that, along with the +!! subroutines that it calls, implements diapycnal mass and momentum +!! fluxes and a bulk mixed layer. The diapycnal diffusion can be +!! used without the bulk mixed layer. +!! +!! diabatic first determines the (diffusive) diapycnal mass fluxes +!! based on the convergence of the buoyancy fluxes within each layer. +!! The dual-stream entrainment scheme of MacDougall and Dewar (JPO, +!! 1997) is used for combined diapycnal advection and diffusion, +!! calculated implicitly and potentially with the Richardson number +!! dependent mixing, as described by Hallberg (MWR, 2000). Diapycnal +!! advection is fundamentally the residual of diapycnal diffusion, +!! so the fully implicit upwind differencing scheme that is used is +!! entirely appropriate. The downward buoyancy flux in each layer +!! is determined from an implicit calculation based on the previously +!! calculated flux of the layer above and an estimated flux in the +!! layer below. This flux is subject to the following conditions: +!! (1) the flux in the top and bottom layers are set by the boundary +!! conditions, and (2) no layer may be driven below an Angstrom thick- +!! ness. If there is a bulk mixed layer, the buffer layer is treat- +!! ed as a fixed density layer with vanishingly small diffusivity. +!! +!! diabatic takes 5 arguments: the two velocities (u and v), the +!! thicknesses (h), a structure containing the forcing fields, and +!! the length of time over which to act (dt). The velocities and +!! thickness are taken as inputs and modified within the subroutine. +!! There is no limit on the time step. + end module MOM_diabatic_aux diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 24ebb3ebd1..24a529716d 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -10,6 +10,7 @@ module MOM_diabatic_driver use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE use MOM_CVMix_shear, only : CVMix_shear_is_used +use MOM_CVMix_ddiff, only : CVMix_ddiff_is_used use MOM_diabatic_aux, only : diabatic_aux_init, diabatic_aux_end, diabatic_aux_CS use MOM_diabatic_aux, only : make_frazil, adjust_salt, insert_brine, differential_diffuse_T_S, triDiagTS use MOM_diabatic_aux, only : find_uv_at_h, diagnoseMLDbyDensityDifference, applyBoundaryFluxesInOut @@ -49,8 +50,9 @@ module MOM_diabatic_driver use MOM_internal_tides, only : propagate_int_tide use MOM_internal_tides, only : internal_tides_init, internal_tides_end, int_tide_CS use MOM_kappa_shear, only : kappa_shear_is_used -use MOM_KPP, only : KPP_CS, KPP_init, KPP_calculate, KPP_end, KPP_get_BLD -use MOM_KPP, only : KPP_NonLocalTransport_temp, KPP_NonLocalTransport_saln +use MOM_CVMix_KPP, only : KPP_CS, KPP_init, KPP_compute_BLD, KPP_calculate +use MOM_CVMix_KPP, only : KPP_end, KPP_get_BLD +use MOM_CVMix_KPP, only : KPP_NonLocalTransport_temp, KPP_NonLocalTransport_saln use MOM_opacity, only : opacity_init, set_opacity, opacity_end, opacity_CS use MOM_regularize_layers, only : regularize_layers, regularize_layers_init, regularize_layers_CS use MOM_set_diffusivity, only : set_diffusivity, set_BBL_TKE @@ -59,10 +61,10 @@ module MOM_diabatic_driver use MOM_shortwave_abs, only : absorbRemainingSW, optics_type use MOM_sponge, only : apply_sponge, sponge_CS use MOM_ALE_sponge, only : apply_ALE_sponge, ALE_sponge_CS -use MOM_time_manager, only : operator(-), set_time -use MOM_time_manager, only : operator(<=), time_type ! for testing itides (BDM) +use MOM_time_manager, only : time_type, real_to_time, operator(-), operator(<=) use MOM_tracer_flow_control, only : call_tracer_column_fns, tracer_flow_control_CS use MOM_tracer_diabatic, only : tracer_vertdiff +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs, vertvisc_type, accel_diag_ptrs use MOM_variables, only : cont_diag_ptrs, MOM_thermovar_chksum, p3d use MOM_verticalGrid, only : verticalGrid_type @@ -81,18 +83,27 @@ module MOM_diabatic_driver public extract_diabatic_member public adiabatic public adiabatic_driver_init +public legacy_diabatic + +! 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. !> Control structure for this module -type, public:: diabatic_CS ; private +type, public:: diabatic_CS; private logical :: bulkmixedlayer !< If true, a refined bulk mixed layer is used with !! nkml sublayers (and additional buffer layers). logical :: use_energetic_PBL !< If true, use the implicit energetics planetary !! boundary layer scheme to determine the diffusivity !! in the surface boundary layer. + logical :: use_KPP !< If true, use CVMix/KPP boundary layer scheme to determine the + !! OBLD and the diffusivities within this layer. logical :: use_kappa_shear !< If true, use the kappa_shear module to find the !! shear-driven diapycnal diffusivity. logical :: use_CVMix_shear !< If true, use the CVMix module to find the !! shear-driven diapycnal diffusivity. + logical :: use_CVMix_ddiff !< If true, use the CVMix double diffusion module. logical :: use_tidal_mixing !< If true, activate tidal mixing diffusivity. logical :: use_CVMix_conv !< If true, use the CVMix module to get enhanced !! mixing due to convection. @@ -142,122 +153,1016 @@ module MOM_diabatic_driver !! operating. real :: Kd_BBL_tr !< A bottom boundary layer tracer diffusivity that !! will allow for explicitly specified bottom fluxes - !! in m2 s-1. The entrainment at the bottom is at + !! [Z2 s-1 ~> m2 s-1]. The entrainment at the bottom is at !! least sqrt(Kd_BBL_tr*dt) over the same distance. real :: Kd_min_tr !< A minimal diffusivity that should always be !! applied to tracers, especially in massless layers - !! near the bottom, in m2 s-1. + !! near the bottom [Z2 s-1 ~> m2 s-1]. real :: minimum_forcing_depth = 0.001 !< The smallest depth over which heat and freshwater - !! fluxes is applied, in m. + !! fluxes are applied [m]. real :: evap_CFL_limit = 0.8 !< The largest fraction of a layer that can be - !! evaporated in one time-step (non-dim). + !! evaporated in one time-step [nondim]. + integer :: halo_TS_diff = 0 !< The temperature, salinity and thickness halo size that + !! must be valid for the diffusivity calculations. + logical :: useKPP = .false. !< use CVMix/KPP diffusivities and non-local transport + logical :: salt_reject_below_ML !< If true, add salt below mixed layer (layer mode only) + logical :: KPPisPassive !< If true, KPP is in passive mode, not changing answers. + logical :: debug !< If true, write verbose checksums for debugging purposes. + logical :: debugConservation !< If true, monitor conservation and extrema. + logical :: tracer_tridiag !< If true, use tracer_vertdiff instead of tridiagTS for + !< vertical diffusion of T and S + 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 + integer :: nsw !< SW_NBANDS + + !>@{ Diagnostic IDs + integer :: id_cg1 = -1 ! diag handle for mode-1 speed (BDM) + 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_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 + + ! diagnostic for fields prior to applying diapycnal physics + integer :: id_u_predia = -1, id_v_predia = -1, id_h_predia = -1 + integer :: id_T_predia = -1, id_S_predia = -1, id_e_predia = -1 + + integer :: id_diabatic_diff_temp_tend = -1 + integer :: id_diabatic_diff_saln_tend = -1 + integer :: id_diabatic_diff_heat_tend = -1 + integer :: id_diabatic_diff_salt_tend = -1 + integer :: id_diabatic_diff_heat_tend_2d = -1 + integer :: id_diabatic_diff_salt_tend_2d = -1 + integer :: id_diabatic_diff_h= -1 + + integer :: id_boundary_forcing_h = -1 + integer :: id_boundary_forcing_h_tendency = -1 + integer :: id_boundary_forcing_temp_tend = -1 + integer :: id_boundary_forcing_saln_tend = -1 + integer :: id_boundary_forcing_heat_tend = -1 + integer :: id_boundary_forcing_salt_tend = -1 + integer :: id_boundary_forcing_heat_tend_2d = -1 + integer :: id_boundary_forcing_salt_tend_2d = -1 + + integer :: id_frazil_h = -1 + integer :: id_frazil_temp_tend = -1 + integer :: id_frazil_heat_tend = -1 + integer :: id_frazil_heat_tend_2d = -1 + !!@} + + logical :: diabatic_diff_tendency_diag = .false. !< If true calculate diffusive tendency diagnostics + logical :: boundary_forcing_tendency_diag = .false. !< If true calculate frazil diagnostics + logical :: frazil_tendency_diag = .false. !< If true calculate frazil tendency diagnostics + real, allocatable, dimension(:,:,:) :: frazil_heat_diag !< diagnose 3d heat tendency from frazil + real, allocatable, dimension(:,:,:) :: frazil_temp_diag !< diagnose 3d temp tendency from frazil + + type(diabatic_aux_CS), pointer :: diabatic_aux_CSp => NULL() !< Control structure for a child module + type(entrain_diffusive_CS), pointer :: entrain_diffusive_CSp => NULL() !< Control structure for a child module + type(bulkmixedlayer_CS), pointer :: bulkmixedlayer_CSp => NULL() !< Control structure for a child module + type(energetic_PBL_CS), pointer :: energetic_PBL_CSp => NULL() !< Control structure for a child module + type(regularize_layers_CS), pointer :: regularize_layers_CSp => NULL() !< Control structure for a child module + type(geothermal_CS), pointer :: geothermal_CSp => NULL() !< Control structure for a child module + type(int_tide_CS), pointer :: int_tide_CSp => NULL() !< Control structure for a child module + type(int_tide_input_CS), pointer :: int_tide_input_CSp => NULL() !< Control structure for a child module + type(int_tide_input_type), pointer :: int_tide_input => NULL() !< Control structure for a child module + type(opacity_CS), pointer :: opacity_CSp => NULL() !< Control structure for a child module + type(set_diffusivity_CS), pointer :: set_diff_CSp => NULL() !< Control structure for a child module + type(sponge_CS), pointer :: sponge_CSp => NULL() !< Control structure for a child module + 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 + type(diapyc_energy_req_CS), pointer :: diapyc_en_rec_CSp => NULL() !< Control structure for a child module + + type(group_pass_type) :: pass_hold_eb_ea !< For group halo pass + type(group_pass_type) :: pass_Kv !< For group halo pass + type(diag_grid_storage) :: diag_grids_prev!< Stores diagnostic grids at some previous point in the algorithm + ! Data arrays for communicating between components + real, allocatable, dimension(:,:,:) :: KPP_NLTheat !< KPP non-local transport for heat [m s-1] + real, allocatable, dimension(:,:,:) :: KPP_NLTscalar !< KPP non-local transport for scalars [m s-1] + real, allocatable, dimension(:,:,:) :: KPP_buoy_flux !< KPP forcing buoyancy flux [m2 s-3] + real, allocatable, dimension(:,:) :: KPP_temp_flux !< KPP effective temperature flux [degC m s-1] + real, allocatable, dimension(:,:) :: KPP_salt_flux !< KPP effective salt flux [ppt m s-1] + + type(time_type), pointer :: Time !< Pointer to model time (needed for sponges) +end type diabatic_CS + +! clock ids +integer :: id_clock_entrain, id_clock_mixedlayer, id_clock_set_diffusivity +integer :: id_clock_tracers, id_clock_tridiag, id_clock_pass, id_clock_sponge +integer :: id_clock_geothermal, id_clock_differential_diff, id_clock_remap +integer :: id_clock_kpp + +contains + +!> This subroutine imposes the diapycnal mass fluxes and the +!! accompanying diapycnal advection of momentum and tracers. +subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & + G, GV, US, CS, WAVES) + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + 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),SZK_(G)), intent(inout) :: u !< zonal velocity [m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: v !< meridional velocity [m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields + !! unused have NULL ptrs + real, dimension(:,:), pointer :: Hml !< mixed layer depth [m] + type(forcing), intent(inout) :: fluxes !< points to forcing fields + !! unused fields have NULL ptrs + type(vertvisc_type), intent(inout) :: visc !< vertical viscosities, BBL properies, and + type(accel_diag_ptrs), intent(inout) :: ADp !< related points to accelerations in momentum + !! equations, to enable the later derived + !! diagnostics, like energy budgets + type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations + real, intent(in) :: dt !< time increment [s] + type(time_type), intent(in) :: Time_end !< Time at the end of the interval + type(diabatic_CS), pointer :: CS !< module control structure + type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves + + ! local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & + ea_s, & ! amount of fluid entrained from the layer above within + ! one time step [H ~> m or kg m-2] + eb_s, & ! amount of fluid entrained from the layer below within + ! one time step [H ~> m or kg m-2] + ea_t, & ! amount of fluid entrained from the layer above within + ! 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] + 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 + ! the initial layer thicknesses (if a mixed layer is used), + ! [H ~> m or kg m-2] + dSV_dT, & ! The partial derivatives of specific volume with temperature + dSV_dS, & ! and salinity in [m3 kg-1 degC-1] and [m3 kg-1 ppt-1]. + cTKE, & ! convective TKE requirements for each layer [J/m^2]. + u_h, & ! zonal and meridional velocities at thickness points after + v_h ! entrainment [m s-1] + real, dimension(SZI_(G),SZJ_(G),CS%nMode) :: & + cn ! baroclinic gravity wave speeds + real, dimension(SZI_(G),SZJ_(G)) :: & + Rcv_ml, & ! coordinate density of mixed layer, used for applying sponges + SkinBuoyFlux! 2d surface buoyancy flux [Z2 s-3 ~> m2 s-3], used by ePBL + real, dimension(SZI_(G),SZJ_(G),G%ke) :: h_diag ! diagnostic array for thickness + real, dimension(SZI_(G),SZJ_(G),G%ke) :: temp_diag ! diagnostic array for temp + real, dimension(SZI_(G),SZJ_(G),G%ke) :: saln_diag ! diagnostic array for salinity + real, dimension(SZI_(G),SZJ_(G)) :: tendency_2d ! depth integrated content tendency for diagn + real, dimension(SZI_(G),SZJ_(G)) :: TKE_itidal_input_test ! override of energy input for testing (BDM) + + real :: net_ent ! The net of ea-eb at an interface. + + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), target :: & + ! These are targets so that the space can be shared with eaml & ebml. + eatr, & ! The equivalent of ea and eb for tracers, which differ from ea and + ebtr ! eb in that they tend to homogenize tracers in massless layers + ! 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_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] + eta, & ! Interface heights before diapycnal mixing [m]. + Tdif_flx, & ! diffusive diapycnal heat flux across interfaces [degC m s-1] + Tadv_flx, & ! advective diapycnal heat flux across interfaces [degC m s-1] + Sdif_flx, & ! diffusive diapycnal salt flux across interfaces [ppt m s-1] + Sadv_flx ! advective diapycnal salt flux across interfaces [ppt m s-1] + + ! The following 5 variables are only used with a bulk mixed layer. + real, pointer, dimension(:,:,:) :: & + eaml, & ! The equivalent of ea and eb due to mixed layer processes [H ~> m or kg m-2] + ebml ! [H ~> m or kg m-2]. These will be + ! pointers to eatr and ebtr so as to reuse the memory as + ! the arrays are not needed at the same time. + + integer :: kb(SZI_(G),SZJ_(G)) ! index of the lightest layer denser + ! than the buffer layer [nondim] + + real :: p_ref_cv(SZI_(G)) ! Reference pressure for the potential + ! density which defines the coordinate + ! variable, set to P_Ref [Pa]. + + logical :: in_boundary(SZI_(G)) ! True if there are no massive layers below, + ! where massive is defined as sufficiently thick that + ! the no-flux boundary conditions have not restricted + ! the entrainment - usually sqrt(Kd*dt). + + real :: b_denom_1 ! The first term in the denominator of b1 + ! [H ~> m or kg m-2] + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected + ! [H ~> m or kg m-2] + real :: h_neglect2 ! h_neglect^2 [H2 ~> m2 or kg2 m-4] + real :: add_ent ! Entrainment that needs to be added when mixing tracers + ! [H ~> m or kg m-2] + real :: eaval ! eaval is 2*ea at velocity grid points [H ~> m or kg m-2] + real :: hval ! hval is 2*h at velocity grid points [H ~> m or kg m-2] + real :: h_tr ! h_tr is h at tracer points with a tiny thickness + ! added to ensure positive definiteness [H ~> m or kg m-2] + real :: Tr_ea_BBL ! The diffusive tracer thickness in the BBL that is + ! coupled to the bottom within a timestep [H ~> m or kg m-2] + + real :: htot(SZIB_(G)) ! The summed thickness from the bottom [H ~> m or kg m-2]. + real :: b1(SZIB_(G)), d1(SZIB_(G)) ! b1, c1, and d1 are variables used by the + real :: c1(SZIB_(G),SZK_(G)) ! tridiagonal solver. + + real :: Ent_int ! The diffusive entrainment rate at an interface [H ~> m or kg m-2] + 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 + + integer :: ig, jg ! global indices for testing testing itide point source (BDM) + logical :: avg_enabled ! for testing internal tides (BDM) + real :: Kd_add_here ! An added diffusivity [Z2 s-1 ~> m2 s-1]. + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + nkmb = GV%nk_rho_varies + h_neglect = GV%H_subroundoff ; h_neglect2 = h_neglect*h_neglect + Kd_heat(:,:,:) = 0.0 ; Kd_salt(:,:,:) = 0.0 + + if (nz == 1) return + showCallTree = callTree_showQuery() + if (showCallTree) call callTree_enter("diabatic(), MOM_diabatic_driver.F90") + + if (.not. (CS%useALEalgorithm)) call MOM_error(FATAL, "MOM_diabatic_driver: "// & + "The ALE algorithm must be enabled when using MOM_diabatic_driver.") + + ! Offer diagnostics of various state varables at the start of diabatic + ! these are mostly for debugging purposes. + if (CS%id_u_predia > 0) call post_data(CS%id_u_predia, u, CS%diag) + if (CS%id_v_predia > 0) call post_data(CS%id_v_predia, v, CS%diag) + if (CS%id_h_predia > 0) call post_data(CS%id_h_predia, h, CS%diag) + if (CS%id_T_predia > 0) call post_data(CS%id_T_predia, tv%T, CS%diag) + if (CS%id_S_predia > 0) call post_data(CS%id_S_predia, tv%S, CS%diag) + if (CS%id_e_predia > 0) then + call find_eta(h, tv, G, GV, US, eta, eta_to_m=1.0) + call post_data(CS%id_e_predia, eta, CS%diag) + endif + + + ! set equivalence between the same bits of memory for these arrays + eaml => eatr ; ebml => ebtr + + ! inverse time step + if (dt == 0.0) call MOM_error(FATAL, "MOM_diabatic_driver: "// & + "diabatic was called with a zero length timestep.") + if (dt < 0.0) call MOM_error(FATAL, "MOM_diabatic_driver: "// & + "diabatic was called with a negative timestep.") + Idt = 1.0 / dt + + if (.not. associated(CS)) call MOM_error(FATAL, "MOM_diabatic_driver: "// & + "Module must be initialized before it is used.") + + if (CS%debug) then + call MOM_state_chksum("Start of diabatic ", u, v, h, G, GV, haloshift=0) + call MOM_forcing_chksum("Start of diabatic", fluxes, G, US, haloshift=0) + endif + if (CS%debugConservation) call MOM_state_stats('Start of diabatic', u, v, h, tv%T, tv%S, G) + + if (CS%debug_energy_req) & + call diapyc_energy_req_test(h, dt, tv, G, GV, US, CS%diapyc_en_rec_CSp) + + + call cpu_clock_begin(id_clock_set_diffusivity) + call set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS%set_diff_CSp) + call cpu_clock_end(id_clock_set_diffusivity) + + ! Frazil formation keeps the temperature above the freezing point. + ! make_frazil is deliberately called at both the beginning and at + ! the end of the diabatic processes. + if (associated(tv%T) .AND. associated(tv%frazil)) then + ! For frazil diagnostic, the first call covers the first half of the time step + call enable_averaging(0.5*dt, Time_end - real_to_time(0.5*dt), CS%diag) + if (CS%frazil_tendency_diag) then + do k=1,nz ; do j=js,je ; do i=is,ie + temp_diag(i,j,k) = tv%T(i,j,k) + enddo ; enddo ; enddo + endif + + if (associated(fluxes%p_surf_full)) then + call make_frazil(h, tv, G, GV, CS%diabatic_aux_CSp, fluxes%p_surf_full, halo=CS%halo_TS_diff) + else + call make_frazil(h, tv, G, GV, CS%diabatic_aux_CSp, halo=CS%halo_TS_diff) + endif + if (showCallTree) call callTree_waypoint("done with 1st make_frazil (diabatic)") + + if (CS%frazil_tendency_diag) then + call diagnose_frazil_tendency(tv, h, temp_diag, 0.5*dt, G, GV, CS) + if (CS%id_frazil_h > 0) call post_data(CS%id_frazil_h, h, CS%diag) + endif + call disable_averaging(CS%diag) + endif !associated(tv%T) .AND. associated(tv%frazil) + + ! For all other diabatic subroutines, the averaging window should be the entire diabatic timestep + call enable_averaging(dt, Time_end, CS%diag) + if (CS%debugConservation) call MOM_state_stats('1st make_frazil', u, v, h, tv%T, tv%S, G) + + if ((CS%ML_mix_first > 0.0) .or. CS%use_geothermal) then + halo = CS%halo_TS_diff + !$OMP parallel do default(shared) + do k=1,nz ; do j=js-halo,je+halo ; do i=is-halo,ie+halo + h_orig(i,j,k) = h(i,j,k) ; eaml(i,j,k) = 0.0 ; ebml(i,j,k) = 0.0 + enddo ; enddo ; enddo + endif + + if (CS%use_geothermal) then + call cpu_clock_begin(id_clock_geothermal) + call geothermal(h, tv, dt, eaml, ebml, G, GV, CS%geothermal_CSp, halo=CS%halo_TS_diff) + call cpu_clock_end(id_clock_geothermal) + if (showCallTree) call callTree_waypoint("geothermal (diabatic)") + if (CS%debugConservation) call MOM_state_stats('geothermal', u, v, h, tv%T, tv%S, G) + endif + + ! Whenever thickness changes let the diag manager know, target grids + ! for vertical remapping may need to be regenerated. + call diag_update_remap_grids(CS%diag) + + ! Set_opacity estimates the optical properties of the water column. + ! It will need to be modified later to include information about the + ! biological properties and layer thicknesses. + if (associated(CS%optics)) & + call set_opacity(CS%optics, fluxes, G, GV, CS%opacity_CSp) + + if (CS%debug) & + call MOM_state_chksum("before find_uv_at_h", u, v, h, G, GV, haloshift=0) + + if (CS%use_kappa_shear .or. CS%use_CVMix_shear) then + if ((CS%ML_mix_first > 0.0) .or. CS%use_geothermal) then + call find_uv_at_h(u, v, h_orig, u_h, v_h, G, GV, eaml, ebml) + if (CS%debug) then + call hchksum(eaml, "after find_uv_at_h eaml",G%HI, scale=GV%H_to_m) + call hchksum(ebml, "after find_uv_at_h ebml",G%HI, scale=GV%H_to_m) + endif + else + call find_uv_at_h(u, v, h, u_h, v_h, G, GV) + endif + if (showCallTree) call callTree_waypoint("done with find_uv_at_h (diabatic)") + endif + + if (CS%use_int_tides) then + ! This block provides an interface for the unresolved low-mode internal + ! tide module (BDM). + + ! PROVIDE ENERGY DISTRIBUTION (calculate time-varying energy source) + call set_int_tide_input(u, v, h, tv, fluxes, CS%int_tide_input, dt, G, GV, US, & + CS%int_tide_input_CSp) + ! CALCULATE MODAL VELOCITIES + cn(:,:,:) = 0.0 + if (CS%uniform_cg) then + ! SET TO CONSTANT VALUE TO TEST PROPAGATE CODE + do m=1,CS%nMode ; cn(:,:,m) = CS%cg_test ; enddo + else + call wave_speeds(h, tv, G, GV, US, CS%nMode, cn, full_halos=.true.) + ! uncomment the lines below for a hard-coded cn that changes linearly with latitude + !do j=G%jsd,G%jed ; do i=G%isd,G%ied + ! cn(i,j,:) = ((7.-1.)/14000000.)*G%geoLatBu(i,j) + (1.-((7.-1.)/14000000.)*-7000000.) + !enddo ; enddo + endif + + if (CS%int_tide_source_test) then + ! BUILD 2D ARRAY WITH POINT SOURCE FOR TESTING + ! This block of code should be moved into set_int_tide_input. -RWH + TKE_itidal_input_test(:,:) = 0.0 + avg_enabled = query_averaging_enabled(CS%diag,time_end=CS%time_end) + if (CS%time_end <= CS%time_max_source) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec + !INPUT ARBITRARY ENERGY POINT SOURCE + if ((G%idg_offset + i == CS%int_tide_source_x) .and. & + (G%jdg_offset + j == CS%int_tide_source_y)) then + TKE_itidal_input_test(i,j) = 1.0 + endif + enddo ; enddo + endif + ! CALL ROUTINE USING PRESCRIBED KE FOR TESTING + call propagate_int_tide(h, tv, cn, TKE_itidal_input_test, & + CS%int_tide_input%tideamp, CS%int_tide_input%Nb, dt, G, GV, US, & + CS%int_tide_CSp) + else + ! CALL ROUTINE USING CALCULATED KE INPUT + call propagate_int_tide(h, tv, cn, CS%int_tide_input%TKE_itidal_input, & + CS%int_tide_input%tideamp, CS%int_tide_input%Nb, dt, G, GV, US, & + CS%int_tide_CSp) + endif + if (showCallTree) call callTree_waypoint("done with propagate_int_tide (diabatic)") + endif ! end CS%use_int_tides + + call cpu_clock_begin(id_clock_set_diffusivity) + ! Sets: Kd_lay, Kd_int, visc%Kd_extra_T, visc%Kd_extra_S + ! Also changes: visc%Kd_shear, visc%Kv_slow and visc%TKE_turb (not clear that TKE_turb is used as input ???? + call set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, CS%optics, visc, dt, G, GV, US, & + CS%set_diff_CSp, Kd_lay, Kd_int) + call cpu_clock_end(id_clock_set_diffusivity) + if (showCallTree) call callTree_waypoint("done with set_diffusivity (diabatic)") + + ! Set diffusivities for heat and salt separately + + !$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) + enddo ; enddo ; enddo + ! Add contribution from double diffusion + 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 + Kd_salt(i,j,k) = Kd_salt(i,j,k) + visc%Kd_extra_S(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 + Kd_heat(i,j,k) = Kd_heat(i,j,k) + visc%Kd_extra_T(i,j,k) + enddo ; enddo ; enddo + endif + + if (CS%debug) then + 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_heat, "after set_diffusivity Kd_heat", G%HI, haloshift=0, scale=US%Z_to_m**2) + call hchksum(Kd_salt, "after set_diffusivity Kd_salt", G%HI, haloshift=0, scale=US%Z_to_m**2) + endif + + if (CS%useKPP) then + call cpu_clock_begin(id_clock_kpp) + ! total vertical viscosity in the interior is represented via visc%Kv_shear + do k=1,nz+1 ; do j=js,je ; do i=is,ie + visc%Kv_shear(i,j,k) = visc%Kv_shear(i,j,k) + visc%Kv_slow(i,j,k) + enddo ; enddo ; enddo + + ! KPP needs the surface buoyancy flux but does not update state variables. + ! We could make this call higher up to avoid a repeat unpacking of the surface fluxes. + ! Sets: CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux + ! NOTE: CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux are returned as rates (i.e. stuff per second) + ! unlike other instances where the fluxes are integrated in time over a time-step. + call calculateBuoyancyFlux2d(G, GV, US, fluxes, CS%optics, h, tv%T, tv%S, tv, & + CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux) + ! The KPP scheme calculates boundary layer diffusivities and non-local transport. + + call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv%eqn_of_state, & + fluxes%ustar, CS%KPP_buoy_flux, Waves=Waves) + + call KPP_calculate(CS%KPP_CSp, G, GV, US, h, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & + Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves) + + if (associated(Hml)) then + !$OMP parallel default(shared) + call KPP_get_BLD(CS%KPP_CSp, Hml(:,:), G) + !$OMP end parallel + call pass_var(Hml, G%domain, halo=1) + ! If visc%MLD exists, copy KPP's BLD into it + if (associated(visc%MLD)) visc%MLD(:,:) = Hml(:,:) + endif + + call cpu_clock_end(id_clock_kpp) + if (showCallTree) call callTree_waypoint("done with KPP_calculate (diabatic)") + if (CS%debug) then + 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_heat, "after KPP Kd_heat", G%HI, haloshift=0, scale=US%Z_to_m**2) + call hchksum(Kd_salt, "after KPP Kd_salt", G%HI, haloshift=0, scale=US%Z_to_m**2) + endif + + endif ! endif for KPP + + + if (CS%useKPP) then + call cpu_clock_begin(id_clock_kpp) + if (CS%debug) then + call hchksum(CS%KPP_temp_flux, "before KPP_applyNLT netHeat",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(CS%KPP_salt_flux, "before KPP_applyNLT netSalt",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(CS%KPP_NLTheat, "before KPP_applyNLT NLTheat",G%HI,haloshift=0) + call hchksum(CS%KPP_NLTscalar, "before KPP_applyNLT NLTscalar",G%HI,haloshift=0) + endif + ! Apply non-local transport of heat and salt + ! Changes: tv%T, tv%S + call KPP_NonLocalTransport_temp(CS%KPP_CSp, G, GV, h, CS%KPP_NLTheat, CS%KPP_temp_flux, dt, tv%T, tv%C_p) + call KPP_NonLocalTransport_saln(CS%KPP_CSp, G, GV, h, CS%KPP_NLTscalar, CS%KPP_salt_flux, dt, tv%S) + call cpu_clock_end(id_clock_kpp) + if (showCallTree) call callTree_waypoint("done with KPP_applyNonLocalTransport (diabatic)") + if (CS%debugConservation) call MOM_state_stats('KPP_applyNonLocalTransport', u, v, h, tv%T, tv%S, G) + + if (CS%debug) then + call MOM_state_chksum("after KPP_applyNLT ", u, v, h, G, GV, haloshift=0) + call MOM_forcing_chksum("after KPP_applyNLT ", fluxes, G, US, haloshift=0) + call MOM_thermovar_chksum("after KPP_applyNLT ", tv, G) + endif + endif ! endif for KPP + + ! This is the "old" method for applying differential diffusion. + ! Changes: tv%T, tv%S + if (associated(visc%Kd_extra_T) .and. associated(visc%Kd_extra_S) .and. associated(tv%T) .and. .not. & + CS%use_CVMix_ddiff) then + + call cpu_clock_begin(id_clock_differential_diff) + call differential_diffuse_T_S(h, tv, visc, dt, G, GV) + call cpu_clock_end(id_clock_differential_diff) + + if (showCallTree) call callTree_waypoint("done with differential_diffuse_T_S (diabatic)") + if (CS%debugConservation) call MOM_state_stats('differential_diffuse_T_S', u, v, h, tv%T, tv%S, G) + + ! increment heat and salt diffusivity. + ! CS%useKPP==.true. already has extra_T and extra_S included + if (.not. CS%useKPP) then + !$OMP parallel do default(shared) + do K=2,nz ; do j=js,je ; do i=is,ie + Kd_heat(i,j,K) = Kd_heat(i,j,K) + visc%Kd_extra_T(i,j,K) + Kd_salt(i,j,K) = Kd_salt(i,j,K) + visc%Kd_extra_S(i,j,K) + enddo ; enddo ; enddo + endif + + endif + + ! Calculate vertical mixing due to convection (computed via CVMix) + if (CS%use_CVMix_conv) then + call calculate_CVMix_conv(h, tv, G, GV, US, CS%CVMix_conv_csp, Hml) + ! Increment vertical diffusion and viscosity due to convection + !$OMP parallel do default(shared) + do k=1,nz+1 ; do j=js,je ; do i=is,ie + Kd_heat(i,j,k) = Kd_heat(i,j,k) + CS%CVMix_conv_csp%kd_conv(i,j,k) + Kd_salt(i,j,k) = Kd_salt(i,j,k) + CS%CVMix_conv_csp%kd_conv(i,j,k) + if (CS%useKPP) then + visc%Kv_shear(i,j,k) = visc%Kv_shear(i,j,k) + CS%CVMix_conv_csp%kv_conv(i,j,k) + else + visc%Kv_slow(i,j,k) = visc%Kv_slow(i,j,k) + CS%CVMix_conv_csp%kv_conv(i,j,k) + endif + enddo ; enddo ; enddo + endif + + ! Save fields before boundary forcing is applied for tendency diagnostics + if (CS%boundary_forcing_tendency_diag) then + do k=1,nz ; do j=js,je ; do i=is,ie + h_diag(i,j,k) = h(i,j,k) + temp_diag(i,j,k) = tv%T(i,j,k) + saln_diag(i,j,k) = tv%S(i,j,k) + enddo ; enddo ; enddo + endif + + ! Apply forcing + call cpu_clock_begin(id_clock_remap) + + ! Changes made to following fields: h, tv%T and tv%S. + do k=1,nz ; do j=js,je ; do i=is,ie + h_prebound(i,j,k) = h(i,j,k) + enddo ; enddo ; enddo + if (CS%use_energetic_PBL) then + + skinbuoyflux(:,:) = 0.0 + call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt, fluxes, CS%optics, & + h, tv, CS%aggregate_FW_forcing, CS%evap_CFL_limit, & + CS%minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, SkinBuoyFlux=SkinBuoyFlux) + + if (CS%debug) then + call hchksum(ea_t, "after applyBoundaryFluxes ea_t",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(eb_t, "after applyBoundaryFluxes eb_t",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(ea_s, "after applyBoundaryFluxes ea_s",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(eb_s, "after applyBoundaryFluxes eb_s",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(cTKE, "after applyBoundaryFluxes cTKE",G%HI,haloshift=0) + call hchksum(dSV_dT, "after applyBoundaryFluxes dSV_dT",G%HI,haloshift=0) + call hchksum(dSV_dS, "after applyBoundaryFluxes dSV_dS",G%HI,haloshift=0) + endif + + call find_uv_at_h(u, v, h, u_h, v_h, G, GV) + call energetic_PBL(h, u_h, v_h, tv, fluxes, dt, Kd_ePBL, G, GV, US, & + CS%energetic_PBL_CSp, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) + + if (associated(Hml)) then + call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, Hml(:,:), G, US) + call pass_var(Hml, G%domain, halo=1) + ! If visc%MLD exists, copy ePBL's MLD into it + if (associated(visc%MLD)) visc%MLD(:,:) = Hml(:,:) + elseif (associated(visc%MLD)) then + call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, visc%MLD, G, US) + call pass_var(visc%MLD, G%domain, halo=1) + endif + + ! Augment the diffusivities and viscosity due to those diagnosed in energetic_PBL. + do K=2,nz ; do j=js,je ; do i=is,ie + !### These expressesions assume a Prandtl number of 1. + if (CS%ePBL_is_additive) then + Kd_add_here = Kd_ePBL(i,j,K) + visc%Kv_shear(i,j,K) = visc%Kv_shear(i,j,K) + Kd_ePBL(i,j,K) + else + Kd_add_here = max(Kd_ePBL(i,j,K) - visc%Kd_shear(i,j,K), 0.0) + visc%Kv_shear(i,j,K) = max(visc%Kv_shear(i,j,K), Kd_ePBL(i,j,K)) + endif + + Kd_heat(i,j,K) = Kd_heat(i,j,K) + Kd_add_here + Kd_salt(i,j,K) = Kd_salt(i,j,K) + Kd_add_here + + enddo ; enddo ; enddo + + if (CS%debug) then + call hchksum(ea_t, "after ePBL ea_t",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(eb_t, "after ePBL eb_t",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(ea_s, "after ePBL ea_s",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(eb_s, "after ePBL eb_s",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(Kd_ePBL, "after ePBL Kd_ePBL", G%HI, haloshift=0, scale=US%Z_to_m**2) + endif + + else + call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt, fluxes, CS%optics, & + h, tv, CS%aggregate_FW_forcing, & + CS%evap_CFL_limit, CS%minimum_forcing_depth) + + endif ! endif for CS%use_energetic_PBL + + ! diagnose the tendencies due to boundary forcing + ! At this point, the diagnostic grids have not been updated since the call to the boundary layer scheme + ! so all tendency diagnostics need to be posted on h_diag, and grids rebuilt afterwards + if (CS%boundary_forcing_tendency_diag) then + call diagnose_boundary_forcing_tendency(tv, h, temp_diag, saln_diag, h_diag, dt, G, GV, CS) + if (CS%id_boundary_forcing_h > 0) call post_data(CS%id_boundary_forcing_h, h, CS%diag, alt_h = h_diag) + endif + ! Boundary fluxes may have changed T, S, and h + call diag_update_remap_grids(CS%diag) + call cpu_clock_end(id_clock_remap) + if (CS%debug) then + call MOM_forcing_chksum("after applyBoundaryFluxes ", fluxes, G, US, haloshift=0) + call MOM_thermovar_chksum("after applyBoundaryFluxes ", tv, G) + call MOM_state_chksum("after applyBoundaryFluxes ", u, v, h, G, GV, haloshift=0) + endif + if (showCallTree) call callTree_waypoint("done with applyBoundaryFluxes (diabatic)") + if (CS%debugConservation) call MOM_state_stats('applyBoundaryFluxes', u, v, h, tv%T, tv%S, G) + + if (showCallTree) call callTree_waypoint("done with h=ea-eb (diabatic)") + if (CS%debugConservation) call MOM_state_stats('h=ea-eb', u, v, h, tv%T, tv%S, G) + + ! calculate change in temperature & salinity due to dia-coordinate surface diffusion + if (associated(tv%T)) then + + if (CS%debug) then + call hchksum(ea_t, "before triDiagTS ea_t ",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(eb_t, "before triDiagTS eb_t ",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(ea_s, "before triDiagTS ea_s ",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(eb_s, "before triDiagTS eb_s ",G%HI,haloshift=0, scale=GV%H_to_m) + endif + + call cpu_clock_begin(id_clock_tridiag) + ! Keep salinity from falling below a small but positive threshold. + ! This constraint is needed for SIS1 ice model, which can extract + ! more salt than is present in the ocean. SIS2 does not suffer + ! from this limitation, in which case we can let salinity=0 and still + ! have salt conserved with SIS2 ice. So for SIS2, we can run with + ! BOUND_SALINITY=False in MOM.F90. + if (associated(tv%S) .and. associated(tv%salt_deficit)) & + call adjust_salt(h, tv, G, GV, CS%diabatic_aux_CSp) + + if (CS%diabatic_diff_tendency_diag) then + do k=1,nz ; do j=js,je ; do i=is,ie + temp_diag(i,j,k) = tv%T(i,j,k) + saln_diag(i,j,k) = tv%S(i,j,k) + enddo ; enddo ; enddo + endif + + ! set ea_t=eb_t=Kd_heat and ea_s=eb_s=Kd_salt on interfaces for use in the + ! tri-diagonal solver. + + do j=js,je ; do i=is,ie + ea_t(i,j,1) = 0.; ea_s(i,j,1) = 0. + enddo ; enddo + + !$OMP parallel do default(shared) 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_t(i,j,k) = (GV%Z_to_H**2) * dt * hval * Kd_heat(i,j,k) + eb_t(i,j,k-1) = ea_t(i,j,k) + ea_s(i,j,k) = (GV%Z_to_H**2) * dt * hval * Kd_salt(i,j,k) + eb_s(i,j,k-1) = ea_s(i,j,k) + enddo ; enddo ; enddo + do j=js,je ; do i=is,ie + eb_t(i,j,nz) = 0. ; eb_s(i,j,nz) = 0. + enddo ; enddo + if (showCallTree) call callTree_waypoint("done setting ea_t,ea_s,eb_t,eb_s from Kd_heat" //& + "and Kd_salt (diabatic)") + + ! Initialize halo regions of ea, eb, and hold to default values. + !$OMP parallel do default(shared) + do k=1,nz + do i=is-1,ie+1 + ea_t(i,js-1,k) = 0.0 ; eb_t(i,js-1,k) = 0.0 + ea_s(i,js-1,k) = 0.0 ; eb_s(i,js-1,k) = 0.0 + ea_t(i,je+1,k) = 0.0 ; eb_t(i,je+1,k) = 0.0 + ea_s(i,je+1,k) = 0.0 ; eb_s(i,je+1,k) = 0.0 + enddo + do j=js,je + ea_t(is-1,j,k) = 0.0 ; eb_t(is-1,j,k) = 0.0 + ea_s(is-1,j,k) = 0.0 ; eb_s(is-1,j,k) = 0.0 + ea_t(ie+1,j,k) = 0.0 ; eb_t(ie+1,j,k) = 0.0 + ea_s(ie+1,j,k) = 0.0 ; eb_s(ie+1,j,k) = 0.0 + enddo + enddo + + ! Changes T and S via the tridiagonal solver; no change to h + call tracer_vertdiff(h, ea_t, eb_t, dt, tv%T, G, GV) + call tracer_vertdiff(h, ea_s, eb_s, dt, tv%S, G, GV) + + + ! In ALE-mode, layer thicknesses do not change. Therefore, we can use h below + if (CS%diabatic_diff_tendency_diag) then + call diagnose_diabatic_diff_tendency(tv, h, temp_diag, saln_diag, dt, G, GV, CS) + endif + call cpu_clock_end(id_clock_tridiag) + + if (showCallTree) call callTree_waypoint("done with triDiagTS (diabatic)") + + endif ! endif corresponding to if (associated(tv%T)) + + if (CS%debugConservation) call MOM_state_stats('triDiagTS', u, v, h, tv%T, tv%S, G) + + if (CS%debug) then + call MOM_state_chksum("after mixed layer ", u, v, h, G, GV, haloshift=0) + call MOM_thermovar_chksum("after mixed layer ", tv, G) + endif + + ! Whenever thickness changes let the diag manager know, as the + ! target grids for vertical remapping may need to be regenerated. + 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 + 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 + enddo ; enddo + !$OMP parallel do default(shared) + do K=2,nz ; do j=js,je ; do i=is,ie + Tdif_flx(i,j,K) = (Idt * 0.5*(ea_t(i,j,k) + eb_t(i,j,k-1))) * & + (tv%T(i,j,k-1) - tv%T(i,j,k)) + Tadv_flx(i,j,K) = (Idt * (ea_t(i,j,k) - eb_t(i,j,k-1))) * & + 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 + 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 + enddo ; enddo + !$OMP parallel do default(shared) + do K=2,nz ; do j=js,je ; do i=is,ie + Sdif_flx(i,j,K) = (Idt * 0.5*(ea_s(i,j,k) + eb_s(i,j,k-1))) * & + (tv%S(i,j,k-1) - tv%S(i,j,k)) + Sadv_flx(i,j,K) = (Idt * (ea_s(i,j,k) - eb_s(i,j,k-1))) * & + 0.5*(tv%S(i,j,k-1) + tv%S(i,j,k)) + enddo ; enddo ; enddo + endif + + ! mixing of passive tracers from massless boundary layers to interior + call cpu_clock_begin(id_clock_tracers) + + if (CS%mix_boundary_tracers) then + Tr_ea_BBL = GV%Z_to_H * sqrt(dt*CS%Kd_BBL_tr) + !$OMP parallel do default(shared) private(htot,in_boundary,add_ent) + do j=js,je + do i=is,ie + ebtr(i,j,nz) = eb_s(i,j,nz) + htot(i) = 0.0 + in_boundary(i) = (G%mask2dT(i,j) > 0.0) + enddo + do k=nz,2,-1 ; do i=is,ie + if (in_boundary(i)) then + htot(i) = htot(i) + h(i,j,k) + ! If diapycnal mixing has been suppressed because this is a massless + ! layer near the bottom, add some mixing of tracers between these + ! layers. This flux is based on the harmonic mean of the two + ! thicknesses, as this corresponds pretty closely (to within + ! differences in the density jumps between layers) with what is done + ! in the calculation of the fluxes in the first place. Kd_min_tr + ! should be much less than the values that have been set in Kd_lay, + ! perhaps a molecular diffusivity. + add_ent = ((dt * CS%Kd_min_tr) * GV%Z_to_H**2) * & + ((h(i,j,k-1)+h(i,j,k)+h_neglect) / & + (h(i,j,k-1)*h(i,j,k)+h_neglect2)) - & + 0.5*(ea_s(i,j,k) + eb_s(i,j,k-1)) + if (htot(i) < Tr_ea_BBL) then + add_ent = max(0.0, add_ent, & + (Tr_ea_BBL - htot(i)) - min(ea_s(i,j,k),eb_s(i,j,k-1))) + elseif (add_ent < 0.0) then + add_ent = 0.0 ; in_boundary(i) = .false. + endif + + ebtr(i,j,k-1) = eb_s(i,j,k-1) + add_ent + eatr(i,j,k) = ea_s(i,j,k) + add_ent + else + ebtr(i,j,k-1) = eb_s(i,j,k-1) ; eatr(i,j,k) = ea_s(i,j,k) + endif + + if (associated(visc%Kd_extra_S)) then ; if (visc%Kd_extra_S(i,j,k) > 0.0) then + add_ent = ((dt * visc%Kd_extra_S(i,j,k)) * GV%Z_to_H**2) / & + (0.5 * (h(i,j,k-1) + h(i,j,k)) + & + h_neglect) + ebtr(i,j,k-1) = ebtr(i,j,k-1) + add_ent + eatr(i,j,k) = eatr(i,j,k) + add_ent + endif ; endif + enddo ; enddo + do i=is,ie ; eatr(i,j,1) = ea_s(i,j,1) ; enddo + + enddo - logical :: useKPP = .false. !< use CVMix/KPP diffusivities and non-local transport - logical :: salt_reject_below_ML !< If true, add salt below mixed layer (layer mode only) - logical :: KPPisPassive !< If true, KPP is in passive mode, not changing answers. - logical :: debug !< If true, write verbose checksums for debugging purposes. - logical :: debugConservation !< If true, monitor conservation and extrema. - logical :: tracer_tridiag !< If true, use tracer_vertdiff instead of tridiagTS for - !< vertical diffusion of T and S - 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 - integer :: nsw !< SW_NBANDS + ! For passive tracers, the changes in thickness due to boundary fluxes has yet to be applied + ! so hold should be h_orig + call call_tracer_column_fns(h_prebound, h, ea_s, eb_s, fluxes, Hml, dt, G, GV, tv, & + CS%optics, CS%tracer_flow_CSp, CS%debug, & + evap_CFL_limit = CS%evap_CFL_limit, & + minimum_forcing_depth = CS%minimum_forcing_depth) - integer :: id_cg1 = -1 ! diag handle for mode-1 speed (BDM) - integer, allocatable, dimension(:) :: id_cn ! diag handle for all mode speeds (BDM) - integer :: id_dudt_dia = -1, id_dvdt_dia = -1, id_wd = -1 - integer :: id_ea = -1, id_eb = -1, id_Kd_z = -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 + elseif (associated(visc%Kd_extra_S)) then ! extra diffusivity for passive tracers - ! diagnostic for fields prior to applying diapycnal physics - integer :: id_u_predia = -1, id_v_predia = -1, id_h_predia = -1 - integer :: id_T_predia = -1, id_S_predia = -1, id_e_predia = -1 + do j=js,je ; do i=is,ie + ebtr(i,j,nz) = eb_s(i,j,nz) ; eatr(i,j,1) = ea_s(i,j,1) + enddo ; enddo + !$OMP parallel do default(shared) private(add_ent) + do k=nz,2,-1 ; do j=js,je ; do i=is,ie + if (visc%Kd_extra_S(i,j,k) > 0.0) then + add_ent = ((dt * visc%Kd_extra_S(i,j,k)) * GV%Z_to_H**2) / & + (0.5 * (h(i,j,k-1) + h(i,j,k)) + & + h_neglect) + else + add_ent = 0.0 + endif + ebtr(i,j,k-1) = eb_s(i,j,k-1) + add_ent + eatr(i,j,k) = ea_s(i,j,k) + add_ent + enddo ; enddo ; enddo - integer :: id_diabatic_diff_temp_tend = -1 - integer :: id_diabatic_diff_saln_tend = -1 - integer :: id_diabatic_diff_heat_tend = -1 - integer :: id_diabatic_diff_salt_tend = -1 - integer :: id_diabatic_diff_heat_tend_2d = -1 - integer :: id_diabatic_diff_salt_tend_2d = -1 - integer :: id_diabatic_diff_h= -1 - logical :: diabatic_diff_tendency_diag = .false. + ! For passive tracers, the changes in thickness due to boundary fluxes has yet to be applied + call call_tracer_column_fns(h_prebound, h, eatr, ebtr, fluxes, Hml, dt, G, GV, tv, & + CS%optics, CS%tracer_flow_CSp, CS%debug,& + evap_CFL_limit = CS%evap_CFL_limit, & + minimum_forcing_depth = CS%minimum_forcing_depth) - integer :: id_boundary_forcing_h = -1 - integer :: id_boundary_forcing_h_tendency = -1 - integer :: id_boundary_forcing_temp_tend = -1 - integer :: id_boundary_forcing_saln_tend = -1 - integer :: id_boundary_forcing_heat_tend = -1 - integer :: id_boundary_forcing_salt_tend = -1 - integer :: id_boundary_forcing_heat_tend_2d = -1 - integer :: id_boundary_forcing_salt_tend_2d = -1 - logical :: boundary_forcing_tendency_diag = .false. + else + ! For passive tracers, the changes in thickness due to boundary fluxes has yet to be applied + call call_tracer_column_fns(h_prebound, h, eatr, ebtr, fluxes, Hml, dt, G, GV, tv, & + CS%optics, CS%tracer_flow_CSp, CS%debug, & + evap_CFL_limit = CS%evap_CFL_limit, & + minimum_forcing_depth = CS%minimum_forcing_depth) - integer :: id_frazil_h = -1 - integer :: id_frazil_temp_tend = -1 - integer :: id_frazil_heat_tend = -1 - integer :: id_frazil_heat_tend_2d = -1 - logical :: frazil_tendency_diag = .false. - real, allocatable, dimension(:,:,:) :: frazil_heat_diag !< diagnose 3d heat tendency from frazil - real, allocatable, dimension(:,:,:) :: frazil_temp_diag !< diagnose 3d temp tendency from frazil + endif ! (CS%mix_boundary_tracers) + + call cpu_clock_end(id_clock_tracers) - real :: ppt2mks = 0.001 - - type(diabatic_aux_CS), pointer :: diabatic_aux_CSp => NULL() - type(entrain_diffusive_CS), pointer :: entrain_diffusive_CSp => NULL() - type(bulkmixedlayer_CS), pointer :: bulkmixedlayer_CSp => NULL() - type(energetic_PBL_CS), pointer :: energetic_PBL_CSp => NULL() - type(regularize_layers_CS), pointer :: regularize_layers_CSp => NULL() - type(geothermal_CS), pointer :: geothermal_CSp => NULL() - type(int_tide_CS), pointer :: int_tide_CSp => NULL() - type(int_tide_input_CS), pointer :: int_tide_input_CSp => NULL() - type(int_tide_input_type), pointer :: int_tide_input => NULL() - type(opacity_CS), pointer :: opacity_CSp => NULL() - type(set_diffusivity_CS), pointer :: set_diff_CSp => NULL() - type(sponge_CS), pointer :: sponge_CSp => NULL() - type(ALE_sponge_CS), pointer :: ALE_sponge_CSp => NULL() - type(tracer_flow_control_CS), pointer :: tracer_flow_CSp => NULL() - type(optics_type), pointer :: optics => NULL() - type(diag_to_Z_CS), pointer :: diag_to_Z_CSp => NULL() - type(KPP_CS), pointer :: KPP_CSp => NULL() - type(tidal_mixing_cs), pointer :: tidal_mixing_csp => NULL() - type(CVMix_conv_cs), pointer :: CVMix_conv_csp => NULL() - type(diapyc_energy_req_CS), pointer :: diapyc_en_rec_CSp => NULL() + ! sponges + if (CS%use_sponge) then + call cpu_clock_begin(id_clock_sponge) + if (associated(CS%ALE_sponge_CSp)) then + ! ALE sponge + call apply_ALE_sponge(h, dt, G, GV, US, CS%ALE_sponge_CSp, CS%Time) + endif - type(group_pass_type) :: pass_hold_eb_ea !< For group halo pass - type(group_pass_type) :: pass_Kv !< For group halo pass - type(diag_grid_storage) :: diag_grids_prev!< Stores diagnostic grids at some previous point in the algorithm - ! Data arrays for communicating between components - real, allocatable, dimension(:,:,:) :: KPP_NLTheat !< KPP non-local transport for heat (m/s) - real, allocatable, dimension(:,:,:) :: KPP_NLTscalar !< KPP non-local transport for scalars (m/s) - real, allocatable, dimension(:,:,:) :: KPP_buoy_flux !< KPP forcing buoyancy flux (m^2/s^3) - real, allocatable, dimension(:,:) :: KPP_temp_flux !< KPP effective temperature flux (K m/s) - real, allocatable, dimension(:,:) :: KPP_salt_flux !< KPP effective salt flux (ppt m/s) + call cpu_clock_end(id_clock_sponge) + if (CS%debug) then + call MOM_state_chksum("apply_sponge ", u, v, h, G, GV, haloshift=0) + call MOM_thermovar_chksum("apply_sponge ", tv, G) + endif + endif ! CS%use_sponge - type(time_type), pointer :: Time !< Pointer to model time (needed for sponges) -end type diabatic_CS + call cpu_clock_begin(id_clock_pass) + if (G%symmetric) then ; dir_flag = To_All+Omit_Corners + else ; dir_flag = To_West+To_South+Omit_Corners ; endif + call create_group_pass(CS%pass_hold_eb_ea, eb_t, G%Domain, dir_flag, halo=1) + call create_group_pass(CS%pass_hold_eb_ea, eb_s, G%Domain, dir_flag, halo=1) + call create_group_pass(CS%pass_hold_eb_ea, ea_t, G%Domain, dir_flag, halo=1) + call create_group_pass(CS%pass_hold_eb_ea, ea_s, G%Domain, dir_flag, halo=1) + call do_group_pass(CS%pass_hold_eb_ea, G%Domain) + ! visc%Kv_shear and visc%Kv_slow are not in the group pass because it has larger vertical extent. + if (associated(visc%Kv_shear)) & + call pass_var(visc%Kv_shear, G%Domain, To_All+Omit_Corners, halo=1) + if (associated(visc%Kv_slow)) & + call pass_var(visc%Kv_slow, G%Domain, To_All+Omit_Corners, halo=1) -! clock ids -integer :: id_clock_entrain, id_clock_mixedlayer, id_clock_set_diffusivity -integer :: id_clock_tracers, id_clock_tridiag, id_clock_pass, id_clock_sponge -integer :: id_clock_geothermal, id_clock_differential_diff, id_clock_remap -integer :: id_clock_kpp + call cpu_clock_end(id_clock_pass) -contains + call disable_averaging(CS%diag) + ! Frazil formation keeps temperature above the freezing point. + ! make_frazil is deliberately called at both the beginning and at + ! the end of the diabatic processes. + if (associated(tv%T) .AND. associated(tv%frazil)) then + call enable_averaging(0.5*dt, Time_end, CS%diag) + if (CS%frazil_tendency_diag) then + do k=1,nz ; do j=js,je ; do i=is,ie + temp_diag(i,j,k) = tv%T(i,j,k) + enddo ; enddo ; enddo + endif -!> This subroutine imposes the diapycnal mass fluxes and the -!! accompanying diapycnal advection of momentum and tracers. -subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, GV, CS, WAVES) + if (associated(fluxes%p_surf_full)) then + call make_frazil(h, tv, G, GV, CS%diabatic_aux_CSp, fluxes%p_surf_full) + else + call make_frazil(h, tv, G, GV, CS%diabatic_aux_CSp) + endif + + if (CS%frazil_tendency_diag) then + call diagnose_frazil_tendency(tv, h, temp_diag, 0.5*dt, G, GV, CS) + if (CS%id_frazil_h > 0 ) call post_data(CS%id_frazil_h, h, CS%diag) + endif + + if (showCallTree) call callTree_waypoint("done with 2nd make_frazil (diabatic)") + if (CS%debugConservation) call MOM_state_stats('2nd make_frazil', u, v, h, tv%T, tv%S, G) + call disable_averaging(CS%diag) + + endif ! endif for frazil + + ! Diagnose the diapycnal diffusivities and other related quantities. + call enable_averaging(dt, Time_end, CS%diag) + + if (CS%id_Kd_interface > 0) call post_data(CS%id_Kd_interface, Kd_int, CS%diag) + if (CS%id_Kd_heat > 0) call post_data(CS%id_Kd_heat, Kd_heat, CS%diag) + if (CS%id_Kd_salt > 0) call post_data(CS%id_Kd_salt, Kd_salt, CS%diag) + if (CS%id_Kd_ePBL > 0) call post_data(CS%id_Kd_ePBL, Kd_ePBL, CS%diag) + + if (CS%id_ea_t > 0) call post_data(CS%id_ea_t, ea_t, CS%diag) + if (CS%id_eb_t > 0) call post_data(CS%id_eb_t, eb_t, CS%diag) + if (CS%id_ea_s > 0) call post_data(CS%id_ea_s, ea_s, CS%diag) + if (CS%id_eb_s > 0) call post_data(CS%id_eb_s, eb_s, CS%diag) + + if (CS%id_dudt_dia > 0) call post_data(CS%id_dudt_dia, ADp%du_dt_dia, CS%diag) + if (CS%id_dvdt_dia > 0) call post_data(CS%id_dvdt_dia, ADp%dv_dt_dia, CS%diag) + + 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) + endif + if (CS%id_MLD_0125 > 0) then + call diagnoseMLDbyDensityDifference(CS%id_MLD_0125, h, tv, 0.125, G, GV, US, CS%diag) + endif + if (CS%id_MLD_user > 0) then + call diagnoseMLDbyDensityDifference(CS%id_MLD_user, h, tv, CS%MLDdensityDifference, G, GV, US, CS%diag) + endif + + if (CS%id_Tdif > 0) call post_data(CS%id_Tdif, Tdif_flx, CS%diag) + if (CS%id_Tadv > 0) call post_data(CS%id_Tadv, Tadv_flx, CS%diag) + if (CS%id_Sdif > 0) call post_data(CS%id_Sdif, Sdif_flx, CS%diag) + if (CS%id_Sadv > 0) call post_data(CS%id_Sadv, Sadv_flx, CS%diag) + if (CS%use_int_tides) then + if (CS%id_cg1 > 0) call post_data(CS%id_cg1, cn(:,:,1),CS%diag) + do m=1,CS%nMode + if (CS%id_cn(m) > 0) call post_data(CS%id_cn(m),cn(:,:,m),CS%diag) + enddo + endif + + 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()") + +end subroutine diabatic + +!> Imposes the diapycnal mass fluxes and the accompanying diapycnal advection of momentum and tracers +!! using the original MOM6 algorithms. +subroutine legacy_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & + G, GV, US, CS, WAVES) 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(inout) :: u !< zonal velocity (m/s) - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: v !< meridional velocity (m/s) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< thickness (m for Bouss / kg/m2 for non-Bouss) - type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields; + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: u !< zonal velocity [m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: v !< meridional velocity [m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields !! unused have NULL ptrs real, dimension(:,:), pointer :: Hml !< active mixed layer depth type(forcing), intent(inout) :: fluxes !< points to forcing fields @@ -267,34 +1172,34 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G !! equations, to enable the later derived !! diagnostics, like energy budgets type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations - real, intent(in) :: dt !< time increment (seconds) + real, intent(in) :: dt !< time increment [s] type(time_type), intent(in) :: Time_end !< Time at the end of the interval type(diabatic_CS), pointer :: CS !< module control structure - type(Wave_parameters_CS), pointer, optional :: Waves !< Surface gravity waves + type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & ea, & ! amount of fluid entrained from the layer above within - ! one time step (m for Bouss, kg/m^2 for non-Bouss) + ! one time step [H ~> m or kg m-2] eb, & ! amount of fluid entrained from the layer below within - ! one time step (m for Bouss, kg/m^2 for non-Bouss) - Kd, & ! diapycnal diffusivity of layers (m^2/sec) - h_orig, & ! initial layer thicknesses (m for Bouss, kg/m^2 for non-Bouss) - h_prebound, & ! initial layer thicknesses (m for Bouss, kg/m^2 for non-Bouss) + ! one time step [H ~> m or kg m-2] + Kd_lay, & ! diapycnal diffusivity of layers [Z2 s-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 ! the initial layer thicknesses (if a mixed layer is used), - ! (m for Bouss, kg/m^2 for non-Bouss) - dSV_dT, & ! The partial derivatives of specific volume with temperature - dSV_dS, & ! and salinity in m^3/(kg K) and m^3/(kg ppt). - cTKE, & ! convective TKE requirements for each layer in J/m^2. + ! [H ~> m or kg m-2] + dSV_dT, & ! The partial derivative of specific volume with temperature [m3 kg-1 degC-1] + dSV_dS, & ! The partial derivative of specific volume with salinity [m3 kg-1 ppt-1]. + cTKE, & ! convective TKE requirements for each layer [J m-2]. u_h, & ! zonal and meridional velocities at thickness points after - v_h ! entrainment (m/s) + v_h ! entrainment [m s-1] real, dimension(SZI_(G),SZJ_(G),CS%nMode) :: & cn ! baroclinic gravity wave speeds (formerly cg1 - BDM) real, dimension(SZI_(G),SZJ_(G)) :: & Rcv_ml, & ! coordinate density of mixed layer, used for applying sponges - SkinBuoyFlux! 2d surface buoyancy flux (m2/s3), used by ePBL + SkinBuoyFlux! 2d surface buoyancy flux [m2 s-3], used by ePBL real, dimension(SZI_(G),SZJ_(G),G%ke) :: h_diag ! diagnostic array for thickness real, dimension(SZI_(G),SZJ_(G),G%ke) :: temp_diag ! diagnostic array for temp real, dimension(SZI_(G),SZJ_(G),G%ke) :: saln_diag ! diagnostic array for salinity @@ -307,32 +1212,32 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G ! These are targets so that the space can be shared with eaml & ebml. eatr, & ! The equivalent of ea and eb for tracers, which differ from ea and ebtr ! eb in that they tend to homogenize tracers in massless layers - ! near the boundaries (m for Bouss and kg/m^2 for non-Bouss) + ! 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 (m^2/s) - Kd_heat, & ! diapycnal diffusivity of heat (m^2/s) - Kd_salt, & ! diapycnal diffusivity of salt and passive tracers (m^2/s) - Kd_ePBL, & ! test array of diapycnal diffusivities at interfaces (m^2/s) - eta, & ! Interface heights before diapycnal mixing, in m. - Tdif_flx, & ! diffusive diapycnal heat flux across interfaces (K m/s) - Tadv_flx, & ! advective diapycnal heat flux across interfaces (K m/s) - Sdif_flx, & ! diffusive diapycnal salt flux across interfaces (ppt m/s) - Sadv_flx ! advective diapycnal salt flux across interfaces (ppt m/s) + Kd_int, & ! diapycnal diffusivity of interfaces [Z2 s-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] + eta, & ! Interface heights before diapycnal mixing [m]. + Tdif_flx, & ! diffusive diapycnal heat flux across interfaces [degC m s-1] + Tadv_flx, & ! advective diapycnal heat flux across interfaces [degC m s-1] + Sdif_flx, & ! diffusive diapycnal salt flux across interfaces [ppt m s-1] + Sadv_flx ! advective diapycnal salt flux across interfaces [ppt m s-1] ! The following 5 variables are only used with a bulk mixed layer. real, pointer, dimension(:,:,:) :: & eaml, & ! The equivalent of ea and eb due to mixed layer processes, - ebml ! (m for Bouss and kg/m^2 for non-Bouss). These will be + ebml ! [H ~> m or kg m-2]. These will be ! pointers to eatr and ebtr so as to reuse the memory as ! the arrays are not needed at the same time. integer :: kb(SZI_(G),SZJ_(G)) ! index of the lightest layer denser - ! than the buffer laye (nondimensional) + ! than the buffer layer [nondim] real :: p_ref_cv(SZI_(G)) ! Reference pressure for the potential ! density which defines the coordinate - ! variable, set to P_Ref, in Pa. + ! variable, set to P_Ref [Pa]. logical :: in_boundary(SZI_(G)) ! True if there are no massive layers below, ! where massive is defined as sufficiently thick that @@ -340,39 +1245,38 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G ! the entrainment - usually sqrt(Kd*dt). real :: b_denom_1 ! The first term in the denominator of b1 - ! (m for Bouss, kg/m^2 for non-Bouss) + ! [H ~> m or kg m-2] real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected - ! (m for Bouss and kg/m^2 for non-Bouss) - real :: h_neglect2 ! h_neglect^2 (m^2 for Bouss, kg^2/m^4 for non-Bouss) + ! [H ~> m or kg m-2] + real :: h_neglect2 ! h_neglect^2 [H2 ~> m2 or kg2 m-4] real :: add_ent ! Entrainment that needs to be added when mixing tracers - ! (m for Bouss and kg/m^2 for non-Bouss) - real :: eaval ! eaval is 2*ea at velocity grid points (m for Bouss, kg/m^2 for non-Bouss) - real :: hval ! hval is 2*h at velocity grid points (m for Bouss, kg/m^2 for non-Bouss) + ! [H ~> m or kg m-2] + real :: eaval ! eaval is 2*ea at velocity grid points [H ~> m or kg m-2] + real :: hval ! hval is 2*h at velocity grid points [H ~> m or kg m-2] real :: h_tr ! h_tr is h at tracer points with a tiny thickness - ! added to ensure positive definiteness (m for Bouss, kg/m^2 for non-Bouss) + ! added to ensure positive definiteness [H ~> m or kg m-2] real :: Tr_ea_BBL ! The diffusive tracer thickness in the BBL that is - ! coupled to the bottom within a timestep (m) + ! coupled to the bottom within a timestep [H ~> m or kg m-2] - real :: htot(SZIB_(G)) ! The summed thickness from the bottom, in m. + real :: htot(SZIB_(G)) ! The summed thickness from the bottom [H ~> m or kg m-2]. real :: b1(SZIB_(G)), d1(SZIB_(G)) ! b1, c1, and d1 are variables used by the real :: c1(SZIB_(G),SZK_(G)) ! tridiagonal solver. - real :: Ent_int ! The diffusive entrainment rate at an interface - ! (H units = m for Bouss, kg/m^2 for non-Bouss). - real :: dt_mix ! amount of time over which to apply mixing (seconds) - real :: Idt ! inverse time step (1/s) + real :: Ent_int ! The diffusive entrainment rate at an interface [H ~> m or kg m-2]. + 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 + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb, m, halo integer :: ig, jg ! global indices for testing testing itide point source (BDM) logical :: avg_enabled ! for testing internal tides (BDM) - real :: Kd_add_here ! An added diffusivity in m2/s + real :: Kd_add_here ! An added diffusivity [Z2 s-1 ~> m2 s-1]. is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB @@ -385,8 +1289,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G showCallTree = callTree_showQuery() if (showCallTree) call callTree_enter("diabatic(), MOM_diabatic_driver.F90") - - ! Offer diagnostics of various state varables at the start of diabatic; + ! Offer diagnostics of various state varables at the start of diabatic ! these are mostly for debugging purposes. if (CS%id_u_predia > 0) call post_data(CS%id_u_predia, u, CS%diag) if (CS%id_v_predia > 0) call post_data(CS%id_v_predia, v, CS%diag) @@ -394,15 +1297,18 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G if (CS%id_T_predia > 0) call post_data(CS%id_T_predia, tv%T, CS%diag) if (CS%id_S_predia > 0) call post_data(CS%id_S_predia, tv%S, CS%diag) if (CS%id_e_predia > 0) then - call find_eta(h, tv, GV%g_Earth, G, GV, eta) + call find_eta(h, tv, G, GV, US, eta, eta_to_m=1.0) call post_data(CS%id_e_predia, eta, CS%diag) endif - ! set equivalence between the same bits of memory for these arrays eaml => eatr ; ebml => ebtr ! inverse time step + if (dt == 0.0) call MOM_error(FATAL, "MOM_diabatic_driver: "// & + "legacy_diabatic was called with a zero length timestep.") + if (dt < 0.0) call MOM_error(FATAL, "MOM_diabatic_driver: "// & + "legacy_diabatic was called with a negative timestep.") Idt = 1.0 / dt if (.not. associated(CS)) call MOM_error(FATAL, "MOM_diabatic_driver: "// & @@ -410,16 +1316,15 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G if (CS%debug) then call MOM_state_chksum("Start of diabatic ", u, v, h, G, GV, haloshift=0) - call MOM_forcing_chksum("Start of diabatic", fluxes, G, haloshift=0) + call MOM_forcing_chksum("Start of diabatic", fluxes, G, US, haloshift=0) endif if (CS%debugConservation) call MOM_state_stats('Start of diabatic', u, v, h, tv%T, tv%S, G) if (CS%debug_energy_req) & - call diapyc_energy_req_test(h, dt, tv, G, GV, CS%diapyc_en_rec_CSp) - + call diapyc_energy_req_test(h, dt, tv, G, GV, US, CS%diapyc_en_rec_CSp) call cpu_clock_begin(id_clock_set_diffusivity) - call set_BBL_TKE(u, v, h, fluxes, visc, G, GV, CS%set_diff_CSp) + call set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS%set_diff_CSp) call cpu_clock_end(id_clock_set_diffusivity) ! Frazil formation keeps the temperature above the freezing point. @@ -427,17 +1332,17 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G ! the end of the diabatic processes. if (associated(tv%T) .AND. associated(tv%frazil)) then ! For frazil diagnostic, the first call covers the first half of the time step - call enable_averaging(0.5*dt, Time_end - set_time(int(floor(0.5*dt+0.5))), CS%diag) - if(CS%frazil_tendency_diag) then + call enable_averaging(0.5*dt, Time_end - real_to_time(0.5*dt), CS%diag) + if (CS%frazil_tendency_diag) then do k=1,nz ; do j=js,je ; do i=is,ie temp_diag(i,j,k) = tv%T(i,j,k) enddo ; enddo ; enddo endif if (associated(fluxes%p_surf_full)) then - call make_frazil(h, tv, G, GV, CS%diabatic_aux_CSp, fluxes%p_surf_full) + call make_frazil(h, tv, G, GV, CS%diabatic_aux_CSp, fluxes%p_surf_full, halo=CS%halo_TS_diff) else - call make_frazil(h, tv, G, GV, CS%diabatic_aux_CSp) + call make_frazil(h, tv, G, GV, CS%diabatic_aux_CSp, halo=CS%halo_TS_diff) endif if (showCallTree) call callTree_waypoint("done with 1st make_frazil (diabatic)") @@ -452,15 +1357,16 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G if (CS%debugConservation) call MOM_state_stats('1st make_frazil', u, v, h, tv%T, tv%S, G) if ((CS%ML_mix_first > 0.0) .or. CS%use_geothermal) then -!$OMP parallel do default(none) shared(is,ie,js,je,nz,h_orig,h,eaml,ebml) - do k=1,nz ; do j=js,je ; do i=is,ie + halo = CS%halo_TS_diff + !$OMP parallel do default(shared) + do k=1,nz ; do j=js-halo,je+halo ; do i=is-halo,ie+halo h_orig(i,j,k) = h(i,j,k) ; eaml(i,j,k) = 0.0 ; ebml(i,j,k) = 0.0 enddo ; enddo ; enddo endif if (CS%use_geothermal) then call cpu_clock_begin(id_clock_geothermal) - call geothermal(h, tv, dt, eaml, ebml, G, GV, CS%geothermal_CSp) + call geothermal(h, tv, dt, eaml, ebml, G, GV, CS%geothermal_CSp, halo=CS%halo_TS_diff) call cpu_clock_end(id_clock_geothermal) if (showCallTree) call callTree_waypoint("geothermal (diabatic)") if (CS%debugConservation) call MOM_state_stats('geothermal', u, v, h, tv%T, tv%S, G) @@ -478,7 +1384,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G if (CS%bulkmixedlayer) then if (CS%debug) then - call MOM_forcing_chksum("Before mixedlayer", fluxes, G, haloshift=0) + call MOM_forcing_chksum("Before mixedlayer", fluxes, G, US, haloshift=0) endif if (CS%ML_mix_first > 0.0) then @@ -495,7 +1401,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G if (CS%ML_mix_first < 1.0) then ! Changes: h, tv%T, tv%S, eaml and ebml (G is also inout???) call bulkmixedlayer(h, u_h, v_h, tv, fluxes, dt*CS%ML_mix_first, & - eaml,ebml, G, GV, CS%bulkmixedlayer_CSp, CS%optics, & + eaml,ebml, G, GV, US, CS%bulkmixedlayer_CSp, CS%optics, & Hml, CS%aggregate_FW_forcing, dt, last_call=.false.) if (CS%salt_reject_below_ML) & call insert_brine(h, tv, G, GV, fluxes, nkmb, CS%diabatic_aux_CSp, & @@ -503,8 +1409,8 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G else ! Changes: h, tv%T, tv%S, eaml and ebml (G is also inout???) call bulkmixedlayer(h, u_h, v_h, tv, fluxes, dt, eaml, ebml, & - G, GV, CS%bulkmixedlayer_CSp, CS%optics, & - Hml, CS%aggregate_FW_forcing, dt, last_call=.true.) + G, GV, US, CS%bulkmixedlayer_CSp, CS%optics, & + Hml, CS%aggregate_FW_forcing, dt, last_call=.true.) endif ! Keep salinity from falling below a small but positive threshold. @@ -518,7 +1424,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G call cpu_clock_end(id_clock_mixedlayer) if (CS%debug) then call MOM_state_chksum("After mixedlayer ", u, v, h, G, GV, haloshift=0) - call MOM_forcing_chksum("After mixedlayer", fluxes, G, haloshift=0) + call MOM_forcing_chksum("After mixedlayer", fluxes, G, US, haloshift=0) endif if (showCallTree) call callTree_waypoint("done with 1st bulkmixedlayer (diabatic)") if (CS%debugConservation) call MOM_state_stats('1st bulkmixedlayer', u, v, h, tv%T, tv%S, G) @@ -546,7 +1452,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G ! tide module (BDM). ! PROVIDE ENERGY DISTRIBUTION (calculate time-varying energy source) - call set_int_tide_input(u, v, h, tv, fluxes, CS%int_tide_input, dt, G, GV, & + call set_int_tide_input(u, v, h, tv, fluxes, CS%int_tide_input, dt, G, GV, US, & CS%int_tide_input_CSp) ! CALCULATE MODAL VELOCITIES cn(:,:,:) = 0.0 @@ -554,7 +1460,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G ! SET TO CONSTANT VALUE TO TEST PROPAGATE CODE do m=1,CS%nMode ; cn(:,:,m) = CS%cg_test ; enddo else - call wave_speeds(h, tv, G, GV, CS%nMode, cn, full_halos=.true.) + call wave_speeds(h, tv, G, GV, US, CS%nMode, cn, full_halos=.true.) ! uncomment the lines below for a hard-coded cn that changes linearly with latitude !do j=G%jsd,G%jed ; do i=G%isd,G%ied ! cn(i,j,:) = ((7.-1.)/14000000.)*G%geoLatBu(i,j) + (1.-((7.-1.)/14000000.)*-7000000.) @@ -576,30 +1482,36 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G enddo ; enddo endif ! CALL ROUTINE USING PRESCRIBED KE FOR TESTING - call propagate_int_tide(h, tv, cn, TKE_itidal_input_test, & - CS%int_tide_input%tideamp, CS%int_tide_input%Nb, dt, G, GV, CS%int_tide_CSp) + call propagate_int_tide(h, tv, cn, TKE_itidal_input_test, CS%int_tide_input%tideamp, & + CS%int_tide_input%Nb, dt, G, GV, US, CS%int_tide_CSp) else ! CALL ROUTINE USING CALCULATED KE INPUT - call propagate_int_tide(h, tv, cn, CS%int_tide_input%TKE_itidal_input, & - CS%int_tide_input%tideamp, CS%int_tide_input%Nb, dt, G, GV, CS%int_tide_CSp) + call propagate_int_tide(h, tv, cn, CS%int_tide_input%TKE_itidal_input, CS%int_tide_input%tideamp, & + CS%int_tide_input%Nb, dt, G, GV, US, CS%int_tide_CSp) endif if (showCallTree) call callTree_waypoint("done with propagate_int_tide (diabatic)") endif call cpu_clock_begin(id_clock_set_diffusivity) - ! Sets: Kd, Kd_int, visc%Kd_extra_T, visc%Kd_extra_S + ! Sets: Kd_lay, Kd_int, visc%Kd_extra_T, visc%Kd_extra_S ! Also changes: visc%Kd_shear, visc%TKE_turb (not clear that TKE_turb is used as input ???? ! And sets visc%Kv_shear - call set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, CS%optics, visc, dt, G, GV, CS%set_diff_CSp, Kd, Kd_int) + if ((CS%halo_TS_diff > 0) .and. (CS%ML_mix_first > 0.0)) then + if (associated(tv%T)) call pass_var(tv%T, G%Domain, halo=CS%halo_TS_diff, complete=.false.) + if (associated(tv%T)) call pass_var(tv%S, G%Domain, halo=CS%halo_TS_diff, complete=.false.) + call pass_var(h, G%domain, halo=CS%halo_TS_diff, complete=.true.) + endif + call set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, CS%optics, visc, dt, G, GV, US, & + CS%set_diff_CSp, Kd_lay, Kd_int) call cpu_clock_end(id_clock_set_diffusivity) if (showCallTree) call callTree_waypoint("done with set_diffusivity (diabatic)") if (CS%debug) then call MOM_state_chksum("after set_diffusivity ", u, v, h, G, GV, haloshift=0) - call MOM_forcing_chksum("after set_diffusivity ", fluxes, G, 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, "after set_diffusivity Kd",G%HI,haloshift=0) - call hchksum(Kd_Int, "after set_diffusivity Kd_Int",G%HI,haloshift=0) + 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) endif @@ -610,84 +1522,83 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G ! Sets: CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux ! NOTE: CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux are returned as rates (i.e. stuff per second) ! unlike other instances where the fluxes are integrated in time over a time-step. - call calculateBuoyancyFlux2d(G, GV, fluxes, CS%optics, h, tv%T, tv%S, tv, & + call calculateBuoyancyFlux2d(G, GV, US, fluxes, CS%optics, h, tv%T, tv%S, tv, & CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux) ! The KPP scheme calculates boundary layer diffusivities and non-local transport. - ! MOM6 implementation of KPP matches the boundary layer to zero interior diffusivity, - ! since the matching to nonzero interior diffusivity can be problematic. - ! Changes: Kd_int. Sets: KPP_NLTheat, KPP_NLTscalar -!$OMP parallel default(none) shared(is,ie,js,je,nz,Kd_salt,Kd_int,visc,CS,Kd_heat) -!$OMP do + !$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) = Kd_int(i,j,K) + Kd_heat(i,j,k) = Kd_int(i,j,K) enddo ; enddo ; enddo if (associated(visc%Kd_extra_S)) then -!$OMP do + !$OMP parallel do default(shared) do k=1,nz+1 ; do j=js,je ; do i=is,ie Kd_salt(i,j,k) = Kd_salt(i,j,k) + visc%Kd_extra_S(i,j,k) enddo ; enddo ; enddo endif if (associated(visc%Kd_extra_T)) then -!$OMP do + !$OMP parallel do default(shared) do k=1,nz+1 ; do j=js,je ; do i=is,ie Kd_heat(i,j,k) = Kd_heat(i,j,k) + visc%Kd_extra_T(i,j,k) enddo ; enddo ; enddo endif -!$OMP end parallel - call KPP_calculate(CS%KPP_CSp, G, GV, h, tv%T, tv%S, u, v, tv%eqn_of_state, & - fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, & - CS%KPP_NLTscalar, Waves=Waves) -!$OMP parallel default(none) shared(is,ie,js,je,nz,Kd_salt,Kd_int,visc,CS,G,Kd_heat,Hml) + call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv%eqn_of_state, & + fluxes%ustar, CS%KPP_buoy_flux, Waves=Waves) + + call KPP_calculate(CS%KPP_CSp, G, GV, US, h, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & + Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves) if (associated(Hml)) then call KPP_get_BLD(CS%KPP_CSp, Hml(:,:), G) call pass_var(Hml, G%domain, halo=1) + ! If visc%MLD exists, copy KPP's BLD into it + if (associated(visc%MLD)) visc%MLD(:,:) = Hml(:,:) endif if (.not. CS%KPPisPassive) then -!$OMP do + !$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) = min( Kd_salt(i,j,k), Kd_heat(i,j,k) ) enddo ; enddo ; enddo if (associated(visc%Kd_extra_S)) then -!$OMP do + !$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) - Kd_int(i,j,K)) enddo ; enddo ; enddo endif if (associated(visc%Kd_extra_T)) then -!$OMP do + !$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) - Kd_int(i,j,K)) enddo ; enddo ; enddo endif endif ! not passive -!$OMP end parallel + call cpu_clock_end(id_clock_kpp) if (showCallTree) call callTree_waypoint("done with KPP_calculate (diabatic)") if (CS%debug) then call MOM_state_chksum("after KPP", u, v, h, G, GV, haloshift=0) - call MOM_forcing_chksum("after KPP", fluxes, G, haloshift=0) + call MOM_forcing_chksum("after KPP", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after KPP", tv, G) - call hchksum(Kd, "after KPP Kd",G%HI,haloshift=0) - call hchksum(Kd_Int, "after KPP Kd_Int",G%HI,haloshift=0) + 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) endif endif ! endif for KPP ! Add vertical diff./visc. due to convection (computed via CVMix) if (CS%use_CVMix_conv) then - call calculate_CVMix_conv(h, tv, G, GV, CS%CVMix_conv_csp, Hml) + call calculate_CVMix_conv(h, tv, G, GV, US, CS%CVMix_conv_csp, Hml) - !!!!!!!! GMM, the following needs to be checked !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - 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) - visc%Kv_slow(i,j,k) = visc%Kv_slow(i,j,k) + CS%CVMix_conv_csp%kv_conv(i,j,k) - enddo ; enddo ; enddo - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!!!!!!! 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) + visc%Kv_slow(i,j,k) = visc%Kv_slow(i,j,k) + CS%CVMix_conv_csp%kv_conv(i,j,k) + enddo ; enddo ; enddo + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! endif @@ -710,7 +1621,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G if (CS%debug) then call MOM_state_chksum("after KPP_applyNLT ", u, v, h, G, GV, haloshift=0) - call MOM_forcing_chksum("after KPP_applyNLT ", fluxes, G, haloshift=0) + call MOM_forcing_chksum("after KPP_applyNLT ", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after KPP_applyNLT ", tv, G) endif @@ -718,9 +1629,6 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G ! Differential diffusion done here. ! Changes: tv%T, tv%S - ! If using matching within the KPP scheme, then this step needs to provide - ! a diffusivity and happen before KPP. But generally in MOM, we do not match - ! KPP boundary layer to interior, so this diffusivity can be computed when convenient. if (associated(visc%Kd_extra_T) .and. associated(visc%Kd_extra_S) .and. associated(tv%T)) then call cpu_clock_begin(id_clock_differential_diff) @@ -731,17 +1639,15 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G ! increment heat and salt diffusivity. ! CS%useKPP==.true. already has extra_T and extra_S included - if(.not. CS%useKPP) then + if (.not. CS%useKPP) then do K=2,nz ; do j=js,je ; do i=is,ie Kd_heat(i,j,K) = Kd_heat(i,j,K) + visc%Kd_extra_T(i,j,K) Kd_salt(i,j,K) = Kd_salt(i,j,K) + visc%Kd_extra_S(i,j,K) enddo ; enddo ; enddo endif - endif - ! This block sets ea, eb from Kd or Kd_int. ! If using ALE algorithm, set ea=eb=Kd_int on interfaces for ! use in the tri-diagonal solver. @@ -756,7 +1662,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G !$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%m_to_H**2) * dt * hval * Kd_int(i,j,k) + ea(i,j,k) = (GV%Z_to_H**2) * dt * hval * 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 @@ -770,15 +1676,15 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G call cpu_clock_begin(id_clock_entrain) ! 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, CS%entrain_diffusive_CSp, & - ea, eb, kb, Kd_Lay=Kd, Kd_int=Kd_int) + 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) call cpu_clock_end(id_clock_entrain) if (showCallTree) call callTree_waypoint("done with Entrainment_diffusive (diabatic)") endif ! endif for (CS%useALEalgorithm) if (CS%debug) then - call MOM_forcing_chksum("after calc_entrain ", fluxes, G, haloshift=0) + call MOM_forcing_chksum("after calc_entrain ", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after calc_entrain ", tv, G) call MOM_state_chksum("after calc_entrain ", u, v, h, G, GV, haloshift=0) call hchksum(ea, "after calc_entrain ea", G%HI, haloshift=0, scale=GV%H_to_m) @@ -786,7 +1692,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G endif ! Save fields before boundary forcing is applied for tendency diagnostics - if(CS%boundary_forcing_tendency_diag) then + if (CS%boundary_forcing_tendency_diag) then do k=1,nz ; do j=js,je ; do i=is,ie h_diag(i,j,k) = h(i,j,k) temp_diag(i,j,k) = tv%T(i,j,k) @@ -806,7 +1712,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G if (CS%use_energetic_PBL) then skinbuoyflux(:,:) = 0.0 - call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, dt, fluxes, CS%optics, & + call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt, fluxes, CS%optics, & h, tv, CS%aggregate_FW_forcing, CS%evap_CFL_limit, & CS%minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, SkinBuoyFlux=SkinBuoyFlux) @@ -819,12 +1725,12 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G endif call find_uv_at_h(u, v, h, u_h, v_h, G, GV) - call energetic_PBL(h, u_h, v_h, tv, fluxes, dt, Kd_ePBL, G, GV, & + call energetic_PBL(h, u_h, v_h, tv, fluxes, dt, Kd_ePBL, G, GV, US, & CS%energetic_PBL_CSp, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) ! If visc%MLD exists, copy the ePBL's MLD into it if (associated(visc%MLD)) then - call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, visc%MLD, G) + call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, visc%MLD, G, US) call pass_var(visc%MLD, G%domain, halo=1) Hml(:,:) = visc%MLD(:,:) endif @@ -839,11 +1745,11 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G Kd_add_here = max(Kd_ePBL(i,j,K) - visc%Kd_shear(i,j,K), 0.0) visc%Kv_shear(i,j,K) = max(visc%Kv_shear(i,j,K), Kd_ePBL(i,j,K)) endif - Ent_int = Kd_add_here * (GV%m_to_H**2 * dt) / & + Ent_int = Kd_add_here * (GV%Z_to_H**2 * dt) / & (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) + Kd_add_here ! for diagnostics Kd_heat(i,j,K) = Kd_heat(i,j,K) + Kd_int(i,j,K) @@ -854,11 +1760,11 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G if (CS%debug) then call hchksum(ea, "after ePBL ea",G%HI,haloshift=0, scale=GV%H_to_m) call hchksum(eb, "after ePBL eb",G%HI,haloshift=0, scale=GV%H_to_m) - call hchksum(Kd_ePBL, "after ePBL Kd_ePBL",G%HI,haloshift=0) + call hchksum(Kd_ePBL, "after ePBL Kd_ePBL", G%HI, haloshift=0, scale=US%Z_to_m**2) endif else - call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, dt, fluxes, CS%optics, & + call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt, fluxes, CS%optics, & h, tv, CS%aggregate_FW_forcing, & CS%evap_CFL_limit, CS%minimum_forcing_depth) @@ -867,7 +1773,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G ! diagnose the tendencies due to boundary forcing ! At this point, the diagnostic grids have not been updated since the call to the boundary layer scheme ! so all tendency diagnostics need to be posted on h_diag, and grids rebuilt afterwards - if(CS%boundary_forcing_tendency_diag) then + if (CS%boundary_forcing_tendency_diag) then call diagnose_boundary_forcing_tendency(tv, h, temp_diag, saln_diag, h_diag, dt, G, GV, CS) if (CS%id_boundary_forcing_h > 0) call post_data(CS%id_boundary_forcing_h, h, CS%diag, alt_h = h_diag) endif @@ -876,7 +1782,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G call cpu_clock_end(id_clock_remap) if (CS%debug) then - call MOM_forcing_chksum("after applyBoundaryFluxes ", fluxes, G, haloshift=0) + call MOM_forcing_chksum("after applyBoundaryFluxes ", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after applyBoundaryFluxes ", tv, G) call MOM_state_chksum("after applyBoundaryFluxes ", u, v, h, G, GV, haloshift=0) endif @@ -901,10 +1807,10 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G hold(i,j,nz) = h(i,j,nz) h(i,j,nz) = h(i,j,nz) + (ea(i,j,nz) - eb(i,j,nz-1)) if (h(i,j,1) <= 0.0) then - h(i,j,1) = GV%Angstrom + h(i,j,1) = GV%Angstrom_H endif if (h(i,j,nz) <= 0.0) then - h(i,j,nz) = GV%Angstrom + h(i,j,nz) = GV%Angstrom_H endif enddo do k=2,nz-1 ; do i=is,ie @@ -912,7 +1818,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G h(i,j,k) = h(i,j,k) + ((ea(i,j,k) - eb(i,j,k-1)) + & (eb(i,j,k) - ea(i,j,k+1))) if (h(i,j,k) <= 0.0) then - h(i,j,k) = GV%Angstrom + h(i,j,k) = GV%Angstrom_H endif enddo ; enddo enddo @@ -921,13 +1827,12 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G if (CS%debug) then call MOM_state_chksum("after negative check ", u, v, h, G, GV, haloshift=0) - call MOM_forcing_chksum("after negative check ", fluxes, G, haloshift=0) + call MOM_forcing_chksum("after negative check ", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after negative check ", tv, G) endif if (showCallTree) call callTree_waypoint("done with h=ea-eb (diabatic)") if (CS%debugConservation) call MOM_state_stats('h=ea-eb', u, v, h, tv%T, tv%S, G) - ! Here, T and S are updated according to ea and eb. ! If using the bulk mixed layer, T and S are also updated ! by surface fluxes (in fluxes%*). @@ -1051,8 +1956,8 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G call cpu_clock_begin(id_clock_mixedlayer) ! Changes: h, tv%T, tv%S, ea and eb (G is also inout???) call bulkmixedlayer(h, u_h, v_h, tv, fluxes, dt_mix, ea, eb, & - G, GV, CS%bulkmixedlayer_CSp, CS%optics, & - Hml, CS%aggregate_FW_forcing, dt, last_call=.true.) + G, GV, US, CS%bulkmixedlayer_CSp, CS%optics, & + Hml, CS%aggregate_FW_forcing, dt, last_call=.true.) if (CS%salt_reject_below_ML) & call insert_brine(h, tv, G, GV, fluxes, nkmb, CS%diabatic_aux_CSp, dt_mix, & @@ -1074,7 +1979,6 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G else ! following block for when NOT using BULKMIXEDLAYER - ! calculate change in temperature & salinity due to dia-coordinate surface diffusion if (associated(tv%T)) then @@ -1093,7 +1997,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G if (associated(tv%S) .and. associated(tv%salt_deficit)) & call adjust_salt(h, tv, G, GV, CS%diabatic_aux_CSp) - if(CS%diabatic_diff_tendency_diag) then + if (CS%diabatic_diff_tendency_diag) then do k=1,nz ; do j=js,je ; do i=is,ie temp_diag(i,j,k) = tv%T(i,j,k) saln_diag(i,j,k) = tv%S(i,j,k) @@ -1101,7 +2005,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G endif ! Changes T and S via the tridiagonal solver; no change to h - if(CS%tracer_tridiag) then + if (CS%tracer_tridiag) then call tracer_vertdiff(hold, ea, eb, dt, tv%T, G, GV) call tracer_vertdiff(hold, ea, eb, dt, tv%S, G, GV) else @@ -1112,7 +2016,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G ! Note: hold here refers to the thicknesses from before the dual-entraintment when using ! the bulk mixed layer scheme. Otherwise in ALE-mode, layer thicknesses will have changed ! In either case, tendencies should be posted on hold - if(CS%diabatic_diff_tendency_diag) then + if (CS%diabatic_diff_tendency_diag) then call diagnose_diabatic_diff_tendency(tv, hold, temp_diag, saln_diag, dt, G, GV, CS) if (CS%id_diabatic_diff_h > 0) call post_data(CS%id_diabatic_diff_h, hold, CS%diag, alt_h = hold) endif @@ -1123,10 +2027,8 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G endif ! endif corresponding to if (associated(tv%T)) if (CS%debugConservation) call MOM_state_stats('triDiagTS', u, v, h, tv%T, tv%S, G) - endif ! endif for the BULKMIXEDLAYER block - if (CS%debug) then call MOM_state_chksum("after mixed layer ", u, v, h, G, GV, haloshift=0) call MOM_thermovar_chksum("after mixed layer ", tv, G) @@ -1179,7 +2081,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G ! mixing of passive tracers from massless boundary layers to interior call cpu_clock_begin(id_clock_tracers) if (CS%mix_boundary_tracers) then - Tr_ea_BBL = sqrt(dt*CS%Kd_BBL_tr) + Tr_ea_BBL = sqrt(dt*CS%Kd_BBL_tr) !### I think this needs GV%Z_to_H !$OMP parallel do default(shared) private(htot,in_boundary,add_ent) do j=js,je do i=is,ie @@ -1196,9 +2098,9 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G ! thicknesses, as this corresponds pretty closely (to within ! differences in the density jumps between layers) with what is done ! in the calculation of the fluxes in the first place. Kd_min_tr - ! should be much less than the values that have been set in Kd, + ! should be much less than the values that have been set in Kd_lay, ! perhaps a molecular diffusivity. - add_ent = ((dt * CS%Kd_min_tr) * GV%m_to_H**2) * & + add_ent = ((dt * CS%Kd_min_tr) * GV%Z_to_H**2) * & ((h(i,j,k-1)+h(i,j,k)+h_neglect) / & (h(i,j,k-1)*h(i,j,k)+h_neglect2)) - & 0.5*(ea(i,j,k) + eb(i,j,k-1)) @@ -1215,7 +2117,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G ebtr(i,j,k-1) = eb(i,j,k-1) ; eatr(i,j,k) = ea(i,j,k) endif if (associated(visc%Kd_extra_S)) then ; if (visc%Kd_extra_S(i,j,k) > 0.0) then - add_ent = ((dt * visc%Kd_extra_S(i,j,k)) * GV%m_to_H**2) / & + add_ent = ((dt * visc%Kd_extra_S(i,j,k)) * GV%Z_to_H**2) / & (0.25 * ((h(i,j,k-1) + h(i,j,k)) + (hold(i,j,k-1) + hold(i,j,k))) + & h_neglect) ebtr(i,j,k-1) = ebtr(i,j,k-1) + add_ent @@ -1246,7 +2148,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G !$OMP parallel do default(shared) private(add_ent) do k=nz,2,-1 ; do j=js,je ; do i=is,ie if (visc%Kd_extra_S(i,j,k) > 0.0) then - add_ent = ((dt * visc%Kd_extra_S(i,j,k)) * GV%m_to_H**2) / & + add_ent = ((dt * visc%Kd_extra_S(i,j,k)) * GV%Z_to_H**2) / & (0.25 * ((h(i,j,k-1) + h(i,j,k)) + (hold(i,j,k-1) + hold(i,j,k))) + & h_neglect) else @@ -1281,17 +2183,14 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G endif ! (CS%mix_boundary_tracers) - - call cpu_clock_end(id_clock_tracers) - ! sponges if (CS%use_sponge) then call cpu_clock_begin(id_clock_sponge) if (associated(CS%ALE_sponge_CSp)) then ! ALE sponge - call apply_ALE_sponge(h, dt, G, CS%ALE_sponge_CSp, CS%Time) + call apply_ALE_sponge(h, dt, G, GV, US, CS%ALE_sponge_CSp, CS%Time) else ! Layer mode sponge if (CS%bulkmixedlayer .and. associated(tv%eqn_of_state)) then @@ -1313,7 +2212,6 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G endif endif ! CS%use_sponge - ! Save the diapycnal mass fluxes as a diagnostic field. if (associated(CDp%diapyc_vel)) then !$OMP parallel do default(shared) @@ -1354,12 +2252,12 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G !$OMP parallel do default(shared) do k=1,nz do i=is-1,ie+1 - hold(i,js-1,k) = GV%Angstrom ; ea(i,js-1,k) = 0.0 ; eb(i,js-1,k) = 0.0 - hold(i,je+1,k) = GV%Angstrom ; ea(i,je+1,k) = 0.0 ; eb(i,je+1,k) = 0.0 + hold(i,js-1,k) = GV%Angstrom_H ; ea(i,js-1,k) = 0.0 ; eb(i,js-1,k) = 0.0 + hold(i,je+1,k) = GV%Angstrom_H ; ea(i,je+1,k) = 0.0 ; eb(i,je+1,k) = 0.0 enddo do j=js,je - hold(is-1,j,k) = GV%Angstrom ; ea(is-1,j,k) = 0.0 ; eb(is-1,j,k) = 0.0 - hold(ie+1,j,k) = GV%Angstrom ; ea(ie+1,j,k) = 0.0 ; eb(ie+1,j,k) = 0.0 + hold(is-1,j,k) = GV%Angstrom_H ; ea(is-1,j,k) = 0.0 ; eb(is-1,j,k) = 0.0 + hold(ie+1,j,k) = GV%Angstrom_H ; ea(ie+1,j,k) = 0.0 ; eb(ie+1,j,k) = 0.0 enddo enddo @@ -1459,7 +2357,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G ! the end of the diabatic processes. if (associated(tv%T) .AND. associated(tv%frazil)) then call enable_averaging(0.5*dt, Time_end, CS%diag) - if(CS%frazil_tendency_diag) then + if (CS%frazil_tendency_diag) then do k=1,nz ; do j=js,je ; do i=is,ie temp_diag(i,j,k) = tv%T(i,j,k) enddo ; enddo ; enddo @@ -1498,14 +2396,14 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G if (CS%id_wd > 0) call post_data(CS%id_wd, CDp%diapyc_vel, CS%diag) 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, CS%diag, & + 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) endif if (CS%id_MLD_0125 > 0) then - call diagnoseMLDbyDensityDifference(CS%id_MLD_0125, h, tv, 0.125, G, GV, CS%diag) + call diagnoseMLDbyDensityDifference(CS%id_MLD_0125, h, tv, 0.125, G, GV, US, CS%diag) endif if (CS%id_MLD_user > 0) then - call diagnoseMLDbyDensityDifference(CS%id_MLD_user, h, tv, CS%MLDdensityDifference, G, GV, CS%diag) + call diagnoseMLDbyDensityDifference(CS%id_MLD_user, h, tv, CS%MLDdensityDifference, G, GV, US, CS%diag) endif if (CS%id_Tdif > 0) call post_data(CS%id_Tdif, Tdif_flx, CS%diag) @@ -1549,18 +2447,20 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G if (CS%debugConservation) call MOM_state_stats('leaving diabatic', u, v, h, tv%T, tv%S, G) if (showCallTree) call callTree_leave("diabatic()") -end subroutine diabatic +end subroutine legacy_diabatic !> Returns pointers or values of members within the diabatic_CS type. For extensibility, !! each returned argument is an optional argument subroutine extract_diabatic_member(CS, opacity_CSp, optics_CSp, & evap_CFL_limit, minimum_forcing_depth) - type(diabatic_CS), intent(in ) :: CS + type(diabatic_CS), intent(in ) :: CS !< module control structure ! All output arguments are optional - type(opacity_CS), optional, pointer :: opacity_CSp - type(optics_type), optional, pointer :: optics_CSp - real, optional, intent( out) :: evap_CFL_limit - real, optional, intent( out) :: minimum_forcing_depth + type(opacity_CS), optional, pointer :: opacity_CSp !< A pointer to be set to the opacity control structure + type(optics_type), optional, pointer :: optics_CSp !< A pointer to be set to the optics control structure + real, optional, intent( out) :: evap_CFL_limit ! CS%opacity_CSp @@ -1576,10 +2476,10 @@ subroutine extract_diabatic_member(CS, opacity_CSp, optics_CSp, & subroutine adiabatic(h, tv, fluxes, dt, G, GV, CS) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(inout) :: h !< thickness (m for Bouss or kg/m2 for non-Bouss) + intent(inout) :: h !< thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields type(forcing), intent(inout) :: fluxes !< boundary fluxes - real, intent(in) :: dt !< time step (seconds) + real, intent(in) :: dt !< time step [s] type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(diabatic_CS), pointer :: CS !< module control structure @@ -1600,19 +2500,21 @@ subroutine diagnose_diabatic_diff_tendency(tv, h, temp_old, saln_old, dt, G, GV, type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(thermo_var_ptrs), intent(in) :: tv !< points to updated thermodynamic fields - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< thickness (m or kg/m2) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< thickness [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: temp_old !< temperature prior to diabatic physics - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: saln_old !< salinity prior to diabatic physics (PPT) - real, intent(in) :: dt !< time step (sec) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: saln_old !< salinity prior to diabatic physics [ppt] + real, intent(in) :: dt !< time step [s] type(diabatic_CS), pointer :: CS !< module control structure + ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: work_3d real, dimension(SZI_(G),SZJ_(G)) :: work_2d - real :: Idt + real :: Idt ! The inverse of the timestep [s-1] + real :: ppt2mks = 0.001 ! Conversion factor from g/kg to kg/kg. integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke - Idt = 1/dt + Idt = 0.0 ; if (dt > 0.0) Idt = 1. / dt work_3d(:,:,:) = 0.0 work_2d(:,:) = 0.0 @@ -1621,19 +2523,19 @@ subroutine diagnose_diabatic_diff_tendency(tv, h, temp_old, saln_old, dt, G, GV, do k=1,nz ; do j=js,je ; do i=is,ie work_3d(i,j,k) = (tv%T(i,j,k)-temp_old(i,j,k))*Idt enddo ; enddo ; enddo - if(CS%id_diabatic_diff_temp_tend > 0) then + if (CS%id_diabatic_diff_temp_tend > 0) then call post_data(CS%id_diabatic_diff_temp_tend, work_3d, CS%diag, alt_h = h) endif ! heat tendency - if(CS%id_diabatic_diff_heat_tend > 0 .or. CS%id_diabatic_diff_heat_tend_2d > 0) then + if (CS%id_diabatic_diff_heat_tend > 0 .or. CS%id_diabatic_diff_heat_tend_2d > 0) then do k=1,nz ; do j=js,je ; do i=is,ie work_3d(i,j,k) = h(i,j,k) * GV%H_to_kg_m2 * tv%C_p * work_3d(i,j,k) enddo ; enddo ; enddo - if(CS%id_diabatic_diff_heat_tend > 0) then + if (CS%id_diabatic_diff_heat_tend > 0) then call post_data(CS%id_diabatic_diff_heat_tend, work_3d, CS%diag, alt_h = h) endif - if(CS%id_diabatic_diff_heat_tend_2d > 0) then + if (CS%id_diabatic_diff_heat_tend_2d > 0) then do j=js,je ; do i=is,ie work_2d(i,j) = 0.0 do k=1,nz @@ -1645,7 +2547,7 @@ subroutine diagnose_diabatic_diff_tendency(tv, h, temp_old, saln_old, dt, G, GV, endif ! salinity tendency - if(CS%id_diabatic_diff_saln_tend > 0) then + if (CS%id_diabatic_diff_saln_tend > 0) then do k=1,nz ; do j=js,je ; do i=is,ie work_3d(i,j,k) = (tv%S(i,j,k)-saln_old(i,j,k))*Idt enddo ; enddo ; enddo @@ -1653,14 +2555,14 @@ subroutine diagnose_diabatic_diff_tendency(tv, h, temp_old, saln_old, dt, G, GV, endif ! salt tendency - if(CS%id_diabatic_diff_salt_tend > 0 .or. CS%id_diabatic_diff_salt_tend_2d > 0) then + if (CS%id_diabatic_diff_salt_tend > 0 .or. CS%id_diabatic_diff_salt_tend_2d > 0) then do k=1,nz ; do j=js,je ; do i=is,ie - work_3d(i,j,k) = h(i,j,k) * GV%H_to_kg_m2 * CS%ppt2mks * work_3d(i,j,k) + work_3d(i,j,k) = h(i,j,k) * GV%H_to_kg_m2 * ppt2mks * work_3d(i,j,k) enddo ; enddo ; enddo - if(CS%id_diabatic_diff_salt_tend > 0) then + if (CS%id_diabatic_diff_salt_tend > 0) then call post_data(CS%id_diabatic_diff_salt_tend, work_3d, CS%diag, alt_h = h) endif - if(CS%id_diabatic_diff_salt_tend_2d > 0) then + if (CS%id_diabatic_diff_salt_tend_2d > 0) then do j=js,je ; do i=is,ie work_2d(i,j) = 0.0 do k=1,nz @@ -1680,28 +2582,34 @@ end subroutine diagnose_diabatic_diff_tendency !! in which case we distribute the flux into k > 1 layers. subroutine diagnose_boundary_forcing_tendency(tv, h, temp_old, saln_old, h_old, & dt, G, GV, CS) - type(ocean_grid_type), intent(in) :: G !< ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(thermo_var_ptrs), intent(in) :: tv !< points to updated thermodynamic fields - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< thickness after boundary flux application (m or kg/m2) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: temp_old !< temperature prior to boundary flux application - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: saln_old !< salinity prior to boundary flux application (PPT) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_old !< thickness prior to boundary flux application (m or kg/m2) - real, intent(in) :: dt !< time step (sec) - type(diabatic_CS), pointer :: CS !< module control structure + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(thermo_var_ptrs), intent(in) :: tv !< points to updated thermodynamic fields + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< thickness after boundary flux application [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: temp_old !< temperature prior to boundary flux application [degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: saln_old !< salinity prior to boundary flux application [ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_old !< thickness prior to boundary flux application [H ~> m or kg m-2] + real, intent(in) :: dt !< time step [s] + type(diabatic_CS), pointer :: CS !< module control structure + ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: work_3d real, dimension(SZI_(G),SZJ_(G)) :: work_2d - real :: Idt + real :: Idt ! The inverse of the timestep [s-1] + real :: ppt2mks = 0.001 ! Conversion factor from g/kg to kg/kg. integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke - Idt = 1/dt + Idt = 0.0 ; if (dt > 0.0) Idt = 1. / dt work_3d(:,:,:) = 0.0 work_2d(:,:) = 0.0 ! Thickness tendency - if(CS%id_boundary_forcing_h_tendency > 0) then + if (CS%id_boundary_forcing_h_tendency > 0) then do k=1,nz ; do j=js,je ; do i=is,ie work_3d(i,j,k) = (h(i,j,k) - h_old(i,j,k))*Idt enddo ; enddo ; enddo @@ -1709,7 +2617,7 @@ subroutine diagnose_boundary_forcing_tendency(tv, h, temp_old, saln_old, h_old, endif ! temperature tendency - if(CS%id_boundary_forcing_temp_tend > 0) then + if (CS%id_boundary_forcing_temp_tend > 0) then do k=1,nz ; do j=js,je ; do i=is,ie work_3d(i,j,k) = (tv%T(i,j,k)-temp_old(i,j,k))*Idt enddo ; enddo ; enddo @@ -1717,14 +2625,14 @@ subroutine diagnose_boundary_forcing_tendency(tv, h, temp_old, saln_old, h_old, endif ! heat tendency - if(CS%id_boundary_forcing_heat_tend > 0 .or. CS%id_boundary_forcing_heat_tend_2d > 0) then + if (CS%id_boundary_forcing_heat_tend > 0 .or. CS%id_boundary_forcing_heat_tend_2d > 0) then do k=1,nz ; do j=js,je ; do i=is,ie work_3d(i,j,k) = GV%H_to_kg_m2 * tv%C_p * Idt * (h(i,j,k) * tv%T(i,j,k) - h_old(i,j,k) * temp_old(i,j,k)) enddo ; enddo ; enddo - if(CS%id_boundary_forcing_heat_tend > 0) then + if (CS%id_boundary_forcing_heat_tend > 0) then call post_data(CS%id_boundary_forcing_heat_tend, work_3d, CS%diag, alt_h = h_old) endif - if(CS%id_boundary_forcing_heat_tend_2d > 0) then + if (CS%id_boundary_forcing_heat_tend_2d > 0) then do j=js,je ; do i=is,ie work_2d(i,j) = 0.0 do k=1,nz @@ -1736,7 +2644,7 @@ subroutine diagnose_boundary_forcing_tendency(tv, h, temp_old, saln_old, h_old, endif ! salinity tendency - if(CS%id_boundary_forcing_saln_tend > 0) then + if (CS%id_boundary_forcing_saln_tend > 0) then do k=1,nz ; do j=js,je ; do i=is,ie work_3d(i,j,k) = (tv%S(i,j,k)-saln_old(i,j,k))*Idt enddo ; enddo ; enddo @@ -1744,14 +2652,14 @@ subroutine diagnose_boundary_forcing_tendency(tv, h, temp_old, saln_old, h_old, endif ! salt tendency - if(CS%id_boundary_forcing_salt_tend > 0 .or. CS%id_boundary_forcing_salt_tend_2d > 0) then + if (CS%id_boundary_forcing_salt_tend > 0 .or. CS%id_boundary_forcing_salt_tend_2d > 0) then do k=1,nz ; do j=js,je ; do i=is,ie - work_3d(i,j,k) = GV%H_to_kg_m2 * CS%ppt2mks * Idt * (h(i,j,k) * tv%S(i,j,k) - h_old(i,j,k) * saln_old(i,j,k)) + work_3d(i,j,k) = GV%H_to_kg_m2 * ppt2mks * Idt * (h(i,j,k) * tv%S(i,j,k) - h_old(i,j,k) * saln_old(i,j,k)) enddo ; enddo ; enddo - if(CS%id_boundary_forcing_salt_tend > 0) then + if (CS%id_boundary_forcing_salt_tend > 0) then call post_data(CS%id_boundary_forcing_salt_tend, work_3d, CS%diag, alt_h = h_old) endif - if(CS%id_boundary_forcing_salt_tend_2d > 0) then + if (CS%id_boundary_forcing_salt_tend_2d > 0) then do j=js,je ; do i=is,ie work_2d(i,j) = 0.0 do k=1,nz @@ -1774,16 +2682,16 @@ subroutine diagnose_frazil_tendency(tv, h, temp_old, dt, G, GV, CS) type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(diabatic_CS), pointer :: CS !< module control structure type(thermo_var_ptrs), intent(in) :: tv !< points to updated thermodynamic fields - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< thickness (m or kg/m2) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: temp_old !< temperature prior to frazil formation - real, intent(in) :: dt !< time step (sec) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: temp_old !< temperature prior to frazil formation [degC] + real, intent(in) :: dt !< time step [s] real, dimension(SZI_(G),SZJ_(G)) :: work_2d real :: Idt integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke - Idt = 1/dt + Idt = 0.0 ; if (dt > 0.0) Idt = 1. / dt ! temperature tendency if (CS%id_frazil_temp_tend > 0) then @@ -1802,7 +2710,7 @@ subroutine diagnose_frazil_tendency(tv, h, temp_old, dt, G, GV, CS) ! As a consistency check, we must have ! FRAZIL_HEAT_TENDENCY_2d = HFSIFRAZIL - if(CS%id_frazil_heat_tend_2d > 0) then + if (CS%id_frazil_heat_tend_2d > 0) then do j=js,je ; do i=is,ie work_2d(i,j) = 0.0 do k=1,nz @@ -1821,17 +2729,18 @@ end subroutine diagnose_frazil_tendency !! of the diabatic processes to be used. subroutine adiabatic_driver_init(Time, G, param_file, diag, CS, & tracer_flow_CSp, diag_to_Z_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 - type(diag_ctrl), target, intent(inout) :: diag !< regulates diagnostic output - type(diabatic_CS), pointer :: CS !< module control structure - type(tracer_flow_control_CS), pointer :: tracer_flow_CSp !< points to control structure of tracer flow control module - type(diag_to_Z_CS), pointer :: diag_to_Z_CSp !< pointer to Z-diagnostics control structure + 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 + type(diag_ctrl), target, intent(inout) :: diag !< regulates diagnostic output + 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" - character(len=40) :: mod = "MOM_diabatic_driver" ! This module's name. + character(len=40) :: mdl = "MOM_diabatic_driver" ! This module's name. if (associated(CS)) then call MOM_error(WARNING, "adiabatic_driver_init called with an "// & @@ -1844,19 +2753,20 @@ subroutine adiabatic_driver_init(Time, G, param_file, diag, CS, & 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, mod, version, & + call log_version(param_file, mdl, version, & "The following parameters are used for diabatic processes.") end subroutine adiabatic_driver_init !> This routine initializes the diabatic driver module. -subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, & +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) 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 + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< file to parse for parameter values logical, intent(in) :: useALEalgorithm !< logical for whether to use ALE remapping type(diag_ctrl), target, intent(inout) :: diag !< structure to regulate diagnostic output @@ -1864,7 +2774,8 @@ subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, !! to enable diagnostics, like energy budgets type(cont_diag_ptrs), intent(inout) :: CDp !< pointers to terms in continuity equations type(diabatic_CS), pointer :: CS !< module control structure - type(tracer_flow_control_CS), pointer :: tracer_flow_CSp !< pointer to control structure of tracer flow control module + type(tracer_flow_control_CS), pointer :: tracer_flow_CSp !< pointer to control structure of the + !! 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 @@ -1876,7 +2787,7 @@ subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, ! This "include" declares and sets the variable "version". #include "version_variable.h" - character(len=40) :: mod = "MOM_diabatic_driver" ! This module's name. + character(len=40) :: mdl = "MOM_diabatic_driver" ! This module's name. character(len=48) :: thickness_units character(len=40) :: var_name character(len=160) :: var_descript @@ -1904,80 +2815,92 @@ subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, CS%bulkmixedlayer = (GV%nkml > 0) ! Set default, read and log parameters - call log_version(param_file, mod, version, & + call log_version(param_file, mdl, version, & "The following parameters are used for diabatic processes.") - - call get_param(param_file, mod, "SPONGE", CS%use_sponge, & + 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"//& "set_up_sponge_field.", default=.false.) - call get_param(param_file, mod, "ENABLE_THERMODYNAMICS", use_temperature, & + call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", use_temperature, & "If true, temperature and salinity are used as state \n"//& "variables.", default=.true.) - call get_param(param_file, mod, "ENERGETICS_SFC_PBL", CS%use_energetic_PBL, & + 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"//& "in the surface boundary layer.", default=.false.) - call get_param(param_file, mod, "EPBL_IS_ADDITIVE", CS%ePBL_is_additive, & + 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.) - call get_param(param_file, mod, "DOUBLE_DIFFUSION", differentialDiffusion, & + 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.", & + default=.false., do_not_log=.true.) + CS%use_CVMix_ddiff = CVMix_ddiff_is_used(param_file) + + if (CS%use_CVMix_ddiff .and. differentialDiffusion) then + call MOM_error(FATAL, 'diabatic_driver_init: '// & + 'Multiple double-diffusion options selected (DOUBLE_DIFFUSION and'//& + 'USE_CVMIX_DDIFF), please disable all but one option to proceed.') + endif + CS%use_kappa_shear = kappa_shear_is_used(param_file) CS%use_CVMix_shear = CVMix_shear_is_used(param_file) + if (CS%bulkmixedlayer) then - call get_param(param_file, mod, "ML_MIX_FIRST", CS%ML_mix_first, & + call get_param(param_file, mdl, "ML_MIX_FIRST", CS%ML_mix_first, & "The fraction of the mixed layer mixing that is applied \n"//& "before interior diapycnal mixing. 0 by default.", & units="nondim", default=0.0) - call get_param(param_file, mod, "NKBL", CS%nkbl, default=2, do_not_log=.true.) + call get_param(param_file, mdl, "NKBL", CS%nkbl, default=2, do_not_log=.true.) else CS%ML_mix_first = 0.0 endif if (use_temperature) then - call get_param(param_file, mod, "DO_GEOTHERMAL", CS%use_geothermal, & + call get_param(param_file, mdl, "DO_GEOTHERMAL", CS%use_geothermal, & "If true, apply geothermal heating.", default=.false.) else CS%use_geothermal = .false. endif - call get_param(param_file, mod, "INTERNAL_TIDES", CS%use_int_tides, & + call get_param(param_file, mdl, "INTERNAL_TIDES", CS%use_int_tides, & "If true, use the code that advances a separate set of \n"//& "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, mod, "INTERNAL_TIDE_MODES", CS%nMode, & + call get_param(param_file, mdl, "INTERNAL_TIDE_MODES", CS%nMode, & "The number of distinct internal tide modes \n"//& "that will be calculated.", default=1, do_not_log=.true.) ! The following parameters are used in testing the internal tide code. ! GET LOCATION AND DURATION OF ENERGY POINT SOURCE FOR TESTING (BDM) - call get_param(param_file, mod, "INTERNAL_TIDE_SOURCE_TEST", CS%int_tide_source_test, & + call get_param(param_file, mdl, "INTERNAL_TIDE_SOURCE_TEST", CS%int_tide_source_test, & "If true, apply an arbitrary generation site for internal tide testing", & default=.false.) - if(CS%int_tide_source_test)then - call get_param(param_file, mod, "INTERNAL_TIDE_SOURCE_X", CS%int_tide_source_x, & + if (CS%int_tide_source_test)then + 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, mod, "INTERNAL_TIDE_SOURCE_Y", CS%int_tide_source_y, & + 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.) - call get_param(param_file, mod, "INTERNAL_TIDE_SOURCE_TLEN_DAYS", CS%tlen_days, & + call get_param(param_file, mdl, "INTERNAL_TIDE_SOURCE_TLEN_DAYS", CS%tlen_days, & "Time interval from start of experiment for adding wave source", & units="days", default=0) CS%time_max_source = increment_time(Time,0,days=CS%tlen_days) endif ! GET UNIFORM MODE VELOCITY FOR TESTING (BDM) - call get_param(param_file, mod, "UNIFORM_CG", CS%uniform_cg, & + call get_param(param_file, mdl, "UNIFORM_CG", CS%uniform_cg, & "If true, set cg = cg_test everywhere for test case", default=.false.) - if(CS%uniform_cg)then - call get_param(param_file, mod, "CG_TEST", CS%cg_test, & + if (CS%uniform_cg)then + call get_param(param_file, mdl, "CG_TEST", CS%cg_test, & "Uniform group velocity of internal tide for test case", default=1.) endif endif - call get_param(param_file, mod, "MASSLESS_MATCH_TARGETS", & + 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"//& @@ -1985,7 +2908,7 @@ subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, "diffusively to match massive neighboring layers.", & default=.true.) - call get_param(param_file, mod, "AGGREGATE_FW_FORCING", CS%aggregate_FW_forcing, & + 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"//& @@ -1993,44 +2916,44 @@ subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, "into the first non-vanished layer for which the column remains stable", & default=.true.) - call get_param(param_file, mod, "DEBUG", CS%debug, & + call get_param(param_file, mdl, "DEBUG", CS%debug, & "If true, write out verbose debugging data.", & default=.false., debuggingParam=.true.) - call get_param(param_file, mod, "DEBUG_CONSERVATION", CS%debugConservation, & + call get_param(param_file, mdl, "DEBUG_CONSERVATION", CS%debugConservation, & "If true, monitor conservation and extrema.", & default=.false., debuggingParam=.true.) - call get_param(param_file, mod, "DEBUG_ENERGY_REQ", CS%debug_energy_req, & + 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, mod, "MIX_BOUNDARY_TRACERS", CS%mix_boundary_tracers, & + 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"//& "KD_MIN_TR were operating.", default=.true.) if (CS%mix_boundary_tracers) then - call get_param(param_file, mod, "KD", Kd, fail_if_missing=.true.) - call get_param(param_file, mod, "KD_MIN_TR", CS%Kd_min_tr, & + 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"//& - "The default is 0.1*KD.", units="m2 s-1", default=0.1*Kd) - call get_param(param_file, mod, "KD_BBL_TR", CS%Kd_BBL_tr, & + "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"//& - "over the same distance.", units="m2 s-1", default=0.) + "over the same distance.", units="m2 s-1", default=0., scale=US%m_to_Z**2) endif - call get_param(param_file, mod, "TRACER_TRIDIAG", CS%tracer_tridiag, & + call get_param(param_file, mdl, "TRACER_TRIDIAG", CS%tracer_tridiag, & "If true, use the passive tracer tridiagonal solver for T and S\n", & default=.false.) - call get_param(param_file, mod, "MINIMUM_FORCING_DEPTH", CS%minimum_forcing_depth, & + 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"//& "scaled down by distributing the forcing over this depth scale.", & units="m", default=0.001) - call get_param(param_file, mod, "EVAP_CFL_LIMIT", CS%evap_CFL_limit, & + 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"//& "mass loss is passed down through the column.", & @@ -2041,16 +2964,28 @@ subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, if (GV%Boussinesq) then ; thickness_units = "m" else ; thickness_units = "kg m-2" ; endif + CS%id_ea_t = register_diag_field('ocean_model','ea_t',diag%axesTL,Time, & + 'Layer (heat) entrainment from above per timestep','m') + CS%id_eb_t = register_diag_field('ocean_model','eb_t',diag%axesTL,Time, & + 'Layer (heat) entrainment from below per timestep', 'm') + CS%id_ea_s = register_diag_field('ocean_model','ea_s',diag%axesTL,Time, & + 'Layer (salt) entrainment from above per timestep','m') + CS%id_eb_s = register_diag_field('ocean_model','eb_s',diag%axesTL,Time, & + 'Layer (salt) entrainment from below per timestep', 'm') + ! used by layer diabatic CS%id_ea = register_diag_field('ocean_model','ea',diag%axesTL,Time, & 'Layer entrainment from above per timestep','m') CS%id_eb = register_diag_field('ocean_model','eb',diag%axesTL,Time, & 'Layer entrainment from below per timestep', 'm') + CS%id_wd = register_diag_field('ocean_model','wd',diag%axesTi,Time, & + 'Diapycnal velocity', 'm s-1') + if (CS%id_wd > 0) call safe_alloc_ptr(CDp%diapyc_vel,isd,ied,jsd,jed,nz+1) + CS%id_dudt_dia = register_diag_field('ocean_model','dudt_dia',diag%axesCuL,Time, & 'Zonal Acceleration from Diapycnal Mixing', 'm s-2') CS%id_dvdt_dia = register_diag_field('ocean_model','dvdt_dia',diag%axesCvL,Time, & 'Meridional Acceleration from Diapycnal Mixing', 'm s-2') - CS%id_wd = register_diag_field('ocean_model','wd',diag%axesTi,Time, & - 'Diapycnal Velocity', 'm s-1') + if (CS%use_int_tides) then CS%id_cg1 = register_diag_field('ocean_model','cn1', diag%axesT1, & Time, 'First baroclinic mode (eigen) speed', 'm s-1') @@ -2076,20 +3011,21 @@ subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, 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', cmor_field_name='mlotst', & - cmor_long_name='Ocean Mixed Layer Thickness Defined by Sigma T', & + 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') + 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') + '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') - call get_param(param_file, mod, "DIAG_MLD_DENSITY_DIFF", CS%MLDdensityDifference, & + 'Mixed layer depth (used defined)', 'm', conversion=US%Z_to_m) + 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"//& @@ -2105,22 +3041,21 @@ subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, 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",& + "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",& + "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",& + "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 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) - if (CS%id_wd > 0) call safe_alloc_ptr(CDp%diapyc_vel,isd,ied,jsd,jed,nz+1) ! diagnostics for values prior to diabatic and prior to ALE CS%id_u_predia = register_diag_field('ocean_model', 'u_predia', diag%axesCuL, Time, & @@ -2141,26 +3076,26 @@ subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, !call set_diffusivity_init(Time, G, param_file, diag, CS%set_diff_CSp, diag_to_Z_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') + 'Total diapycnal diffusivity at interfaces', 'm2 s-1', conversion=US%Z_to_m**2) 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') + 'ePBL diapycnal diffusivity at interfaces', 'm2 s-1', conversion=US%Z_to_m**2) endif CS%id_Kd_heat = register_diag_field('ocean_model', 'Kd_heat', diag%axesTi, Time, & - 'Total diapycnal diffusivity for heat at interfaces', 'm2 s-1', & + 'Total diapycnal diffusivity for heat at interfaces', 'm2 s-1', conversion=US%Z_to_m**2, & cmor_field_name='difvho', & cmor_standard_name='ocean_vertical_heat_diffusivity', & cmor_long_name='Ocean vertical heat diffusivity') CS%id_Kd_salt = register_diag_field('ocean_model', 'Kd_salt', diag%axesTi, Time, & - 'Total diapycnal diffusivity for salt at interfaces', 'm2 s-1', & + 'Total diapycnal diffusivity for salt at interfaces', 'm2 s-1', conversion=US%Z_to_m**2, & cmor_field_name='difvso', & cmor_standard_name='ocean_vertical_salt_diffusivity', & cmor_long_name='Ocean vertical salt diffusivity') ! CS%useKPP is set to True if KPP-scheme is to be used, False otherwise. ! KPP_init() allocated CS%KPP_Csp and also sets CS%KPPisPassive - CS%useKPP = KPP_init(param_file, G, diag, Time, CS%KPP_CSp, passive=CS%KPPisPassive) + CS%useKPP = KPP_init(param_file, G, GV, US, diag, Time, CS%KPP_CSp, passive=CS%KPPisPassive) if (CS%useKPP) then allocate( CS%KPP_NLTheat(isd:ied,jsd:jed,nz+1) ) ; CS%KPP_NLTheat(:,:,:) = 0. allocate( CS%KPP_NLTscalar(isd:ied,jsd:jed,nz+1) ) ; CS%KPP_NLTscalar(:,:,:) = 0. @@ -2171,7 +3106,13 @@ subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, allocate( CS%KPP_salt_flux(isd:ied,jsd:jed) ) ; CS%KPP_salt_flux(:,:) = 0. endif - call get_param(param_file, mod, "SALT_REJECT_BELOW_ML", CS%salt_reject_below_ML, & + if (CS%useKPP .and. differentialDiffusion) then + call MOM_error(FATAL, 'diabatic_driver_init: '// & + 'DOUBLE_DIFFUSION (old method) does not work with KPP. Please'//& + 'set DOUBLE_DIFFUSION=False and USE_CVMIX_DDIFF=True.') + 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"// & "into the first non-vanished layer for which the column remains stable", & default=.false.) @@ -2182,7 +3123,7 @@ subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, endif - ! diagnostics for tendencies of temp and saln due to diabatic processes; + ! diagnostics for tendencies of temp and saln due to diabatic processes ! available only for ALE algorithm. ! diagnostics for tendencies of temp and heat due to frazil CS%id_diabatic_diff_h = register_diag_field('ocean_model', 'diabatic_diff_h', diag%axesTL, Time, & @@ -2202,59 +3143,59 @@ subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, CS%diabatic_diff_tendency_diag = .true. endif - CS%id_diabatic_diff_heat_tend = register_diag_field('ocean_model', & - 'diabatic_heat_tendency', diag%axesTL, Time, & - 'Diabatic diffusion heat tendency', & - 'W m-2',cmor_field_name='opottempdiff', & - cmor_standard_name= & - 'tendency_of_sea_water_potential_temperature_expressed_as_heat_content_due_to_parameterized_dianeutral_mixing',& - cmor_long_name = & - 'Tendency of sea water potential temperature expressed as heat content due to parameterized dianeutral mixing',& + CS%id_diabatic_diff_heat_tend = register_diag_field('ocean_model', & + 'diabatic_heat_tendency', diag%axesTL, Time, & + 'Diabatic diffusion heat tendency', & + 'W m-2',cmor_field_name='opottempdiff', & + cmor_standard_name='tendency_of_sea_water_potential_temperature_expressed_as_heat_content_'// & + 'due_to_parameterized_dianeutral_mixing', & + cmor_long_name='Tendency of sea water potential temperature expressed as heat content '// & + 'due to parameterized dianeutral mixing',& v_extensive=.true.) if (CS%id_diabatic_diff_heat_tend > 0) then CS%diabatic_diff_tendency_diag = .true. endif - CS%id_diabatic_diff_salt_tend = register_diag_field('ocean_model', & - 'diabatic_salt_tendency', diag%axesTL, Time, & - 'Diabatic diffusion of salt tendency', & - 'kg m-2 s-1',cmor_field_name='osaltdiff', & - cmor_standard_name= & - 'tendency_of_sea_water_salinity_expressed_as_salt_content_due_to_parameterized_dianeutral_mixing', & - cmor_long_name = & - 'Tendency of sea water salinity expressed as salt content due to parameterized dianeutral mixing', & + CS%id_diabatic_diff_salt_tend = register_diag_field('ocean_model', & + 'diabatic_salt_tendency', diag%axesTL, Time, & + 'Diabatic diffusion of salt tendency', & + 'kg m-2 s-1',cmor_field_name='osaltdiff', & + cmor_standard_name='tendency_of_sea_water_salinity_expressed_as_salt_content_'// & + 'due_to_parameterized_dianeutral_mixing', & + cmor_long_name='Tendency of sea water salinity expressed as salt content '// & + 'due to parameterized dianeutral mixing', & v_extensive=.true.) if (CS%id_diabatic_diff_salt_tend > 0) then CS%diabatic_diff_tendency_diag = .true. endif ! This diagnostic should equal to roundoff if all is working well. - CS%id_diabatic_diff_heat_tend_2d = register_diag_field('ocean_model', & - 'diabatic_heat_tendency_2d', diag%axesT1, Time, & - 'Depth integrated diabatic diffusion heat tendency', & - 'W m-2',cmor_field_name='opottempdiff_2d', & - cmor_standard_name= & - 'tendency_of_sea_water_potential_temperature_expressed_as_heat_content_due_to_parameterized_dianeutral_mixing_depth_integrated',& - cmor_long_name = & - 'Tendency of sea water potential temperature expressed as heat content due to parameterized dianeutral mixing depth integrated') + CS%id_diabatic_diff_heat_tend_2d = register_diag_field('ocean_model', & + 'diabatic_heat_tendency_2d', diag%axesT1, Time, & + 'Depth integrated diabatic diffusion heat tendency', & + 'W m-2',cmor_field_name='opottempdiff_2d', & + cmor_standard_name='tendency_of_sea_water_potential_temperature_expressed_as_heat_content_'//& + 'due_to_parameterized_dianeutral_mixing_depth_integrated', & + cmor_long_name='Tendency of sea water potential temperature expressed as heat content '//& + 'due to parameterized dianeutral mixing depth integrated') if (CS%id_diabatic_diff_heat_tend_2d > 0) then CS%diabatic_diff_tendency_diag = .true. endif ! This diagnostic should equal to roundoff if all is working well. - CS%id_diabatic_diff_salt_tend_2d = register_diag_field('ocean_model', & - 'diabatic_salt_tendency_2d', diag%axesT1, Time, & - 'Depth integrated diabatic diffusion salt tendency', & - 'kg m-2 s-1',cmor_field_name='osaltdiff_2d', & - cmor_standard_name= & - 'tendency_of_sea_water_salinity_expressed_as_salt_content_due_to_parameterized_dianeutral_mixing_depth_integrated',& - cmor_long_name = & - 'Tendency of sea water salinity expressed as salt content due to parameterized dianeutral mixing depth integrated') + CS%id_diabatic_diff_salt_tend_2d = register_diag_field('ocean_model', & + 'diabatic_salt_tendency_2d', diag%axesT1, Time, & + 'Depth integrated diabatic diffusion salt tendency', & + 'kg m-2 s-1',cmor_field_name='osaltdiff_2d', & + cmor_standard_name='tendency_of_sea_water_salinity_expressed_as_salt_content_'// & + 'due_to_parameterized_dianeutral_mixing_depth_integrated', & + cmor_long_name='Tendency of sea water salinity expressed as salt content '// & + 'due to parameterized dianeutral mixing depth integrated') if (CS%id_diabatic_diff_salt_tend_2d > 0) then CS%diabatic_diff_tendency_diag = .true. endif - ! diagnostics for tendencies of thickness temp and saln due to boundary forcing; + ! diagnostics for tendencies of thickness temp and saln due to boundary forcing ! available only for ALE algorithm. ! diagnostics for tendencies of temp and heat due to frazil CS%id_boundary_forcing_h = register_diag_field('ocean_model', 'boundary_forcing_h', diag%axesTL, Time, & @@ -2348,13 +3289,14 @@ subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, 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, param_file, diag, diag_to_Z_CSp, CS%tidal_mixing_CSp) + CS%use_tidal_mixing = tidal_mixing_init(Time, G, GV, US, param_file, diag, diag_to_Z_CSp, & + CS%tidal_mixing_CSp) ! CS%use_CVMix_conv is set to True if CVMix convection will be used, otherwise ! False. - CS%use_CVMix_conv = CVMix_conv_init(Time, G, GV, param_file, diag, CS%CVMix_conv_csp) + CS%use_CVMix_conv = CVMix_conv_init(Time, G, GV, US, param_file, diag, CS%CVMix_conv_csp) - call entrain_diffusive_init(Time, G, GV, param_file, diag, CS%entrain_diffusive_CSp) + call entrain_diffusive_init(Time, G, GV, US, param_file, diag, CS%entrain_diffusive_CSp) ! initialize the geothermal heating module if (CS%use_geothermal) & @@ -2362,13 +3304,14 @@ subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, ! initialize module for internal tide induced mixing if (CS%use_int_tides) then - call int_tide_input_init(Time, G, GV, param_file, diag, CS%int_tide_input_CSp, & + call int_tide_input_init(Time, G, GV, US, param_file, diag, CS%int_tide_input_CSp, & CS%int_tide_input) - call internal_tides_init(Time, G, GV, param_file, diag, CS%int_tide_CSp) + call internal_tides_init(Time, G, GV, US, param_file, diag, CS%int_tide_CSp) endif ! initialize module for setting diffusivities - call set_diffusivity_init(Time, G, GV, param_file, diag, CS%set_diff_CSp, diag_to_Z_CSp, CS%int_tide_CSp, CS%tidal_mixing_CSp) + call set_diffusivity_init(Time, G, GV, US, param_file, diag, CS%set_diff_CSp, diag_to_Z_CSp, & + CS%int_tide_CSp, CS%tidal_mixing_CSp, CS%halo_TS_diff) ! set up the clocks for this module @@ -2389,23 +3332,23 @@ subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, id_clock_differential_diff = cpu_clock_id('(Ocean differential diffusion)', grain=CLOCK_ROUTINE) ! initialize the auxiliary diabatic driver module - call diabatic_aux_init(Time, G, GV, param_file, diag, CS%diabatic_aux_CSp, & + call diabatic_aux_init(Time, G, GV, US, param_file, diag, CS%diabatic_aux_CSp, & CS%useALEalgorithm, CS%use_energetic_PBL) ! initialize the boundary layer modules if (CS%bulkmixedlayer) & - call bulkmixedlayer_init(Time, G, GV, param_file, diag, CS%bulkmixedlayer_CSp) + call bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS%bulkmixedlayer_CSp) if (CS%use_energetic_PBL) & - call energetic_PBL_init(Time, G, GV, param_file, diag, CS%energetic_PBL_CSp) + call energetic_PBL_init(Time, G, GV, US, param_file, diag, CS%energetic_PBL_CSp) - call regularize_layers_init(Time, G, param_file, diag, CS%regularize_layers_CSp) + call regularize_layers_init(Time, G, GV, param_file, diag, CS%regularize_layers_CSp) if (CS%debug_energy_req) & - call diapyc_energy_req_init(Time, G, param_file, diag, CS%diapyc_en_rec_CSp) + call diapyc_energy_req_init(Time, G, GV, US, param_file, diag, CS%diapyc_en_rec_CSp) ! obtain information about the number of bands for penetrative shortwave if (use_temperature) then - call get_param(param_file, mod, "PEN_SW_NBANDS", nbands, default=1) + call get_param(param_file, mdl, "PEN_SW_NBANDS", nbands, default=1) if (nbands > 0) then allocate(CS%optics) call opacity_init(Time, G, param_file, diag, CS%tracer_flow_CSp, CS%opacity_CSp, CS%optics) @@ -2462,8 +3405,7 @@ subroutine diabatic_driver_end(CS) !call diag_grid_storage_end(CS%diag_grids_prev) - if (associated(CS)) deallocate(CS) - + deallocate(CS) end subroutine diabatic_driver_end diff --git a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 index 7054a90ca4..53e4b29178 100644 --- a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 +++ b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 @@ -1,19 +1,15 @@ +!> Calculates the energy requirements of mixing. module MOM_diapyc_energy_req ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Robert Hallberg, May 2015 * -!* * -!* This module calculates the energy requirements of mixing. * -!* * -!********+*********+*********+*********+*********+*********+*********+** +!! \author By Robert Hallberg, May 2015 -use MOM_diag_mediator, only : diag_ctrl, Time_type, post_data_1d_k, register_diag_field +use MOM_diag_mediator, only : diag_ctrl, Time_type, post_data, register_diag_field 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 +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use MOM_EOS, only : calculate_specific_vol_derivs, calculate_density @@ -22,57 +18,57 @@ module MOM_diapyc_energy_req public diapyc_energy_req_init, diapyc_energy_req_calc, diapyc_energy_req_test, diapyc_energy_req_end +! 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. + +!> This control structure holds parameters for the MOM_diapyc_energy_req module type, public :: diapyc_energy_req_CS ; private - logical :: initialized = .false. ! A variable that is here because empty - ! structures are not permitted by some compilers. - real :: test_Kh_scaling ! A scaling factor for the diapycnal diffusivity. - real :: ColHt_scaling ! A scaling factor for the column height change - ! correction term. - logical :: use_test_Kh_profile ! If true, use the internal test diffusivity - ! profile in place of any that might be passed - ! in as an argument. - type(diag_ctrl), pointer :: diag ! Structure used to regulate timing of diagnostic output + logical :: initialized = .false. !< A variable that is here because empty + !! structures are not permitted by some compilers. + real :: test_Kh_scaling !< A scaling factor for the diapycnal diffusivity. + real :: ColHt_scaling !< A scaling factor for the column height change correction term. + logical :: use_test_Kh_profile !< If true, use the internal test diffusivity profile in place of + !! any that might be passed in as an argument. + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + + !>@{ Diagnostic IDs integer :: id_ERt=-1, id_ERb=-1, id_ERc=-1, id_ERh=-1, id_Kddt=-1, id_Kd=-1 integer :: id_CHCt=-1, id_CHCb=-1, id_CHCc=-1, id_CHCh=-1 integer :: id_T0=-1, id_Tf=-1, id_S0=-1, id_Sf=-1, id_N2_0=-1, id_N2_f=-1 integer :: id_h=-1, id_zInt=-1 + !!@} end type diapyc_energy_req_CS contains -! #@# This subroutine needs a doxygen description -subroutine diapyc_energy_req_test(h_3d, dt, tv, G, GV, CS, Kd_int) +!> This subroutine helps test the accuracy of the diapycnal mixing energy requirement code +!! by writing diagnostics, possibly using an intensely mixing test profile of diffusivity +subroutine diapyc_energy_req_test(h_3d, dt, tv, G, GV, US, CS, Kd_int) 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 real, dimension(G%isd:G%ied,G%jsd:G%jed,GV%ke), & - intent(in) :: h_3d !< Layer thickness before entrainment, - !! in m or kg m-2. + intent(in) :: h_3d !< Layer thickness before entrainment [H ~> m or kg m-2]. type(thermo_var_ptrs), intent(inout) :: tv !< A structure containing pointers to any !! available thermodynamic fields. !! Absent fields have NULL ptrs. - real, intent(in) :: dt !< The amount of time covered by this call, - !! in s. + real, intent(in) :: dt !< The amount of time covered by this call [s]. type(diapyc_energy_req_CS), pointer :: CS !< This module's control structure. real, dimension(G%isd:G%ied,G%jsd:G%jed,GV%ke+1), & - optional, intent(in) :: Kd_int !< Interface diffusivities. - -! Arguments: h_3d - Layer thickness before entrainment, in m or kg m-2. -! (in) tv - A structure containing pointers to any available -! thermodynamic fields. Absent fields have NULL ptrs. -! (in) dt - The amount of time covered by this call, in s. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - This module's control structure -! (in,opt) Kd_int - Interface diffusivities. + optional, intent(in) :: Kd_int !< Interface diffusivities [Z2 s-1 ~> m2 s-1]. + ! Local variables real, dimension(GV%ke) :: & - T0, S0, & ! T0 & S0 are columns of initial temperatures and salinities, in degC and g/kg. - h_col ! h_col is a column of thicknesses h at tracer points, in H (m or kg m-2). + T0, S0, & ! T0 & S0 are columns of initial temperatures and salinities [degC] and g/kg. + h_col ! h_col is a column of thicknesses h at tracer points [H ~> m or kg m-2]. real, dimension(GV%ke+1) :: & - Kd, & ! A column of diapycnal diffusivities at interfaces, in m2 s-1. - h_top, h_bot ! Distances from the top or bottom, in H. + Kd, & ! A column of diapycnal diffusivities at interfaces [Z2 s-1 ~> m2 s-1]. + h_top, h_bot ! Distances from the top or bottom [H ~> m or kg m-2]. real :: ustar, absf, htot - real :: energy_Kd ! The energy used by diapycnal mixing in W m-2. + real :: energy_Kd ! The energy used by diapycnal mixing [W m-2]. real :: tmp1 ! A temporary array. integer :: i, j, k, is, ie, js, je, nz, itt logical :: may_print @@ -98,18 +94,18 @@ subroutine diapyc_energy_req_test(h_3d, dt, tv, G, GV, CS, Kd_int) h_bot(K) = h_bot(K+1) + h_col(k) enddo - ustar = 0.01 ! Change this to being an input parameter? + ustar = 0.01*US%m_to_Z ! Change this to being an input parameter? absf = 0.25*((abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J))) + & (abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J)))) Kd(1) = 0.0 ; Kd(nz+1) = 0.0 do K=2,nz - tmp1 = h_top(K) * h_bot(K) * GV%H_to_m - Kd(K) = CS%test_Kh_scaling * & + tmp1 = h_top(K) * h_bot(K) * GV%H_to_Z + Kd(K) = CS%test_Kh_scaling * & ustar * 0.41 * (tmp1*ustar) / (absf*tmp1 + htot*ustar) enddo endif may_print = is_root_PE() .and. (i==ie) .and. (j==je) - call diapyc_energy_req_calc(h_col, T0, S0, Kd, energy_Kd, dt, tv, G, GV, & + call diapyc_energy_req_calc(h_col, T0, S0, Kd, energy_Kd, dt, tv, G, GV, US, & may_print=may_print, CS=CS) endif ; enddo ; enddo @@ -122,40 +118,26 @@ end subroutine diapyc_energy_req_test !! The various estimates are taken because they will later be used as templates !! for other bits of code subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & - G, GV, may_print, CS) + G, GV, US, may_print, 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. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(GV%ke), intent(in) :: h_in !< Layer thickness before entrainment, - !! in m or kg m-2. - real, dimension(GV%ke), intent(in) :: T_in !< The layer temperatures, in degC. - real, dimension(GV%ke), intent(in) :: S_in !< The layer salinities, in g kg-1. - real, dimension(GV%ke+1), intent(in) :: Kd !< The interfaces diapycnal diffusivities, - !! in m2 s-1. - real, intent(in) :: dt !< The amount of time covered by this call, - !! in s. + !! [H ~> m or kg m-2]. + real, dimension(GV%ke), intent(in) :: T_in !< The layer temperatures [degC]. + real, dimension(GV%ke), intent(in) :: S_in !< The layer salinities [ppt]. + real, dimension(GV%ke+1), intent(in) :: Kd !< The interfaces diapycnal diffusivities + !! [Z2 s-1 ~> m2 s-1]. + real, intent(in) :: dt !< The amount of time covered by this call [s]. real, intent(out) :: energy_Kd !< The column-integrated rate of energy - !! consumption by diapycnal diffusion, in W m-2. + !! consumption by diapycnal diffusion [W m-2]. type(thermo_var_ptrs), intent(inout) :: tv !< A structure containing pointers to any !! available thermodynamic fields. !! Absent fields have NULL ptrs. logical, optional, intent(in) :: may_print !< If present and true, write out diagnostics !! of energy use. type(diapyc_energy_req_CS), & - optional, pointer :: CS !< This module's control structure. - -! Arguments: h_in - Layer thickness before entrainment, in m or kg m-2. -! (in) T_in - The layer temperatures, in degC. -! (in) S_in - The layer salinities, in g kg-1. -! (in) Kd - The interfaces diapycnal diffusivities, in m2 s-1. -! (in/out) tv - A structure containing pointers to any available -! thermodynamic fields. Absent fields have NULL ptrs. -! (in) dt - The amount of time covered by this call, in s. -! (out) energy_Kd - The column-integrated rate of energy consumption -! by diapycnal diffusion, in W m-2. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in,opt) may_print - If present and true, write out diagnostics of energy use. -! (in,opt) CS - This module's control structure + optional, pointer :: CS !< This module's control structure. ! This subroutine uses a substantially refactored tridiagonal equation for ! diapycnal mixing of temperature and salinity to estimate the potential energy @@ -165,91 +147,100 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & ! for other bits of code. real, dimension(GV%ke) :: & - p_lay, & ! Average pressure of a layer, in Pa. - dSV_dT, & ! Partial derivative of specific volume with temperature, in m3 kg-1 K-1. - dSV_dS, & ! Partial derivative of specific volume with salinity, in m3 kg-1 / (g kg-1). - T0, S0, & ! Initial temperatures and salinities. - Te, Se, & ! Running incomplete estimates of the new temperatures and salinities. - Te_a, Se_a, & ! Running incomplete estimates of the new temperatures and salinities. - Te_b, Se_b, & ! Running incomplete estimates of the new temperatures and salinities. - Tf, Sf, & ! New final values of the temperatures and salinities. - dTe, dSe, & ! Running (1-way) estimates of temperature and salinity change. - dTe_a, dSe_a, & ! Running (1-way) estimates of temperature and salinity change. - dTe_b, dSe_b, & ! Running (1-way) estimates of temperature and salinity change. - Th_a, & ! An effective temperature times a thickness in the layer above, - ! including implicit mixing effects with other yet higher layers, in K H. - Sh_a, & ! An effective salinity times a thickness in the layer above, - ! including implicit mixing effects with other yet higher layers, in K H. - Th_b, & ! An effective temperature times a thickness in the layer below, - ! including implicit mixing effects with other yet lower layers, in K H. - Sh_b, & ! An effective salinity times a thickness in the layer below, - ! including implicit mixing effects with other yet lower layers, in K H. + p_lay, & ! Average pressure of a layer [Pa]. + dSV_dT, & ! Partial derivative of specific volume with temperature [m3 kg-1 degC-1]. + dSV_dS, & ! Partial derivative of specific volume with salinity [m3 kg-1 ppt-1]. + T0, S0, & ! Initial temperatures and salinities [degC] and [ppt]. + Te, Se, & ! Running incomplete estimates of the new temperatures and salinities [degC] and [ppt]. + Te_a, Se_a, & ! Running incomplete estimates of the new temperatures and salinities [degC] and [ppt]. + Te_b, Se_b, & ! Running incomplete estimates of the new temperatures and salinities [degC] and [ppt]. + Tf, Sf, & ! New final values of the temperatures and salinities [degC] and [ppt]. + dTe, dSe, & ! Running (1-way) estimates of temperature and salinity change [degC] and [ppt]. + dTe_a, dSe_a, & ! Running (1-way) estimates of temperature and salinity change [degC] and [ppt]. + dTe_b, dSe_b, & ! Running (1-way) estimates of temperature and salinity change [degC] and [ppt]. + Th_a, & ! An effective temperature times a thickness in the layer above, including implicit + ! mixing effects with other yet higher layers [degC H ~> degC m or degC kg m-2]. + Sh_a, & ! An effective salinity times a thickness in the layer above, including implicit + ! mixing effects with other yet higher layers [ppt H ~> ppt m or ppt kg m-2]. + Th_b, & ! An effective temperature times a thickness in the layer below, including implicit + ! mixing effects with other yet lower layers [degC H ~> degC m or degC kg m-2]. + Sh_b, & ! An effective salinity times a thickness in the layer below, including implicit + ! mixing effects with other yet lower layers [ppt H ~> ppt m or ppt kg m-2]. dT_to_dPE, & ! Partial derivative of column potential energy with the temperature - dS_to_dPE, & ! and salinity changes within a layer, in J m-2 K-1 and J m-2 / (g kg-1). + dS_to_dPE, & ! and salinity changes within a layer [J m-2 degC-1] and [J m-2 ppt-1]. dT_to_dColHt, & ! Partial derivatives of the total column height with the temperature - dS_to_dColHt, & ! and salinity changes within a layer, in m K-1 and m ppt-1. + dS_to_dColHt, & ! and salinity changes within a layer [Z degC-1 ~> m degC-1] and [Z ppt-1 ~> m ppt-1]. dT_to_dColHt_a, & ! Partial derivatives of the total column height with the temperature dS_to_dColHt_a, & ! and salinity changes within a layer, including the implicit effects - ! of mixing with layers higher in the water colun, in m K-1 and m ppt-1. + ! of mixing with layers higher in the water colun [Z degC-1 ~> m degC-1] and [Z ppt-1 ~> m ppt-1]. dT_to_dColHt_b, & ! Partial derivatives of the total column height with the temperature dS_to_dColHt_b, & ! and salinity changes within a layer, including the implicit effects - ! of mixing with layers lower in the water colun, in m K-1 and m ppt-1. + ! of mixing with layers lower in the water colun [Z degC-1 ~> m degC-1] and [Z ppt-1 ~> m ppt-1]. dT_to_dPE_a, & ! Partial derivatives of column potential energy with the temperature dS_to_dPE_a, & ! and salinity changes within a layer, including the implicit effects ! of mixing with layers higher in the water column, in - ! units of J m-2 K-1 and J m-2 ppt-1. + ! units of [J m-2 degC-1] and [J m-2 ppt-1]. dT_to_dPE_b, & ! Partial derivatives of column potential energy with the temperature dS_to_dPE_b, & ! and salinity changes within a layer, including the implicit effects ! of mixing with layers lower in the water column, in - ! units of J m-2 K-1 and J m-2 ppt-1. + ! units of [J m-2 degC-1] and [J m-2 ppt-1]. hp_a, & ! An effective pivot thickness of the layer including the effects - ! of coupling with layers above, in H. This is the first term + ! of coupling with layers above [H ~> m or kg m-2]. This is the first term ! in the denominator of b1 in a downward-oriented tridiagonal solver. hp_b, & ! An effective pivot thickness of the layer including the effects - ! of coupling with layers below, in H. This is the first term + ! of coupling with layers below [H ~> m or kg m-2]. This is the first term ! in the denominator of b1 in an upward-oriented tridiagonal solver. - c1_a, & ! c1_a is used by a downward-oriented tridiagonal solver, ND. - c1_b, & ! c1_b is used by an upward-oriented tridiagonal solver, ND. + c1_a, & ! c1_a is used by a downward-oriented tridiagonal solver [nondim]. + c1_b, & ! c1_b is used by an upward-oriented tridiagonal solver [nondim]. h_tr ! h_tr is h at tracer points with a h_neglect added to - ! ensure positive definiteness, in m or kg m-2. + ! ensure positive definiteness [H ~> m or kg m-2]. real, dimension(GV%ke+1) :: & - pres, & ! Interface pressures in Pa. - z_Int, & ! Interface heights relative to the surface, in m. - N2, & ! An estimate of the buoyancy frequency in s-2. - Kddt_h_a, & ! - Kddt_h_b, & ! + pres, & ! Interface pressures [Pa]. + pres_Z, & ! Interface pressures with a rescaling factor to convert interface height + ! movements into changes in column potential energy [J m-2 Z-1 ~> J m-3]. + z_Int, & ! Interface heights relative to the surface [H ~> m or kg m-2]. + N2, & ! An estimate of the buoyancy frequency [s-2]. Kddt_h, & ! The diapycnal diffusivity times a timestep divided by the - ! average thicknesses around a layer, in m or kg m-2. + ! average thicknesses around a layer [H ~> m or kg m-2]. + Kddt_h_a, & ! The value of Kddt_h for layers above the central point in the + ! tridiagonal solver [H ~> m or kg m-2]. + Kddt_h_b, & ! The value of Kddt_h for layers below the central point in the + ! tridiagonal solver [H ~> m or kg m-2]. Kd_so_far ! The value of Kddt_h that has been applied already in - ! calculating the energy changes, in m or kg m-2. + ! calculating the energy changes [H ~> m or kg m-2]. real, dimension(GV%ke+1,4) :: & PE_chg_k, & ! The integrated potential energy change within a timestep due ! to the diffusivity at interface K for 4 different orders of - ! accumulating the diffusivities, in J m-2. + ! accumulating the diffusivities [J m-2]. ColHt_cor_k ! The correction to the potential energy change due to - ! changes in the net column height, in J m-2. + ! changes in the net column height [J m-2]. real :: & - b1 ! b1 is used by the tridiagonal solver, in m-1 or m2 kg-1. + b1 ! b1 is used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. real :: & - I_b1 ! The inverse of b1, in m or kg m-2. - real :: Kd0, dKd + I_b1 ! The inverse of b1 [H ~> m or kg m-2]. + real :: Kd0 ! The value of Kddt_h that has already been applied [H ~> m or kg m-2]. + real :: dKd ! The change in the value of Kddt_h [H ~> m or kg m-2]. real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected, in m. - real :: dTe_term, dSe_term - real :: Kddt_h_guess - real :: dMass ! The mass per unit area within a layer, in kg m-2. - real :: dPres ! The hydrostatic pressure change across a layer, in Pa. + ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: dTe_term ! A diffusivity-independent term related to the temperature + ! change in the layer below the interface [degC H ~> degC m or degC kg m-2]. + real :: dSe_term ! A diffusivity-independent term related to the salinity + ! change in the layer below the interface [ppt H ~> ppt m or ppt kg m-2]. + real :: Kddt_h_guess ! A guess of the final value of Kddt_h [H ~> m or kg m-2]. + real :: dMass ! The mass per unit area within a layer [kg m-2]. + real :: dPres ! The hydrostatic pressure change across a layer [Pa]. real :: dMKE_max ! The maximum amount of mean kinetic energy that could be ! converted to turbulent kinetic energy if the velocity in ! the layer below an interface were homogenized with all of - ! the water above the interface, in J m-2 = kg s-2. - real :: rho_here ! The in-situ density, in kg m-3. - real :: PE_change, ColHt_cor - real :: htot - real :: dT_k, dT_km1, dS_k, dS_km1 ! Temporary arrays - real :: b1Kd ! Temporary arrays - real :: Kd_rat, Kdr_denom, I_Kdr_denom ! Temporary arrays - real :: dTe_t2, dSe_t2, dT_km1_t2, dS_km1_t2, dT_k_t2, dS_k_t2 + ! the water above the interface [J m-2 = kg s-2]. + real :: rho_here ! The in-situ density [kg m-3]. + real :: PE_change ! The change in column potential energy from applying Kddt_h at the + ! present interface [J m-2]. + real :: ColHt_cor ! The correction to PE_chg that is made due to a net + ! change in the column height [J m-2]. + real :: htot ! A running sum of thicknesses [H ~> m or kg m-2]. + real :: dTe_t2, dT_km1_t2, dT_k_t2 ! Temporary arrays describing temperature changes [degC]. + real :: dSe_t2, dS_km1_t2, dS_k_t2 ! Temporary arrays describing salinity changes [ppt]. logical :: do_print ! The following are a bunch of diagnostic arrays for debugging purposes. @@ -266,15 +257,12 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & real :: PE_chg(6) real, dimension(6) :: dT_k_itt, dS_k_itt, dT_km1_itt, dS_km1_itt - real :: I_G_Earth - real :: dKd_rat_dKd, ddT_k_dKd, ddS_k_dKd, ddT_km1_dKd, ddS_km1_dKd integer :: k, nz, itt, max_itt, k_cent logical :: surface_BL, bottom_BL, central, halves, debug logical :: old_PE_calc nz = G%ke h_neglect = GV%H_subroundoff - I_G_Earth = 1.0 / GV%g_Earth debug = .true. surface_BL = .true. ; bottom_BL = .true. ; halves = .true. @@ -282,17 +270,20 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & do_print = .false. ; if (present(may_print) .and. present(CS)) do_print = may_print - dPEa_dKd(:) = 0.0 ; dPEa_dKd_est(:) = 0.0 ; dPEa_dKd_err(:) = 0.0 ; dPEa_dKd_err_norm(:) = 0.0 ; dPEa_dKd_trunc(:) = 0.0 - dPEb_dKd(:) = 0.0 ; dPEb_dKd_est(:) = 0.0 ; dPEb_dKd_err(:) = 0.0 ; dPEb_dKd_err_norm(:) = 0.0 ; dPEb_dKd_trunc(:) = 0.0 + dPEa_dKd(:) = 0.0 ; dPEa_dKd_est(:) = 0.0 ; dPEa_dKd_err(:) = 0.0 + dPEa_dKd_err_norm(:) = 0.0 ; dPEa_dKd_trunc(:) = 0.0 + dPEb_dKd(:) = 0.0 ; dPEb_dKd_est(:) = 0.0 ; dPEb_dKd_err(:) = 0.0 + dPEb_dKd_err_norm(:) = 0.0 ; dPEb_dKd_trunc(:) = 0.0 - htot = 0.0 ; pres(1) = 0.0 ; Z_int(1) = 0.0 + htot = 0.0 ; pres(1) = 0.0 ; pres_Z(1) = 0.0 ; Z_int(1) = 0.0 do k=1,nz T0(k) = T_in(k) ; S0(k) = S_in(k) h_tr(k) = h_in(k) htot = htot + h_tr(k) - pres(K+1) = pres(K) + GV%g_Earth * GV%H_to_kg_m2 * h_tr(k) + pres(K+1) = pres(K) + GV%H_to_Pa * h_tr(k) + pres_Z(K+1) = US%Z_to_m * pres(K+1) p_lay(k) = 0.5*(pres(K) + pres(K+1)) - Z_int(K+1) = Z_int(K) - GV%H_to_m * h_tr(k) + Z_int(K+1) = Z_int(K) - h_tr(k) enddo do k=1,nz h_tr(k) = max(h_tr(k), 1e-15*htot) @@ -302,7 +293,7 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & Kddt_h(1) = 0.0 ; Kddt_h(nz+1) = 0.0 do K=2,nz - Kddt_h(K) = min((GV%m_to_H**2*dt)*Kd(k) / (0.5*(h_tr(k-1) + h_tr(k))),1e3*htot) + Kddt_h(K) = min((GV%Z_to_H**2*dt)*Kd(k) / (0.5*(h_tr(k-1) + h_tr(k))), 1e3*htot) enddo ! Solve the tridiagonal equations for new temperatures. @@ -311,11 +302,11 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & do k=1,nz dMass = GV%H_to_kg_m2 * h_tr(k) - dPres = GV%g_Earth * dMass + dPres = GV%H_to_Pa * h_tr(k) dT_to_dPE(k) = (dMass * (pres(K) + 0.5*dPres)) * dSV_dT(k) dS_to_dPE(k) = (dMass * (pres(K) + 0.5*dPres)) * dSV_dS(k) - dT_to_dColHt(k) = dMass * dSV_dT(k) * CS%ColHt_scaling - dS_to_dColHt(k) = dMass * dSV_dS(k) * CS%ColHt_scaling + dT_to_dColHt(k) = dMass * US%m_to_Z * dSV_dT(k) * CS%ColHt_scaling + dS_to_dColHt(k) = dMass * US%m_to_Z * dSV_dS(k) * CS%ColHt_scaling enddo ! PE_chg_k(1) = 0.0 ; PE_chg_k(nz+1) = 0.0 @@ -373,14 +364,14 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & call find_PE_chg_orig(Kddt_h_guess, h_tr(k), hp_a(k-1), & dTe_term, dSe_term, dT_km1_t2, dS_km1_t2, & dT_to_dPE(k), dS_to_dPE(k), dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), & - pres(K), dT_to_dColHt(k), dS_to_dColHt(k), & + pres_Z(K), dT_to_dColHt(k), dS_to_dColHt(k), & dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & PE_chg_k(k,1), dPEa_dKd(k)) else call find_PE_chg(0.0, Kddt_h_guess, hp_a(k-1), hp_b(k), & Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & - pres(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & dT_to_dColHt_b(k), dS_to_dColHt_b(k), & PE_chg=PE_chg_k(K,1), dPEc_dKd=dPEa_dKd(K), & ColHt_cor=ColHt_cor_k(K,1)) @@ -394,14 +385,14 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & call find_PE_chg_orig(Kddt_h_guess, h_tr(k), hp_a(k-1), & dTe_term, dSe_term, dT_km1_t2, dS_km1_t2, & dT_to_dPE(k), dS_to_dPE(k), dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), & - pres(K), dT_to_dColHt(k), dS_to_dColHt(k), & + pres_Z(K), dT_to_dColHt(k), dS_to_dColHt(k), & dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & PE_chg=PE_chg(itt)) else call find_PE_chg(0.0, Kddt_h_guess, hp_a(k-1), hp_b(k), & Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & - pres(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & dT_to_dColHt_b(k), dS_to_dColHt_b(k), & PE_chg=PE_chg(itt)) endif @@ -518,14 +509,14 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & call find_PE_chg_orig(Kddt_h_guess, h_tr(k-1), hp_b(k), & dTe_term, dSe_term, dT_k_t2, dS_k_t2, & dT_to_dPE(k-1), dS_to_dPE(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & - pres(K), dT_to_dColHt(k-1), dS_to_dColHt(k-1), & + pres_Z(K), dT_to_dColHt(k-1), dS_to_dColHt(k-1), & dT_to_dColHt_b(k), dS_to_dColHt_b(k), & PE_chg=PE_chg_k(K,2), dPEc_dKd=dPEb_dKd(K)) else call find_PE_chg(0.0, Kddt_h_guess, hp_a(k-1), hp_b(k), & Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & - pres(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & dT_to_dColHt_b(k), dS_to_dColHt_b(k), & PE_chg=PE_chg_k(K,2), dPEc_dKd=dPEb_dKd(K), & ColHt_cor=ColHt_cor_k(K,2)) @@ -540,14 +531,14 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & call find_PE_chg_orig(Kddt_h_guess, h_tr(k-1), hp_b(k), & dTe_term, dSe_term, dT_k_t2, dS_k_t2, & dT_to_dPE(k-1), dS_to_dPE(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & - pres(K), dT_to_dColHt(k-1), dS_to_dColHt(k-1), & + pres_Z(K), dT_to_dColHt(k-1), dS_to_dColHt(k-1), & dT_to_dColHt_b(k), dS_to_dColHt_b(k), & PE_chg=PE_chg(itt)) else call find_PE_chg(0.0, Kddt_h_guess, hp_a(k-1), hp_b(k), & Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & - pres(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & dT_to_dColHt_b(k), dS_to_dColHt_b(k), & PE_chg=PE_chg(itt)) endif @@ -639,15 +630,13 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & endif Th_b(k) = h_tr(k) * T0(k) ; Sh_b(k) = h_tr(k) * S0(k) - Kddt_h_a(K) = 0.0 - if (K < K_cent) Kddt_h_a(K) = Kddt_h(K) - + Kddt_h_a(K) = 0.0 ; if (K < K_cent) Kddt_h_a(K) = Kddt_h(K) dKd = Kddt_h_a(K) call find_PE_chg(Kd0, dKd, hp_a(k-1), hp_b(k), & Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & - pres(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & dT_to_dColHt_b(k), dS_to_dColHt_b(k), & PE_chg=PE_change, ColHt_cor=ColHt_cor) PE_chg_k(K,3) = PE_change @@ -694,7 +683,7 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & call find_PE_chg(Kd0, dKd, hp_a(k-1), hp_b(k), & Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & - pres(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & dT_to_dColHt_b(k), dS_to_dColHt_b(k), & PE_chg=PE_change, ColHt_cor=ColHt_cor) PE_chg_k(K,3) = PE_chg_k(K,3) + PE_change @@ -741,7 +730,7 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & call find_PE_chg(Kd0, dKd, hp_a(k-1), hp_b(k), & Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & - pres(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & dT_to_dColHt_b(k), dS_to_dColHt_b(k), & PE_chg=PE_change, ColHt_cor=ColHt_cor) PE_chg_k(K,3) = PE_chg_k(K,3) + PE_change @@ -826,7 +815,7 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & call find_PE_chg(Kd0, dKd, hp_a(k-1), hp_b(k), & Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & - pres(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & dT_to_dColHt_b(k), dS_to_dColHt_b(k), & PE_chg=PE_change, ColHt_cor=ColHt_cor) @@ -874,7 +863,7 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & call find_PE_chg(Kd0, dKd, hp_a(k-1), hp_b(k), & Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & - pres(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & dT_to_dColHt_b(k), dS_to_dColHt_b(k), & PE_chg=PE_change, ColHt_cor=ColHt_cor) @@ -931,43 +920,43 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & K=nz if (do_print) then - if (CS%id_ERt>0) call post_data_1d_k(CS%id_ERt, PE_chg_k(:,1), CS%diag) - if (CS%id_ERb>0) call post_data_1d_k(CS%id_ERb, PE_chg_k(:,2), CS%diag) - if (CS%id_ERc>0) call post_data_1d_k(CS%id_ERc, PE_chg_k(:,3), CS%diag) - if (CS%id_ERh>0) call post_data_1d_k(CS%id_ERh, PE_chg_k(:,4), CS%diag) - if (CS%id_Kddt>0) call post_data_1d_k(CS%id_Kddt, GV%H_to_m*Kddt_h, CS%diag) - if (CS%id_Kd>0) call post_data_1d_k(CS%id_Kd, Kd, CS%diag) - if (CS%id_h>0) call post_data_1d_k(CS%id_h, GV%H_to_m*h_tr, CS%diag) - if (CS%id_zInt>0) call post_data_1d_k(CS%id_zInt, Z_int, CS%diag) - if (CS%id_CHCt>0) call post_data_1d_k(CS%id_CHCt, ColHt_cor_k(:,1), CS%diag) - if (CS%id_CHCb>0) call post_data_1d_k(CS%id_CHCb, ColHt_cor_k(:,2), CS%diag) - if (CS%id_CHCc>0) call post_data_1d_k(CS%id_CHCc, ColHt_cor_k(:,3), CS%diag) - if (CS%id_CHCh>0) call post_data_1d_k(CS%id_CHCh, ColHt_cor_k(:,4), CS%diag) - if (CS%id_T0>0) call post_data_1d_k(CS%id_T0, T0, CS%diag) - if (CS%id_Tf>0) call post_data_1d_k(CS%id_Tf, Tf, CS%diag) - if (CS%id_S0>0) call post_data_1d_k(CS%id_S0, S0, CS%diag) - if (CS%id_Sf>0) call post_data_1d_k(CS%id_Sf, Sf, CS%diag) + if (CS%id_ERt>0) call post_data(CS%id_ERt, PE_chg_k(:,1), CS%diag) + if (CS%id_ERb>0) call post_data(CS%id_ERb, PE_chg_k(:,2), CS%diag) + if (CS%id_ERc>0) call post_data(CS%id_ERc, PE_chg_k(:,3), CS%diag) + if (CS%id_ERh>0) call post_data(CS%id_ERh, PE_chg_k(:,4), CS%diag) + if (CS%id_Kddt>0) call post_data(CS%id_Kddt, Kddt_h, CS%diag) + if (CS%id_Kd>0) call post_data(CS%id_Kd, Kd, CS%diag) + if (CS%id_h>0) call post_data(CS%id_h, h_tr, CS%diag) + if (CS%id_zInt>0) call post_data(CS%id_zInt, Z_int, CS%diag) + if (CS%id_CHCt>0) call post_data(CS%id_CHCt, ColHt_cor_k(:,1), CS%diag) + if (CS%id_CHCb>0) call post_data(CS%id_CHCb, ColHt_cor_k(:,2), CS%diag) + if (CS%id_CHCc>0) call post_data(CS%id_CHCc, ColHt_cor_k(:,3), CS%diag) + if (CS%id_CHCh>0) call post_data(CS%id_CHCh, ColHt_cor_k(:,4), CS%diag) + if (CS%id_T0>0) call post_data(CS%id_T0, T0, CS%diag) + if (CS%id_Tf>0) call post_data(CS%id_Tf, Tf, CS%diag) + if (CS%id_S0>0) call post_data(CS%id_S0, S0, CS%diag) + if (CS%id_Sf>0) call post_data(CS%id_Sf, Sf, CS%diag) if (CS%id_N2_0>0) then N2(1) = 0.0 ; N2(nz+1) = 0.0 do K=2,nz call calculate_density(0.5*(T0(k-1) + T0(k)), 0.5*(S0(k-1) + S0(k)), & pres(K), rho_here, tv%eqn_of_state) - N2(K) = (GV%g_Earth * rho_here / (0.5*GV%H_to_m*(h_tr(k-1) + h_tr(k)))) * & + N2(K) = ((GV%g_Earth*US%m_to_Z**2) * rho_here / (0.5*GV%H_to_Z*(h_tr(k-1) + h_tr(k)))) * & ( 0.5*(dSV_dT(k-1) + dSV_dT(k)) * (T0(k-1) - T0(k)) + & 0.5*(dSV_dS(k-1) + dSV_dS(k)) * (S0(k-1) - S0(k)) ) enddo - call post_data_1d_k(CS%id_N2_0, N2, CS%diag) + call post_data(CS%id_N2_0, N2, CS%diag) endif if (CS%id_N2_f>0) then N2(1) = 0.0 ; N2(nz+1) = 0.0 do K=2,nz call calculate_density(0.5*(Tf(k-1) + Tf(k)), 0.5*(Sf(k-1) + Sf(k)), & pres(K), rho_here, tv%eqn_of_state) - N2(K) = (GV%g_Earth * rho_here / (0.5*GV%H_to_m*(h_tr(k-1) + h_tr(k)))) * & + N2(K) = ((GV%g_Earth*US%m_to_Z**2) * rho_here / (0.5*GV%H_to_Z*(h_tr(k-1) + h_tr(k)))) * & ( 0.5*(dSV_dT(k-1) + dSV_dT(k)) * (Tf(k-1) - Tf(k)) + & 0.5*(dSV_dS(k-1) + dSV_dS(k)) * (Sf(k-1) - Sf(k)) ) enddo - call post_data_1d_k(CS%id_N2_f, N2, CS%diag) + call post_data(CS%id_N2_f, N2, CS%diag) endif endif @@ -977,92 +966,92 @@ end subroutine diapyc_energy_req_calc !! for several changes in an interfaces's diapycnal diffusivity times a timestep. subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & dT_to_dPE_a, dS_to_dPE_a, dT_to_dPE_b, dS_to_dPE_b, & - pres, dT_to_dColHt_a, dS_to_dColHt_a, dT_to_dColHt_b, dS_to_dColHt_b, & + pres_Z, dT_to_dColHt_a, dS_to_dColHt_a, dT_to_dColHt_b, dS_to_dColHt_b, & PE_chg, dPEc_dKd, dPE_max, dPEc_dKd_0, ColHt_cor) real, intent(in) :: Kddt_h0 !< The previously used diffusivity at an interface times !! the time step and divided by the average of the - !! thicknesses around the interface, in units of H (m or kg-2). + !! thicknesses around the interface [H ~> m or kg m-2]. real, intent(in) :: dKddt_h !< The trial change in the diffusivity at an interface times !! the time step and divided by the average of the - !! thicknesses around the interface, in units of H (m or kg-2). + !! thicknesses around the interface [H ~> m or kg m-2]. real, intent(in) :: hp_a !< The effective pivot thickness of the layer above the !! interface, given by h_k plus a term that !! is a fraction (determined from the tridiagonal solver) of - !! Kddt_h for the interface above, in H. + !! Kddt_h for the interface above [H ~> m or kg m-2]. real, intent(in) :: hp_b !< The effective pivot thickness of the layer below the !! interface, given by h_k plus a term that !! is a fraction (determined from the tridiagonal solver) of - !! Kddt_h for the interface above, in H. + !! Kddt_h for the interface above [H ~> m or kg m-2]. real, intent(in) :: Th_a !< An effective temperature times a thickness in the layer !! above, including implicit mixing effects with other - !! yet higher layers, in K H. + !! yet higher layers [degC H ~> degC m or degC kg m-2]. real, intent(in) :: Sh_a !< An effective salinity times a thickness in the layer !! above, including implicit mixing effects with other - !! yet higher layers, in K H. + !! yet higher layers [ppt H ~> ppt m or ppt kg m-2]. real, intent(in) :: Th_b !< An effective temperature times a thickness in the layer !! below, including implicit mixing effects with other - !! yet lower layers, in K H. + !! yet lower layers [degC H ~> degC m or degC kg m-2]. real, intent(in) :: Sh_b !< An effective salinity times a thickness in the layer !! below, including implicit mixing effects with other - !! yet lower layers, in K H. + !! yet lower layers [ppt H ~> ppt m or ppt kg m-2]. real, intent(in) :: dT_to_dPE_a !< A factor (pres_lay*mass_lay*dSpec_vol/dT) relating !! a layer's temperature change to the change in column !! potential energy, including all implicit diffusive changes - !! in the temperatures of all the layers above, in J m-2 K-1. + !! in the temperatures of all the layers above [J m-2 degC-1]. real, intent(in) :: dS_to_dPE_a !< A factor (pres_lay*mass_lay*dSpec_vol/dS) relating !! a layer's salinity change to the change in column !! potential energy, including all implicit diffusive changes - !! in the salinities of all the layers above, in J m-2 ppt-1. + !! in the salinities of all the layers above [J m-2 ppt-1]. real, intent(in) :: dT_to_dPE_b !< A factor (pres_lay*mass_lay*dSpec_vol/dT) relating !! a layer's temperature change to the change in column !! potential energy, including all implicit diffusive changes - !! in the temperatures of all the layers below, in J m-2 K-1. + !! in the temperatures of all the layers below [J m-2 degC-1]. real, intent(in) :: dS_to_dPE_b !< A factor (pres_lay*mass_lay*dSpec_vol/dS) relating !! a layer's salinity change to the change in column !! potential energy, including all implicit diffusive changes - !! in the salinities of all the layers below, in J m-2 ppt-1. - real, intent(in) :: pres !< The hydrostatic interface pressure, which is used to relate + !! in the salinities of all the layers below [J m-2 ppt-1]. + real, intent(in) :: pres_Z !< The hydrostatic interface pressure, which is used to relate !! the changes in column thickness to the energy that is radiated - !! as gravity waves and unavailable to drive mixing, in Pa. + !! as gravity waves and unavailable to drive mixing [J m-2 Z-1 ~> J m-3]. real, intent(in) :: dT_to_dColHt_a !< A factor (mass_lay*dSColHtc_vol/dT) relating !! a layer's temperature change to the change in column !! height, including all implicit diffusive changes - !! in the temperatures of all the layers above, in m K-1. + !! in the temperatures of all the layers above [Z degC-1 ~> m degC-1]. real, intent(in) :: dS_to_dColHt_a !< A factor (mass_lay*dSColHtc_vol/dS) relating !! a layer's salinity change to the change in column !! height, including all implicit diffusive changes - !! in the salinities of all the layers above, in m ppt-1. + !! in the salinities of all the layers above [Z ppt-1 ~> m ppt-1]. real, intent(in) :: dT_to_dColHt_b !< A factor (mass_lay*dSColHtc_vol/dT) relating !! a layer's temperature change to the change in column !! height, including all implicit diffusive changes - !! in the temperatures of all the layers below, in m K-1. + !! in the temperatures of all the layers below [Z degC-1 ~> m degC-1]. real, intent(in) :: dS_to_dColHt_b !< A factor (mass_lay*dSColHtc_vol/dS) relating !! a layer's salinity change to the change in column !! height, including all implicit diffusive changes - !! in the salinities of all the layers below, in m ppt-1. + !! in the salinities of all the layers below [Z ppt-1 ~> m ppt-1]. real, optional, intent(out) :: PE_chg !< The change in column potential energy from applying - !! Kddt_h at the present interface, in J m-2. + !! Kddt_h at the present interface [J m-2]. real, optional, intent(out) :: dPEc_dKd !< The partial derivative of PE_chg with Kddt_h, - !! in units of J m-2 H-1. + !! [J m-2 H-1 ~> J m-3 or J kg-1]. real, optional, intent(out) :: dPE_max !< The maximum change in column potential energy that could !! be realizedd by applying a huge value of Kddt_h at the - !! present interface, in J m-2. + !! present interface [J m-2]. real, optional, intent(out) :: dPEc_dKd_0 !< The partial derivative of PE_chg with Kddt_h in the - !! limit where Kddt_h = 0, in J m-2 H-1. + !! limit where Kddt_h = 0 [J m-2 H-1 ~> J m-3 or J kg-1]. real, optional, intent(out) :: ColHt_cor !< The correction to PE_chg that is made due to a net - !! change in the column height, in J m-2. + !! change in the column height [J m-2]. - real :: hps ! The sum of the two effective pivot thicknesses, in H. - real :: bdt1 ! A product of the two pivot thicknesses plus a diffusive term, in H2. - real :: dT_c ! The core term in the expressions for the temperature changes, in K H2. - real :: dS_c ! The core term in the expressions for the salinity changes, in psu H2. + real :: hps ! The sum of the two effective pivot thicknesses [H ~> m or kg m-2]. + real :: bdt1 ! A product of the two pivot thicknesses plus a diffusive term [H2 ~> m2 or kg2 m-4]. + real :: dT_c ! The core term in the expressions for the temperature changes [degC H2 ~> degC m2 or degC kg2 m-4]. + real :: dS_c ! The core term in the expressions for the salinity changes [psu H2 ~> psu m2 or psu kg2 m-4]. real :: PEc_core ! The diffusivity-independent core term in the expressions - ! for the potential energy changes, J m-3. + ! for the potential energy changes [J m-3]. real :: ColHt_core ! The diffusivity-independent core term in the expressions - ! for the column height changes, J m-3. - real :: ColHt_chg ! The change in the column height, in m. - real :: y1 ! A local temporary term, in units of H-3 or H-4 in various contexts. + ! for the column height changes [J m-3]. + real :: ColHt_chg ! The change in the column height [Z ~> m]. + real :: y1 ! A local temporary term, in [H-3] or [H-4] in various contexts. ! The expression for the change in potential energy used here is derived ! from the expression for the final estimates of the changes in temperature @@ -1087,11 +1076,11 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & y1 = dKddt_h / (bdt1 * (bdt1 + dKddt_h * hps)) PE_chg = PEc_core * y1 ColHt_chg = ColHt_core * y1 - if (ColHt_chg < 0.0) PE_chg = PE_chg - pres * ColHt_chg - if (present(ColHt_cor)) ColHt_cor = -pres * min(ColHt_chg, 0.0) - else if (present(ColHt_cor)) then + if (ColHt_chg < 0.0) PE_chg = PE_chg - pres_Z * ColHt_chg + if (present(ColHt_cor)) ColHt_cor = -pres_Z * min(ColHt_chg, 0.0) + elseif (present(ColHt_cor)) then y1 = dKddt_h / (bdt1 * (bdt1 + dKddt_h * hps)) - ColHt_cor = -pres * min(ColHt_core * y1, 0.0) + ColHt_cor = -pres_Z * min(ColHt_core * y1, 0.0) endif if (present(dPEc_dKd)) then @@ -1099,7 +1088,7 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & y1 = 1.0 / (bdt1 + dKddt_h * hps)**2 dPEc_dKd = PEc_core * y1 ColHt_chg = ColHt_core * y1 - if (ColHt_chg < 0.0) dPEc_dKd = dPEc_dKd - pres * ColHt_chg + if (ColHt_chg < 0.0) dPEc_dKd = dPEc_dKd - pres_Z * ColHt_chg endif if (present(dPE_max)) then @@ -1107,7 +1096,7 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & y1 = 1.0 / (bdt1 * hps) dPE_max = PEc_core * y1 ColHt_chg = ColHt_core * y1 - if (ColHt_chg < 0.0) dPE_max = dPE_max - pres * ColHt_chg + if (ColHt_chg < 0.0) dPE_max = dPE_max - pres_Z * ColHt_chg endif if (present(dPEc_dKd_0)) then @@ -1115,7 +1104,7 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & y1 = 1.0 / bdt1**2 dPEc_dKd_0 = PEc_core * y1 ColHt_chg = ColHt_core * y1 - if (ColHt_chg < 0.0) dPEc_dKd_0 = dPEc_dKd_0 - pres * ColHt_chg + if (ColHt_chg < 0.0) dPEc_dKd_0 = dPEc_dKd_0 - pres_Z * ColHt_chg endif end subroutine find_PE_chg @@ -1126,70 +1115,70 @@ end subroutine find_PE_chg !! using the original form used in the first version of ePBL. subroutine find_PE_chg_orig(Kddt_h, h_k, b_den_1, dTe_term, dSe_term, & dT_km1_t2, dS_km1_t2, dT_to_dPE_k, dS_to_dPE_k, & - dT_to_dPEa, dS_to_dPEa, pres, dT_to_dColHt_k, & + dT_to_dPEa, dS_to_dPEa, pres_Z, dT_to_dColHt_k, & dS_to_dColHt_k, dT_to_dColHta, dS_to_dColHta, & PE_chg, dPEc_dKd, dPE_max, dPEc_dKd_0) real, intent(in) :: Kddt_h !< The diffusivity at an interface times the time step and !! divided by the average of the thicknesses around the - !! interface, in units of H (m or kg-2). - real, intent(in) :: h_k !< The thickness of the layer below the interface, in H. + !! interface [H ~> m or kg m-2]. + real, intent(in) :: h_k !< The thickness of the layer below the interface [H ~> m or kg m-2]. real, intent(in) :: b_den_1 !< The first term in the denominator of the pivot !! for the tridiagonal solver, given by h_k plus a term that !! is a fraction (determined from the tridiagonal solver) of - !! Kddt_h for the interface above, in H. - real, intent(in) :: dTe_term !< A diffusivity-independent term related to the - !! temperature change in the layer below the interface, in K H. - real, intent(in) :: dSe_term !< A diffusivity-independent term related to the - !! salinity change in the layer below the interface, in ppt H. + !! Kddt_h for the interface above [H ~> m or kg m-2]. + real, intent(in) :: dTe_term !< A diffusivity-independent term related to the temperature change + !! in the layer below the interface [degC H ~> degC m or degC kg m-2]. + real, intent(in) :: dSe_term !< A diffusivity-independent term related to the salinity change + !! in the layer below the interface [ppt H ~> ppt m or ppt kg m-2]. real, intent(in) :: dT_km1_t2 !< A diffusivity-independent term related to the - !! temperature change in the layer above the interface, in K. + !! temperature change in the layer above the interface [degC]. real, intent(in) :: dS_km1_t2 !< A diffusivity-independent term related to the - !! salinity change in the layer above the interface, in ppt. - real, intent(in) :: pres !< The hydrostatic interface pressure, which is used to relate + !! salinity change in the layer above the interface [ppt]. + real, intent(in) :: pres_Z !< The hydrostatic interface pressure, which is used to relate !! the changes in column thickness to the energy that is radiated - !! as gravity waves and unavailable to drive mixing, in Pa. + !! as gravity waves and unavailable to drive mixing [J m-2 Z-1 ~> J m-3]. real, intent(in) :: dT_to_dPE_k !< A factor (pres_lay*mass_lay*dSpec_vol/dT) relating !! a layer's temperature change to the change in column !! potential energy, including all implicit diffusive changes - !! in the temperatures of all the layers below, in J m-2 K-1. + !! in the temperatures of all the layers below [J m-2 degC-1]. real, intent(in) :: dS_to_dPE_k !< A factor (pres_lay*mass_lay*dSpec_vol/dS) relating !! a layer's salinity change to the change in column !! potential energy, including all implicit diffusive changes - !! in the salinities of all the layers below, in J m-2 ppt-1. + !! in the salinities of all the layers below [J m-2 ppt-1]. real, intent(in) :: dT_to_dPEa !< A factor (pres_lay*mass_lay*dSpec_vol/dT) relating !! a layer's temperature change to the change in column !! potential energy, including all implicit diffusive changes - !! in the temperatures of all the layers above, in J m-2 K-1. + !! in the temperatures of all the layers above [J m-2 degC-1]. real, intent(in) :: dS_to_dPEa !< A factor (pres_lay*mass_lay*dSpec_vol/dS) relating !! a layer's salinity change to the change in column !! potential energy, including all implicit diffusive changes - !! in the salinities of all the layers above, in J m-2 ppt-1. + !! in the salinities of all the layers above [J m-2 ppt-1]. real, intent(in) :: dT_to_dColHt_k !< A factor (mass_lay*dSColHtc_vol/dT) relating !! a layer's temperature change to the change in column !! height, including all implicit diffusive changes - !! in the temperatures of all the layers below, in m K-1. + !! in the temperatures of all the layers below [Z degC-1 ~> m degC-1]. real, intent(in) :: dS_to_dColHt_k !< A factor (mass_lay*dSColHtc_vol/dS) relating !! a layer's salinity change to the change in column !! height, including all implicit diffusive changes - !! in the salinities of all the layers below, in m ppt-1. + !! in the salinities of all the layers below [Z ppt-1 ~> m ppt-1]. real, intent(in) :: dT_to_dColHta !< A factor (mass_lay*dSColHtc_vol/dT) relating !! a layer's temperature change to the change in column !! height, including all implicit diffusive changes - !! in the temperatures of all the layers above, in m K-1. + !! in the temperatures of all the layers above [Z degC-1 ~> m degC-1]. real, intent(in) :: dS_to_dColHta !< A factor (mass_lay*dSColHtc_vol/dS) relating !! a layer's salinity change to the change in column !! height, including all implicit diffusive changes - !! in the salinities of all the layers above, in m ppt-1. + !! in the salinities of all the layers above [Z ppt-1 ~> m ppt-1]. real, optional, intent(out) :: PE_chg !< The change in column potential energy from applying - !! Kddt_h at the present interface, in J m-2. + !! Kddt_h at the present interface [J m-2]. real, optional, intent(out) :: dPEc_dKd !< The partial derivative of PE_chg with Kddt_h, - !! in units of J m-2 H-1. + !! [J m-2 H-1 ~> J m-3 or J kg-1]. real, optional, intent(out) :: dPE_max !< The maximum change in column potential energy that could - !! be realizedd by applying a huge value of Kddt_h at the - !! present interface, in J m-2. + !! be realized by applying a huge value of Kddt_h at the + !! present interface [J m-2]. real, optional, intent(out) :: dPEc_dKd_0 !< The partial derivative of PE_chg with Kddt_h in the - !! limit where Kddt_h = 0, in J m-2 H-1. + !! limit where Kddt_h = 0 [J m-2 H-1 ~> J m-3 or J kg-1]. ! This subroutine determines the total potential energy change due to mixing ! at an interface, including all of the implicit effects of the prescribed @@ -1200,16 +1189,17 @@ subroutine find_PE_chg_orig(Kddt_h, h_k, b_den_1, dTe_term, dSe_term, & ! this routine can also be used for an upward pass with the sense of direction ! reversed. - real :: b1 ! b1 is used by the tridiagonal solver, in H-1. - real :: b1Kd ! Temporary array (nondim.) - real :: ColHt_chg ! The change in column thickness in m. - real :: dColHt_max ! The change in column thickess for infinite diffusivity, in m. - real :: dColHt_dKd ! The partial derivative of column thickess with diffusivity, in s m-1. - real :: dT_k, dT_km1 ! Temporary arrays in K. - real :: dS_k, dS_km1 ! Temporary arrays in ppt. - real :: I_Kr_denom, dKr_dKd ! Temporary arrays in H-2 and nondim. - real :: ddT_k_dKd, ddT_km1_dKd ! Temporary arrays in K H-1. - real :: ddS_k_dKd, ddS_km1_dKd ! Temporary arrays in ppt H-1. + real :: b1 ! b1 is used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. + real :: b1Kd ! Temporary array [nondim] + real :: ColHt_chg ! The change in column thickness [Z ~> m]. + real :: dColHt_max ! The change in column thickness for infinite diffusivity [Z ~> m]. + real :: dColHt_dKd ! The partial derivative of column thickness with diffusivity [s Z-1 ~> s m-1]. + real :: dT_k, dT_km1 ! Temporary arrays [degC]. + real :: dS_k, dS_km1 ! Temporary arrays [ppt]. + real :: I_Kr_denom ! Temporary arrays [H-2 ~> m-2 or m4 kg-2]. + real :: dKr_dKd ! Nondimensional temporary array [nondim]. + real :: ddT_k_dKd, ddT_km1_dKd ! Temporary arrays [degC H-1 ~> m-1 or m2 kg-1]. + real :: ddS_k_dKd, ddS_km1_dKd ! Temporary arrays [ppt H-1 ~> ppt m-1 or ppt m2 kg-1]. b1 = 1.0 / (b_den_1 + Kddt_h) b1Kd = Kddt_h*b1 @@ -1234,7 +1224,7 @@ subroutine find_PE_chg_orig(Kddt_h, h_k, b_den_1, dTe_term, dSe_term, & (dS_to_dPE_k * dS_k + dS_to_dPEa * dS_km1) ColHt_chg = (dT_to_dColHt_k * dT_k + dT_to_dColHta * dT_km1) + & (dS_to_dColHt_k * dS_k + dS_to_dColHta * dS_km1) - if (ColHt_chg < 0.0) PE_chg = PE_chg - pres * ColHt_chg + if (ColHt_chg < 0.0) PE_chg = PE_chg - pres_Z * ColHt_chg endif if (present(dPEc_dKd)) then @@ -1251,7 +1241,7 @@ subroutine find_PE_chg_orig(Kddt_h, h_k, b_den_1, dTe_term, dSe_term, & (dS_to_dPE_k * ddS_k_dKd + dS_to_dPEa * ddS_km1_dKd) dColHt_dKd = (dT_to_dColHt_k * ddT_k_dKd + dT_to_dColHta * ddT_km1_dKd) + & (dS_to_dColHt_k * ddS_k_dKd + dS_to_dColHta * ddS_km1_dKd) - if (dColHt_dKd < 0.0) dPEc_dKd = dPEc_dKd - pres * dColHt_dKd + if (dColHt_dKd < 0.0) dPEc_dKd = dPEc_dKd - pres_Z * dColHt_dKd endif if (present(dPE_max)) then @@ -1262,7 +1252,7 @@ subroutine find_PE_chg_orig(Kddt_h, h_k, b_den_1, dTe_term, dSe_term, & dColHt_max = (dT_to_dColHta * dT_km1_t2 + dS_to_dColHta * dS_km1_t2) + & ((dT_to_dColHt_k + dT_to_dColHta) * dTe_term + & (dS_to_dColHt_k + dS_to_dColHta) * dSe_term) / (b_den_1 + h_k) - if (dColHt_max < 0.0) dPE_max = dPE_max - pres*dColHt_max + if (dColHt_max < 0.0) dPE_max = dPE_max - pres_Z*dColHt_max endif if (present(dPEc_dKd_0)) then @@ -1271,20 +1261,21 @@ subroutine find_PE_chg_orig(Kddt_h, h_k, b_den_1, dTe_term, dSe_term, & (dT_to_dPE_k * dTe_term + dS_to_dPE_k * dSe_term) / (h_k*b_den_1) dColHt_dKd = (dT_to_dColHta * dT_km1_t2 + dS_to_dColHta * dS_km1_t2) / (b_den_1) + & (dT_to_dColHt_k * dTe_term + dS_to_dColHt_k * dSe_term) / (h_k*b_den_1) - if (dColHt_dKd < 0.0) dPEc_dKd_0 = dPEc_dKd_0 - pres*dColHt_dKd + if (dColHt_dKd < 0.0) dPEc_dKd_0 = dPEc_dKd_0 - pres_Z*dColHt_dKd endif end subroutine find_PE_chg_orig -subroutine diapyc_energy_req_init(Time, G, param_file, diag, CS) +!> Initialize parameters and allocate memory associated with the diapycnal energy requirement module. +subroutine diapyc_energy_req_init(Time, G, GV, US, param_file, diag, CS) type(time_type), intent(in) :: Time !< model time type(ocean_grid_type), intent(in) :: G !< model grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< file to parse for parameter values type(diag_ctrl), target, intent(inout) :: diag !< structure to regulate diagnostic output type(diapyc_energy_req_CS), pointer :: CS !< module control structure -! Arguments: param_file - A structure indicating the open file to parse for -! model parameter values. -! (in/out) Reg - A pointer that is set to point to the tracer registry. + integer, save :: init_calls = 0 ! This include declares and sets the variable "version". #include "version_variable.h" @@ -1319,13 +1310,13 @@ subroutine diapyc_energy_req_init(Time, G, param_file, diag, CS) CS%id_ERh = register_diag_field('ocean_model', 'EnReqTest_ERh', diag%axesZi, Time, & "Diffusivity Energy Requirements, halves", "J m-2") CS%id_Kddt = register_diag_field('ocean_model', 'EnReqTest_Kddt', diag%axesZi, Time, & - "Implicit diffusive coupling coefficient", "m") + "Implicit diffusive coupling coefficient", "m", conversion=GV%H_to_m) CS%id_Kd = register_diag_field('ocean_model', 'EnReqTest_Kd', diag%axesZi, Time, & - "Diffusivity in test", "m2 s-1") + "Diffusivity in test", "m2 s-1", conversion=US%Z_to_m**2) CS%id_h = register_diag_field('ocean_model', 'EnReqTest_h_lay', diag%axesZL, Time, & - "Test column layer thicknesses", "m") - CS%id_zInt = register_diag_field('ocean_model', 'EnReqTest_z_int', diag%axesZi, Time, & - "Test column layer interface heights", "m") + "Test column layer thicknesses", "m", conversion=GV%H_to_m) + CS%id_zInt = register_diag_field('ocean_model', 'EnReqTest_z_int', diag%axesZi, Time, & + "Test column layer interface heights", "m", conversion=GV%H_to_m) CS%id_CHCt = register_diag_field('ocean_model', 'EnReqTest_CHCt', diag%axesZi, Time, & "Column Height Correction to Energy Requirements, top-down", "J m-2") CS%id_CHCb = register_diag_field('ocean_model', 'EnReqTest_CHCb', diag%axesZi, Time, & @@ -1349,8 +1340,10 @@ subroutine diapyc_energy_req_init(Time, G, param_file, diag, CS) end subroutine diapyc_energy_req_init +!> Clean up and deallocate memory associated with the diapycnal energy requirement module. subroutine diapyc_energy_req_end(CS) - type(diapyc_energy_req_CS), pointer :: CS + type(diapyc_energy_req_CS), pointer :: CS !< Diapycnal energy requirement control structure that + !! will be deallocated in this subroutine. if (associated(CS)) deallocate(CS) end subroutine diapyc_energy_req_end diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index d7ea7007c6..5d4d70ec30 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -1,52 +1,8 @@ +!> Energetically consistent planetary boundary layer parameterization module MOM_energetic_PBL ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Robert Hallberg, 2015. * -!* * -!* This file contains the subroutine (energetic_PBL) that uses an * -!* integrated boundary layer energy budget (like a bulk- or refined- * -!* bulk mixed layer scheme), but instead of homogenizing this model * -!* calculates a finite diffusivity and viscosity, which in this * -!* regard is conceptually similar to what is done with KPP or various * -!* two-equation closures. However, the scheme that is implemented * -!* here has the big advantage that is entirely implicit, but is * -!* simple enough that it requires only a single vertical pass to * -!* determine the diffusivity. The development of bulk mixed layer * -!* models stems from the work of various people, as described in the * -!* review paper by Niiler and Kraus (1979). The work here draws in * -!* with particular on the form for TKE decay proposed by Oberhuber * -!* (JPO, 1993, 808-829), with an extension to a refined bulk mixed * -!* layer as described in Hallberg (Aha Huliko'a, 2003). The physical * -!* processes portrayed in this subroutine include convectively driven * -!* mixing and mechanically driven mixing. Unlike boundary-layer * -!* mixing, stratified shear mixing is not a one-directional turbulent * -!* process, and it is dealt with elsewhere in the MOM6 code within * -!* the module MOM_kappa_shear.F90. It is assumed that the heat, * -!* mass, and salt fluxes have been applied elsewhere, but that their * -!* implications for the integrated TKE budget have been captured in * -!* an array that is provided as an argument to this subroutine. This * -!* is a full 3-d array due to the effects of penetrating shortwave * -!* radiation. * -!* * -!* Macros written all in capital letters are defined in MOM_memory.h. * -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q * -!* j+1 > o > o > At ^: v * -!* j x ^ x ^ x At >: u * -!* j > o > o > At o: h, T, S, Kd, etc. * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** - use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_alloc use MOM_diag_mediator, only : time_type, diag_ctrl @@ -55,6 +11,7 @@ module MOM_energetic_PBL use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use MOM_wave_interface, only: wave_parameters_CS, Get_Langmuir_Number @@ -68,138 +25,147 @@ module MOM_energetic_PBL public energetic_PBL, energetic_PBL_init, energetic_PBL_end public energetic_PBL_get_MLD +! 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. + +!> This control structure holds parameters for the MOM_energetic_PBL module type, public :: energetic_PBL_CS ; private - real :: mstar ! The ratio of the friction velocity cubed to the - ! TKE available to drive entrainment, nondimensional. - ! This quantity is the vertically integrated - ! shear production minus the vertically integrated - ! dissipation of TKE produced by shear. - real :: nstar ! The fraction of the TKE input to the mixed layer - ! available to drive entrainment, nondim. - ! This quantity is the vertically integrated - ! buoyancy production minus the vertically integrated - ! dissipation of TKE produced by buoyancy. - real :: MixLenExponent ! Exponent in the mixing length shape-function. - ! 1 is law-of-the-wall at top and bottom, - ! 2 is more KPP like. - real :: TKE_decay ! The ratio of the natural Ekman depth to the TKE - ! decay scale, nondimensional. - real :: MKE_to_TKE_effic ! The efficiency with which mean kinetic energy - ! released by mechanically forced entrainment of - ! the mixed layer is converted to TKE, nondim. -! real :: Hmix_min ! The minimum mixed layer thickness in m. - real :: ustar_min ! A minimum value of ustar to avoid numerical - ! problems, in m s-1. If the value is small enough, - ! this should not affect the solution. - real :: omega ! The Earth's rotation rate, in s-1. - real :: omega_frac ! 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). - real :: wstar_ustar_coef ! A ratio relating the efficiency with which - ! convectively released energy is converted to a - ! turbulent velocity, relative to mechanically - ! forced turbulent kinetic energy, nondim. Making - ! this larger increases the diffusivity. - real :: vstar_scale_fac ! An overall nondimensional scaling factor - ! for vstar. Making this larger increases the - ! diffusivity. - real :: Ekman_scale_coef ! A nondimensional scaling factor controlling - ! the inhibition of the diffusive length scale by - ! rotation. Making this larger decreases the - ! diffusivity in the planetary boundary layer. - real :: transLay_scale ! 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, but a - ! value of 0.1 might be better justified by observations. - real :: MLD_tol ! A tolerance for determining the boundary layer - ! thickness when Use_MLD_iteration is true, in m. - real :: min_mix_len ! The minimum mixing length scale that will be - ! used by ePBL, in m. The default (0) does not - ! set a minimum. - real :: N2_Dissipation_Scale_Neg - real :: N2_Dissipation_Scale_Pos - ! A nondimensional scaling factor controlling the - ! loss of TKE due to enhanced dissipation in the presence - ! of stratification. This dissipation is applied to the - ! available TKE which includes both that generated at the - ! surface and that generated at depth. It may be important - ! to distinguish which TKE flavor that this dissipation - ! applies to in subsequent revisions of this code. - ! "_Neg" and "_Pos" refer to which scale is applied as a - ! function of negative or positive local buoyancy. - 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), - ! but will be taken as constant for now. - real :: MSTAR_SLOPE ! Slope of the function which relates the shear production - ! to the mixing layer depth, Ekman depth, and Monin-Obukhov - ! depth. - real :: MSTAR_XINT ! Value where MSTAR function transitions from linear - ! to decay toward MSTAR->0 at fully developed Ekman depth. - 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 :: MSTAR_N = -2. ! Exponent in decay at negative and positive limits of MLD_over_STAB - real :: MSTAR_A,MSTAR_A2 ! MSTAR_A and MSTAR_B are coefficients in asymptote toward limits. - real :: MSTAR_B,MSTAR_B2 ! These are computed to match the function value and slope at both - ! ends of the linear fit within the well constrained region. - 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 - real :: LaC_MLDoEK ! Coefficients for Langmuir number modification based on - real :: LaC_MLDoOB_stab ! length scale ratios, MLD is boundary, EK is Ekman, - real :: LaC_EKoOB_stab ! and OB is Obukhov, the "o" in the name is for division. - real :: LaC_MLDoOB_un ! Stab/un are for stable (pos) and unstable (neg) Obukhov depths - real :: LaC_EKoOB_un ! ... - real :: Max_Enhance_M = 5. ! The maximum allowed LT enhancement to the mixing. - real :: CNV_MST_FAC ! Factor to reduce mstar when statically unstable. - type(time_type), pointer :: Time ! A pointer to the ocean model's clock. - - integer :: MSTAR_MODE = 0 ! An integer to determine which formula is used to - ! set mstar - integer :: CONST_MSTAR=0,MLD_o_OBUKHOV=1,EKMAN_o_OBUKHOV=2 - logical :: MSTAR_FLATCAP=.true. !Set false to use asymptotic mstar cap. - logical :: TKE_diagnostics = .false. - logical :: Use_LT = .false. ! Flag for using LT in Energy calculation - logical :: orig_PE_calc = .true. - logical :: Use_MLD_iteration=.false. ! False to use old ePBL method. - logical :: Orig_MLD_iteration=.false. ! False to use old MLD value - logical :: MLD_iteration_guess=.false. ! False to default to guessing half the - ! ocean depth for the iteration. - logical :: Mixing_Diagnostics = .false. ! Will be true when outputing mixing - ! length and velocity scale - logical :: MSTAR_Diagnostics=.false. - type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the - ! timing of diagnostic output. - -! These are terms in the mixed layer TKE budget, all in J m-2 = kg s-2. + real :: mstar !< The ratio of the friction velocity cubed to the TKE available to + !! drive entrainment, nondimensional. This quantity is the vertically + !! integrated shear production minus the vertically integrated + !! dissipation of TKE produced by shear. + real :: nstar !< The fraction of the TKE input to the mixed layer available to drive + !! entrainment [nondim]. This quantity is the vertically integrated + !! buoyancy production minus the vertically integrated dissipation of + !! TKE produced by buoyancy. + real :: MixLenExponent !< Exponent in the mixing length shape-function. + !! 1 is law-of-the-wall at top and bottom, + !! 2 is more KPP like. + real :: TKE_decay !< The ratio of the natural Ekman depth to the TKE decay scale [nondim]. + real :: MKE_to_TKE_effic !< The efficiency with which mean kinetic energy released by + !! mechanically forced entrainment of the mixed layer is converted to + !! TKE [nondim]. +! real :: Hmix_min !< The minimum mixed layer thickness in m. + real :: ustar_min !< A minimum value of ustar to avoid numerical problems [m s-1]. + !! If the value is small enough, this should not affect the solution. + real :: omega !< The Earth's rotation rate [s-1]. + real :: omega_frac !< 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). + real :: wstar_ustar_coef !< A ratio relating the efficiency with which convectively released + !! energy is converted to a turbulent velocity, relative to + !! mechanically forced turbulent kinetic energy [nondim]. + !! Making this larger increases the diffusivity. + 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 + !! diffusive length scale by rotation. Making this larger decreases + !! the diffusivity in the planetary boundary layer. + real :: transLay_scale !< 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, but a + !! value of 0.1 might be better justified by observations. + real :: MLD_tol !< A tolerance for determining the boundary layer thickness when + !! Use_MLD_iteration is true [Z ~> m]. + real :: min_mix_len !< The minimum mixing length scale that will be used by ePBL [Z ~> m]. + !! The default (0) does not set a minimum. + real :: N2_Dissipation_Scale_Neg !< A nondimensional scaling factor controlling the loss of TKE + !! due to enhanced dissipation in the presence of negative (unstable) + !! local stratification. This dissipation is applied to the available + !! TKE which includes both that generated at the surface and that + !! generated at depth. + real :: N2_Dissipation_Scale_Pos !< A nondimensional scaling factor controlling the loss of TKE + !! due to enhanced dissipation in the presence of positive (stable) + !! local stratification. This dissipation is applied to the available + !! TKE which includes both that generated at the surface and that + !! generated at depth. + 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), + !! but will be taken as constant for now. + real :: MSTAR_SLOPE !< Slope of the function which relates the shear production to the + !< mixing layer depth, Ekman depth, and Monin-Obukhov depth. + real :: MSTAR_XINT !< Value where MSTAR function transitions from linear + !! to decay toward MSTAR->0 at fully developed Ekman depth. + 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 :: 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 + !! within the well constrained region. + real :: MSTAR_A2 !< Coefficients of expressions for mstar in asymptotic limits. + real :: MSTAR_B !< Coefficients of expressions for mstar in asymptotic limits. + 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 + 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 + !! the mixed layer depth over the Obukov depth with stablizing forcing. + real :: LaC_EKoOB_stab !< Coefficient for Langmuir number modification based on the ratio of + !! the Ekman depth over the Obukov depth with stablizing forcing. + real :: LaC_MLDoOB_un !< Coefficient for Langmuir number modification based on the ratio of + !! the mixed layer depth over the Obukov depth with destablizing forcing. + real :: LaC_EKoOB_un !< Coefficient for Langmuir number modification based on the ratio of + !! the Ekman depth over the Obukov depth with destablizing forcing. + real :: Max_Enhance_M = 5. !< The maximum allowed LT enhancement to the mixing. + real :: CNV_MST_FAC !< Factor to reduce mstar when statically unstable. + type(time_type), pointer :: Time=>NULL() !< A pointer to the ocean model's clock. + + integer :: MSTAR_MODE = 0 !< An coded integer to determine which formula is used to set mstar + integer :: CONST_MSTAR=0 !< The value of MSTAR_MODE to use a constant mstar + integer :: MLD_o_OBUKHOV=1 !< The value of MSTAR_MODE to base mstar on the ratio of the mixed + !! 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 + 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 + logical :: orig_PE_calc = .true. !< If true, the ePBL code uses the original form of the + !! potential energy change code. Otherwise, it uses a newer version + !! that can work with successive increments to the diffusivity in + !! upward or downward passes. + logical :: Use_MLD_iteration=.false. !< False to use old ePBL method. + logical :: Orig_MLD_iteration=.false. !< False to use old MLD value + logical :: MLD_iteration_guess=.false. !< False to default to guessing half the + !! ocean depth for the iteration. + logical :: Mixing_Diagnostics = .false. !< Will be true when outputting mixing + !! length and velocity scales + logical :: MSTAR_Diagnostics=.false. !< If true, utput diagnostics of the mstar calculation. + type(diag_ctrl), pointer :: diag=>NULL() !< A structure that is used to regulate the + !! timing of diagnostic output. + + ! These are terms in the mixed layer TKE budget, all in [J m-2] = [kg s-2]. real, allocatable, dimension(:,:) :: & - diag_TKE_wind, & ! The wind source of TKE. - diag_TKE_MKE, & ! The resolved KE source of TKE. - diag_TKE_conv, & ! The convective source of TKE. - diag_TKE_forcing, & ! The TKE sink required to mix surface - ! penetrating shortwave heating. - diag_TKE_mech_decay, & ! The decay of mechanical TKE. - diag_TKE_conv_decay, & ! The decay of convective TKE. - diag_TKE_mixing,& ! The work done by TKE to deepen - ! the mixed layer. + diag_TKE_wind, & !< The wind source of TKE [J m-2]. + diag_TKE_MKE, & !< The resolved KE source of TKE [J m-2]. + diag_TKE_conv, & !< The convective source of TKE [J m-2]. + diag_TKE_forcing, & !< The TKE sink required to mix surface penetrating shortwave heating [J m-2]. + diag_TKE_mech_decay, & !< The decay of mechanical TKE [J m-2]. + diag_TKE_conv_decay, & !< The decay of convective TKE [J m-2]. + diag_TKE_mixing,& !< The work done by TKE to deepen the mixed layer [J m-2]. ! Additional output parameters also 2d - ML_depth, & ! The mixed layer depth in m. (result after iteration step) - ML_depth2, & ! The mixed layer depth in m. (guess for iteration step) - Enhance_M, & ! The enhancement to the turbulent velocity scale (non-dim) - MSTAR_MIX, & ! Mstar used in EPBL - MSTAR_LT, & ! Mstar for Langmuir turbulence - MLD_EKMAN, & ! MLD over Ekman length - MLD_OBUKHOV, & ! MLD over Obukhov length - EKMAN_OBUKHOV, & ! Ekman over Obukhov length - LA, & ! Langmuir number - LA_MOD ! Modified Langmuir number + ML_depth, & !< The mixed layer depth [Z ~> m]. (result after iteration step) + ML_depth2, & !< The mixed layer depth [Z ~> m]. (guess for iteration step) + Enhance_M, & !< The enhancement to the turbulent velocity scale [nondim] + MSTAR_MIX, & !< Mstar used in EPBL [nondim] + MSTAR_LT, & !< Mstar for Langmuir turbulence [nondim] + MLD_EKMAN, & !< MLD over Ekman length [nondim] + MLD_OBUKHOV, & !< MLD over Obukhov length [nondim] + EKMAN_OBUKHOV, & !< Ekman over Obukhov length [nondim] + LA, & !< Langmuir number [nondim] + LA_MOD !< Modified Langmuir number [nondim] real, allocatable, dimension(:,:,:) :: & - Velocity_Scale, & ! The velocity scale used in getting Kd - Mixing_Length ! The length scale used in getting Kd + Velocity_Scale, & !< The velocity scale used in getting Kd [Z s-1 ~> m s-1] + Mixing_Length !< The length scale used in getting Kd [Z ~> m] + !>@{ Diagnostic IDs integer :: id_ML_depth = -1, id_TKE_wind = -1, id_TKE_mixing = -1 integer :: id_TKE_MKE = -1, id_TKE_conv = -1, id_TKE_forcing = -1 integer :: id_TKE_mech_decay = -1, id_TKE_conv_decay = -1 @@ -208,66 +174,71 @@ module MOM_energetic_PBL integer :: id_OSBL = -1, id_LT_Enhancement = -1, id_MSTAR_mix = -1 integer :: id_mld_ekman = -1, id_mld_obukhov = -1, id_ekman_obukhov = -1 integer :: id_LA_mod = -1, id_LA = -1, id_MSTAR_LT = -1 + !!@} end type energetic_PBL_CS -integer :: num_msg = 0, max_msg = 2 - contains !> This subroutine determines the diffusivities from the integrated energetics !! mixed layer model. It assumes that heating, cooling and freshwater fluxes !! have already been applied. All calculations are done implicitly, and there !! is no stability limit on the time step. -subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & +subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS, & dSV_dT, dSV_dS, TKE_forced, Buoy_Flux, dt_diag, last_call, & dT_expected, dS_expected, waves ) 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(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(inout) :: h_3d !< Layer thickness, in m or kg m-2. - !! (Intent in/out) The units of h are referred - !! to as H below. + intent(inout) :: h_3d !< Layer thicknesses [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: u_3d !< Zonal velocities interpolated to h points, - !! m s-1. + intent(in) :: u_3d !< Zonal velocities interpolated to h points + !! [m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: v_3d !< Zonal velocities interpolated to h points, - !! m s-1. + intent(in) :: v_3d !< Zonal velocities interpolated to h points + !! [m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: dSV_dT !< The partial derivative of in-situ specific - !! volume with potential temperature, - !! in m3 kg-1 K-1. + !! volume with potential temperature + !! [m3 kg-1 degC-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: dSV_dS !< The partial derivative of in-situ specific - !! volume with salinity, in m3 kg-1 ppt-1. + !! volume with salinity [m3 kg-1 ppt-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: TKE_forced !< The forcing requirements to homogenize the !! forcing that has been applied to each layer - !! through each layer, in J m-2. + !! through each layer [J m-2]. type(thermo_var_ptrs), intent(inout) :: tv !< A structure containing pointers to any !! available thermodynamic fields. Absent fields !! have NULL ptrs. type(forcing), intent(inout) :: fluxes !< A structure containing pointers to any !! possible forcing fields. Unused fields have !! NULL ptrs. - real, intent(in) :: dt !< Time increment, in s. + real, intent(in) :: dt !< Time increment [s]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & - intent(out) :: Kd_int !< The diagnosed diffusivities at interfaces, - !! in m2 s-1. + intent(out) :: Kd_int !< The diagnosed diffusivities at interfaces + !! [Z2 s-1 ~> m2 s-1]. type(energetic_PBL_CS), pointer :: CS !< The control structure returned by a previous !! call to mixedlayer_init. real, dimension(SZI_(G),SZJ_(G)), & - intent(in) :: Buoy_Flux !< The surface buoyancy flux. in m2/s3. + intent(in) :: Buoy_Flux !< The surface buoyancy flux [Z2 s-3 ~> m2 s-3]. real, optional, intent(in) :: dt_diag !< The diagnostic time step, which may be less !! than dt if there are two callse to - !! mixedlayer, in s. + !! mixedlayer [s]. logical, optional, intent(in) :: last_call !< If true, this is the last call to !! mixedlayer in the current time step, so !! diagnostics will be written. The default !! is .true. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - optional, intent(out) :: dT_expected, dS_expected - type(wave_parameters_CS), pointer, optional :: Waves ! m or kg m-2]. + T, & ! The layer temperatures [degC]. + S, & ! The layer salinities [ppt]. + u, & ! The zonal velocity [m s-1]. + v ! The meridional velocity [m s-1]. real, dimension(SZI_(G),SZK_(GV)+1) :: & - Kd, & ! The diapycnal diffusivity, in m2 s-1. - pres, & ! Interface pressures in Pa. + Kd, & ! The diapycnal diffusivity [Z2 s-1 ~> m2 s-1]. + pres, & ! Interface pressures [Pa]. + pres_Z, & ! Interface pressures with a rescaling factor to convert interface height + ! movements into changes in column potential energy [J m-2 Z-1 ~> J m-3]. hb_hs ! The distance from the bottom over the thickness of the - ! water column, nondim. + ! water column [nondim]. real, dimension(SZI_(G)) :: & mech_TKE, & ! The mechanically generated turbulent kinetic energy - ! available for mixing over a time step, in J m-2 = kg s-2. + ! available for mixing over a time step [J m-2 = kg s-2]. conv_PErel, & ! The potential energy that has been convectively released - ! during this timestep, in J m-2 = kg s-2. A portion nstar_FC + ! during this timestep [J m-2 = kg s-2]. A portion nstar_FC ! of conv_PErel is available to drive mixing. - htot, & ! The total depth of the layers above an interface, in H. + htot, & ! The total depth of the layers above an interface [H ~> m or kg m-2]. uhtot, & ! The depth integrated zonal and meridional velocities in the - vhtot, & ! layers above, in H m s-1. - mech_TKE_top, & ! The value of mech_TKE at the top of the column, in J m-2. - conv_PErel_top, & ! The value of conv_PErel at the top of the column, in J m-2. + vhtot, & ! layers above [H m s-1 ~> m2 s-1 or kg m-1 s-1]. + mech_TKE_top, & ! The value of mech_TKE at the top of the column [J m-2]. + conv_PErel_top, & ! The value of conv_PErel at the top of the column [J m-2]. - Idecay_len_TKE, & ! The inverse of a turbulence decay length scale, in H-1. - h_sum, & ! The total thickness of the water column, in H. - absf ! The absolute value of f, in s-1. + Idecay_len_TKE, & ! The inverse of a turbulence decay length scale [H-1 ~> m-1 or m2 kg-1]. + h_sum, & ! The total thickness of the water column [H ~> m or kg m-2]. + absf ! The absolute value of f [s-1]. real, dimension(SZI_(G),SZK_(GV)) :: & dT_to_dColHt, & ! Partial derivatives of the total column height with the temperature - dS_to_dColHt, & ! and salinity changes within a layer, in m K-1 and m ppt-1. + dS_to_dColHt, & ! and salinity changes within a layer [Z degC-1 ~> m degC-1] and [Z ppt-1 ~> m ppt-1]. dT_to_dPE, & ! Partial derivatives of column potential energy with the temperature - dS_to_dPE, & ! and salinity changes within a layer, in J m-2 K-1 and J m-2 ppt-1. + dS_to_dPE, & ! and salinity changes within a layer, in [J m-2 degC-1] and [J m-2 ppt-1]. dT_to_dColHt_a, & ! Partial derivatives of the total column height with the temperature dS_to_dColHt_a, & ! and salinity changes within a layer, including the implicit effects - ! of mixing with layers higher in the water colun, in m K-1 and m ppt-1. + ! of mixing with layers higher in the water colun [Z degC-1 ~> m degC-1] and [Z ppt-1 ~> m ppt-1]. dT_to_dPE_a, & ! Partial derivatives of column potential energy with the temperature dS_to_dPE_a ! and salinity changes within a layer, including the implicit effects ! of mixing with layers higher in the water column, in - ! units of J m-2 K-1 and J m-2 ppt-1. + ! units of [J m-2 degC-1] and [J m-2 ppt-1]. real, dimension(SZK_(GV)) :: & - T0, S0, & ! Initial values of T and S in the column, in K and ppt. - Te, Se, & ! Estimated final values of T and S in the column, in K and ppt. - c1, & ! c1 is used by the tridiagonal solver, ND. + T0, S0, & ! Initial values of T and S in the column, in [degC] and [ppt]. + Te, Se, & ! Estimated final values of T and S in the column, in [degC] and [ppt]. + c1, & ! c1 is used by the tridiagonal solver [nondim]. dTe, dSe ! Running (1-way) estimates of temperature and salinity change. real, dimension(SZK_(GV)) :: & - Th_a, & ! An effective temperature times a thickness in the layer above, - ! including implicit mixing effects with other yet higher layers, in K H. - Sh_a, & ! An effective salinity times a thickness in the layer above, - ! including implicit mixing effects with other yet higher layers, in K H. - Th_b, & ! An effective temperature times a thickness in the layer below, - ! including implicit mixing effects with other yet lower layers, in K H. - Sh_b ! An effective salinity times a thickness in the layer below, - ! including implicit mixing effects with other yet lower layers, in K H. + Th_a, & ! An effective temperature times a thickness in the layer above, including implicit + ! mixing effects with other yet higher layers [degC H ~> degC m or degC kg m-2]. + Sh_a, & ! An effective salinity times a thickness in the layer above, including implicit + ! mixing effects with other yet higher layers [ppt H ~> ppt m or ppt kg m-2]. + Th_b, & ! An effective temperature times a thickness in the layer below, including implicit + ! mixing effects with other yet lower layers [degC H ~> degC m or degC kg m-2]. + Sh_b ! An effective salinity times a thickness in the layer below, including implicit + ! mixing effects with other yet lower layers [ppt H ~> ppt m or ppt kg m-2]. real, dimension(SZI_(G)) :: & hp_a ! An effective pivot thickness of the layer including the effects - ! of coupling with layers above, in H. This is the first term + ! of coupling with layers above [H ~> m or kg m-2]. This is the first term ! in the denominator of b1 in a downward-oriented tridiagonal solver. real, dimension(SZK_(GV)+1) :: & MixLen_shape, & ! A nondimensional shape factor for the mixing length that ! gives it an appropriate assymptotic value at the bottom of ! the boundary layer. Kddt_h ! The diapycnal diffusivity times a timestep divided by the - ! average thicknesses around a layer, in H (m or kg m-2). - real :: b1 ! b1 is inverse of the pivot used by the tridiagonal solver, in H-1. + ! average thicknesses around a layer [H ~> m or kg m-2]. + real :: b1 ! b1 is inverse of the pivot used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected, in H. - real :: dMass ! The mass per unit area within a layer, in kg m-2. - real :: dPres ! The hydrostatic pressure change across a layer, in Pa. + ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: dMass ! The mass per unit area within a layer [kg m-2]. + real :: dPres ! The hydrostatic pressure change across a layer [Pa]. real :: dMKE_max ! The maximum amount of mean kinetic energy that could be ! converted to turbulent kinetic energy if the velocity in ! the layer below an interface were homogenized with all of - ! the water above the interface, in J m-2 = kg s-2. + ! the water above the interface [J m-2 = kg s-2]. real :: MKE2_Hharm ! Twice the inverse of the harmonic mean of the thickness ! of a layer and the thickness of the water above, used in - ! the MKE conversion equation, in H-1. + ! the MKE conversion equation [H-1 ~> m-1 or m2 kg-1]. real :: dt_h ! The timestep divided by the averages of the thicknesses around - ! a layer, times a thickness conversion factor, in H s m-2. - real :: h_bot ! The distance from the bottom, in H. - real :: h_rsum ! The running sum of h from the top, in H. - real :: I_hs ! The inverse of h_sum, in H-1. - real :: I_mld ! The inverse of the current value of MLD, in H-1. + ! a layer, times a thickness conversion factor [H s m-2 ~> s m-1 or kg s m-4]. + real :: h_bot ! The distance from the bottom [H ~> m or kg m-2]. + real :: h_rsum ! The running sum of h from the top [Z ~> m]. + real :: I_hs ! The inverse of h_sum [H-1 ~> m-1 or m2 kg-1]. + real :: I_MLD ! The inverse of the current value of MLD [Z-1 ~> m-1]. real :: h_tt ! The distance from the surface or up to the next interface ! that did not exhibit turbulent mixing from this scheme plus - ! a surface mixing roughness length given by h_tt_min, in H. - real :: h_tt_min ! A surface roughness length, in H. + ! a surface mixing roughness length given by h_tt_min [H ~> m or kg m-2]. + real :: h_tt_min ! A surface roughness length [H ~> m or kg m-2]. real :: C1_3 ! = 1/3. real :: vonKar ! The vonKarman constant. - real :: I_dtrho ! 1.0 / (dt * Rho0) in m3 kg-1 s-1. This is + real :: I_dtrho ! 1.0 / (dt * Rho0) in [m3 kg-1 s-1]. This is ! used convert TKE back into ustar^3. - real :: U_star ! The surface friction velocity, in m s-1. - real :: U_Star_Mean ! The surface friction without gustiness in m s-1. - real :: vstar ! An in-situ turbulent velocity, in m s-1. + real :: U_star ! The surface friction velocity [Z s-1 ~> m s-1]. + real :: U_Star_Mean ! The surface friction without gustiness [Z s-1 ~> m s-1]. + real :: vstar ! An in-situ turbulent velocity [m s-1]. real :: Enhance_M ! An enhancement factor for vstar, based here on Langmuir impact. - real :: LA ! The Langmuir number (non-dim) + real :: LA ! The Langmuir number [nondim] real :: LAmod ! A modified Langmuir number accounting for other parameters. real :: hbs_here ! The local minimum of hb_hs and MixLen_shape, times a - ! conversion factor from H to M, in m H-1. - real :: nstar_FC ! The fraction of conv_PErel that can be converted to mixing, nondim. + ! conversion factor from H to Z [Z H-1 ~> 1 or m3 kg-1]. + real :: nstar_FC ! The fraction of conv_PErel that can be converted to mixing [nondim]. real :: TKE_reduc ! The fraction by which TKE and other energy fields are - ! reduced to support mixing, nondim. between 0 and 1. - real :: tot_TKE ! The total TKE available to support mixing at interface K, in J m-2. - real :: TKE_here ! The total TKE at this point in the algorithm, in J m-2. + ! reduced to support mixing [nondim]. between 0 and 1. + real :: tot_TKE ! The total TKE available to support mixing at interface K [J m-2]. + real :: TKE_here ! The total TKE at this point in the algorithm [J m-2]. real :: dT_km1_t2 ! A diffusivity-independent term related to the temperature - ! change in the layer above the interface, in K. + ! change in the layer above the interface [degC]. real :: dS_km1_t2 ! A diffusivity-independent term related to the salinity - ! change in the layer above the interface, in ppt. + ! change in the layer above the interface [ppt]. real :: dTe_term ! A diffusivity-independent term related to the temperature - ! change in the layer below the interface, in K H. + ! change in the layer below the interface [degC H ~> degC m or degC kg m-2]. real :: dSe_term ! A diffusivity-independent term related to the salinity - ! change in the layer above the interface, in ppt H. - real :: dTe_t2 ! A part of dTe_term, in K H. - real :: dSe_t2 ! A part of dSe_term, in ppt H. - real :: dPE_conv ! The convective change in column potential energy, in J m-2. - real :: MKE_src ! The mean kinetic energy source of TKE due to Kddt_h(K), in J m-2. - real :: dMKE_src_dK ! The partial derivative of MKE_src with Kddt_h(K), in J m-2 H-1. - real :: Kd_guess0, PE_chg_g0, dPEa_dKd_g0, Kddt_h_g0 + ! change in the layer above the interface [ppt H ~> ppt m or ppt kg m-2]. + real :: dTe_t2 ! A part of dTe_term [degC H ~> degC m or degC kg m-2]. + real :: dSe_t2 ! A part of dSe_term [ppt H ~> ppt m or ppt kg m-2]. + real :: dPE_conv ! The convective change in column potential energy [J m-2]. + real :: MKE_src ! The mean kinetic energy source of TKE due to Kddt_h(K) [J m-2]. + real :: dMKE_src_dK ! The partial derivative of MKE_src with Kddt_h(K) [J m-2 H-1 ~> J m-3 or J kg-1]. + real :: Kd_guess0 ! A first guess of the diapycnal diffusivity [Z2 s-1 ~> m2 s-1]. + real :: PE_chg_g0 ! The potential energy change when Kd is Kd_guess0 [J m-2] + real :: dPEa_dKd_g0 + real :: Kddt_h_g0 ! The first guess diapycnal diffusivity times a timestep divided + ! by the average thicknesses around a layer [H ~> m or kg m-2]. real :: PE_chg_max ! The maximum PE change for very large values of Kddt_h(K). real :: dPEc_dKd_Kd0 ! The partial derivative of PE change with Kddt_h(K) - ! for very small values of Kddt_h(K), in J m-2 H-1. + ! for very small values of Kddt_h(K) [J m-2 H-1 ~> J m-3 or J kg-1]. real :: PE_chg ! The change in potential energy due to mixing at an - ! interface, in J m-2, positive for the column increasing + ! interface [J m-2], positive for the column increasing ! in potential energy (i.e., consuming TKE). real :: TKE_left ! The amount of turbulent kinetic energy left for the most - ! recent guess at Kddt_h(K), in J m-2. - real :: dPEc_dKd ! The partial derivative of PE_chg with Kddt_h(K), in J m-2 H-1. - real :: TKE_left_min, TKE_left_max, Kddt_h_max, Kddt_h_min - real :: Kddt_h_guess ! A guess at the value of Kddt_h(K), in H. - real :: Kddt_h_next ! The next guess at the value of Kddt_h(K), in H. - real :: dKddt_h ! The change between guesses at Kddt_h(K), in H. - real :: dKddt_h_Newt ! The change between guesses at Kddt_h(K) with Newton's method, in H. - real :: Kddt_h_newt ! The Newton's method next guess for Kddt_h(K), in H. - real :: exp_kh ! The nondimensional decay of TKE across a layer, ND. + ! recent guess at Kddt_h(K) [J m-2]. + real :: dPEc_dKd ! The partial derivative of PE_chg with Kddt_h(K) [J m-2 H-1 ~> J m-3 or J kg-1]. + real :: TKE_left_min, TKE_left_max ! Maximum and minimum values of TKE_left [J m-2]. + real :: Kddt_h_max, Kddt_h_min ! Maximum and minimum values of Kddt_h(K) [H ~> m or kg m-2]. + real :: Kddt_h_guess ! A guess at the value of Kddt_h(K) [H ~> m or kg m-2]. + real :: Kddt_h_next ! The next guess at the value of Kddt_h(K) [H ~> m or kg m-2]. + real :: dKddt_h ! The change between guesses at Kddt_h(K) [H ~> m or kg m-2]. + real :: dKddt_h_Newt ! The change between guesses at Kddt_h(K) with Newton's method [H ~> m or kg m-2]. + real :: Kddt_h_newt ! The Newton's method next guess for Kddt_h(K) [H ~> m or kg m-2]. + real :: exp_kh ! The nondimensional decay of TKE across a layer [nondim]. logical :: use_Newt ! Use Newton's method for the next guess at Kddt_h(K). logical :: convectively_stable logical, dimension(SZI_(G)) :: & @@ -462,21 +414,20 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & ! from the surface. ! The following is only used as a diagnostic. - real :: dt__diag ! A copy of dt_diag (if present) or dt, in s. - real :: IdtdR0 ! = 1.0 / (dt__diag * Rho0), in m3 kg-1 s-1. + real :: dt__diag ! A copy of dt_diag (if present) or dt [s]. + real :: IdtdR0 ! = 1.0 / (dt__diag * Rho0) [m3 kg-1 s-1]. real, dimension(SZI_(G),SZJ_(G)) :: & - Hsfc_used ! The thickness of the surface region after buffer layer + Hsfc_used ! The thickness of the surface region [Z ~> m]. logical :: write_diags ! If true, write out diagnostics with this step. logical :: reset_diags ! If true, zero out the accumulated diagnostics. - ! detrainment, in units of m. - ! Local column copies of energy change diagnostics, all in J m-2. + ! Local column copies of energy change diagnostics, all [J m-2]. real :: dTKE_conv, dTKE_forcing, dTKE_mixing real :: dTKE_MKE, dTKE_mech_decay, dTKE_conv_decay !---------------------------------------------------------------------- !/BGR added Aug24,2016 for adding iteration to get boundary layer depth ! - needed to compute new mixing length. - real :: MLD_guess, MLD_found ! Mixing Layer depth guessed/found for iteration, in m. - real :: max_MLD, min_MLD ! Iteration bounds, in m, which are adjusted at each step + real :: MLD_guess, MLD_found ! Mixing Layer depth guessed/found for iteration [Z ~> m]. + real :: max_MLD, min_MLD ! Iteration bounds [Z ~> m], which are adjusted at each step ! - These are initialized based on surface/bottom ! 1. The iteration guesses a value (possibly from ! prev step or neighbor). @@ -524,29 +475,29 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & integer, save :: NOTCONVERGED! !-End BGR iteration parameters----------------------------------------- real :: N2_dissipation - real :: Bf_STABLE ! Buoyancy flux, capped at 0 (negative only) + real :: Bf_STABLE ! Buoyancy flux, capped at 0 (negative only) real :: Bf_UNSTABLE ! Buoyancy flux, floored at 0 (positive only) - real :: STAB_SCALE ! Composite of Stabilizing length scales: - ! Ekman scale and Monin-Obukhov scale. - real :: iL_Ekman ! Inverse of Ekman length scale - real :: iL_Obukhov ! Inverse of Obukhov length scale + real :: Stab_Scale ! Composite of stabilizing Ekman scale and Monin-Obukhov length scales [Z ~> m]. + real :: iL_Ekman ! Inverse of Ekman length scale [Z-1 ~> m-1]. + real :: iL_Obukhov ! Inverse of Obukhov length scale [Z-1 ~> m-1]. real :: MLD_o_Ekman ! > real :: MLD_o_Obukhov_stab ! Ratios of length scales where MLD is boundary layer depth real :: Ekman_o_Obukhov_stab ! > real :: MLD_o_Obukhov_un ! Ratios of length scales where MLD is boundary layer depth real :: Ekman_o_Obukhov_un ! > - real :: C_MO = 1. ! Constant in STAB_SCALE for Monin-Obukhov - real :: C_EK = 2. ! Constant in STAB_SCALE for Ekman length - real :: MLD_over_STAB ! Mixing layer depth divided by STAB_SCALE - real :: MSTAR_MIX! The value of mstar (Proportionality of TKE to drive mixing to ustar + real :: C_MO = 1. ! Constant in Stab_Scale for Monin-Obukhov + real :: C_EK = 2. ! Constant in Stab_Scale for Ekman length + real :: MLD_over_STAB ! Mixing layer depth divided by Stab_Scale + real :: MSTAR_MIX ! The value of mstar (Proportionality of TKE to drive mixing to ustar ! cubed) which is computed as a function of latitude, boundary layer depth, ! and the Monin-Obukhov depth. - real :: MSTAR_LT ! The added mstar contribution due to Langmuir turbulence + 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. logical :: debug=.false. ! Change this hard-coded value for debugging. -! The following arrays are used only for debugging purposes. + + ! The following arrays are used only for debugging purposes. real :: dPE_debug, mixing_debug, taux2, tauy2 real, dimension(20) :: TKE_left_itt, PE_chg_itt, Kddt_h_itt, dPEa_dKd_itt, MKE_src_itt real, dimension(SZI_(G),SZK_(GV)) :: & @@ -570,7 +521,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & h_neglect = GV%H_subroundoff - if(.not.CS%Use_MLD_Iteration) MAX_OBL_IT=1 + if (.not.CS%Use_MLD_Iteration) MAX_OBL_IT=1 C1_3 = 1.0 / 3.0 dt__diag = dt ; if (present(dt_diag)) dt__diag = dt_diag IdtdR0 = 1.0 / (dt__diag * GV%Rho0) @@ -588,9 +539,8 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & reset_diags = .false. ! This is the second call to mixedlayer. if (reset_diags) then -!!OMP parallel default(none) shared(is,ie,js,je,CS) if (CS%TKE_diagnostics) then -!!OMP do +!!OMP parallel do default(none) shared(is,ie,js,je,CS) do j=js,je ; do i=is,ie CS%diag_TKE_wind(i,j) = 0.0 ; CS%diag_TKE_MKE(i,j) = 0.0 CS%diag_TKE_conv(i,j) = 0.0 ; CS%diag_TKE_forcing(i,j) = 0.0 @@ -598,23 +548,23 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & CS%diag_TKE_conv_decay(i,j) = 0.0 !; CS%diag_TKE_unbalanced_forcing(i,j) = 0.0 enddo ; enddo endif +!!OMP parallel do default(none) shared(CS) if (CS%Mixing_Diagnostics) then CS%Mixing_Length(:,:,:) = 0.0 CS%Velocity_Scale(:,:,:) = 0.0 endif -!!OMP end parallel endif !!OMP parallel do default(none) shared(js,je,nz,is,ie,h_3d,u_3d,v_3d,tv,dt, & -!!OMP CS,G,GV,fluxes,IdtdR0, & +!!OMP CS,G,GV,US,fluxes,IdtdR0, & !!OMP TKE_forced,debug,H_neglect,dSV_dT, & -!!OMP dSV_dS,I_dtrho,C1_3,h_tt_min,vonKar, & +!!OMP dSV_dS,I_dtrho,C1_3,h_tt_min,vonKar, & !!OMP max_itt,Kd_int) & -!!OMP private(i,j,k,h,u,v,T,S,Kd,mech_TKE_k,conv_PErel_k, & +!!OMP private(i,j,k,h,u,v,T,S,Kd,mech_TKE_k,conv_PErel_k, & !!OMP U_Star,absf,mech_TKE,conv_PErel,nstar_k, & !!OMP h_sum,I_hs,h_bot,hb_hs,T0,S0,num_itts, & -!!OMP pres,dMass,dPres,dT_to_dPE,dS_to_dPE, & +!!OMP pres,pres_Z,dMass,dPres,dT_to_dPE,dS_to_dPE, & !!OMP dT_to_dColHt,dS_to_dColHt,Kddt_h,hp_a, & !!OMP Th_a,Sh_a,Th_b,Sh_b,dT_to_dPE_a,htot, & !!OMP dT_to_dColHt_a,dS_to_dColHt_a,uhtot,vhtot, & @@ -643,8 +593,8 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & Kd(i,K) = 0.0 enddo ; enddo do i=is,ie - CS%ML_depth(i,j) = h(i,1)*GV%H_to_m - !CS%ML_depth2(i,j) = h(i,1)*GV%H_to_m + CS%ML_depth(i,j) = h(i,1)*GV%H_to_Z + !CS%ML_depth2(i,j) = h(i,1)*GV%H_to_Z sfc_connected(i) = .true. enddo @@ -660,33 +610,48 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & ! interface. do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then - U_Star = fluxes%ustar(i,j) + U_star = fluxes%ustar(i,j) U_Star_Mean = fluxes%ustar_gustless(i,j) if (associated(fluxes%ustar_shelf) .and. associated(fluxes%frac_shelf_h)) then if (fluxes%frac_shelf_h(i,j) > 0.0) & - U_Star = (1.0 - fluxes%frac_shelf_h(i,j)) * U_star + & + U_star = (1.0 - fluxes%frac_shelf_h(i,j)) * U_star + & fluxes%frac_shelf_h(i,j) * fluxes%ustar_shelf(i,j) endif if (U_Star < CS%ustar_min) U_Star = CS%ustar_min + ! Computing Bf w/ limiters. - Bf_Stable = max(0.0,buoy_Flux(i,j)) ! Positive for stable - Bf_Unstable = min(0.0,buoy_flux(i,j)) ! Negative for unstable + Bf_Stable = max(0.0, buoy_Flux(i,j)) ! Positive for stable + Bf_Unstable = min(0.0, buoy_flux(i,j)) ! Negative for unstable if (CS%omega_frac >= 1.0) then ; absf(i) = 2.0*CS%omega else absf(i) = 0.25*((abs(G%CoriolisBu(I,J)) + abs(G%CoriolisBu(I-1,J-1))) + & - (abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I-1,J)))) + (abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I-1,J)))) if (CS%omega_frac > 0.0) & absf(i) = sqrt(CS%omega_frac*4.0*CS%omega**2 + (1.0-CS%omega_frac)*absf(i)**2) endif ! Computing stability scale which correlates with TKE for mixing, where ! TKE for mixing = TKE production minus TKE dissipation - Stab_Scale = u_star**2 / ( VonKar * ( C_MO * BF_Stable/u_star - C_EK * u_star * absf(i))) + Stab_Scale = U_star**2 / ( VonKar * ( C_MO * BF_Stable / U_star - C_EK * U_star * absf(i))) ! Inverse of Ekman and Obukhov - iL_Ekman = absf(i)/U_star - iL_Obukhov = buoy_flux(i,j)*vonkar/U_Star**3 + iL_Ekman = absf(i) / U_star + iL_Obukhov = buoy_flux(i,j)*vonkar / (U_star**3) + if (CS%USE_LT) then + Ekman_o_Obukhov_stab = abs(max(0., iL_Obukhov / (iL_Ekman + 1.e-10*US%Z_to_m))) + Ekman_o_Obukhov_un = abs(min(0., iL_Obukhov / (iL_Ekman + 1.e-10*US%Z_to_m))) + !### Consider recoding this as... + ! Max_ratio = 1.0e16 + ! Ekman_Obukhov = Max_ratio + ! if (abs(buoy_flux(i,j)*vonkar) < Max_ratio*(absf(i) * U_star**2)) & + ! Ekman_Obukhov = buoy_flux(i,j)*vonkar / (absf(i) * U_star**2) + ! if (buoy_flux(i,j) > 0.0) then + ! Ekman_o_Obukhov_stab = Ekman_Obukhov ; Ekman_o_Obukhov_un = 0.0 + ! else + ! Ekman_o_Obukhov_un = Ekman_Obukhov ; Ekman_o_Obukhov_stab = 0.0 + ! endif + endif if (CS%Mstar_Mode == CS%CONST_MSTAR) then - mech_TKE(i) = (dt*CS%mstar*GV%Rho0)*((U_Star**3)) + mech_TKE(i) = (dt*CS%mstar*GV%Rho0) * US%Z_to_m**3 * U_star**3 conv_PErel(i) = 0.0 if (CS%TKE_diagnostics) then @@ -723,16 +688,17 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & hb_hs(i,K) = h_bot * I_hs enddo - pres(i,1) = 0.0 + pres(i,1) = 0.0 ; pres_Z(i,1) = 0.0 do k=1,nz dMass = GV%H_to_kg_m2 * h(i,k) - dPres = GV%g_Earth * dMass + dPres = (GV%g_Earth*US%m_to_Z) * dMass ! This is equivalent to GV%H_to_Pa * h(i,k) dT_to_dPE(i,k) = (dMass * (pres(i,K) + 0.5*dPres)) * dSV_dT(i,j,k) dS_to_dPE(i,k) = (dMass * (pres(i,K) + 0.5*dPres)) * dSV_dS(i,j,k) - dT_to_dColHt(i,k) = dMass * dSV_dT(i,j,k) - dS_to_dColHt(i,k) = dMass * dSV_dS(i,j,k) + dT_to_dColHt(i,k) = dMass * US%m_to_Z * dSV_dT(i,j,k) + dS_to_dColHt(i,k) = dMass * US%m_to_Z * dSV_dS(i,j,k) pres(i,K+1) = pres(i,K) + dPres + pres_Z(i,K+1) = US%Z_to_m * pres(i,K+1) enddo ! endif ; enddo @@ -748,18 +714,18 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & !/The following lines are for the iteration over MLD !{ ! max_MLD will initialized as ocean bottom depth - max_MLD = 0.0 ; do k=1,nz ; max_MLD = max_MLD + h(i,k)*GV%H_to_m ; enddo + max_MLD = 0.0 ; do k=1,nz ; max_MLD = max_MLD + h(i,k)*GV%H_to_Z ; enddo min_MLD = 0.0 !min_MLD will initialize as 0. !/BGR: May add user-input bounds for max/min MLD !/BGR: Add MLD_guess based on stored previous value. ! note that this is different from ML_Depth already ! computed by EPBL, need to figure out why. - if (CS%MLD_iteration_guess .and. CS%ML_Depth2(i,j) > 1.) then + if (CS%MLD_iteration_guess .and. (CS%ML_Depth2(i,j) > 1.0*US%m_to_Z)) then !If prev value is present use for guess. - MLD_guess=CS%ML_Depth2(i,j) + MLD_guess = CS%ML_Depth2(i,j) else - !Otherwise guess middle of water column (or stab_scale if smaller). + !Otherwise guess middle of water column (or Stab_Scale if smaller). MLD_guess = 0.5 * (min_MLD+max_MLD) endif @@ -772,16 +738,18 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & do OBL_IT=1,MAX_OBL_IT ; if (.not. OBL_CONVERGED) then ! Reset ML_depth - CS%ML_depth(i,j) = h(i,1)*GV%H_to_m - !CS%ML_depth2(i,j) = h(i,1)*GV%H_to_m + CS%ML_depth(i,j) = h(i,1)*GV%H_to_Z + !CS%ML_depth2(i,j) = h(i,1)*GV%H_to_Z sfc_connected(i) = .true. - if (CS%Mstar_Mode.gt.0) then + if (CS%Mstar_Mode > 0) then ! Note the value of mech_TKE(i) now must be iterated over, so it is moved here ! First solve for the TKE to PE length scale if (CS%MSTAR_MODE == CS%MLD_o_OBUKHOV) then MLD_over_Stab = MLD_guess / Stab_Scale - CS%MSTAR_XINT + !### MLD_over_Stab = (MLD_guess * (VonKar * (C_MO*BF_Stable - C_EK*U_star**2*absf(i)))) / & + !### U_star**3 - CS%MSTAR_XINT if ((MLD_over_Stab) <= 0.0) then !Asymptote to 0 as MLD_over_Stab -> -infinity (always) MSTAR_mix = (CS%MSTAR_B*(MLD_over_Stab)+CS%MSTAR_A)**(CS%MSTAR_N) @@ -805,42 +773,36 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & endif elseif (CS%MSTAR_MODE == CS%EKMAN_o_OBUKHOV) then !### Please refrain from using the construct A / B / C in place of A/(B*C). - mstar_STAB = CS%MSTAR_COEF*sqrt(Bf_Stable/u_star**2/(absf(i)+1.e-10)) - mstar_ROT = CS%C_EK*log(max(1.,u_star/(absf(i)+1.e-10)/mld_guess)) - if ( CS%MSTAR_CAP <= 0.0) then !No cap. - MSTAR_MIX = max(mstar_STAB,& ! 1st term if balance of rotation and stabilizing - ! the balance is f(L_Ekman,L_Obukhov) - min(& ! 2nd term for forced stratification limited - 1.25,& !.5/von Karman (Obukhov limit) - ! 3rd term for rotation (Ekman length) limited - mstar_ROT)) - else - MSTAR_MIX = min( & ! Sets a cap. The cap should be large and just - ! meant to be a safety net. - CS%MSTAR_CAP, & - max(mstar_STAB,& ! 1st term if balance of rotation and stabilizing - ! the balance is f(L_Ekman,L_Obukhov) - min(& ! 2nd term for forced stratification limited - 1.25,& !.5/von Karman (Obukhov limit) - ! 3rd term for rotation (Ekman length) limited - mstar_ROT))) - endif!cap for mstar_mode==2 + ! The limit for the balance of rotation and stabilizing is f(L_Ekman,L_Obukhov) + mstar_STAB = CS%MSTAR_COEF*sqrt(Bf_Stable / U_star**2 / (absf(i)+1.e-10)) + !### Should be mstar_STAB = CS%MSTAR_COEF*sqrt(Bf_Stable / (U_star**2 * (absf(i)+1.e-10))) + ! The limit for rotation (Ekman length) limited mixin + mstar_ROT = CS%C_EK * log(max(1., U_star / (absf(i)+1.e-10) / MLD_guess)) + !### Consider rewriting the expression for mstar_ROT as: + ! mstar_Rot = 0.0 + ! if (Ustar > absf(i) * MLD_guess) & + ! 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 ! Adjustment for unstable buoyancy flux. ! Convection reduces mechanical mixing because there ! is less density gradient to mix. (Statically unstable near surface) - MSTAR_Conv_Adj = 1. - CS%CNV_MST_FAC * (-BF_Unstable+1.e-10) / & - ( (-Bf_Unstable+1.e-10)+ & - 2. *MSTAR_MIX *U_STAR**3 / MLD_GUESS ) + MSTAR_Conv_Adj = 1. - CS%CNV_MST_FAC * (-BF_Unstable + 1.e-10*US%m_to_Z**2) / & + ( (-Bf_Unstable + 1.e-10*US%m_to_Z**2) + & + 2.0 *MSTAR_MIX * U_star**3 / MLD_guess ) + ! MSTAR_Conv_Adj = 1. - CS%CNV_MST_FAC * ((-BF_Unstable + 1.e-10*US%m_to_Z**2)*MLD_guess) / & + ! ( (-Bf_Unstable + 1.e-10*US%m_to_Z**2)*MLD_guess + & + ! 2.0*MSTAR_MIX * U_star**3 ) if (CS%USE_LT) then - call get_Langmuir_Number( LA, G, GV, abs(MLD_guess), u_star_mean, I, J, & + call get_Langmuir_Number( LA, G, GV, US, abs(MLD_guess), u_star_mean, i, j, & H=H(i,:), U_H=U(i,:), V_H=V(i,:), WAVES=WAVES) ! 2. Get parameters for modified LA - MLD_o_Ekman = abs(MLD_guess*iL_Ekman) - MLD_o_Obukhov_stab = abs(max(0.,MLD_guess*iL_Obukhov)) - MLD_o_Obukhov_un = abs(min(0.,MLD_guess*iL_Obukhov)) - Ekman_o_Obukhov_stab = abs(max(0.,iL_Obukhov/(iL_Ekman+1.e-10))) - Ekman_o_Obukhov_un = abs(min(0.,iL_Obukhov/(iL_Ekman+1.e-10))) + MLD_o_Ekman = abs(MLD_guess * iL_Ekman) + MLD_o_Obukhov_stab = abs(max(0., MLD_guess*iL_Obukhov)) + MLD_o_Obukhov_un = abs(min(0., MLD_guess*iL_Obukhov)) ! 3. Adjust LA based on various parameters. ! Assumes linear factors based on length scale ratios to adjust LA ! Note when these coefficients are set to 0 recovers simple LA. @@ -852,10 +814,10 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & if (CS%LT_Enhance_Form==1) then !Original w'/ust scaling w/ Van Roekel et al. 2012 scaling ! NOTE we know now that this is not the right way to scale M. - ENHANCE_M = (1+(1.4*LA)**(-2)+(5.4*LA)**(-4))**(1.5) + ENHANCE_M = (1. + (1.4*LA)**(-2) + (5.4*LA)**(-4))**(1.5) elseif (CS%LT_Enhance_Form==2) then ! Enhancement is multiplied (added mst_lt set to 0) - ENHANCE_M = min(CS%Max_Enhance_M,(1.+CS%LT_ENHANCE_COEF*LAmod**CS%LT_ENHANCE_EXP)) + ENHANCE_M = min(CS%Max_Enhance_M, (1. + CS%LT_ENHANCE_COEF*LAmod**CS%LT_ENHANCE_EXP)) MSTAR_LT = 0.0 elseif (CS%LT_ENHANCE_Form == 3) then ! or Enhancement is additive (multiplied enhance_m set to 1) @@ -864,7 +826,8 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & endif endif !Reset mech_tke and conv_perel values (based on new mstar) - mech_TKE(i) = ( MSTAR_mix * MSTAR_conv_adj * ENHANCE_M + MSTAR_LT) * (dt*GV%Rho0*U_Star**3) + mech_TKE(i) = ( MSTAR_mix * MSTAR_conv_adj * ENHANCE_M + MSTAR_LT) * & + US%Z_to_m**3 * (dt*GV%Rho0*U_star**3) conv_PErel(i) = 0.0 if (CS%TKE_diagnostics) then CS%diag_TKE_wind(i,j) = CS%diag_TKE_wind(i,j) + mech_TKE(i) * IdtdR0 @@ -915,7 +878,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & I_MLD = 1.0 / MLD_guess ; h_rsum = 0.0 MixLen_shape(1) = 1.0 do K=2,nz+1 - h_rsum = h_rsum + h(i,k-1)*GV%H_to_m + h_rsum = h_rsum + h(i,k-1)*GV%H_to_Z if (CS%MixLenExponent==2.0)then MixLen_shape(K) = CS%transLay_scale + (1.0 - CS%transLay_scale) * & (max(0.0, (MLD_guess - h_rsum)*I_MLD) )**2!CS%MixLenExponent @@ -947,7 +910,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & ! different rates. The following form is often used for mechanical ! stirring from the surface, perhaps due to breaking surface gravity ! waves and wind-driven turbulence. - Idecay_len_TKE(i) = (CS%TKE_decay * absf(i) / U_Star) * GV%H_to_m + Idecay_len_TKE(i) = (CS%TKE_decay * absf(i) / U_star) * GV%H_to_Z exp_kh = 1.0 if (Idecay_len_TKE(i) > 0.0) exp_kh = exp(-h(i,k-1)*Idecay_len_TKE(i)) if (CS%TKE_diagnostics) & @@ -1018,7 +981,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & dSe_t2 = Kddt_h(K-1) * ((S0(k-2) - S0(k-1)) + dSe(k-2)) endif endif - dt_h = (GV%m_to_H**2*dt) / max(0.5*(h(i,k-1)+h(i,k)), 1e-15*h_sum(i)) + dt_h = (GV%Z_to_H**2*dt) / max(0.5*(h(i,k-1)+h(i,k)), 1e-15*h_sum(i)) ! This tests whether the layers above and below this interface are in ! a convetively stable configuration, without considering any effects of @@ -1108,13 +1071,13 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & 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 - hbs_here = GV%H_to_m * min(hb_hs(i,K), MixLen_shape(K)) - Mixing_Length_Used(k) = MAX(CS%min_mix_len,((h_tt*hbs_here)*vstar) / & + 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)) !Note setting Kd_guess0 to Mixing_Length_Used(K) here will ! change the answers. Therefore, skipping that. if (.not.CS%Use_MLD_Iteration) then - Kd_guess0 = vstar * vonKar * ((h_tt*hbs_here)*vstar) / & + Kd_guess0 = vstar * vonKar * ((h_tt*hbs_here)*vstar) / & ((CS%Ekman_scale_coef * absf(i)) * (h_tt*hbs_here) + vstar) else Kd_guess0 = vstar * vonKar * Mixing_Length_Used(k) @@ -1129,7 +1092,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & call find_PE_chg_orig(Kddt_h_g0, h(i,k), hp_a(i), dTe_term, dSe_term, & dT_km1_t2, dS_km1_t2, dT_to_dPE(i,k), dS_to_dPE(i,k), & dT_to_dPE_a(i,k-1), dS_to_dPE_a(i,k-1), & - pres(i,K), dT_to_dColHt(i,k), dS_to_dColHt(i,k), & + pres_Z(i,K), dT_to_dColHt(i,k), dS_to_dColHt(i,k), & dT_to_dColHt_a(i,k-1), dS_to_dColHt_a(i,k-1), & PE_chg=PE_chg_g0, dPEc_dKd=dPEa_dKd_g0, dPE_max=PE_chg_max, & dPEc_dKd_0=dPEc_dKd_Kd0 ) @@ -1137,7 +1100,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & call find_PE_chg(0.0, Kddt_h_g0, hp_a(i), h(i,k), & Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & dT_to_dPE_a(i,k-1), dS_to_dPE_a(i,k-1), dT_to_dPE(i,k), dS_to_dPE(i,k), & - pres(i,K), dT_to_dColHt_a(i,k-1), dS_to_dColHt_a(i,k-1), & + pres_Z(i,K), dT_to_dColHt_a(i,k-1), dS_to_dColHt_a(i,k-1), & dT_to_dColHt(i,k), dS_to_dColHt(i,k), & PE_chg=PE_chg_g0, dPEc_dKd=dPEa_dKd_g0, dPE_max=PE_chg_max, & dPEc_dKd_0=dPEc_dKd_Kd0 ) @@ -1145,7 +1108,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & MKE_src = dMKE_max*(1.0 - exp(-Kddt_h_g0 * MKE2_Hharm)) - if (pe_chg_g0 .gt. 0.0) then + if (pe_chg_g0 > 0.0) then !Negative buoyancy (increases PE) N2_dissipation = 1.+CS%N2_DISSIPATION_SCALE_NEG else @@ -1160,16 +1123,16 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & 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 - hbs_here = GV%H_to_m * min(hb_hs(i,K), MixLen_shape(K)) + 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)) if (.not.CS%Use_MLD_Iteration) then ! Note again (as prev) that using Mixing_Length_Used here ! instead of redoing the computation will change answers... - Kd(i,k) = vstar * vonKar * ((h_tt*hbs_here)*vstar) / & + Kd(i,k) = vstar * vonKar * ((h_tt*hbs_here)*vstar) / & ((CS%Ekman_scale_coef * absf(i)) * (h_tt*hbs_here) + vstar) else - Kd(i,k) = vstar * vonKar * Mixing_Length_Used(k) + Kd(i,k) = vstar * vonKar * Mixing_Length_Used(k) endif else vstar = 0.0 ; Kd(i,k) = 0.0 @@ -1180,14 +1143,14 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & call find_PE_chg_orig(Kd(i,k)*dt_h, h(i,k), hp_a(i), dTe_term, dSe_term, & dT_km1_t2, dS_km1_t2, dT_to_dPE(i,k), dS_to_dPE(i,k), & dT_to_dPE_a(i,k-1), dS_to_dPE_a(i,k-1), & - pres(i,K), dT_to_dColHt(i,k), dS_to_dColHt(i,k), & + pres_Z(i,K), dT_to_dColHt(i,k), dS_to_dColHt(i,k), & dT_to_dColHt_a(i,k-1), dS_to_dColHt_a(i,k-1), & PE_chg=dPE_conv) else call find_PE_chg(0.0, Kd(i,k)*dt_h, hp_a(i), h(i,k), & Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & dT_to_dPE_a(i,k-1), dS_to_dPE_a(i,k-1), dT_to_dPE(i,k), dS_to_dPE(i,k), & - pres(i,K), dT_to_dColHt_a(i,k-1), dS_to_dColHt_a(i,k-1), & + pres_Z(i,K), dT_to_dColHt_a(i,k-1), dS_to_dColHt_a(i,k-1), & dT_to_dColHt(i,k), dS_to_dColHt(i,k), & PE_chg=dPE_conv) endif @@ -1208,8 +1171,8 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & dTKE_MKE = dTKE_MKE + MKE_src * IdtdR0 endif if (sfc_connected(i)) then - CS%ML_depth(i,J) = CS%ML_depth(i,J) + GV%H_to_m * h(i,k) - !CS%ML_depth2(i,j) = CS%ML_depth2(i,J) + GV%H_to_m * h(i,k) + CS%ML_depth(i,J) = CS%ML_depth(i,J) + GV%H_to_Z * h(i,k) + ! CS%ML_depth2(i,j) = CS%ML_depth2(i,J) + GV%H_to_Z * h(i,k) endif Kddt_h(K) = Kd(i,k)*dt_h @@ -1233,8 +1196,8 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & mech_TKE(i) = TKE_reduc*(mech_TKE(i) + MKE_src) conv_PErel(i) = TKE_reduc*conv_PErel(i) if (sfc_connected(i)) then - CS%ML_depth(i,J) = CS%ML_depth(i,J) + GV%H_to_m * h(i,k) - !CS%ML_depth2(i,J) = CS%ML_depth2(i,J) + GV%H_to_m * h(i,k) + CS%ML_depth(i,J) = CS%ML_depth(i,J) + GV%H_to_Z * h(i,k) + ! CS%ML_depth2(i,J) = CS%ML_depth2(i,J) + GV%H_to_Z * h(i,k) endif elseif (tot_TKE == 0.0) then ! This can arise if nstar_FC = 0. @@ -1245,7 +1208,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & ! There is not enough energy to support the mixing, so reduce the ! diffusivity to what can be supported. Kddt_h_max = Kddt_h_g0 ; Kddt_h_min = 0.0 - TKE_left_max = tot_TKE + (MKE_src - N2_DISSIPATION*PE_chg_g0) ; + TKE_left_max = tot_TKE + (MKE_src - N2_DISSIPATION*PE_chg_g0) TKE_left_min = tot_TKE ! As a starting guess, take the minimum of a false position estimate @@ -1267,14 +1230,14 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & call find_PE_chg_orig(Kddt_h_guess, h(i,k), hp_a(i), dTe_term, dSe_term, & dT_km1_t2, dS_km1_t2, dT_to_dPE(i,k), dS_to_dPE(i,k), & dT_to_dPE_a(i,k-1), dS_to_dPE_a(i,k-1), & - pres(i,K), dT_to_dColHt(i,k), dS_to_dColHt(i,k), & + pres_Z(i,K), dT_to_dColHt(i,k), dS_to_dColHt(i,k), & dT_to_dColHt_a(i,k-1), dS_to_dColHt_a(i,k-1), & PE_chg=PE_chg, dPEc_dKd=dPEc_dKd ) else call find_PE_chg(0.0, Kddt_h_guess, hp_a(i), h(i,k), & Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & dT_to_dPE_a(i,k-1), dS_to_dPE_a(i,k-1), dT_to_dPE(i,k), dS_to_dPE(i,k), & - pres(i,K), dT_to_dColHt_a(i,k-1), dS_to_dColHt_a(i,k-1), & + pres_Z(i,K), dT_to_dColHt_a(i,k-1), dS_to_dColHt_a(i,k-1), & dT_to_dColHt(i,k), dS_to_dColHt(i,k), & PE_chg=dPE_conv) endif @@ -1336,7 +1299,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & endif if (sfc_connected(i)) CS%ML_depth(i,J) = CS%ML_depth(i,J) + & - (PE_chg / PE_chg_g0) * GV%H_to_m * h(i,k) + (PE_chg / PE_chg_g0) * GV%H_to_Z * h(i,k) tot_TKE = 0.0 ; mech_TKE(i) = 0.0 ; conv_PErel(i) = 0.0 sfc_disconnect = .true. endif @@ -1420,18 +1383,18 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & ITmin(obl_it) = min_MLD ! Track min } For debug purpose ITguess(obl_it) = MLD_guess ! Track guess } !/ - MLD_FOUND=0.0 ; FIRST_OBL=.true. + MLD_found = 0.0 ; FIRST_OBL = .true. if (CS%Orig_MLD_iteration) then !This is how the iteration was original conducted do k=2,nz if (FIRST_OBL) then !Breaks when OBL found - if (Vstar_Used(k) > 1.e-10 .and. k < nz) then - MLD_FOUND = MLD_FOUND + h(i,k-1)*GV%H_to_m + if ((Vstar_Used(k) > 1.e-10*US%m_to_Z) .and. k < nz) then + MLD_found = MLD_found + h(i,k-1)*GV%H_to_Z else FIRST_OBL = .false. - if (MLD_FOUND-CS%MLD_tol > MLD_guess) then + if (MLD_found - CS%MLD_tol > MLD_guess) then min_MLD = MLD_guess - elseif ((MLD_guess-MLD_FOUND) < max(CS%MLD_tol,h(i,k-1)*GV%H_to_m)) then + elseif ((MLD_guess - MLD_found) < max(CS%MLD_tol,h(i,k-1)*GV%H_to_Z)) then OBL_CONVERGED = .true.!Break convergence loop if (OBL_IT_STATS) then !Compute iteration statistics MAXIT = max(MAXIT,obl_it) @@ -1449,10 +1412,10 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & enddo else !New method uses ML_DEPTH as computed in ePBL routine - MLD_FOUND=CS%ML_DEPTH(i,j) - if (MLD_FOUND-CS%MLD_tol > MLD_guess) then + MLD_found = CS%ML_Depth(i,j) + if (MLD_found - CS%MLD_tol > MLD_guess) then min_MLD = MLD_guess - elseif (abs(MLD_guess-MLD_FOUND) < (CS%MLD_tol)) then + elseif (abs(MLD_guess - MLD_found) < CS%MLD_tol) then OBL_CONVERGED = .true.!Break convergence loop if (OBL_IT_STATS) then !Compute iteration statistics MAXIT = max(MAXIT,obl_it) @@ -1467,8 +1430,8 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & endif endif ! For next pass, guess average of minimum and maximum values. - MLD_guess = min_MLD*0.5 + max_MLD*0.5 - ITresult(obl_it) = MLD_FOUND + MLD_guess = 0.5*(min_MLD + max_MLD) + ITresult(obl_it) = MLD_found endif ; enddo ! Iteration loop for converged boundary layer thickness. if (.not.OBL_CONVERGED) then !/Temp output, warn that EPBL didn't converge @@ -1511,13 +1474,13 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & if (allocated(CS%Enhance_M)) CS%Enhance_M(i,j) = Enhance_M if (allocated(CS%mstar_mix)) CS%mstar_mix(i,j) = MSTAR_MIX if (allocated(CS%mstar_lt)) CS%mstar_lt(i,j) = MSTAR_LT - if (allocated(CS%MLD_Obukhov)) CS%MLD_Obukhov(i,j) = (MLD_guess*iL_Obukhov) - if (allocated(CS%MLD_Ekman)) CS%MLD_Ekman(i,j) = (MLD_guess*iL_Ekman) - if (allocated(CS%Ekman_Obukhov)) CS%Ekman_Obukhov(i,j) = (iL_Obukhov/(iL_Ekman+1.e-10)) + if (allocated(CS%MLD_Obukhov)) CS%MLD_Obukhov(i,j) = MLD_guess * iL_Obukhov + if (allocated(CS%MLD_Ekman)) CS%MLD_Ekman(i,j) = MLD_guess * iL_Ekman + if (allocated(CS%Ekman_Obukhov)) CS%Ekman_Obukhov(i,j) = iL_Obukhov / (iL_Ekman + 1.e-10*US%Z_to_m) if (allocated(CS%La)) CS%La(i,j) = LA if (allocated(CS%La_mod)) CS%La_mod(i,j) = LAmod - else - ! For masked points, Kd_int must still be set (to 0) because it has intent(out). + else ! End of the ocean-point part of the i-loop + ! For masked points, Kd_int must still be set (to 0) because it has intent out. do K=1,nz+1 Kd(i,K) = 0. enddo @@ -1527,12 +1490,12 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & if (present(dS_expected)) then do k=1,nz ; dS_expected(i,j,k) = 0.0 ; enddo endif - endif ; enddo ; ! Close of i-loop - Note unusual loop order! + endif ; enddo ! Close of i-loop - Note unusual loop order! if (CS%id_Hsfc_used > 0) then - do i=is,ie ; Hsfc_used(i,j) = h(i,1)*GV%H_to_m ; enddo + do i=is,ie ; Hsfc_used(i,j) = h(i,1)*GV%H_to_Z ; enddo do k=2,nz ; do i=is,ie - if (Kd(i,K) > 0.0) Hsfc_used(i,j) = Hsfc_used(i,j) + h(i,k)*GV%H_to_m + if (Kd(i,K) > 0.0) Hsfc_used(i,j) = Hsfc_used(i,j) + h(i,k)*GV%H_to_Z enddo ; enddo endif @@ -1591,92 +1554,92 @@ end subroutine energetic_PBL !! for several changes in an interfaces's diapycnal diffusivity times a timestep. subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & dT_to_dPE_a, dS_to_dPE_a, dT_to_dPE_b, dS_to_dPE_b, & - pres, dT_to_dColHt_a, dS_to_dColHt_a, dT_to_dColHt_b, dS_to_dColHt_b, & + pres_Z, dT_to_dColHt_a, dS_to_dColHt_a, dT_to_dColHt_b, dS_to_dColHt_b, & PE_chg, dPEc_dKd, dPE_max, dPEc_dKd_0, ColHt_cor) real, intent(in) :: Kddt_h0 !< The previously used diffusivity at an interface times !! the time step and divided by the average of the - !! thicknesses around the interface, in units of H (m or kg-2). + !! thicknesses around the interface [H ~> m or kg m-2]. real, intent(in) :: dKddt_h !< The trial change in the diffusivity at an interface times !! the time step and divided by the average of the - !! thicknesses around the interface, in units of H (m or kg-2). + !! thicknesses around the interface [H ~> m or kg m-2]. real, intent(in) :: hp_a !< The effective pivot thickness of the layer above the !! interface, given by h_k plus a term that !! is a fraction (determined from the tridiagonal solver) of - !! Kddt_h for the interface above, in H. + !! Kddt_h for the interface above [H ~> m or kg m-2]. real, intent(in) :: hp_b !< The effective pivot thickness of the layer below the !! interface, given by h_k plus a term that !! is a fraction (determined from the tridiagonal solver) of - !! Kddt_h for the interface above, in H. + !! Kddt_h for the interface above [H ~> m or kg m-2]. real, intent(in) :: Th_a !< An effective temperature times a thickness in the layer !! above, including implicit mixing effects with other - !! yet higher layers, in K H. + !! yet higher layers [degC H ~> degC m or degC kg m-2]. real, intent(in) :: Sh_a !< An effective salinity times a thickness in the layer !! above, including implicit mixing effects with other - !! yet higher layers, in K H. + !! yet higher layers [degC H ~> degC m or degC kg m-2]. real, intent(in) :: Th_b !< An effective temperature times a thickness in the layer !! below, including implicit mixing effects with other - !! yet lower layers, in K H. + !! yet lower layers [degC H ~> degC m or degC kg m-2]. real, intent(in) :: Sh_b !< An effective salinity times a thickness in the layer !! below, including implicit mixing effects with other - !! yet lower layers, in K H. + !! yet lower layers [degC H ~> degC m or degC kg m-2]. real, intent(in) :: dT_to_dPE_a !< A factor (pres_lay*mass_lay*dSpec_vol/dT) relating !! a layer's temperature change to the change in column !! potential energy, including all implicit diffusive changes - !! in the temperatures of all the layers above, in J m-2 K-1. + !! in the temperatures of all the layers above [J m-2 degC-1]. real, intent(in) :: dS_to_dPE_a !< A factor (pres_lay*mass_lay*dSpec_vol/dS) relating !! a layer's salinity change to the change in column !! potential energy, including all implicit diffusive changes - !! in the salinities of all the layers above, in J m-2 ppt-1. + !! in the salinities of all the layers above [J m-2 ppt-1]. real, intent(in) :: dT_to_dPE_b !< A factor (pres_lay*mass_lay*dSpec_vol/dT) relating !! a layer's temperature change to the change in column !! potential energy, including all implicit diffusive changes - !! in the temperatures of all the layers below, in J m-2 K-1. + !! in the temperatures of all the layers below [J m-2 degC-1]. real, intent(in) :: dS_to_dPE_b !< A factor (pres_lay*mass_lay*dSpec_vol/dS) relating !! a layer's salinity change to the change in column !! potential energy, including all implicit diffusive changes - !! in the salinities of all the layers below, in J m-2 ppt-1. - real, intent(in) :: pres !< The hydrostatic interface pressure, which is used to relate + !! in the salinities of all the layers below [J m-2 ppt-1]. + real, intent(in) :: pres_Z !< The rescaled hydrostatic interface pressure, which relates !! the changes in column thickness to the energy that is radiated - !! as gravity waves and unavailable to drive mixing, in Pa. + !! as gravity waves and unavailable to drive mixing [J m-2 Z-1 ~> J m-3]. real, intent(in) :: dT_to_dColHt_a !< A factor (mass_lay*dSColHtc_vol/dT) relating !! a layer's temperature change to the change in column !! height, including all implicit diffusive changes - !! in the temperatures of all the layers above, in m K-1. + !! in the temperatures of all the layers above [Z degC-1 ~> m degC-1]. real, intent(in) :: dS_to_dColHt_a !< A factor (mass_lay*dSColHtc_vol/dS) relating !! a layer's salinity change to the change in column !! height, including all implicit diffusive changes - !! in the salinities of all the layers above, in m ppt-1. + !! in the salinities of all the layers above [Z ppt-1 ~> m ppt-1]. real, intent(in) :: dT_to_dColHt_b !< A factor (mass_lay*dSColHtc_vol/dT) relating !! a layer's temperature change to the change in column !! height, including all implicit diffusive changes - !! in the temperatures of all the layers below, in m K-1. + !! in the temperatures of all the layers below [Z degC-1 ~> m degC-1]. real, intent(in) :: dS_to_dColHt_b !< A factor (mass_lay*dSColHtc_vol/dS) relating !! a layer's salinity change to the change in column !! height, including all implicit diffusive changes - !! in the salinities of all the layers below, in m ppt-1. + !! in the salinities of all the layers below [Z ppt-1 ~> m ppt-1]. real, optional, intent(out) :: PE_chg !< The change in column potential energy from applying - !! Kddt_h at the present interface, in J m-2. - real, optional, intent(out) :: dPEc_dKd !< The partial derivative of PE_chg with Kddt_h, - !! in units of J m-2 H-1. + !! Kddt_h at the present interface [J m-2]. + real, optional, intent(out) :: dPEc_dKd !< The partial derivative of PE_chg with Kddt_h + !! [J m-2 H-1 ~> J m-3 or J kg-1]. real, optional, intent(out) :: dPE_max !< The maximum change in column potential energy that could !! be realizedd by applying a huge value of Kddt_h at the - !! present interface, in J m-2. + !! present interface [J m-2]. real, optional, intent(out) :: dPEc_dKd_0 !< The partial derivative of PE_chg with Kddt_h in the - !! limit where Kddt_h = 0, in J m-2 H-1. + !! limit where Kddt_h = 0 [J m-2 H-1 ~> J m-3 or J kg-1]. real, optional, intent(out) :: ColHt_cor !< The correction to PE_chg that is made due to a net - !! change in the column height, in J m-2. + !! change in the column height [J m-2]. - real :: hps ! The sum of the two effective pivot thicknesses, in H. - real :: bdt1 ! A product of the two pivot thicknesses plus a diffusive term, in H2. - real :: dT_c ! The core term in the expressions for the temperature changes, in K H2. - real :: dS_c ! The core term in the expressions for the salinity changes, in psu H2. + real :: hps ! The sum of the two effective pivot thicknesses [H ~> m or kg m-2]. + real :: bdt1 ! A product of the two pivot thicknesses plus a diffusive term [H2 ~> m2 or kg2 m-4]. + real :: dT_c ! The core term in the expressions for the temperature changes [degC H2 ~> degC m2 or degC kg2 m-4]. + real :: dS_c ! The core term in the expressions for the salinity changes [ppt H2 ~> ppt m2 or ppt kg2 m-4]. real :: PEc_core ! The diffusivity-independent core term in the expressions - ! for the potential energy changes, J m-3. + ! for the potential energy changes [J m-3]. real :: ColHt_core ! The diffusivity-independent core term in the expressions - ! for the column height changes, J m-3. - real :: ColHt_chg ! The change in the column height, in m. - real :: y1 ! A local temporary term, in units of H-3 or H-4 in various contexts. + ! for the column height changes [J m-3]. + real :: ColHt_chg ! The change in the column height [H ~> m or kg m-2]. + real :: y1 ! A local temporary term, [H-3 ~> m-3 or m6 kg-3] or [H-4 ~> m-4 or m8 kg-4] in various contexts. ! The expression for the change in potential energy used here is derived ! from the expression for the final estimates of the changes in temperature @@ -1701,11 +1664,11 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & y1 = dKddt_h / (bdt1 * (bdt1 + dKddt_h * hps)) PE_chg = PEc_core * y1 ColHt_chg = ColHt_core * y1 - if (ColHt_chg < 0.0) PE_chg = PE_chg - pres * ColHt_chg - if (present(ColHt_cor)) ColHt_cor = -pres * min(ColHt_chg, 0.0) - else if (present(ColHt_cor)) then + if (ColHt_chg < 0.0) PE_chg = PE_chg - pres_Z * ColHt_chg + if (present(ColHt_cor)) ColHt_cor = -pres_Z * min(ColHt_chg, 0.0) + elseif (present(ColHt_cor)) then y1 = dKddt_h / (bdt1 * (bdt1 + dKddt_h * hps)) - ColHt_cor = -pres * min(ColHt_core * y1, 0.0) + ColHt_cor = -pres_Z * min(ColHt_core * y1, 0.0) endif if (present(dPEc_dKd)) then @@ -1713,7 +1676,7 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & y1 = 1.0 / (bdt1 + dKddt_h * hps)**2 dPEc_dKd = PEc_core * y1 ColHt_chg = ColHt_core * y1 - if (ColHt_chg < 0.0) dPEc_dKd = dPEc_dKd - pres * ColHt_chg + if (ColHt_chg < 0.0) dPEc_dKd = dPEc_dKd - pres_Z * ColHt_chg endif if (present(dPE_max)) then @@ -1721,7 +1684,7 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & y1 = 1.0 / (bdt1 * hps) dPE_max = PEc_core * y1 ColHt_chg = ColHt_core * y1 - if (ColHt_chg < 0.0) dPE_max = dPE_max - pres * ColHt_chg + if (ColHt_chg < 0.0) dPE_max = dPE_max - pres_Z * ColHt_chg endif if (present(dPEc_dKd_0)) then @@ -1729,7 +1692,7 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & y1 = 1.0 / bdt1**2 dPEc_dKd_0 = PEc_core * y1 ColHt_chg = ColHt_core * y1 - if (ColHt_chg < 0.0) dPEc_dKd_0 = dPEc_dKd_0 - pres * ColHt_chg + if (ColHt_chg < 0.0) dPEc_dKd_0 = dPEc_dKd_0 - pres_Z * ColHt_chg endif end subroutine find_PE_chg @@ -1739,70 +1702,70 @@ end subroutine find_PE_chg !! using the original form used in the first version of ePBL. subroutine find_PE_chg_orig(Kddt_h, h_k, b_den_1, dTe_term, dSe_term, & dT_km1_t2, dS_km1_t2, dT_to_dPE_k, dS_to_dPE_k, & - dT_to_dPEa, dS_to_dPEa, pres, dT_to_dColHt_k, & + dT_to_dPEa, dS_to_dPEa, pres_Z, dT_to_dColHt_k, & dS_to_dColHt_k, dT_to_dColHta, dS_to_dColHta, & PE_chg, dPEc_dKd, dPE_max, dPEc_dKd_0) real, intent(in) :: Kddt_h !< The diffusivity at an interface times the time step and !! divided by the average of the thicknesses around the - !! interface, in units of H (m or kg-2). - real, intent(in) :: h_k !< The thickness of the layer below the interface, in H. + !! interface [H ~> m or kg m-2]. + real, intent(in) :: h_k !< The thickness of the layer below the interface [H ~> m or kg m-2]. real, intent(in) :: b_den_1 !< The first term in the denominator of the pivot !! for the tridiagonal solver, given by h_k plus a term that !! is a fraction (determined from the tridiagonal solver) of - !! Kddt_h for the interface above, in H. - real, intent(in) :: dTe_term !< A diffusivity-independent term related to the - !! temperature change in the layer below the interface, in K H. - real, intent(in) :: dSe_term !< A diffusivity-independent term related to the - !! salinity change in the layer below the interface, in ppt H. + !! Kddt_h for the interface above [H ~> m or kg m-2]. + real, intent(in) :: dTe_term !< A diffusivity-independent term related to the temperature change + !! in the layer below the interface [degC H ~> degC m or degC kg m-2]. + real, intent(in) :: dSe_term !< A diffusivity-independent term related to the salinity change + !! in the layer below the interface [ppt H ~> ppt m or ppt kg m-2]. real, intent(in) :: dT_km1_t2 !< A diffusivity-independent term related to the - !! temperature change in the layer above the interface, in K. + !! temperature change in the layer above the interface [degC]. real, intent(in) :: dS_km1_t2 !< A diffusivity-independent term related to the - !! salinity change in the layer above the interface, in ppt. - real, intent(in) :: pres !< The hydrostatic interface pressure, which is used to relate + !! salinity change in the layer above the interface [ppt]. + real, intent(in) :: pres_Z !< The rescaled hydrostatic interface pressure, which relates !! the changes in column thickness to the energy that is radiated - !! as gravity waves and unavailable to drive mixing, in Pa. + !! as gravity waves and unavailable to drive mixing [J m-2 Z-1 ~> J m-3]. real, intent(in) :: dT_to_dPE_k !< A factor (pres_lay*mass_lay*dSpec_vol/dT) relating !! a layer's temperature change to the change in column !! potential energy, including all implicit diffusive changes - !! in the temperatures of all the layers below, in J m-2 K-1. + !! in the temperatures of all the layers below [J m-2 degC-1]. real, intent(in) :: dS_to_dPE_k !< A factor (pres_lay*mass_lay*dSpec_vol/dS) relating !! a layer's salinity change to the change in column !! potential energy, including all implicit diffusive changes - !! in the salinities of all the layers below, in J m-2 ppt-1. + !! in the salinities of all the layers below [J m-2 ppt-1]. real, intent(in) :: dT_to_dPEa !< A factor (pres_lay*mass_lay*dSpec_vol/dT) relating !! a layer's temperature change to the change in column !! potential energy, including all implicit diffusive changes - !! in the temperatures of all the layers above, in J m-2 K-1. + !! in the temperatures of all the layers above [J m-2 degC-1]. real, intent(in) :: dS_to_dPEa !< A factor (pres_lay*mass_lay*dSpec_vol/dS) relating !! a layer's salinity change to the change in column !! potential energy, including all implicit diffusive changes - !! in the salinities of all the layers above, in J m-2 ppt-1. + !! in the salinities of all the layers above [J m-2 ppt-1]. real, intent(in) :: dT_to_dColHt_k !< A factor (mass_lay*dSColHtc_vol/dT) relating !! a layer's temperature change to the change in column !! height, including all implicit diffusive changes - !! in the temperatures of all the layers below, in m K-1. + !! in the temperatures of all the layers below [Z degC-1 ~> m degC-1]. real, intent(in) :: dS_to_dColHt_k !< A factor (mass_lay*dSColHtc_vol/dS) relating !! a layer's salinity change to the change in column !! height, including all implicit diffusive changes - !! in the salinities of all the layers below, in m ppt-1. + !! in the salinities of all the layers below [Z ppt-1 ~> m ppt-1]. real, intent(in) :: dT_to_dColHta !< A factor (mass_lay*dSColHtc_vol/dT) relating !! a layer's temperature change to the change in column !! height, including all implicit diffusive changes - !! in the temperatures of all the layers above, in m K-1. + !! in the temperatures of all the layers above [Z degC-1 ~> m degC-1]. real, intent(in) :: dS_to_dColHta !< A factor (mass_lay*dSColHtc_vol/dS) relating !! a layer's salinity change to the change in column !! height, including all implicit diffusive changes - !! in the salinities of all the layers above, in m ppt-1. + !! in the salinities of all the layers above [Z ppt-1 ~> m ppt-1]. real, optional, intent(out) :: PE_chg !< The change in column potential energy from applying - !! Kddt_h at the present interface, in J m-2. - real, optional, intent(out) :: dPEc_dKd !< The partial derivative of PE_chg with Kddt_h, - !! in units of J m-2 H-1. + !! Kddt_h at the present interface [J m-2]. + real, optional, intent(out) :: dPEc_dKd !< The partial derivative of PE_chg with Kddt_h + !! [J m-2 H-1 ~> J m-3 or J kg-1]. real, optional, intent(out) :: dPE_max !< The maximum change in column potential energy that could !! be realizedd by applying a huge value of Kddt_h at the - !! present interface, in J m-2. + !! present interface [J m-2]. real, optional, intent(out) :: dPEc_dKd_0 !< The partial derivative of PE_chg with Kddt_h in the - !! limit where Kddt_h = 0, in J m-2 H-1. + !! limit where Kddt_h = 0 [J m-2 H-1 ~> J m-3 or J kg-1]. ! This subroutine determines the total potential energy change due to mixing ! at an interface, including all of the implicit effects of the prescribed @@ -1813,16 +1776,17 @@ subroutine find_PE_chg_orig(Kddt_h, h_k, b_den_1, dTe_term, dSe_term, & ! this routine can also be used for an upward pass with the sense of direction ! reversed. - real :: b1 ! b1 is used by the tridiagonal solver, in H-1. - real :: b1Kd ! Temporary array (nondim.) - real :: ColHt_chg ! The change in column thickness in m. - real :: dColHt_max ! The change in column thickess for infinite diffusivity, in m. - real :: dColHt_dKd ! The partial derivative of column thickess with diffusivity, in s m-1. - real :: dT_k, dT_km1 ! Temporary arrays in K. - real :: dS_k, dS_km1 ! Temporary arrays in ppt. - real :: I_Kr_denom, dKr_dKd ! Temporary arrays in H-2 and nondim. - real :: ddT_k_dKd, ddT_km1_dKd ! Temporary arrays in K H-1. - real :: ddS_k_dKd, ddS_km1_dKd ! Temporary arrays in ppt H-1. + real :: b1 ! b1 is used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. + real :: b1Kd ! Temporary array [nondim] + real :: ColHt_chg ! The change in column thickness [Z ~> m]. + real :: dColHt_max ! The change in column thickness for infinite diffusivity [Z ~> m]. + real :: dColHt_dKd ! The partial derivative of column thickness with diffusivity [s Z-1 ~> s m-1]. + real :: dT_k, dT_km1 ! Temporary arrays [degC]. + real :: dS_k, dS_km1 ! Temporary arrays [ppt]. + real :: I_Kr_denom ! Temporary array [H-2 ~> m-2 or m4 kg-2] + real :: dKr_dKd ! Nondimensional temporary array. + real :: ddT_k_dKd, ddT_km1_dKd ! Temporary arrays [degC H-1 ~> m-1 or m2 kg-1]. + real :: ddS_k_dKd, ddS_km1_dKd ! Temporary arrays [ppt H-1 ~> ppt m-1 or ppt m2 kg-1]. b1 = 1.0 / (b_den_1 + Kddt_h) b1Kd = Kddt_h*b1 @@ -1846,7 +1810,7 @@ subroutine find_PE_chg_orig(Kddt_h, h_k, b_den_1, dTe_term, dSe_term, & (dS_to_dPE_k * dS_k + dS_to_dPEa * dS_km1) ColHt_chg = (dT_to_dColHt_k * dT_k + dT_to_dColHta * dT_km1) + & (dS_to_dColHt_k * dS_k + dS_to_dColHta * dS_km1) - if (ColHt_chg < 0.0) PE_chg = PE_chg - pres * ColHt_chg + if (ColHt_chg < 0.0) PE_chg = PE_chg - pres_Z * ColHt_chg endif if (present(dPEc_dKd)) then @@ -1863,7 +1827,7 @@ subroutine find_PE_chg_orig(Kddt_h, h_k, b_den_1, dTe_term, dSe_term, & (dS_to_dPE_k * ddS_k_dKd + dS_to_dPEa * ddS_km1_dKd) dColHt_dKd = (dT_to_dColHt_k * ddT_k_dKd + dT_to_dColHta * ddT_km1_dKd) + & (dS_to_dColHt_k * ddS_k_dKd + dS_to_dColHta * ddS_km1_dKd) - if (dColHt_dKd < 0.0) dPEc_dKd = dPEc_dKd - pres * dColHt_dKd + if (dColHt_dKd < 0.0) dPEc_dKd = dPEc_dKd - pres_Z * dColHt_dKd endif if (present(dPE_max)) then @@ -1874,7 +1838,7 @@ subroutine find_PE_chg_orig(Kddt_h, h_k, b_den_1, dTe_term, dSe_term, & dColHt_max = (dT_to_dColHta * dT_km1_t2 + dS_to_dColHta * dS_km1_t2) + & ((dT_to_dColHt_k + dT_to_dColHta) * dTe_term + & (dS_to_dColHt_k + dS_to_dColHta) * dSe_term) / (b_den_1 + h_k) - if (dColHt_max < 0.0) dPE_max = dPE_max - pres*dColHt_max + if (dColHt_max < 0.0) dPE_max = dPE_max - pres_Z*dColHt_max endif if (present(dPEc_dKd_0)) then @@ -1883,28 +1847,37 @@ subroutine find_PE_chg_orig(Kddt_h, h_k, b_den_1, dTe_term, dSe_term, & (dT_to_dPE_k * dTe_term + dS_to_dPE_k * dSe_term) / (h_k*b_den_1) dColHt_dKd = (dT_to_dColHta * dT_km1_t2 + dS_to_dColHta * dS_km1_t2) / (b_den_1) + & (dT_to_dColHt_k * dTe_term + dS_to_dColHt_k * dSe_term) / (h_k*b_den_1) - if (dColHt_dKd < 0.0) dPEc_dKd_0 = dPEc_dKd_0 - pres*dColHt_dKd + if (dColHt_dKd < 0.0) dPEc_dKd_0 = dPEc_dKd_0 - pres_Z*dColHt_dKd endif end subroutine find_PE_chg_orig !> Copies the ePBL active mixed layer depth into MLD -subroutine energetic_PBL_get_MLD(CS, MLD, G) +subroutine energetic_PBL_get_MLD(CS, MLD, G, US, m_to_MLD_units) type(energetic_PBL_CS), pointer :: CS !< Control structure for ePBL type(ocean_grid_type), intent(in) :: G !< Grid structure - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: MLD !< Depth of ePBL active mixing layer + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: MLD !< Depth of ePBL active mixing layer [m or other units] + real, optional, intent(in) :: m_to_MLD_units !< A conversion factor to the desired units for MLD ! Local variables + real :: scale ! A dimensional rescaling factor integer :: i,j - do j = G%jsc, G%jec ; do i = G%isc, G%iec - MLD(i,j) = CS%ML_depth(i,j) + + scale = US%Z_to_m ; if (present(m_to_MLD_units)) scale = scale * m_to_MLD_units + + do j=G%jsc,G%jec ; do i=G%isc,G%iec + MLD(i,j) = scale*CS%ML_Depth(i,j) enddo ; enddo + end subroutine energetic_PBL_get_MLD !> Computes wind speed from ustar_air based on COARE 3.5 Cd relationship -subroutine ust_2_u10_coare3p5(USTair,U10,GV) - real, intent(in) :: USTair - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, intent(out) :: U10 +subroutine ust_2_u10_coare3p5(USTair, U10, GV, US) + real, intent(in) :: USTair !< Ustar in the air [m s-1]. + 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, intent(out) :: U10 !< The 10 m wind speed [m s-1]. + real, parameter :: vonkar = 0.4 real, parameter :: nu=1e-6 real :: z0sm, z0, z0rough, u10a, alpha, CD @@ -1918,14 +1891,14 @@ subroutine ust_2_u10_coare3p5(USTair,U10,GV) z0sm = 0.11 * nu / USTair; !Compute z0smooth from ustar guess u10 = USTair/sqrt(0.001); !Guess for u10 - u10a = 1000; + u10a = 1000 CT=0 do while (abs(u10a/u10-1.)>0.001) CT=CT+1 u10a = u10 alpha = min(0.028,0.0017 * u10 - 0.005) - z0rough = alpha * USTair**2/GV%g_Earth ! Compute z0rough from ustar guess + z0rough = alpha * USTair**2/(GV%g_Earth*US%m_to_Z) ! Compute z0rough from ustar guess z0=z0sm+z0rough CD = ( vonkar / log(10/z0) )**2 ! Compute CD from derived roughness u10 = USTair/sqrt(CD);!Compute new u10 from derived CD, while loop @@ -1943,10 +1916,17 @@ subroutine ust_2_u10_coare3p5(USTair,U10,GV) return end subroutine ust_2_u10_coare3p5 -subroutine get_LA_windsea(ustar, hbl, GV, LA) +!> This subroutine returns the Langmuir number, given ustar and the boundary +!! layer thickness, inclusion conversion to the 10m wind. +subroutine get_LA_windsea(ustar, hbl, GV, US, LA) + real, intent(in) :: ustar !< The water-side surface friction velocity [m s-1] + real, intent(in) :: hbl !< The ocean boundary layer depth [m] + 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, intent(out) :: LA !< The Langmuir number returned from this module ! Original description: ! This function returns the enhancement factor, given the 10-meter -! wind (m/s), friction velocity (m/s) and the boundary layer depth (m). +! wind [m s-1], friction velocity [m s-1] and the boundary layer depth [m]. ! Update (Jan/25): ! Converted from function to subroutine, now returns Langmuir number. ! Computes 10m wind internally, so only ustar and hbl need passed to @@ -1958,13 +1938,6 @@ subroutine get_LA_windsea(ustar, hbl, GV, LA) ! BGR remove u10 input ! Input - real, intent(in) :: & - ! water-side surface friction velocity (m/s) - ustar, & - ! boundary layer depth (m) - hbl - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, intent(out) :: LA ! Local variables ! parameters real, parameter :: & @@ -1977,27 +1950,26 @@ subroutine get_LA_windsea(ustar, hbl, GV, LA) us_to_u10 = 0.0162, & ! loss ratio of Stokes transport r_loss = 0.667 - real :: us, hm0, fm, fp, vstokes, kphil, kstar + real :: uStokes, hm0, fm, fp, vstokes, kphil, kstar real :: z0, z0i, r1, r2, r3, r4, tmp, us_sl, lasl_sqr_i real :: pi, u10 pi = 4.0*atan(1.0) - if (ustar .gt. 0.0) then - ! Computing u10 based on u_star and COARE 3.5 relationships - call ust_2_u10_coare3p5(ustar*sqrt(GV%Rho0/1.225),U10,GV) + if (ustar > 0.0) then + ! Computing u10 based on ustar and COARE 3.5 relationships + call ust_2_u10_coare3p5(ustar * sqrt(GV%Rho0/1.225), U10, GV, US) ! surface Stokes drift - us = us_to_u10*u10 - ! - ! significant wave height from Pierson-Moskowitz - ! spectrum (Bouws, 1998) + uStokes = us_to_u10*u10 + + ! significant wave height from Pierson-Moskowitz spectrum (Bouws, 1998) hm0 = 0.0246 *u10**2 - ! + ! peak frequency (PM, Bouws, 1998) tmp = 2.0 * PI * u19p5_to_u10 * u10 - fp = 0.877 * GV%g_Earth / tmp - ! + fp = 0.877 * (GV%g_Earth*US%m_to_Z) / tmp + ! mean frequency fm = fm_to_fp * fp - ! + ! total Stokes transport (a factor r_loss is applied to account ! for the effect of directional spreading, multidirectional waves ! and the use of PM peak frequency and PM significant wave height @@ -2006,7 +1978,7 @@ subroutine get_LA_windsea(ustar, hbl, GV, LA) ! ! the general peak wavenumber for Phillips' spectrum ! (Breivik et al., 2016) with correction of directional spreading - kphil = 0.176 * us / vstokes + kphil = 0.176 * uStokes / vstokes ! ! surface layer averaged Stokes dirft with Stokes drift profile ! estimated from Phillips' spectrum (Breivik et al., 2016) @@ -2029,7 +2001,7 @@ subroutine get_LA_windsea(ustar, hbl, GV, LA) r4 = ( 0.125 + 0.0946 / kstar * z0i ) & *sqrt( 2.0 * PI *kstar * z0) & *erfc( sqrt( 2.0 * kstar * z0 ) ) - us_sl = us * (0.715 + r1 + r2 + r3 + r4) + us_sl = uStokes * (0.715 + r1 + r2 + r3 + r4) ! LA = sqrt(ustar / us_sl) else @@ -2037,23 +2009,19 @@ subroutine get_LA_windsea(ustar, hbl, GV, LA) endif endsubroutine Get_LA_windsea -subroutine energetic_PBL_init(Time, G, GV, param_file, diag, CS) - type(time_type), target, intent(in) :: Time +!> This subroutine initializes the energetic_PBL module +subroutine energetic_PBL_init(Time, G, GV, US, param_file, 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 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 - type(energetic_PBL_CS), pointer :: CS -! Arguments: Time - The current model time. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in) diag - A structure that is used to regulate diagnostic output. -! (in/out) CS - A pointer that is set to point to the control structure -! for this module -! This include declares and sets the variable "version". -#include "version_variable.h" + type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to regulate diagnostic output + type(energetic_PBL_CS), pointer :: CS !< A pointer that is set to point to the control + !! structure for this module + ! Local variables + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "MOM_energetic_PBL" ! This module's name. real :: omega_frac_dflt integer :: isd, ied, jsd, jed @@ -2161,7 +2129,7 @@ subroutine energetic_PBL_init(Time, G, GV, param_file, diag, CS) call get_param(param_file, mdl, "VSTAR_SCALE_FACTOR", CS%vstar_scale_fac, & "An overall nondimensional scaling factor for v*. \n"// & "Making this larger decreases the PBL diffusivity.", & - units="nondim", default=1.0) + units="nondim", default=1.0, scale=US%m_to_Z) 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"//& @@ -2181,11 +2149,11 @@ subroutine energetic_PBL_init(Time, G, GV, param_file, diag, CS) call get_param(param_file, mdl, "EPBL_MLD_TOLERANCE", CS%MLD_tol, & "The tolerance for the iteratively determined mixed \n"// & "layer depth. This is only used with USE_MLD_ITERATION.", & - units="meter", default=1.0) + 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"//& "by ePBL. The default (0) does not set a minimum.", & - units="meter", default=0.0) + 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"// & @@ -2196,7 +2164,7 @@ subroutine energetic_PBL_init(Time, G, GV, param_file, diag, CS) "at the edge of the boundary layer as a fraction of the \n"//& "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).ge.0.5) then + if ( CS%USE_MLD_ITERATION .and. abs(CS%transLay_scale-0.5) >= 0.5) then call MOM_error(FATAL, "If flag USE_MLD_ITERATION is true, then "// & "EPBL_TRANSITION should be greater than 0 and less than 1.") endif @@ -2259,13 +2227,13 @@ subroutine energetic_PBL_init(Time, G, GV, param_file, diag, CS) 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_m*GV%H_subroundoff) - call log_param(param_file, mdl, "EPBL_USTAR_MIN", CS%ustar_min, & + 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"//& "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, & - Time, 'Surface boundary layer depth', 'm', & + Time, 'Surface boundary layer depth', 'm', conversion=US%Z_to_m, & cmor_long_name='Ocean Mixed Layer Thickness Defined by Mixing Scheme') CS%id_TKE_wind = register_diag_field('ocean_model', 'ePBL_TKE_wind', diag%axesT1, & Time, 'Wind-stirring source of mixed layer TKE', 'm3 s-3') @@ -2274,8 +2242,8 @@ subroutine energetic_PBL_init(Time, G, GV, param_file, diag, CS) CS%id_TKE_conv = register_diag_field('ocean_model', 'ePBL_TKE_conv', diag%axesT1, & Time, 'Convective source of mixed layer TKE', 'm3 s-3') CS%id_TKE_forcing = register_diag_field('ocean_model', 'ePBL_TKE_forcing', diag%axesT1, & - Time, 'TKE consumed by mixing surface forcing or penetrative shortwave radation'//& - ' through model layers', 'm3 s-3') + Time, 'TKE consumed by mixing surface forcing or penetrative shortwave radation '//& + 'through model layers', 'm3 s-3') CS%id_TKE_mixing = register_diag_field('ocean_model', 'ePBL_TKE_mixing', diag%axesT1, & Time, 'TKE consumed by mixing that deepens the mixed layer', 'm3 s-3') CS%id_TKE_mech_decay = register_diag_field('ocean_model', 'ePBL_TKE_mech_decay', diag%axesT1, & @@ -2283,17 +2251,17 @@ subroutine energetic_PBL_init(Time, G, GV, param_file, diag, CS) CS%id_TKE_conv_decay = register_diag_field('ocean_model', 'ePBL_TKE_conv_decay', diag%axesT1, & Time, 'Convective energy decay sink of mixed layer TKE', 'm3 s-3') CS%id_Hsfc_used = register_diag_field('ocean_model', 'ePBL_Hs_used', diag%axesT1, & - Time, 'Surface region thickness that is used', 'm') + Time, 'Surface region thickness that is used', 'm', conversion=US%m_to_Z) CS%id_Mixing_Length = register_diag_field('ocean_model', 'Mixing_Length', diag%axesTi, & - Time, 'Mixing Length that is used', 'm') + Time, 'Mixing Length that is used', 'm', conversion=US%Z_to_m) CS%id_Velocity_Scale = register_diag_field('ocean_model', 'Velocity_Scale', diag%axesTi, & - Time, 'Velocity Scale that is used.', 'm s-1') + Time, 'Velocity Scale that is used.', 'm s-1', conversion=US%Z_to_m) CS%id_LT_enhancement = register_diag_field('ocean_model', 'LT_Enhancement', diag%axesT1, & Time, 'LT enhancement that is used.', 'nondim') CS%id_MSTAR_mix = register_diag_field('ocean_model', 'MSTAR', diag%axesT1, & Time, 'MSTAR that is used.', 'nondim') CS%id_OSBL = register_diag_field('ocean_model', 'ePBL_OSBL', diag%axesT1, & - Time, 'ePBL Surface Boundary layer depth.', 'm') + Time, 'ePBL Surface Boundary layer depth.', 'm', conversion=US%m_to_Z) ! BGR (9/21/2017) Note that ePBL_OSBL is the guess for iteration step while ePBL_h_ML is ! result from iteration step. CS%id_mld_ekman = register_diag_field('ocean_model', 'MLD_EKMAN', diag%axesT1, & @@ -2360,8 +2328,10 @@ subroutine energetic_PBL_init(Time, G, GV, param_file, diag, CS) end subroutine energetic_PBL_init +!> Clean up and deallocate memory associated with the energetic_PBL module. subroutine energetic_PBL_end(CS) - type(energetic_PBL_CS), pointer :: CS + type(energetic_PBL_CS), pointer :: CS !< Energetic_PBL control structure that + !! will be deallocated in this subroutine. if (.not.associated(CS)) return @@ -2389,4 +2359,33 @@ subroutine energetic_PBL_end(CS) end subroutine energetic_PBL_end +!> \namespace MOM_energetic_PBL +!! +!! By Robert Hallberg, 2015. +!! +!! This file contains the subroutine (energetic_PBL) that uses an +!! integrated boundary layer energy budget (like a bulk- or refined- +!! bulk mixed layer scheme), but instead of homogenizing this model +!! calculates a finite diffusivity and viscosity, which in this +!! regard is conceptually similar to what is done with KPP or various +!! two-equation closures. However, the scheme that is implemented +!! here has the big advantage that is entirely implicit, but is +!! simple enough that it requires only a single vertical pass to +!! determine the diffusivity. The development of bulk mixed layer +!! models stems from the work of various people, as described in the +!! review paper by Niiler and Kraus (1979). The work here draws in +!! with particular on the form for TKE decay proposed by Oberhuber +!! (JPO, 1993, 808-829), with an extension to a refined bulk mixed +!! layer as described in Hallberg (Aha Huliko'a, 2003). The physical +!! processes portrayed in this subroutine include convectively driven +!! mixing and mechanically driven mixing. Unlike boundary-layer +!! mixing, stratified shear mixing is not a one-directional turbulent +!! process, and it is dealt with elsewhere in the MOM6 code within +!! the module MOM_kappa_shear.F90. It is assumed that the heat, +!! mass, and salt fluxes have been applied elsewhere, but that their +!! implications for the integrated TKE budget have been captured in +!! an array that is provided as an argument to this subroutine. This +!! is a full 3-d array due to the effects of penetrating shortwave +!! radiation. + end module MOM_energetic_PBL diff --git a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 index 1852e87c48..824bab78b2 100644 --- a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 +++ b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 @@ -1,61 +1,15 @@ +!> Diapycnal mixing and advection in isopycnal mode module MOM_entrain_diffusive ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Robert Hallberg, September 1997 - July 2000 * -!* * -!* This file contains the subroutines that implement diapycnal * -!* mixing and advection in isopycnal layers. The main subroutine, * -!* calculate_entrainment, returns the entrainment by each layer * -!* across the interfaces above and below it. These are calculated * -!* subject to the constraints that no layers can be driven to neg- * -!* ative thickness and that the each layer maintains its target * -!* density, using the scheme described in Hallberg (MWR 2000). There * -!* may or may not be a bulk mixed layer above the isopycnal layers. * -!* The solution is iterated until the change in the entrainment * -!* between successive iterations is less than some small tolerance. * -!* * -!* The dual-stream entrainment scheme of MacDougall and Dewar * -!* (JPO 1997) is used for combined diapycnal advection and diffusion, * -!* modified as described in Hallberg (MWR 2000) to be solved * -!* implicitly in time. Any profile of diffusivities may be used. * -!* Diapycnal advection is fundamentally the residual of diapycnal * -!* diffusion, so the fully implicit upwind differencing scheme that * -!* is used is entirely appropriate. The downward buoyancy flux in * -!* each layer is determined from an implicit calculation based on * -!* the previously calculated flux of the layer above and an estim- * -!* ated flux in the layer below. This flux is subject to the foll- * -!* owing conditions: (1) the flux in the top and bottom layers are * -!* set by the boundary conditions, and (2) no layer may be driven * -!* below an Angstrom thickness. If there is a bulk mixed layer, the * -!* mixed and buffer layers are treated as Eulerian layers, whose * -!* thicknesses only change due to entrainment by the interior layers. * -!* * -!* In addition, the model may adjust the fluxes to drive the layer * -!* densities (sigma 2?) back toward their targer values. * -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q * -!* j+1 > o > o > At ^: v * -!* j x ^ x ^ x At >: u * -!* j > o > o > At o: h, buoy, T, S, ea, eb, etc. * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** - use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : diag_ctrl, time_type use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_forcing_type, only : forcing use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use MOM_EOS, only : calculate_density, calculate_density_derivs @@ -66,124 +20,102 @@ module MOM_entrain_diffusive public entrainment_diffusive, entrain_diffusive_init, entrain_diffusive_end +! 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 holding parametes for the MOM_entrain_diffusive module type, public :: entrain_diffusive_CS ; private - logical :: bulkmixedlayer ! If true, a refined bulk mixed layer is used with - ! GV%nk_rho_varies variable density mixed & buffer - ! layers. - logical :: correct_density ! If true, the layer densities are restored toward - ! their target variables by the diapycnal mixing. - integer :: max_ent_it ! The maximum number of iterations that may be - ! used to calculate the diapycnal entrainment. - real :: Tolerance_Ent ! The tolerance with which to solve for entrainment - ! values, in m. - type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the - ! timing of diagnostic output. - integer :: id_Kd = -1, id_diff_work = -1 + logical :: bulkmixedlayer !< If true, a refined bulk mixed layer is used with + !! GV%nk_rho_varies variable density mixed & buffer layers. + logical :: correct_density !< If true, the layer densities are restored toward + !! their target variables by the diapycnal mixing. + integer :: max_ent_it !< The maximum number of iterations that may be used to + !! calculate the diapycnal entrainment. + real :: Tolerance_Ent !< The tolerance with which to solve for entrainment values + !! [H ~> m or kg m-2]. + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + integer :: id_Kd = -1 !< Diagnostic ID for diffusivity + integer :: id_diff_work = -1 !< Diagnostic ID for mixing work end type entrain_diffusive_CS contains -!> 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 the buoyancy flux in a layer and inversely -!! proportional to the density differences between layers. The -!! scheme that is used here is described in detail in Hallberg, Mon. -!! Wea. Rev. 2000. -subroutine entrainment_diffusive(u, v, h, tv, fluxes, dt, G, GV, CS, ea, eb, & +!> 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 +!! the buoyancy flux in a layer and inversely proportional to the density +!! differences between layers. The scheme that is used here is described in +!! detail in Hallberg, Mon. Wea. Rev. 2000. +subroutine entrainment_diffusive(u, v, h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & kb_out, Kd_Lay, Kd_int) 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 real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & - intent(in) :: u !< The zonal velocity, in m s-1. + intent(in) :: u !< The zonal velocity [m s-1]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & - intent(in) :: v !< The meridional velocity, in m s-1. + intent(in) :: v !< The meridional velocity [m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2). + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any available !! thermodynamic fields. Absent fields have NULL !! ptrs. type(forcing), intent(in) :: fluxes !< A structure of surface fluxes that may !! be used. - real, intent(in) :: dt !< The time increment in s. + real, intent(in) :: dt !< The time increment [s]. type(entrain_diffusive_CS), pointer :: CS !< The control structure returned by a previous !! call to entrain_diffusive_init. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(out) :: ea !< The amount of fluid entrained from the layer - !! above within this time step, in the same units - !! as h, m or kg m-2. + !! above within this time step [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(out) :: eb !< The amount of fluid entrained from the layer - !! below within this time step, in the same units - !! as h, m or kg m-2. + !! below within this time step [H ~> m or kg m-2]. integer, dimension(SZI_(G),SZJ_(G)), & optional, intent(inout) :: kb_out !< The index of the lightest layer denser than - !! the buffer layer. At least one of the two - !! arguments must be present. + !! the buffer layer. + ! 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, - !! in m2 s-1. + optional, intent(in) :: Kd_Lay !< The diapycnal diffusivity of layers + !! [Z2 s-1 ~> m2 s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & - optional, intent(in) :: Kd_int !< The diapycnal diffusivity of interfaces, - !! in 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 the buoyancy flux in a layer and inversely -! proportional to the density differences between layers. The -! scheme that is used here is described in detail in Hallberg, Mon. -! Wea. Rev. 2000. - -! Arguments: u - Zonal velocity, in m s-1. -! (in) v - Meridional velocity, in m s-1. -! (in) h - Layer thickness, in m or kg m-2. -! (in) fluxes - A structure of surface fluxes that may be used. -! (in) kb_out - The index of the lightest layer denser than the -! buffer layers. -! (in) tv - A structure containing pointers to any available -! thermodynamic fields. Absent fields have NULL ptrs. -! (in) dt - The time increment in s. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - The control structure returned by a previous call to -! entrain_diffusive_init. -! (out) ea - The amount of fluid entrained from the layer above within -! this time step, in the same units as h, m or kg m-2. -! (out) eb - The amount of fluid entrained from the layer below within -! this time step, in the same units as h, m or kg m-2. -! (out,opt) kb - The index of the lightest layer denser than the buffer layer. -! At least one of the two arguments must be present. -! (in,opt) Kd_Lay - The diapycnal diffusivity of layers, in m2 s-1. -! (in,opt) Kd_int - The diapycnal diffusivity of interfaces, in m2 s-1. - -! In the comments below, H is used as shorthand for the units of h, m or kg m-2. + optional, intent(in) :: Kd_int !< The diapycnal diffusivity of interfaces + !! [Z2 s-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 +! the buoyancy flux in a layer and inversely proportional to the density +! differences between layers. The scheme that is used here is described in +! detail in Hallberg, Mon. Wea. Rev. 2000. + real, dimension(SZI_(G),SZK_(G)) :: & - dtKd ! The layer diapycnal diffusivity times the time step, translated - ! into the same unints as h, m2 or kg2 m-4 (i.e. H2). + dtKd ! The layer diapycnal diffusivity times the time step [H2 ~> m2 or kg2 m-4]. real, dimension(SZI_(G),SZK_(G)+1) :: & - dtKd_int ! The diapycnal diffusivity at the interfaces times the time step, - ! translated into the same unints as h, m2 or kg2 m-4 (i.e. H2). + dtKd_int ! The diapycnal diffusivity at the interfaces times the time step [H2 ~> m2 or kg2 m-4] real, dimension(SZI_(G),SZK_(G)) :: & F, & ! The density flux through a layer within a time step divided by the - ! density difference across the interface below the layer, in H. + ! density difference across the interface below the layer [H ~> m or kg m-2]. maxF, & ! maxF is the maximum value of F that will not deplete all of the - ! layers above or below a layer within a timestep, in H. + ! layers above or below a layer within a timestep [H ~> m or kg m-2]. minF, & ! minF is the minimum flux that should be expected in the absence of - ! interactions between layers, in H. - Fprev, &! The previous estimate of F, in H. + ! interactions between layers [H ~> m or kg m-2]. + Fprev, &! The previous estimate of F [H ~> m or kg m-2]. dFdfm, &! The partial derivative of F with respect to changes in F of the - ! neighboring layers. Nondimensional. + ! neighboring layers. [nondim] h_guess ! An estimate of the layer thicknesses after entrainment, but ! before the entrainments are adjusted to drive the layer - ! densities toward their target values, in H. + ! densities toward their target values [H ~> m or kg m-2]. real, dimension(SZI_(G),SZK_(G)+1) :: & Ent_bl ! The average entrainment upward and downward across - ! each interface around the buffer layers, in H. + ! each interface around the buffer layers [H ~> m or kg m-2]. real, allocatable, dimension(:,:,:) :: & Kd_eff, & ! The effective diffusivity that actually applies to each ! layer after the effects of boundary conditions are - ! considered, in m2 s-1. + ! considered [Z2 s-1 ~> m2 s-1]. diff_work ! The work actually done by diffusion across each - ! interface, in W m-2. Sum vertically for the total work. + ! interface [W m-2]. Sum vertically for the total work. real :: hm, fm, fr, fk ! Work variables with units of H, H, H, and H2. @@ -191,81 +123,81 @@ subroutine entrainment_diffusive(u, v, h, tv, fluxes, dt, G, GV, CS, ea, eb, & real :: c1(SZI_(G),SZK_(G)) ! tridiagonal solver. real, dimension(SZI_(G)) :: & - htot, & ! The total thickness above or below a layer in H. + htot, & ! The total thickness above or below a layer [H ~> m or kg m-2]. Rcv, & ! Value of the coordinate variable (potential density) - ! based on the simulated T and S and P_Ref, kg m-3. - pres, & ! Reference pressure (P_Ref) in Pa. + ! based on the simulated T and S and P_Ref [kg m-3]. + pres, & ! Reference pressure (P_Ref) [Pa]. eakb, & ! The entrainment from above by the layer below the buffer - ! layer (i.e. layer kb), in H. - ea_kbp1, & ! The entrainment from above by layer kb+1, in H. - eb_kmb, & ! The entrainment from below by the deepest buffer layer, in H. + ! layer (i.e. layer kb) [H ~> m or kg m-2]. + ea_kbp1, & ! The entrainment from above by layer kb+1 [H ~> m or kg m-2]. + eb_kmb, & ! The entrainment from below by the deepest buffer layer [H ~> m or kg m-2]. dS_kb, & ! The reference potential density difference across the - ! interface between the buffer layers and layer kb, in kg m-3. + ! interface between the buffer layers and layer kb [kg m-3]. dS_anom_lim, &! The amount by which dS_kb is reduced when limits are - ! applied, in kg m-3. + ! applied [kg m-3]. I_dSkbp1, & ! The inverse of the potential density difference across the - ! interface below layer kb, in m3 kg-1. - dtKd_kb, & ! The diapycnal diffusivity in layer kb times the time step, - ! in units of H2. + ! interface below layer kb [m3 kg-1]. + dtKd_kb, & ! The diapycnal diffusivity in layer kb times the time step + ! [H2 ~> m2 or kg2 m-4]. maxF_correct, & ! An amount by which to correct maxF due to excessive - ! surface heat loss, in H. - zeros, & ! An array of all zeros. (Usually used with units of H.) - max_eakb, & ! The maximum value of eakb that might be realized, in H. - min_eakb, & ! The minimum value of eakb that might be realized, in H. + ! surface heat loss [H ~> m or kg m-2]. + zeros, & ! An array of all zeros. (Usually used with [H ~> m or kg m-2].) + max_eakb, & ! The maximum value of eakb that might be realized [H ~> m or kg m-2]. + min_eakb, & ! The minimum value of eakb that might be realized [H ~> m or kg m-2]. err_max_eakb0, & ! The value of error returned by determine_Ea_kb err_min_eakb0, & ! when eakb = min_eakb and max_eakb and ea_kbp1 = 0. err_eakb0, & ! A value of error returned by determine_Ea_kb. F_kb, & ! The value of F in layer kb, or equivalently the entrainment - ! from below by layer kb, in H. - dFdfm_kb, & ! The partial derivative of F with fm, nondim. See dFdfm. - maxF_kb, & ! The maximum value of F_kb that might be realized, in H. - eakb_maxF, & ! The value of eakb that gives F_kb=maxF_kb, in H. - F_kb_maxEnt ! The value of F_kb when eakb = max_eakb, in H. + ! from below by layer kb [H ~> m or kg m-2]. + dFdfm_kb, & ! The partial derivative of F with fm [nondim]. See dFdfm. + maxF_kb, & ! The maximum value of F_kb that might be realized [H ~> m or kg m-2]. + eakb_maxF, & ! The value of eakb that gives F_kb=maxF_kb [H ~> m or kg m-2]. + F_kb_maxEnt ! The value of F_kb when eakb = max_eakb [H ~> m or kg m-2]. real, dimension(SZI_(G),SZK_(G)) :: & Sref, & ! The reference potential density of the mixed and buffer layers, ! and of the two lightest interior layers (kb and kb+1) copied - ! into layers kmb+1 and kmb+2, in kg m-3. + ! into layers kmb+1 and kmb+2 [kg m-3]. h_bl ! The thicknesses of the mixed and buffer layers, and of the two ! lightest interior layers (kb and kb+1) copied into layers kmb+1 - ! and kmb+2, in H. + ! and kmb+2 [H ~> m or kg m-2]. real, dimension(SZI_(G),SZK_(G)) :: & ds_dsp1, & ! The coordinate variable (sigma-2) difference across an ! interface divided by the difference across the interface - ! below it. Nondimensional. + ! below it. [nondim] dsp1_ds, & ! The inverse coordinate variable (sigma-2) difference ! across an interface times the difference across the - ! interface above it. Nondimensional. - I2p2dsp1_ds, & ! 1 / (2 + 2 * ds_k+1 / ds_k). Nondimensional. + ! interface above it. [nondim] + I2p2dsp1_ds, & ! 1 / (2 + 2 * ds_k+1 / ds_k). [nondim] grats ! 2*(2 + ds_k+1 / ds_k + ds_k / ds_k+1) = - ! 4*ds_Lay*(1/ds_k + 1/ds_k+1). Nondim. + ! 4*ds_Lay*(1/ds_k + 1/ds_k+1). [nondim] real :: dRHo ! The change in locally referenced potential density between - ! the layers above and below an interface, in kg m-3. - real :: g_2dt ! 0.5 * G_Earth / dt, in m s-3. + ! the layers above and below an interface [kg m-3]. + real :: g_2dt ! 0.5 * G_Earth / dt, times unit conversion factors + ! [m3 H-2 s-3 ~> m s-3 or m7 kg-2 s-3]. real, dimension(SZI_(G)) :: & - pressure, & ! The pressure at an interface, in Pa. + pressure, & ! The pressure at an interface [Pa]. T_eos, S_eos, & ! The potential temperature and salinity at which to - ! evaluate dRho_dT and dRho_dS, in degC and PSU. + ! evaluate dRho_dT and dRho_dS [degC] and [ppt]. dRho_dT, dRho_dS ! The partial derivatives of potential density with - ! temperature and salinity, in kg m-3 K-1 and kg m-3 psu-1. + ! temperature and salinity, [kg m-3 degC-1] and [kg m-3 ppt-1]. - real :: tolerance ! The tolerance within which E must be converged, in H. - real :: Angstrom ! The minimum layer thickness, in H. + real :: tolerance ! The tolerance within which E must be converged [H ~> m or kg m-2]. + real :: Angstrom ! The minimum layer thickness [H ~> m or kg m-2]. real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected, in H. + ! in roundoff and can be neglected [H ~> m or kg m-2]. real :: F_cor ! A correction to the amount of F that is used to - ! entrain from the layer above, in H. - real :: Kd_here ! The effective diapycnal diffusivity, in H2 s-1. - real :: h_avail ! The thickness that is available for entrainment, in H. + ! entrain from the layer above [H ~> m or kg m-2]. + real :: Kd_here ! The effective diapycnal diffusivity [H2 s-1 ~> m2 s-1 or kg2 m-4 s-1]. + real :: h_avail ! The thickness that is available for entrainment [H ~> m or kg m-2]. real :: dS_kb_eff ! The value of dS_kb after limiting is taken into account. real :: Rho_cor ! The depth-integrated potential density anomaly that - ! needs to be corrected for, in kg m-2. - real :: ea_cor ! The corrective adjustment to eakb, in H. + ! needs to be corrected for [H kg m-3 ~> kg m-2 or kg2 m-5]. + real :: ea_cor ! The corrective adjustment to eakb [H ~> m or kg m-2]. real :: h1 ! The layer thickness after entrainment through the - ! interface below is taken into account, in H. - real :: Idt ! The inverse of the time step, in s-1. - real :: H_to_m, m_to_H ! Local copies of unit conversion factors. + ! interface below is taken into account [H ~> m or kg m-2]. + real :: Idt ! The inverse of the time step [s-1]. logical :: do_any logical :: do_i(SZI_(G)), did_i(SZI_(G)), reiterate, correct_density @@ -275,7 +207,7 @@ subroutine entrainment_diffusive(u, v, h, tv, fluxes, dt, G, GV, CS, ea, eb, & integer :: kb_min_act ! The minimum active value of kb in the current j-row. integer :: is1, ie1 ! The minimum and maximum active values of i in the current j-row. is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke - Angstrom = GV%Angstrom + Angstrom = GV%Angstrom_H h_neglect = GV%H_subroundoff if (.not. associated(CS)) call MOM_error(FATAL, & @@ -295,9 +227,7 @@ subroutine entrainment_diffusive(u, v, h, tv, fluxes, dt, G, GV, CS, ea, eb, & &and a linear equation of state to drive the model.") endif - H_to_m = GV%H_to_m ; m_to_H = GV%m_to_H - tolerance = m_to_H * CS%Tolerance_Ent - g_2dt = 0.5 * GV%g_Earth / dt + tolerance = CS%Tolerance_Ent kmb = GV%nk_rho_varies K2 = max(kmb+1,2) ; kb_min = K2 if (.not. CS%bulkmixedlayer) then @@ -320,44 +250,44 @@ subroutine entrainment_diffusive(u, v, h, tv, fluxes, dt, G, GV, CS, ea, eb, & pres(:) = 0.0 endif -!$OMP parallel do default(none) shared(is,ie,js,je,nz,Kd_Lay,G,GV,dt,Kd_int,CS,h,tv, & -!$OMP kmb,Angstrom,fluxes,K2,h_neglect,tolerance, & -!$OMP ea,eb,correct_density,Kd_eff,diff_work, & -!$OMP g_2dt, kb_out, m_to_H, H_to_m) & -!$OMP firstprivate(kb,ds_dsp1,dsp1_ds,pres,kb_min) & -!$OMP private(dtKd,dtKd_int,do_i,Ent_bl,dtKd_kb,h_bl, & -!$OMP I2p2dsp1_ds,grats,htot,max_eakb,I_dSkbp1, & -!$OMP zeros,maxF_kb,maxF,ea_kbp1,eakb,Sref, & -!$OMP maxF_correct,do_any, & -!$OMP err_min_eakb0,err_max_eakb0,eakb_maxF, & -!$OMP min_eakb,err_eakb0,F,minF,hm,fk,F_kb_maxent,& -!$OMP F_kb,is1,ie1,kb_min_act,dFdfm_kb,b1,dFdfm, & -!$OMP Fprev,fm,fr,c1,reiterate,eb_kmb,did_i, & -!$OMP h_avail,h_guess,dS_kb,Rcv,F_cor,dS_kb_eff, & -!$OMP Rho_cor,ea_cor,h1,Idt,Kd_here,pressure, & -!$OMP T_eos,S_eos,dRho_dT,dRho_dS,dRho,dS_anom_lim) + !$OMP parallel do default(none) shared(is,ie,js,je,nz,Kd_Lay,G,GV,US,dt,CS,h,tv, & + !$OMP kmb,Angstrom,fluxes,K2,h_neglect,tolerance, & + !$OMP ea,eb,correct_density,Kd_int,Kd_eff, & + !$OMP diff_work,g_2dt, kb_out) & + !$OMP firstprivate(kb,ds_dsp1,dsp1_ds,pres,kb_min) & + !$OMP private(dtKd,dtKd_int,do_i,Ent_bl,dtKd_kb,h_bl, & + !$OMP I2p2dsp1_ds,grats,htot,max_eakb,I_dSkbp1, & + !$OMP zeros,maxF_kb,maxF,ea_kbp1,eakb,Sref, & + !$OMP maxF_correct,do_any, & + !$OMP err_min_eakb0,err_max_eakb0,eakb_maxF, & + !$OMP min_eakb,err_eakb0,F,minF,hm,fk,F_kb_maxent,& + !$OMP F_kb,is1,ie1,kb_min_act,dFdfm_kb,b1,dFdfm, & + !$OMP Fprev,fm,fr,c1,reiterate,eb_kmb,did_i, & + !$OMP h_avail,h_guess,dS_kb,Rcv,F_cor,dS_kb_eff, & + !$OMP Rho_cor,ea_cor,h1,Idt,Kd_here,pressure, & + !$OMP T_eos,S_eos,dRho_dT,dRho_dS,dRho,dS_anom_lim) do j=js,je do i=is,ie ; kb(i) = 1 ; enddo if (present(Kd_Lay)) then do k=1,nz ; do i=is,ie - dtKd(i,k) = m_to_H**2 * (dt*Kd_Lay(i,j,k)) + dtKd(i,k) = GV%Z_to_H**2 * (dt*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) = m_to_H**2 * (dt*Kd_int(i,j,K)) + dtKd_int(i,K) = GV%Z_to_H**2 * (dt*Kd_int(i,j,K)) enddo ; enddo else do K=2,nz ; do i=is,ie - dtKd_int(i,K) = m_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*(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) = m_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*(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) = m_to_H**2 * (dt*Kd_int(i,j,K)) + dtKd_int(i,K) = GV%Z_to_H**2 * (dt*Kd_int(i,j,K)) enddo ; enddo endif @@ -455,7 +385,7 @@ subroutine entrainment_diffusive(u, v, h, tv, fluxes, dt, G, GV, CS, ea, eb, & htot(i) = h(i,j,1) - Angstrom enddo if (associated(fluxes%buoy)) then ; do i=is,ie - maxF(i,1) = (dt*fluxes%buoy(i,j)) / GV%g_prime(2) + maxF(i,1) = (dt*fluxes%buoy(i,j)) / (GV%g_prime(2)*US%m_to_Z) enddo ; endif endif @@ -736,7 +666,7 @@ subroutine entrainment_diffusive(u, v, h, tv, fluxes, dt, G, GV, CS, ea, eb, & F(i,k) = MIN(F(i,k), ds_dsp1(i,k)*( ((F(i,k-1) + & dsp1_ds(i,k-1)*F(i,k-1)) - F(i,k-2)) + (h(i,j,k-1) - Angstrom))) F(i,k) = MAX(F(i,k),MIN(minF(i,k),0.0)) - else if (k == kb(i)+1) then + elseif (k == kb(i)+1) then F(i,k) = MIN(F(i,k), ds_dsp1(i,k)*( ((F(i,k-1) + eakb(i)) - & eb_kmb(i)) + (h(i,j,k-1) - Angstrom))) F(i,k) = MAX(F(i,k),MIN(minF(i,k),0.0)) @@ -791,7 +721,7 @@ subroutine entrainment_diffusive(u, v, h, tv, fluxes, dt, G, GV, CS, ea, eb, & ea(i,j,k) = ea(i,j,k) - dsp1_ds(i,k)*F_cor eb(i,j,k) = eb(i,j,k) + F_cor - else if ((k==kb(i)) .and. (F(i,k) > 0.0)) then + elseif ((k==kb(i)) .and. (F(i,k) > 0.0)) then ! Rho_cor is the density anomaly that needs to be corrected, ! taking into account that the true potential density of the ! deepest buffer layer is not exactly what is returned as dS_kb. @@ -817,7 +747,7 @@ subroutine entrainment_diffusive(u, v, h, tv, fluxes, dt, G, GV, CS, ea, eb, & ea(i,j,k) = ea(i,j,k) + ea_cor eb(i,j,k) = eb(i,j,k) - (dS_kb(i) * I_dSkbp1(i)) * ea_cor - else if (k < kb(i)) then + elseif (k < kb(i)) then ! Repetative, unless ea(kb) has been corrected. ea(i,j,k) = ea(i,j,k+1) endif @@ -880,22 +810,23 @@ subroutine entrainment_diffusive(u, v, h, tv, fluxes, dt, G, GV, CS, ea, eb, & endif ! correct_density if (CS%id_Kd > 0) then - Idt = 1.0 / dt + Idt = GV%H_to_Z**2 / dt do k=2,nz-1 ; do i=is,ie if (k 0) then + g_2dt = 0.5 * GV%H_to_Z**2 * (GV%g_Earth / dt) do i=is,ie ; diff_work(i,j,1) = 0.0 ; diff_work(i,j,nz+1) = 0.0 ; enddo if (associated(tv%eqn_of_state)) then if (associated(fluxes%p_surf)) then @@ -959,24 +890,42 @@ end subroutine entrainment_diffusive !! amount of surface forcing that is applied to each layer if there is no bulk !! mixed layer. subroutine F_to_ent(F, h, kb, kmb, j, G, GV, CS, dsp1_ds, eakb, Ent_bl, ea, eb, do_i_in) - 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),SZK_(G)), intent(in) :: F - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - integer, dimension(SZI_(G)), intent(in) :: kb - integer, intent(in) :: kmb, j - type(entrain_diffusive_CS), intent(in) :: CS - real, dimension(SZI_(G),SZK_(G)), intent(in) :: dsp1_ds - real, dimension(SZI_(G)), intent(in) :: eakb - real, dimension(SZI_(G),SZK_(G)), intent(in) :: Ent_bl - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: ea, eb - logical, dimension(SZI_(G)), optional, intent(in) :: do_i_in + 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),SZK_(G)), intent(in) :: F !< The density flux through a layer within + !! a time step divided by the density + !! difference across the interface below + !! the layer [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + integer, dimension(SZI_(G)), intent(in) :: kb !< The index of the lightest layer denser than + !! the deepest buffer layer. + integer, intent(in) :: kmb !< The number of mixed and buffer layers. + integer, intent(in) :: j !< The meridional index upon which to work. + type(entrain_diffusive_CS), intent(in) :: CS !< This module's control structure. + real, dimension(SZI_(G),SZK_(G)), intent(in) :: dsp1_ds !< The ratio of coordinate variable + !! differences across the interfaces below + !! a layer over the difference across the + !! interface above the layer. + real, dimension(SZI_(G)), intent(in) :: eakb !< The entrainment from above by the layer + !! below the buffer layer [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZK_(G)), intent(in) :: Ent_bl !< The average entrainment upward and + !! downward across each interface around + !! the buffer layers [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(inout) :: ea !< The amount of fluid entrained from the layer + !! above within this time step [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(inout) :: eb !< The amount of fluid entrained from the layer + !! below within this time step [H ~> m or kg m-2]. + logical, dimension(SZI_(G)), & + optional, intent(in) :: do_i_in !< Indicates which i-points to work on. ! This subroutine calculates the actual entrainments (ea and eb) and the ! amount of surface forcing that is applied to each layer if there is no bulk ! mixed layer. real :: h1 ! The thickness in excess of the minimum that will remain - ! after exchange with the layer below, in m or kg m-2. + ! after exchange with the layer below [H ~> m or kg m-2]. logical :: do_i(SZI_(G)) integer :: i, k, is, ie, nz @@ -1007,7 +956,7 @@ subroutine F_to_ent(F, h, kb, kmb, j, G, GV, CS, dsp1_ds, eakb, Ent_bl, ea, eb, ! elsewhere, so F should always be nonnegative. ea(i,j,k) = dsp1_ds(i,k)*F(i,k) eb(i,j,k) = F(i,k) - else if (k == kb(i)) then + elseif (k == kb(i)) then ea(i,j,k) = eakb(i) eb(i,j,k) = F(i,k) elseif (k == kb(i)-1) then @@ -1017,7 +966,7 @@ subroutine F_to_ent(F, h, kb, kmb, j, G, GV, CS, dsp1_ds, eakb, Ent_bl, ea, eb, ea(i,j,k) = ea(i,j,k+1) ! Add the entrainment of the thin interior layers to eb going ! up into the buffer layer. - eb(i,j,k) = eb(i,j,k+1) + max(0.0, h(i,j,k+1) - GV%Angstrom) + eb(i,j,k) = eb(i,j,k+1) + max(0.0, h(i,j,k+1) - GV%Angstrom_H) endif endif ; enddo ; enddo k = kmb @@ -1025,10 +974,10 @@ subroutine F_to_ent(F, h, kb, kmb, j, G, GV, CS, dsp1_ds, eakb, Ent_bl, ea, eb, ! Adjust the previously calculated entrainment from below by the deepest ! buffer layer to account for entrainment of thin interior layers . if (kb(i) > kmb+1) & - eb(i,j,k) = eb(i,j,k+1) + max(0.0, h(i,j,k+1) - GV%Angstrom) + eb(i,j,k) = eb(i,j,k+1) + max(0.0, h(i,j,k+1) - GV%Angstrom_H) ! Determine the entrainment from above for each buffer layer. - h1 = (h(i,j,k) - GV%Angstrom) + (eb(i,j,k) - ea(i,j,k+1)) + h1 = (h(i,j,k) - GV%Angstrom_H) + (eb(i,j,k) - ea(i,j,k+1)) ea(i,j,k) = MAX(Ent_bl(i,K), Ent_bl(i,K)-0.5*h1, -h1) endif ; enddo do k=kmb-1,2,-1 ; do i=is,ie ; if (do_i(i)) then @@ -1036,7 +985,7 @@ subroutine F_to_ent(F, h, kb, kmb, j, G, GV, CS, dsp1_ds, eakb, Ent_bl, ea, eb, eb(i,j,k) = max(2.0*Ent_bl(i,K+1) - ea(i,j,k+1), 0.0) ! Determine the entrainment from above for each buffer layer. - h1 = (h(i,j,k) - GV%Angstrom) + (eb(i,j,k) - ea(i,j,k+1)) + h1 = (h(i,j,k) - GV%Angstrom_H) + (eb(i,j,k) - ea(i,j,k+1)) ea(i,j,k) = MAX(Ent_bl(i,K), Ent_bl(i,K)-0.5*h1, -h1) ! if (h1 >= 0.0) then ; ea(i,j,k) = Ent_bl(i,K) ! elseif (Ent_bl(i,K)+0.5*h1 >= 0.0) then ; ea(i,j,k) = Ent_bl(i,K)-0.5*h1 @@ -1074,76 +1023,57 @@ subroutine set_Ent_bl(h, dtKd_int, tv, kb, kmb, do_i, G, GV, CS, j, Ent_bl, Sref 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 !< Layer thicknesses, in H - !! (usually m or kg m-2). + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] real, dimension(SZI_(G),SZK_(G)+1), & intent(in) :: dtKd_int !< The diapycnal diffusivity across - !! each interface times the time step, - !! in H2. + !! each interface times the time step + !! [H2 ~> m2 or kg2 m-4]. type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any !! available thermodynamic fields. Absent !! fields have NULL ptrs. integer, dimension(SZI_(G)), intent(inout) :: kb !< The index of the lightest layer denser !! than the buffer layer or 1 if there is !! no buffer layer. - integer, intent(in) :: kmb + integer, intent(in) :: kmb !< The number of mixed and buffer layers. logical, dimension(SZI_(G)), intent(in) :: do_i !< A logical variable indicating which !! i-points to work on. type(entrain_diffusive_CS), pointer :: CS !< This module's control structure. - integer, intent(in) :: j !< The meridional index upon which - !! to work. + integer, intent(in) :: j !< The meridional index upon which to work. real, dimension(SZI_(G),SZK_(G)+1), & intent(out) :: Ent_bl !< The average entrainment upward and !! downward across each interface around - !! the buffer layers, in H. - real, dimension(SZI_(G),SZK_(G)), intent(out) :: Sref !< The coordinate potential density - - !! 1000 for each layer, in kg m-3. - real, dimension(SZI_(G),SZK_(G)), intent(out) :: h_bl !< The thickness of each layer, in H. - -! Arguments: h - Layer thickness, in m or kg m-2 (abbreviated as H below). -! (in) dtKd_int - The diapycnal diffusivity across each interface times -! the time step, in H2. -! (in) tv - A structure containing pointers to any available -! thermodynamic fields. Absent fields have NULL ptrs. -! (in) kb - The index of the lightest layer denser than the -! buffer layer or 1 if there is no buffer layer. -! (in) do_i - A logical variable indicating which i-points to work on. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - This module's control structure. -! (in) j - The meridional index upon which to work. -! (out) Ent_bl - The average entrainment upward and downward across -! each interface around the buffer layers, in H. -! (out) Sref - The coordinate potential density - 1000 for each layer, -! in kg m-3. -! (out) h_bl - The thickness of each layer, in H. + !! the buffer layers [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZK_(G)), intent(out) :: Sref !< The coordinate potential density minus + !! 1000 for each layer [kg m-3]. + real, dimension(SZI_(G),SZK_(G)), intent(out) :: h_bl !< The thickness of each layer [H ~> m or kg m-2]. ! This subroutine sets the average entrainment across each of the interfaces ! between buffer layers within a timestep. It also causes thin and relatively ! light interior layers to be entrained by the deepest buffer layer. ! Also find the initial coordinate potential densities (Sref) of each layer. - ! Does there need to be limiting when the layers below are all thin? + + ! Local variables real, dimension(SZI_(G)) :: & - b1, d1, & ! Variables used by the tridiagonal solver, in H-1 and ND. + b1, d1, & ! Variables used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1] and [nondim]. Rcv, & ! Value of the coordinate variable (potential density) - ! based on the simulated T and S and P_Ref, kg m-3. - pres, & ! Reference pressure (P_Ref) in Pa. - frac_rem, & ! The fraction of the diffusion remaining, ND. - h_interior ! The interior thickness available for entrainment, in H. + ! based on the simulated T and S and P_Ref [kg m-3]. + pres, & ! Reference pressure (P_Ref) [Pa]. + frac_rem, & ! The fraction of the diffusion remaining [nondim]. + h_interior ! The interior thickness available for entrainment [H ~> m or kg m-2]. real, dimension(SZI_(G), SZK_(G)) :: & S_est ! An estimate of the coordinate potential density - 1000 after - ! entrainment for each layer, in kg m-3. - real :: max_ent ! The maximum possible entrainment, in H. - real :: dh ! An available thickness, in H. + ! entrainment for each layer [kg m-3]. + real :: max_ent ! The maximum possible entrainment [H ~> m or kg m-2]. + real :: dh ! An available thickness [H ~> m or kg m-2]. real :: Kd_x_dt ! The diffusion that remains after thin layers are - ! entrained, in H2. + ! entrained [H2 ~> m2 or kg2 m-4]. real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected, in H. + ! in roundoff and can be neglected [H ~> m or kg m-2]. integer :: i, k, is, ie, nz is = G%isc ; ie = G%iec ; nz = G%ke -! max_ent = 1.0e14*GV%Angstrom ! This is set to avoid roundoff problems. +! max_ent = 1.0e14*GV%Angstrom_H ! This is set to avoid roundoff problems. max_ent = 1.0e4*GV%m_to_H h_neglect = GV%H_subroundoff @@ -1197,9 +1127,9 @@ subroutine set_Ent_bl(h, dtKd_int, tv, kb, kmb, do_i, G, GV, CS, j, Ent_bl, Sref do k=kmb+1,nz ; do i=is,ie ; if (do_i(i)) then if ((k == kb(i)) .and. (S_est(i,kmb) > (GV%Rlay(k) - 1000.0))) then if (4.0*dtKd_int(i,Kmb+1)*frac_rem(i) > & - (h_bl(i,kmb) + h(i,j,k)) * (h(i,j,k) - GV%Angstrom)) then + (h_bl(i,kmb) + h(i,j,k)) * (h(i,j,k) - GV%Angstrom_H)) then ! Entrain this layer into the buffer layer and move kb down. - dh = max((h(i,j,k) - GV%Angstrom), 0.0) + dh = max((h(i,j,k) - GV%Angstrom_H), 0.0) if (dh > 0.0) then frac_rem(i) = frac_rem(i) - ((h_bl(i,kmb) + h(i,j,k)) * dh) / & (4.0*dtKd_int(i,Kmb+1)) @@ -1217,7 +1147,7 @@ subroutine set_Ent_bl(h, dtKd_int, tv, kb, kmb, do_i, G, GV, CS, j, Ent_bl, Sref ! This is where variables are be set up with a different vertical grid ! in which the (newly?) massless layers are taken out. do k=nz,kmb+1,-1 ; do i=is,ie - if (k >= kb(i)) h_interior(i) = h_interior(i) + (h(i,j,k)-GV%Angstrom) + if (k >= kb(i)) h_interior(i) = h_interior(i) + (h(i,j,k)-GV%Angstrom_H) if (k==kb(i)) then h_bl(i,kmb+1) = h(i,j,k) ; Sref(i,kmb+1) = GV%Rlay(k) - 1000.0 elseif (k==kb(i)+1) then @@ -1227,7 +1157,7 @@ subroutine set_Ent_bl(h, dtKd_int, tv, kb, kmb, do_i, G, GV, CS, j, Ent_bl, Sref do i=is,ie ; if (kb(i) >= nz) then h_bl(i,kmb+1) = h(i,j,nz) Sref(i,kmb+1) = GV%Rlay(nz) - 1000.0 - h_bl(i,kmb+2) = GV%Angstrom + h_bl(i,kmb+2) = GV%Angstrom_H Sref(i,kmb+2) = Sref(i,kmb+1) + (GV%Rlay(nz) - GV%Rlay(nz-1)) endif ; enddo @@ -1267,18 +1197,16 @@ subroutine determine_dSkb(h_bl, Sref, Ent_bl, E_kb, is, ie, kmb, G, GV, limit, & 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),SZK_(G)), intent(in) :: h_bl !< Layer thickness, in m or kg m-2 - !! (abbreviated as H below). - real, dimension(SZI_(G),SZK_(G)), intent(in) :: Sref !< Reference potential vorticity - !! (in kg m-3?). + real, dimension(SZI_(G),SZK_(G)), intent(in) :: h_bl !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZK_(G)), intent(in) :: Sref !< Reference potential density [kg m-3] real, dimension(SZI_(G),SZK_(G)), intent(in) :: Ent_bl !< The average entrainment upward and !! downward across each interface - !! around the buffer layers, in H. + !! around the buffer layers [H ~> m or kg m-2]. real, dimension(SZI_(G)), intent(in) :: E_kb !< The entrainment by the top interior - !! layer, in H. - integer, intent(in) :: is, ie !< The range of i-indices to work on. - integer, intent(in) :: kmb !< The number of mixed and buffer - !! layers. + !! layer [H ~> m or kg m-2]. + integer, intent(in) :: is !< The start of the i-index range to work on. + integer, intent(in) :: ie !< The end of the i-index range to work on. + integer, intent(in) :: kmb !< The number of mixed and buffer layers. logical, intent(in) :: limit !< If true, limit dSkb and dSlay to !! avoid negative values. real, dimension(SZI_(G)), intent(inout) :: dSkb !< The limited potential density @@ -1286,36 +1214,21 @@ subroutine determine_dSkb(h_bl, Sref, Ent_bl, E_kb, is, ie, kmb, G, GV, limit, & !! between the bottommost buffer layer !! and the topmost interior layer. !! dSkb > 0. - real, dimension(SZI_(G)), optional, intent(inout) :: ddSkb_dE !< The partial derivative of dSkb - !! with E, in kg m-3 H-1. - real, dimension(SZI_(G)), optional, intent(inout) :: dSlay !< The limited potential density + real, dimension(SZI_(G)), optional, intent(inout) :: ddSkb_dE !< The partial derivative of dSkb + !! with E [kg m-3 H-1 ~> kg m-4 or m-1]. + real, dimension(SZI_(G)), optional, intent(inout) :: dSlay !< The limited potential density !! difference across the topmost !! interior layer. 0 < dSkb real, dimension(SZI_(G)), optional, intent(inout) :: ddSlay_dE !< The partial derivative of dSlay - !! with E, in kg m-3 H-1. - real, dimension(SZI_(G)), optional, intent(inout) :: dS_anom_lim - logical, dimension(SZI_(G)), optional, intent(in) :: do_i_in !< If present, determines which + !! with E [kg m-3 H-1 ~> kg m-4 or m-1]. + real, dimension(SZI_(G)), optional, intent(inout) :: dS_anom_lim !< A limiting value to use for + !! the density anomalies below the + !! buffer layer [kg m-3]. + logical, dimension(SZI_(G)), optional, intent(in) :: do_i_in !< If present, determines which !! columns are worked on. -! Arguments: h_bl - Layer thickness, in m or kg m-2 (abbreviated as H below). -! (in) Sref - Reference potential vorticity (in kg m-3?) -! (in) Ent_bl - The average entrainment upward and downward across -! each interface around the buffer layers, in H. -! (in) E_kb - The entrainment by the top interior layer, in H. -! (in) is, ie - The range of i-indices to work on. -! (in) kmb - The number of mixed and buffer layers. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) limit - If true, limit dSkb and dSlay to avoid negative values. -! (out) dSkb - The limited potential density difference across the -! interface between the bottommost buffer layer and the -! topmost interior layer. dSkb > 0. -! (out,opt) dSlay - The limited potential density difference across the -! topmost interior layer. 0 < dSkb -! (out,opt) ddSkb_dE - The partial derivative of dSkb with E, in kg m-3 H-1. -! (out,opt) ddSlay_dE - The partial derivative of dSlay with E, in kg m-3 H-1. -! (in,opt) do_i_in - If present, determines which columns are worked on. + ! Note that dSkb, ddSkb_dE, dSlay, ddSlay_dE, and dS_anom_lim are declared -! intent(inout) because they should not change where do_i_in is false. +! intent inout because they should not change where do_i_in is false. ! This subroutine determines the reference density difference between the ! bottommost buffer layer and the first interior after the mixing between mixed @@ -1329,6 +1242,8 @@ subroutine determine_dSkb(h_bl, Sref, Ent_bl, E_kb, is, ie, kmb, G, GV, limit, & ! exceed the density differences across an interface. ! Additionally, the partial derivatives of dSkb and dSlay with E_kb could ! also be returned. + + ! Local variables real, dimension(SZI_(G),SZK_(G)) :: & b1, c1, & ! b1 and c1 are variables used by the tridiagonal solver. S, dS_dE, & ! The coordinate density and its derivative with R. @@ -1338,19 +1253,19 @@ subroutine determine_dSkb(h_bl, Sref, Ent_bl, E_kb, is, ie, kmb, G, GV, limit, & real :: d1(SZI_(G)) ! d1 = 1.0-c1 is also used by the tridiagonal solver. real :: src ! A source term for dS_dR. real :: h1 ! The thickness in excess of the minimum that will remain - ! after exchange with the layer below, in m or kg m-2. + ! after exchange with the layer below [H ~> m or kg m-2]. logical, dimension(SZI_(G)) :: do_i real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected, in H. + ! in roundoff and can be neglected [H ~> m or kg m-2]. real :: h_tr ! h_tr is h at tracer points with a tiny thickness - ! added to ensure positive definiteness, in m or kg m-2. - real :: b_denom_1 ! The first term in the denominator of b1 in m or kg m-2. + ! added to ensure positive definiteness [H ~> m or kg m-2]. + real :: b_denom_1 ! The first term in the denominator of b1 [H ~> m or kg m-2]. real :: rat real :: dS_kbp1, IdS_kbp1 real :: deriv_dSLay - real :: Inv_term ! Nondimensional. - real :: f1, df1_drat ! Nondimensional temporary variables. - real :: z, dz_drat, f2, df2_dz, expz ! Nondimensional temporary variables. + real :: Inv_term ! [nondim] + real :: f1, df1_drat ! Temporary variables [nondim]. + real :: z, dz_drat, f2, df2_dz, expz ! Temporary variables [nondim]. real :: eps_dSLay, eps_dSkb ! Small nondimensional constants. integer :: i, k @@ -1380,7 +1295,7 @@ subroutine determine_dSkb(h_bl, Sref, Ent_bl, E_kb, is, ie, kmb, G, GV, limit, & endif ! Determine the entrainment from above for each buffer layer. - h1 = (h_bl(i,k) - GV%Angstrom) + (eb(i,k) - ea(i,k+1)) + h1 = (h_bl(i,k) - GV%Angstrom_H) + (eb(i,k) - ea(i,k+1)) if (h1 >= 0.0) then ea(i,k) = Ent_bl(i,K) ; dea_dE(i,k) = 0.0 elseif (Ent_bl(i,K) + 0.5*h1 >= 0.0) then @@ -1463,7 +1378,7 @@ subroutine determine_dSkb(h_bl, Sref, Ent_bl, E_kb, is, ie, kmb, G, GV, limit, & if (present(dSLay)) then dz_drat = 1000.0 ! The limit of large dz_drat the same as choosing a ! Heaviside function. - eps_dSLay = 1.0e-10 ! Should be ~= GV%Angstrom / sqrt(Kd*dt) + eps_dSLay = 1.0e-10 ! Should be ~= GV%Angstrom_H / sqrt(Kd*dt) do i=is,ie ; if (do_i(i)) then dS_kbp1 = Sref(i,kmb+2) - Sref(i,kmb+1) IdS_kbp1 = 1.0 / (Sref(i,kmb+2) - Sref(i,kmb+1)) @@ -1513,22 +1428,38 @@ subroutine determine_dSkb(h_bl, Sref, Ent_bl, E_kb, is, ie, kmb, G, GV, limit, & end subroutine determine_dSkb - +!> Given an entrainment from below for layer kb, determine a consistent +!! entrainment from above, such that dSkb * ea_kb = dSkbp1 * F_kb. The input +!! value of ea_kb is both the maximum value that can be obtained and the first +!! guess of the iterations. Ideally ea_kb should be an under-estimate subroutine F_kb_to_ea_kb(h_bl, Sref, Ent_bl, I_dSkbp1, F_kb, kmb, i, & G, GV, CS, ea_kb, tol_in) - 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),SZK_(G)), intent(in) :: h_bl, Sref, Ent_bl - real, dimension(SZI_(G)), intent(in) :: I_dSkbp1, F_kb - integer, intent(in) :: kmb, i - type(entrain_diffusive_CS), pointer :: CS - real, dimension(SZI_(G)), intent(inout) :: ea_kb - real, optional, intent(in) :: tol_in - - ! Given an entrainment from below for layer kb, determine a consistent - ! entrainment from above, such that dSkb * ea_kb = dSkbp1 * F_kb. The input - ! value of ea_kb is both the maximum value that can be obtained and the first - ! guess of the iterations. Also, make sure that ea_kb is an under-estimate + 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),SZK_(G)), & + intent(in) :: h_bl !< Layer thickness, with the top interior + !! layer at k-index kmb+1 [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZK_(G)), & + intent(in) :: Sref !< The coordinate reference potential density, + !! with the value of the topmost interior layer + !! at index kmb+1 [kg m-3]. + real, dimension(SZI_(G),SZK_(G)), & + intent(in) :: Ent_bl !< The average entrainment upward and downward + !! across each interface around the buffer layers, + !! [H ~> m or kg m-2]. + real, dimension(SZI_(G)), intent(in) :: I_dSkbp1 !< The inverse of the difference in reference + !! potential density across the base of the + !! uppermost interior layer [m3 kg-1]. + real, dimension(SZI_(G)), intent(in) :: F_kb !< The entrainment from below by the + !! uppermost interior layer [H ~> m or kg m-2] + integer, intent(in) :: kmb !< The number of mixed and buffer layers. + integer, intent(in) :: i !< The i-index to work on + type(entrain_diffusive_CS), pointer :: CS !< This module's control structure. + real, dimension(SZI_(G)), intent(inout) :: ea_kb !< The entrainment from above by the layer below + !! the buffer layer (i.e. layer kb) [H ~> m or kg m-2]. + real, optional, intent(in) :: tol_in !< A tolerance for the iterative determination + !! of the entrainment [H ~> m or kg m-2]. + real :: max_ea, min_ea real :: err, err_min, err_max real :: derr_dea @@ -1547,7 +1478,7 @@ subroutine F_kb_to_ea_kb(h_bl, Sref, Ent_bl, I_dSkbp1, F_kb, kmb, i, & val = dS_kbp1 * F_kb(i) err_min = -val - tolerance = GV%m_to_H * CS%Tolerance_Ent + tolerance = CS%Tolerance_Ent if (present(tol_in)) tolerance = tol_in bisect_next = .true. @@ -1630,117 +1561,93 @@ subroutine F_kb_to_ea_kb(h_bl, Sref, Ent_bl, I_dSkbp1, F_kb, kmb, i, & end subroutine F_kb_to_ea_kb +!> This subroutine determines the entrainment from above by the top interior +!! layer (labeled kb elsewhere) given an entrainment by the layer below it, +!! constrained to be within the provided bounds. subroutine determine_Ea_kb(h_bl, dtKd_kb, Sref, I_dSkbp1, Ent_bl, ea_kbp1, & min_eakb, max_eakb, kmb, is, ie, do_i, G, GV, CS, Ent, & error, err_min_eakb0, err_max_eakb0, F_kb, dFdfm_kb) 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),SZK_(G)), intent(in) :: h_bl !< Layer thickness, with the top - !! interior layer at k-index kmb+1, in - !! units of m or kg m-2 - !! (abbreviated as H below). + real, dimension(SZI_(G),SZK_(G)), intent(in) :: h_bl !< Layer thickness, with the top interior + !! layer at k-index kmb+1 [H ~> m or kg m-2]. real, dimension(SZI_(G),SZK_(G)), intent(in) :: Sref !< The coordinate reference potential !! density, with the value of the !! topmost interior layer at layer - !! kmb+1, in units of kg m-3. + !! kmb+1 [kg m-3]. real, dimension(SZI_(G),SZK_(G)), intent(in) :: Ent_bl !< The average entrainment upward and !! downward across each interface around - !! the buffer layers, in H. + !! the buffer layers [H ~> m or kg m-2]. real, dimension(SZI_(G)), intent(in) :: I_dSkbp1 !< The inverse of the difference in !! reference potential density across !! the base of the uppermost interior - !! layer, in units of m3 kg-1. + !! layer [m3 kg-1]. real, dimension(SZI_(G)), intent(in) :: dtKd_kb !< The diapycnal diffusivity in the top - !! interior layer times the time step, - !! in H2. + !! interior layer times the time step + !! [H2 ~> m2 or kg2 m-4]. real, dimension(SZI_(G)), intent(in) :: ea_kbp1 !< The entrainment from above by layer - !! kb+1, in H. + !! kb+1 [H ~> m or kg m-2]. real, dimension(SZI_(G)), intent(in) :: min_eakb !< The minimum permissible rate of - !! entrainment, in H. + !! entrainment [H ~> m or kg m-2]. real, dimension(SZI_(G)), intent(in) :: max_eakb !< The maximum permissible rate of - !! entrainment, in H. - integer, intent(in) :: kmb - integer, intent(in) :: is, ie !< The range of i-indices to work on. + !! entrainment [H ~> m or kg m-2]. + integer, intent(in) :: kmb !< The number of mixed and buffer layers. + integer, intent(in) :: is !< The start of the i-index range to work on. + integer, intent(in) :: ie !< The end of the i-index range to work on. logical, dimension(SZI_(G)), intent(in) :: do_i !< A logical variable indicating which !! i-points to work on. type(entrain_diffusive_CS), pointer :: CS !< This module's control structure. real, dimension(SZI_(G)), intent(inout) :: Ent !< The entrainment rate of the uppermost - !! interior layer, in H. The input value - !! is the first guess. - real, dimension(SZI_(G)), intent(out), optional :: error !< The error (locally defined in this + !! interior layer [H ~> m or kg m-2]. + !! The input value is the first guess. + real, dimension(SZI_(G)), optional, intent(out) :: error !< The error (locally defined in this !! routine) associated with the returned !! solution. - real, dimension(SZI_(G)), intent(in), optional :: err_min_eakb0, err_max_eakb0 !< The errors - !! (locally defined) associated with - !! min_eakb and max_eakb when ea_kbp1 - !! = 0, returned from a previous call - !! to this routine. - real, dimension(SZI_(G)), intent(out), optional :: F_kb !< The entrainment from below by the + real, dimension(SZI_(G)), optional, intent(in) :: err_min_eakb0 !< The errors (locally defined) + !! associated with min_eakb when ea_kbp1 = 0, + !! returned from a previous call to this fn. + real, dimension(SZI_(G)), optional, intent(in) :: err_max_eakb0 !< The errors (locally defined) + !! associated with min_eakb when ea_kbp1 = 0, + !! returned from a previous call to this fn. + real, dimension(SZI_(G)), optional, intent(out) :: F_kb !< The entrainment from below by the !! uppermost interior layer !! corresponding to the returned - !! value of Ent, in H. - real, dimension(SZI_(G)), intent(out), optional :: dFdfm_kb !< The partial derivative of F_kb with - !! ea_kbp1, nondim. - -! Arguments: h_bl - Layer thickness, with the top interior layer at k-index -! kmb+1, in units of m or kg m-2 (abbreviated as H below). -! (in) dtKd_kb - The diapycnal diffusivity in the top interior layer times -! the time step, in H2. -! (in) Sref - The coordinate reference potential density, with the -! value of the topmost interior layer at layer kmb+1, -! in units of kg m-3. -! (in) I_dSkbp1 - The inverse of the difference in reference potential -! density across the base of the uppermost interior layer, -! in units of m3 kg-1. -! (in) Ent_bl - The average entrainment upward and downward across -! each interface around the buffer layers, in H. -! (in) ea_kbp1 - The entrainment from above by layer kb+1, in H. -! (in) min_eakb - The minimum permissible rate of entrainment, in H. -! (in) max_eakb - The maximum permissible rate of entrainment, in H. -! (in) is, ie - The range of i-indices to work on. -! (in) do_i - A logical variable indicating which i-points to work on. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - This module's control structure. -! (in/out) Ent - The entrainment rate of the uppermost interior layer, in H. -! The input value is the first guess. -! (out,opt) error - The error (locally defined in this routine) associated with -! the returned solution. -! (in,opt) error_min_eakb0, error_max_eakb0 - The errors (locally defined) -! associated with min_eakb and max_eakb when ea_kbp1 = 0, -! returned from a previous call to this routine. -! (out,opt) F_kb - The entrainment from below by the uppermost interior layer -! corresponding to the returned value of Ent, in H. -! (out,out) dFdfm_kb - The partial derivative of F_kb with ea_kbp1, nondim. + !! value of Ent [H ~> m or kg m-2]. + real, dimension(SZI_(G)), optional, intent(out) :: dFdfm_kb !< The partial derivative of F_kb with + !! ea_kbp1 [nondim]. ! This subroutine determines the entrainment from above by the top interior ! layer (labeled kb elsewhere) given an entrainment by the layer below it, ! constrained to be within the provided bounds. + + ! Local variables real, dimension(SZI_(G)) :: & dS_kb, & ! The coordinate-density difference between the ! layer kb and deepest buffer layer, limited to - ! ensure that it is positive, in kg m-3. + ! ensure that it is positive [kg m-3]. dS_Lay, & ! The coordinate-density difference across layer ! kb, limited to ensure that it is positive and not - ! too much bigger than dS_kb or dS_kbp1, in kg m-3. - ddSkb_dE, ddSlay_dE, & ! The derivatives of dS_kb and dS_Lay with E, - ! in units of kg m-3 H-1. - derror_dE, & ! The derivative of err with E, in H. - err, & ! The "error" whose zero is being sought, in H2. - E_min, E_max, & ! The minimum and maximum values of E, in H. - error_minE, error_maxE ! err when E = E_min or E = E_max, in H2. - real :: err_est ! An estimate of what err will be, in H2. + ! too much bigger than dS_kb or dS_kbp1 [kg m-3]. + ddSkb_dE, ddSlay_dE, & ! The derivatives of dS_kb and dS_Lay with E + ! [kg m-3 H-1 ~> kg m-4 or m-1]. + derror_dE, & ! The derivative of err with E [H ~> m or kg m-2]. + err, & ! The "error" whose zero is being sought [H2 ~> m2 or kg2 m-4]. + E_min, E_max, & ! The minimum and maximum values of E [H ~> m or kg m-2]. + error_minE, error_maxE ! err when E = E_min or E = E_max [H2 ~> m2 or kg2 m-4]. + real :: err_est ! An estimate of what err will be [H2 ~> m2 or kg2 m-4]. real :: eL ! 1 or 0, depending on whether increases in E lead ! to decreases in the entrainment from below by the ! deepest buffer layer. - real :: fa, fk, fm, fr ! Temporary variables used to calculate err, in ND, H2, H, H. - real :: tolerance ! The tolerance within which E must be converged, in H. - real :: E_prev ! The previous value of E, in H. + real :: fa ! Temporary variable used to calculate err [nondim]. + real :: fk ! Temporary variable used to calculate err [H2 ~> m2 or kg2 m-4]. + real :: fm, fr ! Temporary variables used to calculate err [H ~> m or kg m-2]. + real :: tolerance ! The tolerance within which E must be converged [H ~> m or kg m-2]. + real :: E_prev ! The previous value of E [H ~> m or kg m-2]. logical, dimension(SZI_(G)) :: false_position ! If true, the false position ! method might be used for the next iteration. logical, dimension(SZI_(G)) :: redo_i ! If true, more work is needed on this column. logical :: do_any - real :: large_err ! A large error measure, in H2. + real :: large_err ! A large error measure [H2 ~> m2 or kg2 m-4]. integer :: i, it integer, parameter :: MAXIT = 30 @@ -1748,7 +1655,7 @@ subroutine determine_Ea_kb(h_bl, dtKd_kb, Sref, I_dSkbp1, Ent_bl, ea_kbp1, & call MOM_error(FATAL, "determine_Ea_kb should not be called "//& "unless BULKMIXEDLAYER is defined.") endif - tolerance = GV%m_to_H * CS%Tolerance_Ent + tolerance = CS%Tolerance_Ent large_err = GV%m_to_H**2 * 1.0e30 do i=is,ie ; redo_i(i) = do_i(i) ; enddo @@ -1790,7 +1697,7 @@ subroutine determine_Ea_kb(h_bl, dtKd_kb, Sref, I_dSkbp1, Ent_bl, ea_kbp1, & fa = (1.0 + eL) + dS_kb(i)*I_dSkbp1(i) fk = dtKd_kb(i) * (dS_Lay(i)/dS_kb(i)) fm = (ea_kbp1(i) - h_bl(i,kmb+1)) + eL*2.0*Ent_bl(i,Kmb+1) - if (fm > -GV%Angstrom) fm = fm + GV%Angstrom ! This could be smooth if need be. + if (fm > -GV%Angstrom_H) fm = fm + GV%Angstrom_H ! This could be smooth if need be. err(i) = (fa * Ent(i)**2 - fm * Ent(i)) - fk derror_dE(i) = ((2.0*fa + (ddSkb_dE(i)*I_dSkbp1(i))*Ent(i))*Ent(i) - fm) - & dtKd_kb(i) * (ddSlay_dE(i)*dS_kb(i) - ddSkb_dE(i)*dS_Lay(i))/(dS_kb(i)**2) @@ -1868,71 +1775,49 @@ subroutine determine_Ea_kb(h_bl, dtKd_kb, Sref, I_dSkbp1, Ent_bl, ea_kbp1, & end subroutine determine_Ea_kb +!> Maximize F = ent*ds_kb*I_dSkbp1 in the range min_ent < ent < max_ent. subroutine find_maxF_kb(h_bl, Sref, Ent_bl, I_dSkbp1, min_ent_in, max_ent_in, & kmb, is, ie, G, GV, CS, maxF, ent_maxF, do_i_in, & F_lim_maxent, F_thresh) - 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(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),SZK_(G)), & - intent(in) :: h_bl !< Layer thickness, in m or kg m-2 - !! (abbreviated as H below). + intent(in) :: h_bl !< Layer thickness [H ~> m or kg m-2] real, dimension(SZI_(G),SZK_(G)), & - intent(in) :: Sref !< Reference potential density (in kg m-3?). + intent(in) :: Sref !< Reference potential density [kg m-3]. real, dimension(SZI_(G),SZK_(G)), & - intent(in) :: Ent_bl !< The average entrainment upward and - !! downward across each interface around - !! the buffer layers, in H. - real, dimension(SZI_(G)), intent(in) :: I_dSkbp1 !< The inverse of the difference in - !! reference potential density across the - !! base of the uppermost interior layer, - !! in units of m3 kg-1. - real, dimension(SZI_(G)), intent(in) :: min_ent_in !< The minimum value of ent to search, - !! in H. - real, dimension(SZI_(G)), intent(in) :: max_ent_in !< The maximum value of ent to search, - !! in H. - integer, intent(in) :: kmb - integer, intent(in) :: is, ie !< The range of i-indices to work on. - type(entrain_diffusive_CS), pointer :: CS !< This module's control structure. - real, dimension(SZI_(G)), intent(out) :: maxF !< The maximum value of F - !! = ent*ds_kb*I_dSkbp1 found in the range - !! min_ent < ent < max_ent, in H. - real, dimension(SZI_(G)), intent(out), & - optional :: ent_maxF !< The value of ent at that maximum, in H. - logical, dimension(SZI_(G)), intent(in), & - optional :: do_i_in !< A logical array indicating which columns - !! to work on. - real, dimension(SZI_(G)), intent(out), & - optional :: F_lim_maxent !< If present, do not apply the limit in - !! finding the maximum value, but return the - !! limited value at ent=max_ent_in in this - !! array, in H. - real, dimension(SZI_(G)), intent(in), & - optional :: F_thresh !< If F_thresh is present, return the first - !! value found that has F > F_thresh, or - !! the maximum. - -! Arguments: h_bl - Layer thickness, in m or kg m-2 (abbreviated as H below). -! (in) Sref - Reference potential density (in kg m-3?) -! (in) Ent_bl - The average entrainment upward and downward across -! each interface around the buffer layers, in H. -! (in) I_dSkbp1 - The inverse of the difference in reference potential -! density across the base of the uppermost interior layer, -! in units of m3 kg-1. -! (in) min_ent_in - The minimum value of ent to search, in H. -! (in) max_ent_in - The maximum value of ent to search, in H. -! (in) is, ie - The range of i-indices to work on. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - This module's control structure. -! (out) maxF - The maximum value of F = ent*ds_kb*I_dSkbp1 found in the -! range min_ent < ent < max_ent, in H. -! (out,opt) ent_maxF - The value of ent at that maximum, in H. -! (in, opt) do_i_in - A logical array indicating which columns to work on. -! (out,opt) F_lim_maxent - If present, do not apply the limit in finding the -! maximum value, but return the limited value at -! ent=max_ent_in in this array, in H. -! (in, opt) F_thresh - If F_thresh is present, return the first value found -! that has F > F_thresh, or the maximum. + intent(in) :: Ent_bl !< The average entrainment upward and + !! downward across each interface around + !! the buffer layers [H ~> m or kg m-2]. + real, dimension(SZI_(G)), intent(in) :: I_dSkbp1 !< The inverse of the difference in + !! reference potential density across the + !! base of the uppermost interior layer + !! [m3 kg-1]. + real, dimension(SZI_(G)), intent(in) :: min_ent_in !< The minimum value of ent to search, + !! [H ~> m or kg m-2]. + real, dimension(SZI_(G)), intent(in) :: max_ent_in !< The maximum value of ent to search, + !! [H ~> m or kg m-2]. + integer, intent(in) :: kmb !< The number of mixed and buffer layers. + integer, intent(in) :: is !< The start of the i-index range to work on. + integer, intent(in) :: ie !< The end of the i-index range to work on. + type(entrain_diffusive_CS), pointer :: CS !< This module's control structure. + real, dimension(SZI_(G)), intent(out) :: maxF !< The maximum value of F + !! = ent*ds_kb*I_dSkbp1 found in the range + !! min_ent < ent < max_ent [H ~> m or kg m-2]. + real, dimension(SZI_(G)), & + optional, intent(out) :: ent_maxF !< The value of ent at that maximum [H ~> m or kg m-2]. + logical, dimension(SZI_(G)), & + optional, intent(in) :: do_i_in !< A logical array indicating which columns + !! to work on. + real, dimension(SZI_(G)), & + optional, intent(out) :: F_lim_maxent !< If present, do not apply the limit in + !! finding the maximum value, but return the + !! limited value at ent=max_ent_in in this + !! array [H ~> m or kg m-2]. + real, dimension(SZI_(G)), & + optional, intent(in) :: F_thresh !< If F_thresh is present, return the first + !! value found that has F > F_thresh, or + !! the maximum. ! Maximize F = ent*ds_kb*I_dSkbp1 in the range min_ent < ent < max_ent. ! ds_kb may itself be limited to positive values in determine_dSkb, which gives @@ -1957,7 +1842,7 @@ subroutine find_maxF_kb(h_bl, Sref, Ent_bl, I_dSkbp1, min_ent_in, max_ent_in, & integer :: i, it, is1, ie1 integer, parameter :: MAXIT = 20 - tolerance = GV%m_to_H * CS%Tolerance_Ent + tolerance = CS%Tolerance_Ent if (present(do_i_in)) then do i=is,ie ; do_i(i) = do_i_in(i) ; enddo @@ -2109,7 +1994,7 @@ subroutine find_maxF_kb(h_bl, Sref, Ent_bl, I_dSkbp1, min_ent_in, max_ent_in, & new_min_bound = .false. ! We have a new maximum bound. else ! This case would bracket a minimum. Wierd. ! Unless the derivative indicates that there is a maximum near the - ! lower bound, try keeping the end with the larger value of F; + ! lower bound, try keeping the end with the larger value of F ! in a tie keep the minimum as the answer here will be compared ! with the maximum input value later. new_min_bound = .true. @@ -2186,10 +2071,13 @@ subroutine find_maxF_kb(h_bl, Sref, Ent_bl, I_dSkbp1, min_ent_in, max_ent_in, & end subroutine find_maxF_kb -subroutine entrain_diffusive_init(Time, G, GV, param_file, diag, CS) +!> This subroutine initializes the parameters and memory associated with the +!! entrain_diffusive module. +subroutine entrain_diffusive_init(Time, G, GV, US, param_file, diag, CS) type(time_type), intent(in) :: Time !< The 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 !< A structure that is used to regulate diagnostic @@ -2208,7 +2096,7 @@ subroutine entrain_diffusive_init(Time, G, GV, param_file, diag, CS) real :: decay_length, dt, Kd ! This include declares and sets the variable "version". #include "version_variable.h" - character(len=40) :: mod = "MOM_entrain_diffusive" ! This module's name. + character(len=40) :: mdl = "MOM_entrain_diffusive" ! This module's name. if (associated(CS)) then call MOM_error(WARNING, "entrain_diffusive_init called with an associated "// & @@ -2222,37 +2110,70 @@ subroutine entrain_diffusive_init(Time, G, GV, param_file, diag, CS) CS%bulkmixedlayer = (GV%nkml > 0) ! Set default, read and log parameters - call log_version(param_file, mod, version, "") - call get_param(param_file, mod, "CORRECT_DENSITY", CS%correct_density, & + 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"//& "mixing, as described in Hallberg (MWR, 2000).", & default=.true.) - call get_param(param_file, mod, "MAX_ENT_IT", CS%max_ent_it, & + call get_param(param_file, mdl, "MAX_ENT_IT", CS%max_ent_it, & "The maximum number of iterations that may be used to \n"//& "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, mod, "KD", Kd, fail_if_missing=.true.) - call get_param(param_file, mod, "DT", dt, & +! 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.) + call get_param(param_file, mdl, "DT", dt, & "The (baroclinic) dynamics time step.", units = "s", & fail_if_missing=.true.) -! CS%Tolerance_Ent = MAX(100.0*GV%Angstrom,1.0e-4*sqrt(dt*Kd)) ! - call get_param(param_file, mod, "TOLERANCE_ENT", CS%Tolerance_Ent, & +! CS%Tolerance_Ent = MAX(100.0*GV%Angstrom_H,1.0e-4*sqrt(dt*Kd)) ! + call get_param(param_file, mdl, "TOLERANCE_ENT", CS%Tolerance_Ent, & "The tolerance with which to solve for entrainment values.", & - units="m", default=MAX(100.0*GV%Angstrom_Z,1.0e-4*sqrt(dt*Kd))) + units="m", default=MAX(100.0*GV%Angstrom_m,1.0e-4*sqrt(dt*Kd)), scale=GV%m_to_H) CS%id_Kd = register_diag_field('ocean_model', 'Kd_effective', diag%axesTL, Time, & - 'Diapycnal diffusivity as applied', 'm2 s-1') + 'Diapycnal diffusivity as applied', 'm2 s-1', conversion=US%Z_to_m**2) CS%id_diff_work = register_diag_field('ocean_model', 'diff_work', diag%axesTi, Time, & - 'Work actually done by diapycnal diffusion across each interface', 'W m-2') + 'Work actually done by diapycnal diffusion across each interface', 'W m-2', conversion=US%Z_to_m) end subroutine entrain_diffusive_init +!> This subroutine cleans up and deallocates any memory associated with the +!! entrain_diffusive module. subroutine entrain_diffusive_end(CS) - type(entrain_diffusive_CS), pointer :: CS - + type(entrain_diffusive_CS), pointer :: CS !< A pointer to the control structure for this + !! module that will be deallocated. if (associated(CS)) deallocate(CS) end subroutine entrain_diffusive_end +!> \namespace mom_entrain_diffusive +!! +!! By Robert Hallberg, September 1997 - July 2000 +!! +!! This file contains the subroutines that implement diapycnal +!! mixing and advection in isopycnal layers. The main subroutine, +!! calculate_entrainment, returns the entrainment by each layer +!! across the interfaces above and below it. These are calculated +!! subject to the constraints that no layers can be driven to neg- +!! ative thickness and that the each layer maintains its target +!! density, using the scheme described in Hallberg (MWR 2000). There +!! may or may not be a bulk mixed layer above the isopycnal layers. +!! The solution is iterated until the change in the entrainment +!! between successive iterations is less than some small tolerance. +!! +!! The dual-stream entrainment scheme of MacDougall and Dewar +!! (JPO 1997) is used for combined diapycnal advection and diffusion, +!! modified as described in Hallberg (MWR 2000) to be solved +!! implicitly in time. Any profile of diffusivities may be used. +!! Diapycnal advection is fundamentally the residual of diapycnal +!! diffusion, so the fully implicit upwind differencing scheme that +!! is used is entirely appropriate. The downward buoyancy flux in +!! each layer is determined from an implicit calculation based on +!! the previously calculated flux of the layer above and an estim- +!! ated flux in the layer below. This flux is subject to the foll- +!! owing conditions: (1) the flux in the top and bottom layers are +!! set by the boundary conditions, and (2) no layer may be driven +!! below an Angstrom thickness. If there is a bulk mixed layer, the +!! mixed and buffer layers are treated as Eulerian layers, whose +!! thicknesses only change due to entrainment by the interior layers. + end module MOM_entrain_diffusive diff --git a/src/parameterizations/vertical/MOM_full_convection.F90 b/src/parameterizations/vertical/MOM_full_convection.F90 new file mode 100644 index 0000000000..5fd3d67b36 --- /dev/null +++ b/src/parameterizations/vertical/MOM_full_convection.F90 @@ -0,0 +1,425 @@ +!> Does full convective adjustment of unstable regions via a strong diffusivity. +module MOM_full_convection + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_grid, only : ocean_grid_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use MOM_EOS, only : int_specific_vol_dp, calculate_density_derivs + +implicit none ; private + +#include + +public full_convection + +contains + +!> Calculate new temperatures and salinities that have been subject to full convective mixing. +subroutine full_convection(G, GV, h, tv, T_adj, S_adj, p_surf, Kddt_smooth, & + Kddt_convect, halo) + 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 !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(out) :: T_adj !< Adjusted potential temperature [degC]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(out) :: S_adj !< Adjusted salinity [ppt]. + real, dimension(:,:), pointer :: p_surf !< The pressure at the ocean surface [Pa] (or NULL). + real, intent(in) :: Kddt_smooth !< A smoothing vertical + !! diffusivity times a timestep [H2 ~> m2 or kg2 m-4]. + real, optional, intent(in) :: Kddt_convect !< A large convecting vertical + !! diffusivity times a timestep [H2 ~> m2 or kg2 m-4]. + integer, optional, intent(in) :: halo !< Halo width over which to compute + + ! Local variables + real, dimension(SZI_(G),SZK_(G)+1) :: & + drho_dT, & ! The derivatives of density with temperature and + drho_dS ! salinity [kg m-3 degC-1] and [kg m-3 ppt-1]. + real :: h_neglect, h0 ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [H ~> m or kg m-2]. +! logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. + real, dimension(SZI_(G),SZK0_(G)) :: & + Te_a, & ! A partially updated temperature estimate including the influnce from + ! mixing with layers above rescaled by a factor of d_a [degC]. + ! This array is discreted on tracer cells, but contains an extra + ! layer at the top for algorithmic convenience. + Se_a ! A partially updated salinity estimate including the influnce from + ! mixing with layers above rescaled by a factor of d_a [ppt]. + ! This array is discreted on tracer cells, but contains an extra + ! layer at the top for algorithmic convenience. + real, dimension(SZI_(G),SZK_(G)+1) :: & + Te_b, & ! A partially updated temperature estimate including the influnce from + ! mixing with layers below rescaled by a factor of d_b [degC]. + ! This array is discreted on tracer cells, but contains an extra + ! layer at the bottom for algorithmic convenience. + Se_b ! A partially updated salinity estimate including the influnce from + ! mixing with layers below rescaled by a factor of d_b [ppt]. + ! This array is discreted on tracer cells, but contains an extra + ! layer at the bottom for algorithmic convenience. + real, dimension(SZI_(G),SZK_(G)+1) :: & + c_a, & ! The fractional influence of the properties of the layer below + ! in the final properies with a downward-first solver, nondim. + d_a, & ! The fractional influence of the properties of the layer in question + ! and layers above in the final properies with a downward-first solver, nondim. + ! d_a = 1.0 - c_a + c_b, & ! The fractional influence of the properties of the layer above + ! in the final properies with a upward-first solver, nondim. + d_b ! The fractional influence of the properties of the layer in question + ! and layers below in the final properies with a upward-first solver, nondim. + ! d_b = 1.0 - c_b + real, dimension(SZI_(G),SZK_(G)+1) :: & + mix !< The amount of mixing across the interface between layers [H ~> m or kg m-2]. + real :: mix_len ! The length-scale of mixing, when it is active [H ~> m or kg m-2] + real :: h_b, h_a ! The thicknessses of the layers above and below an interface [H ~> m or kg m-2] + real :: b_b, b_a ! Inverse pivots used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. + + real :: kap_dt_x2 ! The product of 2*kappa*dt [H2 ~> m2 or kg2 m-4]. + + logical, dimension(SZI_(G)) :: do_i ! Do more work on this column. + logical, dimension(SZI_(G)) :: last_down ! The last setup pass was downward. + integer, dimension(SZI_(G)) :: change_ct ! The number of interfaces where the + ! mixing has changed this iteration. + integer :: changed_col ! The number of colums whose mixing changed. + integer :: i, j, k, is, ie, js, je, nz, itt + + if (present(halo)) then + is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo + else + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + endif + nz = G%ke + + if (.not.associated(tv%eqn_of_state)) return + + h_neglect = GV%H_subroundoff + kap_dt_x2 = 0.0 + if (present(Kddt_convect)) kap_dt_x2 = 2.0*Kddt_convect + mix_len = (1.0e20 * nz) * (G%max_depth * GV%Z_to_H) + h0 = 1.0e-16*sqrt(Kddt_smooth) + h_neglect + + do j=js,je + mix(:,:) = 0.0 ; d_b(:,:) = 1.0 + ! These would be Te_b(:,:) = tv%T(:,j,:), etc., but the values are not used + Te_b(:,:) = 0.0 ; Se_b(:,:) = 0.0 + + call smoothed_dRdT_dRdS(h, tv, Kddt_smooth, drho_dT, drho_dS, G, GV, j, p_surf, halo) + + do i=is,ie + do_i(i) = (G%mask2dT(i,j) > 0.0) + + d_a(i,1) = 1.0 + last_down(i) = .true. ! This is set for debuggers. + ! These are extra values are used for convenience in the stability test + Te_a(i,0) = 0.0 ; Se_a(i,0) = 0.0 + enddo + + do itt=1,nz ! At least 2 interfaces will change with each full pass, or the + ! iterations stop, so the maximum count of nz is very conservative. + + do i=is,ie ; change_ct(i) = 0 ; enddo + ! Move down the water column, finding unstable interfaces, and building up the + ! temporary arrays for the tridiagonal solver. + do K=2,nz ; do i=is,ie ; if (do_i(i)) then + + h_a = h(i,j,k-1) + h_neglect ; h_b = h(i,j,k) + h_neglect + if (mix(i,K) <= 0.0) then + if (is_unstable(dRho_dT(i,K), dRho_dS(i,K), h_a, h_b, mix(i,K-1), mix(i,K+1), & + tv%T(i,j,k-1), tv%T(i,j,k), tv%S(i,j,k-1), tv%S(i,j,k), & + Te_a(i,k-2), Te_b(i,k+1), Se_a(i,k-2), Se_b(i,k+1), & + d_a(i,K-1), d_b(i,K+1))) then + mix(i,K) = mix_len + if (kap_dt_x2 > 0.0) mix(i,K) = kap_dt_x2 / ((h(i,j,k-1)+h(i,j,k)) + h0) + change_ct(i) = change_ct(i) + 1 + endif + endif + + b_a = 1.0 / ((h_a + d_a(i,K-1)*mix(i,K-1)) + mix(i,K)) + if (mix(i,K) <= 0.0) then + c_a(i,K) = 0.0 ; d_a(i,K) = 1.0 + else + d_a(i,K) = b_a * (h_a + d_a(i,K-1)*mix(i,K-1)) ! = 1.0-c_a(i,K) + c_a(i,K) = 1.0 ; if (d_a(i,K) > epsilon(b_a)) c_a(i,K) = b_a * mix(i,K) + endif + + if (K>2) then + Te_a(i,k-1) = b_a * (h_a*tv%T(i,j,k-1) + mix(i,K-1)*Te_a(i,k-2)) + Se_a(i,k-1) = b_a * (h_a*tv%S(i,j,k-1) + mix(i,K-1)*Se_a(i,k-2)) + else + Te_a(i,k-1) = b_a * (h_a*tv%T(i,j,k-1)) + Se_a(i,k-1) = b_a * (h_a*tv%S(i,j,k-1)) + endif + endif ; enddo ; enddo + + ! Determine which columns might have further instabilities. + changed_col = 0 + do i=is,ie ; if (do_i(i)) then + if (change_ct(i) == 0) then + last_down(i) = .true. ; do_i(i) = .false. + else + changed_col = changed_col + 1 ; change_ct(i) = 0 + endif + endif ; enddo + if (changed_col == 0) exit ! No more columns are unstable. + + ! This is the same as above, but with the direction reversed (bottom to top) + do K=nz,2,-1 ; do i=is,ie ; if (do_i(i)) then + + h_a = h(i,j,k-1) + h_neglect ; h_b = h(i,j,k) + h_neglect + if (mix(i,K) <= 0.0) then + if (is_unstable(dRho_dT(i,K), dRho_dS(i,K), h_a, h_b, mix(i,K-1), mix(i,K+1), & + tv%T(i,j,k-1), tv%T(i,j,k), tv%S(i,j,k-1), tv%S(i,j,k), & + Te_a(i,k-2), Te_b(i,k+1), Se_a(i,k-2), Se_b(i,k+1), & + d_a(i,K-1), d_b(i,K+1))) then + mix(i,K) = mix_len + if (kap_dt_x2 > 0.0) mix(i,K) = kap_dt_x2 / ((h(i,j,k-1)+h(i,j,k)) + h0) + change_ct(i) = change_ct(i) + 1 + endif + endif + + b_b = 1.0 / ((h_b + d_b(i,K+1)*mix(i,K+1)) + mix(i,K)) + if (mix(i,K) <= 0.0) then + c_b(i,K) = 0.0 ; d_b(i,K) = 1.0 + else + d_b(i,K) = b_b * (h_b + d_b(i,K+1)*mix(i,K+1)) ! = 1.0-c_b(i,K) + c_b(i,K) = 1.0 ; if (d_b(i,K) > epsilon(b_b)) c_b(i,K) = b_b * mix(i,K) + endif + + if (k 0.0) .and. last_down(i)) ; enddo + do i=is,ie ; if (do_i(i)) then + h_a = h(i,j,nz) + h_neglect + b_a = 1.0 / (h_a + d_a(i,nz)*mix(i,nz)) + T_adj(i,j,nz) = b_a * (h_a*tv%T(i,j,nz) + mix(i,nz)*Te_a(i,nz-1)) + S_adj(i,j,nz) = b_a * (h_a*tv%S(i,j,nz) + mix(i,nz)*Se_a(i,nz-1)) + endif ; enddo + do k=nz-1,1,-1 ; do i=is,ie ; if (do_i(i)) then + T_adj(i,j,k) = Te_a(i,k) + c_a(i,K+1)*T_adj(i,j,k+1) + S_adj(i,j,k) = Se_a(i,k) + c_a(i,K+1)*S_adj(i,j,k+1) + endif ; enddo ; enddo + + do i=is,ie ; if (do_i(i)) then + k = 1 ! A hook for debugging. + endif ; enddo + + ! Do the final return pass on the columns where the penultimate pass was upward. + ! Also do a simple copy of T & S values on land points. + do i=is,ie + do_i(i) = ((G%mask2dT(i,j) > 0.0) .and. .not.last_down(i)) + if (do_i(i)) then + h_b = h(i,j,1) + h_neglect + b_b = 1.0 / (h_b + d_b(i,2)*mix(i,2)) + T_adj(i,j,1) = b_b * (h_b*tv%T(i,j,1) + mix(i,2)*Te_b(i,2)) + S_adj(i,j,1) = b_b * (h_b*tv%S(i,j,1) + mix(i,2)*Se_b(i,2)) + elseif (G%mask2dT(i,j) <= 0.0) then + T_adj(i,j,1) = tv%T(i,j,1) ; S_adj(i,j,1) = tv%S(i,j,1) + endif + enddo + do k=2,nz ; do i=is,ie + if (do_i(i)) then + T_adj(i,j,k) = Te_b(i,k) + c_b(i,K)*T_adj(i,j,k-1) + S_adj(i,j,k) = Se_b(i,k) + c_b(i,K)*S_adj(i,j,k-1) + elseif (G%mask2dT(i,j) <= 0.0) then + T_adj(i,j,k) = tv%T(i,j,k) ; S_adj(i,j,k) = tv%S(i,j,k) + endif + enddo ; enddo + + do i=is,ie ; if (do_i(i)) then + k = 1 ! A hook for debugging. + endif ; enddo + + enddo ! j-loop + + k = 1 ! A hook for debugging. + + ! The following set of expressions for the final values are derived from the the partial + ! updates for the estimated temperatures and salinities around an interface, then directly + ! solving for the final temperatures and salinities. They are here for later reference + ! and to document an intermediate step in the stability calculation. + ! hp_a = (h_a + d_a(i,K-1)*mix(i,K-1)) + ! hp_b = (h_b + d_b(i,K+1)*mix(i,K+1)) + ! b2_c = 1.0 / (hp_a*hp_b + (hp_a + hp_b) * mix(i,K)) + ! Th_a = h_a*tv%T(i,j,k-1) + mix(i,K-1)*Te_a(i,k-2) + ! Th_b = h_b*tv%T(i,j,k) + mix(i,K+1)*Te_b(i,k+1) + ! T_fin(i,k) = ( (hp_a + mix(i,K)) * Th_b + Th_a * mix(i,K) ) * b2_c + ! T_fin(i,k-1) = ( (hp_b + mix(i,K)) * Th_a + Th_b * mix(i,K) ) * b2_c + ! Sh_a = h_a*tv%S(i,j,k-1) + mix(i,K-1)*Se_a(i,k-2) + ! Sh_b = h_b*tv%S(i,j,k) + mix(i,K+1)*Se_b(i,k+1) + ! S_fin(i,k) = ( (hp_a + mix(i,K)) * Sh_b + Sh_a * mix(i,K) ) * b2_c + ! S_fin(i,k-1) = ( (hp_b + mix(i,K)) * Sh_a + Sh_b * mix(i,K) ) * b2_c + +end subroutine full_convection + +!> This function returns True if the profiles around the given interface will be +!! statically unstable after mixing above below. The arguments are the ocean state +!! above and below, including partial calculations from a tridiagonal solver. +function is_unstable(dRho_dT, dRho_dS, h_a, h_b, mix_A, mix_B, T_a, T_b, S_a, S_b, & + Te_aa, Te_bb, Se_aa, Se_bb, d_A, d_B) + real, intent(in) :: dRho_dT !< The derivative of in situ density with temperature [kg m-3 degC-1] + real, intent(in) :: dRho_dS !< The derivative of in situ density with salinity [kg m-3 ppt-1] + real, intent(in) :: h_a !< The thickness of the layer above [H ~> m or kg m-2] + real, intent(in) :: h_b !< The thickness of the layer below [H ~> m or kg m-2] + real, intent(in) :: mix_A !< The time integrated mixing rate of the interface above [H ~> m or kg m-2] + real, intent(in) :: mix_B !< The time integrated mixing rate of the interface below [H ~> m or kg m-2] + real, intent(in) :: T_a !< The initial temperature of the layer above [degC] + real, intent(in) :: T_b !< The initial temperature of the layer below [degC] + real, intent(in) :: S_a !< The initial salinity of the layer below [ppt] + real, intent(in) :: S_b !< The initial salinity of the layer below [ppt] + real, intent(in) :: Te_aa !< The estimated temperature two layers above rescaled by d_A [degC] + real, intent(in) :: Te_bb !< The estimated temperature two layers below rescaled by d_B [degC] + real, intent(in) :: Se_aa !< The estimated salinity two layers above rescaled by d_A [ppt] + real, intent(in) :: Se_bb !< The estimated salinity two layers below rescaled by d_B [ppt] + real, intent(in) :: d_A !< The rescaling dependency across the interface above, nondim. + real, intent(in) :: d_B !< The rescaling dependency across the interface below, nondim. + logical :: is_unstable !< The return value, true if the profile is statically unstable + !! around the interface in question. + + ! These expressions for the local stability are long, but they have been carefully + ! grouped for accuracy even when the mixing rates are huge or tiny, and common + ! positive definite factors that would appear in the final expression for the + ! locally referenced potential density difference across an interface have been omitted. + is_unstable = (dRho_dT * ((h_a * h_b * (T_b - T_a) + & + mix_A*mix_B * (d_A*Te_bb - d_B*Te_aa)) + & + (h_a*mix_B * (Te_bb - d_B*T_a) + & + h_b*mix_A * (d_A*T_b - Te_aa)) ) + & + dRho_dS * ((h_a * h_b * (S_b - S_a) + & + mix_A*mix_B * (d_A*Se_bb - d_B*Se_aa)) + & + (h_a*mix_B * (Se_bb - d_B*S_a) + & + h_b*mix_A * (d_A*S_b - Se_aa)) ) < 0.0) +end function is_unstable + +!> Returns the partial derivatives of locally referenced potential density with +!! temperature and salinity after the properties have been smoothed with a small +!! constant diffusivity. +subroutine smoothed_dRdT_dRdS(h, tv, Kddt, dR_dT, dR_dS, G, GV, j, p_surf, halo) + 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 !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables + real, intent(in) :: Kddt !< A diffusivity times a time increment [H2 ~> m2 or kg2 m-4]. + real, dimension(SZI_(G),SZK_(G)+1), & + intent(out) :: dR_dT !< Derivative of locally referenced + !! potential density with temperature [kg m-3 degC-1] + real, dimension(SZI_(G),SZK_(G)+1), & + intent(out) :: dR_dS !< Derivative of locally referenced + !! potential density with salinity [kg m-3 ppt-1] + integer, intent(in) :: j !< The j-point to work on. + real, dimension(:,:), pointer :: p_surf !< The pressure at the ocean surface [Pa]. + integer, optional, intent(in) :: halo !< Halo width over which to compute + + ! Local variables + real :: mix(SZI_(G),SZK_(G)+1) ! The diffusive mixing length (kappa*dt)/dz + ! between layers within in a timestep [H ~> m or kg m-2]. + real :: b1(SZI_(G)), d1(SZI_(G)) ! b1, c1, and d1 are variables used by the + real :: c1(SZI_(G),SZK_(G)) ! tridiagonal solver. + real :: T_f(SZI_(G),SZK_(G)) ! Filtered temperatures [degC] + real :: S_f(SZI_(G),SZK_(G)) ! Filtered salinities [ppt] + real :: pres(SZI_(G)) ! Interface pressures [Pa]. + real :: T_EOS(SZI_(G)) ! Filtered and vertically averaged temperatures [degC] + real :: S_EOS(SZI_(G)) ! Filtered and vertically averaged salinities [ppt] + real :: kap_dt_x2 ! The product of 2*kappa*dt [H2 ~> m2 or kg2 m-4]. + real :: h_neglect, h0 ! Negligible thicknesses to allow for zero thicknesses, + ! [H ~> m or kg m-2]. + real :: h_tr ! The thickness at tracer points, plus h_neglect [H ~> m or kg m-2]. + integer :: i, k, is, ie, nz + + if (present(halo)) then + is = G%isc-halo ; ie = G%iec+halo + else + is = G%isc ; ie = G%iec + endif + nz = G%ke + + h_neglect = GV%H_subroundoff + kap_dt_x2 = 2.0*Kddt + + if (Kddt <= 0.0) then + do k=1,nz ; do i=is,ie + T_f(i,k) = tv%T(i,j,k) ; S_f(i,k) = tv%S(i,j,k) + enddo ; enddo + else + h0 = 1.0e-16*sqrt(Kddt) + h_neglect + do i=is,ie + mix(i,2) = kap_dt_x2 / ((h(i,j,1)+h(i,j,2)) + h0) + + h_tr = h(i,j,1) + h_neglect + b1(i) = 1.0 / (h_tr + mix(i,2)) + d1(i) = b1(i) * h(i,j,1) + T_f(i,1) = (b1(i)*h_tr)*tv%T(i,j,1) + S_f(i,1) = (b1(i)*h_tr)*tv%S(i,j,1) + enddo + do k=2,nz-1 ; do i=is,ie + mix(i,K+1) = kap_dt_x2 / ((h(i,j,k)+h(i,j,k+1)) + h0) + + c1(i,k) = mix(i,K) * b1(i) + h_tr = h(i,j,k) + h_neglect + b1(i) = 1.0 / ((h_tr + d1(i)*mix(i,K)) + mix(i,K+1)) + d1(i) = b1(i) * (h_tr + d1(i)*mix(i,K)) + T_f(i,k) = b1(i) * (h_tr*tv%T(i,j,k) + mix(i,K)*T_f(i,k-1)) + S_f(i,k) = b1(i) * (h_tr*tv%S(i,j,k) + mix(i,K)*S_f(i,k-1)) + enddo ; enddo + do i=is,ie + c1(i,nz) = mix(i,nz) * b1(i) + h_tr = h(i,j,nz) + h_neglect + b1(i) = 1.0 / (h_tr + d1(i)*mix(i,nz)) + T_f(i,nz) = b1(i) * (h_tr*tv%T(i,j,nz) + mix(i,nz)*T_f(i,nz-1)) + S_f(i,nz) = b1(i) * (h_tr*tv%S(i,j,nz) + mix(i,nz)*S_f(i,nz-1)) + enddo + do k=nz-1,1,-1 ; do i=is,ie + T_f(i,k) = T_f(i,k) + c1(i,k+1)*T_f(i,k+1) + S_f(i,k) = S_f(i,k) + c1(i,k+1)*S_f(i,k+1) + enddo ; enddo + endif + + if (associated(p_surf)) then + do i=is,ie ; pres(i) = p_surf(i,j) ; enddo + else + do i=is,ie ; pres(i) = 0.0 ; enddo + endif + call calculate_density_derivs(T_f(:,1), S_f(:,1), pres, dR_dT(:,1), dR_dS(:,1), & + is-G%isd+1, ie-is+1, tv%eqn_of_state) + do i=is,ie ; pres(i) = pres(i) + h(i,j,1)*GV%H_to_Pa ; enddo + do K=2,nz + do i=is,ie + T_EOS(i) = 0.5*(T_f(i,k-1) + T_f(i,k)) + S_EOS(i) = 0.5*(S_f(i,k-1) + S_f(i,k)) + enddo + call calculate_density_derivs(T_EOS, S_EOS, pres, dR_dT(:,K), dR_dS(:,K), & + is-G%isd+1, ie-is+1, tv%eqn_of_state) + do i=is,ie ; pres(i) = pres(i) + h(i,j,k)*GV%H_to_Pa ; enddo + enddo + call calculate_density_derivs(T_f(:,nz), S_f(:,nz), pres, dR_dT(:,nz+1), dR_dS(:,nz+1), & + is-G%isd+1, ie-is+1, tv%eqn_of_state) + + +end subroutine smoothed_dRdT_dRdS + +end module MOM_full_convection diff --git a/src/parameterizations/vertical/MOM_geothermal.F90 b/src/parameterizations/vertical/MOM_geothermal.F90 index bfad193803..7ca06c6139 100644 --- a/src/parameterizations/vertical/MOM_geothermal.F90 +++ b/src/parameterizations/vertical/MOM_geothermal.F90 @@ -1,40 +1,11 @@ +!> Implemented geothermal heating at the ocean bottom. module MOM_geothermal ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Robert Hallberg, 2010. * -!* * -!* This file contains the subroutine (geothemal) that implements * -!* a geothermal heating at the bottom. This can be done either in a * -!* layered isopycnal mode, in which the heating raises the density of * -!* the layer to the target density of the layer above, and then moves * -!* the water into that layer, or in a simple Eulerian mode, in which * -!* the bottommost GEOTHERMAL_THICKNESS are heated. Geothermal heating* -!* will also provide a buoyant source of bottom TKE that can be used * -!* to further mix the near-bottom water. In cold fresh water lakes * -!* where heating increases density, water should be moved into deeper * -!* layers, but this is not implemented yet. * -!* * -!* Macros written all in capital letters are defined in MOM_memory.h. * -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q * -!* j+1 > o > o > At ^: v * -!* j x ^ x ^ x At >: u * -!* j > o > o > At o: h, buoy, Rml, eaml, ebml, etc. * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** - use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : register_static_field, time_type, diag_ctrl +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_io, only : MOM_read_data, slasher @@ -49,110 +20,85 @@ module MOM_geothermal public geothermal, geothermal_init, geothermal_end +!> Control structure for geothermal heating type, public :: geothermal_CS ; private - real :: dRcv_dT_inplace ! The value of dRcv_dT above which (dRcv_dT is - ! negative) the water is heated in place instead - ! of moving upward between layers, in kg m-3 K-1. - real, pointer :: geo_heat(:,:) => NULL() ! The geothermal heat flux, in - ! W m-2. - real :: geothermal_thick ! The thickness over which geothermal heating is - ! applied, in m. - logical :: apply_geothermal ! If true, geothermal heating will be applied; - ! otherwise GEOTHERMAL_SCALE has been set to 0 and - ! there is no heat to apply. - - type(time_type), pointer :: Time ! A pointer to the ocean model's clock. - type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the - ! timing of diagnostic output. + real :: dRcv_dT_inplace !< The value of dRcv_dT above which (dRcv_dT is + !! negative) the water is heated in place instead + !! of moving upward between layers [kg m-3 degC-1]. + real, pointer :: geo_heat(:,:) => NULL() !< The geothermal heat flux [W m-2]. + real :: geothermal_thick !< The thickness over which geothermal heating is + !! applied [m] (not [H]). + logical :: apply_geothermal !< If true, geothermal heating will be applied + !! otherwise GEOTHERMAL_SCALE has been set to 0 and + !! there is no heat to apply. + + type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. end type geothermal_CS contains -!> This subroutine applies geothermal heating, including the movement of water +!> Applies geothermal heating, including the movement of water !! between isopycnal layers to match the target densities. The heating is !! applied to the bottommost layers that occur within ### of the bottom. If !! the partial derivative of the coordinate density with temperature is positive !! or very small, the layers are simply heated in place. Any heat that can not !! be applied to the ocean is returned (WHERE)? -subroutine geothermal(h, tv, dt, ea, eb, G, GV, CS) +subroutine geothermal(h, tv, dt, ea, eb, G, GV, CS, halo) 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(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thicknesses, in H - !! (usually m or kg m-2). + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] type(thermo_var_ptrs), intent(inout) :: tv !< A structure containing pointers !! to any available thermodynamic !! fields. Absent fields have NULL !! ptrs. - real, intent(in) :: dt !< Time increment, in s. + real, intent(in) :: dt !< Time increment [s]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: ea !< The amount of fluid moved !! downward into a layer; this !! should be increased due to mixed - !! layer detrainment, in the same - !! units as h - usually m or kg m-2 - !! (i.e., H). + !! layer detrainment [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: eb !< The amount of fluid moved upward !! into a layer; this should be !! increased due to mixed layer - !! entrainment, in the same units as - !! h - usually m or kg m-2 (i.e., H) + !! entrainment [H ~> m or kg m-2]. type(geothermal_CS), pointer :: CS !< The control structure returned by !! a previous call to !! geothermal_init. - -! This subroutine applies geothermal heating, including the movement of water -! between isopycnal layers to match the target densities. The heating is -! applied to the bottommost layers that occur within ### of the bottom. If -! the partial derivative of the coordinate density with temperature is positive -! or very small, the layers are simply heated in place. Any heat that can not -! be applied to the ocean is returned (WHERE)? - -! Arguments: h - Layer thickness, in m or kg m-2. (Intent in/out) -! The units of h are referred to as H below. -! (in/out) tv - A structure containing pointers to any available -! thermodynamic fields. Absent fields have NULL ptrs. -! (in) dt - Time increment, in s. -! (in/out) ea - The amount of fluid moved downward into a layer; this should -! be increased due to mixed layer detrainment, in the same units -! as h - usually m or kg m-2 (i.e., H). -! (in/out) eb - The amount of fluid moved upward into a layer; this should -! be increased due to mixed layer entrainment, in the same units -! as h - usually m or kg m-2 (i.e., H). -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - The control structure returned by a previous call to -! geothermal_init. - -! real :: resid(SZI_(G),SZJ_(G)) !z1l: never been used. - + integer, optional, intent(in) :: halo !< Halo width over which to work + ! Local variables real, dimension(SZI_(G)) :: & - heat_rem, & ! remaining heat (H * degC) - h_geo_rem, & ! remaining thickness to apply geothermal heating (units of H) - Rcv_BL, & ! coordinate density in the deepest variable density layer (kg/m3) - p_ref ! coordiante densities reference pressure (Pa) + heat_rem, & ! remaining heat [H degC ~> m degC or kg degC m-2] + h_geo_rem, & ! remaining thickness to apply geothermal heating [H ~> m or kg m-2] + Rcv_BL, & ! coordinate density in the deepest variable density layer [kg m-3] + p_ref ! coordiante densities reference pressure [Pa] real, dimension(2) :: & - T2, S2, & ! temp and saln in the present and target layers (degC and ppt) - dRcv_dT_, & ! partial derivative of coordinate density wrt temp (kg m-3 K-1) - dRcv_dS_ ! partial derivative of coordinate density wrt saln (kg m-3 ppt-1) - - real :: Angstrom, H_neglect ! small thicknesses in H - real :: Rcv ! coordinate density of present layer (kg m-3) - real :: Rcv_tgt ! coordinate density of target layer (kg m-3) - real :: dRcv ! difference between Rcv and Rcv_tgt (kg m-3) + T2, S2, & ! temp and saln in the present and target layers [degC] and [ppt] + dRcv_dT_, & ! partial derivative of coordinate density wrt temp [kg m-3 degC-1] + dRcv_dS_ ! partial derivative of coordinate density wrt saln [kg m-3 ppt-1] + + real :: Angstrom, H_neglect ! small thicknesses [H ~> m or kg m-2] + real :: Rcv ! coordinate density of present layer [kg m-3] + real :: Rcv_tgt ! coordinate density of target layer [kg m-3] + real :: dRcv ! difference between Rcv and Rcv_tgt [kg m-3] real :: dRcv_dT ! partial derivative of coordinate density wrt temp - ! in the present layer (kg m-3 K-1); usually negative - real :: h_heated ! thickness that is being heated (units of H) - real :: heat_avail ! heating available for the present layer (units of Kelvin * H) - real :: heat_in_place ! heating to warm present layer w/o movement between layers (K * H) - real :: heat_trans ! heating available to move water from present layer to target layer (K * H) - real :: heating ! heating used to move water from present layer to target layer (K * H) + ! in the present layer [kg m-3 degC-1]; usually negative + real :: h_heated ! thickness that is being heated [H ~> m or kg m-2] + real :: heat_avail ! heating available for the present layer [degC H ~> degC m or degC kg m-2] + real :: heat_in_place ! heating to warm present layer w/o movement between layers + ! [degC H ~> degC m or degC kg m-2] + real :: heat_trans ! heating available to move water from present layer to target + ! layer [degC H ~> degC m or degC kg m-2] + real :: heating ! heating used to move water from present layer to target layer + ! [degC H ~> degC m or degC kg m-2] ! 0 <= heating <= heat_trans - real :: h_transfer ! thickness moved between layers (units of H) - real :: wt_in_place ! relative weighting that goes from 0 to 1 (non-dim) - real :: I_h ! inverse thickness (units of 1/H) - real :: dTemp ! temperature increase in a layer (Kelvin) - real :: Irho_cp ! inverse of heat capacity per unit layer volume (units K H m2 J-1) + real :: h_transfer ! thickness moved between layers [H ~> m or kg m-2] + real :: wt_in_place ! relative weighting that goes from 0 to 1 [nondim] + real :: I_h ! inverse thickness [H-1 ~> m-1 or m2 kg-1] + real :: dTemp ! temperature increase in a layer [degC] + real :: Irho_cp ! inverse of heat capacity per unit layer volume + ! [degC H m2 J-1 ~> degC m3 J-1 or degC kg J-1] logical :: do_i(SZI_(G)) integer :: i, j, k, is, ie, js, je, nz, k2, i2 @@ -160,6 +106,9 @@ subroutine geothermal(h, tv, dt, ea, eb, G, GV, CS) 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 + endif if (.not. associated(CS)) call MOM_error(FATAL, "MOM_geothermal: "//& "Module must be initialized before it is used.") @@ -167,7 +116,7 @@ subroutine geothermal(h, tv, dt, ea, eb, G, GV, CS) nkmb = GV%nk_rho_varies Irho_cp = 1.0 / (GV%H_to_kg_m2 * tv%C_p) - Angstrom = GV%Angstrom + Angstrom = GV%Angstrom_H H_neglect = GV%H_subroundoff p_ref(:) = tv%P_Ref @@ -362,27 +311,19 @@ subroutine geothermal(h, tv, dt, ea, eb, G, GV, CS) end subroutine geothermal +!> Initialize parameters and allocate memory associated with the geothermal heating module. subroutine geothermal_init(Time, G, param_file, diag, CS) type(time_type), target, intent(in) :: Time !< Current model time. - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time !! parameters. type(diag_ctrl), target, intent(inout) :: diag !< Structure used to regulate diagnostic output. type(geothermal_CS), pointer :: CS !< Pointer pointing to the module control !! structure. - -! Arguments: -! (in) Time - current model time -! (in) G - ocean grid structure -! (in) param_file - structure indicating the open file to parse for -! model parameter values -! (in) diag - structure used to regulate diagnostic output -! (in/out) CS - pointer pointing to the module control structure - ! This include declares and sets the variable "version". #include "version_variable.h" - character(len=40) :: mdl = "MOM_geothermal" ! module name + ! Local variables character(len=200) :: inputdir, geo_file, filename, geotherm_var real :: scale integer :: i, j, isd, ied, jsd, jed, id @@ -440,6 +381,7 @@ subroutine geothermal_init(Time, G, param_file, diag, CS) CS%geo_heat(i,j) = G%mask2dT(i,j) * scale enddo ; enddo endif + call pass_var(CS%geo_heat, G%domain) ! post the static geothermal heating field id = register_static_field('ocean_model', 'geo_heat', diag%axesT1, & @@ -452,11 +394,22 @@ subroutine geothermal_init(Time, G, param_file, diag, CS) end subroutine geothermal_init +!> Clean up and deallocate memory associated with the geothermal heating module. subroutine geothermal_end(CS) - type(geothermal_CS), pointer :: CS + type(geothermal_CS), pointer :: CS !< Geothermal heating control structure that + !! will be deallocated in this subroutine. if (associated(CS%geo_heat)) deallocate(CS%geo_heat) if (associated(CS)) deallocate(CS) end subroutine geothermal_end +!> \namespace mom_geothermal +!! +!! Geothermal heating can be added either in a layered isopycnal mode, in which the heating raises the density +!! of the layer to the target density of the layer above, and then moves the water into that layer, or in a +!! simple Eulerian mode, in which the bottommost GEOTHERMAL_THICKNESS are heated. Geothermal heating will also +!! provide a buoyant source of bottom TKE that can be used to further mix the near-bottom water. In cold fresh +!! water lakes where heating increases density, water should be moved into deeper layers, but this is not +!! implemented yet. + end module MOM_geothermal diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index e65af9183c..111e8d44e2 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -1,28 +1,8 @@ +!> Calculates energy input to the internal tides module MOM_int_tide_input ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Robert Hallberg, January 2013 * -!* * -!* This file contains the subroutines that sets the energy input * -!* to the internal tides. * -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q * -!* j+1 > o > o > At ^: v * -!* j x ^ x ^ x At >: u * -!* j > o > o > At o: h, buoy, ustar, T, S, Kd, ea, eb, etc. * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** - use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE use MOM_diag_mediator, only : diag_ctrl, time_type @@ -35,6 +15,7 @@ module MOM_int_tide_input use MOM_grid, only : ocean_grid_type use MOM_io, only : slasher, vardesc, MOM_read_data use MOM_thickness_diffuse, only : vert_fill_TS +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs, vertvisc_type, p3d use MOM_verticalGrid, only : verticalGrid_type use MOM_EOS, only : calculate_density, calculate_density_derivs @@ -45,62 +26,60 @@ module MOM_int_tide_input public set_int_tide_input, int_tide_input_init, int_tide_input_end +! 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. + +!> This control structure holds parameters that regulate internal tide energy inputs. type, public :: int_tide_input_CS ; private - logical :: debug ! If true, write verbose checksums for debugging. - type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the - ! timing of diagnostic output. - real :: TKE_itide_max ! Maximum Internal tide conversion (W m-2) - ! available to mix above the BBL + logical :: debug !< If true, write verbose checksums for debugging. + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + real :: TKE_itide_max !< Maximum Internal tide conversion + !! available to mix above the BBL [W m-2] - real, allocatable, dimension(:,:) :: & - TKE_itidal_coef ! The time-invariant field that enters the TKE_itidal - ! input calculation, in J m-2. + real, allocatable, dimension(:,:) :: TKE_itidal_coef + !< The time-invariant field that enters the TKE_itidal input calculation [J m-2]. + character(len=200) :: inputdir !< The directory for input files. + !>@{ Diagnostic IDs integer :: id_TKE_itidal = -1, id_Nb = -1, id_N2_bot = -1 - character(len=200) :: inputdir + !!@} end type int_tide_input_CS +!> This type is used to exchange fields related to the internal tides. type, public :: int_tide_input_type real, allocatable, dimension(:,:) :: & - TKE_itidal_input, & ! The internal tide TKE input at the bottom of - ! the ocean, in W m-2. - h2, & ! The squared topographic roughness height, in m2. - tideamp, & ! The amplitude of the tidal velocities, in m s-1. - Nb ! The bottom stratification, in s-1. + TKE_itidal_input, & !< The internal tide TKE input at the bottom of the ocean [W m-2]. + h2, & !< The squared topographic roughness height [Z2 ~> m2]. + tideamp, & !< The amplitude of the tidal velocities [m s-1]. + Nb !< The bottom stratification [s-1]. end type int_tide_input_type contains -subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, 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 - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< The zonal velocity, in m s-1 - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< The meridional velocity, in m s-1 - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - type(thermo_var_ptrs), intent(in) :: tv - type(forcing), intent(in) :: fluxes - type(int_tide_input_type), intent(inout) :: itide - real, intent(in) :: dt - type(int_tide_input_CS), pointer :: CS - -! Arguments: u - Zonal velocity, in m s-1. -! (in) v - Meridional velocity, in m s-1. -! (in) h - Layer thickness, in m or kg m-2. -! (in) tv - A structure containing pointers to any available -! thermodynamic fields. Absent fields have NULL ptrs. -! (in) fluxes - A structure of surface fluxes that may be used. -! (inout) itide - A structure containing fields related to the internal -! tide sources. -! (in) dt - The time increment in s. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - This module's control structure. - +!> Sets the model-state dependent internal tide energy sources. +subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, 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 + 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] + type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to the + !! thermodynamic fields + type(forcing), intent(in) :: fluxes !< A structure of thermodynamic surface fluxes + type(int_tide_input_type), intent(inout) :: itide !< A structure containing fields related + !! to the internal tide sources. + real, intent(in) :: dt !< The time increment [s]. + type(int_tide_input_CS), pointer :: CS !< This module's control structure. + ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & - N2_bot ! The bottom squared buoyancy frequency, in s-2. + N2_bot ! The bottom squared buoyancy frequency [s-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & - T_f, S_f ! The temperature and salinity in C and PSU with the values in + T_f, S_f ! The temperature and salinity in [degC] and [ppt] with the values in ! the massless layers filled vertically by diffusion. logical :: use_EOS ! If true, density is calculated from T & S using an ! equation of state. @@ -116,8 +95,8 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, CS) if (.not.associated(CS)) call MOM_error(FATAL,"set_diffusivity: "//& "Module must be initialized before it is used.") - kappa_fill = 1.e-3 ! m2 s-1 - dt_fill = 7200. + kappa_fill = 1.e-3*US%m_to_Z**2 !### Dimensional constant [m2 s-1]. + dt_fill = 7200. !### Dimensionalconstant [s]. use_EOS = associated(tv%eqn_of_state) @@ -126,7 +105,7 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, CS) call vert_fill_TS(h, tv%T, tv%S, kappa_fill, dt_fill, T_f, S_f, G, GV) endif - call find_N2_bottom(h, tv, T_f, S_f, itide%h2, fluxes, G, GV, N2_bot) + call find_N2_bottom(h, tv, T_f, S_f, itide%h2, fluxes, G, GV, US, N2_bot) !$OMP parallel do default(none) shared(is,ie,js,je,G,itide,N2_bot,CS) do j=js,je ; do i=is,ie @@ -145,37 +124,44 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, CS) end subroutine set_int_tide_input -subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, N2_bot) - 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 !< Layer thicknesses, in H (usually m or kg m-2) - type(thermo_var_ptrs), intent(in) :: tv - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: T_f, S_f - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h2 - type(forcing), intent(in) :: fluxes - type(int_tide_input_CS), pointer :: CS - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: N2_bot - +!> Estimates the near-bottom buoyancy frequency (N^2). +subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot) + 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 + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to the + !! thermodynamic fields + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: T_f !< Temperature after vertical filtering to + !! smooth out the values in thin layers [degC]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: S_f !< Salinity after vertical filtering to + !! smooth out the values in thin layers [ppt]. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h2 !< Bottom topographic roughness [Z2 ~> m2]. + type(forcing), intent(in) :: fluxes !< A structure of thermodynamic surface fluxes + type(int_tide_input_CS), pointer :: CS !< This module's control structure. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: N2_bot !< The squared buoyancy freqency at the + !! ocean bottom [s-2]. + ! Local variables real, dimension(SZI_(G),SZK_(G)+1) :: & dRho_int ! The unfiltered density differences across interfaces. real, dimension(SZI_(G)) :: & - pres, & ! The pressure at each interface, in Pa. - Temp_int, & ! The temperature at each interface, in degC. - Salin_int, & ! The salinity at each interface, in PSU. + pres, & ! The pressure at each interface [Pa]. + Temp_int, & ! The temperature at each interface [degC]. + Salin_int, & ! The salinity at each interface [ppt]. drho_bot, & - h_amp, & - hb, & - z_from_bot, & + h_amp, & ! The amplitude of topographic roughness [Z ~> m]. + hb, & ! The depth below a layer [Z ~> m]. + z_from_bot, & ! The height of a layer center above the bottom [Z ~> m]. dRho_dT, & ! The partial derivatives of density with temperature and - dRho_dS ! salinity, in kg m-3 degC-1 and kg m-3 PSU-1. + dRho_dS ! salinity [kg m-3 degC-1] and [kg m-3 ppt-1]. - real :: dz_int ! The thickness associated with an interface, in m. + real :: dz_int ! The thickness associated with an interface [Z ~> m]. real :: G_Rho0 ! The gravitation acceleration divided by the Boussinesq - ! density, in m4 s-2 kg-1. + ! density [Z m3 s-2 kg-1 ~> m4 s-2 kg-1]. logical :: do_i(SZI_(G)), do_any integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke - G_Rho0 = GV%g_Earth / GV%Rho0 + G_Rho0 = (GV%g_Earth*US%m_to_Z**2) / GV%Rho0 ! Find the (limited) density jump across each interface. do i=is,ie @@ -216,7 +202,7 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, N2_bot) ! Find the bottom boundary layer stratification. do i=is,ie hb(i) = 0.0 ; dRho_bot(i) = 0.0 - z_from_bot(i) = 0.5*GV%H_to_m*h(i,j,nz) + z_from_bot(i) = 0.5*GV%H_to_Z*h(i,j,nz) do_i(i) = (G%mask2dT(i,j) > 0.5) h_amp(i) = sqrt(h2(i,j)) enddo @@ -224,7 +210,7 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, N2_bot) do k=nz,2,-1 do_any = .false. do i=is,ie ; if (do_i(i)) then - dz_int = 0.5*GV%H_to_m*(h(i,j,k) + h(i,j,k-1)) + dz_int = 0.5*GV%H_to_Z*(h(i,j,k) + h(i,j,k-1)) z_from_bot(i) = z_from_bot(i) + dz_int ! middle of the layer above hb(i) = hb(i) + dz_int @@ -233,7 +219,7 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, N2_bot) if (z_from_bot(i) > h_amp(i)) then if (k>2) then ! Always include at least one full layer. - hb(i) = hb(i) + 0.5*GV%H_to_m*(h(i,j,k-1) + h(i,j,k-2)) + hb(i) = hb(i) + 0.5*GV%H_to_Z*(h(i,j,k-1) + h(i,j,k-2)) dRho_bot(i) = dRho_bot(i) + dRho_int(i,K-1) endif do_i(i) = .false. @@ -253,23 +239,18 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, N2_bot) end subroutine find_N2_bottom -subroutine int_tide_input_init(Time, G, GV, param_file, diag, CS, itide) - type(time_type), intent(in) :: 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(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(diag_ctrl), target, intent(inout) :: diag - type(int_tide_input_CS), pointer :: CS - type(int_tide_input_type), pointer :: itide -! Arguments: Time - The current model time. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in) diag - A structure that is used to regulate diagnostic output. -! (in/out) CS - A pointer that is set to point to the control structure -! for this module -! (in) diag_to_Z_CSp - A pointer to the Z-diagnostics control structure. +!> Initializes the data related to the internal tide input module +subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) + type(time_type), intent(in) :: Time !< The 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 !< structure used to regulate diagnostic output. + type(int_tide_input_CS), pointer :: CS !< This module's control structure, which is initialized here. + type(int_tide_input_type), pointer :: itide !< A structure containing fields related + !! to the internal tide sources. + ! Local variables type(vardesc) :: vd logical :: read_tideamp ! This include declares and sets the variable "version". @@ -279,12 +260,11 @@ subroutine int_tide_input_init(Time, G, GV, param_file, diag, CS, itide) character(len=200) :: filename, tideamp_file, h2_file real :: mask_itidal - real :: utide ! constant tidal amplitude (m s-1) to be used if + real :: utide ! constant tidal amplitude [m s-1] to be used if ! tidal amplitude file is not present. real :: kappa_h2_factor ! factor for the product of wavenumber * rms sgs height. real :: kappa_itides ! topographic wavenumber and non-dimensional scaling - real :: min_zbot_itides ! Minimum ocean depth for internal tide conversion, - ! in m. + real :: min_zbot_itides ! Minimum ocean depth for internal tide conversion [Z ~> m]. integer :: i, j, is, ie, js, je, isd, ied, jsd, jed if (associated(CS)) then @@ -315,7 +295,7 @@ subroutine int_tide_input_init(Time, G, GV, param_file, diag, CS, itide) call get_param(param_file, mdl, "MIN_ZBOT_ITIDES", min_zbot_itides, & "Turn off internal tidal dissipation when the total \n"//& - "ocean depth is less than this value.", units="m", default=0.0) + "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, & "The constant tidal amplitude used with INT_TIDE_DISSIPATION.", & @@ -358,7 +338,7 @@ subroutine int_tide_input_init(Time, G, GV, param_file, diag, CS, itide) fail_if_missing=.true.) filename = trim(CS%inputdir) // trim(h2_file) call log_param(param_file, mdl, "INPUTDIR/H2_FILE", filename) - call MOM_read_data(filename, 'h2', itide%h2, G%domain, timelevel=1) + call MOM_read_data(filename, 'h2', itide%h2, G%domain, timelevel=1, scale=US%m_to_Z**2) do j=js,je ; do i=is,ie mask_itidal = 1.0 @@ -367,12 +347,13 @@ subroutine int_tide_input_init(Time, G, GV, param_file, diag, CS, itide) itide%tideamp(i,j) = itide%tideamp(i,j) * mask_itidal * G%mask2dT(i,j) ! Restrict rms topo to 10 percent of column depth. + !### Note the use here of a hard-coded nondimensional constant. itide%h2(i,j) = min(0.01*G%bathyT(i,j)**2, itide%h2(i,j)) ! Compute the fixed part of internal tidal forcing; units are [J m-2] here. CS%TKE_itidal_coef(i,j) = 0.5*kappa_h2_factor*GV%Rho0*& - kappa_itides * itide%h2(i,j) * itide%tideamp(i,j)**2 - enddo; enddo + kappa_itides * US%Z_to_m**2*itide%h2(i,j) * itide%tideamp(i,j)**2 + enddo ; enddo CS%id_TKE_itidal = register_diag_field('ocean_model','TKE_itidal_itide',diag%axesT1,Time, & @@ -386,8 +367,9 @@ subroutine int_tide_input_init(Time, G, GV, param_file, diag, CS, itide) end subroutine int_tide_input_init +!> Deallocates any memory related to the internal tide input module. subroutine int_tide_input_end(CS) - type(int_tide_input_CS), pointer :: CS + type(int_tide_input_CS), pointer :: CS !< This module's control structure, which is deallocated here. if (associated(CS)) deallocate(CS) diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index 3344f218bc..a92106444e 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -1,37 +1,17 @@ +!> Shear-dependent mixing following Jackson et al. 2008. module MOM_kappa_shear ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Laura Jackson and Robert Hallberg, 2006-2008 * -!* * -!* This file contains the subroutines that determine the diapycnal * -!* diffusivity driven by resolved shears, as specified by the * -!* parameterizations described in Jackson and Hallberg (JPO, 2008). * -!* * -!* The technique by which the 6 equations (for kappa, TKE, u, v, T, * -!* and S) are solved simultaneously has been dramatically revised * -!* from the previous version. The previous version was not converging * -!* in some cases, especially near the surface mixed layer, while the * -!* revised version does. The revised version solves for kappa and * -!* TKE with shear and stratification fixed, then marches the density * -!* and velocities forward with an adaptive (and aggressive) time step * -!* in a predictor-corrector-corrector emulation of a trapezoidal * -!* scheme. Run-time-settable parameters determine the tolerence to * -!* which the kappa and TKE equations are solved and the minimum time * -!* step that can be taken. * -!* * -!********+*********+*********+*********+*********+*********+*********+** - use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : diag_ctrl, time_type -use MOM_debugging, only : hchksum +use MOM_debugging, only : hchksum, Bchksum use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use MOM_EOS, only : calculate_density, calculate_density_derivs @@ -43,156 +23,140 @@ module MOM_kappa_shear #include #endif -public Calculate_kappa_shear, kappa_shear_init, kappa_shear_is_used +public Calculate_kappa_shear, Calc_kappa_shear_vertex, kappa_shear_init +public kappa_shear_is_used, kappa_shear_at_vertex + +! 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. +!> This control structure holds the parameters that regulate shear mixing type, public :: Kappa_shear_CS ; private - real :: RiNo_crit ! The critical shear Richardson number for - ! shear-entrainment. The theoretical value is 0.25. - ! The values found by Jackson et al. are 0.25-0.35. - real :: Shearmix_rate ! A nondimensional rate scale for shear-driven - ! entrainment. The value given by Jackson et al. - ! is 0.085-0.089. - real :: FRi_curvature ! A constant giving the curvature of the function - ! of the Richardson number that relates shear to - ! sources in the kappa equation, Nondim. - ! The values found by Jackson et al. are -0.97 - -0.89. - real :: C_N ! The coefficient for the decay of TKE due to - ! stratification (i.e. proportional to N*tke), ND. - ! The values found by Jackson et al. are 0.24-0.28. - real :: C_S ! The coefficient for the decay of TKE due to - ! shear (i.e. proportional to |S|*tke), ND. - ! The values found by Jackson et al. are 0.14-0.12. - real :: lambda ! The coefficient for the buoyancy length scale - ! in the kappa equation. Nondimensional. - ! The values found by Jackson et al. are 0.82-0.81. - real :: lambda2_N_S ! The square of the ratio of the coefficients of - ! the buoyancy and shear scales in the diffusivity - ! equation, 0 to eliminate the shear scale. Nondim. - real :: TKE_bg ! The background level of TKE, in m2 s-2. - real :: kappa_0 ! The background diapycnal diffusivity, in m2 s-1. - real :: kappa_tol_err ! The fractional error in kappa that is tolerated. - real :: Prandtl_turb ! Prandtl number used to convert Kd_shear into viscosity. - integer :: nkml ! The number of layers in the mixed layer, as - ! treated in this routine. If the pieces of the - ! mixed layer are not to be treated collectively, - ! nkml is set to 1. - integer :: max_RiNo_it ! The maximum number of iterations that may be used - ! to estimate the instantaneous shear-driven mixing. - integer :: max_KS_it ! The maximum number of iterations that may be used - ! to estimate the time-averaged diffusivity. - logical :: eliminate_massless ! If true, massless layers are merged with neighboring - ! massive layers in this calculation. I can think of - ! no good reason why this should be false. - logical :: layer_stagger = .false. - logical :: debug = .false. - type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the - ! timing of diagnostic output. - integer :: id_Kd_shear = -1, id_TKE = -1 - integer :: id_ILd2 = -1, id_dz_Int = -1 + real :: RiNo_crit !< The critical shear Richardson number for + !! shear-entrainment. The theoretical value is 0.25. + !! The values found by Jackson et al. are 0.25-0.35. + real :: Shearmix_rate !< A nondimensional rate scale for shear-driven + !! entrainment. The value given by Jackson et al. + !! is 0.085-0.089. + real :: FRi_curvature !< A constant giving the curvature of the function + !! of the Richardson number that relates shear to + !! sources in the kappa equation [nondim]. + !! The values found by Jackson et al. are -0.97 - -0.89. + real :: C_N !< The coefficient for the decay of TKE due to + !! stratification (i.e. proportional to N*tke) [nondim]. + !! The values found by Jackson et al. are 0.24-0.28. + real :: C_S !< The coefficient for the decay of TKE due to + !! shear (i.e. proportional to |S|*tke) [nondim]. + !! The values found by Jackson et al. are 0.14-0.12. + real :: lambda !< The coefficient for the buoyancy length scale + !! in the kappa equation. Nondimensional. + !! The values found by Jackson et al. are 0.82-0.81. + real :: lambda2_N_S !< The square of the ratio of the coefficients of + !! the buoyancy and shear scales in the diffusivity + !! equation, 0 to eliminate the shear scale. Nondim. + real :: TKE_bg !< The background level of TKE [m2 s-2]. + real :: kappa_0 !< The background diapycnal diffusivity [Z2 s-1 ~> m2 s-1]. + real :: kappa_tol_err !< The fractional error in kappa that is tolerated. + real :: Prandtl_turb !< Prandtl number used to convert Kd_shear into viscosity. + integer :: nkml !< The number of layers in the mixed layer, as + !! treated in this routine. If the pieces of the + !! mixed layer are not to be treated collectively, + !! nkml is set to 1. + integer :: max_RiNo_it !< The maximum number of iterations that may be used + !! to estimate the instantaneous shear-driven mixing. + integer :: max_KS_it !< The maximum number of iterations that may be used + !! to estimate the time-averaged diffusivity. + logical :: KS_at_vertex !< If true, do the calculations of the shear-driven mixing + !! at the cell vertices (i.e., the vorticity points). + logical :: eliminate_massless !< If true, massless layers are merged with neighboring + !! massive layers in this calculation. + ! I can think of no good reason why this should be false. - RWH + real :: vel_underflow !< Velocity components smaller than vel_underflow + !! are set to 0 [m s-1]. +! logical :: layer_stagger = .false. ! If true, do the calculations centered at + ! layers, rather than the interfaces. + logical :: debug = .false. !< If true, write verbose debugging messages. + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + !>@{ Diagnostic IDs + integer :: id_Kd_shear = -1, id_TKE = -1, id_ILd2 = -1, id_dz_Int = -1 + !!@} end type Kappa_shear_CS ! integer :: id_clock_project, id_clock_KQ, id_clock_avg, id_clock_setup - character(len=40) :: mdl = "MOM_kappa_shear" ! This module's name. #undef DEBUG #undef ADD_DIAGNOSTICS contains -!> Subroutine for calculating diffusivity and TKE +!> Subroutine for calculating shear-driven diffusivity and TKE in tracer columns subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & - kv_io, dt, G, GV, CS, initialize_all) + kv_io, dt, G, GV, US, CS, initialize_all) 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 real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: u_in !< Initial zonal velocity, in m s-1. (Intent in) + intent(in) :: u_in !< Initial zonal velocity [m s-1]. (Intent in) real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: v_in !< Initial meridional velocity, in m s-1. + intent(in) :: v_in !< Initial meridional velocity [m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2). + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any !! available thermodynamic fields. Absent fields !! have NULL ptrs. - real, dimension(:,:), pointer :: p_surf !< The pressure at the ocean surface in Pa - !! (or NULL). + real, dimension(:,:), pointer :: p_surf !< The pressure at the ocean surface [Pa] (or NULL). real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(inout) :: kappa_io !< The diapycnal diffusivity at each interface - !! (not layer!) in m2 s-1. Initially this is the + !! (not layer!) [Z2 s-1 ~> m2 s-1]. Initially this is the !! value from the previous timestep, which may !! accelerate the iteration toward convergence. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(inout) :: tke_io !< The turbulent kinetic energy per unit mass at - !! each interface (not layer!) in m2 s-2. + !! each interface (not layer!) [m2 s-2]. !! Initially this is the value from the previous !! timestep, which may accelerate the iteration !! toward convergence. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(inout) :: kv_io !< The vertical viscosity at each interface - !! (not layer!) in m2 s-1. This discards any - !! previous value i.e. intent(out) and simply - !! sets Kv = Prandtl * Kd_shear - real, intent(in) :: dt !< Time increment, in s. + !! (not layer!) [Z2 s-1 ~> m2 s-1]. This discards any + !! previous value (i.e. it is intent out) and + !! simply sets Kv = Prandtl * Kd_shear + real, intent(in) :: dt !< Time increment [s]. type(Kappa_shear_CS), pointer :: CS !< The control structure returned by a previous !! call to kappa_shear_init. logical, optional, intent(in) :: initialize_all !< If present and false, the previous !! value of kappa is used to start the iterations -! -! ---------------------------------------------- -! Subroutine for calculating diffusivity and TKE -! ---------------------------------------------- -! Arguments: u_in - Initial zonal velocity, in m s-1. (Intent in) -! (in) v_in - Initial meridional velocity, in m s-1. -! (in) h - Layer thickness, in m or kg m-2. -! (in) tv - A structure containing pointers to any available -! thermodynamic fields. Absent fields have NULL ptrs. -! (in) p_surf - The pressure at the ocean surface in Pa (or NULL). -! (in/out) kappa_io - The diapycnal diffusivity at each interface -! (not layer!) in m2 s-1. Initially this is the value -! from the previous timestep, which may accelerate the -! iteration toward convergence. -! (in/out) tke_io - The turbulent kinetic energy per unit mass at each -! interface (not layer!) in m2 s-2. Initially this is the -! value from the previous timestep, which may accelerate -! the iteration toward convergence. -! (in/out) kv_io - The vertical viscosity at each interface -! (not layer!) in m2 s-1. This discards any previous value -! i.e. intent(out) and simply sets Kv = Prandtl * Kd_shear -! (in) dt - Time increment, in s. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - The control structure returned by a previous call to -! kappa_shear_init. -! (in,opt) initialize_all - If present and false, the previous value of -! kappa is used to start the iterations. + + ! Local variables real, dimension(SZI_(G),SZK_(GV)) :: & h_2d, & ! A 2-D version of h, but converted to m. u_2d, v_2d, T_2d, S_2d, rho_2d ! 2-D versions of u_in, v_in, T, S, and rho. real, dimension(SZI_(G),SZK_(GV)+1) :: & - kappa_2d, tke_2d ! 2-D versions of various kappa_io and tke_io. + kappa_2d, tke_2d ! 2-D versions of various kappa_io and tke_io. real, dimension(SZK_(GV)) :: & - u, & ! The zonal velocity after a timestep of mixing, in m s-1. - v, & ! The meridional velocity after a timestep of mixing, in m s-1. - Idz, & ! The inverse of the distance between TKE points, in m. - T, & ! The potential temperature after a timestep of mixing, in C. - Sal, & ! The salinity after a timestep of mixing, in psu. - dz, & ! The layer thickness, in m. - u0xdz, & ! The initial zonal velocity times dz, in m2 s-1. - v0xdz, & ! The initial meridional velocity times dz, in m2 s-1. - T0xdz, & ! The initial temperature times dz, in C m. - S0xdz ! The initial salinity times dz, in PSU m. + u, & ! The zonal velocity after a timestep of mixing [m s-1]. + v, & ! The meridional velocity after a timestep of mixing [m s-1]. + Idz, & ! The inverse of the distance between TKE points [Z-1 ~> m-1]. + T, & ! The potential temperature after a timestep of mixing [degC]. + Sal, & ! The salinity after a timestep of mixing [ppt]. + dz, & ! The layer thickness [Z ~> m]. + u0xdz, & ! The initial zonal velocity times dz [Z m s-1 ~> m2 s-1]. + v0xdz, & ! The initial meridional velocity times dz [Z m s-1 ~> m2 s-1]. + T0xdz, & ! The initial temperature times dz [degC Z ~> degC m]. + S0xdz ! The initial salinity times dz [ppt Z ~> ppt m]. real, dimension(SZK_(GV)+1) :: & - kappa, & ! The shear-driven diapycnal diffusivity at an interface, in - ! units of m2 s-1. - tke, & ! The Turbulent Kinetic Energy per unit mass at an interface, - ! in units of m2 s-2. - kappa_avg, & ! The time-weighted average of kappa, in m2 s-1. - tke_avg ! The time-weighted average of TKE, in m2 s-2. - real :: f2 ! The squared Coriolis parameter of each column, in s-2. - real :: surface_pres ! The top surface pressure, in Pa. - - real :: dz_in_lay ! The running sum of the thickness in a layer, in m. - real :: k0dt ! The background diffusivity times the timestep, in m2. - real :: dz_massless ! A layer thickness that is considered massless, in m. + kappa, & ! The shear-driven diapycnal diffusivity at an interface [Z2 s-1 ~> m2 s-1]. + tke, & ! The Turbulent Kinetic Energy per unit mass at an interface [m2 s-2]. + kappa_avg, & ! The time-weighted average of kappa [Z2 s-1 ~> m2 s-1]. + tke_avg ! The time-weighted average of TKE [m2 s-2]. + real :: f2 ! The squared Coriolis parameter of each column [s-2]. + real :: surface_pres ! The top surface pressure [Pa]. + + real :: dz_in_lay ! The running sum of the thickness in a layer [Z ~> m]. + real :: k0dt ! The background diffusivity times the timestep [Z2 ~> m2]. + real :: dz_massless ! A layer thickness that is considered massless [Z ~> m]. logical :: use_temperature ! If true, temperature and salinity have been ! allocated and are being used as state variables. logical :: new_kappa = .true. ! If true, ignore the value of kappa from the @@ -202,7 +166,7 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & ! interfaces and the interfaces with massless layers ! merged into nearby massive layers. real, dimension(SZK_(GV)+1) :: kf ! The fractional weight of interface kc+1 for - ! interpolating back to the original index space, ND. + ! interpolating back to the original index space [nondim]. integer :: is, ie, js, je, i, j, k, nz, nzc ! Diagnostics that should be deleted? @@ -218,8 +182,8 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & integer :: max_debug_itt ; parameter(max_debug_itt=20) real :: wt(SZK_(GV)+1), wt_tot, I_wt_tot, wt_itt real, dimension(SZK_(GV)+1) :: & - Ri_k, tke_prev, dtke, dkappa, dtke_norm, & - ksrc_av ! The average through the iterations of k_src, in s-1. + Ri_k, tke_prev, dtke, dkap, dtke_norm, & + ksrc_av ! The average through the iterations of k_src [s-1]. real, dimension(SZK_(GV)+1,0:max_debug_itt) :: & tke_it1, N2_it1, Sh2_it1, ksrc_it1, kappa_it1, kprev_it1 real, dimension(SZK_(GV)+1,1:max_debug_itt) :: & @@ -232,37 +196,20 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & #endif is = G%isc ; ie = G%iec; js = G%jsc ; je = G%jec ; nz = GV%ke - ! These are hard-coded for now. Perhaps these could be made dynamic later? - ! tol_dksrc = 0.5*tol_ksrc_chg ; tol_dksrc_low = 1.0 - 1.0/tol_ksrc_chg ? -! tol_dksrc = 10.0 ; tol_dksrc_low = 0.95 ; tol2 = 2.0*CS%kappa_tol_err -! dt_refinements = 5 ! Selected so that 1/2^dt_refinements < 1-tol_dksrc_low - use_temperature = .false. ; if (associated(tv%T)) use_temperature = .true. new_kappa = .true. ; if (present(initialize_all)) new_kappa = initialize_all -! Ri_crit = CS%Rino_crit -! gR0 = GV%Rho0*GV%g_Earth ; g_R0 = GV%g_Earth/GV%Rho0 - k0dt = dt*CS%kappa_0 dz_massless = 0.1*sqrt(k0dt) -!$OMP parallel do default(none) shared(js,je,is,ie,nz,h,u_in,v_in,use_temperature,new_kappa, & -!$OMP tv,G,GV,CS,kappa_io,dz_massless,k0dt,p_surf,dt, & + !$OMP parallel do default(private) shared(js,je,is,ie,nz,h,u_in,v_in,use_temperature,new_kappa, & #ifdef ADD_DIAGNOSTICS -!$OMP I_Ld2_3d,dz_Int_3d, & + !$OMP I_Ld2_3d,dz_Int_3d, & #endif -!$OMP tke_io,kv_io) & -!$OMP private(h_2d,u_2d,v_2d,T_2d,S_2d,rho_2d,kappa_2d,nzc,dz, & -!$OMP u0xdz,v0xdz,T0xdz,S0xdz,kc,Idz,kf,dz_in_lay, & -!$OMP u,v,T,Sal,f2,kappa,kappa_avg,tke_avg,tke,surface_pres,& -#ifdef ADD_DIAGNOSTICS -!$OMP I_Ld2_1d,I_Ld2_2d, dz_Int_2d, & -#endif -!$OMP tke_2d) - + !$OMP tv,G,GV,US,CS,kappa_io,dz_massless,k0dt,p_surf,dt,tke_io,kv_io) do j=js,je do k=1,nz ; do i=is,ie - h_2d(i,k) = h(i,j,k)*GV%H_to_m + h_2d(i,k) = h(i,j,k)*GV%H_to_Z u_2d(i,k) = u_in(i,j,k) ; v_2d(i,k) = v_in(i,j,k) enddo ; enddo if (use_temperature) then ; do k=1,nz ; do i=is,ie @@ -350,14 +297,14 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & ! Set the initial guess for kappa, here defined at interfaces. ! ---------------------------------------------------- if (new_kappa) then - do K=1,nzc+1 ; kappa(K) = 1.0 ; enddo + do K=1,nzc+1 ; kappa(K) = US%m_to_Z**2*1.0 ; enddo else do K=1,nzc+1 ; kappa(K) = kappa_2d(i,K) ; enddo endif call kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & dz, u0xdz, v0xdz, T0xdz, S0xdz, kappa_avg, & - tke_avg, tv, CS, GV) + tke_avg, tv, CS, GV, US) ! call cpu_clock_begin(id_clock_setup) ! Extrapolate from the vertically reduced grid back to the original layers. @@ -383,8 +330,8 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & #ifdef ADD_DIAGNOSTICS I_Ld2_2d(i,1) = 0.0 ; dz_Int_2d(i,1) = dz_Int(1) do K=2,nzc - I_Ld2_2d(i,K) = (N2(K) / CS%lambda**2 + f2) / & - max(TKE(K),1e-30) + I_L2_bdry(K) + I_Ld2_2d(i,K) = I_L2_bdry(K) + & + (N2(K) / CS%lambda**2 + f2) * Z2_to_L2 / (max(TKE(K),1e-30)) dz_Int_2d(i,K) = dz_Int(K) enddo I_Ld2_2d(i,nzc+1) = 0.0 ; dz_Int_2d(i,nzc+1) = dz_Int(nzc+1) @@ -416,8 +363,8 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & enddo ! end of j-loop if (CS%debug) then - call hchksum(kappa_io,"kappa",G%HI) - call hchksum(tke_io,"tke",G%HI) + call hchksum(kappa_io, "kappa", G%HI, scale=US%Z_to_m**2) + call hchksum(tke_io, "tke", G%HI) endif if (CS%id_Kd_shear > 0) call post_data(CS%id_Kd_shear, kappa_io, CS%diag) @@ -427,37 +374,368 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & if (CS%id_dz_Int > 0) call post_data(CS%id_dz_Int, dz_Int_3d, CS%diag) #endif - return - end subroutine Calculate_kappa_shear + +!> Subroutine for calculating shear-driven diffusivity and TKE in corner columns +subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_io, tke_io, & + kv_io, dt, G, GV, US, CS, initialize_all) + 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 + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u_in !< Initial zonal velocity [m s-1]. (Intent in) + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: v_in !< Initial meridional velocity [m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: T_in !< Layer potential temperatures [degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: S_in !< Layer salinities in ppt. + type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any + !! available thermodynamic fields. Absent fields + !! have NULL ptrs. + real, dimension(:,:), pointer :: p_surf !< The pressure at the ocean surface [Pa] + !! (or NULL). + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & + intent(out) :: kappa_io !< The diapycnal diffusivity at each interface + !! (not layer!) [Z2 s-1 ~> m2 s-1]. + real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)+1), & + intent(inout) :: tke_io !< The turbulent kinetic energy per unit mass at + !! each interface (not layer!) [m2 s-2]. + !! Initially this is the value from the previous + !! timestep, which may accelerate the iteration + !! toward convergence. + real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)+1), & + intent(inout) :: kv_io !< The vertical viscosity at each interface [Z2 s-1 ~> m2 s-1]. + !! The previous value is used to initialize kappa + !! in the vertex columes as Kappa = Kv/Prandtl + !! to accelerate the iteration toward covergence. + real, intent(in) :: dt !< Time increment [s]. + type(Kappa_shear_CS), pointer :: CS !< The control structure returned by a previous + !! call to kappa_shear_init. + logical, optional, intent(in) :: initialize_all !< If present and false, the previous + !! value of kappa is used to start the iterations + + ! Local variables + real, dimension(SZIB_(G),SZK_(GV)) :: & + h_2d, & ! A 2-D version of h, but converted to m. + u_2d, v_2d, T_2d, S_2d, rho_2d ! 2-D versions of u_in, v_in, T, S, and rho. + real, dimension(SZIB_(G),SZK_(GV)+1,2) :: & + kappa_2d ! Quasi 2-D versions of kappa_io [Z2 s-1 ~> m2 s-1]. + real, dimension(SZIB_(G),SZK_(GV)+1) :: & + tke_2d ! 2-D version tke_io [m2 s-2]. + real, dimension(SZK_(GV)) :: & + u, & ! The zonal velocity after a timestep of mixing [m s-1]. + v, & ! The meridional velocity after a timestep of mixing [m s-1]. + Idz, & ! The inverse of the distance between TKE points [Z-1 ~> m-1]. + T, & ! The potential temperature after a timestep of mixing [degC]. + Sal, & ! The salinity after a timestep of mixing [ppt]. + dz, & ! The layer thickness [Z ~> m]. + u0xdz, & ! The initial zonal velocity times dz [m Z s-1 ~> m2 s-1]. + v0xdz, & ! The initial meridional velocity times dz [m Z s-1 ~> m2 s-1]. + T0xdz, & ! The initial temperature times dz [degC Z ~> degC m]. + S0xdz ! The initial salinity times dz [ppt Z ~> ppt m]. + real, dimension(SZK_(GV)+1) :: & + kappa, & ! The shear-driven diapycnal diffusivity at an interface [Z2 s-1 ~> m2 s-1]. + tke, & ! The Turbulent Kinetic Energy per unit mass at an interface [m2 s-2]. + kappa_avg, & ! The time-weighted average of kappa [Z2 s-1 ~> m2 s-1]. + tke_avg ! The time-weighted average of TKE [m2 s-2]. + real :: f2 ! The squared Coriolis parameter of each column [s-2]. + real :: surface_pres ! The top surface pressure [Pa]. + + real :: dz_in_lay ! The running sum of the thickness in a layer [Z ~> m]. + real :: k0dt ! The background diffusivity times the timestep [Z2 ~> m2]. + real :: dz_massless ! A layer thickness that is considered massless [Z ~> m]. + real :: I_hwt ! The inverse of the masked thickness weights [H-1 ~> m-1 or m2 kg-1]. + real :: I_Prandtl + logical :: use_temperature ! If true, temperature and salinity have been + ! allocated and are being used as state variables. + logical :: new_kappa = .true. ! If true, ignore the value of kappa from the + ! last call to this subroutine. + logical :: do_i ! If true, work on this column. + + integer, dimension(SZK_(GV)+1) :: kc ! The index map between the original + ! interfaces and the interfaces with massless layers + ! merged into nearby massive layers. + real, dimension(SZK_(GV)+1) :: kf ! The fractional weight of interface kc+1 for + ! interpolating back to the original index space [nondim]. + integer :: IsB, IeB, JsB, JeB, i, j, k, nz, nzc, J2, J2m1 + + ! Diagnostics that should be deleted? +#ifdef ADD_DIAGNOSTICS + real, dimension(SZK_(GV)+1) :: & ! Additional diagnostics. + I_Ld2_1d + real, dimension(SZI_(G),SZK_(GV)+1) :: & ! 2-D versions of diagnostics. + I_Ld2_2d, dz_Int_2d + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & ! 3-D versions of diagnostics. + I_Ld2_3d, dz_Int_3d +#endif +#ifdef DEBUG + integer :: max_debug_itt ; parameter(max_debug_itt=20) + real :: wt(SZK_(GV)+1), wt_tot, I_wt_tot, wt_itt + real, dimension(SZK_(GV)+1) :: & + Ri_k, tke_prev, dtke, dkappa, dtke_norm, & + ksrc_av ! The average through the iterations of k_src [s-1]. + real, dimension(SZK_(GV)+1,0:max_debug_itt) :: & + tke_it1, N2_it1, Sh2_it1, ksrc_it1, kappa_it1, kprev_it1 + real, dimension(SZK_(GV)+1,1:max_debug_itt) :: & + dkappa_it1, wt_it1, K_Q_it1, d_dkappa_it1, dkappa_norm + real, dimension(SZK_(GV),0:max_debug_itt) :: & + u_it1, v_it1, rho_it1, T_it1, S_it1 + real, dimension(0:max_debug_itt) :: & + dk_wt_it1, dkpos_wt_it1, dkneg_wt_it1, k_mag + real, dimension(max_debug_itt) :: dt_it1 +#endif + isB = G%isc-1 ; ieB = G%iecB ; jsB = G%jsc-1 ; jeB = G%jecB ; nz = GV%ke + + use_temperature = .false. ; if (associated(tv%T)) use_temperature = .true. + new_kappa = .true. ; if (present(initialize_all)) new_kappa = initialize_all + + k0dt = dt*CS%kappa_0 + dz_massless = 0.1*sqrt(k0dt) + I_Prandtl = 0.0 ; if (CS%Prandtl_turb > 0.0) I_Prandtl = 1.0 / CS%Prandtl_turb + + !$OMP parallel do default(private) shared(jsB,jeB,isB,ieB,nz,h,u_in,v_in,use_temperature,new_kappa, & +#ifdef ADD_DIAGNOSTICS + !$OMP I_Ld2_3d,dz_Int_3d, & +#endif + !$OMP tv,G,GV,US,CS,kappa_io,dz_massless,k0dt,p_surf,dt,tke_io,kv_io) + do J=JsB,JeB + J2 = mod(J,2)+1 ; J2m1 = 3-J2 ! = mod(J-1,2)+1 + + ! Interpolate the various quantities to the corners, using masks. + do k=1,nz ; do I=IsB,IeB + u_2d(I,k) = (u_in(I,j,k) * (G%mask2dCu(I,j) * (h(i,j,k) + h(i+1,j,k))) + & + u_in(I,j+1,k) * (G%mask2dCu(I,j+1) * (h(i,j+1,k) + h(i+1,j+1,k))) ) / & + ((G%mask2dCu(I,j) * (h(i,j,k) + h(i+1,j,k)) + & + G%mask2dCu(I,j+1) * (h(i,j+1,k) + h(i+1,j+1,k))) + GV%H_subroundoff) + v_2d(I,k) = (v_in(i,J,k) * (G%mask2dCv(i,J) * (h(i,j,k) + h(i,j+1,k))) + & + v_in(i+1,J,k) * (G%mask2dCv(i+1,J) * (h(i+1,j,k) + h(i+1,j+1,k))) ) / & + ((G%mask2dCv(i,J) * (h(i,j,k) + h(i,j+1,k)) + & + G%mask2dCv(i+1,J) * (h(i+1,j,k) + h(i+1,j+1,k))) + GV%H_subroundoff) + I_hwt = 1.0 / (((G%mask2dT(i,j) * h(i,j,k) + G%mask2dT(i+1,j+1) * h(i+1,j+1,k)) + & + (G%mask2dT(i+1,j) * h(i+1,j,k) + G%mask2dT(i,j+1) * h(i,j+1,k))) + & + GV%H_subroundoff) + if (use_temperature) then + T_2d(I,k) = ( ((G%mask2dT(i,j) * h(i,j,k)) * T_in(i,j,k) + & + (G%mask2dT(i+1,j+1) * h(i+1,j+1,k)) * T_in(i+1,j+1,k)) + & + ((G%mask2dT(i+1,j) * h(i+1,j,k)) * T_in(i+1,j,k) + & + (G%mask2dT(i,j+1) * h(i,j+1,k)) * T_in(i,j+1,k)) ) * I_hwt + S_2d(I,k) = ( ((G%mask2dT(i,j) * h(i,j,k)) * S_in(i,j,k) + & + (G%mask2dT(i+1,j+1) * h(i+1,j+1,k)) * S_in(i+1,j+1,k)) + & + ((G%mask2dT(i+1,j) * h(i+1,j,k)) * S_in(i+1,j,k) + & + (G%mask2dT(i,j+1) * h(i,j+1,k)) * S_in(i,j+1,k)) ) * I_hwt + endif + h_2d(I,k) = GV%H_to_Z * ((G%mask2dT(i,j) * h(i,j,k) + G%mask2dT(i+1,j+1) * h(i+1,j+1,k)) + & + (G%mask2dT(i+1,j) * h(i+1,j,k) + G%mask2dT(i,j+1) * h(i,j+1,k)) ) / & + ((G%mask2dT(i,j) + G%mask2dT(i+1,j+1)) + & + (G%mask2dT(i+1,j) + G%mask2dT(i,j+1)) + 1.0e-36 ) +! h_2d(I,k) = 0.25*((h(i,j,k) + h(i+1,j+1,k)) + (h(i+1,j,k) + h(i,j+1,k)))*GV%H_to_Z +! h_2d(I,k) = ((h(i,j,k)**2 + h(i+1,j+1,k)**2) + & +! (h(i+1,j,k)**2 + h(i,j+1,k)**2))*GV%H_to_Z * I_hwt + enddo ; enddo + if (.not.use_temperature) then ; do k=1,nz ; do I=IsB,IeB + rho_2d(I,k) = GV%Rlay(k) + enddo ; enddo ; endif + if (.not.new_kappa) then ; do K=1,nz+1 ; do I=IsB,IeB + kappa_2d(I,K,J2) = kv_io(I,J,K) * I_Prandtl + enddo ; enddo ; endif + +!--------------------------------------- +! Work on each column. +!--------------------------------------- + do I=IsB,IeB ; if ((G%mask2dCu(I,j) + G%mask2dCu(I,j+1)) + & + (G%mask2dCv(i,J) + G%mask2dCv(i+1,J)) > 0.0) then + ! call cpu_clock_begin(Id_clock_setup) + ! Store a transposed version of the initial arrays. + ! Any elimination of massless layers would occur here. + if (CS%eliminate_massless) then + nzc = 1 + do k=1,nz + ! Zero out the thicknesses of all layers, even if they are unused. + dz(k) = 0.0 ; u0xdz(k) = 0.0 ; v0xdz(k) = 0.0 + T0xdz(k) = 0.0 ; S0xdz(k) = 0.0 + + ! Add a new layer if this one has mass. +! if ((dz(nzc) > 0.0) .and. (h_2d(I,k) > dz_massless)) nzc = nzc+1 + if ((k>CS%nkml) .and. (dz(nzc) > 0.0) .and. & + (h_2d(I,k) > dz_massless)) nzc = nzc+1 + + ! Only merge clusters of massless layers. +! if ((dz(nzc) > dz_massless) .or. & +! ((dz(nzc) > 0.0) .and. (h_2d(I,k) > dz_massless))) nzc = nzc+1 + + kc(k) = nzc + dz(nzc) = dz(nzc) + h_2d(I,k) + u0xdz(nzc) = u0xdz(nzc) + u_2d(I,k)*h_2d(I,k) + v0xdz(nzc) = v0xdz(nzc) + v_2d(I,k)*h_2d(I,k) + if (use_temperature) then + T0xdz(nzc) = T0xdz(nzc) + T_2d(I,k)*h_2d(I,k) + S0xdz(nzc) = S0xdz(nzc) + S_2d(I,k)*h_2d(I,k) + else + T0xdz(nzc) = T0xdz(nzc) + rho_2d(I,k)*h_2d(I,k) + S0xdz(nzc) = S0xdz(nzc) + rho_2d(I,k)*h_2d(I,k) + endif + enddo + kc(nz+1) = nzc+1 + + ! Set up Idz as the inverse of layer thicknesses. + do k=1,nzc ; Idz(k) = 1.0 / dz(k) ; enddo + + ! Now determine kf, the fractional weight of interface kc when + ! interpolating between interfaces kc and kc+1. + kf(1) = 0.0 ; dz_in_lay = h_2d(I,1) + do k=2,nz + if (kc(k) > kc(k-1)) then + kf(k) = 0.0 ; dz_in_lay = h_2d(I,k) + else + kf(k) = dz_in_lay*Idz(kc(k)) ; dz_in_lay = dz_in_lay + h_2d(I,k) + endif + enddo + kf(nz+1) = 0.0 + else + do k=1,nz + dz(k) = h_2d(I,k) + u0xdz(k) = u_2d(I,k)*dz(k) ; v0xdz(k) = v_2d(I,k)*dz(k) + enddo + if (use_temperature) then + do k=1,nz + T0xdz(k) = T_2d(I,k)*dz(k) ; S0xdz(k) = S_2d(I,k)*dz(k) + enddo + else + do k=1,nz + T0xdz(k) = rho_2d(I,k)*dz(k) ; S0xdz(k) = rho_2d(I,k)*dz(k) + enddo + endif + nzc = nz + do k=1,nzc+1 ; kc(k) = k ; kf(k) = 0.0 ; enddo + endif + f2 = G%CoriolisBu(I,J)**2 + surface_pres = 0.0 ; if (associated(p_surf)) then + surface_pres = 0.25 * ((p_surf(i,j) + p_surf(i+1,j+1)) + & + (p_surf(i+1,j) + p_surf(i,j+1))) + endif + + ! ---------------------------------------------------- + ! Set the initial guess for kappa, here defined at interfaces. + ! ---------------------------------------------------- + if (new_kappa) then + do K=1,nzc+1 ; kappa(K) = US%m_to_Z**2*1.0 ; enddo + else + do K=1,nzc+1 ; kappa(K) = kappa_2d(I,K,J2) ; enddo + endif + + call kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & + dz, u0xdz, v0xdz, T0xdz, S0xdz, kappa_avg, & + tke_avg, tv, CS, GV, US) + + ! call cpu_clock_begin(Id_clock_setup) + ! Extrapolate from the vertically reduced grid back to the original layers. + if (nz == nzc) then + do K=1,nz+1 + kappa_2d(I,K,J2) = kappa_avg(K) + !### Should this be tke_avg? + tke_2d(I,K) = tke(K) + enddo + else + do K=1,nz+1 + if (kf(K) == 0.0) then + kappa_2d(I,K,J2) = kappa_avg(kc(K)) + tke_2d(I,K) = tke_avg(kc(K)) + else + kappa_2d(I,K,J2) = (1.0-kf(K)) * kappa_avg(kc(K)) + & + kf(K) * kappa_avg(kc(K)+1) + tke_2d(I,K) = (1.0-kf(K)) * tke_avg(kc(K)) + & + kf(K) * tke_avg(kc(K)+1) + endif + enddo + endif +#ifdef ADD_DIAGNOSTICS + I_Ld2_2d(I,1) = 0.0 ; dz_Int_2d(I,1) = dz_Int(1) + do K=2,nzc + I_Ld2_2d(I,K) = I_L2_bdry(K) + & + (N2(K) / CS%lambda**2 + f2) * Z2_to_L2 / (max(TKE(K),1e-30)) + dz_Int_2d(I,K) = dz_Int(K) + enddo + I_Ld2_2d(I,nzc+1) = 0.0 ; dz_Int_2d(I,nzc+1) = dz_Int(nzc+1) + do K=nzc+2,nz+1 + I_Ld2_2d(I,K) = 0.0 ; dz_Int_2d(I,K) = 0.0 + enddo +#endif + ! call cpu_clock_end(Id_clock_setup) + else ! Land points, still inside the i-loop. + do K=1,nz+1 + kappa_2d(I,K,J2) = 0.0 ; tke_2d(I,K) = 0.0 +#ifdef ADD_DIAGNOSTICS + I_Ld2_2d(I,K) = 0.0 + dz_Int_2d(I,K) = dz_Int(K) +#endif + enddo + endif ; enddo ! i-loop + + do K=1,nz+1 ; do I=IsB,IeB + tke_io(I,J,K) = G%mask2dBu(I,J) * tke_2d(I,K) + kv_io(I,J,K) = ( G%mask2dBu(I,J) * kappa_2d(I,K,J2) ) * CS%Prandtl_turb +#ifdef ADD_DIAGNOSTICS + I_Ld2_3d(I,J,K) = I_Ld2_2d(I,K) + dz_Int_3d(I,J,K) = dz_Int_2d(I,K) +#endif + enddo ; enddo + if (J>=G%jsc) then ; do K=1,nz+1 ; do i=G%isc,G%iec + ! Set the diffusivities in tracer columns from the values at vertices. + kappa_io(i,j,K) = G%mask2dT(i,j) * 0.25 * & + ((kappa_2d(I-1,K,J2m1) + kappa_2d(I,K,J2)) + & + (kappa_2d(I-1,K,J2) + kappa_2d(I,K,J2m1))) + enddo ; enddo ; endif + + enddo ! end of J-loop + + if (CS%debug) then + call hchksum(kappa_io, "kappa", G%HI, scale=US%Z_to_m**2) + call Bchksum(tke_io, "tke", G%HI) + endif + + if (CS%id_Kd_shear > 0) call post_data(CS%id_Kd_shear, kappa_io, CS%diag) + if (CS%id_TKE > 0) call post_data(CS%id_TKE, tke_io, CS%diag) +#ifdef ADD_DIAGNOSTICS + if (CS%id_ILd2 > 0) call post_data(CS%id_ILd2, I_Ld2_3d, CS%diag) + if (CS%id_dz_Int > 0) call post_data(CS%id_dz_Int, dz_Int_3d, CS%diag) +#endif + +end subroutine Calc_kappa_shear_vertex + + +!> This subroutine calculates shear-driven diffusivity and TKE in a single column subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & dz, u0xdz, v0xdz, T0xdz, S0xdz, kappa_avg, & - tke_avg, tv, CS, GV) + tke_avg, tv, CS, GV, US) 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(SZK_(GV)+1), & - intent(inout) :: kappa !< The time-weighted average of kappa, in m2 s-1. + intent(inout) :: kappa !< The time-weighted average of kappa [Z2 s-1 ~> m2 s-1]. real, dimension(SZK_(GV)+1), & intent(inout) :: tke !< The Turbulent Kinetic Energy per unit mass at - !! an interface, in units of m2 s-2. + !! an interface [m2 s-2]. integer, intent(in) :: nzc !< The number of active layers in the column. - real, intent(in) :: f2 !< The square of the Coriolis parameter, in s-2. - real, intent(in) :: surface_pres !< The surface pressure, in Pa. + real, intent(in) :: f2 !< The square of the Coriolis parameter [s-2]. + real, intent(in) :: surface_pres !< The surface pressure [Pa]. real, dimension(SZK_(GV)), & - intent(in) :: dz !< The layer thickness, in m. + intent(in) :: dz !< The layer thickness [Z ~> m]. real, dimension(SZK_(GV)), & - intent(in) :: u0xdz !< The initial zonal velocity times dz, in m2 s-1. + intent(in) :: u0xdz !< The initial zonal velocity times dz [Z m s-1 ~> m2 s-1]. real, dimension(SZK_(GV)), & - intent(in) :: v0xdz !< The initial meridional velocity times dz, in m2 s-1. + intent(in) :: v0xdz !< The initial meridional velocity times dz [Z m s-1 ~> m2 s-1]. real, dimension(SZK_(GV)), & - intent(in) :: T0xdz !< The initial temperature times dz, in C m. + intent(in) :: T0xdz !< The initial temperature times dz [degC Z ~> degC m]. real, dimension(SZK_(GV)), & - intent(in) :: S0xdz !< The initial salinity times dz, in PSU m. + intent(in) :: S0xdz !< The initial salinity times dz [ppt Z ~> ppt m]. real, dimension(SZK_(GV)+1), & - intent(out) :: kappa_avg !< The time-weighted average of kappa, in m2 s-1. + intent(out) :: kappa_avg !< The time-weighted average of kappa [Z2 s-1 ~> m2 s-1]. real, dimension(SZK_(GV)+1), & - intent(out) :: tke_avg !< The time-weighted average of TKE, in m2 s-2. - real, intent(in) :: dt !< Time increment, in s. + intent(out) :: tke_avg !< The time-weighted average of TKE [m2 s-2]. + real, intent(in) :: dt !< Time increment [s]. type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any !! available thermodynamic fields. Absent fields !! have NULL ptrs. @@ -465,70 +743,69 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & !! call to kappa_shear_init. real, dimension(nzc) :: & - u, & ! The zonal velocity after a timestep of mixing, in m s-1. - v, & ! The meridional velocity after a timestep of mixing, in m s-1. - Idz, & ! The inverse of the distance between TKE points, in m. - T, & ! The potential temperature after a timestep of mixing, in C. - Sal, & ! The salinity after a timestep of mixing, in psu. + u, & ! The zonal velocity after a timestep of mixing [m s-1]. + v, & ! The meridional velocity after a timestep of mixing [m s-1]. + Idz, & ! The inverse of the distance between TKE points [Z-1 ~> m-1]. + T, & ! The potential temperature after a timestep of mixing [degC]. + Sal, & ! The salinity after a timestep of mixing [ppt]. u_test, v_test, T_test, S_test real, dimension(nzc+1) :: & - N2, & ! The squared buoyancy frequency at an interface, in s-2. + N2, & ! The squared buoyancy frequency at an interface [s-2]. dz_Int, & ! The extent of a finite-volume space surrounding an interface, - ! as used in calculating kappa and TKE, in m. + ! as used in calculating kappa and TKE [Z ~> m]. I_dz_int, & ! The inverse of the distance between velocity & density points - ! above and below an interface, in m-1. This is used to + ! above and below an interface [Z-1 ~> m-1]. This is used to ! calculate N2, shear, and fluxes, and it might differ from ! 1/dz_Int, as they have different uses. - S2, & ! The squared shear at an interface, in s-2. + S2, & ! The squared shear at an interface [s-2]. a1, & ! a1 is the coupling between adjacent interfaces in the TKE, - ! velocity, and density equations, in m s-1 or m. + ! velocity, and density equations [Z s-1 ~> m s-1] or [Z ~> m] c1, & ! c1 is used in the tridiagonal (and similar) solvers. - k_src, & ! The shear-dependent source term in the kappa equation, in s-1. - kappa_src, & ! The shear-dependent source term in the kappa equation in s-1. - kappa_out, & ! The kappa that results from the kappa equation, in m2 s-1. - kappa_mid, & ! The average of the initial and predictor estimates of kappa, - ! in units of m2 s-1. - tke_pred, & ! The value of TKE from a predictor step, in m2 s-2. - kappa_pred, & ! The value of kappa from a predictor step, in m2 s-1. - pressure, & ! The pressure at an interface, in Pa. - T_int, & ! The temperature interpolated to an interface, in C. - Sal_int, & ! The salinity interpolated to an interface, in psu. - dbuoy_dT, & ! The partial derivatives of buoyancy with changes in - dbuoy_dS, & ! temperature and salinity, in m s-2 K-1 and m s-2 psu-1. + k_src, & ! The shear-dependent source term in the kappa equation [s-1]. + kappa_src, & ! The shear-dependent source term in the kappa equation [s-1]. + kappa_out, & ! The kappa that results from the kappa equation [Z2 s-1 ~> m2 s-1]. + kappa_mid, & ! The average of the initial and predictor estimates of kappa [Z2 s-1 ~> m2 s-1]. + tke_pred, & ! The value of TKE from a predictor step [m2 s-2]. + kappa_pred, & ! The value of kappa from a predictor step [Z2 s-1 ~> m2 s-1]. + pressure, & ! The pressure at an interface [Pa]. + T_int, & ! The temperature interpolated to an interface [degC]. + Sal_int, & ! The salinity interpolated to an interface [ppt]. + dbuoy_dT, & ! The partial derivatives of buoyancy with changes in temperature + dbuoy_dS, & ! and salinity, [Z s-2 degC-1 ~> m s-2 degC-1] and [Z s-2 ppt-1 ~> m s-2 ppt-1]. I_L2_bdry, & ! The inverse of the square of twice the harmonic mean - ! distance to the top and bottom boundaries, in m-2. - K_Q, & ! Diffusivity divided by TKE, in s. - K_Q_tmp, & ! Diffusivity divided by TKE, in s. - local_src_avg, & ! The time-integral of the local source, nondim. - tol_min, & ! Minimum tolerated ksrc for the corrector step, in s-1. - tol_max, & ! Maximum tolerated ksrc for the corrector step, in s-1. - tol_chg, & ! The tolerated change integrated in time, nondim. - dist_from_top, & ! The distance from the top surface, in m. + ! distance to the top and bottom boundaries [Z-2 ~> m-2]. + K_Q, & ! Diffusivity divided by TKE [Z2 m-2 s ~> s]. + K_Q_tmp, & ! A temporary copy of diffusivity divided by TKE [Z2 m-2 s ~> s]. + local_src_avg, & ! The time-integral of the local source [nondim]. + tol_min, & ! Minimum tolerated ksrc for the corrector step [s-1]. + tol_max, & ! Maximum tolerated ksrc for the corrector step [s-1]. + tol_chg, & ! The tolerated change integrated in time [nondim]. + dist_from_top, & ! The distance from the top surface [Z ~> m]. local_src ! The sum of all sources of kappa, including kappa_src and - ! sources from the elliptic term, in s-1. + ! sources from the elliptic term [s-1]. - real :: dist_from_bot ! The distance from the bottom surface, in m. + real :: dist_from_bot ! The distance from the bottom surface [Z ~> m]. real :: b1 ! The inverse of the pivot in the tridiagonal equations. real :: bd1 ! A term in the denominator of b1. real :: d1 ! 1 - c1 in the tridiagonal equations. - real :: gR0 ! Rho_0 times g in kg m-2 s-2. - real :: g_R0 ! g_R0 is g/Rho in m4 kg-1 s-2. - real :: Norm ! A factor that normalizes two weights to 1, in m-2. + real :: gR0 ! Rho_0 times g [kg m-2 s-2]. + real :: g_R0 ! g_R0 is g/Rho [Z m3 kg-1 s-2 ~> m4 kg-1 s-2]. + real :: Norm ! A factor that normalizes two weights to 1 [Z-2 ~> m-2]. real :: tol_dksrc, tol2 ! ### Tolerances that need to be set better later. real :: tol_dksrc_low ! The tolerance for the fractional decrease in ksrc ! within an iteration. 0 < tol_dksrc_low < 1. real :: Ri_crit ! The critical shear Richardson number for shear- ! driven mixing. The theoretical value is 0.25. - real :: dt_rem ! The remaining time to advance the solution, in s. - real :: dt_now ! The time step used in the current iteration, in s. - real :: dt_wt ! The fractional weight of the current iteration, ND. + real :: dt_rem ! The remaining time to advance the solution [s]. + real :: dt_now ! The time step used in the current iteration [s]. + real :: dt_wt ! The fractional weight of the current iteration [nondim]. real :: dt_test ! A time-step that is being tested for whether it - ! gives acceptably small changes in k_src, in s. - real :: Idtt ! Idtt = 1 / dt_test, in s-1. - real :: dt_inc ! An increment to dt_test that is being tested, in s. + ! gives acceptably small changes in k_src [s]. + real :: Idtt ! Idtt = 1 / dt_test [s-1]. + real :: dt_inc ! An increment to dt_test that is being tested [s]. - real :: k0dt ! The background diffusivity times the timestep, in m2. + real :: k0dt ! The background diffusivity times the timestep [Z2 ~> m2]. logical :: valid_dt ! If true, all levels so far exhibit acceptably small ! changes in k_src. logical :: use_temperature ! If true, temperature and salinity have been @@ -543,7 +820,7 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & integer :: k, itt, itt_dt Ri_crit = CS%Rino_crit - gR0 = GV%Rho0*GV%g_Earth ; g_R0 = GV%g_Earth/GV%Rho0 + gR0 = GV%Rho0*(GV%g_Earth*US%m_to_Z) ; g_R0 = (GV%g_Earth*US%m_to_Z**2)/GV%Rho0 k0dt = dt*CS%kappa_0 ! These are hard-coded for now. Perhaps these could be made dynamic later? ! tol_dksrc = 0.5*tol_ksrc_chg ; tol_dksrc_low = 1.0 - 1.0/tol_ksrc_chg ? @@ -568,7 +845,7 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & ! layers and applying a time-step of background diffusion. if (nzc > 1) then a1(2) = k0dt*I_dz_int(2) - b1 = 1.0 / (dz(1)+a1(2)) + b1 = 1.0 / (dz(1) + a1(2)) u(1) = b1 * u0xdz(1) ; v(1) = b1 * v0xdz(1) T(1) = b1 * T0xdz(1) ; Sal(1) = b1 * S0xdz(1) c1(2) = a1(2) * b1 ; d1 = dz(1) * b1 ! = 1 - c1 @@ -626,14 +903,14 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & do K=nzc,2,-1 dist_from_bot = dist_from_bot + dz(k) I_L2_bdry(K) = (dist_from_top(K) + dist_from_bot)**2 / & - (dist_from_top(K) * dist_from_bot)**2 + (dist_from_top(K) * dist_from_bot)**2 enddo ! Calculate thermodynamic coefficients and an initial estimate of N2. if (use_temperature) then pressure(1) = surface_pres do K=2,nzc - pressure(K) = pressure(K-1) + gR0*dz(k-1) + pressure(K) = pressure(K-1) + gR0*US%Z_to_m*dz(k-1) T_int(K) = 0.5*(T(k-1) + T(k)) Sal_int(K) = 0.5*(Sal(k-1) + Sal(k)) enddo @@ -688,9 +965,9 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & #endif ! This call just calculates N2 and S2. - call calculate_projected_state(kappa, u, v, T, Sal, 0.0, nzc, & - dz, I_dz_int, dbuoy_dT, dbuoy_dS, & - u, v, T, Sal, N2=N2, S2=S2) + call calculate_projected_state(kappa, u, v, T, Sal, 0.0, nzc, dz, I_dz_int, & + dbuoy_dT, dbuoy_dS, u, v, T, Sal, GV, US, & + N2=N2, S2=S2, vel_underflow=CS%vel_underflow) ! ---------------------------------------------------- ! Iterate ! ---------------------------------------------------- @@ -721,7 +998,7 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & ! call cpu_clock_begin(id_clock_KQ) call find_kappa_tke(N2, S2, kappa, Idz, dz_Int, I_L2_bdry, f2, & - nzc, CS, K_Q, tke, kappa_out, kappa_src, local_src) + nzc, CS, GV, US, K_Q, tke, kappa_out, kappa_src, local_src) ! call cpu_clock_end(id_clock_KQ) ! call cpu_clock_begin(id_clock_avg) @@ -758,10 +1035,10 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & ! timestep is found long before the minimum is reached, so the ! value of max_KS_it may be unimportant, especially if it is large ! enough. - call calculate_projected_state(kappa_out, u, v, T, Sal, 0.5*dt_test, nzc, & - dz, I_dz_int, dbuoy_dT, dbuoy_dS, & - u_test, v_test, T_test, S_test, N2, S2, & - ks_int = ks_kappa, ke_int = ke_kappa) + call calculate_projected_state(kappa_out, u, v, T, Sal, 0.5*dt_test, nzc, dz, I_dz_int, & + dbuoy_dT, dbuoy_dS, u_test, v_test, T_test, S_test, & + GV, US, N2, S2, ks_int=ks_kappa, ke_int=ke_kappa, & + vel_underflow=CS%vel_underflow) valid_dt = .true. Idtt = 1.0 / dt_test do K=max(ks_kappa-1,2),min(ke_kappa+1,nzc) @@ -785,10 +1062,9 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & if ((dt_test < dt_rem) .and. valid_dt) then dt_inc = 0.5*dt_test do itt_dt=1,dt_refinements - call calculate_projected_state(kappa_out, u, v, T, Sal, & - 0.5*(dt_test+dt_inc), nzc, dz, I_dz_int, dbuoy_dT, & - dbuoy_dS, u_test, v_test, T_test, S_test, N2, S2, & - ks_int = ks_kappa, ke_int = ke_kappa) + call calculate_projected_state(kappa_out, u, v, T, Sal, 0.5*(dt_test+dt_inc), & + nzc, dz, I_dz_int, dbuoy_dT, dbuoy_dS, u_test, v_test, T_test, S_test, & + GV, US, N2, S2, ks_int=ks_kappa, ke_int=ke_kappa, vel_underflow=CS%vel_underflow) valid_dt = .true. Idtt = 1.0 / (dt_test+dt_inc) do K=max(ks_kappa-1,2),min(ke_kappa+1,nzc) @@ -839,16 +1115,16 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & ! call cpu_clock_end(id_clock_avg) else ! call cpu_clock_begin(id_clock_project) - call calculate_projected_state(kappa_out, u, v, T, Sal, dt_now, nzc, & - dz, I_dz_int, dbuoy_dT, dbuoy_dS, & - u_test, v_test, T_test, S_test, N2=N2, S2=S2, & - ks_int = ks_kappa, ke_int = ke_kappa) + call calculate_projected_state(kappa_out, u, v, T, Sal, dt_now, nzc, dz, I_dz_int, & + dbuoy_dT, dbuoy_dS, u_test, v_test, T_test, S_test, & + GV, US, N2=N2, S2=S2, ks_int=ks_kappa, ke_int=ke_kappa, & + vel_underflow=CS%vel_underflow) ! call cpu_clock_end(id_clock_project) ! call cpu_clock_begin(id_clock_KQ) do K=1,nzc+1 ; K_Q_tmp(K) = K_Q(K) ; enddo call find_kappa_tke(N2, S2, kappa_out, Idz, dz_Int, I_L2_bdry, f2, & - nzc, CS, K_Q_tmp, tke_pred, kappa_pred) + nzc, CS, GV, US, K_Q_tmp, tke_pred, kappa_pred) ! call cpu_clock_end(id_clock_KQ) ks_kappa = GV%ke+1 ; ke_kappa = 0 @@ -859,15 +1135,15 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & enddo ! call cpu_clock_begin(id_clock_project) - call calculate_projected_state(kappa_mid, u, v, T, Sal, dt_now, nzc, & - dz, I_dz_int, dbuoy_dT, dbuoy_dS, & - u_test, v_test, T_test, S_test, N2=N2, S2=S2, & - ks_int = ks_kappa, ke_int = ke_kappa) + call calculate_projected_state(kappa_mid, u, v, T, Sal, dt_now, nzc, dz, I_dz_int, & + dbuoy_dT, dbuoy_dS, u_test, v_test, T_test, S_test, & + GV, US, N2=N2, S2=S2, ks_int=ks_kappa, ke_int=ke_kappa, & + vel_underflow=CS%vel_underflow) ! call cpu_clock_end(id_clock_project) ! call cpu_clock_begin(id_clock_KQ) call find_kappa_tke(N2, S2, kappa_out, Idz, dz_Int, I_L2_bdry, f2, & - nzc, CS, K_Q, tke_pred, kappa_pred) + nzc, CS, GV, US, K_Q, tke_pred, kappa_pred) ! call cpu_clock_end(id_clock_KQ) ! call cpu_clock_begin(id_clock_avg) @@ -885,8 +1161,8 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & ! Update the values of u, v, T, Sal, N2, and S2 for the next iteration. ! call cpu_clock_begin(id_clock_project) call calculate_projected_state(kappa_mid, u, v, T, Sal, dt_now, nzc, & - dz, I_dz_int, dbuoy_dT, dbuoy_dS, & - u, v, T, Sal, N2, S2) + dz, I_dz_int, dbuoy_dT, dbuoy_dS, u, v, T, Sal, & + GV, US, N2, S2, vel_underflow=CS%vel_underflow) ! call cpu_clock_end(id_clock_project) endif @@ -920,7 +1196,7 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & Ri_k(K) = 1e3 ; if (N2(K) < 1e3 * S2(K)) Ri_k(K) = N2(K) / S2(K) dtke(K) = tke_pred(K) - tke(K) dtke_norm(K) = dtke(K) / (0.5*(tke(K) + tke_pred(K))) - dkappa(K) = kappa_pred(K) - kappa_out(K) + dkap(K) = kappa_pred(K) - kappa_out(K) enddo if (itt <= max_debug_itt) then do k=1,nzc @@ -937,7 +1213,7 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & if (abs(dkappa_it1(K,itt-1)) > 1e-20) & d_dkappa_it1(K,itt) = dkappa_it1(K,itt) / dkappa_it1(K,itt-1) endif - dkappa_norm(K,itt) = dkappa(K) / max(0.5*(Kappa_pred(K) + kappa_out(K)), 1e-100) + dkappa_norm(K,itt) = dkap(K) / max(0.5*(kappa_pred(K) + kappa_out(K)), US%m_to_Z**2*1e-100) enddo endif #endif @@ -948,73 +1224,57 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & end subroutine kappa_shear_column -subroutine calculate_projected_state(kappa, u0, v0, T0, S0, dt, nz, & - dz, I_dz_int, dbuoy_dT, dbuoy_dS, & - u, v, T, Sal, N2, S2, ks_int, ke_int) -!< This subroutine calculates the velocities, temperature and salinity that +!> This subroutine calculates the velocities, temperature and salinity that !! the water column will have after mixing for dt with diffusivities kappa. It !! may also calculate the projected buoyancy frequency and shear. +subroutine calculate_projected_state(kappa, u0, v0, T0, S0, dt, nz, & + dz, I_dz_int, dbuoy_dT, dbuoy_dS, & + u, v, T, Sal, GV, US, N2, S2, ks_int, ke_int, vel_underflow) integer, intent(in) :: nz !< The number of layers (after eliminating massless !! layers?). real, dimension(nz+1), intent(in) :: kappa !< The diapycnal diffusivity at interfaces, - !! in m2 s-1. - real, dimension(nz), intent(in) :: u0 !< The initial zonal velocity, in m s-1. - real, dimension(nz), intent(in) :: v0 !< The initial meridional velocity, in m s-1. - real, dimension(nz), intent(in) :: T0 !< The initial temperature, in C. - real, dimension(nz), intent(in) :: S0 !< The initial salinity, in PSU. - real, dimension(nz), intent(in) :: dz !< The grid spacing of layers, in m. - real, dimension(nz+1), intent(in) :: I_dz_int !< The inverse of the layer's thicknesses, - !! in m-1. + !! [Z2 s-1 ~> m2 s-1]. + real, dimension(nz), intent(in) :: u0 !< The initial zonal velocity [m s-1]. + real, dimension(nz), intent(in) :: v0 !< The initial meridional velocity [m s-1]. + real, dimension(nz), intent(in) :: T0 !< The initial temperature [degC]. + real, dimension(nz), intent(in) :: S0 !< The initial salinity [ppt]. + real, dimension(nz), intent(in) :: dz !< The grid spacing of layers [Z ~> m]. + real, dimension(nz+1), intent(in) :: I_dz_int !< The inverse of the layer's thicknesses + !! [Z-1 ~> m-1]. real, dimension(nz+1), intent(in) :: dbuoy_dT !< The partial derivative of buoyancy with - !! temperature, in m s-2 C-1. + !! temperature [Z s-2 degC-1 ~> m s-2 degC-1]. real, dimension(nz+1), intent(in) :: dbuoy_dS !< The partial derivative of buoyancy with - !! salinity, in m s-2 PSU-1. - real, intent(in) :: dt !< The time step in s. - real, dimension(nz), intent(inout) :: u !< The zonal velocity after dt, in m s-1. - real, dimension(nz), intent(inout) :: v !< The meridional velocity after dt, in m s-1. - real, dimension(nz), intent(inout) :: T !< The temperature after dt, in C. - real, dimension(nz), intent(inout) :: Sal !< The salinity after dt, in PSU. + !! salinity [Z s-2 ppt-1 ~> m s-2 ppt-1]. + real, intent(in) :: dt !< The time step [s]. + real, dimension(nz), intent(inout) :: u !< The zonal velocity after dt [m s-1]. + real, dimension(nz), intent(inout) :: v !< The meridional velocity after dt [m s-1]. + real, dimension(nz), intent(inout) :: T !< The temperature after dt [degC]. + real, dimension(nz), intent(inout) :: Sal !< The salinity after dt [ppt]. + 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(nz+1), optional, & - intent(inout) :: N2 !< The buoyancy frequency squared at interfaces, - !! in s-2. + intent(inout) :: N2 !< The buoyancy frequency squared at interfaces [s-2]. real, dimension(nz+1), optional, & - intent(inout) :: S2 !< The squared shear at interfaces, in s-2. + intent(inout) :: S2 !< The squared shear at interfaces [s-2]. integer, optional, intent(in) :: ks_int !< The topmost k-index with a non-zero diffusivity. integer, optional, intent(in) :: ke_int !< The bottommost k-index with a non-zero !! diffusivity. + real, optional, intent(in) :: vel_underflow !< If present and true, any velocities that + !! are smaller in magnitude than this value are + !! set to 0 [m s-1]. - ! Arguments: kappa - The diapycnal diffusivity at interfaces, in m2 s-1. - ! (in) Sh - The shear at interfaces, in s-1. - ! (in) u0 - The initial zonal velocity, in m s-1. - ! (in) v0 - The initial meridional velocity, in m s-1. - ! (in) T0 - The initial temperature, in C. - ! (in) S0 - The initial salinity, in PSU. - ! (in) nz - The number of layers (after eliminating massless layers?). - ! (in) dz - The grid spacing of layers, in m. - ! (in) I_dz_int - The inverse of the layer's thicknesses, in m-1. - ! (in) dbuoy_dT - The partial derivative of buoyancy with temperature, - ! in m s-2 C-1. - ! (in) dbuoy_dS - The partial derivative of buoyancy with salinity, - ! in m s-2 PSU-1. - ! (in) dt - The time step in s. - ! (in) nz - The number of layers to work on. - ! (out) u - The zonal velocity after dt, in m s-1. - ! (out) v - The meridional velocity after dt, in m s-1. - ! (in) T - The temperature after dt, in C. - ! (in) Sal - The salinity after dt, in PSU. - ! (out) N2 - The buoyancy frequency squared at interfaces, in s-2. - ! (out) S2 - The squared shear at interfaces, in s-2. - ! (in,opt) ks_int - The topmost k-index with a non-zero diffusivity. - ! (in,opt) ke_int - The bottommost k-index with a non-zero diffusivity. - - ! UNCOMMENT THE FOLLOWING IF NOT CONTAINED IN THE OUTER SUBROUTINE. + ! Local variables real, dimension(nz+1) :: c1 + real :: L2_to_Z2 ! A conversion factor from horizontal length units to vertical depth + ! units squared [Z2 m-2 ~> 1]. + real :: underflow_vel ! Velocities smaller in magnitude than underflow_vel are set to 0 [m s-1]. real :: a_a, a_b, b1, d1, bd1, b1nz_0 integer :: k, ks, ke ks = 1 ; ke = nz if (present(ks_int)) ks = max(ks_int-1,1) if (present(ke_int)) ke = min(ke_int,nz) + underflow_vel = 0.0 ; if (present(vel_underflow)) underflow_vel = vel_underflow if (ks > ke) return @@ -1057,28 +1317,35 @@ subroutine calculate_projected_state(kappa, u0, v0, T0, S0, dt, nz, & endif u(ke) = b1nz_0 * (dz(ke)*u0(ke) + a_a*u(ke-1)) v(ke) = b1nz_0 * (dz(ke)*v0(ke) + a_a*v(ke-1)) + if (abs(u(ke)) < underflow_vel) u(ke) = 0.0 + if (abs(v(ke)) < underflow_vel) v(ke) = 0.0 do k=ke-1,ks,-1 u(k) = u(k) + c1(k+1)*u(k+1) v(k) = v(k) + c1(k+1)*v(k+1) + if (abs(u(k)) < underflow_vel) u(k) = 0.0 + if (abs(v(k)) < underflow_vel) v(k) = 0.0 T(k) = T(k) + c1(k+1)*T(k+1) Sal(k) = Sal(k) + c1(k+1)*Sal(k+1) enddo else ! dt <= 0.0 do k=1,nz u(k) = u0(k) ; v(k) = v0(k) ; T(k) = T0(k) ; Sal(k) = S0(k) + if (abs(u(k)) < underflow_vel) u(k) = 0.0 + if (abs(v(k)) < underflow_vel) v(k) = 0.0 enddo endif if (present(S2)) then + L2_to_Z2 = US%m_to_Z**2 S2(1) = 0.0 ; S2(nz+1) = 0.0 if (ks > 1) & - S2(ks) = ((u(ks)-u0(ks-1))**2 + (v(ks)-v0(ks-1))**2) * I_dz_int(ks)**2 + S2(ks) = ((u(ks)-u0(ks-1))**2 + (v(ks)-v0(ks-1))**2) * (L2_to_Z2*I_dz_int(ks)**2) do K=ks+1,ke - S2(K) = ((u(k)-u(k-1))**2 + (v(k)-v(k-1))**2) * I_dz_int(K)**2 + S2(K) = ((u(k)-u(k-1))**2 + (v(k)-v(k-1))**2) * (L2_to_Z2*I_dz_int(K)**2) enddo if (ke This subroutine calculates new, consistent estimates of TKE and kappa. subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & - nz, CS, K_Q, tke, kappa, kappa_src, local_src) + nz, CS, GV, US, K_Q, tke, kappa, kappa_src, local_src) integer, intent(in) :: nz !< The number of layers to work on. - real, dimension(nz+1), intent(in) :: N2 !< The buoyancy frequency squared at interfaces, - !! in s-2. - real, dimension(nz+1), intent(in) :: S2 !< The squared shear at interfaces, in s-2. - real, dimension(nz+1), intent(in) :: kappa_in !< The initial guess at the diffusivity, - !! in m2 s-1. - real, dimension(nz+1), intent(in) :: dz_Int !< The thicknesses associated with interfaces, - !! in m. + real, dimension(nz+1), intent(in) :: N2 !< The buoyancy frequency squared at interfaces [s-2]. + real, dimension(nz+1), intent(in) :: S2 !< The squared shear at interfaces [s-2]. + real, dimension(nz+1), intent(in) :: kappa_in !< The initial guess at the diffusivity + !! [Z2 s-1 ~> m2 s-1]. + real, dimension(nz+1), intent(in) :: dz_Int !< The thicknesses associated with interfaces + !! [Z-1 ~> m-1]. real, dimension(nz+1), intent(in) :: I_L2_bdry !< The inverse of the squared distance to - !! boundaries, m2. - real, dimension(nz), intent(in) :: Idz !< The inverse grid spacing of layers, in m-1. - real, intent(in) :: f2 !< The squared Coriolis parameter, in s-2. + !! boundaries [m-2]. + real, dimension(nz), intent(in) :: Idz !< The inverse grid spacing of layers [Z-1 ~> m-1]. + real, intent(in) :: f2 !< The squared Coriolis parameter [s-2]. type(Kappa_shear_CS), pointer :: CS !< A pointer to this module's control 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(nz+1), intent(inout) :: K_Q !< The shear-driven diapycnal diffusivity divided by !! the turbulent kinetic energy per unit mass at - !! interfaces, in s. + !! interfaces [s]. real, dimension(nz+1), intent(out) :: tke !< The turbulent kinetic energy per unit mass at - !! interfaces, in units of m2 s-2. - real, dimension(nz+1), intent(out) :: kappa !< The diapycnal diffusivity at interfaces, - !! in m2 s-1. + !! interfaces [m2 s-2]. + real, dimension(nz+1), intent(out) :: kappa !< The diapycnal diffusivity at interfaces + !! [Z2 s-1 ~> m2 s-1]. real, dimension(nz+1), optional, & - intent(out) :: kappa_src !< The source term for kappa, in s-1. + intent(out) :: kappa_src !< The source term for kappa [s-1]. real, dimension(nz+1), optional, & intent(out) :: local_src !< The sum of all local sources for kappa, - !! in s-1. + !! [s-1]. ! This subroutine calculates new, consistent estimates of TKE and kappa. -! Arguments: N2 - The buoyancy frequency squared at interfaces, in s-2. -! (in) S2 - The squared shear at interfaces, in s-2. -! (in) kappa_in - The initial guess at the diffusivity, in m2 s-1. -! (in) Idz - The inverse grid spacing of layers, in m-1. -! (in) dz_Int - The thicknesses associated with interfaces, in m. -! (in) I_L2_bdry - The inverse of the squared distance to boundaries, m2. -! (in) f2 - The squared Coriolis parameter, in s-2. -! (in) nz - The number of layers to work on. -! (in) CS - A pointer to this module's control structure. -! (inout) K_Q - The shear-driven diapycnal diffusivity divided by the -! turbulent kinetic energy per unit mass at interfaces, in s. -! (out) tke - The turbulent kinetic energy per unit mass at interfaces, -! in units of m2 s-2. -! (out) kappa - The diapycnal diffusivity at interfaces, in m2 s-1. -! (out,opt) kappa_src - The source term for kappa, in s-1. -! (out,opt) local_src - The sum of all local sources for kappa, in s-1. - -! UNCOMMENT THE FOLLOWING IF NOT CONTAINED IN Calculate_kappa_shear + ! Local variables real, dimension(nz) :: & - aQ, & ! aQ is the coupling between adjacent interfaces in the TKE - ! equations, in m s-1. - dQdz ! Half the partial derivative of TKE with depth, m s-2. + aQ, & ! aQ is the coupling between adjacent interfaces in the TKE equations [m s-1]. + dQdz ! Half the partial derivative of TKE with depth [m s-2]. real, dimension(nz+1) :: & - dK, & ! The change in kappa, in m2 s-1. - dQ, & ! The change in TKE, in m2 s-1. + dK, & ! The change in kappa [Z2 s-1 ~> m2 s-1]. + dQ, & ! The change in TKE [m2 s-2]. cQ, cK, & ! cQ and cK are the upward influences in the tridiagonal and - ! hexadiagonal solvers for the TKE and kappa equations, ND. + ! hexadiagonal solvers for the TKE and kappa equations [nondim]. I_Ld2, & ! 1/Ld^2, where Ld is the effective decay length scale - ! for kappa, in units of m-2. - TKE_decay, & ! The local TKE decay rate in s-1. - k_src, & ! The source term in the kappa equation, in s-1. - dQmdK, & ! With Newton's method the change in dQ(k-1) due to dK(k), s. - dKdQ, & ! With Newton's method the change in dK(k) due to dQ(k), s-1. + ! for kappa [Z-2 ~> m-2]. + TKE_decay, & ! The local TKE decay rate [s-1]. + k_src, & ! The source term in the kappa equation [s-1]. + dQmdK, & ! With Newton's method the change in dQ(k-1) due to dK(k) [m2 s Z-2 ~> s]. + dKdQ, & ! With Newton's method the change in dK(k) due to dQ(k) [Z2 m-2 s-1 ~> s-1]. e1 ! The fractional change in a layer TKE due to a change in the ! TKE of the layer above when all the kappas below are 0. ! e1 is nondimensional, and 0 < e1 < 1. real :: tke_src ! The net source of TKE due to mixing against the shear - ! and stratification, in m2 s-3. (For convenience, + ! and stratification [m2 s-3]. (For convenience, ! a term involving the non-dissipation of q0 is also ! included here.) - real :: bQ, bK ! The inverse of the pivot in the tridiagonal equations. + real :: bQ, bK ! The inverse of the pivot in the tridiagonal equations [Z-1 ~> m-1]. real :: bd1 ! A term in the denominator of bQ or bK. real :: cQcomp, cKcomp ! 1 - cQ or 1 - cK in the tridiagonal equations. real :: c_s2 ! The coefficient for the decay of TKE due to ! shear (i.e. proportional to |S|*tke), nondimensional. real :: c_n2 ! The coefficient for the decay of TKE due to - ! stratification (i.e. proportional to N*tke), nondim. + ! stratification (i.e. proportional to N*tke) [nondim]. real :: Ri_crit ! The critical shear Richardson number for shear- ! driven mixing. The theoretical value is 0.25. - real :: q0 ! The background level of TKE, in m2 s-2. + real :: q0 ! The background level of TKE [m2 s-2]. real :: Ilambda2 ! 1.0 / CS%lambda**2. real :: TKE_min ! The minimum value of shear-driven TKE that can be - ! solved for, in m2 s-2. - real :: kappa0 ! The background diapycnal diffusivity, in m2 s-1. - real :: max_err ! The maximum value of norm_err in a column, nondim. - real :: kappa_trunc ! Diffusivities smaller than this are rounded to 0, m2 s-1. + ! solved for [m2 s-2]. + real :: kappa0 ! The background diapycnal diffusivity [Z2 s-1 ~> m2 s-1]. + real :: max_err ! The maximum value of norm_err in a column [nondim]. + real :: kappa_trunc ! Diffusivities smaller than this are rounded to 0 [Z2 s-1 ~> m2 s-1]. real :: eden1, eden2, I_eden, ome ! Variables used in calculating e1. - real :: diffusive_src ! The diffusive source in the kappa equation, in m s-1. + real :: diffusive_src ! The diffusive source in the kappa equation [m s-1]. real :: chg_by_k0 ! The value of k_src that leads to an increase of - ! kappa_0 if only the diffusive term is a sink, in s-1. + ! kappa_0 if only the diffusive term is a sink [s-1]. - real :: kappa_mean ! A mean value of kappa, in m2 s-1. + real :: kappa_mean ! A mean value of kappa [Z2 s-1 ~> m2 s-1]. real :: Newton_test ! The value of relative error that will cause the next ! iteration to use Newton's method. ! Temporary variables used in the Newton's method iterations. - real :: decay_term, I_Q, kap_src, v1, v2 - + real :: decay_term_k ! The decay term in the diffusivity equation + real :: decay_term_Q ! The decay term in the TKE equation + real :: I_Q ! The inverse of TKE [s2 m-2] + real :: kap_src + real :: v1, v2 + real :: Z2_to_L2 ! A conversion factor from vertical depth units to horizontal length + ! units squared [m2 Z-2]. real :: tol_err ! The tolerance for max_err that determines when to ! stop iterating. real :: Newton_err ! The tolerance for max_err that determines when to @@ -1219,13 +1474,13 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & integer :: max_debug_itt ; parameter(max_debug_itt=20) real :: K_err_lin, Q_err_lin real, dimension(nz+1) :: & - kappa_prev, & ! The value of kappa at the start of the current iteration, in m2 s-1. - TKE_prev ! The value of TKE at the start of the current iteration, in m2 s-2. + kappa_prev, & ! The value of kappa at the start of the current iteration [Z2 s-1 ~> m2 s-1]. + TKE_prev ! The value of TKE at the start of the current iteration [m2 s-2]. real, dimension(nz+1,1:max_debug_itt) :: & tke_it1, kappa_it1, kprev_it1, & ! Various values from each iteration. dkappa_it1, K_Q_it1, d_dkappa_it1, dkappa_norm_it1 real :: norm_err ! The absolute change in kappa between iterations, - ! normalized by the value of kappa, nondim. + ! normalized by the value of kappa [nondim]. real :: max_TKE_err, min_TKE_err, TKE_err(nz) ! Various normalized TKE changes. integer :: it2 #endif @@ -1234,6 +1489,7 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & q0 = CS%TKE_bg ; kappa0 = CS%kappa_0 ; TKE_min = max(CS%TKE_bg,1.0E-20) Ri_crit = CS%Rino_crit Ilambda2 = 1.0 / CS%lambda**2 + Z2_to_L2 = US%Z_to_m**2 kappa_trunc = 0.01*kappa0 ! ### CHANGE THIS HARD-WIRING LATER? do_Newton = .false. ; abort_Newton = .false. tol_err = CS%kappa_tol_err @@ -1317,13 +1573,13 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & ! terms. ke_tke = max(ke_kappa,ke_kappa_prev)+1 - ! aQ is the coupling between adjacent interfaces in m s-1. + ! aQ is the coupling between adjacent interfaces [Z s-1 ~> m s-1]. do k=1,min(ke_tke,nz) - aQ(k) = (0.5*(kappa(K)+kappa(K+1))+kappa0) * Idz(k) + aQ(k) = (0.5*(kappa(K)+kappa(K+1)) + kappa0) * Idz(k) enddo dQ(1) = -TKE(1) if (tke_noflux_top_BC) then - tke_src = kappa0*S2(1) + q0 * TKE_decay(1) ! Uses that kappa(1) = 0 + tke_src = Z2_to_L2*kappa0*S2(1) + q0 * TKE_decay(1) ! Uses that kappa(1) = 0 bd1 = dz_Int(1) * TKE_decay(1) bQ = 1.0 / (bd1 + aQ(1)) tke(1) = bQ * (dz_Int(1)*tke_src) @@ -1333,8 +1589,8 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & endif do K=2,ke_tke-1 dQ(K) = -TKE(K) - tke_src = (kappa(K) + kappa0)*S2(K) + q0*TKE_decay(K) - bd1 = dz_Int(K)*(TKE_decay(K) + N2(K)*K_Q(K)) + cQcomp*aQ(k-1) + tke_src = Z2_to_L2*(kappa(K) + kappa0)*S2(K) + q0*TKE_decay(K) + bd1 = dz_Int(K)*(TKE_decay(K) + N2(K)*Z2_to_L2*K_Q(K)) + cQcomp*aQ(k-1) bQ = 1.0 / (bd1 + aQ(k)) tke(K) = bQ * (dz_Int(K)*tke_src + aQ(k-1)*tke(K-1)) cQ(K+1) = aQ(k) * bQ ; cQcomp = bd1 * bQ ! = 1 - cQ @@ -1344,7 +1600,7 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & dQ(nz+1) = 0.0 else k = ke_tke - tke_src = kappa0*S2(K) + q0*TKE_decay(K) ! Uses that kappa(ke_tke) = 0 + tke_src = Z2_to_L2*kappa0*S2(K) + q0*TKE_decay(K) ! Uses that kappa(ke_tke) = 0 if (K == nz+1) then dQ(K) = -TKE(K) bQ = 1.0 / (dz_Int(K)*TKE_decay(K) + cQcomp*aQ(k-1)) @@ -1387,12 +1643,12 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & dK(1) = 0.0 ! kappa takes boundary values of 0. cK(2) = 0.0 ; cKcomp = 1.0 if (itt == 1) then ; dO K=2,nz - I_Ld2(K) = (N2(K)*Ilambda2 + f2) / tke(K) + I_L2_bdry(K) + I_Ld2(K) = (N2(K)*Ilambda2 + f2) * Z2_to_L2 / tke(K) + I_L2_bdry(K) enddo ; endif do K=2,nz dK(K) = -kappa(K) if (itt>1) & - I_Ld2(K) = (N2(K)*Ilambda2 + f2) / tke(K) + I_L2_bdry(K) + I_Ld2(K) = (N2(K)*Ilambda2 + f2) * Z2_to_L2 / tke(K) + I_L2_bdry(K) bd1 = dz_Int(K)*I_Ld2(K) + cKcomp*Idz(k-1) bK = 1.0 / (bd1 + Idz(k)) @@ -1436,7 +1692,7 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & aQ(1) = (0.5*(kappa(1)+kappa(2))+kappa0) * Idz(1) dQdz(1) = 0.5*(TKE(1) - TKE(2))*Idz(1) if (tke_noflux_top_BC) then - tke_src = dz_Int(1) * (kappa0*S2(1) - (TKE(1) - q0)*TKE_decay(1)) - & + tke_src = dz_Int(1) * (Z2_to_L2*kappa0*S2(1) - (TKE(1) - q0)*TKE_decay(1)) - & aQ(1) * (TKE(1) - TKE(2)) bQ = 1.0 / (aQ(1) + dz_Int(1)*TKE_decay(1)) @@ -1449,21 +1705,21 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & endif do K=2,nz I_Q = 1.0 / TKE(K) - I_Ld2(K) = (N2(K)*Ilambda2 + f2) * I_Q + I_L2_bdry(K) + I_Ld2(K) = (N2(K)*Ilambda2 + f2) * (Z2_to_L2*I_Q) + I_L2_bdry(K) kap_src = dz_Int(K) * (k_src(K) - I_Ld2(K)*kappa(K)) + & - Idz(k-1)*(kappa(K-1)-kappa(K)) - Idz(k)*(kappa(K)-kappa(K+1)) + Idz(k-1)*(kappa(K-1)-kappa(K)) - Idz(k)*(kappa(K)-kappa(K+1)) ! Ensure that the pivot is always positive, and that 0 <= cK <= 1. ! Otherwise do not use Newton's method. - decay_term = -Idz(k-1)*dQmdK(K)*dKdQ(K-1) + dz_Int(K)*I_Ld2(K) - if (decay_term < 0.0) then ; abort_Newton = .true. ; exit ; endif - bK = 1.0 / (Idz(k) + Idz(k-1)*cKcomp + decay_term) + decay_term_k = -Idz(k-1)*dQmdK(K)*dKdQ(K-1) + dz_Int(K)*I_Ld2(K) + if (decay_term_k < 0.0) then ; abort_Newton = .true. ; exit ; endif + bK = 1.0 / (Idz(k) + Idz(k-1)*cKcomp + decay_term_k) cK(K+1) = bK * Idz(k) - cKcomp = bK * (Idz(k-1)*cKcomp + decay_term) ! = 1-cK(K+1) + cKcomp = bK * (Idz(k-1)*cKcomp + decay_term_k) ! = 1-cK(K+1) dKdQ(K) = bK * (Idz(k-1)*dKdQ(K-1)*cQ(K) + & - (N2(K)*Ilambda2 + f2)*I_Q**2*kappa(K)) + US%Z_to_m*(N2(K)*Ilambda2 + f2) * I_Q**2 * kappa(K) ) dK(K) = bK * (kap_src + Idz(k-1)*dK(K-1) + Idz(k-1)*dKdQ(K-1)*dQ(K-1)) ! Truncate away negligibly small values of kappa. @@ -1477,21 +1733,21 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & ! Solve for dQ(K)... aQ(k) = (0.5*(kappa(K)+kappa(K+1))+kappa0) * Idz(k) dQdz(k) = 0.5*(TKE(K) - TKE(K+1))*Idz(k) - tke_src = dz_Int(K) * ((kappa(k) + kappa0)*S2(k) - kappa(k)*N2(k) - & - (TKE(k) - q0)*TKE_decay(k)) - & + tke_src = dz_Int(K) * (Z2_to_L2*((kappa(k) + kappa0)*S2(k) - kappa(k)*N2(k)) - & + (TKE(k) - q0)*TKE_decay(k)) - & (aQ(k) * (TKE(K) - TKE(K+1)) - aQ(k-1) * (TKE(K-1) - TKE(K))) v1 = aQ(k-1) + dQdz(k-1)*dKdQ(K-1) v2 = (v1*dQmdK(K) + dQdz(k-1)*cK(K)) + & - ((dQdz(k-1) - dQdz(k)) + dz_Int(K)*(S2(K) - N2(K))) + ((dQdz(k-1) - dQdz(k)) + Z2_to_L2*dz_Int(K)*(S2(K) - N2(K))) ! Ensure that the pivot is always positive, and that 0 <= cQ <= 1. ! Otherwise do not use Newton's method. - decay_term = dz_Int(K)*TKE_decay(K) - dQdz(k-1)*dKdQ(K-1)*cQ(K) - v2*dKdQ(K) - if (decay_term < 0.0) then ; abort_Newton = .true. ; exit ; endif - bQ = 1.0 / (aQ(k) + (cQcomp*aQ(k-1) + decay_term)) + decay_term_Q = dz_Int(K)*TKE_decay(K) - dQdz(k-1)*dKdQ(K-1)*cQ(K) - v2*dKdQ(K) + if (decay_term_Q < 0.0) then ; abort_Newton = .true. ; exit ; endif + bQ = 1.0 / (aQ(k) + (cQcomp*aQ(k-1) + decay_term_Q)) cQ(K+1) = aQ(k) * bQ - cQcomp = (cQcomp*aQ(k-1) + decay_term) * bQ + cQcomp = (cQcomp*aQ(k-1) + decay_term_Q) * bQ dQmdK(K+1) = (v2 * cK(K+1) - dQdz(k)) * bQ ! Ensure that TKE+dQ will not drop below 0.5*TKE. @@ -1509,15 +1765,15 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & dK(nz+1) = 0.0 ; dKdQ(nz+1) = 0.0 if (tke_noflux_bottom_BC) then K = nz+1 - tke_src = dz_Int(K) * (kappa0*S2(K) - (TKE(K) - q0)*TKE_decay(K)) + & + tke_src = dz_Int(K) * (Z2_to_L2*kappa0*S2(K) - (TKE(K) - q0)*TKE_decay(K)) + & aQ(k-1) * (TKE(K-1) - TKE(K)) v1 = aQ(k-1) + dQdz(k-1)*dKdQ(K-1) - decay_term = max(0.0, dz_Int(K)*TKE_decay(K) - dQdz(k-1)*dKdQ(K-1)*cQ(K)) - if (decay_term < 0.0) then + decay_term_Q = max(0.0, dz_Int(K)*TKE_decay(K) - dQdz(k-1)*dKdQ(K-1)*cQ(K)) + if (decay_term_Q < 0.0) then abort_Newton = .true. else - bQ = 1.0 / (aQ(k) + (cQcomp*aQ(k-1) + decay_term)) + bQ = 1.0 / (aQ(k) + (cQcomp*aQ(k-1) + decay_term_Q)) ! Ensure that TKE+dQ will not drop below 0.5*TKE. dQ(K) = max(bQ * ((v1 * dQ(K-1) + dQdz(k-1)*dK(K-1)) + tke_src), & -0.5*TKE(K)) @@ -1535,10 +1791,9 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & if (K < nz+1) then ! Ignore this source? aQ(k) = (0.5*(kappa(K)+kappa(K+1))+kappa0) * Idz(k) - tke_src = (dz_Int(K) * (kappa0*S2(K) - (TKE(K)-q0)*TKE_decay(K)) - & - (aQ(k) * (TKE(K) - TKE(K+1)) - & - aQ(k-1) * (TKE(K-1) - TKE(K))) ) / & - (aQ(k) + (aQ(k-1) + dz_Int(K)*TKE_decay(K))) + tke_src = (dz_Int(K) * (Z2_to_L2*kappa0*S2(K) - (TKE(K)-q0)*TKE_decay(K)) - & + (aQ(k) * (TKE(K) - TKE(K+1)) - aQ(k-1) * (TKE(K-1) - TKE(K))) ) / & + (aQ(k) + (aQ(k-1) + dz_Int(K)*TKE_decay(K))) endif #endif dK(K) = 0.0 @@ -1579,7 +1834,8 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & endif #ifdef DEBUG - ! Check these solutions for consistency. + ! Check these solutions for consistency. + ! The unit conversions here have not been carefully tested. do K=2,nz ! In these equations, K_err_lin and Q_err_lin should be at round-off levels ! compared with the dominant terms, perhaps, dz_Int*I_Ld2*kappa and @@ -1587,23 +1843,23 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & ! been increased to ensure a positive pivot, or 2) negative TKEs have been ! truncated, or 3) small or negative kappas have been rounded toward 0. I_Q = 1.0 / TKE(K) - I_Ld2(K) = (N2(K)*Ilambda2 + f2) * I_Q + I_L2_bdry(K) + I_Ld2(K) = (N2(K)*Ilambda2 + f2) * (Z2_to_L2*I_Q) + I_L2_bdry(K) kap_src = dz_Int(K) * (k_src(K) - I_Ld2(K)*kappa_prev(K)) + & - (Idz(k-1)*(kappa_prev(k-1)-kappa_prev(k)) - & - Idz(k)*(kappa_prev(k)-kappa_prev(k+1))) - K_err_lin = -Idz(k-1)*(dK(K-1)-dK(K)) + Idz(k)*(dK(K)-dK(K+1)) + & + (Idz(k-1)*(kappa_prev(k-1)-kappa_prev(k)) - & + Idz(k)*(kappa_prev(k)-kappa_prev(k+1))) + K_err_lin = -Idz(k-1)*(dK(K-1)-dK(K)) + Idz(k)*(dK(K)-dK(K+1)) + & dz_Int(K)*I_Ld2(K)*dK(K) - kap_src - & - (N2(K)*Ilambda2 + f2)*I_Q**2*kappa_prev(K) * dQ(K) + US%Z_to_m*(N2(K)*Ilambda2 + f2)*I_Q**2*kappa_prev(K) * dQ(K) - tke_src = dz_Int(K) * ((kappa_prev(K) + kappa0)*S2(K) - & - kappa_prev(K)*N2(K) - (TKE_prev(K) - q0)*TKE_decay(K)) - & + tke_src = dz_Int(K) * (Z2_to_L2*(kappa_prev(K) + kappa0)*S2(K) - & + Z2_to_L2*kappa_prev(K)*N2(K) - (TKE_prev(K) - q0)*TKE_decay(K)) - & (aQ(k) * (TKE_prev(K) - TKE_prev(K+1)) - & aQ(k-1) * (TKE_prev(K-1) - TKE_prev(K))) Q_err_lin = (aQ(k-1) * (dQ(K-1)-dQ(K)) - aQ(k) * (dQ(k)-dQ(k+1))) - & 0.5*(TKE_prev(K)-TKE_prev(K+1))*Idz(k) * (dK(K) + dK(K+1)) - & 0.5*(TKE_prev(K)-TKE_prev(K-1))*Idz(k-1)* (dK(K-1) + dK(K)) + & - dz_Int(K) * (dK(K) * (S2(K) - N2(K)) - dQ(K)*TKE_decay(K)) + tke_src + dz_Int(K) * (Z2_to_L2*dK(K) * (S2(K) - N2(K)) - dQ(K)*TKE_decay(K)) + tke_src enddo #endif endif ! End of the Newton's method solver. @@ -1705,8 +1961,7 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & if (present(local_src)) then local_src(1) = 0.0 ; local_src(nz+1) = 0.0 do K=2,nz - diffusive_src = Idz(k-1)*(kappa(K-1)-kappa(K)) + & - Idz(k)*(kappa(K+1)-kappa(K)) + diffusive_src = Idz(k-1)*(kappa(K-1)-kappa(K)) + Idz(k)*(kappa(K+1)-kappa(K)) chg_by_k0 = kappa0 * ((Idz(k-1)+Idz(k)) / dz_Int(K) + I_Ld2(K)) if (diffusive_src <= 0.0) then local_src(K) = k_src(K) + chg_by_k0 @@ -1724,31 +1979,28 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & end subroutine find_kappa_tke - -logical function kappa_shear_init(Time, G, GV, param_file, diag, CS) +!> This subroutineinitializesthe parameters that regulate shear-driven mixing +function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) type(time_type), intent(in) :: Time !< The 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 !< A structure that is used to regulate diagnostic !! output. type(Kappa_shear_CS), pointer :: CS !< A pointer that is set to point to the control !! structure for this module -! Arguments: Time - The current model time. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in) diag - A structure that is used to regulate diagnostic output. -! (in/out) CS - A pointer that is set to point to the control structure -! for this module -! (returns) kappa_shear_init - True if module is to be used, False otherwise + logical :: kappa_shear_init !< True if module is to be used, False otherwise + + ! Local variables logical :: merge_mixedlayer ! This include declares and sets the variable "version". #include "version_variable.h" + character(len=40) :: mdl = "MOM_kappa_shear" ! This module's name. real :: KD_normal ! The KD of the main model, read here only as a parameter ! for setting the default of KD_SMOOTH + if (associated(CS)) then call MOM_error(WARNING, "kappa_shear_init called with an associated "// & "control structure.") @@ -1771,6 +2023,10 @@ logical function kappa_shear_init(Time, G, GV, param_file, diag, CS) call get_param(param_file, mdl, "USE_JACKSON_PARAM", kappa_shear_init, & "If true, use the Jackson-Hallberg-Legg (JPO 2008) \n"//& "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"//& + "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) @@ -1786,7 +2042,8 @@ logical function kappa_shear_init(Time, G, GV, param_file, diag, CS) 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"//& - "diffusivities. Defaults to value of KD.", units="m2 s-1", default=KD_normal) + "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"//& @@ -1836,16 +2093,21 @@ logical function kappa_shear_init(Time, G, GV, param_file, diag, CS) call get_param(param_file, mdl, "PRANDTL_TURB", CS%Prandtl_turb, & "The turbulent Prandtl number applied to shear \n"//& "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"//& + "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"//& "be used in single-column mode!", & default=.false., debuggingParam=.true.) -! id_clock_KQ = cpu_clock_id('Ocean KS kappa_shear',grain=CLOCK_ROUTINE) -! id_clock_avg = cpu_clock_id('Ocean KS avg',grain=CLOCK_ROUTINE) -! id_clock_project = cpu_clock_id('Ocean KS project',grain=CLOCK_ROUTINE) -! id_clock_setup = cpu_clock_id('Ocean KS setup',grain=CLOCK_ROUTINE) +! id_clock_KQ = cpu_clock_id('Ocean KS kappa_shear', grain=CLOCK_ROUTINE) +! id_clock_avg = cpu_clock_id('Ocean KS avg', grain=CLOCK_ROUTINE) +! id_clock_project = cpu_clock_id('Ocean KS project', grain=CLOCK_ROUTINE) +! id_clock_setup = cpu_clock_id('Ocean KS setup', grain=CLOCK_ROUTINE) CS%nkml = 1 if (GV%nkml>0) then @@ -1861,25 +2123,67 @@ logical function kappa_shear_init(Time, G, GV, param_file, diag, CS) CS%diag => diag CS%id_Kd_shear = register_diag_field('ocean_model','Kd_shear',diag%axesTi,Time, & - 'Shear-driven Diapycnal Diffusivity', 'm2 s-1') + 'Shear-driven Diapycnal Diffusivity', 'm2 s-1', conversion=US%Z_to_m**2) CS%id_TKE = register_diag_field('ocean_model','TKE_shear',diag%axesTi,Time, & 'Shear-driven Turbulent Kinetic Energy', 'm2 s-2') #ifdef ADD_DIAGNOSTICS CS%id_ILd2 = register_diag_field('ocean_model','ILd2_shear',diag%axesTi,Time, & - 'Inverse kappa decay scale at interfaces', 'm-2') + 'Inverse kappa decay scale at interfaces', 'm-2', conversion=US%m_to_Z**2) CS%id_dz_Int = register_diag_field('ocean_model','dz_Int_shear',diag%axesTi,Time, & - 'Finite volume thickness of interfaces', 'm') + 'Finite volume thickness of interfaces', 'm', conversion=US%Z_to_m) #endif end function kappa_shear_init +!> This function indicates to other modules whether the Jackson et al shear mixing +!! parameterization will be used without needing to duplicate the log entry. logical function kappa_shear_is_used(param_file) -! Reads the parameter "USE_JACKSON_PARAM" and returns state. -! This function allows other modules to know whether this parameterization will -! be used without needing to duplicate the log entry. type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters +! Reads the parameter "USE_JACKSON_PARAM" and returns state. + character(len=40) :: mdl = "MOM_kappa_shear" ! This module's name. + call get_param(param_file, mdl, "USE_JACKSON_PARAM", kappa_shear_is_used, & - default=.false., do_not_log = .true.) + default=.false., do_not_log=.true.) end function kappa_shear_is_used +!> This function indicates to other modules whether the Jackson et al shear mixing +!! parameterization will be used without needing to duplicate the log entry. +logical function kappa_shear_at_vertex(param_file) + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters +! Reads the parameter "USE_JACKSON_PARAM" and returns state. + character(len=40) :: mdl = "MOM_kappa_shear" ! This module's name. + + logical :: do_kappa_shear + + call get_param(param_file, mdl, "USE_JACKSON_PARAM", do_kappa_shear, & + default=.false., do_not_log=.true.) + 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"//& + "at the cell vertices (i.e., the vorticity points).", & + default=.false., do_not_log=.true.) + +end function kappa_shear_at_vertex + +!> \namespace mom_kappa_shear +!! +!! By Laura Jackson and Robert Hallberg, 2006-2008 +!! +!! This file contains the subroutines that determine the diapycnal +!! diffusivity driven by resolved shears, as specified by the +!! parameterizations described in Jackson and Hallberg (JPO, 2008). +!! +!! The technique by which the 6 equations (for kappa, TKE, u, v, T, +!! and S) are solved simultaneously has been dramatically revised +!! from the previous version. The previous version was not converging +!! in some cases, especially near the surface mixed layer, while the +!! revised version does. The revised version solves for kappa and +!! TKE with shear and stratification fixed, then marches the density +!! and velocities forward with an adaptive (and aggressive) time step +!! in a predictor-corrector-corrector emulation of a trapezoidal +!! scheme. Run-time-settable parameters determine the tolerence to +!! which the kappa and TKE equations are solved and the minimum time +!! step that can be taken. + end module MOM_kappa_shear diff --git a/src/parameterizations/vertical/MOM_opacity.F90 b/src/parameterizations/vertical/MOM_opacity.F90 index 502f05e3e1..e89ded7e13 100644 --- a/src/parameterizations/vertical/MOM_opacity.F90 +++ b/src/parameterizations/vertical/MOM_opacity.F90 @@ -1,43 +1,10 @@ +!> Routines used to calculate the opacity of the ocean. module MOM_opacity ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* This module contains the routines used to calculate the opacity * -!* of the ocean. * -!* * -!* CHL_from_file: * -!* In this routine, the Morel (modified) and Manizza (modified) * -!* schemes use the "blue" band in the paramterizations to determine * -!* the e-folding depth of the incoming shortwave attenuation. The red * -!* portion is lumped into the net heating at the surface. * -!* * -!* Morel, A., 1988: Optical modeling of the upper ocean in relation * -!* to itsbiogenous matter content (case-i waters)., J. Geo. Res., * -!* 93, 10,749-10,768. * -!* * -!* Manizza, M., C. LeQuere, A. J. Watson, and E. T. Buitenhuis, 2005: * -!* Bio-optical feedbacks amoung phytoplankton, upper ocean physics * -!* and sea-ice in a global model, Geophys. Res. Let., 32, L05603, * -!* doi:10.1029/2004GL020778. * -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q * -!* j+1 > o > o > At ^: v * -!* j x ^ x ^ x At >: u * -!* j > o > o > At o: h, buoy, Rml, eaml, ebml, etc. * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** use MOM_diag_mediator, only : time_type, diag_ctrl, safe_alloc_ptr, post_data use MOM_diag_mediator, only : query_averaging_enabled, register_diag_field -use MOM_time_manager, only : get_time use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_string_functions, only : uppercase @@ -55,79 +22,73 @@ module MOM_opacity public set_opacity, opacity_init, opacity_end, opacity_manizza, opacity_morel +!> The control structure with paramters for the MOM_opacity module type, public :: opacity_CS ; private - logical :: var_pen_sw ! If true, use one of the CHL_A schemes - ! (specified below) to determine the e-folding - ! depth of incoming short wave radiation. - ! The default is false. - integer :: opacity_scheme ! An integer indicating which scheme should be - ! used to translate water properties into the - ! opacity (i.e., the e-folding depth) and (perhaps) - ! the number of bands of penetrating shortwave - ! radiation to use. - real :: pen_sw_scale ! The vertical absorption e-folding depth of the - ! penetrating shortwave radiation, in m. - real :: pen_sw_scale_2nd ! The vertical absorption e-folding depth of the - ! (2nd) penetrating shortwave radiation, in m. - real :: SW_1ST_EXP_RATIO ! Ratio for 1st exp decay in Two Exp decay opacity - real :: pen_sw_frac ! The fraction of shortwave radiation that is - ! penetrating with a constant e-folding approach. - real :: blue_frac ! The fraction of the penetrating shortwave - ! radiation that is in the blue band, ND. - real :: opacity_land_value ! The value to use for opacity over land, in m-1. - ! The default is 10 m-1 - a value for muddy water. - integer :: sbc_chl ! An integer handle used in time interpolation of - ! chlorophyll read from a file. - logical :: chl_from_file ! If true, chl_a is read from a file. - type(time_type), pointer :: Time ! A pointer to the ocean model's clock. - type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the - ! timing of diagnostic output. + logical :: var_pen_sw !< If true, use one of the CHL_A schemes (specified below) to + !! determine the e-folding depth of incoming short wave radiation. + !! The default is false. + integer :: opacity_scheme !< An integer indicating which scheme should be used to translate + !! water properties into the opacity (i.e., the e-folding depth) and + !! (perhaps) the number of bands of penetrating shortwave radiation to use. + real :: pen_sw_scale !< The vertical absorption e-folding depth of the + !! penetrating shortwave radiation [m]. + real :: pen_sw_scale_2nd !< The vertical absorption e-folding depth of the + !! (2nd) penetrating shortwave radiation [m]. + real :: SW_1ST_EXP_RATIO !< Ratio for 1st exp decay in Two Exp decay opacity + real :: pen_sw_frac !< The fraction of shortwave radiation that is + !! penetrating with a constant e-folding approach. + real :: blue_frac !< The fraction of the penetrating shortwave + !! radiation that is in the blue band [nondim]. + real :: opacity_land_value !< The value to use for opacity over land [m-1]. + !! The default is 10 m-1 - a value for muddy water. + integer :: sbc_chl !< An integer handle used in time interpolation of + !! chlorophyll read from a file. + logical :: chl_from_file !< If true, chl_a is read from a file. + type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. type(tracer_flow_control_CS), pointer :: tracer_flow_CSp => NULL() - ! A pointer to the control structure of the tracer modules. + !< A pointer to the control structure of the tracer modules. + !>@{ Diagnostic IDs integer :: id_sw_pen = -1, id_sw_vis_pen = -1, id_chl = -1 integer, pointer :: id_opacity(:) => NULL() + !!@} end type opacity_CS -integer, parameter :: NO_SCHEME = 0, MANIZZA_05 = 1, MOREL_88 = 2, & - SINGLE_EXP = 3, DOUBLE_EXP = 4 +!>@{ Coded integers to specify the opacity scheme +integer, parameter :: NO_SCHEME = 0, MANIZZA_05 = 1, MOREL_88 = 2, SINGLE_EXP = 3, DOUBLE_EXP = 4 +!!@} -character*(10), parameter :: MANIZZA_05_STRING = "MANIZZA_05" -character*(10), parameter :: MOREL_88_STRING = "MOREL_88" -character*(10), parameter :: SINGLE_EXP_STRING = "SINGLE_EXP" -character*(10), parameter :: DOUBLE_EXP_STRING = "DOUBLE_EXP" +character*(10), parameter :: MANIZZA_05_STRING = "MANIZZA_05" !< String to specify the opacity scheme +character*(10), parameter :: MOREL_88_STRING = "MOREL_88" !< String to specify the opacity scheme +character*(10), parameter :: SINGLE_EXP_STRING = "SINGLE_EXP" !< String to specify the opacity scheme +character*(10), parameter :: DOUBLE_EXP_STRING = "DOUBLE_EXP" !< String to specify the opacity scheme contains +!> This sets the opacity of sea water based based on one of several different schemes. subroutine set_opacity(optics, fluxes, G, GV, CS) - type(optics_type), intent(inout) :: optics - type(forcing), intent(in) :: fluxes !< A structure containing pointers to any - !! possible forcing fields. Unused fields - !! have NULL ptrs. - 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(opacity_CS), pointer :: CS !< The control structure earlier set up by - !! opacity_init. - -! Arguments: (inout) opacity - The inverse of the vertical absorption decay -! scale for penetrating shortwave radiation, in m-1. -! (inout) fluxes - A structure containing pointers to any possible -! forcing fields. Unused fields have NULL ptrs. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - The control structure earlier set up by opacity_init. + type(optics_type), intent(inout) :: optics !< An optics structure that has values + !! set based on the opacities. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to any + !! possible forcing fields. Unused fields + !! have NULL ptrs. + 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(opacity_CS), pointer :: CS !< The control structure earlier set up by + !! opacity_init. ! local variables integer :: i, j, k, n, is, ie, js, je, nz - real :: inv_sw_pen_scale ! The inverse of the e-folding scale, in m-1. + real :: inv_sw_pen_scale ! The inverse of the e-folding scale [m-1]. real :: Inv_nbands ! The inverse of the number of bands of penetrating ! shortwave radiation. logical :: call_for_surface ! if horizontal slice is the surface layer real :: tmp(SZI_(G),SZJ_(G),SZK_(G)) ! A 3-d temporary array. - real :: chl(SZI_(G),SZJ_(G),SZK_(G)) ! The concentration of chlorophyll-A - ! in mg m-3. + real :: chl(SZI_(G),SZJ_(G),SZK_(G)) ! The concentration of chlorophyll-A [mg m-3]. real :: Pen_SW_tot(SZI_(G),SZJ_(G)) ! The penetrating shortwave radiation - ! summed across all bands, in W m-2. + ! summed across all bands [W m-2]. is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke if (.not. associated(CS)) call MOM_error(FATAL, "set_opacity: "// & @@ -145,49 +106,47 @@ subroutine set_opacity(optics, fluxes, G, GV, CS) else ; Inv_nbands = 1.0 / real(optics%nbands) ; endif ! Make sure there is no division by 0. - inv_sw_pen_scale = 1.0 / max(CS%pen_sw_scale, 0.1*GV%Angstrom_z, & + inv_sw_pen_scale = 1.0 / max(CS%pen_sw_scale, 0.1*GV%Angstrom_m, & GV%H_to_m*GV%H_subroundoff) -!$OMP parallel default(none) shared(is,ie,js,je,nz,optics,inv_sw_pen_scale,fluxes,CS,Inv_nbands,GV) if ( CS%Opacity_scheme == DOUBLE_EXP ) then -!$OMP do + !$OMP parallel do default(shared) do k=1,nz ; do j=js,je ; do i=is,ie optics%opacity_band(1,i,j,k) = inv_sw_pen_scale optics%opacity_band(2,i,j,k) = 1.0 / max(CS%pen_sw_scale_2nd, & - 0.1*GV%Angstrom_z,GV%H_to_m*GV%H_subroundoff) + 0.1*GV%Angstrom_m,GV%H_to_m*GV%H_subroundoff) enddo ; enddo ; enddo if (.not.associated(fluxes%sw) .or. (CS%pen_SW_scale <= 0.0)) then -!$OMP do + !$OMP parallel do default(shared) do j=js,je ; do i=is,ie ; do n=1,optics%nbands optics%sw_pen_band(n,i,j) = 0.0 enddo ; enddo ; enddo else -!$OMP do - do j=js,je ; do i=is,ie ; + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie optics%sw_pen_band(1,i,j) = (CS%SW_1st_EXP_RATIO) * fluxes%sw(i,j) optics%sw_pen_band(2,i,j) = (1.-CS%SW_1st_EXP_RATIO) * fluxes%sw(i,j) - enddo ; enddo ; + enddo ; enddo endif else do k=1,nz ; do j=js,je ; do i=is,ie ; do n=1,optics%nbands optics%opacity_band(n,i,j,k) = inv_sw_pen_scale enddo ; enddo ; enddo ; enddo if (.not.associated(fluxes%sw) .or. (CS%pen_SW_scale <= 0.0)) then -!$OMP do + !$OMP parallel do default(shared) do j=js,je ; do i=is,ie ; do n=1,optics%nbands optics%sw_pen_band(n,i,j) = 0.0 enddo ; enddo ; enddo else -!$OMP do + !$OMP parallel do default(shared) do j=js,je ; do i=is,ie ; do n=1,optics%nbands optics%sw_pen_band(n,i,j) = CS%pen_SW_frac * Inv_nbands * fluxes%sw(i,j) enddo ; enddo ; enddo endif endif -!$OMP end parallel endif if (query_averaging_enabled(CS%diag)) then if (CS%id_sw_pen > 0) then -!$OMP parallel do default(none) shared(is,ie,js,je,Pen_SW_tot,optics) + !$OMP parallel do default(shared) do j=js,je ; do i=is,ie Pen_SW_tot(i,j) = 0.0 do n=1,optics%nbands @@ -198,7 +157,7 @@ subroutine set_opacity(optics, fluxes, G, GV, CS) endif if (CS%id_sw_vis_pen > 0) then if (CS%opacity_scheme == MANIZZA_05) then -!$OMP parallel do default(none) shared(is,ie,js,je,Pen_SW_tot,optics) + !$OMP parallel do default(shared) do j=js,je ; do i=is,ie Pen_SW_tot(i,j) = 0.0 do n=1,min(optics%nbands,2) @@ -206,7 +165,7 @@ subroutine set_opacity(optics, fluxes, G, GV, CS) enddo enddo ; enddo else -!$OMP parallel do default(none) shared(is,ie,js,je,Pen_SW_tot,optics) + !$OMP parallel do default(shared) do j=js,je ; do i=is,ie Pen_SW_tot(i,j) = 0.0 do n=1,optics%nbands @@ -217,7 +176,7 @@ subroutine set_opacity(optics, fluxes, G, GV, CS) call post_data(CS%id_sw_vis_pen, Pen_SW_tot, CS%diag) endif do n=1,optics%nbands ; if (CS%id_opacity(n) > 0) then -!$OMP parallel do default(none) shared(nz,is,ie,js,je,tmp,optics,n) + !$OMP parallel do default(shared) do k=1,nz ; do j=js,je ; do i=is,ie tmp(i,j,k) = optics%opacity_band(n,i,j,k) enddo ; enddo ; enddo @@ -228,45 +187,40 @@ subroutine set_opacity(optics, fluxes, G, GV, CS) end subroutine set_opacity +!> This sets the "blue" band opacity based on chloophyll A concencentrations +!! The red portion is lumped into the net heating at the surface. subroutine opacity_from_chl(optics, fluxes, G, CS, chl_in) - type(optics_type), intent(inout) :: optics - type(forcing), intent(in) :: fluxes !< A structure containing pointers to any - !! possible forcing fields. Unused fields - !! have NULL ptrs. - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(opacity_CS), pointer :: CS !< The control structure. + type(optics_type), intent(inout) :: optics !< An optics structure that has values + !! set based on the opacities. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to any + !! possible forcing fields. Unused fields + !! have NULL ptrs. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(opacity_CS), pointer :: CS !< The control structure. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in), optional :: chl_in !< A 3-d field of chlorophyll A, - !! in mg m-3. -! Arguments: fluxes - A structure containing pointers to any possible -! forcing fields. Unused fields have NULL ptrs. -! (out) opacity - The inverse of the vertical absorption decay -! scale for penetrating shortwave radiation, in m-1. -! (in) G - The ocean's grid structure. -! (in) chl_in - A 3-d field of chlorophyll A, in mg m-3. + optional, intent(in) :: chl_in !< A 3-d field of chlorophyll A, + !! in mg m-3. - real :: chl_data(SZI_(G),SZJ_(G)) ! The chlorophyll A concentrations in - ! a layer, in mg/m^3. + real :: chl_data(SZI_(G),SZJ_(G)) ! The chlorophyll A concentrations in a layer [mg m-3]. real :: Inv_nbands ! The inverse of the number of bands of penetrating ! shortwave radiation. real :: Inv_nbands_nir ! The inverse of the number of bands of penetrating ! near-infrafed radiation. real :: SW_pen_tot ! The sum across the bands of the penetrating - ! shortwave radiation, in W m-2. + ! shortwave radiation [W m-2]. real :: SW_vis_tot ! The sum across the visible bands of shortwave - ! radiation, in W m-2. + ! radiation [W m-2]. real :: SW_nir_tot ! The sum across the near infrared bands of shortwave - ! radiation, in W m-2. + ! radiation [W m-2]. type(time_type) :: day character(len=128) :: mesg - integer :: days, seconds integer :: i, j, k, n, is, ie, js, je, nz, nbands logical :: multiband_vis_input, multiband_nir_input is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke ! In this model, the Morel (modified) and Manizza (modified) schemes -! use the "blue" band in the paramterizations to determine the e-folding +! use the "blue" band in the parameterizations to determine the e-folding ! depth of the incoming shortwave attenuation. The red portion is lumped ! into the net heating at the surface. ! @@ -292,7 +246,7 @@ subroutine opacity_from_chl(optics, fluxes, G, CS, chl_in) associated(fluxes%sw_nir_dif)) chl_data(:,:) = 0.0 - if(present(chl_in)) then + if (present(chl_in)) then do j=js,je ; do i=is,ie ; chl_data(i,j) = chl_in(i,j,1) ; enddo ; enddo do k=1,nz; do j=js,je ; do i=is,ie if ((G%mask2dT(i,j) > 0.5) .and. (chl_in(i,j,k) < 0.0)) then @@ -301,11 +255,10 @@ subroutine opacity_from_chl(optics, fluxes, G, CS, chl_in) chl_in(i,j,k), i, j, k, G%geoLonT(i,j), G%geoLatT(i,j) call MOM_error(FATAL,"MOM_opacity opacity_from_chl: "//trim(mesg)) endif - enddo; enddo; enddo + enddo ; enddo ; enddo else ! Only the 2-d surface chlorophyll can be read in from a file. The ! same value is assumed for all layers. - call get_time(CS%Time,seconds,days) call time_interp_external(CS%sbc_chl, CS%Time, chl_data) do j=js,je ; do i=is,ie if ((G%mask2dT(i,j) > 0.5) .and. (chl_data(i,j) < 0.0)) then @@ -318,7 +271,7 @@ subroutine opacity_from_chl(optics, fluxes, G, CS, chl_in) endif if (CS%id_chl > 0) then - if(present(chl_in)) then + if (present(chl_in)) then call post_data(CS%id_chl, chl_in(:,:,1), CS%diag) else call post_data(CS%id_chl, chl_data, CS%diag) @@ -374,7 +327,7 @@ subroutine opacity_from_chl(optics, fluxes, G, CS, chl_in) enddo enddo ; enddo case default - call MOM_error(FATAL, "opacity_from_chl: CS%opacity_scheme is not valid.") + call MOM_error(FATAL, "opacity_from_chl: CS%opacity_scheme is not valid.") end select !$OMP parallel do default(none) shared(nz,is,ie,js,je,CS,G,chl_in,optics,nbands) & @@ -419,8 +372,10 @@ subroutine opacity_from_chl(optics, fluxes, G, CS, chl_in) end subroutine opacity_from_chl +!> This sets the blue-wavelength opacity according to the scheme proposed by +!! Morel and Antoine (1994). function opacity_morel(chl_data) - real, intent(in) :: chl_data + real, intent(in) :: chl_data !< The chlorophyll-A concentration in mg m-3. real :: opacity_morel ! Argument : chl_data - The chlorophyll-A concentration in mg m-3. ! The following are coefficients for the optical model taken from Morel and @@ -437,8 +392,10 @@ function opacity_morel(chl_data) ((Z2_coef(3) + Chl*Z2_coef(4)) + Chl2*(Z2_coef(5) + Chl*Z2_coef(6))) ) end function +!> This sets the penetrating shortwave fraction according to the scheme proposed by +!! Morel and Antoine (1994). function SW_pen_frac_morel(chl_data) - real, intent(in) :: chl_data + real, intent(in) :: chl_data !< The chlorophyll-A concentration in mg m-3. real :: SW_pen_frac_morel ! Argument : chl_data - The chlorophyll-A concentration in mg m-3. ! The following are coefficients for the optical model taken from Morel and @@ -455,8 +412,10 @@ function SW_pen_frac_morel(chl_data) ((V1_coef(3) + Chl*V1_coef(4)) + Chl2*(V1_coef(5) + Chl*V1_coef(6))) ) end function SW_pen_frac_morel +!> This sets the blue-wavelength opacity according to the scheme proposed by +!! Manizza, M. et al, 2005. function opacity_manizza(chl_data) - real, intent(in) :: chl_data + real, intent(in) :: chl_data !< The chlorophyll-A concentration in mg m-3. real :: opacity_manizza ! Argument : chl_data - The chlorophyll-A concentration in mg m-3. ! This sets the blue-wavelength opacity according to the scheme proposed by @@ -473,10 +432,12 @@ subroutine opacity_init(Time, G, param_file, diag, tracer_flow, CS, optics) type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to regulate diagnostic !! output. type(tracer_flow_control_CS), & - target, intent(in) :: tracer_flow + target, intent(in) :: tracer_flow !< A pointer to the tracer flow control + !! module's control structure type(opacity_CS), pointer :: CS !< A pointer that is set to point to the control !! structure for this module. - type(optics_type), pointer :: optics + type(optics_type), pointer :: optics !< An optics structure that has parameters + !! set and arrays allocated here. ! Arguments: Time - The current model time. ! (in) G - The ocean's grid structure. ! (in) param_file - A structure indicating the open file to parse for @@ -614,12 +575,12 @@ subroutine opacity_init(Time, G, param_file, diag, tracer_flow, CS, optics) "The number of bands of penetrating shortwave radiation.", & default=1) if (CS%Opacity_scheme == DOUBLE_EXP ) then - if (optics%nbands.ne.2) then + if (optics%nbands /= 2) then call MOM_error(FATAL, "set_opacity: "// & "Cannot use a double_exp opacity scheme with nbands!=2.") endif elseif (CS%Opacity_scheme == SINGLE_EXP ) then - if (optics%nbands.ne.1) then + if (optics%nbands /= 1) then call MOM_error(FATAL, "set_opacity: "// & "Cannot use a single_exp opacity scheme with nbands!=1.") endif @@ -674,8 +635,8 @@ end subroutine opacity_init subroutine opacity_end(CS, optics) - type(opacity_CS), pointer :: CS - type(optics_type), pointer, optional :: optics + type(opacity_CS), pointer :: CS !< An opacity control structure that should be deallocated. + type(optics_type), optional, pointer :: optics !< An optics type structure that should be deallocated. if (associated(CS%id_opacity)) deallocate(CS%id_opacity) if (associated(CS)) deallocate(CS) @@ -687,4 +648,21 @@ subroutine opacity_end(CS, optics) end subroutine opacity_end +!> \namespace mom_opacity +!! +!! CHL_from_file: +!! In this routine, the Morel (modified) and Manizza (modified) +!! schemes use the "blue" band in the paramterizations to determine +!! the e-folding depth of the incoming shortwave attenuation. The red +!! portion is lumped into the net heating at the surface. +!! +!! Morel, A., 1988: Optical modeling of the upper ocean in relation +!! to itsbiogenous matter content (case-i waters)., J. Geo. Res., +!! 93, 10,749-10,768. +!! +!! Manizza, M., C. LeQuere, A. J. Watson, and E. T. Buitenhuis, 2005: +!! Bio-optical feedbacks amoung phytoplankton, upper ocean physics +!! and sea-ice in a global model, Geophys. Res. Let., 32, L05603, +!! doi:10.1029/2004GL020778. + end module MOM_opacity diff --git a/src/parameterizations/vertical/MOM_regularize_layers.F90 b/src/parameterizations/vertical/MOM_regularize_layers.F90 index b4b21d9e6b..989b2f0154 100644 --- a/src/parameterizations/vertical/MOM_regularize_layers.F90 +++ b/src/parameterizations/vertical/MOM_regularize_layers.F90 @@ -1,36 +1,8 @@ +!> Provides regularization of layers in isopycnal mode module MOM_regularize_layers ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Robert Hallberg and Alistair Adcroft, 2011. * -!* * -!* This file contains the code to do vertical remapping of mass, * -!* temperature and salinity in MOM. Other tracers and the horizontal * -!* velocity components will be remapped outside of this subroutine * -!* using the values that are stored in ea and eb. * -!* The code that is here now only applies in very limited cases * -!* where the mixed- and buffer-layer structures are problematic, but * -!* future additions will include the ability to emulate arbitrary * -!* vertical coordinates. * -!* * -!* Macros written all in capital letters are defined in MOM_memory.h. * -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q * -!* j+1 > o > o > At ^: v * -!* j x ^ x ^ x At >: u * -!* j > o > o > At o: h, T, S, ea, eb, etc. * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** - use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : time_type, diag_ctrl @@ -49,34 +21,38 @@ module MOM_regularize_layers public regularize_layers, regularize_layers_init +!> This control structure holds parameters used by the MOM_regularize_layers module type, public :: regularize_layers_CS ; private - logical :: regularize_surface_layers ! If true, vertically restructure the - ! near-surface layers when they have too much - ! lateral variations to allow for sensible lateral - ! barotropic transports. - logical :: reg_sfc_detrain - real :: h_def_tol1 ! The value of the relative thickness deficit at - ! which to start modifying the structure, 0.5 by - ! default (or a thickness ratio of 5.83). - real :: h_def_tol2 ! The value of the relative thickness deficit at - ! which to the structure modification is in full - ! force, now 20% of the way from h_def_tol1 to 1. - real :: h_def_tol3 ! The values of the relative thickness defitic at - real :: h_def_tol4 ! which to start detrainment from the buffer layers - ! to the interior, and at which to do this at full - ! intensity. Now 30% and 50% of the way from - ! h_def_tol1 to 1. - real :: Hmix_min ! The minimum mixed layer thickness in m. - type(time_type), pointer :: Time ! A pointer to the ocean model's clock. - type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the - ! timing of diagnostic output. - logical :: debug ! If true, do more thorough checks for debugging purposes. - - integer :: id_def_rat = -1 - logical :: 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. + logical :: regularize_surface_layers !< If true, vertically restructure the + !! near-surface layers when they have too much + !! lateral variations to allow for sensible lateral + !! barotropic transports. + logical :: reg_sfc_detrain !< If true, allow the buffer layers to detrain into the + !! interior as a part of the restructuring when + !! regularize_surface_layers is true + real :: h_def_tol1 !< The value of the relative thickness deficit at + !! which to start modifying the structure, 0.5 by + !! default (or a thickness ratio of 5.83). + real :: h_def_tol2 !< The value of the relative thickness deficit at + !! which to the structure modification is in full + !! force, now 20% of the way from h_def_tol1 to 1. + real :: h_def_tol3 !< The value of the relative thickness deficit at which to start + !! detrainment from the buffer layers to the interior, now 30% of + !! the way from h_def_tol1 to 1. + real :: h_def_tol4 !< The value of the relative thickness deficit at which to do + !! detrainment from the buffer layers to the interior at full + !! force, now 50% of the way from h_def_tol1 to 1. + real :: Hmix_min !< The minimum mixed layer thickness [H ~> m or kg m-2]. + type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + logical :: debug !< If true, do more thorough checks for debugging purposes. + + integer :: id_def_rat = -1 !< A diagnostic ID + logical :: 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. #ifdef DEBUG_CODE + !>@{ Diagnostic IDs integer :: id_def_rat_2 = -1, id_def_rat_3 = -1 integer :: id_def_rat_u = -1, id_def_rat_v = -1 integer :: id_e1 = -1, id_e2 = -1, id_e3 = -1 @@ -85,10 +61,14 @@ module MOM_regularize_layers integer :: id_def_rat_v_2 = -1, id_def_rat_v_2b = -1 integer :: id_def_rat_u_3 = -1, id_def_rat_u_3b = -1 integer :: id_def_rat_v_3 = -1, id_def_rat_v_3b = -1 + !!@} #endif end type regularize_layers_CS +!>@{ Clock IDs +!! \todo Should these be global? integer :: id_clock_pass, id_clock_EOS +!!@} contains @@ -98,43 +78,22 @@ subroutine regularize_layers(h, tv, dt, ea, eb, 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(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]. type(thermo_var_ptrs), intent(inout) :: tv !< A structure containing pointers to any !! available thermodynamic fields. Absent fields !! have NULL ptrs. - real, intent(in) :: dt !< Time increment, in s. + real, intent(in) :: dt !< Time increment [s]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(inout) :: ea !< The amount of fluid moved downward into a !! layer; this should be increased due to mixed - !! layer detrainment, in the same units as - !! h - usually m or kg m-2 (i.e., H). + !! layer detrainment [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(inout) :: eb !< The amount of fluid moved upward into a layer; + intent(inout) :: eb !< The amount of fluid moved upward into a layer !! this should be increased due to mixed layer - !! entrainment, in the same units as h - usually - !! m or kg m-2 (i.e., H). + !! entrainment [H ~> m or kg m-2]. type(regularize_layers_CS), pointer :: CS !< The control structure returned by a previous !! call to regularize_layers_init. - -! This subroutine partially steps the bulk mixed layer model. -! The following processes are executed, in the order listed. - -! Arguments: h - Layer thickness, in m or kg m-2. (Intent in/out) -! The units of h are referred to as H below. -! (in/out) tv - A structure containing pointers to any available -! thermodynamic fields. Absent fields have NULL ptrs. -! (in) dt - Time increment, in s. -! (in/out) ea - The amount of fluid moved downward into a layer; this should -! be increased due to mixed layer detrainment, in the same units -! as h - usually m or kg m-2 (i.e., H). -! (in/out) eb - The amount of fluid moved upward into a layer; this should -! be increased due to mixed layer entrainment, in the same units -! as h - usually m or kg m-2 (i.e., H). -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - The control structure returned by a previous call to -! regularize_layers_init. - + ! Local variables integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -157,51 +116,30 @@ subroutine regularize_surface(h, tv, dt, ea, eb, 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(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]. type(thermo_var_ptrs), intent(inout) :: tv !< A structure containing pointers to any !! available thermodynamic fields. Absent fields !! have NULL ptrs. - real, intent(in) :: dt !< Time increment, in s. + real, intent(in) :: dt !< Time increment [s]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(inout) :: ea !< The amount of fluid moved downward into a !! layer; this should be increased due to mixed - !! layer detrainment, in the same units as h - - !! usually m or kg m-2 (i.e., H). + !! layer detrainment [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(inout) :: eb !< The amount of fluid moved upward into a layer; + intent(inout) :: eb !< The amount of fluid moved upward into a layer !! this should be increased due to mixed layer - !! entrainment, in the same units as h - usually - !! m or kg m-2 (i.e., H). + !! entrainment [H ~> m or kg m-2]. type(regularize_layers_CS), pointer :: CS !< The control structure returned by a previous !! call to regularize_layers_init. - -! This subroutine ensures that there is a degree of horizontal smoothness -! in the depths of the near-surface interfaces. - -! Arguments: h - Layer thickness, in m or kg m-2. (Intent in/out) -! The units of h are referred to as H below. -! (in/out) tv - A structure containing pointers to any available -! thermodynamic fields. Absent fields have NULL ptrs. -! (in) dt - Time increment, in s. -! (in/out) ea - The amount of fluid moved downward into a layer; this should -! be increased due to mixed layer detrainment, in the same units -! as h - usually m or kg m-2 (i.e., H). -! (in/out) eb - The amount of fluid moved upward into a layer; this should -! be increased due to mixed layer entrainment, in the same units -! as h - usually m or kg m-2 (i.e., H). -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - The control structure returned by a previous call to -! regularize_layers_init. - + ! Local variables real, dimension(SZIB_(G),SZJ_(G)) :: & - def_rat_u ! The ratio of the thickness deficit to the minimum depth, ND. + def_rat_u ! The ratio of the thickness deficit to the minimum depth [nondim]. real, dimension(SZI_(G),SZJB_(G)) :: & - def_rat_v ! The ratio of the thickness deficit to the minimum depth, ND. + def_rat_v ! The ratio of the thickness deficit to the minimum depth [nondim]. real, dimension(SZI_(G),SZJ_(G)) :: & - def_rat_h ! The ratio of the thickness deficit to the minimum depth, ND. + def_rat_h ! The ratio of the thickness deficit to the minimum depth [nondim]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: & - e ! The interface depths, in H, positive upward. + e ! The interface depths [H ~> m or kg m-2], positive upward. #ifdef DEBUG_CODE real, dimension(SZIB_(G),SZJ_(G)) :: & @@ -211,51 +149,51 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, CS) real, dimension(SZI_(G),SZJB_(G)) :: & def_rat_h2, def_rat_h3 real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: & - ef ! The filtered interface depths, in H, positive upward. + ef ! The filtered interface depths [H ~> m or kg m-2], positive upward. #endif real, dimension(SZI_(G),SZK_(G)+1) :: & - e_filt, e_2d ! The interface depths, in H, positive upward. + e_filt, e_2d ! The interface depths [H ~> m or kg m-2], positive upward. real, dimension(SZI_(G),SZK_(G)) :: & - h_2d, & ! A 2-d version of h, in H. - T_2d, & ! A 2-d version of tv%T, in deg C. - S_2d, & ! A 2-d version of tv%S, in PSU. - Rcv, & ! A 2-d version of the coordinate density, in kg m-3. - h_2d_init, & ! The initial value of h_2d, in H. - T_2d_init, & ! THe initial value of T_2d, in deg C. - S_2d_init, & ! The initial value of S_2d, in PSU. + h_2d, & ! A 2-d version of h [H ~> m or kg m-2]. + T_2d, & ! A 2-d version of tv%T [degC]. + S_2d, & ! A 2-d version of tv%S [ppt]. + Rcv, & ! A 2-d version of the coordinate density [kg m-3]. + h_2d_init, & ! The initial value of h_2d [H ~> m or kg m-2]. + T_2d_init, & ! THe initial value of T_2d [degC]. + S_2d_init, & ! The initial value of S_2d [ppt]. d_eb, & ! The downward increase across a layer in the entrainment from - ! below, in H. The sign convention is that positive values of + ! below [H ~> m or kg m-2]. The sign convention is that positive values of ! d_eb correspond to a gain in mass by a layer by upward motion. d_ea ! The upward increase across a layer in the entrainment from - ! above, in H. The sign convention is that positive values of + ! above [H ~> m or kg m-2]. The sign convention is that positive values of ! d_ea mean a net gain in mass by a layer from downward motion. real, dimension(SZI_(G)) :: & p_ref_cv, & ! Reference pressure for the potential density which defines - ! the coordinate variable, set to P_Ref, in Pa. + ! the coordinate variable, set to P_Ref [Pa]. Rcv_tol, & ! A tolerence, relative to the target density differences - ! between layers, for detraining into the interior, ND. + ! between layers, for detraining into the interior [nondim]. h_add_tgt, h_add_tot, & h_tot1, Th_tot1, Sh_tot1, & h_tot3, Th_tot3, Sh_tot3, & h_tot2, Th_tot2, Sh_tot2 real, dimension(SZK_(G)) :: & - h_prev_1d ! The previous thicknesses, in H. - real :: I_dtol ! The inverse of the tolerance changes, nondim. - real :: I_dtol34 ! The inverse of the tolerance changes, nondim. - real :: h1, h2 ! Temporary thicknesses, in H. - real :: e_e, e_w, e_n, e_s ! Temporary interface heights, in H. - real :: wt ! The weight of the filted interfaces in setting the targets, ND. - real :: scale ! A scaling factor, ND. + h_prev_1d ! The previous thicknesses [H ~> m or kg m-2]. + real :: I_dtol ! The inverse of the tolerance changes [nondim]. + real :: I_dtol34 ! The inverse of the tolerance changes [nondim]. + real :: h1, h2 ! Temporary thicknesses [H ~> m or kg m-2]. + real :: e_e, e_w, e_n, e_s ! Temporary interface heights [H ~> m or kg m-2]. + real :: wt ! The weight of the filted interfaces in setting the targets [nondim]. + real :: scale ! A scaling factor [nondim]. real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected, in H. + ! in roundoff and can be neglected [H ~> m or kg m-2]. real, dimension(SZK_(G)+1) :: & int_flux, int_Tflux, int_Sflux, int_Rflux real :: h_add real :: h_det_tot real :: max_def_rat real :: Rcv_min_det ! The lightest (min) and densest (max) coordinate density - real :: Rcv_max_det ! that can detrain into a layer, in kg m-3. + real :: Rcv_max_det ! that can detrain into a layer [kg m-3]. real :: int_top, int_bot real :: h_predicted @@ -395,20 +333,20 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, CS) do K=1,nz_filt ; do i=is,ie ; if (do_i(i)) then if (G%mask2dCu(I,j) <= 0.0) then ; e_e = e(i,j,K) ; else e_e = max(e(i+1,j,K) + min(e(i,j,K) - e(i+1,j,nz+1), 0.0), & - e(i,j,nz+1) + (nz+1-k)*GV%Angstrom) + e(i,j,nz+1) + (nz+1-k)*GV%Angstrom_H) endif if (G%mask2dCu(I-1,j) <= 0.0) then ; e_w = e(i,j,K) ; else e_w = max(e(i-1,j,K) + min(e(i,j,K) - e(i-1,j,nz+1), 0.0), & - e(i,j,nz+1) + (nz+1-k)*GV%Angstrom) + e(i,j,nz+1) + (nz+1-k)*GV%Angstrom_H) endif if (G%mask2dCv(i,J) <= 0.0) then ; e_n = e(i,j,K) ; else e_n = max(e(i,j+1,K) + min(e(i,j,K) - e(i,j+1,nz+1), 0.0), & - e(i,j,nz+1) + (nz+1-k)*GV%Angstrom) + e(i,j,nz+1) + (nz+1-k)*GV%Angstrom_H) endif if (G%mask2dCv(i,J-1) <= 0.0) then ; e_s = e(i,j,K) ; else e_s = max(e(i,j-1,K) + min(e(i,j,K) - e(i,j-1,nz+1), 0.0), & - e(i,j,nz+1) + (nz+1-k)*GV%Angstrom) + e(i,j,nz+1) + (nz+1-k)*GV%Angstrom_H) endif wt = max(0.0, min(1.0, I_dtol*(def_rat_h(i,j)-CS%h_def_tol1))) @@ -444,10 +382,10 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, CS) do k=nkmb+1,nz cols_left = .false. do i=is,ie ; if (more_ent_i(i)) then - if (h_2d(i,k) - GV%Angstrom > h_neglect) then - if (e_2d(i,nkmb+1)-e_filt(i,nkmb+1) > h_2d(i,k) - GV%Angstrom) then - h_add = h_2d(i,k) - GV%Angstrom - h_2d(i,k) = GV%Angstrom + if (h_2d(i,k) - GV%Angstrom_H > h_neglect) then + if (e_2d(i,nkmb+1)-e_filt(i,nkmb+1) > h_2d(i,k) - GV%Angstrom_H) then + h_add = h_2d(i,k) - GV%Angstrom_H + h_2d(i,k) = GV%Angstrom_H else h_add = e_2d(i,nkmb+1)-e_filt(i,nkmb+1) h_2d(i,k) = h_2d(i,k) - h_add @@ -702,7 +640,7 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, CS) h_predicted = h_2d_init(i,k) + ((d_ea(i,k) - d_eb(i,k-1)) + & (d_eb(i,k) - d_ea(i,k+1))) endif - if (abs(h(i,j,k) - h_predicted) > MAX(1e-9*abs(h_predicted),GV%Angstrom)) & + if (abs(h(i,j,k) - h_predicted) > MAX(1e-9*abs(h_predicted),GV%Angstrom_H)) & call MOM_error(FATAL, "regularize_surface: d_ea mismatch.") endif ; enddo ; enddo do i=is,ie ; if (do_i(i)) then @@ -785,62 +723,43 @@ subroutine find_deficit_ratios(e, def_rat_u, def_rat_v, G, GV, 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. real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & - intent(in) :: e !< Interface depths, in m or kg m-2. + intent(in) :: e !< Interface depths [H ~> m or kg m-2] real, dimension(SZIB_(G),SZJ_(G)), & intent(out) :: def_rat_u !< The thickness deficit ratio at u points, - !! nondim. + !! [nondim]. real, dimension(SZI_(G),SZJB_(G)), & intent(out) :: def_rat_v !< The thickness deficit ratio at v points, - !! nondim. + !! [nondim]. type(regularize_layers_CS), pointer :: CS !< The control structure returned by a !! previous call to regularize_layers_init. real, dimension(SZIB_(G),SZJ_(G)), & optional, intent(out) :: def_rat_u_2lay !< The thickness deficit ratio at u !! points when the mixed and buffer layers - !! are aggregated into 1 layer, nondim. + !! are aggregated into 1 layer [nondim]. real, dimension(SZI_(G),SZJB_(G)), & optional, intent(out) :: def_rat_v_2lay !< The thickness deficit ratio at v !! pointswhen the mixed and buffer layers - !! are aggregated into 1 layer, nondim. + !! are aggregated into 1 layer [nondim]. integer, optional, intent(in) :: halo !< An extra-wide halo size, 0 by default. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - optional, intent(in) :: h !< Layer thicknesses, in H (usually m or kg - !! m-2); if h is not present, vertical - !! differences in interface heights are used - !! instead. - -! This subroutine determines the amount by which the harmonic mean -! thickness at velocity points differ from the arithmetic means, relative to -! the the arithmetic means, after eliminating thickness variations that are -! solely due to topography and aggregating all interior layers into one. - -! Arguments: e - Interface depths, in m or kg m-2. -! (out) def_rat_u - The thickness deficit ratio at u points, nondim. -! (out) def_rat_v - The thickness deficit ratio at v points, nondim. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - The control structure returned by a previous call to -! regularize_layers_init. -! (out,opt) def_rat_u_2lay - The thickness deficit ratio at u points when the -! mixed and buffer layers are aggregated into 1 layer, nondim. -! (out,opt) def_rat_v_2lay - The thickness deficit ratio at v pointswhen the -! mixed and buffer layers are aggregated into 1 layer, nondim. -! (in,opt) halo - An extra-wide halo size, 0 by default. -! (in,opt) h - The layer thicknesse; if not present take vertical differences of e. + optional, intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + !! If h is not present, vertical differences + !! in interface heights are used instead. + ! Local variables real, dimension(SZIB_(G),SZJ_(G)) :: & - h_def_u, & ! The vertically summed thickness deficits at u-points, in H. + h_def_u, & ! The vertically summed thickness deficits at u-points [H ~> m or kg m-2]. h_norm_u, & ! The vertically summed arithmetic mean thickness by which - ! h_def_u is normalized, in H. + ! h_def_u is normalized [H ~> m or kg m-2]. h_def2_u real, dimension(SZI_(G),SZJB_(G)) :: & - h_def_v, & ! The vertically summed thickness deficits at v-points, in H. + h_def_v, & ! The vertically summed thickness deficits at v-points [H ~> m or kg m-2]. h_norm_v, & ! The vertically summed arithmetic mean thickness by which - ! h_def_v is normalized, in H. + ! h_def_v is normalized [H ~> m or kg m-2]. h_def2_v real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected, in H. - real :: Hmix_min ! CS%Hmix_min converted to units of H. - real :: h1, h2 ! Temporary thicknesses, in H. + ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: Hmix_min ! A local copy of CS%Hmix_min [H ~> m or kg m-2]. + real :: h1, h2 ! Temporary thicknesses [H ~> m or kg m-2]. integer :: i, j, k, is, ie, js, je, nz, nkmb is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -849,7 +768,7 @@ subroutine find_deficit_ratios(e, def_rat_u, def_rat_v, G, GV, CS, & endif nkmb = GV%nk_rho_varies h_neglect = GV%H_subroundoff - Hmix_min = CS%Hmix_min * GV%m_to_H + Hmix_min = CS%Hmix_min ! Determine which zonal faces are problematic. do j=js,je ; do I=is-1,ie @@ -951,23 +870,17 @@ subroutine find_deficit_ratios(e, def_rat_u, def_rat_v, G, GV, CS, & end subroutine find_deficit_ratios -subroutine regularize_layers_init(Time, G, param_file, diag, CS) +!> Initializes the regularize_layers control structure +subroutine regularize_layers_init(Time, G, GV, param_file, 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. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(param_file_type), intent(in) :: param_file !< A structure to parse for !! run-time parameters. type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to regulate !! diagnostic output. type(regularize_layers_CS), pointer :: CS !< A pointer that is set to point to the !! control structure for this module. -! Arguments: Time - The current model time. -! (in) G - The ocean's grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in) diag - A structure that is used to regulate diagnostic output. -! (in/out) CS - A pointer that is set to point to the control structure -! for this module -! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "MOM_regularize_layers" ! This module's name. logical :: use_temperature @@ -999,7 +912,7 @@ subroutine regularize_layers_init(Time, G, param_file, diag, CS) call get_param(param_file, mdl, "HMIX_MIN", CS%Hmix_min, & "The minimum mixed layer depth if the mixed layer depth \n"//& - "is determined dynamically.", units="m", default=0.0) + "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"//& @@ -1062,7 +975,7 @@ subroutine regularize_layers_init(Time, G, param_file, diag, CS) Time, 'V-point filtered 2-layer thickness deficit ratio', 'nondim') #endif - if(CS%allow_clocks_in_omp_loops) then + if (CS%allow_clocks_in_omp_loops) then id_clock_EOS = cpu_clock_id('(Ocean regularize_layers EOS)', grain=CLOCK_ROUTINE) endif id_clock_pass = cpu_clock_id('(Ocean regularize_layers halo updates)', grain=CLOCK_ROUTINE) diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 6b1c219508..e4214c8d16 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -1,3 +1,4 @@ +!> Calculate vertical diffusivity from all mixing processes module MOM_set_diffusivity ! This file is part of MOM6. See LICENSE.md for the license. @@ -7,13 +8,14 @@ module MOM_set_diffusivity 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 +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 use MOM_error_handler, only : callTree_showQuery use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing, optics_type +use MOM_full_convection, only : full_convection use MOM_grid, only : ocean_grid_type use MOM_internal_tides, only : int_tide_CS, get_lowmode_loss use MOM_tidal_mixing, only : tidal_mixing_CS, calculate_tidal_mixing @@ -21,18 +23,21 @@ module MOM_set_diffusivity use MOM_intrinsic_functions, only : invcosh use MOM_io, only : slasher, vardesc, var_desc, 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 use MOM_CVMix_shear, only : CVMix_shear_end +use MOM_CVMix_ddiff, only : CVMix_ddiff_init, CVMix_ddiff_end, CVMix_ddiff_cs +use MOM_CVMix_ddiff, only : compute_ddiff_coeffs use MOM_bkgnd_mixing, only : calculate_bkgnd_mixing, bkgnd_mixing_init, bkgnd_mixing_cs use MOM_bkgnd_mixing, only : bkgnd_mixing_end, sfc_bkgnd_mixing use MOM_string_functions, only : uppercase use MOM_thickness_diffuse, only : vert_fill_TS +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs, vertvisc_type, p3d use MOM_verticalGrid, only : verticalGrid_type use user_change_diffusivity, only : user_change_diff, user_change_diff_init use user_change_diffusivity, only : user_change_diff_end, user_change_diff_CS - implicit none ; private #include @@ -42,210 +47,222 @@ module MOM_set_diffusivity public set_diffusivity_init public set_diffusivity_end +! 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. + +!> This control structure contains parameters for MOM_set_diffusivity. type, public :: set_diffusivity_CS ; private - logical :: debug ! If true, write verbose checksums for debugging. - - logical :: bulkmixedlayer ! If true, a refined bulk mixed layer is used with - ! GV%nk_rho_varies variable density mixed & buffer - ! layers. - real :: FluxRi_max ! 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). The default is 0.2. - logical :: bottomdraglaw ! If true, the bottom stress is calculated with a - ! drag law c_drag*|u|*u. - logical :: BBL_mixing_as_max ! If true, take the maximum of the diffusivity - ! from the BBL mixing and the other diffusivities. - ! Otherwise, diffusivities from the BBL_mixing is - ! added. - logical :: use_LOTW_BBL_diffusivity ! If true, use simpler/less precise, BBL diffusivity. - logical :: LOTW_BBL_use_omega ! If true, use simpler/less precise, BBL diffusivity. - real :: BBL_effic ! efficiency with which the energy extracted - ! by bottom drag drives BBL diffusion (nondim) - real :: cdrag ! quadratic drag coefficient (nondim) - real :: IMax_decay ! inverse of a maximum decay scale for - ! bottom-drag driven turbulence, (1/m) - - real :: Kd ! interior diapycnal diffusivity (m2/s) - real :: Kd_min ! minimum diapycnal diffusivity (m2/s) - real :: Kd_max ! maximum increment for diapycnal diffusivity (m2/s) - ! Set to a negative value to have no limit. - real :: Kd_add ! uniform diffusivity added everywhere without - ! filtering or scaling (m2/s) - real :: Kv ! interior vertical viscosity (m2/s) - real :: Kdml ! mixed layer diapycnal diffusivity (m2/s) - ! when bulkmixedlayer==.false. - real :: Hmix ! mixed layer thickness (meter) when - ! bulkmixedlayer==.false. - type(diag_ctrl), pointer :: diag ! structure to regulate diagn output timing - - logical :: limit_dissipation ! If enabled, dissipation is limited to be larger - ! than the following: - real :: dissip_min ! Minimum dissipation (W/m3) - real :: dissip_N0 ! Coefficient a in minimum dissipation = a+b*N (W/m3) - real :: dissip_N1 ! Coefficient b in minimum dissipation = a+b*N (J/m3) - real :: dissip_N2 ! Coefficient c in minimum dissipation = c*N2 (W m-3 s2) - real :: dissip_Kd_min ! Minimum Kd (m2/s) with dissipatio 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) - 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 - ! 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 - ! calculated the same way as in the mixed layer code. - ! The diapycnal diffusivity is KD(k) = E/(N2(k)+OMEGA2), - ! 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 (m2/s) - 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 - ! mixed layer base (nondimensional) - logical :: ML_rad_TKE_decay ! If true, apply same exponential decay - ! 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 (m/s). 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 - ! TKE input to the mixed layer (nondim) - logical :: ML_use_omega ! If true, use absolute rotation rate instead - ! of the vertical component of rotation when - ! setting the decay scale for mixed layer turbulence. - real :: ML_omega_frac ! When setting the decay scale for turbulence, use - ! this fraction of the absolute rotation rate blended - ! with the local value of f, as f^2 ~= (1-of)*f^2 + of*4*omega^2. - logical :: user_change_diff ! If true, call user-defined code to change diffusivity. - logical :: useKappaShear ! If true, use the kappa_shear module to find the - ! shear-driven diapycnal diffusivity. - logical :: use_CVMix_shear ! If true, use one of the CVMix modules to find - ! shear-driven diapycnal diffusivity. - logical :: double_diffusion ! If true, enable double-diffusive mixing. - 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 (m2/s) - real :: Kv_molecular ! molecular visc for double diff convect (m2/s) - - character(len=200) :: inputdir - type(user_change_diff_CS), pointer :: user_change_diff_CSp => NULL() - type(diag_to_Z_CS), pointer :: diag_to_Z_CSp => NULL() - type(Kappa_shear_CS), pointer :: kappaShear_CSp => NULL() - type(CVMix_shear_cs), pointer :: CVMix_shear_csp => NULL() - type(bkgnd_mixing_cs), pointer :: bkgnd_mixing_csp => NULL() - type(int_tide_CS), pointer :: int_tide_CSp => NULL() - type(tidal_mixing_cs), pointer :: tm_csp => NULL() - - integer :: id_maxTKE = -1 - integer :: id_TKE_to_Kd = -1 - - integer :: id_Kd_user = -1 - integer :: id_Kd_layer = -1 - integer :: id_Kd_BBL = -1 - integer :: id_Kd_BBL_z = -1 - integer :: id_Kd_user_z = -1 - integer :: id_Kd_Work = -1 - - integer :: id_N2 = -1 - integer :: id_N2_z = -1 - - integer :: id_KT_extra = -1 - integer :: id_KS_extra = -1 - integer :: id_KT_extra_z = -1 - integer :: id_KS_extra_z = -1 + logical :: debug !< If true, write verbose checksums for debugging. + + logical :: bulkmixedlayer !< If true, a refined bulk mixed layer is used with + !! GV%nk_rho_varies variable density mixed & buffer layers. + real :: FluxRi_max !< 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). The default is 0.2. + logical :: bottomdraglaw !< If true, the bottom stress is calculated with a + !! drag law c_drag*|u|*u. + logical :: BBL_mixing_as_max !< If true, take the maximum of the diffusivity + !! from the BBL mixing and the other diffusivities. + !! Otherwise, diffusivities from the BBL_mixing is + !! added. + logical :: use_LOTW_BBL_diffusivity !< If true, use simpler/less precise, BBL diffusivity. + logical :: LOTW_BBL_use_omega !< If true, use simpler/less precise, BBL diffusivity. + real :: BBL_effic !< efficiency with which the energy extracted + !! by bottom drag drives BBL diffusion [nondim] + 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]. + !! 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]. + !! 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 :: TKE_itide_max !< maximum internal tide conversion [W m-2] + !! available to mix above the BBL + real :: omega !< Earth's rotation frequency [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 + !! 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 + !! calculated the same way as in the mixed layer code. + !! The diapycnal diffusivity is KD(k) = E/(N2(k)+OMEGA2), + !! 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]. + 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 + !! mixed layer base [nondim] + logical :: ML_rad_TKE_decay !< If true, apply same exponential decay + !! 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, + !! 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 + !! TKE input to the mixed layer [nondim] + logical :: ML_use_omega !< If true, use absolute rotation rate instead + !! of the vertical component of rotation when + !! setting the decay scale for mixed layer turbulence. + real :: ML_omega_frac !< When setting the decay scale for turbulence, use + !! this fraction of the absolute rotation rate blended + !! with the local value of f, as f^2 ~= (1-of)*f^2 + of*4*omega^2. + logical :: user_change_diff !< If true, call user-defined code to change diffusivity. + logical :: useKappaShear !< If true, use the kappa_shear module to find the + !! shear-driven diapycnal diffusivity. + logical :: Vertex_Shear !< If true, do the calculations of the shear-driven mixing + !! at the cell vertices (i.e., the vorticity points). + logical :: use_CVMix_shear !< If true, use one of the CVMix modules to find + !! shear-driven diapycnal diffusivity. + logical :: double_diffusion !< If true, enable double-diffusive mixing using an old method. + logical :: use_CVMix_ddiff !< If true, enable double-diffusive mixing via CVMix. + 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] + + 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 + type(bkgnd_mixing_cs), pointer :: bkgnd_mixing_csp => NULL() !< Control structure for a child module + type(int_tide_CS), pointer :: int_tide_CSp => NULL() !< Control structure for a child module + type(tidal_mixing_cs), pointer :: tm_csp => NULL() !< Control structure for a child module + + !>@{ 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_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 +!> 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 (1/s2) - Kd_user => NULL(),& ! user-added diffusivity at interfaces (m2/s) - Kd_BBL => NULL(),& ! BBL diffusivity at interfaces (m2/s) - Kd_work => NULL(),& ! layer integrated work by diapycnal mixing (W/m2) - maxTKE => NULL(),& ! energy required to entrain to h_max (m3/s3) - TKE_to_Kd => NULL(),& ! 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 - KT_extra => NULL(),& ! double diffusion diffusivity for temp (m2/s) - KS_extra => NULL() ! double diffusion diffusivity for saln (m2/s) + 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]. + 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] end type diffusivity_diags -! Clocks -integer :: id_clock_kappaShear +!>@{ CPU time clocks +integer :: id_clock_kappaShear, id_clock_CVMix_ddiff +!!@} contains +!> Sets the interior vertical diffusion of scalars due to the following processes: +!! 1. Shear-driven mixing: two options, Jackson et at. and KPP interior; +!! 2. Background mixing via CVMix (Bryan-Lewis profile) or the scheme described by +!! Harrison & Hallberg, JPO 2008; +!! 3. Double-diffusion, old method and new method via CVMix; +!! 4. Tidal mixing: many options available, see MOM_tidal_mixing.F90; +!! In addition, this subroutine has the option to set the interior vertical +!! viscosity associated with processes 1,2 and 4 listed above, which is stored in +!! visc%Kv_slow. Vertical viscosity due to shear-driven mixing is passed via +!! visc%Kv_shear subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & - G, GV, CS, Kd, Kd_int) + G, GV, US, CS, Kd_lay, Kd_int) 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 real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & - intent(in) :: u !< The zonal velocity, in m s-1. + intent(in) :: u !< The zonal velocity [m s-1]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & - intent(in) :: v !< The meridional velocity, in m s-1. + intent(in) :: v !< The meridional velocity [m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2). + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: u_h + intent(in) :: u_h !< Zonal velocity interpolated to h points [m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: v_h + intent(in) :: v_h !< Meridional velocity interpolated to h points [m s-1]. type(thermo_var_ptrs), intent(inout) :: tv !< Structure with pointers to thermodynamic !! fields. Out is for tv%TempxPmE. - type(forcing), intent(in) :: fluxes !< Structure of surface fluxes that may be - !! used. - type(optics_type), pointer :: optics - type(vertvisc_type), intent(inout) :: visc !< Structure containing vertical viscosities, - !! bottom boundary layer properies, and related - !! fields. - real, intent(in) :: dt !< Time increment (sec). + type(forcing), intent(in) :: fluxes !< A structure of thermodynamic surface fluxes + type(optics_type), pointer :: optics !< A structure describing the optical + !! properties of the ocean. + type(vertvisc_type), intent(inout) :: visc !< Structure containing vertical viscosities, bottom + !! boundary layer properies, and related fields. + 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 !< Diapycnal diffusivity of each layer (m2/sec). + intent(out) :: Kd_lay !< Diapycnal diffusivity of each layer [Z2 s-1 ~> m2 s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & - optional, intent(out) :: Kd_int !< Diapycnal diffusivity at each interface - !! (m2/sec). + optional, intent(out) :: Kd_int !< Diapycnal diffusivity at each interface [Z2 s-1 ~> m2 s-1]. ! local variables real, dimension(SZI_(G)) :: & - N2_bot ! bottom squared buoyancy frequency (1/s2) + N2_bot ! bottom squared buoyancy frequency [s-2] type(diffusivity_diags) :: dd ! structure w/ arrays of pointers to avail diags real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & - T_f, S_f ! temperature and salinity (deg C and ppt); + T_f, S_f ! Temperature and salinity [degC] and [ppt] with ! massless layers filled vertically by diffusion. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & + T_adj, S_adj ! Temperature and salinity [degC] and [ppt] + ! after full convective adjustment. real, dimension(SZI_(G),SZK_(G)) :: & - N2_lay, & ! squared buoyancy frequency associated with layers (1/s2) - maxTKE, & ! energy required to entrain to h_max (m3/s3) - 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. + N2_lay, & !< squared buoyancy frequency associated with layers [s-2] + maxTKE, & !< energy required to entrain to h_max [m3 s-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]. real, dimension(SZI_(G),SZK_(G)+1) :: & - N2_int, & ! squared buoyancy frequency associated at interfaces (1/s2) - dRho_int, & ! locally ref potential density difference across interfaces (in s-2) smg: or kg/m3? - KT_extra, & ! double difusion diffusivity on temperature (m2/sec) - KS_extra ! double difusion diffusivity on salinity (m2/sec) + N2_int, & !< squared buoyancy frequency associated at interfaces [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] - real :: I_Rho0 ! inverse of Boussinesq density (m3/kg) - real :: dissip ! local variable for dissipation calculations (W/m3) - real :: Omega2 ! squared absolute rotation rate (1/s2) + 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] 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. + ! 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. @@ -265,16 +282,22 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & "Module must be initialized before it is used.") I_Rho0 = 1.0/GV%Rho0 - kappa_fill = 1.e-3 ! m2 s-1 - dt_fill = 7200. + 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 use_EOS = associated(tv%eqn_of_state) - if ((CS%double_diffusion) .and. & - .not.(associated(visc%Kd_extra_T) .and. associated(visc%Kd_extra_S)) ) & - call MOM_error(FATAL, "set_diffusivity: visc%Kd_extra_T and "//& - "visc%Kd_extra_S must be associated when DOUBLE_DIFFUSION is true.") + if ((CS%use_CVMix_ddiff .or. CS%double_diffusion) .and. .not. & + (associated(visc%Kd_extra_T) .and. associated(visc%Kd_extra_S))) & + call MOM_error(FATAL, "set_diffusivity: both visc%Kd_extra_T and "//& + "visc%Kd_extra_S must be associated when USE_CVMIX_DDIFF or DOUBLE_DIFFUSION are true.") + + ! Set Kd_lay, Kd_int and Kv_slow to constant values. + ! 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 ! Set up arrays for diagnostics. @@ -327,71 +350,82 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & call hchksum(v_h, "before calc_KS v_h",G%HI) endif call cpu_clock_begin(id_clock_kappaShear) - ! Changes: visc%Kd_shear, visc%TKE_turb (not clear that TKE_turb is used as input ????) - ! Sets visc%Kv_shear - call calculate_kappa_shear(u_h, v_h, h, tv, fluxes%p_surf, visc%Kd_shear, visc%TKE_turb, & - visc%Kv_shear, dt, G, GV, CS%kappaShear_CSp) - call cpu_clock_end(id_clock_kappaShear) - if (CS%debug) then - call hchksum(visc%Kd_shear, "after calc_KS visc%Kd_shear",G%HI) - call hchksum(visc%Kv_shear, "after calc_KS visc%Kv_shear",G%HI) - call hchksum(visc%TKE_turb, "after calc_KS visc%TKE_turb",G%HI) + 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) + + 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) + if (associated(visc%Kv_shear)) visc%Kv_shear(:,:,:) = 0.0 ! needed for other parameterizations + if (CS%debug) then + call hchksum(visc%Kd_shear, "after calc_KS_vert visc%Kd_shear", G%HI, scale=US%Z_to_m**2) + call Bchksum(visc%Kv_shear_Bu, "after calc_KS_vert visc%Kv_shear_Bu", G%HI, scale=US%Z_to_m**2) + call Bchksum(visc%TKE_turb, "after calc_KS_vert visc%TKE_turb", G%HI) + endif + else + ! Changes: visc%Kd_shear, visc%TKE_turb (not clear that TKE_turb is used as input ????) + ! Sets visc%Kv_shear + call calculate_kappa_shear(u_h, v_h, h, tv, fluxes%p_surf, visc%Kd_shear, visc%TKE_turb, & + visc%Kv_shear, dt, G, GV, US, CS%kappaShear_CSp) + if (CS%debug) then + call hchksum(visc%Kd_shear, "after calc_KS visc%Kd_shear", G%HI, scale=US%Z_to_m**2) + call hchksum(visc%Kv_shear, "after calc_KS visc%Kv_shear", G%HI, scale=US%Z_to_m**2) + call hchksum(visc%TKE_turb, "after calc_KS visc%TKE_turb", G%HI) + endif endif + call cpu_clock_end(id_clock_kappaShear) if (showCallTree) call callTree_waypoint("done with calculate_kappa_shear (set_diffusivity)") elseif (CS%use_CVMix_shear) then !NOTE{BGR}: this needs to be cleaned up. It works in 1D case, but has not been tested outside. - call calculate_CVMix_shear(u_h, v_h, h, tv, visc%Kd_shear, visc%Kv_shear,G,GV,CS%CVMix_shear_csp) + call calculate_CVMix_shear(u_h, v_h, h, tv, visc%Kd_shear, visc%Kv_shear, G, GV, US, CS%CVMix_shear_CSp) + if (CS%debug) then + call hchksum(visc%Kd_shear, "after CVMix_shear visc%Kd_shear", G%HI, scale=US%Z_to_m**2) + call hchksum(visc%Kv_shear, "after CVMix_shear visc%Kv_shear", G%HI, scale=US%Z_to_m**2) + endif elseif (associated(visc%Kv_shear)) then - visc%Kv_shear(:,:,:) = 0. ! needed if calculate_kappa_shear is not enabled + visc%Kv_shear(:,:,:) = 0.0 ! needed if calculate_kappa_shear is not enabled endif - ! Calculate the diffusivity, Kd, for each layer. This would be + ! Calculate the diffusivity, Kd_lay, for each layer. This would be ! the appropriate place to add a depth-dependent parameterization or ! another explicit parameterization of Kd. ! set surface diffusivities (CS%bkgnd_mixing_csp%Kd_sfc) - call sfc_bkgnd_mixing(G, CS%bkgnd_mixing_csp) - -! GMM, fix OMP calls below + call sfc_bkgnd_mixing(G, US, CS%bkgnd_mixing_csp) -!$OMP parallel do default(none) shared(is,ie,js,je,nz,G,GV,CS,h,tv,T_f,S_f,fluxes,dd, & -!$OMP Kd,visc, & -!$OMP Kd_int,dt,u,v,Omega2) & -!$OMP private(dRho_int, & -!$OMP N2_lay, N2_int, N2_bot, & -!$OMP KT_extra, KS_extra, & -!$OMP TKE_to_Kd,maxTKE,dissip,kb) + !$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) do j=js,je ! Set up variables related to the stratification. - call find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, CS, dRho_int, N2_lay, N2_int, N2_bot) + call find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, N2_lay, N2_int, N2_bot) if (associated(dd%N2_3d)) then do K=1,nz+1 ; do i=is,ie ; dd%N2_3d(i,j,K) = N2_int(i,K) ; enddo ; enddo endif - ! add background mixing - call calculate_bkgnd_mixing(h, tv, N2_lay, Kd, visc%Kv_slow, j, G, GV, CS%bkgnd_mixing_csp) + ! Add background mixing + call calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay, visc%Kv_slow, j, G, GV, US, CS%bkgnd_mixing_csp) - ! GMM, the following will go into the MOM_CVMix_double_diffusion module + ! Double-diffusion (old method) if (CS%double_diffusion) then - call double_diffusion(tv, h, T_f, S_f, j, G, GV, CS, KT_extra, KS_extra) + 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(i,j,k-1) = Kd(i,j,k-1) + 0.5*KT_extra(i,K) - Kd(i,j,k) = Kd(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) = (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(i,j,k-1) = Kd(i,j,k-1) + 0.5*KS_extra(i,K) - Kd(i,j,k) = Kd(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) = (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 visc%Kd_extra_S(i,j,k) = 0.0 endif - enddo; enddo + enddo ; enddo if (associated(dd%KT_extra)) then ; do K=1,nz+1 ; do i=is,ie dd%KT_extra(i,j,K) = KT_extra(i,K) enddo ; enddo ; endif @@ -401,11 +435,19 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & enddo ; enddo ; endif endif + ! Apply double diffusion via CVMix + ! GMM, we need to pass HBL to compute_ddiff_coeffs, but it is not yet available. + if (CS%use_CVMix_ddiff) then + call cpu_clock_begin(id_clock_CVMix_ddiff) + call compute_ddiff_coeffs(h, tv, G, GV, US, j, visc%Kd_extra_T, visc%Kd_extra_S, CS%CVMix_ddiff_csp) + call cpu_clock_end(id_clock_CVMix_ddiff) + endif + ! Add the input turbulent diffusivity. 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(i,j,k-1) + Kd(i,j,k)) + Kd_int(i,j,K) = 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. @@ -413,20 +455,20 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & enddo endif do k=1,nz ; do i=is,ie - Kd(i,j,k) = Kd(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*(visc%Kd_shear(i,j,K) + visc%Kd_shear(i,j,K+1)) enddo ; enddo else if (present(Kd_int)) then do i=is,ie - Kd_int(i,j,1) = Kd(i,j,1) ; Kd_int(i,j,nz+1) = 0.0 + 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(i,j,k-1) + Kd(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, CS, TKE_to_Kd, & + call find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, 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) @@ -437,114 +479,123 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & ! Add the ML_Rad diffusivity. if (CS%ML_radiation) & - call add_MLrad_diffusivity(h, fluxes, j, G, GV, CS, Kd, TKE_to_Kd, Kd_int) + call add_MLrad_diffusivity(h, fluxes, j, G, GV, US, CS, Kd_lay, TKE_to_Kd, Kd_int) ! Add the Nikurashin and / or tidal bottom-driven mixing - call calculate_tidal_mixing(h, N2_bot, j, TKE_to_Kd, maxTKE, G, GV, CS%tm_csp, & - N2_lay, N2_int, Kd, Kd_int, CS%Kd_max) + call calculate_tidal_mixing(h, N2_bot, j, TKE_to_Kd, maxTKE, G, GV, US, CS%tm_csp, & + N2_lay, N2_int, Kd_lay, Kd_int, CS%Kd_max, visc%Kv_slow) ! This adds the diffusion sustained by the energy extracted from the flow ! by the bottom drag. if (CS%bottomdraglaw .and. (CS%BBL_effic>0.0)) then if (CS%use_LOTW_BBL_diffusivity) then - call add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, G, GV, CS, & - Kd, Kd_int, dd%Kd_BBL) + call add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, G, GV, US, CS, & + Kd_lay, Kd_int, dd%Kd_BBL) else call add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & - maxTKE, kb, G, GV, CS, Kd, Kd_int, dd%Kd_BBL) + maxTKE, kb, G, GV, US, CS, Kd_lay, Kd_int, dd%Kd_BBL) endif endif if (CS%limit_dissipation) then - do k=2,nz-1 ; do i=is,ie ! This calculates the dissipation ONLY from Kd calculated in this routine - ! dissip has units of W/m3 (kg/m3 * m2/s * 1/s2 = J/s/m3) + ! dissip has units of W/m3 (= kg/m3 * m2/s * 1/s2) ! 1) a global constant, ! 2) a dissipation proportional to N (aka Gargett) and ! 3) dissipation corresponding to a (nearly) constant diffusivity. + 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(i,j,k) = max( Kd(i,j,k) , & ! Apply floor to Kd - dissip * (CS%FluxRi_max / (GV%Rho0 * (N2_lay(i,k) + Omega2))) ) + 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 - ! This calculates the dissipation ONLY from Kd calculated in this routine - ! dissip has units of W/m3 (kg/m3 * m2/s * 1/s2 = J/s/m3) - ! 1) a global constant, - ! 2) a dissipation proportional to N (aka Gargett) and - ! 3) dissipation corresponding to a (nearly) constant diffusivity. 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))) ) + 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 * Kd(i,j,k) * N2_lay(i,k) * & - GV%H_to_m*h(i,j,k) ! Watt m-2 s or kg s-3 + dd%Kd_Work(i,j,k) = GV%Rho0 * US%Z_to_m**3*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 ,"Kd",G%HI,haloshift=0) + call hchksum(Kd_lay ,"Kd_lay", G%HI, haloshift=0, scale=US%Z_to_m**2) + + if (CS%useKappaShear) call hchksum(visc%Kd_shear, "Turbulent Kd", G%HI, haloshift=0, scale=US%Z_to_m**2) - if (CS%useKappaShear) call hchksum(visc%Kd_shear,"Turbulent Kd",G%HI,haloshift=0) + if (CS%use_CVMix_ddiff) then + call hchksum(visc%Kd_extra_T, "MOM_set_diffusivity: Kd_extra_T", G%HI, haloshift=0, scale=US%Z_to_m**2) + call hchksum(visc%Kd_extra_S, "MOM_set_diffusivity: Kd_extra_S", G%HI, haloshift=0, scale=US%Z_to_m**2) + endif if (associated(visc%kv_bbl_u) .and. associated(visc%kv_bbl_v)) then call uvchksum("BBL Kv_bbl_[uv]", visc%kv_bbl_u, visc%kv_bbl_v, & - G%HI, 0, symmetric=.true.) + G%HI, 0, symmetric=.true., scale=US%Z_to_m**2) endif if (associated(visc%bbl_thick_u) .and. associated(visc%bbl_thick_v)) then call uvchksum("BBL bbl_thick_[uv]", visc%bbl_thick_u, & - visc%bbl_thick_v, G%HI, 0, symmetric=.true.) + visc%bbl_thick_v, G%HI, 0, symmetric=.true., scale=US%Z_to_m) endif if (associated(visc%Ray_u) .and. associated(visc%Ray_v)) then - call uvchksum("Ray_[uv]", visc%Ray_u, visc%Ray_v, G%HI, 0, symmetric=.true.) + call uvchksum("Ray_[uv]", visc%Ray_u, visc%Ray_v, G%HI, 0, symmetric=.true., scale=US%Z_to_m) endif endif - ! send bkgnd_mixing diagnostics to post_data - if (CS%bkgnd_mixing_csp%id_kd_bkgnd > 0) & - call post_data(CS%bkgnd_mixing_csp%id_kd_bkgnd, CS%bkgnd_mixing_csp%kd_bkgnd, CS%bkgnd_mixing_csp%diag) - if (CS%bkgnd_mixing_csp%id_kv_bkgnd > 0) & - call post_data(CS%bkgnd_mixing_csp%id_kv_bkgnd, CS%bkgnd_mixing_csp%kv_bkgnd, CS%bkgnd_mixing_csp%diag) - if (CS%Kd_add > 0.0) then if (present(Kd_int)) then -!$OMP parallel do default(none) shared(is,ie,js,je,nz,Kd_int,CS,Kd) + !$OMP parallel do default(shared) do k=1,nz ; do j=js,je ; do i=is,ie Kd_int(i,j,K) = Kd_int(i,j,K) + CS%Kd_add - Kd(i,j,k) = Kd(i,j,k) + CS%Kd_add + Kd_lay(i,j,k) = Kd_lay(i,j,k) + CS%Kd_add enddo ; enddo ; enddo else -!$OMP parallel do default(none) shared(is,ie,js,je,nz,CS,Kd) + !$OMP parallel do default(shared) do k=1,nz ; do j=js,je ; do i=is,ie - Kd(i,j,k) = Kd(i,j,k) + CS%Kd_add + Kd_lay(i,j,k) = Kd_lay(i,j,k) + CS%Kd_add enddo ; enddo ; enddo endif endif if (CS%user_change_diff) then - call user_change_diff(h, tv, G, CS%user_change_diff_CSp, Kd, Kd_int, & + call user_change_diff(h, tv, G, GV, CS%user_change_diff_CSp, Kd_lay, Kd_int, & T_f, S_f, dd%Kd_user) endif - ! GMM, post diags... - if (CS%id_Kd_layer > 0) call post_data(CS%id_Kd_layer, Kd, CS%diag) + ! post diagnostics - num_z_diags = 0 + ! background mixing + if (CS%bkgnd_mixing_csp%id_kd_bkgnd > 0) & + call post_data(CS%bkgnd_mixing_csp%id_kd_bkgnd, CS%bkgnd_mixing_csp%kd_bkgnd, CS%bkgnd_mixing_csp%diag) + if (CS%bkgnd_mixing_csp%id_kv_bkgnd > 0) & + call post_data(CS%bkgnd_mixing_csp%id_kv_bkgnd, CS%bkgnd_mixing_csp%kv_bkgnd, CS%bkgnd_mixing_csp%diag) + + ! double diffusive mixing + if (CS%CVMix_ddiff_csp%id_KT_extra > 0) & + call post_data(CS%CVMix_ddiff_csp%id_KT_extra, visc%Kd_extra_T, CS%CVMix_ddiff_csp%diag) + if (CS%CVMix_ddiff_csp%id_KS_extra > 0) & + call post_data(CS%CVMix_ddiff_csp%id_KS_extra, visc%Kd_extra_S, CS%CVMix_ddiff_csp%diag) + if (CS%CVMix_ddiff_csp%id_R_rho > 0) & + call post_data(CS%CVMix_ddiff_csp%id_R_rho, CS%CVMix_ddiff_csp%R_rho, CS%CVMix_ddiff_csp%diag) + + if (CS%id_Kd_layer > 0) call post_data(CS%id_Kd_layer, Kd_lay, CS%diag) + ! 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 @@ -573,21 +624,21 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & 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 + 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 + 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%KS_extra + 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) & @@ -606,51 +657,64 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & end subroutine set_diffusivity -subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, CS, & +!> Convert turbulent kinetic energy to diffusivity +subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & TKE_to_Kd, maxTKE, kb) - 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 !< Layer thicknesses, in H (usually m or kg m-2) - type(thermo_var_ptrs), intent(in) :: tv - real, dimension(SZI_(G),SZK_(G)+1), intent(in) :: dRho_int - real, dimension(SZI_(G),SZK_(G)), intent(in) :: N2_lay - integer, intent(in) :: j - real, intent(in) :: dt - type(set_diffusivity_CS), pointer :: CS - real, dimension(SZI_(G),SZK_(G)), intent(out) :: TKE_to_Kd, maxTKE - integer, dimension(SZI_(G)), intent(out) :: kb - + 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 + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any available + !! thermodynamic fields. + 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]. + integer, intent(in) :: j !< j-index of row to work on + real, intent(in) :: dt !< Time increment [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 + !! 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] + 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] + 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 real, dimension(SZI_(G),SZK_(G)) :: & ds_dsp1, & ! coordinate variable (sigma-2) difference across an ! interface divided by the difference across the interface - ! below it (nondimensional) + ! below it [nondim] dsp1_ds, & ! inverse coordinate variable (sigma-2) difference ! across an interface times the difference across the - ! interface above it (nondimensional) - rho_0, & ! Layer potential densities relative to surface pressure (kg/m3) + ! interface above it [nondim] + rho_0, & ! Layer potential densities relative to surface pressure [kg m-3] maxEnt ! maxEnt is the maximum value of entrainment from below (with ! compensating entrainment from above to keep the layer ! density from changing) that will not deplete all of the - ! layers above or below a layer within a timestep (meter) + ! layers above or below a layer within a timestep [Z ~> m]. real, dimension(SZI_(G)) :: & htot, & ! total thickness above or below a layer, or the - ! integrated thickness in the BBL (meter) + ! integrated thickness in the BBL [Z ~> m]. mFkb, & ! total thickness in the mixed and buffer layers - ! times ds_dsp1 (meter) + ! times ds_dsp1 [Z ~> m]. p_ref, & ! array of tv%P_Ref pressures Rcv_kmb, & ! coordinate density in the lowest buffer layer p_0 ! An array of 0 pressures real :: dh_max ! maximum amount of entrainment a layer could ! undergo before entraining all fluid in the layers - ! above or below (meter) - real :: dRho_lay ! density change across a layer (kg/m3) - real :: Omega2 ! rotation rate squared (1/s2) - real :: G_Rho0 ! gravitation accel divided by Bouss ref density (m4 s-2 kg-1) - real :: I_Rho0 ! inverse of Boussinesq reference density (m3/kg) - real :: I_dt ! 1/dt (1/sec) - real :: H_neglect ! negligibly small thickness (units as h) - real :: hN2pO2 ! h * (N^2 + Omega^2), in m s-2. + ! 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 :: I_Rho0 ! inverse of Boussinesq reference density [m3 kg-1] + real :: I_dt ! 1/dt [s-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]. logical :: do_i(SZI_(G)) integer :: i, k, is, ie, nz, i_rem, kmb, kb_min @@ -658,16 +722,16 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, CS, & I_dt = 1.0/dt Omega2 = CS%Omega**2 - G_Rho0 = GV%g_Earth / GV%Rho0 + G_Rho0 = (GV%g_Earth*US%m_to_Z**2) / GV%Rho0 H_neglect = GV%H_subroundoff I_Rho0 = 1.0/GV%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 = ( GV%H_to_m * h(i,j,k) ) * ( N2_lay(i,k) + Omega2 ) ! Units of m s-2. + 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. if (hN2pO2>0.) then - TKE_to_Kd(i,k) = 1./ hN2pO2 ! Units of s2 m-1. + TKE_to_Kd(i,k) = 1.0 / hN2pO2 ! Units of Z2 s2 m-3. 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. @@ -682,11 +746,11 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, CS, & kmb = GV%nk_rho_varies do i=is,ie ; p_0(i) = 0.0 ; p_ref(i) = tv%P_Ref ; enddo do k=1,nz - call calculate_density(tv%T(:,j,k),tv%S(:,j,k),p_0,rho_0(:,k),& - is,ie-is+1,tv%eqn_of_state) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_0, rho_0(:,k), & + is, ie-is+1, tv%eqn_of_state) enddo - call calculate_density(tv%T(:,j,kmb),tv%S(:,j,kmb),p_ref,Rcv_kmb,& - is,ie-is+1,tv%eqn_of_state) + call calculate_density(tv%T(:,j,kmb), tv%S(:,j,kmb), p_ref, Rcv_kmb, & + is, ie-is+1, tv%eqn_of_state) kb_min = kmb+1 do i=is,ie @@ -699,7 +763,7 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, CS, & ! in sigma-0. do k=kb(i)-1,kmb+1,-1 if (rho_0(i,kmb) > rho_0(i,k)) exit - if (h(i,j,k)>2.0*GV%Angstrom) kb(i) = k + if (h(i,j,k)>2.0*GV%Angstrom_H) kb(i) = k enddo enddo @@ -720,32 +784,32 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, CS, & if (CS%bulkmixedlayer) then kmb = GV%nk_rho_varies do i=is,ie - htot(i) = GV%H_to_m*h(i,j,kmb) + htot(i) = GV%H_to_Z*h(i,j,kmb) mFkb(i) = 0.0 if (kb(i) < nz) & - mFkb(i) = ds_dsp1(i,kb(i)) * (GV%H_to_m*(h(i,j,kmb) - GV%Angstrom)) + mFkb(i) = ds_dsp1(i,kb(i)) * (GV%H_to_Z*(h(i,j,kmb) - GV%Angstrom_H)) enddo do k=1,kmb-1 ; do i=is,ie - htot(i) = htot(i) + GV%H_to_m*h(i,j,k) - mFkb(i) = mFkb(i) + ds_dsp1(i,k+1)*(GV%H_to_m*(h(i,j,k) - GV%Angstrom)) + htot(i) = htot(i) + GV%H_to_Z*h(i,j,k) + mFkb(i) = mFkb(i) + ds_dsp1(i,k+1)*(GV%H_to_Z*(h(i,j,k) - GV%Angstrom_H)) enddo ; enddo else do i=is,i - maxEnt(i,1) = 0.0 ; htot(i) = GV%H_to_m*(h(i,j,1) - GV%Angstrom) + maxEnt(i,1) = 0.0 ; htot(i) = GV%H_to_Z*(h(i,j,1) - GV%Angstrom_H) enddo endif do k=kb_min,nz-1 ; do i=is,ie if (k == kb(i)) then - maxEnt(i,kb(i))= mFkb(i) + maxEnt(i,kb(i)) = mFkb(i) elseif (k > kb(i)) then maxEnt(i,k) = (1.0/dsp1_ds(i,k))*(maxEnt(i,k-1) + htot(i)) ! maxEnt(i,k) = ds_dsp1(i,k)*(maxEnt(i,k-1) + htot(i)) ! BITWISE CHG - htot(i) = htot(i) + GV%H_to_m*(h(i,j,k) - GV%Angstrom) + htot(i) = htot(i) + GV%H_to_Z*(h(i,j,k) - GV%Angstrom_H) endif enddo ; enddo do i=is,ie - htot(i) = GV%H_to_m*(h(i,j,nz) - GV%Angstrom) ; maxEnt(i,nz) = 0.0 + htot(i) = GV%H_to_Z*(h(i,j,nz) - GV%Angstrom_H) ; maxEnt(i,nz) = 0.0 do_i(i) = (G%mask2dT(i,j) > 0.5) enddo do k=nz-1,kb_min,-1 @@ -754,7 +818,7 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, CS, & if (k Calculate Brunt-Vaisala frequency, N^2. +subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & N2_lay, N2_int, N2_bot) - 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 !< Layer thicknesses, in H (usually m or kg m-2) - type(thermo_var_ptrs), intent(in) :: tv - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: T_f, S_f - type(forcing), intent(in) :: fluxes - integer, intent(in) :: j - type(set_diffusivity_CS), pointer :: CS - real, dimension(SZI_(G),SZK_(G)+1), intent(out) :: dRho_int, N2_int - real, dimension(SZI_(G),SZK_(G)), intent(out) :: N2_lay - real, dimension(SZI_(G)), intent(out) :: N2_bot - + 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 + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any available + !! thermodynamic fields. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: T_f !< layer temperature with the values in massless layers + !! filled vertically by diffusion [degC]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: S_f !< Layer salinities with values in massless + !! layers filled vertically by diffusion [ppt]. + type(forcing), intent(in) :: fluxes !< A structure of thermodynamic surface fluxes + integer, intent(in) :: j !< j-index of row to work on + type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure + real, dimension(SZI_(G),SZK_(G)+1), & + 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]. + 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]. + ! Local variables real, dimension(SZI_(G),SZK_(G)+1) :: & dRho_int_unfilt, & ! unfiltered density differences across interfaces - dRho_dT, & ! partial derivative of density wrt temp (kg m-3 degC-1) - dRho_dS ! partial derivative of density wrt saln (kg m-3 PPT-1) + dRho_dT, & ! partial derivative of density wrt temp [kg m-3 degC-1] + dRho_dS ! partial derivative of density wrt saln [kg m-3 ppt-1] real, dimension(SZI_(G)) :: & - pres, & ! pressure at each interface (Pa) - Temp_int, & ! temperature at each interface (degC) - Salin_int, & ! salinity at each interface (PPT) + pres, & ! pressure at each interface [Pa] + Temp_int, & ! temperature at each interface [degC] + Salin_int, & ! salinity at each interface [ppt] drho_bot, & - h_amp, & - hb, & - z_from_bot + h_amp, & ! The topographic roughness amplitude [Z ~> m]. + hb, & ! The thickness of the bottom layer [Z ~> m]. + z_from_bot ! The hieght above the bottom [Z ~> m]. real :: Rml_base ! density of the deepest variable density layer - real :: dz_int ! thickness associated with an interface (meter) - real :: G_Rho0 ! gravitation acceleration divided by Bouss reference density (m4 s-2 kg-1) + 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]. 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 / GV%Rho0 + G_Rho0 = (GV%g_Earth*US%m_to_Z**2) / GV%Rho0 H_neglect = GV%H_subroundoff ! Find the (limited) density jump across each interface. @@ -872,18 +951,18 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, CS, dRho_int, & ! Set the buoyancy frequencies. do k=1,nz ; do i=is,ie N2_lay(i,k) = G_Rho0 * 0.5*(dRho_int(i,K) + dRho_int(i,K+1)) / & - (GV%H_to_m*(h(i,j,k) + H_neglect)) + (GV%H_to_Z*(h(i,j,k) + H_neglect)) enddo ; enddo do i=is,ie ; N2_int(i,1) = 0.0 ; N2_int(i,nz+1) = 0.0 ; enddo do K=2,nz ; do i=is,ie N2_int(i,K) = G_Rho0 * dRho_int(i,K) / & - (0.5*GV%H_to_m*(h(i,j,k-1) + h(i,j,k) + H_neglect)) + (0.5*GV%H_to_Z*(h(i,j,k-1) + h(i,j,k) + H_neglect)) enddo ; enddo ! Find the bottom boundary layer stratification, and use this in the deepest layers. do i=is,ie hb(i) = 0.0 ; dRho_bot(i) = 0.0 - z_from_bot(i) = 0.5*GV%H_to_m*h(i,j,nz) + z_from_bot(i) = 0.5*GV%H_to_Z*h(i,j,nz) do_i(i) = (G%mask2dT(i,j) > 0.5) if ( (CS%tm_csp%Int_tide_dissipation .or. CS%tm_csp%Lee_wave_dissipation) .and. & @@ -897,7 +976,7 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, CS, dRho_int, & do k=nz,2,-1 do_any = .false. do i=is,ie ; if (do_i(i)) then - dz_int = 0.5*GV%H_to_m*(h(i,j,k) + h(i,j,k-1)) + dz_int = 0.5*GV%H_to_Z*(h(i,j,k) + h(i,j,k-1)) z_from_bot(i) = z_from_bot(i) + dz_int ! middle of the layer above hb(i) = hb(i) + dz_int @@ -906,7 +985,7 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, CS, dRho_int, & if (z_from_bot(i) > h_amp(i)) then if (k>2) then ! Always include at least one full layer. - hb(i) = hb(i) + 0.5*GV%H_to_m*(h(i,j,k-1) + h(i,j,k-2)) + hb(i) = hb(i) + 0.5*GV%H_to_Z*(h(i,j,k-1) + h(i,j,k-2)) dRho_bot(i) = dRho_bot(i) + dRho_int(i,K-1) endif do_i(i) = .false. @@ -921,14 +1000,14 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, CS, dRho_int, & if (hb(i) > 0.0) then N2_bot(i) = (G_Rho0 * dRho_bot(i)) / hb(i) else ; N2_bot(i) = 0.0 ; endif - z_from_bot(i) = 0.5*GV%H_to_m*h(i,j,nz) + z_from_bot(i) = 0.5*GV%H_to_Z*h(i,j,nz) do_i(i) = (G%mask2dT(i,j) > 0.5) enddo do k=nz,2,-1 do_any = .false. do i=is,ie ; if (do_i(i)) then - dz_int = 0.5*GV%H_to_m*(h(i,j,k) + h(i,j,k-1)) + dz_int = 0.5*GV%H_to_Z*(h(i,j,k) + h(i,j,k-1)) z_from_bot(i) = z_from_bot(i) + dz_int ! middle of the layer above N2_int(i,K) = N2_bot(i) @@ -952,8 +1031,6 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, CS, dRho_int, & end subroutine find_N2 -! GMM, the following will be moved to a new module - !> This subroutine sets the additional diffusivities of temperature and !! salinity due to double diffusion, using the same functional form as is !! used in MOM4.1, and taken from an NCAR technical note (REF?) that updates @@ -961,72 +1038,55 @@ end subroutine find_N2 !! be made run-time variables rather than hard-coded constants. !! !! \todo Find reference for NCAR tech note above. -subroutine double_diffusion(tv, h, T_f, S_f, j, G, GV, CS, Kd_T_dd, Kd_S_dd) +subroutine double_diffusion(tv, h, T_f, S_f, j, G, GV, US, CS, Kd_T_dd, Kd_S_dd) 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(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any available - !! thermodynamic fields; absent fields have NULL - !! ptrs. + !! thermodynamic fields; absent fields have NULL ptrs. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2). + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: T_f !< layer temp in C with the values in massless layers - !! filled vertically by diffusion. + intent(in) :: T_f !< layer temperatures with the values in massless layers + !! filled vertically by diffusion [degC]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: S_f !< Layer salinities in PPT with values in massless - !! layers filled vertically by diffusion. + intent(in) :: S_f !< Layer salinities with values in massless + !! layers filled vertically by diffusion [ppt]. integer, intent(in) :: j !< Meridional index upon which to work. 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 (m2/sec). + !! diffusivity for temp [Z2 s-1 ~> m2 s-1]. real, dimension(SZI_(G),SZK_(G)+1), & intent(out) :: Kd_S_dd !< Interface double diffusion diapycnal - !! diffusivity for saln (m2/sec). - -! Arguments: -! (in) tv - structure containing pointers to any available -! thermodynamic fields; absent fields have NULL ptrs -! (in) h - layer thickness (m or kg m-2) -! (in) T_f - layer temp in C with the values in massless layers -! filled vertically by diffusion -! (in) S_f - layer salinities in PPT with values in massless layers -! filled vertically by diffusion -! (in) G - ocean grid structure -! (in) GV - The ocean's vertical grid structure. -! (in) CS - module control structure -! (in) j - meridional index upon which to work -! (out) Kd_T_dd - interface double diffusion diapycnal diffusivity for temp (m2/sec) -! (out) Kd_S_dd - interface double diffusion diapycnal diffusivity for saln (m2/sec) - -! This subroutine sets the additional diffusivities of temperature and -! salinity due to double diffusion, using the same functional form as is -! used in MOM4.1, and taken from an NCAR technical note (###REF?) that updates -! what was in Large et al. (1994). All the coefficients here should probably -! be made run-time variables rather than hard-coded constants. + !! diffusivity for saln [Z2 s-1 ~> m2 s-1]. real, dimension(SZI_(G)) :: & - dRho_dT, & ! partial derivatives of density wrt temp (kg m-3 degC-1) - dRho_dS, & ! partial derivatives of density wrt saln (kg m-3 PPT-1) - pres, & ! pressure at each interface (Pa) - Temp_int, & ! temp and saln at interfaces - Salin_int + dRho_dT, & ! partial derivatives of density wrt temp [kg m-3 degC-1] + dRho_dS, & ! partial derivatives of density wrt saln [kg m-3 ppt-1] + pres, & ! pressure at each interface [Pa] + Temp_int, & ! temperature at interfaces [degC] + Salin_int ! Salinity at interfaces [ppt] - real :: alpha_dT ! density difference between layers due to temp diffs (kg/m3) - real :: beta_dS ! density difference between layers due to saln diffs (kg/m3) + real :: alpha_dT ! density difference between layers due to temp diffs [kg m-3] + real :: beta_dS ! density difference between layers due to saln diffs [kg m-3] - real :: Rrho ! vertical density ratio - real :: diff_dd ! factor for double-diffusion - real :: prandtl ! flux ratio for diffusive convection regime + 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 :: prandtl ! flux ratio for diffusive convection regime - real, parameter :: Rrho0 = 1.9 ! limit for double-diffusive density ratio - real, parameter :: dsfmax = 1.e-4 ! max diffusivity in case of salt fingering - real, parameter :: Kv_molecular = 1.5e-6 ! molecular viscosity (m2/sec) + 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 @@ -1045,18 +1105,18 @@ subroutine double_diffusion(tv, h, T_f, S_f, j, G, GV, CS, Kd_T_dd, Kd_S_dd) beta_dS = dRho_dS(i) * (S_f(i,j,k-1) - S_f(i,j,k)) if ((alpha_dT > beta_dS) .and. (beta_dS > 0.0)) then ! salt finger case - Rrho = min(alpha_dT/beta_dS,Rrho0) + Rrho = min(alpha_dT / beta_dS, Rrho0) diff_dd = 1.0 - ((RRho-1.0)/(RRho0-1.0)) - diff_dd = dsfmax*diff_dd*diff_dd*diff_dd - Kd_T_dd(i,K) = 0.7*diff_dd - Kd_S_dd(i,K) = diff_dd + Kd_dd = dsfmax * 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 - diff_dd = Kv_molecular*0.909*exp(4.6*exp(-0.54*(1/Rrho-1))) + Rrho = alpha_dT / beta_dS + Kd_dd = 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) = diff_dd - Kd_S_dd(i,K) = prandtl*diff_dd + Kd_T_dd(i,K) = 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 @@ -1065,50 +1125,68 @@ subroutine double_diffusion(tv, h, T_f, S_f, j, G, GV, CS, Kd_T_dd, Kd_S_dd) endif end subroutine double_diffusion + !> This routine adds diffusion sustained by flow energy extracted by bottom drag. subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & - maxTKE, kb, G, GV, CS, Kd, Kd_int, Kd_BBL) - 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(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< The zonal velocity, in m s-1 - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< The meridional velocity, in m s-1 - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - type(thermo_var_ptrs), intent(in) :: tv - type(forcing), intent(in) :: fluxes - type(vertvisc_type), intent(in) :: visc - integer, intent(in) :: j - real, dimension(SZI_(G),SZK_(G)), intent(in) :: TKE_to_Kd, maxTKE - integer, dimension(SZI_(G)), intent(in) :: kb - type(set_diffusivity_CS), pointer :: CS - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: Kd - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: Kd_int - real, dimension(:,:,:), pointer :: Kd_BBL + maxTKE, kb, G, GV, US, CS, Kd_lay, Kd_int, Kd_BBL) + 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 + 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] + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any available + !! thermodynamic fields. + type(forcing), intent(in) :: fluxes !< A structure of thermodynamic surface fluxes + type(vertvisc_type), intent(in) :: visc !< Structure containing vertical viscosities, bottom + !! boundary layer properies, and related fields + integer, intent(in) :: j !< j-index of row 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] + 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] + 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]. + 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]. ! This routine adds diffusion sustained by flow energy extracted by bottom drag. real, dimension(SZK_(G)+1) :: & - Rint ! coordinate density of an interface (kg/m3) + Rint ! coordinate density of an interface [kg m-3] real, dimension(SZI_(G)) :: & htot, & ! total thickness above or below a layer, or the - ! integrated thickness in the BBL (meter) - rho_htot, & ! running integral with depth of density (kg/m2) + ! integrated thickness in the BBL [Z ~> m]. + rho_htot, & ! running integral with depth of density [Z kg m-3 ~> kg m-2] gh_sum_top, & ! BBL value of g'h that can be supported by - ! the local ustar, times R0_g (kg/m2) - Rho_top, & ! density at top of the BBL (kg/m3) + ! 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/s3) - I2decay ! inverse of twice the TKE decay scale (1/m) - - real :: TKE_to_layer ! TKE used to drive mixing in a layer (m3/s3) - real :: TKE_Ray ! TKE from layer Rayleigh drag used to drive mixing in layer (m3/s3) - real :: TKE_here ! TKE that goes into mixing in this layer (m3/s3) - real :: dRl, dRbot ! temporaries holding density differences (kg/m3) - real :: cdrag_sqrt ! square root of the drag coefficient (nondimensional) - real :: ustar_h ! value of ustar at a thickness point (m/s) - real :: absf ! average absolute Coriolis parameter around a thickness point (1/s) - real :: R0_g ! Rho0 / G_Earth (kg s2 m-2) - real :: I_rho0 ! 1 / RHO0 - real :: delta_Kd ! increment to Kd from the bottom boundary layer mixing (m2/s) + ! bottom-boundary layer mixing in a layer [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 :: 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 :: 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]. logical :: Rayleigh_drag ! Set to true if Rayleigh drag velocities ! defined in visc, on the assumption that this ! extracted energy also drives diapycnal mixing. @@ -1128,7 +1206,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/GV%g_Earth + R0_g = GV%Rho0 / (US%m_to_Z**2*GV%g_Earth) do K=2,nz ; Rint(K) = 0.5*(GV%Rlay(k-1)+GV%Rlay(k)) ; enddo @@ -1140,7 +1218,7 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & do i=is,ie ustar_h = visc%ustar_BBL(i,j) if (associated(fluxes%ustar_tidal)) & - ustar_h = ustar_h + fluxes%ustar_tidal(i,j) + ustar_h = ustar_h + US%m_to_Z*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 @@ -1151,12 +1229,12 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & I2decay(i) = 0.5*CS%IMax_decay endif TKE(i) = ((CS%BBL_effic * cdrag_sqrt) * & - exp(-I2decay(i)*(GV%H_to_m*h(i,j,nz))) ) * & + 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 * & - (CS%BBL_effic * exp(-I2decay(i)*(GV%H_to_m*h(i,j,nz)))) + (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 ! Killworth & Edwards (1999) and Zilitikevich & Mironov (1996). @@ -1166,16 +1244,16 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & gh_sum_top(i) = R0_g * 400.0 * ustar_h**2 do_i(i) = (G%mask2dT(i,j) > 0.5) - htot(i) = GV%H_to_m*h(i,j,nz) - rho_htot(i) = GV%Rlay(nz)*(GV%H_to_m*h(i,j,nz)) + htot(i) = GV%H_to_Z*h(i,j,nz) + rho_htot(i) = GV%Rlay(nz)*(GV%H_to_Z*h(i,j,nz)) Rho_top(i) = GV%Rlay(1) if (CS%bulkmixedlayer .and. do_i(i)) Rho_top(i) = GV%Rlay(kb(i)-1) enddo do k=nz-1,2,-1 ; domore = .false. do i=is,ie ; if (do_i(i)) then - htot(i) = htot(i) + GV%H_to_m*h(i,j,k) - rho_htot(i) = rho_htot(i) + GV%Rlay(k)*(GV%H_to_m*h(i,j,k)) + htot(i) = htot(i) + GV%H_to_Z*h(i,j,k) + rho_htot(i) = rho_htot(i) + GV%Rlay(k)*(GV%H_to_Z*h(i,j,k)) if (htot(i)*GV%Rlay(k-1) <= (rho_htot(i) - gh_sum_top(i))) then ! The top of the mixing is in the interface atop the current layer. Rho_top(i) = (rho_htot(i) - gh_sum_top(i)) / htot(i) @@ -1194,7 +1272,7 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & i_rem = i_rem + 1 ! Count the i-rows that are still being worked on. ! Apply vertical decay of the turbulent energy. This energy is ! simply lost. - TKE(i) = TKE(i) * exp(-I2decay(i) * (GV%H_to_m*(h(i,j,k) + h(i,j,k+1)))) + TKE(i) = TKE(i) * exp(-I2decay(i) * (GV%H_to_Z*(h(i,j,k) + h(i,j,k+1)))) ! if (maxEnt(i,k) <= 0.0) cycle if (maxTKE(i,k) <= 0.0) cycle @@ -1212,7 +1290,7 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & 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 * G%IareaT(i,j) * & + if (Rayleigh_drag) TKE_Ray = 0.5*CS%BBL_effic * US%Z_to_m * 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 + & @@ -1225,15 +1303,15 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & TKE(i) = TKE(i) - TKE_to_layer - if (Kd(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(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(i,j,k) = Kd(i,j,k) + delta_Kd + delta_Kd = CS%Kd_max + Kd_lay(i,j,k) = Kd_lay(i,j,k) + delta_Kd else - Kd(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) = 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 @@ -1241,12 +1319,12 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & endif endif else - if (Kd(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(i,j,k) + (TKE_to_layer+TKE_Ray)*TKE_to_Kd(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(i,j,k)/TKE_to_Kd(i,k)) - & + TKE_here = ( (TKE_to_layer+TKE_Ray) + Kd_lay(i,j,k)/TKE_to_Kd(i,k) ) - & maxTKE(i,k) TKE(i) = TKE(i) - TKE_here + TKE_Ray else @@ -1256,10 +1334,10 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & if (TKE(i) < 0.0) TKE(i) = 0.0 ! This should be unnecessary? if (TKE_here > 0.0) then - delta_Kd = TKE_here*TKE_to_Kd(i,k) + delta_Kd = TKE_here * TKE_to_Kd(i,k) if (CS%Kd_max >= 0.0) delta_Kd = min(delta_Kd, CS%Kd_max) - Kd(i,j,k) = Kd(i,j,k) + delta_Kd - Kd_int(i,j,K) = Kd_int(i,j,K) + 0.5*delta_Kd + 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 if (do_diag_Kd_BBL) then Kd_BBL(i,j,K) = Kd_BBL(i,j,K) + 0.5*delta_Kd @@ -1287,43 +1365,52 @@ end subroutine add_drag_diffusivity !! wall turbulent viscosity, up to a BBL height where the energy used for mixing has !! consumed the mechanical TKE input. subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, & - G, GV, CS, Kd, Kd_int, Kd_BBL) - type(ocean_grid_type), intent(in) :: G !< Grid structure - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< u component of flow (m s-1) - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< v component of flow (m s-1) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness (m or kg m-2) - type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables structure - type(forcing), intent(in) :: fluxes !< Surface fluxes structure - type(vertvisc_type), intent(in) :: visc !< Vertical viscosity structure - 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) - type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: Kd !< Layer net diffusivity (m2 s-1) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: Kd_int !< Interface net diffusivity (m2 s-1) - real, dimension(:,:,:), pointer :: Kd_BBL !< Interface BBL diffusivity (m2 s-1) + G, GV, US, CS, Kd_lay, Kd_int, Kd_BBL) + 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 + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(in) :: u !< u component of flow [m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(in) :: v !< v component of flow [m s-1] + 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 !< Structure containing pointers to any available + !! thermodynamic fields. + type(forcing), intent(in) :: fluxes !< Surface fluxes structure + type(vertvisc_type), intent(in) :: visc !< Structure containing vertical viscosities, bottom + !! 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] + 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] + 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] ! 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 :: cdrag_sqrt ! square root of the drag coefficient (nondimensional) - real :: ustar ! value of ustar at a thickness point (m/s) - real :: ustar2 ! square of ustar, for convenience (m2/s2) - real :: absf ! average absolute value of Coriolis parameter around a thickness point (1/sec) - real :: dh, dhm1 ! thickness of layers k and k-1, respecitvely (meter) - real :: z ! distance to interface k from bottom (meter) - real :: D_minus_z ! distance to interface k from surface (meter) - real :: total_thickness ! total thickness of water column (meter) - real :: Idecay ! inverse of decay scale used for "Joule heating" loss of TKE with height (1/m) - real :: Kd_wall ! Law of the wall diffusivity (m2/s) - real :: Kd_lower ! diffusivity for lower interface (m2/sec) - real :: ustar_D ! u* x D (m2/s) + 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 :: 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 :: 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 :: I_Rho0 ! 1 / rho0 - real :: N2_min ! Minimum value of N2 to use in calculation of TKE_Kd_wall (1/s2) + real :: N2_min ! Minimum value of N2 to use in calculation of TKE_Kd_wall [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 @@ -1349,42 +1436,43 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, & 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, in m s-1. + ! u* at the bottom [m s-1]. ustar = 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 + fluxes%ustar_tidal(i,j) + if (associated(fluxes%ustar_tidal)) ustar = ustar + US%m_to_Z*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 - ! Energy input at the bottom, in m3 s-3. + ! Energy input at the bottom [m3 s-3]. ! (Note that visc%TKE_BBL is in 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, in m3 s-3. - ! Note that TKE_tidal is in W m-2. + ! 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 TKE_column = CS%BBL_effic * TKE_column ! Only use a fraction of the mechanical dissipation for mixing. TKE_remaining = TKE_column - total_thickness = ( sum(h(i,j,:)) + GV%H_subroundoff )* GV%H_to_m ! Total column thickness, in m. + total_thickness = ( sum(h(i,j,:)) + GV%H_subroundoff )* GV%H_to_Z ! Total column thickness [Z ~> m]. ustar_D = ustar * total_thickness - z = 0. + z_bot = 0. Kd_lower = 0. ! Diffusivity on bottom boundary. ! Work upwards from the bottom, accumulating work used until it exceeds the available TKE input ! at the bottom. do k=G%ke,2,-1 - dh = GV%H_to_m * h(i,j,k) ! Thickness of this level in m. + dh = GV%H_to_Z * h(i,j,k) ! Thickness of this level [Z ~> m]. km1 = max(k-1, 1) - dhm1 = GV%H_to_m * h(i,j,km1) ! Thickness of level above in m. + dhm1 = GV%H_to_Z * h(i,j,km1) ! Thickness of level above [Z ~> m]. ! Add in additional energy input from bottom-drag against slopes (sides) - if (Rayleigh_drag) TKE_remaining = TKE_remaining + 0.5*CS%BBL_effic * G%IareaT(i,j) * & + if (Rayleigh_drag) TKE_remaining = TKE_remaining + & + 0.5*CS%BBL_effic * US%Z_to_m * 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 + & @@ -1394,28 +1482,29 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, & ! This is energy loss in addition to work done as mixing, apparently to Joule heating. TKE_remaining = exp(-Idecay*dh) * TKE_remaining - z = z + h(i,j,k)*GV%H_to_m ! Distance between upper interface of layer and the bottom, in m. - D_minus_z = max(total_thickness - z, 0.) ! Thickness above layer, m. + z_bot = z_bot + h(i,j,k)*GV%H_to_Z ! Distance between upper interface of layer and the bottom [Z ~> m]. + D_minus_z = max(total_thickness - z_bot, 0.) ! Thickness above layer, Z. - ! Diffusivity using law of the wall, limited by rotation, at height z, in m2/s. + ! Diffusivity using law of the wall, limited by rotation, at height z [m2 s-1]. ! This calculation is at the upper interface of the layer - if ( ustar_D + absf * ( z * D_minus_z ) == 0.) then + if ( ustar_D + absf * ( z_bot * D_minus_z ) == 0.) then Kd_wall = 0. else - Kd_wall = ( ( von_karm * ustar2 ) * ( z * D_minus_z ) )/( ustar_D + absf * ( z * 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, in m3 s-2. + ! TKE associated with Kd_wall [m3 s-2]. ! This calculation if for the volume spanning the interface. - TKE_Kd_wall = Kd_wall * 0.5 * (dh + dhm1) * max(N2_int(i,k), N2_min) + TKE_Kd_wall = US%Z_to_m**3*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 + 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. else ! Either N2=0 or dh = 0. - if (TKE_remaining>0.) then + if (TKE_remaining > 0.) then Kd_wall = CS%Kd_max else Kd_wall = 0. @@ -1427,41 +1516,54 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, & TKE_remaining = TKE_remaining - TKE_consumed ! Note this will be non-negative ! Add this BBL diffusivity to the model net diffusivity. - Kd_int(i,j,k) = Kd_int(i,j,k) + Kd_wall - Kd(i,j,k) = Kd(i,j,k) + 0.5*(Kd_wall + Kd_lower) + 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_lower = Kd_wall ! Store for next level up. - if (do_diag_Kd_BBL) Kd_BBL(i,j,k) = Kd_wall + if (do_diag_Kd_BBL) Kd_BBL(i,j,K) = Kd_wall enddo ! k enddo ! i end subroutine add_LOTW_BBL_diffusivity + !> This routine adds effects of mixed layer radiation to the layer diffusivities. -subroutine add_MLrad_diffusivity(h, fluxes, j, G, GV, CS, Kd, TKE_to_Kd, Kd_int) - 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 !< Layer thicknesses, in H (usually m or kg m-2) - type(forcing), intent(in) :: fluxes - integer, intent(in) :: j - type(set_diffusivity_CS), pointer :: CS - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: Kd - real, dimension(SZI_(G),SZK_(G)), intent(in) :: TKE_to_Kd - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), optional, intent(inout) :: Kd_int +subroutine add_MLrad_diffusivity(h, fluxes, j, G, GV, US, CS, Kd_lay, TKE_to_Kd, Kd_int) + 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 + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + 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]. + 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] + 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]. ! This routine adds effects of mixed layer radiation to the layer diffusivities. - real, dimension(SZI_(G)) :: & - h_ml, & - TKE_ml_flux, & - I_decay, & - Kd_mlr_ml - - real :: f_sq, h_ml_sq, ustar_sq, Kd_mlr, C1_6 - real :: Omega2 ! rotation rate squared (1/s2) - real :: z1 ! layer thickness times I_decay (nondim) - real :: dzL ! thickness converted to meter + real, dimension(SZI_(G)) :: h_ml ! Mixed layer thickness [Z ~> m]. + real, dimension(SZI_(G)) :: TKE_ml_flux + 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 :: f_sq ! The square of the local Coriolis parameter or a related variable [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 :: C1_6 ! 1/6 + real :: Omega2 ! rotation rate squared [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 - ! TKE, as used in the mixed layer code (1/m2) - real :: h_neglect ! negligibly small thickness (meter) + ! TKE, as used in the mixed layer code [Z-2 ~> m-2]. + real :: h_neglect ! negligibly small thickness [Z ~> m]. logical :: do_any, do_i(SZI_(G)) integer :: i, k, is, ie, nz, kml @@ -1470,12 +1572,12 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, G, GV, CS, Kd, TKE_to_Kd, Kd_int) Omega2 = CS%Omega**2 C1_6 = 1.0 / 6.0 kml = GV%nkml - h_neglect = GV%H_subroundoff*GV%H_to_m + h_neglect = GV%H_subroundoff*GV%H_to_Z if (.not.CS%ML_radiation) return do i=is,ie ; h_ml(i) = 0.0 ; do_i(i) = (G%mask2dT(i,j) > 0.5) ; enddo - do k=1,kml ; do i=is,ie ; h_ml(i) = h_ml(i) + GV%H_to_m*h(i,j,k) ; enddo ; enddo + do k=1,kml ; do i=is,ie ; h_ml(i) = h_ml(i) + GV%H_to_Z*h(i,j,k) ; enddo ; enddo do i=is,ie ; if (do_i(i)) then if (CS%ML_omega_frac >= 1.0) then @@ -1489,7 +1591,7 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, G, GV, CS, Kd, TKE_to_Kd, Kd_int) ustar_sq = max(fluxes%ustar(i,j), CS%ustar_min)**2 - TKE_ml_flux(i) = (CS%mstar*CS%ML_rad_coeff)*(ustar_sq*fluxes%ustar(i,j)) + TKE_ml_flux(i) = (CS%mstar*CS%ML_rad_coeff)*(US%Z_to_m**3*ustar_sq*fluxes%ustar(i,j)) I_decay_len2_TKE = CS%TKE_decay**2 * (f_sq / ustar_sq) if (CS%ML_rad_TKE_decay) & @@ -1501,7 +1603,7 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, G, GV, CS, Kd, TKE_to_Kd, Kd_int) ! Average the dissipation layer kml+1, using ! a more accurate Taylor series approximations for very thin layers. - z1 = (GV%H_to_m*h(i,j,kml+1)) * I_decay(i) + 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)) @@ -1509,12 +1611,12 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, G, GV, CS, Kd, TKE_to_Kd, Kd_int) 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) + Kd_mlr_ml(i) = min(Kd_mlr, CS%ML_rad_kd_max) TKE_ml_flux(i) = TKE_ml_flux(i) * exp(-z1) endif ; enddo do k=1,kml+1 ; do i=is,ie ; if (do_i(i)) then - Kd(i,j,k) = Kd(i,j,k) + Kd_mlr_ml(i) + Kd_lay(i,j,k) = Kd_lay(i,j,k) + Kd_mlr_ml(i) endif ; enddo ; enddo if (present(Kd_int)) then do K=2,kml+1 ; do i=is,ie ; if (do_i(i)) then @@ -1528,23 +1630,23 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, G, GV, CS, Kd, TKE_to_Kd, Kd_int) do k=kml+2,nz-1 do_any = .false. do i=is,ie ; if (do_i(i)) then - dzL = GV%H_to_m*h(i,j,k) ; z1 = dzL*I_decay(i) + 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)) * & - ((1.0 - exp(-z1)) / dzL) + US%m_to_Z * ((1.0 - exp(-z1)) / dzL) else Kd_mlr = (TKE_ml_flux(i) * TKE_to_Kd(i,k)) * & - (I_decay(i) * (1.0 - z1 * (0.5 - C1_6*z1))) + US%m_to_Z * (I_decay(i) * (1.0 - z1 * (0.5 - C1_6*z1))) endif - Kd_mlr = min(Kd_mlr,CS%ML_rad_kd_max) - Kd(i,j,k) = Kd(i,j,k) + Kd_mlr + 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) = 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*Omega2) then + if (TKE_ml_flux(i) * I_decay(i) < 0.1*CS%Kd_min*US%Z_to_m**3*Omega2) then do_i(i) = .false. else ; do_any = .true. ; endif endif ; enddo @@ -1555,36 +1657,41 @@ end subroutine add_MLrad_diffusivity !> This subroutine calculates several properties related to bottom !! boundary layer turbulence. -subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, 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 - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< The zonal velocity, in m s-1 - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< The meridional velocity, in m s-1 - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - type(forcing), intent(in) :: fluxes - type(vertvisc_type), intent(inout) :: visc - type(set_diffusivity_CS), pointer :: CS +subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, 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 + 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] + type(forcing), intent(in) :: fluxes !< A structure of thermodynamic surface fluxes + type(vertvisc_type), intent(in) :: visc !< Structure containing vertical viscosities, bottom + !! boundary layer properies, and related fields. + type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure ! This subroutine calculates several properties related to bottom ! boundary layer turbulence. real, dimension(SZI_(G)) :: & htot ! total thickness above or below a layer, or the - ! integrated thickness in the BBL (meter) + ! integrated thickness in the BBL [Z ~> m]. real, dimension(SZIB_(G)) :: & - uhtot, & ! running integral of u in the BBL (m2/s) - ustar, & ! bottom boundary layer turbulence speed (m/s) - u2_bbl ! square of the mean zonal velocity in the BBL (m2/s2) + uhtot, & ! running integral of u in the BBL [Z m s-1 ~> m2 s-1] + ustar, & ! bottom boundary layer turbulence speed [Z s-1 ~> m s-1]. + u2_bbl ! square of the mean zonal velocity in the BBL [m2 s-2] - real :: vhtot(SZI_(G)) ! running integral of v in the BBL (m2/sec) + real :: vhtot(SZI_(G)) ! running integral of v in the BBL [Z m s-1 ~> m2 s-1] real, dimension(SZI_(G),SZJB_(G)) :: & - vstar, & ! ustar at at v-points in 2 j-rows (m/s) - v2_bbl ! square of average meridional velocity in BBL (m2/s2) + vstar, & ! ustar at at v-points [Z s-1 ~> m s-1]. + v2_bbl ! square of average meridional velocity in BBL [m2 s-2] - real :: cdrag_sqrt ! square root of the drag coefficient (nondim) - real :: hvel ! thickness at velocity points (meter) + real :: cdrag_sqrt ! square root of the drag coefficient [nondim] + real :: hvel ! thickness at velocity points [Z ~> m]. logical :: domore, do_i(SZI_(G)) integer :: i, j, k, is, ie, js, je, nz @@ -1605,7 +1712,7 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, CS) cdrag_sqrt = sqrt(CS%cdrag) -!$OMP parallel default(none) shared(cdrag_sqrt,is,ie,js,je,nz,visc,CS,G,GV,vstar,h,v, & +!$OMP parallel default(none) shared(cdrag_sqrt,is,ie,js,je,nz,visc,CS,G,GV,US,vstar,h,v, & !$OMP v2_bbl,u) & !$OMP private(do_i,vhtot,htot,domore,hvel,uhtot,ustar,u2_bbl) !$OMP do @@ -1615,14 +1722,14 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, CS) ! vertical decay scale. do i=is,ie ; if ((G%mask2dCv(i,J) > 0.5) .and. (cdrag_sqrt*visc%bbl_thick_v(i,J) > 0.0)) then do_i(i) = .true. ; vhtot(i) = 0.0 ; htot(i) = 0.0 - vstar(i,J) = visc%kv_bbl_v(i,J)/(cdrag_sqrt*visc%bbl_thick_v(i,J)) + vstar(i,J) = visc%kv_bbl_v(i,J) / (cdrag_sqrt*visc%bbl_thick_v(i,J)) else do_i(i) = .false. ; vstar(i,J) = 0.0 ; htot(i) = 0.0 endif ; enddo do k=nz,1,-1 domore = .false. do i=is,ie ; if (do_i(i)) then - hvel = 0.5*GV%H_to_m*(h(i,j,k) + h(i,j+1,k)) + hvel = 0.5*GV%H_to_Z*(h(i,j,k) + h(i,j+1,k)) if ((htot(i) + hvel) >= visc%bbl_thick_v(i,J)) then vhtot(i) = vhtot(i) + (visc%bbl_thick_v(i,J) - htot(i))*v(i,J,k) htot(i) = visc%bbl_thick_v(i,J) @@ -1645,13 +1752,13 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, CS) do j=js,je do I=is-1,ie ; if ((G%mask2dCu(I,j) > 0.5) .and. (cdrag_sqrt*visc%bbl_thick_u(I,j) > 0.0)) then do_i(I) = .true. ; uhtot(I) = 0.0 ; htot(I) = 0.0 - ustar(I) = visc%kv_bbl_u(I,j)/(cdrag_sqrt*visc%bbl_thick_u(I,j)) + ustar(I) = visc%kv_bbl_u(I,j) / (cdrag_sqrt*visc%bbl_thick_u(I,j)) else do_i(I) = .false. ; ustar(I) = 0.0 ; htot(I) = 0.0 endif ; enddo do k=nz,1,-1 ; domore = .false. do I=is-1,ie ; if (do_i(I)) then - hvel = 0.5*GV%H_to_m*(h(i,j,k) + h(i+1,j,k)) + hvel = 0.5*GV%H_to_Z*(h(i,j,k) + h(i+1,j,k)) if ((htot(I) + hvel) >= visc%bbl_thick_u(I,j)) then uhtot(I) = uhtot(I) + (visc%bbl_thick_u(I,j) - htot(I))*u(I,j,k) htot(I) = visc%bbl_thick_u(I,j) @@ -1676,10 +1783,11 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, 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) = (((G%areaCu(I-1,j)*(ustar(I-1)*u2_bbl(I-1)) + & + visc%TKE_BBL(i,j) = US%Z_to_m * & + (((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)) + & - G%areaCv(i,J) * (vstar(i,J)*v2_bbl(i,J))))*G%IareaT(i,j)) + G%areaCv(i,J) * (vstar(i,J)*v2_bbl(i,J))) )*G%IareaT(i,j)) enddo enddo !$OMP end parallel @@ -1690,44 +1798,30 @@ subroutine set_density_ratios(h, tv, kb, G, GV, CS, j, ds_dsp1, rho_0) 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 !< Layer thicknesses, in H (usually m - !! or kg m-2). + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any !! available thermodynamic fields; absent !! fields have NULL ptrs. - integer, dimension(SZI_(G)), intent(in) :: kb !< Index of lightest layer denser than the - !! buffer layer. + 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 !< Control structure returned by previous !! call to diabatic_entrain_init. integer, intent(in) :: j !< Meridional index upon which to work. real, dimension(SZI_(G),SZK_(G)), intent(out) :: ds_dsp1 !< Coordinate variable (sigma-2) !! difference across an interface divided by !! the difference across the interface below - !! it (nondimensional) + !! it [nondim] real, dimension(SZI_(G),SZK_(G)), & optional, intent(in) :: rho_0 !< Layer potential densities relative to - !! surface press (kg/m3). - -! Arguments: -! (in) h - layer thickness (meter) -! (in) tv - structure containing pointers to any available -! thermodynamic fields; absent fields have NULL ptrs -! (in) kb - index of lightest layer denser than the buffer layer -! (in) G - ocean grid structure -! (in) GV - The ocean's vertical grid structure. -! (in) CS - control structure returned by previous call to diabatic_entrain_init -! (in) j - meridional index upon which to work -! (in) ds_dsp1 - coordinate variable (sigma-2) difference across an -! interface divided by the difference across the interface -! below it (nondimensional) -! (in) rho_0 - layer potential densities relative to surface press (kg/m3) - - real :: g_R0 ! g_R0 is g/Rho (m4 kg-1 s-2) + !! surface press [kg m-3]. + + ! Local variables + real :: g_R0 ! g_R0 is g/Rho [m5 Z-1 kg-1 s-2 ~> m4 kg-1 s-2] real :: eps, tmp ! nondimensional temproray variables real :: a(SZK_(G)), a_0(SZK_(G)) ! nondimensional temporary variables real :: p_ref(SZI_(G)) ! an array of tv%P_Ref pressures - real :: Rcv(SZI_(G),SZK_(G)) ! coordinate density in the mixed and buffer layers (kg/m3) - real :: I_Drho ! temporary variable (m3/kg) + real :: Rcv(SZI_(G),SZK_(G)) ! coordinate density in the mixed and buffer layers [kg m-3] + real :: I_Drho ! temporary variable [m3 kg-1] integer :: i, k, k3, is, ie, nz, kmb is = G%isc ; ie = G%iec ; nz = G%ke @@ -1750,8 +1844,8 @@ subroutine set_density_ratios(h, tv, kb, G, GV, CS, j, ds_dsp1, rho_0) eps = 0.1 do i=is,ie ; p_ref(i) = tv%P_Ref ; enddo do k=1,kmb - call calculate_density(tv%T(:,j,k),tv%S(:,j,k),p_ref,Rcv(:,k),& - is,ie-is+1,tv%eqn_of_state) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_ref, Rcv(:,k), & + is, ie-is+1, tv%eqn_of_state) enddo do i=is,ie if (kb(i) <= nz-1) then @@ -1804,14 +1898,15 @@ 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, param_file, diag, CS, diag_to_Z_CSp, int_tide_CSp, & - tm_CSp) - type(time_type), intent(in) :: Time +subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, diag_to_Z_CSp, 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. 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 !< structure used to regulate diagnostic output. + 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 @@ -1820,6 +1915,8 @@ subroutine set_diffusivity_init(Time, G, GV, param_file, diag, CS, diag_to_Z_CSp !! structure (BDM) type(tidal_mixing_cs), pointer :: tm_csp !< pointer to tidal mixing control !! structure + integer, optional, intent(out) :: halo_TS !< The halo size of tracer points that must be + !! valid for the calculations in set_diffusivity. ! local variables real :: decay_length @@ -1851,7 +1948,7 @@ subroutine set_diffusivity_init(Time, G, GV, param_file, diag, CS, 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%Kdml = 0.0 ; CS%cdrag = 0.003 ; CS%BBL_effic = 0.0 CS%bulkmixedlayer = (GV%nkml > 0) @@ -1877,7 +1974,7 @@ subroutine set_diffusivity_init(Time, G, GV, param_file, diag, CS, diag_to_Z_CSp "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_m) + 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"//& @@ -1887,8 +1984,8 @@ subroutine set_diffusivity_init(Time, G, GV, param_file, diag, CS, diag_to_Z_CSp 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"//& - "This is only used if ML_RADIATION is true.", units="m2 s-1", & - default=1.0e-3) + "This is only used if ML_RADIATION is true.", & + units="m2 s-1", default=1.0e-3, scale=US%m_to_Z**2) 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"//& @@ -1897,7 +1994,7 @@ subroutine set_diffusivity_init(Time, G, GV, param_file, diag, CS, diag_to_Z_CSp 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"//& - "mixed layer code. This is only used if ML_RADIATION is true.",& + "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"//& @@ -1940,10 +2037,10 @@ subroutine set_diffusivity_init(Time, G, GV, param_file, diag, CS, diag_to_Z_CSp "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"//& - "This is only used if BOTTOMDRAGLAW is true.", units="m", & - default=0.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 + 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"//& @@ -1962,8 +2059,8 @@ subroutine set_diffusivity_init(Time, G, GV, param_file, diag, CS, diag_to_Z_CSp 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') + 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) 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"//& @@ -1972,25 +2069,30 @@ subroutine set_diffusivity_init(Time, G, GV, param_file, diag, CS, diag_to_Z_CSp default=.false.) ! set params releted to the background mixing - call bkgnd_mixing_init(Time, G, GV, param_file, CS%diag, CS%bkgnd_mixing_csp) + 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 molecular value, ~1e-6 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, "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", fail_if_missing=.true.) + "may be used.", units="m2 s-1", scale=US%m_to_Z**2, 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) + units="m2 s-1", default=0.01*CS%Kd*US%Z_to_m**2, scale=US%m_to_Z**2) 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) + "negative value for no limit.", units="m2 s-1", default=-1.0, scale=US%m_to_Z**2) 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"//& "everywhere without any filtering or scaling.", & - units="m2 s-1", default=0.0) + units="m2 s-1", default=0.0, scale=US%m_to_Z**2) 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.") @@ -2008,7 +2110,7 @@ subroutine set_diffusivity_init(Time, G, GV, param_file, diag, CS, diag_to_Z_CSp "If BULKMIXEDLAYER is false, KDML is the elevated \n"//& "diapycnal diffusivity in the topmost HMIX of fluid. \n"//& "KDML is only used if BULKMIXEDLAYER is false.", & - units="m2 s-1", default=CS%Kd) + 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"//& @@ -2024,20 +2126,20 @@ subroutine set_diffusivity_init(Time, G, GV, param_file, diag, CS, diag_to_Z_CSp 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) + "bound of Kd (a floor).", units="W m-3", default=0.0, scale=US%m_to_Z**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"//& "a lower bound of Kd (a floor): A in eps_min = A + B*N.", & - units="W m-3", default=0.0) + units="W m-3", default=0.0, scale=US%m_to_Z**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"//& "bound of Kd (a floor): B in eps_min = A + B*N", & - units="J m-3", default=0.0) + units="J m-3", default=0.0, scale=US%m_to_Z**2) 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) + units="m2 s-1", default=0.0, scale=US%m_to_Z**2) CS%limit_dissipation = (CS%dissip_min>0.) .or. (CS%dissip_N1>0.) .or. & (CS%dissip_N0>0.) .or. (CS%dissip_Kd_min>0.) @@ -2046,42 +2148,41 @@ subroutine set_diffusivity_init(Time, G, GV, param_file, diag, CS, diag_to_Z_CSp 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') + 'Diapycnal diffusivity of layers (as set)', 'm2 s-1', conversion=US%Z_to_m**2) 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, & + CS%id_Kd_Work = register_diag_field('ocean_model', 'Kd_Work', diag%axesTL, Time, & 'Work done by Diapycnal Mixing', 'W m-2') - CS%id_maxTKE = register_diag_field('ocean_model','maxTKE',diag%axesTL,Time, & + CS%id_maxTKE = register_diag_field('ocean_model', 'maxTKE', diag%axesTL, Time, & 'Maximum layer TKE', 'm3 s-3') - CS%id_TKE_to_Kd = register_diag_field('ocean_model','TKE_to_Kd',diag%axesTL,Time, & - 'Convert TKE to Kd', 's2 m') - 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',& + 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) + 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') 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') + 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",& + 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) + CS%id_Kd_user_z = register_Zint_diag(vd, CS%diag_to_Z_CSp, Time, conversion=US%Z_to_m**2) endif endif - - ! GMM, the following should be moved to the DD module 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.", & default=.false.) + if (CS%double_diffusion) then call get_param(param_file, mdl, "MAX_RRHO_SALT_FINGERS", CS%Max_Rrho_salt_fingers, & "Maximum density ratio for salt fingering regime.", & @@ -2094,41 +2195,53 @@ subroutine set_diffusivity_init(Time, G, GV, param_file, diag, CS, diag_to_Z_CSp "double-diffusive convection.", default=1.5e-6, units="m2 s-1") ! 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') + 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) - CS%id_KS_extra = register_diag_field('ocean_model','KS_extra',diag%axesTi,Time, & - 'Double-diffusive diffusivity for salinity', 'm2 s-1') + 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) + 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",& + "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) + 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) + CS%id_Kd_BBL_z = register_Zint_diag(vd, CS%diag_to_Z_CSp, Time, conversion=US%Z_to_m**2) endif - endif + endif ! old double-diffusion if (CS%user_change_diff) then - call user_change_diff_init(Time, G, param_file, diag, CS%user_change_diff_CSp) + call user_change_diff_init(Time, G, GV, US, param_file, diag, CS%user_change_diff_CSp) endif if (CS%tm_csp%Int_tide_dissipation .and. CS%bkgnd_mixing_csp%Bryan_Lewis_diffusivity) & call MOM_error(FATAL,"MOM_Set_Diffusivity: "// & "Bryan-Lewis and internal tidal dissipation are both enabled. Choose one.") - CS%useKappaShear = kappa_shear_init(Time, G, GV, param_file, CS%diag, CS%kappaShear_CSp) + CS%useKappaShear = kappa_shear_init(Time, G, GV, US, param_file, CS%diag, CS%kappaShear_CSp) + if (CS%useKappaShear) CS%Vertex_Shear = kappa_shear_at_vertex(param_file) + if (CS%useKappaShear) & id_clock_kappaShear = cpu_clock_id('(Ocean kappa_shear)', grain=CLOCK_MODULE) ! CVMix shear-driven mixing - CS%use_CVMix_shear = CVMix_shear_init(Time, G, GV, param_file, CS%diag, CS%CVMix_shear_csp) + CS%use_CVMix_shear = CVMix_shear_init(Time, G, GV, US, param_file, CS%diag, CS%CVMix_shear_csp) + + ! CVMix double diffusion mixing + CS%use_CVMix_ddiff = CVMix_ddiff_init(Time, G, GV, US, param_file, CS%diag, CS%CVMix_ddiff_csp) + if (CS%use_CVMix_ddiff) & + id_clock_CVMix_ddiff = cpu_clock_id('(Double diffusion via CVMix)', grain=CLOCK_MODULE) + + if (present(halo_TS)) then + halo_TS = 0 + if (CS%Vertex_Shear) halo_TS = 1 + endif end subroutine set_diffusivity_init @@ -2146,6 +2259,9 @@ subroutine set_diffusivity_end(CS) if (CS%use_CVMix_shear) & call CVMix_shear_end(CS%CVMix_shear_csp) + if (CS%use_CVMix_ddiff) & + call CVMix_ddiff_end(CS%CVMix_ddiff_csp) + if (associated(CS)) deallocate(CS) end subroutine set_diffusivity_end diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 90401313dc..7eba2fbac0 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -1,55 +1,27 @@ +!> Calculates various values related to the bottom boundary layer, such as the viscosity and +!! thickness of the BBL (set_viscous_BBL). module MOM_set_visc ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Robert Hallberg, April 1994 - October 2006 * -!* Quadratic Bottom Drag by James Stephens and R. Hallberg. * -!* * -!* This file contains the subroutine that calculates various values * -!* related to the bottom boundary layer, such as the viscosity and * -!* thickness of the BBL (set_viscous_BBL). This would also be the * -!* module in which other viscous quantities that are flow-independent * -!* might be set. This information is transmitted to other modules * -!* via a vertvisc type structure. * -!* * -!* The same code is used for the two velocity components, by * -!* indirectly referencing the velocities and defining a handful of * -!* direction-specific defined variables. * -!* * -!* Macros written all in capital letters are defined in MOM_memory.h. * -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q * -!* j+1 > o > o > At ^: v, frhatv, tauy * -!* j x ^ x ^ x At >: u, frhatu, taux * -!* j > o > o > At o: h * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** - use MOM_debugging, only : uvchksum, hchksum use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : diag_ctrl, time_type +use MOM_domains, only : pass_var, CORNER 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, mech_forcing use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type -use MOM_kappa_shear, only : kappa_shear_is_used -use MOM_CVMix_shear, only : CVMix_shear_is_used -use MOM_CVMix_conv, only : CVMix_conv_is_used -use MOM_io, only : vardesc, var_desc -use MOM_restart, only : register_restart_field, MOM_restart_CS -use MOM_variables, only : thermo_var_ptrs -use MOM_variables, only : vertvisc_type +use MOM_kappa_shear, only : kappa_shear_is_used, kappa_shear_at_vertex +use MOM_cvmix_shear, only : cvmix_shear_is_used +use MOM_cvmix_conv, only : cvmix_conv_is_used +use MOM_CVMix_ddiff, only : CVMix_ddiff_is_used +use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS +use MOM_safe_alloc, only : safe_alloc_ptr, safe_alloc_alloc +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs, vertvisc_type use MOM_verticalGrid, only : verticalGrid_type use MOM_EOS, only : calculate_density, calculate_density_derivs use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_DIRECTION_E @@ -62,80 +34,84 @@ module MOM_set_visc public set_viscous_BBL, set_viscous_ML, set_visc_init, set_visc_end public set_visc_register_restarts +! 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. + +!> Control structure for MOM_set_visc type, public :: set_visc_CS ; private - real :: Hbbl ! The static bottom boundary layer thickness, in - ! the same units as thickness (m or kg m-2). - real :: cdrag ! The quadratic drag coefficient. - real :: c_Smag ! The Laplacian Smagorinsky coefficient for - ! calculating the drag in channels. - real :: drag_bg_vel ! An assumed unresolved background velocity for - ! calculating the bottom drag, in m s-1. - real :: BBL_thick_min ! The minimum bottom boundary layer thickness in - ! the same units as thickness (m or kg m-2). - ! This might be Kv / (cdrag * drag_bg_vel) to give - ! Kv as the minimum near-bottom viscosity. - real :: Htbl_shelf ! A nominal thickness of the surface boundary layer - ! for use in calculating the near-surface velocity, - ! in units of m. - real :: Htbl_shelf_min ! The minimum surface boundary layer thickness in m. - real :: KV_BBL_min ! The minimum viscosities in the bottom and top - real :: KV_TBL_min ! boundary layers, both in m2 s-1. - - logical :: bottomdraglaw ! If true, the bottom stress is calculated with a - ! drag law 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 whether linear_drag is true. - logical :: BBL_use_EOS ! If true, use the equation of state in determining - ! the properties of the bottom boundary layer. - logical :: linear_drag ! If true, the drag law is cdrag*DRAG_BG_VEL*u. - logical :: Channel_drag ! If true, the drag is exerted directly on each - ! layer according to what fraction of the bottom - ! they overlie. - logical :: RiNo_mix ! If true, use Richardson number dependent mixing. - logical :: dynamic_viscous_ML ! If true, use a bulk Richardson number criterion to - ! determine the mixed layer thickness for viscosity. - real :: bulk_Ri_ML ! The bulk mixed layer used to determine the - ! thickness of the viscous mixed layer. Nondim. - real :: omega ! The Earth's rotation rate, in s-1. - real :: ustar_min ! A minimum value of ustar to avoid numerical - ! problems, in m s-1. If the value is small enough, - ! this should not affect the solution. - real :: TKE_decay ! The ratio of the natural Ekman depth to the TKE - ! decay scale, nondimensional. - real :: omega_frac ! 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). - logical :: debug ! If true, write verbose checksums for debugging purposes. - type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the - ! timing of diagnostic output. + real :: Hbbl !< The static bottom boundary layer thickness [H ~> m or kg m-2] + real :: cdrag !< The quadratic drag coefficient. + real :: c_Smag !< The Laplacian Smagorinsky coefficient for + !! calculating the drag in channels. + real :: drag_bg_vel !< An assumed unresolved background velocity for + !! calculating the bottom drag [m s-1]. + real :: BBL_thick_min !< The minimum bottom boundary layer thickness [H ~> m or kg m-2]. + !! This might be Kv / (cdrag * drag_bg_vel) to give + !! Kv as the minimum near-bottom viscosity. + real :: Htbl_shelf !< A nominal thickness of the surface boundary layer for use + !! in calculating the near-surface velocity [H ~> m or kg m-2]. + real :: Htbl_shelf_min !< The minimum surface boundary layer thickness [H ~> m or kg m-2]. + real :: KV_BBL_min !< The minimum viscosity in the bottom boundary layer [Z2 s-1 ~> m2 s-1]. + real :: KV_TBL_min !< The minimum viscosity in the top boundary layer [Z2 s-1 ~> m2 s-1]. + logical :: bottomdraglaw !< If true, the bottom stress is calculated with a + !! drag law 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 whether linear_drag is true. + logical :: BBL_use_EOS !< If true, use the equation of state in determining + !! the properties of the bottom boundary layer. + logical :: linear_drag !< If true, the drag law is cdrag*DRAG_BG_VEL*u. + logical :: Channel_drag !< If true, the drag is exerted directly on each + !! layer according to what fraction of the bottom + !! they overlie. + logical :: RiNo_mix !< If true, use Richardson number dependent mixing. + logical :: dynamic_viscous_ML !< If true, use a bulk Richardson number criterion to + !! determine the mixed layer thickness for viscosity. + real :: bulk_Ri_ML !< The bulk mixed layer used to determine the + !! thickness of the viscous mixed layer. Nondim. + real :: omega !< The Earth's rotation rate [s-1]. + real :: ustar_min !< A minimum value of ustar to avoid numerical + !! problems [Z s-1 ~> m s-1]. If the value is small enough, + !! this should not affect the solution. + real :: TKE_decay !< The ratio of the natural Ekman depth to the TKE + !! decay scale, nondimensional. + real :: omega_frac !< 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). + logical :: debug !< If true, write verbose checksums for debugging purposes. + type(ocean_OBC_type), pointer :: OBC => NULL() !< Open boundaries control structure + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + !>@{ Diagnostics handles integer :: id_bbl_thick_u = -1, id_kv_bbl_u = -1 integer :: id_bbl_thick_v = -1, id_kv_bbl_v = -1 integer :: id_Ray_u = -1, id_Ray_v = -1 integer :: id_nkml_visc_u = -1, id_nkml_visc_v = -1 - type(ocean_OBC_type), pointer :: OBC => NULL() + !!@} end type set_visc_CS contains -!> The following subroutine calculates the thickness of the bottom -!! boundary layer and the viscosity within that layer. A drag law is -!! used, either linearized about an assumed bottom velocity or using +!> Calculates the thickness of the bottom boundary layer and the viscosity within that layer. +!! A drag law is used, either linearized about an assumed bottom velocity or using !! the actual near-bottom velocities combined with an assumed !! unresolved velocity. The bottom boundary layer thickness is !! limited by a combination of stratification and rotation, as in the !! paper of Killworth and Edwards, JPO 1999. It is not necessary to !! calculate the thickness and viscosity every time step; instead !! previous values may be used. -subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, CS, symmetrize) +subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, symmetrize) 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, in m s-1. + intent(in) :: u !< The zonal velocity [m s-1]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & - intent(in) :: v !< The meridional velocity, in m s-1. + intent(in) :: v !< The meridional velocity [m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2). + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any !! available thermodynamic fields. Absent fields !! have NULL ptrs.. @@ -146,155 +122,136 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, CS, symmetrize) logical, optional, intent(in) :: symmetrize !< If present and true, do extra calculations !! of those values in visc that would be !! calculated with symmetric memory. -! The following subroutine calculates the thickness of the bottom -! boundary layer and the viscosity within that layer. A drag law is -! used, either linearized about an assumed bottom velocity or using -! the actual near-bottom velocities combined with an assumed -! unresolved velocity. The bottom boundary layer thickness is -! limited by a combination of stratification and rotation, as in the -! paper of Killworth and Edwards, JPO 1999. It is not necessary to -! calculate the thickness and viscosity every time step; instead -! previous values may be used. -! -! Arguments: u - Zonal velocity, in m s-1. -! (in) v - Meridional velocity, in m s-1. -! (in) h - Layer thickness, in m or kg m-2. In the comments below, -! the units of h are denoted as H. -! (in) tv - A structure containing pointers to any available -! thermodynamic fields. Absent fields have NULL ptrs. -! (out) visc - A structure containing vertical viscosities and related -! fields. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - The control structure returned by a previous call to -! vertvisc_init. + + ! Local variables real, dimension(SZIB_(G)) :: & - ustar, & ! The bottom friction velocity, in m s-1. + ustar, & ! The bottom friction velocity [Z s-1 ~> m s-1]. T_EOS, & ! The temperature used to calculate the partial derivatives - ! of density with T and S, in deg C. + ! of density with T and S [degC]. S_EOS, & ! The salinity used to calculate the partial derivatives - ! of density with T and S, in PSU. + ! of density with T and S [ppt]. dR_dT, & ! Partial derivative of the density in the bottom boundary - ! layer with temperature, in units of kg m-3 K-1. + ! layer with temperature [kg m-3 degC-1]. dR_dS, & ! Partial derivative of the density in the bottom boundary - ! layer with salinity, in units of kg m-3 psu-1. - press ! The pressure at which dR_dT and dR_dS are evaluated, in Pa. - real :: htot ! Sum of the layer thicknesses up to some - ! point, in H (i.e., m or kg m-2). - real :: htot_vel ! Sum of the layer thicknesses up to some - ! point, in H (i.e., m or kg m-2). - - real :: Rhtot ! Running sum of thicknesses times the - ! layer potential densities in H kg m-3. + ! layer with salinity [kg m-3 ppt-1]. + press ! The pressure at which dR_dT and dR_dS are evaluated [Pa]. + real :: htot ! Sum of the layer thicknesses up to some point [H ~> m or kg m-2]. + real :: htot_vel ! Sum of the layer thicknesses up to some point [H ~> m or kg m-2]. + + real :: Rhtot ! Running sum of thicknesses times the layer potential + ! densities [H kg m-3 ~> kg m-2 or kg2 m-5]. real, dimension(SZIB_(G),SZJ_(G)) :: & - D_u, & ! Bottom depth interpolated to u points, in m. + D_u, & ! Bottom depth interpolated to u points [Z ~> m]. mask_u ! A mask that disables any contributions from u points that - ! are land or past open boundary conditions, nondim., 0 or 1. + ! are land or past open boundary conditions [nondim], 0 or 1. real, dimension(SZI_(G),SZJB_(G)) :: & - D_v, & ! Bottom depth interpolated to v points, in m. + D_v, & ! Bottom depth interpolated to v points [Z ~> m]. mask_v ! A mask that disables any contributions from v points that - ! are land or past open boundary conditions, nondim., 0 or 1. + ! are land or past open boundary conditions [nondim], 0 or 1. real, dimension(SZIB_(G),SZK_(G)) :: & h_at_vel, & ! Layer thickness at a velocity point, using an upwind-biased ! second order accurate estimate based on the previous velocity - ! direction, in H. + ! direction [H ~> m or kg m-2]. h_vel, & ! Arithmetic mean of the layer thicknesses adjacent to a - ! velocity point, in H. + ! velocity point [H ~> m or kg m-2]. T_vel, & ! Arithmetic mean of the layer temperatures adjacent to a - ! velocity point, in deg C. + ! velocity point [degC]. S_vel, & ! Arithmetic mean of the layer salinities adjacent to a - ! velocity point, in PSU. + ! velocity point [ppt]. Rml_vel ! Arithmetic mean of the layer coordinate densities adjacent - ! to a velocity point, in kg m-3. + ! to a velocity point [kg m-3]. real :: h_vel_pos ! The arithmetic mean thickness at a velocity point - ! plus H_neglect to avoid 0 values, in H. + ! plus H_neglect to avoid 0 values [H ~> m or kg m-2]. real :: ustarsq ! 400 times the square of ustar, times ! Rho0 divided by G_Earth and the conversion - ! from m to thickness units, in kg m-2 or kg2 m-5. - real :: cdrag_sqrt ! Square root of the drag coefficient, nd. + ! from m to thickness units [H kg m-3 ~> kg m-2 or kg2 m-5]. + real :: cdrag_sqrt_Z ! Square root of the drag coefficient, times a unit conversion + ! factor from lateral lengths to vertical depths [Z m-1 ~> 1]. + real :: cdrag_sqrt ! Square root of the drag coefficient [nondim]. real :: oldfn ! The integrated energy required to ! entrain up to the bottom of the layer, - ! divided by G_Earth, in H kg m-3. + ! divided by G_Earth [H kg m-3 ~> kg m-2 or kg2 m-5]. real :: Dfn ! The increment in oldfn for entraining - ! the layer, in H kg m-3. + ! the layer [H kg m-3 ~> kg m-2 or kg2 m-5]. real :: Dh ! The increment in layer thickness from - ! the present layer, in H. - real :: bbl_thick ! The thickness of the bottom boundary layer in m. + ! the present layer [H ~> m or kg m-2]. + real :: bbl_thick ! The thickness of the bottom boundary layer [H ~> m or kg m-2]. + real :: bbl_thick_Z ! The thickness of the bottom boundary layer [Z ~> m]. real :: C2f ! C2f = 2*f at velocity points. real :: U_bg_sq ! The square of an assumed background ! velocity, for calculating the mean ! magnitude near the bottom for use in the - ! quadratic bottom drag, in m2. + ! quadratic bottom drag [m2 s-2]. real :: hwtot ! Sum of the thicknesses used to calculate - ! the near-bottom velocity magnitude, in H. + ! the near-bottom velocity magnitude [H ~> m or kg m-2]. real :: hutot ! Running sum of thicknesses times the - ! velocity magnitudes, in H m s-1. - real :: Thtot ! Running sum of thickness times temperature, in H C. - real :: Shtot ! Running sum of thickness times salinity, in H psu. + ! velocity magnitudes [H m s-1 ~> m2 s-1 or kg m-1 s-1]. + real :: Thtot ! Running sum of thickness times temperature [degC H ~> degC m or degC kg m-2]. + real :: Shtot ! Running sum of thickness times salinity [ppt H ~> ppt m or ppt kg m-2]. real :: hweight ! The thickness of a layer that is within Hbbl - ! of the bottom, in H. - real :: v_at_u, u_at_v ! v at a u point or vice versa, m s-1. - real :: Rho0x400_G ! 400*Rho0/G_Earth, in kg s2 m-4. The 400 is a - ! constant proposed by Killworth and Edwards, 1999. + ! of the bottom [H ~> m or kg m-2]. + real :: v_at_u, u_at_v ! v at a u point or vice versa [m s-1]. + real :: Rho0x400_G ! 400*Rho0/G_Earth, times unit conversion factors + ! [kg s2 H m-3 Z-2 ~> kg s2 m-4 or kg2 s2 m-7]. + ! The 400 is a constant proposed by Killworth and Edwards, 1999. real, dimension(SZI_(G),SZJ_(G),max(GV%nk_rho_varies,1)) :: & - Rml ! The mixed layer coordinate density, in kg m-3. + Rml ! The mixed layer coordinate density [kg m-3]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate - ! density, in Pa (usually set to 2e7 Pa = 2000 dbar). + ! density [Pa] (usually set to 2e7 Pa = 2000 dbar). - ! The units H in the following are thickness units - typically m or kg m-2. - real :: D_vel ! The bottom depth at a velocity point, in H. - real :: Dp, Dm ! The depths at the edges of a velocity cell, in H. + real :: D_vel ! The bottom depth at a velocity point [H ~> m or kg m-2]. + real :: Dp, Dm ! The depths at the edges of a velocity cell [H ~> m or kg m-2]. real :: a ! a is the curvature of the bottom depth across a - ! cell, times the cell width squared, in H. - real :: a_3, a_12, C24_a ! a/3, a/12, and 24/a, in H, H, and H-1. + ! cell, times the cell width squared [H ~> m or kg m-2]. + real :: a_3, a_12 ! a/3 and a/12 [H ~> m or kg m-2]. + real :: C24_a ! 24/a [H-1 ~> m-1 or m2 kg-1]. real :: slope ! The absolute value of the bottom depth slope across - ! a cell times the cell width, in H. + ! a cell times the cell width [H ~> m or kg m-2]. real :: apb_4a, ax2_3apb ! Various nondimensional ratios of a and slope. - real :: a2x48_apb3, Iapb, Ibma_2 ! Combinations of a and slope with units of H-1. - ! All of the following "volumes" have units of meters as they are normalized + real :: a2x48_apb3, Iapb, Ibma_2 ! Combinations of a and slope [H-1 ~> m-1 or m2 kg-1]. + ! All of the following "volumes" have units of thickness because they are normalized ! by the full horizontal area of a velocity cell. - real :: Vol_open ! The cell volume above which it is open, in H. - real :: Vol_direct ! With less than Vol_direct (in H), there is a direct + real :: Vol_open ! The cell volume above which it is open [H ~> m or kg m-2]. + real :: Vol_direct ! With less than Vol_direct [H ~> m or kg m-2], there is a direct ! solution of a cubic equation for L. real :: Vol_2_reg ! The cell volume above which there are two separate - ! open areas that must be integrated, in H. + ! open areas that must be integrated [H ~> m or kg m-2]. real :: vol ! The volume below the interface whose normalized - ! width is being sought, in H. + ! width is being sought [H ~> m or kg m-2]. real :: vol_below ! The volume below the interface below the one that - ! is currently under consideration, in H. + ! is currently under consideration [H ~> m or kg m-2]. real :: Vol_err ! The error in the volume with the latest estimate of - ! L, or the error for the interface below, in H. - real :: Vol_quit ! The volume error below which to quit iterating, in H. - real :: Vol_tol ! A volume error tolerance, in H. + ! L, or the error for the interface below [H ~> m or kg m-2]. + real :: Vol_quit ! The volume error below which to quit iterating [H ~> m or kg m-2]. + real :: Vol_tol ! A volume error tolerance [H ~> m or kg m-2]. real :: L(SZK_(G)+1) ! The fraction of the full cell width that is open at ! the depth of each interface, nondimensional. - real :: L_direct ! The value of L above volume Vol_direct, nondim. + real :: L_direct ! The value of L above volume Vol_direct [nondim]. real :: L_max, L_min ! Upper and lower bounds on the correct value for L. real :: Vol_err_max ! The volume errors for the upper and lower bounds on - real :: Vol_err_min ! the correct value for L, in H. - real :: Vol_0 ! A deeper volume with known width L0, in H. - real :: L0 ! The value of L above volume Vol_0, nondim. - real :: dVol ! vol - Vol_0, in H. + real :: Vol_err_min ! the correct value for L [H ~> m or kg m-2]. + real :: Vol_0 ! A deeper volume with known width L0 [H ~> m or kg m-2]. + real :: L0 ! The value of L above volume Vol_0 [nondim]. + real :: dVol ! vol - Vol_0 [H ~> m or kg m-2]. real :: dV_dL2 ! The partial derivative of volume with L squared - ! evaluated at L=L0, in H. + ! evaluated at L=L0 [H ~> m or kg m-2]. real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected, in H. - real :: ustH ! ustar converted to units of H s-1. - real :: root ! A temporary variable with units of H s-1. - real :: H_to_m, m_to_H ! Local copies of unit conversion factors. - - real :: Cell_width ! The transverse width of the velocity cell, in m. - real :: Rayleigh ! A nondimensional value that is multiplied by the - ! layer's velocity magnitude to give the Rayleigh - ! drag velocity. + ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: ustH ! ustar converted to units of H s-1 [H s-1 ~> m s-1 or kg m-2 s-1]. + real :: root ! A temporary variable [H s-1 ~> m s-1 or kg m-2 s-1]. + + real :: Cell_width ! The transverse width of the velocity cell [m]. + real :: Rayleigh ! A nondimensional value that is multiplied by the layer's + ! velocity magnitude to give the Rayleigh drag velocity, times + ! a lateral to vertical distance conversion factor [Z L-1 ~> 1]. real :: gam ! The ratio of the change in the open interface width - ! to the open interface width atop a cell, nondim. + ! to the open interface width atop a cell [nondim]. real :: BBL_frac ! The fraction of a layer's drag that goes into the - ! viscous bottom boundary layer, nondim. + ! viscous bottom boundary layer [nondim]. real :: BBL_visc_frac ! The fraction of all the drag that is expressed as - ! a viscous bottom boundary layer, nondim. + ! a viscous bottom boundary layer [nondim]. real, parameter :: C1_3 = 1.0/3.0, C1_6 = 1.0/6.0, C1_12 = 1.0/12.0 real :: C2pi_3 ! An irrational constant, 2/3 pi. real :: tmp ! A temporary variable. @@ -308,9 +265,8 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, CS, symmetrize) Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB nkmb = GV%nk_rho_varies ; nkml = GV%nkml h_neglect = GV%H_subroundoff - Rho0x400_G = 400.0*(GV%Rho0/GV%g_Earth)*GV%m_to_H - Vol_quit = 0.9*GV%Angstrom + h_neglect - H_to_m = GV%H_to_m ; m_to_H = GV%m_to_H + Rho0x400_G = 400.0*(GV%Rho0/GV%g_Earth) * US%Z_to_m**2 * GV%Z_to_H + Vol_quit = 0.9*GV%Angstrom_H + h_neglect C2pi_3 = 8.0*atan(1.0)/3.0 if (.not.associated(CS)) call MOM_error(FATAL,"MOM_vert_friction(BBL): "//& @@ -332,11 +288,12 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, CS, symmetrize) OBC => CS%OBC U_bg_sq = CS%drag_bg_vel * CS%drag_bg_vel - cdrag_sqrt=sqrt(CS%cdrag) + cdrag_sqrt = sqrt(CS%cdrag) + cdrag_sqrt_Z = US%m_to_Z * sqrt(CS%cdrag) K2 = max(nkmb+1, 2) ! With a linear drag law, the friction velocity is already known. -! if (CS%linear_drag) ustar(:) = cdrag_sqrt*CS%drag_bg_vel +! if (CS%linear_drag) ustar(:) = cdrag_sqrt_Z*CS%drag_bg_vel if ((nkml>0) .and. .not.use_BBL_EOS) then do i=Isq,Ieq+1 ; p_ref(i) = tv%P_ref ; enddo @@ -401,20 +358,10 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, CS, symmetrize) if (.not.use_BBL_EOS) Rml_vel(:,:) = 0.0 -!$OMP parallel do default(none) shared(u, v, h, tv, visc, G, GV, CS, Rml, is, ie, js, je, & -!$OMP nz, Isq, Ieq, Jsq, Jeq, nkmb, h_neglect, Rho0x400_G,& -!$OMP C2pi_3, U_bg_sq, cdrag_sqrt,K2,use_BBL_EOS,OBC, & -!$OMP maxitt,nkml,m_to_H,H_to_m,Vol_quit,D_u,D_v,mask_u,mask_v) & -!$OMP private(do_i,h_at_vel,htot_vel,hwtot,hutot,Thtot,Shtot, & -!$OMP hweight,v_at_u,u_at_v,ustar,T_EOS,S_EOS,press, & -!$OMP dR_dT, dR_dS,ustarsq,htot,T_vel,S_vel,Rml_vel, & -!$OMP oldfn,Dfn,Dh,Rhtot,C2f,ustH,root,bbl_thick, & -!$OMP D_vel,tmp,Dp,Dm,a_3,a,a_12,slope,Vol_open,Vol_2_reg,& -!$OMP C24_a,apb_4a,Iapb,a2x48_apb3,ax2_3apb,Vol_direct, & -!$OMP L_direct,Ibma_2,L,vol,vol_below,Vol_err,h_vel_pos, & -!$OMP BBL_visc_frac,h_vel,L0,Vol_0,dV_dL2,dVol,L_max, & -!$OMP L_min,Vol_err_min,Vol_err_max,BBL_frac,Cell_width, & -!$OMP gam,Rayleigh, Vol_tol, tmp_val_m1_to_p1) + !$OMP parallel do default(private) shared(u,v,h,tv,visc,G,GV,US,CS,Rml,is,ie,js,je,nz,nkmb, & + !$OMP nkml,Isq,Ieq,Jsq,Jeq,h_neglect,Rho0x400_G,C2pi_3, & + !$OMP U_bg_sq,cdrag_sqrt_Z,cdrag_sqrt,K2,use_BBL_EOS, & + !$OMP OBC,maxitt,Vol_quit,D_u,D_v,mask_u,mask_v) do j=Jsq,Jeq ; do m=1,2 if (m==1) then @@ -548,7 +495,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, CS, symmetrize) if (htot_vel>=CS%Hbbl) exit ! terminate the k loop hweight = MIN(CS%Hbbl - htot_vel, h_at_vel(i,k)) - if (hweight < 1.5*GV%Angstrom + h_neglect) cycle + if (hweight < 1.5*GV%Angstrom_H + h_neglect) cycle htot_vel = htot_vel + h_at_vel(i,k) hwtot = hwtot + hweight @@ -570,9 +517,9 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, CS, symmetrize) enddo ! end of k loop if (.not.CS%linear_drag .and. (hwtot > 0.0)) then - ustar(i) = cdrag_sqrt*hutot/hwtot + ustar(i) = cdrag_sqrt_Z*hutot/hwtot else - ustar(i) = cdrag_sqrt*CS%drag_bg_vel + ustar(i) = cdrag_sqrt_Z*CS%drag_bg_vel endif if (use_BBL_EOS) then ; if (hwtot > 0.0) then @@ -582,7 +529,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, CS, symmetrize) endif ; endif endif ; enddo else - do i=is,ie ; ustar(i) = cdrag_sqrt*CS%drag_bg_vel ; enddo + do i=is,ie ; ustar(i) = cdrag_sqrt_Z*CS%drag_bg_vel ; enddo endif ! Not linear_drag if (use_BBL_EOS) then @@ -643,7 +590,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, CS, symmetrize) if (oldfn >= ustarsq) then cycle - else if ((oldfn + Dfn) <= ustarsq) then + elseif ((oldfn + Dfn) <= ustarsq) then Dh = h_at_vel(i,k) else Dh = h_at_vel(i,k) * sqrt((ustarsq-oldfn)/Dfn) @@ -659,7 +606,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, CS, symmetrize) if (oldfn >= ustarsq) then cycle - else if ((oldfn + Dfn) <= ustarsq) then + elseif ((oldfn + Dfn) <= ustarsq) then Dh = h_at_vel(i,k) else Dh = h_at_vel(i,k) * sqrt((ustarsq-oldfn)/Dfn) @@ -684,7 +631,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, CS, symmetrize) if (CS%cdrag * U_bg_sq <= 0.0) then ! This avoids NaNs and overflows, and could be used in all cases, ! but is not bitwise identical to the current code. - ustH = ustar(i)*m_to_H ; root = sqrt(0.25*ustH**2 + (htot*C2f)**2) + ustH = ustar(i)*GV%Z_to_H ; root = sqrt(0.25*ustH**2 + (htot*C2f)**2) if (htot*ustH <= (CS%BBL_thick_min+h_neglect) * (0.5*ustH + root)) then bbl_thick = CS%BBL_thick_min else @@ -692,7 +639,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, CS, symmetrize) endif else bbl_thick = htot / (0.5 + sqrt(0.25 + htot*htot*C2f*C2f/ & - ((ustar(i)*ustar(i)) * (m_to_H**2) ))) + ((ustar(i)*ustar(i)) * (GV%Z_to_H**2) ))) if (bbl_thick < CS%BBL_thick_min) bbl_thick = CS%BBL_thick_min endif @@ -723,7 +670,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, CS, symmetrize) if (Dm > Dp) then ; tmp = Dp ; Dp = Dm ; Dm = tmp ; endif ! Convert the D's to the units of thickness. - Dp = m_to_H*Dp ; Dm = m_to_H*Dm ; D_vel = m_to_H*D_vel + Dp = GV%Z_to_H*Dp ; Dm = GV%Z_to_H*Dm ; D_vel = GV%Z_to_H*D_vel a_3 = (Dp + Dm - 2.0*D_vel) ; a = 3.0*a_3 ; a_12 = 0.25*a_3 slope = Dp - Dm @@ -822,18 +769,18 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, CS, symmetrize) dV_dL2 = 0.5*(slope+a) - a*L0 ; dVol = (vol-Vol_0) ! dV_dL2 = 0.5*(slope+a) - a*L0 ; dVol = max(vol-Vol_0, 0.0) - !### The following code is more robust when GV%Angstrom=0, but it + !### The following code is more robust when GV%Angstrom_H=0, but it !### changes answers. - ! Vol_tol = max(0.5*GV%Angstrom + GV%H_subroundoff, 1e-14*vol) - ! Vol_quit = max(0.9*GV%Angstrom + GV%H_subroundoff, 1e-14*vol) + ! Vol_tol = max(0.5*GV%Angstrom_H + GV%H_subroundoff, 1e-14*vol) + ! Vol_quit = max(0.9*GV%Angstrom_H + GV%H_subroundoff, 1e-14*vol) ! if (dVol <= 0.0) then ! L(K) = L0 ! Vol_err = 0.5*(L(K)*L(K))*(slope + a_3*(3.0-4.0*L(K))) - vol ! elseif (a*a*dVol**3 < Vol_tol*dV_dL2**2 * & ! (dV_dL2*Vol_tol - 2.0*a*L0*dVol)) then - if (a*a*dVol**3 < GV%Angstrom*dV_dL2**2 * & - (0.25*dV_dL2*GV%Angstrom - a*L0*dVol)) then + if (a*a*dVol**3 < GV%Angstrom_H*dV_dL2**2 * & + (0.25*dV_dL2*GV%Angstrom_H - a*L0*dVol)) then ! One iteration of Newton's method should give an estimate ! that is accurate to within Vol_tol. L(K) = sqrt(L0*L0 + dVol / dV_dL2) @@ -882,9 +829,9 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, CS, symmetrize) if (m==1) then ; Cell_width = G%dy_Cu(I,j) else ; Cell_width = G%dx_Cv(i,J) ; endif gam = 1.0 - L(K+1)/L(K) - Rayleigh = CS%cdrag * (L(K)-L(K+1)) * (1.0-BBL_frac) * & - (12.0*CS%c_Smag*h_vel_pos) / (12.0*CS%c_Smag*h_vel_pos + m_to_H * & - CS%cdrag * gam*(1.0-gam)*(1.0-1.5*gam) * L(K)**2 * Cell_width) + Rayleigh = US%m_to_Z * CS%cdrag * (L(K)-L(K+1)) * (1.0-BBL_frac) * & + (12.0*CS%c_Smag*h_vel_pos) / (12.0*CS%c_Smag*h_vel_pos + & + GV%m_to_H * CS%cdrag * gam*(1.0-gam)*(1.0-1.5*gam) * L(K)**2 * Cell_width) else ! This layer feels no drag. Rayleigh = 0.0 endif @@ -905,27 +852,27 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, CS, symmetrize) enddo ! k loop to determine L(K). - bbl_thick = bbl_thick * H_to_m + bbl_thick_Z = bbl_thick * GV%H_to_Z if (m==1) then visc%kv_bbl_u(I,j) = max(CS%KV_BBL_min, & - cdrag_sqrt*ustar(i)*bbl_thick*BBL_visc_frac) - visc%bbl_thick_u(I,j) = bbl_thick + cdrag_sqrt*ustar(i)*bbl_thick_Z*BBL_visc_frac) + visc%bbl_thick_u(I,j) = bbl_thick_Z else visc%kv_bbl_v(i,J) = max(CS%KV_BBL_min, & - cdrag_sqrt*ustar(i)*bbl_thick*BBL_visc_frac) - visc%bbl_thick_v(i,J) = bbl_thick + cdrag_sqrt*ustar(i)*bbl_thick_Z*BBL_visc_frac) + visc%bbl_thick_v(i,J) = bbl_thick_Z endif else ! Not Channel_drag. ! Here the near-bottom viscosity is set to a value which will give ! the correct stress when the shear occurs over bbl_thick. - bbl_thick = bbl_thick * H_to_m + bbl_thick_Z = bbl_thick * GV%H_to_Z if (m==1) then - visc%kv_bbl_u(I,j) = max(CS%KV_BBL_min, cdrag_sqrt*ustar(i)*bbl_thick) - visc%bbl_thick_u(I,j) = bbl_thick + visc%kv_bbl_u(I,j) = max(CS%KV_BBL_min, cdrag_sqrt*ustar(i)*bbl_thick_Z) + visc%bbl_thick_u(I,j) = bbl_thick_Z else - visc%kv_bbl_v(i,J) = max(CS%KV_BBL_min, cdrag_sqrt*ustar(i)*bbl_thick) - visc%bbl_thick_v(i,J) = bbl_thick + visc%kv_bbl_v(i,J) = max(CS%KV_BBL_min, cdrag_sqrt*ustar(i)*bbl_thick_Z) + visc%bbl_thick_v(i,J) = bbl_thick_Z endif endif endif ; enddo ! end of i loop @@ -947,29 +894,34 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, CS, symmetrize) if (CS%debug) then if (associated(visc%Ray_u) .and. associated(visc%Ray_v)) & - call uvchksum("Ray [uv]", visc%Ray_u, visc%Ray_v, G%HI,haloshift=0) + call uvchksum("Ray [uv]", visc%Ray_u, visc%Ray_v, G%HI, haloshift=0, scale=US%Z_to_m) if (associated(visc%kv_bbl_u) .and. associated(visc%kv_bbl_v)) & - call uvchksum("kv_bbl_[uv]", visc%kv_bbl_u, visc%kv_bbl_v, G%HI,haloshift=0) + call uvchksum("kv_bbl_[uv]", visc%kv_bbl_u, visc%kv_bbl_v, G%HI, haloshift=0, scale=US%Z_to_m**2) if (associated(visc%bbl_thick_u) .and. associated(visc%bbl_thick_v)) & call uvchksum("bbl_thick_[uv]", visc%bbl_thick_u, & - visc%bbl_thick_v, G%HI,haloshift=0) + visc%bbl_thick_v, G%HI, haloshift=0, scale=US%Z_to_m) endif end subroutine set_viscous_BBL !> This subroutine finds a thickness-weighted value of v at the u-points. function set_v_at_u(v, h, G, i, j, k, mask2dCv, OBC) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< The meridional velocity, in m s-1 - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - integer, intent(in) :: i, j, k - real, dimension(SZI_(G),SZJB_(G)), intent(in) :: mask2dCv - type(ocean_OBC_type), pointer :: OBC - real :: set_v_at_u + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + 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] + integer, intent(in) :: i !< The i-index of the u-location to work on. + integer, intent(in) :: j !< The j-index of the u-location to work on. + integer, intent(in) :: k !< The k-index of the u-location to work on. + real, dimension(SZI_(G),SZJB_(G)),& + intent(in) :: mask2dCv !< A multiplicative mask of the v-points + type(ocean_OBC_type), pointer :: OBC !< A pointer to an open boundary condition structure + real :: set_v_at_u !< The retur value of v at u points [m s-1]. ! This subroutine finds a thickness-weighted value of v at the u-points. - real :: hwt(0:1,-1:0) ! Masked weights used to average u onto v, in H. - real :: hwt_tot ! The sum of the masked thicknesses, in H. + real :: hwt(0:1,-1:0) ! Masked weights used to average u onto v [H ~> m or kg m-2]. + real :: hwt_tot ! The sum of the masked thicknesses [H ~> m or kg m-2]. integer :: i0, j0, i1, j1 do j0 = -1,0 ; do i0 = 0,1 ; i1 = i+i0 ; J1 = J+j0 @@ -998,16 +950,21 @@ end function set_v_at_u !> This subroutine finds a thickness-weighted value of u at the v-points. function set_u_at_v(u, h, G, i, j, k, mask2dCu, OBC) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< The zonal velocity, in m s-1 - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - integer, intent(in) :: i, j, k - real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: mask2dCu - type(ocean_OBC_type), pointer :: OBC - real :: set_u_at_v + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(in) :: u !< The zonal velocity [m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + integer, intent(in) :: i !< The i-index of the u-location to work on. + integer, intent(in) :: j !< The j-index of the u-location to work on. + integer, intent(in) :: k !< The k-index of the u-location to work on. + real, dimension(SZIB_(G),SZJ_(G)), & + intent(in) :: mask2dCu !< A multiplicative mask of the u-points + type(ocean_OBC_type), pointer :: OBC !< A pointer to an open boundary condition structure + real :: set_u_at_v !< The return value of u at v points [m s-1]. ! This subroutine finds a thickness-weighted value of u at the v-points. - real :: hwt(-1:0,0:1) ! Masked weights used to average u onto v, in H. - real :: hwt_tot ! The sum of the masked thicknesses, in H. + real :: hwt(-1:0,0:1) ! Masked weights used to average u onto v [H ~> m or kg m-2]. + real :: hwt_tot ! The sum of the masked thicknesses [H ~> m or kg m-2]. integer :: i0, j0, i1, j1 do j0 = 0,1 ; do i0 = -1,0 ; I1 = I+i0 ; j1 = j+j0 @@ -1033,146 +990,125 @@ function set_u_at_v(u, h, G, i, j, k, mask2dCu, OBC) end function set_u_at_v -!> The following subroutine calculates the thickness of the surface boundary -!! layer for applying an elevated viscosity. A bulk Richardson criterion or -!! the thickness of the topmost NKML layers (with a bulk mixed layer) are -!! currently used. The thicknesses are given in terms of fractional layers, so -!! that this thickness will move as the thickness of the topmost layers change. -subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, CS, symmetrize) +!> Calculates the thickness of the surface boundary layer for applying an elevated viscosity. +!! +!! A bulk Richardson criterion or the thickness of the topmost NKML layers (with a bulk mixed layer) +!! are currently used. The thicknesses are given in terms of fractional layers, so that this +!! thickness will move as the thickness of the topmost layers change. +subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS, symmetrize) 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, in m s-1. + intent(in) :: u !< The zonal velocity [m s-1]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & - intent(in) :: v !< The meridional velocity, in m s-1. + intent(in) :: v !< The meridional velocity [m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2). + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any available !! thermodynamic fields. Absent fields have !! NULL ptrs. type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces type(vertvisc_type), intent(inout) :: visc !< A structure containing vertical viscosities and !! related fields. - real, intent(in) :: dt !< Time increment in s. + real, intent(in) :: dt !< Time increment [s]. type(set_visc_CS), pointer :: CS !< The control structure returned by a previous !! call to vertvisc_init. logical, optional, intent(in) :: symmetrize !< If present and true, do extra calculations - !! of those values in visc that would be - !! calculated with symmetric memory. - -! The following subroutine calculates the thickness of the surface boundary -! layer for applying an elevated viscosity. A bulk Richardson criterion or -! the thickness of the topmost NKML layers (with a bulk mixed layer) are -! currently used. The thicknesses are given in terms of fractional layers, so -! that this thickness will move as the thickness of the topmost layers change. -! -! Arguments: u - Zonal velocity, in m s-1. -! (in) v - Meridional velocity, in m s-1. -! (in) h - Layer thickness, in m or kg m-2. In the comments below, -! the units of h are denoted as H. -! (in) tv - A structure containing pointers to any available -! thermodynamic fields. Absent fields have NULL ptrs. -! (in) forces - A structure containing pointers to mechanical -! forcing fields. Unused fields have NULL ptrs. -! (out) visc - A structure containing vertical viscosities and related -! fields. -! (in) dt - Time increment in s. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - The control structure returned by a previous call to -! vertvisc_init. - + !! of those values in visc that would be + !! calculated with symmetric memory. + ! Local variables real, dimension(SZIB_(G)) :: & htot, & ! The total depth of the layers being that are within the - ! surface mixed layer, in H. + ! surface mixed layer [H ~> m or kg m-2]. Thtot, & ! The integrated temperature of layers that are within the - ! surface mixed layer, in H degC. + ! surface mixed layer [H degC ~> m degC or kg degC m-2]. Shtot, & ! The integrated salt of layers that are within the - ! surface mixed layer H PSU. - Rhtot, & ! The integrated density of layers that are within the - ! surface mixed layer, in H kg m-3. Rhtot is only used if no + ! surface mixed layer [H ppt ~> m ppt or kg ppt m-2]. + Rhtot, & ! The integrated density of layers that are within the surface mixed layer + ! [H kg m-3 ~> kg m-2 or kg2 m-5]. Rhtot is only used if no ! equation of state is used. uhtot, & ! The depth integrated zonal and meridional velocities within - vhtot, & ! the surface mixed layer, in H m s-1. - Idecay_len_TKE, & ! The inverse of a turbulence decay length scale, in H-1. + vhtot, & ! the surface mixed layer [H m s-1 ~> m2 s-1 or kg m-1 s-1]. + Idecay_len_TKE, & ! The inverse of a turbulence decay length scale [H-1 ~> m-1 or m2 kg-1]. dR_dT, & ! Partial derivative of the density at the base of layer nkml - ! (roughly the base of the mixed layer) with temperature, in - ! units of kg m-3 K-1. + ! (roughly the base of the mixed layer) with temperature [kg m-3 degC-1]. dR_dS, & ! Partial derivative of the density at the base of layer nkml - ! (roughly the base of the mixed layer) with salinity, in units - ! of kg m-3 psu-1. - ustar, & ! The surface friction velocity under ice shelves, in m s-1. - press, & ! The pressure at which dR_dT and dR_dS are evaluated, in Pa. - T_EOS, & ! T_EOS and S_EOS are the potential temperature and salnity at which dR_dT and dR_dS - S_EOS ! which dR_dT and dR_dS are evaluated, in degC and PSU. + ! (roughly the base of the mixed layer) with salinity [kg m-3 ppt-1]. + ustar, & ! The surface friction velocity under ice shelves [Z s-1 ~> m s-1]. + press, & ! The pressure at which dR_dT and dR_dS are evaluated [Pa]. + T_EOS, & ! The potential temperature at which dR_dT and dR_dS are evaluated [degC] + S_EOS ! The salinity at which dR_dT and dR_dS are evaluated [ppt]. real, dimension(SZIB_(G),SZJ_(G)) :: & mask_u ! A mask that disables any contributions from u points that - ! are land or past open boundary conditions, nondim., 0 or 1. + ! are land or past open boundary conditions [nondim], 0 or 1. real, dimension(SZI_(G),SZJB_(G)) :: & mask_v ! A mask that disables any contributions from v points that - ! are land or past open boundary conditions, nondim., 0 or 1. + ! are land or past open boundary conditions [nondim], 0 or 1. real :: h_at_vel(SZIB_(G),SZK_(G))! Layer thickness at velocity points, ! using an upwind-biased second order accurate estimate based - ! on the previous velocity direction, in H. + ! on the previous velocity direction [H ~> m or kg m-2]. integer :: k_massive(SZIB_(G)) ! The k-index of the deepest layer yet found ! that has more than h_tiny thickness and will be in the ! viscous mixed layer. real :: Uh2 ! The squared magnitude of the difference between the velocity ! integrated through the mixed layer and the velocity of the - ! interior layer layer times the depth of the the mixed layer, - ! in H2 m2 s-2. - real :: htot_vel ! Sum of the layer thicknesses up to some - ! point, in H (i.e., m or kg m-2). + ! interior layer layer times the depth of the the mixed layer + ! [H2 m2 s-2 ~> m4 s-2 or kg2 m-2 s-2]. + real :: htot_vel ! Sum of the layer thicknesses up to some point [H ~> m or kg m-2]. real :: hwtot ! Sum of the thicknesses used to calculate - ! the near-bottom velocity magnitude, in H. + ! the near-bottom velocity magnitude [H ~> m or kg m-2]. real :: hutot ! Running sum of thicknesses times the - ! velocity magnitudes, in H m s-1. + ! velocity magnitudes [H m s-1 ~> m2 s-1 or kg m-1 s-1]. real :: hweight ! The thickness of a layer that is within Hbbl - ! of the bottom, in H. - - real :: hlay ! The layer thickness at velocity points, in H. - real :: I_2hlay ! 1 / 2*hlay, in H-1. - real :: T_lay ! The layer temperature at velocity points, in deg C. - real :: S_lay ! The layer salinity at velocity points, in PSU. - real :: Rlay ! The layer potential density at velocity points, in kg m-3. - real :: Rlb ! The potential density of the layer below, in kg m-3. - real :: v_at_u ! The meridonal velocity at a zonal velocity point in m s-1. - real :: u_at_v ! The zonal velocity at a meridonal velocity point in m s-1. + ! of the bottom [H ~> m or kg m-2]. + real :: tbl_thick_Z ! The thickness of the top boundary layer [Z ~> m]. + + real :: hlay ! The layer thickness at velocity points [H ~> m or kg m-2]. + real :: I_2hlay ! 1 / 2*hlay [H-1 ~> m-1 or m2 kg-1]. + real :: T_lay ! The layer temperature at velocity points [degC]. + real :: S_lay ! The layer salinity at velocity points [ppt]. + real :: Rlay ! The layer potential density at velocity points [kg m-3]. + real :: Rlb ! The potential density of the layer below [kg m-3]. + real :: v_at_u ! The meridonal velocity at a zonal velocity point [m s-1]. + real :: u_at_v ! The zonal velocity at a meridonal velocity point [m s-1]. real :: gHprime ! The mixed-layer internal gravity wave speed squared, based ! on the mixed layer thickness and density difference across - ! the base of the mixed layer, in m2 s-2. + ! the base of the mixed layer [m2 s-2]. real :: RiBulk ! The bulk Richardson number below which water is in the ! viscous mixed layer, including reduction for turbulent ! decay. Nondimensional. real :: dt_Rho0 ! The time step divided by the conversion from the layer - ! thickness to layer mass, in s H m2 kg-1. - real :: g_H_Rho0 ! The gravitational acceleration times the conversion from - ! H to m divided by the mean density, in m5 s-2 H-1 kg-1. + ! thickness to layer mass [s H m2 kg-1 ~> s m3 kg-1 or s]. + real :: g_H_Rho0 ! The gravitational acceleration times the conversion from H to m divided + ! by the mean density [m5 s-2 H-1 kg-1 ~> m4 s-2 kg-1 or m7 s-2 kg-2]. real :: ustarsq ! 400 times the square of ustar, times ! Rho0 divided by G_Earth and the conversion - ! from m to thickness units, in kg m-2 or kg2 m-5. - real :: cdrag_sqrt ! Square root of the drag coefficient, nd. + ! from m to thickness units [H kg m-3 ~> kg m-2 or kg2 m-5]. + real :: cdrag_sqrt_Z ! Square root of the drag coefficient, times a unit conversion + ! factor from lateral lengths to vertical depths [Z m-1 ~> 1]. + real :: cdrag_sqrt ! Square root of the drag coefficient [nondim]. real :: oldfn ! The integrated energy required to ! entrain up to the bottom of the layer, - ! divided by G_Earth, in H kg m-3. + ! divided by G_Earth [H kg m-3 ~> kg m-2 or kg2 m-5]. real :: Dfn ! The increment in oldfn for entraining - ! the layer, in H kg m-3. + ! the layer [H kg m-3 ~> kg m-2 or kg2 m-5]. real :: Dh ! The increment in layer thickness from - ! the present layer, in H. + ! the present layer [H ~> m or kg m-2]. real :: U_bg_sq ! The square of an assumed background velocity, for ! calculating the mean magnitude near the top for use in - ! the quadratic surface drag, in m2. - real :: h_tiny ! A very small thickness, in H. Layers that are less than + ! the quadratic surface drag [m2 s-2]. + real :: h_tiny ! A very small thickness [H ~> m or kg m-2]. Layers that are less than ! h_tiny can not be the deepest in the viscous mixed layer. real :: absf ! The absolute value of f averaged to velocity points, s-1. - real :: U_star ! The friction velocity at velocity points, in m s-1. + real :: U_star ! The friction velocity at velocity points [Z s-1 ~> m s-1]. real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected, in H. - real :: Rho0x400_G ! 400*Rho0/G_Earth, in kg s2 m-4. The 400 is a - ! constant proposed by Killworth and Edwards, 1999. - real :: H_to_m, m_to_H ! Local copies of unit conversion factors. - real :: ustar1 ! ustar in units of H/s - real :: h2f2 ! (h*2*f)^2 + ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: Rho0x400_G ! 400*Rho0/G_Earth, times unit conversion factors + ! [kg s2 H m-3 Z-2 ~> kg s2 m-4 or kg2 s2 m-7]. + ! The 400 is a constant proposed by Killworth and Edwards, 1999. + real :: ustar1 ! ustar [H s-1 ~> m s-1 or kg m-2 s-1] + real :: h2f2 ! (h*2*f)^2 [H2 s-2 ~> m2 s-2 or kg2 m-4 s-2] logical :: use_EOS, do_any, do_any_shelf, do_i(SZIB_(G)) integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, K2, nkmb, nkml, n type(ocean_OBC_type), pointer :: OBC => NULL() @@ -1190,17 +1126,17 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, CS, symmetrize) Jsq = js-1 ; Isq = is-1 endif ; endif - Rho0x400_G = 400.0*(GV%Rho0/GV%g_Earth)*GV%m_to_H + Rho0x400_G = 400.0*(GV%Rho0/GV%g_Earth) * US%Z_to_m**2 * GV%Z_to_H U_bg_sq = CS%drag_bg_vel * CS%drag_bg_vel - cdrag_sqrt=sqrt(CS%cdrag) + cdrag_sqrt = sqrt(CS%cdrag) + cdrag_sqrt_Z = US%m_to_Z * sqrt(CS%cdrag) OBC => CS%OBC use_EOS = associated(tv%eqn_of_state) dt_Rho0 = dt/GV%H_to_kg_m2 h_neglect = GV%H_subroundoff - h_tiny = 2.0*GV%Angstrom + h_neglect - g_H_Rho0 = (GV%g_Earth * GV%H_to_m) / GV%Rho0 - H_to_m = GV%H_to_m ; m_to_H = GV%m_to_H + h_tiny = 2.0*GV%Angstrom_H + h_neglect + g_H_Rho0 = (GV%g_Earth*GV%H_to_Z) / GV%Rho0 if (associated(forces%frac_shelf_u) .neqv. associated(forces%frac_shelf_v)) & call MOM_error(FATAL, "set_viscous_ML: one of forces%frac_shelf_u and "//& @@ -1209,29 +1145,14 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, CS, symmetrize) if (associated(forces%frac_shelf_u)) then ! This configuration has ice shelves, and the appropriate variables need to ! be allocated. - if (.not.associated(visc%tauy_shelf)) then - allocate(visc%tauy_shelf(G%isd:G%ied,G%JsdB:G%JedB)) - visc%tauy_shelf(:,:) = 0.0 - endif - if (.not.associated(visc%tbl_thick_shelf_u)) then - allocate(visc%tbl_thick_shelf_u(G%IsdB:G%IedB,G%jsd:G%jed)) - visc%tbl_thick_shelf_u(:,:) = 0.0 - endif - if (.not.associated(visc%tbl_thick_shelf_v)) then - allocate(visc%tbl_thick_shelf_v(G%isd:G%ied,G%JsdB:G%JedB)) - visc%tbl_thick_shelf_v(:,:) = 0.0 - endif - if (.not.associated(visc%kv_tbl_shelf_u)) then - allocate(visc%kv_tbl_shelf_u(G%IsdB:G%IedB,G%jsd:G%jed)) - visc%kv_tbl_shelf_u(:,:) = 0.0 - endif - if (.not.associated(visc%kv_tbl_shelf_v)) then - allocate(visc%kv_tbl_shelf_v(G%isd:G%ied,G%JsdB:G%JedB)) - visc%kv_tbl_shelf_v(:,:) = 0.0 - endif + call safe_alloc_ptr(visc%tauy_shelf, G%isd, G%ied, G%JsdB, G%JedB) + call safe_alloc_ptr(visc%tbl_thick_shelf_u, G%IsdB, G%IedB, G%jsd, G%jed) + call safe_alloc_ptr(visc%tbl_thick_shelf_v, G%isd, G%ied, G%JsdB, G%JedB) + call safe_alloc_ptr(visc%kv_tbl_shelf_u, G%IsdB, G%IedB, G%jsd, G%jed) + call safe_alloc_ptr(visc%kv_tbl_shelf_v, G%isd, G%ied, G%JsdB, G%JedB) ! With a linear drag law, the friction velocity is already known. -! if (CS%linear_drag) ustar(:) = cdrag_sqrt*CS%drag_bg_vel +! if (CS%linear_drag) ustar(:) = cdrag_sqrt_Z*CS%drag_bg_vel endif !$OMP parallel do default(shared) @@ -1262,16 +1183,9 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, CS, symmetrize) endif enddo ; endif -!$OMP parallel do default(none) shared(u, v, h, tv, forces, visc, dt, G, GV, CS, use_EOS, & -!$OMP dt_Rho0, h_neglect, h_tiny, g_H_Rho0,js,je,OBC, & -!$OMP H_to_m, m_to_H, Isq, Ieq, nz, U_bg_sq,mask_v, & -!$OMP cdrag_sqrt,Rho0x400_G,nkml) & -!$OMP private(do_any,htot,do_i,k_massive,Thtot,uhtot,vhtot,U_Star, & -!$OMP Idecay_len_TKE,press,k2,I_2hlay,T_EOS,S_EOS,dR_dT, & -!$OMP dR_dS,hlay,v_at_u,Uh2,T_lay,S_lay,gHprime, & -!$OMP RiBulk,Shtot,Rhtot,absf,do_any_shelf, & -!$OMP h_at_vel,ustar,htot_vel,hwtot,hutot,hweight,ustarsq, & -!$OMP oldfn,Dfn,Dh,Rlay,Rlb,h2f2,ustar1) + !$OMP parallel do default(private) shared(u,v,h,tv,forces,visc,dt,G,GV,US,CS,use_EOS,dt_Rho0, & + !$OMP h_neglect,h_tiny,g_H_Rho0,js,je,OBC,Isq,Ieq,nz, & + !$OMP U_bg_sq,mask_v,cdrag_sqrt,cdrag_sqrt_Z,Rho0x400_G,nkml) do j=js,je ! u-point loop if (CS%dynamic_viscous_ML) then do_any = .false. @@ -1292,8 +1206,8 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, CS, symmetrize) if (CS%omega_frac > 0.0) & absf = sqrt(CS%omega_frac*4.0*CS%omega**2 + (1.0-CS%omega_frac)*absf**2) endif - U_Star = max(CS%ustar_min, 0.5 * (forces%ustar(i,j) + forces%ustar(i+1,j))) - Idecay_len_TKE(I) = ((absf / U_Star) * CS%TKE_decay) * H_to_m + U_star = max(CS%ustar_min, 0.5 * (forces%ustar(i,j) + forces%ustar(i+1,j))) + Idecay_len_TKE(I) = ((absf / U_star) * CS%TKE_decay) * GV%H_to_Z endif enddo @@ -1400,7 +1314,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, CS, symmetrize) if (use_EOS .or. .not.CS%linear_drag) then ; do k=1,nz if (htot_vel>=CS%Htbl_shelf) exit ! terminate the k loop hweight = MIN(CS%Htbl_shelf - htot_vel, h_at_vel(i,k)) - if (hweight <= 1.5*GV%Angstrom + h_neglect) cycle + if (hweight <= 1.5*GV%Angstrom_H + h_neglect) cycle htot_vel = htot_vel + h_at_vel(i,k) hwtot = hwtot + hweight @@ -1417,9 +1331,9 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, CS, symmetrize) enddo ; endif if ((.not.CS%linear_drag) .and. (hwtot > 0.0)) then - ustar(I) = cdrag_sqrt*hutot/hwtot + ustar(I) = cdrag_sqrt_Z*hutot/hwtot else - ustar(I) = cdrag_sqrt*CS%drag_bg_vel + ustar(I) = cdrag_sqrt_Z*CS%drag_bg_vel endif if (use_EOS) then ; if (hwtot > 0.0) then @@ -1489,32 +1403,24 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, CS, symmetrize) htot(i) = htot(i) + h_at_vel(i,nz) endif ! use_EOS - !visc%tbl_thick_shelf_u(I,j) = max(CS%Htbl_shelf_min, & + !visc%tbl_thick_shelf_u(I,j) = GV%H_to_Z * max(CS%Htbl_shelf_min, & ! htot(I) / (0.5 + sqrt(0.25 + & ! (htot(i)*(G%CoriolisBu(I,J-1)+G%CoriolisBu(I,J)))**2 / & - ! (ustar(i)*m_to_H)**2 )) ) - ustar1 = ustar(i)*m_to_H + ! (ustar(i)*GV%Z_to_H)**2 )) ) + ustar1 = ustar(i)*GV%Z_to_H h2f2 = (htot(i)*(G%CoriolisBu(I,J-1)+G%CoriolisBu(I,J)) + h_neglect*CS%Omega)**2 - visc%tbl_thick_shelf_u(I,j) = max(CS%Htbl_shelf_min, & + tbl_thick_Z = GV%H_to_Z * max(CS%Htbl_shelf_min, & ( htot(I)*ustar1 ) / ( 0.5*ustar1 + sqrt((0.5*ustar1)**2 + h2f2 ) ) ) - visc%kv_tbl_shelf_u(I,j) = max(CS%KV_TBL_min, & - cdrag_sqrt*ustar(I)*visc%tbl_thick_shelf_u(I,j)) + visc%tbl_thick_shelf_u(I,j) = tbl_thick_Z + visc%kv_tbl_shelf_u(I,j) = max(CS%KV_TBL_min, cdrag_sqrt*ustar(i)*tbl_thick_Z) endif ; enddo ! I-loop endif ! do_any_shelf enddo ! j-loop at u-points -!$OMP parallel do default(none) shared(u, v, h, tv, forces, visc, dt, G, GV, CS, use_EOS,& -!$OMP dt_Rho0, h_neglect, h_tiny, g_H_Rho0,is,ie,OBC, & -!$OMP Jsq,Jeq,nz,U_bg_sq,cdrag_sqrt,Rho0x400_G,nkml, & -!$OMP m_to_H,H_to_m,mask_u) & -!$OMP private(do_any,htot,do_i,k_massive,Thtot,vhtot,uhtot,absf,& -!$OMP U_Star,Idecay_len_TKE,press,k2,I_2hlay,T_EOS, & -!$OMP S_EOS,dR_dT, dR_dS,hlay,u_at_v,Uh2, & -!$OMP T_lay,S_lay,gHprime,RiBulk,do_any_shelf, & -!$OMP Shtot,Rhtot,ustar,h_at_vel,htot_vel,hwtot, & -!$OMP hutot,hweight,ustarsq,oldfn,Dh,Rlay,Rlb,Dfn, & -!$OMP h2f2,ustar1) + !$OMP parallel do default(private) shared(u,v,h,tv,forces,visc,dt,G,GV,US,CS,use_EOS,dt_Rho0, & + !$OMP h_neglect,h_tiny,g_H_Rho0,is,ie,OBC,Jsq,Jeq,nz, & + !$OMP U_bg_sq,cdrag_sqrt,cdrag_sqrt_Z,Rho0x400_G,nkml,mask_u) do J=Jsq,Jeq ! v-point loop if (CS%dynamic_viscous_ML) then do_any = .false. @@ -1536,8 +1442,8 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, CS, symmetrize) absf = sqrt(CS%omega_frac*4.0*CS%omega**2 + (1.0-CS%omega_frac)*absf**2) endif - U_Star = max(CS%ustar_min, 0.5 * (forces%ustar(i,j) + forces%ustar(i,j+1))) - Idecay_len_TKE(i) = ((absf / U_Star) * CS%TKE_decay) * H_to_m + U_star = max(CS%ustar_min, 0.5 * (forces%ustar(i,j) + forces%ustar(i,j+1))) + Idecay_len_TKE(i) = ((absf / U_star) * CS%TKE_decay) * GV%H_to_Z endif enddo @@ -1617,12 +1523,12 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, CS, symmetrize) do_any_shelf = .false. if (associated(forces%frac_shelf_v)) then - do I=Is,Ie + do i=is,ie if (forces%frac_shelf_v(i,J)*G%mask2dCv(i,J) == 0.0) then - do_i(I) = .false. + do_i(i) = .false. visc%tbl_thick_shelf_v(i,J) = 0.0 ; visc%kv_tbl_shelf_v(i,J) = 0.0 else - do_i(I) = .true. ; do_any_shelf = .true. + do_i(i) = .true. ; do_any_shelf = .true. endif enddo endif @@ -1645,7 +1551,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, CS, symmetrize) if (use_EOS .or. .not.CS%linear_drag) then ; do k=1,nz if (htot_vel>=CS%Htbl_shelf) exit ! terminate the k loop hweight = MIN(CS%Htbl_shelf - htot_vel, h_at_vel(i,k)) - if (hweight <= 1.5*GV%Angstrom + h_neglect) cycle + if (hweight <= 1.5*GV%Angstrom_H + h_neglect) cycle htot_vel = htot_vel + h_at_vel(i,k) hwtot = hwtot + hweight @@ -1662,9 +1568,9 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, CS, symmetrize) enddo ; endif if (.not.CS%linear_drag) then ; if (hwtot > 0.0) then - ustar(i) = cdrag_sqrt*hutot/hwtot + ustar(i) = cdrag_sqrt_Z*hutot/hwtot else - ustar(i) = cdrag_sqrt*CS%drag_bg_vel + ustar(i) = cdrag_sqrt_Z*CS%drag_bg_vel endif ; endif if (use_EOS) then ; if (hwtot > 0.0) then @@ -1734,16 +1640,17 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, CS, symmetrize) htot(i) = htot(i) + h_at_vel(i,nz) endif ! use_EOS - !visc%tbl_thick_shelf_v(i,J) = max(CS%Htbl_shelf_min, & + !visc%tbl_thick_shelf_v(i,J) = GV%H_to_Z * max(CS%Htbl_shelf_min, & ! htot(i) / (0.5 + sqrt(0.25 + & ! (htot(i)*(G%CoriolisBu(I-1,J)+G%CoriolisBu(I,J)))**2 / & - ! (ustar(i)*m_to_H)**2 )) ) - ustar1 = ustar(i)*m_to_H + ! (ustar(i)*GV%Z_to_H)**2 )) ) + ustar1 = ustar(i)*GV%Z_to_H h2f2 = (htot(i)*(G%CoriolisBu(I-1,J)+G%CoriolisBu(I,J)) + h_neglect*CS%Omega)**2 - visc%tbl_thick_shelf_v(i,J) = max(CS%Htbl_shelf_min, & + tbl_thick_Z = GV%H_to_Z * max(CS%Htbl_shelf_min, & ( htot(i)*ustar1 ) / ( 0.5*ustar1 + sqrt((0.5*ustar1)**2 + h2f2 ) ) ) - visc%kv_tbl_shelf_v(i,J) = max(CS%KV_TBL_min, & - cdrag_sqrt*ustar(i)*visc%tbl_thick_shelf_v(i,J)) + visc%tbl_thick_shelf_v(i,J) = tbl_thick_Z + visc%kv_tbl_shelf_v(i,J) = max(CS%KV_TBL_min, cdrag_sqrt*ustar(i)*tbl_thick_Z) + endif ; enddo ! i-loop endif ! do_any_shelf @@ -1761,8 +1668,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, CS, symmetrize) end subroutine set_viscous_ML -!> This subroutine is used to register any fields associated with the -!! vertvisc_type. +!> Register any fields associated with the vertvisc_type. subroutine set_visc_register_restarts(HI, GV, param_file, visc, 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. @@ -1771,32 +1677,27 @@ subroutine set_visc_register_restarts(HI, GV, param_file, visc, restart_CS) type(vertvisc_type), intent(inout) :: visc !< A structure containing vertical !! viscosities and related fields. !! Allocated here. - type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control - !! structure. -! This subroutine is used to register any fields associated with the -! vertvisc_type. -! Arguments: HI - A horizontal index type structure. -! (in) GV - The ocean's vertical grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (out) visc - A structure containing vertical viscosities and related -! fields. Allocated here. -! (in) restart_CS - A pointer to the restart control structure. - type(vardesc) :: vd - logical :: use_kappa_shear, adiabatic, useKPP, useEPBL + type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure. + ! Local variables + logical :: use_kappa_shear, KS_at_vertex + logical :: adiabatic, useKPP, useEPBL logical :: use_CVMix_shear, MLE_use_PBL_MLD, use_CVMix_conv integer :: isd, ied, jsd, jed, nz + real :: hfreeze !< If hfreeze > 0 [m], melt potential will be computed. character(len=40) :: mdl = "MOM_set_visc" ! This module's name. isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke call get_param(param_file, mdl, "ADIABATIC", adiabatic, default=.false., & do_not_log=.true.) - use_kappa_shear = .false. ; use_CVMix_shear = .false. ; - useKPP = .false. ; useEPBL = .false. ; use_CVMix_conv = .false. ; + + use_kappa_shear = .false. ; KS_at_vertex = .false. ; use_CVMix_shear = .false. + useKPP = .false. ; useEPBL = .false. ; use_CVMix_conv = .false. + if (.not.adiabatic) then use_kappa_shear = kappa_shear_is_used(param_file) + KS_at_vertex = kappa_shear_at_vertex(param_file) use_CVMix_shear = CVMix_shear_is_used(param_file) - use_CVMix_conv = CVMix_conv_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"// & "to calculate diffusivities and non-local transport in the OBL.", & @@ -1808,43 +1709,63 @@ subroutine set_visc_register_restarts(HI, GV, param_file, visc, restart_CS) endif if (use_kappa_shear .or. useKPP .or. useEPBL .or. use_CVMix_shear .or. use_CVMix_conv) then - allocate(visc%Kd_shear(isd:ied,jsd:jed,nz+1)) ; visc%Kd_shear(:,:,:) = 0.0 - allocate(visc%TKE_turb(isd:ied,jsd:jed,nz+1)) ; visc%TKE_turb(:,:,:) = 0.0 - allocate(visc%Kv_shear(isd:ied,jsd:jed,nz+1)) ; visc%Kv_shear(:,:,:) = 0.0 - allocate(visc%Kv_slow(isd:ied,jsd:jed,nz+1)) ; visc%Kv_slow(:,:,:) = 0.0 - - vd = var_desc("Kd_shear","m2 s-1","Shear-driven turbulent diffusivity at interfaces", & - hor_grid='h', z_grid='i') - call register_restart_field(visc%Kd_shear, vd, .false., restart_CS) - - vd = var_desc("TKE_turb","m2 s-2","Turbulent kinetic energy per unit mass at interfaces", & - hor_grid='h', z_grid='i') - call register_restart_field(visc%TKE_turb, vd, .false., restart_CS) - vd = var_desc("Kv_shear","m2 s-1","Shear-driven turbulent viscosity at interfaces", & - hor_grid='h', z_grid='i') - call register_restart_field(visc%Kv_shear, vd, .false., restart_CS) - vd = var_desc("Kv_slow","m2 s-1","Vertical turbulent viscosity at interfaces due \n" // & - " to slow processes", hor_grid='h', z_grid='i') - call register_restart_field(visc%Kv_slow, vd, .false., restart_CS) - + call safe_alloc_ptr(visc%Kd_shear, isd, ied, jsd, jed, nz+1) + call register_restart_field(visc%Kd_shear, "Kd_shear", .false., restart_CS, & + "Shear-driven turbulent diffusivity at interfaces", "m2 s-1", z_grid='i') + endif + if (useKPP .or. useEPBL .or. use_CVMix_shear .or. use_CVMix_conv .or. & + (use_kappa_shear .and. .not.KS_at_vertex )) then + call safe_alloc_ptr(visc%Kv_shear, isd, ied, jsd, jed, nz+1) + call register_restart_field(visc%Kv_shear, "Kv_shear", .false., restart_CS, & + "Shear-driven turbulent viscosity at interfaces", "m2 s-1", z_grid='i') endif + if (use_kappa_shear .and. KS_at_vertex) then + call safe_alloc_ptr(visc%TKE_turb, HI%IsdB, HI%IedB, HI%JsdB, HI%JedB, nz+1) + call register_restart_field(visc%TKE_turb, "TKE_turb", .false., restart_CS, & + "Turbulent kinetic energy per unit mass at interfaces", "m2 s-2", & + hor_grid="Bu", z_grid='i') + call safe_alloc_ptr(visc%Kv_shear_Bu, HI%IsdB, HI%IedB, HI%JsdB, HI%JedB, nz+1) + call register_restart_field(visc%Kv_shear_Bu, "Kv_shear_Bu", .false., restart_CS, & + "Shear-driven turbulent viscosity at vertex interfaces", "m2 s-1", & + hor_grid="Bu", z_grid='i') + elseif (use_kappa_shear) then + call safe_alloc_ptr(visc%TKE_turb, isd, ied, jsd, jed, nz+1) + call register_restart_field(visc%TKE_turb, "TKE_turb", .false., restart_CS, & + "Turbulent kinetic energy per unit mass at interfaces", "m2 s-2", z_grid='i') + endif + + ! MOM_bkgnd_mixing is always used, so always allocate visc%Kv_slow. GMM + call safe_alloc_ptr(visc%Kv_slow, isd, ied, jsd, jed, nz+1) + call register_restart_field(visc%Kv_slow, "Kv_slow", .false., restart_CS, & + "Vertical turbulent viscosity at interfaces due to slow processes", & + "m2 s-1", z_grid='i') - ! visc%MLD is used to communicate the state of the (e)PBL to the rest of the model + ! visc%MLD is used to communicate the state of the (e)PBL or KPP to the rest of the model call get_param(param_file, mdl, "MLE_USE_PBL_MLD", MLE_use_PBL_MLD, & default=.false., do_not_log=.true.) + ! visc%MLD needs to be allocated when melt potential is computed (HFREEZE>0) + call get_param(param_file, mdl, "HFREEZE", hfreeze, & + default=-1.0, do_not_log=.true.) + if (MLE_use_PBL_MLD) then - allocate(visc%MLD(isd:ied,jsd:jed)) ; visc%MLD(:,:) = 0.0 - vd = var_desc("MLD","m","Instantaneous active mixing layer depth", & - hor_grid='h', z_grid='1') - call register_restart_field(visc%MLD, vd, .false., restart_CS) + call safe_alloc_ptr(visc%MLD, isd, ied, jsd, jed) + call register_restart_field(visc%MLD, "MLD", .false., restart_CS, & + "Instantaneous active mixing layer depth", "m") endif + if (hfreeze >= 0.0 .and. .not.MLE_use_PBL_MLD) then + call safe_alloc_ptr(visc%MLD, isd, ied, jsd, jed) + endif + + end subroutine set_visc_register_restarts -subroutine set_visc_init(Time, G, GV, param_file, diag, visc, CS, OBC) +!> Initializes the MOM_set_visc control structure +subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS, OBC) type(time_type), target, intent(in) :: Time !< The current model time. - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + 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 type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time !! parameters. type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to regulate diagnostic @@ -1853,23 +1774,19 @@ subroutine set_visc_init(Time, G, GV, param_file, diag, visc, CS, OBC) !! related fields. Allocated here. type(set_visc_CS), pointer :: CS !< A pointer that is set to point to the control !! structure for this module - type(ocean_OBC_type), pointer :: OBC -! Arguments: Time - The current model time. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in) diag - A structure that is used to regulate diagnostic output. -! (out) visc - A structure containing vertical viscosities and related -! fields. Allocated here. -! (in/out) CS - A pointer that is set to point to the control structure -! for this module + type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure. + type(ocean_OBC_type), pointer :: OBC !< A pointer to an open boundary condition structure + ! Local variables real :: Csmag_chan_dflt, smag_const1, TKE_decay_dflt, bulk_Ri_ML_dflt real :: Kv_background real :: omega_frac_dflt - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz, i, j, n - logical :: use_kappa_shear, adiabatic, differential_diffusion, use_omega - type(OBC_segment_type), pointer :: segment ! pointer to OBC segment type + real :: Z_rescale ! A rescaling factor for heights from the representation in + ! a reastart fole to the internal representation in this run. + integer :: i, j, k, is, ie, js, je, n + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz + logical :: use_kappa_shear, adiabatic, use_omega + logical :: use_CVMix_ddiff, differential_diffusion, use_KPP + type(OBC_segment_type), pointer :: segment => NULL() ! pointer to OBC segment type ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "MOM_set_visc" ! This module's name. @@ -1883,16 +1800,16 @@ subroutine set_visc_init(Time, G, GV, param_file, diag, visc, CS, OBC) CS%OBC => OBC + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - CS%diag => diag -! Set default, read and log parameters + ! Set default, read and log parameters call log_version(param_file, mdl, version, "") - CS%RiNo_mix = .false. - use_kappa_shear = .false. ; differential_diffusion = .false. !; adiabatic = .false. ! Needed? -AJA + 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"//& @@ -1917,13 +1834,14 @@ subroutine set_visc_init(Time, G, GV, param_file, diag, visc, CS, OBC) endif if (.not.adiabatic) then - use_kappa_shear = kappa_shear_is_used(param_file) - CS%RiNo_mix = use_kappa_shear + 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.", & 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"//& "instability.", units="nondim", default=1.0) @@ -1967,7 +1885,7 @@ subroutine set_visc_init(Time, G, GV, param_file, diag, visc, CS, OBC) "The rotation rate of the earth.", units="s-1", & default=7.2921e-5) ! 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_to_m*GV%H_subroundoff) + CS%ustar_min = 2e-4*CS%omega*(GV%Angstrom_Z + GV%H_to_Z*GV%H_subroundoff) else call get_param(param_file, mdl, "OMEGA", CS%omega, & "The rotation rate of the earth.", units="s-1", & @@ -1979,7 +1897,7 @@ subroutine set_visc_init(Time, G, GV, param_file, diag, visc, CS, OBC) "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"//& - "but LINEAR_DRAG is not.", units="m", fail_if_missing=.true.) + "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"//& @@ -2001,27 +1919,49 @@ subroutine set_visc_init(Time, G, GV, param_file, diag, visc, CS, OBC) "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"//& - "near-bottom viscosity.", units="m", default=0.0) + "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"//& - "near-top viscosity.", units="m", default=CS%BBL_thick_min) + "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"//& - "default this is the same as HBBL", units="m", default=CS%Hbbl) + "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 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"// & + "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.", & + do_not_log=.true., default=.false.) + + if (use_KPP .and. visc%add_Kv_slow) call MOM_error(FATAL,"set_visc_init: "//& + "When USE_KPP=True, ADD_KV_SLOW must be false. Otherwise vertical "//& + "viscosity due to slow processes will be double counted. Please set "//& + "ADD_KV_SLOW=False.") + call get_param(param_file, mdl, "KV_BBL_MIN", CS%KV_BBL_min, & "The minimum viscosities in the bottom boundary layer.", & - units="m2 s-1", default=Kv_background) + units="m2 s-1", default=Kv_background, scale=US%m_to_Z**2) call get_param(param_file, mdl, "KV_TBL_MIN", CS%KV_TBL_min, & "The minimum viscosities in the top boundary layer.", & - units="m2 s-1", default=Kv_background) + units="m2 s-1", default=Kv_background, scale=US%m_to_Z**2) if (CS%Channel_drag) then call get_param(param_file, mdl, "SMAG_LAP_CONST", smag_const1, default=-1.0) @@ -2039,6 +1979,12 @@ subroutine set_visc_init(Time, G, GV, param_file, diag, visc, CS, OBC) if (CS%c_Smag < 0.0) CS%c_Smag = 0.15 endif + if (CS%RiNo_mix .and. kappa_shear_at_vertex(param_file)) then + ! These are necessary for reproduciblity across restarts in non-symmetric mode. + call pass_var(visc%TKE_turb, G%Domain, position=CORNER, complete=.false.) + call pass_var(visc%Kv_shear_Bu, G%Domain, position=CORNER, complete=.true.) + endif + if (CS%bottomdraglaw) then allocate(visc%bbl_thick_u(IsdB:IedB,jsd:jed)) ; visc%bbl_thick_u = 0.0 allocate(visc%kv_bbl_u(IsdB:IedB,jsd:jed)) ; visc%kv_bbl_u = 0.0 @@ -2048,24 +1994,24 @@ subroutine set_visc_init(Time, G, GV, param_file, diag, visc, CS, OBC) allocate(visc%TKE_bbl(isd:ied,jsd:jed)) ; visc%TKE_bbl = 0.0 CS%id_bbl_thick_u = register_diag_field('ocean_model', 'bbl_thick_u', & - diag%axesCu1, Time, 'BBL thickness at u points', 'm') + diag%axesCu1, Time, 'BBL thickness at u points', 'm', conversion=US%Z_to_m) CS%id_kv_bbl_u = register_diag_field('ocean_model', 'kv_bbl_u', diag%axesCu1, & - Time, 'BBL viscosity at u points', 'm2 s-1') + Time, 'BBL viscosity at u points', 'm2 s-1', conversion=US%Z_to_m**2) CS%id_bbl_thick_v = register_diag_field('ocean_model', 'bbl_thick_v', & - diag%axesCv1, Time, 'BBL thickness at v points', 'm') + diag%axesCv1, Time, 'BBL thickness at v points', 'm', conversion=US%Z_to_m) CS%id_kv_bbl_v = register_diag_field('ocean_model', 'kv_bbl_v', diag%axesCv1, & - Time, 'BBL viscosity at v points', 'm2 s-1') + Time, 'BBL viscosity at v points', 'm2 s-1', conversion=US%Z_to_m**2) endif if (CS%Channel_drag) then allocate(visc%Ray_u(IsdB:IedB,jsd:jed,nz)) ; visc%Ray_u = 0.0 allocate(visc%Ray_v(isd:ied,JsdB:JedB,nz)) ; visc%Ray_v = 0.0 CS%id_Ray_u = register_diag_field('ocean_model', 'Rayleigh_u', diag%axesCuL, & - Time, 'Rayleigh drag velocity at u points', 'm s-1') + Time, 'Rayleigh drag velocity at u points', 'm s-1', conversion=US%Z_to_m) CS%id_Ray_v = register_diag_field('ocean_model', 'Rayleigh_v', diag%axesCvL, & - Time, 'Rayleigh drag velocity at v points', 'm s-1') + Time, 'Rayleigh drag velocity at v points', 'm s-1', conversion=US%Z_to_m) endif - if (differential_diffusion) then + if (use_CVMix_ddiff .or. differential_diffusion) then allocate(visc%Kd_extra_T(isd:ied,jsd:jed,nz+1)) ; visc%Kd_extra_T = 0.0 allocate(visc%Kd_extra_S(isd:ied,jsd:jed,nz+1)) ; visc%Kd_extra_S = 0.0 endif @@ -2079,14 +2025,41 @@ subroutine set_visc_init(Time, G, GV, param_file, diag, visc, CS, OBC) diag%axesCv1, Time, 'Number of layers in viscous mixed layer at v points', 'm') endif - CS%Hbbl = CS%Hbbl * GV%m_to_H - CS%BBL_thick_min = CS%BBL_thick_min * GV%m_to_H + if ((US%m_to_Z_restart /= 0.0) .and. (US%m_to_Z_restart /= US%m_to_Z)) then + Z_rescale = US%m_to_Z / US%m_to_Z_restart + if (associated(visc%Kd_shear)) then ; if (query_initialized(visc%Kd_shear, "Kd_shear", restart_CS)) then + do k=1,nz+1 ; do j=js,je ; do i=is,ie + visc%Kd_shear(i,j,k) = Z_rescale**2 * visc%Kd_shear(i,j,k) + enddo ; enddo ; enddo + endif ; endif + + if (associated(visc%Kv_shear)) then ; if (query_initialized(visc%Kv_shear, "Kv_shear", restart_CS)) then + do k=1,nz+1 ; do j=js,je ; do i=is,ie + visc%Kv_shear(i,j,k) = Z_rescale**2 * visc%Kv_shear(i,j,k) + enddo ; enddo ; enddo + endif ; endif + + if (associated(visc%Kv_shear_Bu)) then ; if (query_initialized(visc%Kv_shear_Bu, "Kv_shear_Bu", restart_CS)) then + do k=1,nz+1 ; do j=js,je ; do i=is,ie + visc%Kv_shear_Bu(i,j,k) = Z_rescale**2 * visc%Kv_shear_Bu(i,j,k) + enddo ; enddo ; enddo + endif ; endif + + if (associated(visc%Kv_slow)) then ; if (query_initialized(visc%Kv_slow, "Kv_slow", restart_CS)) then + do k=1,nz+1 ; do j=js,je ; do i=is,ie + visc%Kv_slow(i,j,k) = Z_rescale**2 * visc%Kv_slow(i,j,k) + enddo ; enddo ; enddo + endif ; endif + endif end subroutine set_visc_init +!> This subroutine dellocates any memory in the set_visc control structure. subroutine set_visc_end(visc, CS) - type(vertvisc_type), intent(inout) :: visc - type(set_visc_CS), pointer :: CS + type(vertvisc_type), intent(inout) :: visc !< A structure containing vertical viscosities and + !! related fields. Elements are deallocated here. + type(set_visc_CS), pointer :: CS !< The control structure returned by a previous + !! call to vertvisc_init. if (CS%bottomdraglaw) then deallocate(visc%bbl_thick_u) ; deallocate(visc%bbl_thick_v) deallocate(visc%kv_bbl_u) ; deallocate(visc%kv_bbl_v) @@ -2101,6 +2074,7 @@ subroutine set_visc_end(visc, CS) if (associated(visc%Kv_slow)) deallocate(visc%Kv_slow) if (associated(visc%TKE_turb)) deallocate(visc%TKE_turb) if (associated(visc%Kv_shear)) deallocate(visc%Kv_shear) + if (associated(visc%Kv_shear_Bu)) deallocate(visc%Kv_shear_Bu) if (associated(visc%ustar_bbl)) deallocate(visc%ustar_bbl) if (associated(visc%TKE_bbl)) deallocate(visc%TKE_bbl) if (associated(visc%taux_shelf)) deallocate(visc%taux_shelf) @@ -2113,4 +2087,12 @@ subroutine set_visc_end(visc, CS) deallocate(CS) end subroutine set_visc_end +!> \namespace mom_set_visc +!! +!! This would also be the module in which other viscous quantities that are flow-independent might be set. +!! This information is transmitted to other modules via a vertvisc type structure. +!! +!! The same code is used for the two velocity components, by indirectly referencing the velocities and +!! defining a handful of direction-specific defined variables. + end module MOM_set_visc diff --git a/src/parameterizations/vertical/MOM_shortwave_abs.F90 b/src/parameterizations/vertical/MOM_shortwave_abs.F90 index 1e22ba5bf9..cf0da1c5f3 100644 --- a/src/parameterizations/vertical/MOM_shortwave_abs.F90 +++ b/src/parameterizations/vertical/MOM_shortwave_abs.F90 @@ -1,3 +1,4 @@ +!> Absorption of downwelling shortwave radiation module MOM_shortwave_abs ! This file is part of MOM6. See LICENSE.md for the license. @@ -13,59 +14,54 @@ module MOM_shortwave_abs public absorbRemainingSW, sumSWoverBands +!> This type is used to exchange information about ocean optical properties type, public :: optics_type ! ocean optical properties - integer :: nbands ! number of penetrating bands of SW radiation + integer :: nbands !< number of penetrating bands of SW radiation - real, pointer, dimension(:,:,:,:) :: & - opacity_band => NULL() ! SW optical depth per unit thickness (1/m) - ! Number of radiation bands is most rapidly varying (first) index. + real, pointer, dimension(:,:,:,:) :: opacity_band => NULL() !< SW optical depth per unit thickness [m-1] + !! The number of radiation bands is most rapidly varying (first) index. - real, pointer, dimension(:,:,:) :: & - SW_pen_band => NULL() ! shortwave radiation (W/m^2) at the surface in each of - ! the nbands bands that penetrates beyond the surface. - ! The most rapidly varying dimension is the band. + real, pointer, dimension(:,:,:) :: SW_pen_band => NULL() !< shortwave radiation [W m-2] at the surface + !! in each of the nbands bands that penetrates beyond the surface. + !! The most rapidly varying dimension is the band. - real, pointer, dimension(:) :: & - min_wavelength_band => NULL(), & ! The range of wavelengths in each band of - max_wavelength_band => NULL() ! penetrating shortwave radiation (nm) + real, pointer, dimension(:) :: & + min_wavelength_band => NULL(), & !< The minimum wavelength in each band of penetrating shortwave radiation [nm] + max_wavelength_band => NULL() !< The maximum wavelength in each band of penetrating shortwave radiation [nm] end type optics_type - contains -!> Apply shortwave heating below surface boundary layer. +!> Apply shortwave heating below the boundary layer (when running with the bulk mixed layer inhereted +!! from GOLD) or throughout the water column. +!! +!! In addition, it causes all of the remaining SW radiation to be absorbed, provided that the total +!! water column thickness is greater than H_limit_fluxes. +!! For thinner water columns, the heating is scaled down proportionately, the assumption being that the +!! remaining heating (which is left in Pen_SW) should go into an (absent for now) ocean bottom sediment layer. subroutine absorbRemainingSW(G, GV, h, opacity_band, nsw, j, dt, H_limit_fluxes, & adjustAbsorptionProfile, absorbAllSW, T, Pen_SW_bnd, & eps, ksort, htot, Ttot, TKE, dSV_dT) -!< This subroutine applies shortwave heating below the boundary layer (when running -!! with the bulk mixed layer from GOLD) or throughout the water column. In -!! addition, it causes all of the remaining SW radiation to be absorbed, -!! provided that the total water column thickness is greater than -!! H_limit_fluxes. For thinner water columns, the heating is scaled down -!! proportionately, the assumption being that the remaining heating (which is -!! left in Pen_SW) should go into an (absent for now) ocean bottom sediment layer. - 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),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or - !! kg m-2). - real, dimension(:,:,:), intent(in) :: opacity_band !< Opacity in each band of - !! penetrating shortwave radiation (1/H). + real, dimension(SZI_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + real, dimension(:,:,:), intent(in) :: opacity_band !< Opacity in each band of penetrating + !! shortwave radiation [H-1 ~> m-1 or m2 kg-1]. !! The indicies are band, i, k. integer, intent(in) :: nsw !< Number of bands of penetrating !! shortwave radiation. integer, intent(in) :: j !< j-index to work on. - real, intent(in) :: dt !< Time step (seconds). + real, intent(in) :: dt !< Time step [s]. real, intent(in) :: H_limit_fluxes !< If the total ocean depth is !! less than this, they are scaled away - !! to avoid numerical instabilities. (H) - !! This would not be necessary if a - !! finite heat capacity mud-layer - !! were added. + !! to avoid numerical instabilities + !! [H ~> m or kg m-2]. This would + !! not be necessary if a finite heat + !! capacity mud-layer were added. logical, intent(in) :: adjustAbsorptionProfile !< If true, apply !! heating above the layers in which it !! should have occurred to get the @@ -79,69 +75,27 @@ subroutine absorbRemainingSW(G, GV, h, opacity_band, nsw, j, dt, H_limit_fluxes, !! shortwave that should be absorbed by !! each layer. real, dimension(SZI_(G),SZK_(G)), intent(inout) :: T !< Layer potential/conservative - !! temperatures (deg C) + !! temperatures [degC] real, dimension(:,:), intent(inout) :: Pen_SW_bnd !< Penetrating shortwave heating in - !! each band that hits the bottom and - !! will be redistributed through the - !! water column (units of K*H), size - !! nsw x SZI_(G). - real, dimension(SZI_(G),SZK_(G)), & - optional, intent(in) :: eps !< Small thickness that must remain in + !! each band that hits the bottom and will + !! will be redistributed through the water + !! column [degC H ~> degC m or degC kg m-2], + !! size nsw x SZI_(G). + real, dimension(SZI_(G),SZK_(G)), optional, intent(in) :: eps !< Small thickness that must remain in !! each layer, and which will not be - !! subject to heating (units of H) - integer, dimension(SZI_(G),SZK_(G)), & - optional, intent(in) :: ksort !< Density-sorted k-indicies. - real, dimension(SZI_(G)), & - optional, intent(in) :: htot !< Total mixed layer thickness, in H . - real, dimension(SZI_(G)), & - optional, intent(inout) :: Ttot !< Depth integrated mixed layer - !! temperature (units of K H). - real, dimension(SZI_(G),SZK_(G)), & - optional, intent(in) :: dSV_dT !< The partial derivative of specific - !! volume with temperature, in m3 kg-1 - !! K-1. - real, dimension(SZI_(G),SZK_(G)), & - optional, intent(inout) :: TKE !< The TKE sink from mixing the heating - !! throughout a layer, in J m-2. - -! Arguments: -! (in) G = the ocean grid structure. -! (in) GV = The ocean's vertical grid structure. -! (in) h = the layer thicknesses, in m or kg m-2. -! units of h are referred to as "H" below. -! (in) opacity_band = opacity in each band of penetrating shortwave -! radiation (1/H). The indicies are band, i, k. -! (in) nsw = number of bands of penetrating shortwave radiation -! (in) j = j-index to work on -! (in) dt = time step (seconds) -! (in) H_limit_fluxes = if the total ocean depth is less than this, they -! are scaled away to avoid numerical instabilities. (H) -! This would not be necessary if a finite heat -! capacity mud-layer were added. -! (in) adjustAbsorptionProfile = if true, apply heating above the layers -! in which it should have occurred to get the correct -! mean depth (and potential energy change) of the -! shortwave that should be absorbed by each layer. -! (in) absorbAllSW = if true, any shortwave radiation that hits the -! bottom is absorbed uniformly over the water column. -! (inout) T = layer potential/conservative temperatures (deg C) -! (inout) Pen_SW_bnd = penetrating shortwave heating in each band that -! hits the bottom and will be redistributed through -! the water column (units of K*H), size nsw x SZI_(G). - -! These optional arguments apply when the bulk mixed layer is used -! but are unnecessary with other schemes. -! (in,opt) eps = small thickness that must remain in each layer, and -! which will not be subject to heating (units of H) -! (inout,opt) ksort = density-sorted k-indicies -! (in,opt) htot = total mixed layer thickness, in H -! (inout,opt) Ttot = depth integrated mixed layer temperature (units of K H) -! (in,opt) dSV_dT = the partial derivative of specific volume with temperature, in m3 kg-1 K-1. -! (inout,opt) TKE = the TKE sink from mixing the heating throughout a layer, in J m-2. - + !! subject to heating [H ~> m or kg m-2] + integer, dimension(SZI_(G),SZK_(G)), optional, intent(in) :: ksort !< Density-sorted k-indicies. + real, dimension(SZI_(G)), optional, intent(in) :: htot !< Total mixed layer thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G)), optional, intent(inout) :: Ttot !< Depth integrated mixed layer + !! temperature [degC H ~> degC m or degC kg m-2] + real, dimension(SZI_(G),SZK_(G)), optional, intent(in) :: dSV_dT !< The partial derivative of specific + !! volume with temperature [m3 kg-1 degC-1]. + real, dimension(SZI_(G),SZK_(G)), optional, intent(inout) :: TKE !< The TKE sink from mixing the heating + !! throughout a layer [J m-2]. + ! Local variables real, dimension(SZI_(G),SZK_(G)) :: & T_chg_above ! A temperature change that will be applied to all the thick - ! layers above a given layer, in K. This is only nonzero if + ! layers above a given layer [degC]. This is only nonzero if ! adjustAbsorptionProfile is true, in which case the net ! change in the temperature of a layer is the sum of the ! direct heating of that layer plus T_chg_above from all of @@ -149,33 +103,33 @@ subroutine absorbRemainingSW(G, GV, h, opacity_band, nsw, j, dt, H_limit_fluxes, ! radiation that hits the bottom. real, dimension(SZI_(G)) :: & h_heat, & ! The thickness of the water column that will be heated by - ! any remaining shortwave radiation (H units). + ! any remaining shortwave radiation [H ~> m or kg m-2]. T_chg, & ! The temperature change of thick layers due to the remaining - ! shortwave radiation and contributions from T_chg_above, in K. + ! shortwave radiation and contributions from T_chg_above [degC]. Pen_SW_rem ! The sum across all wavelength bands of the penetrating shortwave ! heating that hits the bottom and will be redistributed through - ! the water column (in units of K H) + ! the water column [degC H ~> degC m or degC kg m-2] real :: SW_trans ! fraction of shortwave radiation that is not - ! absorbed in a layer (nondimensional) + ! absorbed in a layer [nondim] real :: unabsorbed ! fraction of the shortwave radiation that ! is not absorbed because the layers are too thin real :: Ih_limit ! inverse of the total depth at which the - ! surface fluxes start to be limited (1/H) - real :: h_min_heat ! minimum thickness layer that should get heated (H) - real :: opt_depth ! optical depth of a layer (non-dim) - real :: exp_OD ! exp(-opt_depth) (non-dim) + ! surface fluxes start to be limited [H-1 ~> m-1 or m2 kg-1] + real :: h_min_heat ! minimum thickness layer that should get heated [H ~> m or kg m-2] + real :: opt_depth ! optical depth of a layer [nondim] + real :: exp_OD ! exp(-opt_depth) [nondim] real :: heat_bnd ! heating due to absorption in the current ! layer by the current band, including any piece that - ! is moved upward (K H units) + ! is moved upward [degC H ~> degC m or degC kg m-2] real :: SWa ! fraction of the absorbed shortwave that is - ! moved to layers above with adjustAbsorptionProfile (non-dim) + ! moved to layers above with adjustAbsorptionProfile [nondim] real :: coSWa_frac ! The fraction of SWa that is actually moved upward. - real :: min_SW_heating ! A minimum remaining shortwave heating rate that will be - ! simply absorbed in the next layer for computational - ! efficiency, instead of continuing to penetrate, in units - ! of K H s-1. The default, 2.5e-11, is about 0.08 K m / century. + real :: min_SW_heating ! A minimum remaining shortwave heating rate that will be simply + ! absorbed in the next layer for computational efficiency, instead of + ! continuing to penetrate [degC H s-1 ~> degC m s-1 or degC kg m-2 s-1]. + ! The default, 2.5e-11, is about 0.08 degC m / century. real :: epsilon ! A small thickness that must remain in each - ! layer, and which will not be subject to heating (units of H) + ! layer, and which will not be subject to heating [H ~> m or kg m-2] real :: I_G_Earth real :: g_Hconv2 logical :: SW_Remains ! If true, some column has shortwave radiation that @@ -188,12 +142,12 @@ subroutine absorbRemainingSW(G, GV, h, opacity_band, nsw, j, dt, H_limit_fluxes, min_SW_heating = 2.5e-11 - h_min_heat = 2.0*GV%Angstrom + GV%H_subroundoff + h_min_heat = 2.0*GV%Angstrom_H + GV%H_subroundoff is = G%isc ; ie = G%iec ; nz = G%ke C1_6 = 1.0 / 6.0 ; C1_60 = 1.0 / 60.0 TKE_calc = (present(TKE) .and. present(dSV_dT)) - g_Hconv2 = GV%g_Earth * GV%H_to_kg_m2**2 + g_Hconv2 = GV%H_to_Pa * GV%H_to_kg_m2 h_heat(:) = 0.0 if (present(htot)) then ; do i=is,ie ; h_heat(i) = htot(i) ; enddo ; endif @@ -346,61 +300,55 @@ subroutine sumSWoverBands(G, GV, h, opacity_band, nsw, j, dt, & !< This subroutine calculates the total shortwave heat flux integrated over !! bands as a function of depth. This routine is only called for computing !! buoyancy fluxes for use in KPP. This routine does not updat e the state. - 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),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m - !! or kg m-2). - real, dimension(:,:,:), intent(in) :: opacity_band !< opacity in each band of - !! penetrating shortwave radiation, - !! in m-1. The indicies are band, i, k. - integer, intent(in) :: nsw !< number of bands of penetrating - !! shortwave radiation. - integer, intent(in) :: j !< j-index to work on. - real, intent(in) :: dt !< Time step (seconds). - real, intent(in) :: H_limit_fluxes - logical, intent(in) :: absorbAllSW - real, dimension(:,:), intent(in) :: iPen_SW_bnd - real, dimension(SZI_(G),SZK_(G)+1), intent(inout) :: netPen ! Units of K H. - -! Arguments: -! (in) G = ocean grid structure -! (in) GV = The ocean's vertical grid structure. -! (in) h = layer thickness (units of m or kg/m^2); -! units of h are referred to as H below. -! (in) opacity_band = opacity in each band of penetrating shortwave -! radiation, in m-1. The indicies are band, i, k. -! (in) nsw = number of bands of penetrating shortwave radiation -! (in) j = j-index to work on -! (in) dt = time step (seconds) -! (inout) Pen_SW_bnd = penetrating shortwave heating in each band that -! hits the bottom and will be redistributed through -! the water column (K H units); size nsw x SZI_(G). -! (out) netPen = attenuated flux at interfaces, summed over bands (K H units) - + 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),SZK_(G)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + real, dimension(:,:,:), intent(in) :: opacity_band !< opacity in each band of + !! penetrating shortwave radiation [m-1]. + !! The indicies are band, i, k. + integer, intent(in) :: nsw !< number of bands of penetrating + !! shortwave radiation. + integer, intent(in) :: j !< j-index to work on. + real, intent(in) :: dt !< Time step [s]. + real, intent(in) :: H_limit_fluxes !< the total depth at which the + !! surface fluxes start to be limited to avoid + !! excessive heating of a thin ocean [H ~> m or kg m-2] + logical, intent(in) :: absorbAllSW !< If true, ensure that all shortwave + !! radiation is absorbed in the ocean water column. + real, dimension(:,:), intent(in) :: iPen_SW_bnd !< The incident penetrating shortwave + !! heating in each band that hits the bottom and + !! will be redistributed through the water column + !! [degC H ~> degC m or degC kg m-2]; size nsw x SZI_(G). + real, dimension(SZI_(G),SZK_(G)+1), & + intent(inout) :: netPen !< Net penetrating shortwave heat flux at each + !! interface, summed across all bands + !! [degC H ~> degC m or degC kg m-2]. + ! Local variables real :: h_heat(SZI_(G)) ! thickness of the water column that receives - ! remaining shortwave radiation, in H. + ! remaining shortwave radiation [H ~> m or kg m-2]. real :: Pen_SW_rem(SZI_(G)) ! sum across all wavelength bands of the ! penetrating shortwave heating that hits the bottom ! and will be redistributed through the water column - ! (K H units) + ! [degC H ~> degC m or degC kg m-2] real, dimension(size(iPen_SW_bnd,1),size(iPen_SW_bnd,2)) :: Pen_SW_bnd real :: SW_trans ! fraction of shortwave radiation not - ! absorbed in a layer (nondimensional) + ! absorbed in a layer [nondim] real :: unabsorbed ! fraction of the shortwave radiation ! not absorbed because the layers are too thin. real :: Ih_limit ! inverse of the total depth at which the - ! surface fluxes start to be limited (1/H units) - real :: h_min_heat ! minimum thickness layer that should get heated (H units) - real :: opt_depth ! optical depth of a layer (non-dim) - real :: exp_OD ! exp(-opt_depth) (non-dim) + ! surface fluxes start to be limited [H-1 ~> m-1 or m2 kg-1] + real :: h_min_heat ! minimum thickness layer that should get heated [H ~> m or kg m-2] + real :: opt_depth ! optical depth of a layer [nondim] + real :: exp_OD ! exp(-opt_depth) [nondim] logical :: SW_Remains ! If true, some column has shortwave radiation that ! was not entirely absorbed. integer :: is, ie, nz, i, k, ks, n SW_Remains = .false. - h_min_heat = 2.0*GV%Angstrom + GV%H_subroundoff + h_min_heat = 2.0*GV%Angstrom_H + GV%H_subroundoff is = G%isc ; ie = G%iec ; nz = G%ke pen_SW_bnd(:,:) = iPen_SW_bnd(:,:) diff --git a/src/parameterizations/vertical/MOM_sponge.F90 b/src/parameterizations/vertical/MOM_sponge.F90 index 0bb4a9bfdb..eaa2faf765 100644 --- a/src/parameterizations/vertical/MOM_sponge.F90 +++ b/src/parameterizations/vertical/MOM_sponge.F90 @@ -1,59 +1,8 @@ +!> Implements sponge regions in isopycnal mode module MOM_sponge ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Robert Hallberg, March 1999-June 2000 * -!* * -!* This program contains the subroutines that implement sponge * -!* regions, in which the stratification and water mass properties * -!* are damped toward some profiles. There are three externally * -!* callable subroutines in this file. * -!* * -!* initialize_sponge determines the mapping from the model * -!* variables into the arrays of damped columns. This remapping is * -!* done for efficiency and to conserve memory. Only columns which * -!* have positive inverse damping times and which are deeper than a * -!* supplied depth are placed in sponges. The inverse damping * -!* time is also stored in this subroutine, and memory is allocated * -!* for all of the reference profiles which will subsequently be * -!* provided through calls to set_up_sponge_field. The first two * -!* arguments are a two-dimensional array containing the damping * -!* rates, and the interface heights to damp towards. * -!* * -!* set_up_sponge_field is called to provide a reference profile * -!* and the location of the field that will be damped back toward * -!* that reference profile. A third argument, the number of layers * -!* in the field is also provided, but this should always be nz. * -!* * -!* Apply_sponge damps all of the fields that have been registered * -!* with set_up_sponge_field toward their reference profiles. The * -!* four arguments are the thickness to be damped, the amount of time * -!* over which the damping occurs, and arrays to which the movement * -!* of fluid into a layer from above and below will be added. The * -!* effect on momentum of the sponge may be accounted for later using * -!* the movement of water recorded in these later arrays. * -!* * -!* All of the variables operated upon in this file are defined at * -!* the thickness points. * -!* * -!* Macros written all in capital letters are defined in MOM_memory.h. * -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q * -!* j+1 > o > o > At ^: v * -!* j x ^ x ^ x At >: u * -!* j > o > o > At o: h, T, S, Iresttime, ea, eb * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** - use MOM_coms, only : sum_across_PEs use MOM_diag_mediator, only : post_data, query_averaging_enabled, register_diag_field use MOM_diag_mediator, only : diag_ctrl @@ -73,76 +22,87 @@ module MOM_sponge public set_up_sponge_field, set_up_sponge_ML_density public initialize_sponge, apply_sponge, sponge_end, init_sponge_diags -type :: p3d - real, dimension(:,:,:), pointer :: p => NULL() +! 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. + +!> A structure for creating arrays of pointers to 3D arrays +type, public :: p3d + real, dimension(:,:,:), pointer :: p => NULL() !< A pointer to a 3D array end type p3d -type :: p2d - real, dimension(:,:), pointer :: p => NULL() +!> A structure for creating arrays of pointers to 2D arrays +type, public :: p2d + real, dimension(:,:), pointer :: p => NULL() !< A pointer to a 2D array end type p2d +!> This control structure holds memory and parameters for the MOM_sponge module type, public :: sponge_CS ; private - logical :: bulkmixedlayer ! If true, a refined bulk mixed layer is used with - ! nkml sublayers and nkbl buffer layer. - integer :: nz ! The total number of layers. - integer :: isc, iec, jsc, jec ! The index ranges of the computational domain. - integer :: isd, ied, jsd, jed ! The index ranges of the data domain. - integer :: num_col ! The number of sponge points within the - ! computational domain. - integer :: fldno = 0 ! The number of fields which have already been - ! registered by calls to set_up_sponge_field - integer, pointer :: col_i(:) => NULL() ! Arrays containing the i- and j- indicies - integer, pointer :: col_j(:) => NULL() ! of each of the columns being damped. - real, pointer :: Iresttime_col(:) => NULL() ! The inverse restoring time of - ! each column. - real, pointer :: Rcv_ml_ref(:) => NULL() ! The value toward which the mixed layer - ! coordinate-density is being damped, in kg m-3. - real, pointer :: Ref_eta(:,:) => NULL() ! The value toward which the interface - ! heights are being damped, in m. - type(p3d) :: var(MAX_FIELDS_) ! Pointers to the fields that are being damped. - type(p2d) :: Ref_val(MAX_FIELDS_) ! The values to which the fields are damped. - - logical :: do_i_mean_sponge ! If true, apply sponges to the i-mean fields. - real, pointer :: Iresttime_im(:) => NULL() ! The inverse restoring time of - ! each row for i-mean sponges. - real, pointer :: Rcv_ml_ref_im(:) => NULL() ! The value toward which the i-mean - ! mixed layer coordinate-density is being damped, - ! in kg m-3. - real, pointer :: Ref_eta_im(:,:) => NULL() ! The value toward which the i-mean - ! interface heights are being damped, in m. - type(p2d) :: Ref_val_im(MAX_FIELDS_) ! The values toward which the i-means of - ! fields are damped. - - type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the - ! timing of diagnostic output. - integer :: id_w_sponge = -1 - + logical :: bulkmixedlayer !< If true, a refined bulk mixed layer is used with + !! nkml sublayers and nkbl buffer layer. + integer :: nz !< The total number of layers. + integer :: isc !< The starting i-index of the computational domain at h. + integer :: iec !< The ending i-index of the computational domain at h. + integer :: jsc !< The starting j-index of the computational domain at h. + integer :: jec !< The ending j-index of the computational domain at h. + integer :: isd !< The starting i-index of the data domain at h. + integer :: ied !< The ending i-index of the data domain at h. + integer :: jsd !< The starting j-index of the data domain at h. + integer :: jed !< The ending j-index of the data domain at h. + integer :: num_col !< The number of sponge points within the computational domain. + integer :: fldno = 0 !< The number of fields which have already been + !! registered by calls to set_up_sponge_field + integer, pointer :: col_i(:) => NULL() !< Array of the i-indicies of each of the columns being damped. + integer, pointer :: col_j(:) => NULL() !< Array of the j-indicies of each of the columns being damped. + real, pointer :: Iresttime_col(:) => NULL() !< The inverse restoring time of each column. + real, pointer :: Rcv_ml_ref(:) => NULL() !< The value toward which the mixed layer + !! coordinate-density is being damped [kg m-3]. + real, pointer :: Ref_eta(:,:) => NULL() !< The value toward which the interface + !! heights are being damped [Z ~> m]. + type(p3d) :: var(MAX_FIELDS_) !< Pointers to the fields that are being damped. + type(p2d) :: Ref_val(MAX_FIELDS_) !< The values to which the fields are damped. + + logical :: do_i_mean_sponge !< If true, apply sponges to the i-mean fields. + real, pointer :: Iresttime_im(:) => NULL() !< The inverse restoring time of + !! each row for i-mean sponges. + real, pointer :: Rcv_ml_ref_im(:) => NULL() !! The value toward which the i-mean + !< mixed layer coordinate-density is being damped [kg m-3]. + real, pointer :: Ref_eta_im(:,:) => NULL() !< The value toward which the i-mean + !! interface heights are being damped [Z ~> m]. + type(p2d) :: Ref_val_im(MAX_FIELDS_) !< The values toward which the i-means of + !! fields are damped. + + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + integer :: id_w_sponge = -1 !< A diagnostic ID end type sponge_CS contains -subroutine initialize_sponge(Iresttime, int_height, G, param_file, CS, & +!> This subroutine determines the number of points which are within +!! sponges in this computational domain. Only points that have +!! positive values of Iresttime and which mask2dT indicates are ocean +!! points are included in the sponges. It also stores the target interface +!! heights. +subroutine initialize_sponge(Iresttime, int_height, G, param_file, CS, GV, & Iresttime_i_mean, int_height_i_mean) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Iresttime - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: int_height - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(sponge_CS), pointer :: CS - real, dimension(SZJ_(G)), optional, intent(in) :: Iresttime_i_mean - real, dimension(SZJ_(G),SZK_(G)+1), optional, intent(in) :: int_height_i_mean - -! This subroutine determines the number of points which are within -! sponges in this computational domain. Only points that have -! positive values of Iresttime and which mask2dT indicates are ocean -! points are included in the sponges. It also stores the target interface -! heights. - -! Arguments: Iresttime - The inverse of the restoring time, in s-1. -! (in) int_height - The interface heights to damp back toward, in m. -! (in) G - The ocean's grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in/out) CS - A pointer that is set to point to the control structure -! for this module + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: Iresttime !< The inverse of the restoring time [s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & + intent(in) :: int_height !< The interface heights to damp back toward [Z ~> m]. + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(sponge_CS), pointer :: CS !< A pointer that is set to point to the control + !! structure for this module + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZJ_(G)), & + optional, intent(in) :: Iresttime_i_mean !< The inverse of the restoring time for + !! the zonal mean properties [s-1]. + real, dimension(SZJ_(G),SZK_(G)+1), & + optional, intent(in) :: int_height_i_mean !< The interface heights toward which to + !! damp the zonal mean heights [Z ~> m]. + + ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "MOM_sponge" ! This module's name. @@ -173,8 +133,8 @@ subroutine initialize_sponge(Iresttime, int_height, G, param_file, CS, & CS%do_i_mean_sponge = present(Iresttime_i_mean) CS%nz = G%ke - CS%isc = G%isc ; CS%iec = G%iec ; CS%jsc = G%jsc ; CS%jec = G%jec - CS%isd = G%isd ; CS%ied = G%ied ; CS%jsd = G%jsd ; CS%jed = G%jed +! CS%isc = G%isc ; CS%iec = G%iec ; CS%jsc = G%jsc ; CS%jec = G%jec +! CS%isd = G%isd ; CS%ied = G%ied ; CS%jsd = G%jsd ; CS%jed = G%jed ! CS%bulkmixedlayer may be set later via a call to set_up_sponge_ML_density. CS%bulkmixedlayer = .false. @@ -226,21 +186,15 @@ subroutine initialize_sponge(Iresttime, int_height, G, param_file, CS, & 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. subroutine init_sponge_diags(Time, G, diag, CS) - type(time_type), target, intent(in) :: Time + type(time_type), target, intent(in) :: Time !< The current model time type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(diag_ctrl), target, intent(inout) :: diag - type(sponge_CS), pointer :: CS - -! 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. - -! Arguments: Time - The current model time. -! (in) G - The ocean's grid structure. -! (in) diag - A structure that is used to regulate diagnostic output. -! (in/out) CS - A pointer to the control structure for this module that is -! set by a previous call to initialize_sponge. + type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to regulate diagnostic output + type(sponge_CS), pointer :: CS !< A pointer to the control structure for this module that + !! is set by a previous call to initialize_sponge. if (.not.associated(CS)) return @@ -250,25 +204,21 @@ subroutine init_sponge_diags(Time, G, diag, CS) end subroutine init_sponge_diags +!> This subroutine stores the reference profile for the variable +!! whose address is given by f_ptr. nlay is the number of layers in +!! this variable. subroutine set_up_sponge_field(sp_val, f_ptr, G, nlay, CS, sp_val_i_mean) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: sp_val - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), target, intent(in) :: f_ptr - integer, intent(in) :: nlay - type(sponge_CS), pointer :: CS - real, dimension(SZJ_(G),SZK_(G)), optional, intent(in) :: sp_val_i_mean -! This subroutine stores the reference profile for the variable -! whose address is given by f_ptr. nlay is the number of layers in -! this variable. - -! Arguments: sp_val - The reference profiles of the quantity being -! registered. -! (in) f_ptr - a pointer to the field which will be damped. -! (in) nlay - the number of layers in this quantity. -! (in/out) CS - A pointer to the control structure for this module that is -! set by a previous call to initialize_sponge. -! (in,opt) sp_val_i_mean - The i-mean reference value for this field with -! i-mean sponges. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: sp_val !< The reference profiles of the quantity being registered. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + target, intent(in) :: f_ptr !< a pointer to the field which will be damped + integer, intent(in) :: nlay !< the number of layers in this quantity + type(sponge_CS), pointer :: CS !< A pointer to the control structure for this module that + !! is set by a previous call to initialize_sponge. + real, dimension(SZJ_(G),SZK_(G)),& + optional, intent(in) :: sp_val_i_mean !< The i-mean reference value for + !! this field with i-mean sponges. integer :: j, k, col character(len=256) :: mesg ! String for error messages @@ -318,11 +268,17 @@ subroutine set_up_sponge_field(sp_val, f_ptr, G, nlay, CS, sp_val_i_mean) end subroutine set_up_sponge_field +!> This subroutine stores the reference value for mixed layer density. It is handled differently +!! from other values because it is only used in determining which layers can be inflated. subroutine set_up_sponge_ML_density(sp_val, G, CS, sp_val_i_mean) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: sp_val - type(sponge_CS), pointer :: CS - real, dimension(SZJ_(G)), optional, intent(in) :: sp_val_i_mean + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: sp_val !< The reference values of the mixed layer density [kg m-3] + type(sponge_CS), pointer :: CS !< A pointer to the control structure for this module that is + !! set by a previous call to initialize_sponge. + real, dimension(SZJ_(G)), & + optional, intent(in) :: sp_val_i_mean !< the reference values of the zonal mean mixed + !! layer density [kg m-3], for use if Iresttime_i_mean > 0. ! This subroutine stores the reference value for mixed layer density. It is ! handled differently from other values because it is only used in determining ! which layers can be inflated. @@ -359,74 +315,68 @@ subroutine set_up_sponge_ML_density(sp_val, G, CS, sp_val_i_mean) end subroutine set_up_sponge_ML_density +!> This subroutine applies damping to the layers thicknesses, mixed layer buoyancy, and a variety of +!! tracers for every column where there is damping. subroutine apply_sponge(h, dt, G, GV, ea, eb, CS, Rcv_ml) - 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(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thicknesses, in H (usually m or kg m-2) - real, intent(in) :: dt - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: ea !< an array to which the amount of - !! fluid entrained from the layer above during - !! this call will be added, in H. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: eb !< an array to which the amount of - !! fluid entrained from the layer below - !! during this call will be added, in H. - type(sponge_CS), pointer :: CS - real, dimension(SZI_(G),SZJ_(G)), optional, intent(inout) :: Rcv_ml + 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(SZI_(G),SZJ_(G),SZK_(G)), & + intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, intent(in) :: dt !< The amount of time covered by this call [s]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(inout) :: 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(inout) :: 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(sponge_CS), pointer :: CS !< A pointer to the control structure for this module + !! that is set by a previous call to initialize_sponge. + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(inout) :: Rcv_ml !< The coordinate density of the mixed layer [kg m-3]. ! This subroutine applies damping to the layers thicknesses, mixed ! layer buoyancy, and a variety of tracers for every column where ! there is damping. -! Arguments: h - Layer thickness, in m. -! (in) dt - The amount of time covered by this call, in s. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (out) ea - an array to which the amount of fluid entrained -! from the layer above during this call will be -! added, in H. -! (out) eb - an array to which the amount of fluid entrained -! from the layer below during this call will be -! added, in H. -! (in) CS - A pointer to the control structure for this module that is -! set by a previous call to initialize_sponge. -! (inout,opt) Rcv_ml - The coordinate density of the mixed layer. - + ! Local variables real, dimension(SZI_(G), SZJ_(G), SZK_(G)+1) :: & w_int, & ! Water moved upward across an interface within a timestep, - ! in H. + ! [H ~> m or kg m-2]. e_D ! Interface heights that are dilated to have a value of 0 - ! at the surface, in m. + ! at the surface [Z ~> m]. real, dimension(SZI_(G), SZJ_(G)) :: & eta_anom, & ! Anomalies in the interface height, relative to the i-mean - ! target value, in m. + ! target value [Z ~> m]. fld_anom ! Anomalies in a tracer concentration, relative to the ! i-mean target value. real, dimension(SZJ_(G), SZK_(G)+1) :: & - eta_mean_anom ! The i-mean interface height anomalies, in m. + eta_mean_anom ! The i-mean interface height anomalies [Z ~> m]. real, allocatable, dimension(:,:,:) :: & fld_mean_anom ! THe i-mean tracer concentration anomalies. real, dimension(SZI_(G), SZK_(G)+1) :: & - h_above, & ! The total thickness above an interface, in H. - h_below ! The total thickness below an interface, in H. + h_above, & ! The total thickness above an interface [H ~> m or kg m-2]. + h_below ! The total thickness below an interface [H ~> m or kg m-2]. real, dimension(SZI_(G)) :: & dilate ! A nondimensional factor by which to dilate layers to - ! give 0 at the surface. + ! give 0 at the surface [nondim]. - real :: e(SZK_(G)+1) ! The interface heights, in m, usually negative. - real :: e0 ! The height of the free surface in m. + real :: e(SZK_(G)+1) ! The interface heights [Z ~> m], usually negative. + real :: e0 ! The height of the free surface [Z ~> m]. real :: e_str ! A nondimensional amount by which the reference ! profile must be stretched for the free surfaces ! heights in the two profiles to agree. real :: w ! The thickness of water moving upward through an - ! interface within 1 timestep, in H. - real :: wm ! wm is w if w is negative and 0 otherwise, in H. - real :: wb ! w at the interface below a layer, in H. - real :: wpb ! wpb is wb if wb is positive and 0 otherwise, in H. - real :: ea_k, eb_k ! in H - real :: damp ! The timestep times the local damping coefficient. ND. - real :: I1pdamp ! I1pdamp is 1/(1 + damp). Nondimensional. - real :: damp_1pdamp ! damp_1pdamp is damp/(1 + damp). Nondimensional. - real :: Idt ! 1.0/dt, in s-1. + ! interface within 1 timestep [H ~> m or kg m-2]. + real :: wm ! wm is w if w is negative and 0 otherwise [H ~> m or kg m-2]. + real :: wb ! w at the interface below a layer [H ~> m or kg m-2]. + real :: wpb ! wpb is wb if wb is positive and 0 otherwise [H ~> m or kg m-2]. + real :: ea_k, eb_k ! [H ~> m or kg m-2] + real :: damp ! The timestep times the local damping coefficient [nondim]. + real :: I1pdamp ! I1pdamp is 1/(1 + damp). [nondim] + real :: damp_1pdamp ! damp_1pdamp is damp/(1 + damp). [nondim] + real :: Idt ! 1.0/dt [s-1]. integer :: c, m, nkmb, i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -450,7 +400,7 @@ subroutine apply_sponge(h, dt, G, GV, ea, eb, CS, Rcv_ml) do j=js,je ; do i=is,ie ; e_D(i,j,nz+1) = -G%bathyT(i,j) ; enddo ; enddo do k=nz,1,-1 ; do j=js,je ; do i=is,ie - e_D(i,j,K) = e_D(i,j,K+1) + h(i,j,k)*GV%H_to_m + e_D(i,j,K) = e_D(i,j,K+1) + h(i,j,k)*GV%H_to_Z enddo ; enddo ; enddo do j=js,je do i=is,ie @@ -484,15 +434,15 @@ subroutine apply_sponge(h, dt, G, GV, ea, eb, CS, Rcv_ml) h_above(i,1) = 0.0 ; h_below(i,nz+1) = 0.0 enddo do K=nz,1,-1 ; do i=is,ie - h_below(i,K) = h_below(i,K+1) + max(h(i,j,k)-GV%Angstrom, 0.0) + h_below(i,K) = h_below(i,K+1) + max(h(i,j,k)-GV%Angstrom_H, 0.0) enddo ; enddo do K=2,nz+1 ; do i=is,ie - h_above(i,K) = h_above(i,K-1) + max(h(i,j,k-1)-GV%Angstrom, 0.0) + h_above(i,K) = h_above(i,K-1) + max(h(i,j,k-1)-GV%Angstrom_H, 0.0) enddo ; enddo do K=2,nz ! w is positive for an upward (lightward) flux of mass, resulting ! in the downward movement of an interface. - w = damp_1pdamp * eta_mean_anom(j,K) * GV%m_to_H + w = damp_1pdamp * eta_mean_anom(j,K) * GV%Z_to_H do i=is,ie if (w > 0.0) then w_int(i,j,K) = min(w, h_below(i,K)) @@ -514,7 +464,7 @@ subroutine apply_sponge(h, dt, G, GV, ea, eb, CS, Rcv_ml) enddo h(i,j,k) = max(h(i,j,k) + (w_int(i,j,K+1) - w_int(i,j,K)), & - min(h(i,j,k), GV%Angstrom)) + min(h(i,j,k), GV%Angstrom_H)) enddo ; enddo endif ; enddo @@ -530,7 +480,7 @@ subroutine apply_sponge(h, dt, G, GV, ea, eb, CS, Rcv_ml) e(1) = 0.0 ; e0 = 0.0 do K=1,nz - e(K+1) = e(K) - h(i,j,k)*GV%H_to_m + e(K+1) = e(K) - h(i,j,k)*GV%H_to_Z enddo e_str = e(nz+1) / CS%Ref_eta(nz+1,c) @@ -548,8 +498,8 @@ subroutine apply_sponge(h, dt, G, GV, ea, eb, CS, Rcv_ml) wpb = 0.0; wb = 0.0 do k=nz,nkmb+1,-1 if (GV%Rlay(k) > Rcv_ml(i,j)) then - w = MIN((((e(K)-e0) - e_str*CS%Ref_eta(K,c)) * damp)*GV%m_to_H, & - ((wb + h(i,j,k)) - GV%Angstrom)) + w = MIN((((e(K)-e0) - e_str*CS%Ref_eta(K,c)) * damp)*GV%Z_to_H, & + ((wb + h(i,j,k)) - GV%Angstrom_H)) wm = 0.5*(w-ABS(w)) do m=1,CS%fldno CS%var(m)%p(i,j,k) = (h(i,j,k)*CS%var(m)%p(i,j,k) + & @@ -561,7 +511,7 @@ subroutine apply_sponge(h, dt, G, GV, ea, eb, CS, Rcv_ml) CS%var(m)%p(i,j,k) = I1pdamp * & (CS%var(m)%p(i,j,k) + CS%Ref_val(m)%p(k,c)*damp) enddo - w = wb + (h(i,j,k) - GV%Angstrom) + w = wb + (h(i,j,k) - GV%Angstrom_H) wm = 0.5*(w-ABS(w)) endif eb(i,j,k) = eb(i,j,k) + wpb @@ -573,7 +523,7 @@ subroutine apply_sponge(h, dt, G, GV, ea, eb, CS, Rcv_ml) if (wb < 0) then do k=nkmb,1,-1 - w = MIN((wb + (h(i,j,k) - GV%Angstrom)),0.0) + w = MIN((wb + (h(i,j,k) - GV%Angstrom_H)),0.0) h(i,j,k) = h(i,j,k) + (wb - w) ea(i,j,k) = ea(i,j,k) - w wb = w @@ -604,8 +554,8 @@ subroutine apply_sponge(h, dt, G, GV, ea, eb, CS, Rcv_ml) wpb = 0.0 wb = 0.0 do k=nz,1,-1 - w = MIN((((e(K)-e0) - e_str*CS%Ref_eta(K,c)) * damp)*GV%m_to_H, & - ((wb + h(i,j,k)) - GV%Angstrom)) + w = MIN((((e(K)-e0) - e_str*CS%Ref_eta(K,c)) * damp)*GV%Z_to_H, & + ((wb + h(i,j,k)) - GV%Angstrom_H)) wm = 0.5*(w - ABS(w)) do m=1,CS%fldno CS%var(m)%p(i,j,k) = (h(i,j,k)*CS%var(m)%p(i,j,k) + & @@ -624,9 +574,9 @@ subroutine apply_sponge(h, dt, G, GV, ea, eb, CS, Rcv_ml) if (associated(CS%diag)) then ; if (query_averaging_enabled(CS%diag)) then if (CS%id_w_sponge > 0) then - Idt = 1.0 / dt + Idt = GV%H_to_m / dt do k=1,nz+1 ; do j=js,je ; do i=is,ie - w_int(i,j,K) = w_int(i,j,K) * Idt * GV%H_to_m ! Scale values by clobbering array since it is local + w_int(i,j,K) = w_int(i,j,K) * Idt ! Scale values by clobbering array since it is local enddo ; enddo ; enddo call post_data(CS%id_w_sponge, w_int(:,:,:), CS%diag) endif @@ -634,10 +584,10 @@ subroutine apply_sponge(h, dt, G, GV, ea, eb, CS, Rcv_ml) end subroutine apply_sponge +!> This call deallocates any memory in the sponge control structure. subroutine sponge_end(CS) - type(sponge_CS), pointer :: CS -! (in) CS - A pointer to the control structure for this module that is -! set by a previous call to initialize_sponge. + type(sponge_CS), pointer :: CS !< A pointer to the control structure for this module + !! that is set by a previous call to initialize_sponge. integer :: m if (.not.associated(CS)) return @@ -663,4 +613,37 @@ subroutine sponge_end(CS) end subroutine sponge_end +!> \namespace mom_sponge +!! +!! By Robert Hallberg, March 1999-June 2000 +!! +!! This program contains the subroutines that implement sponge +!! regions, in which the stratification and water mass properties +!! are damped toward some profiles. There are three externally +!! callable subroutines in this file. +!! +!! initialize_sponge determines the mapping from the model +!! variables into the arrays of damped columns. This remapping is +!! done for efficiency and to conserve memory. Only columns which +!! have positive inverse damping times and which are deeper than a +!! supplied depth are placed in sponges. The inverse damping +!! time is also stored in this subroutine, and memory is allocated +!! for all of the reference profiles which will subsequently be +!! provided through calls to set_up_sponge_field. The first two +!! arguments are a two-dimensional array containing the damping +!! rates, and the interface heights to damp towards. +!! +!! set_up_sponge_field is called to provide a reference profile +!! and the location of the field that will be damped back toward +!! that reference profile. A third argument, the number of layers +!! in the field is also provided, but this should always be nz. +!! +!! Apply_sponge damps all of the fields that have been registered +!! with set_up_sponge_field toward their reference profiles. The +!! four arguments are the thickness to be damped, the amount of time +!! over which the damping occurs, and arrays to which the movement +!! of fluid into a layer from above and below will be added. The +!! effect on momentum of the sponge may be accounted for later using +!! the movement of water recorded in these later arrays. + end module MOM_sponge diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 5524ef074a..6f85bc5dbe 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -3,24 +3,28 @@ module MOM_tidal_mixing ! This file is part of MOM6. See LICENSE.md for the license. -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_EOS, only : calculate_density -use MOM_variables, only : thermo_var_ptrs, p3d -use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE -use MOM_debugging, only : hchksum -use MOM_grid, only : ocean_grid_type -use MOM_verticalGrid, only : verticalGrid_type -use MOM_file_parser, only : openParameterBlock, closeParameterBlock -use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_string_functions, only : uppercase, lowercase -use MOM_io, only : slasher, MOM_read_data, vardesc, var_desc -use CVMix_tidal, only : CVMix_init_tidal, CVMix_compute_Simmons_invariant -use CVMix_tidal, only : CVMix_coeffs_tidal, CVMix_tidal_params_type -use CVMix_kinds_and_types, only : CVMix_global_params_type -use CVMix_put_get, only : CVMix_put +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_remapping, only : remapping_CS, initialize_remapping, remapping_core_h +use MOM_string_functions, only : uppercase, lowercase +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs, p3d +use MOM_verticalGrid, only : verticalGrid_type +use CVMix_tidal, only : CVMix_init_tidal, CVMix_compute_Simmons_invariant +use CVMix_tidal, only : CVMix_coeffs_tidal, CVMix_tidal_params_type +use CVMix_tidal, only : CVMix_compute_Schmittner_invariant, CVMix_compute_SchmittnerCoeff +use CVMix_tidal, only : CVMix_coeffs_tidal_schmittner +use CVMix_kinds_and_types, only : CVMix_global_params_type +use CVMix_put_get, only : CVMix_put implicit none ; private @@ -32,121 +36,137 @@ module MOM_tidal_mixing public post_tidal_diagnostics public tidal_mixing_end +! 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. + !> Containers for tidal mixing diagnostics -type, public :: tidal_mixing_diags +type, public :: tidal_mixing_diags ; private real, pointer, dimension(:,:,:) :: & - Kd_itidal => NULL(),& ! internal tide diffusivity at interfaces (m2/s) - Fl_itidal => NULL(),& ! vertical flux of tidal turbulent dissipation (m3/s3) - Kd_lowmode => NULL(),& ! internal tide diffusivity at interfaces - ! due to propagating low modes (m2/s) (BDM) - Fl_lowmode => NULL(),& ! vertical flux of tidal turbulent dissipation - ! due to propagating low modes (m3/s3) (BDM) - Kd_Niku => NULL(),& ! lee-wave diffusivity at interfaces (m2/s) - Kd_Niku_work => NULL(),& ! layer integrated work by lee-wave driven mixing (W/m2) - Kd_Itidal_Work => NULL(),& ! layer integrated work by int tide driven mixing (W/m2) - Kd_Lowmode_Work => NULL(),& ! layer integrated work by low mode driven mixing (W/m2) BDM - N2_int => NULL(),& - vert_dep_3d => NULL() - + 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] + 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] + 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? + real, pointer, dimension(:,:,:) :: tidal_qe_md => NULL() !< Input tidal energy dissipated locally, + !! interpolated to model vertical coordinate [W m-3?] + 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] real, pointer, dimension(:,:) :: & - TKE_itidal_used => NULL(),& ! internal tide TKE input at ocean bottom (W/m2) - N2_bot => NULL(),& ! bottom squared buoyancy frequency (1/s2) - N2_meanz => NULL(),& ! vertically averaged buoyancy frequency (1/s2) - Polzin_decay_scale_scaled => NULL(),& ! vertical scale of decay for tidal dissipation - Polzin_decay_scale => NULL(),& ! vertical decay scale for tidal diss with Polzin (meter) - Simmons_coeff_2d => NULL() + TKE_itidal_used => NULL(),& !< internal tide TKE input at ocean bottom [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 + Polzin_decay_scale => NULL(),& !< vertical decay scale for tidal diss with Polzin [m] + Simmons_coeff_2d => NULL() !< The Simmons et al mixing coefficient end type -!> Control structure for tidal mixing module. +!> Control structure with parameters for the tidal mixing module. type, public :: tidal_mixing_cs - logical :: debug = .true. + ! TODO: private + logical :: debug = .true. !< If true, do more extensive debugging checks. This is hard-coded. ! Parameters - logical :: int_tide_dissipation = .false. ! Internal tide conversion (from barotropic) - ! with the schemes of St Laurent et al (2002)/ - ! Simmons et al (2004) - - integer :: Int_tide_profile ! A coded integer indicating the vertical profile - ! for dissipation of the internal waves. Schemes that - ! are currently encoded are St Laurent et al (2002) and - ! Polzin (2009). - logical :: Lee_wave_dissipation = .false. ! Enable lee-wave driven mixing, following - ! Nikurashin (2010), with a vertical energy - ! deposition profile specified by Lee_wave_profile. - ! St Laurent et al (2002) or - ! Simmons et al (2004) scheme - - integer :: Lee_wave_profile ! A coded integer indicating the vertical profile - ! for dissipation of the lee waves. Schemes that are - ! currently encoded are St Laurent et al (2002) and - ! Polzin (2009). - real :: Int_tide_decay_scale ! decay scale for internal wave TKE (meter) - - real :: Mu_itides ! efficiency for conversion of dissipation - ! to potential energy (nondimensional) - - real :: Gamma_itides ! fraction of local dissipation (nondimensional) - - real :: Gamma_lee ! fraction of local dissipation for lee waves - ! (Nikurashin's energy input) (nondimensional) - real :: Decay_scale_factor_lee ! Scaling factor for the decay scale of lee - ! wave energy dissipation (nondimensional) - - real :: min_zbot_itides ! minimum depth for internal tide conversion (meter) - logical :: Lowmode_itidal_dissipation = .false. ! Internal tide conversion (from low modes) - ! with the schemes of St Laurent et al (2002)/ - ! Simmons et al (2004) !BDM - - real :: Nu_Polzin ! The non-dimensional constant used in Polzin form of - ! the vertical scale of decay of tidal dissipation - - real :: Nbotref_Polzin ! Reference value for the buoyancy frequency at the - ! ocean bottom used in Polzin formulation of the - ! vertical scale of decay of tidal dissipation (1/s) - real :: Polzin_decay_scale_factor ! Scaling factor for the decay length scale - ! of the tidal dissipation profile in Polzin - ! (nondimensional) - real :: Polzin_decay_scale_max_factor ! The decay length scale of tidal - ! dissipation profile in Polzin formulation should not - ! exceed Polzin_decay_scale_max_factor * depth of the - ! ocean (nondimensional). - real :: Polzin_min_decay_scale ! minimum decay scale of the tidal dissipation - ! profile in Polzin formulation (meter) - - real :: TKE_itide_max ! maximum internal tide conversion (W m-2) - ! available to mix above the BBL - - real :: utide ! constant tidal amplitude (m s-1) used if - real :: kappa_itides ! topographic wavenumber and non-dimensional scaling - real :: kappa_h2_factor ! factor for the product of wavenumber * rms sgs height - character(len=200) :: inputdir - - logical :: use_CVMix_tidal = .false. ! true if CVMix is to be used for determining - ! diffusivity due to tidal mixing - - real :: min_thickness ! Minimum thickness allowed [m] + logical :: int_tide_dissipation = .false. !< Internal tide conversion (from barotropic) + !! with the schemes of St Laurent et al (2002) & Simmons et al (2004) + + integer :: Int_tide_profile !< A coded integer indicating the vertical profile + !! for dissipation of the internal waves. Schemes that are + !! currently encoded are St Laurent et al (2002) and Polzin (2009). + logical :: Lee_wave_dissipation = .false. !< Enable lee-wave driven mixing, following + !! Nikurashin (2010), with a vertical energy + !! deposition profile specified by Lee_wave_profile to be + !! St Laurent et al (2002) or Simmons et al (2004) scheme + + integer :: Lee_wave_profile !< A coded integer indicating the vertical profile + !! for dissipation of the lee waves. Schemes that are + !! currently encoded are St Laurent et al (2002) and + !! Polzin (2009). + real :: Int_tide_decay_scale !< decay scale for internal wave TKE [Z ~> m]. + + real :: Mu_itides !< efficiency for conversion of dissipation + !! to potential energy [nondim] + + real :: Gamma_itides !< fraction of local dissipation [nondim] + + real :: Gamma_lee !< fraction of local dissipation for lee waves + !! (Nikurashin's energy input) [nondim] + real :: Decay_scale_factor_lee !< Scaling factor for the decay scale of lee + !! wave energy dissipation [nondim] + + real :: min_zbot_itides !< minimum depth for internal tide conversion [Z ~> m]. + logical :: Lowmode_itidal_dissipation = .false. !< If true, consider mixing due to breaking low + !! modes that have been remotely generated using an internal tidal + !! dissipation scheme to specify the vertical profile of the energy + !! input to drive diapycnal mixing, along the lines of St. Laurent + !! et al. (2002) and Simmons et al. (2004). + + real :: Nu_Polzin !< The non-dimensional constant used in Polzin form of + !! the vertical scale of decay of tidal dissipation + + real :: Nbotref_Polzin !< Reference value for the buoyancy frequency at the + !! ocean bottom used in Polzin formulation of the + !! vertical scale of decay of tidal dissipation [s-1] + real :: Polzin_decay_scale_factor !< Scaling factor for the decay length scale + !! of the tidal dissipation profile in Polzin [nondim] + real :: Polzin_decay_scale_max_factor !< The decay length scale of tidal dissipation + !! profile in Polzin formulation should not exceed + !! Polzin_decay_scale_max_factor * depth of the ocean [nondim]. + 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] + !! available to mix above the BBL + + real :: utide !< constant tidal amplitude [m s-1] used if + 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 + + logical :: use_CVMix_tidal = .false. !< true if CVMix is to be used for determining + !! diffusivity due to tidal mixing + + real :: min_thickness !< Minimum thickness allowed [m] ! CVMix-specific parameters - type(CVMix_tidal_params_type) :: CVMix_tidal_params - type(CVMix_global_params_type) :: CVMix_glb_params ! for Prandtl number only - real :: tidal_max_coef ! maximum allowable tidal diffusivity. [m^2/s] + integer :: CVMix_tidal_scheme = -1 !< 1 for Simmons, 2 for Schmittner + type(CVMix_tidal_params_type) :: CVMix_tidal_params !< A CVMix-specific type with parameters for tidal mixing + type(CVMix_global_params_type) :: CVMix_glb_params !< CVMix-specific for Prandtl number only + real :: tidal_max_coef !< CVMix-specific maximum allowable tidal diffusivity. [m^2/s] + real :: tidal_diss_lim_tc !< CVMix-specific dissipation limit depth for + !! tidal-energy-constituent data [Z ~> m]. + type(remapping_CS) :: remap_CS !< The control structure for remapping ! Data containers - real, pointer, dimension(:,:) :: TKE_Niku => NULL() - real, pointer, dimension(:,:) :: TKE_itidal => NULL() - real, pointer, dimension(:,:) :: Nb => NULL() - real, pointer, dimension(:,:) :: mask_itidal => NULL() - real, pointer, dimension(:,:) :: h2 => NULL() - real, pointer, dimension(:,:) :: tideamp => NULL() ! RMS tidal amplitude (m/s) - real, allocatable,dimension(:,:) :: tidal_qe_2d ! q*E(x,y) + real, pointer, dimension(:,:) :: TKE_Niku => NULL() !< Lee wave driven Turbulent Kinetic Energy input [W m-2] + real, pointer, dimension(:,:) :: TKE_itidal => NULL() !< The internal Turbulent Kinetic Energy input divided + !! by the bottom stratfication [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]. + real, pointer, dimension(:,:) :: tideamp => NULL() !< RMS tidal amplitude [m s-1] + real, allocatable, dimension(:) :: h_src !< tidal constituent input layer thickness [m] + real, allocatable, dimension(:,:) :: tidal_qe_2d !< Tidal energy input times the local dissipation + !! fraction, q*E(x,y), with the CVMix implementation + !! of Jayne et al tidal mixing [W m-2]. + !! TODO: make this E(x,y) only + real, allocatable, dimension(:,:,:) :: tidal_qe_3d_in !< q*E(x,y,z) with the Schmittner parameterization [W m-3?] ! Diagnostics - type(diag_ctrl), pointer :: diag => NULL() ! structure to regulate diagn output timing - type(diag_to_Z_CS), pointer :: diag_to_Z_CSp => NULL() - type(tidal_mixing_diags), pointer :: dd => NULL() + 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 + !>@{ Diagnostic identifiers integer :: id_TKE_itidal = -1 integer :: id_TKE_leewave = -1 integer :: id_Kd_itidal = -1 @@ -167,41 +187,46 @@ module MOM_tidal_mixing integer :: id_Polzin_decay_scale_scaled = -1 integer :: id_N2_int = -1 integer :: id_Simmons_coeff = -1 + integer :: id_Schmittner_coeff = -1 + integer :: id_tidal_qe_md = -1 integer :: id_vert_dep = -1 + !!@} end type tidal_mixing_cs +!!@{ Coded parmameters for specifying mixing schemes character(len=40) :: mdl = "MOM_tidal_mixing" !< This module's name. character*(20), parameter :: STLAURENT_PROFILE_STRING = "STLAURENT_02" character*(20), parameter :: POLZIN_PROFILE_STRING = "POLZIN_09" -character*(20), parameter :: SIMMONS_PROFILE_STRING = "SIMMONS" -character*(20), parameter :: SCHMITTNER_PROFILE_STRING = "SCHMITTNER" integer, parameter :: STLAURENT_02 = 1 integer, parameter :: POLZIN_09 = 2 -integer, parameter :: SIMMONS_04 = 3 -integer, parameter :: SCHMITTNER = 4 +character*(20), parameter :: SIMMONS_SCHEME_STRING = "SIMMONS" +character*(20), parameter :: SCHMITTNER_SCHEME_STRING = "SCHMITTNER" +integer, parameter :: SIMMONS = 1 +integer, parameter :: SCHMITTNER = 2 +!!@} contains !> Initializes internal tidal dissipation scheme for diapycnal mixing -logical function tidal_mixing_init(Time, G, GV, param_file, diag, diag_to_Z_CSp, CS) - +logical function tidal_mixing_init(Time, G, GV, US, param_file, diag, diag_to_Z_CSp, 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. + type(tidal_mixing_cs), pointer :: CS !< This module's control structure. ! Local variables logical :: read_tideamp character(len=20) :: tmpstr, int_tide_profile_str - character(len=20) :: default_profile_string, tidal_energy_type + 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, zbot, hamp, prandtl_tidal + real :: utide, hamp, prandtl_tidal real :: Niku_scale ! local variable for scaling the Nikurashin TKE flux data integer :: i, j, is, ie, js, je integer :: isd, ied, jsd, jed @@ -244,43 +269,50 @@ logical function tidal_mixing_init(Time, G, GV, param_file, diag, diag_to_Z_CSp, if (.not. tidal_mixing_init) return if (CS%int_tide_dissipation) then - default_profile_string = STLAURENT_PROFILE_STRING - if (CS%use_CVMix_tidal) default_profile_string = SIMMONS_PROFILE_STRING - call get_param(param_file, mdl, "INT_TIDE_PROFILE", int_tide_profile_str, & - "INT_TIDE_PROFILE selects the vertical profile of energy \n"//& - "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 decay profile.", & - default=default_profile_string) - ! TODO: list the newly available profile selections - int_tide_profile_str = uppercase(int_tide_profile_str) - select case (int_tide_profile_str) - case (STLAURENT_PROFILE_STRING) ; CS%int_tide_profile = STLAURENT_02 - case (POLZIN_PROFILE_STRING) ; CS%int_tide_profile = POLZIN_09 - case (SIMMONS_PROFILE_STRING) ; CS%int_tide_profile = SIMMONS_04 - case (SCHMITTNER_PROFILE_STRING) ; CS%int_tide_profile = SCHMITTNER - case default - call MOM_error(FATAL, "tidal_mixing_init: Unrecognized setting "// & - "#define INT_TIDE_PROFILE "//trim(int_tide_profile_str)//" found in input file.") - end select - ! Check profile consistency - if (CS%use_CVMix_tidal .and. (CS%int_tide_profile.eq.STLAURENT_02 .or. & - CS%int_tide_profile.eq.POLZIN_09)) then - call MOM_error(FATAL, "tidal_mixing_init: Tidal mixing profile"// & - " "//trim(int_tide_profile_str)//" unavailable in CVMix. Available "//& - "profiles in CVMix are "//trim(SIMMONS_PROFILE_STRING)//" and "//& - trim(SCHMITTNER_PROFILE_STRING)//".") - else if (.not.CS%use_CVMix_tidal .and. (CS%int_tide_profile.eq.SIMMONS_04.or. & - CS%int_tide_profile.eq.SCHMITTNER)) then - call MOM_error(FATAL, "tidal_mixing_init: Tidal mixing profiles "// & - trim(SIMMONS_PROFILE_STRING)//" and "//trim(SCHMITTNER_PROFILE_STRING)//& - " are available only when USE_CVMix_TIDAL is True.") + ! 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"//& + "scheme with INT_TIDE_DISSIPATION. Valid values are:\n"//& + "\t SIMMONS - Use the Simmons et al (2004) tidal \n"//& + "\t mixing scheme.\n"//& + "\t SCHMITTNER - Use the Schmittner et al (2014) tidal \n"//& + "\t mixing scheme.", & + default=SIMMONS_SCHEME_STRING) + CVMix_tidal_scheme_str = uppercase(CVMix_tidal_scheme_str) + + select case (CVMix_tidal_scheme_str) + case (SIMMONS_SCHEME_STRING) ; CS%CVMix_tidal_scheme = SIMMONS + case (SCHMITTNER_SCHEME_STRING) ; CS%CVMix_tidal_scheme = SCHMITTNER + case default + call MOM_error(FATAL, "tidal_mixing_init: Unrecognized setting "// & + "#define CVMIX_TIDAL_SCHEME "//trim(CVMix_tidal_scheme_str)//" found in input file.") + end select + endif ! CS%use_CVMix_tidal + + ! 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"//& + "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 decay profile.", & + default=STLAURENT_PROFILE_STRING) + int_tide_profile_str = uppercase(int_tide_profile_str) + + select case (int_tide_profile_str) + case (STLAURENT_PROFILE_STRING) ; CS%int_tide_profile = STLAURENT_02 + case (POLZIN_PROFILE_STRING) ; CS%int_tide_profile = POLZIN_09 + case default + call MOM_error(FATAL, "tidal_mixing_init: Unrecognized setting "// & + "#define INT_TIDE_PROFILE "//trim(int_tide_profile_str)//" found in input file.") + end select endif - else if (CS%use_CVMix_tidal) then + elseif (CS%use_CVMix_tidal) then call MOM_error(FATAL, "tidal_mixing_init: Cannot set INT_TIDE_DISSIPATION to False "// & "when USE_CVMix_TIDAL is set to True.") endif @@ -294,7 +326,7 @@ logical function tidal_mixing_init(Time, G, GV, param_file, diag, diag_to_Z_CSp, if (CS%use_CVMix_tidal) then call MOM_error(FATAL, "tidal_mixing_init: Lee wave driven dissipation scheme cannot "// & "be used when CVMix tidal mixing scheme is active.") - end if + endif call get_param(param_file, mdl, "LEE_WAVE_PROFILE", tmpstr, & "LEE_WAVE_PROFILE selects the vertical profile of energy \n"//& "dissipation with LEE_WAVE_DISSIPATION. Valid values are:\n"//& @@ -325,7 +357,7 @@ logical function tidal_mixing_init(Time, G, GV, param_file, diag, diag_to_Z_CSp, if (CS%use_CVMix_tidal) then call MOM_error(FATAL, "tidal_mixing_init: Polzin scheme cannot "// & "be used when CVMix tidal mixing scheme is active.") - end if + 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"//& @@ -352,7 +384,7 @@ logical function tidal_mixing_init(Time, G, GV, param_file, diag, diag_to_Z_CSp, "When the Polzin decay profile is used, this is the \n"//& "minimum vertical decay scale for the vertical profile\n"//& "of internal tide dissipation with the Polzin (2009) formulation", & - units="m", default=0.0) + units="m", default=0.0, scale=US%m_to_Z) endif if (CS%Int_tide_dissipation .or. CS%Lee_wave_dissipation) then @@ -360,7 +392,7 @@ logical function tidal_mixing_init(Time, G, GV, param_file, diag, diag_to_Z_CSp, "The decay scale away from the bottom for tidal TKE with \n"//& "the new coding when INT_TIDE_DISSIPATION is used.", & !units="m", default=0.0) - units="m", default=500.0) ! TODO: confirm this new default + 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"//& "INT_TIDE_DISSIPATION, often 0.2.", units="nondim", default=0.2) @@ -371,7 +403,7 @@ logical function tidal_mixing_init(Time, G, GV, param_file, diag, diag_to_Z_CSp, 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"//& - "ocean depth is less than this value.", units="m", default=0.0) + "ocean depth is less than this value.", units="m", default=0.0, scale=US%m_to_Z) endif if ( (CS%Int_tide_dissipation .or. CS%Lee_wave_dissipation) .and. & @@ -385,7 +417,7 @@ logical function tidal_mixing_init(Time, G, GV, param_file, diag, diag_to_Z_CSp, call get_param(param_file, mdl, "KAPPA_ITIDES", CS%kappa_itides, & "A topographic wavenumber used with INT_TIDE_DISSIPATION. \n"//& "The default is 2pi/10 km, as in St.Laurent et al. 2002.", & - units="m-1", default=8.e-4*atan(1.0)) + 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.", & @@ -407,7 +439,7 @@ logical function tidal_mixing_init(Time, G, GV, param_file, diag, diag_to_Z_CSp, if (CS%use_CVMix_tidal) then call MOM_error(FATAL, "tidal_mixing_init: Tidal amplitude files are "// & "not compatible with CVMix tidal mixing. ") - end if + endif call get_param(param_file, mdl, "TIDEAMP_FILE", tideamp_file, & "The path to the file containing the spatially varying \n"//& "tidal amplitudes with INT_TIDE_DISSIPATION.", default="tideamp.nc") @@ -422,23 +454,22 @@ logical function tidal_mixing_init(Time, G, GV, param_file, diag, diag_to_Z_CSp, fail_if_missing=(.not.CS%use_CVMix_tidal)) filename = trim(CS%inputdir) // trim(h2_file) call log_param(param_file, mdl, "INPUTDIR/H2_FILE", filename) - call MOM_read_data(filename, 'h2', CS%h2, G%domain, timelevel=1) + call MOM_read_data(filename, 'h2', CS%h2, G%domain, timelevel=1, scale=US%m_to_Z**2) do j=js,je ; do i=is,ie if (G%bathyT(i,j) < CS%min_zbot_itides) CS%mask_itidal(i,j) = 0.0 CS%tideamp(i,j) = CS%tideamp(i,j) * CS%mask_itidal(i,j) * G%mask2dT(i,j) ! Restrict rms topo to 10 percent of column depth. - zbot = G%bathyT(i,j) - hamp = sqrt(CS%h2(i,j)) - hamp = min(0.1*zbot,hamp) + !### Note the hard-coded nondimensional constant, and that this could be simplified. + hamp = min(0.1*G%bathyT(i,j),sqrt(CS%h2(i,j))) CS%h2(i,j) = hamp*hamp utide = CS%tideamp(i,j) - ! Compute the fixed part of internal tidal forcing; units are [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 + ! 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*& + CS%kappa_itides * CS%h2(i,j) * utide*utide + enddo ; enddo endif @@ -456,7 +487,7 @@ logical function tidal_mixing_init(Time, G, GV, param_file, diag, diag_to_Z_CSp, filename = trim(CS%inputdir) // trim(Niku_TKE_input_file) 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 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 CS%TKE_Niku(:,:) = Niku_scale * CS%TKE_Niku(:,:) @@ -480,15 +511,14 @@ logical function tidal_mixing_init(Time, G, GV, param_file, diag, diag_to_Z_CSp, call get_param(param_file, mdl, "TIDAL_MAX_COEF", CS%tidal_max_coef, & "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"//& + "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"//& "dissipation. Used with CVMix tidal mixing schemes.", & fail_if_missing=.true.) - tidal_energy_file = trim(CS%inputdir) // trim(tidal_energy_file) - call get_param(param_file, mdl, "TIDAL_ENERGY_TYPE",tidal_energy_type, & - "The type of input tidal energy flux dataset.",& - fail_if_missing=.true.) - ! TODO: list all available tidal energy types here 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, & @@ -498,21 +528,32 @@ logical function tidal_mixing_init(Time, G, GV, param_file, diag, diag_to_Z_CSp, do_not_log=.true.) call CVMix_put(CS%CVMix_glb_params,'Prandtl',prandtl_tidal) - int_tide_profile_str = lowercase(int_tide_profile_str) - - - ! TODO: check parameter consistency. (see POP::tidal_mixing.F90::tidal_check) + tidal_energy_file = trim(CS%inputdir) // trim(tidal_energy_file) + call get_param(param_file, mdl, "TIDAL_ENERGY_TYPE",tidal_energy_type, & + "The type of input tidal energy flux dataset. Valid values are"//& + "\t Jayne\n"//& + "\t ER03 \n",& + fail_if_missing=.true.) + ! Check whether tidal energy input format and CVMix tidal mixing scheme are consistent + if ( .not. ( & + (uppercase(tidal_energy_type(1:4)).eq.'JAYN' .and. CS%CVMix_tidal_scheme.eq.SIMMONS).or. & + (uppercase(tidal_energy_type(1:4)).eq.'ER03' .and. CS%CVMix_tidal_scheme.eq.SCHMITTNER) ) )then + call MOM_error(FATAL, "tidal_mixing_init: Tidal energy file type ("//& + trim(tidal_energy_type)//") is incompatible with CVMix tidal "//& + " mixing scheme: "//trim(CVMix_tidal_scheme_str) ) + endif + CVMix_tidal_scheme_str = lowercase(CVMix_tidal_scheme_str) ! Set up CVMix - call CVMix_init_tidal(CVMix_tidal_params_user = CS%CVMix_tidal_params, & - mix_scheme = int_tide_profile_str, & + call CVMix_init_tidal(CVmix_tidal_params_user = CS%CVMix_tidal_params, & + mix_scheme = CVMix_tidal_scheme_str, & efficiency = CS%Mu_itides, & - vertical_decay_scale = CS%int_tide_decay_scale, & + vertical_decay_scale = CS%int_tide_decay_scale*US%Z_to_m, & max_coefficient = CS%tidal_max_coef, & local_mixing_frac = CS%Gamma_itides, & - depth_cutoff = CS%min_zbot_itides) + depth_cutoff = CS%min_zbot_itides*US%Z_to_m) - call read_tidal_energy(G, tidal_energy_type, tidal_energy_file, CS) + call read_tidal_energy(G, US, tidal_energy_type, tidal_energy_file, CS) !call closeParameterBlock(param_file) @@ -524,14 +565,18 @@ logical function tidal_mixing_init(Time, G, GV, param_file, diag, diag_to_Z_CSp, CS%Lowmode_itidal_dissipation) then CS%id_Kd_itidal = register_diag_field('ocean_model','Kd_itides',diag%axesTi,Time, & - 'Internal Tide Driven Diffusivity', 'm2 s-1') + 'Internal Tide Driven Diffusivity', 'm2 s-1', conversion=US%Z_to_m**2) if (CS%use_CVMix_tidal) then CS%id_N2_int = register_diag_field('ocean_model','N2_int',diag%axesTi,Time, & 'Bouyancy frequency squared, at interfaces', 's-2') - ! TODO: add units + !> TODO: add units CS%id_Simmons_coeff = register_diag_field('ocean_model','Simmons_coeff',diag%axesT1,Time, & 'time-invariant portion of the tidal mixing coefficient using the Simmons', '') + CS%id_Schmittner_coeff = register_diag_field('ocean_model','Schmittner_coeff',diag%axesTL,Time, & + 'time-invariant portion of the tidal mixing coefficient using the Schmittner', '') + CS%id_tidal_qe_md = register_diag_field('ocean_model','tidal_qe_md',diag%axesTL,Time, & + 'input tidal energy dissipated locally interpolated to model vertical coordinates', '') CS%id_vert_dep = register_diag_field('ocean_model','vert_dep',diag%axesTi,Time, & 'vertical deposition function needed for Simmons et al tidal mixing', '') @@ -542,7 +587,7 @@ logical function tidal_mixing_init(Time, G, GV, param_file, diag, diag_to_Z_CSp, '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') + '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') @@ -551,10 +596,12 @@ logical function tidal_mixing_init(Time, G, GV, param_file, diag, diag_to_Z_CSp, 'Vertical flux of tidal turbulent dissipation (from propagating low modes)', 'm3 s-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') + '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, & - 'Vertical decay scale for the tidal turbulent dissipation with Polzin scheme, scaled by N2_bot/N2_meanz', 'm') + CS%id_Polzin_decay_scale_scaled = register_diag_field('ocean_model', & + 'Polzin_decay_scale_scaled', diag%axesT1, Time, & + 'Vertical decay scale for the tidal turbulent dissipation with Polzin scheme, '// & + 'scaled by N2_bot/N2_meanz', 'm', conversion=US%Z_to_m) CS%id_N2_bot = register_diag_field('ocean_model','N2_b',diag%axesT1,Time, & 'Bottom Buoyancy frequency squared', 's-2') @@ -575,24 +622,24 @@ logical function tidal_mixing_init(Time, G, GV, param_file, diag, diag_to_Z_CSp, CS%id_TKE_leewave = register_diag_field('ocean_model','TKE_leewave',diag%axesT1,Time, & 'Lee wave Driven Turbulent Kinetic Energy', 'W m-2') CS%id_Kd_Niku = register_diag_field('ocean_model','Kd_Nikurashin',diag%axesTi,Time, & - 'Lee Wave Driven Diffusivity', 'm2 s-1') + '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) + 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) + 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) + CS%id_Kd_lowmode_z = register_Zint_diag(vd, CS%diag_to_Z_CSp, Time, conversion=US%Z_to_m**2) endif endif @@ -604,59 +651,92 @@ end function tidal_mixing_init !> Depending on whether or not CVMix is active, calls the associated subroutine to compute internal !! tidal dissipation and to add the effect of internal-tide-driven mixing to the layer or interface !! diffusivities. -subroutine calculate_tidal_mixing(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, CS, & - N2_lay, N2_int, Kd, Kd_int, Kd_max) - 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 !< Layer thicknesses, in H (usually m or kg m-2) - real, dimension(SZI_(G)), intent(in) :: N2_bot - real, dimension(SZI_(G),SZK_(G)), intent(in) :: N2_lay - real, dimension(SZI_(G),SZK_(G)+1), intent(in) :: N2_int - integer, intent(in) :: j - real, dimension(SZI_(G),SZK_(G)), intent(in) :: TKE_to_Kd, max_TKE - type(tidal_mixing_cs), pointer :: CS - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: Kd - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), optional, intent(inout) :: Kd_int - real, intent(inout) :: Kd_max +subroutine calculate_tidal_mixing(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, US, CS, & + N2_lay, N2_int, Kd_lay, Kd_int, Kd_max, Kv) + 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 + 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]. + real, dimension(SZI_(G),SZK_(G)), intent(in) :: N2_lay !< The squared buoyancy frequency of the + !! layers [s-2]. + real, dimension(SZI_(G),SZK_(G)+1), intent(in) :: N2_int !< The squared buoyancy frequency at the + !! interfaces [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, + !! usually (~Rho_0 / (G_Earth * dRho_lay)) + !! [Z2 s-1 / m3 s-3 = Z2 s2 m-3 ~> 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] + 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]. + 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]. + real, intent(in) :: Kd_max !< The maximum increment for diapycnal + !! diffusivity due to TKE-based processes, + !! [Z2 s-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]. if (CS%Int_tide_dissipation .or. CS%Lee_wave_dissipation .or. CS%Lowmode_itidal_dissipation) then if (CS%use_CVMix_tidal) then - call calculate_CVMix_tidal(h, j, G, GV, CS, N2_int, Kd) + 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, CS, & - N2_lay, Kd, 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, Kd_max) endif endif -end subroutine +end subroutine calculate_tidal_mixing !> Calls the CVMix routines to compute tidal dissipation and to add the effect of internal-tide-driven !! mixing to the interface diffusivities. -subroutine calculate_CVMix_tidal(h, j, G, GV, CS, N2_int, Kd) - integer, intent(in) :: j - type(ocean_grid_type), intent(in) :: G !< Grid structure. - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(tidal_mixing_cs), pointer :: CS !< This module's control structure. - real, dimension(SZI_(G),SZK_(G)+1), intent(in) :: N2_int - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2). - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: Kd +subroutine calculate_CVMix_tidal(h, j, G, GV, US, CS, N2_int, Kd_lay, Kv) + integer, intent(in) :: j !< The j-index to work on + type(ocean_grid_type), intent(in) :: G !< Grid structure. + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + 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]. + 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]. + real, dimension(:,:,:), pointer :: Kv !< The "slow" vertical viscosity at each interface + !! (not layer!) [Z2 s-1 ~> m2 s-1]. + ! Local variables + real, dimension(SZK_(G)+1) :: Kd_tidal ! tidal diffusivity [m2/s] + real, dimension(SZK_(G)+1) :: Kv_tidal ! tidal viscosity [m2/s] + real, dimension(SZK_(G)+1) :: vert_dep ! vertical deposition + real, dimension(SZK_(G)+1) :: iFaceHeight ! Height of interfaces [m] + real, dimension(SZK_(G)+1) :: SchmittnerSocn + 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)) :: Schmittner_coeff + real, dimension(SZK_(G)) :: h_m ! Cell thickness [m] + real, allocatable, dimension(:,:) :: exp_hab_zetar - ! local - real, dimension(SZK_(G)+1) :: Kd_tidal !< tidal diffusivity [m2/s] - real, dimension(SZK_(G)+1) :: Kv_tidal !< tidal viscosity [m2/s] - real, dimension(SZK_(G)+1) :: vert_dep !< vertical deposition needed for Simmons tidal mixing. - real, dimension(SZK_(G)+1) :: iFaceHeight !< Height of interfaces (m) - real, dimension(SZK_(G)) :: cellHeight !< Height of cell centers (m) integer :: i, k, is, ie real :: dh, hcorr, Simmons_coeff - real, parameter :: rho_fw = 1000.0 ! fresh water density [kg/m^3] ! TODO: when coupled, get this from CESM (SHR_CONST_RHOFW) - type(tidal_mixing_diags), pointer :: dd + real, parameter :: rho_fw = 1000.0 ! fresh water density [kg/m^3] + ! TODO: when coupled, get this from CESM (SHR_CONST_RHOFW) + real :: h_neglect, h_neglect_edge + type(tidal_mixing_diags), pointer :: dd => NULL() is = G%isc ; ie = G%iec dd => CS%dd - select case (CS%int_tide_profile) - case (SIMMONS_04) + select case (CS%CVMix_tidal_scheme) + case (SIMMONS) do i=is,ie if (G%mask2dT(i,j)<1) cycle @@ -665,7 +745,7 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, CS, N2_int, Kd) hcorr = 0.0 do k=1,G%ke ! cell center and cell bottom in meters (negative values in the ocean) - dh = h(i,j,k) * GV%H_to_m ! Nominal thickness to use for increment + dh = h(i,j,k) * GV%H_to_m ! Nominal thickness to use for increment, rescaled to m for use by CVMix. dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness @@ -699,11 +779,18 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, CS, N2_int, Kd) CVMix_params = CS%CVMix_glb_params, & CVMix_tidal_params_user = CS%CVMix_tidal_params) + ! Update diffusivity do k=1,G%ke - Kd(i,j,k) = Kd(i,j,k) + 0.5*(Kd_tidal(k) + Kd_tidal(k+1) ) - !TODO: Kv(i,j,k) = ???????????? + 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. enddo + ! Update viscosity with the proper unit conversion. + if (associated(Kv)) then + do k=1,G%ke+1 + Kv(i,j,k) = Kv(i,j,k) + US%m_to_Z**2 * Kv_tidal(k) ! Rescale from m2 s-1 to Z2 s-1. + enddo + endif + ! diagnostics if (associated(dd%Kd_itidal)) then dd%Kd_itidal(i,j,:) = Kd_tidal(:) @@ -720,10 +807,111 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, CS, N2_int, Kd) enddo ! i=is,ie - ! TODO: case (SCHMITTNER) + case (SCHMITTNER) + + ! TODO: correct exp_hab_zetar shapes in CVMix_compute_Schmittner_invariant + ! and CVMix_compute_SchmittnerCoeff low subroutines + + allocate(exp_hab_zetar(G%ke+1,G%ke+1)) + if (GV%Boussinesq) then + h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 + else + h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 + endif + + + do i=is,ie + + if (G%mask2dT(i,j)<1) cycle + + iFaceHeight = 0.0 ! BBL is all relative to the surface + hcorr = 0.0 + do k=1,G%ke + h_m(k) = h(i,j,k)*GV%H_to_m ! Rescale thicknesses to m for use by CVmix. + ! cell center and cell bottom in meters (negative values in the ocean) + dh = h_m(k) + hcorr ! Nominal thickness less the accumulated error (could temporarily make dh<0) + hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 + dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness + cellHeight(k) = iFaceHeight(k) - 0.5 * dh + iFaceHeight(k+1) = iFaceHeight(k) - dh + enddo + + SchmittnerSocn = 0.0 ! TODO: compute this + + ! form the time-invariant part of Schmittner coefficient term + call CVMix_compute_Schmittner_invariant(nlev = G%ke, & + VertDep = vert_dep, & + efficiency = CS%Mu_itides, & + rho = rho_fw, & + exp_hab_zetar = exp_hab_zetar, & + zw = iFaceHeight, & + CVmix_tidal_params_user = CS%CVMix_tidal_params) + !TODO: in above call, there is no need to pass efficiency, since it gets + ! passed via CVMix_init_tidal and stored in CVMix_tidal_params. Change + ! CVMix API to prevent this redundancy. + + ! remap from input z coordinate to model coordinate: + tidal_qe_md = 0.0 + call remapping_core_h(CS%remap_cs, size(CS%h_src), CS%h_src, CS%tidal_qe_3d_in(i,j,:), & + G%ke, h_m, tidal_qe_md) + + ! form the Schmittner coefficient that is based on 3D q*E, which is formed from + ! summing q_i*TidalConstituent_i over the number of constituents. + call CVMix_compute_SchmittnerCoeff( nlev = G%ke, & + energy_flux = tidal_qe_md(:), & + rho = rho_fw, & + SchmittnerCoeff = Schmittner_coeff, & + exp_hab_zetar = exp_hab_zetar, & + CVmix_tidal_params_user = CS%CVMix_tidal_params) + + + call CVMix_coeffs_tidal_schmittner( Mdiff_out = Kv_tidal, & + Tdiff_out = Kd_tidal, & + Nsqr = N2_int(i,:), & + OceanDepth = -iFaceHeight(G%ke+1), & + vert_dep = vert_dep, & + nlev = G%ke, & + max_nlev = G%ke, & + SchmittnerCoeff = Schmittner_coeff, & + SchmittnerSouthernOcean = SchmittnerSocn, & + CVmix_params = CS%CVMix_glb_params, & + CVmix_tidal_params_user = CS%CVMix_tidal_params) + + ! 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. + enddo + + ! Update viscosity + if (associated(Kv)) then + do k=1,G%ke+1 + Kv(i,j,k) = Kv(i,j,k) + US%m_to_Z**2 * Kv_tidal(k) ! Rescale from m2 s-1 to Z2 s-1. + enddo + endif + + ! diagnostics + if (associated(dd%Kd_itidal)) then + dd%Kd_itidal(i,j,:) = Kd_tidal(:) + endif + if (associated(dd%N2_int)) then + dd%N2_int(i,j,:) = N2_int(i,:) + endif + if (associated(dd%Schmittner_coeff_3d)) then + dd%Schmittner_coeff_3d(i,j,:) = Schmittner_coeff(:) + endif + if (associated(dd%tidal_qe_md)) then + dd%tidal_qe_md(i,j,:) = tidal_qe_md(:) + endif + if (associated(dd%vert_dep_3d)) then + dd%vert_dep_3d(i,j,:) = vert_dep(:) + endif + enddo ! i=is,ie + + deallocate(exp_hab_zetar) + case default - call MOM_error(FATAL, "tidal_mixing_init: The selected"// & - " INT_TIDE_PROFILE is unavailable in CVMix") + call MOM_error(FATAL, "tidal_mixing_init: Unrecognized setting "// & + "#define CVMIX_TIDAL_SCHEME found in input file.") end select end subroutine calculate_CVMix_tidal @@ -735,68 +923,80 @@ end subroutine calculate_CVMix_tidal !! low modes (rays) of the internal tide ("lowmode"), and (3) local dissipation of internal lee waves. !! Will eventually need to add diffusivity due to other wave-breaking processes (e.g. Bottom friction, !! Froude-number-depending breaking, PSI, etc.). -subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, CS, & - N2_lay, Kd, Kd_int, Kd_max) - 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 !< Layer thicknesses, in H (usually m or kg m-2) - real, dimension(SZI_(G)), intent(in) :: N2_bot - real, dimension(SZI_(G),SZK_(G)), intent(in) :: N2_lay - integer, intent(in) :: j - real, dimension(SZI_(G),SZK_(G)), intent(in) :: TKE_to_Kd, max_TKE - type(tidal_mixing_cs), pointer :: CS - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: Kd - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), optional, intent(inout) :: Kd_int - real, intent(inout) :: Kd_max - - ! This subroutine adds the effect of internal-tide-driven mixing to the layer diffusivities. - ! The mechanisms considered are (1) local dissipation of internal waves generated by the - ! barotropic flow ("itidal"), (2) local dissipation of internal waves generated by the propagating - ! low modes (rays) of the internal tide ("lowmode"), and (3) local dissipation of internal lee waves. - ! Will eventually need to add diffusivity due to other wave-breaking processes (e.g. Bottom friction, - ! Froude-number-depending breaking, PSI, etc.). +subroutine 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) + 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 + 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]. + real, dimension(SZI_(G),SZK_(G)), intent(in) :: N2_lay !< The squared buoyancy frequency of the + !! layers [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, + !! usually (~Rho_0 / (G_Earth * dRho_lay)) + !! [Z2 s-1 / m3 s-3 = Z2 s2 m-3 ~> 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] + 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]. + 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]. + real, intent(in) :: Kd_max !< The maximum increment for diapycnal + !! diffusivity due to TKE-based processes + !! [Z2 s-1 ~> m2 s-1]. + !! Set this to a negative value to have no limit. + + ! local real, dimension(SZI_(G)) :: & htot, & ! total thickness above or below a layer, or the - ! integrated thickness in the BBL (meter) - htot_WKB, & ! distance from top to bottom (meter) WKB scaled - TKE_itidal_bot, & ! internal tide TKE at ocean bottom (m3/s3) - TKE_Niku_bot, & ! lee-wave TKE at ocean bottom (m3/s3) - TKE_lowmode_bot, & ! internal tide TKE at ocean bottom lost from all remote low modes (m3/s3) (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) - z0_Polzin, & ! TKE decay scale in Polzin formulation (meter) - z0_Polzin_scaled, & ! TKE decay scale in Polzin formulation (meter) + ! 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) + 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) + z0_Polzin, & ! TKE decay scale in Polzin formulation [Z ~> m]. + z0_Polzin_scaled, & ! TKE decay scale in Polzin formulation [Z ~> m]. ! multiplied by N2_bot/N2_meanz to be coherent with the WKB scaled z ! 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 (1/s2) for WKB scaling + 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_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, & ! 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, & - ! fraction of bottom TKE that should appear at top of a layer (nondim) (BDM) - z_from_bot, & ! distance from bottom (meter) - z_from_bot_WKB ! distance from bottom (meter), WKB scaled - - real :: I_rho0 ! 1 / RHO0, (m3/kg) - real :: Kd_add ! diffusivity to add in a layer (m2/sec) - real :: TKE_itide_lay ! internal tide TKE imparted to a layer (from barotropic) (m3/s3) - real :: TKE_Niku_lay ! lee-wave TKE imparted to a layer (m3/s3) - real :: TKE_lowmode_lay ! internal tide TKE imparted to a layer (from low mode) (m3/s3) (BDM) - real :: frac_used ! fraction of TKE that can be used in a layer (nondim) - real :: Izeta ! inverse of TKE decay scale (1/meter) - real :: Izeta_lee ! inverse of TKE decay scale for lee waves (1/meter) - real :: z0_psl ! temporary variable with units of meter - real :: TKE_lowmode_tot ! TKE from all low modes (W/m2) (BDM) + ! fraction of bottom TKE that should appear at top of a layer [nondim] (BDM) + z_from_bot, & ! distance from bottom [Z ~> m]. + z_from_bot_WKB ! WKB scaled distance from bottom [Z ~> m]. + + 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 :: 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) logical :: use_Polzin, use_Simmons + character(len=160) :: mesg ! The text of an error message integer :: i, k, is, ie, nz integer :: a, fr, m - type(tidal_mixing_diags), pointer :: dd + type(tidal_mixing_diags), pointer :: dd => NULL() is = G%isc ; ie = G%iec ; nz = G%ke dd => CS%dd @@ -805,7 +1005,7 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, CS, do i=is,ie ; htot(i) = 0.0 ; Inv_int(i) = 0.0 ; Inv_int_lee(i) = 0.0 ; Inv_int_low(i) = 0.0 ;enddo do k=1,nz ; do i=is,ie - htot(i) = htot(i) + GV%H_to_m*h(i,j,k) + htot(i) = htot(i) + GV%H_to_Z*h(i,j,k) enddo ; enddo I_Rho0 = 1.0/GV%Rho0 @@ -820,9 +1020,9 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, CS, ! Calculate parameters for vertical structure of dissipation ! Simmons: if ( use_Simmons ) then - Izeta = 1.0 / max(CS%Int_tide_decay_scale, GV%H_subroundoff*GV%H_to_m) + Izeta = 1.0 / max(CS%Int_tide_decay_scale, GV%H_subroundoff*GV%H_to_Z) Izeta_lee = 1.0 / max(CS%Int_tide_decay_scale*CS%Decay_scale_factor_lee, & - GV%H_subroundoff*GV%H_to_m) + 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) @@ -841,7 +1041,7 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, CS, Inv_int_low(i) = 1.0 / (1.0 - exp(-Izeta*htot(i))) endif endif - z_from_bot(i) = GV%H_to_m*h(i,j,nz) + z_from_bot(i) = GV%H_to_Z*h(i,j,nz) enddo endif ! Simmons @@ -850,10 +1050,10 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, CS, ! 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_m*h(i,j,k) + N2_meanz(i) = N2_meanz(i) + 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_m) + N2_meanz(i) = N2_meanz(i) / (htot(i) + GV%H_subroundoff*GV%H_to_Z) if (associated(dd%N2_meanz)) dd%N2_meanz(i,j) = N2_meanz(i) enddo @@ -861,20 +1061,21 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, CS, 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_m*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)*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)) + !### 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) = CS%Polzin_decay_scale_factor * CS%Nu_Polzin * & + z0_polzin(i) = US%m_to_Z * 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 ) 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 + if (N2_meanz(i) > 1.0e-14 ) then !### Here 1.0e-14 has dimensions of s-2. z0_polzin_scaled(i) = z0_polzin(i)*CS%Nb(i,j)**2 / N2_meanz(i) else z0_polzin_scaled(i) = CS%Polzin_decay_scale_max_factor * htot(i) @@ -895,30 +1096,29 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, CS, if ( CS%Int_tide_dissipation .and. (CS%int_tide_profile == POLZIN_09) ) then ! For the Polzin formulation, this if loop prevents the vertical ! flux of energy dissipation from having NaN values - if (htot_WKB(i) > 1.0e-14) then - Inv_int(i) = ( z0_polzin_scaled(i) / htot_WKB(i) ) + 1 + if (htot_WKB(i) > 1.0e-14*US%m_to_Z) then !### Avoid using this dimensional constant. + Inv_int(i) = ( z0_polzin_scaled(i) / htot_WKB(i) ) + 1.0 endif endif if ( CS%lee_wave_dissipation .and. (CS%lee_wave_profile == POLZIN_09) ) then ! For the Polzin formulation, this if loop prevents the vertical ! flux of energy dissipation from having NaN values - if (htot_WKB(i) > 1.0e-14) then - Inv_int_lee(i) = ( z0_polzin_scaled(i)*CS%Decay_scale_factor_lee / htot_WKB(i) ) + 1 + if (htot_WKB(i) > 1.0e-14*US%m_to_Z) then !### Avoid using this dimensional constant. + Inv_int_lee(i) = ( z0_polzin_scaled(i)*CS%Decay_scale_factor_lee / htot_WKB(i) ) + 1.0 endif endif if ( CS%Lowmode_itidal_dissipation .and. (CS%int_tide_profile == POLZIN_09) ) then ! For the Polzin formulation, this if loop prevents the vertical ! flux of energy dissipation from having NaN values - if (htot_WKB(i) > 1.0e-14) then - Inv_int_low(i) = ( z0_polzin_scaled(i) / htot_WKB(i) ) + 1 + if (htot_WKB(i) > 1.0e-14*US%m_to_Z) then !### Avoid using this dimensional constant. + Inv_int_low(i) = ( z0_polzin_scaled(i) / htot_WKB(i) ) + 1.0 endif endif - z_from_bot(i) = GV%H_to_m*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 - z_from_bot_WKB(i) = GV%H_to_m*h(i,j,nz)*N2_lay(i,nz) / N2_meanz(i) + 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) else ; z_from_bot_WKB(i) = 0 ; endif enddo endif ! Polzin @@ -944,8 +1144,8 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, CS, ! TODO: uncomment the following call and fix it !call get_lowmode_loss(i,j,G,CS%int_tide_CSp,"WaveDrag",TKE_lowmode_tot) - print *, "========", __FILE__, __LINE__ - call MOM_error(FATAL,"this block not supported yet. (aa)") + write (mesg,*) "========", __FILE__, __LINE__ + call MOM_error(FATAL,trim(mesg)//": this block not supported yet. (aa)") TKE_lowmode_bot(i) = CS%Mu_itides * I_rho0 * TKE_lowmode_tot endif @@ -962,7 +1162,7 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, CS, if ( use_Simmons ) then do k=nz-1,2,-1 ; do i=is,ie if (max_TKE(i,k) <= 0.0) cycle - z_from_bot(i) = z_from_bot(i) + GV%H_to_m*h(i,j,k) + z_from_bot(i) = z_from_bot(i) + GV%H_to_Z*h(i,j,k) ! Fraction of bottom flux predicted to reach top of this layer TKE_frac_top(i) = Inv_int(i) * exp(-Izeta * z_from_bot(i)) @@ -977,10 +1177,10 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, CS, ! 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) - TKE_itide_lay = frac_used * TKE_itide_lay - TKE_Niku_lay = frac_used * TKE_Niku_lay - TKE_lowmode_lay = frac_used * TKE_lowmode_lay + 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 endif ! Calculate vertical flux available to bottom of layer above @@ -992,7 +1192,7 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, CS, Kd_add = 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(i,j,k) = Kd(i,j,k) + Kd_add + Kd_lay(i,j,k) = Kd_lay(i,j,k) + Kd_add if (present(Kd_int)) then Kd_int(i,j,K) = Kd_int(i,j,K) + 0.5*Kd_add @@ -1036,16 +1236,16 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, CS, dd%Kd_lowmode_work(i,j,k) = GV%Rho0 * TKE_lowmode_lay if (associated(dd%Fl_lowmode)) dd%Fl_lowmode(i,j,k) = TKE_lowmode_rem(i) - enddo ; enddo ; + enddo ; enddo endif ! Simmons ! Polzin: if ( use_Polzin ) then do k=nz-1,2,-1 ; do i=is,ie if (max_TKE(i,k) <= 0.0) cycle - z_from_bot(i) = z_from_bot(i) + GV%H_to_m*h(i,j,k) + z_from_bot(i) = z_from_bot(i) + GV%H_to_Z*h(i,j,k) if (N2_meanz(i) > 1.0e-14 ) then - z_from_bot_WKB(i) = z_from_bot_WKB(i) + GV%H_to_m*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)*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 @@ -1079,7 +1279,7 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, CS, Kd_add = 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(i,j,k) = Kd(i,j,k) + Kd_add + Kd_lay(i,j,k) = Kd_lay(i,j,k) + Kd_add if (present(Kd_int)) then Kd_int(i,j,K) = Kd_int(i,j,K) + 0.5*Kd_add @@ -1122,19 +1322,19 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, CS, dd%Kd_lowmode_work(i,j,k) = GV%Rho0 * TKE_lowmode_lay if (associated(dd%Fl_lowmode)) dd%Fl_lowmode(i,j,k) = TKE_lowmode_rem(i) - enddo ; enddo; + enddo ; enddo endif ! Polzin end subroutine add_int_tide_diffusivity !> Sets up diagnostics arrays for tidal mixing. subroutine setup_tidal_diagnostics(G,CS) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(tidal_mixing_cs), pointer :: CS + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(tidal_mixing_cs), pointer :: CS !< The control structure for this module ! local integer :: isd, ied, jsd, jed, nz - type(tidal_mixing_diags), pointer :: dd + type(tidal_mixing_diags), pointer :: dd => NULL() isd = G%isd; ied = G%ied; jsd = G%jsd; jed = G%jed; nz = G%ke dd => CS%dd @@ -1190,25 +1390,44 @@ subroutine setup_tidal_diagnostics(G,CS) allocate(dd%N2_int(isd:ied,jsd:jed,nz+1)) ; dd%N2_int(:,:,:) = 0.0 endif if (CS%id_Simmons_coeff > 0) then + if (CS%CVMix_tidal_scheme .ne. SIMMONS) then + call MOM_error(FATAL, "setup_tidal_diagnostics: Simmons_coeff diagnostics is available "//& + "only when CVMix_tidal_scheme is Simmons") + endif allocate(dd%Simmons_coeff_2d(isd:ied,jsd:jed)) ; dd%Simmons_coeff_2d(:,:) = 0.0 endif if (CS%id_vert_dep > 0) then allocate(dd%vert_dep_3d(isd:ied,jsd:jed,nz+1)) ; dd%vert_dep_3d(:,:,:) = 0.0 endif + if (CS%id_Schmittner_coeff > 0) then + if (CS%CVMix_tidal_scheme .ne. SCHMITTNER) then + call MOM_error(FATAL, "setup_tidal_diagnostics: Schmittner_coeff diagnostics is available "//& + "only when CVMix_tidal_scheme is Schmittner.") + endif + allocate(dd%Schmittner_coeff_3d(isd:ied,jsd:jed,nz)) ; dd%Schmittner_coeff_3d(:,:,:) = 0.0 + endif + if (CS%id_tidal_qe_md > 0) then + if (CS%CVMix_tidal_scheme .ne. SCHMITTNER) then + call MOM_error(FATAL, "setup_tidal_diagnostics: tidal_qe_md diagnostics is available "//& + "only when CVMix_tidal_scheme is Schmittner.") + endif + allocate(dd%tidal_qe_md(isd:ied,jsd:jed,nz)) ; dd%tidal_qe_md(:,:,:) = 0.0 + endif end subroutine setup_tidal_diagnostics -subroutine post_tidal_diagnostics(G,GV,h,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. +!> This subroutine offers up diagnostics of the tidal mixing. +subroutine post_tidal_diagnostics(G, GV, h ,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. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2). - type(tidal_mixing_cs), pointer :: CS + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + 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 + type(tidal_mixing_diags), pointer :: dd => NULL() num_z_diags = 0 dd => CS%dd @@ -1229,6 +1448,8 @@ subroutine post_tidal_diagnostics(G,GV,h,CS) if (CS%id_N2_int> 0) call post_data(CS%id_N2_int, dd%N2_int, CS%diag) if (CS%id_vert_dep> 0) call post_data(CS%id_vert_dep, dd%vert_dep_3d, CS%diag) if (CS%id_Simmons_coeff> 0) call post_data(CS%id_Simmons_coeff, dd%Simmons_coeff_2d, CS%diag) + if (CS%id_Schmittner_coeff> 0) call post_data(CS%id_Schmittner_coeff, dd%Schmittner_coeff_3d, CS%diag) + if (CS%id_tidal_qe_md> 0) call post_data(CS%id_tidal_qe_md, dd%tidal_qe_md, CS%diag) if (CS%id_Kd_Itidal_Work > 0) & call post_data(CS%id_Kd_Itidal_Work, dd%Kd_Itidal_Work, CS%diag) @@ -1280,51 +1501,167 @@ subroutine post_tidal_diagnostics(G,GV,h,CS) if (associated(dd%N2_int)) deallocate(dd%N2_int) if (associated(dd%vert_dep_3d)) deallocate(dd%vert_dep_3d) if (associated(dd%Simmons_coeff_2d)) deallocate(dd%Simmons_coeff_2d) + if (associated(dd%Schmittner_coeff_3d)) deallocate(dd%Schmittner_coeff_3d) + if (associated(dd%tidal_qe_md)) deallocate(dd%tidal_qe_md) end subroutine post_tidal_diagnostics ! TODO: move this subroutine to MOM_internal_tide_input module (?) -subroutine read_tidal_energy(G, tidal_energy_type, tidal_energy_file, CS) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - character(len=20), intent(in) :: tidal_energy_type - character(len=200), intent(in) :: tidal_energy_file - type(tidal_mixing_cs), pointer :: CS +!> This subroutine read tidal energy inputs from a file. +subroutine read_tidal_energy(G, US, tidal_energy_type, tidal_energy_file, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + character(len=20), intent(in) :: tidal_energy_type !< The type of tidal energy inputs to read + character(len=200), intent(in) :: tidal_energy_file !< The file from which to read tidalinputs + type(tidal_mixing_cs), pointer :: CS !< The control structure for this module ! local - integer :: isd, ied, jsd, jed - real, allocatable, dimension(:,:) :: tidal_energy_flux_2d ! input tidal energy flux at T-grid points (W/m^2) + integer :: i, j, isd, ied, jsd, jed, nz + real, allocatable, dimension(:,:) :: tidal_energy_flux_2d ! input tidal energy flux at T-grid points [W m-2] - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - - if (.not. allocated(CS%tidal_qe_2d)) allocate(CS%tidal_qe_2d(isd:ied,jsd:jed)) - allocate(tidal_energy_flux_2d(isd:ied,jsd:jed)) + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = G%ke select case (uppercase(tidal_energy_type(1:4))) - case ('JAYN') ! Jayne 2009 input tidal energy flux + case ('JAYN') ! Jayne 2009 + if (.not. allocated(CS%tidal_qe_2d)) allocate(CS%tidal_qe_2d(isd:ied,jsd:jed)) + allocate(tidal_energy_flux_2d(isd:ied,jsd:jed)) call MOM_read_data(tidal_energy_file,'wave_dissipation',tidal_energy_flux_2d, G%domain) - CS%tidal_qe_2d = (CS%Gamma_itides) * tidal_energy_flux_2d + do j=G%jsc,G%jec ; do i=G%isc,G%iec + CS%tidal_qe_2d(i,j) = CS%Gamma_itides * tidal_energy_flux_2d(i,j) + enddo ; enddo + deallocate(tidal_energy_flux_2d) + case ('ER03') ! Egbert & Ray 2003 + call read_tidal_constituents(G, US, tidal_energy_file, CS) case default call MOM_error(FATAL, "read_tidal_energy: Unknown tidal energy file type.") - ! TODO: add more tidal energy file types, e.g., Arbic, ER03, GN13, LGM0, etc. - ! see POP::tidal_mixing.F90 end select - deallocate(tidal_energy_flux_2d) - end subroutine read_tidal_energy +!> This subroutine reads tidal input energy from a file by constituent. +subroutine read_tidal_constituents(G, US, tidal_energy_file, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + character(len=200), intent(in) :: tidal_energy_file !< The file from which to read tidal energy inputs + type(tidal_mixing_cs), pointer :: CS !< The control structure for this module + + ! local variables + real, parameter :: C1_3 = 1.0/3.0 + real, dimension(SZI_(G),SZJ_(G)) :: & + tidal_qk1, & ! qk1 coefficient used in Schmittner & Egbert + tidal_qo1 ! qo1 coefficient used in Schmittner & Egbert + real, allocatable, dimension(:) :: & + z_t, & ! depth from surface to midpoint of input layer [Z] + z_w ! depth from surface to top of input layer [Z] + real, allocatable, dimension(:,:,:) :: & + tc_m2, & ! input lunar semidiurnal tidal energy flux [W/m^2] + tc_s2, & ! input solar semidiurnal tidal energy flux [W/m^2] + tc_k1, & ! input lunar diurnal tidal energy flux [W/m^2] + tc_o1 ! input lunar diurnal tidal energy flux [W/m^2] + integer, dimension(4) :: nz_in + integer :: k, is, ie, js, je, isd, ied, jsd, jed, i, j + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + ! get number of input levels: + call field_size(tidal_energy_file, 'z_t', nz_in) + + ! allocate local variables + allocate(z_t(nz_in(1)), z_w(nz_in(1)) ) + allocate(tc_m2(isd:ied,jsd:jed,nz_in(1)), & + tc_s2(isd:ied,jsd:jed,nz_in(1)), & + tc_k1(isd:ied,jsd:jed,nz_in(1)), & + tc_o1(isd:ied,jsd:jed,nz_in(1)) ) + + ! allocate CS variables associated with 3d tidal energy dissipation + if (.not. allocated(CS%tidal_qe_3d_in)) allocate(CS%tidal_qe_3d_in(isd:ied,jsd:jed,nz_in(1))) + if (.not. allocated(CS%h_src)) allocate(CS%h_src(nz_in(1))) + + ! read in tidal constituents + call MOM_read_data(tidal_energy_file, 'M2', tc_m2, G%domain) + call MOM_read_data(tidal_energy_file, 'S2', tc_s2, G%domain) + call MOM_read_data(tidal_energy_file, 'K1', tc_k1, G%domain) + call MOM_read_data(tidal_energy_file, 'O1', tc_o1, G%domain) + ! Note the hard-coded assumption that z_t and z_w in the file are in centimeters. + call MOM_read_data(tidal_energy_file, 'z_t', z_t, scale=100.0*US%m_to_Z) + call MOM_read_data(tidal_energy_file, 'z_w', z_w, scale=100.0*US%m_to_Z) + + do j=js,je ; do i=is,ie + if (abs(G%geoLatT(i,j)) < 30.0) then + tidal_qk1(i,j) = C1_3 + tidal_qo1(i,j) = C1_3 + else + tidal_qk1(i,j) = 1.0 + tidal_qo1(i,j) = 1.0 + endif + enddo ; enddo + + CS%tidal_qe_3d_in(:,:,:) = 0.0 + do k=1,nz_in(1) + ! Store the input cell thickness in m for use with CVmix. + CS%h_src(k) = US%Z_to_m*(z_t(k)-z_w(k))*2.0 + ! form tidal_qe_3d_in from weighted tidal constituents + do j=js,je ; do i=is,ie + if ((z_t(k) <= G%bathyT(i,j)) .and. (z_w(k) > CS%tidal_diss_lim_tc)) & + CS%tidal_qe_3d_in(i,j,k) = C1_3*tc_m2(i,j,k) + C1_3*tc_s2(i,j,k) + & + tidal_qk1(i,j)*tc_k1(i,j,k) + tidal_qo1(i,j)*tc_o1(i,j,k) + enddo ; enddo + enddo + + !open(unit=1905,file="out_1905.txt",access="APPEND") + !do j=G%jsd,G%jed + ! do i=isd,ied + ! if ( i+G%idg_offset .eq. 90 .and. j+G%jdg_offset .eq. 126) then + ! write(1905,*) "-------------------------------------------" + ! do k=50,nz_in(1) + ! write(1905,*) i,j,k + ! write(1905,*) CS%tidal_qe_3d_in(i,j,k), tc_m2(i,j,k) + ! write(1905,*) z_t(k), G%bathyT(i,j), z_w(k),CS%tidal_diss_lim_tc + ! end do + ! endif + ! enddo + !enddo + !close(1905) + + ! test if qE is positive + if (any(CS%tidal_qe_3d_in<0.0)) then + call MOM_error(FATAL, "read_tidal_constituents: Negative tidal_qe_3d_in terms.") + endif + + !! collapse 3D q*E to 2D q*E + !CS%tidal_qe_2d(:,:) = 0.0 + !do k=1,nz_in(1) ; do j=js,je ; do i=is,ie + ! if (z_t(k) <= G%bathyT(i,j)) & + ! CS%tidal_qe_2d(i,j) = CS%tidal_qe_2d(i,j) + CS%tidal_qe_3d_in(i,j,k) + !enddo ; enddo ; enddo + + ! initialize input remapping: + call initialize_remapping(CS%remap_cs, remapping_scheme="PLM", & + boundary_extrapolation=.false., check_remapping=CS%debug) + + deallocate(tc_m2) + deallocate(tc_s2) + deallocate(tc_k1) + deallocate(tc_o1) + deallocate(z_t) + deallocate(z_w) + +end subroutine read_tidal_constituents !> Clear pointers and deallocate memory subroutine tidal_mixing_end(CS) - type(tidal_mixing_cs), pointer :: CS ! This module's control structure + type(tidal_mixing_cs), pointer :: CS !< This module's control structure, which + !! will be deallocated in this routine. if (.not.associated(CS)) return !TODO deallocate all the dynamically allocated members here ... - if (allocated(CS%tidal_qe_2d)) deallocate(CS%tidal_qe_2d) + if (allocated(CS%tidal_qe_2d)) deallocate(CS%tidal_qe_2d) + if (allocated(CS%tidal_qe_3d_in)) deallocate(CS%tidal_qe_3d_in) + if (allocated(CS%h_src)) deallocate(CS%h_src) deallocate(CS%dd) deallocate(CS) end subroutine tidal_mixing_end - end module MOM_tidal_mixing diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 4fc0c276df..e01374b5c6 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -2,7 +2,7 @@ module MOM_vert_friction ! This file is part of MOM6. See LICENSE.md for the license. - +use MOM_domains, only : pass_var, To_All, Omit_corners use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : diag_ctrl use MOM_debugging, only : uvchksum, hchksum @@ -16,6 +16,7 @@ module MOM_vert_friction use MOM_PointAccel, only : write_u_accel, write_v_accel, PointAccel_init use MOM_PointAccel, only : PointAccel_CS use MOM_time_manager, only : time_type, time_type_to_real, operator(-) +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs, vertvisc_type use MOM_variables, only : cont_diag_ptrs, accel_diag_ptrs use MOM_variables, only : ocean_internal_state @@ -29,20 +30,25 @@ module MOM_vert_friction public vertvisc_limit_vel, vertvisc_init, vertvisc_end public updateCFLtruncationValue +! 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 with parameters and memory for the MOM_vert_friction module type, public :: vertvisc_CS ; private - real :: Hmix !< The mixed layer thickness in m. + real :: Hmix !< The mixed layer thickness in thickness units [H ~> m or kg m-2]. real :: Hmix_stress !< The mixed layer thickness over which the wind - !! stress is applied with direct_stress, in m. - real :: Kvml !< The mixed layer vertical viscosity in m2 s-1. - real :: Kv !< The interior vertical viscosity in m2 s-1. - real :: Hbbl !< The static bottom boundary layer thickness, in m. + !! stress is applied with direct_stress [H ~> m or kg m-2]. + real :: Kvml !< The mixed layer vertical viscosity [Z2 s-1 ~> m2 s-1]. + real :: Kv !< The interior vertical viscosity [Z2 s-1 ~> m2 s-1]. + real :: Hbbl !< The static bottom boundary layer thickness [H ~> m or kg m-2]. real :: Kvbbl !< The vertical viscosity in the bottom boundary - !! layer, in m2 s-1. + !! layer [Z2 s-1 ~> m2 s-1]. - real :: maxvel !< Velocity components greater than maxvel, - !! in m s-1, are truncated. + real :: maxvel !< Velocity components greater than maxvel are truncated [m s-1]. real :: vel_underflow !< Velocity components smaller than vel_underflow - !! are set to 0, in m s-1. + !! are set to 0 [m s-1]. logical :: CFL_based_trunc !< If true, base truncations on CFL numbers, not !! absolute velocities. real :: CFL_trunc !< Velocity components will be truncated when they @@ -59,20 +65,17 @@ module MOM_vert_friction type(time_type) :: rampStartTime !< The time at which the ramping of CFL_trunc starts real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NK_INTERFACE_) :: & - a_u !< The u-drag coefficient across an interface, in m s-1. + a_u !< The u-drag coefficient across an interface [Z s-1 ~> m s-1]. real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: & - h_u !< The effective layer thickness at u-points, m or kg m-2. + h_u !< The effective layer thickness at u-points [H ~> m or kg m-2]. real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NK_INTERFACE_) :: & - a_v !< The v-drag coefficient across an interface, in m s-1. + a_v !< The v-drag coefficient across an interface [Z s-1 ~> m s-1]. real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: & - h_v !< The effective layer thickness at v-points, m or kg m-2. - !>@{ - !! The surface coupling coefficient under ice shelves - !! in m s-1. Retained to determine stress under shelves. - real, pointer, dimension(:,:) :: & - a1_shelf_u => NULL(), & - a1_shelf_v => NULL() - !>@} + h_v !< The effective layer thickness at v-points [H ~> m or kg m-2]. + real, pointer, dimension(:,:) :: a1_shelf_u => NULL() !< The u-momentum coupling coefficient under + !! ice shelves [Z s-1 ~> m s-1]. Retained to determine stress under shelves. + real, pointer, dimension(:,:) :: a1_shelf_v => NULL() !< The v-momentum coupling coefficient under + !! ice shelves [Z s-1 ~> m s-1]. Retained to determine stress under shelves. logical :: split !< If true, use the split time stepping scheme. logical :: bottomdraglaw !< If true, the bottom stress is calculated with a @@ -99,27 +102,28 @@ module MOM_vert_friction !! thickness for viscosity. logical :: debug !< If true, write verbose checksums for debugging purposes. integer :: nkml !< The number of layers in the mixed layer. - integer, pointer :: ntrunc !< The number of times the velocity has been - !! truncated since the last call to write_energy. - !>@{ - !! The complete path to files in which a column's worth of - !! accelerations are written when velocity truncations occur. - character(len=200) :: u_trunc_file - character(len=200) :: v_trunc_file - !>@} + integer, pointer :: ntrunc !< The number of times the velocity has been + !! truncated since the last call to write_energy. + character(len=200) :: u_trunc_file !< The complete path to a file in which a column of + !! u-accelerations are written if velocity truncations occur. + character(len=200) :: v_trunc_file !< The complete path to a file in which a column of + !! v-accelerations are written if velocity truncations occur. + logical :: StokesMixing !< If true, do Stokes drift mixing via the Lagrangian current + !! (Eulerian plus Stokes drift). False by default and set + !! via STOKES_MIXING_COMBINED. type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the !! timing of diagnostic output. - !>@{ - !! Diagnostic identifiers + !>@{ Diagnostic identifiers integer :: id_du_dt_visc = -1, id_dv_dt_visc = -1, id_au_vv = -1, id_av_vv = -1 integer :: id_h_u = -1, id_h_v = -1, id_hML_u = -1 , id_hML_v = -1 integer :: id_Ray_u = -1, id_Ray_v = -1, id_taux_bot = -1, id_tauy_bot = -1 + integer :: id_Kv_slow = -1, id_Kv_u = -1, id_Kv_v = -1 !>@} - type(PointAccel_CS), pointer :: PointAccel_CSp => NULL() - logical :: StokesMixing + type(PointAccel_CS), pointer :: PointAccel_CSp => NULL() !< A pointer to the control structure + !! for recording accelerations leading to velocity truncations end type vertvisc_CS contains @@ -138,63 +142,60 @@ module MOM_vert_friction !! There is an additional stress term on the right-hand side !! if DIRECT_STRESS is true, applied to the surface layer. -subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, CS, & +subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & taux_bot, tauy_bot, Waves) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - real, intent(inout), & - dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: u !< Zonal velocity in m s-1 - real, intent(inout), & - dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: v !< Meridional velocity in m s-1 - real, intent(in), & - dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h !< Layer thickness in H + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: u !< Zonal velocity [m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: v !< Meridional velocity [m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2] type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces type(vertvisc_type), intent(inout) :: visc !< Viscosities and bottom drag - real, intent(in) :: dt !< Time increment in s + real, intent(in) :: dt !< Time increment [s] type(ocean_OBC_type), pointer :: OBC !< Open boundary condition structure type(accel_diag_ptrs), intent(inout) :: ADp !< Accelerations in the momentum !! equations for diagnostics type(cont_diag_ptrs), intent(inout) :: CDp !< Continuity equation terms type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure - !> Zonal bottom stress from ocean to rock in Pa - real, optional, intent(out), dimension(SZIB_(G),SZJ_(G)) :: taux_bot - !> Meridional bottom stress from ocean to rock in Pa - real, optional, intent(out), dimension(SZI_(G),SZJB_(G)) :: tauy_bot - type(wave_parameters_CS), pointer, optional :: Waves !< Container for wave/Stokes information + real, dimension(SZIB_(G),SZJ_(G)), & + optional, intent(out) :: taux_bot !< Zonal bottom stress from ocean to rock [Pa] + real, dimension(SZI_(G),SZJB_(G)), & + optional, intent(out) :: tauy_bot !< Meridional bottom stress from ocean to rock [Pa] + type(wave_parameters_CS), & + optional, pointer :: Waves !< Container for wave/Stokes information ! Fields from forces used in this subroutine: - ! taux: Zonal wind stress in Pa. - ! tauy: Meridional wind stress in Pa. + ! taux: Zonal wind stress [Pa]. + ! tauy: Meridional wind stress [Pa]. ! Local variables - real :: b1(SZIB_(G)) ! b1 and c1 are variables used by the - real :: c1(SZIB_(G),SZK_(G)) ! tridiagonal solver. c1 is nondimensional, - ! while b1 has units of inverse thickness. - real :: d1(SZIB_(G)) ! d1=1-c1 is used by the tridiagonal solver, ND. - real :: Ray(SZIB_(G),SZK_(G)) ! Ray is the Rayleigh-drag velocity in m s-1 - real :: b_denom_1 ! The first term in the denominator of b1, in H. + real :: b1(SZIB_(G)) ! A variable used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. + real :: c1(SZIB_(G),SZK_(G)) ! A variable used by the tridiagonal solver [nondim]. + real :: d1(SZIB_(G)) ! d1=1-c1 is used by the tridiagonal solver [nondim]. + real :: Ray(SZIB_(G),SZK_(G)) ! Ray is the Rayleigh-drag velocity [Z s-1 ~> m s-1]. + real :: b_denom_1 ! The first term in the denominator of b1 [H ~> m or kg m-2]. real :: Hmix ! The mixed layer thickness over which stress - ! is applied with direct_stress, translated into - ! thickness units - either m or kg m-2. - real :: I_Hmix ! The inverse of Hmix, in m-1 or m2 kg-1. - real :: Idt ! The inverse of the time step, in s-1. - real :: dt_Rho0 ! The time step divided by the mean - ! density, in s m3 kg-1. - real :: Rho0 ! A density used to convert drag laws into stress in - ! Pa, in kg m-3. - real :: dt_m_to_H ! The time step times the conversion from m to the - ! units of thickness - either s or s m3 kg-1. + ! is applied with direct_stress [H ~> m or kg m-2]. + real :: I_Hmix ! The inverse of Hmix [H-1 ~> m-1 or m2 kg-1]. + real :: Idt ! The inverse of the time step [s-1]. + real :: dt_Rho0 ! The time step divided by the mean density [s m3 kg-1]. + real :: Rho0 ! A density used to convert drag laws into stress in Pa [kg m-3]. + real :: dt_Z_to_H ! The time step times the conversion from Z to the + ! units of thickness - [s H Z-1 ~> s or s kg m-3]. real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected, in m or kg m-2. + ! in roundoff and can be neglected [H ~> m or kg m-2]. real :: stress ! The surface stress times the time step, divided - ! by the density, in units of m2 s-1. + ! by the density [m2 s-1]. real :: zDS, hfr, h_a ! Temporary variables used with direct_stress. - real :: surface_stress(SZIB_(G))! The same as stress, unless the wind - ! stress is applied as a body force, in - ! units of m2 s-1. + real :: surface_stress(SZIB_(G))! The same as stress, unless the wind stress + ! stress is applied as a body force [m2 s-1]. logical :: do_i(SZIB_(G)) logical :: DoStokesMixing @@ -207,24 +208,22 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, CS, & "Module must be initialized before it is used.") if (CS%direct_stress) then - Hmix = CS%Hmix_stress*GV%m_to_H + Hmix = CS%Hmix_stress I_Hmix = 1.0 / Hmix endif dt_Rho0 = dt/GV%H_to_kg_m2 - dt_m_to_H = dt*GV%m_to_H + dt_Z_to_H = dt*GV%Z_to_H Rho0 = GV%Rho0 h_neglect = GV%H_subroundoff Idt = 1.0 / dt !Check if Stokes mixing allowed if requested (present and associated) + DoStokesMixing=.false. if (CS%StokesMixing) then - DoStokesMixing=(present(Waves) .and. associated(Waves)) - if (.not.DoStokesMixing) then + if (present(Waves)) DoStokesMixing = associated(Waves) + if (.not. DoStokesMixing) & call MOM_error(FATAL,"Stokes Mixing called without allocated"//& - "Waves Control Structure") - endif - else - DoStokesMixing=.false. + "Waves Control Structure") endif do k=1,nz ; do i=Isq,Ieq ; Ray(i,k) = 0.0 ; enddo ; enddo @@ -232,17 +231,17 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, CS, & ! Update the zonal velocity component using a modification of a standard ! tridagonal solver. - ! When mixing down Eulerian current + Stokes drift add before calling solver - if (DoStokesMixing) then ; do k=1,nz ; do j=G%jsc,G%jec ; do I=Isq,Ieq - if (G%mask2dCu(I,j) > 0) u(I,j,k) = u(I,j,k) + Waves%Us_x(I,j,k) - enddo ; enddo ; enddo ; endif - !$OMP parallel do default(shared) firstprivate(Ray) & !$OMP private(do_i,surface_stress,zDS,stress,h_a,hfr, & !$OMP b_denom_1,b1,d1,c1) do j=G%jsc,G%jec do I=Isq,Ieq ; do_i(I) = (G%mask2dCu(I,j) > 0) ; enddo + ! When mixing down Eulerian current + Stokes drift add before calling solver + if (DoStokesMixing) then ; do k=1,nz ; do I=Isq,Ieq + if (do_i(I)) u(I,j,k) = u(I,j,k) + Waves%Us_x(I,j,k) + enddo ; enddo ; endif + if (associated(ADp%du_dt_visc)) then ; do k=1,nz ; do I=Isq,Ieq ADp%du_dt_visc(I,j,k) = u(I,j,k) enddo ; enddo ; endif @@ -276,9 +275,9 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, CS, & ! and the superdiagonal as c_k. The right-hand side terms are d_k. ! ! ignoring the rayleigh drag contribution, - ! we have a_k = -dt_m_to_H * a_u(k) - ! b_k = h_u(k) + dt_m_to_H * (a_u(k) + a_u(k+1)) - ! c_k = -dt_m_to_H * a_u(k+1) + ! we have a_k = -dt_Z_to_H * a_u(k) + ! b_k = h_u(k) + dt_Z_to_H * (a_u(k) + a_u(k+1)) + ! c_k = -dt_Z_to_H * a_u(k+1) ! ! for forward elimination, we want to: ! calculate c'_k = - c_k / (b_k + a_k c'_(k-1)) @@ -294,18 +293,18 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, CS, & ! and the right-hand-side is destructively updated to be d'_k ! do I=Isq,Ieq ; if (do_i(I)) then - b_denom_1 = CS%h_u(I,j,1) + dt_m_to_H * (Ray(I,1) + CS%a_u(I,j,1)) - b1(I) = 1.0 / (b_denom_1 + dt_m_to_H*CS%a_u(I,j,2)) + b_denom_1 = CS%h_u(I,j,1) + dt_Z_to_H * (Ray(I,1) + CS%a_u(I,j,1)) + b1(I) = 1.0 / (b_denom_1 + dt_Z_to_H*CS%a_u(I,j,2)) d1(I) = b_denom_1 * b1(I) u(I,j,1) = b1(I) * (CS%h_u(I,j,1) * u(I,j,1) + surface_stress(I)) endif ; enddo do k=2,nz ; do I=Isq,Ieq ; if (do_i(I)) then - c1(I,k) = dt_m_to_H * CS%a_u(I,j,K) * b1(I) - b_denom_1 = CS%h_u(I,j,k) + dt_m_to_H * (Ray(I,k) + CS%a_u(I,j,K)*d1(I)) - b1(I) = 1.0 / (b_denom_1 + dt_m_to_H * CS%a_u(I,j,K+1)) + c1(I,k) = dt_Z_to_H * CS%a_u(I,j,K) * b1(I) + b_denom_1 = CS%h_u(I,j,k) + dt_Z_to_H * (Ray(I,k) + CS%a_u(I,j,K)*d1(I)) + b1(I) = 1.0 / (b_denom_1 + dt_Z_to_H * CS%a_u(I,j,K+1)) d1(I) = b_denom_1 * b1(I) u(I,j,k) = (CS%h_u(I,j,k) * u(I,j,k) + & - dt_m_to_H * CS%a_u(I,j,K) * u(I,j,k-1)) * b1(I) + dt_Z_to_H * CS%a_u(I,j,K) * u(I,j,k-1)) * b1(I) endif ; enddo ; enddo ! back substitute to solve for the new velocities @@ -330,19 +329,15 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, CS, & taux_bot(I,j) = taux_bot(I,j) + Rho0 * (Ray(I,k)*u(I,j,k)) enddo ; enddo ; endif endif - enddo ! end u-component j loop - ! When mixing down Eulerian current + Stokes drift subtract after calling solver - if (DoStokesMixing) then ; do k=1,nz ; do j=G%jsc,G%jec ; do I=Isq,Ieq - if (G%mask2dCu(I,j) > 0) u(I,j,k) = u(I,j,k) - Waves%Us_x(I,j,k) - enddo ; enddo ; enddo ; endif + ! When mixing down Eulerian current + Stokes drift subtract after calling solver + if (DoStokesMixing) then ; do k=1,nz ; do I=Isq,Ieq + if (do_i(I)) u(I,j,k) = u(I,j,k) - Waves%Us_x(I,j,k) + enddo ; enddo ; endif + + enddo ! end u-component j loop ! Now work on the meridional velocity component. - ! When mixing down Eulerian current + Stokes drift add before calling solver - if (DoStokesMixing) then ; do k=1,nz ; do j=Jsq,Jeq ; do I=Is,Ie - if (G%mask2dCv(I,j) > 0) & - v(i,j,k) = v(i,j,k) + Waves%Us_y(i,j,k) - enddo ; enddo ; enddo ; endif !$OMP parallel do default(shared) firstprivate(Ray) & !$OMP private(do_i,surface_stress,zDS,stress,h_a,hfr, & @@ -350,6 +345,11 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, CS, & do J=Jsq,Jeq do i=is,ie ; do_i(i) = (G%mask2dCv(i,J) > 0) ; enddo + ! When mixing down Eulerian current + Stokes drift add before calling solver + if (DoStokesMixing) then ; do k=1,nz ; do i=is,ie + if (do_i(i)) v(i,j,k) = v(i,j,k) + Waves%Us_y(i,j,k) + enddo ; enddo ; endif + if (associated(ADp%dv_dt_visc)) then ; do k=1,nz ; do i=is,ie ADp%dv_dt_visc(i,J,k) = v(i,J,k) enddo ; enddo ; endif @@ -378,18 +378,17 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, CS, & enddo ; enddo ; endif do i=is,ie ; if (do_i(i)) then - b_denom_1 = CS%h_v(i,J,1) + dt_m_to_H * (Ray(i,1) + CS%a_v(i,J,1)) - b1(i) = 1.0 / (b_denom_1 + dt_m_to_H*CS%a_v(i,J,2)) + b_denom_1 = CS%h_v(i,J,1) + dt_Z_to_H * (Ray(i,1) + CS%a_v(i,J,1)) + b1(i) = 1.0 / (b_denom_1 + dt_Z_to_H*CS%a_v(i,J,2)) d1(i) = b_denom_1 * b1(i) v(i,J,1) = b1(i) * (CS%h_v(i,J,1) * v(i,J,1) + surface_stress(i)) endif ; enddo do k=2,nz ; do i=is,ie ; if (do_i(i)) then - c1(i,k) = dt_m_to_H * CS%a_v(i,J,K) * b1(i) - b_denom_1 = CS%h_v(i,J,k) + dt_m_to_H * (Ray(i,k) + CS%a_v(i,J,K)*d1(i)) - b1(i) = 1.0 / (b_denom_1 + dt_m_to_H * CS%a_v(i,J,K+1)) + c1(i,k) = dt_Z_to_H * CS%a_v(i,J,K) * b1(i) + b_denom_1 = CS%h_v(i,J,k) + dt_Z_to_H * (Ray(i,k) + CS%a_v(i,J,K)*d1(i)) + b1(i) = 1.0 / (b_denom_1 + dt_Z_to_H * CS%a_v(i,J,K+1)) d1(i) = b_denom_1 * b1(i) - v(i,J,k) = (CS%h_v(i,J,k) * v(i,J,k) + dt_m_to_H * & - CS%a_v(i,J,K) * v(i,J,k-1)) * b1(i) + v(i,J,k) = (CS%h_v(i,J,k) * v(i,J,k) + dt_Z_to_H * CS%a_v(i,J,K) * v(i,J,k-1)) * b1(i) endif ; enddo ; enddo do k=nz-1,1,-1 ; do i=is,ie ; if (do_i(i)) then v(i,J,k) = v(i,J,k) + c1(i,k+1) * v(i,J,k+1) @@ -411,14 +410,15 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, CS, & tauy_bot(i,J) = tauy_bot(i,J) + Rho0 * (Ray(i,k)*v(i,J,k)) enddo ; enddo ; endif endif - enddo ! end of v-component J loop - ! When mixing down Eulerian current + Stokes drift subtract after calling solver - if (DoStokesMixing) then ; do k=1,nz ; do J=Jsq,Jeq ; do i=Is,Ie - if (G%mask2dCv(i,J) > 0) v(i,J,k) = v(i,J,k) - Waves%Us_y(i,J,k) - enddo ; enddo ; enddo ; endif + ! When mixing down Eulerian current + Stokes drift subtract after calling solver + if (DoStokesMixing) then ; do k=1,nz ; do i=is,ie + if (do_i(i)) v(i,J,k) = v(i,J,k) - Waves%Us_y(i,J,k) + enddo ; enddo ; endif - call vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, CS) + enddo ! end of v-component J loop + + call vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, US, CS) ! Here the velocities associated with open boundary conditions are applied. if (associated(OBC)) then @@ -458,27 +458,27 @@ end subroutine vertvisc subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt, G, GV, CS) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - type(vertvisc_type), intent(in) :: visc !< Viscosities and bottom drag - !> Fraction of a time-step's worth of a barotopic acceleration that - !! a layer experiences after viscosity is applied in the zonal direction - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: visc_rem_u - !> Fraction of a time-step's worth of a barotopic acceleration that - !! a layer experiences after viscosity is applied in the meridional direction - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: visc_rem_v - real, intent(in) :: dt !< Time increment in s - type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure + type(vertvisc_type), intent(in) :: visc !< Viscosities and bottom drag + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: visc_rem_u !< Fraction of a time-step's worth of a + !! barotopic acceleration that a layer experiences after + !! viscosity is applied in the zonal direction [nondim] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: visc_rem_v !< Fraction of a time-step's worth of a + !! barotopic acceleration that a layer experiences after + !! viscosity is applied in the meridional direction [nondim] + real, intent(in) :: dt !< Time increment [s] + type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure ! Local variables - real :: b1(SZIB_(G)) ! b1 and c1 are variables used by the - real :: c1(SZIB_(G),SZK_(G)) ! tridiagonal solver. c1 is nondimensional, - ! while b1 has units of inverse thickness. - real :: d1(SZIB_(G)) ! d1=1-c1 is used by the tridiagonal solver, ND. - real :: Ray(SZIB_(G),SZK_(G)) ! Ray is the Rayleigh-drag velocity times the - ! time step, in m. - real :: b_denom_1 ! The first term in the denominator of b1, in m or kg m-2. - real :: dt_m_to_H ! The time step times the conversion from m to the - ! units of thickness - either s or s m3 kg-1. + real :: b1(SZIB_(G)) ! A variable used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. + real :: c1(SZIB_(G),SZK_(G)) ! A variable used by the tridiagonal solver [nondim]. + real :: d1(SZIB_(G)) ! d1=1-c1 is used by the tridiagonal solver [nondim]. + real :: Ray(SZIB_(G),SZK_(G)) ! Ray is the Rayleigh-drag velocity times the time step [m]. + real :: b_denom_1 ! The first term in the denominator of b1 [H ~> m or kg m-2]. + real :: dt_Z_to_H ! The time step times the conversion from Z to the + ! units of thickness [s H Z-1 ~> s or s kg m-3]. logical :: do_i(SZIB_(G)) integer :: i, j, k, is, ie, Isq, Ieq, Jsq, Jeq, nz @@ -488,12 +488,12 @@ subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt, G, GV, CS) if (.not.associated(CS)) call MOM_error(FATAL,"MOM_vert_friction(visc): "// & "Module must be initialized before it is used.") - dt_m_to_H = dt*GV%m_to_H + dt_Z_to_H = dt*GV%Z_to_H do k=1,nz ; do i=Isq,Ieq ; Ray(i,k) = 0.0 ; enddo ; enddo ! Find the zonal viscous using a modification of a standard tridagonal solver. -!$OMP parallel do default(none) shared(G,Isq,Ieq,CS,nz,visc,dt_m_to_H,visc_rem_u) & +!$OMP parallel do default(none) shared(G,Isq,Ieq,CS,nz,visc,dt_Z_to_H,visc_rem_u) & !$OMP firstprivate(Ray) & !$OMP private(do_i,b_denom_1,b1,d1,c1) do j=G%jsc,G%jec @@ -504,17 +504,17 @@ subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt, G, GV, CS) enddo ; enddo ; endif do I=Isq,Ieq ; if (do_i(I)) then - b_denom_1 = CS%h_u(I,j,1) + dt_m_to_H * (Ray(I,1) + CS%a_u(I,j,1)) - b1(I) = 1.0 / (b_denom_1 + dt_m_to_H*CS%a_u(I,j,2)) + b_denom_1 = CS%h_u(I,j,1) + dt_Z_to_H * (Ray(I,1) + CS%a_u(I,j,1)) + b1(I) = 1.0 / (b_denom_1 + dt_Z_to_H*CS%a_u(I,j,2)) d1(I) = b_denom_1 * b1(I) visc_rem_u(I,j,1) = b1(I) * CS%h_u(I,j,1) endif ; enddo do k=2,nz ; do I=Isq,Ieq ; if (do_i(I)) then - c1(I,k) = dt_m_to_H * CS%a_u(I,j,K)*b1(I) - b_denom_1 = CS%h_u(I,j,k) + dt_m_to_H * (Ray(I,k) + CS%a_u(I,j,K)*d1(I)) - b1(I) = 1.0 / (b_denom_1 + dt_m_to_H * CS%a_u(I,j,K+1)) + c1(I,k) = dt_Z_to_H * CS%a_u(I,j,K)*b1(I) + b_denom_1 = CS%h_u(I,j,k) + dt_Z_to_H * (Ray(I,k) + CS%a_u(I,j,K)*d1(I)) + b1(I) = 1.0 / (b_denom_1 + dt_Z_to_H * CS%a_u(I,j,K+1)) d1(I) = b_denom_1 * b1(I) - visc_rem_u(I,j,k) = (CS%h_u(I,j,k) + dt_m_to_H * CS%a_u(I,j,K) * visc_rem_u(I,j,k-1)) * b1(I) + visc_rem_u(I,j,k) = (CS%h_u(I,j,k) + dt_Z_to_H * CS%a_u(I,j,K) * visc_rem_u(I,j,k-1)) * b1(I) endif ; enddo ; enddo do k=nz-1,1,-1 ; do I=Isq,Ieq ; if (do_i(I)) then visc_rem_u(I,j,k) = visc_rem_u(I,j,k) + c1(I,k+1)*visc_rem_u(I,j,k+1) @@ -524,7 +524,7 @@ subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt, G, GV, CS) enddo ! end u-component j loop ! Now find the meridional viscous using a modification. -!$OMP parallel do default(none) shared(Jsq,Jeq,is,ie,G,CS,visc,dt_m_to_H,visc_rem_v,nz) & +!$OMP parallel do default(none) shared(Jsq,Jeq,is,ie,G,CS,visc,dt_Z_to_H,visc_rem_v,nz) & !$OMP firstprivate(Ray) & !$OMP private(do_i,b_denom_1,b1,d1,c1) do J=Jsq,Jeq @@ -535,17 +535,17 @@ subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt, G, GV, CS) enddo ; enddo ; endif do i=is,ie ; if (do_i(i)) then - b_denom_1 = CS%h_v(i,J,1) + dt_m_to_H * (Ray(i,1) + CS%a_v(i,J,1)) - b1(i) = 1.0 / (b_denom_1 + dt_m_to_H*CS%a_v(i,J,2)) + b_denom_1 = CS%h_v(i,J,1) + dt_Z_to_H * (Ray(i,1) + CS%a_v(i,J,1)) + b1(i) = 1.0 / (b_denom_1 + dt_Z_to_H*CS%a_v(i,J,2)) d1(i) = b_denom_1 * b1(i) visc_rem_v(i,J,1) = b1(i) * CS%h_v(i,J,1) endif ; enddo do k=2,nz ; do i=is,ie ; if (do_i(i)) then - c1(i,k) = dt_m_to_H * CS%a_v(i,J,K)*b1(i) - b_denom_1 = CS%h_v(i,J,k) + dt_m_to_H * (Ray(i,k) + CS%a_v(i,J,K)*d1(i)) - b1(i) = 1.0 / (b_denom_1 + dt_m_to_H * CS%a_v(i,J,K+1)) + c1(i,k) = dt_Z_to_H * CS%a_v(i,J,K)*b1(i) + b_denom_1 = CS%h_v(i,J,k) + dt_Z_to_H * (Ray(i,k) + CS%a_v(i,J,K)*d1(i)) + b1(i) = 1.0 / (b_denom_1 + dt_Z_to_H * CS%a_v(i,J,K+1)) d1(i) = b_denom_1 * b1(i) - visc_rem_v(i,J,k) = (CS%h_v(i,J,k) + dt_m_to_H * CS%a_v(i,J,K) * visc_rem_v(i,J,k-1)) * b1(i) + visc_rem_v(i,J,k) = (CS%h_v(i,J,k) + dt_Z_to_H * CS%a_v(i,J,K) * visc_rem_v(i,J,k-1)) * b1(i) endif ; enddo ; enddo do k=nz-1,1,-1 ; do i=is,ie ; if (do_i(i)) then visc_rem_v(i,J,k) = visc_rem_v(i,J,k) + c1(i,k+1)*visc_rem_v(i,J,k+1) @@ -562,68 +562,69 @@ end subroutine vertvisc_remnant !> Calculate the coupling coefficients (CS%a_u and CS%a_v) !! and effective layer thicknesses (CS%h_u and CS%h_v) for later use in the !! applying the implicit vertical viscosity via vertvisc(). -subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, CS, OBC) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure +subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - real, intent(in), & - dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: u !< Zonal velocity in m s-1 - real, intent(in), & - dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: v !< Meridional velocity in m s-1 - real, intent(in), & - dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h !< Layer thickness in H - type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces - type(vertvisc_type), intent(in) :: visc !< Viscosities and bottom drag - real, intent(in) :: dt !< Time increment in s - type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure - type(ocean_OBC_type), pointer :: OBC !< Open boundary condition structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u !< Zonal velocity [m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: v !< Meridional velocity [m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces + type(vertvisc_type), intent(in) :: visc !< Viscosities and bottom drag + real, intent(in) :: dt !< Time increment [s] + type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure + type(ocean_OBC_type), pointer :: OBC !< Open boundary condition structure ! Field from forces used in this subroutine: - ! ustar: the friction velocity in m s-1, used here as the mixing + ! ustar: the friction velocity [m s-1], used here as the mixing ! velocity in the mixed layer if NKML > 1 in a bulk mixed layer. ! Local variables real, dimension(SZIB_(G),SZK_(G)) :: & h_harm, & ! Harmonic mean of the thicknesses around a velocity grid point, - ! given by 2*(h+ * h-)/(h+ + h-), in m or kg m-2 (H for short). - h_arith, & ! The arithmetic mean thickness, in m or kg m-2. - h_delta, & ! The lateral difference of thickness, in m or kg m-2. - hvel, & ! hvel is the thickness used at a velocity grid point, in H. - hvel_shelf ! The equivalent of hvel under shelves, in H. + ! given by 2*(h+ * h-)/(h+ + h-) [H ~> m or kg m-2]. + h_arith, & ! The arithmetic mean thickness [H ~> m or kg m-2]. + h_delta, & ! The lateral difference of thickness [H ~> m or kg m-2]. + hvel, & ! hvel is the thickness used at a velocity grid point [H ~> m or kg m-2]. + hvel_shelf ! The equivalent of hvel under shelves [H ~> m or kg m-2]. real, dimension(SZIB_(G),SZK_(G)+1) :: & - a, & ! The drag coefficients across interfaces, in m s-1. a times + a_cpl, & ! The drag coefficients across interfaces [Z s-1 ~> m s-1]. a_cpl times ! the velocity difference gives the stress across an interface. a_shelf, & ! The drag coefficients across interfaces in water columns under - ! ice shelves, in m s-1. + ! ice shelves [Z s-1 ~> m s-1]. z_i ! An estimate of each interface's height above the bottom, ! normalized by the bottom boundary layer thickness, nondim. real, dimension(SZIB_(G)) :: & - kv_bbl, & ! The bottom boundary layer viscosity in m2 s-1. - bbl_thick, & ! The bottom boundary layer thickness in m or kg m-2. - I_Hbbl, & ! The inverse of the bottom boundary layer thickness, in units - ! of H-1 (i.e., m-1 or m2 kg-1). - I_Htbl, & ! The inverse of the top boundary layer thickness, in units - ! of H-1 (i.e., m-1 or m2 kg-1). + kv_bbl, & ! The bottom boundary layer viscosity [Z2 s-1 ~> m2 s-1]. + bbl_thick, & ! The bottom boundary layer thickness [H ~> m or kg m-2]. + I_Hbbl, & ! The inverse of the bottom boundary layer thickness [H-1 ~> m-1 or m2 kg-1]. + I_Htbl, & ! The inverse of the top boundary layer thickness [H-1 ~> m-1 or m2 kg-1]. zcol1, & ! The height of the interfaces to the north and south of a - zcol2, & ! v-point, in m or kg m-2. - Ztop_min, & ! The deeper of the two adjacent surface heights, in H. + zcol2, & ! v-point [H ~> m or kg m-2]. + Ztop_min, & ! The deeper of the two adjacent surface heights [H ~> m or kg m-2]. Dmin, & ! The shallower of the two adjacent bottom depths converted to - ! thickness units, in m or kg m-2. + ! thickness units [H ~> m or kg m-2]. zh, & ! An estimate of the interface's distance from the bottom - ! based on harmonic mean thicknesses, in m or kg m-2. - h_ml ! The mixed layer depth, in m or kg m-2. - real, allocatable, dimension(:,:) :: hML_u, hML_v - real :: zcol(SZI_(G)) ! The height of an interface at h-points, in m or kg m-2. + ! based on harmonic mean thicknesses [H ~> m or kg m-2]. + h_ml ! The mixed layer depth [H ~> m or kg m-2]. + real, allocatable, dimension(:,:) :: hML_u ! Diagnostic of the mixed layer depth at u points [H ~> m or kg m-2]. + real, allocatable, dimension(:,:) :: hML_v ! Diagnostic of the mixed layer depth at v points [H ~> m or kg m-2]. + real, allocatable, dimension(:,:,:) :: Kv_u !< Total vertical viscosity at u-points [Z2 s-1 ~> m2 s-1]. + real, allocatable, dimension(:,:,:) :: Kv_v !< Total vertical viscosity at v-points [Z2 s-1 ~> m2 s-1]. + real :: zcol(SZI_(G)) ! The height of an interface at h-points [H ~> m or kg m-2]. real :: botfn ! A function which goes from 1 at the bottom to 0 much more ! than Hbbl into the interior. real :: topfn ! A function which goes from 1 at the top to 0 much more ! than Htbl into the interior. real :: z2 ! The distance from the bottom, normalized by Hbbl, nondim. real :: z2_wt ! A nondimensional (0-1) weight used when calculating z2. - real :: z_clear ! The clearance of an interface above the surrounding topography, in H. - real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected, in H. - real :: H_to_m, m_to_H ! Unit conversion factors. + real :: z_clear ! The clearance of an interface above the surrounding topography [H ~> m or kg m-2]. + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [H ~> m or kg m-2]. real :: I_valBL ! The inverse of a scaling factor determining when water is ! still within the boundary layer, as determined by the sum @@ -641,10 +642,17 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, CS, OBC) "Module must be initialized before it is used.") h_neglect = GV%H_subroundoff - H_to_m = GV%H_to_m ; m_to_H = GV%m_to_H - I_Hbbl(:) = 1.0 / (CS%Hbbl * GV%m_to_H + h_neglect) + I_Hbbl(:) = 1.0 / (CS%Hbbl + h_neglect) I_valBL = 0.0 ; if (CS%harm_BL_val > 0.0) I_valBL = 1.0 / CS%harm_BL_val + if (CS%id_Kv_u > 0) then + allocate(Kv_u(G%IsdB:G%IedB,G%jsd:G%jed,G%ke)) ; Kv_u(:,:,:) = 0.0 + endif + + if (CS%id_Kv_v > 0) then + allocate(Kv_v(G%isd:G%ied,G%JsdB:G%JedB,G%ke)) ; Kv_v(:,:,:) = 0.0 + endif + if (CS%debug .or. (CS%id_hML_u > 0)) then allocate(hML_u(G%IsdB:G%IedB,G%jsd:G%jed)) ; hML_u(:,:) = 0.0 endif @@ -661,18 +669,15 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, CS, OBC) allocate(CS%a1_shelf_v(G%isd:G%ied,G%JsdB:G%JedB)) ; CS%a1_shelf_v(:,:)=0.0 endif -!$OMP parallel do default(none) shared(G,GV,CS,visc,Isq,ieq,nz,u,h,forces,hML_u, & -!$OMP OBC,h_neglect,dt,m_to_H,I_valBL) & -!$OMP firstprivate(i_hbbl) & -!$OMP private(do_i,kv_bbl,bbl_thick,z_i,h_harm,h_arith,h_delta,hvel,z2, & -!$OMP botfn,zh,Dmin,zcol,a,do_any_shelf,do_i_shelf,zi_dir, & -!$OMP a_shelf,Ztop_min,I_HTbl,hvel_shelf,topfn,h_ml,z2_wt,z_clear) + !$OMP parallel do default(private) shared(G,GV,US,CS,visc,Isq,Ieq,nz,u,h,forces,hML_u, & + !$OMP OBC,h_neglect,dt,I_valBL,Kv_u) & + !$OMP firstprivate(i_hbbl) do j=G%Jsc,G%Jec do I=Isq,Ieq ; do_i(I) = (G%mask2dCu(I,j) > 0) ; enddo if (CS%bottomdraglaw) then ; do I=Isq,Ieq kv_bbl(I) = visc%kv_bbl_u(I,j) - bbl_thick(I) = visc%bbl_thick_u(I,j) * m_to_H + bbl_thick(I) = visc%bbl_thick_u(I,j) * GV%Z_to_H if (do_i(I)) I_Hbbl(I) = 1.0 / (bbl_thick(I) + h_neglect) enddo ; endif @@ -682,7 +687,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, CS, OBC) h_delta(I,k) = h(i+1,j,k) - h(i,j,k) endif ; enddo ; enddo do I=Isq,Ieq - Dmin(I) = min(G%bathyT(i,j), G%bathyT(i+1,j)) * m_to_H + Dmin(I) = min(G%bathyT(i,j), G%bathyT(i+1,j)) * GV%Z_to_H zi_dir(I) = 0 enddo @@ -691,18 +696,18 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, CS, OBC) do I=Isq,Ieq ; if (do_i(I) .and. (OBC%segnum_u(I,j) /= OBC_NONE)) then if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then do k=1,nz ; h_harm(I,k) = h(i,j,k) ; h_arith(I,k) = h(i,j,k) ; h_delta(I,k) = 0. ; enddo - Dmin(I) = G%bathyT(i,j) * m_to_H + Dmin(I) = G%bathyT(i,j) * GV%Z_to_H zi_dir(I) = -1 elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then do k=1,nz ; h_harm(I,k) = h(i+1,j,k) ; h_arith(I,k) = h(i+1,j,k) ; h_delta(I,k) = 0. ; enddo - Dmin(I) = G%bathyT(i+1,j) * m_to_H + Dmin(I) = G%bathyT(i+1,j) * GV%Z_to_H zi_dir(I) = 1 endif endif ; enddo endif ; endif ! The following block calculates the thicknesses at velocity -! grid points for the vertical viscosity (hvel[k]). Near the +! grid points for the vertical viscosity (hvel). Near the ! bottom an upwind biased thickness is used to control the effect ! of spurious Montgomery potential gradients at the bottom where ! nearly massless layers layers ride over the topography. @@ -718,7 +723,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, CS, OBC) endif ; enddo ; enddo ! i & k loops else ! Not harmonic_visc do I=Isq,Ieq ; zh(I) = 0.0 ; z_i(I,nz+1) = 0.0 ; enddo - do i=Isq,Ieq+1 ; zcol(i) = -G%bathyT(i,j) * m_to_H ; enddo + do i=Isq,Ieq+1 ; zcol(i) = -G%bathyT(i,j) * GV%Z_to_H ; enddo do k=nz,1,-1 do i=Isq,Ieq+1 ; zcol(i) = zcol(i) + h(i,j,k) ; enddo do I=Isq,Ieq ; if (do_i(I)) then @@ -747,8 +752,8 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, CS, OBC) enddo ! k loop endif - call find_coupling_coef(a, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, h_ml, & - dt, j, G, GV, CS, visc, forces, work_on_u=.true., OBC=OBC) + call find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, h_ml, & + dt, j, G, GV, US, CS, visc, forces, work_on_u=.true., OBC=OBC) if (allocated(hML_u)) then do i=isq,ieq ; if (do_i(i)) then ; hML_u(I,j) = h_ml(I) ; endif ; enddo endif @@ -763,13 +768,13 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, CS, OBC) if (do_any_shelf) then if (CS%harmonic_visc) then call find_coupling_coef(a_shelf, hvel, do_i_shelf, h_harm, bbl_thick, & - kv_bbl, z_i, h_ml, dt, j, G, GV, CS, & + kv_bbl, z_i, h_ml, dt, j, G, GV, US, CS, & visc, forces, work_on_u=.true., OBC=OBC, shelf=.true.) else ! Find upwind-biased thickness near the surface. ! Perhaps this needs to be done more carefully, via find_eta. do I=Isq,Ieq ; if (do_i_shelf(I)) then zh(I) = 0.0 ; Ztop_min(I) = min(zcol(i), zcol(i+1)) - I_HTbl(I) = 1.0 / (visc%tbl_thick_shelf_u(I,j)*m_to_H + h_neglect) + I_HTbl(I) = 1.0 / (visc%tbl_thick_shelf_u(I,j)*GV%Z_to_H + h_neglect) endif ; enddo do k=1,nz do i=Isq,Ieq+1 ; zcol(i) = zcol(i) - h(i,j,k) ; enddo @@ -791,7 +796,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, CS, OBC) endif ; enddo enddo call find_coupling_coef(a_shelf, hvel_shelf, do_i_shelf, h_harm, & - bbl_thick, kv_bbl, z_i, h_ml, dt, j, G, GV, CS, & + bbl_thick, kv_bbl, z_i, h_ml, dt, j, G, GV, US, CS, & visc, forces, work_on_u=.true., OBC=OBC, shelf=.true.) endif do I=Isq,Ieq ; if (do_i_shelf(I)) CS%a1_shelf_u(I,j) = a_shelf(I,1) ; enddo @@ -801,12 +806,12 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, CS, OBC) if (do_any_shelf) then do K=1,nz+1 ; do I=Isq,Ieq ; if (do_i_shelf(I)) then CS%a_u(I,j,K) = forces%frac_shelf_u(I,j) * a_shelf(I,K) + & - (1.0-forces%frac_shelf_u(I,j)) * a(I,K) + (1.0-forces%frac_shelf_u(I,j)) * a_cpl(I,K) ! This is Alistair's suggestion, but it destabilizes the model. I do not know why. RWH -! CS%a_u(I,j,K) = forces%frac_shelf_u(I,j) * max(a_shelf(I,K), a(I,K)) + & -! (1.0-forces%frac_shelf_u(I,j)) * a(I,K) +! CS%a_u(I,j,K) = forces%frac_shelf_u(I,j) * max(a_shelf(I,K), a_cpl(I,K)) + & +! (1.0-forces%frac_shelf_u(I,j)) * a_cpl(I,K) elseif (do_i(I)) then - CS%a_u(I,j,K) = a(I,K) + CS%a_u(I,j,K) = a_cpl(I,K) endif ; enddo ; enddo do k=1,nz ; do I=Isq,Ieq ; if (do_i_shelf(I)) then ! Should we instead take the inverse of the average of the inverses? @@ -816,26 +821,30 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, CS, OBC) CS%h_u(I,j,k) = hvel(I,k) endif ; enddo ; enddo else - do K=1,nz+1 ; do I=Isq,Ieq ; if (do_i(I)) CS%a_u(I,j,K) = a(I,K) ; enddo ; enddo + do K=1,nz+1 ; do I=Isq,Ieq ; if (do_i(I)) CS%a_u(I,j,K) = a_cpl(I,K) ; enddo ; enddo do k=1,nz ; do I=Isq,Ieq ; if (do_i(I)) CS%h_u(I,j,k) = hvel(I,k) ; enddo ; enddo endif + ! Diagnose total Kv at u-points + if (CS%id_Kv_u > 0) then + do k=1,nz ; do I=Isq,Ieq + if (do_i(I)) Kv_u(I,j,k) = 0.5 * GV%H_to_Z*(CS%a_u(I,j,K)+CS%a_u(I,j,K+1)) * CS%h_u(I,j,k) + enddo ; enddo + endif + enddo ! Now work on v-points. -!$OMP parallel do default(none) shared(G,GV,CS,visc,is,ie,Jsq,Jeq,nz,v,h,forces,hML_v, & -!$OMP OBC,h_neglect,dt,m_to_H,I_valBL) & -!$OMP firstprivate(i_hbbl) & -!$OMP private(do_i,kv_bbl,bbl_thick,z_i,h_harm,h_arith,h_delta,hvel,z2,zi_dir, & -!$OMP botfn,zh,Dmin,zcol1,zcol2,a,do_any_shelf,do_i_shelf, & -!$OMP a_shelf,Ztop_min,I_HTbl,hvel_shelf,topfn,h_ml,z2_wt,z_clear) + !$OMP parallel do default(private) shared(G,GV,CS,US,visc,is,ie,Jsq,Jeq,nz,v,h,forces,hML_v, & + !$OMP OBC,h_neglect,dt,I_valBL,Kv_v) & + !$OMP firstprivate(i_hbbl) do J=Jsq,Jeq do i=is,ie ; do_i(i) = (G%mask2dCv(i,J) > 0) ; enddo if (CS%bottomdraglaw) then ; do i=is,ie kv_bbl(i) = visc%kv_bbl_v(i,J) - bbl_thick(i) = visc%bbl_thick_v(i,J) * m_to_H + bbl_thick(i) = visc%bbl_thick_v(i,J) * GV%Z_to_H if (do_i(i)) I_Hbbl(i) = 1.0 / bbl_thick(i) enddo ; endif @@ -845,7 +854,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, CS, OBC) h_delta(i,k) = h(i,j+1,k) - h(i,j,k) endif ; enddo ; enddo do i=is,ie - Dmin(i) = min(G%bathyT(i,j), G%bathyT(i,j+1)) * m_to_H + Dmin(i) = min(G%bathyT(i,j), G%bathyT(i,j+1)) * GV%Z_to_H zi_dir(i) = 0 enddo @@ -854,18 +863,18 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, CS, OBC) do i=is,ie ; if (do_i(i) .and. (OBC%segnum_v(i,J) /= OBC_NONE)) then if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then do k=1,nz ; h_harm(I,k) = h(i,j,k) ; h_arith(I,k) = h(i,j,k) ; h_delta(i,k) = 0. ; enddo - Dmin(I) = G%bathyT(i,j) * m_to_H + Dmin(I) = G%bathyT(i,j) * GV%Z_to_H zi_dir(I) = -1 elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then do k=1,nz ; h_harm(i,k) = h(i,j+1,k) ; h_arith(i,k) = h(i,j+1,k) ; h_delta(i,k) = 0. ; enddo - Dmin(i) = G%bathyT(i,j+1) * m_to_H + Dmin(i) = G%bathyT(i,j+1) * GV%Z_to_H zi_dir(i) = 1 endif endif ; enddo endif ; endif ! The following block calculates the thicknesses at velocity -! grid points for the vertical viscosity (hvel[k]). Near the +! grid points for the vertical viscosity (hvel). Near the ! bottom an upwind biased thickness is used to control the effect ! of spurious Montgomery potential gradients at the bottom where ! nearly massless layers layers ride over the topography. @@ -883,8 +892,8 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, CS, OBC) else ! Not harmonic_visc do i=is,ie zh(i) = 0.0 ; z_i(i,nz+1) = 0.0 - zcol1(i) = -G%bathyT(i,j) * m_to_H - zcol2(i) = -G%bathyT(i,j+1) * m_to_H + zcol1(i) = -G%bathyT(i,j) * GV%Z_to_H + zcol2(i) = -G%bathyT(i,j+1) * GV%Z_to_H enddo do k=nz,1,-1 ; do i=is,ie ; if (do_i(i)) then zh(i) = zh(i) + h_harm(i,k) @@ -912,8 +921,8 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, CS, OBC) endif ; enddo ; enddo ! i & k loops endif - call find_coupling_coef(a, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, h_ml, & - dt, j, G, GV, CS, visc, forces, work_on_u=.false., OBC=OBC) + call find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, h_ml, & + dt, j, G, GV, US, CS, visc, forces, work_on_u=.false., OBC=OBC) if ( allocated(hML_v)) then do i=is,ie ; if (do_i(i)) then ; hML_v(i,J) = h_ml(i) ; endif ; enddo endif @@ -927,13 +936,13 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, CS, OBC) if (do_any_shelf) then if (CS%harmonic_visc) then call find_coupling_coef(a_shelf, hvel, do_i_shelf, h_harm, bbl_thick, & - kv_bbl, z_i, h_ml, dt, j, G, GV, CS, visc, & + kv_bbl, z_i, h_ml, dt, j, G, GV, US, CS, visc, & forces, work_on_u=.false., OBC=OBC, shelf=.true.) else ! Find upwind-biased thickness near the surface. ! Perhaps this needs to be done more carefully, via find_eta. do i=is,ie ; if (do_i_shelf(i)) then zh(i) = 0.0 ; Ztop_min(I) = min(zcol1(i), zcol2(i)) - I_HTbl(i) = 1.0 / (visc%tbl_thick_shelf_v(i,J)*m_to_H + h_neglect) + I_HTbl(i) = 1.0 / (visc%tbl_thick_shelf_v(i,J)*GV%Z_to_H + h_neglect) endif ; enddo do k=1,nz do i=is,ie ; if (do_i_shelf(i)) then @@ -955,7 +964,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, CS, OBC) endif ; enddo enddo call find_coupling_coef(a_shelf, hvel_shelf, do_i_shelf, h_harm, & - bbl_thick, kv_bbl, z_i, h_ml, dt, j, G, GV, CS, & + bbl_thick, kv_bbl, z_i, h_ml, dt, j, G, GV, US, CS, & visc, forces, work_on_u=.false., OBC=OBC, shelf=.true.) endif do i=is,ie ; if (do_i_shelf(i)) CS%a1_shelf_v(i,J) = a_shelf(i,1) ; enddo @@ -965,12 +974,12 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, CS, OBC) if (do_any_shelf) then do K=1,nz+1 ; do i=is,ie ; if (do_i_shelf(i)) then CS%a_v(i,J,K) = forces%frac_shelf_v(i,J) * a_shelf(i,k) + & - (1.0-forces%frac_shelf_v(i,J)) * a(i,K) + (1.0-forces%frac_shelf_v(i,J)) * a_cpl(i,K) ! This is Alistair's suggestion, but it destabilizes the model. I do not know why. RWH -! CS%a_v(i,J,K) = forces%frac_shelf_v(i,J) * max(a_shelf(i,K), a(i,K)) + & -! (1.0-forces%frac_shelf_v(i,J)) * a(i,K) +! CS%a_v(i,J,K) = forces%frac_shelf_v(i,J) * max(a_shelf(i,K), a_cpl(i,K)) + & +! (1.0-forces%frac_shelf_v(i,J)) * a_cpl(i,K) elseif (do_i(i)) then - CS%a_v(i,J,K) = a(i,K) + CS%a_v(i,J,K) = a_cpl(i,K) endif ; enddo ; enddo do k=1,nz ; do i=is,ie ; if (do_i_shelf(i)) then ! Should we instead take the inverse of the average of the inverses? @@ -980,22 +989,33 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, CS, OBC) CS%h_v(i,J,k) = hvel(i,k) endif ; enddo ; enddo else - do K=1,nz+1 ; do i=is,ie ; if (do_i(i)) CS%a_v(i,J,K) = a(i,K) ; enddo ; enddo + do K=1,nz+1 ; do i=is,ie ; if (do_i(i)) CS%a_v(i,J,K) = a_cpl(i,K) ; enddo ; enddo do k=1,nz ; do i=is,ie ; if (do_i(i)) CS%h_v(i,J,k) = hvel(i,k) ; enddo ; enddo endif + + ! Diagnose total Kv at v-points + if (CS%id_Kv_v > 0) then + do k=1,nz ; do i=is,ie + if (do_i(I)) Kv_v(i,J,k) = 0.5 * GV%H_to_Z*(CS%a_v(i,J,K)+CS%a_v(i,J,K+1)) * CS%h_v(i,J,k) + enddo ; enddo + endif + enddo ! end of v-point j loop if (CS%debug) then call uvchksum("vertvisc_coef h_[uv]", CS%h_u, & CS%h_v, G%HI,haloshift=0, scale=GV%H_to_m) call uvchksum("vertvisc_coef a_[uv]", CS%a_u, & - CS%a_v, G%HI, haloshift=0) + CS%a_v, G%HI, haloshift=0, scale=US%Z_to_m) if (allocated(hML_u) .and. allocated(hML_v)) & call uvchksum("vertvisc_coef hML_[uv]", hML_u, hML_v, & G%HI, haloshift=0, scale=GV%H_to_m) endif ! Offer diagnostic fields for averaging. + if (CS%id_Kv_slow > 0) call post_data(CS%id_Kv_slow, visc%Kv_slow, CS%diag) + if (CS%id_Kv_u > 0) call post_data(CS%id_Kv_u, Kv_u, CS%diag) + if (CS%id_Kv_v > 0) call post_data(CS%id_Kv_v, Kv_v, CS%diag) if (CS%id_au_vv > 0) call post_data(CS%id_au_vv, CS%a_u, CS%diag) if (CS%id_av_vv > 0) call post_data(CS%id_av_vv, CS%a_v, CS%diag) if (CS%id_h_u > 0) call post_data(CS%id_h_u, CS%h_u, CS%diag) @@ -1008,73 +1028,64 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, CS, OBC) end subroutine vertvisc_coef -!> Calculate the 'coupling coefficient' (a[k]) at the -!! interfaces. If BOTTOMDRAGLAW is defined, the minimum of Hbbl and half the -!! adjacent layer thicknesses are used to calculate a[k] near the bottom. -subroutine find_coupling_coef(a, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, h_ml, & - dt, j, G, GV, CS, visc, forces, work_on_u, OBC, shelf) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - !> Coupling coefficient across interfaces, in m s-1 - real, dimension(SZIB_(G),SZK_(GV)+1), intent(out) :: a - !> Thickness at velocity points, in H - real, dimension(SZIB_(G),SZK_(GV)), intent(in) :: hvel - !> If true, determine coupling coefficient for a column - logical, dimension(SZIB_(G)), intent(in) :: do_i - !> Harmonic mean of thicknesses around a velocity grid point, in H - real, dimension(SZIB_(G),SZK_(GV)), intent(in) :: h_harm - !> Bottom boundary layer thickness, in H - real, dimension(SZIB_(G)), intent(in) :: bbl_thick - !> Bottom boundary layer viscosity, in m2 s-1 - real, dimension(SZIB_(G)), intent(in) :: kv_bbl - !> Estimate of interface heights above the bottom, - !! normalised by the bottom boundary layer thickness - real, dimension(SZIB_(G),SZK_(GV)+1), intent(in) :: z_i - !> Mixed layer depth, in H - real, dimension(SZIB_(G)), intent(out) :: h_ml - !> j-index to find coupling coefficient for - integer, intent(in) :: j - !> Time increment, in s - real, intent(in) :: dt - !> Vertical viscosity control structure - type(vertvisc_CS), pointer :: CS - !> Structure containing viscosities and bottom drag - type(vertvisc_type), intent(in) :: visc - type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces - !> If true, u-points are being calculated, otherwise v-points - logical, intent(in) :: work_on_u - !> Open boundary condition structure - type(ocean_OBC_type), pointer :: OBC - !> If present and true, use a surface boundary condition - !! appropriate for an ice shelf. - logical, optional, intent(in) :: shelf +!> Calculate the 'coupling coefficient' (a_cpl) at the interfaces. +!! If BOTTOMDRAGLAW is defined, the minimum of Hbbl and half the adjacent +!! layer thicknesses are used to calculate a_cpl near the bottom. +subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, h_ml, & + dt, j, G, GV, US, CS, visc, forces, work_on_u, OBC, shelf) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + 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),SZK_(GV)+1), & + intent(out) :: a_cpl !< Coupling coefficient across interfaces [Z s-1 ~> m s-1]. + real, dimension(SZIB_(G),SZK_(GV)), & + intent(in) :: hvel !< Thickness at velocity points [H ~> m or kg m-2] + logical, dimension(SZIB_(G)), & + intent(in) :: do_i !< If true, determine coupling coefficient for a column + real, dimension(SZIB_(G),SZK_(GV)), & + intent(in) :: h_harm !< Harmonic mean of thicknesses around a velocity + !! grid point [H ~> m or kg m-2] + real, dimension(SZIB_(G)), intent(in) :: bbl_thick !< Bottom boundary layer thickness [H ~> m or kg m-2] + real, dimension(SZIB_(G)), intent(in) :: kv_bbl !< Bottom boundary layer viscosity [Z2 s-1 ~> m2 s-1]. + real, dimension(SZIB_(G),SZK_(GV)+1), & + intent(in) :: z_i !< Estimate of interface heights above the bottom, + !! normalized by the bottom boundary layer thickness + real, dimension(SZIB_(G)), intent(out) :: h_ml !< Mixed layer depth [H ~> m or kg m-2] + integer, intent(in) :: j !< j-index to find coupling coefficient for + real, intent(in) :: dt !< Time increment [s] + type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure + type(vertvisc_type), intent(in) :: visc !< Structure containing viscosities and bottom drag + type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces + logical, intent(in) :: work_on_u !< If true, u-points are being calculated, + !! otherwise they are v-points + type(ocean_OBC_type), pointer :: OBC !< Open boundary condition structure + logical, optional, intent(in) :: shelf !< If present and true, use a surface boundary + !! condition appropriate for an ice shelf. ! Local variables real, dimension(SZIB_(G)) :: & - u_star, & ! ustar at a velocity point, in m s-1. - absf, & ! The average of the neighboring absolute values of f, in s-1. -! h_ml, & ! The mixed layer depth, in m or kg m-2. + u_star, & ! ustar at a velocity point [Z s-1 ~> m s-1]. + absf, & ! The average of the neighboring absolute values of f [s-1]. +! h_ml, & ! The mixed layer depth [H ~> m or kg m-2]. nk_visc, & ! The (real) interface index of the base of mixed layer. z_t, & ! The distance from the top, sometimes normalized - ! by Hmix, in m or nondimensional. - kv_tbl, & + ! by Hmix, [H ~> m or kg m-2] or [nondim]. + kv_tbl, & ! The viscosity in a top boundary layer under ice [Z2 s-1 ~> m2 s-1]. tbl_thick real, dimension(SZIB_(G),SZK_(GV)) :: & - Kv_add ! A viscosity to add, in m2 s-1. - real :: h_shear ! The distance over which shears occur, m or kg m-2. - real :: r ! A thickness to compare with Hbbl, in m or kg m-2. - real :: visc_ml ! The mixed layer viscosity, in m2 s-1. - real :: I_Hmix ! The inverse of the mixed layer thickness, in m-1 or m2 kg-1. + Kv_add ! A viscosity to add [Z2 s-1 ~> m2 s-1]. + real :: h_shear ! The distance over which shears occur [H ~> m or kg m-2]. + real :: r ! A thickness to compare with Hbbl [H ~> m or kg m-2]. + real :: visc_ml ! The mixed layer viscosity [Z2 s-1 ~> m2 s-1]. + real :: I_Hmix ! The inverse of the mixed layer thickness [H-1 ~> m-1 or m2 kg-1]. real :: a_ml ! The layer coupling coefficient across an interface in - ! the mixed layer, in m s-1. - real :: temp1 ! A temporary variable in m2 s-1. + ! the mixed layer [m s-1]. + real :: I_amax ! The inverse of the maximum coupling coefficient [Z-1 ~> m-1].??? + real :: temp1 ! A temporary variable [H Z ~> m2 or kg m-1] real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected, in H. - real :: dz_neglect ! A thickness in m that is so small it is usually lost - ! in roundoff and can be neglected, in m. + ! in roundoff and can be neglected [H ~> m or kg m-2]. real :: z2 ! A copy of z_i, nondim. - real :: H_to_m, m_to_H ! Unit conversion factors. real :: topfn real :: a_top logical :: do_shelf, do_OBCs @@ -1082,14 +1093,17 @@ subroutine find_coupling_coef(a, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, h_m integer :: nz real :: botfn - a(:,:) = 0.0 + a_cpl(:,:) = 0.0 if (work_on_u) then ; is = G%IscB ; ie = G%IecB else ; is = G%isc ; ie = G%iec ; endif nz = G%ke h_neglect = GV%H_subroundoff - H_to_m = GV%H_to_m ; m_to_H = GV%m_to_H - dz_neglect = GV%H_subroundoff*GV%H_to_m + + ! The maximum coupling coefficent was originally introduced to avoid + ! truncation error problems in the tridiagonal solver. Effectively, the 1e-10 + ! sets the maximum coupling coefficient increment to 1e10 m per timestep. + I_amax = (1.0e-10*US%Z_to_m) * dt do_shelf = .false. ; if (present(shelf)) do_shelf = shelf do_OBCs = .false. @@ -1098,15 +1112,15 @@ subroutine find_coupling_coef(a, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, h_m ! The following loop calculates the vertical average velocity and ! surface mixed layer contributions to the vertical viscosity. - do i=is,ie ; a(i,1) = 0.0 ; enddo + do i=is,ie ; a_cpl(i,1) = 0.0 ; enddo if ((GV%nkml>0) .or. do_shelf) then ; do k=2,nz ; do i=is,ie - if (do_i(i)) a(i,K) = 2.0*CS%Kv + if (do_i(i)) a_cpl(i,K) = 2.0*CS%Kv enddo ; enddo ; else - I_Hmix = 1.0 / (CS%Hmix * m_to_H + h_neglect) + I_Hmix = 1.0 / (CS%Hmix + h_neglect) do i=is,ie ; z_t(i) = h_neglect*I_Hmix ; enddo do K=2,nz ; do i=is,ie ; if (do_i(i)) then z_t(i) = z_t(i) + h_harm(i,k-1)*I_Hmix - a(i,K) = 2.0*CS%Kv + 2.0*CS%Kvml / ((z_t(i)*z_t(i)) * & + a_cpl(i,K) = 2.0*CS%Kv + 2.0*CS%Kvml / ((z_t(i)*z_t(i)) * & (1.0 + 0.09*z_t(i)*z_t(i)*z_t(i)*z_t(i)*z_t(i)*z_t(i))) endif ; enddo ; enddo endif @@ -1115,12 +1129,12 @@ subroutine find_coupling_coef(a, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, h_m if (CS%bottomdraglaw) then r = hvel(i,nz)*0.5 if (r < bbl_thick(i)) then - a(i,nz+1) = 1.0*kv_bbl(i) / (1e-10*dt*kv_bbl(i) + r*H_to_m) + a_cpl(i,nz+1) = 1.0*kv_bbl(i) / (I_amax*kv_bbl(i) + r*GV%H_to_Z) else - a(i,nz+1) = 1.0*kv_bbl(i) / (1e-10*dt*kv_bbl(i) + bbl_thick(i)*H_to_m) + a_cpl(i,nz+1) = 1.0*kv_bbl(i) / (I_amax*kv_bbl(i) + bbl_thick(i)*GV%H_to_Z) endif else - a(i,nz+1) = 2.0*CS%Kvbbl / (hvel(i,nz)*H_to_m + 2.0e-10*dt*CS%Kvbbl) + a_cpl(i,nz+1) = 2.0*CS%Kvbbl / (hvel(i,nz)*GV%H_to_Z + 2.0*I_amax*CS%Kvbbl) endif endif ; enddo @@ -1143,7 +1157,7 @@ subroutine find_coupling_coef(a, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, h_m endif ; enddo endif do K=2,nz ; do i=is,ie ; if (do_i(i)) then - a(i,K) = a(i,K) + Kv_add(i,K) + a_cpl(i,K) = a_cpl(i,K) + Kv_add(i,K) endif ; enddo ; enddo else do K=2,nz ; do i=is,ie ; if (do_i(i)) then @@ -1159,7 +1173,58 @@ subroutine find_coupling_coef(a, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, h_m endif ; enddo endif do K=2,nz ; do i=is,ie ; if (do_i(i)) then - a(i,K) = a(i,K) + Kv_add(i,K) + a_cpl(i,K) = a_cpl(i,K) + Kv_add(i,K) + endif ; enddo ; enddo + endif + endif + + if (associated(visc%Kv_shear_Bu)) then + if (work_on_u) then + do K=2,nz ; do I=Is,Ie ; If (do_i(I)) then + a_cpl(I,K) = a_cpl(I,K) + (2.*0.5)*(visc%Kv_shear_Bu(I,J-1,k) + visc%Kv_shear_Bu(I,J,k)) + endif ; enddo ; enddo + else + do K=2,nz ; do i=is,ie ; if (do_i(i)) then + a_cpl(i,K) = a_cpl(i,K) + (2.*0.5)*(visc%Kv_shear_Bu(I-1,J,k) + visc%Kv_shear_Bu(I,J,k)) + endif ; enddo ; enddo + endif + endif + + ! add "slow" varying vertical viscosity (e.g., from background, tidal etc) + if (associated(visc%Kv_slow) .and. (visc%add_Kv_slow)) then + ! GMM/ A factor of 2 is also needed here, see comment above from BGR. + if (work_on_u) then + do K=2,nz ; do i=is,ie ; if (do_i(i)) then + Kv_add(i,K) = Kv_add(i,K) + 1.0 * (visc%Kv_slow(i,j,k) + visc%Kv_slow(i+1,j,k)) + endif ; enddo ; enddo + if (do_OBCs) then + do I=is,ie ; if (do_i(I) .and. (OBC%segnum_u(I,j) /= OBC_NONE)) then + if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then + do K=2,nz ; Kv_add(i,K) = Kv_add(i,K) + 2. * visc%Kv_slow(i,j,k) ; enddo + elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then + do K=2,nz ; Kv_add(i,K) = Kv_add(i,K) + 2. * visc%Kv_slow(i+1,j,k) ; enddo + endif + endif ; enddo + endif + do K=2,nz ; do i=is,ie ; if (do_i(i)) then + a_cpl(i,K) = a_cpl(i,K) + Kv_add(i,K) + endif ; enddo ; enddo + else + do K=2,nz ; do i=is,ie ; if (do_i(i)) then + Kv_add(i,K) = Kv_add(i,K) + 1.0*(visc%Kv_slow(i,j,k) + visc%Kv_slow(i,j+1,k)) + endif ; enddo ; enddo + !### I am pretty sure that this is double counting here! - RWH + if (do_OBCs) then + do i=is,ie ; if (do_i(i) .and. (OBC%segnum_v(i,J) /= OBC_NONE)) then + if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then + do K=2,nz ; Kv_add(i,K) = Kv_add(i,K) + 2. * visc%Kv_slow(i,j,k) ; enddo + elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then + do K=2,nz ; Kv_add(i,K) = Kv_add(i,K) + 2. * visc%Kv_slow(i,j+1,k) ; enddo + endif + endif ; enddo + endif + do K=2,nz ; do i=is,ie ; if (do_i(i)) then + a_cpl(i,K) = a_cpl(i,K) + Kv_add(i,K) endif ; enddo ; enddo endif endif @@ -1171,7 +1236,7 @@ subroutine find_coupling_coef(a, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, h_m botfn = 1.0 / (1.0 + 0.09*z2*z2*z2*z2*z2*z2) if (CS%bottomdraglaw) then - a(i,K) = a(i,K) + 2.0*(kv_bbl(i)-CS%Kv)*botfn + a_cpl(i,K) = a_cpl(i,K) + 2.0*(kv_bbl(i) - CS%Kv)*botfn r = (hvel(i,k)+hvel(i,k-1)) if (r > 2.0*bbl_thick(i)) then h_shear = ((1.0 - botfn) * r + botfn*2.0*bbl_thick(i)) @@ -1179,15 +1244,12 @@ subroutine find_coupling_coef(a, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, h_m h_shear = r endif else - a(i,K) = a(i,K) + 2.0*(CS%Kvbbl-CS%Kv)*botfn + a_cpl(i,K) = a_cpl(i,K) + 2.0*(CS%Kvbbl-CS%Kv)*botfn h_shear = hvel(i,k) + hvel(i,k-1) + h_neglect endif - ! Up to this point a has units of m2 s-1, but now is converted to m s-1. - ! The term including 1e-10 in the denominators is here to avoid - ! truncation error problems in the tridiagonal solver. Effectively, this - ! sets the maximum coupling coefficient at 1e10 m. - a(i,K) = a(i,K) / (h_shear*H_to_m + 1.0e-10*dt*a(i,K)) + ! Up to this point a_cpl has had units of Z2 s-1, but now is converted to Z s-1. + a_cpl(i,K) = a_cpl(i,K) / (h_shear*GV%H_to_Z + I_amax*a_cpl(i,K)) endif ; enddo ; enddo ! i & k loops if (do_shelf) then @@ -1195,18 +1257,18 @@ subroutine find_coupling_coef(a, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, h_m do i=is,ie ; if (do_i(i)) then if (work_on_u) then kv_tbl(i) = visc%kv_tbl_shelf_u(I,j) - tbl_thick(i) = visc%tbl_thick_shelf_u(I,j) * m_to_H + tbl_thick(i) = visc%tbl_thick_shelf_u(I,j) * GV%Z_to_H else kv_tbl(i) = visc%kv_tbl_shelf_v(i,J) - tbl_thick(i) = visc%tbl_thick_shelf_v(i,J) * m_to_H + tbl_thick(i) = visc%tbl_thick_shelf_v(i,J) * GV%Z_to_H endif z_t(i) = 0.0 - ! If a(i,1) were not already 0, it would be added here. + ! If a_cpl(i,1) were not already 0, it would be added here. if (0.5*hvel(i,1) > tbl_thick(i)) then - a(i,1) = kv_tbl(i) / (tbl_thick(i) *H_to_m + (1.0e-10*dt)*kv_tbl(i)) + a_cpl(i,1) = kv_tbl(i) / (tbl_thick(i) *GV%H_to_Z + I_amax*kv_tbl(i)) else - a(i,1) = kv_tbl(i) / (0.5*hvel(i,1)*H_to_m + (1.0e-10*dt)*kv_tbl(i)) + a_cpl(i,1) = kv_tbl(i) / (0.5*hvel(i,1)*GV%H_to_Z + I_amax*kv_tbl(i)) endif endif ; enddo @@ -1220,11 +1282,9 @@ subroutine find_coupling_coef(a, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, h_m else h_shear = r endif - ! The term including 1e-10 in the denominators is here to avoid - ! truncation error problems in the tridiagonal solver. Effectively, this - ! sets the maximum coupling coefficient increment to 1e10 m. + a_top = 2.0 * topfn * kv_tbl(i) - a(i,K) = a(i,K) + a_top / (h_shear*H_to_m + 1.0e-10*dt*a_top) + a_cpl(i,K) = a_cpl(i,K) + a_top / (h_shear*GV%H_to_Z + I_amax*a_top) endif ; enddo ; enddo elseif (CS%dynamic_viscous_ML .or. (GV%nkml>0)) then max_nk = 0 @@ -1270,16 +1330,15 @@ subroutine find_coupling_coef(a, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, h_m do K=2,max_nk ; do i=is,ie ; if (do_i(i)) then ; if (k < nk_visc(i)) then ! Set the viscosity at the interfaces. z_t(i) = z_t(i) + hvel(i,k-1) - temp1 = (z_t(i)*h_ml(i) - z_t(i)*z_t(i)) * H_to_m - ! This viscosity is set to go to 0 at the mixed layer top and bottom - ! (in a log-layer) and be further limited by rotation to give the - ! natural Ekman length. + temp1 = (z_t(i)*h_ml(i) - z_t(i)*z_t(i))*GV%H_to_Z + ! This viscosity is set to go to 0 at the mixed layer top and bottom (in a log-layer) + ! and be further limited by rotation to give the natural Ekman length. visc_ml = u_star(i) * 0.41 * (temp1*u_star(i)) / & (absf(i)*temp1 + h_ml(i)*u_star(i)) - a_ml = 4.0*visc_ml / ((hvel(i,k)+hvel(i,k-1) + h_neglect) * H_to_m + & - 2.0e-10*dt*visc_ml) + a_ml = 4.0*visc_ml / ((hvel(i,k)+hvel(i,k-1) + h_neglect) * GV%H_to_Z + & + 2.0*I_amax* visc_ml) ! Choose the largest estimate of a. - if (a_ml > a(i,K)) a(i,K) = a_ml + if (a_ml > a_cpl(i,K)) a_cpl(i,K) = a_ml endif ; endif ; enddo ; enddo endif @@ -1288,29 +1347,30 @@ end subroutine find_coupling_coef !> Velocity components which exceed a threshold for physically !! reasonable values are truncated. Optionally, any column with excessive !! velocities may be sent to a diagnostic reporting subroutine. -subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, CS) +subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, US, CS) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure 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),SZK_(GV)), & - intent(inout) :: u !< Zonal velocity in m s-1 + intent(inout) :: u !< Zonal velocity [m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - intent(inout) :: v !< Meridional velocity in m s-1 + intent(inout) :: v !< Meridional velocity [m s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< Layer thickness in H + intent(in) :: h !< Layer thickness [H ~> m or kg m-2] type(accel_diag_ptrs), intent(in) :: ADp !< Acceleration diagnostic pointers type(cont_diag_ptrs), intent(in) :: CDp !< Continuity diagnostic pointers type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces type(vertvisc_type), intent(in) :: visc !< Viscosities and bottom drag - real, intent(in) :: dt !< Time increment in s + real, intent(in) :: dt !< Time increment [s] type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure ! Local variables real :: maxvel ! Velocities components greater than maxvel - real :: truncvel ! are truncated to truncvel, both in m s-1. + real :: truncvel ! are truncated to truncvel, both [m s-1]. real :: CFL ! The local CFL number. real :: H_report ! A thickness below which not to report truncations. - real :: dt_Rho0 ! The timestep divided by the Boussinesq density, in dt m3 kg-1. + real :: dt_Rho0 ! The timestep divided by the Boussinesq density [s m3 kg-1]. real :: vel_report(SZIB_(G),SZJB_(G)) real :: u_old(SZIB_(G),SZJ_(G),SZK_(G)) real :: v_old(SZI_(G),SZJB_(G),SZK_(G)) @@ -1321,7 +1381,7 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, CS) maxvel = CS%maxvel truncvel = 0.9*maxvel - H_report = 6.0 * GV%Angstrom + H_report = 6.0 * GV%Angstrom_H dt_Rho0 = dt / GV%Rho0 if (len_trim(CS%u_trunc_file) > 0) then @@ -1372,7 +1432,7 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, CS) do k=1,nz ; do I=Isq,Ieq ; if (abs(u(I,j,k)) > maxvel) then u(I,j,k) = SIGN(truncvel,u(I,j,k)) if (h(i,j,k) + h(i+1,j,k) > H_report) CS%ntrunc = CS%ntrunc + 1 - endif ; enddo ; enddo + endif ; enddo ; enddo endif ; endif enddo ! j-loop else ! Do not report accelerations leading to large velocities. @@ -1404,10 +1464,9 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, CS) do j=js,je; do I=Isq,Ieq ; if (dowrite(I,j)) then ! Here the diagnostic reporting subroutines are called if ! unphysically large values were found. - call write_u_accel(I, j, u_old, h, ADp, CDp, dt, G, GV, CS%PointAccel_CSp, & - vel_report(I,j), -vel_report(I,j), forces%taux(I,j)*dt_Rho0, & - a=CS%a_u(:,j,:), hv=CS%h_u(:,j,:)) - endif ; enddo; enddo + call write_u_accel(I, j, u_old, h, ADp, CDp, dt, G, GV, US, CS%PointAccel_CSp, & + vel_report(I,j), forces%taux(I,j)*dt_Rho0, a=CS%a_u, hv=CS%h_u) + endif ; enddo ; enddo endif if (len_trim(CS%v_trunc_file) > 0) then @@ -1458,7 +1517,7 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, CS) do k=1,nz ; do i=is,ie ; if (abs(v(i,J,k)) > maxvel) then v(i,J,k) = SIGN(truncvel,v(i,J,k)) if (h(i,j,k) + h(i,j+1,k) > H_report) CS%ntrunc = CS%ntrunc + 1 - endif ; enddo ; enddo + endif ; enddo ; enddo endif ; endif enddo ! J-loop else ! Do not report accelerations leading to large velocities. @@ -1490,33 +1549,36 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, CS) do J=Jsq,Jeq; do i=is,ie ; if (dowrite(i,J)) then ! Here the diagnostic reporting subroutines are called if ! unphysically large values were found. - call write_v_accel(i, J, v_old, h, ADp, CDp, dt, G, GV, CS%PointAccel_CSp, & - vel_report(i,J), -vel_report(i,J), forces%tauy(i,J)*dt_Rho0, & - a=CS%a_v(:,J,:),hv=CS%h_v(:,J,:)) - endif ; enddo; enddo + call write_v_accel(i, J, v_old, h, ADp, CDp, dt, G, GV, US, CS%PointAccel_CSp, & + vel_report(i,J), forces%tauy(i,J)*dt_Rho0, a=CS%a_v, hv=CS%h_v) + endif ; enddo ; enddo endif end subroutine vertvisc_limit_vel -!> Initialise the vertical friction module -subroutine vertvisc_init(MIS, Time, G, GV, param_file, diag, ADp, dirs, & +!> Initialize the vertical friction module +subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & ntrunc, CS) - !> "MOM Internal State", a set of pointers to the fields and accelerations - !! that make up the ocean's physical state - type(ocean_internal_state), target, intent(in) :: MIS - type(time_type), target, intent(in) :: Time !< Current model time - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(ocean_internal_state), & + target, intent(in) :: MIS !< The "MOM Internal State", a set of pointers + !! to the fields and accelerations that make + !! up the ocean's physical state + type(time_type), target, intent(in) :: Time !< Current model time + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< File to parse for parameters - type(diag_ctrl), target, intent(inout) :: diag !< Diagnostic control structure - type(accel_diag_ptrs), intent(inout) :: ADp !< Acceleration diagnostic pointers - type(directories), intent(in) :: dirs !< Relevant directory paths - integer, target, intent(inout) :: ntrunc !< Number of velocity truncations - type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure + type(diag_ctrl), target, intent(inout) :: diag !< Diagnostic control structure + type(accel_diag_ptrs), intent(inout) :: ADp !< Acceleration diagnostic pointers + type(directories), intent(in) :: dirs !< Relevant directory paths + integer, target, intent(inout) :: ntrunc !< Number of velocity truncations + type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure ! Local variables real :: hmix_str_dflt + real :: Kv_dflt ! A default viscosity [m2 s-1]. + real :: Hmix_m ! A boundary layer thickness [m]. integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz ! This include declares and sets the variable "version". #include "version_variable.h" @@ -1583,16 +1645,17 @@ subroutine vertvisc_init(MIS, Time, G, GV, param_file, diag, ADp, dirs, & 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"//& - "mixed layer is not used.", units="m", fail_if_missing=.true.) + "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"//& - "DIRECT_STRESS is true.", units="m", default=CS%Hmix) + "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"//& - "DIRECT_STRESS is true.", units="m", fail_if_missing=.true.) + "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.") @@ -1600,25 +1663,24 @@ subroutine vertvisc_init(MIS, Time, G, GV, param_file, diag, ADp, dirs, & call get_param(param_file, mdl, "KV", CS%Kv, & "The background kinematic viscosity in the interior. \n"//& "The molecular value, ~1e-6 m2 s-1, may be used.", & - units="m2 s-1", fail_if_missing=.true.) + units="m2 s-1", fail_if_missing=.true., scale=US%m_to_Z**2, unscaled=Kv_dflt) -! CS%Kvml = CS%Kv ; CS%Kvbbl = CS%Kv ! Needed? -AJA 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"//& "BULKMIXEDLAYER is true. The default is set by KV.", & - units="m2 s-1", default=CS%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"//& "BOTTOMDRAGLAW is true. The default is set by KV.", & - units="m2 s-1", default=CS%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"//& - "but LINEAR_DRAG is not.", units="m", fail_if_missing=.true.) + "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"//& "components are truncated.", units="m s-1", default=3.0e8) @@ -1672,17 +1734,30 @@ subroutine vertvisc_init(MIS, Time, G, GV, param_file, diag, ADp, dirs, & ALLOC_(CS%a_v(isd:ied,JsdB:JedB,nz+1)) ; CS%a_v(:,:,:) = 0.0 ALLOC_(CS%h_v(isd:ied,JsdB:JedB,nz)) ; CS%h_v(:,:,:) = 0.0 + CS%id_Kv_slow = register_diag_field('ocean_model', 'Kv_slow', diag%axesTi, Time, & + 'Slow varying vertical viscosity', 'm2 s-1', conversion=US%Z_to_m**2) + + CS%id_Kv_u = register_diag_field('ocean_model', 'Kv_u', diag%axesCuL, Time, & + 'Total vertical viscosity at u-points', 'm2 s-1', conversion=US%Z_to_m**2) + + CS%id_Kv_v = register_diag_field('ocean_model', 'Kv_v', diag%axesCvL, Time, & + 'Total vertical viscosity at v-points', 'm2 s-1', conversion=US%Z_to_m**2) + CS%id_au_vv = register_diag_field('ocean_model', 'au_visc', diag%axesCui, Time, & - 'Zonal Viscous Vertical Coupling Coefficient', 'm s-1') + 'Zonal Viscous Vertical Coupling Coefficient', 'm s-1', conversion=US%Z_to_m) + CS%id_av_vv = register_diag_field('ocean_model', 'av_visc', diag%axesCvi, Time, & - 'Meridional Viscous Vertical Coupling Coefficient', 'm s-1') + 'Meridional Viscous Vertical Coupling Coefficient', 'm s-1', conversion=US%Z_to_m) CS%id_h_u = register_diag_field('ocean_model', 'Hu_visc', diag%axesCuL, Time, & 'Thickness at Zonal Velocity Points for Viscosity', thickness_units) + CS%id_h_v = register_diag_field('ocean_model', 'Hv_visc', diag%axesCvL, Time, & 'Thickness at Meridional Velocity Points for Viscosity', thickness_units) + CS%id_hML_u = register_diag_field('ocean_model', 'HMLu_visc', diag%axesCu1, Time, & 'Mixed Layer Thickness at Zonal Velocity Points for Viscosity', thickness_units) + CS%id_hML_v = register_diag_field('ocean_model', 'HMLv_visc', diag%axesCv1, Time, & 'Mixed Layer Thickness at Meridional Velocity Points for Viscosity', thickness_units) @@ -1709,8 +1784,8 @@ end subroutine vertvisc_init subroutine updateCFLtruncationValue(Time, CS, activate) type(time_type), target, intent(in) :: Time !< Current model time type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure - !> Whether to record the value of Time as the beginning of the ramp period - logical, optional, intent(in) :: activate + logical, optional, intent(in) :: activate !< Specifiy whether to record the value of + !! Time as the beginning of the ramp period ! Local variables real :: deltaTime, wghtA @@ -1745,7 +1820,9 @@ end subroutine updateCFLtruncationValue !> Clean up and deallocate the vertical friction module subroutine vertvisc_end(CS) - type(vertvisc_CS), pointer :: CS + type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure that + !! will be deallocated in this subroutine. + DEALLOC_(CS%a_u) ; DEALLOC_(CS%h_u) DEALLOC_(CS%a_v) ; DEALLOC_(CS%h_v) if (associated(CS%a1_shelf_u)) deallocate(CS%a1_shelf_u) diff --git a/src/tracer/DOME_tracer.F90 b/src/tracer/DOME_tracer.F90 index 62d2c98de6..45eebb983e 100644 --- a/src/tracer/DOME_tracer.F90 +++ b/src/tracer/DOME_tracer.F90 @@ -1,3 +1,4 @@ +!> A tracer package that is used as a diagnostic in the DOME experiments module DOME_tracer ! This file is part of MOM6. See LICENSE.md for the license. @@ -14,9 +15,10 @@ module DOME_tracer use MOM_open_boundary, only : OBC_segment_type, register_segment_tracer use MOM_restart, only : MOM_restart_CS use MOM_sponge, only : set_up_sponge_field, sponge_CS -use MOM_time_manager, only : time_type, get_time +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_unit_scaling, only : unit_scale_type use MOM_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type @@ -30,35 +32,35 @@ module DOME_tracer public register_DOME_tracer, initialize_DOME_tracer public DOME_tracer_column_physics, DOME_tracer_surface_state, DOME_tracer_end -! ntr is the number of tracers in this module. -integer, parameter :: ntr = 11 +! 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. +integer, parameter :: ntr = 11 !< The number of tracers in this module. + +!> The DOME_tracer control structure type, public :: DOME_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() - real, pointer :: tr(:,:,:,:) => NULL() ! The array of tracers used in this - ! subroutine, in g m-3? - real :: land_val(NTR) = -1.0 ! The value of tr used where land is masked out. - logical :: use_sponge ! If true, sponges may be applied somewhere in the domain. - - integer, dimension(NTR) :: ind_tr ! Indices returned by aof_set_coupler_flux - ! if it is used and the surface tracer concentrations are to be - ! provided to the coupler. - - type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the - ! timing of diagnostic output. - - type(vardesc) :: tr_desc(NTR) + 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 => NULL() !< 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, in g m-3? + real :: land_val(NTR) = -1.0 !< The value of tr used where land is masked out. + logical :: use_sponge !< If true, sponges may be applied somewhere in the domain. + + integer, dimension(NTR) :: ind_tr !< Indices returned by aof_set_coupler_flux if it is used and the + !! surface tracer concentrations are to be provided to the coupler. + + type(diag_ctrl), pointer :: diag => NULL() !< 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 DOME_tracer_CS contains -!> This subroutine is used to register tracer fields and subroutines -!! to be used with MOM. +!> Register tracer fields and subroutines to be used with MOM. function register_DOME_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 @@ -137,16 +139,16 @@ function register_DOME_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) register_DOME_tracer = .true. end function register_DOME_tracer -!> This subroutine initializes the NTR tracer fields in tr(:,:,:,:) -!! and it sets up the tracer output. -subroutine initialize_DOME_tracer(restart, day, G, GV, h, diag, OBC, CS, & +!> 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) 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 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 thicknesses, in H (usually m or kg m-2) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(diag_ctrl), target, intent(in) :: diag !< Structure used to regulate diagnostic output. type(ocean_OBC_type), pointer :: OBC !< Structure specifying open boundary options. type(DOME_tracer_CS), pointer :: CS !< The control structure returned by a previous @@ -172,10 +174,11 @@ subroutine initialize_DOME_tracer(restart, day, G, GV, h, diag, OBC, CS, & 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 :: dist2 ! The distance squared from a line [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 + ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: e(SZK_(G)+1), e_top, e_bot ! Heights [Z ~> m]. + real :: d_tr ! A change in tracer concentraions, in tracer units. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m integer :: IsdB, IedB, JsdB, JedB @@ -214,30 +217,30 @@ subroutine initialize_DOME_tracer(restart, day, G, GV, h, diag, OBC, CS, & ! This adds the stripes of tracer to every layer. CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + tr_y enddo - enddo; enddo; enddo + enddo ; enddo ; enddo if (NTR > 7) then do j=js,je ; do i=is,ie e(nz+1) = -G%bathyT(i,j) do k=nz,1,-1 - e(K) = e(K+1) + h(i,j,k)*GV%H_to_m + e(K) = e(K+1) + h(i,j,k)*GV%H_to_Z do m=7,NTR - e_top = -600.0*real(m-1) + 3000.0 - e_bot = -600.0*real(m-1) + 2700.0 + e_top = (-600.0*real(m-1) + 3000.0) * US%m_to_Z + e_bot = (-600.0*real(m-1) + 2700.0) * US%m_to_Z if (e_top < e(K)) then if (e_top < e(K+1)) then ; d_tr = 0.0 elseif (e_bot < e(K+1)) then - d_tr = (e_top-e(K+1)) / ((h(i,j,k)+h_neglect)*GV%H_to_m) - else ; d_tr = (e_top-e_bot) / ((h(i,j,k)+h_neglect)*GV%H_to_m) + d_tr = 1.0 * (e_top-e(K+1)) / ((h(i,j,k)+h_neglect)*GV%H_to_Z) + else ; d_tr = 1.0 * (e_top-e_bot) / ((h(i,j,k)+h_neglect)*GV%H_to_Z) endif elseif (e_bot < e(K)) then if (e_bot < e(K+1)) then ; d_tr = 1.0 - else ; d_tr = (e(K)-e_bot) / ((h(i,j,k)+h_neglect)*GV%H_to_m) + else ; d_tr = 1.0 * (e(K)-e_bot) / ((h(i,j,k)+h_neglect)*GV%H_to_Z) endif else d_tr = 0.0 endif - if (h(i,j,k) < 2.0*GV%Angstrom) d_tr=0.0 + if (h(i,j,k) < 2.0*GV%Angstrom_H) d_tr=0.0 CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + d_tr enddo enddo @@ -282,28 +285,32 @@ end subroutine initialize_DOME_tracer !! This is a simple example of a set of advected passive tracers. !! !! 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] +!! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) subroutine DOME_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, - !! in m or kg m-2. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_new !< Layer thickness after entrainment, - !! in 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, in 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, in 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, in s - type(DOME_tracer_CS), pointer :: CS !< The control structure returned by a previous - !! call to DOME_register_tracer. - real, optional,intent(in) :: evap_CFL_limit - real, optional,intent(in) :: 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 thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call [s] + type(DOME_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to DOME_register_tracer. + 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] ! Local variables real :: b1(SZI_(G)) ! b1 and c1 are variables used by the @@ -318,7 +325,7 @@ subroutine DOME_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, 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; + enddo ; enddo ; enddo call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m) , dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) @@ -339,7 +346,7 @@ subroutine DOME_tracer_surface_state(state, h, G, CS) type(surface), intent(inout) :: state !< A structure containing fields that !! describe the surface state of the ocean. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< Layer thickness, in m or kg m-2. + intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. type(DOME_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to DOME_register_tracer. @@ -366,7 +373,8 @@ end subroutine DOME_tracer_surface_state !> Clean up memory allocations, if any. subroutine DOME_tracer_end(CS) - type(DOME_tracer_CS), pointer :: CS + type(DOME_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to DOME_register_tracer. integer :: m if (associated(CS)) then @@ -375,38 +383,21 @@ subroutine DOME_tracer_end(CS) endif end subroutine DOME_tracer_end -!> \namespace DOME_tracer -!! * -!! By Robert Hallberg, 2002 * -!! * -!! This file contains an example of the code that is needed to set * -!! up and use a set (in this case eleven) of dynamically passive * -!! tracers. These tracers dye the inflowing water or water initially * -!! within a range of latitudes or water initially in a range of * -!! depths. * -!! * -!! A single subroutine is called from within each file to register * -!! each of the tracers for reinitialization and advection and to * -!! register the subroutine that initializes the tracers and set up * -!! their output and the subroutine that does any tracer physics or * -!! chemistry along with diapycnal mixing (included here because some * -!! tracers may float or swim vertically or dye diapycnal processes). * -!! * -!! * -!! Macros written all in capital letters are defined in MOM_memory.h. * -!! * -!! A small fragment of the grid is shown below: * -!! * -!! j+1 x ^ x ^ x At x: q * -!! j+1 > o > o > At ^: v * -!! j x ^ x ^ x At >: u * -!! j > o > o > At o: h, tr * -!! j-1 x ^ x ^ x * -!! i-1 i i+1 At x & ^: * -!! i i+1 At > & o: * -!! * -!! The boundaries always run through q grid points (x). * -!! * -!!*******+*********+*********+*********+*********+*********+*********+** +!> \namespace dome_tracer +!! +!! By Robert Hallberg, 2002 +!! +!! This file contains an example of the code that is needed to set +!! up and use a set (in this case eleven) of dynamically passive +!! tracers. These tracers dye the inflowing water or water initially +!! within a range of latitudes or water initially in a range of +!! depths. +!! +!! A single subroutine is called from within each file to register +!! each of the tracers for reinitialization and advection and to +!! register the subroutine that initializes the tracers and set up +!! their output and the subroutine that does any tracer physics or +!! chemistry along with diapycnal mixing (included here because some +!! tracers may float or swim vertically or dye diapycnal processes). end module DOME_tracer diff --git a/src/tracer/ISOMIP_tracer.F90 b/src/tracer/ISOMIP_tracer.F90 index 80c2cc2c3c..36bc3edb65 100644 --- a/src/tracer/ISOMIP_tracer.F90 +++ b/src/tracer/ISOMIP_tracer.F90 @@ -1,20 +1,14 @@ -!> This module contains the routines used to set up and use a set of (one for now) -!! dynamically passive tracers. For now, just one passive tracer is injected in +!> Routines used to set up and use a set of (one for now) +!! dynamically passive tracers in the ISOMIP configuration. +!! +!! For now, just one passive tracer is injected in !! the sponge layer. -!! Set up and use passive tracers requires the following: -!! (1) register_ISOMIP_tracer -!! (2) module ISOMIP_tracer ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* Original sample tracer package by Robert Hallberg, 2002 * -!* Adapted to the ISOMIP test case by Gustavo Marques, May 2016 * -!* * -!********+*********+*********+*********+*********+*********+*********+** - +! Original sample tracer package by Robert Hallberg, 2002 +! 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 @@ -26,7 +20,7 @@ module ISOMIP_tracer use MOM_io, only : file_exists, MOM_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 -use MOM_time_manager, only : time_type, get_time +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 @@ -45,42 +39,39 @@ module ISOMIP_tracer public register_ISOMIP_tracer, initialize_ISOMIP_tracer public ISOMIP_tracer_column_physics, ISOMIP_tracer_surface_state, ISOMIP_tracer_end -!< ntr is the number of tracers in this module. -integer, parameter :: ntr = 1 +integer, parameter :: ntr = 1 !< ntr is the number of tracers in this module. -!> tracer control structure +!> ISOMIP tracer package control structure type, public :: ISOMIP_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. + 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() - real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this - !< subroutine, in g m-3? + type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the MOM tracer registry + real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this package, in g m-3? real :: land_val(NTR) = -1.0 !< The value of tr used where land is masked out. - logical :: use_sponge ! If true, sponges may be applied somewhere in the domain. + logical :: use_sponge !< If true, sponges may be applied somewhere in the domain. integer, dimension(NTR) :: ind_tr !< Indices returned by aof_set_coupler_flux !< if it is used and the surface tracer concentrations are to be !< provided to the coupler. type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the - !< timing of diagnostic output. + !! timing of diagnostic output. - type(vardesc) :: tr_desc(NTR) + type(vardesc) :: tr_desc(NTR) !< Descriptions and metadata for the tracers in this package end type ISOMIP_tracer_CS contains !> This subroutine is used to register tracer fields -function register_ISOMIP_tracer(HI, GV, param_file, CS, tr_Reg, & - restart_CS) +function register_ISOMIP_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) type(hor_index_type), intent(in) :: HI ! m or kg m-2]. + type(diag_ctrl), target, intent(in) :: diag !< A structure that is 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(ISOMIP_tracer_CS), pointer :: CS !< The control structure returned by a previous call + !! to ISOMIP_register_tracer. + 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(:,:,:) :: & @@ -182,9 +181,9 @@ subroutine initialize_ISOMIP_tracer(restart, day, G, GV, h, diag, OBC, CS, & 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 :: dist2 ! The distance squared from a line [m2]. real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected, in m. + ! in roundoff and can be neglected [H ~> m or kg m-2]. real :: e(SZK_(G)+1), e_top, e_bot, d_tr integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m integer :: IsdB, IedB, JsdB, JedB @@ -249,45 +248,45 @@ subroutine initialize_ISOMIP_tracer(restart, day, G, GV, h, diag, OBC, CS, & end subroutine initialize_ISOMIP_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. +!> This subroutine applies diapycnal diffusion, including the surface boundary +!! conditions and any other column tracer physics or chemistry to the tracers from this file. subroutine ISOMIP_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, h_new, ea, eb - type(forcing), intent(in) :: fluxes - real, intent(in) :: dt !< The amount of time covered by this call, in s - type(ISOMIP_tracer_CS), pointer :: CS - real, optional,intent(in) :: evap_CFL_limit - real, optional,intent(in) :: minimum_forcing_depth - -! Arguments: h_old - Layer thickness before entrainment, in m or kg m-2. -! (in) h_new - Layer thickness after entrainment, in m or kg m-2. -! (in) ea - an array to which the amount of fluid entrained -! from the layer above during this call will be -! added, in m or kg m-2. -! (in) eb - an array to which the amount of fluid entrained -! from the layer below during this call will be -! added, in m or kg m-2. -! (in) fluxes - A structure containing pointers to any possible -! forcing fields. Unused fields have NULL ptrs. -! (in) dt - The amount of time covered by this call, in s. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - The control structure returned by a previous call to -! ISOMIP_register_tracer. -! + 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 thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call [s] + type(ISOMIP_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to ISOMIP_register_tracer. + 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] +! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) + ! Local variables real :: mmax 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 :: melt(SZI_(G),SZJ_(G)) ! melt water (positive for melting ! negative for freezing) + character(len=256) :: mesg ! The text of an error message 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 @@ -298,15 +297,15 @@ subroutine ISOMIP_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, G ! max. melt mmax = MAXVAL(melt(is:ie,js:je)) call max_across_PEs(mmax) - !write(*,*)'max melt', mmax + ! write(mesg,*) 'max melt = ', mmax + ! call MOM_mesg(mesg, 5) ! dye melt water (m=1), dye = 1 if melt=max(melt) do m=1,NTR - do j=js,je ; do i=is,ie + do j=js,je ; do i=is,ie if (melt(i,j) > 0.0) then ! melting - !write(*,*)'i,j,melt,melt/mmax',i,j,melt(i,j),melt(i,j)/mmax - CS%tr(i,j,1:2,m) = melt(i,j)/mmax ! inject dye in the ML + CS%tr(i,j,1:2,m) = melt(i,j)/mmax ! inject dye in the ML else ! freezing - CS%tr(i,j,1:2,m) = 0.0 + CS%tr(i,j,1:2,m) = 0.0 endif enddo ; enddo enddo @@ -314,10 +313,10 @@ subroutine ISOMIP_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, G 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; + 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) + evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) enddo else @@ -336,7 +335,7 @@ subroutine ISOMIP_tracer_surface_state(state, h, G, CS) type(surface), intent(inout) :: state !< A structure containing fields that !! describe the surface state of the ocean. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< Layer thickness, in m or kg m-2. + intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. type(ISOMIP_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to ISOMIP_register_tracer. @@ -361,8 +360,10 @@ subroutine ISOMIP_tracer_surface_state(state, h, G, CS) end subroutine ISOMIP_tracer_surface_state +!> Deallocate any memory used by the ISOMIP tracer package subroutine ISOMIP_tracer_end(CS) - type(ISOMIP_tracer_CS), pointer :: CS + type(ISOMIP_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to ISOMIP_register_tracer. integer :: m if (associated(CS)) then diff --git a/src/tracer/MOM_OCMIP2_CFC.F90 b/src/tracer/MOM_OCMIP2_CFC.F90 index 454521184e..805409c16b 100644 --- a/src/tracer/MOM_OCMIP2_CFC.F90 +++ b/src/tracer/MOM_OCMIP2_CFC.F90 @@ -1,52 +1,8 @@ +!> Simulates CFCs using the OCMIP2 protocols module MOM_OCMIP2_CFC ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Robert Hallberg, 2007 * -!* * -!* This file contains an example of the code that is needed to set * -!* up and use CFC-11 and CFC-12 in a fully coupled or ice-ocean model * -!* context. There are 5 subroutines in this file. * -!* * -!* register_OCMIP2_CFC determines if the module is going to work, * -!* then makes several calls registering tracers to be advected and * -!* read from a restart file. it also sets various run-time parameters * -!* for this module and sets up a "control structure" (CS) to store * -!* all information for this module. * -!* * -!* initialize_OCMIP2_CFC initializes this modules arrays if they * -!* have not been found in a restart file. It also determines which * -!* diagnostics will need to be calculated. * -!* * -!* OCMIP2_CFC_column_physics updates the CFC concentrations, * -!* applying everthing but horizontal advection and diffusion. * -!* Surface fluxes are applied inside an implicit vertical advection * -!* and diffusion tridiagonal solver, and any interior sources and * -!* sinks (not applicable for CFCs) would also be applied here. This * -!* subroutine also sends out any requested interior diagnostics. * -!* * -!* OCMIP2_CFC_surface_state calculates the information required * -!* from the ocean for the FMS coupler to calculate CFC fluxes. * -!* * -!* OCMIP2_CFC_end deallocates the persistent run-time memory used * -!* by this module. * -!* * -!* A small fragment of the horizontal grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q * -!* j+1 > o > o > At ^: v, * -!* j x ^ x ^ x At >: u * -!* j > o > o > At o: h, CFC11, CFC12 * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** - 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 @@ -58,10 +14,11 @@ module MOM_OCMIP2_CFC use MOM_open_boundary, only : ocean_OBC_type use MOM_restart, only : query_initialized, MOM_restart_CS use MOM_sponge, only : set_up_sponge_field, sponge_CS -use MOM_time_manager, only : time_type, get_time +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_tracer_Z_init, only : tracer_Z_init +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type @@ -78,51 +35,61 @@ module MOM_OCMIP2_CFC public OCMIP2_CFC_stock, OCMIP2_CFC_end -! NTR is the number of tracers in this module. -integer, parameter :: NTR = 2 +integer, parameter :: NTR = 2 !< the number of tracers in this module. +!> The control structure for the OCMPI2_CFC tracer package type, public :: OCMIP2_CFC_CS ; private - character(len=200) :: IC_file ! The file in which the CFC initial values can - ! be found, or an empty string for internal initilaization. - logical :: Z_IC_file ! If true, the IC_file is in Z-space. The default is false.. - type(time_type), pointer :: Time ! A pointer to the ocean model's clock. - type(tracer_registry_type), pointer :: tr_Reg => NULL() + character(len=200) :: IC_file !< The file in which the CFC initial values can + !! be found, or an empty string for internal initilaization. + logical :: Z_IC_file !< If true, the IC_file is in Z-space. The default is false.. + type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. + type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the MOM6 tracer registry real, pointer, dimension(:,:,:) :: & - CFC11 => NULL(), & ! The CFC11 concentration in mol m-3. - CFC12 => NULL() ! The CFC12 concentration in mol m-3. + CFC11 => NULL(), & !< The CFC11 concentration [mol m-3]. + CFC12 => NULL() !< The CFC12 concentration [mol m-3]. ! In the following variables a suffix of _11 refers to CFC11 and _12 to CFC12. - real :: a1_11, a2_11, a3_11, a4_11 ! Coefficients in the calculation of the - real :: a1_12, a2_12, a3_12, a4_12 ! CFC11 and CFC12 Schmidt numbers, in - ! units of ND, degC-1, degC-2, degC-3. - real :: d1_11, d2_11, d3_11, d4_11 ! Coefficients in the calculation of the - real :: d1_12, d2_12, d3_12, d4_12 ! CFC11 and CFC12 solubilities, in units - ! of ND, K-1, log(K)^-1, K-2. - real :: e1_11, e2_11, e3_11 ! More coefficients in the calculation of - real :: e1_12, e2_12, e3_12 ! the CFC11 and CFC12 solubilities, in - ! units of PSU-1, PSU-1 K-1, PSU-1 K-2. - real :: CFC11_IC_val = 0.0 ! The initial value assigned to CFC11. - real :: CFC12_IC_val = 0.0 ! The initial value assigned to CFC12. - real :: CFC11_land_val = -1.0 ! The values of CFC11 and CFC12 used where - real :: CFC12_land_val = -1.0 ! land is masked out. - logical :: tracers_may_reinit ! If true, tracers may go through the - ! initialization code if they are not found in the - ! restart files. - character(len=16) :: CFC11_name, CFC12_name ! Variable names. - - integer :: ind_cfc_11_flux ! Indices returned by aof_set_coupler_flux that - integer :: ind_cfc_12_flux ! are used to pack and unpack surface boundary - ! condition arrays. - - type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the - ! timing of diagnostic output. + !>@{ Coefficients used in the CFC11 and CFC12 solubility calculation + real :: a1_11, a1_12 ! Coefficients for calculating CFC11 and CFC12 Schmidt numbers [nondim] + real :: a2_11, a2_12 ! Coefficients for calculating CFC11 and CFC12 Schmidt numbers [degC-1] + real :: a3_11, a3_12 ! Coefficients for calculating CFC11 and CFC12 Schmidt numbers [degC-2] + real :: a4_11, a4_12 ! Coefficients for calculating CFC11 and CFC12 Schmidt numbers [degC-3] + + real :: d1_11, d1_12 ! Coefficients for calculating CFC11 and CFC12 solubilities [nondim] + real :: d2_11, d2_12 ! Coefficients for calculating CFC11 and CFC12 solubilities [hectoKelvin-1] + real :: d3_11, d3_12 ! Coefficients for calculating CFC11 and CFC12 solubilities [log(hectoKelvin)-1] + real :: d4_11, d4_12 ! Coefficients for calculating CFC11 and CFC12 solubilities [hectoKelvin-2] + + real :: e1_11, e1_12 ! Coefficients for calculating CFC11 and CFC12 solubilities [PSU-1] + real :: e2_11, e2_12 ! Coefficients for calculating CFC11 and CFC12 solubilities [PSU-1 hectoKelvin-1] + real :: e3_11, e3_12 ! Coefficients for calculating CFC11 and CFC12 solubilities [PSU-2 hectoKelvin-2] + !!@} + real :: CFC11_IC_val = 0.0 !< The initial value assigned to CFC11 [mol m-3]. + real :: CFC12_IC_val = 0.0 !< The initial value assigned to CFC12 [mol m-3]. + real :: CFC11_land_val = -1.0 !< The value of CFC11 used where land is masked out [mol m-3]. + real :: CFC12_land_val = -1.0 !< The value of CFC12 used where land is masked out [mol m-3]. + logical :: tracers_may_reinit !< If true, tracers may be reset via the initialization code + !! if they are not found in the restart files. + character(len=16) :: CFC11_name !< CFC11 variable name + character(len=16) :: CFC12_name !< CFC12 variable name + + integer :: ind_cfc_11_flux !< Index returned by aof_set_coupler_flux that is used to + !! pack and unpack surface boundary condition arrays. + integer :: ind_cfc_12_flux !< Index returned by aof_set_coupler_flux that is used to + !! pack and unpack surface boundary condition arrays. + + type(diag_ctrl), pointer :: diag => NULL() ! A structure that is used to + ! regulate the timing of diagnostic output. type(MOM_restart_CS), pointer :: restart_CSp => NULL() ! The following vardesc types contain a package of metadata about each tracer. - type(vardesc) :: CFC11_desc, CFC12_desc + type(vardesc) :: CFC11_desc !< A set of metadata for the CFC11 tracer + type(vardesc) :: CFC12_desc !< A set of metadata for the CFC12 tracer end type OCMIP2_CFC_CS contains +!> Register the OCMIP2 CFC tracers to be used with MOM and read the parameters +!! that are used with this tracer package function register_OCMIP2_CFC(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. @@ -134,19 +101,13 @@ function register_OCMIP2_CFC(HI, GV, param_file, CS, tr_Reg, restart_CS) type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure. ! This subroutine is used to register tracer fields and subroutines ! to be used with MOM. -! Arguments: HI - A horizontal index type structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in/out) CS - A pointer that is set to point to the control structure -! for this module -! (in/out) tr_Reg - A pointer to the tracer registry. -! (in) restart_CS - A pointer to the restart control structure. - -! This include declares and sets the variable "version". -#include "version_variable.h" + + ! Local variables character(len=40) :: mdl = "MOM_OCMIP2_CFC" ! This module's name. character(len=200) :: inputdir ! The directory where NetCDF input files are. - real, dimension(:,:,:), pointer :: tr_ptr + ! This include declares and sets the variable "version". +#include "version_variable.h" + real, dimension(:,:,:), pointer :: tr_ptr => NULL() real :: a11_dflt(4), a12_dflt(4) ! Default values of the various coefficients real :: d11_dflt(4), d12_dflt(4) ! In the expressions for the solubility and real :: e11_dflt(3), e12_dflt(3) ! Schmidt numbers. @@ -351,18 +312,17 @@ subroutine flux_init_OCMIP2_CFC(CS, verbosity) end subroutine flux_init_OCMIP2_CFC -!>This subroutine initializes the NTR tracer fields in tr(:,:,:,:) -!! and it sets up the tracer output. -subroutine initialize_OCMIP2_CFC(restart, day, G, GV, h, diag, OBC, CS, & +!> 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) 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. 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 real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< Layer thicknesses, in H - !! (usually m or kg m-2). + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate !! diagnostic output. type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type @@ -378,21 +338,6 @@ subroutine initialize_OCMIP2_CFC(restart, day, G, GV, h, diag, OBC, CS, & ! This subroutine initializes the NTR tracer fields in tr(:,:,:,:) ! and it sets up the tracer output. -! Arguments: restart - .true. if the fields have already been read from -! a restart file. -! (in) day - Time of the start of the run. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) h - Layer thickness, in m or kg m-2. -! (in) diag - A structure that is used to regulate diagnostic output. -! (in) OBC - This open boundary condition type specifies whether, where, -! and what open boundary conditions are used. -! (in/out) CS - The control structure returned by a previous call to -! register_OCMIP2_CFC. -! (in/out) sponge_CSp - A pointer to the control structure for the sponges, if -! they are in use. Otherwise this may be unassociated. -! (in/out) diag_to_Z_Csp - A pointer to the control structure for diagnostics -! in depth space. logical :: from_file = .false. if (.not.associated(CS)) return @@ -403,12 +348,12 @@ subroutine initialize_OCMIP2_CFC(restart, day, G, GV, h, diag, OBC, CS, & if (.not.restart .or. (CS%tracers_may_reinit .and. & .not.query_initialized(CS%CFC11, CS%CFC11_name, CS%restart_CSp))) & call init_tracer_CFC(h, CS%CFC11, CS%CFC11_name, CS%CFC11_land_val, & - CS%CFC11_IC_val, G, CS) + CS%CFC11_IC_val, G, US, CS) if (.not.restart .or. (CS%tracers_may_reinit .and. & .not.query_initialized(CS%CFC12, CS%CFC12_name, CS%restart_CSp))) & call init_tracer_CFC(h, CS%CFC12, CS%CFC12_name, CS%CFC12_land_val, & - CS%CFC12_IC_val, G, CS) + CS%CFC12_IC_val, G, US, CS) if (associated(OBC)) then ! Steal from updated DOME in the fullness of time. @@ -417,13 +362,16 @@ subroutine initialize_OCMIP2_CFC(restart, day, G, GV, h, diag, OBC, CS, & end subroutine initialize_OCMIP2_CFC !>This subroutine initializes a tracer array. -subroutine init_tracer_CFC(h, tr, name, land_val, IC_val, G, CS) +subroutine init_tracer_CFC(h, tr, name, land_val, IC_val, G, US, 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, in H (usually m or kg m-2) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: tr - character(len=*), intent(in) :: name - real, intent(in) :: land_val, IC_val - type(OCMIP2_CFC_CS), pointer :: CS + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + 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(out) :: tr !< The tracer concentration array + character(len=*), intent(in) :: name !< The tracer name + real, intent(in) :: land_val !< A value the tracer takes over land + real, intent(in) :: IC_val !< The initial condition value for the tracer + type(OCMIP2_CFC_CS), pointer :: CS !< The control structure returned by a + !! previous call to register_OCMIP2_CFC. ! This subroutine initializes a tracer array. @@ -436,9 +384,9 @@ subroutine init_tracer_CFC(h, tr, name, land_val, IC_val, G, CS) if (.not.file_exists(CS%IC_file, G%Domain)) & call MOM_error(FATAL, "initialize_OCMIP2_CFC: Unable to open "//CS%IC_file) if (CS%Z_IC_file) then - OK = tracer_Z_init(tr, h, CS%IC_file, name, G) + OK = tracer_Z_init(tr, h, CS%IC_file, name, G, US) if (.not.OK) then - OK = tracer_Z_init(tr, h, CS%IC_file, trim(name), G) + OK = tracer_Z_init(tr, h, CS%IC_file, trim(name), G, US) if (.not.OK) call MOM_error(FATAL,"initialize_OCMIP2_CFC: "//& "Unable to read "//trim(name)//" from "//& trim(CS%IC_file)//".") @@ -458,67 +406,49 @@ subroutine init_tracer_CFC(h, tr, name, land_val, IC_val, G, CS) end subroutine init_tracer_CFC -!> This subroutine applies diapycnal diffusion and any other column -! tracer physics or chemistry to the tracers from this file. -! CFCs are relatively simple, as they are passive tracers. with only a surface -! flux as a source. +!> This subroutine applies diapycnal diffusion, souces and sinks and any other column +!! tracer physics or chemistry to the OCMIP2 CFC tracers. +!! CFCs are relatively simple, as they are passive tracers with only a surface flux as a source. subroutine OCMIP2_CFC_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. + 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, - !! in m or kg m-2. + 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, - !! in m or kg m-2. + 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, in m or kg m-2. + 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, in 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, in s - type(OCMIP2_CFC_CS), pointer :: CS !< The control structure returned by a - !! previous call to register_OCMIP2_CFC. - real, optional,intent(in) :: evap_CFL_limit - real, optional,intent(in) :: minimum_forcing_depth + 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 thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call [s] + type(OCMIP2_CFC_CS), pointer :: CS !< The control structure returned by a + !! previous call to register_OCMIP2_CFC. + 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] ! This subroutine applies diapycnal diffusion and any other column ! tracer physics or chemistry to the tracers from this file. ! CFCs are relatively simple, as they are passive tracers. with only a surface ! flux as a source. -! Arguments: h_old - Layer thickness before entrainment, in m or kg m-2. -! (in) h_new - Layer thickness after entrainment, in m or kg m-2. -! (in) ea - an array to which the amount of fluid entrained -! from the layer above during this call will be -! added, in m or kg m-2. -! (in) eb - an array to which the amount of fluid entrained -! from the layer below during this call will be -! added, in m or kg m-2. -! (in) fluxes - A structure containing pointers to any possible -! forcing fields. Unused fields have NULL ptrs. -! (in) dt - The amount of time covered by this call, in s. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - The control structure returned by a previous call to -! register_OCMIP2_CFC. -! ! 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] +! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) + ! Local variables 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)) :: & CFC11_flux, & ! The fluxes of CFC11 and CFC12 into the ocean, in the CFC12_flux ! units of CFC concentrations times meters per second. - real, pointer, dimension(:,:,:) :: CFC11, CFC12 + real, pointer, dimension(:,:,:) :: CFC11 => NULL(), CFC12 => NULL() real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_work ! Used so that h can be modified integer :: i, j, k, m, is, ie, js, je, nz, idim(4), jdim(4) @@ -542,14 +472,14 @@ subroutine OCMIP2_CFC_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then 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; + enddo ; enddo ; enddo call applyTracerBoundaryFluxesInOut(G, GV, CFC11, dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CFC11, G, GV, sfc_flux=CFC11_flux) 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; + enddo ; enddo ; enddo call applyTracerBoundaryFluxesInOut(G, GV, CFC12, dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CFC12, G, GV, sfc_flux=CFC12_flux) @@ -569,34 +499,18 @@ function OCMIP2_CFC_stock(h, stocks, G, GV, CS, names, units, stock_index) 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 !< Layer thicknesses, in H - !! (usually m or kg m-2). - real, dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount - !! of each tracer, in kg times - !! concentration units. + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + real, dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of each + !! tracer, in kg times concentration units [kg conc]. type(OCMIP2_CFC_CS), pointer :: CS !< The control structure returned by a !! previous call to register_OCMIP2_CFC. character(len=*), dimension(:), intent(out) :: names !< The names of the stocks calculated. character(len=*), dimension(:), intent(out) :: units !< The units of the stocks calculated. integer, optional, intent(in) :: stock_index !< The coded index of a specific !! stock being sought. - integer :: OCMIP2_CFC_stock -! This function calculates the mass-weighted integral of all tracer stocks, -! returning the number of stocks it has calculated. If the stock_index -! is present, only the stock corresponding to that coded index is returned. - -! Arguments: h - Layer thickness, in m or kg m-2. -! (out) stocks - the mass-weighted integrated amount of each tracer, -! in kg times concentration units. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - The control structure returned by a previous call to -! register_OCMIP2_CFC. -! (out) names - the names of the stocks calculated. -! (out) units - the units of the stocks calculated. -! (in,opt) stock_index - the coded index of a specific stock being sought. -! Return value: the number of stocks calculated here. + integer :: OCMIP2_CFC_stock !< The number of stocks calculated here. + ! Local variables real :: mass integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -635,20 +549,21 @@ subroutine OCMIP2_CFC_surface_state(state, h, G, CS) type(surface), intent(inout) :: state !< A structure containing fields that !! describe the surface state of the ocean. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< Layer thickness, in m or kg m-2. + intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. type(OCMIP2_CFC_CS), pointer :: CS !< The control structure returned by a previous !! call to register_OCMIP2_CFC. + ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & - CFC11_Csurf, & ! The CFC-11 and CFC-12 surface concentrations times the - CFC12_Csurf, & ! Schmidt number term, both in mol m-3. - CFC11_alpha, & ! The CFC-11 solubility in mol m-3 pptv-1. - CFC12_alpha ! The CFC-12 solubility in mol m-3 pptv-1. - real :: ta ! Absolute sea surface temperature in units of dekaKelvin!?! - real :: sal ! Surface salinity in PSU. - real :: SST ! Sea surface temperature in degrees Celsius. - real :: alpha_11 ! The solubility of CFC 11 in mol m-3 pptv-1. - real :: alpha_12 ! The solubility of CFC 12 in mol m-3 pptv-1. + CFC11_Csurf, & ! The CFC-11 surface concentrations times the Schmidt number term [mol m-3]. + CFC12_Csurf, & ! The CFC-12 surface concentrations times the Schmidt number term [mol m-3]. + CFC11_alpha, & ! The CFC-11 solubility [mol m-3 pptv-1]. + CFC12_alpha ! The CFC-12 solubility [mol m-3 pptv-1]. + real :: ta ! Absolute sea surface temperature [hectoKelvin] (Why use such bizzare units?) + real :: sal ! Surface salinity [PSU]. + real :: SST ! Sea surface temperature [degC]. + real :: alpha_11 ! The solubility of CFC 11 [mol m-3 pptv-1]. + real :: alpha_12 ! The solubility of CFC 12 [mol m-3 pptv-1]. real :: sc_11, sc_12 ! The Schmidt numbers of CFC 11 and CFC 12. real :: sc_no_term ! A term related to the Schmidt number. integer :: i, j, m, is, ie, js, je, idim(4), jdim(4) @@ -700,8 +615,10 @@ subroutine OCMIP2_CFC_surface_state(state, h, G, CS) end subroutine OCMIP2_CFC_surface_state +!> Deallocate any memory associated with the OCMIP2 CFC tracer package subroutine OCMIP2_CFC_end(CS) - type(OCMIP2_CFC_CS), pointer :: CS + type(OCMIP2_CFC_CS), pointer :: CS !< The control structure returned by a + !! previous call to register_OCMIP2_CFC. ! This subroutine deallocates the memory owned by this module. ! Argument: CS - The control structure returned by a previous call to ! register_OCMIP2_CFC. @@ -715,4 +632,13 @@ subroutine OCMIP2_CFC_end(CS) endif end subroutine OCMIP2_CFC_end + +!> \namespace mom_ocmip2_cfc +!! +!! By Robert Hallberg, 2007 +!! +!! This module contains the code that is needed to set +!! up and use CFC-11 and CFC-12 in a fully coupled or ice-ocean model +!! context using the OCMIP2 protocols + end module MOM_OCMIP2_CFC diff --git a/src/tracer/MOM_OCMIP2_CO2calc.F90 b/src/tracer/MOM_OCMIP2_CO2calc.F90 deleted file mode 100644 index 0f3d16abd1..0000000000 --- a/src/tracer/MOM_OCMIP2_CO2calc.F90 +++ /dev/null @@ -1,532 +0,0 @@ -module MOM_ocmip2_co2calc_mod !{ - -! This file is part of MOM6. See LICENSE.md for the license. - -! Richard D. Slater -! -! -! John P. Dunne -! -! -! -! Surface fCO2 calculation -! -! -! -! Calculate the fugacity of CO2 at the surface in thermodynamic -! equilibrium with the current alkalinity (Alk) and total dissolved -! inorganic carbon (DIC) at a particular temperature and salinity -! using an initial guess for the total hydrogen -! ion concentration (htotal) -! -! - -! -!------------------------------------------------------------------ -! -! Global definitions -! -!------------------------------------------------------------------ -! - -implicit none - -private - -public :: MOM_ocmip2_co2calc, CO2_dope_vector - -! This include declares and sets the variable "version". -#include "version_variable.h" - -type CO2_dope_vector - integer :: isc, iec, jsc, jec - integer :: isd, ied, jsd, jed -end type CO2_dope_vector -! -!----------------------------------------------------------------------- -! -! Subroutine and function definitions -! -!----------------------------------------------------------------------- -! - -contains - - -!####################################################################### -! -! -! -! Calculate co2* from total alkalinity and total CO2 at -! temperature (t) and salinity (s). -! It is assumed that init_ocmip2_co2calc has already been called with -! the T and S to calculate the various coefficients. -! -! INPUT -! -! dope_vec = an array of indices corresponding to the compute -! and data domain boundaries. -! -! mask = land mask array (0.0 = land) -! -! dic_in = total inorganic carbon (mol/kg) -! where 1 T = 1 metric ton = 1000 kg -! -! ta_in = total alkalinity (eq/kg) -! -! pt_in = inorganic phosphate (mol/kg) -! -! sit_in = inorganic silicate (mol/kg) -! -! htotallo = lower limit of htotal range -! -! htotalhi = upper limit of htotal range -! -! htotal = H+ concentration (mol/kg) -! -! OUTPUT -! co2star = CO2*water, or H2CO3 concentration (mol/kg) -! alpha = Solubility of CO2 for air (mol/kg/atm) -! pco2surf = oceanic pCO2 (ppmv) -! co3_ion = Carbonate ion, or CO3-- concentration (mol/kg) -! -! FILES and PROGRAMS NEEDED: drtsafe, ta_iter_1 -! -! IMPORTANT: co2star and alpha need to be multiplied by rho before being -! passed to the atmosphere. -! -! - -subroutine MOM_ocmip2_co2calc(dope_vec, mask, & - t_in, s_in, dic_in, pt_in, sit_in, ta_in, htotallo, & - htotalhi, htotal, co2star, alpha, pCO2surf, co3_ion) !{ - -implicit none - -! -! local parameters -! - -real, parameter :: permeg = 1.e-6 -real, parameter :: xacc = 1.0e-10 - -! -! arguments -! -type(CO2_dope_vector), intent(in) :: dope_vec -real, dimension(dope_vec%isd:dope_vec%ied,dope_vec%jsd:dope_vec%jed), & - intent(in):: mask, & - t_in, & - s_in, & - dic_in, & - pt_in, & - sit_in, & - ta_in, & - htotallo, & - htotalhi -real, dimension(dope_vec%isd:dope_vec%ied,dope_vec%jsd:dope_vec%jed), & - intent(inout) :: htotal -real, dimension(dope_vec%isd:dope_vec%ied,dope_vec%jsd:dope_vec%jed), & - intent(out), optional :: alpha, & - pCO2surf, & - co2star, & - co3_ion -! -! local variables -! -integer :: isc, iec, jsc, jec -integer :: i,j -real :: alpha_internal -real :: bt -real :: co2star_internal -real :: dlogtk -real :: ft -real :: htotal2 -real :: invtk -real :: is -real :: is2 -real :: k0 -real :: k1 -real :: k2 -real :: k1p -real :: k2p -real :: k3p -real :: kb -real :: kf -real :: ks -real :: ksi -real :: kw -real :: log100 -real :: s2 -real :: scl -real :: sqrtis -real :: sqrts -real :: st -real :: tk -real :: tk100 -real :: tk1002 -real :: logf_of_s - -! Set the loop indices. - isc = dope_vec%isc ; iec = dope_vec%iec - jsc = dope_vec%jsc ; jec = dope_vec%jec - -! -! Initialize the module -! - log100 = log(100.0) - - do j = jsc, jec !{ - do i = isc, iec !{ -! -!--------------------------------------------------------------------- -! -!*********************************************************************** -! Calculate all constants needed to convert between various measured -! carbon species. References for each equation are noted in the code. -! Once calculated, the constants are stored and passed in the common -! block "const". The original version of this code was based on -! the code by Dickson in Version 2 of "Handbook of Methods for the -! Analysis of the Various Parameters of the Carbon Dioxide System -! in Seawater", DOE, 1994 (SOP No. 3, p25-26). - tk = 273.15 + t_in(i,j) - tk100 = tk / 100.0 - tk1002 = tk100**2 - invtk = 1.0 / tk - dlogtk = log(tk) - is = 19.924 * s_in(i,j) /(1000.0 -1.005 * s_in(i,j)) - is2 = is * is - sqrtis = sqrt(is) - s2 = s_in(i,j) * s_in(i,j) - sqrts = sqrt(s_in(i,j)) - scl = s_in(i,j) / 1.80655 - logf_of_s = log(1.0 - 0.001005 * s_in(i,j)) -! -! k0 from Weiss 1974 -! - - k0 = exp(93.4517/tk100 - 60.2409 + 23.3585 * log(tk100) + & - s_in(i,j) * (0.023517 - 0.023656 * tk100 + & - 0.0047036 * tk1002)) -! -! k1 = [H][HCO3]/[H2CO3] -! k2 = [H][CO3]/[HCO3] -! -! Millero p.664 (1995) using Mehrbach et al. data on seawater scale -! - - k1 = 10.0**(-(3670.7 * invtk - 62.008 + 9.7944 * dlogtk - & - 0.0118 * s_in(i,j) + 0.000116 * s2)) - k2 = 10.0**(-(1394.7 * invtk + 4.777 - & - 0.0184 * s_in(i,j) + 0.000118 * s2)) -! -! kb = [H][BO2]/[HBO2] -! -! Millero p.669 (1995) using data from Dickson (1990) -! - - kb = exp((-8966.90 - 2890.53 * sqrts - 77.942 * s_in(i,j) + & - 1.728 * sqrts**3 - 0.0996 * s2) * invtk + (148.0248 + & - 137.1942 * sqrts + 1.62142 * s_in(i,j)) + (-24.4344 - & - 25.085 * sqrts - 0.2474 * s_in(i,j)) * dlogtk + & - 0.053105 * sqrts * tk) -! -! k1p = [H][H2PO4]/[H3PO4] -! -! DOE(1994) eq 7.2.20 with footnote using data from Millero (1974) -! - - k1p = exp(-4576.752 * invtk + 115.525 - 18.453 * dlogtk + & - (-106.736 * invtk + 0.69171) * sqrts + (-0.65643 * & - invtk - 0.01844) * s_in(i,j)) -! -! k2p = [H][HPO4]/[H2PO4] -! -! DOE(1994) eq 7.2.23 with footnote using data from Millero (1974)) -! - - k2p = exp(-8814.715 * invtk + 172.0883 - 27.927 * (-160.340 * & - invtk + 1.3566) * sqrts + (0.37335 * invtk - & - 0.05778) * s_in(i,j)) -! -!----------------------------------------------------------------------- -! k3p = [H][PO4]/[HPO4] -! -! DOE(1994) eq 7.2.26 with footnote using data from Millero (1974) -! - - k3p = exp(-3070.75 * invtk - 18.141 +(17.27039 * invtk + & - 2.81197) * sqrts + (-44.99486 * invtk - 0.09984) * & - s_in(i,j)) -! -!----------------------------------------------------------------------- -! ksi = [H][SiO(OH)3]/[Si(OH)4] -! -! Millero p.671 (1995) using data from Yao and Millero (1995) -! - ksi = exp(-8904.2 * invtk + 117.385 - 19.334 * dlogtk + & - (-458.79 * invtk + 3.5913) * sqrtis + (188.74 * & - invtk - 1.5998) * is + (-12.1652 * invtk + 0.07871) * & - is2 + logf_of_s) -! -!----------------------------------------------------------------------- -! kw = [H][OH] -! -! Millero p.670 (1995) using composite data -! - - kw = exp(-13847.26 * invtk + 148.9652 - 23.6521 * dlogtk + & - (118.67 * invtk - 5.977 + 1.0495 * dlogtk) * sqrts - & - 0.01615 * s_in(i,j)) -! -!----------------------------------------------------------------------- -! ks = [H][SO4]/[HSO4] -! -! Dickson (1990, J. chem. Thermodynamics 22, 113) -! - ks = exp(-4276.1 * invtk + 141.328 - 23.093 * dlogtk + & - (-13856.0 * invtk + 324.57 - 47.986 * dlogtk) * & - sqrtis + (35474.0 * invtk - 771.54 + 114.723 * & - dlogtk) * is - 2698.0 * invtk * sqrtis**3 + & - 1776.0 * invtk * is2 + logf_of_s) -! -!----------------------------------------------------------------------- -! kf = [H][F]/[HF] -! -! Dickson and Riley (1979) -- change pH scale to total -! - kf = exp(1590.2 * invtk - 12.641 + 1.525 * sqrtis + logf_of_s + & - log(1.0 + (0.1400 / 96.062) * scl / ks)) -! -!----------------------------------------------------------------------- -! Calculate concentrations for borate, sulfate, and fluoride -! -! Uppstrom (1974) -! - bt = 0.000232 / 10.811 * scl -! -! Morris & Riley (1966) -! - st = 0.14 / 96.062 * scl -! -! Riley (1965) -! - ft = 0.000067 / 18.9984 * scl -! -!*********************************************************************** -! -! Calculate [H+] total when DIC and TA are known at T, S and 1 atm. -! The solution converges to err of xacc. The solution must be within -! the range x1 to x2. -! -! If DIC and TA are known then either a root finding or iterative method -! must be used to calculate htotal. In this case we use the -! Newton-Raphson "safe" method taken from "Numerical Recipes" -! (function "rtsafe.f" with error trapping removed). -! -! As currently set, this procedure iterates about 12 times. The x1 -! and x2 values set below will accomodate ANY oceanographic values. -! If an initial guess of the pH is known, then the number of -! iterations can be reduced to about 5 by narrowing the gap between -! x1 and x2. It is recommended that the first few time steps be run -! with x1 and x2 set as below. After that, set x1 and x2 to the -! previous value of the pH +/- ~0.5. The current setting of xacc will -! result in co2star accurate to 3 significant figures (xx.y). Making -! xacc bigger will result in faster convergence also, but this is not -! recommended (xacc of 10**-9 drops precision to 2 significant -! figures). -! - if (mask(i,j) .ne. 0.0) then !{ - htotal(i,j) = drtsafe(k0, k1, k2, kb, k1p, k2p, k3p, ksi, kw, & - ks, kf, bt, dic_in(i,j), ft, pt_in(i,j),& - sit_in(i,j), st, ta_in(i,j), & - htotalhi(i,j), htotallo(i,j), xacc) - endif -! -! Calculate [CO2*] as defined in DOE Methods Handbook 1994 Ver.2, -! ORNL/CDIAC-74, Dickson and Goyet, eds. (Ch 2 p 10, Eq A.49) -! - htotal2 = htotal(i,j) * htotal(i,j) - co2star_internal = dic_in(i,j) * htotal2 / (htotal2 + & - k1 * htotal(i,j) + k1 * k2) - if (present(co2star)) co2star(i,j) = co2star_internal - if (present(co3_ion)) co3_ion(i,j) = co2star_internal * k1 * k2 / htotal2 -! -! Weiss & Price (1980, Mar. Chem., 8, 347-359; Eq 13 with table 6 -! values) -! - if (present(alpha) .or. present(pCO2surf)) then - alpha_internal = exp(-162.8301 + 218.2968 / tk100 + 90.9241 * & - (dlogtk -log100) - 1.47696 * tk1002 + & - s_in(i,j) * (0.025695 - 0.025225 * tk100 + & - 0.0049867 * tk1002)) - endif - if (present(alpha)) alpha(i,j) = alpha_internal - if (present(pCO2surf)) then - pCO2surf(i,j) = co2star_internal / (alpha_internal * permeg) - endif - enddo !} i - enddo !} j - -return - -end subroutine MOM_ocmip2_co2calc !} -! NAME="MOM_ocmip2_co2calc" - - -!####################################################################### -! -! -! -! File taken from Numerical Recipes. Modified R. M. Key 4/94 -! - -function drtsafe(k0, k1, k2, kb, k1p, k2p, k3p, ksi, kw, ks, kf, & - bt, dic, ft, pt, sit, st, ta, x1, x2, xacc) !{ - -implicit none - -! -! arguments -! - -real :: k0, k1, k2, kb, k1p, k2p, k3p, ksi, kw, ks, kf -real :: bt, dic, ft, pt, sit, st, ta -real :: drtsafe -real :: x1, x2, xacc - -! -! local parameters -! - -integer, parameter :: maxit = 100 - -! -! local variables -! - -integer :: j -real :: fl, df, fh, swap, xl, xh, dxold, dx, f, temp - -call ta_iter_1(k0, k1, k2, kb, k1p, k2p, k3p, ksi, kw, ks, kf, & - bt, dic, ft, pt, sit, st, ta, x1, fl, df) -call ta_iter_1(k0, k1, k2, kb, k1p, k2p, k3p, ksi, kw, ks, kf, & - bt, dic, ft, pt, sit, st, ta, x2, fh, df) -if(fl .lt. 0.0) then - xl=x1 - xh=x2 -else - xh=x1 - xl=x2 - swap=fl - fl=fh - fh=swap -end if -drtsafe=0.5*(x1+x2) -dxold=abs(x2-x1) -dx=dxold -call ta_iter_1(k0, k1, k2, kb, k1p, k2p, k3p, ksi, kw, ks, kf, & - bt, dic, ft, pt, sit, st, ta, drtsafe, f, df) -do j=1,maxit !{ - if (((drtsafe-xh)*df-f)*((drtsafe-xl)*df-f) .ge. 0.0 .or. & - abs(2.0*f) .gt. abs(dxold*df)) then - dxold=dx - dx=0.5*(xh-xl) - drtsafe=xl+dx - if (xl .eq. drtsafe) then -! write (6,*) 'Exiting drtsafe at A on iteration ', j, ', ph = ', -log10(drtsafe) - return - endif - else - dxold=dx - dx=f/df - temp=drtsafe - drtsafe=drtsafe-dx - if (temp .eq. drtsafe) then -! write (6,*) 'Exiting drtsafe at B on iteration ', j, ', ph = ', -log10(drtsafe) - return - endif - end if - if (abs(dx) .lt. xacc) then -! write (6,*) 'Exiting drtsafe at C on iteration ', j, ', ph = ', -log10(drtsafe) - return - endif - call ta_iter_1(k0, k1, k2, kb, k1p, k2p, k3p, ksi, kw, ks, kf, & - bt, dic, ft, pt, sit, st, ta, drtsafe, f, df) - if(f .lt. 0.0) then - xl=drtsafe - fl=f - else - xh=drtsafe - fh=f - end if -enddo !} j - -return - -end function drtsafe !} -! NAME="drtsafe" - - -!####################################################################### -! -! -! -! This routine expresses TA as a function of DIC, htotal and constants. -! It also calculates the derivative of this function with respect to -! htotal. It is used in the iterative solution for htotal. In the call -! "x" is the input value for htotal, "fn" is the calculated value for TA -! and "df" is the value for dTA/dhtotal -! - -subroutine ta_iter_1(k0, k1, k2, kb, k1p, k2p, k3p, ksi, kw, ks, kf, & - bt, dic, ft, pt, sit, st, ta, x, fn, df) !{ - -implicit none - -! -! arguments -! - -real :: k0, k1, k2, kb, k1p, k2p, k3p, ksi, kw, ks, kf -real :: bt, dic, ft, pt, sit, st, ta, x, fn, df - -! -! local variables -! - -real :: x2, x3, k12, k12p, k123p, c, a, a2, da, b, b2, db - -x2 = x*x -x3 = x2*x -k12 = k1*k2 -k12p = k1p*k2p -k123p = k12p*k3p -c = 1.0 + st/ks -a = x3 + k1p*x2 + k12p*x + k123p -a2 = a*a -da = 3.0*x2 + 2.0*k1p*x + k12p -b = x2 + k1*x + k12 -b2 = b*b -db = 2.0*x + k1 -! -! fn = hco3+co3+borate+oh+hpo4+2*po4+silicate+hfree+hso4+hf+h3po4-ta -! -fn = k1*x*dic/b + 2.0*dic*k12/b + bt/ (1.0 + x/kb) + kw/x + & - pt*k12p*x/a + 2.0*pt*k123p/a + sit/(1.0 + x/ksi) - & - x/c - st/(1.0 + ks/x/c) - ft/(1.0 + kf/x) - pt*x3/a - ta -! -! df = dfn/dx -! -df = ((k1*dic*b) - k1*x*dic*db)/b2 - 2.0*dic*k12*db/b2 - & - bt/kb/(1.0+x/kb)**2 - kw/x2 + (pt*k12p*(a - x*da))/a2 - & - 2.0*pt*k123p*da/a2 - sit/ksi/ (1.0+x/ksi)**2 - 1.0/c + & - st*(1.0 + ks/x/c)**(-2)*(ks/c/x2) + & - ft*(1.0 + kf/x)**(-2)*kf/x2 - pt*x2*(3.0*a-x*da)/a2 - -return - -end subroutine ta_iter_1 !} -! NAME="ta_iter_1" - -end module MOM_ocmip2_co2calc_mod !} diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index 34f83ccba6..93f72b239d 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -35,11 +35,12 @@ module MOM_generic_tracer use MOM_spatial_means, only : global_area_mean use MOM_sponge, only : set_up_sponge_field, sponge_CS use MOM_ALE_sponge, only : set_up_ALE_sponge_field, ALE_sponge_CS - use MOM_time_manager, only : time_type, get_time, set_time + use MOM_time_manager, only : time_type, set_time use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_tracer_Z_init, only : tracer_Z_init use MOM_tracer_initialization_from_Z, only : MOM_initialize_tracer_from_Z + use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface, thermo_var_ptrs use MOM_open_boundary, only : ocean_OBC_type use MOM_verticalGrid, only : verticalGrid_type @@ -66,8 +67,8 @@ module MOM_generic_tracer ! initialization code if they are not found in the ! restart files. - type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the - ! timing of diagnostic output. + type(diag_ctrl), pointer :: diag => NULL() ! A structure that is used to + ! regulate the timing of diagnostic output. type(MOM_restart_CS), pointer :: restart_CSp => NULL() ! The following pointer will be directed to the first element of the @@ -178,7 +179,7 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) !Get the tracer list call generic_tracer_get_list(CS%g_tracer_list) - if(.NOT. associated(CS%g_tracer_list)) call mpp_error(FATAL, trim(sub_name)//& + 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 T_prog index and get its fields @@ -205,7 +206,7 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) !traverse the linked list till hit NULL call g_tracer_get_next(g_tracer, g_tracer_next) - if(.NOT. associated(g_tracer_next)) exit + if (.NOT. associated(g_tracer_next)) exit g_tracer=>g_tracer_next enddo @@ -222,24 +223,25 @@ 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, h, param_file, diag, OBC, CS, & + 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) 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. 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(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(diag_ctrl), target, intent(in) :: diag !< Regulates diagnostic output. type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies whether, !! where, and what open boundary conditions are used. type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. - type(sponge_CS), pointer :: sponge_CSp !< Pointer to the control structure for the sponges. + 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. + !! 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 @@ -260,13 +262,13 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, h, param_file, dia CS%diag=>diag !Get the tracer list - if(.NOT. associated(CS%g_tracer_list)) call mpp_error(FATAL, trim(sub_name)//& + 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 - if(INDEX(CS%IC_file, '_NULL_') .ne. 0) then + if (INDEX(CS%IC_file, '_NULL_') /= 0) then call MOM_error(WARNING,"The name of the IC_file "//trim(CS%IC_file)//& " indicates no MOM initialization was asked for the generic tracers."//& "Bypassing the MOM initialization of ALL generic tracers!") @@ -279,12 +281,12 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, h, param_file, dia if (.not.restart .or. (CS%tracers_may_reinit .and. & .not.query_initialized(tr_ptr, g_tracer_name, CS%restart_CSp))) then - if(g_tracer%requires_src_info ) then + if (g_tracer%requires_src_info ) then call MOM_error(NOTE,"initialize_MOM_generic_tracer: "//& "initializing generic tracer "//trim(g_tracer_name)//& " using MOM_initialize_tracer_from_Z ") - call MOM_initialize_tracer_from_Z(h, tr_ptr, G, GV, param_file, & + call MOM_initialize_tracer_from_Z(h, tr_ptr, G, GV, US, param_file, & src_file = g_tracer%src_file, & src_var_nam = g_tracer%src_var_name, & src_var_unit_conversion = g_tracer%src_var_unit_conversion,& @@ -293,22 +295,25 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, h, param_file, dia !Check/apply the bounds for each g_tracer do k=1,nk ; do j=jsc,jec ; do i=isc,iec - if(tr_ptr(i,j,k) .ne. CS%tracer_land_val) then - if(tr_ptr(i,j,k) .lt. g_tracer%src_var_valid_min) tr_ptr(i,j,k) = g_tracer%src_var_valid_min + if (tr_ptr(i,j,k) /= CS%tracer_land_val) then + if (tr_ptr(i,j,k) < g_tracer%src_var_valid_min) tr_ptr(i,j,k) = g_tracer%src_var_valid_min !Jasmin does not want to apply the maximum for now - !if(tr_ptr(i,j,k) .gt. g_tracer%src_var_valid_max) tr_ptr(i,j,k) = g_tracer%src_var_valid_max + !if (tr_ptr(i,j,k) > g_tracer%src_var_valid_max) tr_ptr(i,j,k) = g_tracer%src_var_valid_max endif - enddo; enddo ; enddo + enddo ; enddo ; enddo !jgj: Reset CASED to 0 below K=1 - if(trim(g_tracer_name) .eq. 'cased') then + if (trim(g_tracer_name) == 'cased') then do k=2,nk ; do j=jsc,jec ; do i=isc,iec - if(tr_ptr(i,j,k) .ne. CS%tracer_land_val) then + if (tr_ptr(i,j,k) /= CS%tracer_land_val) then tr_ptr(i,j,k) = 0.0 endif - enddo; enddo ; enddo + enddo ; enddo ; enddo endif - + elseif(.not. g_tracer%requires_restart) then + !Do nothing for this tracer, it is initialized by the tracer package + call MOM_error(NOTE,"initialize_MOM_generic_tracer: "//& + "skip initialization of generic tracer "//trim(g_tracer_name)) else !Do it old way if the tracer is not registered to start from a specific source file. !This path should be deprecated if all generic tracers are required to start from specified sources. if (len_trim(CS%IC_file) > 0) then @@ -316,9 +321,9 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, h, param_file, dia if (.not.file_exists(CS%IC_file)) call MOM_error(FATAL, & "initialize_MOM_Generic_tracer: Unable to open "//CS%IC_file) if (CS%Z_IC_file) then - OK = tracer_Z_init(tr_ptr, h, CS%IC_file, g_tracer_name, G) + OK = tracer_Z_init(tr_ptr, h, CS%IC_file, g_tracer_name, G, US) if (.not.OK) then - OK = tracer_Z_init(tr_ptr, h, CS%IC_file, trim(g_tracer_name), G) + OK = tracer_Z_init(tr_ptr, h, CS%IC_file, trim(g_tracer_name), G, US) if (.not.OK) call MOM_error(FATAL,"initialize_MOM_Generic_tracer: "//& "Unable to read "//trim(g_tracer_name)//" from "//& trim(CS%IC_file)//".") @@ -335,7 +340,8 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, h, param_file, dia endif else call MOM_error(FATAL,"initialize_MOM_generic_tracer: "//& - "check Generic Tracer IC filename "//trim(CS%IC_file)//".") + "check Generic Tracer IC filename "//trim(CS%IC_file)//& + " for tracer "//trim(g_tracer_name)) endif endif @@ -343,7 +349,7 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, h, param_file, dia !traverse the linked list till hit NULL call g_tracer_get_next(g_tracer, g_tracer_next) - if(.NOT. associated(g_tracer_next)) exit + if (.NOT. associated(g_tracer_next)) exit g_tracer=>g_tracer_next enddo !! end section to re-initialize generic tracers @@ -355,7 +361,7 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, h, param_file, dia grid_tmask(:,:,:) = 0.0 grid_kmt(:,:) = 0 do j = G%jsd, G%jed ; do i = G%isd, G%ied - if (G%mask2dT(i,j) .gt. 0) then + if (G%mask2dT(i,j) > 0) then grid_tmask(i,j,:) = 1.0 grid_kmt(i,j) = G%ke ! Tell the code that a layer thicker than 1m is the bottom layer. endif @@ -376,7 +382,7 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, h, param_file, dia ! Register Z diagnostic output. !Get the tracer list - if(.NOT. associated(CS%g_tracer_list)) call mpp_error(FATAL, trim(sub_name)//& + 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 @@ -393,7 +399,7 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, h, param_file, dia !traverse the linked list till hit NULL call g_tracer_get_next(g_tracer, g_tracer_next) - if(.NOT. associated(g_tracer_next)) exit + if (.NOT. associated(g_tracer_next)) exit g_tracer=>g_tracer_next enddo @@ -401,16 +407,16 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, h, param_file, dia !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 + if (associated(CS%g_diag_list)) then g_diag=>CS%g_diag_list do - if(g_diag%Z_diag .ne. 0) & + 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 + if (.NOT. associated(g_diag)) exit enddo endif @@ -431,32 +437,33 @@ end subroutine initialize_MOM_generic_tracer !! flux as a source. subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, CS, tv, optics, & 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, - !! in m or kg !m-2. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_new !< Layer thickness after entrainment, - !! in 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, in 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, in m or kg !m-2. - type(forcing), intent(in) :: fluxes - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Hml !< Mixed layer depth - real, intent(in) :: dt !< The amount of time covered by this call, in s - type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. - type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables - type(optics_type), intent(in) :: optics - real, optional,intent(in) :: evap_CFL_limit !< Limits how much water can be fluxed out of - !! the top layer Stored previously in diabatic CS. - real, optional,intent(in) :: minimum_forcing_depth !< The smallest depth over which fluxes - !! can be applied Stored previously in diabatic 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 + 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 !< The amount of fluid entrained from the layer + !! above during this call [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: eb !< The amount of fluid entrained from the layer + !! below during this call [H ~> m or kg m-2]. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic + !! and tracer forcing fields. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Hml !< Mixed layer depth [H ~> m or kg m-2] + real, intent(in) :: dt !< The amount of time covered by this call [s] + type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + type(optics_type), intent(in) :: optics !< The structure containing optical properties. + real, optional, intent(in) :: evap_CFL_limit !< Limits how much water can be fluxed out of + !! the top layer Stored previously in diabatic CS. + real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which fluxes + !! can be applied Stored previously in diabatic CS. ! 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] + ! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) -! Local variables + ! Local variables character(len=fm_string_len), parameter :: sub_name = 'MOM_generic_tracer_column_physics' type(g_tracer_type), pointer :: g_tracer, g_tracer_next @@ -473,7 +480,7 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec ; nk = G%ke !Get the tracer list - if(.NOT. associated(CS%g_tracer_list)) call mpp_error(FATAL,& + if (.NOT. associated(CS%g_tracer_list)) call mpp_error(FATAL,& trim(sub_name)//": No tracer in the list.") #ifdef _USE_MOM6_DIAG @@ -493,7 +500,7 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, ! g_tracer=>CS%g_tracer_list do - if(_allocated(g_tracer%trunoff)) then + if (_ALLOCATED(g_tracer%trunoff)) then call g_tracer_get_alias(g_tracer,g_tracer_name) call g_tracer_get_pointer(g_tracer,g_tracer_name,'stf', stf_array) call g_tracer_get_pointer(g_tracer,g_tracer_name,'trunoff',trunoff_array) @@ -505,7 +512,7 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, !traverse the linked list till hit NULL call g_tracer_get_next(g_tracer, g_tracer_next) - if(.NOT. associated(g_tracer_next)) exit + if (.NOT. associated(g_tracer_next)) exit g_tracer=>g_tracer_next enddo @@ -514,15 +521,15 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, !Prepare input arrays for source update ! - rho_dzt(:,:,:) = GV%H_to_kg_m2 * GV%Angstrom + rho_dzt(:,:,:) = GV%H_to_kg_m2 * GV%Angstrom_H do k = 1, nk ; do j = jsc, jec ; do i = isc, iec !{ rho_dzt(i,j,k) = GV%H_to_kg_m2 * h_old(i,j,k) - enddo; enddo ; enddo !} + enddo ; enddo ; enddo !} dzt(:,:,:) = 1.0 do k = 1, nk ; do j = jsc, jec ; do i = isc, iec !{ dzt(i,j,k) = GV%H_to_m * h_old(i,j,k) - enddo; enddo ; enddo !} + enddo ; enddo ; enddo !} do j=jsc,jec ; do i=isc,iec surface_field(i,j) = tv%S(i,j,1) @@ -546,14 +553,14 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, if (g_tracer_is_prog(g_tracer)) then do k=1,nk ;do j=jsc,jec ; do i=isc,iec h_work(i,j,k) = h_old(i,j,k) - enddo ; enddo ; enddo; + enddo ; enddo ; enddo call applyTracerBoundaryFluxesInOut(G, GV, g_tracer%field(:,:,:,1), dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth) endif !traverse the linked list till hit NULL call g_tracer_get_next(g_tracer, g_tracer_next) - if(.NOT. associated(g_tracer_next)) exit + if (.NOT. associated(g_tracer_next)) exit g_tracer=>g_tracer_next enddo endif @@ -564,14 +571,17 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, ! Use a tridiagonal solver to determine the concentrations after the ! surface source is applied and diapycnal advection and diffusion occurs. if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then - call generic_tracer_vertdiff_G(h_work, ea, eb, dt, GV%kg_m2_to_H, GV%m_to_H, 1) !Last arg is tau which is always 1 for MOM + ! Last arg is tau which is always 1 for MOM6 + call generic_tracer_vertdiff_G(h_work, ea, eb, dt, GV%kg_m2_to_H, GV%m_to_H, 1) else - call generic_tracer_vertdiff_G(h_old, ea, eb, dt, GV%kg_m2_to_H, GV%m_to_H, 1) !Last arg is tau which is always 1 for MOM + ! Last arg is tau which is always 1 for MOM6 + call generic_tracer_vertdiff_G(h_old, ea, eb, dt, GV%kg_m2_to_H, GV%m_to_H, 1) endif ! Update bottom fields after vertical processes - call generic_tracer_update_from_bottom(dt, 1, get_diag_time_end(CS%diag)) !Second arg is tau which is always 1 for MOM + ! Second arg is tau which is always 1 for MOM6 + call generic_tracer_update_from_bottom(dt, 1, get_diag_time_end(CS%diag)) !Output diagnostics via diag_manager for all generic tracers and their fluxes call g_tracer_send_diag(CS%g_tracer_list, get_diag_time_end(CS%diag), tau=1) @@ -590,9 +600,9 @@ end subroutine MOM_generic_tracer_column_physics function MOM_generic_tracer_stock(h, stocks, G, GV, CS, names, units, stock_index) 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 !< Layer thicknesses, in H (usually m or kg m-2) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] real, dimension(:), intent(out) :: stocks !< The mass-weighted integrated amount of each - !! tracer, in kg times concentration units. + !! tracer, in kg times concentration units [kg conc]. type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. character(len=*), dimension(:), intent(out) :: names !< The names of the stocks calculated. character(len=*), dimension(:), intent(out) :: units !< The units of the stocks calculated. @@ -620,7 +630,7 @@ function MOM_generic_tracer_stock(h, stocks, G, GV, CS, names, units, stock_inde return endif ; endif - if(.NOT. associated(CS%g_tracer_list)) return ! No stocks. + if (.NOT. associated(CS%g_tracer_list)) return ! No stocks. m=1 ; g_tracer=>CS%g_tracer_list do @@ -639,7 +649,7 @@ function MOM_generic_tracer_stock(h, stocks, G, GV, CS, names, units, stock_inde !traverse the linked list till hit NULL call g_tracer_get_next(g_tracer, g_tracer_next) - if(.NOT. associated(g_tracer_next)) exit + if (.NOT. associated(g_tracer_next)) exit g_tracer=>g_tracer_next m = m+1 enddo @@ -651,21 +661,28 @@ end function MOM_generic_tracer_stock !> This subroutine find the global min and max of either of all !! available tracer concentrations, or of a tracer that is being !! requested specifically, returning the number of tracers it has gone through. - function MOM_generic_tracer_min_max(ind_start, got_minmax, gmin, gmax, xgmin, ygmin, zgmin, xgmax, ygmax, zgmax , G, CS, names, units) + function MOM_generic_tracer_min_max(ind_start, got_minmax, gmin, gmax, xgmin, ygmin, zgmin, & + xgmax, ygmax, zgmax , G, CS, names, units) use mpp_utilities_mod, only: mpp_array_global_min_max - integer, intent(in) :: ind_start - logical, dimension(:), intent(out) :: got_minmax - real, dimension(:), intent(out) :: gmin !< Global minimum of each tracer, in kg - !! times concentration units. - real, dimension(:), intent(out) :: gmax !< Global maximum of each tracer, in kg - !! times concentration units. - real, dimension(:), intent(out) :: xgmin, ygmin, zgmin, xgmax, ygmax, zgmax - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. - character(len=*), dimension(:), intent(out) :: names !< The names of the stocks calculated. - character(len=*), dimension(:), intent(out) :: units !< The units of the stocks calculated. - integer :: MOM_generic_tracer_min_max !< Return value, the - !! number of tracers done here. + integer, intent(in) :: ind_start !< The index of the tracer to start with + logical, dimension(:), intent(out) :: got_minmax !< Indicates whether the global min and + !! max are found for each tracer + real, dimension(:), intent(out) :: gmin !< Global minimum of each tracer, in kg + !! times concentration units. + real, dimension(:), intent(out) :: gmax !< Global maximum of each tracer, in kg + !! times concentration units. + real, dimension(:), intent(out) :: xgmin !< The x-position of the global minimum + real, dimension(:), intent(out) :: ygmin !< The y-position of the global minimum + real, dimension(:), intent(out) :: zgmin !< The z-position of the global minimum + real, dimension(:), intent(out) :: xgmax !< The x-position of the global maximum + real, dimension(:), intent(out) :: ygmax !< The y-position of the global maximum + real, dimension(:), intent(out) :: zgmax !< The z-position of the global maximum + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. + character(len=*), dimension(:), intent(out) :: names !< The names of the stocks calculated. + character(len=*), dimension(:), intent(out) :: units !< The units of the stocks calculated. + integer :: MOM_generic_tracer_min_max !< Return value, the + !! number of tracers done here. ! Local variables type(g_tracer_type), pointer :: g_tracer, g_tracer_next @@ -684,7 +701,7 @@ function MOM_generic_tracer_min_max(ind_start, got_minmax, gmin, gmax, xgmin, yg MOM_generic_tracer_min_max = 0 if (.not.associated(CS)) return - if(.NOT. associated(CS%g_tracer_list)) return ! No stocks. + if (.NOT. associated(CS%g_tracer_list)) return ! No stocks. call g_tracer_get_common(isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau,grid_tmask=grid_tmask) @@ -694,7 +711,6 @@ function MOM_generic_tracer_min_max(ind_start, got_minmax, gmin, gmax, xgmin, yg allocate(geo_z(nk)) do k=1,nk ; geo_z(k) = real(k) ; enddo - m=ind_start ; g_tracer=>CS%g_tracer_list do call g_tracer_get_alias(g_tracer,names(m)) @@ -707,16 +723,15 @@ function MOM_generic_tracer_min_max(ind_start, got_minmax, gmin, gmax, xgmin, yg tr_ptr => tr_field(:,:,:,1) - call mpp_array_global_min_max(tr_ptr, grid_tmask,isd,jsd,isc,iec,jsc,jec,nk , gmin(m), gmax(m), & - G%geoLonT,G%geoLatT,geo_z,xgmin(m), ygmin(m), zgmin(m), xgmax(m), ygmax(m), zgmax(m)) + G%geoLonT,G%geoLatT,geo_z,xgmin(m), ygmin(m), zgmin(m), & + xgmax(m), ygmax(m), zgmax(m)) got_minmax(m) = .true. - !traverse the linked list till hit NULL call g_tracer_get_next(g_tracer, g_tracer_next) - if(.NOT. associated(g_tracer_next)) exit + if (.NOT. associated(g_tracer_next)) exit g_tracer=>g_tracer_next m = m+1 enddo @@ -735,7 +750,7 @@ subroutine MOM_generic_tracer_surface_state(state, h, G, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(surface), intent(inout) :: state !< A structure containing fields that !! describe the surface state of the ocean. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. ! Local variables @@ -763,7 +778,7 @@ subroutine MOM_generic_tracer_surface_state(state, h, G, CS) tau=1,sosga=sosga,model_time=get_diag_time_end(CS%diag)) !Output diagnostics via diag_manager for all tracers in this module -! if(.NOT. associated(CS%g_tracer_list)) call mpp_error(FATAL, trim(sub_name)//& +! if (.NOT. associated(CS%g_tracer_list)) call mpp_error(FATAL, trim(sub_name)//& ! "No tracer in the list.") ! call g_tracer_send_diag(CS%g_tracer_list, get_diag_time_end(CS%diag), tau=1) !Niki: The problem with calling diagnostic outputs here is that this subroutine is called every dt_cpld @@ -775,7 +790,7 @@ end subroutine MOM_generic_tracer_surface_state !ALL PE subroutine on Ocean! Due to otpm design the fluxes should be initialized like this on ALL PE's! subroutine MOM_generic_flux_init(verbosity) - integer, intent(in), optional :: verbosity !< A 0-9 integer indicating a level of verbosity. + integer, optional, intent(in) :: verbosity !< A 0-9 integer indicating a level of verbosity. integer :: ind character(len=fm_string_len) :: g_tracer_name,longname, package,units,old_package,file_in,file_out @@ -789,7 +804,7 @@ subroutine MOM_generic_flux_init(verbosity) endif call generic_tracer_get_list(g_tracer_list) - if(.NOT. associated(g_tracer_list)) then + if (.NOT. associated(g_tracer_list)) then call mpp_error(WARNING, trim(sub_name)// ": No generic tracer in the list.") return endif @@ -801,7 +816,7 @@ subroutine MOM_generic_flux_init(verbosity) !traverse the linked list till hit NULL call g_tracer_get_next(g_tracer, g_tracer_next) - if(.NOT. associated(g_tracer_next)) exit + if (.NOT. associated(g_tracer_next)) exit g_tracer=>g_tracer_next enddo @@ -809,8 +824,9 @@ subroutine MOM_generic_flux_init(verbosity) end subroutine MOM_generic_flux_init subroutine MOM_generic_tracer_fluxes_accumulate(flux_tmp, weight) - type(forcing), intent(in) :: flux_tmp - real, intent(in) :: weight + type(forcing), intent(in) :: flux_tmp !< A structure containing pointers to + !! thermodynamic and tracer forcing fields. + real, intent(in) :: weight !< A weight for accumulating this flux call generic_tracer_coupler_accumulate(flux_tmp%tr_fluxes, weight) @@ -819,7 +835,7 @@ end subroutine MOM_generic_tracer_fluxes_accumulate !> Copy the requested tracer into an array. subroutine MOM_generic_tracer_get(name,member,array, CS) character(len=*), intent(in) :: name !< Name of requested tracer. - character(len=*), intent(in) :: member !< ?? + character(len=*), intent(in) :: member !< The tracer element to return. real, dimension(:,:,:), intent(out) :: array !< Array filled by this routine. type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 5fb99a448b..d5a6f45c5f 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -31,56 +31,60 @@ module MOM_neutral_diffusion #include -public neutral_diffusion -public neutral_diffusion_init -public neutral_diffusion_end +public neutral_diffusion, neutral_diffusion_init, neutral_diffusion_end public neutral_diffusion_calc_coeffs public neutral_diffusion_unit_tests +!> The control structure for the MOM_neutral_diffusion module type, public :: neutral_diffusion_CS ; private - integer :: nkp1 ! Number of interfaces for a column = nk + 1 - integer :: nsurf ! Number of neutral surfaces - integer :: deg = 2 ! Degree of polynomial used for reconstructions - logical :: continuous_reconstruction = .true. ! True if using continuous PPM reconstruction at interfaces - logical :: refine_position = .false. - logical :: debug = .false. - integer :: max_iter ! Maximum number of iterations if refine_position is defined - real :: tolerance ! Convergence criterion representing difference from true neutrality - real :: ref_pres ! Reference pressure, negative if using locally referenced neutral density + integer :: nkp1 !< Number of interfaces for a column = nk + 1 + integer :: nsurf !< Number of neutral surfaces + integer :: deg = 2 !< Degree of polynomial used for reconstructions + logical :: continuous_reconstruction = .true. !< True if using continuous PPM reconstruction at interfaces + logical :: refine_position = .false. !< If true, iterate to refine the corresponding positions + !! in neighboring columns + logical :: debug = .false. !< If true, write verbose debugging messages + integer :: max_iter !< Maximum number of iterations if refine_position is defined + real :: tolerance !< Convergence criterion representing difference from true neutrality + real :: ref_pres !< Reference pressure, negative if using locally referenced neutral density ! Positions of neutral surfaces in both the u, v directions - real, allocatable, dimension(:,:,:) :: uPoL ! Non-dimensional position with left layer uKoL-1, u-point - real, allocatable, dimension(:,:,:) :: uPoR ! Non-dimensional position with right layer uKoR-1, u-point - integer, allocatable, dimension(:,:,:) :: uKoL ! Index of left interface corresponding to neutral surface, u-point - integer, allocatable, dimension(:,:,:) :: uKoR ! Index of right interface corresponding to neutral surface, u-point - real, allocatable, dimension(:,:,:) :: uHeff ! Effective thickness at u-point (H units) - real, allocatable, dimension(:,:,:) :: vPoL ! Non-dimensional position with left layer uKoL-1, v-point - real, allocatable, dimension(:,:,:) :: vPoR ! Non-dimensional position with right layer uKoR-1, v-point - integer, allocatable, dimension(:,:,:) :: vKoL ! Index of left interface corresponding to neutral surface, v-point - integer, allocatable, dimension(:,:,:) :: vKoR ! Index of right interface corresponding to neutral surface, v-point - real, allocatable, dimension(:,:,:) :: vHeff ! Effective thickness at v-point (H units) + real, allocatable, dimension(:,:,:) :: uPoL !< Non-dimensional position with left layer uKoL-1, u-point + real, allocatable, dimension(:,:,:) :: uPoR !< Non-dimensional position with right layer uKoR-1, u-point + integer, allocatable, dimension(:,:,:) :: uKoL !< Index of left interface corresponding to neutral surface, + !! at a u-point + integer, allocatable, dimension(:,:,:) :: uKoR !< Index of right interface corresponding to neutral surface, + !! at a u-point + real, allocatable, dimension(:,:,:) :: uHeff !< Effective thickness at u-point [H ~> m or kg m-2] + real, allocatable, dimension(:,:,:) :: vPoL !< Non-dimensional position with left layer uKoL-1, v-point + real, allocatable, dimension(:,:,:) :: vPoR !< Non-dimensional position with right layer uKoR-1, v-point + integer, allocatable, dimension(:,:,:) :: vKoL !< Index of left interface corresponding to neutral surface, + !! at a v-point + integer, allocatable, dimension(:,:,:) :: vKoR !< Index of right interface corresponding to neutral surface, + !! at a v-point + real, allocatable, dimension(:,:,:) :: vHeff !< Effective thickness at v-point [H ~> m or kg m-2] ! Coefficients of polynomial reconstructions for temperature and salinity real, allocatable, dimension(:,:,:,:) :: ppoly_coeffs_T !< Polynomial coefficients for temperature - real, allocatable, dimension(:,:,:,:) :: ppoly_coeffs_S !< Polynomial coefficients for temperature + real, allocatable, dimension(:,:,:,:) :: ppoly_coeffs_S !< Polynomial coefficients for salinity ! Variables needed for continuous reconstructions - real, allocatable, dimension(:,:,:) :: dRdT ! dRho/dT (kg/m3/degC) at interfaces - real, allocatable, dimension(:,:,:) :: dRdS ! dRho/dS (kg/m3/ppt) at interfaces - real, allocatable, dimension(:,:,:) :: Tint ! Interface T (degC) - real, allocatable, dimension(:,:,:) :: Sint ! Interface S (ppt) - real, allocatable, dimension(:,:,:) :: Pint ! Interface pressure (Pa) + real, allocatable, dimension(:,:,:) :: dRdT !< dRho/dT [kg m-3 degC-1] at interfaces + real, allocatable, dimension(:,:,:) :: dRdS !< dRho/dS [kg m-3 ppt-1] at interfaces + real, allocatable, dimension(:,:,:) :: Tint !< Interface T [degC] + real, allocatable, dimension(:,:,:) :: Sint !< Interface S [ppt] + real, allocatable, dimension(:,:,:) :: Pint !< Interface pressure [Pa] ! Variables needed for discontinuous reconstructions - real, allocatable, dimension(:,:,:,:) :: T_i ! Top edge reconstruction of temperature (degC) - real, allocatable, dimension(:,:,:,:) :: S_i ! Top edge reconstruction of salinity (ppt) - real, allocatable, dimension(:,:,:,:) :: dRdT_i ! dRho/dT (kg/m3/degC) at top edge - real, allocatable, dimension(:,:,:,:) :: dRdS_i ! dRho/dS (kg/m3/ppt) at top edge - integer, allocatable, dimension(:,:) :: ns ! Number of interfacs in a column - logical, allocatable, dimension(:,:,:) :: stable_cell ! True if the cell is stably stratified wrt to the next cell - - type(diag_ctrl), pointer :: diag ! structure to regulate output - integer :: id_uhEff_2d = -1 - integer :: id_vhEff_2d = -1 - - real :: C_p ! heat capacity of seawater (J kg-1 K-1) + real, allocatable, dimension(:,:,:,:) :: T_i !< Top edge reconstruction of temperature [degC] + real, allocatable, dimension(:,:,:,:) :: S_i !< Top edge reconstruction of salinity [ppt] + real, allocatable, dimension(:,:,:,:) :: dRdT_i !< dRho/dT [kg m-3 degC-1] at top edge + real, allocatable, dimension(:,:,:,:) :: dRdS_i !< dRho/dS [kg m-3 ppt-1] at top edge + integer, allocatable, dimension(:,:) :: ns !< Number of interfacs in a column + logical, allocatable, dimension(:,:,:) :: stable_cell !< True if the cell is stably stratified wrt to the next cell + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + integer :: id_uhEff_2d = -1 !< Diagnostic IDs + integer :: id_vhEff_2d = -1 !< Diagnostic IDs + + real :: C_p !< heat capacity of seawater (J kg-1 K-1) type(EOS_type), pointer :: EOS !< Equation of state parameters type(remapping_CS) :: remap_CS !< Remapping control structure used to create sublayers type(ndiff_aux_CS_type), pointer :: ndiff_aux_CS !< Store parameters for iteratively finding neutral surface @@ -88,7 +92,7 @@ module MOM_neutral_diffusion ! This include declares and sets the variable "version". #include "version_variable.h" -character(len=40) :: mdl = "MOM_neutral_diffusion" ! module name +character(len=40) :: mdl = "MOM_neutral_diffusion" !< module name contains @@ -229,9 +233,9 @@ end function neutral_diffusion_init subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, CS) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness (H units) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: T !< Potential temperature (degC) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: S !< Salinity (ppt) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: T !< Potential temperature [degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: S !< Salinity [ppt] type(neutral_diffusion_CS), pointer :: CS !< Neutral diffusion control structure ! Local variables @@ -372,9 +376,10 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, CS) endif enddo ; enddo - ! Continuous reconstructions calculate hEff as the difference between the pressures of the neutral surfaces which - ! need to be reconverted to thickness units. The discontinuous version calculates hEff from the fraction of the - ! nondimensional fraction of the layer occupied by the + ! Continuous reconstructions calculate hEff as the difference between the pressures of the + ! neutral surfaces which need to be reconverted to thickness units. The discontinuous version + ! calculates hEff from the fraction of the nondimensional fraction of the layer occupied by + ! the... (Please finish this thought. -RWH) if (CS%continuous_reconstruction) then do k = 1, CS%nsurf-1 ; do j = G%jsc, G%jec ; do I = G%isc-1, G%iec if (G%mask2dCu(I,j) > 0.) CS%uhEff(I,j,k) = CS%uhEff(I,j,k) * pa_to_H @@ -388,14 +393,14 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, CS) hEff_sum(:,:) = 0. do k = 1,CS%nsurf-1 ; do j=G%jsc,G%jec ; do i=G%isc-1,G%iec hEff_sum(i,j) = hEff_sum(i,j) + CS%uhEff(i,j,k) - enddo ; enddo; enddo + enddo ; enddo ; enddo call post_data(CS%id_uhEff_2d, hEff_sum, CS%diag) endif if (CS%id_vhEff_2d>0) then hEff_sum(:,:) = 0. do k = 1,CS%nsurf-1 ; do j=G%jsc-1,G%jec ; do i=G%isc,G%iec hEff_sum(i,j) = hEff_sum(i,j) + CS%vhEff(i,j,k) - enddo ; enddo; enddo + enddo ; enddo ; enddo call post_data(CS%id_vhEff_2d, hEff_sum, CS%diag) endif @@ -405,16 +410,18 @@ end subroutine neutral_diffusion_calc_coeffs subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, CS) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness (H units) - real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: Coef_x !< dt * Kh * dy / dx at u-points (m^2) - real, dimension(SZI_(G),SZJB_(G)), intent(in) :: Coef_y !< dt * Kh * dx / dy at u-points (m^2) - real, intent(in) :: dt !< Tracer time step * I_numitts (I_numitts in tracer_hordiff) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: Coef_x !< dt * Kh * dy / dx at u-points [m2] + real, dimension(SZI_(G),SZJB_(G)), intent(in) :: Coef_y !< dt * Kh * dx / dy at v-points [m2] + real, intent(in) :: dt !< Tracer time step * I_numitts + !! (I_numitts in tracer_hordiff) type(tracer_registry_type), pointer :: Reg !< Tracer registry type(neutral_diffusion_CS), pointer :: CS !< Neutral diffusion control structure ! Local variables - real, dimension(SZIB_(G),SZJ_(G),CS%nsurf-1) :: uFlx ! Zonal flux of tracer (concentration * H) - real, dimension(SZI_(G),SZJB_(G),CS%nsurf-1) :: vFlx ! Meridional flux of tracer (concentration * H) + real, dimension(SZIB_(G),SZJ_(G),CS%nsurf-1) :: uFlx ! Zonal flux of tracer [H conc ~> m conc or conc kg m-2] + real, dimension(SZI_(G),SZJB_(G),CS%nsurf-1) :: vFlx ! Meridional flux of tracer + ! [H conc ~> m conc or conc kg m-2] real, dimension(SZI_(G),SZJ_(G),G%ke) :: tendency ! tendency array for diagn real, dimension(SZI_(G),SZJ_(G)) :: tendency_2d ! depth integrated content tendency for diagn real, dimension(SZIB_(G),SZJ_(G)) :: trans_x_2d ! depth integrated diffusive tracer x-transport diagn @@ -438,7 +445,7 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, CS) tracer => Reg%Tr(m) ! for diagnostics - if(tracer%id_dfxy_conc > 0 .or. tracer%id_dfxy_cont > 0 .or. tracer%id_dfxy_cont_2d > 0 .or. & + if (tracer%id_dfxy_conc > 0 .or. tracer%id_dfxy_cont > 0 .or. tracer%id_dfxy_cont_2d > 0 .or. & tracer%id_dfx_2d > 0 .or. tracer%id_dfy_2d > 0) then Idt = 1.0/dt tendency(:,:,:) = 0.0 @@ -476,7 +483,7 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, CS) if (G%mask2dT(i,j)>0.) then dTracer(:) = 0. - do ks = 1,CS%nsurf-1 ; + do ks = 1,CS%nsurf-1 k = CS%uKoL(I,j,ks) dTracer(k) = dTracer(k) + Coef_x(I,j) * uFlx(I,j,ks) k = CS%uKoR(I-1,j,ks) @@ -491,7 +498,7 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, CS) ( G%IareaT(i,j) / ( h(i,j,k) + GV%H_subroundoff ) ) enddo - if(tracer%id_dfxy_conc > 0 .or. tracer%id_dfxy_cont > 0 .or. tracer%id_dfxy_cont_2d > 0 ) then + if (tracer%id_dfxy_conc > 0 .or. tracer%id_dfxy_cont > 0 .or. tracer%id_dfxy_cont_2d > 0 ) then do k = 1, GV%ke tendency(i,j,k) = dTracer(k) * G%IareaT(i,j) * Idt enddo @@ -502,11 +509,11 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, CS) ! Diagnose vertically summed zonal flux, giving zonal tracer transport from ndiff. ! Note sign corresponds to downgradient flux convention. - if(tracer%id_dfx_2d > 0) then + if (tracer%id_dfx_2d > 0) then do j = G%jsc,G%jec ; do I = G%isc-1,G%iec trans_x_2d(I,j) = 0. if (G%mask2dCu(I,j)>0.) then - do ks = 1,CS%nsurf-1 ; + do ks = 1,CS%nsurf-1 trans_x_2d(I,j) = trans_x_2d(I,j) - Coef_x(I,j) * uFlx(I,j,ks) enddo trans_x_2d(I,j) = trans_x_2d(I,j) * Idt @@ -517,11 +524,11 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, CS) ! Diagnose vertically summed merid flux, giving meridional tracer transport from ndiff. ! Note sign corresponds to downgradient flux convention. - if(tracer%id_dfy_2d > 0) then + if (tracer%id_dfy_2d > 0) then do J = G%jsc-1,G%jec ; do i = G%isc,G%iec trans_y_2d(i,J) = 0. if (G%mask2dCv(i,J)>0.) then - do ks = 1,CS%nsurf-1 ; + do ks = 1,CS%nsurf-1 trans_y_2d(i,J) = trans_y_2d(i,J) - Coef_y(i,J) * vFlx(i,J,ks) enddo trans_y_2d(i,J) = trans_y_2d(i,J) * Idt @@ -531,12 +538,12 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, CS) endif ! post tendency of tracer content - if(tracer%id_dfxy_cont > 0) then + if (tracer%id_dfxy_cont > 0) then call post_data(tracer%id_dfxy_cont, tendency(:,:,:), CS%diag) endif ! post depth summed tendency for tracer content - if(tracer%id_dfxy_cont_2d > 0) then + if (tracer%id_dfxy_cont_2d > 0) then tendency_2d(:,:) = 0. do j = G%jsc,G%jec ; do i = G%isc,G%iec do k = 1, GV%ke @@ -549,7 +556,7 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, CS) ! post tendency of tracer concentration; this step must be ! done after posting tracer content tendency, since we alter ! the tendency array. - if(tracer%id_dfxy_conc > 0) then + if (tracer%id_dfxy_conc > 0) then do k = 1, GV%ke ; do j = G%jsc,G%jec ; do i = G%isc,G%iec tendency(i,j,k) = tendency(i,j,k) / ( h(i,j,k) + GV%H_subroundoff ) enddo ; enddo ; enddo @@ -562,12 +569,12 @@ end subroutine neutral_diffusion !> Returns interface scalar, Si, for a column of layer values, S. subroutine interface_scalar(nk, h, S, Si, i_method, h_neglect) integer, intent(in) :: nk !< Number of levels - real, dimension(nk), intent(in) :: h !< Layer thickness (H units) + real, dimension(nk), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] real, dimension(nk), intent(in) :: S !< Layer scalar (conc, e.g. ppt) real, dimension(nk+1), intent(inout) :: Si !< Interface scalar (conc, e.g. ppt) integer, intent(in) :: i_method !< =1 use average of PLM edges !! =2 use continuous PPM edge interpolation - real, intent(in) :: h_neglect !< A negligibly small thickness (H units) + real, intent(in) :: h_neglect !< A negligibly small thickness [H ~> m or kg m-2] ! Local variables integer :: k, km2, kp1 real, dimension(nk) :: diff @@ -607,7 +614,7 @@ real function ppm_edge(hkm1, hk, hkp1, hkp2, Ak, Akp1, Pk, Pkp1, h_neglect) real, intent(in) :: Akp1 !< Average scalar value of cell k+1 real, intent(in) :: Pk !< PLM slope for cell k real, intent(in) :: Pkp1 !< PLM slope for cell k+1 - real, intent(in) :: h_neglect !< A negligibly small thickness (H units) + real, intent(in) :: h_neglect !< A negligibly small thickness [H ~> m or kg m-2] ! Local variables real :: R_hk_hkp1, R_2hk_hkp1, R_hk_2hkp1, f1, f2, f3, f4 @@ -678,7 +685,7 @@ end function signum !! The limiting follows equation 1.8 in Colella & Woodward, 1984: JCP 54, 174-201. subroutine PLM_diff(nk, h, S, c_method, b_method, diff) integer, intent(in) :: nk !< Number of levels - real, dimension(nk), intent(in) :: h !< Layer thickness (H units) + real, dimension(nk), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] real, dimension(nk), intent(in) :: S !< Layer salinity (conc, e.g. ppt) integer, intent(in) :: c_method !< Method to use for the centered difference integer, intent(in) :: b_method !< =1, use PCM in first/last cell, =2 uses linear extrapolation @@ -799,24 +806,26 @@ end function fvlsq_slope !> Returns positions within left/right columns of combined interfaces using continuous reconstructions of T/S -subroutine find_neutral_surface_positions_continuous(nk, Pl, Tl, Sl, dRdTl, dRdSl, Pr, Tr, Sr, dRdTr, dRdSr, PoL, & - PoR, KoL, KoR, hEff) +subroutine find_neutral_surface_positions_continuous(nk, Pl, Tl, Sl, dRdTl, dRdSl, Pr, Tr, Sr, & + dRdTr, dRdSr, PoL, PoR, KoL, KoR, hEff) integer, intent(in) :: nk !< Number of levels - real, dimension(nk+1), intent(in) :: Pl !< Left-column interface pressure (Pa) - real, dimension(nk+1), intent(in) :: Tl !< Left-column interface potential temperature (degC) - real, dimension(nk+1), intent(in) :: Sl !< Left-column interface salinity (ppt) - real, dimension(nk+1), intent(in) :: dRdTl !< Left-column dRho/dT (kg/m3/degC) - real, dimension(nk+1), intent(in) :: dRdSl !< Left-column dRho/dS (kg/m3/ppt) - real, dimension(nk+1), intent(in) :: Pr !< Right-column interface pressure (Pa) - real, dimension(nk+1), intent(in) :: Tr !< Right-column interface potential temperature (degC) - real, dimension(nk+1), intent(in) :: Sr !< Right-column interface salinity (ppt) - real, dimension(nk+1), intent(in) :: dRdTr !< Left-column dRho/dT (kg/m3/degC) - real, dimension(nk+1), intent(in) :: dRdSr !< Left-column dRho/dS (kg/m3/ppt) - real, dimension(2*nk+2), intent(inout) :: PoL !< Fractional position of neutral surface within layer KoL of left column - real, dimension(2*nk+2), intent(inout) :: PoR !< Fractional position of neutral surface within layer KoR of right column + real, dimension(nk+1), intent(in) :: Pl !< Left-column interface pressure [Pa] + real, dimension(nk+1), intent(in) :: Tl !< Left-column interface potential temperature [degC] + real, dimension(nk+1), intent(in) :: Sl !< Left-column interface salinity [ppt] + real, dimension(nk+1), intent(in) :: dRdTl !< Left-column dRho/dT [kg m-3 degC-1] + real, dimension(nk+1), intent(in) :: dRdSl !< Left-column dRho/dS [kg m-3 ppt-1] + real, dimension(nk+1), intent(in) :: Pr !< Right-column interface pressure [Pa] + real, dimension(nk+1), intent(in) :: Tr !< Right-column interface potential temperature [degC] + real, dimension(nk+1), intent(in) :: Sr !< Right-column interface salinity [ppt] + real, dimension(nk+1), intent(in) :: dRdTr !< Left-column dRho/dT [kg m-3 degC-1] + real, dimension(nk+1), intent(in) :: dRdSr !< Left-column dRho/dS [kg m-3 ppt-1] + real, dimension(2*nk+2), intent(inout) :: PoL !< Fractional position of neutral surface within + !! layer KoL of left column + real, dimension(2*nk+2), intent(inout) :: PoR !< Fractional position of neutral surface within + !! layer KoR of right column integer, dimension(2*nk+2), intent(inout) :: KoL !< Index of first left interface above neutral surface integer, dimension(2*nk+2), intent(inout) :: KoR !< Index of first right interface above neutral surface - real, dimension(2*nk+1), intent(inout) :: hEff !< Effective thickness between two neutral surfaces (Pa) + real, dimension(2*nk+1), intent(inout) :: hEff !< Effective thickness between two neutral surfaces [Pa] ! Local variables integer :: ns ! Number of neutral surfaces @@ -979,37 +988,41 @@ end subroutine find_neutral_surface_positions_continuous !> Higher order version of find_neutral_surface_positions. Returns positions within left/right columns !! of combined interfaces using intracell reconstructions of T/S -subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, & - Pres_l, hcol_l, Tl, Sl, dRdT_l, dRdS_l, stable_l, Pres_r, hcol_r, Tr, Sr, dRdT_r, dRdS_r, stable_r, & +subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, Pres_l, hcol_l, Tl, Sl, & + dRdT_l, dRdS_l, stable_l, Pres_r, hcol_r, Tr, Sr, dRdT_r, dRdS_r, stable_r, & PoL, PoR, KoL, KoR, hEff, ppoly_T_l, ppoly_S_l, ppoly_T_r, ppoly_S_r) - type(neutral_diffusion_CS) :: CS !< Neutral diffusion control structure + type(neutral_diffusion_CS), intent(inout) :: CS !< Neutral diffusion control structure integer, intent(in) :: nk !< Number of levels integer, intent(in) :: ns !< Number of neutral surfaces - real, dimension(nk+1), intent(in) :: Pres_l !< Left-column interface pressure (Pa) + real, dimension(nk+1), intent(in) :: Pres_l !< Left-column interface pressure [Pa] real, dimension(nk), intent(in) :: hcol_l !< Left-column layer thicknesses - real, dimension(nk,2), intent(in) :: Tl !< Left-column top interface potential temperature (degC) - real, dimension(nk,2), intent(in) :: Sl !< Left-column top interface salinity (ppt) - real, dimension(nk,2), intent(in) :: dRdT_l !< Left-column, top interface dRho/dT (kg/m3/degC) - real, dimension(nk,2), intent(in) :: dRdS_l !< Left-column, top interface dRho/dS (kg/m3/ppt) - logical, dimension(nk), intent(in) :: stable_l !< Left-column, top interface dRho/dS (kg/m3/ppt) - real, dimension(nk+1), intent(in) :: Pres_r !< Right-column interface pressure (Pa) + real, dimension(nk,2), intent(in) :: Tl !< Left-column top interface potential temperature [degC] + real, dimension(nk,2), intent(in) :: Sl !< Left-column top interface salinity [ppt] + real, dimension(nk,2), intent(in) :: dRdT_l !< Left-column, top interface dRho/dT [kg m-3 degC-1] + real, dimension(nk,2), intent(in) :: dRdS_l !< Left-column, top interface dRho/dS [kg m-3 ppt-1] + logical, dimension(nk), intent(in) :: stable_l !< Left-column, top interface is stable + real, dimension(nk+1), intent(in) :: Pres_r !< Right-column interface pressure [Pa] real, dimension(nk), intent(in) :: hcol_r !< Left-column layer thicknesses - real, dimension(nk,2), intent(in) :: Tr !< Right-column top interface potential temperature (degC) - real, dimension(nk,2), intent(in) :: Sr !< Right-column top interface salinity (ppt) - real, dimension(nk,2), intent(in) :: dRdT_r !< Right-column, top interface dRho/dT (kg/m3/degC) - real, dimension(nk,2), intent(in) :: dRdS_r !< Right-column, top interface dRho/dS (kg/m3/ppt) - logical, dimension(nk), intent(in) :: stable_r !< Left-column, top interface dRho/dS (kg/m3/ppt) + real, dimension(nk,2), intent(in) :: Tr !< Right-column top interface potential temperature [degC] + real, dimension(nk,2), intent(in) :: Sr !< Right-column top interface salinity [ppt] + real, dimension(nk,2), intent(in) :: dRdT_r !< Right-column, top interface dRho/dT [kg m-3 degC-1] + real, dimension(nk,2), intent(in) :: dRdS_r !< Right-column, top interface dRho/dS [kg m-3 ppt-1] + logical, dimension(nk), intent(in) :: stable_r !< Right-column, top interface is stable real, dimension(4*nk), intent(inout) :: PoL !< Fractional position of neutral surface within !! layer KoL of left column real, dimension(4*nk), intent(inout) :: PoR !< Fractional position of neutral surface within !! layer KoR of right column integer, dimension(4*nk), intent(inout) :: KoL !< Index of first left interface above neutral surface integer, dimension(4*nk), intent(inout) :: KoR !< Index of first right interface above neutral surface - real, dimension(4*nk-1), intent(inout) :: hEff !< Effective thickness between two neutral surfaces (Pa) - real, dimension(nk,CS%deg+1), optional, intent(in) :: ppoly_T_l !< Left-column coefficients of T reconstruction - real, dimension(nk,CS%deg+1), optional, intent(in) :: ppoly_S_l !< Left-column coefficients of S reconstruction - real, dimension(nk,CS%deg+1), optional, intent(in) :: ppoly_T_r !< Right-column coefficients of T reconstruction - real, dimension(nk,CS%deg+1), optional, intent(in) :: ppoly_S_r !< Right-column coefficients of S reconstruction + real, dimension(4*nk-1), intent(inout) :: hEff !< Effective thickness between two neutral surfaces [Pa] + real, dimension(nk,CS%deg+1), & + optional, intent(in) :: ppoly_T_l !< Left-column coefficients of T reconstruction + real, dimension(nk,CS%deg+1), & + optional, intent(in) :: ppoly_S_l !< Left-column coefficients of S reconstruction + real, dimension(nk,CS%deg+1), & + optional, intent(in) :: ppoly_T_r !< Right-column coefficients of T reconstruction + real, dimension(nk,CS%deg+1), & + optional, intent(in) :: ppoly_S_r !< Right-column coefficients of S reconstruction ! Local variables integer :: k_surface ! Index of neutral surface @@ -1032,8 +1045,9 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, bot_connected_l(:) = .false. ; bot_connected_r(:) = .false. ! Check to make sure that polynomial reconstructions were passed if refine_pos defined) - if(CS%refine_position) then - if (.not. ( present(ppoly_T_l) .and. present(ppoly_S_l) .and. present(ppoly_T_r) .and. present(ppoly_S_r) )) & + if (CS%refine_position) then + if (.not. ( present(ppoly_T_l) .and. present(ppoly_S_l) .and. & + present(ppoly_T_r) .and. present(ppoly_S_r) ) ) & call MOM_error(FATAL, "fine_neutral_surface_positions_discontinuous: refine_pos is requested, but " //& "polynomial coefficients not available for T and S") endif @@ -1063,10 +1077,11 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, ! Loop over each neutral surface, working from top to bottom neutral_surfaces: do k_surface = 1, ns ! Potential density difference, rho(kr) - rho(kl) - dRho = 0.5 * & - ( ( dRdT_r(kl_right,ki_right) + dRdT_l(kl_left,ki_left) ) * ( Tr(kl_right,ki_right) - Tl(kl_left,ki_left) ) & - + ( dRdS_r(kl_right,ki_right) + dRdS_l(kl_left,ki_left) ) * ( Sr(kl_right,ki_right) - Sl(kl_left,ki_left) ) ) - if (CS%debug) write(*,'(A,I2,A,E12.4,A,I2,A,I2,A,I2,A,I2)') "k_surface=",k_surface," dRho=",dRho, & + dRho = 0.5 * ( ( dRdT_r(kl_right,ki_right) + dRdT_l(kl_left,ki_left) ) * & + ( Tr(kl_right,ki_right) - Tl(kl_left,ki_left) ) & + + ( dRdS_r(kl_right,ki_right) + dRdS_l(kl_left,ki_left) ) * & + ( Sr(kl_right,ki_right) - Sl(kl_left,ki_left) ) ) + if (CS%debug) write(*,'(A,I2,A,E12.4,A,I2,A,I2,A,I2,A,I2)') "k_surface=",k_surface," dRho=",dRho, & "kl_left=",kl_left, " ki_left=",ki_left," kl_right=",kl_right, " ki_right=",ki_right ! Which column has the lighter surface for the current indexes, kr and kl if (.not. reached_bottom) then @@ -1077,7 +1092,8 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, searching_right_column = .true. searching_left_column = .false. else ! dRho == 0. - if ( ( kl_left == kl_left_0) .and. ( kl_right == kl_right_0 ) .and. (ki_left + ki_right == 2) ) then ! Still at surface + if ( ( kl_left == kl_left_0) .and. ( kl_right == kl_right_0 ) .and. & + (ki_left + ki_right == 2) ) then ! Still at surface searching_left_column = .true. searching_right_column = .false. else ! Not the surface so we simply change direction @@ -1103,7 +1119,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, call drho_at_pos(CS%ndiff_aux_CS, T_other, S_other, dRdT_other, dRdS_other, Pres_l(kl_left), & Pres_l(kl_left+1), ppoly_T_l(kl_left,:), ppoly_S_l(kl_left,:), lastP_left, dRhoTop) else - dRhoTop = calc_drho(Tl(kl_left,1), Sl(kl_left,1), dRdT_l(kl_left,1), dRdS_l(kl_left,1), T_other, S_other, & + dRhoTop = calc_drho(Tl(kl_left,1), Sl(kl_left,1), dRdT_l(kl_left,1), dRdS_l(kl_left,1), T_other, S_other, & dRdT_other, dRdS_other) endif ! Potential density difference, rho(kl) - rho(kl_right,ki_right) (will be positive) @@ -1123,8 +1139,9 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, KoR(k_surface) = kl_right ! Set position within the searched column - call search_other_column(dRhoTop, dRhoBot, Pres_l(kl_left), Pres_l(kl_left+1), lastP_left, lastK_left, kl_left, & - kl_left_0, ki_left, top_connected_l, bot_connected_l, PoL(k_surface), KoL(k_surface), search_layer) + call search_other_column(dRhoTop, dRhoBot, Pres_l(kl_left), Pres_l(kl_left+1), & + lastP_left, lastK_left, kl_left, kl_left_0, ki_left, & + top_connected_l, bot_connected_l, PoL(k_surface), KoL(k_surface), search_layer) if ( CS%refine_position .and. search_layer ) then min_bound = 0. @@ -1137,7 +1154,8 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, endif if (PoL(k_surface) == 0.) top_connected_l(KoL(k_surface)) = .true. if (PoL(k_surface) == 1.) bot_connected_l(KoL(k_surface)) = .true. - call increment_interface(nk, kl_right, ki_right, stable_r, reached_bottom, searching_right_column, searching_left_column) + call increment_interface(nk, kl_right, ki_right, stable_r, reached_bottom, & + searching_right_column, searching_left_column) elseif (searching_right_column) then if (CS%ref_pres>=0.) then @@ -1189,7 +1207,8 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, endif if (PoR(k_surface) == 0.) top_connected_r(KoR(k_surface)) = .true. if (PoR(k_surface) == 1.) bot_connected_r(KoR(k_surface)) = .true. - call increment_interface(nk, kl_left, ki_left, stable_l, reached_bottom, searching_left_column, searching_right_column) + call increment_interface(nk, kl_left, ki_left, stable_l, reached_bottom, & + searching_left_column, searching_right_column) else stop 'Else what?' @@ -1197,8 +1216,8 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, lastK_left = KoL(k_surface) ; lastP_left = PoL(k_surface) lastK_right = KoR(k_surface) ; lastP_right = PoR(k_surface) - if (CS%debug) write(*,'(A,I3,A,ES16.6,A,I2,A,ES16.6)') "KoL:", KoL(k_surface), " PoL:", PoL(k_surface), " KoR:", & - KoR(k_surface), " PoR:", PoR(k_surface) + if (CS%debug) write(*,'(A,I3,A,ES16.6,A,I2,A,ES16.6)') "KoL:", KoL(k_surface), " PoL:", PoL(k_surface), & + " KoR:", KoR(k_surface), " PoR:", PoR(k_surface) ! Effective thickness if (k_surface>1) then ! This is useful as a check to make sure that positions are monotonically increasing @@ -1246,12 +1265,12 @@ end subroutine find_neutral_surface_positions_discontinuous real function absolute_position(n,ns,Pint,Karr,NParr,k_surface) integer, intent(in) :: n !< Number of levels integer, intent(in) :: ns !< Number of neutral surfaces - real, intent(in) :: Pint(n+1) !< Position of interfaces (Pa) + real, intent(in) :: Pint(n+1) !< Position of interfaces [Pa] integer, intent(in) :: Karr(ns) !< Index of interface above position real, intent(in) :: NParr(ns) !< Non-dimensional position within layer Karr(:) - + integer, intent(in) :: k_surface !< k-interface to query ! Local variables - integer :: k_surface, k + integer :: k k = Karr(k_surface) if (k>n) stop 'absolute_position: k>nk is out of bounds!' @@ -1263,11 +1282,11 @@ end function absolute_position function absolute_positions(n,ns,Pint,Karr,NParr) integer, intent(in) :: n !< Number of levels integer, intent(in) :: ns !< Number of neutral surfaces - real, intent(in) :: Pint(n+1) !< Position of interface (Pa) + real, intent(in) :: Pint(n+1) !< Position of interface [Pa] integer, intent(in) :: Karr(ns) !< Indexes of interfaces about positions real, intent(in) :: NParr(ns) !< Non-dimensional positions within layers Karr(:) - real, dimension(ns) :: absolute_positions ! Absolute positions (Pa) + real, dimension(ns) :: absolute_positions ! Absolute positions [Pa] ! Local variables integer :: k_surface, k @@ -1284,8 +1303,8 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K integer, intent(in) :: nk !< Number of levels integer, intent(in) :: nsurf !< Number of neutral surfaces integer, intent(in) :: deg !< Degree of polynomial reconstructions - real, dimension(nk), intent(in) :: hl !< Left-column layer thickness (Pa) - real, dimension(nk), intent(in) :: hr !< Right-column layer thickness (Pa) + real, dimension(nk), intent(in) :: hl !< Left-column layer thickness [Pa] + real, dimension(nk), intent(in) :: hr !< Right-column layer thickness [Pa] real, dimension(nk), intent(in) :: Tl !< Left-column layer tracer (conc, e.g. degC) real, dimension(nk), intent(in) :: Tr !< Right-column layer tracer (conc, e.g. degC) real, dimension(nsurf), intent(in) :: PiL !< Fractional position of neutral surface @@ -1294,13 +1313,14 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K !! within layer KoR of right column integer, dimension(nsurf), intent(in) :: KoL !< Index of first left interface above neutral surface integer, dimension(nsurf), intent(in) :: KoR !< Index of first right interface above neutral surface - real, dimension(nsurf-1), intent(in) :: hEff !< Effective thickness between two neutral surfaces (Pa) + real, dimension(nsurf-1), intent(in) :: hEff !< Effective thickness between two neutral surfaces [Pa] real, dimension(nsurf-1), intent(inout) :: Flx !< Flux of tracer between pairs of neutral layers (conc H) logical, intent(in) :: continuous !< True if using continuous reconstruction real, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions !! in the same units as h0. - type(remapping_CS), optional, intent(in) :: remap_CS + type(remapping_CS), optional, intent(in) :: remap_CS !< Remapping control structure used + !! to create sublayers real, optional, intent(in) :: h_neglect_edge !< A negligibly small width !! for the purpose of edge value calculations !! in the same units as h0. @@ -1364,7 +1384,7 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K dT_bottom = T_right_bottom - T_left_bottom dT_ave = 0.5 * ( dT_top + dT_bottom ) dT_layer = T_right_layer - T_left_layer - if (signum(1.,dT_top) * signum(1.,dT_bottom) <= 0. .or. signum(1.,dT_ave) * signum(1.,dT_layer) <= 0. ) then + if (signum(1.,dT_top) * signum(1.,dT_bottom) <= 0. .or. signum(1.,dT_ave) * signum(1.,dT_layer) <= 0.) then dT_ave = 0. else dT_ave = dT_layer @@ -1372,10 +1392,12 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K Flx(k_sublayer) = dT_ave * hEff(k_sublayer) else ! Discontinuous reconstruction ! Calculate tracer values on left and right side of the neutral surface - call neutral_surface_T_eval(nk, nsurf, k_sublayer, KoL, PiL, Tl, Tid_l, deg, iMethod, ppoly_r_coeffs_l, & - T_left_top, T_left_bottom, T_left_sub, T_left_top_int, T_left_bot_int, T_left_layer) - call neutral_surface_T_eval(nk, nsurf, k_sublayer, KoR, PiR, Tr, Tid_r, deg, iMethod, ppoly_r_coeffs_r, & - T_right_top, T_right_bottom, T_right_sub, T_right_top_int, T_right_bot_int, T_right_layer) + call neutral_surface_T_eval(nk, nsurf, k_sublayer, KoL, PiL, Tl, Tid_l, deg, iMethod, & + ppoly_r_coeffs_l, T_left_top, T_left_bottom, T_left_sub, & + T_left_top_int, T_left_bot_int, T_left_layer) + call neutral_surface_T_eval(nk, nsurf, k_sublayer, KoR, PiR, Tr, Tid_r, deg, iMethod, & + ppoly_r_coeffs_r, T_right_top, T_right_bottom, T_right_sub, & + T_right_top_int, T_right_bot_int, T_right_layer) dT_top = T_right_top - T_left_top dT_bottom = T_right_bottom - T_left_bottom @@ -1427,7 +1449,7 @@ subroutine neutral_surface_T_eval(nk, ns, k_sub, Ks, Ps, T_mean, T_int, deg, iMe ks_top = k_sub ks_bot = k_sub + 1 - if ( Ks(ks_top) .ne. Ks(ks_bot) ) then + if ( Ks(ks_top) /= Ks(ks_bot) ) then call MOM_error(FATAL, "Neutral surfaces span more than one layer") endif kl = Ks(k_sub) @@ -1482,7 +1504,7 @@ end subroutine ppm_left_right_edge_values !> Returns true if unit tests of neutral_diffusion functions fail. Otherwise returns false. logical function neutral_diffusion_unit_tests(verbose) - logical, intent(in) :: verbose + logical, intent(in) :: verbose !< If true, write results to stdout neutral_diffusion_unit_tests = .false. .or. & ndiff_unit_tests_continuous(verbose) .or. ndiff_unit_tests_discontinuous(verbose) @@ -1492,7 +1514,7 @@ end function neutral_diffusion_unit_tests !> Returns true if unit tests of neutral_diffusion functions fail. Otherwise returns false. logical function ndiff_unit_tests_continuous(verbose) - logical, intent(in) :: verbose !< It true, write results to stdout + logical, intent(in) :: verbose !< If true, write results to stdout ! Local variables integer, parameter :: nk = 4 real, dimension(nk+1) :: TiL, TiR1, TiR2, TiR4, Tio ! Test interface temperatures @@ -1769,9 +1791,9 @@ logical function ndiff_unit_tests_discontinuous(verbose) integer, dimension(ns) :: KoL, KoR real, dimension(ns) :: PoL, PoR real, dimension(ns-1) :: hEff, Flx - type(neutral_diffusion_CS) :: CS - type(EOS_type), pointer :: EOS ! Structure for linear equation of state - type(remapping_CS), pointer :: remap_CS ! Remapping control structure (PLM) + type(neutral_diffusion_CS) :: CS !< Neutral diffusion control structure + type(EOS_type), pointer :: EOS !< Structure for linear equation of state + type(remapping_CS), pointer :: remap_CS !< Remapping control structure (PLM) real, dimension(nk,2) :: poly_T_l, poly_T_r, poly_S, poly_slope ! Linear reconstruction for T real, dimension(nk,2) :: dRdT, dRdS logical, dimension(nk) :: stable_l, stable_r @@ -1829,7 +1851,7 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/0.0, 0.0, 0.5, 0.5, 1.0, 0.0, 0.5, 0.5, 1.0, 0.0, 0.5, 1.0/), & ! pR (/0.0, 5.0, 0.0, 5.0, 0.0, 5.0, 0.0, 5.0, 0.0, 5.0, 0.0/), & ! hEff 'Right column slightly cooler') - Tl = (/18.,14.,10./) ; Tr = (/20.,16.,12./) ; + Tl = (/18.,14.,10./) ; Tr = (/20.,16.,12./) call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod, h_neglect, h_neglect_edge ) call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod, h_neglect, h_neglect_edge ) call mark_unstable_cells( nk, dRdT, dRdS, Til, Sil, stable_l, ns_l ) @@ -1971,7 +1993,7 @@ logical function test_fv_diff(verbose, hkm1, hk, hkp1, Skm1, Sk, Skp1, Ptrue, ti real, intent(in) :: Skm1 !< Left cell average value real, intent(in) :: Sk !< Center cell average value real, intent(in) :: Skp1 !< Right cell average value - real, intent(in) :: Ptrue !< True answer (Pa) + real, intent(in) :: Ptrue !< True answer [Pa] character(len=*), intent(in) :: title !< Title for messages ! Local variables @@ -2003,7 +2025,7 @@ logical function test_fvlsq_slope(verbose, hkm1, hk, hkp1, Skm1, Sk, Skp1, Ptrue real, intent(in) :: Skm1 !< Left cell average value real, intent(in) :: Sk !< Center cell average value real, intent(in) :: Skp1 !< Right cell average value - real, intent(in) :: Ptrue !< True answer (Pa) + real, intent(in) :: Ptrue !< True answer [Pa] character(len=*), intent(in) :: title !< Title for messages ! Local variables @@ -2029,11 +2051,11 @@ end function test_fvlsq_slope !> Returns true if a test of interpolate_for_nondim_position() fails, and conditionally writes results to stream logical function test_ifndp(verbose, rhoNeg, Pneg, rhoPos, Ppos, Ptrue, title) logical, intent(in) :: verbose !< If true, write results to stdout - real, intent(in) :: rhoNeg !< Lighter density (kg/m3) - real, intent(in) :: Pneg !< Interface position of lighter density (Pa) - real, intent(in) :: rhoPos !< Heavier density (kg/m3) - real, intent(in) :: Ppos !< Interface position of heavier density (Pa) - real, intent(in) :: Ptrue !< True answer (Pa) + real, intent(in) :: rhoNeg !< Lighter density [kg m-3] + real, intent(in) :: Pneg !< Interface position of lighter density [Pa] + real, intent(in) :: rhoPos !< Heavier density [kg m-3] + real, intent(in) :: Ppos !< Interface position of heavier density [Pa] + real, intent(in) :: Ptrue !< True answer [Pa] character(len=*), intent(in) :: title !< Title for messages ! Local variables @@ -2048,9 +2070,11 @@ logical function test_ifndp(verbose, rhoNeg, Pneg, rhoPos, Ppos, Ptrue, title) if (test_ifndp) stdunit = 0 ! In case of wrong results, write to error stream write(stdunit,'(a)') title if (test_ifndp) then - write(stdunit,'(4(x,a,f20.16),2(x,a,1pe22.15),x,a)') 'r1=',rhoNeg,'p1=',Pneg,'r2=',rhoPos,'p2=',Ppos,'pRet=',Pret,'pTrue=',Ptrue,'WRONG!' + write(stdunit,'(4(x,a,f20.16),2(x,a,1pe22.15),x,a)') & + 'r1=',rhoNeg,'p1=',Pneg,'r2=',rhoPos,'p2=',Ppos,'pRet=',Pret,'pTrue=',Ptrue,'WRONG!' else - write(stdunit,'(4(x,a,f20.16),2(x,a,1pe22.15))') 'r1=',rhoNeg,'p1=',Pneg,'r2=',rhoPos,'p2=',Ppos,'pRet=',Pret,'pTrue=',Ptrue + write(stdunit,'(4(x,a,f20.16),2(x,a,1pe22.15))') & + 'r1=',rhoNeg,'p1=',Pneg,'r2=',rhoPos,'p2=',Ppos,'pRet=',Pret,'pTrue=',Ptrue endif endif @@ -2079,10 +2103,12 @@ logical function test_data1d(verbose, nk, Po, Ptrue, title) do k = 1,nk if (Po(k) /= Ptrue(k)) then test_data1d = .true. - write(stdunit,'(a,i2,2(x,a,f20.16),x,a,1pe22.15,x,a)') 'k=',k,'Po=',Po(k),'Ptrue=',Ptrue(k),'err=',Po(k)-Ptrue(k),'WRONG!' + write(stdunit,'(a,i2,2(x,a,f20.16),x,a,1pe22.15,x,a)') & + 'k=',k,'Po=',Po(k),'Ptrue=',Ptrue(k),'err=',Po(k)-Ptrue(k),'WRONG!' else if (verbose) & - write(stdunit,'(a,i2,2(x,a,f20.16),x,a,1pe22.15)') 'k=',k,'Po=',Po(k),'Ptrue=',Ptrue(k),'err=',Po(k)-Ptrue(k) + write(stdunit,'(a,i2,2(x,a,f20.16),x,a,1pe22.15)') & + 'k=',k,'Po=',Po(k),'Ptrue=',Ptrue(k),'err=',Po(k)-Ptrue(k) endif enddo endif @@ -2122,7 +2148,8 @@ logical function test_data1di(verbose, nk, Po, Ptrue, title) end function test_data1di -!> Returns true if output of find_neutral_surface_positions() does not match correct values, and conditionally writes results to stream +!> Returns true if output of find_neutral_surface_positions() does not match correct values, +!! and conditionally writes results to stream logical function test_nsp(verbose, ns, KoL, KoR, pL, pR, hEff, KoL0, KoR0, pL0, pR0, hEff0, title) logical, intent(in) :: verbose !< If true, write results to stdout integer, intent(in) :: ns !< Number of surfaces @@ -2130,7 +2157,7 @@ logical function test_nsp(verbose, ns, KoL, KoR, pL, pR, hEff, KoL0, KoR0, pL0, integer, dimension(ns), intent(in) :: KoR !< Index of first right interface above neutral surface real, dimension(ns), intent(in) :: pL !< Fractional position of neutral surface within layer KoL of left column real, dimension(ns), intent(in) :: pR !< Fractional position of neutral surface within layer KoR of right column - real, dimension(ns-1), intent(in) :: hEff !< Effective thickness between two neutral surfaces (Pa) + real, dimension(ns-1), intent(in) :: hEff !< Effective thickness between two neutral surfaces [Pa] integer, dimension(ns), intent(in) :: KoL0 !< Correct value for KoL integer, dimension(ns), intent(in) :: KoR0 !< Correct value for KoR real, dimension(ns), intent(in) :: pL0 !< Correct value for pL @@ -2196,21 +2223,21 @@ end function compare_nsp_row !> Compares output position from refine_nondim_position with an expected value logical function test_rnp(expected_pos, test_pos, title) - real, intent(in) :: expected_pos - real, intent(in) :: test_pos - character(len=*), intent(in) :: title + real, intent(in) :: expected_pos !< The expected position + real, intent(in) :: test_pos !< The position returned by the code + character(len=*), intent(in) :: title !< A label for this test ! Local variables integer :: stdunit = 6 ! Output to standard error test_rnp = expected_pos /= test_pos if (test_rnp) then write(stdunit,'(A, f20.16, " .neq. ", f20.16, " <-- WRONG")') title, expected_pos, test_pos else - write(stdunit,'(A, f20.16, " .eq. ", f20.16)') title, expected_pos, test_pos + write(stdunit,'(A, f20.16, " == ", f20.16)') title, expected_pos, test_pos endif end function test_rnp !> Deallocates neutral_diffusion control structure subroutine neutral_diffusion_end(CS) - type(neutral_diffusion_CS), pointer :: CS + type(neutral_diffusion_CS), pointer :: CS !< Neutral diffusion control structure if (associated(CS)) deallocate(CS) diff --git a/src/tracer/MOM_neutral_diffusion_aux.F90 b/src/tracer/MOM_neutral_diffusion_aux.F90 index 09ed0c0e58..88df1ddbc5 100644 --- a/src/tracer/MOM_neutral_diffusion_aux.F90 +++ b/src/tracer/MOM_neutral_diffusion_aux.F90 @@ -20,17 +20,17 @@ module MOM_neutral_diffusion_aux public check_neutral_positions public kahan_sum +!> The control structure for this module type, public :: ndiff_aux_CS_type ; private integer :: nterm !< Number of terms in polynomial (deg+1) integer :: max_iter !< Maximum number of iterations - real :: drho_tol !< Tolerance criterion for difference in density (kg/m3) - real :: xtol !< Criterion for how much position changes (nondim) + real :: drho_tol !< Tolerance criterion for difference in density [kg m-3] + real :: xtol !< Criterion for how much position changes [nondim] real :: ref_pres !< Determines whether a constant reference pressure is used everywhere or locally referenced !< density is done. ref_pres <-1 is the latter, ref_pres >= 0. otherwise - logical :: force_brent = .false. !< Use Brent's method instead of Newton even when second derivatives are available - logical :: debug + logical :: force_brent = .false. !< Use Brent's method instead of Newton even when second derivatives are available + logical :: debug !< If true, write verbose debugging messages and checksusm type(EOS_type), pointer :: EOS !< Pointer to equation of state used in the model - end type ndiff_aux_CS_type contains @@ -62,10 +62,10 @@ end subroutine set_ndiff_aux_params !! For an layer to be unstable the top interface must be denser than the bottom or the bottom interface of the layer subroutine mark_unstable_cells(nk, dRdT, dRdS,T, S, stable_cell, ns) integer, intent(in) :: nk !< Number of levels in a column - real, dimension(nk,2), intent(in) :: dRdT !< drho/dT (kg/m3/degC) at interfaces - real, dimension(nk,2), intent(in) :: dRdS !< drho/dS (kg/m3/ppt) at interfaces - real, dimension(nk,2), intent(in) :: T !< drho/dS (kg/m3/ppt) at interfaces - real, dimension(nk,2), intent(in) :: S !< drho/dS (kg/m3/ppt) at interfaces + real, dimension(nk,2), intent(in) :: dRdT !< drho/dT [kg m-3 degC-1] at interfaces + real, dimension(nk,2), intent(in) :: dRdS !< drho/dS [kg m-3 ppt-1] at interfaces + real, dimension(nk,2), intent(in) :: T !< Temperature [degC] at interfaces + real, dimension(nk,2), intent(in) :: S !< Salinity [ppt] at interfaces logical, dimension(nk), intent( out) :: stable_cell !< True if this cell is unstably stratified integer, intent( out) :: ns !< Number of neutral surfaces in unmasked part of the column @@ -174,7 +174,7 @@ subroutine drho_at_pos(CS, T_ref, S_ref, alpha_ref, beta_ref, P_top, P_bot, ppol real, dimension(CS%nterm), intent(in) :: ppoly_T !< Coefficients of T reconstruction real, dimension(CS%nterm), intent(in) :: ppoly_S !< Coefficients of S reconstruciton real, intent(in) :: x0 !< Nondimensional position to evaluate - real, intent(out) :: delta_rho + real, intent(out) :: delta_rho !< The density difference from a reference value real, optional, intent(out) :: P_out !< Pressure at point x0 real, optional, intent(out) :: T_out !< Temperature at point x0 real, optional, intent(out) :: S_out !< Salinity at point x0 @@ -328,8 +328,10 @@ real function interpolate_for_nondim_position(dRhoNeg, Pneg, dRhoPos, Ppos) else ! dRhoPos - dRhoNeg < 0 interpolate_for_nondim_position = 0.5 endif - if ( interpolate_for_nondim_position < 0. ) stop 'interpolate_for_nondim_position: Houston, we have a problem! Pint < Pneg' - if ( interpolate_for_nondim_position > 1. ) stop 'interpolate_for_nondim_position: Houston, we have a problem! Pint > Ppos' + if ( interpolate_for_nondim_position < 0. ) & + stop 'interpolate_for_nondim_position: Houston, we have a problem! Pint < Pneg' + if ( interpolate_for_nondim_position > 1. ) & + stop 'interpolate_for_nondim_position: Houston, we have a problem! Pint > Ppos' end function interpolate_for_nondim_position !> Use root-finding methods to find where dRho = 0, based on the equation of state and the polynomial @@ -339,8 +341,8 @@ end function interpolate_for_nondim_position !! to see if it it diverges outside the interval. In that case (or in the case that second derivatives are not !! available), Brent's method is used following the implementation found at !! https://people.sc.fsu.edu/~jburkardt/f_src/brent/brent.f90 -real function refine_nondim_position(CS, T_ref, S_ref, alpha_ref, beta_ref, P_top, P_bot, ppoly_T, ppoly_S, drho_top, & - drho_bot, min_bound) +real function refine_nondim_position(CS, T_ref, S_ref, alpha_ref, beta_ref, P_top, P_bot, & + ppoly_T, ppoly_S, drho_top, drho_bot, min_bound) type(ndiff_aux_CS_type), intent(in) :: CS !< Control structure with parameters for this module real, intent(in) :: T_ref !< Temperature of the neutral surface at the searched from interface real, intent(in) :: S_ref !< Salinity of the neutral surface at the searched from interface @@ -463,7 +465,7 @@ real function refine_nondim_position(CS, T_ref, S_ref, alpha_ref, beta_ref, P_to ! For the logic to find neutral surfaces to work properly, the function needs to converge to zero ! or a small negative value - if( (fb <= 0.) .and. (fb >= -CS%drho_tol) ) then + if ((fb <= 0.) .and. (fb >= -CS%drho_tol)) then refine_nondim_position = b exit endif @@ -505,7 +507,7 @@ real function refine_nondim_position(CS, T_ref, S_ref, alpha_ref, beta_ref, P_to fa = fb fb = fc fc = fa - end if + endif tol = 2. * machep * abs ( sb ) + CS%xtol m = 0.5 * ( c - sb ) if ( abs ( m ) <= tol .or. fb == 0. ) then @@ -524,12 +526,12 @@ real function refine_nondim_position(CS, T_ref, S_ref, alpha_ref, beta_ref, P_to r = fb / fc p = s0 * ( 2. * m * q * ( q - r ) - ( sb - sa ) * ( r - 1. ) ) q = ( q - 1. ) * ( r - 1. ) * ( s0 - 1. ) - end if + endif if ( 0. < p ) then q = - q else p = - p - end if + endif s0 = e e = d if ( 2. * p < 3. * m * q - abs ( tol * q ) .and. & @@ -538,17 +540,17 @@ real function refine_nondim_position(CS, T_ref, S_ref, alpha_ref, beta_ref, P_to else e = m d = e - end if - end if + endif + endif sa = sb fa = fb if ( tol < abs ( d ) ) then sb = sb + d - else if ( 0. < m ) then + elseif ( 0. < m ) then sb = sb + tol else sb = sb - tol - end if + endif call drho_at_pos(CS, T_ref, S_ref, alpha_ref, beta_ref, P_top, P_bot, ppoly_T, ppoly_S, & sb, fb) if ( ( 0. < fb .and. 0. < fc ) .or. & @@ -557,7 +559,7 @@ real function refine_nondim_position(CS, T_ref, S_ref, alpha_ref, beta_ref, P_to fc = fa e = sb - sa d = e - end if + endif enddo ! Modified from original to ensure that the minimum is found fa = ABS(fa) ; fb = ABS(fb) ; fc = ABS(fc) diff --git a/src/tracer/MOM_offline_aux.F90 b/src/tracer/MOM_offline_aux.F90 index 39c8385029..89f4a6eef4 100644 --- a/src/tracer/MOM_offline_aux.F90 +++ b/src/tracer/MOM_offline_aux.F90 @@ -22,7 +22,7 @@ module MOM_offline_aux use MOM_diag_mediator, only : post_data use MOM_forcing_type, only : forcing -implicit none +implicit none ; private public update_offline_from_files public update_offline_from_arrays @@ -44,12 +44,16 @@ module MOM_offline_aux !> This updates thickness based on the convergence of horizontal mass fluxes !! NOTE: Only used in non-ALE mode subroutine update_h_horizontal_flux(G, GV, uhtr, vhtr, h_pre, h_new) - type(ocean_grid_type), pointer :: G - type(verticalGrid_type), pointer :: GV - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: uhtr - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: vhtr - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) , intent(in) :: h_pre - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) , intent(inout) :: h_new + type(ocean_grid_type), pointer :: G !< ocean grid structure + type(verticalGrid_type), pointer :: GV !< ocean vertical grid structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(in) :: uhtr !< Accumulated mass flux through zonal face [kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(in) :: vhtr !< Accumulated mass flux through meridional face [kg] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_pre !< Previous layer thicknesses [kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(inout) :: h_new !< Updated layer thicknesses [kg m-2]. ! Local variables integer :: i, j, k, m, is, ie, js, je, nz @@ -66,7 +70,7 @@ subroutine update_h_horizontal_flux(G, GV, uhtr, vhtr, h_pre, h_new) ! add a bit of mass to avoid truncation errors. This will lead to ! non-conservation of tracers h_new(i,j,k) = h_new(i,j,k) + & - max(GV%Angstrom, 1.0e-13*h_new(i,j,k) - G%areaT(i,j)*h_pre(i,j,k)) + max(GV%Angstrom_H, 1.0e-13*h_new(i,j,k) - G%areaT(i,j)*h_pre(i,j,k)) ! Convert back to thickness h_new(i,j,k) = h_new(i,j,k)/G%areaT(i,j) @@ -78,12 +82,19 @@ end subroutine update_h_horizontal_flux !> Updates layer thicknesses due to vertical mass transports !! NOTE: Only used in non-ALE configuration subroutine update_h_vertical_flux(G, GV, ea, eb, h_pre, h_new) - type(ocean_grid_type), pointer :: G - type(verticalGrid_type), pointer :: GV - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) , intent(in) :: ea - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) , intent(in) :: eb - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) , intent(in) :: h_pre - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) , intent(inout) :: h_new + type(ocean_grid_type), pointer :: G !< ocean grid structure + type(verticalGrid_type), pointer :: GV !< ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: ea !< Mass of fluid entrained from the layer + !! above within this timestep [kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: eb !< Mass of fluid entrained from the layer + !! below within this timestep [kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_pre !< Layer thicknesses at the end of the previous + !! step [kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(inout) :: h_new !< Updated layer thicknesses [kg m-2]. ! Local variables integer :: i, j, k, m, is, ie, js, je, nz @@ -124,13 +135,21 @@ end subroutine update_h_vertical_flux !> This routine limits the mass fluxes so that the a layer cannot be completely depleted. !! NOTE: Only used in non-ALE mode subroutine limit_mass_flux_3d(G, GV, uh, vh, ea, eb, h_pre) - type(ocean_grid_type), pointer :: G - type(verticalGrid_type), pointer :: GV - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: uh - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: vh - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) , intent(inout) :: ea - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) , intent(inout) :: eb - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) , intent(in) :: h_pre + type(ocean_grid_type), pointer :: G !< ocean grid structure + type(verticalGrid_type), pointer :: GV !< ocean vertical grid structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(inout) :: uh !< Mass flux through zonal face [kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(inout) :: vh !< Mass flux through meridional face [kg] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(inout) :: ea !< Mass of fluid entrained from the layer + !! above within this timestep [kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(inout) :: eb !< Mass of fluid entrained from the layer + !! below within this timestep [kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_pre !< Layer thicknesses at the end of the previous + !! step [kg m-2]. ! Local variables integer :: i, j, k, m, is, ie, js, je, nz @@ -219,10 +238,13 @@ end subroutine limit_mass_flux_3d !> In the case where offline advection has failed to converge, redistribute the u-flux !! into remainder of the water column as a barotropic equivalent subroutine distribute_residual_uh_barotropic(G, GV, hvol, uh) - type(ocean_grid_type), pointer :: G - type(verticalGrid_type), pointer :: GV - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in ) :: hvol - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: uh + type(ocean_grid_type), pointer :: G !< ocean grid structure + type(verticalGrid_type), pointer :: GV !< ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in ) :: hvol !< Mass of water in the cells at the end + !! of the previous timestep [kg] + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(inout) :: uh !< Zonal mass transport within a timestep [kg] real, dimension(SZIB_(G),SZK_(G)) :: uh2d real, dimension(SZIB_(G)) :: uh2d_sum @@ -252,7 +274,7 @@ subroutine distribute_residual_uh_barotropic(G, GV, hvol, uh) else h2d(i,k) = GV%H_subroundoff endif - enddo; enddo; + enddo ; enddo ! Distribute flux. Note min/max is intended to make sure that the mass transport ! does not deplete a cell @@ -272,7 +294,7 @@ subroutine distribute_residual_uh_barotropic(G, GV, hvol, uh) endif ! Calculate and check that column integrated transports match the original to ! within the tolerance limit - uh_neglect = GV%Angstrom*min(G%areaT(i,j),G%areaT(i+1,j)) + uh_neglect = GV%Angstrom_H*min(G%areaT(i,j),G%areaT(i+1,j)) if ( abs(sum(uh2d(I,:))-uh2d_sum(I)) > uh_neglect) & call MOM_error(WARNING,"Column integral of uh does not match after "//& "barotropic redistribution") @@ -287,10 +309,13 @@ end subroutine distribute_residual_uh_barotropic !> Redistribute the v-flux as a barotropic equivalent subroutine distribute_residual_vh_barotropic(G, GV, hvol, vh) - type(ocean_grid_type), pointer :: G - type(verticalGrid_type), pointer :: GV - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in ) :: hvol - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: vh + type(ocean_grid_type), pointer :: G !< ocean grid structure + type(verticalGrid_type), pointer :: GV !< ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in ) :: hvol !< Mass of water in the cells at the end + !! of the previous timestep [kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(inout) :: vh !< Meridional mass transport within a timestep [kg] real, dimension(SZJB_(G),SZK_(G)) :: vh2d real, dimension(SZJB_(G)) :: vh2d_sum @@ -320,7 +345,7 @@ subroutine distribute_residual_vh_barotropic(G, GV, hvol, vh) else h2d(j,k) = GV%H_subroundoff endif - enddo; enddo; + enddo ; enddo ! Distribute flux evenly throughout a column do j=js-1,je @@ -339,7 +364,7 @@ subroutine distribute_residual_vh_barotropic(G, GV, hvol, vh) endif ! Calculate and check that column integrated transports match the original to ! within the tolerance limit - vh_neglect = GV%Angstrom*min(G%areaT(i,j),G%areaT(i,j+1)) + vh_neglect = GV%Angstrom_H*min(G%areaT(i,j),G%areaT(i,j+1)) if ( abs(sum(vh2d(J,:))-vh2d_sum(J)) > vh_neglect) then call MOM_error(WARNING,"Column integral of vh does not match after "//& "barotropic redistribution") @@ -357,10 +382,13 @@ end subroutine distribute_residual_vh_barotropic !> In the case where offline advection has failed to converge, redistribute the u-flux !! into layers above subroutine distribute_residual_uh_upwards(G, GV, hvol, uh) - type(ocean_grid_type), pointer :: G - type(verticalGrid_type), pointer :: GV - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in ) :: hvol - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: uh + type(ocean_grid_type), pointer :: G !< ocean grid structure + type(verticalGrid_type), pointer :: GV !< ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in ) :: hvol !< Mass of water in the cells at the end + !! of the previous timestep [kg] + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(inout) :: uh !< Zonal mass transport within a timestep [kg] real, dimension(SZIB_(G),SZK_(G)) :: uh2d real, dimension(SZI_(G),SZK_(G)) :: h2d @@ -372,7 +400,7 @@ subroutine distribute_residual_uh_upwards(G, GV, hvol, uh) ! Set index-related variables for fields on T-grid is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - min_h = GV%Angstrom*0.1 + min_h = GV%Angstrom_H*0.1 do j=js,je ! Copy over uh and cell volume to working arrays @@ -432,7 +460,7 @@ subroutine distribute_residual_uh_upwards(G, GV, hvol, uh) ! Calculate and check that column integrated transports match the original to ! within the tolerance limit - uh_neglect = GV%Angstrom*min(G%areaT(i,j),G%areaT(i+1,j)) + uh_neglect = GV%Angstrom_H*min(G%areaT(i,j),G%areaT(i+1,j)) if (abs(uh_col - sum(uh2d(I,:)))>uh_neglect) then call MOM_error(WARNING,"Column integral of uh does not match after "//& "upwards redistribution") @@ -450,10 +478,13 @@ end subroutine distribute_residual_uh_upwards !> In the case where offline advection has failed to converge, redistribute the u-flux !! into layers above subroutine distribute_residual_vh_upwards(G, GV, hvol, vh) - type(ocean_grid_type), pointer :: G - type(verticalGrid_type), pointer :: GV - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in ) :: hvol - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: vh + type(ocean_grid_type), pointer :: G !< ocean grid structure + type(verticalGrid_type), pointer :: GV !< ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in ) :: hvol !< Mass of water in the cells at the end + !! of the previous timestep [kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(inout) :: vh !< Meridional mass transport within a timestep [kg] real, dimension(SZJB_(G),SZK_(G)) :: vh2d real, dimension(SZJB_(G)) :: vh2d_sum @@ -467,7 +498,7 @@ subroutine distribute_residual_vh_upwards(G, GV, hvol, vh) ! Set index-related variables for fields on T-grid is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - min_h = 0.1*GV%Angstrom + min_h = 0.1*GV%Angstrom_H do i=is,ie ! Copy over uh and cell volume to working arrays @@ -527,7 +558,7 @@ subroutine distribute_residual_vh_upwards(G, GV, hvol, vh) ! Calculate and check that column integrated transports match the original to ! within the tolerance limit - vh_neglect = GV%Angstrom*min(G%areaT(i,j),G%areaT(i,j+1)) + vh_neglect = GV%Angstrom_H*min(G%areaT(i,j),G%areaT(i,j+1)) if ( ABS(vh_col-SUM(vh2d(J,:))) > vh_neglect) then call MOM_error(WARNING,"Column integral of vh does not match after "//& "upwards redistribution") @@ -544,10 +575,10 @@ end subroutine distribute_residual_vh_upwards !> add_diurnal_SW adjusts the shortwave fluxes in an forcying_type variable !! to add a synthetic diurnal cycle. Adapted from SIS2 subroutine offline_add_diurnal_SW(fluxes, G, Time_start, Time_end) - type(forcing), intent(inout) :: fluxes !< The type with atmospheric fluxes to be adjusted. - type(ocean_grid_type), intent(in) :: G !< The sea-ice lateral grid type. - type(time_type), intent(in) :: Time_start !< The start time for this step. - type(time_type), intent(in) :: Time_end !< The ending time for this step. + type(forcing), intent(inout) :: fluxes !< The type with atmospheric fluxes to be adjusted. + type(ocean_grid_type), intent(in) :: G !< The ocean lateral grid type. + type(time_type), intent(in) :: Time_start !< The start time for this step. + type(time_type), intent(in) :: Time_end !< The ending time for this step. real :: diurnal_factor, time_since_ae, rad real :: fracday_dt, fracday_day @@ -578,16 +609,16 @@ subroutine offline_add_diurnal_SW(fluxes, G, Time_start, Time_end) call diurnal_solar(G%geoLatT(i,j)*rad, G%geoLonT(i,j)*rad, Time_start, cosz=cosz_dt, & fracday=fracday_dt, rrsun=rrsun_dt, dt_time=dt_here) - call daily_mean_solar (G%geoLatT(i,j)*rad, time_since_ae, cosz_day, fracday_day, rrsun_day) + call daily_mean_solar(G%geoLatT(i,j)*rad, time_since_ae, cosz_day, fracday_day, rrsun_day) diurnal_factor = cosz_dt*fracday_dt*rrsun_dt / & max(1e-30, cosz_day*fracday_day*rrsun_day) i2 = i+i_off ; j2 = j+j_off fluxes%sw(i2,j2) = fluxes%sw(i2,j2) * diurnal_factor fluxes%sw_vis_dir(i2,j2) = fluxes%sw_vis_dir(i2,j2) * diurnal_factor - fluxes%sw_vis_dif (i2,j2) = fluxes%sw_vis_dif (i2,j2) * diurnal_factor + fluxes%sw_vis_dif(i2,j2) = fluxes%sw_vis_dif(i2,j2) * diurnal_factor fluxes%sw_nir_dir(i2,j2) = fluxes%sw_nir_dir(i2,j2) * diurnal_factor - fluxes%sw_nir_dif (i2,j2) = fluxes%sw_nir_dif (i2,j2) * diurnal_factor + fluxes%sw_nir_dif(i2,j2) = fluxes%sw_nir_dif(i2,j2) * diurnal_factor enddo ; enddo end subroutine offline_add_diurnal_sw @@ -606,9 +637,9 @@ subroutine update_offline_from_files(G, GV, nk_input, mean_file, sum_file, snap_ character(len=*), intent(in ) :: snap_file !< Name of file with snapshot fields character(len=*), intent(in ) :: surf_file !< Name of file with surface fields real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & - intent(inout) :: uhtr !< Zonal mass fluxes + intent(inout) :: uhtr !< Zonal mass fluxes [kg] real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & - intent(inout) :: vhtr !< Meridional mass fluxes + intent(inout) :: vhtr !< Meridional mass fluxes [kg] real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(inout) :: h_end !< End of timestep layer thickness real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & @@ -631,7 +662,7 @@ subroutine update_offline_from_files(G, GV, nk_input, mean_file, sum_file, snap_ integer :: i, j, k, is, ie, js, je, nz real :: Initer_vert - do_ale = .false.; + do_ale = .false. if (present(do_ale_in) ) do_ale = do_ale_in is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -707,17 +738,17 @@ subroutine update_offline_from_files(G, GV, nk_input, mean_file, sum_file, snap_ call MOM_read_data(mean_file,'sw_nir',fluxes%sw_nir_dir, G%Domain, & timelevel=ridx_sum) fluxes%sw_vis_dir(:,:) = fluxes%sw_vis_dir(:,:)*0.5 - fluxes%sw_vis_dif (:,:) = fluxes%sw_vis_dir + fluxes%sw_vis_dif(:,:) = fluxes%sw_vis_dir fluxes%sw_nir_dir(:,:) = fluxes%sw_nir_dir(:,:)*0.5 - fluxes%sw_nir_dif (:,:) = fluxes%sw_nir_dir + fluxes%sw_nir_dif(:,:) = fluxes%sw_nir_dir fluxes%sw = fluxes%sw_vis_dir + fluxes%sw_vis_dif + fluxes%sw_nir_dir + fluxes%sw_nir_dif do j=js,je ; do i=is,ie if (G%mask2dT(i,j)<1.0) then fluxes%sw(i,j) = 0.0 fluxes%sw_vis_dir(i,j) = 0.0 fluxes%sw_nir_dir(i,j) = 0.0 - fluxes%sw_vis_dif (i,j) = 0.0 - fluxes%sw_nir_dif (i,j) = 0.0 + fluxes%sw_vis_dif(i,j) = 0.0 + fluxes%sw_nir_dif(i,j) = 0.0 endif enddo ; enddo call pass_var(fluxes%sw,G%Domain) @@ -739,12 +770,12 @@ subroutine update_offline_from_arrays(G, GV, nk_input, ridx_sum, mean_file, sum_ character(len=200), intent(in ) :: mean_file !< Name of file with averages fields character(len=200), intent(in ) :: sum_file !< Name of file with summed fields character(len=200), intent(in ) :: snap_file !< Name of file with snapshot fields - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: uhtr !< Zonal mass fluxes - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: vhtr !< Meridional mass fluxes - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: hend !< End of timestep layer thickness - real, dimension(:,:,:,:), allocatable, intent(inout) :: uhtr_all !< Zonal mass fluxes - real, dimension(:,:,:,:), allocatable, intent(inout) :: vhtr_all !< Meridional mass fluxes - real, dimension(:,:,:,:), allocatable, intent(inout) :: hend_all !< End of timestep layer thickness + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: uhtr !< Zonal mass fluxes [kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: vhtr !< Meridional mass fluxes [kg] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: hend !< End of timestep layer thickness [kg m-2] + real, dimension(:,:,:,:), allocatable, intent(inout) :: uhtr_all !< Zonal mass fluxes [kg] + real, dimension(:,:,:,:), allocatable, intent(inout) :: vhtr_all !< Meridional mass fluxes [kg] + real, dimension(:,:,:,:), allocatable, intent(inout) :: hend_all !< End of timestep layer thickness [kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: temp !< Temperature array real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: salt !< Salinity array real, dimension(:,:,:,:), allocatable, intent(inout) :: temp_all !< Temperature array diff --git a/src/tracer/MOM_offline_main.F90 b/src/tracer/MOM_offline_main.F90 index eed7039fe4..a4676583bd 100644 --- a/src/tracer/MOM_offline_main.F90 +++ b/src/tracer/MOM_offline_main.F90 @@ -15,7 +15,7 @@ module MOM_offline_main use MOM_diabatic_aux, only : tridiagTS use MOM_diag_mediator, only : diag_ctrl, post_data, register_diag_field use MOM_domains, only : sum_across_PEs, pass_var, pass_vector -use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING use MOM_error_handler, only : callTree_enter, callTree_leave use MOM_file_parser, only : read_param, get_param, log_version, param_file_type use MOM_forcing_type, only : forcing @@ -42,32 +42,46 @@ module MOM_offline_main #include "MOM_memory.h" #include "version_variable.h" +!> The control structure for the offline transport module type, public :: offline_transport_CS ; private - !> Pointers to relevant fields from the main MOM control structure + ! Pointers to relevant fields from the main MOM control structure type(ALE_CS), pointer :: ALE_CSp => NULL() + !< A pointer to the ALE control structure type(diabatic_CS), pointer :: diabatic_CSp => NULL() + !< A pointer to the diabatic control structure type(diag_ctrl), pointer :: diag => NULL() + !< Structure that regulates diagnostic output type(ocean_OBC_type), pointer :: OBC => NULL() + !< A pointer to the open boundary condition control structure type(tracer_advect_CS), pointer :: tracer_adv_CSp => NULL() + !< A pointer to the tracer advection control structure + type(opacity_CS), pointer :: opacity_CSp => NULL() + !< A pointer to the opacity control structure type(tracer_flow_control_CS), pointer :: tracer_flow_CSp => NULL() + !< A pointer to control structure that orchestrates the calling of tracer packages type(tracer_registry_type), pointer :: tracer_Reg => NULL() + !< A pointer to the tracer registry type(thermo_var_ptrs), pointer :: tv => NULL() + !< A structure pointing to various thermodynamic variables type(ocean_grid_type), pointer :: G => NULL() + !< Pointer to a structure containing metrics and related information type(verticalGrid_type), pointer :: GV => NULL() + !< Pointer to structure containing information about the vertical grid type(optics_type), pointer :: optics => NULL() - type(opacity_CS), pointer :: opacity_CSp => NULL() + !< Pointer to the optical properties type !> Variables related to reading in fields from online run integer :: start_index !< Timelevel to start integer :: iter_no !< Timelevel to start integer :: numtime !< How many timelevels in the input fields integer :: accumulated_time !< Length of time accumulated in the current offline interval - integer :: & !< Index of each of the variables to be read in - ridx_sum = -1, & !! Separate indices for each variable if they are - ridx_snap = -1 !! setoff from each other in time - integer :: nk_input !! Number of input levels in the input fields - character(len=200) :: offlinedir ! Directory where offline fields are stored + ! Index of each of the variables to be read in with separate indices for each variable if they + ! are set off from each other in time + integer :: ridx_sum = -1 !< Read index offset of the summed variables + integer :: ridx_snap = -1 !< Read index offset of the snapshot variables + integer :: nk_input !< Number of input levels in the input fields + character(len=200) :: offlinedir !< Directory where offline fields are stored character(len=200) :: & ! Names of input files surf_file, & !< Contains surface fields (2d arrays) snap_file, & !< Snapshotted fields (layer thicknesses) @@ -79,14 +93,14 @@ module MOM_offline_main !! 'both' if both methods are used character(len=20) :: mld_var_name !< Name of the mixed layer depth variable to use logical :: fields_are_offset !< True if the time-averaged fields and snapshot fields are - ! offset by one time level + !! offset by one time level logical :: x_before_y !< Which horizontal direction is advected first logical :: print_adv_offline !< Prints out some updates each advection sub interation logical :: skip_diffusion !< Skips horizontal diffusion of tracers logical :: read_sw !< Read in averaged values for shortwave radiation logical :: read_mld !< Check to see whether mixed layer depths should be read in logical :: diurnal_sw !< Adds a synthetic diurnal cycle on shortwave radiation - logical :: debug + logical :: debug !< If true, write verbose debugging messages logical :: redistribute_barotropic !< Redistributes column-summed residual transports throughout !! a column weighted by thickness logical :: redistribute_upwards !< Redistributes remaining fluxes only in layers above @@ -98,13 +112,13 @@ module MOM_offline_main integer :: num_off_iter !< Number of advection iterations per offline step integer :: num_vert_iter !< Number of vertical iterations per offline step integer :: off_ale_mod !< Sets how frequently the ALE step is done during the advection - real :: dt_offline ! Timestep used for offline tracers - real :: dt_offline_vertical ! Timestep used for calls to tracer vertical physics - real :: evap_CFL_limit, minimum_forcing_depth !< Copied from diabatic_CS controlling how tracers - !! follow freshwater fluxes + real :: dt_offline !< Timestep used for offline tracers [s] + real :: dt_offline_vertical !< Timestep used for calls to tracer vertical physics [s] + real :: evap_CFL_limit !< Copied from diabatic_CS controlling how tracers follow freshwater fluxes + real :: minimum_forcing_depth !< Copied from diabatic_CS controlling how tracers follow freshwater fluxes real :: Kd_max !< Runtime parameter specifying the maximum value of vertical diffusivity real :: min_residual !< The minimum amount of total mass flux before exiting the main advection routine - !> Diagnostic manager IDs for some fields that may be of interest when doing offline transport + !>@{ Diagnostic manager IDs for some fields that may be of interest when doing offline transport integer :: & id_uhr = -1, & id_vhr = -1, & @@ -121,42 +135,47 @@ module MOM_offline_main id_h_redist = -1, & id_eta_diff_end = -1 - !> Diagnostic IDs for the regridded/remapped input fields + ! Diagnostic IDs for the regridded/remapped input fields integer :: & id_uhtr_regrid = -1, & id_vhtr_regrid = -1, & id_temp_regrid = -1, & id_salt_regrid = -1, & id_h_regrid = -1 + !!@} - !> IDs for timings of various offline components - integer :: & - id_clock_read_fields = -1, & - id_clock_offline_diabatic = -1, & - id_clock_offline_adv = -1, & - id_clock_redistribute = -1 + ! IDs for timings of various offline components + integer :: id_clock_read_fields = -1 !< A CPU time clock + integer :: id_clock_offline_diabatic = -1 !< A CPU time clock + integer :: id_clock_offline_adv = -1 !< A CPU time clock + integer :: id_clock_redistribute = -1 !< A CPU time clock - !> Variables that may need to be stored between calls to step_MOM + !> Zonal transport that may need to be stored between calls to step_MOM real, allocatable, dimension(:,:,:) :: uhtr + !> Meridional transport that may need to be stored between calls to step_MOM real, allocatable, dimension(:,:,:) :: vhtr ! Fields at T-point - real, allocatable, dimension(:,:,:) :: & - eatr, & !< Amount of fluid entrained from the layer above within - !! one time step (m for Bouss, kg/m^2 for non-Bouss) - ebtr !< Amount of fluid entrained from the layer below within - !! one time step (m for Bouss, kg/m^2 for non-Bouss) + real, allocatable, dimension(:,:,:) :: eatr + !< Amount of fluid entrained from the layer above within + !! one time step [H ~> m or kg m-2] + real, allocatable, dimension(:,:,:) :: ebtr + !< Amount of fluid entrained from the layer below within + !! one time step [H ~> m or kg m-2] ! Fields at T-points on interfaces real, allocatable, dimension(:,:,:) :: Kd !< Vertical diffusivity real, allocatable, dimension(:,:,:) :: h_end !< Thicknesses at the end of offline timestep real, allocatable, dimension(:,:) :: netMassIn !< Freshwater fluxes into the ocean real, allocatable, dimension(:,:) :: netMassOut !< Freshwater fluxes out of the ocean - real, allocatable, dimension(:,:) :: mld !< Mixed layer depths at thickness points, in H. + real, allocatable, dimension(:,:) :: mld !< Mixed layer depths at thickness points [H ~> m or kg m-2]. - !> Allocatable arrays to read in entire fields during initialization - real, allocatable, dimension(:,:,:,:) :: & - uhtr_all, vhtr_all, hend_all, temp_all, salt_all + ! Allocatable arrays to read in entire fields during initialization + real, allocatable, dimension(:,:,:,:) :: uhtr_all !< Entire field of zonal transport + real, allocatable, dimension(:,:,:,:) :: vhtr_all !< Entire field of mericional transport + real, allocatable, dimension(:,:,:,:) :: hend_all !< Entire field of layer thicknesses + real, allocatable, dimension(:,:,:,:) :: temp_all !< Entire field of temperatures + real, allocatable, dimension(:,:,:,:) :: salt_all !< Entire field of salinities end type offline_transport_CS @@ -185,10 +204,14 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, CS, id_clock real, intent(in) :: time_interval !< time interval type(offline_transport_CS), pointer :: CS !< control structure for offline module integer, intent(in) :: id_clock_ALE !< Clock for ALE routines - real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%G)), intent(inout) :: h_pre !< layer thicknesses before advection - real, dimension(SZIB_(CS%G),SZJ_(CS%G),SZK_(CS%G)), intent(inout) :: uhtr !< Zonal mass transport - real, dimension(SZI_(CS%G),SZJB_(CS%G),SZK_(CS%G)), intent(inout) :: vhtr !< Meridional mass transport - logical, intent( out) :: converged + real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%G)), & + intent(inout) :: h_pre !< layer thicknesses before advection + !! [H ~> m or kg m-2] + real, dimension(SZIB_(CS%G),SZJ_(CS%G),SZK_(CS%G)), & + intent(inout) :: uhtr !< Zonal mass transport [H m2 ~> m3 or kg] + real, dimension(SZI_(CS%G),SZJB_(CS%G),SZK_(CS%G)), & + intent(inout) :: vhtr !< Meridional mass transport [H m2 ~> m3 or kg] + logical, intent( out) :: converged !< True if the iterations have converged ! Local pointers type(ocean_grid_type), pointer :: G => NULL() ! Pointer to a structure containing @@ -210,6 +233,7 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, CS, id_clock real, dimension(SZI_(CS%G),SZJ_(CS%G)) :: eta_pre, eta_end integer :: niter, iter real :: Inum_iter + character(len=256) :: mesg ! The text of an error message integer :: i, j, k, m, is, ie, js, je, isd, ied, jsd, jed, nz integer :: isv, iev, jsv, jev ! The valid range of the indices. integer :: IsdB, IedB, JsdB, JedB @@ -218,7 +242,7 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, CS, id_clock integer :: nstocks real :: stock_values(MAX_FIELDS_) - character*20 :: debug_msg + character(len=20) :: debug_msg call cpu_clock_begin(CS%id_clock_offline_adv) ! Grid-related pointer assignments @@ -285,9 +309,8 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, CS, id_clock endif tot_residual = remaining_transport_sum(CS, uhtr, vhtr) if (CS%print_adv_offline) then - if (is_root_pe()) then - write(*,'(A,ES24.16)') "Main advection starting transport: ", tot_residual - endif + write(mesg,'(A,ES24.16)') "Main advection starting transport: ", tot_residual + call MOM_mesg(mesg) endif ! This loop does essentially a flux-limited, nonlinear advection scheme until all mass fluxes @@ -299,7 +322,7 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, CS, id_clock h_pre(i,j,k) = h_new(i,j,k) enddo ; enddo ; enddo - if(CS%debug) then + if (CS%debug) then call hchksum(h_vol,"h_vol before advect",G%HI) call uvchksum("[uv]htr_sub before advect", uhtr_sub, vhtr_sub, G%HI) write(debug_msg, '(A,I4.4)') 'Before advect ', iter @@ -348,13 +371,13 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, CS, id_clock ! advection has stalled tot_residual = remaining_transport_sum(CS, uhtr, vhtr) if (CS%print_adv_offline) then - if (is_root_pe()) then - write(*,'(A,ES24.16)') "Main advection remaining transport: ", tot_residual - endif + write(mesg,'(A,ES24.16)') "Main advection remaining transport: ", tot_residual + call MOM_mesg(mesg) endif ! If all the mass transports have been used u, then quit if (tot_residual == 0.0) then - if (is_root_pe()) write(0,*) "Converged after iteration", iter + write(mesg,*) "Converged after iteration ", iter + call MOM_mesg(mesg) converged = .true. exit endif @@ -387,12 +410,14 @@ end subroutine offline_advection_ale !! throughout the water column. 'upwards' attempts to redistribute the transport in the layers above and will !! eventually work down the entire water column subroutine offline_redistribute_residual(CS, h_pre, uhtr, vhtr, converged) - type(offline_transport_CS), pointer :: CS !< control structure from initialize_MOM - - real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%G)), intent(inout) :: h_pre !< layer thicknesses before advection - real, dimension(SZIB_(CS%G),SZJ_(CS%G),SZK_(CS%G)), intent(inout) :: uhtr !< Zonal mass transport - real, dimension(SZI_(CS%G),SZJB_(CS%G),SZK_(CS%G)), intent(inout) :: vhtr !< Meridional mass transport - logical, intent(in ) :: converged + type(offline_transport_CS), pointer :: CS !< control structure from initialize_MOM + real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%G)), & + intent(inout) :: h_pre !< layer thicknesses before advection + real, dimension(SZIB_(CS%G),SZJ_(CS%G),SZK_(CS%G)), & + intent(inout) :: uhtr !< Zonal mass transport + real, dimension(SZI_(CS%G),SZJB_(CS%G),SZK_(CS%G)), & + intent(inout) :: vhtr !< Meridional mass transport + logical, intent(in ) :: converged !< True if the iterations have converged type(ocean_grid_type), pointer :: G => NULL() ! Pointer to a structure containing ! metrics and related information @@ -409,6 +434,7 @@ subroutine offline_redistribute_residual(CS, h_pre, uhtr, vhtr, converged) real, dimension(SZIB_(CS%G),SZJ_(CS%G),SZK_(CS%G)) :: uhr !< Zonal mass transport real, dimension(SZI_(CS%G),SZJB_(CS%G),SZK_(CS%G)) :: vhr !< Meridional mass transport + character(len=256) :: mesg ! The text of an error message integer :: i, j, k, m, is, ie, js, je, isd, ied, jsd, jed, nz, iter real :: prev_tot_residual, tot_residual, stock_values(MAX_FIELDS_) integer :: nstocks @@ -425,7 +451,7 @@ subroutine offline_redistribute_residual(CS, h_pre, uhtr, vhtr, converged) if (CS%id_eta_pre_distribute>0) then eta_work(:,:) = 0.0 do k=1,nz ; do j=js,je ; do i=is,ie - if (h_pre(i,j,k)>GV%Angstrom) then + if (h_pre(i,j,k)>GV%Angstrom_H) then eta_work(i,j) = eta_work(i,j) + h_pre(i,j,k) endif enddo ; enddo ; enddo @@ -541,9 +567,8 @@ subroutine offline_redistribute_residual(CS, h_pre, uhtr, vhtr, converged) ! Check to see if all transport has been exhausted tot_residual = remaining_transport_sum(CS, uhtr, vhtr) if (CS%print_adv_offline) then - if (is_root_pe()) then - write(*,'(A,ES24.16)') "Residual advection remaining transport: ", tot_residual - endif + write(mesg,'(A,ES24.16)') "Residual advection remaining transport: ", tot_residual + call MOM_mesg(mesg) endif ! If the remaining residual is 0, then this return is done if (tot_residual==0.0 ) then @@ -559,7 +584,7 @@ subroutine offline_redistribute_residual(CS, h_pre, uhtr, vhtr, converged) if (CS%id_eta_post_distribute>0) then eta_work(:,:) = 0.0 do k=1,nz ; do j=js,je ; do i=is,ie - if (h_pre(i,j,k)>GV%Angstrom) then + if (h_pre(i,j,k)>GV%Angstrom_H) then eta_work(i,j) = eta_work(i,j) + h_pre(i,j,k) endif enddo ; enddo ; enddo @@ -607,7 +632,7 @@ real function remaining_transport_sum(CS, uhtr, vhtr) if (ABS(vhtr(i,J,k))>vh_neglect) then remaining_transport_sum = remaining_transport_sum + ABS(vhtr(i,J,k)) endif - enddo; enddo; enddo + enddo ; enddo ; enddo call sum_across_PEs(remaining_transport_sum) end function remaining_transport_sum @@ -617,15 +642,18 @@ end function remaining_transport_sum !! vertical diffuvities and source/sink terms. subroutine offline_diabatic_ale(fluxes, Time_start, Time_end, CS, h_pre, eatr, ebtr) - type(forcing), intent(inout) :: fluxes !< pointers to forcing fields - type(time_type), intent(in) :: Time_start !< starting time of a segment, as a time type - type(time_type), intent(in) :: Time_end !< time interval - type(offline_transport_CS), pointer :: CS !< control structure from initialize_MOM - real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%G)), intent(inout) :: h_pre - real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%G)), intent(inout) :: eatr !< Entrainment from layer above - real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%G)), intent(inout) :: ebtr !< Entrainment from layer below - real, dimension(SZI_(CS%G),SZJ_(CS%G)) :: sw, sw_vis, sw_nir !< Save old value of shortwave radiation + type(forcing), intent(inout) :: fluxes !< pointers to forcing fields + type(time_type), intent(in) :: Time_start !< starting time of a segment, as a time type + type(time_type), intent(in) :: Time_end !< time interval + type(offline_transport_CS), pointer :: CS !< control structure from initialize_MOM + real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%G)), & + intent(inout) :: h_pre !< layer thicknesses before advection [H ~> m or kg m-2] + real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%G)), & + intent(inout) :: eatr !< Entrainment from layer above [H ~> m or kg m-2] + real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%G)), & + intent(inout) :: ebtr !< Entrainment from layer below [H ~> m or kg m-2] + real, dimension(SZI_(CS%G),SZJ_(CS%G)) :: sw, sw_vis, sw_nir !< Save old value of shortwave radiation real :: hval integer :: i,j,k integer :: is, ie, js, je, nz @@ -638,7 +666,7 @@ subroutine offline_diabatic_ale(fluxes, Time_start, Time_end, CS, h_pre, eatr, e call cpu_clock_begin(CS%id_clock_offline_diabatic) - if (is_root_pe()) write (0,*) "Applying tracer source, sinks, and vertical mixing" + call MOM_mesg("Applying tracer source, sinks, and vertical mixing") if (CS%debug) then call hchksum(h_pre,"h_pre before offline_diabatic_ale",CS%G%HI) @@ -717,13 +745,15 @@ end subroutine offline_diabatic_ale !> Apply positive freshwater fluxes (into the ocean) and update netMassOut with only the negative !! (out of the ocean) fluxes subroutine offline_fw_fluxes_into_ocean(G, GV, CS, fluxes, h, in_flux_optional) - type(offline_transport_CS), intent(inout) :: CS !< Offline control structure - type(ocean_grid_type), intent(in) :: G !< Grid structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(forcing), intent(inout) :: fluxes !< Surface fluxes container - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thickness in H units - !> The total time-integrated amount of tracer that leaves with freshwater - real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: in_flux_optional + type(offline_transport_CS), intent(inout) :: CS !< Offline control structure + type(ocean_grid_type), intent(in) :: G !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(forcing), intent(inout) :: fluxes !< Surface fluxes container + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(in) :: in_flux_optional !< The total time-integrated amount + !! of tracer that leaves with freshwater integer :: i, j, m real, dimension(SZI_(G),SZJ_(G)) :: negative_fw !< store all negative fluxes @@ -765,13 +795,15 @@ end subroutine offline_fw_fluxes_into_ocean !> Apply negative freshwater fluxes (out of the ocean) subroutine offline_fw_fluxes_out_ocean(G, GV, CS, fluxes, h, out_flux_optional) - type(offline_transport_CS), intent(inout) :: CS !< Offline control structure - type(ocean_grid_type), intent(in) :: G !< Grid structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(forcing), intent(inout) :: fluxes !< Surface fluxes container - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thickness in H units - !> The total time-integrated amount of tracer that leaves with freshwater - real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: out_flux_optional + type(offline_transport_CS), intent(inout) :: CS !< Offline control structure + type(ocean_grid_type), intent(in) :: G !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(forcing), intent(inout) :: fluxes !< Surface fluxes container + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(in) :: out_flux_optional !< The total time-integrated amount + !! of tracer that leaves with freshwater integer :: m logical :: update_h !< Flag for whether h should be updated @@ -838,6 +870,7 @@ subroutine offline_advection_layer(fluxes, Time_start, time_interval, CS, h_pre, integer :: niter, iter real :: Inum_iter, dt_iter logical :: converged + character(len=160) :: mesg ! The text of an error message integer :: i, j, k, m, is, ie, js, je, isd, ied, jsd, jed, nz integer :: isv, iev, jsv, jev ! The valid range of the indices. integer :: IsdB, IedB, JsdB, JedB @@ -852,15 +885,15 @@ subroutine offline_advection_layer(fluxes, Time_start, time_interval, CS, h_pre, do k = 1, nz ; do j=js-1,je+1 ; do i=is-1,ie+1 eatr_sub(i,j,k) = eatr(i,j,k) ebtr_sub(i,j,k) = ebtr(i,j,k) - enddo; enddo ; enddo + enddo ; enddo ; enddo do k = 1, nz ; do j=js-1,je+1 ; do i=is-2,ie+1 uhtr_sub(I,j,k) = uhtr(I,j,k) - enddo; enddo ; enddo + enddo ; enddo ; enddo do k = 1, nz ; do j=js-2,je+1 ; do i=is-1,ie+1 vhtr_sub(i,J,k) = vhtr(i,J,k) - enddo; enddo ; enddo + enddo ; enddo ; enddo ! Calculate 3d mass transports to be used in this iteration @@ -881,7 +914,7 @@ subroutine offline_advection_layer(fluxes, Time_start, time_interval, CS, h_pre, call update_h_horizontal_flux(G, GV, uhtr_sub, vhtr_sub, h_pre, h_new) do k = 1, nz ; do i = is-1, ie+1 ; do j=js-1, je+1 h_vol(i,j,k) = h_pre(i,j,k)*G%areaT(i,j) - enddo; enddo; enddo + enddo ; enddo ; enddo call advect_tracer(h_pre, uhtr_sub, vhtr_sub, CS%OBC, dt_iter, G, GV, & CS%tracer_adv_CSp, CS%tracer_Reg, h_vol, max_iter_in=30, x_first_in=x_before_y) @@ -898,7 +931,7 @@ subroutine offline_advection_layer(fluxes, Time_start, time_interval, CS, h_pre, call update_h_horizontal_flux(G, GV, uhtr_sub, vhtr_sub, h_pre, h_new) do k = 1, nz ; do i = is-1, ie+1 ; do j=js-1, je+1 h_vol(i,j,k) = h_pre(i,j,k)*G%areaT(i,j) - enddo; enddo; enddo + enddo ; enddo ; enddo call advect_tracer(h_pre, uhtr_sub, vhtr_sub, CS%OBC, dt_iter, G, GV, & CS%tracer_adv_CSp, CS%tracer_Reg, h_vol, max_iter_in=30, x_first_in=x_before_y) @@ -922,15 +955,15 @@ subroutine offline_advection_layer(fluxes, Time_start, time_interval, CS, h_pre, do k = 1, nz ; do j=js-1,je+1 ; do i=is-1,ie+1 eatr(i,j,k) = eatr(i,j,k) - eatr_sub(i,j,k) ebtr(i,j,k) = ebtr(i,j,k) - ebtr_sub(i,j,k) - enddo; enddo ; enddo + enddo ; enddo ; enddo do k = 1, nz ; do j=js-1,je+1 ; do i=is-2,ie+1 uhtr(I,j,k) = uhtr(I,j,k) - uhtr_sub(I,j,k) - enddo; enddo ; enddo + enddo ; enddo ; enddo do k = 1, nz ; do j=js-2,je+1 ; do i=is-1,ie+1 vhtr(i,J,k) = vhtr(i,J,k) - vhtr_sub(i,J,k) - enddo; enddo ; enddo + enddo ; enddo ; enddo call pass_var(eatr,G%Domain) call pass_var(ebtr,G%Domain) @@ -946,19 +979,21 @@ subroutine offline_advection_layer(fluxes, Time_start, time_interval, CS, h_pre, sum_v = sum_v + abs(vhtr(i,J-1,k))+abs(vhtr(I,J,k)) sum_abs_fluxes = sum_abs_fluxes + abs(eatr(i,j,k)) + abs(ebtr(i,j,k)) + abs(uhtr(I-1,j,k)) + & abs(uhtr(I,j,k)) + abs(vhtr(i,J-1,k)) + abs(vhtr(i,J,k)) - enddo; enddo; enddo + enddo ; enddo ; enddo call sum_across_PEs(sum_abs_fluxes) - print *, "Remaining u-flux, v-flux:", sum_u, sum_v + write(mesg,*) "offline_advection_layer: Remaining u-flux, v-flux:", sum_u, sum_v + call MOM_mesg(mesg) if (sum_abs_fluxes==0) then - print *, 'Converged after iteration', iter + write(mesg,*) 'offline_advection_layer: Converged after iteration', iter + call MOM_mesg(mesg) exit endif ! Switch order of Strang split every iteration z_first = .not. z_first x_before_y = .not. x_before_y - end do + enddo end subroutine offline_advection_layer @@ -1023,28 +1058,28 @@ subroutine update_offline_fields(CS, h, fluxes, do_ale) ! Apply masks/factors at T, U, and V points do k=1,nz ; do j=js,je ; do i=is,ie if (CS%G%mask2dT(i,j)<1.0) then - CS%h_end(i,j,k) = CS%GV%Angstrom + CS%h_end(i,j,k) = CS%GV%Angstrom_H endif - enddo; enddo ; enddo + enddo ; enddo ; enddo do k=1,nz+1 ; do j=js,je ; do i=is,ie CS%Kd(i,j,k) = max(0.0, CS%Kd(i,j,k)) if (CS%Kd_max>0.) then CS%Kd(i,j,k) = MIN(CS%Kd_max, CS%Kd(i,j,k)) endif - enddo ; enddo ; enddo ; + enddo ; enddo ; enddo do k=1,nz ; do J=js-1,je ; do i=is,ie if (CS%G%mask2dCv(i,J)<1.0) then CS%vhtr(i,J,k) = 0.0 endif - enddo; enddo ; enddo + enddo ; enddo ; enddo do k=1,nz ; do j=js,je ; do I=is-1,ie if (CS%G%mask2dCu(I,j)<1.0) then CS%uhtr(I,j,k) = 0.0 endif - enddo; enddo ; enddo + enddo ; enddo ; enddo if (CS%debug) then call uvchksum("[uv]htr_sub after update_offline_fields", CS%uhtr, CS%vhtr, CS%G%HI) @@ -1061,9 +1096,9 @@ end subroutine update_offline_fields !> Initialize additional diagnostics required for offline tracer transport subroutine register_diags_offline_transport(Time, diag, CS) - type(offline_transport_CS), pointer :: CS !< Control structure for offline module - type(time_type), intent(in) :: Time !< current model time - type(diag_ctrl), intent(in) :: diag + type(offline_transport_CS), pointer :: CS !< Control structure for offline module + type(time_type), intent(in) :: Time !< current model time + type(diag_ctrl), intent(in) :: diag !< Structure that regulates diagnostic output ! U-cell fields CS%id_uhr = register_diag_field('ocean_model', 'uhr', diag%axesCuL, Time, & @@ -1152,15 +1187,21 @@ subroutine extract_offline_main(CS, uhtr, vhtr, eatr, ebtr, h_end, accumulated_t dt_offline, dt_offline_vertical, skip_diffusion) type(offline_transport_CS), target, intent(in ) :: CS !< Offline control structure ! Returned optional arguments - real, dimension(:,:,:), optional, pointer :: uhtr !< Remaining zonal mass transport - real, dimension(:,:,:), optional, pointer :: vhtr !< Remaining meridional mass transport - real, dimension(:,:,:), optional, pointer :: eatr - real, dimension(:,:,:), optional, pointer :: ebtr - real, dimension(:,:,:), optional, pointer :: h_end - integer, optional, pointer :: accumulated_time - integer, optional, intent( out) :: dt_offline - integer, optional, intent( out) :: dt_offline_vertical - logical, optional, intent( out) :: skip_diffusion + real, dimension(:,:,:), optional, pointer :: uhtr !< Remaining zonal mass transport [H m2 ~> m3 or kg] + real, dimension(:,:,:), optional, pointer :: vhtr !< Remaining meridional mass transport [H m2 ~> m3 or kg] + real, dimension(:,:,:), optional, pointer :: eatr !< Amount of fluid entrained from the layer above within + !! one time step [H ~> m or kg m-2] + real, dimension(:,:,:), optional, pointer :: ebtr !< Amount of fluid entrained from the layer below within + !! one time step [H ~> m or kg m-2] + real, dimension(:,:,:), optional, pointer :: h_end !< Thicknesses at the end of offline timestep + !! [H ~> m or kg m-2] + !### Why are the following variables integers? + integer, optional, pointer :: accumulated_time !< Length of time accumulated in the + !! current offline interval [s] + integer, optional, intent( out) :: dt_offline !< Timestep used for offline tracers [s] + integer, optional, intent( out) :: dt_offline_vertical !< Timestep used for calls to tracer + !! vertical physics [s] + logical, optional, intent( out) :: skip_diffusion !< Skips horizontal diffusion of tracers ! Pointers to 3d members if (present(uhtr)) uhtr => CS%uhtr @@ -1183,20 +1224,30 @@ end subroutine extract_offline_main !! are optional except for the CS itself subroutine insert_offline_main(CS, ALE_CSp, diabatic_CSp, diag, OBC, tracer_adv_CSp, & tracer_flow_CSp, tracer_Reg, tv, G, GV, x_before_y, debug) - type(offline_transport_CS), intent(inout) :: CS !< Offline control structure + type(offline_transport_CS), intent(inout) :: CS !< Offline control structure ! Inserted optional arguments - type(ALE_CS), target, optional, intent(in ) :: ALE_CSp - type(diabatic_CS), target, optional, intent(in ) :: diabatic_CSp - type(diag_ctrl), target, optional, intent(in ) :: diag - type(ocean_OBC_type), target, optional, intent(in ) :: OBC - type(tracer_advect_CS), target, optional, intent(in ) :: tracer_adv_CSp - type(tracer_flow_control_CS), target, optional, intent(in ) :: tracer_flow_CSp - type(tracer_registry_type), target, optional, intent(in ) :: tracer_Reg - type(thermo_var_ptrs), target, optional, intent(in ) :: tv - type(ocean_grid_type), target, optional, intent(in ) :: G !< ocean grid structure - type(verticalGrid_type), target, optional, intent(in ) :: GV !< ocean vertical grid structure - logical, optional, intent(in ) :: x_before_y - logical, optional, intent(in ) :: debug + type(ALE_CS), & + target, optional, intent(in ) :: ALE_CSp !< A pointer to the ALE control structure + type(diabatic_CS), & + target, optional, intent(in ) :: diabatic_CSp !< A pointer to the diabatic control structure + type(diag_ctrl), & + target, optional, intent(in ) :: diag !< A pointer to the structure that regulates diagnostic output + type(ocean_OBC_type), & + target, optional, intent(in ) :: OBC !< A pointer to the open boundary condition control structure + type(tracer_advect_CS), & + target, optional, intent(in ) :: tracer_adv_CSp !< A pointer to the tracer advection control structure + type(tracer_flow_control_CS), & + target, optional, intent(in ) :: tracer_flow_CSp !< A pointer to the tracer flow control control structure + type(tracer_registry_type), & + target, optional, intent(in ) :: tracer_Reg !< A pointer to the tracer registry + type(thermo_var_ptrs), & + target, optional, intent(in ) :: tv !< A structure pointing to various thermodynamic variables + type(ocean_grid_type), & + target, optional, intent(in ) :: G !< ocean grid structure + type(verticalGrid_type), & + target, optional, intent(in ) :: GV !< ocean vertical grid structure + logical, optional, intent(in ) :: x_before_y !< Indicates which horizontal direction is advected first + logical, optional, intent(in ) :: debug !< If true, write verbose debugging messages if (present(ALE_CSp)) CS%ALE_CSp => ALE_CSp @@ -1218,9 +1269,9 @@ end subroutine insert_offline_main ! run time parameters from MOM_input subroutine offline_transport_init(param_file, CS, diabatic_CSp, G, GV) - type(param_file_type), intent(in) :: param_file + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(offline_transport_CS), pointer :: CS !< Offline control structure - type(diabatic_CS), intent(in) :: diabatic_CSp + type(diabatic_CS), intent(in) :: diabatic_CSp !< The diabatic control structure type(ocean_grid_type), target, intent(in) :: G !< ocean grid structure type(verticalGrid_type), target, intent(in) :: GV !< ocean vertical grid structure @@ -1410,7 +1461,7 @@ subroutine read_all_input(CS) allocate(CS%temp_all(isd:ied,jsd:jed,nz,1:ntime)) ; CS%temp_all(:,:,:,:) = 0.0 allocate(CS%salt_all(isd:ied,jsd:jed,nz,1:ntime)) ; CS%salt_all(:,:,:,:) = 0.0 - if (is_root_pe()) write (0,*) "Reading in uhtr, vhtr, h_start, h_end, temp, salt" + call MOM_mesg("Reading in uhtr, vhtr, h_start, h_end, temp, salt") do t = 1,ntime call MOM_read_vector(CS%snap_file, 'uhtr_sum', 'vhtr_sum', CS%uhtr_all(:,:,1:CS%nk_input,t), & CS%vhtr_all(:,:,1:CS%nk_input,t), CS%G%Domain, timelevel=t) diff --git a/src/tracer/MOM_tracer_Z_init.F90 b/src/tracer/MOM_tracer_Z_init.F90 index 9a86d25c9c..dd44fb15b2 100644 --- a/src/tracer/MOM_tracer_Z_init.F90 +++ b/src/tracer/MOM_tracer_Z_init.F90 @@ -1,33 +1,14 @@ +!> Used to initialize tracers from a depth- (or z*-) space file. module MOM_tracer_Z_init ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Robert Hallberg, September 2009 * -!* * -!* This file contains a subroutine to initialize tracers into the * -!* MOM vertical grid from a depth- (or z*-) space file. * -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: * -!* j+1 > o > o > At ^: * -!* j x ^ x ^ x At >: * -!* j > o > o > At o: tr * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** - 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 use MOM_io, only : MOM_read_data +use MOM_unit_scaling, only : unit_scale_type use netcdf @@ -37,28 +18,32 @@ module MOM_tracer_Z_init public tracer_Z_init +! 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. + contains -function tracer_Z_init(tr, h, filename, tr_name, G, missing_val, land_val) - logical :: tracer_Z_init - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: tr - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - character(len=*), intent(in) :: filename, tr_name -! type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - real, optional, intent(in) :: missing_val - real, optional, intent(in) :: land_val -! This function initializes a tracer by reading a Z-space file, returning -! .true. if this appears to have been successful, and false otherwise. -! Arguments: tr - The tracer to initialize. -! (in) h - Layer thickness, in m or kg m-2. -! (in) filename - The name of the file to read from. -! (in) tr_name - The name of the tracer in the file. -! (in) G - The ocean's grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in,opt) missing_val - The missing value for the tracer. -! (in,opt) land_val - The value to use to fill in land points. +!> This function initializes a tracer by reading a Z-space file, returning +!! .true. if this appears to have been successful, and false otherwise. +function tracer_Z_init(tr, h, filename, tr_name, G, US, missing_val, land_val) + logical :: tracer_Z_init !< A return code indicating if the initialization has been successful + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(out) :: tr !< The tracer to initialize + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + character(len=*), intent(in) :: filename !< The name of the file to read from + character(len=*), intent(in) :: tr_name !< The name of the tracer in the file +! type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + real, optional, intent(in) :: missing_val !< The missing value for the tracer + real, optional, intent(in) :: land_val !< A value to use to fill in land points + + ! This function initializes a tracer by reading a Z-space file, returning true if this + ! appears to have been successful, and false otherwise. +! integer, save :: init_calls = 0 ! This include declares and sets the variable "version". #include "version_variable.h" @@ -69,7 +54,7 @@ function tracer_Z_init(tr, h, filename, tr_name, G, missing_val, land_val) tr_in ! The z-space array of tracer concentrations that is read in. real, allocatable, dimension(:) :: & z_edges, & ! The depths of the cell edges or cell centers (depending on - ! the value of has_edges) in the input z* data. + ! the value of has_edges) in the input z* data [Z ~> m]. tr_1d, & ! A copy of the input tracer concentrations in a column. wt, & ! The fractional weight for each layer in the range between ! k_top and k_bot, nondim. @@ -77,14 +62,14 @@ function tracer_Z_init(tr, h, filename, tr_name, G, missing_val, land_val) z2 ! of a z-cell that contributes to a layer, relative to the cell ! center and normalized by the cell thickness, nondim. ! Note that -1/2 <= z1 <= z2 <= 1/2. - real :: e(SZK_(G)+1) ! The z-star interface heights in m. + real :: e(SZK_(G)+1) ! The z-star interface heights [Z ~> m]. real :: landval ! The tracer value to use in land points. real :: sl_tr ! The normalized slope of the tracer ! within the cell, in tracer units. - real :: htot(SZI_(G)) ! The vertical sum of h, in m or kg m-2. + real :: htot(SZI_(G)) ! The vertical sum of h [H ~> m or kg m-2]. real :: dilate ! The amount by which the thicknesses are dilated to ! create a z-star coordinate, nondim or in m3 kg-1. - real :: missing ! The missing value for the tracer. + real :: missing ! The missing value for the tracer. logical :: has_edges, use_missing, zero_surface character(len=80) :: loc_msg @@ -103,7 +88,8 @@ function tracer_Z_init(tr, h, filename, tr_name, G, missing_val, land_val) ! Find out the number of input levels and read the depth of the edges, ! also modifying their sign convention to be monotonically decreasing. - call read_Z_edges(filename, tr_name, z_edges, nz_in, has_edges, use_missing, missing) + call read_Z_edges(filename, tr_name, z_edges, nz_in, has_edges, use_missing, & + missing, scale=US%m_to_Z) if (nz_in < 1) then tracer_Z_init = .false. return @@ -288,28 +274,24 @@ function tracer_Z_init(tr, h, filename, tr_name, G, missing_val, land_val) end function tracer_Z_init - +!> This subroutine reads the vertical coordinate data for a field from a NetCDF file. +!! It also might read the missing value attribute for that same field. subroutine read_Z_edges(filename, tr_name, z_edges, nz_out, has_edges, & - use_missing, missing) - character(len=*), intent(in) :: filename, tr_name - real, allocatable, dimension(:), intent(out) :: z_edges - integer, intent(out) :: nz_out - logical, intent(out) :: has_edges - logical, intent(inout) :: use_missing - real, intent(inout) :: missing -! This subroutine reads the vertical coordinate data for a field from a -! NetCDF file. It also might read the missing value attribute for that -! same field. -! Arguments: filename - The file to be read from. -! (in) tr_name - The name of the tracer to be read. -! (out) z_edges - The depths of the vertical edges of the tracer array. -! (out) nz_out - The number of vertical layers in the tracer array. -! (out) has_edges - If true, the values in z_edges are the edges of the -! tracer cells, otherwise they are the cell centers. -! (inout) use_missing - If false on input, see whether the tracer has a -! missing value, and if so return true. -! (inout) missing - The missing value, if one has been found. - + use_missing, missing, scale) + character(len=*), intent(in) :: filename !< The name of the file to read from. + character(len=*), intent(in) :: tr_name !< The name of the tracer in the file. + real, dimension(:), allocatable, & + intent(out) :: z_edges !< The depths of the vertical edges of the tracer array + integer, intent(out) :: nz_out !< The number of vertical layers in the tracer array + logical, intent(out) :: has_edges !< If true the values in z_edges are the edges of the + !! tracer cells, otherwise they are the cell centers + logical, intent(inout) :: use_missing !< If false on input, see whether the tracer has a + !! missing value, and if so return true + real, intent(inout) :: missing !< The missing value, if one has been found + real, intent(in) :: scale !< A scaling factor for z_edges into new units. + + ! This subroutine reads the vertical coordinate data for a field from a + ! NetCDF file. It also might read the missing value attribute for that same field. character(len=32) :: mdl character(len=120) :: dim_name, edge_name, tr_msg, dim_msg logical :: monotonic @@ -319,7 +301,7 @@ subroutine read_Z_edges(filename, tr_name, z_edges, nz_out, has_edges, & mdl = "MOM_tracer_Z_init read_Z_edges: " tr_msg = trim(tr_name)//" in "//trim(filename) - status = NF90_OPEN(filename, NF90_NOWRITE, ncid); + status = NF90_OPEN(filename, NF90_NOWRITE, ncid) if (status /= NF90_NOERR) then call MOM_error(WARNING,mdl//" Difficulties opening "//trim(filename)//& " - "//trim(NF90_STRERROR(status))) @@ -415,6 +397,8 @@ subroutine read_Z_edges(filename, tr_name, z_edges, nz_out, has_edges, & if (.not.monotonic) & call MOM_error(WARNING,mdl//" "//trim(dim_msg)//" is not monotonic.") + if (scale /= 1.0) then ; do k=1,nz_edge ; z_edges(k) = scale*z_edges(k) ; enddo ; endif + end subroutine read_Z_edges diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index db54e599c6..201f8aeb6f 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -28,18 +28,20 @@ module MOM_tracer_advect !> Control structure for this module type, public :: tracer_advect_CS ; private - real :: dt !< The baroclinic dynamics time step, in s. + real :: dt !< The baroclinic dynamics time step [s]. type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the !< timing of diagnostic output. logical :: debug !< If true, write verbose checksums for debugging purposes. logical :: usePPM !< If true, use PPM instead of PLM logical :: useHuynh !< If true, use the Huynh scheme for PPM interface values - type(group_pass_type) :: pass_uhr_vhr_t_hprev ! For group pass + type(group_pass_type) :: pass_uhr_vhr_t_hprev !< A structred used for group passes end type tracer_advect_CS +!>@{ CPU time clocks integer :: id_clock_advect integer :: id_clock_pass integer :: id_clock_sync +!!@} contains @@ -47,35 +49,45 @@ module MOM_tracer_advect !! monotonic, conservative, weakly diffusive scheme. subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, CS, Reg, & h_prev_opt, max_iter_in, x_first_in, uhr_out, vhr_out, h_out) - type(ocean_grid_type), intent(inout) :: G !< ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_end !< layer thickness after advection (m or kg m-2) - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: uhtr !< accumulated volume/mass flux through zonal face (m3 or kg) - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: vhtr !< accumulated volume/mass flux through merid face (m3 or kg) - type(ocean_OBC_type), pointer :: OBC !< specifies whether, where, and what OBCs are used - real, intent(in) :: dt !< time increment (seconds) - type(tracer_advect_CS), pointer :: CS !< control structure for module - type(tracer_registry_type), pointer :: Reg !< pointer to tracer registry - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional :: h_prev_opt !< layer thickness before advection (m or kg m-2) - integer, optional :: max_iter_in - logical, optional :: x_first_in - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: uhr_out !< accumulated volume/mass flux through zonal face (m3 or kg) - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), optional, intent(out) :: vhr_out !< accumulated volume/mass flux through merid face (m3 or kg) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional :: h_out !< layer thickness before advection (m or kg m-2) + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_end !< layer thickness after advection [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(in) :: uhtr !< accumulated volume/mass flux through zonal face [H m2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(in) :: vhtr !< accumulated volume/mass flux through merid face [H m2 ~> m3 or kg] + type(ocean_OBC_type), pointer :: OBC !< specifies whether, where, and what OBCs are used + real, intent(in) :: dt !< time increment [s] + type(tracer_advect_CS), pointer :: CS !< control structure for module + type(tracer_registry_type), pointer :: Reg !< pointer to tracer registry + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + optional, intent(in) :: h_prev_opt !< layer thickness before advection [H ~> m or kg m-2] + integer, optional, intent(in) :: max_iter_in !< The maximum number of iterations + logical, optional, intent(in) :: x_first_in !< If present, indicate whether to update + !! first in the x- or y-direction. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + optional, intent(out) :: uhr_out !< accumulated volume/mass flux through zonal face + !! [H m2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + optional, intent(out) :: vhr_out !< accumulated volume/mass flux through merid face + !! [H m2 ~> m3 or kg] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + optional, intent(out) :: h_out !< layer thickness before advection [H ~> m or kg m-2] type(tracer_type) :: Tr(MAX_FIELDS_) ! The array of registered tracers real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & - hprev ! cell volume at the end of previous tracer change (m3) + hprev ! cell volume at the end of previous tracer change [H m2 ~> m3 or kg] real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: & - uhr ! The remaining zonal thickness flux (m3) + uhr ! The remaining zonal thickness flux [H m2 ~> m3 or kg] real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: & - vhr ! The remaining meridional thickness fluxes (m3) + vhr ! The remaining meridional thickness fluxes [H m2 ~> m3 or kg] real :: uh_neglect(SZIB_(G),SZJ_(G)) ! uh_neglect and vh_neglect are the real :: vh_neglect(SZI_(G),SZJB_(G)) ! magnitude of remaining transports that - ! can be simply discarded (m3 or kg). + ! can be simply discarded [H m2 ~> m3 or kg]. - real :: landvolfill ! An arbitrary? nonzero cell volume, m3. - real :: Idt ! 1/dt in s-1. + real :: landvolfill ! An arbitrary? nonzero cell volume [H m2 ~> m3 or kg]. + real :: Idt ! 1/dt [s-1]. logical :: domore_u(SZJ_(G),SZK_(G)) ! domore__ indicate whether there is more logical :: domore_v(SZJB_(G),SZK_(G)) ! advection to be done in the corresponding ! row or column. @@ -113,8 +125,8 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, CS, Reg, & max_iter = 2*INT(CEILING(dt/CS%dt)) + 1 - if(present(max_iter_in)) max_iter = max_iter_in - if(present(x_first_in)) x_first = x_first_in + if (present(max_iter_in)) max_iter = max_iter_in + if (present(x_first_in)) x_first = x_first_in call cpu_clock_begin(id_clock_pass) call create_group_pass(CS%pass_uhr_vhr_t_hprev, uhr, vhr, G%Domain) call create_group_pass(CS%pass_uhr_vhr_t_hprev, hprev, G%Domain) @@ -154,7 +166,7 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, CS, Reg, & enddo ; enddo else do i=is,ie ; do j=js,je - hprev(i,j,k) = h_prev_opt(i,j,k); + hprev(i,j,k) = h_prev_opt(i,j,k) enddo ; enddo endif enddo @@ -301,9 +313,9 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, CS, Reg, & enddo ! Iterations loop - if(present(uhr_out)) uhr_out(:,:,:) = uhr(:,:,:) - if(present(vhr_out)) vhr_out(:,:,:) = vhr(:,:,:) - if(present(h_out)) h_out(:,:,:) = hprev(:,:,:) + if (present(uhr_out)) uhr_out(:,:,:) = uhr(:,:,:) + if (present(vhr_out)) vhr_out(:,:,:) = vhr(:,:,:) + if (present(h_out)) h_out(:,:,:) = hprev(:,:,:) call cpu_clock_end(id_clock_advect) @@ -316,37 +328,47 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & is, ie, js, je, k, G, GV, usePPM, useHuynh) 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(tracer_type), dimension(ntr), intent(inout) :: Tr - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: hprev + type(tracer_type), dimension(ntr), intent(inout) :: Tr !< The array of registered tracers to work on + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: hprev !< cell volume at the end of previous + !! tracer change [H m2 ~> m3 or kg] real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: uhr !< accumulated volume/mass flux through - !!the zonal face (m3 or kg) - real, dimension(SZIB_(G),SZJ_(G)), intent(inout) :: uh_neglect - type(ocean_OBC_type), pointer :: OBC - logical, dimension(SZJ_(G),SZK_(G)), intent(inout) :: domore_u - real, intent(in) :: Idt - integer, intent(in) :: ntr, is, ie, js, je,k - logical, intent(in) :: usePPM, useHuynh + !! the zonal face [H m2 ~> m3 or kg] + real, dimension(SZIB_(G),SZJ_(G)), intent(inout) :: uh_neglect !< A tiny zonal mass flux that can + !! be neglected [H m2 ~> m3 or kg] + type(ocean_OBC_type), pointer :: OBC !< specifies whether, where, and what OBCs are used + logical, dimension(SZJ_(G),SZK_(G)), intent(inout) :: domore_u !< If true, there is more advection to be + !! done in this u-row + real, intent(in) :: Idt !< The inverse of dt [s-1] + integer, intent(in) :: ntr !< The number of tracers + integer, intent(in) :: is !< The starting tracer i-index to work on + integer, intent(in) :: ie !< The ending tracer i-index to work on + integer, intent(in) :: js !< The starting tracer j-index to work on + integer, intent(in) :: je !< The ending tracer j-index to work on + integer, intent(in) :: k !< The k-level to work on + logical, intent(in) :: usePPM !< If true, use PPM instead of PLM + logical, intent(in) :: useHuynh !< If true, use the Huynh scheme + !! for PPM interface values real, dimension(SZI_(G),ntr) :: & - slope_x ! The concentration slope per grid point in units of - ! concentration (nondim.). + slope_x ! The concentration slope per grid point [conc]. real, dimension(SZIB_(G),ntr) :: & - flux_x ! The tracer flux across a boundary in m3*conc or kg*conc. + flux_x ! The tracer flux across a boundary [H m2 conc ~> m3 conc or kg conc]. real :: maxslope ! The maximum concentration slope per grid point - ! consistent with monotonicity, in conc. (nondim.). + ! consistent with monotonicity [conc]. real :: hup, hlos ! hup is the upwind volume, hlos is the ! part of that volume that might be lost ! due to advection out the other side of - ! the grid box, both in m3 or kg. + ! the grid box, both in [H m2 ~> m3 or kg]. real :: uhh(SZIB_(G)) ! The zonal flux that occurs during the - ! current iteration, in m3 or kg. + ! current iteration [H m2 ~> m3 or kg]. real, dimension(SZIB_(G)) :: & - hlst, Ihnew, & ! Work variables with units of m3 or kg and m-3 or kg-1. - CFL ! A nondimensional work variable. + hlst, & ! Work variable [H m2 ~> m3 or kg]. + Ihnew, & ! Work variable [H-1 m-2 ~> m-3 or kg-1]. + CFL ! A nondimensional work variable [nondim]. real :: min_h ! The minimum thickness that can be realized during - ! any of the passes, in m or kg m-2. + ! any of the passes [H ~> m or kg m-2]. real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected, in m. + ! in roundoff and can be neglected [H ~> m or kg m-2]. logical :: do_i(SZIB_(G)) ! If true, work on given points. logical :: do_any_i integer :: i, j, m, n, i_up, stencil @@ -362,7 +384,7 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & stencil = 1 if (usePPM .and. .not. useHuynh) stencil = 2 - min_h = 0.1*GV%Angstrom + min_h = 0.1*GV%Angstrom_H h_neglect = GV%H_subroundoff dt=1.0/Idt @@ -544,13 +566,13 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & ishift=0 ! ishift+I corresponds to the nearest interior tracer cell index idir=1 ! idir switches the sign of the flow so that positive is into the reservoir if (segment%direction == OBC_DIRECTION_W) then - ishift=1 - idir=-1 + ishift=1 + idir=-1 endif ! update the reservoir tracer concentration implicitly ! using Backward-Euler timestep do m=1,ntr - if (associated(segment%tr_Reg%Tr(m)%tres)) then + if (associated(segment%tr_Reg%Tr(m)%tres)) then uhh(I)=uhr(I,j,k) u_L_in=max(idir*uhh(I)*segment%Tr_InvLscale3_in,0.) u_L_out=min(idir*uhh(I)*segment%Tr_InvLscale3_out,0.) @@ -558,21 +580,18 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & segment%tr_Reg%Tr(m)%tres(I,j,k)= (1.0/fac1)*(segment%tr_Reg%Tr(m)%tres(I,j,k) + & dt*(u_L_in*Tr(m)%t(I+ishift,j,k) - & u_L_out*segment%tr_Reg%Tr(m)%t(I,j,k))) -! if (j.eq.10 .and. segment%direction==OBC_DIRECTION_E .and. m==2 .and. k.eq.1) & -! print *,'tres=',segment%tr_Reg%Tr(m)%tres(I,j,k),& -! segment%tr_Reg%Tr(m)%t(I,j,k), fac1 endif enddo ! Tracer fluxes are set to prescribed values only for inflows from masked areas. if ((uhr(I,j,k) > 0.0) .and. (G%mask2dT(i,j) < 0.5) .or. & (uhr(I,j,k) < 0.0) .and. (G%mask2dT(i+1,j) < 0.5)) then - uhh(I) = uhr(I,j,k) - do m=1,ntr - if (associated(segment%tr_Reg%Tr(m)%tres)) then - flux_x(I,m) = uhh(I)*segment%tr_Reg%Tr(m)%tres(I,j,k) - else; flux_x(I,m) = uhh(I)*segment%tr_Reg%Tr(m)%OBC_inflow_conc; endif - enddo + uhh(I) = uhr(I,j,k) + do m=1,ntr + if (associated(segment%tr_Reg%Tr(m)%tres)) then + flux_x(I,m) = uhh(I)*segment%tr_Reg%Tr(m)%tres(I,j,k) + else; flux_x(I,m) = uhh(I)*segment%tr_Reg%Tr(m)%OBC_inflow_conc; endif + enddo endif endif enddo @@ -637,37 +656,47 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & is, ie, js, je, k, G, GV, usePPM, useHuynh) 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(tracer_type), dimension(ntr), intent(inout) :: Tr - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: hprev + type(tracer_type), dimension(ntr), intent(inout) :: Tr !< The array of registered tracers to work on + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: hprev !< cell volume at the end of previous + !! tracer change [H m2 ~> m3 or kg] real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: vhr !< accumulated volume/mass flux through - !! the meridional face (m3 or kg) - real, dimension(SZI_(G),SZJB_(G)), intent(inout) :: vh_neglect - type(ocean_OBC_type), pointer :: OBC - logical, dimension(SZJB_(G),SZK_(G)), intent(inout) :: domore_v - real, intent(in) :: Idt - integer, intent(in) :: ntr, is, ie, js, je,k - logical, intent(in) :: usePPM, useHuynh + !! the meridional face [H m2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G)), intent(inout) :: vh_neglect !< A tiny meridional mass flux that can + !! be neglected [H m2 ~> m3 or kg] + type(ocean_OBC_type), pointer :: OBC !< specifies whether, where, and what OBCs are used + logical, dimension(SZJB_(G),SZK_(G)), intent(inout) :: domore_v !< If true, there is more advection to be + !! done in this v-row + real, intent(in) :: Idt !< The inverse of dt [s-1] + integer, intent(in) :: ntr !< The number of tracers + integer, intent(in) :: is !< The starting tracer i-index to work on + integer, intent(in) :: ie !< The ending tracer i-index to work on + integer, intent(in) :: js !< The starting tracer j-index to work on + integer, intent(in) :: je !< The ending tracer j-index to work on + integer, intent(in) :: k !< The k-level to work on + logical, intent(in) :: usePPM !< If true, use PPM instead of PLM + logical, intent(in) :: useHuynh !< If true, use the Huynh scheme + !! for PPM interface values real, dimension(SZI_(G),ntr,SZJ_(G)) :: & - slope_y ! The concentration slope per grid point in units of - ! concentration (nondim.). + slope_y ! The concentration slope per grid point [conc]. real, dimension(SZI_(G),ntr,SZJB_(G)) :: & - flux_y ! The tracer flux across a boundary in m3 * conc or kg*conc. + flux_y ! The tracer flux across a boundary [H m2 conc ~> m3 conc or kg conc]. real :: maxslope ! The maximum concentration slope per grid point - ! consistent with monotonicity, in conc. (nondim.). + ! consistent with monotonicity [conc]. real :: vhh(SZI_(G),SZJB_(G)) ! The meridional flux that occurs during the - ! current iteration, in m3 or kg. + ! current iteration [H m2 ~> m3 or kg]. real :: hup, hlos ! hup is the upwind volume, hlos is the ! part of that volume that might be lost ! due to advection out the other side of - ! the grid box, both in m3 or kg. + ! the grid box, both in [H m2 ~> m3 or kg]. real, dimension(SZIB_(G)) :: & - hlst, Ihnew, & ! Work variables with units of m3 or kg and m-3 or kg-1. + hlst, & ! Work variable [H m2 ~> m3 or kg]. + Ihnew, & ! Work variable [H-1 m-2 ~> m-3 or kg-1]. CFL ! A nondimensional work variable. real :: min_h ! The minimum thickness that can be realized during - ! any of the passes, in m or kg m-2. + ! any of the passes [H ~> m or kg m-2]. real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected, in m. + ! in roundoff and can be neglected [H ~> m or kg m-2]. logical :: do_j_tr(SZJ_(G)) ! If true, calculate the tracer profiles. logical :: do_i(SZIB_(G)) ! If true, work on given points. logical :: do_any_i @@ -684,7 +713,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & stencil = 1 if (usePPM .and. .not. useHuynh) stencil = 2 - min_h = 0.1*GV%Angstrom + min_h = 0.1*GV%Angstrom_H h_neglect = GV%H_subroundoff dt=1.0/Idt !do i=is,ie ; ts2(i) = 0.0 ; enddo @@ -1021,7 +1050,7 @@ end subroutine tracer_advect_init !> Close the tracer advection module subroutine tracer_advect_end(CS) - type(tracer_advect_CS), pointer :: CS + type(tracer_advect_CS), pointer :: CS !< module control structure if (associated(CS)) deallocate(CS) diff --git a/src/tracer/MOM_tracer_diabatic.F90 b/src/tracer/MOM_tracer_diabatic.F90 index e68ff0df9e..f7f8028d91 100644 --- a/src/tracer/MOM_tracer_diabatic.F90 +++ b/src/tracer/MOM_tracer_diabatic.F90 @@ -15,50 +15,54 @@ module MOM_tracer_diabatic #include public tracer_vertdiff public applyTracerBoundaryFluxesInOut + +contains + !> This subroutine solves a tridiagonal equation for the final tracer !! concentrations after the dual-entrainments, and possibly sinking or surface !! and bottom sources, are applied. The sinking is implemented with an !! fully implicit upwind advection scheme. - -contains - subroutine tracer_vertdiff(h_old, ea, eb, dt, tr, G, GV, & sfc_flux, btm_flux, btm_reservoir, sink_rate, convert_flux_in) - type(ocean_grid_type), intent(in) :: G !< ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_old !< layer thickness before entrainment (m or kg m-2) - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: ea !< amount of fluid entrained from the layer above (units of h_work) - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: eb !< amount of fluid entrained from the layer below (units of h_work) - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: tr !< tracer concentration (in concentration units CU) - real, intent(in) :: dt !< amount of time covered by this call (seconds) - real, dimension(SZI_(G),SZJ_(G)), optional,intent(in) :: sfc_flux !< surface flux of the tracer (in CU * kg m-2 s-1) - real, dimension(SZI_(G),SZJ_(G)), optional,intent(in) :: btm_flux !< The (negative upward) bottom flux of the tracer, - !! in units of (CU * kg m-2 s-1) - real, dimension(SZI_(G),SZJ_(G)), optional,intent(inout) :: btm_reservoir !< amount of tracer in a bottom reservoir (units of CU kg m-2; formerly CU m) - real, optional,intent(in) :: sink_rate !< rate at which the tracer sinks, in m s-1 - logical, optional,intent(in) :: convert_flux_in !< True if the specified sfc_flux needs to be integrated in time - - real :: sink_dist ! The distance the tracer sinks in a time step, in m or kg m-2. + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_old !< layer thickness before entrainment + !! [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: ea !< amount of fluid entrained from the layer + !! above [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: eb !< amount of fluid entrained from the layer + !! below [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: tr !< tracer concentration in concentration units [CU] + real, intent(in) :: dt !< amount of time covered by this call [s] + real, dimension(SZI_(G),SZJ_(G)), optional,intent(in) :: sfc_flux !< surface flux of the tracer [CU kg m-2 s-1] + real, dimension(SZI_(G),SZJ_(G)), optional,intent(in) :: btm_flux !< The (negative upward) bottom flux of the + !! tracer [CU kg m-2 s-1] + real, dimension(SZI_(G),SZJ_(G)), optional,intent(inout) :: btm_reservoir !< amount of tracer in a bottom reservoir + !! [CU kg m-2]; formerly [CU m] + real, optional,intent(in) :: sink_rate !< rate at which the tracer sinks [m s-1] + logical, optional,intent(in) :: convert_flux_in !< True if the specified sfc_flux needs + !! to be integrated in time + + ! local variables + real :: sink_dist !< The distance the tracer sinks in a time step [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G)) :: & - sfc_src, & ! The time-integrated surface source of the tracer, in - ! units of m or kg m-2 times a concentration. - btm_src ! The time-integrated bottom source of the tracer, in - ! units of m or kg m-2 times a concentration. + sfc_src, & !< The time-integrated surface source of the tracer [CU H ~> CU m or CU kg m-2]. + btm_src !< The time-integrated bottom source of the tracer [CU H ~> CU m or CU kg m-2]. real, dimension(SZI_(G)) :: & - b1, & ! b1 is used by the tridiagonal solver, in m-1 or m2 kg-1. - d1 ! d1=1-c1 is used by the tridiagonal solver, nondimensional. - real :: c1(SZI_(G),SZK_(GV)) ! c1 is used by the tridiagonal solver, ND. - real :: h_minus_dsink(SZI_(G),SZK_(GV)) ! The layer thickness minus the - ! difference in sinking rates across the layer, in m or kg m-2. - ! By construction, 0 <= h_minus_dsink < h_work. - real :: sink(SZI_(G),SZK_(GV)+1) ! The tracer's sinking distances at the - ! interfaces, limited to prevent characteristics from - ! crossing within a single timestep, in m or kg m-2. - real :: b_denom_1 ! The first term in the denominator of b1, in m or kg m-2. - real :: h_tr ! h_tr is h at tracer points with a h_neglect added to - ! ensure positive definiteness, in m or kg m-2. - real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected, in m. + b1, & !< b1 is used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. + d1 !! d1=1-c1 is used by the tridiagonal solver, nondimensional. + real :: c1(SZI_(G),SZK_(GV)) !< c1 is used by the tridiagonal solver [nondim]. + real :: h_minus_dsink(SZI_(G),SZK_(GV)) !< The layer thickness minus the + !! difference in sinking rates across the layer [H ~> m or kg m-2]. + !! By construction, 0 <= h_minus_dsink < h_work. + real :: sink(SZI_(G),SZK_(GV)+1) !< The tracer's sinking distances at the + !! interfaces, limited to prevent characteristics from + !! crossing within a single timestep [H ~> m or kg m-2]. + real :: b_denom_1 !< The first term in the denominator of b1 [H ~> m or kg m-2]. + real :: h_tr !< h_tr is h at tracer points with a h_neglect added to + !! ensure positive definiteness [H ~> m or kg m-2]. + real :: h_neglect !< A thickness that is so small it is usually lost + !! in roundoff and can be neglected [H ~> m or kg m-2]. logical :: convert_flux = .true. @@ -80,31 +84,31 @@ subroutine tracer_vertdiff(h_old, ea, eb, dt, tr, G, GV, & !$OMP h_old,convert_flux,h_neglect,eb,tr) & !$OMP private(sink,h_minus_dsink,b_denom_1,b1,d1,h_tr,c1) !$OMP do - do j=js,je; do i=is,ie ; sfc_src(i,j) = 0.0 ; btm_src(i,j) = 0.0 ; enddo; enddo + do j=js,je; do i=is,ie ; sfc_src(i,j) = 0.0 ; btm_src(i,j) = 0.0 ; enddo ; enddo if (present(sfc_flux)) then - if(convert_flux) then + if (convert_flux) then !$OMP do do j = js, je; do i = is,ie sfc_src(i,j) = (sfc_flux(i,j)*dt) * GV%kg_m2_to_H - enddo; enddo + enddo ; enddo else !$OMP do do j = js, je; do i = is,ie sfc_src(i,j) = sfc_flux(i,j) - enddo; enddo + enddo ; enddo endif endif if (present(btm_flux)) then - if(convert_flux) then + if (convert_flux) then !$OMP do do j = js, je; do i = is,ie btm_src(i,j) = (btm_flux(i,j)*dt) * GV%kg_m2_to_H - enddo; enddo + enddo ; enddo else !$OMP do do j = js, je; do i = is,ie btm_src(i,j) = btm_flux(i,j) - enddo; enddo + enddo ; enddo endif endif @@ -222,36 +226,39 @@ subroutine applyTracerBoundaryFluxesInOut(G, GV, Tr, dt, fluxes, h, evap_CFL_lim type(ocean_grid_type), intent(in ) :: G !< Grid structure type(verticalGrid_type), intent(in ) :: GV !< ocean vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: Tr !< Tracer concentration on T-cell - real, intent(in ) :: dt !< Time-step over which forcing is applied (s) + real, intent(in ) :: dt !< Time-step over which forcing is applied [s] type(forcing), intent(in ) :: fluxes !< Surface fluxes container - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thickness in H units - real, intent(in ) :: evap_CFL_limit - real, intent(in ) :: minimum_forcing_depth - real, dimension(SZI_(G),SZJ_(G)), optional, intent(in ) :: in_flux_optional ! The total time-integrated amount of tracer! - ! that enters with freshwater - real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: out_flux_optional ! The total time-integrated amount of tracer! - ! that leaves with freshwater - !< Optional flag to determine whether h should be updated - logical, optional, intent(in) :: update_h_opt + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] + real, 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, intent(in ) :: minimum_forcing_depth !< The smallest depth over + !! which fluxes can be applied [m] + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in ) :: in_flux_optional !< The total time-integrated + !! amount of tracer that enters with freshwater + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: out_flux_optional !< The total time-integrated + !! amount of tracer that leaves with freshwater + logical, optional, intent(in) :: update_h_opt !< Optional flag to determine whether + !! h should be updated integer, parameter :: maxGroundings = 5 integer :: numberOfGroundings, iGround(maxGroundings), jGround(maxGroundings) real :: H_limit_fluxes, IforcingDepthScale, Idt real :: dThickness, dTracer real :: fractionOfForcing, hOld, Ithickness - real :: RivermixConst ! A constant used in implementing river mixing, in Pa s. + real :: RivermixConst ! A constant used in implementing river mixing [Pa s]. real, dimension(SZI_(G)) :: & - netMassInOut, & ! surface water fluxes (H units) over time step - netMassIn, & ! mass entering ocean surface (H units) over a time step - netMassOut ! mass leaving ocean surface (H units) over a time step - - real, dimension(SZI_(G), SZK_(G)) :: h2d, Tr2d - real, dimension(SZI_(G),SZJ_(G)) :: in_flux ! The total time-integrated amount of tracer! - ! that enters with freshwater - real, dimension(SZI_(G),SZJ_(G)) :: out_flux ! The total time-integrated amount of tracer! - ! that leaves with freshwater - real, dimension(SZI_(G)) :: in_flux_1d, out_flux_1d - real :: hGrounding(maxGroundings) + netMassInOut, & ! surface water fluxes [H ~> m or kg m-2] over time step + netMassIn, & ! mass entering ocean surface [H ~> m or kg m-2] over a time step + netMassOut ! mass leaving ocean surface [H ~> m or kg m-2] over a time step + + real, dimension(SZI_(G), SZK_(G)) :: h2d, Tr2d + real, dimension(SZI_(G),SZJ_(G)) :: in_flux ! The total time-integrated amount of tracer! + ! that enters with freshwater + real, dimension(SZI_(G),SZJ_(G)) :: out_flux ! The total time-integrated amount of tracer! + ! that leaves with freshwater + real, dimension(SZI_(G)) :: in_flux_1d, out_flux_1d + real :: hGrounding(maxGroundings) real :: Tr_in logical :: update_h integer :: i, j, is, ie, js, je, k, nz, n, nsw @@ -263,12 +270,12 @@ subroutine applyTracerBoundaryFluxesInOut(G, GV, Tr, dt, fluxes, h, evap_CFL_lim if ( (.not. associated(fluxes%netMassIn)) .or. (.not. associated(fluxes%netMassOut)) ) return in_flux(:,:) = 0.0 ; out_flux(:,:) = 0.0 - if(present(in_flux_optional)) then + if (present(in_flux_optional)) then do j=js,je ; do i=is,ie in_flux(i,j) = in_flux_optional(i,j) - enddo; enddo + enddo ; enddo endif - if(present(out_flux_optional)) then + if (present(out_flux_optional)) then do j=js,je ; do i=is,ie out_flux(i,j) = out_flux_optional(i,j) enddo ; enddo @@ -309,7 +316,7 @@ subroutine applyTracerBoundaryFluxesInOut(G, GV, Tr, dt, fluxes, h, evap_CFL_lim ! We aggregate the thermodynamic forcing for a time step into the following: ! These should have been set and stored during a call to applyBoundaryFluxesInOut ! netMassIn = net mass entering at ocean surface over a timestep - ! netMassOut = net mass leaving ocean surface (H units) over a time step. + ! netMassOut = net mass leaving ocean surface [H ~> m or kg m-2] over a time step. ! netMassOut < 0 means mass leaves ocean. ! Note here that the aggregateFW flag has already been taken care of in the call to diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index 0a11de9c1e..a3c75bd7fd 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -1,3 +1,4 @@ +!> Orchestrates the registration and calling of tracer packages module MOM_tracer_flow_control ! This file is part of MOM6. See LICENSE.md for the license. @@ -15,6 +16,7 @@ module MOM_tracer_flow_control use MOM_sponge, only : sponge_CS use MOM_ALE_sponge, only : ALE_sponge_CS use MOM_tracer_registry, only : tracer_registry_type +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface, thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type #include @@ -67,19 +69,21 @@ module MOM_tracer_flow_control public call_tracer_column_fns, call_tracer_surface_state, call_tracer_stocks public call_tracer_flux_init, get_chl_from_model, tracer_flow_control_end +!> The control structure for orchestrating the calling of tracer packages type, public :: tracer_flow_control_CS ; private - logical :: use_USER_tracer_example = .false. - logical :: use_DOME_tracer = .false. - logical :: use_ISOMIP_tracer = .false. - logical :: use_ideal_age = .false. - logical :: use_regional_dyes = .false. - logical :: use_oil = .false. - logical :: use_advection_test_tracer = .false. - logical :: use_OCMIP2_CFC = .false. - logical :: use_MOM_generic_tracer = .false. - logical :: use_pseudo_salt_tracer = .false. - logical :: use_boundary_impulse_tracer = .false. - logical :: use_dyed_obc_tracer = .false. + 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_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 + logical :: use_advection_test_tracer = .false. !< If true, use the advection_test_tracer package + logical :: use_OCMIP2_CFC = .false. !< If true, use the OCMIP2_CFC tracer package + logical :: use_MOM_generic_tracer = .false. !< If true, use the MOM_generic_tracer packages + logical :: use_pseudo_salt_tracer = .false. !< If true, use the psuedo_salt tracer package + logical :: use_boundary_impulse_tracer = .false. !< If true, use the boundary impulse tracer package + logical :: use_dyed_obc_tracer = .false. !< If true, use the dyed OBC tracer package + !>@{ Pointers to the control strucures for the tracer packages 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() @@ -94,6 +98,7 @@ module MOM_tracer_flow_control type(pseudo_salt_tracer_CS), pointer :: pseudo_salt_tracer_CSp => NULL() type(boundary_impulse_tracer_CS), pointer :: boundary_impulse_tracer_CSp => NULL() type(dyed_obc_tracer_CS), pointer :: dyed_obc_tracer_CSp => NULL() + !!@} end type tracer_flow_control_CS contains @@ -137,9 +142,10 @@ end subroutine call_tracer_flux_init !> The following 5 subroutines and associated definitions provide the !! machinery to register and call the subroutines that initialize !! tracers and apply vertical column processes to tracers. -subroutine call_tracer_register(HI, GV, param_file, CS, tr_Reg, restart_CS) +subroutine call_tracer_register(HI, GV, US, 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(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(tracer_flow_control_CS), pointer :: CS !< A pointer that is set to point to the @@ -233,7 +239,7 @@ subroutine call_tracer_register(HI, GV, param_file, CS, tr_Reg, restart_CS) register_ideal_age_tracer(HI, GV, param_file, CS%ideal_age_tracer_CSp, & tr_Reg, restart_CS) if (CS%use_regional_dyes) CS%use_regional_dyes = & - register_dye_tracer(HI, GV, param_file, CS%dye_tracer_CSp, & + register_dye_tracer(HI, GV, US, param_file, CS%dye_tracer_CSp, & tr_Reg, restart_CS) if (CS%use_oil) CS%use_oil = & register_oil_tracer(HI, GV, param_file, CS%oil_tracer_CSp, & @@ -264,7 +270,7 @@ end subroutine call_tracer_register !> This subroutine calls all registered tracer initialization !! subroutines. -subroutine tracer_flow_control_init(restart, day, G, GV, h, param_file, diag, OBC, & +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) logical, intent(in) :: restart !< 1 if the fields have already !! been read from a restart file. @@ -272,8 +278,8 @@ subroutine tracer_flow_control_init(restart, day, G, GV, h, param_file, diag, OB 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(NIMEM_,NJMEM_,NKMEM_), intent(in) :: h !< Layer thicknesses, in H - !! (usually m or kg m-2) + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(NIMEM_,NJMEM_,NKMEM_), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(param_file_type), intent(in) :: param_file !< A structure to parse for !! run-time parameters type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to @@ -304,29 +310,29 @@ subroutine tracer_flow_control_init(restart, day, G, GV, h, param_file, diag, OB call USER_initialize_tracer(restart, day, G, GV, h, diag, OBC, CS%USER_tracer_example_CSp, & sponge_CSp, diag_to_Z_CSp) if (CS%use_DOME_tracer) & - call initialize_DOME_tracer(restart, day, G, GV, h, diag, OBC, CS%DOME_tracer_CSp, & + call initialize_DOME_tracer(restart, day, G, GV, US, h, diag, OBC, CS%DOME_tracer_CSp, & sponge_CSp, diag_to_Z_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) if (CS%use_ideal_age) & - call initialize_ideal_age_tracer(restart, day, G, GV, h, diag, OBC, CS%ideal_age_tracer_CSp, & + call initialize_ideal_age_tracer(restart, day, G, GV, US, h, diag, OBC, CS%ideal_age_tracer_CSp, & sponge_CSp, diag_to_Z_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) if (CS%use_oil) & - call initialize_oil_tracer(restart, day, G, GV, h, diag, OBC, CS%oil_tracer_CSp, & + call initialize_oil_tracer(restart, day, G, GV, US, h, diag, OBC, CS%oil_tracer_CSp, & sponge_CSp, diag_to_Z_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) if (CS%use_OCMIP2_CFC) & - call initialize_OCMIP2_CFC(restart, day, G, GV, h, diag, OBC, CS%OCMIP2_CFC_CSp, & + call initialize_OCMIP2_CFC(restart, day, G, GV, US, h, diag, OBC, CS%OCMIP2_CFC_CSp, & sponge_CSp, diag_to_Z_CSp) #ifdef _USE_GENERIC_TRACER if (CS%use_MOM_generic_tracer) & - call initialize_MOM_generic_tracer(restart, day, G, GV, h, param_file, diag, OBC, & + 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) #endif if (CS%use_pseudo_salt_tracer) & @@ -341,21 +347,14 @@ subroutine tracer_flow_control_init(restart, day, G, GV, h, param_file, diag, OB end subroutine tracer_flow_control_init -! #@# This subroutine needs a doxygen description +!> This subroutine extracts the chlorophyll concentrations from the model state, if possible subroutine get_chl_from_model(Chl_array, G, CS) - real, dimension(NIMEM_,NJMEM_,NKMEM_), intent(out) :: Chl_array !< The array into which the - !! model's Chlorophyll-A - !! concentrations in mg m-3 are - !! to be read. - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(tracer_flow_control_CS), pointer :: CS !< The control structure returned - !! by a previous call to - !! call_tracer_register. -! Arguments: Chl_array - The array into which the model's Chlorophyll-A -! concentrations in mg m-3 are to be read. -! (in) G - The ocean's grid structure. -! (in) CS - The control structure returned by a previous call to -! call_tracer_register. + real, dimension(NIMEM_,NJMEM_,NKMEM_), & + intent(out) :: Chl_array !< The array in which to store the model's + !! Chlorophyll-A concentrations in mg m-3. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(tracer_flow_control_CS), pointer :: CS !< The control structure returned by a + !! previous call to call_tracer_register. #ifdef _USE_GENERIC_TRACER if (CS%use_MOM_generic_tracer) then @@ -391,19 +390,6 @@ subroutine call_tracer_set_forcing(state, fluxes, day_start, day_interval, G, CS type(tracer_flow_control_CS), pointer :: CS !< The control structure returned by a !! previous call to call_tracer_register. -! This subroutine calls the individual tracer modules' subroutines to -! specify or read quantities related to their surface forcing. -! Arguments: state - A structure containing fields that describe the -! surface state of the ocean. -! (out) fluxes - A structure containing pointers to any possible -! forcing fields. Unused fields have NULL ptrs. -! (in) day_start - Start time of the fluxes. -! (in) day_interval - Length of time over which these fluxes -! will be applied. -! (in) G - The ocean's grid structure. -! (in) CS - The control structure returned by a previous call to -! call_tracer_register. - if (.not. associated(CS)) call MOM_error(FATAL, "call_tracer_set_forcing"// & "Module must be initialized via call_tracer_register before it is used.") ! if (CS%use_ideal_age) & @@ -412,27 +398,25 @@ subroutine call_tracer_set_forcing(state, fluxes, day_start, day_interval, G, CS end subroutine call_tracer_set_forcing -!> This subroutine calls all registered tracer column physics -!! subroutines. +!> This subroutine calls all registered tracer column physics subroutines. subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, tv, optics, CS, & debug, evap_CFL_limit, minimum_forcing_depth) - real, dimension(NIMEM_,NJMEM_,NKMEM_), intent(in) :: h_old !< Layer thickness before entrainment, - !! in m (Boussinesq) or kg m-2 - !! (non-Boussinesq). - real, dimension(NIMEM_,NJMEM_,NKMEM_), intent(in) :: h_new !< Layer thickness after entrainment, - !! in m or kg m-2. + real, dimension(NIMEM_,NJMEM_,NKMEM_), intent(in) :: h_old !< Layer thickness before entrainment + !! [H ~> m or kg m-2]. + real, dimension(NIMEM_,NJMEM_,NKMEM_), intent(in) :: h_new !< Layer thickness after entrainment + !! [H ~> m or kg m-2]. real, dimension(NIMEM_,NJMEM_,NKMEM_), intent(in) :: ea !< an array to which the amount of !! fluid entrained from the layer above during this call - !! will be added, in m or kg m-2, the same as h_old. + !! will be added [H ~> m or kg m-2]. real, dimension(NIMEM_,NJMEM_,NKMEM_), intent(in) :: eb !< an array to which the amount of !! fluid entrained from the layer below during this call - !! will be added, in m or kg m-2, the same as h_old. + !! 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, dimension(NIMEM_,NJMEM_), intent(in) :: Hml !< Mixed layer depth (m) + real, dimension(NIMEM_,NJMEM_), intent(in) :: Hml !< Mixed layer depth [H ~> m or kg m-2] real, intent(in) :: dt !< The amount of time covered by this - !! call, in s + !! call [s] type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid !! structure. @@ -443,40 +427,12 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, type(tracer_flow_control_CS), pointer :: CS !< The control structure returned by !! a previous call to !! call_tracer_register. - logical, intent(in) :: debug !< Calculates checksums - real, optional,intent(in) :: evap_CFL_limit !< Limits how much water - !! can be fluxed out of the top layer - !! Stored previously in diabatic] CS. - real, optional,intent(in) :: minimum_forcing_depth !< The smallest depth - !! over which fluxes can be applied - !! Stored previously in diabatic CS. - -! This subroutine calls all registered tracer column physics -! subroutines. - -! Arguments: h_old - Layer thickness before entrainment, in m (Boussinesq) -! or kg m-2 (non-Boussinesq). -! (in) h_new - Layer thickness after entrainment, in m or kg m-2. -! (in) ea - an array to which the amount of fluid entrained -! from the layer above during this call will be -! added, in m or kg m-2, the same as h_old. -! (in) eb - an array to which the amount of fluid entrained -! from the layer below during this call will be -! added, in m or kg m-2, the same as h_old. -! (in) fluxes - A structure containing pointers to any possible -! forcing fields. Unused fields have NULL ptrs. -! (in) dt - The amount of time covered by this call, in s. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) tv - The structure containing thermodynamic variables. -! (in) optics - The structure containing optical properties. -! (in) CS - The control structure returned by a previous call to -! call_tracer_register. -! (in) evap_CFL_limit - Limits how much water can be fluxed out of the top layer -! Stored previously in diabatic CS. -! (in) minimum_forcing_depth - The smallest depth over which fluxes can be applied -! Stored previously in diabatic CS. -! (in) debug - Calculates checksums + logical, intent(in) :: debug !< If true calculate checksums + 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 [H ~> m or kg m-2] if (.not. associated(CS)) call MOM_error(FATAL, "call_tracer_column_fns: "// & "Module must be initialized via call_tracer_register before it is used.") @@ -596,52 +552,38 @@ end subroutine call_tracer_column_fns !> This subroutine calls all registered tracer packages to enable them to !! add to the surface state returned to the coupler. These routines are optional. subroutine call_tracer_stocks(h, stock_values, G, GV, CS, stock_names, stock_units, & - num_stocks, stock_index, got_min_max,global_min, global_max,xgmin, & - ygmin, zgmin, xgmax, ygmax, zgmax) + num_stocks, stock_index, got_min_max, global_min, global_max, & + xgmin, ygmin, zgmin, xgmax, ygmax, zgmax) real, dimension(NIMEM_,NJMEM_,NKMEM_), & - intent(in) :: h !< Layer thicknesses, in H - !! (usually m or kg m-2). - real, dimension(:), intent(out) :: stock_values + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(:), intent(out) :: stock_values !< The integrated amounts of a tracer + !! on the current PE, usually in kg x concentration [kg conc]. 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_flow_control_CS), pointer :: CS !< The control structure returned by a !! previous call to !! call_tracer_register. - character(len=*), dimension(:), optional, & - intent(out) :: stock_names !< Diagnostic names to use for each - !! stock. - character(len=*), dimension(:), optional, & - intent(out) :: stock_units !< Units to use in the metadata for - !! each stock. - integer, optional, & - intent(out) :: num_stocks !< The number of tracer stocks being - !! returned. - integer, optional, & - intent(in) :: stock_index !< The integer stock index from - !! stocks_constans_mod of the stock to be returned. If this is + character(len=*), dimension(:), & + optional, intent(out) :: stock_names !< Diagnostic names to use for each stock. + character(len=*), dimension(:), & + optional, intent(out) :: stock_units !< Units to use in the metadata for each stock. + integer, optional, intent(out) :: num_stocks !< The number of tracer stocks being returned. + integer, optional, intent(in) :: stock_index !< The integer stock index from + !! stocks_constants_mod of the stock to be returned. If this is !! present and greater than 0, only a single stock can be returned. - logical, dimension(:), optional, & - intent(inout) :: got_min_max - real, dimension(:), optional, & - intent(out) :: global_min, global_max - real, dimension(:), optional, & - intent(out) :: xgmin, ygmin, zgmin, xgmax, ygmax, zgmax -! This subroutine calls all registered tracer packages to enable them to -! add to the surface state returned to the coupler. These routines are optional. - -! Arguments: h - Layer thickness, in m (Boussinesq) or kg m-2 (non-Boussinesq). -! (out) stock_values - The integrated amounts of a tracer on the current -! PE, usually in kg x concentration. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - The control structure returned by a previous call to -! call_tracer_register. -! (out,opt) stock_names - Diagnostic names to use for each stock. -! (out,opt) stock_units - Units to use in the metadata for each stock. -! (out,opt) num_stocks - The number of tracer stocks being returned. -! (in,opt) stock_index - The integer stock index from stocks_constans_mod of -! the stock to be returned. If this is present and -! greater than 0, only a single stock can be returned. + logical, dimension(:), & + optional, intent(inout) :: got_min_max !< Indicates whether the global min and + !! max are found for each tracer + real, dimension(:), optional, intent(out) :: global_min !< The global minimum of each tracer + real, dimension(:), optional, intent(out) :: global_max !< The global maximum of each tracer + real, dimension(:), optional, intent(out) :: xgmin !< The x-position of the global minimum + real, dimension(:), optional, intent(out) :: ygmin !< The y-position of the global minimum + real, dimension(:), optional, intent(out) :: zgmin !< The z-position of the global minimum + real, dimension(:), optional, intent(out) :: xgmax !< The x-position of the global maximum + real, dimension(:), optional, intent(out) :: ygmax !< The y-position of the global maximum + real, dimension(:), optional, intent(out) :: zgmax !< The z-position of the global maximum + + ! Local variables character(len=200), dimension(MAX_FIELDS_) :: names, units character(len=200) :: set_pkg_name real, dimension(MAX_FIELDS_) :: values @@ -707,8 +649,9 @@ subroutine call_tracer_stocks(h, stock_values, G, GV, CS, stock_names, stock_uni call store_stocks("MOM_generic_tracer", ns, names, units, values, index, stock_values, & set_pkg_name, max_ns, ns_tot, stock_names, stock_units) nn=ns_tot-ns+1 - nn=MOM_generic_tracer_min_max(nn, got_min_max, global_min, global_max, xgmin, ygmin, zgmin, xgmax, ygmax, zgmax ,& - G, CS%MOM_generic_tracer_CSp,names, units) + nn=MOM_generic_tracer_min_max(nn, got_min_max, global_min, global_max, & + xgmin, ygmin, zgmin, xgmax, ygmax, zgmax ,& + G, CS%MOM_generic_tracer_CSp,names, units) endif #endif @@ -735,16 +678,26 @@ end subroutine call_tracer_stocks !> This routine stores the stocks and does error handling for call_tracer_stocks. subroutine store_stocks(pkg_name, ns, names, units, values, index, stock_values, & set_pkg_name, max_ns, ns_tot, stock_names, stock_units) - character(len=*), intent(in) :: pkg_name - integer, intent(in) :: ns - character(len=*), dimension(:), intent(in) :: names, units - real, dimension(:), intent(in) :: values - integer, intent(in) :: index - real, dimension(:), intent(inout) :: stock_values - character(len=*), intent(inout) :: set_pkg_name - integer, intent(in) :: max_ns - integer, intent(inout) :: ns_tot - character(len=*), dimension(:), optional, intent(inout) :: stock_names, stock_units + character(len=*), intent(in) :: pkg_name !< The tracer package name + integer, intent(in) :: ns !< The number of stocks associated with this tracer package + character(len=*), dimension(:), & + intent(in) :: names !< Diagnostic names to use for each stock. + character(len=*), dimension(:), & + intent(in) :: units !< Units to use in the metadata for each stock. + real, dimension(:), intent(in) :: values !< The values of the tracer stocks + integer, intent(in) :: index !< The integer stock index from + !! stocks_constants_mod of the stock to be returned. If this is + !! present and greater than 0, only a single stock can be returned. + real, dimension(:), intent(inout) :: stock_values !< The master list of stock values + character(len=*), intent(inout) :: set_pkg_name !< The name of the last tracer package whose + !! stocks were stored for a specific index. This is + !! used to trigger an error if there are redundant stocks. + integer, intent(in) :: max_ns !< The maximum size of the master stock list + integer, intent(inout) :: ns_tot !< The total number of stocks in the master list + character(len=*), dimension(:), & + optional, intent(inout) :: stock_names !< Diagnostic names to use for each stock in the master list + character(len=*), dimension(:), & + optional, intent(inout) :: stock_units !< Units to use in the metadata for each stock in the master list ! This routine stores the stocks and does error handling for call_tracer_stocks. character(len=16) :: ind_text, ns_text, max_text @@ -787,20 +740,10 @@ subroutine call_tracer_surface_state(state, h, G, CS) type(surface), intent(inout) :: state !< A structure containing fields that !! describe the surface state of the ocean. real, dimension(NIMEM_,NJMEM_,NKMEM_), & - intent(in) :: h !< Layer thicknesses, in H - !! (usually m or kg m-2). + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(tracer_flow_control_CS), pointer :: CS !< The control structure returned by a !! previous call to call_tracer_register. -! This subroutine calls all registered tracer packages to enable them to -! add to the surface state returned to the coupler. These routines are optional. - -! Arguments: state - A structure containing fields that describe the -! surface state of the ocean. -! (in) h - Layer thickness, in m (Boussinesq) or kg m-2 (non-Boussinesq). -! (in) G - The ocean's grid structure. -! (in) CS - The control structure returned by a previous call to -! call_tracer_register. if (.not. associated(CS)) call MOM_error(FATAL, "call_tracer_surface_state: "// & "Module must be initialized via call_tracer_register before it is used.") @@ -830,7 +773,8 @@ subroutine call_tracer_surface_state(state, h, G, CS) end subroutine call_tracer_surface_state subroutine tracer_flow_control_end(CS) - type(tracer_flow_control_CS), pointer :: CS + type(tracer_flow_control_CS), pointer :: CS !< The control structure returned by a + !! previous call to call_tracer_register. if (CS%use_USER_tracer_example) & call USER_tracer_example_end(CS%USER_tracer_example_CSp) diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index f7fd35d721..48ec698696 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -32,53 +32,61 @@ module MOM_tracer_hor_diff public tracer_hordiff, tracer_hor_diff_init, tracer_hor_diff_end +!> The ocntrol structure for along-layer and epineutral tracer diffusion type, public :: tracer_hor_diff_CS ; private - real :: dt ! The baroclinic dynamics time step, in s. - real :: KhTr ! The along-isopycnal tracer diffusivity in m2/s. - real :: KhTr_Slope_Cff ! The non-dimensional coefficient in KhTr formula - real :: KhTr_min ! Minimum along-isopycnal tracer diffusivity in m2/s. - real :: KhTr_max ! Maximum along-isopycnal tracer diffusivity in m2/s. - real :: KhTr_passivity_coeff ! Passivity coefficient that scales Rd/dx (default = 0) - ! where passivity is the ratio between along-isopycnal - ! tracer mixing and thickness mixing - real :: KhTr_passivity_min ! Passivity minimum (default = 1/2) - real :: ML_KhTR_scale ! With Diffuse_ML_interior, the ratio of the - ! truly horizontal diffusivity in the mixed - ! layer to the epipycnal diffusivity. Nondim. - real :: max_diff_CFL ! If positive, locally limit the along-isopycnal - ! tracer diffusivity to keep the diffusive CFL - ! locally at or below this value. Nondim. - logical :: Diffuse_ML_interior ! If true, diffuse along isopycnals between - ! the mixed layer and the interior. - logical :: check_diffusive_CFL ! If true, automatically iterate the diffusion - ! to ensure that the diffusive equivalent of - ! the CFL limit is not violated. - logical :: use_neutral_diffusion ! If true, use the neutral_diffusion module from within - ! tracer_hor_diff. - type(neutral_diffusion_CS), pointer :: neutral_diffusion_CSp => NULL() ! Control structure for neutral diffusion. - type(diag_ctrl), pointer :: diag ! structure to regulate timing of diagnostic output. - logical :: debug ! If true, write verbose checksums for debugging purposes. - logical :: show_call_tree ! Display the call tree while running. Set by VERBOSITY level. - logical :: first_call = .true. + real :: dt !< The baroclinic dynamics time step [s]. + real :: KhTr !< The along-isopycnal tracer diffusivity [m2 s-1]. + real :: KhTr_Slope_Cff !< The non-dimensional coefficient in KhTr formula + real :: KhTr_min !< Minimum along-isopycnal tracer diffusivity [m2 s-1]. + real :: KhTr_max !< Maximum along-isopycnal tracer diffusivity [m2 s-1]. + real :: KhTr_passivity_coeff !< Passivity coefficient that scales Rd/dx (default = 0) + !! where passivity is the ratio between along-isopycnal + !! tracer mixing and thickness mixing [nondim] + real :: KhTr_passivity_min !< Passivity minimum (default = 1/2) [nondim] + real :: ML_KhTR_scale !< With Diffuse_ML_interior, the ratio of the + !! truly horizontal diffusivity in the mixed + !! layer to the epipycnal diffusivity [nondim]. + real :: max_diff_CFL !< If positive, locally limit the along-isopycnal + !! tracer diffusivity to keep the diffusive CFL + !! locally at or below this value [nondim]. + logical :: Diffuse_ML_interior !< If true, diffuse along isopycnals between + !! the mixed layer and the interior. + logical :: check_diffusive_CFL !< If true, automatically iterate the diffusion + !! to ensure that the diffusive equivalent of + !! the CFL limit is not violated. + logical :: use_neutral_diffusion !< If true, use the neutral_diffusion module from within + !! tracer_hor_diff. + type(neutral_diffusion_CS), pointer :: neutral_diffusion_CSp => NULL() !< Control structure for neutral diffusion. + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + logical :: debug !< If true, write verbose checksums for debugging purposes. + logical :: show_call_tree !< Display the call tree while running. Set by VERBOSITY level. + logical :: first_call = .true. !< This is true until after the first call + !>@{ Diagnostic IDs integer :: id_KhTr_u = -1 integer :: id_KhTr_v = -1 integer :: id_KhTr_h = -1 integer :: id_CFL = -1 integer :: id_khdt_x = -1 integer :: id_khdt_y = -1 + !!@} - type(group_pass_type) :: pass_t !For group halo pass, used in both - !tracer_hordiff and tracer_epipycnal_ML_diff + type(group_pass_type) :: pass_t !< For group halo pass, used in both + !! tracer_hordiff and tracer_epipycnal_ML_diff end type tracer_hor_diff_CS +!> A type that can be used to create arrays of pointers to 2D arrays type p2d - real, dimension(:,:), pointer :: p => NULL() + real, dimension(:,:), pointer :: p => NULL() !< A pointer to a 2D array of reals end type p2d +!> A type that can be used to create arrays of pointers to 2D integer arrays type p2di - integer, dimension(:,:), pointer :: p => NULL() + integer, dimension(:,:), pointer :: p => NULL() !< A pointer to a 2D array of integers end type p2di +!>@{ CPU time clocks integer :: id_clock_diffuse, id_clock_epimix, id_clock_pass, id_clock_sync +!!@} contains @@ -87,61 +95,66 @@ module MOM_tracer_hor_diff !! Multiple iterations are used (if necessary) so that there is no limit !! on the acceptable time increment. subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, CS, Reg, tv, do_online_flag, read_khdt_x, read_khdt_y) - type(ocean_grid_type), intent(inout) :: G !< Grid type - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness (m or kg m-2) - real, intent(in) :: dt !< time step (seconds) - type(MEKE_type), pointer :: MEKE !< MEKE type - type(VarMix_CS), pointer :: VarMix !< Variable mixing type - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(tracer_hor_diff_CS), pointer :: CS !< module control structure - type(tracer_registry_type), pointer :: Reg !< registered tracers - type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any available - !! thermodynamic fields, including potential temp and - !! salinity or mixed layer density. Absent fields have - !! NULL ptrs, and these may (probably will) point to - !! some of the same arrays as Tr does. tv is required - !! for epipycnal mixing between mixed layer and the interior. + type(ocean_grid_type), intent(inout) :: G !< Grid type + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, intent(in) :: dt !< time step [s] + type(MEKE_type), pointer :: MEKE !< MEKE type + type(VarMix_CS), pointer :: VarMix !< Variable mixing type + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(tracer_hor_diff_CS), pointer :: CS !< module control structure + type(tracer_registry_type), pointer :: Reg !< registered tracers + type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any available + !! thermodynamic fields, including potential temp and + !! salinity or mixed layer density. Absent fields have + !! NULL ptrs, and these may (probably will) point to + !! some of the same arrays as Tr does. tv is required + !! for epipycnal mixing between mixed layer and the interior. ! Optional inputs for offline tracer transport - logical, optional :: do_online_flag - real, dimension(SZIB_(G),SZJ_(G)), optional, intent(in) :: read_khdt_x - real, dimension(SZI_(G),SZJB_(G)), optional, intent(in) :: read_khdt_y + logical, optional, intent(in) :: do_online_flag !< If present and true, do online + !! tracer transport with stored velcities. + real, dimension(SZIB_(G),SZJ_(G)), & + optional, intent(in) :: read_khdt_x !< If present, these are the zonal + !! diffusivities from previous run. + real, dimension(SZI_(G),SZJB_(G)), & + optional, intent(in) :: read_khdt_y !< If present, these are the meridional + !! diffusivities from previous run. real, dimension(SZI_(G),SZJ_(G)) :: & Ihdxdy, & ! The inverse of the volume or mass of fluid in a layer in a - ! grid cell, in m-3 or kg-1. - Kh_h, & ! The tracer diffusivity averaged to tracer points, in m2 s-1. - CFL, & ! A diffusive CFL number for each cell, nondim. - dTr ! The change in a tracer's concentration, in units of - ! concentration. + ! grid cell [H-1 m-2 ~> m-3 or kg-1]. + Kh_h, & ! The tracer diffusivity averaged to tracer points [m2 s-1]. + CFL, & ! A diffusive CFL number for each cell [nondim]. + dTr ! The change in a tracer's concentration, in units of concentration [Conc]. real, dimension(SZIB_(G),SZJ_(G)) :: & khdt_x, & ! The value of Khtr*dt times the open face width divided by - ! the distance between adjacent tracer points, in m2. + ! the distance between adjacent tracer points [m2]. Coef_x, & ! The coefficients relating zonal tracer differences - ! to time-integrated fluxes, in m3 or kg. - Kh_u ! Tracer mixing coefficient at u-points, in m2 s-1. + ! to time-integrated fluxes [H m2 ~> m3 or kg]. + Kh_u ! Tracer mixing coefficient at u-points [m2 s-1]. real, dimension(SZI_(G),SZJB_(G)) :: & khdt_y, & ! The value of Khtr*dt times the open face width divided by - ! the distance between adjacent tracer points, in m2. + ! the distance between adjacent tracer points [m2]. Coef_y, & ! The coefficients relating meridional tracer differences - ! to time-integrated fluxes, in m3 or kg. - Kh_v ! Tracer mixing coefficient at u-points, in m2 s-1. + ! to time-integrated fluxes [H m2 ~> m3 or kg]. + Kh_v ! Tracer mixing coefficient at u-points [m2 s-1]. - real :: khdt_max ! The local limiting value of khdt_x or khdt_y, in m2. + real :: khdt_max ! The local limiting value of khdt_x or khdt_y [m2]. real :: max_CFL ! The global maximum of the diffusive CFL number. logical :: use_VarMix, Resoln_scaled, do_online, use_Eady integer :: S_idx, T_idx ! Indices for temperature and salinity if needed integer :: i, j, k, m, is, ie, js, je, nz, ntr, itt, num_itts real :: I_numitts ! The inverse of the number of iterations, num_itts. real :: scale ! The fraction of khdt_x or khdt_y that is applied in this - ! layer for this iteration, nondim. - real :: Idt ! The inverse of the time step, in s-1. + ! layer for this iteration [nondim]. + real :: Idt ! The inverse of the time step [s-1]. real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected, in m. - real :: Kh_loc ! The local value of Kh, in m2 s-1. - real :: Res_Fn ! The local value of the resolution function, nondim. - real :: Rd_dx ! The local value of deformation radius over grid-spacing, nondim. + ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: Kh_loc ! The local value of Kh [m2 s-1]. + real :: Res_Fn ! The local value of the resolution function [nondim]. + real :: Rd_dx ! The local value of deformation radius over grid-spacing [nondim]. real :: normalize ! normalization used for diagnostic Kh_h; diffusivity averaged to h-points. is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -527,7 +540,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & GV, CS, tv, num_itts) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< layer thickness (m or kg m-2) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< layer thickness [H ~> m or kg m-2] real, intent(in) :: dt !< time step type(tracer_type), intent(inout) :: Tr(:) !< tracer array integer, intent(in) :: ntr !< number of tracers @@ -539,19 +552,19 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & real, dimension(SZI_(G), SZJ_(G)) :: & - Rml_max ! The maximum coordinate density within the mixed layer, in kg m-3. + Rml_max ! The maximum coordinate density within the mixed layer [kg m-3]. real, dimension(SZI_(G), SZJ_(G), max(1,GV%nk_rho_varies)) :: & - rho_coord ! The coordinate density that is used to mix along, in kg m-3. + rho_coord ! The coordinate density that is used to mix along [kg m-3]. ! The naming mnemnonic is a=above,b=below,L=Left,R=Right,u=u-point,v=v-point. ! These are 1-D arrays of pointers to 2-d arrays to minimize memory usage. type(p2d), dimension(SZJ_(G)) :: & - deep_wt_Lu, deep_wt_Ru, & ! The relative weighting of the deeper of a pair, ND. - hP_Lu, hP_Ru ! The total thickness on each side for each pair, in m or kg m-2. + deep_wt_Lu, deep_wt_Ru, & ! The relative weighting of the deeper of a pair [nondim]. + hP_Lu, hP_Ru ! The total thickness on each side for each pair [H ~> m or kg m-2]. type(p2d), dimension(SZJB_(G)) :: & - deep_wt_Lv, deep_wt_Rv, & ! The relative weighting of the deeper of a pair, ND. - hP_Lv, hP_Rv ! The total thickness on each side for each pair, in m or kg m-2. + deep_wt_Lv, deep_wt_Rv, & ! The relative weighting of the deeper of a pair [nondim]. + hP_Lv, hP_Rv ! The total thickness on each side for each pair [H ~> m or kg m-2]. type(p2di), dimension(SZJ_(G)) :: & k0b_Lu, k0a_Lu, & ! The original k-indices of the layers that participate @@ -561,21 +574,21 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & k0b_Rv, k0a_Rv ! in each pair of mixing at v-faces. real, dimension(SZI_(G), SZJ_(G), SZK_(G)) :: & - tr_flux_conv ! The flux convergence of tracers, in TR m3 or TR kg. + tr_flux_conv ! The flux convergence of tracers [conc H m2 ~> conc m3 or conc kg] real, dimension(SZI_(G), SZJ_(G), SZK_(G)) :: Tr_flux_3d, Tr_adj_vert_L, Tr_adj_vert_R real, dimension(SZI_(G), SZK_(G), SZJ_(G)) :: & - rho_srt, & ! The density of each layer of the sorted columns, in kg m-3. - h_srt ! The thickness of each layer of the sorted columns, in m or kg m-2. + rho_srt, & ! The density of each layer of the sorted columns [kg m-3]. + h_srt ! The thickness of each layer of the sorted columns [H ~> m or kg m-2]. integer, dimension(SZI_(G), SZK_(G), SZJ_(G)) :: & k0_srt ! The original k-index that each layer of the sorted column ! corresponds to. real, dimension(SZK_(G)) :: & h_demand_L, & ! The thickness in the left (_L) or right (_R) column that - h_demand_R, & ! is demanded to match the thickness in the counterpart, in H. + h_demand_R, & ! is demanded to match the thickness in the counterpart [H ~> m or kg m-2]. h_used_L, & ! The summed thickness from the left or right columns that - h_used_R, & ! have actually been used, in m or kg m-2 (H). + h_used_R, & ! have actually been used [H ~> m or kg m-2]. h_supply_frac_L, & ! The fraction of the demanded thickness that can h_supply_frac_R ! actually be supplied from a layer. integer, dimension(SZK_(G)) :: & @@ -595,22 +608,22 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & integer, dimension(SZI_(G), SZJB_(G)) :: & nPv ! The number of epipycnal pairings at each v-point. real :: h_exclude ! A thickness that layers must attain to be considered - ! for inclusion in mixing, in m. - real :: Idt ! The inverse of the time step, in s-1. + ! for inclusion in mixing [H ~> m or kg m-2]. + real :: Idt ! The inverse of the time step [s-1]. real :: I_maxitt ! The inverse of the maximum number of iterations. - real :: rho_pair, rho_a, rho_b ! Temporary densities, in kg m-3. + real :: rho_pair, rho_a, rho_b ! Temporary densities [kg m-3]. real :: Tr_min_face ! The minimum and maximum tracer concentrations - real :: Tr_max_face ! associated with a pairing, in conc. + real :: Tr_max_face ! associated with a pairing [Conc] real :: Tr_La, Tr_Lb ! The 4 tracer concentrations that might be - real :: Tr_Ra, Tr_Rb ! associated with a pairing, in conc. + real :: Tr_Ra, Tr_Rb ! associated with a pairing [Conc] real :: Tr_av_L ! The average tracer concentrations on the left and right - real :: Tr_av_R ! sides of a pairing, in conc. - real :: Tr_flux ! The tracer flux from left to right in a pair, in conc m3. + real :: Tr_av_R ! sides of a pairing [Conc]. + real :: Tr_flux ! The tracer flux from left to right in a pair [conc H m2 ~> conc m3 or conc kg]. real :: Tr_adj_vert ! A downward vertical adjustment to Tr_flux between the - ! two cells that make up one side of the pairing, in conc m3. - real :: h_L, h_R ! Thicknesses to the left and right, in m or kg m-2 (H). - real :: wt_a, wt_b ! Fractional weights of layers above and below, ND. - real :: vol ! A cell volume or mass, in m3 or kg (H m2). + ! two cells that make up one side of the pairing [conc H m2 ~> conc m3 or conc kg]. + real :: h_L, h_R ! Thicknesses to the left and right [H ~> m or kg m-2]. + real :: wt_a, wt_b ! Fractional weights of layers above and below [nondim]. + real :: vol ! A cell volume or mass [H m2 ~> m3 or kg]. logical, dimension(SZK_(G)) :: & left_set, & ! If true, the left or right point determines the density of right_set ! of the trio. If densities are exactly equal, both are true. @@ -682,7 +695,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & enddo ; enddo if (PEmax_kRho > nz) PEmax_kRho = nz ! PEmax_kRho could have been nz+1. - h_exclude = 10.0*(GV%Angstrom + GV%H_subroundoff) + h_exclude = 10.0*(GV%Angstrom_H + GV%H_subroundoff) !$OMP parallel default(none) shared(is,ie,js,je,nkmb,G,GV,h,h_exclude,num_srt,k0_srt, & !$OMP rho_srt,h_srt,PEmax_kRho,k_end_srt,rho_coord,max_srt) & !$OMP private(ns,tmp,itmp) @@ -717,7 +730,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & tmp = h_srt(i,k2-1,j) ; h_srt(i,k2-1,j) = h_srt(i,k2,j) ; h_srt(i,k2,j) = tmp enddo endif ; enddo - enddo; enddo + enddo ; enddo !$OMP do do j=js-1,je+1 max_srt(j) = 0 @@ -1472,7 +1485,7 @@ subroutine tracer_hor_diff_init(Time, G, param_file, diag, EOS, CS) end subroutine tracer_hor_diff_init subroutine tracer_hor_diff_end(CS) - type(tracer_hor_diff_CS), pointer :: CS + type(tracer_hor_diff_CS), pointer :: CS !< module control structure call neutral_diffusion_end(CS%neutral_diffusion_CSp) if (associated(CS)) deallocate(CS) diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index b7a1e1a421..f5c7d65f03 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -37,42 +37,48 @@ module MOM_tracer_registry !> The tracer type type, public :: tracer_type - real, dimension(:,:,:), pointer :: t => NULL() !< tracer concentration array -! real :: OBC_inflow_conc= 0.0 !< tracer concentration for generic inflows + real, dimension(:,:,:), pointer :: t => NULL() !< tracer concentration array [conc] +! real :: OBC_inflow_conc= 0.0 !< tracer concentration for generic inflows [conc] ! real, dimension(:,:,:), pointer :: OBC_in_u => NULL() !< structured values for flow into the domain ! !! specified in OBCs through u-face of cell ! real, dimension(:,:,:), pointer :: OBC_in_v => NULL() !< structured values for flow into the domain ! !! specified in OBCs through v-face of cell real, dimension(:,:,:), pointer :: ad_x => NULL() !< diagnostic array for x-advective tracer flux + !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:,:), pointer :: ad_y => NULL() !< diagnostic array for y-advective tracer flux + !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:), pointer :: ad2d_x => NULL() !< diagnostic vertical sum x-advective tracer flux - !! in units of (conc * m3/s or conc * kg/s) + !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:), pointer :: ad2d_y => NULL() !< diagnostic vertical sum y-advective tracer flux - !! in units of (conc * m3/s or conc * kg/s) + !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:,:), pointer :: df_x => NULL() !< diagnostic array for x-diffusive tracer flux + !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:,:), pointer :: df_y => NULL() !< diagnostic array for y-diffusive tracer flux + !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:), pointer :: df2d_x => NULL() !< diagnostic vertical sum x-diffusive flux - !! in units of (conc * m3/s or conc * kg/s) + !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:), pointer :: df2d_y => NULL() !< diagnostic vertical sum y-diffusive flux - !! in units of (conc * m3/s or conc * kg/s) + !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:), pointer :: df2d_conc_x => NULL() !< diagnostic vertical sum x-diffusive content flux - !! in units of (conc * m3/s or conc * kg/s) + !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:), pointer :: df2d_conc_y => NULL() !< diagnostic vertical sum y-diffusive content flux - !! in units of (conc * m3/s or conc * kg/s) + !! [conc H m2 s-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:,:), pointer :: advection_xy => NULL() !< convergence of lateral advective tracer fluxes + !! [conc H s-1 ~> conc m s-1 or conc kg m-2 s-1] real, dimension(:,:,:), pointer :: diff_cont_xy => NULL() !< convergence of lateral diffusive tracer fluxes + !! [conc H s-1 ~> conc m s-1 or conc kg m-2 s-1] real, dimension(:,:,:), pointer :: diff_conc_xy => NULL() !< convergence of lateral diffusive tracer fluxes - !! expressed as a change in concentration + !! expressed as a change in concentration [conc s-1] real, dimension(:,:,:), pointer :: t_prev => NULL() !< tracer concentration array at a previous - !! timestep used for diagnostics + !! timestep used for diagnostics [conc] real, dimension(:,:,:), pointer :: Trxh_prev => NULL() !< layer integrated tracer concentration array !! at a previous timestep used for diagnostics character(len=32) :: name !< tracer name used for diagnostics and error messages - character(len=64) :: units !< Physical dimensions of the variable + character(len=64) :: units !< Physical dimensions of the tracer concentration character(len=240) :: longname !< Long name of the variable ! type(vardesc), pointer :: vd => NULL() !< metadata describing the tracer logical :: registry_diags = .false. !< If true, use the registry to set up the @@ -93,7 +99,7 @@ module MOM_tracer_registry character(len=48) :: cmor_tendprefix = "" !< The CMOR variable prefix for tendencies of this !! tracer, required because CMOR does not follow any !! discernable pattern for these names. - integer :: ind_tr_squared = -1 + integer :: ind_tr_squared = -1 !< The tracer registry index for the square of this tracer !### THESE CAPABILITIES HAVE NOT YET BEEN IMPLEMENTED. logical :: advect_tr = .true. !< If true, this tracer should be advected @@ -101,6 +107,7 @@ module MOM_tracer_registry logical :: remap_tr = .true. !< If true, this tracer should be vertically remapped integer :: diag_form = 1 !< An integer indicating which template is to be used to label diagnostics. + !>@{ Diagnostic IDs integer :: id_tr = -1 integer :: id_adx = -1, id_ady = -1, id_dfx = -1, id_dfy = -1 integer :: id_adx_2d = -1, id_ady_2d = -1, id_dfx_2d = -1, id_dfy_2d = -1 @@ -109,6 +116,7 @@ module MOM_tracer_registry integer :: id_remap_conc = -1, id_remap_cont = -1, id_remap_cont_2d = -1 integer :: id_tendency = -1, id_trxh_tendency = -1, id_trxh_tendency_2d = -1 integer :: id_tr_vardec = -1 + !!@} end type tracer_type !> Type to carry basic tracer information @@ -158,10 +166,14 @@ subroutine register_tracer(tr_ptr, Reg, param_file, HI, GV, name, longname, unit real, dimension(:,:,:), optional, pointer :: ad_y !< diagnostic y-advective flux (CONC m3/s or CONC*kg/s) real, dimension(:,:,:), optional, pointer :: df_x !< diagnostic x-diffusive flux (CONC m3/s or CONC*kg/s) real, dimension(:,:,:), optional, pointer :: df_y !< diagnostic y-diffusive flux (CONC m3/s or CONC*kg/s) - real, dimension(:,:), optional, pointer :: ad_2d_x !< vert sum of diagnostic x-advect flux (CONC m3/s or CONC*kg/s) - real, dimension(:,:), optional, pointer :: ad_2d_y !< vert sum of diagnostic y-advect flux (CONC m3/s or CONC*kg/s) - real, dimension(:,:), optional, pointer :: df_2d_x !< vert sum of diagnostic x-diffuse flux (CONC m3/s or CONC*kg/s) - real, dimension(:,:), optional, pointer :: df_2d_y !< vert sum of diagnostic y-diffuse flux (CONC m3/s or CONC*kg/s) + real, dimension(:,:), optional, pointer :: ad_2d_x !< vert sum of diagnostic x-advect flux + !! (CONC m3/s or CONC*kg/s) + real, dimension(:,:), optional, pointer :: ad_2d_y !< vert sum of diagnostic y-advect flux + !! (CONC m3/s or CONC*kg/s) + real, dimension(:,:), optional, pointer :: df_2d_x !< vert sum of diagnostic x-diffuse flux + !! (CONC m3/s or CONC*kg/s) + real, dimension(:,:), optional, pointer :: df_2d_y !< vert sum of diagnostic y-diffuse flux + !! (CONC m3/s or CONC*kg/s) real, dimension(:,:,:), optional, pointer :: advection_xy !< convergence of lateral advective tracer fluxes logical, optional, intent(in) :: registry_diags !< If present and true, use the registry for @@ -173,13 +185,16 @@ subroutine register_tracer(tr_ptr, Reg, param_file, HI, GV, name, longname, unit character(len=*), optional, intent(in) :: flux_units !< The units for the fluxes of this tracer. real, optional, intent(in) :: flux_scale !< A scaling factor used to convert the fluxes !! of this tracer to its desired units. - character(len=*), optional, intent(in) :: convergence_units !< The units for the flux convergence of this tracer. + character(len=*), optional, intent(in) :: convergence_units !< The units for the flux convergence of + !! this tracer. real, optional, intent(in) :: convergence_scale !< A scaling factor used to convert the flux !! convergence of this tracer to its desired units. - character(len=*), optional, intent(in) :: cmor_tendprefix !< The CMOR name for the layer-integrated tendencies of this tracer. - integer, optional, intent(in) :: diag_form !< An integer (1 or 2, 1 by default) indicating the character - !! string template to use in labeling diagnostics - type(MOM_restart_CS), optional, pointer :: restart_CS !< A pointer to the restart control structure; + character(len=*), optional, intent(in) :: cmor_tendprefix !< The CMOR name for the layer-integrated + !! tendencies of this tracer. + integer, optional, intent(in) :: diag_form !< An integer (1 or 2, 1 by default) indicating the + !! character string template to use in + !! labeling diagnostics + type(MOM_restart_CS), optional, pointer :: restart_CS !< A pointer to the restart control structure !! this tracer will be registered for !! restarts if this argument is present logical, optional, intent(in) :: mandatory !< If true, this tracer must be read @@ -720,11 +735,11 @@ end subroutine MOM_tracer_chksum !> Calculates and prints the global inventory of all tracers in the registry. subroutine MOM_tracer_chkinv(mesg, G, h, Tr, ntr) - character(len=*), intent(in) :: mesg !< message that appears on the chksum lines - type(ocean_grid_type), intent(in) :: G !< ocean grid structure - type(tracer_type), intent(in) :: Tr(:) !< array of all of registered tracers - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses - integer, intent(in) :: ntr !< number of registered tracers + character(len=*), intent(in) :: mesg !< message that appears on the chksum lines + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(tracer_type), dimension(:), intent(in) :: Tr !< array of all of registered tracers + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses + integer, intent(in) :: ntr !< number of registered tracers real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: tr_inv !< Tracer inventory real :: total_inv @@ -736,7 +751,7 @@ subroutine MOM_tracer_chkinv(mesg, G, h, Tr, ntr) do k=1,nz ; do j=js,je ; do i=is,ie tr_inv(i,j,k) = Tr(m)%t(i,j,k)*h(i,j,k)*G%areaT(i,j)*G%mask2dT(i,j) enddo ; enddo ; enddo - total_inv = reproducing_sum(tr_inv, is, ie, js, je) + total_inv = reproducing_sum(tr_inv, is+(1-G%isd), ie+(1-G%isd), js+(1-G%jsd), je+(1-G%jsd)) if (is_root_pe()) write(0,'(A,1X,A5,1X,ES25.16,1X,A)') "h-point: inventory", Tr(m)%name, total_inv, mesg enddo @@ -785,7 +800,7 @@ end subroutine tracer_registry_init !> This routine closes the tracer registry module. subroutine tracer_registry_end(Reg) - type(tracer_registry_type), pointer :: Reg + type(tracer_registry_type), pointer :: Reg !< The tracer registry that will be deallocated if (associated(Reg)) deallocate(Reg) end subroutine tracer_registry_end diff --git a/src/tracer/advection_test_tracer.F90 b/src/tracer/advection_test_tracer.F90 index 39e6e668e3..34f788c952 100644 --- a/src/tracer/advection_test_tracer.F90 +++ b/src/tracer/advection_test_tracer.F90 @@ -1,41 +1,8 @@ +!> This tracer package is used to test advection schemes module advection_test_tracer ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Robert Hallberg, 2002 * -!* * -!* This file contains an example of the code that is needed to set * -!* up and use a set (in this case eleven) of dynamically passive * -!* tracers. These tracers dye the inflowing water or water initially * -!* within a range of latitudes or water initially in a range of * -!* depths. * -!* * -!* A single subroutine is called from within each file to register * -!* each of the tracers for reinitialization and advection and to * -!* register the subroutine that initializes the tracers and set up * -!* their output and the subroutine that does any tracer physics or * -!* chemistry along with diapycnal mixing (included here because some * -!* tracers may float or swim vertically or dye diapycnal processes). * -!* * -!* * -!* Macros written all in capital letters are defined in MOM_memory.h. * -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q * -!* j+1 > o > o > At ^: v * -!* j x ^ x ^ x At >: u * -!* j > o > o > At o: h, tr * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** - 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 @@ -47,7 +14,7 @@ module advection_test_tracer use MOM_open_boundary, only : ocean_OBC_type use MOM_restart, only : query_initialized, MOM_restart_CS use MOM_sponge, only : set_up_sponge_field, sponge_CS -use MOM_time_manager, only : time_type, get_time +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 @@ -64,57 +31,51 @@ module advection_test_tracer public advection_test_tracer_surface_state, advection_test_tracer_end public advection_test_tracer_column_physics, advection_test_stock -! ntr is the number of tracers in this module. -integer, parameter :: NTR = 11 +integer, parameter :: NTR = 11 !< The number of tracers in this module. +!> The control structure for the advect_test_tracer module type, public :: advection_test_tracer_CS ; private - integer :: ntr = NTR ! Number of tracers in this module - 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() - real, pointer :: tr(:,:,:,:) => NULL() ! The array of tracers used in this - ! subroutine, in g m-3? - real :: land_val(NTR) = -1.0 ! The value of tr used where land is masked out. - logical :: use_sponge ! If true, sponges may be applied somewhere in the domain. - logical :: tracers_may_reinit - - real :: x_origin, x_width ! Parameters describing the test functions - real :: y_origin, y_width ! Parameters describing the test functions - - integer, dimension(NTR) :: ind_tr ! Indices returned by aof_set_coupler_flux - ! if it is used and the surface tracer concentrations are to be - ! provided to the coupler. - - type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the - ! timing of diagnostic output. - type(MOM_restart_CS), pointer :: restart_CSp => NULL() - - type(vardesc) :: tr_desc(NTR) + integer :: ntr = NTR !< Number of tracers in this module + 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 => NULL() !< A pointer to the ocean model's clock. + type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the MOM tracer registry + real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this subroutine, in g m-3? + real :: land_val(NTR) = -1.0 !< The value of tr used where land is masked out. + logical :: use_sponge !< If true, sponges may be applied somewhere in the domain. + logical :: tracers_may_reinit !< If true, the tracers may be set up via 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. + real :: x_origin !< Parameters describing the test functions + real :: x_width !< Parameters describing the test functions + real :: y_origin !< Parameters describing the test functions + real :: y_width !< Parameters describing the test functions + + integer, dimension(NTR) :: ind_tr !< Indices returned by aof_set_coupler_flux if it is used and + !! the surface tracer concentrations are to be provided to the coupler. + + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< A pointer to the restart control structure. + + type(vardesc) :: tr_desc(NTR) !< Descriptions and metadata for the tracers end type advection_test_tracer_CS contains +!> Register tracer fields and subroutines to be used with MOM. function register_advection_test_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) - type(hor_index_type), intent(in) :: HI + 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 !< A structure to parse for run-time parameters - type(advection_test_tracer_CS), pointer :: CS - type(tracer_registry_type), pointer :: tr_Reg - type(MOM_restart_CS), pointer :: restart_CS -! This subroutine is used to register tracer fields and subroutines -! to be used with MOM. -! Arguments: HI - A horizontal index type structure. -! (in) GV - The ocean's vertical grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in/out) CS - A pointer that is set to point to the control structure -! for this module -! (in/out) tr_Reg - A pointer that is set to point to the control structure -! for the tracer advection and diffusion module. -! (in) restart_CS - A pointer to the restart control structure. + type(advection_test_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_advection_test_tracer. + type(tracer_registry_type), pointer :: tr_Reg !< A pointer that is set to point to the control + !! structure for the tracer advection and + !! diffusion module + type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure + + ! Local variables character(len=80) :: name, longname ! This include declares and sets the variable "version". #include "version_variable.h" @@ -201,36 +162,28 @@ function register_advection_test_tracer(HI, GV, param_file, CS, tr_Reg, restart_ register_advection_test_tracer = .true. 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) - logical, intent(in) :: restart - type(time_type), target, intent(in) :: day + 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. 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 !< Layer thicknesses, in H (usually m or kg m-2) - type(diag_ctrl), target, intent(in) :: diag - type(ocean_OBC_type), pointer :: OBC - type(advection_test_tracer_CS), pointer :: CS - type(sponge_CS), pointer :: sponge_CSp - type(diag_to_Z_CS), pointer :: diag_to_Z_CSp -! This subroutine initializes the NTR tracer fields in tr(:,:,:,:) -! and it sets up the tracer output. - -! Arguments: restart - .true. if the fields have already been read from -! a restart file. -! (in) day - Time of the start of the run. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) h - Layer thickness, in m or kg m-2. -! (in) diag - A structure that is used to regulate diagnostic output. -! (in) OBC - This open boundary condition type specifies whether, where, -! and what open boundary conditions are used. -! (in/out) CS - The control structure returned by a previous call to -! register_advection_test_tracer. -! (in/out) sponge_CSp - A pointer to the control structure for the sponges, if -! they are in use. Otherwise this may be unassociated. -! (in/out) diag_to_Z_Csp - A pointer to the control structure for diagnostics -! in depth space. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(diag_ctrl), target, intent(in) :: diag !< A structure that is 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. + 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(:,:,:) real, pointer, dimension(:,:,:) :: & OBC_tr1_u => NULL(), & ! These arrays should be allocated and set to @@ -245,9 +198,9 @@ subroutine initialize_advection_test_tracer(restart, day, G, GV, h,diag, OBC, CS 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 :: dist2 ! The distance squared from a line [m2]. real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected, in m. + ! in roundoff and can be neglected [H ~> m or kg m-2]. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m integer :: IsdB, IedB, JsdB, JedB real :: tmpx, tmpy, locx, locy @@ -305,38 +258,40 @@ subroutine initialize_advection_test_tracer(restart, day, G, GV, h,diag, OBC, CS end subroutine initialize_advection_test_tracer +!> Applies diapycnal diffusion and any other column tracer physics or chemistry to the tracers +!! from this package. This is a simple example of a set of advected passive tracers. subroutine advection_test_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, h_new, ea, eb - type(forcing), intent(in) :: fluxes - real, intent(in) :: dt !< The amount of time covered by this call, in s - type(advection_test_tracer_CS), pointer :: CS - real, optional,intent(in) :: evap_CFL_limit - real, optional,intent(in) :: 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 thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call [s] + type(advection_test_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_advection_test_tracer. + 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] ! 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. -! Arguments: h_old - Layer thickness before entrainment, in m or kg m-2. -! (in) h_new - Layer thickness after entrainment, in m or kg m-2. -! (in) ea - an array to which the amount of fluid entrained -! from the layer above during this call will be -! added, in m or kg m-2. -! (in) eb - an array to which the amount of fluid entrained -! from the layer below during this call will be -! added, in m or kg m-2. -! (in) fluxes - A structure containing pointers to any possible -! forcing fields. Unused fields have NULL ptrs. -! (in) dt - The amount of time covered by this call, in s. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - The control structure returned by a previous call to -! register_advection_test_tracer. -! ! 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] +! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) + ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_work ! Used so that h can be modified real :: b1(SZI_(G)) ! b1 and c1 are variables used by the real :: c1(SZI_(G),SZK_(G)) ! tridiagonal solver. @@ -349,7 +304,7 @@ subroutine advection_test_tracer_column_physics(h_old, h_new, ea, eb, fluxes, do m=1,CS%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; + enddo ; enddo ; enddo call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m) , dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) @@ -370,7 +325,7 @@ subroutine advection_test_tracer_surface_state(state, h, G, CS) type(surface), intent(inout) :: state !< A structure containing fields that !! describe the surface state of the ocean. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< Layer thickness, in m or kg m-2. + intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. type(advection_test_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_advection_test_tracer. @@ -395,31 +350,20 @@ subroutine advection_test_tracer_surface_state(state, h, G, CS) end subroutine advection_test_tracer_surface_state +!> Calculate the mass-weighted integral of all tracer stocks, returning the number of stocks it has calculated. +!! If the stock_index is present, only the stock corresponding to that coded index is returned. function advection_test_stock(h, stocks, G, GV, CS, names, units, stock_index) - 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, in H (usually m or kg m-2) - real, dimension(:), intent(out) :: stocks - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - type(advection_test_tracer_CS), pointer :: CS - character(len=*), dimension(:), intent(out) :: names - character(len=*), dimension(:), intent(out) :: units - integer, optional, intent(in) :: stock_index - integer :: advection_test_stock -! This function calculates the mass-weighted integral of all tracer stocks, -! returning the number of stocks it has calculated. If the stock_index -! is present, only the stock corresponding to that coded index is returned. - -! Arguments: h - Layer thickness, in m or kg m-2. -! (out) stocks - the mass-weighted integrated amount of each tracer, -! in kg times concentration units. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - The control structure returned by a previous call to -! register_ideal_age_tracer. -! (out) names - the names of the stocks calculated. -! (out) units - the units of the stocks calculated. -! (in,opt) stock_index - the coded index of a specific stock being sought. -! Return value: the number of stocks calculated here. + 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] + real, dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of each + !! tracer, in kg times concentration units [kg conc]. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(advection_test_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_advection_test_tracer. + character(len=*), dimension(:), intent(out) :: names !< the names of the stocks calculated. + character(len=*), dimension(:), intent(out) :: units !< the units of the stocks calculated. + integer, optional, intent(in) :: stock_index !< the coded index of a specific stock being sought. + integer :: advection_test_stock !< the number of stocks calculated here. integer :: i, j, k, is, ie, js, je, nz, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -448,8 +392,10 @@ function advection_test_stock(h, stocks, G, GV, CS, names, units, stock_index) end function advection_test_stock +!> Deallocate memory associated with this module subroutine advection_test_tracer_end(CS) - type(advection_test_tracer_CS), pointer :: CS + type(advection_test_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_advection_test_tracer. integer :: m if (associated(CS)) then diff --git a/src/tracer/boundary_impulse_tracer.F90 b/src/tracer/boundary_impulse_tracer.F90 index 03cf06fdfa..fa95d8aa77 100644 --- a/src/tracer/boundary_impulse_tracer.F90 +++ b/src/tracer/boundary_impulse_tracer.F90 @@ -14,7 +14,7 @@ module boundary_impulse_tracer use MOM_open_boundary, only : ocean_OBC_type use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS use MOM_sponge, only : set_up_sponge_field, sponge_CS -use MOM_time_manager, only : time_type, get_time +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_tracer_Z_init, only : tracer_Z_init @@ -33,66 +33,56 @@ module boundary_impulse_tracer public boundary_impulse_tracer_column_physics, boundary_impulse_tracer_surface_state public boundary_impulse_stock, boundary_impulse_tracer_end -! NTR_MAX is the maximum number of tracers in this module. +!> NTR_MAX is the maximum number of tracers in this module. integer, parameter :: NTR_MAX = 1 +!> The control structure for the boundary impulse tracer package type, public :: boundary_impulse_tracer_CS ; private - integer :: ntr=NTR_MAX ! The number of tracers that are actually used. - logical :: coupled_tracers = .false. ! These tracers are not offered to the - ! coupler. - type(time_type), pointer :: Time ! A pointer to the ocean model's clock. - type(tracer_registry_type), pointer :: tr_Reg => NULL() - real, pointer :: tr(:,:,:,:) => NULL() ! The array of tracers used in this - ! subroutine, in g m-3? - logical :: tracers_may_reinit ! If true, boundary_impulse can be initialized if - ! not found in restart file - integer, dimension(NTR_MAX) :: & - ind_tr ! Indices returned by aof_set_coupler_flux if it is used and the - ! surface tracer concentrations are to be provided to the coupler. - - integer :: nkml ! Number of layers in mixed layer - real, dimension(NTR_MAX) :: land_val = -1.0 - real :: kw_eff ! An effective piston velocity used to flux tracer out at the surface - real :: remaining_source_time ! How much longer (same units as the timestep) to - ! inject the tracer at the surface - - type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the - ! timing of diagnostic output. - type(MOM_restart_CS), pointer :: restart_CSp => NULL() - - type(vardesc) :: tr_desc(NTR_MAX) + integer :: ntr=NTR_MAX !< The number of tracers that are actually used. + logical :: coupled_tracers = .false. !< These tracers are not offered to the coupler. + type(time_type), pointer :: Time => NULL() !< 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 subroutine, in g m-3? + logical :: tracers_may_reinit !< If true, boundary_impulse can be initialized if not found in restart file + integer, dimension(NTR_MAX) :: ind_tr !< Indices returned by aof_set_coupler_flux if it is used and the + !! surface tracer concentrations are to be provided to the coupler. + + integer :: nkml !< Number of layers in mixed layer + real, dimension(NTR_MAX) :: land_val = -1.0 !< A value to use to fill in tracers over land + real :: kw_eff !< An effective piston velocity used to flux tracer out at the surface + real :: remaining_source_time !< How much longer (same units as the timestep) to + !! inject the tracer at the surface + + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< A pointer to the retart control structure + + type(vardesc) :: tr_desc(NTR_MAX) !< Descriptions and metadata for the tracers end type boundary_impulse_tracer_CS contains !> Read in runtime options and add boundary impulse tracer to tracer registry function register_boundary_impulse_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) - type(hor_index_type), intent(in ) :: HI - type(verticalGrid_type), intent(in ) :: GV !< The ocean's vertical grid structure - type(param_file_type), intent(in ) :: param_file !< A structure to parse for run-time parameters - type(boundary_impulse_tracer_CS), pointer, intent(inout) :: CS - type(tracer_registry_type), pointer, intent(inout) :: tr_Reg - type(MOM_restart_CS), pointer, intent(inout) :: restart_CS -! This subroutine is used to register tracer fields and subroutines -! to be used with MOM. -! Arguments: HI - A horizontal index type structure. -! (in) GV - The ocean's vertical grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in/out) CS - A pointer that is set to point to the control structure -! for this module -! (in/out) tr_Reg - A pointer that is set to point to the control structure -! for the tracer advection and diffusion module. -! (in) restart_CS - A pointer to the restart control structure. - -! This include declares and sets the variable "version". -#include "version_variable.h" + 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 !< A structure to parse for run-time parameters + type(boundary_impulse_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_boundary_impulse_tracer. + type(tracer_registry_type), pointer :: tr_Reg !< A pointer that is set to point to the control + !! structure for the tracer advection and + !! diffusion module + type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure + + ! Local variables character(len=40) :: mdl = "boundary_impulse_tracer" ! This module's name. character(len=200) :: inputdir ! The directory where the input files are. character(len=48) :: var_name ! The variable's name. character(len=3) :: name_tag ! String for creating identifying boundary_impulse character(len=48) :: flux_units ! The units for tracer fluxes, usually ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. + ! This include declares and sets the variable "version". +#include "version_variable.h" real, pointer :: tr_ptr(:,:,:) => NULL() real, pointer :: rem_time_ptr => NULL() logical :: register_boundary_impulse_tracer @@ -160,35 +150,26 @@ 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) - logical, intent(in ) :: restart - type(time_type), target, intent(in ) :: day - 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 !< Layer thicknesses, in H (usually m or kg m-2) - type(diag_ctrl), target, intent(in ) :: diag - type(ocean_OBC_type), pointer, intent(inout) :: OBC - type(boundary_impulse_tracer_CS), pointer,intent(inout) :: CS - type(sponge_CS), pointer, intent(inout) :: sponge_CSp - type(diag_to_Z_CS), pointer, intent(inout) :: diag_to_Z_CSp - type(thermo_var_ptrs), intent(in ) :: tv !< A structure pointing to various thermodynamic variables -! This subroutine initializes the CS%ntr tracer fields in tr(:,:,:,:) -! and it sets up the tracer output. - -! Arguments: restart - .true. if the fields have already been read from -! a restart file. -! (in) day - Time of the start of the run. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) h - Layer thickness, in m or kg m-2. -! (in) diag - A structure that is used to regulate diagnostic output. -! (in) OBC - This open boundary condition type specifies whether, where, -! and what open boundary conditions are used. -! (in/out) CS - The control structure returned by a previous call to -! register_boundary_impulse_tracer. -! (in/out) sponge_CSp - A pointer to the control structure for the sponges, if -! they are in use. Otherwise this may be unassociated. -! (in/out) diag_to_Z_Csp - A pointer to the control structure for diagnostics -! in depth space. + 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. + 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 !< Layer thicknesses [H ~> m or kg m-2] + type(diag_ctrl), target, intent(in) :: diag !< A structure that is 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. + 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 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. @@ -224,49 +205,44 @@ subroutine initialize_boundary_impulse_tracer(restart, day, G, GV, h, diag, OBC, end subroutine initialize_boundary_impulse_tracer -! Apply source or sink at boundary and do vertical diffusion -subroutine boundary_impulse_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, tv, debug, & - 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, h_new, ea, eb - type(forcing), intent(in ) :: fluxes - real, intent(in ) :: dt !< The amount of time covered by this call, in s - type(boundary_impulse_tracer_CS), pointer, intent(inout) :: CS - type(thermo_var_ptrs), intent(in ) :: tv !< A structure pointing to various thermodynamic variables - logical, intent(in ) :: debug - real, optional, intent(in ) :: evap_CFL_limit - real, optional, intent(in ) :: minimum_forcing_depth +!> Apply source or sink at boundary and do vertical diffusion +subroutine boundary_impulse_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, & + tv, debug, 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 thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call [s] + type(boundary_impulse_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_boundary_impulse_tracer. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables + logical, intent(in) :: debug !< If true calculate checksums + 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] ! 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. -! Arguments: h_old - Layer thickness before entrainment, in m or kg m-2. -! (in) h_new - Layer thickness after entrainment, in m or kg m-2. -! (in) ea - an array to which the amount of fluid entrained -! from the layer above during this call will be -! added, in m or kg m-2. -! (in) eb - an array to which the amount of fluid entrained -! from the layer below during this call will be -! added, in m or kg m-2. -! (in) fluxes - A structure containing pointers to any possible -! forcing fields. Unused fields have NULL ptrs. -! (in) dt - The amount of time covered by this call, in s. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - The control structure returned by a previous call to -! register_boundary_impulse_tracer. -! (in) tv - Thermodynamic structure with T and S -! (in) evap_CFL_limit - Limits how much water can be fluxed out of the top layer -! Stored previously in diabatic CS. -! (in) minimum_forcing_depth - The smallest depth over which fluxes can be applied -! Stored previously in diabatic CS. -! (in) debug - Calculates checksums -! ! 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] +! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) + ! Local variables real :: Isecs_per_year = 1.0 / (365.0*86400.0) real :: year, h_total, scale, htot, Ih_limit integer :: secs, days @@ -282,7 +258,7 @@ subroutine boundary_impulse_tracer_column_physics(h_old, h_new, ea, eb, fluxes, if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then 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; + enddo ; enddo ; enddo call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,1), dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,1), G, GV) @@ -292,7 +268,7 @@ subroutine boundary_impulse_tracer_column_physics(h_old, h_new, ea, eb, fluxes, ! Set surface conditions do m=1,1 - if(CS%remaining_source_time>0.0) then + if (CS%remaining_source_time>0.0) then do k=1,CS%nkml ; do j=js,je ; do i=is,ie CS%tr(i,j,k,m) = 1.0 enddo ; enddo ; enddo @@ -309,30 +285,24 @@ end subroutine boundary_impulse_tracer_column_physics !> Calculate total inventory of tracer function boundary_impulse_stock(h, stocks, G, GV, CS, names, units, stock_index) - 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 !< Layer thicknesses, in H (usually m or kg m-2) - real, dimension(:), intent( out) :: stocks - type(boundary_impulse_tracer_CS), pointer, intent(in ) :: CS - character(len=*), dimension(:), intent( out) :: names - character(len=*), dimension(:), intent( out) :: units - integer, optional, intent(in ) :: stock_index + 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 !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(:), intent( out) :: stocks !< the mass-weighted integrated amount of each + !! tracer, in kg times concentration units [kg conc]. + type(boundary_impulse_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_boundary_impulse_tracer. + character(len=*), dimension(:), intent( out) :: names !< The names of the stocks calculated. + character(len=*), dimension(:), intent( out) :: units !< The units of the stocks calculated. + integer, optional, intent(in ) :: stock_index !< The coded index of a specific stock + !! being sought. + integer :: boundary_impulse_stock !< Return value: the number of stocks calculated here. + ! This function calculates the mass-weighted integral of all tracer stocks, ! returning the number of stocks it has calculated. If the stock_index ! is present, only the stock corresponding to that coded index is returned. -! Arguments: h - Layer thickness, in m or kg m-2. -! (out) stocks - the mass-weighted integrated amount of each tracer, -! in kg times concentration units. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - The control structure returned by a previous call to -! register_boundary_impulse_tracer. -! (out) names - the names of the stocks calculated. -! (out) units - the units of the stocks calculated. -! (in,opt) stock_index - the coded index of a specific stock being sought. -! Return value: the number of stocks calculated here. - integer :: boundary_impulse_stock + ! Local variables integer :: i, j, k, is, ie, js, je, nz, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -370,7 +340,7 @@ subroutine boundary_impulse_tracer_surface_state(state, h, G, CS) type(surface), intent(inout) :: state !< A structure containing fields that !! describe the surface state of the ocean. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< Layer thickness, in m or kg m-2. + intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. type(boundary_impulse_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_boundary_impulse_tracer. @@ -395,9 +365,10 @@ subroutine boundary_impulse_tracer_surface_state(state, h, G, CS) end subroutine boundary_impulse_tracer_surface_state -! Performs finalization of boundary impulse tracer +!> Performs finalization of boundary impulse tracer subroutine boundary_impulse_tracer_end(CS) - type(boundary_impulse_tracer_CS), pointer :: CS + type(boundary_impulse_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_boundary_impulse_tracer. integer :: m if (associated(CS)) then @@ -407,7 +378,8 @@ subroutine boundary_impulse_tracer_end(CS) end subroutine boundary_impulse_tracer_end !> \namespace boundary_impulse_tracer -!! \section Boundary Impulse Response Tracer and Transit Time Distributions +!! +!! \section section_BIT_desc Boundary Impulse Response Tracer and Transit Time Distributions !! Transit time distributions (TTD) are the Green's function solution of the passive tracer equation between !! the oceanic surface and interior. The name derives from the idea that the 'age' (e.g. time since last !! contact with the atmosphere) of a water parcel is best characterized as a distribution of ages @@ -424,18 +396,18 @@ end subroutine boundary_impulse_tracer_end !! In the References section, both the theoretical discussion of TTDs and BIRs are listed along with !! modeling studies which have this used framework in scientific investigations !! -!! \section Run-time parameters +!! \section section_BIT_params Run-time parameters !! -DO_BOUNDARY_IMPULSE_TRACER: Enables the boundary impulse tracer model !! -IMPULSE_SOURCE_TIME: Length of time that the surface layer acts as a source of the BIR tracer !! -!! \section References +!! \section section_BIT_refs References !! \subsection TTD and BIR Theory !! -Holzer, M., and T.M. Hall, 2000: Transit-time and tracer-age distributions in geophysical flows. !! J. Atmos. Sci., 57, 3539-3558, doi:10.1175/1520-0469(2000)057<3539:TTATAD>2.0.CO;2. !! -T.W.N. Haine, H. Zhang, D.W. Waugh, M. Holzer, On transit-time distributions in unsteady circulation !! models, Ocean Modelling, Volume 21, Issues 1–2, 2008, Pages 35-45, ISSN 1463-5003 !! http://dx.doi.org/10.1016/j.ocemod.2007.11.004. -!! \subsection BIR Modelling applications +!! \subsection section_BIT_apps Modelling applications !! -Peacock, S., and M. Maltrud (2006), Transit-time distributions in a global ocean model, !! J. Phys. Oceanogr., 36(3), 474–495, doi:10.1175/JPO2860.1. !! -Maltrud, M., Bryan, F. & Peacock, Boundary impulse response functions in a century-long eddying global diff --git a/src/tracer/dye_example.F90 b/src/tracer/dye_example.F90 index dcd2b6fecb..51b5ab6c08 100644 --- a/src/tracer/dye_example.F90 +++ b/src/tracer/dye_example.F90 @@ -1,3 +1,4 @@ +!> A tracer package for using dyes to diagnose regional flows. module regional_dyes ! This file is part of MOM6. See LICENSE.md for the license. @@ -13,10 +14,11 @@ module regional_dyes use MOM_open_boundary, only : ocean_OBC_type use MOM_restart, only : query_initialized, MOM_restart_CS use MOM_sponge, only : set_up_sponge_field, sponge_CS -use MOM_time_manager, only : time_type, get_time +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_tracer_Z_init, only : tracer_Z_init +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type @@ -31,40 +33,43 @@ module regional_dyes public dye_tracer_column_physics, dye_tracer_surface_state public dye_stock, regional_dyes_end +! 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 regional dyes tracer package type, public :: dye_tracer_CS ; private - integer :: ntr ! The number of tracers that are actually used. - logical :: coupled_tracers = .false. ! These tracers are not offered to the - ! coupler. - real, allocatable, dimension(:) :: dye_source_minlon, & ! Minimum longitude of region dye will be injected. - dye_source_maxlon, & ! Maximum longitude of region dye will be injected. - dye_source_minlat, & ! Minimum latitude of region dye will be injected. - dye_source_maxlat, & ! Maximum latitude of region dye will be injected. - dye_source_mindepth, & ! Minimum depth of region dye will be injected (m). - dye_source_maxdepth ! Maximum depth of region dye will be injected (m). - type(tracer_registry_type), pointer :: tr_Reg => NULL() - real, pointer :: tr(:,:,:,:) => NULL() ! The array of tracers used in this - ! subroutine, in g m-3? - - integer, allocatable, dimension(:) :: & - ind_tr ! Indices returned by aof_set_coupler_flux if it is used and the - ! surface tracer concentrations are to be provided to the coupler. - - type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the - ! timing of diagnostic output. - type(MOM_restart_CS), pointer :: restart_CSp => NULL() - - type(vardesc), allocatable :: tr_desc(:) - logical :: tracers_may_reinit = .false. ! hard-coding here (mjh) + integer :: ntr !< The number of tracers that are actually used. + logical :: coupled_tracers = .false. !< These tracers are not offered to the coupler. + real, allocatable, dimension(:) :: dye_source_minlon !< Minimum longitude of region dye will be injected. + real, allocatable, dimension(:) :: dye_source_maxlon !< Maximum longitude of region dye will be injected. + real, allocatable, dimension(:) :: dye_source_minlat !< Minimum latitude of region dye will be injected. + real, allocatable, dimension(:) :: dye_source_maxlat !< Maximum latitude of region dye will be injected. + real, allocatable, dimension(:) :: dye_source_mindepth !< Minimum depth of region dye will be injected [Z ~> m]. + real, allocatable, dimension(:) :: dye_source_maxdepth !< Maximum depth of region dye will be injected [Z ~> m]. + 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 subroutine, in g m-3? + + integer, allocatable, dimension(:) :: ind_tr !< Indices returned by aof_set_coupler_flux if it is used and the + !! surface tracer concentrations are to be provided to the coupler. + + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< A pointer to the restart control structure + + type(vardesc), allocatable :: tr_desc(:) !< Descriptions and metadata for the tracers + logical :: tracers_may_reinit = .false. !< If true the tracers may be initialized if not found in a restart file end type dye_tracer_CS contains !> This subroutine is used to register tracer fields and subroutines !! to be used with MOM. -function register_dye_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) +function register_dye_tracer(HI, GV, US, 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(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(dye_tracer_CS), pointer :: CS !< A pointer that is set to point to the control !! structure for this module @@ -136,18 +141,17 @@ function register_dye_tracer(HI, GV, 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.", & - fail_if_missing=.true.) - if (minval(CS%dye_source_mindepth(:)) < -1.e29) & + 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") CS%dye_source_maxdepth(:) = -1.e30 call get_param(param_file, mdl, "DYE_SOURCE_MAXDEPTH", CS%dye_source_maxdepth, & "This is the maximum depth at which we inject dyes.", & - fail_if_missing=.true.) - if (minval(CS%dye_source_maxdepth(:)) < -1.e29) & + units="m", scale=US%m_to_Z, fail_if_missing=.true.) + if (minval(CS%dye_source_maxdepth(:)) < -1.e29*US%m_to_Z) & call MOM_error(FATAL, "register_dye_tracer: Not enough values provided for DYE_SOURCE_MAXDEPTH ") - allocate(CS%tr(isd:ied,jsd:jed,nz,CS%ntr)) ; CS%tr(:,:,:,:) = 0.0 do m = 1, CS%ntr @@ -187,7 +191,7 @@ subroutine initialize_dye_tracer(restart, day, G, GV, h, diag, OBC, CS, sponge_C type(time_type), target, intent(in) :: day !< Time of the start of the run. 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(NIMEM_,NJMEM_,NKMEM_), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) + real, dimension(NIMEM_,NJMEM_,NKMEM_), intent(in) :: h !< Layer thicknesses [H ~> 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 @@ -225,15 +229,15 @@ subroutine initialize_dye_tracer(restart, day, G, GV, h, diag, OBC, CS, sponge_C G%mask2dT(i,j) > 0.0 ) then z_bot = -G%bathyT(i,j) do k = GV%ke, 1, -1 - z_center = z_bot + 0.5*h(i,j,k)*GV%H_to_m + z_center = z_bot + 0.5*h(i,j,k)*GV%H_to_Z if ( z_center > -CS%dye_source_maxdepth(m) .and. & z_center < -CS%dye_source_mindepth(m) ) then CS%tr(i,j,k,m) = 1.0 endif - z_bot = z_bot + h(i,j,k)*GV%H_to_m + z_bot = z_bot + h(i,j,k)*GV%H_to_Z enddo endif - enddo; enddo + enddo ; enddo enddo end subroutine initialize_dye_tracer @@ -242,28 +246,32 @@ end subroutine initialize_dye_tracer !! tracer physics or chemistry to the tracers from this file. !! This is a simple example of a set of advected passive tracers. !! 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] +!! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, & evap_CFL_limit, minimum_forcing_depth) - real, dimension(NIMEM_,NJMEM_,NKMEM_), intent(in) :: h_old !< Layer thickness before entrainment, - !! in m or kg m-2. - real, dimension(NIMEM_,NJMEM_,NKMEM_), intent(in) :: h_new !< Layer thickness after entrainment, - !! in m or kg m-2. - real, dimension(NIMEM_,NJMEM_,NKMEM_), intent(in) :: ea !< an array to which the amount of - !! fluid entrained from the layer above during this - !! call will be added, in m or kg m-2. - real, dimension(NIMEM_,NJMEM_,NKMEM_), intent(in) :: eb !< an array to which the amount of - !! fluid entrained from the layer below during this - !! call will be added, in 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, in s - 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(dye_tracer_CS), pointer :: CS !< The control structure returned by a previous - !! call to register_dye_tracer. - real, optional,intent(in) :: evap_CFL_limit - real, optional,intent(in) :: 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 thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call [s] + type(dye_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_dye_tracer. + 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] ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_work ! Used so that h can be modified @@ -283,7 +291,7 @@ subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS do m=1,CS%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; + enddo ; enddo ; enddo call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m) , dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) @@ -304,15 +312,15 @@ subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS G%mask2dT(i,j) > 0.0 ) then z_bot = -G%bathyT(i,j) do k=nz,1,-1 - z_center = z_bot + 0.5*h_new(i,j,k)*GV%H_to_m + z_center = z_bot + 0.5*h_new(i,j,k)*GV%H_to_Z if ( z_center > -CS%dye_source_maxdepth(m) .and. & z_center < -CS%dye_source_mindepth(m) ) then CS%tr(i,j,k,m) = 1.0 endif - z_bot = z_bot + h_new(i,j,k)*GV%H_to_m + z_bot = z_bot + h_new(i,j,k)*GV%H_to_Z enddo endif - enddo; enddo + enddo ; enddo enddo end subroutine dye_tracer_column_physics @@ -321,9 +329,9 @@ end subroutine dye_tracer_column_physics !! returning the number of stocks it has calculated. If the stock_index !! is present, only the stock corresponding to that coded index is returned. function dye_stock(h, stocks, G, GV, CS, names, units, stock_index) - real, dimension(NIMEM_,NJMEM_,NKMEM_), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) + real, dimension(NIMEM_,NJMEM_,NKMEM_), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] real, dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of - !! each tracer, in kg times concentration units. + !! each tracer, in kg times concentration units [kg conc]. 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(dye_tracer_CS), pointer :: CS !< The control structure returned by a @@ -372,7 +380,7 @@ subroutine dye_tracer_surface_state(state, h, G, CS) type(surface), intent(inout) :: state !< A structure containing fields that !! describe the surface state of the ocean. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< Layer thickness, in m or kg m-2. + intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. type(dye_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_dye_tracer. @@ -399,7 +407,8 @@ end subroutine dye_tracer_surface_state !> Clean up any allocated memory after the run. subroutine regional_dyes_end(CS) - type(dye_tracer_CS), pointer :: CS + type(dye_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_dye_tracer. integer :: m if (associated(CS)) then @@ -408,39 +417,13 @@ subroutine regional_dyes_end(CS) endif end subroutine regional_dyes_end -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Robert Hallberg, 2002 * -!* * -!* This file contains an example of the code that is needed to set * -!* up and use a set (in this case two) of dynamically passive tracers * -!* for diagnostic purposes. The tracers here are dye tracers which * -!* are set to 1 within the geographical region specified. The depth * -!* which a tracer is set is determined by calculating the depth from * -!* the seafloor upwards through the column. * -!* * -!* A single subroutine is called from within each file to register * -!* each of the tracers for reinitialization and advection and to * -!* register the subroutine that initializes the tracers and set up * -!* their output and the subroutine that does any tracer physics or * -!* chemistry along with diapycnal mixing (included here because some * -!* tracers may float or swim vertically or dye diapycnal processes). * -!* * -!* * -!* Macros written all in capital letters are defined in MOM_memory.h. * -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q * -!* j+1 > o > o > At ^: v * -!* j x ^ x ^ x At >: u * -!* j > o > o > At o: h, tr * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** +!> \namespace regional_dyes +!! +!! This file contains an example of the code that is needed to set +!! up and use a set (in this case two) of dynamically passive tracers +!! for diagnostic purposes. The tracers here are dye tracers which +!! are set to 1 within the geographical region specified. The depth +!! which a tracer is set is determined by calculating the depth from +!! the seafloor upwards through the column. end module regional_dyes diff --git a/src/tracer/dyed_obc_tracer.F90 b/src/tracer/dyed_obc_tracer.F90 index 149b207791..7abbafa5fc 100644 --- a/src/tracer/dyed_obc_tracer.F90 +++ b/src/tracer/dyed_obc_tracer.F90 @@ -1,3 +1,4 @@ +!> This tracer package dyes flow through open boundaries module dyed_obc_tracer ! This file is part of MOM6. See LICENSE.md for the license. @@ -12,7 +13,7 @@ module dyed_obc_tracer use MOM_io, only : file_exists, MOM_read_data, slasher, vardesc, var_desc, query_vardesc use MOM_open_boundary, only : ocean_OBC_type use MOM_restart, only : MOM_restart_CS -use MOM_time_manager, only : time_type, get_time +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 @@ -28,32 +29,28 @@ module dyed_obc_tracer public register_dyed_obc_tracer, initialize_dyed_obc_tracer public dyed_obc_tracer_column_physics, dyed_obc_tracer_end +!> The control structure for the dyed_obc tracer package type, public :: dyed_obc_tracer_CS ; private - integer :: ntr ! The number of tracers that are actually used. - 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() - real, pointer :: tr(:,:,:,:) => NULL() ! The array of tracers used in this - ! subroutine, in g m-3? - - integer, allocatable, dimension(:) :: & - ind_tr ! Indices returned by aof_set_coupler_flux if it is used and the - ! surface tracer concentrations are to be provided to the coupler. - - type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the - ! timing of diagnostic output. - type(MOM_restart_CS), pointer :: restart_CSp => NULL() - - type(vardesc), allocatable :: tr_desc(:) + integer :: ntr !< The number of tracers that are actually used. + 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 => NULL() !< 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 subroutine, in g m-3? + + integer, allocatable, dimension(:) :: ind_tr !< Indices returned by aof_set_coupler_flux if it is used and the + !! surface tracer concentrations are to be provided to the coupler. + + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< A pointer to the restart control structure + + type(vardesc), allocatable :: tr_desc(:) !< Descriptions and metadata for the tracers end type dyed_obc_tracer_CS contains -!> This subroutine is used to register tracer fields and subroutines -!! to be used with MOM. +!> Register tracer fields and subroutines to be used with MOM. function register_dyed_obc_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 @@ -134,16 +131,14 @@ function register_dyed_obc_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) register_dyed_obc_tracer = .true. end function register_dyed_obc_tracer -!> This subroutine initializes the CS%ntr tracer fields in tr(:,:,:,:) -!! and it sets up the tracer output. -subroutine initialize_dyed_obc_tracer(restart, day, G, GV, h, diag, OBC, CS, & - diag_to_Z_CSp) +!> 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) 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 !! 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 thicknesses, in H (usually m or kg m-2) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(diag_ctrl), target, intent(in) :: diag !< Structure used to regulate diagnostic output. 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 @@ -165,7 +160,7 @@ subroutine initialize_dyed_obc_tracer(restart, day, G, GV, h, diag, OBC, CS, & ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. real, pointer :: tr_ptr(:,:,:) => NULL() real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected, in m. + ! in roundoff and can be neglected [H ~> m or kg m-2]. real :: e(SZK_(G)+1), e_top, e_bot, d_tr integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m integer :: IsdB, IedB, JsdB, JedB @@ -206,28 +201,32 @@ end subroutine initialize_dyed_obc_tracer !! This is a simple example of a set of advected passive tracers. !! !! 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] +!! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) subroutine dyed_obc_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, - !! in m or kg m-2. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_new !< Layer thickness after entrainment, - !! in 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, in 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, in 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, in s - type(dyed_obc_tracer_CS), pointer :: CS !< The control structure returned by a previous - !! call to dyed_obc_register_tracer. - real, optional,intent(in) :: evap_CFL_limit - real, optional,intent(in) :: 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 thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call [s] + type(dyed_obc_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to dyed_obc_register_tracer. + 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] ! Local variables real :: b1(SZI_(G)) ! b1 and c1 are variables used by the @@ -243,7 +242,7 @@ subroutine dyed_obc_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, do m=1,CS%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; + enddo ; enddo ; enddo call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m) , dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth) if (nz > 1) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) @@ -258,7 +257,8 @@ end subroutine dyed_obc_tracer_column_physics !> Clean up memory allocations, if any. subroutine dyed_obc_tracer_end(CS) - type(dyed_obc_tracer_CS), pointer :: CS + type(dyed_obc_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to dyed_obc_register_tracer. integer :: m if (associated(CS)) then @@ -269,35 +269,19 @@ subroutine dyed_obc_tracer_end(CS) end subroutine dyed_obc_tracer_end !> \namespace dyed_obc_tracer -!! * -!! By Kate Hedstrom, 2017, copied from DOME tracers and also * -!! dye_example. * -!! * -!! This file contains an example of the code that is needed to set * -!! up and use a set of dynamically passive tracers. These tracers * -!! dye the inflowing water, one per open boundary segment. * -!! * -!! A single subroutine is called from within each file to register * -!! each of the tracers for reinitialization and advection and to * -!! register the subroutine that initializes the tracers and set up * -!! their output and the subroutine that does any tracer physics or * -!! chemistry along with diapycnal mixing (included here because some * -!! tracers may float or swim vertically or dye diapycnal processes). * -!! * -!! Macros written all in capital letters are defined in MOM_memory.h. * -!! * -!! A small fragment of the grid is shown below: * -!! * -!! j+1 x ^ x ^ x At x: q * -!! j+1 > o > o > At ^: v * -!! j x ^ x ^ x At >: u * -!! j > o > o > At o: h, tr * -!! j-1 x ^ x ^ x * -!! i-1 i i+1 At x & ^: * -!! i i+1 At > & o: * -!! * -!! The boundaries always run through q grid points (x). * -!! * -!!*******+*********+*********+*********+*********+*********+*********+** +!! +!! By Kate Hedstrom, 2017, copied from DOME tracers and also +!! dye_example. +!! +!! This file contains an example of the code that is needed to set +!! up and use a set of dynamically passive tracers. These tracers +!! dye the inflowing water, one per open boundary segment. +!! +!! A single subroutine is called from within each file to register +!! each of the tracers for reinitialization and advection and to +!! register the subroutine that initializes the tracers and set up +!! their output and the subroutine that does any tracer physics or +!! chemistry along with diapycnal mixing (included here because some +!! tracers may float or swim vertically or dye diapycnal processes). end module dyed_obc_tracer diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index 4f08dd7db1..562947a011 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -1,42 +1,8 @@ +!> A tracer package of ideal age tracers module ideal_age_example ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Robert Hallberg, 2002 * -!* * -!* This file contains an example of the code that is needed to set * -!* up and use a set (in this case two) of dynamically passive tracers * -!* for diagnostic purposes. The tracers here are an ideal age tracer * -!* that ages at a rate of 1/year once it is isolated from the surface,* -!* and a vintage tracer, whose surface concentration grows exponen- * -!* with time with a 30-year timescale (similar to CFCs). * -!* * -!* A single subroutine is called from within each file to register * -!* each of the tracers for reinitialization and advection and to * -!* register the subroutine that initializes the tracers and set up * -!* their output and the subroutine that does any tracer physics or * -!* chemistry along with diapycnal mixing (included here because some * -!* tracers may float or swim vertically or dye diapycnal processes). * -!* * -!* * -!* Macros written all in capital letters are defined in MOM_memory.h. * -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q * -!* j+1 > o > o > At ^: v * -!* j x ^ x ^ x At >: u * -!* j > o > o > At o: h, tr * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** - 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 @@ -48,10 +14,11 @@ module ideal_age_example use MOM_open_boundary, only : ocean_OBC_type use MOM_restart, only : query_initialized, MOM_restart_CS use MOM_sponge, only : set_up_sponge_field, sponge_CS -use MOM_time_manager, only : time_type, get_time +use MOM_time_manager, only : time_type, time_type_to_real use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_tracer_Z_init, only : tracer_Z_init +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type @@ -66,65 +33,53 @@ module ideal_age_example public ideal_age_tracer_column_physics, ideal_age_tracer_surface_state public ideal_age_stock, ideal_age_example_end -! NTR_MAX is the maximum number of tracers in this module. -integer, parameter :: NTR_MAX = 3 +integer, parameter :: NTR_MAX = 3 !< the maximum number of tracers in this module. +!> The control structure for the ideal_age_tracer package type, public :: ideal_age_tracer_CS ; private - integer :: ntr ! The number of tracers that are actually used. - logical :: coupled_tracers = .false. ! These tracers are not offered to the - ! coupler. - integer :: nkml ! The number of layers in the mixed layer. The ideal - ! age tracers are reset in the top nkml layers. - character(len=200) :: IC_file ! The file in which the age-tracer initial values - ! can be found, or an empty string for internal initialization. - logical :: Z_IC_file ! If true, the IC_file is in Z-space. The default is false. - type(time_type), pointer :: Time ! A pointer to the ocean model's clock. - type(tracer_registry_type), pointer :: tr_Reg => NULL() - real, pointer :: tr(:,:,:,:) => NULL() ! The array of tracers used in this - ! subroutine, in g m-3? - real, dimension(NTR_MAX) :: & - IC_val = 0.0, & ! The (uniform) initial condition value. - young_val = 0.0, & ! The value assigned to tr at the surface. - land_val = -1.0, & ! The value of tr used where land is masked out. - sfc_growth_rate, & ! The exponential growth rate for the surface value, - ! in units of year-1. - tracer_start_year ! The year in which tracers start aging, or at which the - ! surface value equals young_val, in years. - logical :: tracers_may_reinit ! If true, tracers may go through the - ! initialization code if they are not found in the - ! restart files. - logical :: tracer_ages(NTR_MAX) - - integer, dimension(NTR_MAX) :: & - ind_tr ! Indices returned by aof_set_coupler_flux if it is used and the - ! surface tracer concentrations are to be provided to the coupler. - - type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the - ! timing of diagnostic output. - type(MOM_restart_CS), pointer :: restart_CSp => NULL() - - type(vardesc) :: tr_desc(NTR_MAX) + integer :: ntr !< The number of tracers that are actually used. + logical :: coupled_tracers = .false. !< These tracers are not offered to the coupler. + integer :: nkml !< The number of layers in the mixed layer. The ideal + !1 age tracers are reset in the top nkml layers. + character(len=200) :: IC_file !< The file in which the age-tracer initial values + !! can be found, or an empty string for internal initialization. + logical :: Z_IC_file !< If true, the IC_file is in Z-space. The default is false. + type(time_type), pointer :: Time => NULL() !< 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, in g m-3? + real, dimension(NTR_MAX) :: IC_val = 0.0 !< The (uniform) initial condition value. + real, dimension(NTR_MAX) :: young_val = 0.0 !< The value assigned to tr at the surface. + real, dimension(NTR_MAX) :: land_val = -1.0 !< The value of tr used where land is masked out. + real, dimension(NTR_MAX) :: sfc_growth_rate !< The exponential growth rate for the surface value [year-1]. + real, dimension(NTR_MAX) :: tracer_start_year !< The year in which tracers start aging, or at which the + !! surface value equals young_val, in years. + logical :: tracers_may_reinit !< If true, these tracers be set up via the initialization code if + !! they are not found in the restart files. + logical :: tracer_ages(NTR_MAX) !< Indicates whether each tracer ages. + + integer, dimension(NTR_MAX) :: ind_tr !< Indices returned by aof_set_coupler_flux if it is used and the + !! surface tracer concentrations are to be provided to the coupler. + + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< A pointer to the restart controls structure + + type(vardesc) :: tr_desc(NTR_MAX) !< Descriptions and metadata for the tracers end type ideal_age_tracer_CS contains +!> Register the ideal age tracer fields to be used with MOM. function register_ideal_age_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) - type(hor_index_type), intent(in) :: HI + 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 !< A structure to parse for run-time parameters - type(ideal_age_tracer_CS), pointer :: CS - type(tracer_registry_type), pointer :: tr_Reg - type(MOM_restart_CS), pointer :: restart_CS -! This subroutine is used to register tracer fields and subroutines -! to be used with MOM. -! Arguments: HI - A horizontal index type structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in/out) CS - A pointer that is set to point to the control structure -! for this module -! (in/out) tr_Reg - A pointer that is set to point to the control structure -! for the tracer advection and diffusion module. -! (in) restart_CS - A pointer to the restart control structure. + type(ideal_age_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_ideal_age_tracer. + type(tracer_registry_type), pointer :: tr_Reg !< A pointer that is set to point to the control + !! structure for the tracer advection and + !! diffusion module + type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure ! This include declares and sets the variable "version". #include "version_variable.h" @@ -237,36 +192,31 @@ function register_ideal_age_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) register_ideal_age_tracer = .true. end function register_ideal_age_tracer -subroutine initialize_ideal_age_tracer(restart, day, G, GV, h, diag, OBC, CS, & +!> 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) - logical, intent(in) :: restart - type(time_type), target, intent(in) :: day + 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. 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 !< Layer thicknesses, in H (usually m or kg m-2) - type(diag_ctrl), target, intent(in) :: diag - type(ocean_OBC_type), pointer :: OBC - type(ideal_age_tracer_CS), pointer :: CS - type(sponge_CS), pointer :: sponge_CSp - type(diag_to_Z_CS), pointer :: diag_to_Z_CSp + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(diag_ctrl), target, intent(in) :: diag !< A structure that is 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. + 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. -! Arguments: restart - .true. if the fields have already been read from -! a restart file. -! (in) day - Time of the start of the run. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) h - Layer thickness, in m or kg m-2. -! (in) diag - A structure that is used to regulate diagnostic output. -! (in) OBC - This open boundary condition type specifies whether, where, -! and what open boundary conditions are used. -! (in/out) CS - The control structure returned by a previous call to -! register_ideal_age_tracer. -! (in/out) sponge_CSp - A pointer to the control structure for the sponges, if -! they are in use. Otherwise this may be unassociated. -! (in/out) 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. character(len=72) :: longname ! The long name of that variable. character(len=48) :: units ! The dimensions of the variable. @@ -301,10 +251,10 @@ subroutine initialize_ideal_age_tracer(restart, day, G, GV, h, diag, OBC, CS, & if (CS%Z_IC_file) then OK = tracer_Z_init(CS%tr(:,:,:,m), h, CS%IC_file, name,& - G, -1e34, 0.0) ! CS%land_val(m)) + G, US, -1e34, 0.0) ! CS%land_val(m)) if (.not.OK) then OK = tracer_Z_init(CS%tr(:,:,:,m), h, CS%IC_file, & - trim(name), G, -1e34, 0.0) ! CS%land_val(m)) + trim(name), G, US, -1e34, 0.0) ! CS%land_val(m)) if (.not.OK) call MOM_error(FATAL,"initialize_ideal_age_tracer: "//& "Unable to read "//trim(name)//" from "//& trim(CS%IC_file)//".") @@ -331,43 +281,43 @@ subroutine initialize_ideal_age_tracer(restart, day, G, GV, h, diag, OBC, CS, & end subroutine initialize_ideal_age_tracer +!> Applies diapycnal diffusion, aging and regeneration at the surface to the ideal age tracers subroutine ideal_age_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, h_new, ea, eb - type(forcing), intent(in) :: fluxes - real, intent(in) :: dt !< The amount of time covered by this call, in s - type(ideal_age_tracer_CS), pointer :: CS - real, optional,intent(in) :: evap_CFL_limit - real, optional,intent(in) :: 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 thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call [s] + type(ideal_age_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_ideal_age_tracer. + 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] ! 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. -! Arguments: h_old - Layer thickness before entrainment, in m or kg m-2. -! (in) h_new - Layer thickness after entrainment, in m or kg m-2. -! (in) ea - an array to which the amount of fluid entrained -! from the layer above during this call will be -! added, in m or kg m-2. -! (in) eb - an array to which the amount of fluid entrained -! from the layer below during this call will be -! added, in m or kg m-2. -! (in) fluxes - A structure containing pointers to any possible -! forcing fields. Unused fields have NULL ptrs. -! (in) dt - The amount of time covered by this call, in s. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - The control structure returned by a previous call to -! register_ideal_age_tracer. -! ! 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] +! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) + ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_work ! Used so that h can be modified real :: sfc_val ! The surface value for the tracers. real :: Isecs_per_year ! The number of seconds in a year. real :: year ! The time in years. - integer :: secs, days ! Integer components of the time type. integer :: i, j, k, is, ie, js, je, nz, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -378,7 +328,7 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, do m=1,CS%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; + enddo ; enddo ; enddo call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m) , dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) @@ -392,8 +342,7 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, Isecs_per_year = 1.0 / (365.0*86400.0) ! Set the surface value of tracer 1 to increase exponentially ! with a 30 year time scale. - call get_time(CS%Time, secs, days) - year = (86400.0*days + real(secs)) * Isecs_per_year + year = time_type_to_real(CS%Time) * Isecs_per_year do m=1,CS%ntr if (CS%sfc_growth_rate(m) == 0.0) then @@ -420,32 +369,26 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, end subroutine ideal_age_tracer_column_physics +!> Calculates the mass-weighted integral of all tracer stocks, returning the number of stocks it +!! has calculated. If stock_index is present, only the stock corresponding to that coded index is found. function ideal_age_stock(h, stocks, G, GV, CS, names, units, stock_index) 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, in H (usually m or kg m-2) - real, dimension(:), intent(out) :: stocks + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of each + !! tracer, in kg times concentration units [kg conc]. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - type(ideal_age_tracer_CS), pointer :: CS - character(len=*), dimension(:), intent(out) :: names - character(len=*), dimension(:), intent(out) :: units - integer, optional, intent(in) :: stock_index - integer :: ideal_age_stock + type(ideal_age_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_ideal_age_tracer. + character(len=*), dimension(:), intent(out) :: names !< the names of the stocks calculated. + character(len=*), dimension(:), intent(out) :: units !< the units of the stocks calculated. + integer, optional, intent(in) :: stock_index !< the coded index of a specific stock + !! being sought. + integer :: ideal_age_stock !< The number of stocks calculated here. ! This function calculates the mass-weighted integral of all tracer stocks, ! returning the number of stocks it has calculated. If the stock_index ! is present, only the stock corresponding to that coded index is returned. -! Arguments: h - Layer thickness, in m or kg m-2. -! (out) stocks - the mass-weighted integrated amount of each tracer, -! in kg times concentration units. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - The control structure returned by a previous call to -! register_ideal_age_tracer. -! (out) names - the names of the stocks calculated. -! (out) units - the units of the stocks calculated. -! (in,opt) stock_index - the coded index of a specific stock being sought. -! Return value: the number of stocks calculated here. - integer :: i, j, k, is, ie, js, je, nz, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -482,7 +425,7 @@ subroutine ideal_age_tracer_surface_state(state, h, G, CS) type(surface), intent(inout) :: state !< A structure containing fields that !! describe the surface state of the ocean. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< Layer thickness, in m or kg m-2. + intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. type(ideal_age_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_ideal_age_tracer. @@ -507,8 +450,11 @@ subroutine ideal_age_tracer_surface_state(state, h, G, CS) end subroutine ideal_age_tracer_surface_state +!> Deallocate any memory associated with this tracer package subroutine ideal_age_example_end(CS) - type(ideal_age_tracer_CS), pointer :: CS + type(ideal_age_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_ideal_age_tracer. + integer :: m if (associated(CS)) then @@ -517,4 +463,15 @@ subroutine ideal_age_example_end(CS) endif end subroutine ideal_age_example_end +!> \namespace ideal_age_example +!! +!! Originally by Robert Hallberg, 2002 +!! +!! This file contains an example of the code that is needed to set +!! up and use a set (in this case two) of dynamically passive tracers +!! for diagnostic purposes. The tracers here are an ideal age tracer +!! that ages at a rate of 1/year once it is isolated from the surface, +!! and a vintage tracer, whose surface concentration grows exponen- +!! with time with a 30-year timescale (similar to CFCs). + end module ideal_age_example diff --git a/src/tracer/oil_tracer.F90 b/src/tracer/oil_tracer.F90 index e7071f9431..6156c20e24 100644 --- a/src/tracer/oil_tracer.F90 +++ b/src/tracer/oil_tracer.F90 @@ -1,42 +1,8 @@ +!> A tracer package to mimic dissolved oil. module oil_tracer ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Robert Hallberg, 2002 * -!* * -!* This file contains an example of the code that is needed to set * -!* up and use a set (in this case two) of dynamically passive tracers * -!* for diagnostic purposes. The tracers here are an ideal age tracer * -!* that ages at a rate of 1/year once it is isolated from the surface,* -!* and a vintage tracer, whose surface concentration grows exponen- * -!* with time with a 30-year timescale (similar to CFCs). * -!* * -!* A single subroutine is called from within each file to register * -!* each of the tracers for reinitialization and advection and to * -!* register the subroutine that initializes the tracers and set up * -!* their output and the subroutine that does any tracer physics or * -!* chemistry along with diapycnal mixing (included here because some * -!* tracers may float or swim vertically or dye diapycnal processes). * -!* * -!* * -!* Macros written all in capital letters are defined in MOM_memory.h. * -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q * -!* j+1 > o > o > At ^: v * -!* j x ^ x ^ x At >: u * -!* j > o > o > At o: h, tr * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** - 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 @@ -48,12 +14,12 @@ module oil_tracer use MOM_open_boundary, only : ocean_OBC_type use MOM_restart, only : query_initialized, MOM_restart_CS use MOM_sponge, only : set_up_sponge_field, sponge_CS -use MOM_time_manager, only : time_type, get_time +use MOM_time_manager, only : time_type, time_type_to_real use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_tracer_Z_init, only : tracer_Z_init -use MOM_variables, only : surface -use MOM_variables, only : thermo_var_ptrs +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface, thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use coupler_types_mod, only : coupler_type_set_data, ind_csurf @@ -67,74 +33,63 @@ module oil_tracer public oil_tracer_column_physics, oil_tracer_surface_state public oil_stock, oil_tracer_end -! NTR_MAX is the maximum number of tracers in this module. -integer, parameter :: NTR_MAX = 20 +integer, parameter :: NTR_MAX = 20 !< the maximum number of tracers in this module. +!> The control structure for the oil tracer package type, public :: oil_tracer_CS ; private - integer :: ntr ! The number of tracers that are actually used. - logical :: coupled_tracers = .false. ! These tracers are not offered to the - ! coupler. - character(len=200) :: IC_file ! The file in which the age-tracer initial values - ! can be found, or an empty string for internal initialization. - logical :: Z_IC_file ! If true, the IC_file is in Z-space. The default is false. - real :: oil_source_longitude, oil_source_latitude ! Lat,lon of source location (geographic) - integer :: oil_source_i=-999, oil_source_j=-999 ! Local i,j of source location (computational) - real :: oil_source_rate ! Rate of oil injection (kg/s) - real :: oil_start_year ! The year in which tracers start aging, or at which the - ! surface value equals young_val, in years. - real :: oil_end_year ! The year in which tracers start aging, or at which the - ! surface value equals young_val, in years. - type(time_type), pointer :: Time ! A pointer to the ocean model's clock. - type(tracer_registry_type), pointer :: tr_Reg => NULL() - real, pointer :: tr(:,:,:,:) => NULL() ! The array of tracers used in this - ! subroutine, in g m-3? - real, dimension(NTR_MAX) :: & - IC_val = 0.0, & ! The (uniform) initial condition value. - young_val = 0.0, & ! The value assigned to tr at the surface. - land_val = -1.0, & ! The value of tr used where land is masked out. - sfc_growth_rate ! The exponential growth rate for the surface value, - ! in units of year-1. - real, dimension(NTR_MAX) :: oil_decay_days, & ! Decay time scale of oil (in days) - oil_decay_rate ! Decay rate of oil (in s^-1) calculated from oil_decay_days - integer, dimension(NTR_MAX) :: oil_source_k ! Layer of source - logical :: oil_may_reinit ! If true, oil may go through the - ! initialization code if they are not found in the - ! restart files. - integer, dimension(NTR_MAX) :: & - ind_tr ! Indices returned by aof_set_coupler_flux if it is used and the - ! surface tracer concentrations are to be provided to the coupler. - - type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the - ! timing of diagnostic output. - type(MOM_restart_CS), pointer :: restart_CSp => NULL() - - type(vardesc) :: tr_desc(NTR_MAX) + integer :: ntr !< The number of tracers that are actually used. + logical :: coupled_tracers = .false. !< These tracers are not offered to the coupler. + character(len=200) :: IC_file !< The file in which the age-tracer initial values + !! can be found, or an empty string for internal initialization. + logical :: Z_IC_file !< If true, the IC_file is in Z-space. The default is false. + real :: oil_source_longitude !< Latitude of source location (geographic) + real :: oil_source_latitude !< Longitude of source location (geographic) + integer :: oil_source_i=-999 !< Local i of source location (computational) + integer :: oil_source_j=-999 !< Local j of source location (computational) + real :: oil_source_rate !< Rate of oil injection [kg s-1] + real :: oil_start_year !< The year in which tracers start aging, or at which the + !! surface value equals young_val, in years. + real :: oil_end_year !< The year in which tracers start aging, or at which the + !! surface value equals young_val, in years. + type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. + type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the MOM tracer registry + real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this subroutine, in g m-3? + real, dimension(NTR_MAX) :: IC_val = 0.0 !< The (uniform) initial condition value. + real, dimension(NTR_MAX) :: young_val = 0.0 !< The value assigned to tr at the surface. + real, dimension(NTR_MAX) :: land_val = -1.0 !< The value of tr used where land is masked out. + real, dimension(NTR_MAX) :: sfc_growth_rate !< The exponential growth rate for the surface value [year-1]. + real, dimension(NTR_MAX) :: oil_decay_days !< Decay time scale of oil [days] + real, dimension(NTR_MAX) :: oil_decay_rate !< Decay rate of oil [s-1] calculated from oil_decay_days + integer, dimension(NTR_MAX) :: oil_source_k !< Layer of source + logical :: oil_may_reinit !< If true, oil tracers may be reset by the initialization code + !! if they are not found in the restart files. + integer, dimension(NTR_MAX) :: ind_tr !< Indices returned by aof_set_coupler_flux if it is used and the + !! surface tracer concentrations are to be provided to the coupler. + type(vardesc) :: tr_desc(NTR_MAX) !< Descriptions and metadata for the tracers + + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< A pointer to the restart control structure end type oil_tracer_CS contains +!> Register oil tracer fields and subroutines to be used with MOM. function register_oil_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) - type(hor_index_type), intent(in) :: HI + 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 !< A structure to parse for run-time parameters - type(oil_tracer_CS), pointer :: CS - type(tracer_registry_type), pointer :: tr_Reg - type(MOM_restart_CS), pointer :: restart_CS -! This subroutine is used to register tracer fields and subroutines -! to be used with MOM. -! Arguments: HI - A horizontal index type structure. -! (in) GV - The ocean's vertical grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in/out) CS - A pointer that is set to point to the control structure -! for this module -! (in/out) tr_Reg - A pointer that is set to point to the control structure -! for the tracer advection and diffusion module. -! (in) restart_CS - A pointer to the restart control structure. - + type(oil_tracer_CS), pointer :: CS !< A pointer that is set to point to the control + !! structure for this module + type(tracer_registry_type), pointer :: tr_Reg !< A pointer that is set to point to the control + !! structure for the tracer advection and + !! diffusion module + type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure + + ! Local variables + character(len=40) :: mdl = "oil_tracer" ! This module's name. ! This include declares and sets the variable "version". #include "version_variable.h" - character(len=40) :: mdl = "oil_tracer" ! This module's name. character(len=200) :: inputdir ! The directory where the input files are. character(len=48) :: var_name ! The variable's name. character(len=3) :: name_tag ! String for creating identifying oils @@ -245,36 +200,29 @@ function register_oil_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) end function register_oil_tracer -subroutine initialize_oil_tracer(restart, day, G, GV, h, diag, OBC, CS, & +!> 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) - logical, intent(in) :: restart - type(time_type), target, intent(in) :: day + 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. 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 !< Layer thicknesses, in H (usually m or kg m-2) - type(diag_ctrl), target, intent(in) :: diag - type(ocean_OBC_type), pointer :: OBC - type(oil_tracer_CS), pointer :: CS - type(sponge_CS), pointer :: sponge_CSp - type(diag_to_Z_CS), pointer :: diag_to_Z_CSp -! This subroutine initializes the CS%ntr tracer fields in tr(:,:,:,:) -! and it sets up the tracer output. - -! Arguments: restart - .true. if the fields have already been read from -! a restart file. -! (in) day - Time of the start of the run. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) h - Layer thickness, in m or kg m-2. -! (in) diag - A structure that is used to regulate diagnostic output. -! (in) OBC - This open boundary condition type specifies whether, where, -! and what open boundary conditions are used. -! (in/out) CS - The control structure returned by a previous call to -! register_oil_tracer. -! (in/out) sponge_CSp - A pointer to the control structure for the sponges, if -! they are in use. Otherwise this may be unassociated. -! (in/out) diag_to_Z_Csp - A pointer to the control structure for diagnostics -! in depth space. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(diag_ctrl), target, intent(in) :: diag !< A structure that is 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. + 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. character(len=72) :: longname ! The long name of that variable. character(len=48) :: units ! The dimensions of the variable. @@ -301,7 +249,7 @@ subroutine initialize_oil_tracer(restart, day, G, GV, h, diag, OBC, CS, & CS%oil_source_i=i CS%oil_source_j=j endif - enddo; enddo + enddo ; enddo CS%Time => day CS%diag => diag @@ -319,10 +267,10 @@ subroutine initialize_oil_tracer(restart, day, G, GV, h, diag, OBC, CS, & if (CS%Z_IC_file) then OK = tracer_Z_init(CS%tr(:,:,:,m), h, CS%IC_file, name, & - G, -1e34, 0.0) ! CS%land_val(m)) + G, US, -1e34, 0.0) ! CS%land_val(m)) if (.not.OK) then OK = tracer_Z_init(CS%tr(:,:,:,m), h, CS%IC_file, & - trim(name), G, -1e34, 0.0) ! CS%land_val(m)) + trim(name), G, US, -1e34, 0.0) ! CS%land_val(m)) if (.not.OK) call MOM_error(FATAL,"initialize_oil_tracer: "//& "Unable to read "//trim(name)//" from "//& trim(CS%IC_file)//".") @@ -349,44 +297,44 @@ subroutine initialize_oil_tracer(restart, day, G, GV, h, diag, OBC, CS, & end subroutine initialize_oil_tracer +!> Apply sources, sinks, diapycnal mixing and rising motions to the oil tracers subroutine oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, tv, & 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, h_new, ea, eb - type(forcing), intent(in) :: fluxes - real, intent(in) :: dt !< The amount of time covered by this call, in s - type(oil_tracer_CS), pointer :: CS - type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables - real, optional,intent(in) :: evap_CFL_limit - real, optional,intent(in) :: 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 thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call [s] + type(oil_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_oil_tracer. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + 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] ! 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. -! Arguments: h_old - Layer thickness before entrainment, in m or kg m-2. -! (in) h_new - Layer thickness after entrainment, in m or kg m-2. -! (in) ea - an array to which the amount of fluid entrained -! from the layer above during this call will be -! added, in m or kg m-2. -! (in) eb - an array to which the amount of fluid entrained -! from the layer below during this call will be -! added, in m or kg m-2. -! (in) fluxes - A structure containing pointers to any possible -! forcing fields. Unused fields have NULL ptrs. -! (in) dt - The amount of time covered by this call, in s. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - The control structure returned by a previous call to -! register_oil_tracer. -! ! 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] +! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) + ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_work ! Used so that h can be modified real :: Isecs_per_year = 1.0 / (365.0*86400.0) real :: year, h_total, ldecay - integer :: secs, days integer :: i, j, k, is, ie, js, je, nz, m, k_max is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -397,7 +345,7 @@ subroutine oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS do m=1,CS%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; + enddo ; enddo ; enddo call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m) , dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) @@ -408,10 +356,7 @@ subroutine oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS enddo endif - ! Set the surface value of tracer 1 to increase exponentially - ! with a 30 year time scale. - call get_time(CS%Time, secs, days) - year = (86400.0*days + real(secs)) * Isecs_per_year + year = time_type_to_real(CS%Time) * Isecs_per_year ! Decay tracer (limit decay rate to 1/dt - just in case) do m=2,CS%ntr @@ -421,8 +366,8 @@ subroutine oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS if (CS%oil_decay_rate(m)>0.) then CS%tr(i,j,k,m) = G%mask2dT(i,j)*max(1.-dt*CS%oil_decay_rate(m),0.)*CS%tr(i,j,k,m) ! Safest elseif (CS%oil_decay_rate(m)<0.) then - ldecay = 12.*(3.0**(-(tv%T(i,j,k)-20.)/10.)) ! Timescale in days - ldecay = 1./(86400.*ldecay) ! Rate in s^-1 + ldecay = 12.*(3.0**(-(tv%T(i,j,k)-20.)/10.)) ! Timescale [days] + ldecay = 1./(86400.*ldecay) ! Rate [s-1] CS%tr(i,j,k,m) = G%mask2dT(i,j)*max(1.-dt*ldecay,0.)*CS%tr(i,j,k,m) endif enddo ; enddo ; enddo @@ -458,32 +403,27 @@ subroutine oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS end subroutine oil_tracer_column_physics +!> Calculate the mass-weighted integral of the oil tracer stocks, returning the number of stocks it +!! has calculated. If the stock_index is present, only the stock corresponding to that coded index is returned. function oil_stock(h, stocks, G, GV, CS, names, units, stock_index) 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 !< Layer thicknesses, in H (usually m or kg m-2) - real, dimension(:), intent(out) :: stocks - type(oil_tracer_CS), pointer :: CS - character(len=*), dimension(:), intent(out) :: names - character(len=*), dimension(:), intent(out) :: units - integer, optional, intent(in) :: stock_index - integer :: oil_stock + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of each + !! tracer, in kg times concentration units [kg conc]. + type(oil_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_oil_tracer. + character(len=*), dimension(:), intent(out) :: names !< the names of the stocks calculated. + character(len=*), dimension(:), intent(out) :: units !< the units of the stocks calculated. + integer, optional, intent(in) :: stock_index !< the coded index of a specific stock + !! being sought. + integer :: oil_stock !< The number of stocks calculated here. + ! This function calculates the mass-weighted integral of all tracer stocks, ! returning the number of stocks it has calculated. If the stock_index ! is present, only the stock corresponding to that coded index is returned. -! Arguments: h - Layer thickness, in m or kg m-2. -! (out) stocks - the mass-weighted integrated amount of each tracer, -! in kg times concentration units. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - The control structure returned by a previous call to -! register_oil_tracer. -! (out) names - the names of the stocks calculated. -! (out) units - the units of the stocks calculated. -! (in,opt) stock_index - the coded index of a specific stock being sought. -! Return value: the number of stocks calculated here. - + ! Local variables integer :: i, j, k, is, ie, js, je, nz, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -520,7 +460,7 @@ subroutine oil_tracer_surface_state(state, h, G, CS) type(surface), intent(inout) :: state !< A structure containing fields that !! describe the surface state of the ocean. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< Layer thickness, in m or kg m-2. + intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. type(oil_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_oil_tracer. @@ -545,8 +485,10 @@ subroutine oil_tracer_surface_state(state, h, G, CS) end subroutine oil_tracer_surface_state +!> Deallocate memory associated with this tracer package subroutine oil_tracer_end(CS) - type(oil_tracer_CS), pointer :: CS + type(oil_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_oil_tracer. integer :: m if (associated(CS)) then @@ -555,4 +497,18 @@ subroutine oil_tracer_end(CS) endif end subroutine oil_tracer_end +!> \namespace oil_tracer +!! +!! By Alistair Adcroft and Robert Hallberg, 2010 * +!! +!! In the midst of the Deepwater Horizon oil spill, it became evident that +!! models were needed to predict the long-term fate of dissolved oil in the +!! open ocean. This tracer packages mimics the transport, dilution and decay +!! of dissolved oil plumes in the ocean. +!! +!! This tracer package was central to the simulations used by Adcroft et al., +!! GRL 2010, to prove that the Deepwater Horizon spill was an important regional +!! event, with implications for dissolved oxygen levels in the Gulf of Mexico, +!! but not one that would directly impact the East Coast of the U.S. + end module oil_tracer diff --git a/src/tracer/pseudo_salt_tracer.F90 b/src/tracer/pseudo_salt_tracer.F90 index 479de3d059..e41ab90095 100644 --- a/src/tracer/pseudo_salt_tracer.F90 +++ b/src/tracer/pseudo_salt_tracer.F90 @@ -1,40 +1,8 @@ +!> A tracer package that mimics salinity module pseudo_salt_tracer ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Andrew Shao, 2016 * -!* * -!* This file contains the routines necessary to model a passive * -!* tracer that uses the same boundary fluxes as salinity. At the * -!* beginning of the run, salt is set to the same as tv%S. Any * -!* deviations between this salt-like tracer and tv%S signifies a * -!* difference between how active and passive tracers are treated. * -!* A single subroutine is called from within each file to register * -!* each of the tracers for reinitialization and advection and to * -!* register the subroutine that initializes the tracers and set up * -!* their output and the subroutine that does any tracer physics or * -!* chemistry along with diapycnal mixing (included here because some * -!* tracers may float or swim vertically or dye diapycnal processes). * -!* * -!* * -!* Macros written all in capital letters are defined in MOM_memory.h. * -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q * -!* j+1 > o > o > At ^: v * -!* j x ^ x ^ x At >: u * -!* j > o > o > At o: h, tr * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** - 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 @@ -48,7 +16,7 @@ module pseudo_salt_tracer use MOM_open_boundary, only : ocean_OBC_type use MOM_restart, only : query_initialized, MOM_restart_CS use MOM_sponge, only : set_up_sponge_field, sponge_CS -use MOM_time_manager, only : time_type, get_time +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_tracer_Z_init, only : tracer_Z_init @@ -67,51 +35,48 @@ module pseudo_salt_tracer public pseudo_salt_tracer_column_physics, pseudo_salt_tracer_surface_state public pseudo_salt_stock, pseudo_salt_tracer_end +!> The control structure for the pseudo-salt tracer type, public :: pseudo_salt_tracer_CS ; private - type(time_type), pointer :: Time ! A pointer to the ocean model's clock. - type(tracer_registry_type), pointer :: tr_Reg => NULL() - real, pointer :: ps(:,:,:) => NULL() ! The array of pseudo-salt tracer used in this - ! subroutine, in psu - real, pointer :: diff(:,:,:) => NULL() ! The difference between the pseudo-salt - ! tracer and the real salt, in psu. - logical :: pseudo_salt_may_reinit = .true. ! Hard coding since this should not matter + type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. + type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the MOM tracer registry + real, pointer :: ps(:,:,:) => NULL() !< The array of pseudo-salt tracer used in this + !! subroutine [ppt} + real, pointer :: diff(:,:,:) => NULL() !< The difference between the pseudo-salt + !! tracer and the real salt [ppt]. + logical :: pseudo_salt_may_reinit = .true. !< Hard coding since this should not matter - integer :: id_psd = -1 + integer :: id_psd = -1 !< A diagnostic ID - type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the - ! timing of diagnostic output. - type(MOM_restart_CS), pointer :: restart_CSp => NULL() + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< A pointer to the restart control structure - type(vardesc) :: tr_desc + type(vardesc) :: tr_desc !< A description and metadata for the pseudo-salt tracer end type pseudo_salt_tracer_CS contains +!> Register the pseudo-salt tracer with MOM6 function register_pseudo_salt_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) - type(hor_index_type), intent(in) :: HI + 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 !< A structure to parse for run-time parameters - type(pseudo_salt_tracer_CS), pointer :: CS - type(tracer_registry_type), pointer :: tr_Reg - type(MOM_restart_CS), pointer :: restart_CS + type(pseudo_salt_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_pseudo_salt_tracer. + type(tracer_registry_type), pointer :: tr_Reg !< A pointer that is set to point to the control + !! structure for the tracer advection and + !! diffusion module + type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure ! This subroutine is used to register tracer fields and subroutines ! to be used with MOM. -! Arguments: HI - A horizontal index type structure. -! (in) GV - The ocean's vertical grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in/out) CS - A pointer that is set to point to the control structure -! for this module -! (in/out) tr_Reg - A pointer that is set to point to the control structure -! for the tracer advection and diffusion module. -! (in) restart_CS - A pointer to the restart control structure. -! This include declares and sets the variable "version". -#include "version_variable.h" + ! Local variables character(len=40) :: mdl = "pseudo_salt_tracer" ! This module's name. character(len=200) :: inputdir ! The directory where the input files are. character(len=48) :: var_name ! The variable's name. character(len=3) :: name_tag ! String for creating identifying pseudo_salt +! This include declares and sets the variable "version". +#include "version_variable.h" real, pointer :: tr_ptr(:,:,:) => NULL() logical :: register_pseudo_salt_tracer integer :: isd, ied, jsd, jed, nz, i, j @@ -147,36 +112,30 @@ function register_pseudo_salt_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) 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) - logical, intent(in) :: restart - type(time_type), target, intent(in) :: day + 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. 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 !< Layer thicknesses, in H (usually m or kg m-2) - type(diag_ctrl), target, intent(in) :: diag - type(ocean_OBC_type), pointer :: OBC - type(pseudo_salt_tracer_CS), pointer :: CS - type(sponge_CS), pointer :: sponge_CSp - type(diag_to_Z_CS), pointer :: diag_to_Z_CSp + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(diag_ctrl), target, intent(in) :: diag !< A structure that is 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. + 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(:,:,:). -! Arguments: restart - .true. if the fields have already been read from -! a restart file. -! (in) day - Time of the start of the run. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) h - Layer thickness, in m or kg m-2. -! (in) diag - A structure that is used to regulate diagnostic output. -! (in) OBC - This open boundary condition type specifies whether, where, -! and what open boundary conditions are used. -! (in/out) CS - The control structure returned by a previous call to -! register_pseudo_salt_tracer. -! (in/out) sponge_CSp - A pointer to the control structure for the sponges, if -! they are in use. Otherwise this may be unassociated. -! (in/out) 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. character(len=72) :: longname ! The long name of that variable. character(len=48) :: units ! The dimensions of the variable. @@ -213,58 +172,48 @@ subroutine initialize_pseudo_salt_tracer(restart, day, G, GV, h, diag, OBC, CS, end subroutine initialize_pseudo_salt_tracer +!> Apply sources, sinks and diapycnal diffusion to the tracers in this package. subroutine pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, tv, debug, & 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, h_new, ea, eb - type(forcing), intent(in) :: fluxes - real, intent(in) :: dt !< The amount of time covered by this call, in s - type(pseudo_salt_tracer_CS), pointer :: CS - type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables - logical, intent(in) :: debug - real, optional,intent(in) :: evap_CFL_limit - real, optional,intent(in) :: 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 thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call [s] + type(pseudo_salt_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_pseudo_salt_tracer. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + logical, intent(in) :: debug !< If true calculate checksums + 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] ! 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. - -! Arguments: h_old - Layer thickness before entrainment, in m or kg m-2. -! (in) h_new - Layer thickness after entrainment, in m or kg m-2. -! (in) ea - an array to which the amount of fluid entrained -! from the layer above during this call will be -! added, in m or kg m-2. -! (in) eb - an array to which the amount of fluid entrained -! from the layer below during this call will be -! added, in m or kg m-2. -! (in) fluxes - A structure containing pointers to any possible -! forcing fields. Unused fields have NULL ptrs. -! (in) dt - The amount of time covered by this call, in s. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - The control structure returned by a previous call to -! register_pseudo_salt_tracer. -! (in) tv - Thermodynamic structure with T and S -! (in) evap_CFL_limit - Limits how much water can be fluxed out of the top layer -! Stored previously in diabatic CS. -! (in) minimum_forcing_depth - The smallest depth over which fluxes can be applied -! Stored previously in diabatic CS. -! (in) debug - Calculates checksums -! + ! 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] +! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) - real :: Isecs_per_year = 1.0 / (365.0*86400.0) + ! Local variables real :: year, h_total, scale, htot, Ih_limit integer :: secs, days integer :: i, j, k, is, ie, js, je, nz, k_max - real, allocatable :: local_tr(:,:,:) real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_work ! Used so that h can be modified - real, dimension(:,:), pointer :: net_salt is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - net_salt=>fluxes%netSalt if (.not.associated(CS)) return if (.not.associated(CS%diff)) return @@ -276,11 +225,11 @@ subroutine pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G ! This uses applyTracerBoundaryFluxesInOut, usually in ALE mode if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then - do k=1,nz ;do j=js,je ; do i=is,ie + 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; + enddo ; enddo ; enddo call applyTracerBoundaryFluxesInOut(G, GV, CS%ps, dt, fluxes, h_work, & - evap_CFL_limit, minimum_forcing_depth, out_flux_optional=net_salt) + evap_CFL_limit, minimum_forcing_depth, out_flux_optional=fluxes%netSalt) call tracer_vertdiff(h_work, ea, eb, dt, CS%ps, G, GV) else call tracer_vertdiff(h_old, ea, eb, dt, CS%ps, G, GV) @@ -290,7 +239,7 @@ subroutine pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G CS%diff(i,j,k) = CS%ps(i,j,k)-tv%S(i,j,k) enddo ; enddo ; enddo - if(debug) then + if (debug) then call hchksum(tv%S,"salt post pseudo-salt vertdiff", G%HI) call hchksum(CS%ps,"pseudo_salt post pseudo-salt vertdiff", G%HI) endif @@ -299,32 +248,28 @@ subroutine pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G end subroutine pseudo_salt_tracer_column_physics + +!> Calculates the mass-weighted integral of all tracer stocks, returning the number of stocks it has +!! calculated. If the stock_index is present, only the stock corresponding to that coded index is returned. function pseudo_salt_stock(h, stocks, G, GV, CS, names, units, stock_index) 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 !< Layer thicknesses, in H (usually m or kg m-2) - real, dimension(:), intent(out) :: stocks - type(pseudo_salt_tracer_CS), pointer :: CS - character(len=*), dimension(:), intent(out) :: names - character(len=*), dimension(:), intent(out) :: units - integer, optional, intent(in) :: stock_index - integer :: pseudo_salt_stock + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of each + !! tracer, in kg times concentration units [kg conc]. + type(pseudo_salt_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_pseudo_salt_tracer. + character(len=*), dimension(:), intent(out) :: names !< The names of the stocks calculated. + character(len=*), dimension(:), intent(out) :: units !< The units of the stocks calculated. + integer, optional, intent(in) :: stock_index !< The coded index of a specific stock + !! being sought. + integer :: pseudo_salt_stock !< Return value: the number of + !! stocks calculated here. + ! This function calculates the mass-weighted integral of all tracer stocks, ! returning the number of stocks it has calculated. If the stock_index ! is present, only the stock corresponding to that coded index is returned. -! Arguments: h - Layer thickness, in m or kg m-2. -! (out) stocks - the mass-weighted integrated amount of each tracer, -! in kg times concentration units. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - The control structure returned by a previous call to -! register_pseudo_salt_tracer. -! (out) names - the names of the stocks calculated. -! (out) units - the units of the stocks calculated. -! (in,opt) stock_index - the coded index of a specific stock being sought. -! Return value: the number of stocks calculated here. - integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -360,7 +305,7 @@ subroutine pseudo_salt_tracer_surface_state(state, h, G, CS) type(surface), intent(inout) :: state !< A structure containing fields that !! describe the surface state of the ocean. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< Layer thickness, in m or kg m-2. + intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. type(pseudo_salt_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_pseudo_salt_tracer. @@ -377,8 +322,10 @@ subroutine pseudo_salt_tracer_surface_state(state, h, G, CS) end subroutine pseudo_salt_tracer_surface_state +!> Deallocate memory associated with this tracer package subroutine pseudo_salt_tracer_end(CS) - type(pseudo_salt_tracer_CS), pointer :: CS + type(pseudo_salt_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_pseudo_salt_tracer. integer :: m if (associated(CS)) then @@ -388,4 +335,14 @@ subroutine pseudo_salt_tracer_end(CS) endif end subroutine pseudo_salt_tracer_end +!> \namespace pseudo_salt_tracer +!! +!! By Andrew Shao, 2016 +!! +!! This file contains the routines necessary to model a passive +!! tracer that uses the same boundary fluxes as salinity. At the +!! beginning of the run, salt is set to the same as tv%S. Any +!! deviations between this salt-like tracer and tv%S signifies a +!! difference between how active and passive tracers are treated. + end module pseudo_salt_tracer diff --git a/src/tracer/tracer_example.F90 b/src/tracer/tracer_example.F90 index 7035d72a26..26ea3fb957 100644 --- a/src/tracer/tracer_example.F90 +++ b/src/tracer/tracer_example.F90 @@ -1,38 +1,8 @@ +!> A sample tracer package that has striped initial conditions module USER_tracer_example ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Robert Hallberg, 2002 * -!* * -!* This file contains an example of the code that is needed to set * -!* up and use a set (in this case one) of dynamically passive tracers.* -!* * -!* A single subroutine is called from within each file to register * -!* each of the tracers for reinitialization and advection and to * -!* register the subroutine that initializes the tracers and set up * -!* their output and the subroutine that does any tracer physics or * -!* chemistry along with diapycnal mixing (included here because some * -!* tracers may float or swim vertically or dye diapycnal processes). * -!* * -!* * -!* Macros written all in capital letters are defined in MOM_memory.h. * -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q * -!* j+1 > o > o > At ^: v * -!* j x ^ x ^ x At >: u * -!* j > o > o > At o: h, tr * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** - 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 @@ -44,7 +14,7 @@ module USER_tracer_example use MOM_open_boundary, only : ocean_OBC_type use MOM_restart, only : MOM_restart_CS use MOM_sponge, only : set_up_sponge_field, sponge_CS -use MOM_time_manager, only : time_type, get_time +use MOM_time_manager, only : time_type use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type @@ -59,45 +29,40 @@ module USER_tracer_example public USER_register_tracer_example, USER_initialize_tracer, USER_tracer_stock public tracer_column_physics, USER_tracer_surface_state, USER_tracer_example_end -! NTR is the number of tracers in this module. -integer, parameter :: NTR = 1 +integer, parameter :: NTR = 1 !< The number of tracers in this module. +!> The control structure for the USER_tracer_example module type, public :: USER_tracer_example_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() - real, pointer :: tr(:,:,:,:) => NULL() ! The array of tracers used in this - ! subroutine, in g m-3? - real :: land_val(NTR) = -1.0 ! The value of tr used where land is masked out. - logical :: use_sponge ! If true, sponges may be applied somewhere in the domain. - - integer, dimension(NTR) :: ind_tr ! Indices returned by aof_set_coupler_flux - ! if it is used and the surface tracer concentrations are to be - ! provided to the coupler. - - type(diag_ctrl), pointer :: diag ! A pointer to a structure of shareable - ! ocean diagnostic fields and control variables. - - type(vardesc) :: tr_desc(NTR) + 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 => NULL() !< 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 subroutine, in g m-3? + real :: land_val(NTR) = -1.0 !< The value of tr that is used where land is masked out. + logical :: use_sponge !< If true, sponges may be applied somewhere in the domain. + + integer, dimension(NTR) :: ind_tr !< Indices returned by aof_set_coupler_flux if it is used and the + !! surface tracer concentrations are to be provided to the coupler. + + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate the timing of diagnostic output. + + type(vardesc) :: tr_desc(NTR) !< Descriptions of each of the tracers. end type USER_tracer_example_CS contains -!> This subroutine is used to register tracer fields and subroutines -!! to be used with MOM. +!> This subroutine is used to register tracer fields and subroutines to be used with MOM. function USER_register_tracer_example(HI, GV, param_file, CS, tr_Reg, restart_CS) - type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. + 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 !< A structure to parse for run-time parameters type(USER_tracer_example_CS), pointer :: CS !< A pointer that is set to point to the control !! structure for this module type(tracer_registry_type), pointer :: tr_Reg !< A pointer that is set to point to the control !! structure for the tracer advection and - !! diffusion module. - type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure. + !! diffusion module + type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure ! Local variables character(len=80) :: name, longname @@ -174,13 +139,13 @@ end function USER_register_tracer_example subroutine USER_initialize_tracer(restart, day, G, GV, h, diag, OBC, CS, & sponge_CSp, diag_to_Z_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. + !! been read from a restart file. + type(time_type), target, intent(in) :: day !< Time of the start of the run. 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 !< Layer thicknesses, in H (usually m or kg m-2) - type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate !! diagnostic output. type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies !! whether, where, and what open boundary @@ -202,7 +167,7 @@ subroutine USER_initialize_tracer(restart, day, G, GV, h, diag, OBC, CS, & 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 :: dist2 ! The distance squared from a line [m2]. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m integer :: IsdB, IedB, JsdB, JedB, lntr @@ -296,25 +261,27 @@ end subroutine USER_initialize_tracer !! tracer physics or chemistry to the tracers from this file. !! This is a simple example of a set of advected passive tracers. !! 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] +!! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) subroutine tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, 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 - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_old !< Layer thickness before entrainment, - !! in m or kg m-2. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_new !< Layer thickness after entrainment, - !! in 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, in 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, in 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, in s - type(USER_tracer_example_CS), pointer :: CS !< The control structure returned by a previous - !! call to USER_register_tracer_example. + 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 thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call [s] + type(USER_tracer_example_CS), pointer :: CS !< The control structure returned by a previous + !! call to USER_register_tracer_example. ! Local variables real :: hold0(SZI_(G)) ! The original topmost layer thickness, @@ -323,8 +290,8 @@ subroutine tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS) real :: c1(SZI_(G),SZK_(G)) ! tridiagonal solver. real :: d1(SZI_(G)) ! d1=1-c1 is used by the tridiagonal solver. real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected, in m. - real :: b_denom_1 ! The first term in the denominator of b1, in m or kg m-2. + ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: b_denom_1 ! The first term in the denominator of b1 [H ~> m or kg m-2]. integer :: i, j, k, is, ie, js, je, nz, m ! The following array (trdc) determines the behavior of the tracer @@ -397,17 +364,17 @@ function USER_tracer_stock(h, stocks, G, GV, CS, names, units, stock_index) 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 !< Layer thicknesses, in H (usually m or kg m-2) + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] real, dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of each - !! tracer, in kg times concentration units. + !! tracer, in kg times concentration units [kg conc]. type(USER_tracer_example_CS), pointer :: CS !< The control structure returned by a !! previous call to register_USER_tracer. - character(len=*), dimension(:), intent(out) :: names !< the names of the stocks calculated. - character(len=*), dimension(:), intent(out) :: units !< the units of the stocks calculated. - integer, optional, intent(in) :: stock_index !< the coded index of a specific stock - !! being sought. + character(len=*), dimension(:), intent(out) :: names !< The names of the stocks calculated. + character(len=*), dimension(:), intent(out) :: units !< The units of the stocks calculated. + integer, optional, intent(in) :: stock_index !< The coded index of a specific stock + !! being sought. integer :: USER_tracer_stock !< Return value: the number of - !! stocks calculated here. + !! stocks calculated here. ! Local variables integer :: i, j, k, is, ie, js, je, nz, m @@ -444,7 +411,7 @@ subroutine USER_tracer_surface_state(state, h, G, CS) type(surface), intent(inout) :: state !< A structure containing fields that !! describe the surface state of the ocean. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(USER_tracer_example_CS), pointer :: CS !< The control structure returned by a previous !! call to register_USER_tracer. @@ -471,7 +438,8 @@ end subroutine USER_tracer_surface_state !> Clean up allocated memory at the end. subroutine USER_tracer_example_end(CS) - type(USER_tracer_example_CS), pointer :: CS + type(USER_tracer_example_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_USER_tracer. integer :: m if (associated(CS)) then @@ -480,4 +448,17 @@ subroutine USER_tracer_example_end(CS) endif end subroutine USER_tracer_example_end +!> \namespace user_tracer_example +!! +!! Original by Robert Hallberg, 2002 +!! +!! This file contains an example of the code that is needed to set +!! up and use a set (in this case one) of dynamically passive tracers. +!! +!! A single subroutine is called from within each file to register +!! each of the tracers for reinitialization and advection and to +!! register the subroutine that initializes the tracers and set up +!! their output and the subroutine that does any tracer physics or +!! chemistry along with diapycnal mixing (included here because some +!! tracers may float or swim vertically or dye diapycnal processes). end module USER_tracer_example diff --git a/src/user/BFB_initialization.F90 b/src/user/BFB_initialization.F90 index 2f84fc7dfa..31223d5686 100644 --- a/src/user/BFB_initialization.F90 +++ b/src/user/BFB_initialization.F90 @@ -1,33 +1,15 @@ +!> Initialization of the boundary-forced-basing configuration module BFB_initialization ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Robert Hallberg, April 1994 - June 2002 * -!* * -!* This subroutine initializes the fields for the simulations. * -!* The one argument passed to initialize, Time, is set to the * -!* current time of the simulation. The fields which are initialized * -!* here are: * -!* G%g_prime - The reduced gravity at each interface, in m s-2. * -!* G%Rlay - Layer potential density (coordinate variable) in kg m-3.* -!* If SPONGE is defined: * -!* A series of subroutine calls are made to set up the damping * -!* rates and reference profiles for all variables that are damped * -!* in the sponge. * -!* * -!* These variables are all set in the set of subroutines (in this * -!* file) BFB_initialize_sponges_southonly and BFB_set_coord. * -!* * -!********+*********+*********+*********+*********+*********+*********+** - use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe 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_sponge, only : set_up_sponge_field, initialize_sponge, sponge_CS use MOM_tracer_registry, only : tracer_registry_type +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_type use MOM_verticalGrid, only : verticalGrid_type @@ -38,18 +20,30 @@ module BFB_initialization public BFB_set_coord public BFB_initialize_sponges_southonly +! 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. + +!> Unsafe model variable +!! \todo Remove this module variable logical :: first_call = .true. contains +!> This subroutine specifies the vertical coordinate in terms of temperature at the surface and at the bottom. +!! This case is set up in such a way that the temperature of the topmost layer is equal to the SST at the +!! southern edge of the domain. The temperatures are then converted to densities of the top and bottom layers +!! and linearly interpolated for the intermediate layers. subroutine BFB_set_coord(Rlay, g_prime, GV, param_file, eqn_of_state) -! This subroutine specifies the vertical coordinate in terms of temperature at the surface and at the bottom. This case is set up in -! such a way that the temperature of the topmost layer is equal to the SST at the southern edge of the domain. The temperatures are -! then converted to densities of the top and bottom layers and linearly interpolated for the intermediate layers. - real, dimension(NKMEM_), intent(out) :: Rlay, g_prime + real, dimension(NKMEM_), intent(out) :: Rlay !< Layer potential density. + real, dimension(NKMEM_), intent(out) :: g_prime !< The reduced gravity at + !! each interface [m2 Z-1 s-2 ~> m s-2]. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(EOS_type), pointer :: eqn_of_state + type(EOS_type), pointer :: eqn_of_state !< Integer that selects the + !! equation of state. + ! Local variables real :: drho_dt, SST_s, T_bot, rho_top, rho_bot integer :: k, nz character(len=40) :: mdl = "BFB_set_coord" ! This subroutine's name. @@ -65,42 +59,40 @@ subroutine BFB_set_coord(Rlay, g_prime, GV, param_file, eqn_of_state) rho_bot = GV%rho0 + drho_dt*T_bot nz = GV%ke - !call MOM_error(FATAL, & - ! "BFB_initialization.F90, BFB_set_coord: " // & - ! "Unmodified user routine called - you must edit the routine to use it") do k = 1,nz Rlay(k) = (rho_bot - rho_top)/(nz-1)*real(k-1) + rho_top if (k >1) then - g_prime(k) = (Rlay(k) - Rlay(k-1))*GV%g_earth/GV%rho0 + g_prime(k) = (Rlay(k) - Rlay(k-1)) * GV%g_Earth/GV%rho0 else - g_prime(k) = GV%g_earth - end if + g_prime(k) = GV%g_Earth + endif !Rlay(:) = 0.0 !g_prime(:) = 0.0 - end do + enddo if (first_call) call write_BFB_log(param_file) end subroutine BFB_set_coord -subroutine BFB_initialize_sponges_southonly(G, use_temperature, tv, param_file, CSp, h) -! This subroutine sets up the sponges for the southern bouundary of the domain. Maximum damping occurs within 2 degrees lat of the -! boundary. The damping linearly decreases northward over the next 2 degrees. - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - logical, intent(in) :: use_temperature - type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(sponge_CS), pointer :: CSp - real, dimension(NIMEM_, NJMEM_, NKMEM_), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - !call MOM_error(FATAL, & - ! "BFB_initialization.F90, BFB_initialize_sponges: " // & - ! "Unmodified user routine called - you must edit the routine to use it") - - real :: eta(SZI_(G),SZJ_(G),SZK_(G)+1) ! A temporary array for eta. - real :: Idamp(SZI_(G),SZJ_(G)) ! The inverse damping rate, in s-1. - - real :: H0(SZK_(G)) - real :: min_depth +!> This subroutine sets up the sponges for the southern bouundary of the domain. Maximum damping occurs +!! within 2 degrees lat of the boundary. The damping linearly decreases northward over the next 2 degrees. +subroutine BFB_initialize_sponges_southonly(G, GV, US, use_temperature, tv, param_file, CSp, h) + 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 + logical, intent(in) :: use_temperature !< If true, temperature and salinity are used as + !! state variables. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(sponge_CS), pointer :: CSp !< A pointer to the sponge control structure + real, dimension(NIMEM_, NJMEM_, NKMEM_), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + + ! Local variables + real :: eta(SZI_(G),SZJ_(G),SZK_(G)+1) ! A temporary array for eta, in depth units [Z ~> m]. + real :: Idamp(SZI_(G),SZJ_(G)) ! The inverse damping rate [s-1]. + real :: H0(SZK_(G)) ! Resting layer thicknesses in depth units [Z ~> m]. + real :: min_depth ! The minimum ocean depth in depth units [Z ~> m]. real :: damp, e_dense, damp_new, slat, wlon, lenlat, lenlon, nlat character(len=40) :: mdl = "BFB_initialize_sponges_southonly" ! This subroutine's name. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz @@ -110,14 +102,14 @@ subroutine BFB_initialize_sponges_southonly(G, use_temperature, tv, param_file, eta(:,:,:) = 0.0 ; Idamp(:,:) = 0.0 -! Here the inverse damping time, in s-1, is set. Set Idamp to 0 ! +! Here the inverse damping time [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. ! ! Set up sponges for DOME configuration call get_param(param_file, mdl, "MINIMUM_DEPTH", min_depth, & - "The minimum depth of the ocean.", units="m", default=0.0) + "The minimum depth of the ocean.", units="m", default=0.0, scale=US%m_to_Z) call get_param(param_file, mdl, "SOUTHLAT", slat, & "The southern latitude of the domain.", units="degrees") @@ -129,7 +121,10 @@ subroutine BFB_initialize_sponges_southonly(G, use_temperature, tv, param_file, "The longitudinal length of the domain.", units="degrees") nlat = slat + lenlat do k=1,nz ; H0(k) = -G%max_depth * real(k-1) / real(nz) ; enddo -! do k=1,nz ; H0(k) = -G%max_depth * real(k-1) / real(nz-1) ; enddo ! Use for meridional thickness profile initialization + + ! Use for meridional thickness profile initialization +! do k=1,nz ; H0(k) = -G%max_depth * real(k-1) / real(nz-1) ; enddo + do i=is,ie; do j=js,je if (G%geoLatT(i,j) < slat+2.0) then ; damp = 1.0 elseif (G%geoLatT(i,j) < slat+4.0) then @@ -147,11 +142,12 @@ subroutine BFB_initialize_sponges_southonly(G, use_temperature, tv, param_file, ! do k = 1,nz; eta(i,j,k) = H0(k); enddo ! if (G%geoLatT(i,j) > 40.0) then ! do k = 1,nz - ! eta(i,j,k) = -G%Angstrom_z*(k-1) + ! eta(i,j,k) = -G%Angstrom_Z*(k-1) ! enddo ! elseif (G%geoLatT(i,j) > 20.0) then ! do k = 1,nz - ! eta(i,j,k) = min(H0(k) + (G%geoLatT(i,j) - 20.0)*(G%max_depth - nz*G%Angstrom_z)/20.0, -(k-1)*G%angstrom_z) + ! eta(i,j,k) = min(H0(k) + (G%geoLatT(i,j) - 20.0)*(G%max_depth - nz*G%Angstrom_Z)/20.0, & + ! -(k-1)*G%Angstrom_Z) ! enddo ! endif eta(i,j,nz+1) = -G%max_depth @@ -163,7 +159,7 @@ subroutine BFB_initialize_sponges_southonly(G, use_temperature, tv, param_file, ! This call sets up the damping rates and interface heights. ! This sets the inverse damping timescale fields in the sponges. ! - call initialize_sponge(Idamp, eta, G, param_file, CSp) + call initialize_sponge(Idamp, eta, G, param_file, CSp, GV) ! Now register all of the fields which are damped in the sponge. ! ! By default, momentum is advected vertically within the sponge, but ! diff --git a/src/user/BFB_surface_forcing.F90 b/src/user/BFB_surface_forcing.F90 index 7aa2943ff0..3d54df5955 100644 --- a/src/user/BFB_surface_forcing.F90 +++ b/src/user/BFB_surface_forcing.F90 @@ -1,20 +1,8 @@ +!> Surface forcing for the boundary-forced-basin (BFB) configuration module BFB_surface_forcing ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* Rewritten by Robert Hallberg, June 2009 * -!* * -!* This file contains subroutines for specifying surface buoyancy * -!* forcing for the buoyancy-forced basin (BFB) case. * -!* BFB_buoyancy_forcing is used to restore the surface buoayncy to * -!* a linear meridional ramp of temperature. The extent of the ramp * -!* can be specified by LFR_SLAT (linear forcing ramp southern * -!* latitude) and LFR_NLAT. The temperatures at these edges of the * -!* ramp can be specified by SST_S and SST_N. * -!* * -!********+*********+*********+*********+*********+*********+*********+** use MOM_diag_mediator, only : post_data, query_averaging_enabled use MOM_diag_mediator, only : register_diag_field, diag_ctrl use MOM_domains, only : pass_var, pass_vector, AGRID @@ -23,7 +11,8 @@ module BFB_surface_forcing use MOM_forcing_type, only : forcing, allocate_forcing_type use MOM_grid, only : ocean_grid_type use MOM_io, only : file_exists, read_data -use MOM_time_manager, only : time_type, operator(+), operator(/), get_time +use MOM_safe_alloc, only : safe_alloc_ptr +use MOM_time_manager, only : time_type, operator(+), operator(/) use MOM_tracer_flow_control, only : call_tracer_set_forcing use MOM_tracer_flow_control, only : tracer_flow_control_CS use MOM_variables, only : surface @@ -32,120 +21,81 @@ module BFB_surface_forcing public BFB_buoyancy_forcing, BFB_surface_forcing_init +!> Control structure for BFB_surface_forcing type, public :: BFB_surface_forcing_CS ; private - ! This control structure should be used to store any run-time variables - ! associated with the user-specified forcing. It can be readily modified - ! for a specific case, and because it is private there will be no changes - ! needed in other code (although they will have to be recompiled). - ! The variables in the cannonical example are used for some common - ! cases, but do not need to be used. - logical :: use_temperature ! If true, temperature and salinity are used as - ! state variables. - logical :: restorebuoy ! If true, use restoring surface buoyancy forcing. - real :: Rho0 ! The density used in the Boussinesq - ! approximation, in kg m-3. - real :: G_Earth ! The gravitational acceleration in m s-2. - real :: Flux_const ! The restoring rate at the surface, in m s-1. - real :: gust_const ! A constant unresolved background gustiness - ! that contributes to ustar, in Pa. - real :: SST_s ! SST at the southern edge of the linear - ! forcing ramp - real :: SST_n ! SST at the northern edge of the linear - ! forcing ramp - real :: lfrslat ! Southern latitude where the linear forcing ramp - ! begins - real :: lfrnlat ! Northern latitude where the linear forcing ramp - ! ends - real :: drho_dt ! Rate of change of density with temperature. - ! Note that temperature is being used as a dummy - ! variable here. All temperatures are converted - ! into density. - - type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the - ! timing of diagnostic output. + logical :: use_temperature !< If true, temperature and salinity are used as state variables. + logical :: restorebuoy !< If true, use restoring surface buoyancy forcing. + real :: Rho0 !< The density used in the Boussinesq approximation [kg m-3]. + real :: G_Earth !< The gravitational acceleration [m s-2] + real :: Flux_const !< The restoring rate at the surface [m s-1]. + real :: gust_const !< A constant unresolved background gustiness + !! that contributes to ustar [Pa]. + real :: SST_s !< SST at the southern edge of the linear forcing ramp [degC] + real :: SST_n !< SST at the northern edge of the linear forcing ramp [degC] + real :: lfrslat !< Southern latitude where the linear forcing ramp begins [degLat] + real :: lfrnlat !< Northern latitude where the linear forcing ramp ends [degLat] + real :: drho_dt !< Rate of change of density with temperature [kg m-3 degC-1]. + !! Note that temperature is being used as a dummy variable here. + !! All temperatures are converted into density. + + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. end type BFB_surface_forcing_CS contains +!> Bouyancy forcing for the boundary-forced-basin (BFB) configuration subroutine BFB_buoyancy_forcing(state, fluxes, day, dt, G, CS) - type(surface), intent(inout) :: state - type(forcing), intent(inout) :: fluxes - type(time_type), intent(in) :: day - real, intent(in) :: dt !< The amount of time over which - !! the fluxes apply, in s - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(BFB_surface_forcing_CS), pointer :: CS - -! This subroutine specifies the current surface fluxes of buoyancy or -! temperature and fresh water. It may also be modified to add -! surface fluxes of user provided tracers. - -! When temperature is used, there are long list of fluxes that need to be -! set - essentially the same as for a full coupled model, but most of these -! can be simply set to zero. The net fresh water flux should probably be -! set in fluxes%evap and fluxes%lprec, with any salinity restoring -! appearing in fluxes%vprec, and the other water flux components -! (fprec, lrunoff and frunoff) left as arrays full of zeros. -! Evap is usually negative and precip is usually positive. All heat fluxes -! are in W m-2 and positive for heat going into the ocean. All fresh water -! fluxes are in kg m-2 s-1 and positive for water moving into the ocean. - -! Arguments: state - A structure containing fields that describe the -! surface state of the ocean. -! (out) fluxes - A structure containing pointers to any possible -! forcing fields. Unused fields have NULL ptrs. -! (in) day_start - Start time of the fluxes. -! (in) day_interval - Length of time over which these fluxes -! will be applied. -! (in) G - The ocean's grid structure. -! (in) CS - A pointer to the control structure returned by a previous -! call to user_surface_forcing_init - - real :: Temp_restore ! The temperature that is being restored toward, in C. - real :: Salin_restore ! The salinity that is being restored toward, in PSU. + type(surface), intent(inout) :: state !< A structure containing fields that + !! describe the surface state of the ocean. + type(forcing), intent(inout) :: fluxes !< A structure containing pointers to any + !! possible forcing fields. Unused fields + !! have NULL ptrs. + type(time_type), intent(in) :: day !< Time of the fluxes. + real, intent(in) :: dt !< The amount of time over which + !! the fluxes apply [s] + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(BFB_surface_forcing_CS), pointer :: CS !< A pointer to the control structure + !! returned by a previous call to + !! BFB_surface_forcing_init. + ! Local variables + real :: Temp_restore ! The temperature that is being restored toward [degC]. + real :: Salin_restore ! The salinity that is being restored toward [ppt]. real :: density_restore ! The potential density that is being restored - ! toward, in kg m-3. - real :: rhoXcp ! The mean density times the heat capacity, in J m-3 K-1. + ! toward [kg m-3]. + real :: rhoXcp ! The mean density times the heat capacity [J m-3 degC-1]. real :: buoy_rest_const ! A constant relating density anomalies to the - ! restoring buoyancy flux, in m5 s-3 kg-1. + ! restoring buoyancy flux [m5 s-3 kg-1]. integer :: i, j, is, ie, js, je integer :: isd, ied, jsd, jed is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - ! When modifying the code, comment out this error message. It is here - ! so that the original (unmodified) version is not accidentally used. - ! call MOM_error(FATAL, "User_buoyancy_surface_forcing: " // & - ! "User forcing routine called without modification." ) - ! Allocate and zero out the forcing arrays, as necessary. This portion is ! usually not changed. if (CS%use_temperature) then - call alloc_if_needed(fluxes%evap, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%lprec, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%fprec, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%lrunoff, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%frunoff, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%vprec, isd, ied, jsd, jed) - - call alloc_if_needed(fluxes%sw, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%lw, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%latent, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%sens, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%evap, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%lprec, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%fprec, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%lrunoff, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%frunoff, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%vprec, isd, ied, jsd, jed) + + call safe_alloc_ptr(fluxes%sw, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%lw, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%latent, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%sens, isd, ied, jsd, jed) else ! This is the buoyancy only mode. - call alloc_if_needed(fluxes%buoy, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%buoy, isd, ied, jsd, jed) endif - - ! MODIFY THE CODE IN THE FOLLOWING LOOPS TO SET THE BUOYANCY FORCING TERMS. - if ( CS%use_temperature ) then ! Set whichever fluxes are to be used here. Any fluxes that ! are always zero do not need to be changed here. do j=js,je ; do i=is,ie - ! Fluxes of fresh water through the surface are in units of kg m-2 s-1 + ! Fluxes of fresh water through the surface are in units of [kg m-2 s-1] ! and are positive downward - i.e. evaporation should be negative. fluxes%evap(i,j) = -0.0 * G%mask2dT(i,j) fluxes%lprec(i,j) = 0.0 * G%mask2dT(i,j) @@ -153,7 +103,7 @@ subroutine BFB_buoyancy_forcing(state, fluxes, day, dt, G, CS) ! vprec will be set later, if it is needed for salinity restoring. fluxes%vprec(i,j) = 0.0 - ! Heat fluxes are in units of W m-2 and are positive into the ocean. + ! Heat fluxes are in units of [W m-2] and are positive into the ocean. fluxes%lw(i,j) = 0.0 * G%mask2dT(i,j) fluxes%latent(i,j) = 0.0 * G%mask2dT(i,j) fluxes%sens(i,j) = 0.0 * G%mask2dT(i,j) @@ -161,7 +111,7 @@ subroutine BFB_buoyancy_forcing(state, fluxes, day, dt, G, CS) enddo ; enddo else ! This is the buoyancy only mode. do j=js,je ; do i=is,ie - ! fluxes%buoy is the buoyancy flux into the ocean in m2 s-3. A positive + ! fluxes%buoy is the buoyancy flux into the ocean [m2 s-3]. A positive ! buoyancy flux is of the same sign as heating the ocean. fluxes%buoy(i,j) = 0.0 * G%mask2dT(i,j) enddo ; enddo @@ -169,7 +119,7 @@ subroutine BFB_buoyancy_forcing(state, fluxes, day, dt, G, CS) if (CS%restorebuoy) then if (CS%use_temperature) then - call alloc_if_needed(fluxes%heat_added, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%heat_added, isd, ied, jsd, jed) ! When modifying the code, comment out this error message. It is here ! so that the original (unmodified) version is not accidentally used. call MOM_error(FATAL, "User_buoyancy_surface_forcing: " // & @@ -177,8 +127,8 @@ subroutine BFB_buoyancy_forcing(state, fluxes, day, dt, G, CS) rhoXcp = CS%Rho0 * fluxes%C_p do j=js,je ; do i=is,ie - ! Set Temp_restore and Salin_restore to the temperature (in C) and - ! salinity (in PSU) that are being restored toward. + ! Set Temp_restore and Salin_restore to the temperature (in degC) and + ! salinity (in ppt) that are being restored toward. Temp_restore = 0.0 Salin_restore = 0.0 @@ -199,15 +149,15 @@ subroutine BFB_buoyancy_forcing(state, fluxes, day, dt, G, CS) Temp_restore = 0.0 do j=js,je ; do i=is,ie ! Set density_restore to an expression for the surface potential - ! density in kg m-3 that is being restored toward. + ! density [kg m-3] that is being restored toward. if (G%geoLatT(i,j) < CS%lfrslat) then Temp_restore = CS%SST_s - else if (G%geoLatT(i,j) > CS%lfrnlat) then + elseif (G%geoLatT(i,j) > CS%lfrnlat) then Temp_restore = CS%SST_n else Temp_restore = (CS%SST_s - CS%SST_n)/(CS%lfrslat - CS%lfrnlat) * & (G%geoLatT(i,j) - CS%lfrslat) + CS%SST_s - end if + endif density_restore = Temp_restore*CS%drho_dt + CS%Rho0 @@ -219,32 +169,14 @@ subroutine BFB_buoyancy_forcing(state, fluxes, day, dt, G, CS) end subroutine BFB_buoyancy_forcing -subroutine alloc_if_needed(ptr, isd, ied, jsd, jed) - ! If ptr is not associated, this routine allocates it with the given size - ! and zeros out its contents. This is equivalent to safe_alloc_ptr in - ! MOM_diag_mediator, but is here so as to be completely transparent. - real, pointer :: ptr(:,:) - integer :: isd, ied, jsd, jed - if (.not.associated(ptr)) then - allocate(ptr(isd:ied,jsd:jed)) - ptr(:,:) = 0.0 - endif -end subroutine alloc_if_needed - +!> Initialization for forcing the boundary-forced-basin (BFB) configuration subroutine BFB_surface_forcing_init(Time, G, param_file, diag, CS) - type(time_type), intent(in) :: Time - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(diag_ctrl), target, intent(in) :: diag - type(BFB_surface_forcing_CS), pointer :: CS -! Arguments: Time - The current model time. -! (in) G - The ocean's grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in) diag - A structure that is used to regulate diagnostic output. -! (in/out) CS - A pointer that is set to point to the control structure -! for this module - + type(time_type), intent(in) :: Time !< The current model time. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to + !! regulate diagnostic output. + type(BFB_surface_forcing_CS), pointer :: CS !< A pointer to the control structure for this module ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "BFB_surface_forcing" ! This module's name. diff --git a/src/user/DOME2d_initialization.F90 b/src/user/DOME2d_initialization.F90 index 4186c2d34d..b81061ab29 100644 --- a/src/user/DOME2d_initialization.F90 +++ b/src/user/DOME2d_initialization.F90 @@ -1,3 +1,4 @@ +!> Initialization of the 2D DOME experiment with density water initialized on a coastal shelf. module DOME2d_initialization ! This file is part of MOM6. See LICENSE.md for the license. @@ -9,6 +10,7 @@ module DOME2d_initialization use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type use MOM_sponge, only : sponge_CS, set_up_sponge_field, initialize_sponge +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_type @@ -26,24 +28,29 @@ module DOME2d_initialization public DOME2d_initialize_temperature_salinity public DOME2d_initialize_sponges +! 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. + character(len=40) :: mdl = "DOME2D_initialization" !< This module's name. contains !> Initialize topography with a shelf and slope in a 2D domain -subroutine DOME2d_initialize_topography ( D, G, param_file, max_depth ) - ! Arguments - type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type +subroutine DOME2d_initialize_topography( D, G, param_file, max_depth ) + type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(out) :: D !< Ocean bottom depth in m - type(param_file_type), intent(in) :: param_file !< Parameter file structure - real, intent(in) :: max_depth !< Maximum depth of model in m + intent(out) :: D !< Ocean bottom depth in the units of depth_max + type(param_file_type), intent(in) :: param_file !< Parameter file structure + real, intent(in) :: max_depth !< Maximum ocean depth in arbitrary units + ! Local variables integer :: i, j real :: x, bay_depth, l1, l2 real :: dome2d_width_bay, dome2d_width_bottom, dome2d_depth_bay -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "DOME2D_SHELF_WIDTH", dome2d_width_bay, & @@ -71,7 +78,7 @@ subroutine DOME2d_initialize_topography ( D, G, param_file, max_depth ) if ( x <= l1 ) then D(i,j) = bay_depth * max_depth - else if (( x > l1 ) .and. ( x < l2 )) then + elseif (( x > l1 ) .and. ( x < l2 )) then D(i,j) = bay_depth * max_depth + (1.0-bay_depth) * max_depth * & ( x - l1 ) / (l2 - l1) else @@ -83,21 +90,22 @@ subroutine DOME2d_initialize_topography ( D, G, param_file, max_depth ) end subroutine DOME2d_initialize_topography !> Initialize thicknesses according to coordinate mode -subroutine DOME2d_initialize_thickness ( h, G, GV, param_file, just_read_params ) +subroutine DOME2d_initialize_thickness ( h, G, GV, US, param_file, just_read_params ) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized, in H. + intent(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2]. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. logical, optional, intent(in) :: just_read_params !< If present and true, this call will !! only read parameters without changing h. ! Local variables - real :: e0(SZK_(GV)) ! The resting interface heights, in m, usually ! - ! negative because it is positive upward. ! - real :: eta1D(SZK_(GV)+1)! Interface height relative to the sea surface ! - ! positive upward, in m. ! + real :: e0(SZK_(GV)) ! The resting interface heights, in depth units [Z ~> m], usually + ! negative because it is positive upward. + real :: eta1D(SZK_(GV)+1)! Interface height relative to the sea surface + ! positive upward, in depth units [Z ~> m]. integer :: i, j, k, is, ie, js, je, nz real :: x real :: delta_h @@ -114,7 +122,7 @@ subroutine DOME2d_initialize_thickness ( h, G, GV, param_file, just_read_params call MOM_mesg("MOM_initialization.F90, DOME2d_initialize_thickness: setting thickness") call get_param(param_file, mdl,"MIN_THICKNESS",min_thickness, & - default=1.e-3, do_not_log=.true.) + default=1.e-3, units="m", do_not_log=.true., scale=US%m_to_Z) call get_param(param_file, mdl,"REGRIDDING_COORDINATE_MODE", verticalCoordinate, & default=DEFAULT_COORDINATE_MODE, do_not_log=.true.) call get_param(param_file, mdl, "DOME2D_SHELF_WIDTH", dome2d_width_bay, & @@ -142,21 +150,21 @@ subroutine DOME2d_initialize_thickness ( h, G, GV, param_file, just_read_params case ( REGRIDDING_LAYER, REGRIDDING_RHO ) do j=js,je ; do i=is,ie - eta1D(nz+1) = -1.0*G%bathyT(i,j) + eta1D(nz+1) = -G%bathyT(i,j) do k=nz,1,-1 eta1D(k) = e0(k) - if (eta1D(k) < (eta1D(k+1) + GV%Angstrom_z)) then - eta1D(k) = eta1D(k+1) + GV%Angstrom_z - h(i,j,k) = GV%Angstrom + if (eta1D(k) < (eta1D(k+1) + GV%Angstrom_Z)) then + eta1D(k) = eta1D(k+1) + GV%Angstrom_Z + h(i,j,k) = GV%Angstrom_H else - h(i,j,k) = GV%m_to_H * (eta1D(k) - eta1D(k+1)) + h(i,j,k) = GV%Z_to_H * (eta1D(k) - eta1D(k+1)) endif enddo x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon if ( x <= dome2d_width_bay ) then - h(i,j,1:nz-1) = GV%Angstrom - h(i,j,nz) = GV%m_to_H * dome2d_depth_bay * G%max_depth - (nz-1) * GV%Angstrom + h(i,j,1:nz-1) = GV%Angstrom_H + h(i,j,nz) = GV%Z_to_H * dome2d_depth_bay * G%max_depth - (nz-1) * GV%Angstrom_H endif enddo ; enddo @@ -164,21 +172,21 @@ subroutine DOME2d_initialize_thickness ( h, G, GV, param_file, just_read_params ! case ( IC_RHO_C ) ! ! do j=js,je ; do i=is,ie - ! eta1D(nz+1) = -1.0*G%bathyT(i,j) + ! eta1D(nz+1) = -G%bathyT(i,j) ! do k=nz,1,-1 ! eta1D(k) = e0(k) ! if (eta1D(k) < (eta1D(k+1) + min_thickness)) then ! eta1D(k) = eta1D(k+1) + min_thickness - ! h(i,j,k) = GV%m_to_H * min_thickness + ! h(i,j,k) = GV%Z_to_H * min_thickness ! else - ! h(i,j,k) = GV%m_to_H * (eta1D(k) - eta1D(k+1)) + ! h(i,j,k) = GV%Z_to_H * (eta1D(k) - eta1D(k+1)) ! endif ! enddo ! ! x = G%geoLonT(i,j) / G%len_lon ! if ( x <= dome2d_width_bay ) then - ! h(i,j,1:nz-1) = GV%m_to_H * min_thickness - ! h(i,j,nz) = GV%m_to_H * (dome2d_depth_bay * G%max_depth - (nz-1) * min_thickness) + ! h(i,j,1:nz-1) = GV%Z_to_H * min_thickness + ! h(i,j,nz) = GV%Z_to_H * (dome2d_depth_bay * G%max_depth - (nz-1) * min_thickness) ! endif ! ! enddo ; enddo @@ -186,22 +194,21 @@ subroutine DOME2d_initialize_thickness ( h, G, GV, param_file, just_read_params case ( REGRIDDING_ZSTAR ) do j=js,je ; do i=is,ie - eta1D(nz+1) = -1.0*G%bathyT(i,j) + eta1D(nz+1) = -G%bathyT(i,j) do k=nz,1,-1 eta1D(k) = e0(k) if (eta1D(k) < (eta1D(k+1) + min_thickness)) then eta1D(k) = eta1D(k+1) + min_thickness - h(i,j,k) = GV%m_to_H * min_thickness + h(i,j,k) = GV%Z_to_H * min_thickness else - h(i,j,k) = GV%m_to_H * (eta1D(k) - eta1D(k+1)) + h(i,j,k) = GV%Z_to_H * (eta1D(k) - eta1D(k+1)) endif enddo enddo ; enddo case ( REGRIDDING_SIGMA ) do j=js,je ; do i=is,ie - delta_h = G%bathyT(i,j) / nz - h(i,j,:) = GV%m_to_H * delta_h + h(i,j,:) = GV%Z_to_H*G%bathyT(i,j) / nz enddo ; enddo case default @@ -218,9 +225,9 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, GV, param_file, eqn_of_state, just_read_params) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: T !< Potential temperature (degC) - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: S !< Salinity (ppt) - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Layer thickness in units of H (m or kg m-2) + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: T !< Potential temperature [degC] + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: S !< Salinity [ppt] + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] type(param_file_type), intent(in) :: param_file !< Parameter file structure type(EOS_type), pointer :: eqn_of_state !< Equation of state structure logical, optional, intent(in) :: just_read_params !< If present and true, this call will @@ -273,7 +280,7 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, GV, param_file, do j=js,je ; do i=is,ie xi0 = 0.0 do k = 1,nz - xi1 = xi0 + (GV%H_to_m * h(i,j,k)) / G%max_depth + xi1 = xi0 + (GV%H_to_Z * h(i,j,k)) / G%max_depth S(i,j,k) = 34.0 + 0.5 * S_range * (xi0 + xi1) xi0 = xi1 enddo @@ -284,7 +291,7 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, GV, param_file, do j=js,je ; do i=is,ie xi0 = 0.0 do k = 1,nz - xi1 = xi0 + (GV%H_to_m * h(i,j,k)) / G%max_depth + xi1 = xi0 + (GV%H_to_Z * h(i,j,k)) / G%max_depth S(i,j,k) = 34.0 + 0.5 * S_range * (xi0 + xi1) xi0 = xi1 enddo @@ -309,7 +316,7 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, GV, param_file, end select ! Modify salinity and temperature when z coordinates are used - if ( coordinateMode(verticalCoordinate) .eq. REGRIDDING_ZSTAR ) then + if ( coordinateMode(verticalCoordinate) == REGRIDDING_ZSTAR ) then index_bay_z = Nint ( dome2d_depth_bay * G%ke ) do j = G%jsc,G%jec ; do i = G%isc,G%iec x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon @@ -321,7 +328,7 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, GV, param_file, endif ! Z initial conditions ! Modify salinity and temperature when sigma coordinates are used - if ( coordinateMode(verticalCoordinate) .eq. REGRIDDING_SIGMA ) then + if ( coordinateMode(verticalCoordinate) == REGRIDDING_SIGMA ) then do i = G%isc,G%iec ; do j = G%jsc,G%jec x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon if ( x <= dome2d_width_bay ) then @@ -333,8 +340,8 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, GV, param_file, ! Modify temperature when rho coordinates are used T(G%isc:G%iec,G%jsc:G%jec,1:G%ke) = 0.0 - if (( coordinateMode(verticalCoordinate) .eq. REGRIDDING_RHO ) .or. & - ( coordinateMode(verticalCoordinate) .eq. REGRIDDING_LAYER )) then + if (( coordinateMode(verticalCoordinate) == REGRIDDING_RHO ) .or. & + ( coordinateMode(verticalCoordinate) == REGRIDDING_LAYER )) then do i = G%isc,G%iec ; do j = G%jsc,G%jec x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon if ( x <= dome2d_width_bay ) then @@ -355,18 +362,19 @@ subroutine DOME2d_initialize_sponges(G, GV, tv, param_file, use_ALE, CSp, ACSp) 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 :: RHO(SZI_(G),SZJ_(G),SZK_(G)) ! A temporary array for RHO - real :: h(SZI_(G),SZJ_(G),SZK_(G)) ! A temporary array for thickness - real :: eta(SZI_(G),SZJ_(G),SZK_(G)+1) ! A temporary array for thickness - real :: Idamp(SZI_(G),SZJ_(G)) ! The inverse damping rate, in s-1. + real :: T(SZI_(G),SZJ_(G),SZK_(G)) ! A temporary array for temp [degC] + real :: S(SZI_(G),SZJ_(G),SZK_(G)) ! A temporary array for salt [ppt] + real :: RHO(SZI_(G),SZJ_(G),SZK_(G)) ! A temporary array for RHO [kg m-3] + real :: h(SZI_(G),SZJ_(G),SZK_(G)) ! A temporary array for thickness [H ~> m or kg m-2]. + real :: eta(SZI_(G),SZJ_(G),SZK_(G)+1) ! A temporary array for thickness [Z ~> m] + real :: Idamp(SZI_(G),SZJ_(G)) ! The inverse damping rate [s-1]. real :: S_ref, T_ref ! Reference salinity and temerature within surface layer real :: S_range, T_range ! Range of salinities and temperatures over the vertical - real :: e0(SZK_(G)+1) ! The resting interface heights, in m, usually ! - ! negative because it is positive upward. ! - real :: eta1D(SZK_(G)+1) ! Interface height relative to the sea surface ! - ! positive upward, in m. + real :: e0(SZK_(G)+1) ! The resting interface heights [Z ~> m], + ! usually negative because it is positive upward. + real :: eta1D(SZK_(G)+1) ! Interface height relative to the sea surface + ! positive upward [Z ~> m]. + real :: d_eta(SZK_(G)) ! The layer thickness in a column [Z ~> m]. real :: dome2d_width_bay, dome2d_width_bottom, dome2d_depth_bay real :: dome2d_west_sponge_time_scale, dome2d_east_sponge_time_scale real :: dome2d_west_sponge_width, dome2d_east_sponge_width @@ -443,17 +451,17 @@ subroutine DOME2d_initialize_sponges(G, GV, tv, param_file, use_ALE, CSp, ACSp) enddo e0(nz+1) = -G%max_depth do j=js,je ; do i=is,ie - eta1D(nz+1) = -1.0*G%bathyT(i,j) + eta1D(nz+1) = -G%bathyT(i,j) do k=nz,1,-1 eta1D(k) = e0(k) - if (eta1D(k) < (eta1D(k+1) + GV%Angstrom_z)) then - eta1D(k) = eta1D(k+1) + GV%Angstrom_z - h(i,j,k) = GV%Angstrom_z + if (eta1D(k) < (eta1D(k+1) + GV%Angstrom_Z)) then + eta1D(k) = eta1D(k+1) + GV%Angstrom_Z + h(i,j,k) = GV%Angstrom_H else - h(i,j,k) = eta1D(k) - eta1D(k+1) + h(i,j,k) = GV%Z_to_H * (eta1D(k) - eta1D(k+1)) endif enddo - enddo; enddo + enddo ; enddo ! Store the grid on which the T/S sponge data will reside call initialize_ALE_sponge(Idamp, G, param_file, ACSp, h, nz) @@ -462,48 +470,48 @@ subroutine DOME2d_initialize_sponges(G, GV, tv, param_file, use_ALE, CSp, ACSp) do j=js,je ; do i=is,ie z = -G%bathyT(i,j) do k = nz,1,-1 - z = z + 0.5 * h(i,j,k) ! Position of the center of layer k + z = z + 0.5 * GV%H_to_Z * h(i,j,k) ! Position of the center of layer k S(i,j,k) = 34.0 - 1.0 * (z/G%max_depth) if ( ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon < dome2d_west_sponge_width ) & S(i,j,k) = S_ref + S_range - z = z + 0.5 * h(i,j,k) ! Position of the interface k + z = z + 0.5 * GV%H_to_Z * h(i,j,k) ! Position of the interface k enddo enddo ; enddo if ( associated(tv%T) ) then - call set_up_ALE_sponge_field(T,G,tv%T,ACSp) + 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) + call set_up_ALE_sponge_field(S, G, tv%S, ACSp) endif else - ! Construct thicknesses to restore to + ! Construct interface heights to restore toward do j=js,je ; do i=is,ie - eta1D(nz+1) = -1.0*G%bathyT(i,j) + eta1D(nz+1) = -G%bathyT(i,j) do k=nz,1,-1 - eta1D(k) = -G%max_depth * real(k-1) / real(nz) - if (eta1D(k) < (eta1D(k+1) + GV%Angstrom_z)) then - eta1D(k) = eta1D(k+1) + GV%Angstrom_z - h(i,j,k) = GV%Angstrom_z + eta1D(K) = -G%max_depth * real(k-1) / real(nz) + if (eta1D(K) < (eta1D(K+1) + GV%Angstrom_Z)) then + eta1D(K) = eta1D(K+1) + GV%Angstrom_Z + d_eta(k) = GV%Angstrom_Z else - h(i,j,k) = eta1D(k) - eta1D(k+1) + d_eta(k) = (eta1D(K) - eta1D(K+1)) endif enddo x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon if ( x <= dome2d_width_bay ) then - h(i,j,1:nz-1) = GV%Angstrom - h(i,j,nz) = dome2d_depth_bay * G%max_depth - (nz-1) * GV%Angstrom + do k=1,nz-1 ; d_eta(k) = GV%Angstrom_Z ; enddo + d_eta(nz) = dome2d_depth_bay * G%max_depth - (nz-1) * GV%Angstrom_Z endif eta(i,j,nz+1) = -G%bathyT(i,j) do K=nz,1,-1 - eta(i,j,K) = eta(i,j,K+1) + h(i,j,k) + eta(i,j,K) = eta(i,j,K+1) + d_eta(k) enddo enddo ; enddo - call initialize_sponge(Idamp, eta, G, param_file, CSp) + call initialize_sponge(Idamp, eta, G, param_file, CSp, GV) endif diff --git a/src/user/DOME_initialization.F90 b/src/user/DOME_initialization.F90 index 3e6baf1f23..e3685ae16f 100644 --- a/src/user/DOME_initialization.F90 +++ b/src/user/DOME_initialization.F90 @@ -1,10 +1,12 @@ +!> Configures the model for the "DOME" experiment. +!! DOME = Dynamics of Overflows and Mixing Experiment module DOME_initialization ! This file is part of MOM6. See LICENSE.md for the license. use MOM_sponge, only : sponge_CS, set_up_sponge_field, initialize_sponge use MOM_dyn_horgrid, only : dyn_horgrid_type -use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe 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 @@ -12,6 +14,7 @@ module DOME_initialization use MOM_open_boundary, only : OBC_segment_type, register_segment_tracer use MOM_tracer_registry, only : tracer_registry_type, tracer_type use MOM_tracer_registry, only : tracer_name_lookup +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_type @@ -25,20 +28,28 @@ module DOME_initialization public DOME_initialize_sponges public DOME_set_OBC_data +! 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. + contains ! ----------------------------------------------------------------------------- !> This subroutine sets up the DOME topography -subroutine DOME_initialize_topography(D, G, param_file, max_depth) - type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type +subroutine DOME_initialize_topography(D, G, param_file, max_depth, US) + type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(out) :: D !< Ocean bottom depth in m - type(param_file_type), intent(in) :: param_file !< Parameter file structure - real, intent(in) :: max_depth !< Maximum depth of model in m - - real :: min_depth ! The minimum and maximum depths in m. -! This include declares and sets the variable "version". -#include "version_variable.h" + intent(out) :: D !< Ocean bottom depth in m or Z if US is present + type(param_file_type), intent(in) :: param_file !< Parameter file structure + real, intent(in) :: max_depth !< Maximum model depth in the units of D + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type + + ! Local variables + real :: m_to_Z ! A dimensional rescaling factor. + real :: min_depth ! The minimum and maximum depths [Z ~> m]. + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "DOME_initialize_topography" ! This subroutine's name. integer :: i, j, is, ie, js, je, isd, ied, jsd, jed is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -46,22 +57,24 @@ subroutine DOME_initialize_topography(D, G, param_file, max_depth) call MOM_mesg(" DOME_initialization.F90, DOME_initialize_topography: setting topography", 5) + m_to_Z = 1.0 ; if (present(US)) m_to_Z = US%m_to_Z + call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "MINIMUM_DEPTH", min_depth, & - "The minimum depth of the ocean.", units="m", default=0.0) + "The minimum depth of the ocean.", units="m", default=0.0, scale=m_to_Z) do j=js,je ; do i=is,ie if (G%geoLatT(i,j) < 600.0) then if (G%geoLatT(i,j) < 300.0) then - D(i,j)=max_depth + D(i,j) = max_depth else - D(i,j)=max_depth-10.0*(G%geoLatT(i,j)-300.0) + D(i,j) = max_depth - 10.0*m_to_Z * (G%geoLatT(i,j)-300.0) endif else - if ((G%geoLonT(i,j) > 1000.0).AND.(G%geoLonT(i,j) < 1100.0)) then - D(i,j)=600.0 + if ((G%geoLonT(i,j) > 1000.0) .AND. (G%geoLonT(i,j) < 1100.0)) then + D(i,j) = 600.0*m_to_Z else - D(i,j)=0.5*min_depth + D(i,j) = 0.5*min_depth endif endif @@ -78,16 +91,16 @@ subroutine DOME_initialize_thickness(h, G, GV, param_file, just_read_params) 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_(GV)), & - intent(out) :: h !< The thickness that is being initialized, in H. + intent(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2]. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. logical, optional, intent(in) :: just_read_params !< If present and true, this call will !! only read parameters without changing h. - real :: e0(SZK_(GV)+1) ! The resting interface heights, in m, usually ! - ! negative because it is positive upward. ! - real :: eta1D(SZK_(GV)+1) ! Interface height relative to the sea surface ! - ! positive upward, in m. ! + real :: e0(SZK_(GV)+1) ! The resting interface heights [Z ~> m], usually + ! negative because it is positive upward [Z ~> m]. + real :: eta1D(SZK_(GV)+1) ! Interface height relative to the sea surface + ! positive upward [Z ~> m]. logical :: just_read ! If true, just read parameters but set nothing. character(len=40) :: mdl = "DOME_initialize_thickness" ! This subroutine's name. integer :: i, j, k, is, ie, js, je, nz @@ -111,14 +124,14 @@ subroutine DOME_initialize_thickness(h, G, GV, param_file, just_read_params) ! Angstrom thick, and 2. the interfaces are where they should be ! ! based on the resting depths and interface height perturbations, ! ! as long at this doesn't interfere with 1. ! - eta1D(nz+1) = -1.0*G%bathyT(i,j) + eta1D(nz+1) = -G%bathyT(i,j) do k=nz,1,-1 eta1D(K) = e0(K) - if (eta1D(K) < (eta1D(K+1) + GV%Angstrom_z)) then - eta1D(K) = eta1D(K+1) + GV%Angstrom_z - h(i,j,k) = GV%Angstrom + if (eta1D(K) < (eta1D(K+1) + GV%Angstrom_Z)) then + eta1D(K) = eta1D(K+1) + GV%Angstrom_Z + h(i,j,k) = GV%Angstrom_H else - h(i,j,k) = GV%m_to_H * (eta1D(K) - eta1D(K+1)) + h(i,j,k) = GV%Z_to_H * (eta1D(K) - eta1D(K+1)) endif enddo enddo ; enddo @@ -132,12 +145,13 @@ end subroutine DOME_initialize_thickness !! number of tracers should be restored within each sponge. The ! !! interface height is always subject to damping, and must always be ! !! the first registered field. ! -subroutine DOME_initialize_sponges(G, GV, tv, PF, CSp) +subroutine DOME_initialize_sponges(G, GV, US, tv, PF, CSp) 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(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any available - !! thermodynamic fields, including potential temperature and - !! salinity or mixed layer density. Absent fields have NULL ptrs. + !! thermodynamic fields, including potential temperature and + !! salinity or mixed layer density. Absent fields have NULL ptrs. type(param_file_type), intent(in) :: PF !< A structure indicating the open file to !! parse for model parameter values. type(sponge_CS), pointer :: CSp !< A pointer that is set to point to the control @@ -145,9 +159,9 @@ subroutine DOME_initialize_sponges(G, GV, tv, PF, CSp) real :: eta(SZI_(G),SZJ_(G),SZK_(G)+1) ! A temporary array for eta. real :: temp(SZI_(G),SZJ_(G),SZK_(G)) ! A temporary array for other variables. ! - real :: Idamp(SZI_(G),SZJ_(G)) ! The inverse damping rate, in s-1. + real :: Idamp(SZI_(G),SZJ_(G)) ! The inverse damping rate [s-1]. - real :: H0(SZK_(G)) + real :: H0(SZK_(G)) ! Interface heights [Z ~> m]. real :: min_depth real :: damp, e_dense, damp_new character(len=40) :: mdl = "DOME_initialize_sponges" ! This subroutine's name. @@ -158,17 +172,17 @@ subroutine DOME_initialize_sponges(G, GV, tv, PF, CSp) eta(:,:,:) = 0.0 ; temp(:,:,:) = 0.0 ; Idamp(:,:) = 0.0 -! Here the inverse damping time, in s-1, is set. Set Idamp to 0 ! +! Here the inverse damping time [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. ! ! Set up sponges for DOME configuration call get_param(PF, mdl, "MINIMUM_DEPTH", min_depth, & - "The minimum depth of the ocean.", units="m", default=0.0) + "The minimum depth of the ocean.", units="m", default=0.0, scale=US%m_to_Z) H0(1) = 0.0 - do k=2,nz ; H0(k) = -(real(k-1)-0.5)*G%max_depth/real(nz-1) ; enddo + do k=2,nz ; H0(k) = -(real(k-1)-0.5)*G%max_depth / real(nz-1) ; enddo do i=is,ie; do j=js,je if (G%geoLonT(i,j) < 100.0) then ; damp = 10.0 elseif (G%geoLonT(i,j) < 200.0) then @@ -188,12 +202,12 @@ subroutine DOME_initialize_sponges(G, GV, tv, PF, CSp) ! depth space for Boussinesq or non-Boussinesq models. eta(i,j,1) = 0.0 do k=2,nz -! eta(i,j,K)=max(H0(k), -G%bathyT(i,j), GV%Angstrom_z*(nz-k+1)-G%bathyT(i,j)) +! eta(i,j,K)=max(H0(k), -G%bathyT(i,j), GV%Angstrom_Z*(nz-k+1) - G%bathyT(i,j)) e_dense = -G%bathyT(i,j) if (e_dense >= H0(k)) then ; eta(i,j,K) = e_dense else ; eta(i,j,K) = H0(k) ; endif - if (eta(i,j,K) < GV%Angstrom_z*(nz-k+1)-G%bathyT(i,j)) & - eta(i,j,K) = GV%Angstrom_z*(nz-k+1)-G%bathyT(i,j) + if (eta(i,j,K) < GV%Angstrom_Z*(nz-k+1) - G%bathyT(i,j)) & + eta(i,j,K) = GV%Angstrom_Z*(nz-k+1) - G%bathyT(i,j) enddo eta(i,j,nz+1) = -G%bathyT(i,j) @@ -204,7 +218,7 @@ subroutine DOME_initialize_sponges(G, GV, tv, PF, CSp) ! This call sets up the damping rates and interface heights. ! This sets the inverse damping timescale fields in the sponges. ! - call initialize_sponge(Idamp, eta, G, PF, CSp) + call initialize_sponge(Idamp, eta, G, PF, CSp, GV) ! Now register all of the fields which are damped in the sponge. ! ! By default, momentum is advected vertically within the sponge, but ! @@ -227,7 +241,7 @@ end subroutine DOME_initialize_sponges !> This subroutine sets the properties of flow at open boundary conditions. !! This particular example is for the DOME inflow describe in Legg et al. 2006. -subroutine DOME_set_OBC_data(OBC, tv, G, GV, param_file, tr_Reg) +subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, param_file, tr_Reg) type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies !! whether, where, and what open boundary !! conditions are used. @@ -237,6 +251,7 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, param_file, tr_Reg) !! fields have NULL ptrs. 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 indicating the open file !! to parse for model parameter values. type(tracer_registry_type), pointer :: tr_Reg !< Tracer registry. @@ -244,15 +259,15 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, param_file, tr_Reg) ! Local variables ! The following variables are used to set the target temperature and salinity. real :: T0(SZK_(G)), S0(SZK_(G)) - real :: pres(SZK_(G)) ! An array of the reference pressure in Pa. - real :: drho_dT(SZK_(G)) ! Derivative of density with temperature in kg m-3 K-1. ! - real :: drho_dS(SZK_(G)) ! Derivative of density with salinity in kg m-3 PSU-1. ! - real :: rho_guess(SZK_(G)) ! Potential density at T0 & S0 in kg m-3. + real :: pres(SZK_(G)) ! An array of the reference pressure [Pa]. + real :: drho_dT(SZK_(G)) ! Derivative of density with temperature [kg m-3 degC-1]. + real :: drho_dS(SZK_(G)) ! Derivative of density with salinity [kg m-3 ppt-1]. + real :: rho_guess(SZK_(G)) ! Potential density at T0 & S0 [kg m-3]. ! The following variables are used to set up the transport in the DOME example. real :: tr_0, y1, y2, tr_k, rst, rsb, rc, v_k, lon_im1 - real :: D_edge ! The thickness in m of the dense fluid at the + real :: D_edge ! The thickness [Z ~> m], of the dense fluid at the ! inner edge of the inflow. - real :: g_prime_tot ! The reduced gravity across all layers, m s-2. + real :: g_prime_tot ! The reduced gravity across all layers [m2 Z-1 s-2 ~> m s-2]. real :: Def_Rad ! The deformation radius, based on fluid of ! thickness D_edge, in the same units as lat. real :: Ri_trans ! The shear Richardson number in the transition @@ -261,15 +276,15 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, param_file, tr_Reg) character(len=32) :: name integer :: i, j, k, itt, is, ie, js, je, isd, ied, jsd, jed, m, nz, NTR integer :: IsdB, IedB, JsdB, JedB - type(OBC_segment_type), pointer :: segment - type(tracer_type), pointer :: tr_ptr + type(OBC_segment_type), pointer :: segment => NULL() + type(tracer_type), pointer :: tr_ptr => NULL() 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 ! The following variables should be transformed into runtime parameters. - D_edge = 300.0 ! The thickness of dense fluid in the inflow. + D_edge = 300.0*US%m_to_Z ! The thickness of dense fluid in the inflow. Ri_trans = 1.0/3.0 ! The shear Richardson number in the transition region ! region of the specified shear profile. @@ -277,10 +292,10 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, param_file, tr_Reg) g_prime_tot = (GV%g_Earth/GV%Rho0)*2.0 Def_Rad = sqrt(D_edge*g_prime_tot) / (1.0e-4*1000.0) - tr_0 = (-D_edge*sqrt(D_edge*g_prime_tot)*0.5e3*Def_Rad) * GV%m_to_H + tr_0 = (-D_edge*sqrt(D_edge*g_prime_tot)*0.5e3*Def_Rad) * GV%Z_to_H - if (OBC%number_of_segments .ne. 1) then - print *, 'Error in DOME OBC segment setup' + if (OBC%number_of_segments /= 1) then + call MOM_error(WARNING, 'Error in DOME OBC segment setup', .true.) return !!! Need a better error message here endif segment => OBC%segment(1) @@ -375,8 +390,4 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, param_file, tr_Reg) end subroutine DOME_set_OBC_data -!> \namespace dome_initialization -!! -!! The module configures the model for the "DOME" experiment. -!! DOME = Dynamics of Overflows and Mixing Experiment end module DOME_initialization diff --git a/src/user/ISOMIP_initialization.F90 b/src/user/ISOMIP_initialization.F90 index c9b47d595f..39c9321111 100644 --- a/src/user/ISOMIP_initialization.F90 +++ b/src/user/ISOMIP_initialization.F90 @@ -1,3 +1,4 @@ +!> Configures the ISOMIP test case. module ISOMIP_initialization ! This file is part of MOM6. See LICENSE.md for the license. @@ -12,6 +13,7 @@ module ISOMIP_initialization use MOM_io, only : file_exists use MOM_io, only : MOM_read_data use MOM_io, only : slasher +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_type @@ -23,51 +25,44 @@ module ISOMIP_initialization #include -! ----------------------------------------------------------------------------- -! Private (module-wise) parameters -! ----------------------------------------------------------------------------- +character(len=40) :: mdl = "ISOMIP_initialization" !< This module's name. -character(len=40) :: mdl = "ISOMIP_initialization" ! This module's name. - -! ----------------------------------------------------------------------------- ! The following routines are visible to the outside world -! ----------------------------------------------------------------------------- public ISOMIP_initialize_topography public ISOMIP_initialize_thickness public ISOMIP_initialize_temperature_salinity public ISOMIP_initialize_sponges -! ----------------------------------------------------------------------------- -! This module contains the following routines -! ----------------------------------------------------------------------------- +! 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. + contains -!> Initialization of topography -subroutine ISOMIP_initialize_topography(D, G, param_file, max_depth) - type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type +!> Initialization of topography for the ISOMIP configuration +subroutine ISOMIP_initialize_topography(D, G, param_file, max_depth, US) + type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(out) :: D !< Ocean bottom depth in m - type(param_file_type), intent(in) :: param_file !< Parameter file structure - real, intent(in) :: max_depth !< Maximum depth of model in m - -! This subroutine sets up the ISOMIP topography - real :: min_depth ! The minimum and maximum depths in m. - -! The following variables are used to set up the bathymetry in the ISOMIP example. -! check this paper: http://www.geosci-model-dev-discuss.net/8/9859/2015/gmdd-8-9859-2015.pdf + intent(out) :: D !< Ocean bottom depth in m or Z if US is present + type(param_file_type), intent(in) :: param_file !< Parameter file structure + real, intent(in) :: max_depth !< Maximum model depth in the units of D + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type + ! Local variables + real :: min_depth ! The minimum and maximum depths [Z ~> m]. + real :: m_to_Z ! A dimensional rescaling factor. + ! The following variables are used to set up the bathymetry in the ISOMIP example. real :: bmax ! max depth of bedrock topography real :: b0,b2,b4,b6 ! first, second, third and fourth bedrock topography coeff - real :: xbar ! characteristic along-flow lenght scale of the bedrock - real :: dc ! depth of the trough compared with side walls + real :: xbar ! characteristic along-flow lenght scale of the bedrock + real :: dc ! depth of the trough compared with side walls [Z ~> m]. real :: fc ! characteristic width of the side walls of the channel real :: wc ! half-width of the trough real :: ly ! domain width (across ice flow) - real :: bx, by, xtil ! dummy vatiables + real :: bx, by ! dummy vatiables [Z ~> m]. + real :: xtil ! dummy vatiable logical :: is_2D ! If true, use 2D setup - -! G%ieg and G%jeg are the last indices in the global domain - ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "ISOMIP_initialize_topography" ! This subroutine's name. @@ -75,18 +70,20 @@ subroutine ISOMIP_initialize_topography(D, G, param_file, max_depth) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - call MOM_mesg(" ISOMIP_initialization.F90, ISOMIP_initialize_topography: setting topography", 5) + m_to_Z = 1.0 ; if (present(US)) m_to_Z = US%m_to_Z + call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "MINIMUM_DEPTH", min_depth, & - "The minimum depth of the ocean.", units="m", default=0.0) + "The minimum depth of the ocean.", units="m", default=0.0, scale=m_to_Z) call get_param(param_file, mdl, "ISOMIP_2D",is_2D,'If true, use a 2D setup.', default=.false.) -! The following variables should be transformed into runtime parameters? - bmax=720.0; b0=-150.0; b2=-728.8; b4=343.91; b6=-50.57 - xbar=300.0E3; dc=500.0; fc=4.0E3; wc=24.0E3; ly=80.0E3 - bx = 0.0; by = 0.0; xtil = 0.0 + ! The following variables should be transformed into runtime parameters? + bmax = 720.0*m_to_Z ; dc = 500.0*m_to_Z + b0 = -150.0*m_to_Z ; b2 = -728.8*m_to_Z ; b4 = 343.91*m_to_Z ; b6 = -50.57*m_to_Z + xbar = 300.0e3 ; fc = 4.0e3 ; wc = 24.0e3 ; ly = 80.0e3 + bx = 0.0 ; by = 0.0 ; xtil = 0.0 if (is_2D) then @@ -94,15 +91,15 @@ subroutine ISOMIP_initialize_topography(D, G, param_file, max_depth) ! 2D setup xtil = G%geoLonT(i,j)*1.0e3/xbar !xtil = 450*1.0e3/xbar - bx = b0+b2*xtil**2 + b4*xtil**4 + b6*xtil**6 + bx = b0 + b2*xtil**2 + b4*xtil**4 + b6*xtil**6 !by = (dc/(1.+exp(-2.*(G%geoLatT(i,j)*1.0e3- ly/2. - wc)/fc))) + & ! (dc/(1.+exp(2.*(G%geoLatT(i,j)*1.0e3- ly/2. + wc)/fc))) ! slice at y = 40 km - by = (dc/(1.+exp(-2.*(40.0*1.0e3- ly/2. - wc)/fc))) + & - (dc/(1.+exp(2.*(40.0*1.0e3- ly/2. + wc)/fc))) + by = (dc / (1.+exp(-2.*(40.0*1.0e3- ly/2. - wc)/fc))) + & + (dc / (1.+exp(2.*(40.0*1.0e3- ly/2. + wc)/fc))) - D(i,j) = -max(bx+by,-bmax) + D(i,j) = -max(bx+by, -bmax) if (D(i,j) > max_depth) D(i,j) = max_depth if (D(i,j) < min_depth) D(i,j) = 0.5*min_depth enddo ; enddo @@ -120,25 +117,25 @@ subroutine ISOMIP_initialize_topography(D, G, param_file, max_depth) xtil = G%geoLonT(i,j)*1.0e3/xbar - bx = b0+b2*xtil**2 + b4*xtil**4 + b6*xtil**6 - by = (dc/(1.+exp(-2.*(G%geoLatT(i,j)*1.0e3- ly/2. - wc)/fc))) + & - (dc/(1.+exp(2.*(G%geoLatT(i,j)*1.0e3- ly/2. + wc)/fc))) + bx = b0 + b2*xtil**2 + b4*xtil**4 + b6*xtil**6 + by = (dc / (1.+exp(-2.*(G%geoLatT(i,j)*1.0e3- ly/2. - wc)/fc))) + & + (dc / (1.+exp(2.*(G%geoLatT(i,j)*1.0e3- ly/2. + wc)/fc))) - D(i,j) = -max(bx+by,-bmax) + D(i,j) = -max(bx+by, -bmax) if (D(i,j) > max_depth) D(i,j) = max_depth if (D(i,j) < min_depth) D(i,j) = 0.5*min_depth enddo ; enddo endif end subroutine ISOMIP_initialize_topography -! ----------------------------------------------------------------------------- !> Initialization of thicknesses -subroutine ISOMIP_initialize_thickness ( h, G, GV, param_file, tv, just_read_params) +subroutine ISOMIP_initialize_thickness ( h, G, GV, US, param_file, tv, just_read_params) 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 real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized, in H. + intent(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2]. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any @@ -146,17 +143,17 @@ subroutine ISOMIP_initialize_thickness ( h, G, GV, param_file, tv, just_read_par !! the eqn. of state. logical, optional, intent(in) :: just_read_params !< If present and true, this call will !! only read parameters without changing h. - ! Local variables - real :: e0(SZK_(G)+1) ! The resting interface heights, in m, usually ! - ! negative because it is positive upward. ! - real :: eta1D(SZK_(G)+1)! Interface height relative to the sea surface ! - ! positive upward, in m. ! + real :: e0(SZK_(G)+1) ! The resting interface heights, in depth units [Z ~> m], + ! usually negative because it is positive upward. + real :: eta1D(SZK_(G)+1)! Interface height relative to the sea surface + ! positive upward, in depth units [Z ~> m]. integer :: i, j, k, is, ie, js, je, nz, tmp1 real :: x - real :: delta_h, rho_range + real :: rho_range real :: min_thickness, s_sur, s_bot, t_sur, t_bot, rho_sur, rho_bot logical :: just_read ! If true, just read parameters but set nothing. + character(len=256) :: mesg ! The text of an error message character(len=40) :: verticalCoordinate is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -166,8 +163,8 @@ subroutine ISOMIP_initialize_thickness ( h, G, GV, param_file, tv, just_read_par if (.not.just_read) & call MOM_mesg("MOM_initialization.F90, initialize_thickness_uniform: setting thickness") - call get_param(param_file, mdl,"MIN_THICKNESS",min_thickness, & - 'Minimum layer thickness', units='m', default=1.e-3, do_not_log=just_read) + call get_param(param_file, mdl,"MIN_THICKNESS", min_thickness, & + 'Minimum layer thickness', units='m', default=1.e-3, do_not_log=just_read, scale=US%m_to_Z) call get_param(param_file, mdl,"REGRIDDING_COORDINATE_MODE", verticalCoordinate, & default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) @@ -186,12 +183,15 @@ subroutine ISOMIP_initialize_thickness ( h, G, GV, param_file, tv, just_read_par if (just_read) return ! All run-time parameters have been read, so return. ! Compute min/max density using T_SUR/S_SUR and T_BOT/S_BOT - call calculate_density(t_sur,s_sur,0.0,rho_sur,tv%eqn_of_state) - !write (*,*)'Surface density is:', rho_sur - call calculate_density(t_bot,s_bot,0.0,rho_bot,tv%eqn_of_state) - !write (*,*)'Bottom density is:', rho_bot + call calculate_density(t_sur, s_sur, 0.0, rho_sur, tv%eqn_of_state) + ! write(mesg,*) 'Surface density is:', rho_sur + ! call MOM_mesg(mesg,5) + call calculate_density(t_bot, s_bot, 0.0, rho_bot, tv%eqn_of_state) + ! write(mesg,*) 'Bottom density is:', rho_bot + ! call MOM_mesg(mesg,5) rho_range = rho_bot - rho_sur - !write (*,*)'Density range is:', rho_range + ! write(mesg,*) 'Density range is:', rho_range + ! call MOM_mesg(mesg,5) ! Construct notional interface positions e0(1) = 0. @@ -199,36 +199,36 @@ subroutine ISOMIP_initialize_thickness ( h, G, GV, param_file, tv, just_read_par e0(k) = -G%max_depth * ( 0.5 * ( GV%Rlay(k-1) + GV%Rlay(k) ) - rho_sur ) / rho_range e0(k) = min( 0., e0(k) ) ! Bound by surface e0(k) = max( -G%max_depth, e0(k) ) ! Bound by possible deepest point in model - !write(*,*)'G%max_depth,GV%Rlay(k-1),GV%Rlay(k),e0(k)',G%max_depth,GV%Rlay(k-1),GV%Rlay(k),e0(k) - + ! write(mesg,*) 'G%max_depth,GV%Rlay(k-1),GV%Rlay(k),e0(k)',G%max_depth,GV%Rlay(k-1),GV%Rlay(k),e0(k) + ! call MOM_mesg(mesg,5) enddo e0(nz+1) = -G%max_depth ! Calculate thicknesses do j=js,je ; do i=is,ie - eta1D(nz+1) = -1.0*G%bathyT(i,j) + eta1D(nz+1) = -G%bathyT(i,j) do k=nz,1,-1 eta1D(k) = e0(k) - if (eta1D(k) < (eta1D(k+1) + GV%Angstrom_z)) then - eta1D(k) = eta1D(k+1) + GV%Angstrom_z - h(i,j,k) = GV%Angstrom + if (eta1D(k) < (eta1D(k+1) + GV%Angstrom_Z)) then + eta1D(k) = eta1D(k+1) + GV%Angstrom_Z + h(i,j,k) = GV%Angstrom_H else - h(i,j,k) = GV%m_to_H * (eta1D(k) - eta1D(k+1)) + h(i,j,k) = GV%Z_to_H * (eta1D(k) - eta1D(k+1)) endif enddo enddo ; enddo - case ( REGRIDDING_ZSTAR, REGRIDDING_SIGMA_SHELF_ZSTAR ) ! Initial thicknesses for z coordinates + case ( REGRIDDING_ZSTAR, REGRIDDING_SIGMA_SHELF_ZSTAR ) ! Initial thicknesses for z coordinates if (just_read) return ! All run-time parameters have been read, so return. do j=js,je ; do i=is,ie - eta1D(nz+1) = -1.0*G%bathyT(i,j) + eta1D(nz+1) = -G%bathyT(i,j) do k=nz,1,-1 eta1D(k) = -G%max_depth * real(k-1) / real(nz) if (eta1D(k) < (eta1D(k+1) + min_thickness)) then eta1D(k) = eta1D(k+1) + min_thickness - h(i,j,k) = GV%m_to_H * min_thickness + h(i,j,k) = GV%Z_to_H * min_thickness else - h(i,j,k) = GV%m_to_H * (eta1D(k) - eta1D(k+1)) + h(i,j,k) = GV%Z_to_H * (eta1D(k) - eta1D(k+1)) endif enddo enddo ; enddo @@ -236,9 +236,8 @@ subroutine ISOMIP_initialize_thickness ( h, G, GV, param_file, tv, just_read_par case ( REGRIDDING_SIGMA ) ! Initial thicknesses for sigma coordinates if (just_read) return ! All run-time parameters have been read, so return. do j=js,je ; do i=is,ie - delta_h = G%bathyT(i,j) / dfloat(nz) - h(i,j,:) = GV%m_to_H * delta_h - end do ; end do + h(i,j,:) = GV%Z_to_H * G%bathyT(i,j) / dfloat(nz) + enddo ; enddo case default call MOM_error(FATAL,"isomip_initialize: "// & @@ -253,35 +252,39 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, param_file, eqn_of_state, just_read_params) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: T !< Potential temperature (degC) - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: S !< Salinity (ppt) - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Layer thickness in H (m or kg m-2) + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: T !< Potential temperature [degC] + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: S !< Salinity [ppt] + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] type(param_file_type), intent(in) :: param_file !< Parameter file structure type(EOS_type), pointer :: eqn_of_state !< Equation of state structure logical, optional, intent(in) :: just_read_params !< If present and true, this call will !! only read parameters without changing T & S. - ! Local variables integer :: i, j, k, is, ie, js, je, nz, itt real :: x, ds, dt, rho_sur, rho_bot - real :: xi0, xi1, dxi, r, S_sur, T_sur, S_bot, T_bot, S_range, T_range - real :: z ! vertical position in z space + real :: xi0, xi1 ! Heights in depth units [Z ~> m]. + real :: S_sur, S_bot ! Salinity at the surface and bottom [ppt] + real :: T_sur, T_bot ! Temperature at the bottom [degC] + real :: dT_dz ! Vertical gradient of temperature [degC Z-1 ~> degC m-1]. + real :: dS_dz ! Vertical gradient of salinity [ppt Z-1 ~> ppt m-1]. + real :: z ! vertical position in z space [Z ~> m] + character(len=256) :: mesg ! The text of an error message character(len=40) :: verticalCoordinate, density_profile real :: rho_tmp - logical :: just_read ! If true, just read parameters but set nothing. + logical :: just_read ! If true, just read parameters but set nothing. logical :: fit_salin ! If true, accept the prescribed temperature and fit the salinity. real :: T0(SZK_(G)), S0(SZK_(G)) - real :: drho_dT(SZK_(G)) ! Derivative of density with temperature in kg m-3 K-1. ! - real :: drho_dS(SZK_(G)) ! Derivative of density with salinity in kg m-3 PSU-1. ! - real :: rho_guess(SZK_(G)) ! Potential density at T0 & S0 in kg m-3. - real :: pres(SZK_(G)) ! An array of the reference pressure in Pa. (zero here) + real :: drho_dT(SZK_(G)) ! Derivative of density with temperature [kg m-3 degC-1]. + real :: drho_dS(SZK_(G)) ! Derivative of density with salinity [kg m-3 ppt-1]. + real :: rho_guess(SZK_(G)) ! Potential density at T0 & S0 [kg m-3]. + real :: pres(SZK_(G)) ! An array of the reference pressure [Pa]. (zero here) real :: drho_dT1, drho_dS1, T_Ref, S_Ref is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke pres(:) = 0.0 just_read = .false. ; if (present(just_read_params)) just_read = just_read_params - call get_param(param_file, mdl,"REGRIDDING_COORDINATE_MODE", verticalCoordinate, & + 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, "ISOMIP_T_SUR",t_sur, & 'Temperature at the surface (interface)', default=-1.9, do_not_log=just_read) @@ -293,109 +296,107 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, param_file, 'Salinity at the bottom (interface)', default=34.55, do_not_log=just_read) call calculate_density(t_sur,s_sur,0.0,rho_sur,eqn_of_state) - !write (*,*)'Density in the surface layer:', rho_sur + ! write(mesg,*) 'Density in the surface layer:', rho_sur + ! call MOM_mesg(mesg,5) call calculate_density(t_bot,s_bot,0.0,rho_bot,eqn_of_state) - !write (*,*)'Density in the bottom layer::', rho_bot + ! write(mesg,*) 'Density in the bottom layer::', rho_bot + ! call MOM_mesg(mesg,5) select case ( coordinateMode(verticalCoordinate) ) case ( REGRIDDING_RHO, REGRIDDING_ZSTAR, REGRIDDING_SIGMA_SHELF_ZSTAR, REGRIDDING_SIGMA ) if (just_read) return ! All run-time parameters have been read, so return. - S_range = s_sur - s_bot - T_range = t_sur - t_bot - !write(*,*)'S_range,T_range',S_range,T_range - - S_range = S_range / G%max_depth ! Convert S_range into dS/dz - T_range = T_range / G%max_depth ! Convert T_range into dT/dz + dS_dz = (s_sur - s_bot) / G%max_depth + dT_dz = (t_sur - t_bot) / G%max_depth do j=js,je ; do i=is,ie xi0 = -G%bathyT(i,j) do k = nz,1,-1 - xi0 = xi0 + 0.5 * h(i,j,k) * GV%H_to_m ! Depth in middle of layer - S(i,j,k) = S_sur + S_range * xi0 - T(i,j,k) = T_sur + T_range * xi0 - xi0 = xi0 + 0.5 * h(i,j,k) * GV%H_to_m ! Depth at top of layer + xi0 = xi0 + 0.5 * h(i,j,k) * GV%H_to_Z ! Depth in middle of layer + S(i,j,k) = S_sur + dS_dz * xi0 + T(i,j,k) = T_sur + dT_dz * xi0 + xi0 = xi0 + 0.5 * h(i,j,k) * GV%H_to_Z ! Depth at top of layer enddo enddo ; enddo case ( REGRIDDING_LAYER ) - call get_param(param_file, mdl, "FIT_SALINITY", fit_salin, & - "If true, accept the prescribed temperature and fit the \n"//& - "salinity; otherwise take salinity and fit temperature.", & - default=.false., do_not_log=just_read) - call get_param(param_file, mdl, "DRHO_DS", drho_dS1, & - "Partial derivative of density with salinity.", & - units="kg m-3 PSU-1", fail_if_missing=.not.just_read, do_not_log=just_read) - call get_param(param_file, mdl, "DRHO_DT", drho_dT1, & - "Partial derivative of density with temperature.", & - units="kg m-3 K-1", fail_if_missing=.not.just_read, do_not_log=just_read) - call get_param(param_file, mdl, "T_REF", T_Ref, & - "A reference temperature used in initialization.", & - units="degC", fail_if_missing=.not.just_read, do_not_log=just_read) - call get_param(param_file, mdl, "S_REF", S_Ref, & - "A reference salinity used in initialization.", units="PSU", & - default=35.0, do_not_log=just_read) - if (just_read) return ! All run-time parameters have been read, so return. - - !write(*,*)'read drho_dS, drho_dT', drho_dS1, drho_dT1 - - S_range = s_bot - s_sur - T_range = t_bot - t_sur - !write(*,*)'S_range,T_range',S_range,T_range - S_range = S_range / G%max_depth ! Convert S_range into dS/dz - T_range = T_range / G%max_depth ! Convert T_range into dT/dz - - do j=js,je ; do i=is,ie - xi0 = 0.0 - do k = 1,nz - !T0(k) = T_Ref; S0(k) = S_Ref - xi1 = xi0 + 0.5 * h(i,j,k) * GV%H_to_m - S0(k) = S_sur + S_range * xi1 - T0(k) = T_sur + T_range * xi1 - xi0 = xi0 + h(i,j,k) * GV%H_to_m - !write(*,*)'S,T,xi0,xi1,k',S0(k),T0(k),xi0,xi1,k - enddo + call get_param(param_file, mdl, "FIT_SALINITY", fit_salin, & + "If true, accept the prescribed temperature and fit the \n"//& + "salinity; otherwise take salinity and fit temperature.", & + default=.false., do_not_log=just_read) + call get_param(param_file, mdl, "DRHO_DS", drho_dS1, & + "Partial derivative of density with salinity.", & + units="kg m-3 PSU-1", fail_if_missing=.not.just_read, do_not_log=just_read) + call get_param(param_file, mdl, "DRHO_DT", drho_dT1, & + "Partial derivative of density with temperature.", & + units="kg m-3 K-1", fail_if_missing=.not.just_read, do_not_log=just_read) + call get_param(param_file, mdl, "T_REF", T_Ref, & + "A reference temperature used in initialization.", & + units="degC", fail_if_missing=.not.just_read, do_not_log=just_read) + call get_param(param_file, mdl, "S_REF", S_Ref, & + "A reference salinity used in initialization.", units="PSU", & + default=35.0, do_not_log=just_read) + if (just_read) return ! All run-time parameters have been read, so return. - call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,1,eqn_of_state) - !write(*,*)'computed drho_dS, drho_dT', drho_dS(1), drho_dT(1) - call calculate_density(T0(1),S0(1),0.,rho_guess(1),eqn_of_state) + ! write(mesg,*) 'read drho_dS, drho_dT', drho_dS1, drho_dT1 + ! call MOM_mesg(mesg,5) - if (fit_salin) then - ! A first guess of the layers' salinity. - do k=nz,1,-1 - S0(k) = max(0.0, S0(1) + (GV%Rlay(k) - rho_guess(1)) / drho_dS1) - enddo - ! Refine the guesses for each layer. - do itt=1,6 - call calculate_density(T0,S0,pres,rho_guess,1,nz,eqn_of_state) - call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,nz,eqn_of_state) - do k=1,nz - S0(k) = max(0.0, S0(k) + (GV%Rlay(k) - rho_guess(k)) / drho_dS1) - enddo - enddo + dS_dz = (s_sur - s_bot) / G%max_depth + dT_dz = (t_sur - t_bot) / G%max_depth - else - ! A first guess of the layers' temperatures. - do k=nz,1,-1 - T0(k) = T0(1) + (GV%Rlay(k) - rho_guess(1)) / drho_dT1 - enddo + do j=js,je ; do i=is,ie + xi0 = 0.0 + do k = 1,nz + !T0(k) = T_Ref; S0(k) = S_Ref + xi1 = xi0 + 0.5 * h(i,j,k) * GV%H_to_Z + S0(k) = S_sur - dS_dz * xi1 + T0(k) = T_sur - dT_dz * xi1 + xi0 = xi0 + h(i,j,k) * GV%H_to_Z + ! write(mesg,*) 'S,T,xi0,xi1,k',S0(k),T0(k),xi0,xi1,k + ! call MOM_mesg(mesg,5) + enddo - do itt=1,6 - call calculate_density(T0,S0,pres,rho_guess,1,nz,eqn_of_state) - call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,nz,eqn_of_state) - do k=1,nz - T0(k) = T0(k) + (GV%Rlay(k) - rho_guess(k)) / drho_dT(k) - enddo - enddo - endif + call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,1,eqn_of_state) + ! write(mesg,*) 'computed drho_dS, drho_dT', drho_dS(1), drho_dT(1) + ! call MOM_mesg(mesg,5) + call calculate_density(T0(1),S0(1),0.,rho_guess(1),eqn_of_state) + + if (fit_salin) then + ! A first guess of the layers' salinity. + do k=nz,1,-1 + S0(k) = max(0.0, S0(1) + (GV%Rlay(k) - rho_guess(1)) / drho_dS1) + enddo + ! Refine the guesses for each layer. + do itt=1,6 + call calculate_density(T0,S0,pres,rho_guess,1,nz,eqn_of_state) + call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,nz,eqn_of_state) + do k=1,nz + S0(k) = max(0.0, S0(k) + (GV%Rlay(k) - rho_guess(k)) / drho_dS1) + enddo + enddo - do k=1,nz - T(i,j,k) = T0(k) ; S(i,j,k) = S0(k) - enddo + else + ! A first guess of the layers' temperatures. + do k=nz,1,-1 + T0(k) = T0(1) + (GV%Rlay(k) - rho_guess(1)) / drho_dT1 + enddo + + do itt=1,6 + call calculate_density(T0,S0,pres,rho_guess,1,nz,eqn_of_state) + call calculate_density_derivs(T0,S0,pres,drho_dT,drho_dS,1,nz,eqn_of_state) + do k=1,nz + T0(k) = T0(k) + (GV%Rlay(k) - rho_guess(k)) / drho_dT(k) + enddo + enddo + endif - enddo ; enddo + do k=1,nz + T(i,j,k) = T0(k) ; S(i,j,k) = S0(k) + enddo + + enddo ; enddo - case default + case default call MOM_error(FATAL,"isomip_initialize: "// & "Unrecognized i.c. setup - set REGRIDDING_COORDINATE_MODE") @@ -404,8 +405,9 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, param_file, ! for debugging !i=G%iec; j=G%jec !do k = 1,nz - ! call calculate_density(T(i,j,k),S(i,j,k),0.0,rho_tmp,eqn_of_state) - ! write(*,*) 'k,h,T,S,rho,Rlay',k,h(i,j,k),T(i,j,k),S(i,j,k),rho_tmp,GV%Rlay(k) + ! call calculate_density(T(i,j,k),S(i,j,k),0.0,rho_tmp,eqn_of_state) + ! write(mesg,*) 'k,h,T,S,rho,Rlay',k,h(i,j,k),T(i,j,k),S(i,j,k),rho_tmp,GV%Rlay(k) + ! call MOM_mesg(mesg,5) !enddo end subroutine ISOMIP_initialize_temperature_salinity @@ -413,9 +415,10 @@ end subroutine ISOMIP_initialize_temperature_salinity !> 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 ISOMIP_initialize_sponges(G, GV, tv, PF, use_ALE, CSp, ACSp) +subroutine ISOMIP_initialize_sponges(G, GV, US, tv, 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(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers !! to any available thermodynamic !! fields, potential temperature and @@ -427,26 +430,24 @@ subroutine ISOMIP_initialize_sponges(G, GV, tv, PF, use_ALE, CSp, ACSp) 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 + ! 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 :: RHO(SZI_(G),SZJ_(G),SZK_(G)) ! A temporary array for RHO real :: h(SZI_(G),SZJ_(G),SZK_(G)) ! A temporary array for thickness - real :: Idamp(SZI_(G),SZJ_(G)) ! The inverse damping rate, in s-1. + real :: Idamp(SZI_(G),SZJ_(G)) ! The inverse damping rate [s-1]. real :: TNUDG ! Nudging time scale, days - real :: S_sur, T_sur; ! Surface salinity and temerature in sponge - real :: S_bot, T_bot; ! Bottom salinity and temerature in sponge - real :: t_ref, s_ref ! reference T and S - real :: rho_sur, rho_bot, rho_range, t_range, s_range - - real :: e0(SZK_(G)+1) ! The resting interface heights, in m, usually ! - ! negative because it is positive upward. ! - real :: eta1D(SZK_(G)+1) ! Interface height relative to the sea surface ! - real :: eta(SZI_(G),SZJ_(G),SZK_(G)+1) ! A temporary array for eta. - - ! positive upward, in m. - real :: min_depth, dummy1, z, delta_h + real :: S_sur, T_sur ! Surface salinity and temerature in sponge + real :: S_bot, T_bot ! Bottom salinity and temerature in sponge + real :: t_ref, s_ref ! reference T and S + real :: rho_sur, rho_bot, rho_range + real :: dT_dz, dS_dz ! Gradients of T and S in degC/Z and PPT/Z. + + real :: e0(SZK_(G)+1) ! The resting interface heights [Z ~> m], usually + ! negative because it is positive upward. + real :: eta1D(SZK_(G)+1) ! Interface height relative to the sea surface, positive upward [Z ~> m]. + real :: eta(SZI_(G),SZJ_(G),SZK_(G)+1) ! A temporary array for eta [Z ~> m]. + real :: min_depth, dummy1, z real :: damp, rho_dummy, min_thickness, rho_tmp, xi0 character(len=40) :: verticalCoordinate, filename, state_file character(len=40) :: temp_var, salt_var, eta_var, inputdir @@ -457,70 +458,75 @@ subroutine ISOMIP_initialize_sponges(G, GV, tv, PF, use_ALE, CSp, ACSp) 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 - call get_param(PF, mdl,"MIN_THICKNESS",min_thickness,'Minimum layer thickness',units='m',default=1.e-3) + call get_param(PF, mdl, "MIN_THICKNESS", min_thickness, "Minimum layer thickness", & + units="m", default=1.e-3, scale=US%m_to_Z) - call get_param(PF, mdl,"REGRIDDING_COORDINATE_MODE", verticalCoordinate, & + call get_param(PF, mdl, "REGRIDDING_COORDINATE_MODE", verticalCoordinate, & default=DEFAULT_COORDINATE_MODE) - call get_param(PF, mdl, "ISOMIP_TNUDG", TNUDG, 'Nudging time scale for sponge layers (days)', default=0.0) + call get_param(PF, mdl, "ISOMIP_TNUDG", TNUDG, "Nudging time scale for sponge layers (days)", default=0.0) - call get_param(PF, mdl, "T_REF", t_ref, 'Reference temperature', default=10.0,& + call get_param(PF, mdl, "T_REF", t_ref, "Reference temperature", default=10.0,& do_not_log=.true.) - call get_param(PF, mdl, "S_REF", s_ref, 'Reference salinity', default=35.0,& + call get_param(PF, mdl, "S_REF", s_ref, "Reference salinity", default=35.0,& do_not_log=.true.) - call get_param(PF, mdl, "ISOMIP_S_SUR_SPONGE", s_sur, 'Surface salinity in sponge layer.', default=s_ref) + call get_param(PF, mdl, "ISOMIP_S_SUR_SPONGE", s_sur, & + 'Surface salinity in sponge layer.', default=s_ref) ! units="ppt") - call get_param(PF, mdl, "ISOMIP_S_BOT_SPONGE", s_bot, 'Bottom salinity in sponge layer.', default=s_ref) + call get_param(PF, mdl, "ISOMIP_S_BOT_SPONGE", s_bot, & + 'Bottom salinity in sponge layer.', default=s_ref) ! units="ppt") - call get_param(PF, mdl, "ISOMIP_T_SUR_SPONGE", t_sur, 'Surface temperature in sponge layer.', default=t_ref) + call get_param(PF, mdl, "ISOMIP_T_SUR_SPONGE", t_sur, & + 'Surface temperature in sponge layer.', default=t_ref) ! units="degC") - call get_param(PF, mdl, "ISOMIP_T_BOT_SPONGE", t_bot, 'Bottom temperature in sponge layer.', default=t_ref) + call get_param(PF, mdl, "ISOMIP_T_BOT_SPONGE", t_bot, & + 'Bottom temperature in sponge layer.', default=t_ref) ! units="degC") T(:,:,:) = 0.0 ; S(:,:,:) = 0.0 ; Idamp(:,:) = 0.0; RHO(:,:,:) = 0.0 - S_range = s_sur - s_bot - T_range = t_sur - t_bot ! Set up sponges for ISOMIP configuration call get_param(PF, mdl, "MINIMUM_DEPTH", min_depth, & - "The minimum depth of the ocean.", units="m", default=0.0) + "The minimum depth of the ocean.", units="m", default=0.0, scale=US%m_to_Z) - if (associated(CSp)) call MOM_error(FATAL, & - "ISOMIP_initialize_sponges called with an associated control structure.") - if (associated(ACSp)) call MOM_error(FATAL, & - "ISOMIP_initialize_sponges called with an associated ALE-sponge control structure.") + if (associated(CSp)) call MOM_error(FATAL, & + "ISOMIP_initialize_sponges called with an associated control structure.") + if (associated(ACSp)) call MOM_error(FATAL, & + "ISOMIP_initialize_sponges called with an associated ALE-sponge control structure.") - ! Here the inverse damping time, in s-1, is set. Set Idamp to 0 ! + ! Here the inverse damping time [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) >= 790.0 .AND. G%geoLonT(i,j) <= 800.0) then + do i=is,ie; do j=js,je + if (G%geoLonT(i,j) >= 790.0 .AND. G%geoLonT(i,j) <= 800.0) then ! 1 / day - dummy1=(G%geoLonT(i,j)-790.0)/(800.0-790.0) - damp = 1.0/TNUDG * max(0.0,dummy1) + dummy1=(G%geoLonT(i,j)-790.0)/(800.0-790.0) + damp = 1.0/TNUDG * max(0.0,dummy1) - else ; damp=0.0 - endif + 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 + if (G%bathyT(i,j) > min_depth) then + Idamp(i,j) = damp/86400.0 + else ; Idamp(i,j) = 0.0 ; endif - - enddo ; enddo + enddo ; enddo ! Compute min/max density using T_SUR/S_SUR and T_BOT/S_BOT - call calculate_density(t_sur,s_sur,0.0,rho_sur,tv%eqn_of_state) - !write (*,*)'Surface density in sponge:', rho_sur - call calculate_density(t_bot,s_bot,0.0,rho_bot,tv%eqn_of_state) - !write (*,*)'Bottom density in sponge:', rho_bot + call calculate_density(t_sur, s_sur, 0.0, rho_sur, tv%eqn_of_state) + !write (mesg,*) 'Surface density in sponge:', rho_sur + ! call MOM_mesg(mesg,5) + call calculate_density(t_bot, s_bot, 0.0, rho_bot, tv%eqn_of_state) + !write (mesg,*) 'Bottom density in sponge:', rho_bot + ! call MOM_mesg(mesg,5) rho_range = rho_bot - rho_sur - !write (*,*)'Density range in sponge:', rho_range + !write (mesg,*) 'Density range in sponge:', rho_range + ! call MOM_mesg(mesg,5) if (use_ALE) then @@ -533,70 +539,71 @@ subroutine ISOMIP_initialize_sponges(G, GV, tv, PF, use_ALE, CSp, ACSp) e0(k) = -G%max_depth * ( 0.5 * ( GV%Rlay(k-1) + GV%Rlay(k) ) - rho_sur ) / rho_range e0(k) = min( 0., e0(k) ) ! Bound by surface e0(k) = max( -G%max_depth, e0(k) ) ! Bound by possible deepest point in model - !write(*,*)'G%max_depth,GV%Rlay(k-1),GV%Rlay(k),e0(k)',G%max_depth,GV%Rlay(k-1),GV%Rlay(k),e0(k) - + ! write(mesg,*) 'G%max_depth,GV%Rlay(k-1),GV%Rlay(k),e0(k)',G%max_depth,GV%Rlay(k-1),GV%Rlay(k),e0(k) + ! call MOM_mesg(mesg,5) enddo e0(nz+1) = -G%max_depth ! Calculate thicknesses do j=js,je ; do i=is,ie - eta1D(nz+1) = -1.0*G%bathyT(i,j) + eta1D(nz+1) = -G%bathyT(i,j) do k=nz,1,-1 eta1D(k) = e0(k) - if (eta1D(k) < (eta1D(k+1) + GV%Angstrom_z)) then - eta1D(k) = eta1D(k+1) + GV%Angstrom_z - h(i,j,k) = GV%Angstrom_z + if (eta1D(k) < (eta1D(k+1) + GV%Angstrom_Z)) then + eta1D(k) = eta1D(k+1) + GV%Angstrom_Z + h(i,j,k) = GV%Angstrom_H else - h(i,j,k) = eta1D(k) - eta1D(k+1) + h(i,j,k) = GV%Z_to_H*(eta1D(k) - eta1D(k+1)) endif enddo enddo ; enddo - case ( REGRIDDING_ZSTAR, REGRIDDING_SIGMA_SHELF_ZSTAR ) ! Initial thicknesses for z coordinates + case ( REGRIDDING_ZSTAR, REGRIDDING_SIGMA_SHELF_ZSTAR ) ! Initial thicknesses for z coordinates do j=js,je ; do i=is,ie - eta1D(nz+1) = -1.0*G%bathyT(i,j) + eta1D(nz+1) = -G%bathyT(i,j) do k=nz,1,-1 eta1D(k) = -G%max_depth * real(k-1) / real(nz) if (eta1D(k) < (eta1D(k+1) + min_thickness)) then eta1D(k) = eta1D(k+1) + min_thickness - h(i,j,k) = min_thickness + h(i,j,k) = min_thickness * GV%Z_to_H else - h(i,j,k) = eta1D(k) - eta1D(k+1) + h(i,j,k) = GV%Z_to_H*(eta1D(k) - eta1D(k+1)) endif enddo enddo ; enddo case ( REGRIDDING_SIGMA ) ! Initial thicknesses for sigma coordinates - do j=js,je ; do i=is,ie - delta_h = G%bathyT(i,j) / dfloat(nz) - h(i,j,:) = delta_h - end do ; end do + do j=js,je ; do i=is,ie + h(i,j,:) = GV%Z_to_H * (G%bathyT(i,j) / dfloat(nz)) + enddo ; enddo case default call MOM_error(FATAL,"ISOMIP_initialize_sponges: "// & "Unrecognized i.c. setup - set REGRIDDING_COORDINATE_MODE") end select + ! This call sets up the damping rates and interface heights. ! This sets the inverse damping timescale fields in the sponges. call initialize_ALE_sponge(Idamp, G, PF, ACSp, h, nz) - S_range = S_range / G%max_depth ! Convert S_range into dS/dz - T_range = T_range / G%max_depth ! Convert T_range into dT/dz + dS_dz = (s_sur - s_bot) / G%max_depth + dT_dz = (t_sur - t_bot) / G%max_depth do j=js,je ; do i=is,ie xi0 = -G%bathyT(i,j) do k = nz,1,-1 - xi0 = xi0 + 0.5 * h(i,j,k) ! Depth in middle of layer - S(i,j,k) = S_sur + S_range * xi0 - T(i,j,k) = T_sur + T_range * xi0 - xi0 = xi0 + 0.5 * h(i,j,k) ! Depth at top of layer + xi0 = xi0 + 0.5 * h(i,j,k) * GV%H_to_Z ! Depth in middle of layer + S(i,j,k) = S_sur + dS_dz * xi0 + T(i,j,k) = T_sur + dT_dz * xi0 + xi0 = xi0 + 0.5 * h(i,j,k) * GV%H_to_Z ! Depth at top of layer enddo enddo ; enddo ! for debugging !i=G%iec; j=G%jec !do k = 1,nz ! call calculate_density(T(i,j,k),S(i,j,k),0.0,rho_tmp,tv%eqn_of_state) - ! write(*,*) 'Sponge - k,h,T,S,rho,Rlay',k,h(i,j,k),T(i,j,k),S(i,j,k),rho_tmp,GV%Rlay(k) + ! write(mesg,*) 'Sponge - k,h,T,S,rho,Rlay',k,h(i,j,k),T(i,j,k),S(i,j,k),rho_tmp,GV%Rlay(k) + ! call MOM_mesg(mesg,5) !enddo ! Now register all of the fields which are damped in the sponge. ! @@ -605,56 +612,57 @@ subroutine ISOMIP_initialize_sponges(G, GV, tv, PF, use_ALE, CSp, ACSp) ! 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) + 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) + call set_up_ALE_sponge_field(S, G, tv%S, ACSp) endif else ! layer mode - ! 1) Read eta, salt and temp from IC file - call get_param(PF, mdl, "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, mdl, "ISOMIP_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, mdl, "SPONGE_PTEMP_VAR", temp_var, & - "The name of the potential temperature variable in \n"//& - "SPONGE_STATE_FILE.", default="Temp") - call get_param(PF, mdl, "SPONGE_SALT_VAR", salt_var, & - "The name of the salinity variable in \n"//& - "SPONGE_STATE_FILE.", default="Salt") - call get_param(PF, mdl, "SPONGE_ETA_VAR", eta_var, & - "The name of the interface height variable in \n"//& - "SPONGE_STATE_FILE.", default="eta") - - !read temp and eta - filename = trim(inputdir)//trim(state_file) - if (.not.file_exists(filename, G%Domain)) & - call MOM_error(FATAL, " ISOMIP_initialize_sponges: Unable to open "//trim(filename)) - call MOM_read_data(filename, eta_var, eta(:,:,:), G%Domain) - call MOM_read_data(filename, temp_var, T(:,:,:), G%Domain) - call MOM_read_data(filename, salt_var, S(:,:,:), G%Domain) - - ! for debugging - !i=G%iec; j=G%jec - !do k = 1,nz - ! call calculate_density(T(i,j,k),S(i,j,k),0.0,rho_tmp,tv%eqn_of_state) - ! write(*,*) 'Sponge - k,eta,T,S,rho,Rlay',k,eta(i,j,k),T(i,j,k),& - ! S(i,j,k),rho_tmp,GV%Rlay(k) - !enddo - - ! 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) - ! 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) + ! 1) Read eta, salt and temp from IC file + call get_param(PF, mdl, "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, mdl, "ISOMIP_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, mdl, "SPONGE_PTEMP_VAR", temp_var, & + "The name of the potential temperature variable in \n"//& + "SPONGE_STATE_FILE.", default="Temp") + call get_param(PF, mdl, "SPONGE_SALT_VAR", salt_var, & + "The name of the salinity variable in \n"//& + "SPONGE_STATE_FILE.", default="Salt") + call get_param(PF, mdl, "SPONGE_ETA_VAR", eta_var, & + "The name of the interface height variable in \n"//& + "SPONGE_STATE_FILE.", default="eta") + + !read temp and eta + filename = trim(inputdir)//trim(state_file) + if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & + "ISOMIP_initialize_sponges: Unable to open "//trim(filename)) + call MOM_read_data(filename, eta_var, eta(:,:,:), G%Domain, scale=US%m_to_Z) + call MOM_read_data(filename, temp_var, T(:,:,:), G%Domain) + call MOM_read_data(filename, salt_var, S(:,:,:), G%Domain) + + ! for debugging + !i=G%iec; j=G%jec + !do k = 1,nz + ! call calculate_density(T(i,j,k),S(i,j,k),0.0,rho_tmp,tv%eqn_of_state) + ! write(mesg,*) 'Sponge - k,eta,T,S,rho,Rlay',k,eta(i,j,k),T(i,j,k),& + ! S(i,j,k),rho_tmp,GV%Rlay(k) + ! call MOM_mesg(mesg,5) + !enddo + + ! 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) + ! 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 @@ -662,5 +670,5 @@ end subroutine ISOMIP_initialize_sponges !> \namespace isomip_initialization !! -!! The module configures the ISOMIP test case. +!! See this paper for details: http://www.geosci-model-dev-discuss.net/8/9859/2015/gmdd-8-9859-2015.pdf end module ISOMIP_initialization diff --git a/src/user/Idealized_Hurricane.F90 b/src/user/Idealized_Hurricane.F90 new file mode 100644 index 0000000000..c29e3beded --- /dev/null +++ b/src/user/Idealized_Hurricane.F90 @@ -0,0 +1,614 @@ +!> Forcing for the idealized hurricane and SCM_idealized_hurricane examples. +module Idealized_hurricane + +! This file is part of MOM6. See LICENSE.md for the license. + +! History +!-------- +! November 2014: Origination. +! October 2018: Renamed module from SCM_idealized_hurricane to idealized_hurricane +! This module is no longer exclusively for use in SCM mode. +! Legacy code that can be deleted is at the bottom (currently maintained +! only to preserve exact answers in SCM mode). +! The T/S initializations have been removed since they are redundant +! w/ T/S initializations in CVMix_tests (which should be moved +! into the main state_initialization to their utility +! for multiple example cases).. +! To do +! 1. Remove the legacy SCM_idealized_hurricane_wind_forcing code +! 2. Make the hurricane-to-background wind transition a runtime parameter +! + +use MOM_error_handler, only : MOM_error, FATAL +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_forcing_type, only : forcing, mech_forcing +use MOM_forcing_type, only : allocate_forcing_type, allocate_mech_forcing +use MOM_grid, only : ocean_grid_type +use MOM_safe_alloc, only : safe_alloc_ptr +use MOM_time_manager, only : time_type, operator(+), operator(/), time_type_to_real +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs, surface +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public idealized_hurricane_wind_init !Public interface to intialize the idealized + ! hurricane wind profile. +public idealized_hurricane_wind_forcing !Public interface to update the idealized + ! hurricane wind profile. +public SCM_idealized_hurricane_wind_forcing !Public interface to the legacy idealized + ! hurricane wind profile for SCM. + +!> Container for parameters describing idealized wind structure +type, public :: idealized_hurricane_CS ; private + + ! Parameters used to compute Holland radial wind profile + real :: rho_a !< Mean air density [kg m-3] + real :: pressure_ambient !< Pressure at surface of ambient air [Pa] + real :: pressure_central !< Pressure at surface at hurricane center [Pa] + real :: rad_max_wind !< Radius of maximum winds [m] + real :: max_windspeed !< Maximum wind speeds [m s-1] + real :: hurr_translation_spd !< Hurricane translation speed [m s-1] + real :: hurr_translation_dir !< Hurricane translation speed [m s-1] + real :: gustiness !< Gustiness (optional, used in u*) [m s-1] + real :: Rho0 !< A reference ocean density [kg m-3] + real :: Hurr_cen_Y0 !< The initial y position of the hurricane + !! This experiment is conducted in a Cartesian + !! grid and this is assumed to be in meters [m] + real :: Hurr_cen_X0 !< The initial x position of the hurricane + !! This experiment is conducted in a Cartesian + !! grid and this is assumed to be in meters [m] + real :: Holland_A !< Parameter 'A' from the Holland formula + real :: Holland_B !< Parameter 'B' from the Holland formula + real :: Holland_AxBxDP !< 'A' x 'B' x (Pressure Ambient-Pressure central) + !! for the Holland prorfile calculation + logical :: relative_tau !< A logical to take difference between wind + !! and surface currents to compute the stress + + + ! Parameters used if in SCM (single column model) mode + logical :: SCM_mode !< If true this being used in Single Column Model mode + logical :: BR_BENCH !< A "benchmark" configuration (which is meant to + !! provide identical wind to reproduce a previous + !! experiment, where that wind formula contained + !! an error) + real :: DY_from_center !< (Fixed) distance in y from storm center path [m] + + ! Par + real :: PI !< Mathematical constant + real :: Deg2Rad !< Mathematical constant + +end type + +! This include declares and sets the variable "version". +#include "version_variable.h" + +character(len=40) :: mdl = "idealized_hurricane" !< This module's name. + +contains + +!> Initializes wind profile for the SCM idealized hurricane example +subroutine idealized_hurricane_wind_init(Time, G, param_file, CS) + type(time_type), & + intent(in) :: Time !< Model time + type(ocean_grid_type), & + intent(in) :: G !< Grid structure + type(param_file_type), & + intent(in) :: param_file !< Input parameter structure + type(idealized_hurricane_CS), & + pointer :: CS !< Parameter container + + real :: DP, C + +! This include declares and sets the variable "version". +#include "version_variable.h" + + if (associated(CS)) then + call MOM_error(FATAL, "idealized_hurricane_wind_init called "// & + "with an associated control structure.") + return + endif + + allocate(CS) + + CS%pi = 4.0*atan(1.0) + CS%Deg2Rad = CS%pi/180. + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + + ! 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"// & + "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 "// & + "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 "// & + "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"// & + "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"// & + "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 "//& + "idealized hurricane wind profile.", units='degrees', & + default=180.0) + CS%hurr_translation_dir = CS%hurr_translation_dir * CS%Deg2Rad + call get_param(param_file, mdl, "IDL_HURR_X0", CS%Hurr_cen_X0, & + "Idealized Hurricane initial X position", & + units='m', default=0.) + call get_param(param_file, mdl, "IDL_HURR_Y0", CS%Hurr_cen_Y0, & + "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"// & + "used in the idealized hurricane wind profile.", & + units='', default=.false.) + + ! Parameters for SCM mode + call get_param(param_file, mdl, "IDL_HURR_SCM_BR_BENCH", CS%BR_BENCH, & + "Single column mode benchmark case switch, which is "// & + "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"// & + "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 "// & + "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"//& + "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, & + "The background gustiness in the winds.", units="Pa", & + default=0.00, do_not_log=.true.) + + + if (CS%BR_BENCH) then + CS%rho_a = 1.2 + endif + DP = CS%pressure_ambient - CS%pressure_central + C = CS%max_windspeed / sqrt( DP ) + CS%Holland_B = C**2 * CS%rho_a * exp(1.0) + CS%Holland_A = (CS%rad_max_wind)**CS%Holland_B + CS%Holland_AxBxDP = CS%Holland_A*CS%Holland_B*DP + + return +end subroutine idealized_hurricane_wind_init + +!> Computes the surface wind for the idealized hurricane test cases +subroutine idealized_hurricane_wind_forcing(state, forces, day, G, US, CS) + type(surface), intent(in) :: state !< Surface state structure + type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces + type(time_type), intent(in) :: day !< Time in days + type(ocean_grid_type), intent(inout) :: G !< Grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(idealized_hurricane_CS), pointer :: CS !< Container for idealized hurricane parameters + + ! Local variables + integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + + real :: TX,TY !< wind stress + real :: Uocn, Vocn !< Surface ocean velocity components + real :: LAT, LON !< Grid location + real :: YY, XX !< storm relative position + real :: XC, YC !< Storm center location + real :: f !< Coriolis + real :: fbench !< The benchmark 'f' value + real :: fbench_fac !< A factor that is set to 0 to use the + !! benchmark 'f' value + real :: rel_tau_fac !< A factor that is set to 0 to disable + !! current relative stress calculation + + ! Bounds for loops and memory allocation + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + ! Allocate the forcing arrays, if necessary. + call allocate_mech_forcing(G, forces, stress=.true., ustar=.true.) + + if (CS%relative_tau) then + REL_TAU_FAC = 1. + else + REL_TAU_FAC = 0. !Multiplied to 0 surface current + endif + + !> Compute storm center location + XC = CS%Hurr_cen_X0 + (time_type_to_real(day)*CS%hurr_translation_spd*& + cos(CS%hurr_translation_dir)) + YC = CS%Hurr_cen_Y0 + (time_type_to_real(day)*CS%hurr_translation_spd*& + sin(CS%hurr_translation_dir)) + + + if (CS%BR_Bench) then + ! f reset to value used in generated wind for benchmark test + fbench = 5.5659e-05 + fbench_fac = 0.0 + else + fbench = 0.0 + fbench_fac = 1.0 + endif + + !> Computes taux + do j=js,je + do I=is-1,Ieq + Uocn = state%u(I,j)*REL_TAU_FAC + Vocn = 0.25*(state%v(i,J)+state%v(i+1,J-1)& + +state%v(i+1,J)+state%v(i,J-1))*REL_TAU_FAC + f = abs(0.5*(G%CoriolisBu(I,J)+G%CoriolisBu(I,J-1)))*fbench_fac & + + fbench + ! Calculate position as a function of time. + if (CS%SCM_mode) then + YY = YC + CS%dy_from_center + XX = XC + else + LAT = G%geoLatCu(I,j)*1000. ! Convert Lat from km to m. + LON = G%geoLonCu(I,j)*1000. ! Convert Lon from km to m. + YY = LAT - YC + XX = LON - XC + endif + call idealized_hurricane_wind_profile(& + CS,f,YY,XX,Uocn,Vocn,TX,TY) + forces%taux(I,j) = G%mask2dCu(I,j) * TX + enddo + enddo + !> Computes tauy + do J=js-1,Jeq + do i=is,ie + Uocn = 0.25*(state%u(I,j)+state%u(I-1,j+1)& + +state%u(I-1,j)+state%u(I,j+1))*REL_TAU_FAC + Vocn = state%v(i,J)*REL_TAU_FAC + f = abs(0.5*(G%CoriolisBu(I-1,J)+G%CoriolisBu(I,J)))*fbench_fac & + + fbench + ! Calculate position as a function of time. + if (CS%SCM_mode) then + YY = YC + CS%dy_from_center + XX = XC + else + LAT = G%geoLatCv(i,J)*1000. ! Convert Lat from km to m. + LON = G%geoLonCv(i,J)*1000. ! Convert Lon from km to m. + YY = LAT - YC + XX = LON - XC + endif + call idealized_hurricane_wind_profile(CS, f, YY, XX, Uocn, Vocn, TX, TY) + forces%tauy(i,J) = G%mask2dCv(i,J) * TY + enddo + enddo + + !> Get Ustar + do j=js,je + do i=is,ie + ! This expression can be changed if desired, but need not be. + forces%ustar(i,j) = US%m_to_Z * G%mask2dT(i,j) * sqrt(CS%gustiness/CS%Rho0 + & + sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & + 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))/CS%Rho0) + enddo + enddo + + return +end subroutine idealized_hurricane_wind_forcing + +!> Calculate the wind speed at a location as a function of time. +subroutine idealized_hurricane_wind_profile(CS, absf, YY, XX, UOCN, VOCN, Tx, Ty) + ! Author: Brandon Reichl + ! Date: Nov-20-2014 + ! Aug-14-2018 Generalized for non-SCM configuration + + ! Input parameters + type(idealized_hurricane_CS), & + pointer :: CS !< Container for SCM parameters + real, intent(in) :: absf ! This subroutine is primarily needed as a legacy for reproducing answers. +!! It is included as an additional subroutine rather than padded into the previous +!! routine with flags to ease its eventual removal. Its functionality is replaced +!! with the new routines and it can be deleted when answer changes are acceptable. +subroutine SCM_idealized_hurricane_wind_forcing(state, forces, day, G, US, CS) + type(surface), intent(in) :: state !< Surface state structure + type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces + type(time_type), intent(in) :: day !< Time in days + type(ocean_grid_type), intent(inout) :: G !< Grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(idealized_hurricane_CS), pointer :: CS !< Container for SCM parameters + ! Local variables + integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + real :: pie, Deg2Rad + real :: U10, A, B, C, r, f, du10, rkm ! For wind profile expression + real :: xx, t0 !for location + real :: dp, rB + real :: Cd ! Air-sea drag coefficient + real :: Uocn, Vocn ! Surface ocean velocity components + real :: dU, dV ! Air-sea differential motion + !Wind angle variables + real :: Alph,Rstr, A0, A1, P1, Adir, transdir, V_TS, U_TS + logical :: BR_Bench + ! Bounds for loops and memory allocation + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + ! Allocate the forcing arrays, if necessary. + + call allocate_mech_forcing(G, forces, stress=.true., ustar=.true.) + pie = 4.0*atan(1.0) ; Deg2Rad = pie/180. + !/ BR + ! Implementing Holland (1980) parameteric wind profile + !------------------------------------------------------| + BR_Bench = .true. !true if comparing to LES runs | + t0 = 129600. !TC 'eye' crosses (0,0) at 36 hours| + transdir = pie !translation direction (-x) | + !------------------------------------------------------| + dp = CS%pressure_ambient - CS%pressure_central + C = CS%max_windspeed / sqrt( DP ) + B = C**2 * CS%rho_a * exp(1.0) + if (BR_Bench) then + ! rho_a reset to value used in generated wind for benchmark test + B = C**2 * 1.2 * exp(1.0) + endif + A = (CS%rad_max_wind/1000.)**B + f =G%CoriolisBu(is,js) ! f=f(x,y) but in the SCM is constant + if (BR_Bench) then + ! f reset to value used in generated wind for benchmark test + f = 5.5659e-05 + endif + !/ BR + ! Calculate x position as a function of time. + xx = ( t0 - time_type_to_real(day)) * CS%hurr_translation_spd * cos(transdir) + r = sqrt(xx**2.+CS%DY_from_center**2.) + !/ BR + ! rkm - r converted to km for Holland prof. + ! used in km due to error, correct implementation should + ! not need rkm, but to match winds w/ experiment this must + ! be maintained. Causes winds far from storm center to be a + ! couple of m/s higher than the correct Holland prof. + if (BR_Bench) then + rkm = r/1000. + rB = (rkm)**B + else + ! if not comparing to benchmark, then use correct Holland prof. + rkm = r + rB = r**B + endif + !/ BR + ! Calculate U10 in the interior (inside of 10x radius of maximum wind), + ! while adjusting U10 to 0 outside of 12x radius of maximum wind. + ! Note that rho_a is set to 1.2 following generated wind for experiment + if (r/CS%rad_max_wind > 0.001 .AND. r/CS%rad_max_wind < 10.) then + U10 = sqrt( A*B*dp*exp(-A/rB)/(1.2*rB) + 0.25*(rkm*f)**2 ) - 0.5*rkm*f + elseif (r/CS%rad_max_wind > 10. .AND. r/CS%rad_max_wind < 12.) then + r=CS%rad_max_wind*10. + if (BR_Bench) then + rkm = r/1000. + rB=rkm**B + else + rkm = r + rB = r**B + endif + U10 = ( sqrt( A*B*dp*exp(-A/rB)/(1.2*rB) + 0.25*(rkm*f)**2 ) - 0.5*rkm*f) & + * (12. - r/CS%rad_max_wind)/2. + else + U10 = 0. + endif + Adir = atan2(CS%DY_from_center,xx) + + !/ BR + ! Wind angle model following Zhang and Ulhorn (2012) + ! ALPH is inflow angle positive outward. + RSTR = min(10.,r / CS%rad_max_wind) + A0 = -0.9*RSTR -0.09*CS%max_windspeed - 14.33 + A1 = -A0 *(0.04*RSTR +0.05*CS%hurr_translation_spd+0.14) + P1 = (6.88*RSTR -9.60*CS%hurr_translation_spd+85.31)*pie/180. + ALPH = A0 - A1*cos( (TRANSDIR - ADIR ) - P1) + if (r/CS%rad_max_wind > 10. .AND. r/CS%rad_max_wind < 12.) then + ALPH = ALPH* (12. - r/CS%rad_max_wind)/2. + elseif (r/CS%rad_max_wind > 12.) then + ALPH = 0.0 + endif + ALPH = ALPH * Deg2Rad + !/BR + ! Prepare for wind calculation + ! X_TS is component of translation speed added to wind vector + ! due to background steering wind. + U_TS = CS%hurr_translation_spd/2.*cos(transdir) + V_TS = CS%hurr_translation_spd/2.*sin(transdir) + + ! Set the surface wind stresses, in [Pa]. A positive taux + ! accelerates the ocean to the (pseudo-)east. + ! The i-loop extends to is-1 so that taux can be used later in the + ! calculation of ustar - otherwise the lower bound would be Isq. + do j=js,je ; do I=is-1,Ieq + !/BR + ! Turn off surface current for stress calculation to be + ! consistent with test case. + Uocn = 0.!state%u(I,j) + Vocn = 0.!0.25*( (state%v(i,J) + state%v(i+1,J-1)) & + ! +(state%v(i+1,J) + state%v(i,J-1)) ) + !/BR + ! Wind vector calculated from location/direction (sin/cos flipped b/c + ! cyclonic wind is 90 deg. phase shifted from position angle). + dU = U10*sin(Adir-pie-Alph) - Uocn + U_TS + dV = U10*cos(Adir-Alph) - Vocn + V_TS + !/----------------------------------------------------| + !BR + ! Add a simple drag coefficient as a function of U10 | + !/----------------------------------------------------| + du10=sqrt(du**2+dv**2) + if (du10 < 11.) then + Cd = 1.2e-3 + elseif (du10 < 20.) then + Cd = (0.49 + 0.065 * U10 )*0.001 + else + Cd = 0.0018 + endif + forces%taux(I,j) = CS%rho_a * G%mask2dCu(I,j) * Cd*sqrt(du**2+dV**2)*dU + enddo ; enddo + !/BR + ! See notes above + do J=js-1,Jeq ; do i=is,ie + Uocn = 0.!0.25*( (state%u(I,j) + state%u(I-1,j+1)) & + ! +(state%u(I-1,j) + state%u(I,j+1)) ) + Vocn = 0.!state%v(i,J) + dU = U10*sin(Adir-pie-Alph) - Uocn + U_TS + dV = U10*cos(Adir-Alph) - Vocn + V_TS + du10=sqrt(du**2+dv**2) + if (du10 < 11.) then + Cd = 1.2e-3 + elseif (du10 < 20.) then + Cd = (0.49 + 0.065 * U10 )*0.001 + else + Cd = 0.0018 + endif + forces%tauy(I,j) = CS%rho_a * G%mask2dCv(I,j) * Cd*du10*dV + enddo ; enddo + ! Set the surface friction velocity [m s-1]. ustar is always positive. + do j=js,je ; do i=is,ie + ! This expression can be changed if desired, but need not be. + forces%ustar(i,j) = US%m_to_Z * G%mask2dT(i,j) * sqrt(CS%gustiness/CS%Rho0 + & + sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & + 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))/CS%Rho0) + enddo ; enddo + return +end subroutine SCM_idealized_hurricane_wind_forcing + +end module idealized_hurricane diff --git a/src/user/Kelvin_initialization.F90 b/src/user/Kelvin_initialization.F90 index 3b249864e4..85e11435dc 100644 --- a/src/user/Kelvin_initialization.F90 +++ b/src/user/Kelvin_initialization.F90 @@ -1,3 +1,8 @@ +!> Configures the model for the Kelvin wave experiment. +!! +!! Kelvin = coastally-trapped Kelvin waves from the ROMS examples. +!! Initialize with level surfaces and drive the wave in at the west, +!! radiate out at the east. module Kelvin_initialization ! This file is part of MOM6. See LICENSE.md for the license. @@ -11,8 +16,9 @@ module Kelvin_initialization use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_E use MOM_open_boundary, only : OBC_DIRECTION_S, OBC_DIRECTION_W use MOM_open_boundary, only : OBC_registry_type +use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type -use MOM_time_manager, only : time_type, set_time, time_type_to_real +use MOM_time_manager, only : time_type, time_type_to_real implicit none ; private @@ -21,19 +27,19 @@ module Kelvin_initialization public Kelvin_set_OBC_data, Kelvin_initialize_topography public register_Kelvin_OBC, Kelvin_OBC_end +! 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. + !> Control structure for Kelvin wave open boundaries. type, public :: Kelvin_OBC_CS ; private integer :: mode = 0 !< Vertical mode real :: coast_angle = 0 !< Angle of coastline real :: coast_offset1 = 0 !< Longshore distance to coastal angle real :: coast_offset2 = 0 !< Longshore distance to coastal angle - real :: N0 = 0 !< Brunt-Vaisala frequency real :: H0 = 0 !< Bottom depth real :: F_0 !< Coriolis parameter - real :: plx = 0 !< Longshore wave parameter - real :: pmz = 0 !< Vertical wave parameter - real :: lambda = 0 !< Vertical wave parameter - real :: omega !< Frequency real :: rho_range !< Density range real :: rho_0 !< Mean density end type Kelvin_OBC_CS @@ -109,22 +115,28 @@ end subroutine Kelvin_OBC_end ! ----------------------------------------------------------------------------- !> This subroutine sets up the Kelvin topography and land mask -subroutine Kelvin_initialize_topography(D, G, param_file, max_depth) - type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: D !< Ocean bottom depth in m - type(param_file_type), intent(in) :: param_file !< Parameter file structure - real, intent(in) :: max_depth !< Maximum depth of model in m +subroutine Kelvin_initialize_topography(D, G, param_file, max_depth, US) + type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type + real, dimension(G%isd:G%ied,G%jsd:G%jed), & + intent(out) :: D !< Ocean bottom depth in m or Z if US is present + type(param_file_type), intent(in) :: param_file !< Parameter file structure + real, intent(in) :: max_depth !< Maximum model depth in the units of D + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type + ! Local variables character(len=40) :: mdl = "Kelvin_initialize_topography" ! This subroutine's name. - real :: min_depth ! The minimum and maximum depths in m. + real :: m_to_Z ! A dimensional rescaling factor. + real :: min_depth ! The minimum and maximum depths [Z ~> m]. real :: PI ! 3.1415... real :: coast_offset1, coast_offset2, coast_angle, right_angle integer :: i, j call MOM_mesg(" Kelvin_initialization.F90, Kelvin_initialize_topography: setting topography", 5) + 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, & - "The minimum depth of the ocean.", units="m", default=0.0) + "The minimum depth of the ocean.", units="m", default=0.0, scale=m_to_Z) call get_param(param_file, mdl, "ROTATED_COAST_OFFSET_1", coast_offset1, & default=100.0, do_not_log=.true.) call get_param(param_file, mdl, "ROTATED_COAST_OFFSET_2", coast_offset2, & @@ -136,17 +148,17 @@ subroutine Kelvin_initialize_topography(D, G, param_file, max_depth) right_angle = 2 * atan(1.0) do j=G%jsc,G%jec ; do i=G%isc,G%iec - D(i,j)=max_depth + D(i,j) = max_depth ! Southern side if ((G%geoLonT(i,j) - G%west_lon > coast_offset1) .AND. & (atan2(G%geoLatT(i,j) - G%south_lat + coast_offset2, & G%geoLonT(i,j) - G%west_lon - coast_offset1) < coast_angle)) & - D(i,j)=0.5*min_depth + D(i,j) = 0.5*min_depth ! Northern side if ((G%geoLonT(i,j) - G%west_lon < G%len_lon - coast_offset1) .AND. & (atan2(G%len_lat + G%south_lat + coast_offset2 - G%geoLatT(i,j), & G%len_lon + G%west_lon - coast_offset1 - G%geoLonT(i,j)) < coast_angle)) & - D(i,j)=0.5*min_depth + D(i,j) = 0.5*min_depth if (D(i,j) > max_depth) D(i,j) = max_depth if (D(i,j) < min_depth) D(i,j) = 0.5*min_depth @@ -155,23 +167,30 @@ subroutine Kelvin_initialize_topography(D, G, param_file, max_depth) end subroutine Kelvin_initialize_topography !> This subroutine sets the properties of flow at open boundary conditions. -subroutine Kelvin_set_OBC_data(OBC, CS, G, h, Time) - type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies - !! whether, where, and what open boundary - !! conditions are used. - type(Kelvin_OBC_CS), pointer :: CS !< Kelvin wave control structure. - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< layer thickness. - type(time_type), intent(in) :: Time !< model time. +subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies + !! whether, where, and what open boundary + !! conditions are used. + type(Kelvin_OBC_CS), pointer :: CS !< Kelvin wave control structure. + 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 + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< layer thickness [H ~> m or kg m-2]. + type(time_type), intent(in) :: Time !< model time. ! The following variables are used to set up the transport in the Kelvin example. real :: time_sec, cff + real :: N0 ! Brunt-Vaisala frequency [s-1] + real :: plx !< Longshore wave parameter + real :: pmz !< Vertical wave parameter + real :: lambda !< Offshore decay scale + real :: omega !< Wave frequency [s-1] real :: PI integer :: i, j, k, n, is, ie, js, je, isd, ied, jsd, jed, nz integer :: IsdB, IedB, JsdB, JedB real :: fac, x, y, x1, y1 real :: val1, val2, sina, cosa - type(OBC_segment_type), pointer :: segment + type(OBC_segment_type), pointer :: segment => NULL() 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 @@ -185,15 +204,18 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, h, Time) fac = 1.0 if (CS%mode == 0) then - CS%omega = 2.0 * PI / (12.42 * 3600.0) ! M2 Tide period - val1 = sin(CS%omega * time_sec) + omega = 2.0 * PI / (12.42 * 3600.0) ! M2 Tide period + val1 = US%m_to_Z * sin(omega * time_sec) else - CS%N0 = sqrt(CS%rho_range / CS%rho_0 * G%g_Earth * CS%H0) + N0 = sqrt((CS%rho_range / CS%rho_0) * GV%g_Earth * (US%m_to_Z * CS%H0)) ! Two wavelengths in domain - CS%plx = 4.0 * PI / G%len_lon - CS%pmz = PI * CS%mode / CS%H0 - CS%lambda = CS%pmz * CS%F_0 / CS%N0 - CS%omega = CS%F_0 * CS%plx / CS%lambda + plx = 4.0 * PI / G%len_lon + pmz = PI * CS%mode / CS%H0 + lambda = pmz * CS%F_0 / N0 + omega = CS%F_0 * plx / lambda + + ! lambda = PI * CS%mode * CS%F_0 / (CS%H0 * N0) + ! omega = (4.0 * CS%H0 * N0) / (CS%mode * G%len_lon) endif sina = sin(CS%coast_angle) @@ -211,37 +233,60 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, h, Time) if (segment%direction == OBC_DIRECTION_W) then IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB jsd = segment%HI%jsd ; jed = segment%HI%jed + JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB do j=jsd,jed ; do I=IsdB,IedB x1 = 1000. * G%geoLonCu(I,j) y1 = 1000. * G%geoLatCu(I,j) x = (x1 - CS%coast_offset1) * cosa + y1 * sina y = - (x1 - CS%coast_offset1) * sina + y1 * cosa if (CS%mode == 0) then - cff = sqrt(G%g_Earth * 0.5 * (G%bathyT(i+1,j) + G%bathyT(i,j))) + cff = sqrt(GV%g_Earth * 0.5 * (G%bathyT(i+1,j) + G%bathyT(i,j))) val2 = fac * exp(- CS%F_0 * y / cff) - segment%eta(I,j) = val2 * cos(CS%omega * time_sec) + segment%eta(I,j) = val2 * cos(omega * time_sec) segment%normal_vel_bt(I,j) = val1 * cff * cosa / & (0.5 * (G%bathyT(i+1,j) + G%bathyT(i,j))) * val2 else + ! Not rotated yet segment%eta(I,j) = 0.0 segment%normal_vel_bt(I,j) = 0.0 if (segment%nudged) then do k=1,nz - segment%nudged_normal_vel(I,j,k) = fac * CS%lambda / CS%F_0 * & - exp(- CS%lambda * y) * cos(PI * CS%mode * (k - 0.5) / nz) * & - cos(CS%omega * time_sec) + segment%nudged_normal_vel(I,j,k) = fac * lambda / CS%F_0 * & + exp(- lambda * y) * cos(PI * CS%mode * (k - 0.5) / nz) * & + cos(omega * time_sec) enddo elseif (segment%specified) then do k=1,nz - segment%normal_vel(I,j,k) = fac * CS%lambda / CS%F_0 * & - exp(- CS%lambda * y) * cos(PI * CS%mode * (k - 0.5) / nz) * & - cos(CS%omega * time_sec) + segment%normal_vel(I,j,k) = fac * lambda / CS%F_0 * & + exp(- lambda * y) * cos(PI * CS%mode * (k - 0.5) / nz) * & + cos(omega * time_sec) segment%normal_trans(I,j,k) = segment%normal_vel(I,j,k) * & h(i+1,j,k) * G%dyCu(I,j) enddo endif endif enddo ; enddo + if (associated(segment%tangential_vel)) then + do J=JsdB+1,JedB-1 ; do I=IsdB,IedB + x1 = 1000. * G%geoLonBu(I,J) + y1 = 1000. * G%geoLatBu(I,J) + x = (x1 - CS%coast_offset1) * cosa + y1 * sina + y = - (x1 - CS%coast_offset1) * sina + y1 * cosa + !### Problem: val2 & cff could be a functions of space, but are not set in this loop. + !### Problem: Is val2 in the numerator or denominator below? + if (CS%mode == 0) then + do k=1,nz + segment%tangential_vel(I,J,k) = val1 * cff * sina / & + (0.25 * (G%bathyT(i+1,j) + G%bathyT(i,j) + & + G%bathyT(i+1,j+1) + G%bathyT(i,j+1))) * val2 +!### For rotational symmetry, this should be: +! segment%tangential_vel(I,J,k) = val1 * cff * sina / & +! ( 0.25*((G%bathyT(i,j) + G%bathyT(i+1,j+1)) +& +! (G%bathyT(i+1,j) + G%bathyT(i,j+1))) ) * val2 + enddo + endif + enddo ; enddo + endif else isd = segment%HI%isd ; ied = segment%HI%ied JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB @@ -251,38 +296,54 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, h, Time) x = (x1 - CS%coast_offset1) * cosa + y1 * sina y = - (x1 - CS%coast_offset1) * sina + y1 * cosa if (CS%mode == 0) then - cff = sqrt(G%g_Earth * 0.5 * (G%bathyT(i,j+1) + G%bathyT(i,j))) + cff = sqrt(GV%g_Earth * 0.5 * (G%bathyT(i,j+1) + G%bathyT(i,j))) val2 = fac * exp(- 0.5 * (G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J)) * y / cff) - segment%eta(I,j) = val2 * cos(CS%omega * time_sec) - segment%normal_vel_bt(I,j) = val1 * cff * sina / & - (0.5 * (G%bathyT(i+1,j) + G%bathyT(i,j))) * val2 + segment%eta(I,j) = val2 * cos(omega * time_sec) + segment%normal_vel_bt(I,j) = val1 * cff * sina / & + (0.5*(G%bathyT(i+1,j) + G%bathyT(i,j))) * val2 else + ! Not rotated yet segment%eta(i,J) = 0.0 segment%normal_vel_bt(i,J) = 0.0 if (segment%nudged) then do k=1,nz - segment%nudged_normal_vel(i,J,k) = fac * CS%lambda / CS%F_0 * & - exp(- CS%lambda * y) * cos(PI * CS%mode * (k - 0.5) / nz) * cosa + segment%nudged_normal_vel(i,J,k) = fac * lambda / CS%F_0 * & + exp(- lambda * y) * cos(PI * CS%mode * (k - 0.5) / nz) * cosa enddo elseif (segment%specified) then do k=1,nz - segment%normal_vel(i,J,k) = fac * CS%lambda / CS%F_0 * & - exp(- CS%lambda * y) * cos(PI * CS%mode * (k - 0.5) / nz) * cosa + segment%normal_vel(i,J,k) = fac * lambda / CS%F_0 * & + exp(- lambda * y) * cos(PI * CS%mode * (k - 0.5) / nz) * cosa segment%normal_trans(i,J,k) = segment%normal_vel(i,J,k) * & h(i,j+1,k) * G%dxCv(i,J) enddo endif endif enddo ; enddo + if (associated(segment%tangential_vel)) then + do J=JsdB,JedB ; do I=IsdB+1,IedB-1 + x1 = 1000. * G%geoLonBu(I,J) + y1 = 1000. * G%geoLatBu(I,J) + x = (x1 - CS%coast_offset1) * cosa + y1 * sina + y = - (x1 - CS%coast_offset1) * sina + y1 * cosa + !### Problem: val2 & cff could be a functions of space, but are not set in this loop. + !### Problem: Is val2 in the numerator or denominator below? + if (CS%mode == 0) then + do k=1,nz + segment%tangential_vel(I,J,k) = val1 * cff * sina / & + (0.25*(G%bathyT(i+1,j) + G%bathyT(i,j) + & + G%bathyT(i+1,j+1) + G%bathyT(i,j+1))) * val2 +!### This should be: +! segment%tangential_vel(I,J,k) = val1 * cff * sina / & +! ( 0.25*((G%bathyT(i,j) + G%bathyT(i+1,j+1)) +& +! (G%bathyT(i+1,j) + G%bathyT(i,j+1))) ) * val2 + enddo + endif + enddo ; enddo + endif endif enddo end subroutine Kelvin_set_OBC_data -!> \class Kelvin_Initialization -!! -!! The module configures the model for the Kelvin wave experiment. -!! Kelvin = coastally-trapped Kelvin waves from the ROMS examples. -!! Initialize with level surfaces and drive the wave in at the west, -!! radiate out at the east. end module Kelvin_initialization diff --git a/src/user/MOM_controlled_forcing.F90 b/src/user/MOM_controlled_forcing.F90 index 0a37ffb801..a061fcb3eb 100644 --- a/src/user/MOM_controlled_forcing.F90 +++ b/src/user/MOM_controlled_forcing.F90 @@ -1,3 +1,9 @@ +!> Use control-theory to adjust the surface heat flux and precipitation. +!! +!! Adjustments are based on the time-mean or periodically (seasonally) varying +!! anomalies from the observed state. +!! +!! The techniques behind this are described in Hallberg and Adcroft (2018, in prep.). module MOM_controlled_forcing ! This file is part of MOM6. See LICENSE.md for the license. @@ -12,13 +18,9 @@ module MOM_controlled_forcing use MOM_io, only : vardesc, var_desc use MOM_restart, only : register_restart_field, MOM_restart_CS use MOM_time_manager, only : time_type, operator(+), operator(/), operator(-) -use MOM_time_manager, only : get_time, get_date, set_time, set_date -use MOM_time_manager, only : time_type_to_real +use MOM_time_manager, only : get_date, set_date +use MOM_time_manager, only : time_type_to_real, real_to_time use MOM_variables, only : surface -! Forcing is a structure containing pointers to the forcing fields -! which may be used to drive MOM. All fluxes are positive downward. -! Surface is a structure containing pointers to various fields that -! may be used describe the surface state of MOM. implicit none ; private @@ -27,30 +29,33 @@ module MOM_controlled_forcing public apply_ctrl_forcing, register_ctrl_forcing_restarts public controlled_forcing_init, controlled_forcing_end +!> Control structure for MOM_controlled_forcing type, public :: ctrl_forcing_CS ; private - logical :: use_temperature ! If true, temperature and salinity are used as - ! state variables. - logical :: do_integrated ! If true, use time-integrated anomalies to control - ! the surface state. - integer :: num_cycle ! The number of elements in the forcing cycle. - real :: heat_int_rate ! The rate at which heating anomalies accumulate, in s-1. - real :: prec_int_rate ! The rate at which precipitation anomalies accumulate, in s-1. - real :: heat_cyc_rate ! The rate at which cyclical heating anomaliess - ! accumulate, in s-1. - real :: prec_cyc_rate ! The rate at which cyclical precipitation anomaliess - ! accumulate, in s-1. - real :: Len2 ! The square of the length scale over which the anomalies - ! are smoothed via a Laplacian filter, in m2. - real :: lam_heat ! A constant of proportionality between SST anomalies - ! and heat fluxes, in W m-2 K-1. - real :: lam_prec ! A constant of proportionality between SSS anomalies - ! (normalised by mean SSS) and precipitation, in kg m-2. - real :: lam_cyc_heat ! A constant of proportionality between cyclical SST - ! anomalies and corrective heat fluxes, in W m-2 K-1. - real :: lam_cyc_prec ! A constant of proportionality between cyclical SSS - ! anomalies (normalised by mean SSS) and corrective - ! precipitation, in kg m-2. - + logical :: use_temperature !< If true, temperature and salinity are used as + !! state variables. + logical :: do_integrated !< If true, use time-integrated anomalies to control + !! the surface state. + integer :: num_cycle !< The number of elements in the forcing cycle. + real :: heat_int_rate !< The rate at which heating anomalies accumulate [s-1]. + real :: prec_int_rate !< The rate at which precipitation anomalies accumulate [s-1]. + real :: heat_cyc_rate !< The rate at which cyclical heating anomaliess + !! accumulate [s-1]. + real :: prec_cyc_rate !< The rate at which cyclical precipitation anomaliess + !! accumulate [s-1]. + real :: Len2 !< The square of the length scale over which the anomalies + !! are smoothed via a Laplacian filter [m2]. + real :: lam_heat !< A constant of proportionality between SST anomalies + !! and heat fluxes [W m-2 degC-1]. + real :: lam_prec !< A constant of proportionality between SSS anomalies + !! (normalised by mean SSS) and precipitation [kg m-2]. + real :: lam_cyc_heat !< A constant of proportionality between cyclical SST + !! anomalies and corrective heat fluxes [W m-2 degC-1]. + real :: lam_cyc_prec !< A constant of proportionality between cyclical SSS + !! anomalies (normalised by mean SSS) and corrective + !! precipitation [kg m-2]. + + !>@{ Pointers for data. + !! \todo Needs more complete documentation. real, pointer, dimension(:) :: & avg_time => NULL() real, pointer, dimension(:,:) :: & @@ -62,9 +67,10 @@ module MOM_controlled_forcing avg_SST_anom => NULL(), & avg_SSS_anom => NULL(), & avg_SSS => NULL() - type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the - ! timing of diagnostic output. - integer :: id_heat_0 = -1 ! See if these are neede later... + !!@} + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + integer :: id_heat_0 = -1 !< Diagnostic handle end type ctrl_forcing_CS contains @@ -75,21 +81,21 @@ subroutine apply_ctrl_forcing(SST_anom, SSS_anom, SSS_mean, virt_heat, virt_prec day_start, dt, G, CS) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: SST_anom !< The sea surface temperature - !! anomalies, in deg C. + !! anomalies [degC]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: SSS_anom !< The sea surface salinity - !! anomlies, in g kg-1. + !! anomlies [ppt]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: SSS_mean !< The mean sea surface - !! salinity, in g kg-1. + !! salinity [ppt]. real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: virt_heat !< Virtual (corrective) heat !! fluxes that are augmented - !! in this subroutine, in W m-2. + !! in this subroutine [W m-2]. real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: virt_precip !< Virtual (corrective) !! precipitation fluxes that !! are augmented in this - !! subroutine, in kg m-2 s-1. + !! subroutine [kg m-2 s-1]. type(time_type), intent(in) :: day_start !< Start time of the fluxes. real, intent(in) :: dt !< Length of time over which these - !! fluxes will be applied, in s. + !! fluxes will be applied [s]. type(ctrl_forcing_CS), pointer :: CS !< A pointer to the control structure !! returned by a previous call to !! ctrl_forcing_init. @@ -101,7 +107,7 @@ subroutine apply_ctrl_forcing(SST_anom, SSS_anom, SSS_mean, virt_heat, virt_prec flux_heat_y, & flux_prec_y type(time_type) :: day_end - real :: coef ! A heat-flux coefficient with units of m2. + real :: coef ! A heat-flux coefficient [m2]. real :: mr_st, mr_end, mr_mid, mr_prev, mr_next real :: dt_wt, dt_heat_rate, dt_prec_rate real :: dt1_heat_rate, dt1_prec_rate, dt2_heat_rate, dt2_prec_rate @@ -115,7 +121,7 @@ subroutine apply_ctrl_forcing(SST_anom, SSS_anom, SSS_mean, virt_heat, virt_prec if (.not.associated(CS)) return if ((CS%num_cycle <= 0) .and. (.not.CS%do_integrated)) return - day_end = day_start + set_time(floor(dt+0.5)) + day_end = day_start + real_to_time(dt) do j=js,je ; do i=is,ie virt_heat(i,j) = 0.0 ; virt_precip(i,j) = 0.0 diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index ac83add05c..fedd46ab03 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -1,36 +1,8 @@ +!> Interface for surface waves module MOM_wave_interface ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Brandon Reichl, 2018. * -!* * -!* This module should be moved as wave coupling progresses and * -!* likely will should mirror the iceberg or sea-ice model set-up. * -!* * -!* This module is meant to contain the routines to read in and * -!* interpret surface wave data for MOM6. In its original form, the * -!* capabilities include setting the Stokes drift in the model (from a * -!* variety of sources including prescribed, empirical, and input * -!* files). In short order, the plan is to also ammend the subroutine * -!* to accept Stokes drift information from an external coupler. * -!* Eventually, it will be necessary to break this file apart so that * -!* general wave information may be stored in the control structure * -!* and the Stokes drift effect can be isolated from processes such as * -!* sea-state dependent momentum fluxes, gas fluxes, and other wave * -!* related air-sea interaction and boundary layer phenomenon. * -!* * -!* The Stokes drift are stored on the C-grid with the conventional * -!* protocol to interpolate to the h-grid to compute Langmuir number, * -!* the primary quantity needed for Langmuir turbulence * -!* parameterizations in both the ePBL and KPP approach. This module * -!* also computes full 3d Stokes drift profiles, which will be useful * -!* if second-order type boundary layer parameterizations are * -!* implemented (perhaps via GOTM, work in progress). * -!* * -!********+*********+*********+*********+*********+*********+*********+** - use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_alloc use MOM_diag_mediator, only : diag_ctrl use MOM_domains, only : pass_var, pass_vector, AGRID @@ -38,12 +10,13 @@ module MOM_wave_interface use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_verticalgrid, only : verticalGrid_type use MOM_safe_alloc, only : safe_alloc_ptr -use MOM_time_manager, only : time_type, operator(+), operator(/), get_time,& - time_type_to_real,real_to_time_type +use MOM_time_manager, only : time_type, operator(+), operator(/) +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs, surface +use MOM_verticalgrid, only : verticalGrid_type use data_override_mod, only : data_override_init, data_override + implicit none ; private #include @@ -65,136 +38,165 @@ module MOM_wave_interface ! CL2 effects. public Waves_end ! public interface to deallocate and free wave related memory. +! 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. !> Container for all surface wave related parameters -type, public:: wave_parameters_CS ; private - - !> Main surface wave options - logical, public :: UseWaves ! Flag to enable surface gravity wave feature - logical, public :: LagrangianMixing ! NOT READY - ! True if Stokes drift is present and mixing - ! should be applied to Lagrangian current - ! (mean current + Stokes drift). - ! See Reichl et al., 2016 KPP-LT approach - logical, public :: StokesMixing ! NOT READY - ! True if vertical mixing of momentum - ! should be applied directly to Stokes current - ! (with separate mixing parameter for Eulerian - ! mixing contribution). - ! See Harcourt 2013, 2015 Second-Moment approach - logical, public :: CoriolisStokes ! NOT READY +type, public :: wave_parameters_CS ; private + + !Main surface wave options + logical, public :: UseWaves !< Flag to enable surface gravity wave feature + logical, public :: LagrangianMixing !< This feature is in development and not ready + !! True if Stokes drift is present and mixing + !! should be applied to Lagrangian current + !! (mean current + Stokes drift). + !! See Reichl et al., 2016 KPP-LT approach + logical, public :: StokesMixing !< This feature is in development and not ready. + !! True if vertical mixing of momentum + !! should be applied directly to Stokes current + !! (with separate mixing parameter for Eulerian + !! mixing contribution). + !! See Harcourt 2013, 2015 Second-Moment approach + logical, public :: CoriolisStokes !< This feature is in development and not ready. ! True if Coriolis-Stokes acceleration should be applied. - integer, public :: StkLevelMode=1 ! = 0 if mid-point value of Stokes drift is used - ! = 1 if average value of Stokes drift over level. - ! If advecting with Stokes transport, 1 is the correct - ! approach. + integer, public :: StkLevelMode=1 !< Sets if Stokes drift is defined at mid-points + !! or layer averaged. Set to 0 if mid-point and set to + !! 1 if average value of Stokes drift over level. + !! If advecting with Stokes transport, 1 is the correct + !! approach. - !> Surface Wave Dependent 1d/2d/3d vars + ! Surface Wave Dependent 1d/2d/3d vars + real, allocatable, dimension(:), public :: & + WaveNum_Cen !< Wavenumber bands for read/coupled [m-1] + real, allocatable, dimension(:), public :: & + Freq_Cen !< Frequency bands for read/coupled [s-1] real, allocatable, dimension(:), public :: & - WaveNum_Cen,& ! Wavenumber bands for read/coupled - Freq_Cen, & ! Frequency bands for read/coupled - PrescribedSurfStkX,& ! Surface Stokes drift if prescribed - PrescribedSurfStkY ! Surface Stokes drift if prescribed + PrescribedSurfStkX !< Surface Stokes drift if prescribed [m s-1] + real, allocatable, dimension(:), public :: & + PrescribedSurfStkY !< Surface Stokes drift if prescribed [m s-1] real, allocatable, dimension(:,:,:), public :: & - Us_x ! 3d Stokes drift profile (zonal) - ! Horizontal -> U points - ! Vertical -> Mid-points + Us_x !< 3d zonal Stokes drift profile [m s-1] + !! Horizontal -> U points + !! Vertical -> Mid-points real, allocatable, dimension(:,:,:), public :: & - Us_y ! 3d Stokes drift profile (meridional) - ! Horizontal -> V points - ! Vertical -> Mid-points - real, allocatable, dimension(:,:), public :: & - LangNum, & ! Langmuir number (directionality factored later) - ! Horizontal -> H points - US0_x, & ! Surface Stokes Drift (zonal) - ! Horizontal -> U points - US0_y ! Surface Stokes Drift (meridional) - ! Horizontal -> V points + Us_y !< 3d meridional Stokes drift profile [m s-1] + !! Horizontal -> V points + !! Vertical -> Mid-points + real, allocatable, dimension(:,:), public :: & + La_SL,& !< SL Langmuir number (directionality factored later) + !! Horizontal -> H points + La_Turb !< Aligned Turbulent Langmuir number + !! Horizontal -> H points + real, allocatable, dimension(:,:), public :: & + US0_x !< Surface Stokes Drift (zonal, m/s) + !! Horizontal -> U points + real, allocatable, dimension(:,:), public :: & + US0_y !< Surface Stokes Drift (meridional, m/s) + !! Horizontal -> V points real, allocatable, dimension(:,:,:), public :: & - STKx0 ! Stokes Drift spectrum (zonal) - ! Horizontal -> U points - ! 3rd dimension -> Freq/Wavenumber + STKx0 !< Stokes Drift spectrum (zonal, m/s) + !! Horizontal -> U points + !! 3rd dimension -> Freq/Wavenumber real, allocatable, dimension(:,:,:), public :: & - STKy0 ! Stokes Drift spectrum (meridional) - ! Horizontal -> V points - ! 3rd dimension -> Freq/Wavenumber + STKy0 !< Stokes Drift spectrum (meridional, m/s) + !! Horizontal -> V points + !! 3rd dimension -> Freq/Wavenumber real, allocatable, dimension(:,:,:), public :: & - KvS !< Viscosity for Stokes Drift shear + KvS !< Viscosity for Stokes Drift shear [Z2/s ~> m2 s-1] ! Pointers to auxiliary fields - type(time_type), pointer, public :: Time ! A pointer to the ocean model's clock. - type(diag_ctrl), pointer, public :: diag ! A structure that is used to regulate the - ! timing of diagnostic output. - - ! Diagnostic handles - integer, public :: id_surfacestokes_x, id_surfacestokes_y - integer, public :: id_3dstokes_x, id_3dstokes_y + type(time_type), pointer, public :: Time !< A pointer to the ocean model's clock. + type(diag_ctrl), pointer, public :: diag !< A structure that is used to regulate the + !! timing of diagnostic output. + + ! An arbitrary lower-bound on the Langmuir number. Run-time parameter. + ! Langmuir number is sqrt(u_star/u_stokes). When both are small + ! but u_star is orders of magnitude smaller the Langmuir number could + ! have unintended consequences. Since both are small it can be safely capped + ! to avoid such consequences. + real :: La_min = 0.05 + + !>@{ Diagnostic handles + integer, public :: id_surfacestokes_x = -1 , id_surfacestokes_y = -1 + integer, public :: id_3dstokes_x = -1 , id_3dstokes_y = -1 + integer, public :: id_La_turb = -1 + !!@} end type wave_parameters_CS -!Options not needed outside of this module +! Options not needed outside of this module -!> Main Option -integer :: WaveMethod=-99 - ! Options for including wave information - ! Valid (tested) choices are: - ! 0 - Test Profile - ! 1 - Surface Stokes Drift Bands - ! 2 - DHH85 - ! 3 - LF17 - ! -99 - No waves computed, but empirical Langmuir number used. +integer :: WaveMethod=-99 !< Options for including wave information + !! Valid (tested) choices are: + !! 0 - Test Profile + !! 1 - Surface Stokes Drift Bands + !! 2 - DHH85 + !! 3 - LF17 + !! -99 - No waves computed, but empirical Langmuir number used. + !! \todo Module variable! Move into a control structure. -!> Options if WaveMethod is Surface Stokes Drift Bands (1) +! Options if WaveMethod is Surface Stokes Drift Bands (1) integer, public :: NumBands =0 !< Number of wavenumber/frequency partitions to receive !! This needs to match the number of bands provided !! via either coupling or file. + !! \todo Module variable! Move into a control structure. integer, public :: PartitionMode !< Method for partition mode (meant to check input) !! 0 - wavenumbers !! 1 - frequencies -integer :: DataSource ! Integer that specifies where the Model Looks for Data - ! Valid choices are: - ! 1 - FMS DataOverride Routine - ! 2 - Reserved For Coupler - ! 3 - User input (fixed values, useful for 1d testing) -!>> Options if using FMS DataOverride Routine -character(len=40) :: SurfBandFileName ! Filename if using DataOverride -logical :: dataoverrideisinitialized ! Flag for DataOverride Initialization - -!> Options for computing Langmuir number + !! \todo Module variable! Move into a control structure. +integer :: DataSource !< Integer that specifies where the Model Looks for Data + !! Valid choices are: + !! 1 - FMS DataOverride Routine + !! 2 - Reserved For Coupler + !! 3 - User input (fixed values, useful for 1d testing) + !! \todo Module variable! Move into a control structure. + +! Options if using FMS DataOverride Routine +character(len=40) :: SurfBandFileName !< Filename if using DataOverride + !! \todo Module variable! Move into a control structure. +logical :: dataoverrideisinitialized !< Flag for DataOverride Initialization + !! \todo Module variable! Move into a control structure. + +! Options for computing Langmuir number real :: LA_FracHBL !< Fraction of OSBL for averaging Langmuir number + !! \todo Module variable! Move into a control structure. logical :: LA_Misalignment = .false. !< Flag to use misalignment in Langmuir number + !! \todo Module variable! Move into a control structure. ! This include declares and sets the variable "version". #include "version_variable.h" -character(len=40) :: mdl = "MOM_wave_interface" ! This module's name. +character(len=40) :: mdl = "MOM_wave_interface" !< This module's name. +!>@{ Undocumented parameters. +!! \todo These module variables need to be documented as static/private variables or moved +!! into a control structure. ! Switches needed in import_stokes_drift integer, parameter :: TESTPROF = 0, SURFBANDS = 1, & DHH85 = 2, LF17 = 3, NULL_WaveMethod=-99, & DATAOVR = 1, COUPLER = 2, INPUT = 3 -! For Test Prof +! Options For Test Prof Real :: TP_STKX0, TP_STKY0, TP_WVL -logical :: WaveAgePeakFreq !> Flag to use W +logical :: WaveAgePeakFreq ! Flag to use W real :: WaveAge, WaveWind real :: PI +!!@} -CONTAINS +contains !> Initializes parameters related to MOM_wave_interface -subroutine MOM_wave_interface_init(time,G,GV,param_file, CS, diag ) - - !Arguments - type(time_type), target, intent(in) :: Time !< Time - type(ocean_grid_type), intent(inout) :: G !< Grid structure +subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) + type(time_type), target, intent(in) :: Time !< Model time + type(ocean_grid_type), intent(inout) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - type(param_file_type), intent(in) :: param_file !< Input parameter structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Input parameter structure type(wave_parameters_CS), pointer :: CS !< Wave parameter control structure type(diag_ctrl), target, intent(inout) :: diag !< Diagnostic Pointer - ! Local variables - ! I/O character*(13) :: TMPSTRING1,TMPSTRING2 character*(5), parameter :: NULL_STRING = "EMPTY" @@ -206,7 +208,7 @@ subroutine MOM_wave_interface_init(time,G,GV,param_file, CS, diag ) character*(7), parameter :: COUPLER_STRING = "COUPLER" character*(5), parameter :: INPUT_STRING = "INPUT" - !/ Dummy Check + ! Dummy Check if (associated(CS)) then call MOM_error(FATAL, "wave_interface_init called with an associated"//& "control structure.") @@ -215,7 +217,7 @@ subroutine MOM_wave_interface_init(time,G,GV,param_file, CS, diag ) PI=4.0*atan(1.0) - !/ Allocate CS and set pointers + ! Allocate CS and set pointers allocate(CS) CS%diag => diag @@ -235,25 +237,25 @@ subroutine MOM_wave_interface_init(time,G,GV,param_file, CS, diag ) "Flag to use Lagrangian Mixing of momentum", units="", & Default=.false.) if (CS%LagrangianMixing) then - !Force Code Intervention + ! Force Code Intervention call MOM_error(FATAL,"Should you be enabling Lagrangian Mixing? Code not ready.") endif call get_param(param_file, mdl, "STOKES_MIXING", CS%StokesMixing, & "Flag to use Stokes Mixing of momentum", units="", & Default=.false.) if (CS%StokesMixing) then - !Force Code Intervention + ! Force Code Intervention call MOM_error(FATAL,"Should you be enabling Stokes Mixing? Code not ready.") endif call get_param(param_file, mdl, "CORIOLIS_STOKES", CS%CoriolisStokes, & "Flag to use Coriolis Stokes acceleration", units="", & Default=.false.) if (CS%CoriolisStokes) then - !Force Code Intervention + ! Force Code Intervention call MOM_error(FATAL,"Should you be enabling Coriolis-Stokes? Code not ready.") endif - ! 1. Get Wave Method and write to integer WaveMethod + ! Get Wave Method and write to integer WaveMethod call get_param(param_file,mdl,"WAVE_METHOD",TMPSTRING1, & "Choice of wave method, valid options include: \n"// & " TEST_PROFILE - Prescribed from surface Stokes drift \n"// & @@ -278,8 +280,8 @@ subroutine MOM_wave_interface_init(time,G,GV,param_file, CS, diag ) 'Surface Stokes (y) for test profile',& units='m/s',default=0.0) call get_param(param_file,mdl,"TP_WVL",TP_WVL,& - units='m',default=50.0) - case (SURFBANDS_STRING)!Surface Stokes Drift Bands + units='m', default=50.0, scale=US%m_to_Z) + case (SURFBANDS_STRING)! Surface Stokes Drift Bands WaveMethod = SURFBANDS call get_param(param_file, mdl, "SURFBAND_SOURCE",TMPSTRING2, & "Choice of SURFACE_BANDS data mode, valid options include: \n"// & @@ -288,27 +290,32 @@ subroutine MOM_wave_interface_init(time,G,GV,param_file, CS, diag ) " INPUT - Testing with fixed values.", & units='', default=NULL_STRING) select case (TRIM(TMPSTRING2)) - case (NULL_STRING)! + case (NULL_STRING)! Default call MOM_error(FATAL, "wave_interface_init called with SURFACE_BANDS"//& " but no SURFBAND_SOURCE.") - case (DATAOVR_STRING)!Using Data Override + case (DATAOVR_STRING)! Using Data Override DataSource = DATAOVR call get_param(param_file, mdl, "SURFBAND_FILENAME", SurfBandFileName, & "Filename of surface Stokes drift input band data.", default="StkSpec.nc") - case (COUPLER_STRING)!Reserved for coupling + case (COUPLER_STRING)! Reserved for coupling DataSource = Coupler - case (INPUT_STRING) + 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.", & units='', default=1) - allocate( CS%WaveNum_Cen(1:NumBands) ) ; CS%WaveNum_Cen(:)=0.0 - allocate( CS%PrescribedSurfStkX(1:NumBands)) ; CS%PrescribedSurfStkX(:) = 0.0 - allocate( CS%PrescribedSurfStkY(1:NumBands)) ; CS%PrescribedSurfStkY(:) = 0.0 - allocate( CS%STKx0(G%isdB:G%iedB,G%jsd:G%jed,1:NumBands)) ; CS%STKx0(:,:,:) = 0.0 - allocate( CS%STKy0(G%isd:G%ied,G%jsdB:G%jedB,1:NumBands)) ; CS%STKy0(:,:,:) = 0.0 + allocate( CS%WaveNum_Cen(1:NumBands) ) + CS%WaveNum_Cen(:) = 0.0 + allocate( CS%PrescribedSurfStkX(1:NumBands)) + CS%PrescribedSurfStkX(:) = 0.0 + allocate( CS%PrescribedSurfStkY(1:NumBands)) + CS%PrescribedSurfStkY(:) = 0.0 + allocate( CS%STKx0(G%isdB:G%iedB,G%jsd:G%jed,1:NumBands)) + CS%STKx0(:,:,:) = 0.0 + allocate( CS%STKy0(G%isd:G%ied,G%jsdB:G%jedB,1:NumBands)) + CS%STKy0(:,:,:) = 0.0 partitionmode=0 call get_param(param_file,mdl,"SURFBAND_WAVENUMBERS",CS%WaveNum_Cen, & "Central wavenumbers for surface Stokes drift bands.",units='rad/m', & @@ -319,12 +326,14 @@ subroutine MOM_wave_interface_init(time,G,GV,param_file, CS, diag ) call get_param(param_file,mdl,"SURFBAND_STOKES_Y",CS%PrescribedSurfStkY, & "Y-direction surface Stokes drift for bands.",units='m/s', & default=0.0) - case default + case default! No method provided call MOM_error(FATAL,'Check WAVE_METHOD.') end select case (DHH85_STRING)!Donelan et al., 1985 spectrum WaveMethod = DHH85 + call MOM_error(WARNING,"DHH85 only ever set-up for uniform cases w/"//& + " Stokes drift in x-direction.") call get_param(param_file,mdl,"DHH85_AGE_FP",WaveAgePeakFreq, & "Choose true to use waveage in peak frequency.", & units='', default=.false.) @@ -348,26 +357,35 @@ subroutine MOM_wave_interface_init(time,G,GV,param_file, CS, diag ) call get_param(param_file, mdl, "LA_MISALIGNMENT", LA_Misalignment, & "Flag (logical) if using misalignment bt shear and waves in LA",& default=.false.) - - ! 2. Allocate and initialize - ! Stokes drift - ! Profiles - allocate(CS%Us_x(G%isdB:G%IedB,G%jsd:G%jed,G%ke)) ; CS%Us_x(:,:,:) = 0.0 - allocate(CS%Us_y(G%isd:G%Ied,G%jsdB:G%jedB,G%ke)) ; CS%Us_y(:,:,:) = 0.0 - ! Surface Values - allocate(CS%US0_x(G%isdB:G%iedB,G%jsd:G%jed)) ; CS%US0_x(:,:) = 0.0 - allocate(CS%US0_y(G%isd:G%ied,G%jsdB:G%jedB)) ; CS%US0_y(:,:) = 0.0 - ! Langmuir number - allocate(CS%LangNum(G%isc:G%iec,G%jsc:G%jec)) ; CS%LangNum(:,:) = 0.0 - + 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",& + default=0.05) + + ! Allocate and initialize + ! a. Stokes driftProfiles + allocate(CS%Us_x(G%isdB:G%IedB,G%jsd:G%jed,G%ke)) + CS%Us_x(:,:,:) = 0.0 + allocate(CS%Us_y(G%isd:G%Ied,G%jsdB:G%jedB,G%ke)) + CS%Us_y(:,:,:) = 0.0 + ! b. Surface Values + allocate(CS%US0_x(G%isdB:G%iedB,G%jsd:G%jed)) + CS%US0_x(:,:) = 0.0 + allocate(CS%US0_y(G%isd:G%ied,G%jsdB:G%jedB)) + CS%US0_y(:,:) = 0.0 + ! c. Langmuir number + allocate(CS%La_SL(G%isc:G%iec,G%jsc:G%jec)) + allocate(CS%La_turb(G%isc:G%iec,G%jsc:G%jec)) + CS%La_SL(:,:) = 0.0 + CS%La_turb (:,:) = 0.0 + ! d. Viscosity for Stokes drift if (CS%StokesMixing) then - ! Viscosity for Stokes drift - allocate(CS%KvS(G%isd:G%Ied,G%jsd:G%jed,G%ke)) ; CS%KvS(:,:,:) = 0.0 + allocate(CS%KvS(G%isd:G%Ied,G%jsd:G%jed,G%ke)) + CS%KvS(:,:,:) = 0.0 endif - ! - ! 3. Initialize Wave related outputs - ! + ! Initialize Wave related outputs CS%id_surfacestokes_y = register_diag_field('ocean_model','surface_stokes_y', & CS%diag%axesCu1,Time,'Surface Stokes drift (y)','m s-1') CS%id_surfacestokes_x = register_diag_field('ocean_model','surface_stokes_x', & @@ -376,20 +394,16 @@ subroutine MOM_wave_interface_init(time,G,GV,param_file, CS, diag ) CS%diag%axesCvL,Time,'3d Stokes drift (y)','m s-1') CS%id_3dstokes_x = register_diag_field('ocean_model','3d_stokes_x', & CS%diag%axesCuL,Time,'3d Stokes drift (y)','m s-1') + CS%id_La_turb = register_diag_field('ocean_model','La_turbulent',& + CS%diag%axesT1,Time,'Surface (turbulent) Langmuir number','nondim') return - end subroutine MOM_wave_interface_init - +!> A 'lite' init subroutine to initialize a few inputs needed if using wave information +!! with the wind-speed dependent Stokes drift formulation of LF17 subroutine MOM_wave_interface_init_lite(param_file) - !It is possible to estimate Stokes drift without the Wave data (if WaveMethod=LF17). - ! In this case there are still a couple inputs we need to read in, which is done - ! here in a reduced wave_interface_init that doesn't allocate the CS. - - !Arguments - type(param_file_type), intent(in) :: param_file !< Input parameter structure - + type(param_file_type), intent(in) :: param_file !< Input parameter structure ! Langmuir number Options call get_param(param_file, mdl, "LA_DEPTH_RATIO", LA_FracHBL, & @@ -406,274 +420,290 @@ subroutine MOM_wave_interface_init_lite(param_file) return end subroutine MOM_wave_interface_init_lite -! Place to add update of surface wave parameters. -subroutine Update_Surface_Waves(G,GV,Day,DT,CS) -!Arguments - type(wave_parameters_CS), pointer :: CS !< Wave parameter Control structure - type(ocean_grid_type), intent(inout) :: G !< Grid structure - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - type(time_type), intent(in) :: Day !