From 79e579713b9a326f6f5c1594024ee624b530159c Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Thu, 4 Jun 2020 13:06:26 -0400 Subject: [PATCH 01/91] First attempt to add a generic tracer to OBC scheme - This commit is the first attempt to add a (generic) tracer to the OBC. - The tracer "gtr1" is added from the ocean_bgc module generic_CFC.F90 - It is to imitate "salt" as if it was a passive tracer. --- src/core/MOM.F90 | 2 +- src/core/MOM_open_boundary.F90 | 131 ++++++++++++++++++++++++- src/tracer/MOM_generic_tracer.F90 | 17 ++-- src/tracer/MOM_tracer_flow_control.F90 | 11 ++- src/tracer/MOM_tracer_registry.F90 | 1 + 5 files changed, 149 insertions(+), 13 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 78d53e0b76..be2274182b 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2133,7 +2133,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, US, param_file, CS%tracer_flow_CSp, & - CS%tracer_Reg, restart_CSp) + CS%tracer_Reg, restart_CSp, CS%OBC) call MEKE_alloc_register_restart(dG%HI, param_file, CS%MEKE, restart_CSp) call set_visc_register_restarts(dG%HI, GV, param_file, CS%visc, restart_CSp) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 3b1559ab81..c6a2bb3cbc 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -53,7 +53,9 @@ module MOM_open_boundary public segment_tracer_registry_end public register_segment_tracer public register_temp_salt_segments +public register_obgc_segments public fill_temp_salt_segments +public fill_obgc_segments public open_boundary_register_restarts public update_segment_tracer_reservoirs public update_OBC_ramp @@ -1414,6 +1416,13 @@ subroutine parse_for_tracer_reservoirs(OBC, PF, use_temperature) OBC%tracer_y_reservoirs_used(2) = .true. endif endif + if (fields(m) == 'gtr1') then + if (segment%is_E_or_W_2) then + OBC%tracer_x_reservoirs_used(2) = .true. + else + OBC%tracer_y_reservoirs_used(2) = .true. + endif + endif endif enddo ! Alternately, set first two to true if use_temperature is true @@ -3206,6 +3215,22 @@ function lookup_seg_field(OBC_seg,field) end function lookup_seg_field +!> Return the tracer index from its name +function get_tracer_index(OBC_seg,tr_name) + type(OBC_segment_type), pointer :: OBC_seg !< OBC segment + character(len=*), intent(in) :: tr_name !< The field name + integer :: get_tracer_index, it + get_tracer_index=-1 + it=1 + do while(allocated(OBC_seg%tr_Reg%Tr(it)%t)) + if (trim(OBC_seg%tr_Reg%Tr(it)%name) == trim(tr_name)) then + get_tracer_index=it + exit + endif + it=it+1 + enddo + return +end function get_tracer_index !> Allocate segment data fields subroutine allocate_OBC_segment_data(OBC, segment) @@ -3448,7 +3473,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) 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 + integer :: IsdB, IedB, JsdB, JedB, n, m, nz, nt, it 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 => NULL() @@ -3937,6 +3962,25 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) else segment%tr_Reg%Tr(2)%OBC_inflow_conc = segment%field(m)%value endif + elseif (trim(segment%field(m)%name) == 'gtr1') then + nt=get_tracer_index(segment,'gtr1') + if(nt .lt. 0) then + call MOM_error(FATAL,"update_OBC_segment_data: Did not find tracer gtr1!") + endif + 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(nt)%t(i,j,k) = segment%field(m)%buffer_dst(i,j,k) + enddo ; enddo ; enddo + if (.not. segment%tr_Reg%Tr(nt)%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(nt)%tres(i,j,k) = segment%tr_Reg%Tr(nt)%t(i,j,k) + enddo ; enddo ; enddo + segment%tr_Reg%Tr(nt)%is_initialized=.true. + endif + else + segment%tr_Reg%Tr(nt)%OBC_inflow_conc = segment%field(m)%value + endif endif enddo ! end field loop @@ -4213,6 +4257,91 @@ subroutine register_temp_salt_segments(GV, OBC, tr_Reg, param_file) end subroutine register_temp_salt_segments +subroutine register_obgc_segments(GV, OBC, tr_Reg, param_file, tr_name) + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + type(tracer_registry_type), pointer :: tr_Reg !< Tracer registry + type(param_file_type), intent(in) :: param_file !< file to parse for model parameter values + character(len=*), intent(in) :: tr_name!< Tracer name +! Local variables + integer :: isd, ied, IsdB, IedB, jsd, jed, JsdB, JedB, nz, nf + integer :: i, j, k, n + type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list + type(tracer_type), pointer :: tr_ptr => NULL() + + if (.not. associated(OBC)) return + + do n=1, OBC%number_of_segments + segment=>OBC%segment(n) + if (.not. segment%on_pe) cycle + !For testing activate only one particular tracer for OBC + !This could be later generalized to all or a list of tracers + if(trim(tr_name) == 'gtr1') then + call tracer_name_lookup(tr_Reg, tr_ptr, tr_name) + call register_segment_tracer(tr_ptr, param_file, GV, segment, OBC_array=.True.) + endif + enddo + +end subroutine register_obgc_segments + +subroutine fill_obgc_segments(G, OBC, tr_ptr, tr_name) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + real, dimension(:,:,:), pointer :: tr_ptr !< Pointer to tracer field + character(len=*), intent(in) :: tr_name!< Tracer name + +! Local variables + integer :: isd, ied, IsdB, IedB, jsd, jed, JsdB, JedB, n, nz, nt + integer :: i, j, k + type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list + + if (.not. associated(OBC)) return + + if(trim(tr_name) /= 'gtr1') return !Test for one particular tracer + + call pass_var(tr_ptr, G%Domain) + + nz = G%ke + + do n=1, OBC%number_of_segments + segment => OBC%segment(n) + if (.not. segment%on_pe) cycle + + nt=get_tracer_index(segment,tr_name) + if(nt .lt. 0) then + call MOM_error(FATAL,"fill_obgc_segments: Did not find tracer "// tr_name) + endif + + isd = segment%HI%isd ; ied = segment%HI%ied + jsd = segment%HI%jsd ; jed = segment%HI%jed + IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB + JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB + + ! Fill with Tracer values + if (segment%is_E_or_W) then + I=segment%HI%IsdB + do k=1,nz ; do j=segment%HI%jsd,segment%HI%jed + if (segment%direction == OBC_DIRECTION_W) then + segment%tr_Reg%Tr(nt)%t(I,j,k) = tr_ptr(i+1,j,k) + else + segment%tr_Reg%Tr(nt)%t(I,j,k) = tr_ptr(i,j,k) + endif + enddo ; enddo + else + J=segment%HI%JsdB + do k=1,nz ; do i=segment%HI%isd,segment%HI%ied + if (segment%direction == OBC_DIRECTION_S) then + segment%tr_Reg%Tr(nt)%t(i,J,k) = tr_ptr(i,j+1,k) + else + segment%tr_Reg%Tr(nt)%t(i,J,k) = tr_ptr(i,j,k) + endif + enddo ; enddo + endif + segment%tr_Reg%Tr(nt)%tres(:,:,:) = segment%tr_Reg%Tr(nt)%t(:,:,:) + enddo + call setup_OBC_tracer_reservoirs(G, OBC) !This will redo the T&S +end subroutine fill_obgc_segments + subroutine fill_temp_salt_segments(G, OBC, tv) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(ocean_OBC_type), pointer :: OBC !< Open boundary structure diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index 83c2c9a8e7..3bdb837b09 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -41,7 +41,7 @@ module MOM_generic_tracer 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_open_boundary, only : ocean_OBC_type, register_obgc_segments, fill_obgc_segments use MOM_verticalGrid, only : verticalGrid_type @@ -69,7 +69,7 @@ module MOM_generic_tracer 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() - + type(ocean_OBC_type), pointer :: OBC => NULL() ! The following pointer will be directed to the first element of the ! linked list of generic tracers. type(g_tracer_type), pointer :: g_tracer_list => NULL() @@ -86,7 +86,7 @@ module MOM_generic_tracer !> Initializes the generic tracer packages and adds their tracers to the list !! Adds the tracers in the list of generic tracers to the set of MOM tracers (i.e., MOM-register them) !! Register these tracers for restart - function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) + function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS, OBC) type(hor_index_type), intent(in) :: HI !< Horizontal index ranges 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 @@ -94,6 +94,8 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) type(tracer_registry_type), pointer :: tr_Reg !< Pointer to the control structure for the tracer !! advection and diffusion module. type(MOM_restart_CS), pointer :: restart_CS !< Pointer to the restart control structure. + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies whether, + !! where, and what open boundary conditions are used. ! Local variables logical :: register_MOM_generic_tracer @@ -149,7 +151,7 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) "restart files of a restarted run.", default=.false.) CS%restart_CSp => restart_CS - + CS%OBC => OBC ntau=1 ! MOM needs the fields at only one time step @@ -195,6 +197,8 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) name=g_tracer_name, longname=longname, units=units, & registry_diags=.false., & !### CHANGE TO TRUE? restart_CS=restart_CS, mandatory=.not.CS%tracers_may_reinit) + if (associated(CS%OBC)) & + call register_obgc_segments(GV, CS%OBC, tr_Reg, param_file, g_tracer_name) else call register_restart_field(tr_ptr, g_tracer_name, .not.CS%tracers_may_reinit, & restart_CS, longname=longname, units=units) @@ -219,7 +223,7 @@ end function register_MOM_generic_tracer !! !! This subroutine initializes the NTR tracer fields in tr(:,:,:,:) !! and it sets up the tracer output. - subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, diag, OBC, CS, & + subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, diag, CS, & sponge_CSp, ALE_sponge_CSp) logical, intent(in) :: restart !< .true. if the fields have already been !! read from a restart file. @@ -230,8 +234,6 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, 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(ALE_sponge_CS), pointer :: ALE_sponge_CSp !< Pointer to the control structure for the @@ -340,6 +342,7 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, endif endif + call fill_obgc_segments(G, CS%OBC, tr_ptr, g_tracer_name) !traverse the linked list till hit NULL call g_tracer_get_next(g_tracer, g_tracer_next) if (.NOT. associated(g_tracer_next)) exit diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index 6e28477d26..d4c8df96d8 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -148,7 +148,7 @@ end subroutine call_tracer_flux_init !> This subroutine determines which tracer packages are to be used and does the calls to !! register their tracers to be advected, diffused, and read from restarts. -subroutine call_tracer_register(HI, GV, US, param_file, CS, tr_Reg, restart_CS) +subroutine call_tracer_register(HI, GV, US, param_file, CS, tr_Reg, restart_CS, OBC) 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 @@ -161,7 +161,10 @@ subroutine call_tracer_register(HI, GV, US, param_file, CS, tr_Reg, restart_CS) !! advection and diffusion module. type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control !! structure. - + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition + !! type specifies whether, where, + !! and what open boundary + !! conditions are used. ! This include declares and sets the variable "version". # include "version_variable.h" @@ -256,7 +259,7 @@ subroutine call_tracer_register(HI, GV, US, param_file, CS, tr_Reg, restart_CS) #ifdef _USE_GENERIC_TRACER if (CS%use_MOM_generic_tracer) CS%use_MOM_generic_tracer = & register_MOM_generic_tracer(HI, GV, param_file, CS%MOM_generic_tracer_CSp, & - tr_Reg, restart_CS) + tr_Reg, restart_CS, OBC) #endif if (CS%use_pseudo_salt_tracer) CS%use_pseudo_salt_tracer = & register_pseudo_salt_tracer(HI, GV, param_file, CS%pseudo_salt_tracer_CSp, & @@ -336,7 +339,7 @@ subroutine tracer_flow_control_init(restart, day, G, GV, US, h, param_file, diag sponge_CSp) #ifdef _USE_GENERIC_TRACER if (CS%use_MOM_generic_tracer) & - call initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, diag, OBC, & + call initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, diag, & CS%MOM_generic_tracer_CSp, sponge_CSp, ALE_sponge_CSp) #endif if (CS%use_pseudo_salt_tracer) & diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index 07ca30dec8..9cadfa2159 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -847,6 +847,7 @@ subroutine tracer_name_lookup(Reg, tr_ptr, name) character(len=32), intent(in) :: name !< tracer name integer n + tr_ptr => null() do n=1,Reg%ntr if (lowercase(Reg%Tr(n)%name) == lowercase(name)) tr_ptr => Reg%Tr(n) enddo From 7c6041ada7ec0e57ddb3f5b71ee37263d70c95e7 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 19 Jun 2020 17:33:07 +0000 Subject: [PATCH 02/91] Replaced copies of GSW files with links - We always intended to use links so that we were not maintaining code that did not belong to us. `listpaths` used to not work as expected so Niki had placed copies here when adding TEOS10. Using links also avoids any license conflicts. --- .../gsw_chem_potential_water_t_exact.f90 | 83 +- .../TEOS10/gsw_ct_freezing_exact.f90 | 44 +- .../TEOS10/gsw_ct_freezing_poly.f90 | 54 +- .../TEOS10/gsw_ct_from_pt.f90 | 53 +- .../TEOS10/gsw_ct_from_t.f90 | 33 +- .../TEOS10/gsw_entropy_part.f90 | 63 +- .../TEOS10/gsw_entropy_part_zerop.f90 | 45 +- src/equation_of_state/TEOS10/gsw_gibbs.f90 | 318 +--- .../TEOS10/gsw_gibbs_ice.f90 | 131 +- .../TEOS10/gsw_gibbs_pt0_pt0.f90 | 48 +- .../gsw_mod_freezing_poly_coefficients.f90 | 64 +- .../TEOS10/gsw_mod_gibbs_ice_coefficients.f90 | 31 +- .../TEOS10/gsw_mod_kinds.f90 | 17 +- .../TEOS10/gsw_mod_specvol_coefficients.f90 | 314 +--- .../TEOS10/gsw_mod_teos10_constants.f90 | 72 +- .../TEOS10/gsw_mod_toolbox.f90 | 1494 +---------------- .../TEOS10/gsw_pt0_from_t.f90 | 60 +- .../TEOS10/gsw_pt_from_ct.f90 | 73 +- .../TEOS10/gsw_pt_from_t.f90 | 62 +- src/equation_of_state/TEOS10/gsw_rho.f90 | 37 +- .../TEOS10/gsw_rho_first_derivatives.f90 | 111 +- .../TEOS10/gsw_rho_second_derivatives.f90 | 79 +- .../TEOS10/gsw_sp_from_sr.f90 | 31 +- src/equation_of_state/TEOS10/gsw_specvol.f90 | 53 +- .../TEOS10/gsw_specvol_first_derivatives.f90 | 105 +- .../TEOS10/gsw_specvol_second_derivatives.f90 | 132 +- .../TEOS10/gsw_sr_from_sp.f90 | 31 +- ...w_t_deriv_chem_potential_water_t_exact.f90 | 89 +- .../TEOS10/gsw_t_freezing_exact.f90 | 72 +- .../TEOS10/gsw_t_freezing_poly.f90 | 79 +- .../TEOS10/gsw_t_from_ct.f90 | 34 +- 31 files changed, 31 insertions(+), 3881 deletions(-) mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_chem_potential_water_t_exact.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_ct_freezing_exact.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_ct_freezing_poly.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_ct_from_pt.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_ct_from_t.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_entropy_part.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_entropy_part_zerop.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_gibbs.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_gibbs_ice.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_gibbs_pt0_pt0.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_mod_freezing_poly_coefficients.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_mod_gibbs_ice_coefficients.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_mod_kinds.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_mod_specvol_coefficients.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_mod_teos10_constants.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_mod_toolbox.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_pt0_from_t.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_pt_from_ct.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_pt_from_t.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_rho.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_rho_first_derivatives.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_rho_second_derivatives.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_sp_from_sr.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_specvol.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_specvol_first_derivatives.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_specvol_second_derivatives.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_sr_from_sp.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_t_deriv_chem_potential_water_t_exact.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_t_freezing_exact.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_t_freezing_poly.f90 mode change 100644 => 120000 src/equation_of_state/TEOS10/gsw_t_from_ct.f90 diff --git a/src/equation_of_state/TEOS10/gsw_chem_potential_water_t_exact.f90 b/src/equation_of_state/TEOS10/gsw_chem_potential_water_t_exact.f90 deleted file mode 100644 index ca1ac55956..0000000000 --- a/src/equation_of_state/TEOS10/gsw_chem_potential_water_t_exact.f90 +++ /dev/null @@ -1,82 +0,0 @@ -!========================================================================== -elemental function gsw_chem_potential_water_t_exact (sa, t, p) -!========================================================================== -! -! Calculates the chemical potential of water in seawater. -! -! SA = Absolute Salinity [ g/kg ] -! t = in-situ temperature (ITS-90) [ deg C ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! -! chem_potential_water_t_exact = chemical potential of water in seawater -! [ J/g ] -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sfac - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, t, p - -real (r8) :: gsw_chem_potential_water_t_exact - -real (r8) :: g03_g, g08_g, g_sa_part, x, x2, y, z - -real (r8), parameter :: kg2g = 1e-3_r8 - -x2 = gsw_sfac*sa -x = sqrt(x2) -y = t*0.025_r8 -z = p*1e-4_r8 - -g03_g = 101.342743139674_r8 + z*(100015.695367145_r8 + & - z*(-2544.5765420363_r8 + z*(284.517778446287_r8 + & - z*(-33.3146754253611_r8 + (4.20263108803084_r8 - 0.546428511471039_r8*z)*z)))) + & - y*(5.90578347909402_r8 + z*(-270.983805184062_r8 + & - z*(776.153611613101_r8 + z*(-196.51255088122_r8 + (28.9796526294175_r8 - 2.13290083518327_r8*z)*z))) + & - y*(-12357.785933039_r8 + z*(1455.0364540468_r8 + & - z*(-756.558385769359_r8 + z*(273.479662323528_r8 + z*(-55.5604063817218_r8 + 4.34420671917197_r8*z)))) + & - y*(736.741204151612_r8 + z*(-672.50778314507_r8 + & - z*(499.360390819152_r8 + z*(-239.545330654412_r8 + (48.8012518593872_r8 - 1.66307106208905_r8*z)*z))) + & - y*(-148.185936433658_r8 + z*(397.968445406972_r8 + & - z*(-301.815380621876_r8 + (152.196371733841_r8 - 26.3748377232802_r8*z)*z)) + & - y*(58.0259125842571_r8 + z*(-194.618310617595_r8 + & - z*(120.520654902025_r8 + z*(-55.2723052340152_r8 + 6.48190668077221_r8*z))) + & - y*(-18.9843846514172_r8 + y*(3.05081646487967_r8 - 9.63108119393062_r8*z) + & - z*(63.5113936641785_r8 + z*(-22.2897317140459_r8 + 8.17060541818112_r8*z)))))))) - -g08_g = x2*(1416.27648484197_r8 + & - x*(-2432.14662381794_r8 + x*(2025.80115603697_r8 + & - y*(543.835333000098_r8 + y*(-68.5572509204491_r8 + & - y*(49.3667694856254_r8 + y*(-17.1397577419788_r8 + 2.49697009569508_r8*y))) - 22.6683558512829_r8*z) + & - x*(-1091.66841042967_r8 - 196.028306689776_r8*y + & - x*(374.60123787784_r8 - 48.5891069025409_r8*x + 36.7571622995805_r8*y) + 36.0284195611086_r8*z) + & - z*(-54.7919133532887_r8 + (-4.08193978912261_r8 - 30.1755111971161_r8*z)*z)) + & - z*(199.459603073901_r8 + z*(-52.2940909281335_r8 + (68.0444942726459_r8 - 3.41251932441282_r8*z)*z)) + & - y*(-493.407510141682_r8 + z*(-175.292041186547_r8 + (83.1923927801819_r8 - 29.483064349429_r8*z)*z) + & - y*(-43.0664675978042_r8 + z*(383.058066002476_r8 + z*(-54.1917262517112_r8 + 25.6398487389914_r8*z)) + & - y*(-10.0227370861875_r8 - 460.319931801257_r8*z + y*(0.875600661808945_r8 + 234.565187611355_r8*z))))) + & - y*(168.072408311545_r8)) - -g_sa_part = 8645.36753595126_r8 + & - x*(-7296.43987145382_r8 + x*(8103.20462414788_r8 + & - y*(2175.341332000392_r8 + y*(-274.2290036817964_r8 + & - y*(197.4670779425016_r8 + y*(-68.5590309679152_r8 + 9.98788038278032_r8*y))) - 90.6734234051316_r8*z) + & - x*(-5458.34205214835_r8 - 980.14153344888_r8*y + & - x*(2247.60742726704_r8 - 340.1237483177863_r8*x + 220.542973797483_r8*y) + 180.142097805543_r8*z) + & - z*(-219.1676534131548_r8 + (-16.32775915649044_r8 - 120.7020447884644_r8*z)*z)) + & - z*(598.378809221703_r8 + z*(-156.8822727844005_r8 + (204.1334828179377_r8 - 10.23755797323846_r8*z)*z)) + & - y*(-1480.222530425046_r8 + z*(-525.876123559641_r8 + (249.57717834054571_r8 - 88.449193048287_r8*z)*z) + & - y*(-129.1994027934126_r8 + z*(1149.174198007428_r8 + z*(-162.5751787551336_r8 + 76.9195462169742_r8*z)) + & - y*(-30.0682112585625_r8 - 1380.9597954037708_r8*z + y*(2.626801985426835_r8 + 703.695562834065_r8*z))))) + & - y*(1187.3715515697959_r8) - -gsw_chem_potential_water_t_exact = kg2g*(g03_g + g08_g - 0.5_r8*x2*g_sa_part) - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_chem_potential_water_t_exact.f90 b/src/equation_of_state/TEOS10/gsw_chem_potential_water_t_exact.f90 new file mode 120000 index 0000000000..7ce7ff9e1e --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_chem_potential_water_t_exact.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_chem_potential_water_t_exact.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_ct_freezing_exact.f90 b/src/equation_of_state/TEOS10/gsw_ct_freezing_exact.f90 deleted file mode 100644 index 1627322dcd..0000000000 --- a/src/equation_of_state/TEOS10/gsw_ct_freezing_exact.f90 +++ /dev/null @@ -1,43 +0,0 @@ -!========================================================================== -elemental function gsw_ct_freezing_exact (sa, p, saturation_fraction) -!========================================================================== -! -! Calculates the Conservative Temperature at which seawater freezes. The -! Conservative Temperature freezing point is calculated from the exact -! in-situ freezing temperature which is found by a modified Newton-Raphson -! iteration (McDougall and Wotherspoon, 2013) of the equality of the -! chemical potentials of water in seawater and in ice. -! -! An alternative GSW function, gsw_CT_freezing_poly, it is based on a -! computationally-efficient polynomial, and is accurate to within -5e-4 K -! and 6e-4 K, when compared with this function. -! -! SA = Absolute Salinity [ g/kg ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! saturation_fraction = the saturation fraction of dissolved air in -! seawater -! -! CT_freezing = Conservative Temperature at freezing of seawater [ deg C ] -!-------------------------------------------------------------------------- - -use gsw_mod_toolbox, only : gsw_t_freezing_exact -use gsw_mod_toolbox, only : gsw_ct_from_t - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, p, saturation_fraction - -real (r8) :: gsw_ct_freezing_exact - -real (r8) :: t_freezing - -t_freezing = gsw_t_freezing_exact(sa,p,saturation_fraction) -gsw_ct_freezing_exact = gsw_ct_from_t(sa,t_freezing,p) - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_ct_freezing_exact.f90 b/src/equation_of_state/TEOS10/gsw_ct_freezing_exact.f90 new file mode 120000 index 0000000000..696fe5c425 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_ct_freezing_exact.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_ct_freezing_exact.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_ct_freezing_poly.f90 b/src/equation_of_state/TEOS10/gsw_ct_freezing_poly.f90 deleted file mode 100644 index a6b8f08091..0000000000 --- a/src/equation_of_state/TEOS10/gsw_ct_freezing_poly.f90 +++ /dev/null @@ -1,53 +0,0 @@ -!========================================================================== -elemental function gsw_ct_freezing_poly (sa, p, saturation_fraction) -!========================================================================== -! -! Calculates the Conservative Temperature at which seawater freezes. -! The error of this fit ranges between -5e-4 K and 6e-4 K when compared -! with the Conservative Temperature calculated from the exact in-situ -! freezing temperature which is found by a Newton-Raphson iteration of the -! equality of the chemical potentials of water in seawater and in ice. -! Note that the Conservative temperature freezing temperature can be found -! by this exact method using the function gsw_CT_freezing. -! -! SA = Absolute Salinity [ g/kg ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! saturation_fraction = the saturation fraction of dissolved air in -! seawater -! -! CT_freezing = Conservative Temperature at freezing of seawater [ deg C ] -! That is, the freezing temperature expressed in -! terms of Conservative Temperature (ITS-90). -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sso - -use gsw_mod_freezing_poly_coefficients - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, p, saturation_fraction - -real (r8) :: gsw_ct_freezing_poly - -real (r8) :: p_r, sa_r, x - -sa_r = sa*1e-2_r8 -x = sqrt(sa_r) -p_r = p*1e-4_r8 - -gsw_ct_freezing_poly = c0 & - + sa_r*(c1 + x*(c2 + x*(c3 + x*(c4 + x*(c5 + c6*x))))) & - + p_r*(c7 + p_r*(c8 + c9*p_r)) + sa_r*p_r*(c10 + p_r*(c12 & - + p_r*(c15 + c21*sa_r)) + sa_r*(c13 + c17*p_r + c19*sa_r) & - + x*(c11 + p_r*(c14 + c18*p_r) + sa_r*(c16 + c20*p_r + c22*sa_r))) - -! Adjust for the effects of dissolved air -gsw_ct_freezing_poly = gsw_ct_freezing_poly - saturation_fraction* & - (1e-3_r8)*(2.4_r8 - a*sa)*(1.0_r8 + b*(1.0_r8 - sa/gsw_sso)) - -return -end function diff --git a/src/equation_of_state/TEOS10/gsw_ct_freezing_poly.f90 b/src/equation_of_state/TEOS10/gsw_ct_freezing_poly.f90 new file mode 120000 index 0000000000..84e6e12572 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_ct_freezing_poly.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_ct_freezing_poly.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_ct_from_pt.f90 b/src/equation_of_state/TEOS10/gsw_ct_from_pt.f90 deleted file mode 100644 index c4a624ed37..0000000000 --- a/src/equation_of_state/TEOS10/gsw_ct_from_pt.f90 +++ /dev/null @@ -1,52 +0,0 @@ -!========================================================================== -elemental function gsw_ct_from_pt (sa, pt) -!========================================================================== -! -! Calculates Conservative Temperature from potential temperature of seawater -! -! sa : Absolute Salinity [g/kg] -! pt : potential temperature with [deg C] -! reference pressure of 0 dbar -! -! gsw_ct_from_pt : Conservative Temperature [deg C] -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_cp0, gsw_sfac - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, pt - -real (r8) :: gsw_ct_from_pt - -real (r8) :: pot_enthalpy, x2, x, y - -x2 = gsw_sfac*sa -x = sqrt(x2) -y = pt*0.025_r8 ! normalize for F03 and F08 - -pot_enthalpy = 61.01362420681071_r8 + y*(168776.46138048015_r8 + & - y*(-2735.2785605119625_r8 + y*(2574.2164453821433_r8 + & - y*(-1536.6644434977543_r8 + y*(545.7340497931629_r8 + & - (-50.91091728474331_r8 - 18.30489878927802_r8*y)*y))))) + & - x2*(268.5520265845071_r8 + y*(-12019.028203559312_r8 + & - y*(3734.858026725145_r8 + y*(-2046.7671145057618_r8 + & - y*(465.28655623826234_r8 + (-0.6370820302376359_r8 - & - 10.650848542359153_r8*y)*y)))) + & - x*(937.2099110620707_r8 + y*(588.1802812170108_r8 + & - y*(248.39476522971285_r8 + (-3.871557904936333_r8 - & - 2.6268019854268356_r8*y)*y)) + & - x*(-1687.914374187449_r8 + x*(246.9598888781377_r8 + & - x*(123.59576582457964_r8 - 48.5891069025409_r8*x)) + & - y*(936.3206544460336_r8 + & - y*(-942.7827304544439_r8 + y*(369.4389437509002_r8 + & - (-33.83664947895248_r8 - 9.987880382780322_r8*y)*y)))))) - -gsw_ct_from_pt = pot_enthalpy/gsw_cp0 - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_ct_from_pt.f90 b/src/equation_of_state/TEOS10/gsw_ct_from_pt.f90 new file mode 120000 index 0000000000..d67d2df3e2 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_ct_from_pt.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_ct_from_pt.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_ct_from_t.f90 b/src/equation_of_state/TEOS10/gsw_ct_from_t.f90 deleted file mode 100644 index b2a0c9e354..0000000000 --- a/src/equation_of_state/TEOS10/gsw_ct_from_t.f90 +++ /dev/null @@ -1,32 +0,0 @@ -!========================================================================== -elemental function gsw_ct_from_t (sa, t, p) -!========================================================================== -! -! Calculates Conservative Temperature from in-situ temperature -! -! sa : Absolute Salinity [g/kg] -! t : in-situ temperature [deg C] -! p : sea pressure [dbar] -! -! gsw_ct_from_t : Conservative Temperature [deg C] -!-------------------------------------------------------------------------- - -use gsw_mod_toolbox, only : gsw_ct_from_pt, gsw_pt0_from_t - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, t, p - -real (r8) :: gsw_ct_from_t - -real (r8) :: pt0 - -pt0 = gsw_pt0_from_t(sa,t,p) -gsw_ct_from_t = gsw_ct_from_pt(sa,pt0) - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_ct_from_t.f90 b/src/equation_of_state/TEOS10/gsw_ct_from_t.f90 new file mode 120000 index 0000000000..6f917027b3 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_ct_from_t.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_ct_from_t.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_entropy_part.f90 b/src/equation_of_state/TEOS10/gsw_entropy_part.f90 deleted file mode 100644 index 70fcd11255..0000000000 --- a/src/equation_of_state/TEOS10/gsw_entropy_part.f90 +++ /dev/null @@ -1,62 +0,0 @@ -!========================================================================== -elemental function gsw_entropy_part (sa, t, p) -!========================================================================== -! -! entropy minus the terms that are a function of only SA -! -! sa : Absolute Salinity [g/kg] -! t : in-situ temperature [deg C] -! p : sea pressure [dbar] -! -! gsw_entropy_part : entropy part -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sfac - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, t, p - -real (r8) :: gsw_entropy_part - -real (r8) :: x2, x, y, z, g03, g08 - -x2 = gsw_sfac*sa -x = sqrt(x2) -y = t*0.025_r8 -z = p*1e-4_r8 - -g03 = z*(-270.983805184062_r8 + & - z*(776.153611613101_r8 + z*(-196.51255088122_r8 + (28.9796526294175_r8 - 2.13290083518327_r8*z)*z))) + & - y*(-24715.571866078_r8 + z*(2910.0729080936_r8 + & - z*(-1513.116771538718_r8 + z*(546.959324647056_r8 + z*(-111.1208127634436_r8 + 8.68841343834394_r8*z)))) + & - y*(2210.2236124548363_r8 + z*(-2017.52334943521_r8 + & - z*(1498.081172457456_r8 + z*(-718.6359919632359_r8 + (146.4037555781616_r8 - 4.9892131862671505_r8*z)*z))) + & - y*(-592.743745734632_r8 + z*(1591.873781627888_r8 + & - z*(-1207.261522487504_r8 + (608.785486935364_r8 - 105.4993508931208_r8*z)*z)) + & - y*(290.12956292128547_r8 + z*(-973.091553087975_r8 + & - z*(602.603274510125_r8 + z*(-276.361526170076_r8 + 32.40953340386105_r8*z))) + & - y*(-113.90630790850321_r8 + y*(21.35571525415769_r8 - 67.41756835751434_r8*z) + & - z*(381.06836198507096_r8 + z*(-133.7383902842754_r8 + 49.023632509086724_r8*z))))))) - -g08 = x2*(z*(729.116529735046_r8 + & - z*(-343.956902961561_r8 + z*(124.687671116248_r8 + z*(-31.656964386073_r8 + 7.04658803315449_r8*z)))) + & - x*( x*(y*(-137.1145018408982_r8 + y*(148.10030845687618_r8 + y*(-68.5590309679152_r8 + 12.4848504784754_r8*y))) - & - 22.6683558512829_r8*z) + z*(-175.292041186547_r8 + (83.1923927801819_r8 - 29.483064349429_r8*z)*z) + & - y*(-86.1329351956084_r8 + z*(766.116132004952_r8 + z*(-108.3834525034224_r8 + 51.2796974779828_r8*z)) + & - y*(-30.0682112585625_r8 - 1380.9597954037708_r8*z + y*(3.50240264723578_r8 + 938.26075044542_r8*z)))) + & - y*(1760.062705994408_r8 + y*(-675.802947790203_r8 + & - y*(365.7041791005036_r8 + y*(-108.30162043765552_r8 + 12.78101825083098_r8*y) + & - z*(-1190.914967948748_r8 + (298.904564555024_r8 - 145.9491676006352_r8*z)*z)) + & - z*(2082.7344423998043_r8 + z*(-614.668925894709_r8 + (340.685093521782_r8 - 33.3848202979239_r8*z)*z))) + & - z*(-1721.528607567954_r8 + z*(674.819060538734_r8 + & - z*(-356.629112415276_r8 + (88.4080716616_r8 - 15.84003094423364_r8*z)*z))))) - -gsw_entropy_part = -(g03 + g08)*0.025_r8 - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_entropy_part.f90 b/src/equation_of_state/TEOS10/gsw_entropy_part.f90 new file mode 120000 index 0000000000..0160db551f --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_entropy_part.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_entropy_part.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_entropy_part_zerop.f90 b/src/equation_of_state/TEOS10/gsw_entropy_part_zerop.f90 deleted file mode 100644 index 2156b71c4e..0000000000 --- a/src/equation_of_state/TEOS10/gsw_entropy_part_zerop.f90 +++ /dev/null @@ -1,44 +0,0 @@ -!========================================================================== -elemental function gsw_entropy_part_zerop (sa, pt0) -!========================================================================== -! -! entropy part evaluated at the sea surface -! -! sa : Absolute Salinity [g/kg] -! pt0 : insitu temperature [deg C] -! -! gsw_entropy_part_zerop : entropy part at the sea surface -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sfac - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, pt0 - -real (r8) :: gsw_entropy_part_zerop - -real (r8) :: x2, x, y, g03, g08 - -x2 = gsw_sfac*sa -x = sqrt(x2) -y = pt0*0.025_r8 - -g03 = y*(-24715.571866078_r8 + y*(2210.2236124548363_r8 + & - y*(-592.743745734632_r8 + y*(290.12956292128547_r8 + & - y*(-113.90630790850321_r8 + y*21.35571525415769_r8))))) - -g08 = x2*(x*(x*(y*(-137.1145018408982_r8 + y*(148.10030845687618_r8 + & - y*(-68.5590309679152_r8 + 12.4848504784754_r8*y)))) + & - y*(-86.1329351956084_r8 + y*(-30.0682112585625_r8 + y*3.50240264723578_r8))) + & - y*(1760.062705994408_r8 + y*(-675.802947790203_r8 + & - y*(365.7041791005036_r8 + y*(-108.30162043765552_r8 + 12.78101825083098_r8*y))))) - -gsw_entropy_part_zerop = -(g03 + g08)*0.025_r8 - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_entropy_part_zerop.f90 b/src/equation_of_state/TEOS10/gsw_entropy_part_zerop.f90 new file mode 120000 index 0000000000..678bce8822 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_entropy_part_zerop.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_entropy_part_zerop.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_gibbs.f90 b/src/equation_of_state/TEOS10/gsw_gibbs.f90 deleted file mode 100644 index 59f7d221ac..0000000000 --- a/src/equation_of_state/TEOS10/gsw_gibbs.f90 +++ /dev/null @@ -1,317 +0,0 @@ -!========================================================================== -elemental function gsw_gibbs (ns, nt, np, sa, t, p) -!========================================================================== -! -! seawater specific Gibbs free energy and derivatives up to order 2 -! -! ns : order of s derivative -! nt : order of t derivative -! np : order of p derivative -! sa : Absolute Salinity [g/kg] -! t : temperature [deg C] -! p : sea pressure [dbar] -! -! gsw_gibbs : specific Gibbs energy or its derivative -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sfac - -use gsw_mod_kinds - -implicit none - -integer, intent(in) :: ns, nt, np -real (r8), intent(in) :: sa, t, p - -real (r8) :: gsw_gibbs - -real (r8) :: x2, x, y, z, g03, g08 - -x2 = gsw_sfac*sa -x = sqrt(x2) -y = t*0.025_r8 -z = p*1e-4_r8 - -if(ns.eq.0 .and. nt.eq.0 .and. np.eq.0) then - - g03 = 101.342743139674_r8 + z*(100015.695367145_r8 + & - z*(-2544.5765420363_r8 + z*(284.517778446287_r8 + & - z*(-33.3146754253611_r8 + (4.20263108803084_r8 - 0.546428511471039_r8*z)*z)))) + & - y*(5.90578347909402_r8 + z*(-270.983805184062_r8 + & - z*(776.153611613101_r8 + z*(-196.51255088122_r8 + (28.9796526294175_r8 - 2.13290083518327_r8*z)*z))) + & - y*(-12357.785933039_r8 + z*(1455.0364540468_r8 + & - z*(-756.558385769359_r8 + z*(273.479662323528_r8 + z*(-55.5604063817218_r8 + 4.34420671917197_r8*z)))) + & - y*(736.741204151612_r8 + z*(-672.50778314507_r8 + & - z*(499.360390819152_r8 + z*(-239.545330654412_r8 + (48.8012518593872_r8 - 1.66307106208905_r8*z)*z))) + & - y*(-148.185936433658_r8 + z*(397.968445406972_r8 + & - z*(-301.815380621876_r8 + (152.196371733841_r8 - 26.3748377232802_r8*z)*z)) + & - y*(58.0259125842571_r8 + z*(-194.618310617595_r8 + & - z*(120.520654902025_r8 + z*(-55.2723052340152_r8 + 6.48190668077221_r8*z))) + & - y*(-18.9843846514172_r8 + y*(3.05081646487967_r8 - 9.63108119393062_r8*z) + & - z*(63.5113936641785_r8 + z*(-22.2897317140459_r8 + 8.17060541818112_r8*z)))))))) - - g08 = x2*(1416.27648484197_r8 + z*(-3310.49154044839_r8 + & - z*(384.794152978599_r8 + z*(-96.5324320107458_r8 + (15.8408172766824_r8 - 2.62480156590992_r8*z)*z))) + & - x*(-2432.14662381794_r8 + x*(2025.80115603697_r8 + & - y*(543.835333000098_r8 + y*(-68.5572509204491_r8 + & - y*(49.3667694856254_r8 + y*(-17.1397577419788_r8 + 2.49697009569508_r8*y))) - 22.6683558512829_r8*z) + & - x*(-1091.66841042967_r8 - 196.028306689776_r8*y + & - x*(374.60123787784_r8 - 48.5891069025409_r8*x + 36.7571622995805_r8*y) + 36.0284195611086_r8*z) + & - z*(-54.7919133532887_r8 + (-4.08193978912261_r8 - 30.1755111971161_r8*z)*z)) + & - z*(199.459603073901_r8 + z*(-52.2940909281335_r8 + (68.0444942726459_r8 - 3.41251932441282_r8*z)*z)) + & - y*(-493.407510141682_r8 + z*(-175.292041186547_r8 + (83.1923927801819_r8 - 29.483064349429_r8*z)*z) + & - y*(-43.0664675978042_r8 + z*(383.058066002476_r8 + z*(-54.1917262517112_r8 + 25.6398487389914_r8*z)) + & - y*(-10.0227370861875_r8 - 460.319931801257_r8*z + y*(0.875600661808945_r8 + 234.565187611355_r8*z))))) + & - y*(168.072408311545_r8 + z*(729.116529735046_r8 + & - z*(-343.956902961561_r8 + z*(124.687671116248_r8 + z*(-31.656964386073_r8 + 7.04658803315449_r8*z)))) + & - y*(880.031352997204_r8 + y*(-225.267649263401_r8 + & - y*(91.4260447751259_r8 + y*(-21.6603240875311_r8 + 2.13016970847183_r8*y) + & - z*(-297.728741987187_r8 + (74.726141138756_r8 - 36.4872919001588_r8*z)*z)) + & - z*(694.244814133268_r8 + z*(-204.889641964903_r8 + (113.561697840594_r8 - 11.1282734326413_r8*z)*z))) + & - z*(-860.764303783977_r8 + z*(337.409530269367_r8 + & - z*(-178.314556207638_r8 + (44.2040358308_r8 - 7.92001547211682_r8*z)*z)))))) - - if(sa.gt.0.0_r8) & - g08 = g08 + x2*(5812.81456626732_r8 + 851.226734946706_r8*y)*log(x) - - gsw_gibbs = g03 + g08 - -elseif(ns.eq.1 .and. nt.eq.0 .and. np.eq.0) then - - g08 = 8645.36753595126_r8 + z*(-6620.98308089678_r8 + & - z*(769.588305957198_r8 + z*(-193.0648640214916_r8 + (31.6816345533648_r8 - 5.24960313181984_r8*z)*z))) + & - x*(-7296.43987145382_r8 + x*(8103.20462414788_r8 + & - y*(2175.341332000392_r8 + y*(-274.2290036817964_r8 + & - y*(197.4670779425016_r8 + y*(-68.5590309679152_r8 + 9.98788038278032_r8*y))) - 90.6734234051316_r8*z) + & - x*(-5458.34205214835_r8 - 980.14153344888_r8*y + & - x*(2247.60742726704_r8 - 340.1237483177863_r8*x + 220.542973797483_r8*y) + 180.142097805543_r8*z) + & - z*(-219.1676534131548_r8 + (-16.32775915649044_r8 - 120.7020447884644_r8*z)*z)) + & - z*(598.378809221703_r8 + z*(-156.8822727844005_r8 + (204.1334828179377_r8 - 10.23755797323846_r8*z)*z)) + & - y*(-1480.222530425046_r8 + z*(-525.876123559641_r8 + (249.57717834054571_r8 - 88.449193048287_r8*z)*z) + & - y*(-129.1994027934126_r8 + z*(1149.174198007428_r8 + z*(-162.5751787551336_r8 + 76.9195462169742_r8*z)) + & - y*(-30.0682112585625_r8 - 1380.9597954037708_r8*z + y*(2.626801985426835_r8 + 703.695562834065_r8*z))))) + & - y*(1187.3715515697959_r8 + z*(1458.233059470092_r8 + & - z*(-687.913805923122_r8 + z*(249.375342232496_r8 + z*(-63.313928772146_r8 + 14.09317606630898_r8*z)))) + & - y*(1760.062705994408_r8 + y*(-450.535298526802_r8 + & - y*(182.8520895502518_r8 + y*(-43.3206481750622_r8 + 4.26033941694366_r8*y) + & - z*(-595.457483974374_r8 + (149.452282277512_r8 - 72.9745838003176_r8*z)*z)) + & - z*(1388.489628266536_r8 + z*(-409.779283929806_r8 + (227.123395681188_r8 - 22.2565468652826_r8*z)*z))) + & - z*(-1721.528607567954_r8 + z*(674.819060538734_r8 + & - z*(-356.629112415276_r8 + (88.4080716616_r8 - 15.84003094423364_r8*z)*z))))) - - if(sa.gt.0_r8) then - g08 = g08 + (11625.62913253464_r8 + 1702.453469893412_r8*y)*log(x) - else - g08 = 0.0_r8 - endif - - gsw_gibbs = 0.5*gsw_sfac*g08 - -elseif(ns.eq.0 .and. nt.eq.1 .and. np.eq.0) then - - g03 = 5.90578347909402_r8 + z*(-270.983805184062_r8 + & - z*(776.153611613101_r8 + z*(-196.51255088122_r8 + (28.9796526294175_r8 - 2.13290083518327_r8*z)*z))) + & - y*(-24715.571866078_r8 + z*(2910.0729080936_r8 + & - z*(-1513.116771538718_r8 + z*(546.959324647056_r8 + z*(-111.1208127634436_r8 + 8.68841343834394_r8*z)))) + & - y*(2210.2236124548363_r8 + z*(-2017.52334943521_r8 + & - z*(1498.081172457456_r8 + z*(-718.6359919632359_r8 + (146.4037555781616_r8 - 4.9892131862671505_r8*z)*z))) + & - y*(-592.743745734632_r8 + z*(1591.873781627888_r8 + & - z*(-1207.261522487504_r8 + (608.785486935364_r8 - 105.4993508931208_r8*z)*z)) + & - y*(290.12956292128547_r8 + z*(-973.091553087975_r8 + & - z*(602.603274510125_r8 + z*(-276.361526170076_r8 + 32.40953340386105_r8*z))) + & - y*(-113.90630790850321_r8 + y*(21.35571525415769_r8 - 67.41756835751434_r8*z) + & - z*(381.06836198507096_r8 + z*(-133.7383902842754_r8 + 49.023632509086724_r8*z))))))) - - g08 = x2*(168.072408311545_r8 + z*(729.116529735046_r8 + & - z*(-343.956902961561_r8 + z*(124.687671116248_r8 + z*(-31.656964386073_r8 + 7.04658803315449_r8*z)))) + & - x*(-493.407510141682_r8 + x*(543.835333000098_r8 + x*(-196.028306689776_r8 + 36.7571622995805_r8*x) + & - y*(-137.1145018408982_r8 + y*(148.10030845687618_r8 + y*(-68.5590309679152_r8 + 12.4848504784754_r8*y))) - & - 22.6683558512829_r8*z) + z*(-175.292041186547_r8 + (83.1923927801819_r8 - 29.483064349429_r8*z)*z) + & - y*(-86.1329351956084_r8 + z*(766.116132004952_r8 + z*(-108.3834525034224_r8 + 51.2796974779828_r8*z)) + & - y*(-30.0682112585625_r8 - 1380.9597954037708_r8*z + y*(3.50240264723578_r8 + 938.26075044542_r8*z)))) + & - y*(1760.062705994408_r8 + y*(-675.802947790203_r8 + & - y*(365.7041791005036_r8 + y*(-108.30162043765552_r8 + 12.78101825083098_r8*y) + & - z*(-1190.914967948748_r8 + (298.904564555024_r8 - 145.9491676006352_r8*z)*z)) + & - z*(2082.7344423998043_r8 + z*(-614.668925894709_r8 + (340.685093521782_r8 - 33.3848202979239_r8*z)*z))) + & - z*(-1721.528607567954_r8 + z*(674.819060538734_r8 + & - z*(-356.629112415276_r8 + (88.4080716616_r8 - 15.84003094423364_r8*z)*z))))) - - if(sa.gt.0_r8) g08 = g08 + 851.226734946706_r8*x2*log(x) - - gsw_gibbs = (g03 + g08)*0.025_r8 - -elseif(ns.eq.0 .and. nt.eq.0 .and. np.eq.1) then - - g03 = 100015.695367145_r8 + z*(-5089.1530840726_r8 + & - z*(853.5533353388611_r8 + z*(-133.2587017014444_r8 + (21.0131554401542_r8 - 3.278571068826234_r8*z)*z))) + & - y*(-270.983805184062_r8 + z*(1552.307223226202_r8 + & - z*(-589.53765264366_r8 + (115.91861051767_r8 - 10.664504175916349_r8*z)*z)) + & - y*(1455.0364540468_r8 + z*(-1513.116771538718_r8 + & - z*(820.438986970584_r8 + z*(-222.2416255268872_r8 + 21.72103359585985_r8*z))) + & - y*(-672.50778314507_r8 + z*(998.720781638304_r8 + & - z*(-718.6359919632359_r8 + (195.2050074375488_r8 - 8.31535531044525_r8*z)*z)) + & - y*(397.968445406972_r8 + z*(-603.630761243752_r8 + (456.589115201523_r8 - 105.4993508931208_r8*z)*z) + & - y*(-194.618310617595_r8 + y*(63.5113936641785_r8 - 9.63108119393062_r8*y + & - z*(-44.5794634280918_r8 + 24.511816254543362_r8*z)) + & - z*(241.04130980405_r8 + z*(-165.8169157020456_r8 + & - 25.92762672308884_r8*z))))))) - - g08 = x2*(-3310.49154044839_r8 + z*(769.588305957198_r8 + & - z*(-289.5972960322374_r8 + (63.3632691067296_r8 - 13.1240078295496_r8*z)*z)) + & - x*(199.459603073901_r8 + x*(-54.7919133532887_r8 + 36.0284195611086_r8*x - 22.6683558512829_r8*y + & - (-8.16387957824522_r8 - 90.52653359134831_r8*z)*z) + & - z*(-104.588181856267_r8 + (204.1334828179377_r8 - 13.65007729765128_r8*z)*z) + & - y*(-175.292041186547_r8 + (166.3847855603638_r8 - 88.449193048287_r8*z)*z + & - y*(383.058066002476_r8 + y*(-460.319931801257_r8 + 234.565187611355_r8*y) + & - z*(-108.3834525034224_r8 + 76.9195462169742_r8*z)))) + & - y*(729.116529735046_r8 + z*(-687.913805923122_r8 + & - z*(374.063013348744_r8 + z*(-126.627857544292_r8 + 35.23294016577245_r8*z))) + & - y*(-860.764303783977_r8 + y*(694.244814133268_r8 + & - y*(-297.728741987187_r8 + (149.452282277512_r8 - 109.46187570047641_r8*z)*z) + & - z*(-409.779283929806_r8 + (340.685093521782_r8 - 44.5130937305652_r8*z)*z)) + & - z*(674.819060538734_r8 + z*(-534.943668622914_r8 + (176.8161433232_r8 - 39.600077360584095_r8*z)*z))))) - - gsw_gibbs = (g03 + g08)*1e-8_r8 - -elseif(ns.eq.0 .and. nt.eq.2 .and. np.eq.0) then - - g03 = -24715.571866078_r8 + z*(2910.0729080936_r8 + z* & - (-1513.116771538718_r8 + z*(546.959324647056_r8 + z*(-111.1208127634436_r8 + 8.68841343834394_r8*z)))) + & - y*(4420.4472249096725_r8 + z*(-4035.04669887042_r8 + & - z*(2996.162344914912_r8 + z*(-1437.2719839264719_r8 + (292.8075111563232_r8 - 9.978426372534301_r8*z)*z))) + & - y*(-1778.231237203896_r8 + z*(4775.621344883664_r8 + & - z*(-3621.784567462512_r8 + (1826.356460806092_r8 - 316.49805267936244_r8*z)*z)) + & - y*(1160.5182516851419_r8 + z*(-3892.3662123519_r8 + & - z*(2410.4130980405_r8 + z*(-1105.446104680304_r8 + 129.6381336154442_r8*z))) + & - y*(-569.531539542516_r8 + y*(128.13429152494615_r8 - 404.50541014508605_r8*z) + & - z*(1905.341809925355_r8 + z*(-668.691951421377_r8 + 245.11816254543362_r8*z)))))) - - g08 = x2*(1760.062705994408_r8 + x*(-86.1329351956084_r8 + & - x*(-137.1145018408982_r8 + y*(296.20061691375236_r8 + y*(-205.67709290374563_r8 + 49.9394019139016_r8*y))) + & - z*(766.116132004952_r8 + z*(-108.3834525034224_r8 + 51.2796974779828_r8*z)) + & - y*(-60.136422517125_r8 - 2761.9195908075417_r8*z + y*(10.50720794170734_r8 + 2814.78225133626_r8*z))) + & - y*(-1351.605895580406_r8 + y*(1097.1125373015109_r8 + y*(-433.20648175062206_r8 + 63.905091254154904_r8*y) + & - z*(-3572.7449038462437_r8 + (896.713693665072_r8 - 437.84750280190565_r8*z)*z)) + & - z*(4165.4688847996085_r8 + z*(-1229.337851789418_r8 + (681.370187043564_r8 - 66.7696405958478_r8*z)*z))) + & - z*(-1721.528607567954_r8 + z*(674.819060538734_r8 + & - z*(-356.629112415276_r8 + (88.4080716616_r8 - 15.84003094423364_r8*z)*z)))) - - gsw_gibbs = (g03 + g08)*0.000625_r8 - -elseif(ns.eq.1 .and. nt.eq.0 .and. np.eq.1) then - - g08 = -6620.98308089678_r8 + z*(1539.176611914396_r8 + & - z*(-579.1945920644748_r8 + (126.7265382134592_r8 - 26.2480156590992_r8*z)*z)) + & - x*(598.378809221703_r8 + x*(-219.1676534131548_r8 + 180.142097805543_r8*x - 90.6734234051316_r8*y + & - (-32.65551831298088_r8 - 362.10613436539325_r8*z)*z) + & - z*(-313.764545568801_r8 + (612.4004484538132_r8 - 40.95023189295384_r8*z)*z) + & - y*(-525.876123559641_r8 + (499.15435668109143_r8 - 265.347579144861_r8*z)*z + & - y*(1149.174198007428_r8 + y*(-1380.9597954037708_r8 + 703.695562834065_r8*y) + & - z*(-325.1503575102672_r8 + 230.7586386509226_r8*z)))) + & - y*(1458.233059470092_r8 + z*(-1375.827611846244_r8 + & - z*(748.126026697488_r8 + z*(-253.255715088584_r8 + 70.4658803315449_r8*z))) + & - y*(-1721.528607567954_r8 + y*(1388.489628266536_r8 + & - y*(-595.457483974374_r8 + (298.904564555024_r8 - 218.92375140095282_r8*z)*z) + & - z*(-819.558567859612_r8 + (681.370187043564_r8 - 89.0261874611304_r8*z)*z)) + & - z*(1349.638121077468_r8 + z*(-1069.887337245828_r8 + (353.6322866464_r8 - 79.20015472116819_r8*z)*z)))) - - gsw_gibbs = g08*gsw_sfac*0.5e-8_r8 - -elseif(ns.eq.0 .and. nt.eq.1 .and. np.eq.1) then - - g03 = -270.983805184062_r8 + z*(1552.307223226202_r8 + z*(-589.53765264366_r8 + & - (115.91861051767_r8 - 10.664504175916349_r8*z)*z)) + & - y*(2910.0729080936_r8 + z*(-3026.233543077436_r8 + & - z*(1640.877973941168_r8 + z*(-444.4832510537744_r8 + 43.4420671917197_r8*z))) + & - y*(-2017.52334943521_r8 + z*(2996.162344914912_r8 + & - z*(-2155.907975889708_r8 + (585.6150223126464_r8 - 24.946065931335752_r8*z)*z)) + & - y*(1591.873781627888_r8 + z*(-2414.523044975008_r8 + (1826.356460806092_r8 - 421.9974035724832_r8*z)*z) + & - y*(-973.091553087975_r8 + z*(1205.20654902025_r8 + z*(-829.084578510228_r8 + 129.6381336154442_r8*z)) + & - y*(381.06836198507096_r8 - 67.41756835751434_r8*y + z*(-267.4767805685508_r8 + 147.07089752726017_r8*z)))))) - - g08 = x2*(729.116529735046_r8 + z*(-687.913805923122_r8 + & - z*(374.063013348744_r8 + z*(-126.627857544292_r8 + 35.23294016577245_r8*z))) + & - x*(-175.292041186547_r8 - 22.6683558512829_r8*x + (166.3847855603638_r8 - 88.449193048287_r8*z)*z + & - y*(766.116132004952_r8 + y*(-1380.9597954037708_r8 + 938.26075044542_r8*y) + & - z*(-216.7669050068448_r8 + 153.8390924339484_r8*z))) + & - y*(-1721.528607567954_r8 + y*(2082.7344423998043_r8 + & - y*(-1190.914967948748_r8 + (597.809129110048_r8 - 437.84750280190565_r8*z)*z) + & - z*(-1229.337851789418_r8 + (1022.055280565346_r8 - 133.5392811916956_r8*z)*z)) + & - z*(1349.638121077468_r8 + z*(-1069.887337245828_r8 + (353.6322866464_r8 - 79.20015472116819_r8*z)*z)))) - - gsw_gibbs = (g03 + g08)*2.5e-10_r8 - -elseif(ns.eq.1 .and. nt.eq.1 .and. np.eq.0) then - - g08 = 1187.3715515697959_r8 + z*(1458.233059470092_r8 + & - z*(-687.913805923122_r8 + z*(249.375342232496_r8 + z*(-63.313928772146_r8 + 14.09317606630898_r8*z)))) + & - x*(-1480.222530425046_r8 + x*(2175.341332000392_r8 + x*(-980.14153344888_r8 + 220.542973797483_r8*x) + & - y*(-548.4580073635929_r8 + y*(592.4012338275047_r8 + y*(-274.2361238716608_r8 + 49.9394019139016_r8*y))) - & - 90.6734234051316_r8*z) + z*(-525.876123559641_r8 + (249.57717834054571_r8 - 88.449193048287_r8*z)*z) + & - y*(-258.3988055868252_r8 + z*(2298.348396014856_r8 + z*(-325.1503575102672_r8 + 153.8390924339484_r8*z)) + & - y*(-90.2046337756875_r8 - 4142.8793862113125_r8*z + y*(10.50720794170734_r8 + 2814.78225133626_r8*z)))) + & - y*(3520.125411988816_r8 + y*(-1351.605895580406_r8 + & - y*(731.4083582010072_r8 + y*(-216.60324087531103_r8 + 25.56203650166196_r8*y) + & - z*(-2381.829935897496_r8 + (597.809129110048_r8 - 291.8983352012704_r8*z)*z)) + & - z*(4165.4688847996085_r8 + z*(-1229.337851789418_r8 + (681.370187043564_r8 - 66.7696405958478_r8*z)*z))) + & - z*(-3443.057215135908_r8 + z*(1349.638121077468_r8 + & - z*(-713.258224830552_r8 + (176.8161433232_r8 - 31.68006188846728_r8*z)*z)))) - - if(sa.gt.0_r8) g08 = g08 + 1702.453469893412_r8*log(x) - - gsw_gibbs = 0.5_r8*gsw_sfac*0.025_r8*g08 - -elseif(ns.eq.2 .and. nt.eq.0 .and. np.eq.0) then - - g08 = 2.0_r8*(8103.20462414788_r8 + & - y*(2175.341332000392_r8 + y*(-274.2290036817964_r8 + & - y*(197.4670779425016_r8 + y*(-68.5590309679152_r8 + 9.98788038278032_r8*y))) - 90.6734234051316_r8*z) + & - 1.5_r8*x*(-5458.34205214835_r8 - 980.14153344888_r8*y + & - (4.0_r8/3.0_r8)*x*(2247.60742726704_r8 - 340.1237483177863_r8*1.25_r8*x + 220.542973797483_r8*y) + & - 180.142097805543_r8*z) + & - z*(-219.1676534131548_r8 + (-16.32775915649044_r8 - 120.7020447884644_r8*z)*z)) - - if (x.gt.0_r8) then - g08 = g08 + (-7296.43987145382_r8 + z*(598.378809221703_r8 + & - z*(-156.8822727844005_r8 + (204.1334828179377_r8 - 10.23755797323846_r8*z)*z)) + & - y*(-1480.222530425046_r8 + z*(-525.876123559641_r8 + & - (249.57717834054571_r8 - 88.449193048287_r8*z)*z) + & - y*(-129.1994027934126_r8 + z*(1149.174198007428_r8 + & - z*(-162.5751787551336_r8 + 76.9195462169742_r8*z)) + & - y*(-30.0682112585625_r8 - 1380.9597954037708_r8*z + & - y*(2.626801985426835_r8 + 703.695562834065_r8*z)))))/x + & - (11625.62913253464_r8 + 1702.453469893412_r8*y)/x2 - else - g08 = 0.0_r8 - end if - - gsw_gibbs = 0.25_r8*gsw_sfac*gsw_sfac*g08 - -elseif(ns.eq.0 .and. nt.eq.0 .and. np.eq.2) then - - g03 = -5089.1530840726_r8 + z*(1707.1066706777221_r8 + & - z*(-399.7761051043332_r8 + (84.0526217606168_r8 - 16.39285534413117_r8*z)*z)) + & - y*(1552.307223226202_r8 + z*(-1179.07530528732_r8 + (347.75583155301_r8 - 42.658016703665396_r8*z)*z) + & - y*(-1513.116771538718_r8 + z*(1640.877973941168_r8 + z*(-666.7248765806615_r8 + 86.8841343834394_r8*z)) + & - y*(998.720781638304_r8 + z*(-1437.2719839264719_r8 + (585.6150223126464_r8 - 33.261421241781_r8*z)*z) + & - y*(-603.630761243752_r8 + (913.178230403046_r8 - 316.49805267936244_r8*z)*z + & - y*(241.04130980405_r8 + y*(-44.5794634280918_r8 + 49.023632509086724_r8*z) + & - z*(-331.6338314040912_r8 + 77.78288016926652_r8*z)))))) - - g08 = x2*(769.588305957198_r8 + z*(-579.1945920644748_r8 + (190.08980732018878_r8 - 52.4960313181984_r8*z)*z) + & - x*(-104.588181856267_r8 + x*(-8.16387957824522_r8 - 181.05306718269662_r8*z) + & - (408.2669656358754_r8 - 40.95023189295384_r8*z)*z + & - y*(166.3847855603638_r8 - 176.898386096574_r8*z + y*(-108.3834525034224_r8 + 153.8390924339484_r8*z))) + & - y*(-687.913805923122_r8 + z*(748.126026697488_r8 + z*(-379.883572632876_r8 + 140.9317606630898_r8*z)) + & - y*(674.819060538734_r8 + z*(-1069.887337245828_r8 + (530.4484299696_r8 - 158.40030944233638_r8*z)*z) + & - y*(-409.779283929806_r8 + y*(149.452282277512_r8 - 218.92375140095282_r8*z) + & - (681.370187043564_r8 - 133.5392811916956_r8*z)*z)))) - - gsw_gibbs = (g03 + g08)*1e-16_r8 - -end if - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_gibbs.f90 b/src/equation_of_state/TEOS10/gsw_gibbs.f90 new file mode 120000 index 0000000000..6bb64d98a7 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_gibbs.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_gibbs.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_gibbs_ice.f90 b/src/equation_of_state/TEOS10/gsw_gibbs_ice.f90 deleted file mode 100644 index 0416a1eeaf..0000000000 --- a/src/equation_of_state/TEOS10/gsw_gibbs_ice.f90 +++ /dev/null @@ -1,130 +0,0 @@ -! ========================================================================= -elemental function gsw_gibbs_ice (nt, np, t, p) -! ========================================================================= -! -! Ice specific Gibbs energy and derivatives up to order 2. -! -! nt = order of t derivative [ integers 0, 1 or 2 ] -! np = order of p derivative [ integers 0, 1 or 2 ] -! t = in-situ temperature (ITS-90) [ deg C ] -! p = sea pressure [ dbar ] -! -! gibbs_ice = Specific Gibbs energy of ice or its derivatives. -! The Gibbs energy (when nt = np = 0) has units of: [ J/kg ] -! The temperature derivatives are output in units of: -! [ (J/kg) (K)^(-nt) ] -! The pressure derivatives are output in units of: -! [ (J/kg) (Pa)^(-np) ] -! The mixed derivatives are output in units of: -! [ (J/kg) (K)^(-nt) (Pa)^(-np) ] -! Note. The derivatives are taken with respect to pressure in Pa, not -! withstanding that the pressure input into this routine is in dbar. -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_t0, db2pa - -use gsw_mod_gibbs_ice_coefficients - -use gsw_mod_kinds - -implicit none - -integer, intent(in) :: nt, np -real (r8), intent(in) :: t, p - -real (r8) :: gsw_gibbs_ice - -real (r8) :: dzi, g0, g0p, g0pp, sqrec_pt -complex (r8) :: r2, r2p, r2pp, g, sqtau_t1, sqtau_t2, tau, tau_t1, tau_t2 - -real (r8), parameter :: s0 = -3.32733756492168e3_r8 - -tau = (t + gsw_t0)*rec_tt - -dzi = db2pa*p*rec_pt - -if (nt.eq.0 .and. np.eq.0) then - - tau_t1 = tau/t1 - sqtau_t1 = tau_t1*tau_t1 - tau_t2 = tau/t2 - sqtau_t2 = tau_t2*tau_t2 - - g0 = g00 + dzi*(g01 + dzi*(g02 + dzi*(g03 + g04*dzi))) - - r2 = r20 + dzi*(r21 + r22*dzi) - - g = r1*(tau*log((1.0_r8 + tau_t1)/(1.0_r8 - tau_t1)) & - + t1*(log(1.0_r8 - sqtau_t1) - sqtau_t1)) & - + r2*(tau*log((1.0_r8 + tau_t2)/(1.0_r8 - tau_t2)) & - + t2*(log(1.0_r8 - sqtau_t2) - sqtau_t2)) - - gsw_gibbs_ice = g0 - tt*(s0*tau - real(g)) - -elseif (nt.eq.1 .and. np.eq.0) then - - tau_t1 = tau/t1 - tau_t2 = tau/t2 - - r2 = r20 + dzi*(r21 + r22*dzi) - - g = r1*(log((1.0_r8 + tau_t1)/(1.0_r8 - tau_t1)) - 2.0_r8*tau_t1) & - + r2*(log((1.0_r8 + tau_t2)/(1.0_r8 - tau_t2)) - 2.0_r8*tau_t2) - - gsw_gibbs_ice = -s0 + real(g) - -elseif (nt.eq.0 .and. np.eq.1) then - - tau_t2 = tau/t2 - sqtau_t2 = tau_t2*tau_t2 - - g0p = rec_pt*(g01 + dzi*(2.0_r8*g02 + dzi*(3.0_r8*g03 + 4.0_r8*g04*dzi))) - - r2p = rec_pt*(r21 + 2.0_r8*r22*dzi) - - g = r2p*(tau*log((1.0_r8 + tau_t2)/(1.0_r8 - tau_t2)) & - + t2*(log(1.0_r8 - sqtau_t2) - sqtau_t2)) - - gsw_gibbs_ice = g0p + tt*real(g) - -elseif (nt.eq.1 .and. np.eq.1) then - - tau_t2 = tau/t2 - - r2p = rec_pt*(r21 + 2.0_r8*r22*dzi) - - g = r2p*(log((1.0_r8 + tau_t2)/(1.0_r8 - tau_t2)) - 2.0_r8*tau_t2) - - gsw_gibbs_ice = real(g) - -elseif (nt.eq.2 .and. np.eq.0) then - - r2 = r20 + dzi*(r21 + r22*dzi) - - g = r1*(1.0_r8/(t1 - tau) + 1.0_r8/(t1 + tau) - 2.0_r8/t1) & - + r2*(1.0_r8/(t2 - tau) + 1.0_r8/(t2 + tau) - 2.0_r8/t2) - - gsw_gibbs_ice = rec_tt*real(g) - -elseif (nt.eq.0 .and. np.eq.2) then - - sqrec_pt = rec_pt*rec_pt - - tau_t2 = tau/t2 - sqtau_t2 = tau_t2*tau_t2 - - g0pp = sqrec_pt*(2.0_r8*g02 + dzi*(6.0_r8*g03 + 12.0_r8*g04*dzi)) - - r2pp = 2.0_r8*r22*sqrec_pt - - g = r2pp*(tau*log((1.0_r8 + tau_t2)/(1.0_r8 - tau_t2)) & - + t2*(log(1.0_r8 - sqtau_t2) - sqtau_t2)) - - gsw_gibbs_ice = g0pp + tt*real(g) - -end if - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_gibbs_ice.f90 b/src/equation_of_state/TEOS10/gsw_gibbs_ice.f90 new file mode 120000 index 0000000000..9d1d06c481 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_gibbs_ice.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_gibbs_ice.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_gibbs_pt0_pt0.f90 b/src/equation_of_state/TEOS10/gsw_gibbs_pt0_pt0.f90 deleted file mode 100644 index 6e8bcfc779..0000000000 --- a/src/equation_of_state/TEOS10/gsw_gibbs_pt0_pt0.f90 +++ /dev/null @@ -1,47 +0,0 @@ -!========================================================================== -elemental function gsw_gibbs_pt0_pt0 (sa, pt0) -!========================================================================== -! -! gibbs_tt at (sa,pt,0) -! -! sa : Absolute Salinity [g/kg] -! pt0 : potential temperature [deg C] -! -! gsw_gibbs_pt0_pt0 : gibbs_tt at (sa,pt,0) -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sfac - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, pt0 - -real (r8) :: gsw_gibbs_pt0_pt0 - -real (r8) :: x2, x, y, g03, g08 - -x2 = gsw_sfac*sa -x = sqrt(x2) -y = pt0*0.025_r8 - -g03 = -24715.571866078_r8 + & - y*(4420.4472249096725_r8 + & - y*(-1778.231237203896_r8 + & - y*(1160.5182516851419_r8 + & - y*(-569.531539542516_r8 + y*128.13429152494615_r8)))) - -g08 = x2*(1760.062705994408_r8 + x*(-86.1329351956084_r8 + & - x*(-137.1145018408982_r8 + y*(296.20061691375236_r8 + & - y*(-205.67709290374563_r8 + 49.9394019139016_r8*y))) + & - y*(-60.136422517125_r8 + y*10.50720794170734_r8)) + & - y*(-1351.605895580406_r8 + y*(1097.1125373015109_r8 + & - y*(-433.20648175062206_r8 + 63.905091254154904_r8*y)))) - -gsw_gibbs_pt0_pt0 = (g03 + g08)*0.000625_r8 - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_gibbs_pt0_pt0.f90 b/src/equation_of_state/TEOS10/gsw_gibbs_pt0_pt0.f90 new file mode 120000 index 0000000000..e345379f5d --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_gibbs_pt0_pt0.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_gibbs_pt0_pt0.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_mod_freezing_poly_coefficients.f90 b/src/equation_of_state/TEOS10/gsw_mod_freezing_poly_coefficients.f90 deleted file mode 100644 index d4b5052f99..0000000000 --- a/src/equation_of_state/TEOS10/gsw_mod_freezing_poly_coefficients.f90 +++ /dev/null @@ -1,63 +0,0 @@ -!========================================================================== -module gsw_mod_freezing_poly_coefficients -!========================================================================== - -use gsw_mod_kinds - -implicit none - -real (r8), parameter :: c0 = 0.017947064327968736_r8 -real (r8), parameter :: c1 = -6.076099099929818_r8 -real (r8), parameter :: c2 = 4.883198653547851_r8 -real (r8), parameter :: c3 = -11.88081601230542_r8 -real (r8), parameter :: c4 = 13.34658511480257_r8 -real (r8), parameter :: c5 = -8.722761043208607_r8 -real (r8), parameter :: c6 = 2.082038908808201_r8 -real (r8), parameter :: c7 = -7.389420998107497_r8 -real (r8), parameter :: c8 = -2.110913185058476_r8 -real (r8), parameter :: c9 = 0.2295491578006229_r8 -real (r8), parameter :: c10 = -0.9891538123307282_r8 -real (r8), parameter :: c11 = -0.08987150128406496_r8 -real (r8), parameter :: c12 = 0.3831132432071728_r8 -real (r8), parameter :: c13 = 1.054318231187074_r8 -real (r8), parameter :: c14 = 1.065556599652796_r8 -real (r8), parameter :: c15 = -0.7997496801694032_r8 -real (r8), parameter :: c16 = 0.3850133554097069_r8 -real (r8), parameter :: c17 = -2.078616693017569_r8 -real (r8), parameter :: c18 = 0.8756340772729538_r8 -real (r8), parameter :: c19 = -2.079022768390933_r8 -real (r8), parameter :: c20 = 1.596435439942262_r8 -real (r8), parameter :: c21 = 0.1338002171109174_r8 -real (r8), parameter :: c22 = 1.242891021876471_r8 - -! Note that a = 0.502500117621_r8/gsw_sso -real (r8), parameter :: a = 0.014289763856964_r8 -real (r8), parameter :: b = 0.057000649899720_r8 - -real (r8), parameter :: t0 = 0.002519_r8 -real (r8), parameter :: t1 = -5.946302841607319_r8 -real (r8), parameter :: t2 = 4.136051661346983_r8 -real (r8), parameter :: t3 = -1.115150523403847e1_r8 -real (r8), parameter :: t4 = 1.476878746184548e1_r8 -real (r8), parameter :: t5 = -1.088873263630961e1_r8 -real (r8), parameter :: t6 = 2.961018839640730_r8 -real (r8), parameter :: t7 = -7.433320943962606_r8 -real (r8), parameter :: t8 = -1.561578562479883_r8 -real (r8), parameter :: t9 = 4.073774363480365e-2_r8 -real (r8), parameter :: t10 = 1.158414435887717e-2_r8 -real (r8), parameter :: t11 = -4.122639292422863e-1_r8 -real (r8), parameter :: t12 = -1.123186915628260e-1_r8 -real (r8), parameter :: t13 = 5.715012685553502e-1_r8 -real (r8), parameter :: t14 = 2.021682115652684e-1_r8 -real (r8), parameter :: t15 = 4.140574258089767e-2_r8 -real (r8), parameter :: t16 = -6.034228641903586e-1_r8 -real (r8), parameter :: t17 = -1.205825928146808e-2_r8 -real (r8), parameter :: t18 = -2.812172968619369e-1_r8 -real (r8), parameter :: t19 = 1.877244474023750e-2_r8 -real (r8), parameter :: t20 = -1.204395563789007e-1_r8 -real (r8), parameter :: t21 = 2.349147739749606e-1_r8 -real (r8), parameter :: t22 = 2.748444541144219e-3_r8 - -end module - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_mod_freezing_poly_coefficients.f90 b/src/equation_of_state/TEOS10/gsw_mod_freezing_poly_coefficients.f90 new file mode 120000 index 0000000000..93ea8e1d2a --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_mod_freezing_poly_coefficients.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/modules/gsw_mod_freezing_poly_coefficients.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_mod_gibbs_ice_coefficients.f90 b/src/equation_of_state/TEOS10/gsw_mod_gibbs_ice_coefficients.f90 deleted file mode 100644 index e9da3baf48..0000000000 --- a/src/equation_of_state/TEOS10/gsw_mod_gibbs_ice_coefficients.f90 +++ /dev/null @@ -1,30 +0,0 @@ -!========================================================================== -module gsw_mod_gibbs_ice_coefficients -!========================================================================== - -use gsw_mod_kinds - -implicit none - -complex(r8), parameter :: t1 =( 3.68017112855051e-2_r8, 5.10878114959572e-2_r8) -complex(r8), parameter :: t2 =( 3.37315741065416e-1_r8, 3.35449415919309e-1_r8) - -complex(r8), parameter :: r1 =( 4.47050716285388e1_r8, 6.56876847463481e1_r8) -complex(r8), parameter :: r20=(-7.25974574329220e1_r8, -7.81008427112870e1_r8) -complex(r8), parameter :: r21=(-5.57107698030123e-5_r8, 4.64578634580806e-5_r8) -complex(r8), parameter :: r22=(2.34801409215913e-11_r8,-2.85651142904972e-11_r8) - -! 1./Pt, where Pt = 611.657; Experimental triple-point pressure in Pa. -real (r8), parameter :: rec_pt = 1.634903221903779e-3_r8 -real (r8), parameter :: tt = 273.16_r8 ! Triple-point temperature, kelvin (K). -real (r8), parameter :: rec_tt = 3.660858105139845e-3_r8 ! = 1/tt - -real (r8), parameter :: g00 = -6.32020233335886e5_r8 -real (r8), parameter :: g01 = 6.55022213658955e-1_r8 -real (r8), parameter :: g02 = -1.89369929326131e-8_r8 -real (r8), parameter :: g03 = 3.3974612327105304e-15_r8 -real (r8), parameter :: g04 = -5.564648690589909e-22_r8 - -end module - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_mod_gibbs_ice_coefficients.f90 b/src/equation_of_state/TEOS10/gsw_mod_gibbs_ice_coefficients.f90 new file mode 120000 index 0000000000..4c72d9079b --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_mod_gibbs_ice_coefficients.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/modules/gsw_mod_gibbs_ice_coefficients.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_mod_kinds.f90 b/src/equation_of_state/TEOS10/gsw_mod_kinds.f90 deleted file mode 100644 index 7a2a80891f..0000000000 --- a/src/equation_of_state/TEOS10/gsw_mod_kinds.f90 +++ /dev/null @@ -1,16 +0,0 @@ -!========================================================================== -module gsw_mod_kinds -!========================================================================== - -implicit none - -integer, parameter :: r4 = selected_real_kind(6,30) - -integer, parameter :: r8 = selected_real_kind(14,30) - -end module - -!-------------------------------------------------------------------------- - - - diff --git a/src/equation_of_state/TEOS10/gsw_mod_kinds.f90 b/src/equation_of_state/TEOS10/gsw_mod_kinds.f90 new file mode 120000 index 0000000000..fa0926e540 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_mod_kinds.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/modules/gsw_mod_kinds.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_mod_specvol_coefficients.f90 b/src/equation_of_state/TEOS10/gsw_mod_specvol_coefficients.f90 deleted file mode 100644 index 7bc89c7b5e..0000000000 --- a/src/equation_of_state/TEOS10/gsw_mod_specvol_coefficients.f90 +++ /dev/null @@ -1,313 +0,0 @@ -!========================================================================== -module gsw_mod_specvol_coefficients -!========================================================================== - -use gsw_mod_kinds - -implicit none - -real (r8), parameter :: a000 = -1.56497346750e-5_r8 -real (r8), parameter :: a001 = 1.85057654290e-5_r8 -real (r8), parameter :: a002 = -1.17363867310e-6_r8 -real (r8), parameter :: a003 = -3.65270065530e-7_r8 -real (r8), parameter :: a004 = 3.14540999020e-7_r8 -real (r8), parameter :: a010 = 5.55242129680e-5_r8 -real (r8), parameter :: a011 = -2.34332137060e-5_r8 -real (r8), parameter :: a012 = 4.26100574800e-6_r8 -real (r8), parameter :: a013 = 5.73918103180e-7_r8 -real (r8), parameter :: a020 = -4.95634777770e-5_r8 -real (r8), parameter :: a021 = 2.37838968519e-5_r8 -real (r8), parameter :: a022 = -1.38397620111e-6_r8 -real (r8), parameter :: a030 = 2.76445290808e-5_r8 -real (r8), parameter :: a031 = -1.36408749928e-5_r8 -real (r8), parameter :: a032 = -2.53411666056e-7_r8 -real (r8), parameter :: a040 = -4.02698077700e-6_r8 -real (r8), parameter :: a041 = 2.53683834070e-6_r8 -real (r8), parameter :: a050 = 1.23258565608e-6_r8 -real (r8), parameter :: a100 = 3.50095997640e-5_r8 -real (r8), parameter :: a101 = -9.56770881560e-6_r8 -real (r8), parameter :: a102 = -5.56991545570e-6_r8 -real (r8), parameter :: a103 = -2.72956962370e-7_r8 -real (r8), parameter :: a110 = -7.48716846880e-5_r8 -real (r8), parameter :: a111 = -4.73566167220e-7_r8 -real (r8), parameter :: a112 = 7.82747741600e-7_r8 -real (r8), parameter :: a120 = 7.24244384490e-5_r8 -real (r8), parameter :: a121 = -1.03676320965e-5_r8 -real (r8), parameter :: a122 = 2.32856664276e-8_r8 -real (r8), parameter :: a130 = -3.50383492616e-5_r8 -real (r8), parameter :: a131 = 5.18268711320e-6_r8 -real (r8), parameter :: a140 = -1.65263794500e-6_r8 -real (r8), parameter :: a200 = -4.35926785610e-5_r8 -real (r8), parameter :: a201 = 1.11008347650e-5_r8 -real (r8), parameter :: a202 = 5.46207488340e-6_r8 -real (r8), parameter :: a210 = 7.18156455200e-5_r8 -real (r8), parameter :: a211 = 5.85666925900e-6_r8 -real (r8), parameter :: a212 = -1.31462208134e-6_r8 -real (r8), parameter :: a220 = -4.30608991440e-5_r8 -real (r8), parameter :: a221 = 9.49659182340e-7_r8 -real (r8), parameter :: a230 = 1.74814722392e-5_r8 -real (r8), parameter :: a300 = 3.45324618280e-5_r8 -real (r8), parameter :: a301 = -9.84471178440e-6_r8 -real (r8), parameter :: a302 = -1.35441856270e-6_r8 -real (r8), parameter :: a310 = -3.73971683740e-5_r8 -real (r8), parameter :: a311 = -9.76522784000e-7_r8 -real (r8), parameter :: a320 = 6.85899736680e-6_r8 -real (r8), parameter :: a400 = -1.19594097880e-5_r8 -real (r8), parameter :: a401 = 2.59092252600e-6_r8 -real (r8), parameter :: a410 = 7.71906784880e-6_r8 -real (r8), parameter :: a500 = 1.38645945810e-6_r8 - -real (r8), parameter :: b000 = -3.10389819760e-4_r8 -real (r8), parameter :: b003 = 3.63101885150e-7_r8 -real (r8), parameter :: b004 = -1.11471254230e-7_r8 -real (r8), parameter :: b010 = 3.50095997640e-5_r8 -real (r8), parameter :: b013 = -2.72956962370e-7_r8 -real (r8), parameter :: b020 = -3.74358423440e-5_r8 -real (r8), parameter :: b030 = 2.41414794830e-5_r8 -real (r8), parameter :: b040 = -8.75958731540e-6_r8 -real (r8), parameter :: b050 = -3.30527589000e-7_r8 -real (r8), parameter :: b100 = 1.33856134076e-3_r8 -real (r8), parameter :: b103 = 3.34926075600e-8_r8 -real (r8), parameter :: b110 = -8.71853571220e-5_r8 -real (r8), parameter :: b120 = 7.18156455200e-5_r8 -real (r8), parameter :: b130 = -2.87072660960e-5_r8 -real (r8), parameter :: b140 = 8.74073611960e-6_r8 -real (r8), parameter :: b200 = -2.55143801811e-3_r8 -real (r8), parameter :: b210 = 1.03597385484e-4_r8 -real (r8), parameter :: b220 = -5.60957525610e-5_r8 -real (r8), parameter :: b230 = 6.85899736680e-6_r8 -real (r8), parameter :: b300 = 2.32344279772e-3_r8 -real (r8), parameter :: b310 = -4.78376391520e-5_r8 -real (r8), parameter :: b320 = 1.54381356976e-5_r8 -real (r8), parameter :: b400 = -1.05461852535e-3_r8 -real (r8), parameter :: b410 = 6.93229729050e-6_r8 -real (r8), parameter :: b500 = 1.91594743830e-4_r8 -real (r8), parameter :: b001 = 2.42624687470e-5_r8 -real (r8), parameter :: b011 = -9.56770881560e-6_r8 -real (r8), parameter :: b021 = -2.36783083610e-7_r8 -real (r8), parameter :: b031 = -3.45587736550e-6_r8 -real (r8), parameter :: b041 = 1.29567177830e-6_r8 -real (r8), parameter :: b101 = -6.95849219480e-5_r8 -real (r8), parameter :: b111 = 2.22016695300e-5_r8 -real (r8), parameter :: b121 = 5.85666925900e-6_r8 -real (r8), parameter :: b131 = 6.33106121560e-7_r8 -real (r8), parameter :: b201 = 1.12412331915e-4_r8 -real (r8), parameter :: b211 = -2.95341353532e-5_r8 -real (r8), parameter :: b221 = -1.46478417600e-6_r8 -real (r8), parameter :: b301 = -6.92888744480e-5_r8 -real (r8), parameter :: b311 = 1.03636901040e-5_r8 -real (r8), parameter :: b401 = 1.54637136265e-5_r8 -real (r8), parameter :: b002 = -5.84844329840e-7_r8 -real (r8), parameter :: b012 = -5.56991545570e-6_r8 -real (r8), parameter :: b022 = 3.91373870800e-7_r8 -real (r8), parameter :: b032 = 7.76188880920e-9_r8 -real (r8), parameter :: b102 = -9.62445031940e-6_r8 -real (r8), parameter :: b112 = 1.09241497668e-5_r8 -real (r8), parameter :: b122 = -1.31462208134e-6_r8 -real (r8), parameter :: b202 = 1.47789320994e-5_r8 -real (r8), parameter :: b212 = -4.06325568810e-6_r8 -real (r8), parameter :: b302 = -7.12478989080e-6_r8 - -real (r8), parameter :: c000 = -6.07991438090e-5_r8 -real (r8), parameter :: c001 = 1.99712338438e-5_r8 -real (r8), parameter :: c002 = -3.39280843110e-6_r8 -real (r8), parameter :: c003 = 4.21246123200e-7_r8 -real (r8), parameter :: c004 = -6.32363064300e-8_r8 -real (r8), parameter :: c005 = 1.17681023580e-8_r8 -real (r8), parameter :: c010 = 1.85057654290e-5_r8 -real (r8), parameter :: c011 = -2.34727734620e-6_r8 -real (r8), parameter :: c012 = -1.09581019659e-6_r8 -real (r8), parameter :: c013 = 1.25816399608e-6_r8 -real (r8), parameter :: c020 = -1.17166068530e-5_r8 -real (r8), parameter :: c021 = 4.26100574800e-6_r8 -real (r8), parameter :: c022 = 8.60877154770e-7_r8 -real (r8), parameter :: c030 = 7.92796561730e-6_r8 -real (r8), parameter :: c031 = -9.22650800740e-7_r8 -real (r8), parameter :: c040 = -3.41021874820e-6_r8 -real (r8), parameter :: c041 = -1.26705833028e-7_r8 -real (r8), parameter :: c050 = 5.07367668140e-7_r8 -real (r8), parameter :: c100 = 2.42624687470e-5_r8 -real (r8), parameter :: c101 = -1.16968865968e-6_r8 -real (r8), parameter :: c102 = 1.08930565545e-6_r8 -real (r8), parameter :: c103 = -4.45885016920e-7_r8 -real (r8), parameter :: c110 = -9.56770881560e-6_r8 -real (r8), parameter :: c111 = -1.11398309114e-5_r8 -real (r8), parameter :: c112 = -8.18870887110e-7_r8 -real (r8), parameter :: c120 = -2.36783083610e-7_r8 -real (r8), parameter :: c121 = 7.82747741600e-7_r8 -real (r8), parameter :: c130 = -3.45587736550e-6_r8 -real (r8), parameter :: c131 = 1.55237776184e-8_r8 -real (r8), parameter :: c140 = 1.29567177830e-6_r8 -real (r8), parameter :: c200 = -3.47924609740e-5_r8 -real (r8), parameter :: c201 = -9.62445031940e-6_r8 -real (r8), parameter :: c202 = 5.02389113400e-8_r8 -real (r8), parameter :: c210 = 1.11008347650e-5_r8 -real (r8), parameter :: c211 = 1.09241497668e-5_r8 -real (r8), parameter :: c220 = 2.92833462950e-6_r8 -real (r8), parameter :: c221 = -1.31462208134e-6_r8 -real (r8), parameter :: c230 = 3.16553060780e-7_r8 -real (r8), parameter :: c300 = 3.74707773050e-5_r8 -real (r8), parameter :: c301 = 9.85262139960e-6_r8 -real (r8), parameter :: c310 = -9.84471178440e-6_r8 -real (r8), parameter :: c311 = -2.70883712540e-6_r8 -real (r8), parameter :: c320 = -4.88261392000e-7_r8 -real (r8), parameter :: c400 = -1.73222186120e-5_r8 -real (r8), parameter :: c401 = -3.56239494540e-6_r8 -real (r8), parameter :: c410 = 2.59092252600e-6_r8 -real (r8), parameter :: c500 = 3.09274272530e-6_r8 - -real (r8), parameter :: h001 = 1.07699958620e-3_r8 -real (r8), parameter :: h002 = -3.03995719050e-5_r8 -real (r8), parameter :: h003 = 3.32853897400e-6_r8 -real (r8), parameter :: h004 = -2.82734035930e-7_r8 -real (r8), parameter :: h005 = 2.10623061600e-8_r8 -real (r8), parameter :: h006 = -2.10787688100e-9_r8 -real (r8), parameter :: h007 = 2.80192913290e-10_r8 -real (r8), parameter :: h011 = -1.56497346750e-5_r8 -real (r8), parameter :: h012 = 9.25288271450e-6_r8 -real (r8), parameter :: h013 = -3.91212891030e-7_r8 -real (r8), parameter :: h014 = -9.13175163830e-8_r8 -real (r8), parameter :: h015 = 6.29081998040e-8_r8 -real (r8), parameter :: h021 = 2.77621064840e-5_r8 -real (r8), parameter :: h022 = -5.85830342650e-6_r8 -real (r8), parameter :: h023 = 7.10167624670e-7_r8 -real (r8), parameter :: h024 = 7.17397628980e-8_r8 -real (r8), parameter :: h031 = -1.65211592590e-5_r8 -real (r8), parameter :: h032 = 3.96398280870e-6_r8 -real (r8), parameter :: h033 = -1.53775133460e-7_r8 -real (r8), parameter :: h042 = -1.70510937410e-6_r8 -real (r8), parameter :: h043 = -2.11176388380e-8_r8 -real (r8), parameter :: h041 = 6.91113227020e-6_r8 -real (r8), parameter :: h051 = -8.05396155400e-7_r8 -real (r8), parameter :: h052 = 2.53683834070e-7_r8 -real (r8), parameter :: h061 = 2.05430942680e-7_r8 -real (r8), parameter :: h101 = -3.10389819760e-4_r8 -real (r8), parameter :: h102 = 1.21312343735e-5_r8 -real (r8), parameter :: h103 = -1.94948109950e-7_r8 -real (r8), parameter :: h104 = 9.07754712880e-8_r8 -real (r8), parameter :: h105 = -2.22942508460e-8_r8 -real (r8), parameter :: h111 = 3.50095997640e-5_r8 -real (r8), parameter :: h112 = -4.78385440780e-6_r8 -real (r8), parameter :: h113 = -1.85663848520e-6_r8 -real (r8), parameter :: h114 = -6.82392405930e-8_r8 -real (r8), parameter :: h121 = -3.74358423440e-5_r8 -real (r8), parameter :: h122 = -1.18391541805e-7_r8 -real (r8), parameter :: h123 = 1.30457956930e-7_r8 -real (r8), parameter :: h131 = 2.41414794830e-5_r8 -real (r8), parameter :: h132 = -1.72793868275e-6_r8 -real (r8), parameter :: h133 = 2.58729626970e-9_r8 -real (r8), parameter :: h141 = -8.75958731540e-6_r8 -real (r8), parameter :: h142 = 6.47835889150e-7_r8 -real (r8), parameter :: h151 = -3.30527589000e-7_r8 -real (r8), parameter :: h201 = 6.69280670380e-4_r8 -real (r8), parameter :: h202 = -1.73962304870e-5_r8 -real (r8), parameter :: h203 = -1.60407505320e-6_r8 -real (r8), parameter :: h204 = 4.18657594500e-9_r8 -real (r8), parameter :: h211 = -4.35926785610e-5_r8 -real (r8), parameter :: h212 = 5.55041738250e-6_r8 -real (r8), parameter :: h213 = 1.82069162780e-6_r8 -real (r8), parameter :: h221 = 3.59078227600e-5_r8 -real (r8), parameter :: h222 = 1.46416731475e-6_r8 -real (r8), parameter :: h223 = -2.19103680220e-7_r8 -real (r8), parameter :: h231 = -1.43536330480e-5_r8 -real (r8), parameter :: h232 = 1.58276530390e-7_r8 -real (r8), parameter :: h241 = 4.37036805980e-6_r8 -real (r8), parameter :: h301 = -8.50479339370e-4_r8 -real (r8), parameter :: h302 = 1.87353886525e-5_r8 -real (r8), parameter :: h303 = 1.64210356660e-6_r8 -real (r8), parameter :: h311 = 3.45324618280e-5_r8 -real (r8), parameter :: h312 = -4.92235589220e-6_r8 -real (r8), parameter :: h313 = -4.51472854230e-7_r8 -real (r8), parameter :: h321 = -1.86985841870e-5_r8 -real (r8), parameter :: h322 = -2.44130696000e-7_r8 -real (r8), parameter :: h331 = 2.28633245560e-6_r8 -real (r8), parameter :: h401 = 5.80860699430e-4_r8 -real (r8), parameter :: h402 = -8.66110930600e-6_r8 -real (r8), parameter :: h403 = -5.93732490900e-7_r8 -real (r8), parameter :: h411 = -1.19594097880e-5_r8 -real (r8), parameter :: h421 = 3.85953392440e-6_r8 -real (r8), parameter :: h412 = 1.29546126300e-6_r8 -real (r8), parameter :: h501 = -2.10923705070e-4_r8 -real (r8), parameter :: h502 = 1.54637136265e-6_r8 -real (r8), parameter :: h511 = 1.38645945810e-6_r8 -real (r8), parameter :: h601 = 3.19324573050e-5_r8 - -real (r8), parameter :: v000 = 1.0769995862e-3_r8 -real (r8), parameter :: v001 = -6.0799143809e-5_r8 -real (r8), parameter :: v002 = 9.9856169219e-6_r8 -real (r8), parameter :: v003 = -1.1309361437e-6_r8 -real (r8), parameter :: v004 = 1.0531153080e-7_r8 -real (r8), parameter :: v005 = -1.2647261286e-8_r8 -real (r8), parameter :: v006 = 1.9613503930e-9_r8 -real (r8), parameter :: v010 = -3.1038981976e-4_r8 -real (r8), parameter :: v011 = 2.4262468747e-5_r8 -real (r8), parameter :: v012 = -5.8484432984e-7_r8 -real (r8), parameter :: v013 = 3.6310188515e-7_r8 -real (r8), parameter :: v014 = -1.1147125423e-7_r8 -real (r8), parameter :: v020 = 6.6928067038e-4_r8 -real (r8), parameter :: v021 = -3.4792460974e-5_r8 -real (r8), parameter :: v022 = -4.8122251597e-6_r8 -real (r8), parameter :: v023 = 1.6746303780e-8_r8 -real (r8), parameter :: v030 = -8.5047933937e-4_r8 -real (r8), parameter :: v031 = 3.7470777305e-5_r8 -real (r8), parameter :: v032 = 4.9263106998e-6_r8 -real (r8), parameter :: v040 = 5.8086069943e-4_r8 -real (r8), parameter :: v041 = -1.7322218612e-5_r8 -real (r8), parameter :: v042 = -1.7811974727e-6_r8 -real (r8), parameter :: v050 = -2.1092370507e-4_r8 -real (r8), parameter :: v051 = 3.0927427253e-6_r8 -real (r8), parameter :: v060 = 3.1932457305e-5_r8 -real (r8), parameter :: v100 = -1.5649734675e-5_r8 -real (r8), parameter :: v101 = 1.8505765429e-5_r8 -real (r8), parameter :: v102 = -1.1736386731e-6_r8 -real (r8), parameter :: v103 = -3.6527006553e-7_r8 -real (r8), parameter :: v104 = 3.1454099902e-7_r8 -real (r8), parameter :: v110 = 3.5009599764e-5_r8 -real (r8), parameter :: v111 = -9.5677088156e-6_r8 -real (r8), parameter :: v112 = -5.5699154557e-6_r8 -real (r8), parameter :: v113 = -2.7295696237e-7_r8 -real (r8), parameter :: v120 = -4.3592678561e-5_r8 -real (r8), parameter :: v121 = 1.1100834765e-5_r8 -real (r8), parameter :: v122 = 5.4620748834e-6_r8 -real (r8), parameter :: v130 = 3.4532461828e-5_r8 -real (r8), parameter :: v131 = -9.8447117844e-6_r8 -real (r8), parameter :: v132 = -1.3544185627e-6_r8 -real (r8), parameter :: v140 = -1.1959409788e-5_r8 -real (r8), parameter :: v141 = 2.5909225260e-6_r8 -real (r8), parameter :: v150 = 1.3864594581e-6_r8 -real (r8), parameter :: v200 = 2.7762106484e-5_r8 -real (r8), parameter :: v201 = -1.1716606853e-5_r8 -real (r8), parameter :: v202 = 2.1305028740e-6_r8 -real (r8), parameter :: v203 = 2.8695905159e-7_r8 -real (r8), parameter :: v210 = -3.7435842344e-5_r8 -real (r8), parameter :: v211 = -2.3678308361e-7_r8 -real (r8), parameter :: v212 = 3.9137387080e-7_r8 -real (r8), parameter :: v220 = 3.5907822760e-5_r8 -real (r8), parameter :: v221 = 2.9283346295e-6_r8 -real (r8), parameter :: v222 = -6.5731104067e-7_r8 -real (r8), parameter :: v230 = -1.8698584187e-5_r8 -real (r8), parameter :: v231 = -4.8826139200e-7_r8 -real (r8), parameter :: v240 = 3.8595339244e-6_r8 -real (r8), parameter :: v300 = -1.6521159259e-5_r8 -real (r8), parameter :: v301 = 7.9279656173e-6_r8 -real (r8), parameter :: v302 = -4.6132540037e-7_r8 -real (r8), parameter :: v310 = 2.4141479483e-5_r8 -real (r8), parameter :: v311 = -3.4558773655e-6_r8 -real (r8), parameter :: v312 = 7.7618888092e-9_r8 -real (r8), parameter :: v320 = -1.4353633048e-5_r8 -real (r8), parameter :: v321 = 3.1655306078e-7_r8 -real (r8), parameter :: v330 = 2.2863324556e-6_r8 -real (r8), parameter :: v400 = 6.9111322702e-6_r8 -real (r8), parameter :: v401 = -3.4102187482e-6_r8 -real (r8), parameter :: v402 = -6.3352916514e-8_r8 -real (r8), parameter :: v410 = -8.7595873154e-6_r8 -real (r8), parameter :: v411 = 1.2956717783e-6_r8 -real (r8), parameter :: v420 = 4.3703680598e-6_r8 -real (r8), parameter :: v500 = -8.0539615540e-7_r8 -real (r8), parameter :: v501 = 5.0736766814e-7_r8 -real (r8), parameter :: v510 = -3.3052758900e-7_r8 -real (r8), parameter :: v600 = 2.0543094268e-7_r8 - -end module - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_mod_specvol_coefficients.f90 b/src/equation_of_state/TEOS10/gsw_mod_specvol_coefficients.f90 new file mode 120000 index 0000000000..934f689c20 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_mod_specvol_coefficients.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/modules/gsw_mod_specvol_coefficients.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_mod_teos10_constants.f90 b/src/equation_of_state/TEOS10/gsw_mod_teos10_constants.f90 deleted file mode 100644 index e3c6afbce0..0000000000 --- a/src/equation_of_state/TEOS10/gsw_mod_teos10_constants.f90 +++ /dev/null @@ -1,71 +0,0 @@ -!========================================================================== -module gsw_mod_teos10_constants -!========================================================================== - -use gsw_mod_kinds - -implicit none - -real (r8), parameter :: db2pa = 1.0e4_r8 -real (r8), parameter :: rec_db2pa = 1.0e-4_r8 - -real (r8), parameter :: pa2db = 1.0e-4_r8 -real (r8), parameter :: rec_pa2db = 1.0e4_r8 - -real (r8), parameter :: pi = 3.141592653589793_r8 -real (r8), parameter :: deg2rad = pi/180.0_r8 -real (r8), parameter :: rad2deg = 180.0_r8/pi - -real (r8), parameter :: gamma = 2.26e-7_r8 - -! cp0 = The "specific heat" for use [ J/(kg K) ] -! with Conservative Temperature - -real (r8), parameter :: gsw_cp0 = 3991.86795711963_r8 - -! T0 = the Celcius zero point. [ K ] - -real (r8), parameter :: gsw_t0 = 273.15_r8 - -! P0 = Absolute Pressure of one standard atmosphere. [ Pa ] - -real (r8), parameter :: gsw_p0 = 101325.0_r8 - -! SSO = Standard Ocean Reference Salinity. [ g/kg ] - -real (r8), parameter :: gsw_sso = 35.16504_r8 -real (r8), parameter :: gsw_sqrtsso = 5.930011804372737_r8 - -! uPS = unit conversion factor for salinities [ g/kg ] - -real (r8), parameter :: gsw_ups = gsw_sso/35.0_r8 - -! sfac = 1/(40*gsw_ups) - -real (r8), parameter :: gsw_sfac = 0.0248826675584615_r8 - -! deltaS = 24, offset = deltaS*gsw_sfac - -real (r8), parameter :: offset = 5.971840214030754e-1_r8 - -! C3515 = Conductivity at (SP=35, t_68=15, p=0) [ mS/cm ] - -real (r8), parameter :: gsw_c3515 = 42.9140_r8 - -! SonCl = SP to Chlorinity ratio [ (g/kg)^-1 ] - -real (r8), parameter :: gsw_soncl = 1.80655_r8 - -! valence_factor = valence factor of sea salt of Reference Composition -! [ unitless ] - -real (r8), parameter :: gsw_valence_factor = 1.2452898_r8 - -! atomic_weight = mole-weighted atomic weight of sea salt of Reference -! Composition [ g/mol ] - -real (r8), parameter :: gsw_atomic_weight = 31.4038218_r8 - -end module - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_mod_teos10_constants.f90 b/src/equation_of_state/TEOS10/gsw_mod_teos10_constants.f90 new file mode 120000 index 0000000000..17dec5add5 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_mod_teos10_constants.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/modules/gsw_mod_teos10_constants.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_mod_toolbox.f90 b/src/equation_of_state/TEOS10/gsw_mod_toolbox.f90 deleted file mode 100644 index a8012e1274..0000000000 --- a/src/equation_of_state/TEOS10/gsw_mod_toolbox.f90 +++ /dev/null @@ -1,1493 +0,0 @@ -module gsw_mod_toolbox - -use gsw_mod_kinds - -implicit none - -public :: gsw_add_barrier -public :: gsw_add_mean -public :: gsw_adiabatic_lapse_rate_from_ct -public :: gsw_adiabatic_lapse_rate_ice -public :: gsw_alpha -public :: gsw_alpha_on_beta -public :: gsw_alpha_wrt_t_exact -public :: gsw_alpha_wrt_t_ice -public :: gsw_beta_const_t_exact -public :: gsw_beta -public :: gsw_cabbeling -public :: gsw_c_from_sp -public :: gsw_chem_potential_water_ice -public :: gsw_chem_potential_water_t_exact -public :: gsw_cp_ice -public :: gsw_ct_first_derivatives -public :: gsw_ct_first_derivatives_wrt_t_exact -public :: gsw_ct_freezing_exact -public :: gsw_ct_freezing -public :: gsw_ct_freezing_first_derivatives -public :: gsw_ct_freezing_first_derivatives_poly -public :: gsw_ct_freezing_poly -public :: gsw_ct_from_enthalpy_exact -public :: gsw_ct_from_enthalpy -public :: gsw_ct_from_entropy -public :: gsw_ct_from_pt -public :: gsw_ct_from_rho -public :: gsw_ct_from_t -public :: gsw_ct_maxdensity -public :: gsw_ct_second_derivatives -public :: gsw_deltasa_atlas -public :: gsw_deltasa_from_sp -public :: gsw_dilution_coefficient_t_exact -public :: gsw_dynamic_enthalpy -public :: gsw_enthalpy_ct_exact -public :: gsw_enthalpy_diff -public :: gsw_enthalpy -public :: gsw_enthalpy_first_derivatives_ct_exact -public :: gsw_enthalpy_first_derivatives -public :: gsw_enthalpy_ice -public :: gsw_enthalpy_second_derivatives_ct_exact -public :: gsw_enthalpy_second_derivatives -public :: gsw_enthalpy_sso_0 -public :: gsw_enthalpy_t_exact -public :: gsw_entropy_first_derivatives -public :: gsw_entropy_from_pt -public :: gsw_entropy_from_t -public :: gsw_entropy_ice -public :: gsw_entropy_part -public :: gsw_entropy_part_zerop -public :: gsw_entropy_second_derivatives -public :: gsw_fdelta -public :: gsw_frazil_properties -public :: gsw_frazil_properties_potential -public :: gsw_frazil_properties_potential_poly -public :: gsw_frazil_ratios_adiabatic -public :: gsw_frazil_ratios_adiabatic_poly -public :: gsw_geo_strf_dyn_height -public :: gsw_geo_strf_dyn_height_pc -public :: gsw_gibbs -public :: gsw_gibbs_ice -public :: gsw_gibbs_ice_part_t -public :: gsw_gibbs_ice_pt0 -public :: gsw_gibbs_ice_pt0_pt0 -public :: gsw_gibbs_pt0_pt0 -public :: gsw_grav -public :: gsw_helmholtz_energy_ice -public :: gsw_hill_ratio_at_sp2 -public :: gsw_ice_fraction_to_freeze_seawater -public :: gsw_internal_energy -public :: gsw_internal_energy_ice -public :: gsw_ipv_vs_fnsquared_ratio -public :: gsw_kappa_const_t_ice -public :: gsw_kappa -public :: gsw_kappa_ice -public :: gsw_kappa_t_exact -public :: gsw_latentheat_evap_ct -public :: gsw_latentheat_evap_t -public :: gsw_latentheat_melting -public :: gsw_linear_interp_sa_ct -public :: gsw_melting_ice_equilibrium_sa_ct_ratio -public :: gsw_melting_ice_equilibrium_sa_ct_ratio_poly -public :: gsw_melting_ice_into_seawater -public :: gsw_melting_ice_sa_ct_ratio -public :: gsw_melting_ice_sa_ct_ratio_poly -public :: gsw_melting_seaice_equilibrium_sa_ct_ratio -public :: gsw_melting_seaice_equilibrium_sa_ct_ratio_poly -public :: gsw_melting_seaice_into_seawater -public :: gsw_melting_seaice_sa_ct_ratio -public :: gsw_melting_seaice_sa_ct_ratio_poly -public :: gsw_nsquared -public :: gsw_pot_enthalpy_from_pt_ice -public :: gsw_pot_enthalpy_from_pt_ice_poly -public :: gsw_pot_enthalpy_ice_freezing -public :: gsw_pot_enthalpy_ice_freezing_first_derivatives -public :: gsw_pot_enthalpy_ice_freezing_first_derivatives_poly -public :: gsw_pot_enthalpy_ice_freezing_poly -public :: gsw_pot_rho_t_exact -public :: gsw_pressure_coefficient_ice -public :: gsw_pressure_freezing_ct -public :: gsw_pt0_cold_ice_poly -public :: gsw_pt0_from_t -public :: gsw_pt0_from_t_ice -public :: gsw_pt_first_derivatives -public :: gsw_pt_from_ct -public :: gsw_pt_from_entropy -public :: gsw_pt_from_pot_enthalpy_ice -public :: gsw_pt_from_pot_enthalpy_ice_poly_dh -public :: gsw_pt_from_pot_enthalpy_ice_poly -public :: gsw_pt_from_t -public :: gsw_pt_from_t_ice -public :: gsw_pt_second_derivatives -public :: gsw_rho_alpha_beta -public :: gsw_rho -public :: gsw_rho_first_derivatives -public :: gsw_rho_first_derivatives_wrt_enthalpy -public :: gsw_rho_ice -public :: gsw_rho_second_derivatives -public :: gsw_rho_second_derivatives_wrt_enthalpy -public :: gsw_rho_t_exact -public :: gsw_rr68_interp_sa_ct -public :: gsw_saar -public :: gsw_sa_freezing_estimate -public :: gsw_sa_freezing_from_ct -public :: gsw_sa_freezing_from_ct_poly -public :: gsw_sa_freezing_from_t -public :: gsw_sa_freezing_from_t_poly -public :: gsw_sa_from_rho -public :: gsw_sa_from_sp_baltic -public :: gsw_sa_from_sp -public :: gsw_sa_from_sstar -public :: gsw_sa_p_inrange -public :: gsw_seaice_fraction_to_freeze_seawater -public :: gsw_sigma0 -public :: gsw_sigma1 -public :: gsw_sigma2 -public :: gsw_sigma3 -public :: gsw_sigma4 -public :: gsw_sound_speed -public :: gsw_sound_speed_ice -public :: gsw_sound_speed_t_exact -public :: gsw_specvol_alpha_beta -public :: gsw_specvol_anom_standard -public :: gsw_specvol -public :: gsw_specvol_first_derivatives -public :: gsw_specvol_first_derivatives_wrt_enthalpy -public :: gsw_specvol_ice -public :: gsw_specvol_second_derivatives -public :: gsw_specvol_second_derivatives_wrt_enthalpy -public :: gsw_specvol_sso_0 -public :: gsw_specvol_t_exact -public :: gsw_sp_from_c -public :: gsw_sp_from_sa_baltic -public :: gsw_sp_from_sa -public :: gsw_sp_from_sk -public :: gsw_sp_from_sr -public :: gsw_sp_from_sstar -public :: gsw_spiciness0 -public :: gsw_spiciness1 -public :: gsw_spiciness2 -public :: gsw_sr_from_sp -public :: gsw_sstar_from_sa -public :: gsw_sstar_from_sp -public :: gsw_t_deriv_chem_potential_water_t_exact -public :: gsw_t_freezing_exact -public :: gsw_t_freezing -public :: gsw_t_freezing_first_derivatives -public :: gsw_t_freezing_first_derivatives_poly -public :: gsw_t_freezing_poly -public :: gsw_t_from_ct -public :: gsw_t_from_pt0_ice -public :: gsw_thermobaric -public :: gsw_turner_rsubrho -public :: gsw_util_indx -public :: gsw_util_interp1q_int -public :: gsw_util_sort_real -public :: gsw_util_xinterp1 -public :: gsw_z_from_p - -interface - - pure subroutine gsw_add_barrier (input_data, long, lat, long_grid, & - lat_grid, dlong_grid, dlat_grid, output_data) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: long, lat, long_grid, lat_grid, dlong_grid - real (r8), intent(in) :: dlat_grid - real (r8), intent(in), dimension(4) :: input_data - real (r8), intent(out), dimension(4) :: output_data - end subroutine gsw_add_barrier - - pure subroutine gsw_add_mean (data_in, data_out) - use gsw_mod_kinds - implicit none - real (r8), intent(in), dimension(4) :: data_in - real (r8), intent(out), dimension(4) :: data_out - end subroutine gsw_add_mean - - elemental function gsw_adiabatic_lapse_rate_from_ct (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_adiabatic_lapse_rate_from_ct - end function gsw_adiabatic_lapse_rate_from_ct - - elemental function gsw_adiabatic_lapse_rate_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_adiabatic_lapse_rate_ice - end function gsw_adiabatic_lapse_rate_ice - - elemental function gsw_alpha (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_alpha - end function gsw_alpha - - elemental function gsw_alpha_on_beta (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_alpha_on_beta - end function gsw_alpha_on_beta - - elemental function gsw_alpha_wrt_t_exact (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_alpha_wrt_t_exact - end function gsw_alpha_wrt_t_exact - - elemental function gsw_alpha_wrt_t_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_alpha_wrt_t_ice - end function gsw_alpha_wrt_t_ice - - elemental function gsw_beta_const_t_exact (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_beta_const_t_exact - end function gsw_beta_const_t_exact - - elemental function gsw_beta (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_beta - end function gsw_beta - - elemental function gsw_cabbeling (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_cabbeling - end function gsw_cabbeling - - elemental function gsw_c_from_sp (sp, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sp, t, p - real (r8) :: gsw_c_from_sp - end function gsw_c_from_sp - - elemental function gsw_chem_potential_water_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_chem_potential_water_ice - end function gsw_chem_potential_water_ice - - elemental function gsw_chem_potential_water_t_exact (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_chem_potential_water_t_exact - end function gsw_chem_potential_water_t_exact - - elemental function gsw_cp_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_cp_ice - end function gsw_cp_ice - - elemental subroutine gsw_ct_first_derivatives (sa, pt, ct_sa, ct_pt) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, pt - real (r8), intent(out), optional :: ct_sa, ct_pt - end subroutine gsw_ct_first_derivatives - - elemental subroutine gsw_ct_first_derivatives_wrt_t_exact (sa, t, p, & - ct_sa_wrt_t, ct_t_wrt_t, ct_p_wrt_t) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8), intent(out), optional :: ct_p_wrt_t, ct_sa_wrt_t, ct_t_wrt_t - end subroutine gsw_ct_first_derivatives_wrt_t_exact - - elemental function gsw_ct_freezing_exact (sa, p, saturation_fraction) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, saturation_fraction - real (r8) :: gsw_ct_freezing_exact - end function gsw_ct_freezing_exact - - elemental function gsw_ct_freezing (sa, p, saturation_fraction, poly) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, saturation_fraction - logical, intent(in), optional :: poly - real (r8) :: gsw_ct_freezing - end function gsw_ct_freezing - - elemental subroutine gsw_ct_freezing_first_derivatives (sa, p, & - saturation_fraction, ctfreezing_sa, ctfreezing_p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, saturation_fraction - real (r8), intent(out), optional :: ctfreezing_sa, ctfreezing_p - end subroutine gsw_ct_freezing_first_derivatives - - elemental subroutine gsw_ct_freezing_first_derivatives_poly (sa, p, & - saturation_fraction, ctfreezing_sa, ctfreezing_p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, saturation_fraction - real (r8), intent(out), optional :: ctfreezing_sa, ctfreezing_p - end subroutine gsw_ct_freezing_first_derivatives_poly - - elemental function gsw_ct_freezing_poly (sa, p, saturation_fraction) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, saturation_fraction - real (r8) :: gsw_ct_freezing_poly - end function gsw_ct_freezing_poly - - elemental function gsw_ct_from_enthalpy_exact (sa, h, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, h, p - real (r8) :: gsw_ct_from_enthalpy_exact - end function gsw_ct_from_enthalpy_exact - - elemental function gsw_ct_from_enthalpy (sa, h, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, h, p - real (r8) :: gsw_ct_from_enthalpy - end function gsw_ct_from_enthalpy - - elemental function gsw_ct_from_entropy (sa, entropy) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, entropy - real (r8) :: gsw_ct_from_entropy - end function gsw_ct_from_entropy - - elemental function gsw_ct_from_pt (sa, pt) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, pt - real (r8) :: gsw_ct_from_pt - end function gsw_ct_from_pt - - elemental subroutine gsw_ct_from_rho (rho, sa, p, ct, ct_multiple) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: rho, sa, p - real (r8), intent(out) :: ct - real (r8), intent(out), optional :: ct_multiple - end subroutine gsw_ct_from_rho - - elemental function gsw_ct_from_t (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_ct_from_t - end function gsw_ct_from_t - - elemental function gsw_ct_maxdensity (sa, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - real (r8) :: gsw_ct_maxdensity - end function gsw_ct_maxdensity - - elemental subroutine gsw_ct_second_derivatives (sa, pt, ct_sa_sa, ct_sa_pt, & - ct_pt_pt) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, pt - real (r8), intent(out), optional :: ct_sa_sa, ct_sa_pt, ct_pt_pt - end subroutine gsw_ct_second_derivatives - - elemental function gsw_deltasa_atlas (p, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: p, long, lat - real (r8) :: gsw_deltasa_atlas - end function gsw_deltasa_atlas - - elemental function gsw_deltasa_from_sp (sp, p, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sp, p, long, lat - real (r8) :: gsw_deltasa_from_sp - end function gsw_deltasa_from_sp - - elemental function gsw_dilution_coefficient_t_exact (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_dilution_coefficient_t_exact - end function gsw_dilution_coefficient_t_exact - - elemental function gsw_dynamic_enthalpy (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_dynamic_enthalpy - end function gsw_dynamic_enthalpy - - elemental function gsw_enthalpy_ct_exact (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_enthalpy_ct_exact - end function gsw_enthalpy_ct_exact - - elemental function gsw_enthalpy_diff (sa, ct, p_shallow, p_deep) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p_shallow, p_deep - real (r8) :: gsw_enthalpy_diff - end function gsw_enthalpy_diff - - elemental function gsw_enthalpy (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_enthalpy - end function gsw_enthalpy - - elemental subroutine gsw_enthalpy_first_derivatives_ct_exact (sa, ct, p, & - h_sa, h_ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8), intent(out), optional :: h_sa, h_ct - end subroutine gsw_enthalpy_first_derivatives_ct_exact - - elemental subroutine gsw_enthalpy_first_derivatives (sa, ct, p, h_sa, h_ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8), intent(out), optional :: h_sa, h_ct - end subroutine gsw_enthalpy_first_derivatives - - elemental function gsw_enthalpy_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_enthalpy_ice - end function gsw_enthalpy_ice - - elemental subroutine gsw_enthalpy_second_derivatives_ct_exact (sa, ct, p, & - h_sa_sa, h_sa_ct, h_ct_ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8), intent(out), optional :: h_sa_sa, h_sa_ct, h_ct_ct - end subroutine gsw_enthalpy_second_derivatives_ct_exact - - elemental subroutine gsw_enthalpy_second_derivatives (sa, ct, p, h_sa_sa, & - h_sa_ct, h_ct_ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8), intent(out), optional :: h_sa_sa, h_sa_ct, h_ct_ct - end subroutine gsw_enthalpy_second_derivatives - - elemental function gsw_enthalpy_sso_0 (p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: p - real (r8) :: gsw_enthalpy_sso_0 - end function gsw_enthalpy_sso_0 - - elemental function gsw_enthalpy_t_exact (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_enthalpy_t_exact - end function gsw_enthalpy_t_exact - - elemental subroutine gsw_entropy_first_derivatives (sa, ct, eta_sa, eta_ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8), intent(out), optional :: eta_sa, eta_ct - end subroutine gsw_entropy_first_derivatives - - elemental function gsw_entropy_from_pt (sa, pt) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, pt - real (r8) :: gsw_entropy_from_pt - end function gsw_entropy_from_pt - - elemental function gsw_entropy_from_t (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_entropy_from_t - end function gsw_entropy_from_t - - elemental function gsw_entropy_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_entropy_ice - end function gsw_entropy_ice - - elemental function gsw_entropy_part (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_entropy_part - end function gsw_entropy_part - - elemental function gsw_entropy_part_zerop (sa, pt0) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, pt0 - real (r8) :: gsw_entropy_part_zerop - end function gsw_entropy_part_zerop - - elemental subroutine gsw_entropy_second_derivatives (sa, ct, eta_sa_sa, & - eta_sa_ct, eta_ct_ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8), intent(out), optional :: eta_sa_sa, eta_sa_ct, eta_ct_ct - end subroutine gsw_entropy_second_derivatives - - elemental function gsw_fdelta (p, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: p, long, lat - real (r8) :: gsw_fdelta - end function gsw_fdelta - - elemental subroutine gsw_frazil_properties (sa_bulk, h_bulk, p, & - sa_final, ct_final, w_ih_final) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa_bulk, h_bulk, p - real (r8), intent(out) :: sa_final, ct_final, w_ih_final - end subroutine gsw_frazil_properties - - elemental subroutine gsw_frazil_properties_potential (sa_bulk, h_pot_bulk,& - p, sa_final, ct_final, w_ih_final) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa_bulk, h_pot_bulk, p - real (r8), intent(out) :: sa_final, ct_final, w_ih_final - end subroutine gsw_frazil_properties_potential - - elemental subroutine gsw_frazil_properties_potential_poly (sa_bulk, & - h_pot_bulk, p, sa_final, ct_final, w_ih_final) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa_bulk, h_pot_bulk, p - real (r8), intent(out) :: sa_final, ct_final, w_ih_final - end subroutine gsw_frazil_properties_potential_poly - - elemental subroutine gsw_frazil_ratios_adiabatic (sa, p, w_ih, & - dsa_dct_frazil, dsa_dp_frazil, dct_dp_frazil) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, w_ih - real (r8), intent(out) :: dsa_dct_frazil, dsa_dp_frazil, dct_dp_frazil - end subroutine gsw_frazil_ratios_adiabatic - - elemental subroutine gsw_frazil_ratios_adiabatic_poly (sa, p, w_ih, & - dsa_dct_frazil, dsa_dp_frazil, dct_dp_frazil) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, w_ih - real (r8), intent(out) :: dsa_dct_frazil, dsa_dp_frazil, dct_dp_frazil - end subroutine gsw_frazil_ratios_adiabatic_poly - - pure function gsw_geo_strf_dyn_height (sa, ct, p, p_ref) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa(:), ct(:), p(:), p_ref - real (r8) :: gsw_geo_strf_dyn_height(size(sa)) - end function gsw_geo_strf_dyn_height - - pure subroutine gsw_geo_strf_dyn_height_pc (sa, ct, delta_p, & - geo_strf_dyn_height_pc, p_mid) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa(:), ct(:), delta_p(:) - real (r8), intent(out) :: geo_strf_dyn_height_pc(:), p_mid(:) - end subroutine gsw_geo_strf_dyn_height_pc - - elemental function gsw_gibbs (ns, nt, np, sa, t, p) - use gsw_mod_kinds - implicit none - integer, intent(in) :: ns, nt, np - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_gibbs - end function gsw_gibbs - - elemental function gsw_gibbs_ice (nt, np, t, p) - use gsw_mod_kinds - implicit none - integer, intent(in) :: nt, np - real (r8), intent(in) :: t, p - real (r8) :: gsw_gibbs_ice - end function gsw_gibbs_ice - - elemental function gsw_gibbs_ice_part_t (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_gibbs_ice_part_t - end function gsw_gibbs_ice_part_t - - elemental function gsw_gibbs_ice_pt0 (pt0) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: pt0 - real (r8) :: gsw_gibbs_ice_pt0 - end function gsw_gibbs_ice_pt0 - - elemental function gsw_gibbs_ice_pt0_pt0 (pt0) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: pt0 - real (r8) :: gsw_gibbs_ice_pt0_pt0 - end function gsw_gibbs_ice_pt0_pt0 - - elemental function gsw_gibbs_pt0_pt0 (sa, pt0) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, pt0 - real (r8) :: gsw_gibbs_pt0_pt0 - end function gsw_gibbs_pt0_pt0 - - elemental function gsw_grav (lat, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: lat, p - real (r8) :: gsw_grav - end function gsw_grav - - elemental function gsw_helmholtz_energy_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_helmholtz_energy_ice - end function gsw_helmholtz_energy_ice - - elemental function gsw_hill_ratio_at_sp2 (t) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t - real (r8) :: gsw_hill_ratio_at_sp2 - end function gsw_hill_ratio_at_sp2 - - elemental subroutine gsw_ice_fraction_to_freeze_seawater (sa, ct, p, & - t_ih, sa_freeze, ct_freeze, w_ih) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p, t_ih - real (r8), intent(out) :: sa_freeze, ct_freeze, w_ih - end subroutine gsw_ice_fraction_to_freeze_seawater - - elemental function gsw_internal_energy (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_internal_energy - end function gsw_internal_energy - - elemental function gsw_internal_energy_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_internal_energy_ice - end function gsw_internal_energy_ice - - pure subroutine gsw_ipv_vs_fnsquared_ratio (sa, ct, p, p_ref, & - ipv_vs_fnsquared_ratio, p_mid) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa(:), ct(:), p(:), p_ref - real (r8), intent(out) :: ipv_vs_fnsquared_ratio(:), p_mid(:) - end subroutine gsw_ipv_vs_fnsquared_ratio - - elemental function gsw_kappa_const_t_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_kappa_const_t_ice - end function gsw_kappa_const_t_ice - - elemental function gsw_kappa (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_kappa - end function gsw_kappa - - elemental function gsw_kappa_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_kappa_ice - end function gsw_kappa_ice - - elemental function gsw_kappa_t_exact (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_kappa_t_exact - end function gsw_kappa_t_exact - - elemental function gsw_latentheat_evap_ct (sa, ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8) :: gsw_latentheat_evap_ct - end function gsw_latentheat_evap_ct - - elemental function gsw_latentheat_evap_t (sa, t) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t - real (r8) :: gsw_latentheat_evap_t - end function gsw_latentheat_evap_t - - elemental function gsw_latentheat_melting (sa, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - real (r8) :: gsw_latentheat_melting - end function gsw_latentheat_melting - - pure subroutine gsw_linear_interp_sa_ct (sa, ct, p, p_i, sa_i, ct_i) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa(:), ct(:), p(:), p_i(:) - real (r8), intent(out) :: sa_i(:), ct_i(:) - end subroutine gsw_linear_interp_sa_ct - - elemental function gsw_melting_ice_equilibrium_sa_ct_ratio (sa, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - real (r8) :: gsw_melting_ice_equilibrium_sa_ct_ratio - end function gsw_melting_ice_equilibrium_sa_ct_ratio - - elemental function gsw_melting_ice_equilibrium_sa_ct_ratio_poly (sa, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - real (r8) :: gsw_melting_ice_equilibrium_sa_ct_ratio_poly - end function gsw_melting_ice_equilibrium_sa_ct_ratio_poly - - elemental subroutine gsw_melting_ice_into_seawater (sa, ct, p, w_ih, t_ih,& - sa_final, ct_final, w_ih_final) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p, w_ih, t_ih - real (r8), intent(out) :: sa_final, ct_final, w_ih_final - end subroutine gsw_melting_ice_into_seawater - - elemental function gsw_melting_ice_sa_ct_ratio (sa, ct, p, t_ih) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p, t_ih - real (r8) :: gsw_melting_ice_sa_ct_ratio - end function gsw_melting_ice_sa_ct_ratio - - elemental function gsw_melting_ice_sa_ct_ratio_poly (sa, ct, p, t_ih) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p, t_ih - real (r8) :: gsw_melting_ice_sa_ct_ratio_poly - end function gsw_melting_ice_sa_ct_ratio_poly - - elemental function gsw_melting_seaice_equilibrium_sa_ct_ratio (sa, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - real (r8) :: gsw_melting_seaice_equilibrium_sa_ct_ratio - end function gsw_melting_seaice_equilibrium_sa_ct_ratio - - elemental function gsw_melting_seaice_equilibrium_sa_ct_ratio_poly (sa, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - real (r8) :: gsw_melting_seaice_equilibrium_sa_ct_ratio_poly - end function gsw_melting_seaice_equilibrium_sa_ct_ratio_poly - - elemental subroutine gsw_melting_seaice_into_seawater (sa, ct, p, & - w_seaice, sa_seaice, t_seaice, sa_final, ct_final) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p, w_seaice, sa_seaice, t_seaice - real (r8), intent(out) :: sa_final, ct_final - end subroutine gsw_melting_seaice_into_seawater - - elemental function gsw_melting_seaice_sa_ct_ratio (sa, ct, p, sa_seaice, & - t_seaice) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p, sa_seaice, t_seaice - real (r8) :: gsw_melting_seaice_sa_ct_ratio - end function gsw_melting_seaice_sa_ct_ratio - - elemental function gsw_melting_seaice_sa_ct_ratio_poly (sa, ct, p, & - sa_seaice, t_seaice) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p, sa_seaice, t_seaice - real (r8) :: gsw_melting_seaice_sa_ct_ratio_poly - end function gsw_melting_seaice_sa_ct_ratio_poly - - pure subroutine gsw_nsquared (sa, ct, p, lat, n2, p_mid) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa(:), ct(:), p(:), lat(:) - real (r8), intent(out) :: n2(:), p_mid(:) - end subroutine gsw_nsquared - - elemental function gsw_pot_enthalpy_from_pt_ice (pt0_ice) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: pt0_ice - real (r8) :: gsw_pot_enthalpy_from_pt_ice - end function gsw_pot_enthalpy_from_pt_ice - - elemental function gsw_pot_enthalpy_from_pt_ice_poly (pt0_ice) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: pt0_ice - real (r8) :: gsw_pot_enthalpy_from_pt_ice_poly - end function gsw_pot_enthalpy_from_pt_ice_poly - - elemental function gsw_pot_enthalpy_ice_freezing (sa, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - real (r8) :: gsw_pot_enthalpy_ice_freezing - end function gsw_pot_enthalpy_ice_freezing - - elemental subroutine gsw_pot_enthalpy_ice_freezing_first_derivatives (sa, & - p, pot_enthalpy_ice_freezing_sa, pot_enthalpy_ice_freezing_p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - real (r8), intent(out), optional :: pot_enthalpy_ice_freezing_sa - real (r8), intent(out), optional :: pot_enthalpy_ice_freezing_p - end subroutine gsw_pot_enthalpy_ice_freezing_first_derivatives - - elemental subroutine gsw_pot_enthalpy_ice_freezing_first_derivatives_poly(& - sa, p, pot_enthalpy_ice_freezing_sa, pot_enthalpy_ice_freezing_p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - real (r8), intent(out), optional :: pot_enthalpy_ice_freezing_sa - real (r8), intent(out), optional :: pot_enthalpy_ice_freezing_p - end subroutine gsw_pot_enthalpy_ice_freezing_first_derivatives_poly - - elemental function gsw_pot_enthalpy_ice_freezing_poly (sa, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - real (r8) :: gsw_pot_enthalpy_ice_freezing_poly - end function gsw_pot_enthalpy_ice_freezing_poly - - elemental function gsw_pot_rho_t_exact (sa, t, p, p_ref) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p, p_ref - real (r8) :: gsw_pot_rho_t_exact - end function gsw_pot_rho_t_exact - - elemental function gsw_pressure_coefficient_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_pressure_coefficient_ice - end function gsw_pressure_coefficient_ice - - elemental function gsw_pressure_freezing_ct (sa, ct, saturation_fraction) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, saturation_fraction - real (r8) :: gsw_pressure_freezing_ct - end function gsw_pressure_freezing_ct - - elemental function gsw_pt0_cold_ice_poly (pot_enthalpy_ice) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: pot_enthalpy_ice - real (r8) :: gsw_pt0_cold_ice_poly - end function gsw_pt0_cold_ice_poly - - elemental function gsw_pt0_from_t (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_pt0_from_t - end function gsw_pt0_from_t - - elemental function gsw_pt0_from_t_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_pt0_from_t_ice - end function gsw_pt0_from_t_ice - - elemental subroutine gsw_pt_first_derivatives (sa, ct, pt_sa, pt_ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8), intent(out), optional :: pt_sa, pt_ct - end subroutine gsw_pt_first_derivatives - - elemental function gsw_pt_from_ct (sa, ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8) :: gsw_pt_from_ct - end function gsw_pt_from_ct - - elemental function gsw_pt_from_entropy (sa, entropy) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, entropy - real (r8) :: gsw_pt_from_entropy - end function gsw_pt_from_entropy - - elemental function gsw_pt_from_pot_enthalpy_ice (pot_enthalpy_ice) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: pot_enthalpy_ice - real (r8) :: gsw_pt_from_pot_enthalpy_ice - end function gsw_pt_from_pot_enthalpy_ice - - elemental function gsw_pt_from_pot_enthalpy_ice_poly_dh (pot_enthalpy_ice) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: pot_enthalpy_ice - real (r8) :: gsw_pt_from_pot_enthalpy_ice_poly_dh - end function gsw_pt_from_pot_enthalpy_ice_poly_dh - - elemental function gsw_pt_from_pot_enthalpy_ice_poly (pot_enthalpy_ice) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: pot_enthalpy_ice - real (r8) :: gsw_pt_from_pot_enthalpy_ice_poly - end function gsw_pt_from_pot_enthalpy_ice_poly - - elemental function gsw_pt_from_t (sa, t, p, p_ref) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p, p_ref - real (r8) :: gsw_pt_from_t - end function gsw_pt_from_t - - elemental function gsw_pt_from_t_ice (t, p, p_ref) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p, p_ref - real (r8) :: gsw_pt_from_t_ice - end function gsw_pt_from_t_ice - - elemental subroutine gsw_pt_second_derivatives (sa, ct, pt_sa_sa, & - pt_sa_ct, pt_ct_ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8), intent(out), optional :: pt_sa_sa, pt_sa_ct, pt_ct_ct - end subroutine gsw_pt_second_derivatives - - elemental subroutine gsw_rho_alpha_beta (sa, ct, p, rho, alpha, beta) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8), intent(out), optional :: rho, alpha, beta - end subroutine gsw_rho_alpha_beta - - elemental function gsw_rho (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_rho - end function gsw_rho - - elemental subroutine gsw_rho_first_derivatives (sa, ct, p, drho_dsa, & - drho_dct, drho_dp) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8), intent(out), optional :: drho_dsa, drho_dct, drho_dp - end subroutine gsw_rho_first_derivatives - - elemental subroutine gsw_rho_first_derivatives_wrt_enthalpy (sa, ct, p, & - rho_sa, rho_h) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8), intent(out), optional :: rho_sa, rho_h - end subroutine gsw_rho_first_derivatives_wrt_enthalpy - - elemental function gsw_rho_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_rho_ice - end function gsw_rho_ice - - elemental subroutine gsw_rho_second_derivatives (sa, ct, p, rho_sa_sa, & - rho_sa_ct, rho_ct_ct, rho_sa_p, rho_ct_p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8), intent(out), optional :: rho_sa_sa, rho_sa_ct, rho_ct_ct - real (r8), intent(out), optional :: rho_sa_p, rho_ct_p - end subroutine gsw_rho_second_derivatives - - elemental subroutine gsw_rho_second_derivatives_wrt_enthalpy (sa, ct, p, & - rho_sa_sa, rho_sa_h, rho_h_h) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8), intent(out), optional :: rho_sa_sa, rho_sa_h, rho_h_h - end subroutine gsw_rho_second_derivatives_wrt_enthalpy - - elemental function gsw_rho_t_exact (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_rho_t_exact - end function gsw_rho_t_exact - - pure subroutine gsw_rr68_interp_sa_ct (sa, ct, p, p_i, sa_i, ct_i) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa(:), ct(:), p(:), p_i(:) - real (r8), intent(out) :: sa_i(:), ct_i(:) - end subroutine gsw_rr68_interp_sa_ct - - elemental function gsw_saar (p, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: p, long, lat - real (r8) :: gsw_saar - end function gsw_saar - - elemental function gsw_sa_freezing_estimate (p, saturation_fraction, ct, t) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: p, saturation_fraction - real (r8), intent(in), optional :: ct, t - real (r8) :: gsw_sa_freezing_estimate - end function gsw_sa_freezing_estimate - - elemental function gsw_sa_freezing_from_ct (ct, p, saturation_fraction) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: ct, p, saturation_fraction - real (r8) :: gsw_sa_freezing_from_ct - end function gsw_sa_freezing_from_ct - - elemental function gsw_sa_freezing_from_ct_poly (ct, p, saturation_fraction) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: ct, p, saturation_fraction - real (r8) :: gsw_sa_freezing_from_ct_poly - end function gsw_sa_freezing_from_ct_poly - - elemental function gsw_sa_freezing_from_t (t, p, saturation_fraction) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p, saturation_fraction - real (r8) :: gsw_sa_freezing_from_t - end function gsw_sa_freezing_from_t - - elemental function gsw_sa_freezing_from_t_poly (t, p, saturation_fraction) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p, saturation_fraction - real (r8) :: gsw_sa_freezing_from_t_poly - end function gsw_sa_freezing_from_t_poly - - elemental function gsw_sa_from_rho (rho, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: rho, ct, p - real (r8) :: gsw_sa_from_rho - end function gsw_sa_from_rho - - elemental function gsw_sa_from_sp_baltic (sp, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sp, long, lat - real (r8) :: gsw_sa_from_sp_baltic - end function gsw_sa_from_sp_baltic - - elemental function gsw_sa_from_sp (sp, p, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sp, p, long, lat - real (r8) :: gsw_sa_from_sp - end function gsw_sa_from_sp - - elemental function gsw_sa_from_sstar (sstar, p, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sstar, p, long, lat - real (r8) :: gsw_sa_from_sstar - end function gsw_sa_from_sstar - - elemental function gsw_sa_p_inrange (sa, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - logical :: gsw_sa_p_inrange - end function gsw_sa_p_inrange - - elemental subroutine gsw_seaice_fraction_to_freeze_seawater (sa, ct, p, & - sa_seaice, t_seaice, sa_freeze, ct_freeze, w_seaice) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p, sa_seaice, t_seaice - real (r8), intent(out) :: sa_freeze, ct_freeze, w_seaice - end subroutine gsw_seaice_fraction_to_freeze_seawater - - elemental function gsw_sigma0 (sa, ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8) :: gsw_sigma0 - end function gsw_sigma0 - - elemental function gsw_sigma1 (sa, ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8) :: gsw_sigma1 - end function gsw_sigma1 - - elemental function gsw_sigma2 (sa, ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8) :: gsw_sigma2 - end function gsw_sigma2 - - elemental function gsw_sigma3 (sa, ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8) :: gsw_sigma3 - end function gsw_sigma3 - - elemental function gsw_sigma4 (sa, ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8) :: gsw_sigma4 - end function gsw_sigma4 - - elemental function gsw_sound_speed (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_sound_speed - end function gsw_sound_speed - - elemental function gsw_sound_speed_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_sound_speed_ice - end function gsw_sound_speed_ice - - elemental function gsw_sound_speed_t_exact (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_sound_speed_t_exact - end function gsw_sound_speed_t_exact - - elemental subroutine gsw_specvol_alpha_beta (sa, ct, p, specvol, alpha, & - beta) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8), intent(out), optional :: specvol, alpha, beta - end subroutine gsw_specvol_alpha_beta - - elemental function gsw_specvol_anom_standard (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_specvol_anom_standard - end function gsw_specvol_anom_standard - - elemental function gsw_specvol (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_specvol - end function gsw_specvol - - elemental subroutine gsw_specvol_first_derivatives (sa, ct, p, v_sa, v_ct, & - v_p, iflag) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - integer, intent(in), optional :: iflag - real (r8), intent(out), optional :: v_sa, v_ct, v_p - end subroutine gsw_specvol_first_derivatives - - elemental subroutine gsw_specvol_first_derivatives_wrt_enthalpy (sa, ct, & - p, v_sa, v_h, iflag) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - integer, intent(in), optional :: iflag - real (r8), intent(out), optional :: v_sa, v_h - end subroutine gsw_specvol_first_derivatives_wrt_enthalpy - - elemental function gsw_specvol_ice (t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: t, p - real (r8) :: gsw_specvol_ice - end function gsw_specvol_ice - - elemental subroutine gsw_specvol_second_derivatives (sa, ct, p, v_sa_sa, & - v_sa_ct, v_ct_ct, v_sa_p, v_ct_p, iflag) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - integer, intent(in), optional :: iflag - real (r8), intent(out), optional :: v_sa_sa, v_sa_ct, v_ct_ct, v_sa_p, v_ct_p - end subroutine gsw_specvol_second_derivatives - - elemental subroutine gsw_specvol_second_derivatives_wrt_enthalpy (sa, ct, & - p, v_sa_sa, v_sa_h, v_h_h, iflag) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - integer, intent(in), optional :: iflag - real (r8), intent(out), optional :: v_sa_sa, v_sa_h, v_h_h - end subroutine gsw_specvol_second_derivatives_wrt_enthalpy - - elemental function gsw_specvol_sso_0 (p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: p - real (r8) :: gsw_specvol_sso_0 - end function gsw_specvol_sso_0 - - elemental function gsw_specvol_t_exact (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_specvol_t_exact - end function gsw_specvol_t_exact - - elemental function gsw_sp_from_c (c, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: c, t, p - real (r8) :: gsw_sp_from_c - end function gsw_sp_from_c - - elemental function gsw_sp_from_sa_baltic (sa, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, long, lat - real (r8) :: gsw_sp_from_sa_baltic - end function gsw_sp_from_sa_baltic - - elemental function gsw_sp_from_sa (sa, p, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, long, lat - real (r8) :: gsw_sp_from_sa - end function gsw_sp_from_sa - - elemental function gsw_sp_from_sk (sk) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sk - real (r8) :: gsw_sp_from_sk - end function gsw_sp_from_sk - - elemental function gsw_sp_from_sr (sr) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sr - real (r8) :: gsw_sp_from_sr - end function gsw_sp_from_sr - - elemental function gsw_sp_from_sstar (sstar, p, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sstar, p, long, lat - real (r8) :: gsw_sp_from_sstar - end function gsw_sp_from_sstar - - elemental function gsw_spiciness0 (sa, ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8) :: gsw_spiciness0 - end function gsw_spiciness0 - - elemental function gsw_spiciness1 (sa, ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8) :: gsw_spiciness1 - end function gsw_spiciness1 - - elemental function gsw_spiciness2 (sa, ct) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct - real (r8) :: gsw_spiciness2 - end function gsw_spiciness2 - - elemental function gsw_sr_from_sp (sp) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sp - real (r8) :: gsw_sr_from_sp - end function gsw_sr_from_sp - - elemental function gsw_sstar_from_sa (sa, p, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, long, lat - real (r8) :: gsw_sstar_from_sa - end function gsw_sstar_from_sa - - elemental function gsw_sstar_from_sp (sp, p, long, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sp, p, long, lat - real (r8) :: gsw_sstar_from_sp - end function gsw_sstar_from_sp - - elemental function gsw_t_deriv_chem_potential_water_t_exact (sa, t, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, t, p - real (r8) :: gsw_t_deriv_chem_potential_water_t_exact - end function gsw_t_deriv_chem_potential_water_t_exact - - elemental function gsw_t_freezing_exact (sa, p, saturation_fraction) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, saturation_fraction - real (r8) :: gsw_t_freezing_exact - end function gsw_t_freezing_exact - - elemental function gsw_t_freezing (sa, p, saturation_fraction, poly) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, saturation_fraction - logical, intent(in), optional :: poly - real (r8) :: gsw_t_freezing - end function gsw_t_freezing - - elemental subroutine gsw_t_freezing_first_derivatives (sa, p, & - saturation_fraction, tfreezing_sa, tfreezing_p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, saturation_fraction - real (r8), intent(out), optional :: tfreezing_sa, tfreezing_p - end subroutine gsw_t_freezing_first_derivatives - - elemental subroutine gsw_t_freezing_first_derivatives_poly (sa, p, & - saturation_fraction, tfreezing_sa, tfreezing_p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p, saturation_fraction - real (r8), intent(out), optional :: tfreezing_sa, tfreezing_p - end subroutine gsw_t_freezing_first_derivatives_poly - - elemental function gsw_t_freezing_poly (sa, p, saturation_fraction, polynomial) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, p - real (r8), intent(in), optional :: saturation_fraction - logical, intent(in), optional :: polynomial - real (r8) :: gsw_t_freezing_poly - end function gsw_t_freezing_poly - - elemental function gsw_t_from_ct (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_t_from_ct - end function gsw_t_from_ct - - elemental function gsw_t_from_pt0_ice (pt0_ice, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: pt0_ice, p - real (r8) :: gsw_t_from_pt0_ice - end function gsw_t_from_pt0_ice - - elemental function gsw_thermobaric (sa, ct, p) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa, ct, p - real (r8) :: gsw_thermobaric - end function gsw_thermobaric - - pure subroutine gsw_turner_rsubrho (sa, ct, p, tu, rsubrho, p_mid) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: sa(:), ct(:), p(:) - real (r8), intent(out) :: tu(:), rsubrho(:), p_mid(:) - end subroutine gsw_turner_rsubrho - - pure subroutine gsw_util_indx (x, n, z, k) - use gsw_mod_kinds - integer, intent(in) :: n - integer, intent(out) :: k - real (r8), intent(in), dimension(n) :: x - real (r8), intent(in) :: z - end subroutine gsw_util_indx - - pure function gsw_util_interp1q_int (x, iy, x_i) result(y_i) - use gsw_mod_kinds - implicit none - integer, intent(in) :: iy(:) - real (r8), intent(in) :: x(:), x_i(:) - real (r8) :: y_i(size(x_i)) - end function gsw_util_interp1q_int - - pure function gsw_util_sort_real (rarray) result(iarray) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: rarray(:) ! Values to be sorted - integer :: iarray(size(rarray)) ! Sorted ids - end function gsw_util_sort_real - - pure function gsw_util_xinterp1 (x, y, n, x0) - use gsw_mod_kinds - implicit none - integer, intent(in) :: n - real (r8), intent(in) :: x0 - real (r8), dimension(n), intent(in) :: x, y - real (r8) :: gsw_util_xinterp1 - end function gsw_util_xinterp1 - - elemental function gsw_z_from_p (p, lat) - use gsw_mod_kinds - implicit none - real (r8), intent(in) :: p, lat - real (r8) :: gsw_z_from_p - end function gsw_z_from_p - -end interface - -end module gsw_mod_toolbox diff --git a/src/equation_of_state/TEOS10/gsw_mod_toolbox.f90 b/src/equation_of_state/TEOS10/gsw_mod_toolbox.f90 new file mode 120000 index 0000000000..f2f4761ec4 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_mod_toolbox.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/modules/gsw_mod_toolbox.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_pt0_from_t.f90 b/src/equation_of_state/TEOS10/gsw_pt0_from_t.f90 deleted file mode 100644 index 63c2c83292..0000000000 --- a/src/equation_of_state/TEOS10/gsw_pt0_from_t.f90 +++ /dev/null @@ -1,59 +0,0 @@ -!========================================================================== -elemental function gsw_pt0_from_t (sa, t, p) -!========================================================================== -! -! Calculates potential temperature with reference pressure, p_ref = 0 dbar. -! -! sa : Absolute Salinity [g/kg] -! t : in-situ temperature [deg C] -! p : sea pressure [dbar] -! -! gsw_pt0_from_t : potential temperature, p_ref = 0 [deg C] -!-------------------------------------------------------------------------- - -use gsw_mod_toolbox, only : gsw_entropy_part, gsw_entropy_part_zerop -use gsw_mod_toolbox, only : gsw_gibbs_pt0_pt0 - -use gsw_mod_teos10_constants, only : gsw_cp0, gsw_sso, gsw_t0, gsw_ups - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, t, p - -real (r8) :: gsw_pt0_from_t - -integer n, no_iter -real (r8) :: s1, true_entropy_part, pt0m -real (r8) :: pt0, pt0_old, de_dt, dentropy, dentropy_dt - -s1 = sa/gsw_ups - -pt0 = t + p*( 8.65483913395442e-6_r8 - & - s1 * 1.41636299744881e-6_r8 - & - p * 7.38286467135737e-9_r8 + & - t *(-8.38241357039698e-6_r8 + & - s1 * 2.83933368585534e-8_r8 + & - t * 1.77803965218656e-8_r8 + & - p * 1.71155619208233e-10_r8)) - -dentropy_dt = gsw_cp0/((gsw_t0 + pt0)*(1.0_r8 - 0.05_r8*(1.0_r8 - sa/gsw_sso))) - -true_entropy_part = gsw_entropy_part(sa,t,p) - -do no_iter = 1, 2 - pt0_old = pt0 - dentropy = gsw_entropy_part_zerop(sa,pt0_old) - true_entropy_part - pt0 = pt0_old - dentropy/dentropy_dt - pt0m = 0.5_r8*(pt0 + pt0_old) - dentropy_dt = -gsw_gibbs_pt0_pt0(sa,pt0m) - pt0 = pt0_old - dentropy/dentropy_dt -end do - -gsw_pt0_from_t = pt0 - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_pt0_from_t.f90 b/src/equation_of_state/TEOS10/gsw_pt0_from_t.f90 new file mode 120000 index 0000000000..79cf5b0d65 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_pt0_from_t.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_pt0_from_t.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_pt_from_ct.f90 b/src/equation_of_state/TEOS10/gsw_pt_from_ct.f90 deleted file mode 100644 index b856b923c8..0000000000 --- a/src/equation_of_state/TEOS10/gsw_pt_from_ct.f90 +++ /dev/null @@ -1,72 +0,0 @@ -!========================================================================== -elemental function gsw_pt_from_ct (sa, ct) -!========================================================================== -! -! potential temperature of seawater from conservative temperature -! -! sa : Absolute Salinity [g/kg] -! ct : Conservative Temperature [deg C] -! p : sea pressure [dbar] -! -! gsw_pt_from_ct : potential temperature with [deg C] -! reference pressure of 0 dbar -!-------------------------------------------------------------------------- - -use gsw_mod_toolbox, only : gsw_ct_from_pt, gsw_gibbs_pt0_pt0 - -use gsw_mod_teos10_constants, only : gsw_cp0, gsw_ups, gsw_t0 - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, ct - -real (r8) :: gsw_pt_from_ct - -real (r8) :: a5ct, b3ct, ct_factor, pt_num, pt_recden, ct_diff -real (r8) :: ct0, pt, pt_old, ptm, dct, dpt_dct, s1 - -real (r8), parameter :: a0 = -1.446013646344788e-2_r8 -real (r8), parameter :: a1 = -3.305308995852924e-3_r8 -real (r8), parameter :: a2 = 1.062415929128982e-4_r8 -real (r8), parameter :: a3 = 9.477566673794488e-1_r8 -real (r8), parameter :: a4 = 2.166591947736613e-3_r8 -real (r8), parameter :: a5 = 3.828842955039902e-3_r8 - -real (r8), parameter :: b0 = 1.0_r8 -real (r8), parameter :: b1 = 6.506097115635800e-4_r8 -real (r8), parameter :: b2 = 3.830289486850898e-3_r8 -real (r8), parameter :: b3 = 1.247811760368034e-6_r8 - -s1 = sa/gsw_ups - -a5ct = a5*ct -b3ct = b3*ct - -ct_factor = (a3 + a4*s1 + a5ct) -pt_num = a0 + s1*(a1 + a2*s1) + ct*ct_factor -pt_recden = 1.0_r8/(b0 + b1*s1 + ct*(b2 + b3ct)) -pt = pt_num*pt_recden - -dpt_dct = (ct_factor + a5ct - (b2 + b3ct + b3ct)*pt)*pt_recden - -! Start the 1.5 iterations through the modified Newton-Rapshon iterative, -! method, which is also known as the Newton-McDougall method. - -ct_diff = gsw_ct_from_pt(sa,pt) - ct -pt_old = pt -pt = pt_old - ct_diff*dpt_dct -ptm = 0.5_r8*(pt + pt_old) - -dpt_dct = -gsw_cp0/((ptm + gsw_t0)*gsw_gibbs_pt0_pt0(sa,ptm)) - -pt = pt_old - ct_diff*dpt_dct -ct_diff = gsw_ct_from_pt(sa,pt) - ct -pt_old = pt -gsw_pt_from_ct = pt_old - ct_diff*dpt_dct - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_pt_from_ct.f90 b/src/equation_of_state/TEOS10/gsw_pt_from_ct.f90 new file mode 120000 index 0000000000..cd794a1316 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_pt_from_ct.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_pt_from_ct.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_pt_from_t.f90 b/src/equation_of_state/TEOS10/gsw_pt_from_t.f90 deleted file mode 100644 index 46dc766fb6..0000000000 --- a/src/equation_of_state/TEOS10/gsw_pt_from_t.f90 +++ /dev/null @@ -1,61 +0,0 @@ -!========================================================================== -elemental function gsw_pt_from_t (sa, t, p, p_ref) -!========================================================================== -! -! Calculates potential temperature of seawater from in-situ temperature -! -! sa : Absolute Salinity [g/kg] -! t : in-situ temperature [deg C] -! p : sea pressure [dbar] -! p_ref : reference sea pressure [dbar] -! -! gsw_pt_from_t : potential temperature [deg C] -!-------------------------------------------------------------------------- - -use gsw_mod_toolbox, only : gsw_entropy_part, gsw_gibbs - -use gsw_mod_teos10_constants, only : gsw_cp0, gsw_sso, gsw_t0, gsw_ups - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, t, p, p_ref - -real (r8) :: gsw_pt_from_t - -integer n, no_iter -real (r8) :: s1, pt, pt_old, de_dt, dentropy, dentropy_dt -real (r8) :: true_entropy_part, ptm - -integer, parameter :: n0=0, n2=2 - -s1 = sa/gsw_ups - -pt = t + (p-p_ref)*( 8.65483913395442e-6_r8 - & - s1 * 1.41636299744881e-6_r8 - & - (p+p_ref)* 7.38286467135737e-9_r8 + & - t *(-8.38241357039698e-6_r8 + & - s1 * 2.83933368585534e-8_r8 + & - t * 1.77803965218656e-8_r8 + & - (p+p_ref)* 1.71155619208233e-10_r8)) - -dentropy_dt = gsw_cp0/((gsw_t0 + pt)*(1.0_r8 - 0.05_r8*(1.0_r8 - sa/gsw_sso))) - -true_entropy_part = gsw_entropy_part(sa,t,p) - -do no_iter = 1, 2 - pt_old = pt - dentropy = gsw_entropy_part(sa,pt_old,p_ref) - true_entropy_part - pt = pt_old - dentropy/dentropy_dt - ptm = 0.5_r8*(pt + pt_old) - dentropy_dt = -gsw_gibbs(n0,n2,n0,sa,ptm,p_ref) - pt = pt_old - dentropy/dentropy_dt -end do - -gsw_pt_from_t = pt - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_pt_from_t.f90 b/src/equation_of_state/TEOS10/gsw_pt_from_t.f90 new file mode 120000 index 0000000000..37fa5f104f --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_pt_from_t.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_pt_from_t.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_rho.f90 b/src/equation_of_state/TEOS10/gsw_rho.f90 deleted file mode 100644 index 3daa65746e..0000000000 --- a/src/equation_of_state/TEOS10/gsw_rho.f90 +++ /dev/null @@ -1,36 +0,0 @@ -!========================================================================== -elemental function gsw_rho (sa, ct, p) -!========================================================================== -! -! Calculates in-situ density from Absolute Salinity and Conservative -! Temperature, using the computationally-efficient expression for -! specific volume in terms of SA, CT and p (Roquet et al., 2014). -! -! Note that potential density with respect to reference pressure, pr, is -! obtained by calling this function with the pressure argument being pr -! (i.e. "gsw_rho(SA,CT,pr)"). -! -! SA = Absolute Salinity [ g/kg ] -! CT = Conservative Temperature (ITS-90) [ deg C ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! -! rho = in-situ density [ kg/m ] -!-------------------------------------------------------------------------- - -use gsw_mod_toolbox, only : gsw_specvol - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, ct, p - -real (r8) :: gsw_rho - -gsw_rho = 1.0_r8/gsw_specvol(sa,ct,p) - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_rho.f90 b/src/equation_of_state/TEOS10/gsw_rho.f90 new file mode 120000 index 0000000000..22eea6219a --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_rho.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_rho.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_rho_first_derivatives.f90 b/src/equation_of_state/TEOS10/gsw_rho_first_derivatives.f90 deleted file mode 100644 index b4ee696a1d..0000000000 --- a/src/equation_of_state/TEOS10/gsw_rho_first_derivatives.f90 +++ /dev/null @@ -1,110 +0,0 @@ -!========================================================================== -elemental subroutine gsw_rho_first_derivatives (sa, ct, p, drho_dsa, & - drho_dct, drho_dp) -!========================================================================== -! -! Calculates the three (3) partial derivatives of in-situ density with -! respect to Absolute Salinity, Conservative Temperature and pressure. -! Note that the pressure derivative is done with respect to pressure in -! Pa, not dbar. This function uses the computationally-efficient expression -! for specific volume in terms of SA, CT and p (Roquet et al., 2014). -! -! SA = Absolute Salinity [ g/kg ] -! CT = Conservative Temperature (ITS-90) [ deg C ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! -! drho_dSA = partial derivatives of density [ kg^2/(g m^3) ] -! with respect to Absolute Salinity -! drho_dCT = partial derivatives of density [ kg/(K m^3) ] -! with respect to Conservative Temperature -! drho_dP = partial derivatives of density [ kg/(Pa m^3) ] -! with respect to pressure in Pa -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : pa2db, gsw_sfac, offset - -use gsw_mod_specvol_coefficients - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, ct, p -real (r8), intent(out), optional :: drho_dsa, drho_dct, drho_dp - -real (r8) :: rho2, v_ct, v_p, v_sa, xs, ys, z, v - -xs = sqrt(gsw_sfac*sa + offset) -ys = ct*0.025_r8 -z = p*1e-4_r8 - -v = v000 + xs*(v010 + xs*(v020 + xs*(v030 + xs*(v040 + xs*(v050 & - + v060*xs))))) + ys*(v100 + xs*(v110 + xs*(v120 + xs*(v130 + xs*(v140 & - + v150*xs)))) + ys*(v200 + xs*(v210 + xs*(v220 + xs*(v230 + v240*xs))) & - + ys*(v300 + xs*(v310 + xs*(v320 + v330*xs)) + ys*(v400 + xs*(v410 & - + v420*xs) + ys*(v500 + v510*xs + v600*ys))))) + z*(v001 + xs*(v011 & - + xs*(v021 + xs*(v031 + xs*(v041 + v051*xs)))) + ys*(v101 + xs*(v111 & - + xs*(v121 + xs*(v131 + v141*xs))) + ys*(v201 + xs*(v211 + xs*(v221 & - + v231*xs)) + ys*(v301 + xs*(v311 + v321*xs) + ys*(v401 + v411*xs & - + v501*ys)))) + z*(v002 + xs*(v012 + xs*(v022 + xs*(v032 + v042*xs))) & - + ys*(v102 + xs*(v112 + xs*(v122 + v132*xs)) + ys*(v202 + xs*(v212 & - + v222*xs) + ys*(v302 + v312*xs + v402*ys))) + z*(v003 + xs*(v013 & - + v023*xs) + ys*(v103 + v113*xs + v203*ys) + z*(v004 + v014*xs + v104*ys & - + z*(v005 + v006*z))))) - -rho2 = (1.0_r8/v)**2 - -if (present(drho_dsa)) then - - v_sa = b000 + xs*(b100 + xs*(b200 + xs*(b300 + xs*(b400 + b500*xs)))) & - + ys*(b010 + xs*(b110 + xs*(b210 + xs*(b310 + b410*xs))) & - + ys*(b020 + xs*(b120 + xs*(b220 + b320*xs)) + ys*(b030 & - + xs*(b130 + b230*xs) + ys*(b040 + b140*xs + b050*ys)))) & - + z*(b001 + xs*(b101 + xs*(b201 + xs*(b301 + b401*xs))) & - + ys*(b011 + xs*(b111 + xs*(b211 + b311*xs)) + ys*(b021 & - + xs*(b121 + b221*xs) + ys*(b031 + b131*xs + b041*ys))) & - + z*(b002 + xs*(b102 + xs*(b202 + b302*xs))+ ys*(b012 & - + xs*(b112 + b212*xs) + ys*(b022 + b122*xs + b032*ys)) & - + z*(b003 + b103*xs + b013*ys + b004*z))) - - drho_dsa = -rho2*0.5_r8*gsw_sfac*v_sa/xs - -end if - -if (present(drho_dct)) then - - v_ct = a000 + xs*(a100 + xs*(a200 + xs*(a300 + xs*(a400 + a500*xs)))) & - + ys*(a010 + xs*(a110 + xs*(a210 + xs*(a310 + a410*xs))) & - + ys*(a020 + xs*(a120 + xs*(a220 + a320*xs)) + ys*(a030 & - + xs*(a130 + a230*xs) + ys*(a040 + a140*xs + a050*ys )))) & - + z*(a001 + xs*(a101 + xs*(a201 + xs*(a301 + a401*xs))) & - + ys*(a011 + xs*(a111 + xs*(a211 + a311*xs)) + ys*(a021 & - + xs*(a121 + a221*xs) + ys*(a031 + a131*xs + a041*ys))) & - + z*(a002 + xs*(a102 + xs*(a202 + a302*xs)) + ys*(a012 & - + xs*(a112 + a212*xs) + ys*(a022 + a122*xs + a032*ys)) & - + z*(a003 + a103*xs + a013*ys + a004*z))) - - drho_dct = -rho2*0.025_r8*v_ct - -end if - -if (present(drho_dp)) then - - v_p = c000 + xs*(c100 + xs*(c200 + xs*(c300 + xs*(c400 + c500*xs)))) & - + ys*(c010 + xs*(c110 + xs*(c210 + xs*(c310 + c410*xs))) + ys*(c020 & - + xs*(c120 + xs*(c220 + c320*xs)) + ys*(c030 + xs*(c130 + c230*xs) & - + ys*(c040 + c140*xs + c050*ys)))) + z*(c001 + xs*(c101 + xs*(c201 & - + xs*(c301 + c401*xs))) + ys*(c011 + xs*(c111 + xs*(c211 + c311*xs)) & - + ys*(c021 + xs*(c121 + c221*xs) + ys*(c031 + c131*xs + c041*ys))) & - + z*(c002 + xs*(c102 + c202*xs) + ys*(c012 + c112*xs + c022*ys) & - + z*(c003 + c103*xs + c013*ys + z*(c004 + c005*z)))) - - drho_dp = -rho2*1e-4_r8*pa2db*v_p - -end if - -return -end subroutine - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_rho_first_derivatives.f90 b/src/equation_of_state/TEOS10/gsw_rho_first_derivatives.f90 new file mode 120000 index 0000000000..3a8ba38824 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_rho_first_derivatives.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_rho_first_derivatives.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_rho_second_derivatives.f90 b/src/equation_of_state/TEOS10/gsw_rho_second_derivatives.f90 deleted file mode 100644 index fdf75e7a0a..0000000000 --- a/src/equation_of_state/TEOS10/gsw_rho_second_derivatives.f90 +++ /dev/null @@ -1,78 +0,0 @@ -!========================================================================== -elemental subroutine gsw_rho_second_derivatives (sa, ct, p, rho_sa_sa, & - rho_sa_ct, rho_ct_ct, rho_sa_p, rho_ct_p) -!========================================================================== -! -! Calculates five second-order derivatives of rho. Note that this function -! uses the using the computationally-efficient expression for specific -! volume (Roquet et al., 2014). -! -! SA = Absolute Salinity [ g/kg ] -! CT = Conservative Temperature (ITS-90) [ deg C ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! -! rho_SA_SA = The second-order derivative of rho with respect to -! Absolute Salinity at constant CT & p. [ J/(kg (g/kg)^2) ] -! rho_SA_CT = The second-order derivative of rho with respect to -! SA and CT at constant p. [ J/(kg K(g/kg)) ] -! rho_CT_CT = The second-order derivative of rho with respect to CT at -! constant SA & p -! rho_SA_P = The second-order derivative with respect to SA & P at -! constant CT. -! rho_CT_P = The second-order derivative with respect to CT & P at -! constant SA. -!-------------------------------------------------------------------------- - -use gsw_mod_toolbox, only : gsw_specvol, gsw_specvol_first_derivatives -use gsw_mod_toolbox, only : gsw_specvol_second_derivatives - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, ct, p -real (r8), intent(out), optional :: rho_sa_sa, rho_sa_ct, rho_ct_ct -real (r8), intent(out), optional :: rho_sa_p, rho_ct_p - -integer :: iflag1, iflag2 -real (r8) :: rec_v, rec_v2, rec_v3, v_ct, v_ct_ct, v_ct_p, v_p, v_sa, v_sa_ct -real (r8) :: v_sa_p, v_sa_sa - -iflag1 = 0 -if (present(rho_sa_sa) .or. present(rho_sa_ct) & - .or. present(rho_sa_p)) iflag1 = ibset(iflag1,1) -if (present(rho_sa_ct) .or. present(rho_ct_ct) & - .or. present(rho_ct_p)) iflag1 = ibset(iflag1,2) -if (present(rho_sa_p) .or. present(rho_ct_p)) iflag1 = ibset(iflag1,3) - -call gsw_specvol_first_derivatives(sa,ct,p,v_sa,v_ct,v_p,iflag=iflag1) - -iflag2 = 0 -if (present(rho_sa_sa)) iflag2 = ibset(iflag2,1) -if (present(rho_sa_ct)) iflag2 = ibset(iflag2,2) -if (present(rho_ct_ct)) iflag2 = ibset(iflag2,3) -if (present(rho_sa_p)) iflag2 = ibset(iflag2,4) -if (present(rho_ct_p)) iflag2 = ibset(iflag2,5) - -call gsw_specvol_second_derivatives(sa,ct,p,v_sa_sa,v_sa_ct,v_ct_ct, & - v_sa_p,v_ct_p,iflag=iflag2) - -rec_v = 1.0_r8/gsw_specvol(sa,ct,p) -rec_v2 = rec_v**2 -rec_v3 = rec_v2*rec_v - -if (present(rho_sa_sa)) rho_sa_sa = -v_sa_sa*rec_v2 + 2.0_r8*v_sa*v_sa*rec_v3 - -if (present(rho_sa_ct)) rho_sa_ct = -v_sa_ct*rec_v2 + 2.0_r8*v_sa*v_ct*rec_v3 - -if (present(rho_ct_ct)) rho_ct_ct = -v_ct_ct*rec_v2 + 2.0_r8*v_ct*v_ct*rec_v3 - -if (present(rho_sa_p)) rho_sa_p = -v_sa_p*rec_v2 + 2.0_r8*v_sa*v_p*rec_v3 - -if (present(rho_ct_p)) rho_ct_p = -v_ct_p*rec_v2 + 2.0_r8*v_ct*v_p*rec_v3 - -return -end subroutine - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_rho_second_derivatives.f90 b/src/equation_of_state/TEOS10/gsw_rho_second_derivatives.f90 new file mode 120000 index 0000000000..8b38e0f56f --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_rho_second_derivatives.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_rho_second_derivatives.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_sp_from_sr.f90 b/src/equation_of_state/TEOS10/gsw_sp_from_sr.f90 deleted file mode 100644 index c01377546c..0000000000 --- a/src/equation_of_state/TEOS10/gsw_sp_from_sr.f90 +++ /dev/null @@ -1,30 +0,0 @@ -!========================================================================== -elemental function gsw_sp_from_sr (sr) -!========================================================================== -! -! Calculates Practical Salinity, sp, from Reference Salinity, sr. -! -! sr : Reference Salinity [g/kg] -! -! gsw_sp_from_sr : Practical Salinity [unitless] -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_ups - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sr - -real (r8) :: gsw_sp_from_sr - -gsw_sp_from_sr = sr/gsw_ups - -return -end function - -!-------------------------------------------------------------------------- - - - diff --git a/src/equation_of_state/TEOS10/gsw_sp_from_sr.f90 b/src/equation_of_state/TEOS10/gsw_sp_from_sr.f90 new file mode 120000 index 0000000000..d8cd41f4bf --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_sp_from_sr.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_sp_from_sr.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_specvol.f90 b/src/equation_of_state/TEOS10/gsw_specvol.f90 deleted file mode 100644 index 00cfaab125..0000000000 --- a/src/equation_of_state/TEOS10/gsw_specvol.f90 +++ /dev/null @@ -1,52 +0,0 @@ -!========================================================================== -elemental function gsw_specvol (sa, ct, p) -!========================================================================== -! -! Calculates specific volume from Absolute Salinity, Conservative -! Temperature and pressure, using the computationally-efficient -! polynomial expression for specific volume (Roquet et al., 2014). -! -! SA = Absolute Salinity [ g/kg ] -! CT = Conservative Temperature (ITS-90) [ deg C ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! -! specvol = specific volume [ m^3/kg ] -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sfac, offset - -use gsw_mod_specvol_coefficients - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, ct, p - -real (r8) :: gsw_specvol - -real (r8) :: xs, ys, z - -xs = sqrt(gsw_sfac*sa + offset) -ys = ct*0.025_r8 -z = p*1e-4_r8 - -gsw_specvol = v000 + xs*(v010 + xs*(v020 + xs*(v030 + xs*(v040 + xs*(v050 & - + v060*xs))))) + ys*(v100 + xs*(v110 + xs*(v120 + xs*(v130 + xs*(v140 & - + v150*xs)))) + ys*(v200 + xs*(v210 + xs*(v220 + xs*(v230 + v240*xs))) & - + ys*(v300 + xs*(v310 + xs*(v320 + v330*xs)) + ys*(v400 + xs*(v410 & - + v420*xs) + ys*(v500 + v510*xs + v600*ys))))) + z*(v001 + xs*(v011 & - + xs*(v021 + xs*(v031 + xs*(v041 + v051*xs)))) + ys*(v101 + xs*(v111 & - + xs*(v121 + xs*(v131 + v141*xs))) + ys*(v201 + xs*(v211 + xs*(v221 & - + v231*xs)) + ys*(v301 + xs*(v311 + v321*xs) + ys*(v401 + v411*xs & - + v501*ys)))) + z*(v002 + xs*(v012 + xs*(v022 + xs*(v032 + v042*xs))) & - + ys*(v102 + xs*(v112 + xs*(v122 + v132*xs)) + ys*(v202 + xs*(v212 & - + v222*xs) + ys*(v302 + v312*xs + v402*ys))) + z*(v003 + xs*(v013 & - + v023*xs) + ys*(v103 + v113*xs + v203*ys) + z*(v004 + v014*xs + v104*ys & - + z*(v005 + v006*z))))) - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_specvol.f90 b/src/equation_of_state/TEOS10/gsw_specvol.f90 new file mode 120000 index 0000000000..7a41a5cea0 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_specvol.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_specvol.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_specvol_first_derivatives.f90 b/src/equation_of_state/TEOS10/gsw_specvol_first_derivatives.f90 deleted file mode 100644 index 2f2a006b17..0000000000 --- a/src/equation_of_state/TEOS10/gsw_specvol_first_derivatives.f90 +++ /dev/null @@ -1,104 +0,0 @@ -!========================================================================== -elemental subroutine gsw_specvol_first_derivatives (sa, ct, p, v_sa, v_ct, & - v_p, iflag) -! ========================================================================= -! -! Calculates three first-order derivatives of specific volume (v). -! Note that this function uses the computationally-efficient -! expression for specific volume (Roquet et al., 2014). -! -! SA = Absolute Salinity [ g/kg ] -! CT = Conservative Temperature (ITS-90) [ deg C ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! -! v_SA = The first derivative of specific volume with respect to -! Absolute Salinity at constant CT & p. [ J/(kg (g/kg)^2) ] -! v_CT = The first derivative of specific volume with respect to -! CT at constant SA and p. [ J/(kg K(g/kg)) ] -! v_P = The first derivative of specific volume with respect to -! P at constant SA and CT. [ J/(kg K^2) ] -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sfac, offset - -use gsw_mod_specvol_coefficients - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, ct, p -integer, intent(in), optional :: iflag -real (r8), intent(out), optional :: v_sa, v_ct, v_p - -integer :: i -logical :: flags(3) -real (r8) :: v_ct_part, v_p_part, v_sa_part, xs, ys, z - -xs = sqrt(gsw_sfac*sa + offset) -ys = ct*0.025_r8 -z = p*1e-4_r8 - -if (present(iflag)) then - do i = 1, 3 - flags(i) = btest(iflag,i) - end do -else - flags = .true. -end if - -if (present(v_sa) .and. flags(1)) then - - v_sa_part = b000 + xs*(b100 + xs*(b200 + xs*(b300 + xs*(b400 + b500*xs)))) & - + ys*(b010 + xs*(b110 + xs*(b210 + xs*(b310 + b410*xs))) & - + ys*(b020 + xs*(b120 + xs*(b220 + b320*xs)) + ys*(b030 & - + xs*(b130 + b230*xs) + ys*(b040 + b140*xs + b050*ys)))) & - + z*(b001 + xs*(b101 + xs*(b201 + xs*(b301 + b401*xs))) & - + ys*(b011 + xs*(b111 + xs*(b211 + b311*xs)) + ys*(b021 & - + xs*(b121 + b221*xs) + ys*(b031 + b131*xs + b041*ys))) & - + z*(b002 + xs*(b102 + xs*(b202 + b302*xs))+ ys*(b012 & - + xs*(b112 + b212*xs) + ys*(b022 + b122*xs + b032*ys)) & - + z*(b003 + b103*xs + b013*ys + b004*z))) - - v_sa = 0.5_r8*gsw_sfac*v_sa_part/xs - -end if - - -if (present(v_ct) .and. flags(2)) then - - v_ct_part = a000 + xs*(a100 + xs*(a200 + xs*(a300 + xs*(a400 + a500*xs)))) & - + ys*(a010 + xs*(a110 + xs*(a210 + xs*(a310 + a410*xs))) & - + ys*(a020 + xs*(a120 + xs*(a220 + a320*xs)) + ys*(a030 & - + xs*(a130 + a230*xs) + ys*(a040 + a140*xs + a050*ys )))) & - + z*(a001 + xs*(a101 + xs*(a201 + xs*(a301 + a401*xs))) & - + ys*(a011 + xs*(a111 + xs*(a211 + a311*xs)) + ys*(a021 & - + xs*(a121 + a221*xs) + ys*(a031 + a131*xs + a041*ys))) & - + z*(a002 + xs*(a102 + xs*(a202 + a302*xs)) + ys*(a012 & - + xs*(a112 + a212*xs) + ys*(a022 + a122*xs + a032*ys)) & - + z*(a003 + a103*xs + a013*ys + a004*z))) - - v_ct = 0.025_r8*v_ct_part - -end if - -if (present(v_p) .and. flags(3)) then - - v_p_part = c000 + xs*(c100 + xs*(c200 + xs*(c300 + xs*(c400 + c500*xs)))) & - + ys*(c010 + xs*(c110 + xs*(c210 + xs*(c310 + c410*xs))) + ys*(c020 & - + xs*(c120 + xs*(c220 + c320*xs)) + ys*(c030 + xs*(c130 + c230*xs) & - + ys*(c040 + c140*xs + c050*ys)))) + z*(c001 + xs*(c101 + xs*(c201 & - + xs*(c301 + c401*xs))) + ys*(c011 + xs*(c111 + xs*(c211 + c311*xs)) & - + ys*(c021 + xs*(c121 + c221*xs) + ys*(c031 + c131*xs + c041*ys))) & - + z*( c002 + xs*(c102 + c202*xs) + ys*(c012 + c112*xs + c022*ys) & - + z*(c003 + c103*xs + c013*ys + z*(c004 + c005*z)))) - - v_p = 1e-8_r8*v_p_part - -end if - -return -end subroutine - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_specvol_first_derivatives.f90 b/src/equation_of_state/TEOS10/gsw_specvol_first_derivatives.f90 new file mode 120000 index 0000000000..ee6ee1f906 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_specvol_first_derivatives.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_specvol_first_derivatives.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_specvol_second_derivatives.f90 b/src/equation_of_state/TEOS10/gsw_specvol_second_derivatives.f90 deleted file mode 100644 index 39096109e9..0000000000 --- a/src/equation_of_state/TEOS10/gsw_specvol_second_derivatives.f90 +++ /dev/null @@ -1,131 +0,0 @@ -!========================================================================== -elemental subroutine gsw_specvol_second_derivatives (sa, ct, p, v_sa_sa, & - v_sa_ct, v_ct_ct, v_sa_p, v_ct_p, iflag) -! ========================================================================= -! -! Calculates five second-order derivatives of specific volume (v). -! Note that this function uses the computationally-efficient -! expression for specific volume (Roquet et al., 2014). -! -! SA = Absolute Salinity [ g/kg ] -! CT = Conservative Temperature (ITS-90) [ deg C ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! -! v_SA_SA = The second derivative of specific volume with respect to -! Absolute Salinity at constant CT & p. [ J/(kg (g/kg)^2) ] -! v_SA_CT = The second derivative of specific volume with respect to -! SA and CT at constant p. [ J/(kg K(g/kg)) ] -! v_CT_CT = The second derivative of specific volume with respect to -! CT at constant SA and p. [ J/(kg K^2) ] -! v_SA_P = The second derivative of specific volume with respect to -! SA and P at constant CT. [ J/(kg K(g/kg)) ] -! v_CT_P = The second derivative of specific volume with respect to -! CT and P at constant SA. [ J/(kg K(g/kg)) ] -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sfac, offset - -use gsw_mod_specvol_coefficients - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, ct, p -integer, intent(in), optional :: iflag -real (r8), intent(out), optional :: v_sa_sa, v_sa_ct, v_ct_ct, v_sa_p, v_ct_p - -integer :: i -logical :: flags(5) -real (r8) :: v_ct_ct_part, v_ct_p_part, v_sa_ct_part, v_sa_p_part -real (r8) :: v_sa_sa_part, xs, xs2, ys, z - -xs2 = gsw_sfac*sa + offset -xs = sqrt(xs2) -ys = ct*0.025_r8 -z = p*1e-4_r8 - -if (present(iflag)) then - do i = 1, 5 - flags(i) = btest(iflag,i) - end do -else - flags = .true. -end if - -if (present(v_sa_sa) .and. flags(1)) then - - v_sa_sa_part = (-b000 + xs2*(b200 + xs*(2.0_r8*b300 + xs*(3.0_r8*b400 & - + 4.0_r8*b500*xs))) + ys*(-b010 + xs2*(b210 + xs*(2.0_r8*b310 & - + 3.0_r8*b410*xs)) + ys*(-b020 + xs2*(b220 + 2.0_r8*b320*xs) & - + ys*(-b030 + b230*xs2 + ys*(-b040 - b050*ys)))) + z*(-b001 & - + xs2*(b201 + xs*(2.0_r8*b301 + 3.0_r8*b401*xs)) + ys*(-b011 & - + xs2*(b211 + 2.0_r8*b311*xs) + ys*(-b021 + b221*xs2 & - + ys*(-b031 - b041*ys))) + z*(-b002 + xs2*(b202 + 2.0_r8*b302*xs) & - + ys*(-b012 + b212*xs2 + ys*(-b022 - b032*ys)) + z*(-b003 & - - b013*ys - b004*z))))/xs2 - - v_sa_sa = 0.25_r8*gsw_sfac*gsw_sfac*v_sa_sa_part/xs - -end if - -if (present(v_sa_ct) .and. flags(2)) then - - v_sa_ct_part = (b010 + xs*(b110 + xs*(b210 + xs*(b310 + b410*xs))) & - + ys*(2.0_r8*(b020 + xs*(b120 + xs*(b220 + b320*xs))) & - + ys*(3.0_r8*(b030 + xs*(b130 + b230*xs)) + ys*(4.0_r8*(b040 + b140*xs) & - + 5.0_r8*b050*ys))) + z*(b011 + xs*(b111 + xs*(b211 + b311*xs)) & - + ys*(2.0_r8*(b021 + xs*(b121 + b221*xs)) + ys*(3.0_r8*(b031 + b131*xs) & - + 4.0_r8*b041*ys)) + z*(b012 + xs*(b112 + b212*xs) + ys*(2.0_r8*(b022 & - + b122*xs) + 3.0_r8*b032*ys) + b013*z)))/xs - - v_sa_ct = 0.025_r8*0.5_r8*gsw_sfac*v_sa_ct_part - -end if - -if (present(v_ct_ct) .and. flags(3)) then - - v_ct_ct_part = a010 + xs*(a110 + xs*(a210 + xs*(a310 + a410*xs))) & - + ys*(2.0_r8*(a020 + xs*(a120 + xs*(a220 + a320*xs))) & - + ys*(3.0_r8*(a030 + xs*(a130 + a230*xs)) + ys*(4.0_r8*(a040 & - + a140*xs) + 5.0_r8*a050*ys))) + z*( a011 + xs*(a111 + xs*(a211 & - + a311*xs)) + ys*(2.0_r8*(a021 + xs*(a121 + a221*xs)) & - + ys*(3.0_r8*(a031 + a131*xs) + 4.0_r8*a041*ys)) + z*(a012 & - + xs*(a112 + a212*xs) + ys*(2.0_r8*(a022 + a122*xs) & - + 3.0_r8*a032*ys) + a013*z)) - - v_ct_ct = 0.025_r8*0.025_r8*v_ct_ct_part - -end if - -if (present(v_sa_p) .and. flags(4)) then - - v_sa_p_part = b001 + xs*(b101 + xs*(b201 + xs*(b301 + b401*xs))) + ys*(b011 & - + xs*(b111 + xs*(b211 + b311*xs)) + ys*(b021 + xs*(b121 + b221*xs) & - + ys*(b031 + b131*xs + b041*ys))) + z*(2.0_r8*(b002 + xs*(b102 & - + xs*(b202 + b302*xs)) + ys*(b012 + xs*(b112 + b212*xs) + ys*(b022 & - + b122*xs + b032*ys))) + z*(3.0_r8*(b003 + b103*xs + b013*ys) & - + 4.0_r8*b004*z)) - - v_sa_p = 1e-8_r8*0.5_r8*gsw_sfac*v_sa_p_part - -end if - -if (present(v_ct_p) .and. flags(5)) then - - v_ct_p_part = a001 + xs*(a101 + xs*(a201 + xs*(a301 + a401*xs))) + ys*(a011 & - + xs*(a111 + xs*(a211 + a311*xs)) + ys*(a021 + xs*(a121 + a221*xs) & - + ys*(a031 + a131*xs + a041*ys))) + z*(2.0_r8*(a002 + xs*(a102 & - + xs*(a202 + a302*xs)) + ys*(a012 + xs*(a112 + a212*xs) + ys*(a022 & - + a122*xs + a032*ys))) + z*(3.0_r8*(a003 + a103*xs + a013*ys) & - + 4.0_r8*a004*z)) - - v_ct_p = 1e-8_r8*0.025_r8*v_ct_p_part - -end if - -return -end subroutine - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_specvol_second_derivatives.f90 b/src/equation_of_state/TEOS10/gsw_specvol_second_derivatives.f90 new file mode 120000 index 0000000000..cdd1c1b87a --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_specvol_second_derivatives.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_specvol_second_derivatives.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_sr_from_sp.f90 b/src/equation_of_state/TEOS10/gsw_sr_from_sp.f90 deleted file mode 100644 index cbcc4fea0b..0000000000 --- a/src/equation_of_state/TEOS10/gsw_sr_from_sp.f90 +++ /dev/null @@ -1,30 +0,0 @@ -!========================================================================== -elemental function gsw_sr_from_sp (sp) -!========================================================================== -! -! Calculates Reference Salinity, SR, from Practical Salinity, SP. -! -! sp : Practical Salinity [unitless] -! -! gsw_sr_from_sp : Reference Salinity [g/kg] -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_ups - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sp - -real (r8) :: gsw_sr_from_sp - -gsw_sr_from_sp = sp*gsw_ups - -return -end function - -!-------------------------------------------------------------------------- - - - diff --git a/src/equation_of_state/TEOS10/gsw_sr_from_sp.f90 b/src/equation_of_state/TEOS10/gsw_sr_from_sp.f90 new file mode 120000 index 0000000000..eda229ff66 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_sr_from_sp.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_sr_from_sp.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_t_deriv_chem_potential_water_t_exact.f90 b/src/equation_of_state/TEOS10/gsw_t_deriv_chem_potential_water_t_exact.f90 deleted file mode 100644 index 668184491f..0000000000 --- a/src/equation_of_state/TEOS10/gsw_t_deriv_chem_potential_water_t_exact.f90 +++ /dev/null @@ -1,88 +0,0 @@ -!========================================================================== -elemental function gsw_t_deriv_chem_potential_water_t_exact (sa, t, p) -!========================================================================== -! -! Calculates the temperature derivative of the chemical potential of water -! in seawater so that it is valid at exactly SA = 0. -! -! SA = Absolute Salinity [ g/kg ] -! t = in-situ temperature (ITS-90) [ deg C ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! -! chem_potential_water_dt = temperature derivative of the chemical -! potential of water in seawater [ J g^-1 K^-1 ] -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sfac, rec_db2pa - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, t, p - -real (r8) :: gsw_t_deriv_chem_potential_water_t_exact - -real (r8) :: g03_t, g08_sa_t, x, x2, y, z, g08_t - -real (r8), parameter :: kg2g = 1e-3_r8 - -! Note. The kg2g, a factor of 1e-3, is needed to convert the output of this -! function into units of J/g. See section (2.9) of the TEOS-10 Manual. - -x2 = gsw_sfac*sa -x = sqrt(x2) -y = t*0.025_r8 -z = p*rec_db2pa ! the input pressure (p) is sea pressure in units of dbar. - -g03_t = 5.90578347909402_r8 + z*(-270.983805184062_r8 + & - z*(776.153611613101_r8 + z*(-196.51255088122_r8 + (28.9796526294175_r8 - & - 2.13290083518327_r8*z)*z))) + & - y*(-24715.571866078_r8 + z*(2910.0729080936_r8 + & - z*(-1513.116771538718_r8 + z*(546.959324647056_r8 + & - z*(-111.1208127634436_r8 + 8.68841343834394_r8*z)))) + & - y*(2210.2236124548363_r8 + z*(-2017.52334943521_r8 + & - z*(1498.081172457456_r8 + z*(-718.6359919632359_r8 + & - (146.4037555781616_r8 - 4.9892131862671505_r8*z)*z))) + & - y*(-592.743745734632_r8 + z*(1591.873781627888_r8 + & - z*(-1207.261522487504_r8 + (608.785486935364_r8 - & - 105.4993508931208_r8*z)*z)) + & - y*(290.12956292128547_r8 + z*(-973.091553087975_r8 + & - z*(602.603274510125_r8 + z*(-276.361526170076_r8 + & - 32.40953340386105_r8*z))) + & - y*(-113.90630790850321_r8 + y*(21.35571525415769_r8 - & - 67.41756835751434_r8*z) + & - z*(381.06836198507096_r8 + z*(-133.7383902842754_r8 + & - 49.023632509086724_r8*z))))))) - -g08_t = x2*(168.072408311545_r8 + & - x*(-493.407510141682_r8 + x*(543.835333000098_r8 + & - x*(-196.028306689776_r8 + 36.7571622995805_r8*x) + & - y*(-137.1145018408982_r8 + y*(148.10030845687618_r8 + & - y*(-68.5590309679152_r8 + 12.4848504784754_r8*y))) - & - 22.6683558512829_r8*z) + z*(-175.292041186547_r8 + & - (83.1923927801819_r8 - 29.483064349429_r8*z)*z) + & - y*(-86.1329351956084_r8 + z*(766.116132004952_r8 + & - z*(-108.3834525034224_r8 + 51.2796974779828_r8*z)) + & - y*(-30.0682112585625_r8 - 1380.9597954037708_r8*z + & - y*(3.50240264723578_r8 + 938.26075044542_r8*z))))) - -g08_sa_t = 1187.3715515697959_r8 + & - x*(-1480.222530425046_r8 + x*(2175.341332000392_r8 + & - x*(-980.14153344888_r8 + 220.542973797483_r8*x) + & - y*(-548.4580073635929_r8 + y*(592.4012338275047_r8 + & - y*(-274.2361238716608_r8 + 49.9394019139016_r8*y))) - & - 90.6734234051316_r8*z) + z*(-525.876123559641_r8 + & - (249.57717834054571_r8 - 88.449193048287_r8*z)*z) + & - y*(-258.3988055868252_r8 + z*(2298.348396014856_r8 + & - z*(-325.1503575102672_r8 + 153.8390924339484_r8*z)) + & - y*(-90.2046337756875_r8 - 4142.8793862113125_r8*z + & - y*(10.50720794170734_r8 + 2814.78225133626_r8*z)))) - -gsw_t_deriv_chem_potential_water_t_exact = kg2g*((g03_t + g08_t)*0.025_r8 - & - 0.5_r8*gsw_sfac*0.025_r8*sa*g08_sa_t) -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_t_deriv_chem_potential_water_t_exact.f90 b/src/equation_of_state/TEOS10/gsw_t_deriv_chem_potential_water_t_exact.f90 new file mode 120000 index 0000000000..3194f69a64 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_t_deriv_chem_potential_water_t_exact.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_t_deriv_chem_potential_water_t_exact.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_t_freezing_exact.f90 b/src/equation_of_state/TEOS10/gsw_t_freezing_exact.f90 deleted file mode 100644 index 63c27db986..0000000000 --- a/src/equation_of_state/TEOS10/gsw_t_freezing_exact.f90 +++ /dev/null @@ -1,71 +0,0 @@ -!========================================================================== -elemental function gsw_t_freezing_exact (sa, p, saturation_fraction) -!========================================================================== -! -! Calculates the in-situ temperature at which seawater freezes. The -! in-situ temperature freezing point is calculated from the exact -! in-situ freezing temperature which is found by a modified Newton-Raphson -! iteration (McDougall and Wotherspoon, 2013) of the equality of the -! chemical potentials of water in seawater and in ice. -! -! An alternative GSW function, gsw_t_freezing_poly, it is based on a -! computationally-efficient polynomial, and is accurate to within -5e-4 K -! and 6e-4 K, when compared with this function. -! -! SA = Absolute Salinity [ g/kg ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! saturation_fraction = the saturation fraction of dissolved air in -! seawater -! (i.e., saturation_fraction must be between 0 and 1, and the default -! is 1, completely saturated) -! -! t_freezing = in-situ temperature at which seawater freezes. [ deg C ] -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sso - -use gsw_mod_toolbox, only : gsw_gibbs_ice, gsw_chem_potential_water_t_exact -use gsw_mod_toolbox, only : gsw_t_deriv_chem_potential_water_t_exact -use gsw_mod_toolbox, only : gsw_t_freezing_poly - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, p, saturation_fraction - -real (r8) :: gsw_t_freezing_exact - -real (r8) :: df_dt, p_r, sa_r, tf, tfm, tf_old, x, f - -! The initial value of t_freezing_exact (for air-free seawater) -tf = gsw_t_freezing_poly(sa,p,polynomial=.true.) - -df_dt = 1e3_r8*gsw_t_deriv_chem_potential_water_t_exact(sa,tf,p) - & - gsw_gibbs_ice(1,0,tf,p) -! df_dt here is the initial value of the derivative of the function f whose -! zero (f = 0) we are finding (see Eqn. (3.33.2) of IOC et al (2010)). - -tf_old = tf -f = 1e3_r8*gsw_chem_potential_water_t_exact(sa,tf_old,p) - & - gsw_gibbs_ice(0,0,tf_old,p) -tf = tf_old - f/df_dt -tfm = 0.5_r8*(tf + tf_old) -df_dt = 1e3_r8*gsw_t_deriv_chem_potential_water_t_exact(sa,tfm,p) - & - gsw_gibbs_ice(1,0,tfm,p) -tf = tf_old - f/df_dt - -tf_old = tf -f = 1e3_r8*gsw_chem_potential_water_t_exact(sa,tf_old,p) - & - gsw_gibbs_ice(0,0,tf_old,p) -tf = tf_old - f/df_dt - -! Adjust for the effects of dissolved air -gsw_t_freezing_exact = tf - & - saturation_fraction*(1e-3_r8)*(2.4_r8 - sa/(2.0_r8*gsw_sso)) - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_t_freezing_exact.f90 b/src/equation_of_state/TEOS10/gsw_t_freezing_exact.f90 new file mode 120000 index 0000000000..ca5434983f --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_t_freezing_exact.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_t_freezing_exact.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_t_freezing_poly.f90 b/src/equation_of_state/TEOS10/gsw_t_freezing_poly.f90 deleted file mode 100644 index 479a323d2c..0000000000 --- a/src/equation_of_state/TEOS10/gsw_t_freezing_poly.f90 +++ /dev/null @@ -1,78 +0,0 @@ -!========================================================================== -elemental function gsw_t_freezing_poly (sa, p, saturation_fraction, polynomial) -!========================================================================== -! -! Calculates the in-situ temperature at which seawater freezes from a -! computationally efficient polynomial. -! -! SA = Absolute Salinity [ g/kg ] -! p = sea pressure [ dbar ] -! ( i.e. absolute pressure - 10.1325 dbar ) -! saturation_fraction = the saturation fraction of dissolved air in -! seawater -! -! t_freezing = in-situ temperature at which seawater freezes. [ deg C ] -! (ITS-90) -!-------------------------------------------------------------------------- - -use gsw_mod_teos10_constants, only : gsw_sso - -use gsw_mod_freezing_poly_coefficients - -use gsw_mod_toolbox, only : gsw_ct_freezing_poly, gsw_t_from_ct - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, p -real (r8), intent(in), optional :: saturation_fraction -logical, intent(in), optional :: polynomial - -real (r8) :: gsw_t_freezing_poly - -real (r8) :: p_r, sa_r, x, ctf, sfrac -logical :: direct_poly - -if (present(polynomial)) then - direct_poly = polynomial -else - direct_poly = .false. -end if - -if (.not. direct_poly) then - - if (present(saturation_fraction)) then - sfrac = saturation_fraction - else - sfrac = 1.0_r8 - end if - - ctf = gsw_ct_freezing_poly(sa,p,sfrac) - gsw_t_freezing_poly = gsw_t_from_ct(sa,ctf,p) - -else - - ! Alternative calculation ... - sa_r = sa*1e-2_r8 - x = sqrt(sa_r) - p_r = p*1e-4_r8 - - gsw_t_freezing_poly = t0 & - + sa_r*(t1 + x*(t2 + x*(t3 + x*(t4 + x*(t5 + t6*x))))) & - + p_r*(t7 + p_r*(t8 + t9*p_r)) & - + sa_r*p_r*(t10 + p_r*(t12 + p_r*(t15 + t21*sa_r)) & - + sa_r*(t13 + t17*p_r + t19*sa_r) & - + x*(t11 + p_r*(t14 + t18*p_r) + sa_r*(t16 + t20*p_r + t22*sa_r))) - - if (.not. present(saturation_fraction)) return - - ! Adjust for the effects of dissolved air - gsw_t_freezing_poly = gsw_t_freezing_poly - & - saturation_fraction*(1e-3_r8)*(2.4_r8 - sa/(2.0_r8*gsw_sso)) -end if - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_t_freezing_poly.f90 b/src/equation_of_state/TEOS10/gsw_t_freezing_poly.f90 new file mode 120000 index 0000000000..fcc75a7d80 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_t_freezing_poly.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_t_freezing_poly.f90 \ No newline at end of file diff --git a/src/equation_of_state/TEOS10/gsw_t_from_ct.f90 b/src/equation_of_state/TEOS10/gsw_t_from_ct.f90 deleted file mode 100644 index 9f85a4530c..0000000000 --- a/src/equation_of_state/TEOS10/gsw_t_from_ct.f90 +++ /dev/null @@ -1,33 +0,0 @@ -!========================================================================== -elemental function gsw_t_from_ct (sa, ct, p) -!========================================================================== -! -! Calculates in-situ temperature from Conservative Temperature of seawater -! -! sa : Absolute Salinity [g/kg] -! ct : Conservative Temperature [deg C] -! -! gsw_t_from_ct : in-situ temperature [deg C] -!-------------------------------------------------------------------------- - -use gsw_mod_toolbox, only : gsw_pt_from_ct, gsw_pt_from_t - -use gsw_mod_kinds - -implicit none - -real (r8), intent(in) :: sa, ct, p - -real (r8) :: gsw_t_from_ct - -real (r8) :: pt0 - -real (r8), parameter :: p0 = 0.0_r8 - -pt0 = gsw_pt_from_ct(sa,ct) -gsw_t_from_ct = gsw_pt_from_t(sa,pt0,p0,p) - -return -end function - -!-------------------------------------------------------------------------- diff --git a/src/equation_of_state/TEOS10/gsw_t_from_ct.f90 b/src/equation_of_state/TEOS10/gsw_t_from_ct.f90 new file mode 120000 index 0000000000..41a33a07b5 --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_t_from_ct.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/toolbox/gsw_t_from_ct.f90 \ No newline at end of file From b31da6a94a0b5f7fe4bc54641a4878c3ae64f2d9 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 19 Jun 2020 18:24:28 +0000 Subject: [PATCH 03/91] Moved pkg/MOM6_DA_hook to config_src/external - Removed two git submodules and added bare interfaces to config_src/exernal/ODA_hooks/ - Added some missing documentation --- .gitmodules | 6 - config_src/external/GFDL_ocean_BGC/README.md | 2 +- config_src/external/ODA_hooks/README.md | 9 ++ config_src/external/ODA_hooks/kdtree.f90 | 12 ++ .../external/ODA_hooks/ocean_da_core.F90 | 90 +++++++++++++ .../external/ODA_hooks/ocean_da_types.F90 | 126 ++++++++++++++++++ .../external/ODA_hooks/write_ocean_obs.F90 | 60 +++++++++ pkg/MOM6_DA_hooks | 1 - pkg/geoKdTree | 1 - src/ocean_data_assim/core | 1 - src/ocean_data_assim/geoKdTree | 1 - 11 files changed, 298 insertions(+), 11 deletions(-) create mode 100644 config_src/external/ODA_hooks/README.md create mode 100644 config_src/external/ODA_hooks/kdtree.f90 create mode 100644 config_src/external/ODA_hooks/ocean_da_core.F90 create mode 100644 config_src/external/ODA_hooks/ocean_da_types.F90 create mode 100644 config_src/external/ODA_hooks/write_ocean_obs.F90 delete mode 160000 pkg/MOM6_DA_hooks delete mode 160000 pkg/geoKdTree delete mode 120000 src/ocean_data_assim/core delete mode 120000 src/ocean_data_assim/geoKdTree diff --git a/.gitmodules b/.gitmodules index b499e43096..637f1188ed 100644 --- a/.gitmodules +++ b/.gitmodules @@ -4,9 +4,3 @@ [submodule "pkg/GSW-Fortran"] path = pkg/GSW-Fortran url = https://github.com/TEOS-10/GSW-Fortran.git -[submodule "pkg/MOM6_DA_hooks"] - path = pkg/MOM6_DA_hooks - url = https://github.com/MJHarrison-GFDL/MOM6_DA_hooks.git -[submodule "pkg/geoKdTree"] - path = pkg/geoKdTree - url = https://github.com/travissluka/geoKdTree.git diff --git a/config_src/external/GFDL_ocean_BGC/README.md b/config_src/external/GFDL_ocean_BGC/README.md index 584e5aa16d..198575c8a7 100644 --- a/config_src/external/GFDL_ocean_BGC/README.md +++ b/config_src/external/GFDL_ocean_BGC/README.md @@ -3,4 +3,4 @@ GFDL_ocean_BGC These APIs reflect those for the GFDL ocean_BGC available at https://github.com/NOAA-GFDL/ocean_BGC. -The modules in this directory do not do any computations. They simple reflect the APIs of the above package. +The modules in this directory do not do any computations. They simply reflect the APIs of the above package. diff --git a/config_src/external/ODA_hooks/README.md b/config_src/external/ODA_hooks/README.md new file mode 100644 index 0000000000..b26731a463 --- /dev/null +++ b/config_src/external/ODA_hooks/README.md @@ -0,0 +1,9 @@ +ODA_hooks +========= + +These APIs reflect those for the ocean data assimilation hooks similar to https://github.com/MJHarrison-GFDL/MOM6_DA_hooks + +The modules in this directory do not do any computations. They simply reflect the APIs of the above package. + +- kdtree.f90 - would come from https://github.com/travissluka/geoKdTree +- ocean_da_core.F90, ocean_da_types.F90, write_ocean_obs.F90 were copied from https://github.com/MJHarrison-GFDL/MOM6_DA_hooks diff --git a/config_src/external/ODA_hooks/kdtree.f90 b/config_src/external/ODA_hooks/kdtree.f90 new file mode 100644 index 0000000000..a27716dde1 --- /dev/null +++ b/config_src/external/ODA_hooks/kdtree.f90 @@ -0,0 +1,12 @@ +!> A null version of K-d tree from geoKdTree +module kdtree + implicit none + private + + public :: kd_root + + !> A K-d tree tpe + type kd_root + integer :: dummy !< To stop a compiler from doing nothing + end type kd_root +end module kdtree diff --git a/config_src/external/ODA_hooks/ocean_da_core.F90 b/config_src/external/ODA_hooks/ocean_da_core.F90 new file mode 100644 index 0000000000..90004bd9d5 --- /dev/null +++ b/config_src/external/ODA_hooks/ocean_da_core.F90 @@ -0,0 +1,90 @@ +!> A set of dummy interfaces for compiling the MOM6 DA driver code. +module ocean_da_core_mod +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! This module contains a set of dummy interfaces for compiling the MOM6 DA +! driver code. These interfaces are not finalized and will be replaced by supported +! interfaces at some later date. +! +! 3/22/18 +! matthew.harrison@noaa.gov +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + use mpp_domains_mod, only : domain2d + use time_manager_mod, only : time_type, set_time, get_date + ! ODA_tools modules + use ocean_da_types_mod, only : ocean_profile_type, grid_type + + + implicit none + private + public :: ocean_da_core_init, open_profile_dataset + public :: get_profiles, copy_profiles + +contains + + !> Initialize ODA + subroutine ocean_da_core_init(Domain, T_grid, Profiles, model_time) + type(domain2d), pointer, intent(in) :: Domain !< MOM type for the local domain` + type(grid_type), pointer, intent(in) :: T_grid !< MOM grid type for the local domain + type(ocean_profile_type), pointer :: Profiles + !< This is an unstructured recursive list of profiles + !< which are either within the localized domain corresponding + !< to the Domain argument, or the global profile list + type(time_type), intent(in) :: model_time !< Model time + + Profiles=>NULL() + return + end subroutine ocean_da_core_init + + !> Open a profile dataset + subroutine open_profile_dataset(Profiles, Domain, T_grid, & + filename, time_start, time_end, obs_variable, localize) + type(ocean_profile_type), pointer :: Profiles + !< This is an unstructured recursive list of profiles + !< which are either within the localized domain corresponding + !< to the Domain argument, or the global profile list + type(domain2d), pointer, intent(in) :: Domain !< MOM type for the local domain + type(grid_type), pointer, intent(in) :: T_grid !< MOM grid type for the local domain + character(len=*), intent(in) :: filename !< filename containing profile data + type(time_type), intent(in) :: time_start, time_end !< start and end times for the analysis + integer, intent(in), optional :: obs_variable !< If present, then extract corresponding data + !< from file, otherwise, extract all available data which. + logical, intent(in), optional :: localize !< Localize the observations to the current computational domain + + return + + end subroutine open_profile_dataset + + !> Get profiles obs relevant to current analysis interval + subroutine get_profiles(model_time, Profiles, Current_profiles) + type(time_type), intent(in) :: model_time + type(ocean_profile_type), pointer :: Profiles + type(ocean_profile_type), pointer :: Current_profiles + + Profiles=>NULL() + Current_Profiles=>NULL() + + return + end subroutine get_profiles + + !> Copy profiles at current analysis step from a linked list to an array + !! feasible now since the number of localized current profiles is small + subroutine copy_profiles(Current_profiles, Profiles) + type(ocean_profile_type), pointer :: Current_profiles + type(ocean_profile_type), pointer, dimension(:) :: Profiles + + return + + end subroutine copy_profiles + + !> Copy observations + subroutine copy_obs(obs_in, obs_out) + type(ocean_profile_type), pointer :: obs_in + type(ocean_profile_type), pointer :: obs_out + + return + end subroutine copy_obs + +end module ocean_da_core_mod diff --git a/config_src/external/ODA_hooks/ocean_da_types.F90 b/config_src/external/ODA_hooks/ocean_da_types.F90 new file mode 100644 index 0000000000..165ed4f4ba --- /dev/null +++ b/config_src/external/ODA_hooks/ocean_da_types.F90 @@ -0,0 +1,126 @@ +!> This module contains a set of data structures and interfaces for compiling the MOM6 DA +!! driver code. +module ocean_da_types_mod +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! This module contains a set of data structures and interfaces for compiling the MOM6 DA +! driver code. This code is not yet finalized and will be replaced by supported +! software at some later date. +! +! 3/22/18 +! matthew.harrison@noaa.gov +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +#ifndef MAX_LEVS_FILE_ +#define MAX_LEVS_FILE_ 50 +#endif + +#ifndef MAX_LINKS_ +#define MAX_LINKS_ 100 +#endif + +!============================================================ +! This module contains type declarations and default values +! for oda modules. +!============================================================ + +! Contact: Matthew.Harrison@noaa.gov and Feiyu.Lu@noaa.gov + + use time_manager_mod, only : time_type + !use obs_tools_mod, only : obs_def_type + !use mpp_domains_mod, only : domain2d + + implicit none + + private + + integer, parameter, public :: MAX_LEVELS_FILE = MAX_LEVS_FILE_ !< Controls record length for optimal storage + integer, parameter, public :: MAX_LINKS = MAX_LINKS_ !< Maximum number of records per profile for storage for profiles + integer, parameter, public :: UNKNOWN = 0 + + integer, save, public :: TEMP_ID = 1 + integer, save, public :: SALT_ID = 2 + real, parameter, public :: MISSING_VALUE = -1.e10 + + !> Type for ocean state in DA space (same decomposition and vertical grid) + type, public :: OCEAN_CONTROL_STRUCT + integer :: ensemble_size + real, pointer, dimension(:,:,:) :: SSH=>NULL() !NULL() !NULL() !NULL() !NULL() !NULL() !NULL(), id_s=>NULL() !< diagnostic IDs for temperature and salinity + integer, dimension(:), pointer :: id_u=>NULL(), id_v=>NULL() !< diagnostic IDs for zonal and meridional velocity + integer, dimension(:), pointer :: id_ssh=>NULL() !< diagnostic IDs for SSH + end type OCEAN_CONTROL_STRUCT + + !> Profile + type, public :: ocean_profile_type + integer :: variable !< variable ids are defined by the ocean_types module (e.g. TEMP_ID, SALT_ID) + integer :: inst_type !< instrument types are defined by platform class (e.g. MOORING, DROP, etc.) and instrument type (XBT, CDT, etc.) + integer :: nvar !< number of observations types associated with the current profile + real :: project !< e.g. FGGE, COARE, ACCE, ... + real :: probe !< MBT, XBT, drifting buoy + real :: ref_inst !< instrument (thermograph, hull sensor, ...) + integer :: wod_cast_num !< NODC world ocean dataset unique id + real :: fix_depth !< adjust profile depths (for XBT drop rate corrections) + real :: ocn_vehicle !< ocean vehicle type + real :: database_id !< a unique profile id + integer :: levels !< number of levels in the current profile + integer :: basin_mask !<1:Southern Ocean, 2:Atlantic Ocean, 3:Pacific Ocean, + !! 4:Arctic Ocean, 5:Indian Ocean, 6:Mediterranean Sea, 7:Black Sea, + !! 8:Hudson Bay, 9:Baltic Sea, 10:Red Sea, 11:Persian Gulf + integer :: profile_flag !< an overall flag for the profile + integer :: profile_flag_s !< an overall flag for the profile salinity + real :: lat, lon !< latitude and longitude (degrees E and N) + logical :: accepted !< logical flag to disable a profile + integer :: nlinks !< number of links used to construct the profile (when reading from disk) + type(ocean_profile_type), pointer :: next=>NULL() !< all profiles are stored as linked list. + type(ocean_profile_type), pointer :: prev=>NULL() + type(ocean_profile_type), pointer :: cnext=>NULL() ! current profiles are stored as linked list. + type(ocean_profile_type), pointer :: cprev=>NULL() + integer :: nbr_xi, nbr_yi ! nearest neighbor model gridpoint for the profile + real :: nbr_dist ! distance to nearest neighbor model gridpoint + real, dimension(:), pointer :: depth + real, dimension(:), pointer :: data_t => NULL(), data_s => NULL() + real, dimension(:), pointer :: data + !integer, dimension(:), pointer :: flag_t + !integer, dimension(:), pointer :: flag_s ! level-by-level flags for salinity + !::sdu:: For now ECDA use flag as a logical, will likely change in future releases. + logical, dimension(:), pointer :: flag + real :: temp_err, salt_err ! measurement error + !real, dimension(:), pointer :: ms_t ! ms temperature by level + !real, dimension(:), pointer :: ms_s ! ms salinity by level + real, dimension(:), pointer :: ms_inv => NULL() + real, dimension(:), pointer :: ms => NULL() +! type(obs_def_type), dimension(:), pointer :: obs_def => NULL() + type(time_type) :: time + integer :: yyyy + integer :: mmdd + !type(time_type), pointer :: Model_time ! each profile can be associated with a first-guess field with an associated time and grid + !type(grid_type), pointer :: Model_grid + real :: i_index, j_index ! model longitude and latitude indices respectively + real, dimension(:), pointer :: k_index ! model depth indices + type(time_type) :: tdiff ! positive difference between model time and observation time + end type ocean_profile_type + + !> Grid information for ODA purposes, including arrays of + !! lat, lon, depth, thickness, basin and land mask + type, public :: grid_type + real, pointer, dimension(:,:) :: x=>NULL(), y=>NULL() + !real, pointer, dimension(:,:) :: x_bound=>NULL(), y_bound=>NULL() + !real, pointer, dimension(:,:) :: dx=>NULL(), dy=>NULL() + real, pointer, dimension(:,:,:) :: z=>NULL() + real, pointer, dimension(:,:,:) :: h=>NULL() + !real, pointer, dimension(:) :: z_bound=>NULL() + !real, pointer, dimension(:) :: dz => NULL() + real, pointer, dimension(:,:) :: basin_mask => NULL() + real, pointer, dimension(:,:,:) :: mask => NULL() + !type(domain2d), pointer :: Dom ! FMS domain type + !logical :: cyclic + integer :: ni, nj, nk + end type grid_type + +end module ocean_da_types_mod diff --git a/config_src/external/ODA_hooks/write_ocean_obs.F90 b/config_src/external/ODA_hooks/write_ocean_obs.F90 new file mode 100644 index 0000000000..468698d475 --- /dev/null +++ b/config_src/external/ODA_hooks/write_ocean_obs.F90 @@ -0,0 +1,60 @@ +!> Dummy interfaces for writing ODA data +module write_ocean_obs_mod + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! This module contains a set of dummy interfaces for compiling the MOM6 DA +! driver code. These interfaces are not finalized and will be replaced by supported +! interfaces at some later date. +! +! 3/22/18 +! matthew.harrison@noaa.gov +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + use ocean_da_types_mod, only : ocean_profile_type + use time_manager_mod, only : time_type, get_time, set_date, operator ( - ) + + implicit none + + private + + public :: open_profile_file, write_profile, close_profile_file, & + write_ocean_obs_init + +contains + +!> Open a profile file +integer function open_profile_file(name, nvar, grid_lon, grid_lat,thread,fset) + character(len=*), intent(in) :: name !< File name + integer, intent(in), optional :: nvar !< Number of variables + real, dimension(:), optional, intent(in) :: grid_lon !< Longitude [degreeE] + real, dimension(:), optional, intent(in) :: grid_lat !< Latitude [degreeN] + integer, intent(in), optional :: thread !< Thread + integer, intent(in), optional :: fset !< File set + + open_profile_file=-1 +end function open_profile_file + +!> Write a profile +subroutine write_profile(unit,profile) + integer, intent(in) :: unit !< File unit + type(ocean_profile_type), intent(in) :: profile !< Profile + + return +end subroutine write_profile + +!> Close a profile file +subroutine close_profile_file(unit) + integer, intent(in) :: unit !< File unit + + return +end subroutine close_profile_file + +!> Initialize write_ocean_obs module +subroutine write_ocean_obs_init() + + return +end subroutine write_ocean_obs_init + +end module write_ocean_obs_mod diff --git a/pkg/MOM6_DA_hooks b/pkg/MOM6_DA_hooks deleted file mode 160000 index 6d8834ca8c..0000000000 --- a/pkg/MOM6_DA_hooks +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 6d8834ca8cf399f1a0d202239d72919907f6cd74 diff --git a/pkg/geoKdTree b/pkg/geoKdTree deleted file mode 160000 index a4670b9743..0000000000 --- a/pkg/geoKdTree +++ /dev/null @@ -1 +0,0 @@ -Subproject commit a4670b9743c883d310d821eeac5b1f77f587b9d5 diff --git a/src/ocean_data_assim/core b/src/ocean_data_assim/core deleted file mode 120000 index e0a21d3192..0000000000 --- a/src/ocean_data_assim/core +++ /dev/null @@ -1 +0,0 @@ -../../pkg/MOM6_DA_hooks/src/core \ No newline at end of file diff --git a/src/ocean_data_assim/geoKdTree b/src/ocean_data_assim/geoKdTree deleted file mode 120000 index 61fd167bb6..0000000000 --- a/src/ocean_data_assim/geoKdTree +++ /dev/null @@ -1 +0,0 @@ -../../pkg/geoKdTree \ No newline at end of file From 6818402edcc717b9dd78c4b1dcb39ad3d564cce8 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 19 Jun 2020 18:35:37 +0000 Subject: [PATCH 04/91] Corrected documentation errors - Updated Doxygen configuration to find files in config_src/external --- config_src/external/ODA_hooks/ocean_da_types.F90 | 10 ++++++---- config_src/external/ODA_hooks/write_ocean_obs.F90 | 2 +- docs/Doxyfile_nortd | 4 +++- docs/Doxyfile_rtd | 4 ++-- 4 files changed, 12 insertions(+), 8 deletions(-) diff --git a/config_src/external/ODA_hooks/ocean_da_types.F90 b/config_src/external/ODA_hooks/ocean_da_types.F90 index 165ed4f4ba..22041ce76b 100644 --- a/config_src/external/ODA_hooks/ocean_da_types.F90 +++ b/config_src/external/ODA_hooks/ocean_da_types.F90 @@ -51,15 +51,16 @@ module ocean_da_types_mod real, pointer, dimension(:,:,:,:) :: S=>NULL() !NULL() !NULL() !NULL(), id_s=>NULL() !< diagnostic IDs for temperature and salinity - integer, dimension(:), pointer :: id_u=>NULL(), id_v=>NULL() !< diagnostic IDs for zonal and meridional velocity + integer, dimension(:), pointer :: id_t=>NULL(), id_s=>NULL() !< diagnostic IDs for temperature and salinity + integer, dimension(:), pointer :: id_u=>NULL(), id_v=>NULL() !< diagnostic IDs for zonal and meridional velocity integer, dimension(:), pointer :: id_ssh=>NULL() !< diagnostic IDs for SSH end type OCEAN_CONTROL_STRUCT !> Profile type, public :: ocean_profile_type integer :: variable !< variable ids are defined by the ocean_types module (e.g. TEMP_ID, SALT_ID) - integer :: inst_type !< instrument types are defined by platform class (e.g. MOORING, DROP, etc.) and instrument type (XBT, CDT, etc.) + integer :: inst_type !< instrument types are defined by platform class + !! (e.g. MOORING, DROP, etc.) and instrument type (XBT, CDT, etc.) integer :: nvar !< number of observations types associated with the current profile real :: project !< e.g. FGGE, COARE, ACCE, ... real :: probe !< MBT, XBT, drifting buoy @@ -99,7 +100,8 @@ module ocean_da_types_mod type(time_type) :: time integer :: yyyy integer :: mmdd - !type(time_type), pointer :: Model_time ! each profile can be associated with a first-guess field with an associated time and grid + !type(time_type), pointer :: Model_time ! each profile can be associated + ! with a first-guess field with an associated time and grid !type(grid_type), pointer :: Model_grid real :: i_index, j_index ! model longitude and latitude indices respectively real, dimension(:), pointer :: k_index ! model depth indices diff --git a/config_src/external/ODA_hooks/write_ocean_obs.F90 b/config_src/external/ODA_hooks/write_ocean_obs.F90 index 468698d475..86dcdbab4b 100644 --- a/config_src/external/ODA_hooks/write_ocean_obs.F90 +++ b/config_src/external/ODA_hooks/write_ocean_obs.F90 @@ -31,7 +31,7 @@ integer function open_profile_file(name, nvar, grid_lon, grid_lat,thread,fset) real, dimension(:), optional, intent(in) :: grid_lon !< Longitude [degreeE] real, dimension(:), optional, intent(in) :: grid_lat !< Latitude [degreeN] integer, intent(in), optional :: thread !< Thread - integer, intent(in), optional :: fset !< File set + integer, intent(in), optional :: fset !< File set open_profile_file=-1 end function open_profile_file diff --git a/docs/Doxyfile_nortd b/docs/Doxyfile_nortd index e07ce4f0b6..76b66b9dd3 100644 --- a/docs/Doxyfile_nortd +++ b/docs/Doxyfile_nortd @@ -794,7 +794,9 @@ INPUT = ../src \ front_page.md \ ../config_src/solo_driver \ ../config_src/dynamic_symmetric - ../config_src/coupled_driver/ocean_model_MOM.F90 + ../config_src/external + ../config_src/coupled_driver + # 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 diff --git a/docs/Doxyfile_rtd b/docs/Doxyfile_rtd index 652f46f076..7a74004d19 100644 --- a/docs/Doxyfile_rtd +++ b/docs/Doxyfile_rtd @@ -783,8 +783,8 @@ WARN_LOGFILE = doxygen.log INPUT = ../src \ ../config_src/solo_driver \ ../config_src/dynamic_symmetric \ - ../config_src/coupled_driver/coupler_util.F90 \ - ../config_src/coupled_driver/ocean_model_MOM.F90 + ../config_src/external \ + ../config_src/coupled_driver # 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 From 9f62a8f11a1b41f96a1d555dcd44e5e9adf23e46 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 19 Jun 2020 21:59:17 +0000 Subject: [PATCH 05/91] Use FMS tag 2019.01.02 in .testing - This version of FMS is a prerequisite to updating calls to FMS ready to try FMS2 I/O behind NOAA-GFDL/SIS2#117 and #1033 --- .testing/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.testing/Makefile b/.testing/Makefile index 5d233d5fb0..29f39e84f1 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -20,7 +20,7 @@ MKMF := $(abspath $(DEPS)/mkmf/bin/mkmf) # FMS framework FMS_URL ?= https://github.com/NOAA-GFDL/FMS.git -FMS_COMMIT ?= 2019.01.01 +FMS_COMMIT ?= 2019.01.02 FMS := $(DEPS)/fms #--- From 146e5c40dcd39a884e6de4b04c8ba37c4c50a09c Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Mon, 22 Jun 2020 09:52:36 -0400 Subject: [PATCH 06/91] Doxygen for DA hooks --- .../external/ODA_hooks/ocean_da_core.F90 | 85 +++--------- .../external/ODA_hooks/ocean_da_types.F90 | 129 ++++++------------ .../external/ODA_hooks/write_ocean_obs.F90 | 14 +- src/framework/MOM_domains.F90 | 1 + src/ocean_data_assim/MOM_oda_driver.F90 | 29 +--- 5 files changed, 71 insertions(+), 187 deletions(-) diff --git a/config_src/external/ODA_hooks/ocean_da_core.F90 b/config_src/external/ODA_hooks/ocean_da_core.F90 index 90004bd9d5..769e44b2aa 100644 --- a/config_src/external/ODA_hooks/ocean_da_core.F90 +++ b/config_src/external/ODA_hooks/ocean_da_core.F90 @@ -1,67 +1,41 @@ !> A set of dummy interfaces for compiling the MOM6 DA driver code. module ocean_da_core_mod -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -! This module contains a set of dummy interfaces for compiling the MOM6 DA -! driver code. These interfaces are not finalized and will be replaced by supported -! interfaces at some later date. -! -! 3/22/18 -! matthew.harrison@noaa.gov -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - use mpp_domains_mod, only : domain2d - use time_manager_mod, only : time_type, set_time, get_date + ! MOM modules + use MOM_domains, only : MOM_domain_type, domain2D + use MOM_time_manager, only : time_type, set_time, get_date ! ODA_tools modules use ocean_da_types_mod, only : ocean_profile_type, grid_type - + use kdtree, only : kd_root implicit none private - public :: ocean_da_core_init, open_profile_dataset - public :: get_profiles, copy_profiles + public :: ocean_da_core_init + public :: get_profiles contains - !> Initialize ODA - subroutine ocean_da_core_init(Domain, T_grid, Profiles, model_time) - type(domain2d), pointer, intent(in) :: Domain !< MOM type for the local domain` - type(grid_type), pointer, intent(in) :: T_grid !< MOM grid type for the local domain - type(ocean_profile_type), pointer :: Profiles - !< This is an unstructured recursive list of profiles - !< which are either within the localized domain corresponding - !< to the Domain argument, or the global profile list - type(time_type), intent(in) :: model_time !< Model time + !> Initializes the MOM6 DA driver code. + subroutine ocean_da_core_init(Domain, global_grid, Profiles, model_time) + type(domain2D), pointer, intent(in) :: Domain !< A MOM domain type + type(grid_type), pointer, intent(in) :: global_grid !< The global ODA horizontal grid type + type(ocean_profile_type), pointer :: Profiles !< This is an unstructured recursive list of profiles + !! which are either within the localized domain corresponding + !! to the Domain argument, or the global profile list (type). + type(time_type), intent(in) :: model_time !< The current model time type. - Profiles=>NULL() - return - end subroutine ocean_da_core_init - !> Open a profile dataset - subroutine open_profile_dataset(Profiles, Domain, T_grid, & - filename, time_start, time_end, obs_variable, localize) - type(ocean_profile_type), pointer :: Profiles - !< This is an unstructured recursive list of profiles - !< which are either within the localized domain corresponding - !< to the Domain argument, or the global profile list - type(domain2d), pointer, intent(in) :: Domain !< MOM type for the local domain - type(grid_type), pointer, intent(in) :: T_grid !< MOM grid type for the local domain - character(len=*), intent(in) :: filename !< filename containing profile data - type(time_type), intent(in) :: time_start, time_end !< start and end times for the analysis - integer, intent(in), optional :: obs_variable !< If present, then extract corresponding data - !< from file, otherwise, extract all available data which. - logical, intent(in), optional :: localize !< Localize the observations to the current computational domain + Profiles=>NULL() return + end subroutine ocean_da_core_init - end subroutine open_profile_dataset - !> Get profiles obs relevant to current analysis interval + !> Get profiles obs within the current analysis interval subroutine get_profiles(model_time, Profiles, Current_profiles) - type(time_type), intent(in) :: model_time - type(ocean_profile_type), pointer :: Profiles - type(ocean_profile_type), pointer :: Current_profiles + type(time_type), intent(in) :: model_time !< The current analysis time. + type(ocean_profile_type), pointer :: Profiles !< The full recursive list of profiles. + type(ocean_profile_type), pointer :: Current_profiles !< A returned list of profiles for the + !! current analysis step. Profiles=>NULL() Current_Profiles=>NULL() @@ -69,22 +43,5 @@ subroutine get_profiles(model_time, Profiles, Current_profiles) return end subroutine get_profiles - !> Copy profiles at current analysis step from a linked list to an array - !! feasible now since the number of localized current profiles is small - subroutine copy_profiles(Current_profiles, Profiles) - type(ocean_profile_type), pointer :: Current_profiles - type(ocean_profile_type), pointer, dimension(:) :: Profiles - - return - - end subroutine copy_profiles - - !> Copy observations - subroutine copy_obs(obs_in, obs_out) - type(ocean_profile_type), pointer :: obs_in - type(ocean_profile_type), pointer :: obs_out - - return - end subroutine copy_obs end module ocean_da_core_mod diff --git a/config_src/external/ODA_hooks/ocean_da_types.F90 b/config_src/external/ODA_hooks/ocean_da_types.F90 index 22041ce76b..407342966e 100644 --- a/config_src/external/ODA_hooks/ocean_da_types.F90 +++ b/config_src/external/ODA_hooks/ocean_da_types.F90 @@ -1,127 +1,82 @@ -!> This module contains a set of data structures and interfaces for compiling the MOM6 DA -!! driver code. +!> Dummy aata structures and methods for ocean data assimilation. module ocean_da_types_mod -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -! This module contains a set of data structures and interfaces for compiling the MOM6 DA -! driver code. This code is not yet finalized and will be replaced by supported -! software at some later date. -! -! 3/22/18 -! matthew.harrison@noaa.gov -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -#ifndef MAX_LEVS_FILE_ -#define MAX_LEVS_FILE_ 50 -#endif -#ifndef MAX_LINKS_ -#define MAX_LINKS_ 100 -#endif - -!============================================================ -! This module contains type declarations and default values -! for oda modules. -!============================================================ - -! Contact: Matthew.Harrison@noaa.gov and Feiyu.Lu@noaa.gov - - use time_manager_mod, only : time_type - !use obs_tools_mod, only : obs_def_type - !use mpp_domains_mod, only : domain2d + use MOM_time_manager, only : time_type implicit none private - integer, parameter, public :: MAX_LEVELS_FILE = MAX_LEVS_FILE_ !< Controls record length for optimal storage - integer, parameter, public :: MAX_LINKS = MAX_LINKS_ !< Maximum number of records per profile for storage for profiles - integer, parameter, public :: UNKNOWN = 0 - integer, save, public :: TEMP_ID = 1 - integer, save, public :: SALT_ID = 2 - real, parameter, public :: MISSING_VALUE = -1.e10 - - !> Type for ocean state in DA space (same decomposition and vertical grid) + !> Example type for ocean ensemble DA state type, public :: OCEAN_CONTROL_STRUCT integer :: ensemble_size - real, pointer, dimension(:,:,:) :: SSH=>NULL() !NULL() !NULL() !NULL() !NULL() !NULL() !NULL() !NULL(), id_s=>NULL() !< diagnostic IDs for temperature and salinity - integer, dimension(:), pointer :: id_u=>NULL(), id_v=>NULL() !< diagnostic IDs for zonal and meridional velocity - integer, dimension(:), pointer :: id_ssh=>NULL() !< diagnostic IDs for SSH end type OCEAN_CONTROL_STRUCT - !> Profile + !> Example of a profile type type, public :: ocean_profile_type - integer :: variable !< variable ids are defined by the ocean_types module (e.g. TEMP_ID, SALT_ID) - integer :: inst_type !< instrument types are defined by platform class - !! (e.g. MOORING, DROP, etc.) and instrument type (XBT, CDT, etc.) - integer :: nvar !< number of observations types associated with the current profile - real :: project !< e.g. FGGE, COARE, ACCE, ... - real :: probe !< MBT, XBT, drifting buoy - real :: ref_inst !< instrument (thermograph, hull sensor, ...) - integer :: wod_cast_num !< NODC world ocean dataset unique id - real :: fix_depth !< adjust profile depths (for XBT drop rate corrections) - real :: ocn_vehicle !< ocean vehicle type - real :: database_id !< a unique profile id + integer :: inst_type !< A numeric code indicating the type of instrument (e.g. ARGO drifter, CTD, ...) + logical :: initialized !< a True value indicates that this profile has been allocated for use + logical :: colocated !< a True value indicated that the measurements of (num_variables) data are colocated in space-time + integer :: ensemble_size !< size of the ensemble of model states used in association with this profile + integer :: num_variables !< number of measurement types associated with this profile. + integer, pointer, dimension(:) :: var_id !< variable ids are defined by the ocean_types module + integer :: platform !< platform types are defined by platform class (e.g. MOORING, DROP, etc.) and instrument type (XBT, CDT, etc.) integer :: levels !< number of levels in the current profile - integer :: basin_mask !<1:Southern Ocean, 2:Atlantic Ocean, 3:Pacific Ocean, + integer :: basin_mask !< 1:Southern Ocean, 2:Atlantic Ocean, 3:Pacific Ocean, !! 4:Arctic Ocean, 5:Indian Ocean, 6:Mediterranean Sea, 7:Black Sea, - !! 8:Hudson Bay, 9:Baltic Sea, 10:Red Sea, 11:Persian Gulf + !! 8:Hudson Bay, 9:Baltic Sea, 10:Red Sea, 11:Persian Gulf integer :: profile_flag !< an overall flag for the profile - integer :: profile_flag_s !< an overall flag for the profile salinity real :: lat, lon !< latitude and longitude (degrees E and N) logical :: accepted !< logical flag to disable a profile - integer :: nlinks !< number of links used to construct the profile (when reading from disk) + type(time_type) :: time_window !< The time window associated with this profile [s] + real, pointer, dimension(:) :: obs_error !< The observation error by variable + real :: loc_dist !< The impact radius of this observation (m) type(ocean_profile_type), pointer :: next=>NULL() !< all profiles are stored as linked list. type(ocean_profile_type), pointer :: prev=>NULL() type(ocean_profile_type), pointer :: cnext=>NULL() ! current profiles are stored as linked list. type(ocean_profile_type), pointer :: cprev=>NULL() integer :: nbr_xi, nbr_yi ! nearest neighbor model gridpoint for the profile real :: nbr_dist ! distance to nearest neighbor model gridpoint - real, dimension(:), pointer :: depth - real, dimension(:), pointer :: data_t => NULL(), data_s => NULL() - real, dimension(:), pointer :: data - !integer, dimension(:), pointer :: flag_t - !integer, dimension(:), pointer :: flag_s ! level-by-level flags for salinity - !::sdu:: For now ECDA use flag as a logical, will likely change in future releases. - logical, dimension(:), pointer :: flag - real :: temp_err, salt_err ! measurement error - !real, dimension(:), pointer :: ms_t ! ms temperature by level - !real, dimension(:), pointer :: ms_s ! ms salinity by level - real, dimension(:), pointer :: ms_inv => NULL() - real, dimension(:), pointer :: ms => NULL() -! type(obs_def_type), dimension(:), pointer :: obs_def => NULL() - type(time_type) :: time - integer :: yyyy - integer :: mmdd - !type(time_type), pointer :: Model_time ! each profile can be associated - ! with a first-guess field with an associated time and grid - !type(grid_type), pointer :: Model_grid - real :: i_index, j_index ! model longitude and latitude indices respectively - real, dimension(:), pointer :: k_index ! model depth indices - type(time_type) :: tdiff ! positive difference between model time and observation time + logical :: compute !< profile is within current compute domain + real, dimension(:,:), pointer :: depth => NULL() !< depth of measurement [m] + real, dimension(:,:), pointer :: data => NULL() !< data by variable type + integer, dimension(:,:), pointer :: flag => NULL() !< flag by depth and variable type + real, dimension(:,:,:), pointer :: forecast => NULL() !< ensemble member first guess + real, dimension(:,:,:), pointer :: analysis => NULL() !< ensemble member analysis + type(forward_operator_type), pointer :: obs_def => NULL() !< observation forward operator + type(time_type) :: time !< profile time type + real :: i_index, j_index !< model longitude and latitude indices respectively + real, dimension(:,:), pointer :: k_index !< model depth indices + type(time_type) :: tdiff !< difference between model time and observation time + character(len=128) :: filename end type ocean_profile_type - !> Grid information for ODA purposes, including arrays of - !! lat, lon, depth, thickness, basin and land mask + !> Example forward operator type. + type, public :: forward_operator_type + integer :: num + integer, dimension(2) :: state_size !< for + integer, dimension(:), pointer :: state_var_index !< for flattened data + integer, dimension(:), pointer :: i_index !< i-dimension index + integer, dimension(:), pointer :: j_index !< j-dimension index + real, dimension(:), pointer :: coef + end type forward_operator_type + + !> Grid type for DA type, public :: grid_type real, pointer, dimension(:,:) :: x=>NULL(), y=>NULL() - !real, pointer, dimension(:,:) :: x_bound=>NULL(), y_bound=>NULL() - !real, pointer, dimension(:,:) :: dx=>NULL(), dy=>NULL() real, pointer, dimension(:,:,:) :: z=>NULL() real, pointer, dimension(:,:,:) :: h=>NULL() - !real, pointer, dimension(:) :: z_bound=>NULL() - !real, pointer, dimension(:) :: dz => NULL() real, pointer, dimension(:,:) :: basin_mask => NULL() real, pointer, dimension(:,:,:) :: mask => NULL() - !type(domain2d), pointer :: Dom ! FMS domain type - !logical :: cyclic + real, pointer, dimension(:,:) :: bathyT => NULL() + logical :: tripolar_N integer :: ni, nj, nk end type grid_type diff --git a/config_src/external/ODA_hooks/write_ocean_obs.F90 b/config_src/external/ODA_hooks/write_ocean_obs.F90 index 86dcdbab4b..a2c41b58d6 100644 --- a/config_src/external/ODA_hooks/write_ocean_obs.F90 +++ b/config_src/external/ODA_hooks/write_ocean_obs.F90 @@ -1,26 +1,16 @@ !> Dummy interfaces for writing ODA data module write_ocean_obs_mod -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -! This module contains a set of dummy interfaces for compiling the MOM6 DA -! driver code. These interfaces are not finalized and will be replaced by supported -! interfaces at some later date. -! -! 3/22/18 -! matthew.harrison@noaa.gov -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! use ocean_da_types_mod, only : ocean_profile_type - use time_manager_mod, only : time_type, get_time, set_date, operator ( - ) + use MOM_time_manager, only : time_type, get_time, set_date implicit none private public :: open_profile_file, write_profile, close_profile_file, & - write_ocean_obs_init + write_ocean_obs_init contains diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index 2f31d50607..13bba88271 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -45,6 +45,7 @@ module MOM_domains 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 +public :: domain2D !> Do a halo update on an array interface pass_var diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index 089e1fc422..acc316cce4 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -1,9 +1,8 @@ !> Interfaces for MOM6 ensembles and data assimilation. module MOM_oda_driver_mod -! 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 + ! This file is part of MOM6. see LICENSE.md for the license. + 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 @@ -250,20 +249,6 @@ subroutine init_oda(Time, G, GV, CS) 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) @@ -364,10 +349,6 @@ subroutine set_prior_tracer(Time, G, GV, h, tv, CS) 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) @@ -478,13 +459,13 @@ subroutine init_ocean_ensemble(CS,Grid,GV,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%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 +! allocate(CS%id_ssh(ens_size));CS%id_ssh(:)=-1 return end subroutine init_ocean_ensemble From 804bf1f0c7208ea76af9ea2b5c79cb9346fb9ea1 Mon Sep 17 00:00:00 2001 From: Graeme MacGilchrist Date: Tue, 23 Jun 2020 17:05:14 -0400 Subject: [PATCH 07/91] added diagnostics for partial derivative of density wrt temperature and salinity --- src/diagnostics/MOM_diagnostics.F90 | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index e08c920c60..b2848781de 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -134,6 +134,7 @@ module MOM_diagnostics integer :: id_pbo = -1 integer :: id_thkcello = -1, id_rhoinsitu = -1 integer :: id_rhopot0 = -1, id_rhopot2 = -1 + integer :: id_drho_dT = -1, id_drho_dS = -1 integer :: id_h_pre_sync = -1 !>@} !> The control structure for calculating wave speed. @@ -619,6 +620,22 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & enddo if (CS%id_rhoinsitu > 0) call post_data(CS%id_rhoinsitu, Rcv, CS%diag) endif + + if (CS%id_drho_dT > 0 .or. CS%id_drho_dS > 0) then + !$OMP parallel do default(none) shared(tv,Rcv,is,ie,js,je,nz,pressure_1d,h,GV) + do j=js,je + pressure_1d(:) = 0. ! Start at p=0 Pa at surface + do k=1,nz + pressure_1d(:) = pressure_1d(:) + 0.5 * h(:,j,k) * GV%H_to_Pa ! Pressure in middle of layer k + ! To avoid storing more arrays, put drho_dT into Rcv, and drho_dS into work3d + call calculate_density_derivs(tv%T(:,j,k),tv%S(:,j,k),pressure_1d, & + Rcv(:,j,k),work_3d(:,j,k),is,ie-is+1, tv%eqn_of_state) + pressure_1d(:) = pressure_1d(:) + 0.5 * h(:,j,k) * GV%H_to_Pa ! Pressure at bottom of layer k + enddo + enddo + if (CS%id_drho_dT > 0) call post_data(CS%id_drho_dT, Rcv, CS%diag) + if (CS%id_drho_dS > 0) call post_data(CS%id_drho_dS, work_3d, CS%diag) + endif endif if ((CS%id_cg1>0) .or. (CS%id_Rd1>0) .or. (CS%id_cfl_cg1>0) .or. & @@ -1600,6 +1617,10 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag 'Potential density referenced to 2000 dbar', 'kg m-3', conversion=US%R_to_kg_m3) CS%id_rhoinsitu = register_diag_field('ocean_model', 'rhoinsitu', diag%axesTL, Time, & 'In situ density', 'kg m-3', conversion=US%R_to_kg_m3) + CS%id_drho_dT = register_diag_field('ocean_model', 'drho_dT', diag%axesTL, Time, & + 'Partial derivative of rhoinsitu with respect to temperature (alpha)', 'kg m-3 degC-1') + CS%id_drho_dS = register_diag_field('ocean_model', 'drho_dS', diag%axesTL, Time, & + 'Partial derivative of rhoinsitu with respect to salinity (beta)', 'kg^2 g-1 m-3') CS%id_du_dt = register_diag_field('ocean_model', 'dudt', diag%axesCuL, Time, & 'Zonal Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) From 3f0f0380286c269b3ed83fa02ff8e1d22064e7a5 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 23 Jun 2020 21:32:09 -0400 Subject: [PATCH 08/91] Remove "-B" flag from pipeline "make test" - The -B option forced make to make all targets. This was to ensure that everything was remade when work in a shared work space which is no longer the case. We always have a clean work space in these tests and in order to invoke make twice to handle srun errors we can't use the -B option anymore. --- .gitlab-ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 02c6d15877..1622ae9886 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -116,7 +116,7 @@ run: - time tar zxf $CACHE_DIR/build-intel-repro-$CI_PIPELINE_ID.tgz - time tar zxf $CACHE_DIR/build-pgi-repro-$CI_PIPELINE_ID.tgz # time tar zxf $CACHE_DIR/build-gnu-debug-$CI_PIPELINE_ID.tgz - - (echo '#!/bin/tcsh';echo 'make -f MRS/Makefile.tests all -B') > job.sh + - (echo '#!/bin/tcsh';echo 'make -f MRS/Makefile.tests all') > job.sh - sbatch --clusters=c3,c4 --nodes=29 --time=0:34:00 --account=gfdl_o --qos=debug --job-name=mom6_regressions --output=log.$CI_PIPELINE_ID --wait job.sh - cat log.$CI_PIPELINE_ID - test -f restart_results_gnu.tar.gz From e0071f1e9d30d30ed29265ea3e310c6d1575240f Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 24 Jun 2020 09:18:18 -0400 Subject: [PATCH 09/91] Adjusted comments in ODA hooks to fit line length --- config_src/external/ODA_hooks/ocean_da_types.F90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/config_src/external/ODA_hooks/ocean_da_types.F90 b/config_src/external/ODA_hooks/ocean_da_types.F90 index 407342966e..bc5af1d782 100644 --- a/config_src/external/ODA_hooks/ocean_da_types.F90 +++ b/config_src/external/ODA_hooks/ocean_da_types.F90 @@ -23,11 +23,13 @@ module ocean_da_types_mod type, public :: ocean_profile_type integer :: inst_type !< A numeric code indicating the type of instrument (e.g. ARGO drifter, CTD, ...) logical :: initialized !< a True value indicates that this profile has been allocated for use - logical :: colocated !< a True value indicated that the measurements of (num_variables) data are colocated in space-time + logical :: colocated !< a True value indicated that the measurements of (num_variables) data are + !! co-located in space-time integer :: ensemble_size !< size of the ensemble of model states used in association with this profile integer :: num_variables !< number of measurement types associated with this profile. integer, pointer, dimension(:) :: var_id !< variable ids are defined by the ocean_types module - integer :: platform !< platform types are defined by platform class (e.g. MOORING, DROP, etc.) and instrument type (XBT, CDT, etc.) + integer :: platform !< platform types are defined by platform class (e.g. MOORING, DROP, etc.) + !! and instrument type (XBT, CDT, etc.) integer :: levels !< number of levels in the current profile integer :: basin_mask !< 1:Southern Ocean, 2:Atlantic Ocean, 3:Pacific Ocean, !! 4:Arctic Ocean, 5:Indian Ocean, 6:Mediterranean Sea, 7:Black Sea, From a7ab5296dfdac7cd3536953955274af14c79e05a Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Mon, 23 Mar 2020 14:58:00 -0400 Subject: [PATCH 10/91] This is the minimum required update to use 2020.01 FMS & FMScoupler - Adding domain position arguments to diag_axis_init calls --- src/framework/MOM_diag_mediator.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 368a6b773b..2a71e7cda5 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -33,7 +33,7 @@ module MOM_diag_mediator use diag_axis_mod, only : get_diag_axis_name use diag_data_mod, only : null_axis_id use diag_manager_mod, only : diag_manager_init, diag_manager_end -use diag_manager_mod, only : send_data, diag_axis_init, diag_field_add_attribute +use diag_manager_mod, only : send_data, diag_axis_init, EAST, NORTH, diag_field_add_attribute ! The following module is needed for PGI since the following line does not compile with PGI 6.5.0 ! was: use diag_manager_mod, only : register_diag_field_fms=>register_diag_field use MOM_diag_manager_wrapper, only : register_diag_field_fms @@ -365,14 +365,14 @@ subroutine set_axes_info(G, GV, US, param_file, diag_cs, set_vertical) ! 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) + 'q point nominal longitude', Domain2=G%Domain%mpp_domain, domain_position=EAST) id_yq = diag_axis_init('yq', G%gridLatB(G%jsgB:G%jegB), G%y_axis_units, 'y', & - 'q point nominal latitude', Domain2=G%Domain%mpp_domain) + 'q point nominal latitude', Domain2=G%Domain%mpp_domain, domain_position=NORTH) else id_xq = diag_axis_init('xq', G%gridLonB(G%isg:G%ieg), G%x_axis_units, 'x', & - 'q point nominal longitude', Domain2=G%Domain%mpp_domain) + 'q point nominal longitude', Domain2=G%Domain%mpp_domain, domain_position=EAST) id_yq = diag_axis_init('yq', G%gridLatB(G%jsg:G%jeg), G%y_axis_units, 'y', & - 'q point nominal latitude', Domain2=G%Domain%mpp_domain) + 'q point nominal latitude', Domain2=G%Domain%mpp_domain, domain_position=NORTH) endif id_xh = diag_axis_init('xh', G%gridLonT(G%isg:G%ieg), G%x_axis_units, 'x', & 'h point nominal longitude', Domain2=G%Domain%mpp_domain) From 2719400c5a96ff69e3d347f689be6cb3a86b27e5 Mon Sep 17 00:00:00 2001 From: Graeme MacGilchrist Date: Wed, 24 Jun 2020 22:44:52 -0400 Subject: [PATCH 11/91] fixes import of dens deriv function --- src/diagnostics/MOM_diagnostics.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index b2848781de..7d390159bb 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -15,7 +15,7 @@ module MOM_diagnostics use MOM_diag_mediator, only : diag_save_grids, diag_restore_grids, diag_copy_storage_to_diag use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type use MOM_domains, only : To_North, To_East -use MOM_EOS, only : calculate_density, int_density_dz, EOS_domain +use MOM_EOS, only : calculate_density, calculate_density_derivs, int_density_dz, EOS_domain use MOM_EOS, only : gsw_sp_from_sr, gsw_pt_from_ct use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_version, param_file_type From 424d30db8b7230cc9d63f2b35d6b33cfe97c2396 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 25 Jun 2020 15:32:18 -0400 Subject: [PATCH 12/91] Testing: Removed environment flag checks Due to unpredictable conflicts with flags, the realization that flag testing would launch jobs on Slurm environment, and the fact that Slurm launchers, OpenMPI, and MPICH all appear to pass environment variables on default, we now just assume that "env=val $(MPIRUN)" will pass an environment variable to the MPI job in all cases. This may not be true on all systems, but for now we will assume this works. --- .testing/Makefile | 30 +++++++++--------------------- 1 file changed, 9 insertions(+), 21 deletions(-) diff --git a/.testing/Makefile b/.testing/Makefile index 29f39e84f1..daac0802f2 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -268,18 +268,6 @@ $(eval $(call CMP_RULE,regression,symmetric target)) #--- # Test run output files -# Generalized MPI environment variable support -# XXX: Using `-env` in the MPICH test can erroneously producing an `nv` file. -# $(1): Environment variables -ifeq ($(shell $(MPIRUN) -x tmp=1 true 2> /dev/null ; echo $$?), 0) - MPIRUN_CMD=$(MPIRUN) $(if $(1),-x $(1),) -else ifeq ($(shell $(MPIRUN) -env tmp=1 true 2> /dev/null ; echo $$? ; rm -f nv), 0) - MPIRUN_CMD=$(MPIRUN) $(if $(1),-env $(1),) -else - MPIRUN_CMD=$(1) $(MPIRUN) -endif - - # Rule to build work//{ocean.stats,chksum_diag}. # $(1): Test configuration name # $(2): Executable type @@ -297,20 +285,20 @@ work/%/$(1)/ocean.stats work/%/$(1)/chksum_diag: build/$(2)/MOM6 mkdir -p $$(@D)/RESTART echo -e "$(4)" > $$(@D)/MOM_override cd $$(@D) \ - && $$(call MPIRUN_CMD,$(5)) -n $(6) ../../../$$< 2> std.err > std.out \ + && $(5) $(MPIRUN) -n $(6) ../../../$$< 2> std.err > std.out \ || !( \ mkdir -p ../../../results/$$*/ ; \ cat std.out | tee ../../../results/$$*/std.$(1).out | tail -20 ; \ - cat std.err | tee ../../../results/$$*/std.$(1).err | tail -20 ; \ - rm ocean.stats chksum_diag ; \ - echo -e "${FAIL}: $$*.$(1) failed at runtime." \ + cat std.err | tee ../../../results/$$*/std.$(1).err | tail -20 ; \ + rm ocean.stats chksum_diag ; \ + echo -e "${FAIL}: $$*.$(1) failed at runtime." \ ) @echo -e "${DONE}: $$*.$(1); no runtime errors." if [ $(3) ]; then \ mkdir -p results/$$* ; \ bash <(curl -s https://codecov.io/bash) -n $$@ \ > work/$$*/codecov.$(1).out \ - 2> work/$$*/codecov.$(1).err ; \ + 2> work/$$*/codecov.$(1).err ; \ fi endef @@ -354,8 +342,8 @@ work/%/restart/ocean.stats: build/symmetric/MOM6 cd $(@D) && $(MPIRUN) -n 1 ../../../$< 2> std1.err > std1.out \ || !( \ cat std1.out | tee ../../../results/$*/std.restart1.out | tail ; \ - cat std1.err | tee ../../../results/$*/std.restart1.err | tail ; \ - echo -e "${FAIL}: $*.restart failed at runtime." \ + cat std1.err | tee ../../../results/$*/std.restart1.err | tail ; \ + echo -e "${FAIL}: $*.restart failed at runtime." \ ) # Setup the next inputs cd $(@D) && rm -rf INPUT && mv RESTART INPUT @@ -365,8 +353,8 @@ work/%/restart/ocean.stats: build/symmetric/MOM6 cd $(@D) && $(MPIRUN) -n 1 ../../../$< 2> std2.err > std2.out \ || !( \ cat std2.out | tee ../../../results/$*/std.restart2.out | tail ; \ - cat std2.err | tee ../../../results/$*/std.restart2.err | tail ; \ - echo -e "${FAIL}: $*.restart failed at runtime." \ + cat std2.err | tee ../../../results/$*/std.restart2.err | tail ; \ + echo -e "${FAIL}: $*.restart failed at runtime." \ ) # TODO: Restart checksum diagnostics From c95421fe281ca79b7f50dca10e6f35a376f3ed20 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 26 Jun 2020 17:16:29 -0400 Subject: [PATCH 13/91] (*)Corrected halo size in EOS call if VERTEX_SHEAR=T Corrected halo size in density derivative calculations in smoothed_dRdT_dRdS This fixes an i-parallelization problem that was recently introduced (as a part of MOM6 PR#1089) when VERTEX_SHEAR is True, and closes MOM6 issue #1146. All answers in the existing MOM6-examples test suite are bitwise identical, but this does change (correct) answers when VERTEX_SHEAR is true. --- src/parameterizations/vertical/MOM_full_convection.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/vertical/MOM_full_convection.F90 b/src/parameterizations/vertical/MOM_full_convection.F90 index 1783955d53..3be6628b14 100644 --- a/src/parameterizations/vertical/MOM_full_convection.F90 +++ b/src/parameterizations/vertical/MOM_full_convection.F90 @@ -408,7 +408,7 @@ subroutine smoothed_dRdT_dRdS(h, tv, Kddt, dR_dT, dR_dS, G, GV, US, j, p_surf, h else do i=is,ie ; pres(i) = 0.0 ; enddo endif - EOSdom(:) = EOS_domain(G%HI) + EOSdom(:) = EOS_domain(G%HI, halo) call calculate_density_derivs(T_f(:,1), S_f(:,1), pres, dR_dT(:,1), dR_dS(:,1), tv%eqn_of_state, EOSdom) do i=is,ie ; pres(i) = pres(i) + h(i,j,1)*(GV%H_to_RZ*GV%g_Earth) ; enddo do K=2,nz From 7bf4a30d3add70e1a6c6531c96bda536e98d492f Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Sat, 27 Jun 2020 23:25:40 -0400 Subject: [PATCH 14/91] Fixing openmp issues with FMS2020 cpu affinity - FMS2020 has newer cpu affinity work. These are mostly to fix the issues with thread placing and hyperthreadng under slurm on gaea. But it also works on Orion. - The new affinity module simplifies the thread-placing calls in the component models. - The name of some functions has changed, that's the reason for crashes like: FATAL: input domain does not have an io_domain. - This update fixes those issues. - openmp runs with 1 and 2 threads gives the same answers as non-openmp - NOTE: I don't rememer why we put the thread placing calls in MOM_domains.F90 They look as unnecessary and the whole #ifndef NOT_SET_AFFINITY block can probably be removed. ocean_nthreads is either set in coupler or solo_driver. --- config_src/solo_driver/MOM_driver.F90 | 25 ++++++++----------------- src/framework/MOM_domains.F90 | 26 +++++--------------------- 2 files changed, 13 insertions(+), 38 deletions(-) diff --git a/config_src/solo_driver/MOM_driver.F90 b/config_src/solo_driver/MOM_driver.F90 index dfdfeff8ef..6e5115bc62 100644 --- a/config_src/solo_driver/MOM_driver.F90 +++ b/config_src/solo_driver/MOM_driver.F90 @@ -66,6 +66,7 @@ program MOM_main use ensemble_manager_mod, only : ensemble_pelist_setup use mpp_mod, only : set_current_pelist => mpp_set_current_pelist use time_interp_external_mod, only : time_interp_external_init + use fms_affinity_mod, only : fms_affinity_init, fms_affinity_set,fms_affinity_get use MOM_ice_shelf, only : initialize_ice_shelf, ice_shelf_end, ice_shelf_CS use MOM_ice_shelf, only : shelf_calc_flux, add_shelf_forces, ice_shelf_save_restart @@ -207,11 +208,10 @@ program MOM_main character(len=40) :: mod_name = "MOM_main (MOM_driver)" ! This module's name. integer :: ocean_nthreads = 1 - integer :: ncores_per_node = 36 logical :: use_hyper_thread = .false. - integer :: omp_get_num_threads,omp_get_thread_num,get_cpu_affinity,adder,base_cpu + integer :: omp_get_num_threads,omp_get_thread_num namelist /ocean_solo_nml/ date_init, calendar, months, days, hours, minutes, seconds,& - ocean_nthreads, ncores_per_node, use_hyper_thread + ocean_nthreads, use_hyper_thread !===================================================================== @@ -252,22 +252,13 @@ program MOM_main endif endif +!$ call fms_affinity_init +!$ call fms_affinity_set('OCEAN', use_hyper_thread, ocean_nthreads) !$ call omp_set_num_threads(ocean_nthreads) -!$ 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 -!$ else -!$ adder = ncores_per_node + omp_get_thread_num()/2 -!$ endif -!$ else -!$ adder = omp_get_thread_num() -!$ endif -!$ call set_cpu_affinity (base_cpu + adder) -!$ write(6,*) " ocean ", base_cpu, get_cpu_affinity(), adder, omp_get_thread_num(), omp_get_num_threads() +!$OMP PARALLEL +!$ write(6,*) "ocean_solo OMPthreading ", fms_affinity_get(), omp_get_thread_num(), omp_get_num_threads() !$ call flush(6) -!$OMP END PARALLEL +!$OMP END PARALLEL ! Read ocean_solo restart, which can override settings from the namelist. if (file_exists(trim(dirs%restart_input_dir)//'ocean_solo.res')) then diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index 13bba88271..24dbd0a011 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -30,6 +30,7 @@ module MOM_domains 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, CENTER use fms_io_mod, only : file_exist, parse_mask_table +use fms_affinity_mod, only : fms_affinity_init, fms_affinity_set,fms_affinity_get implicit none ; private @@ -1192,7 +1193,6 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & integer, dimension(4) :: global_indices !$ integer :: ocean_nthreads ! Number of Openmp threads !$ integer :: get_cpu_affinity, omp_get_thread_num, omp_get_num_threads -!$ integer :: omp_cores_per_node, adder, base_cpu !$ logical :: ocean_omp_hyper_thread integer :: nihalo_dflt, njhalo_dflt integer :: pe, proc_used @@ -1274,6 +1274,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & default=.false.) #ifndef NOT_SET_AFFINITY +!$ call fms_affinity_init !$OMP PARALLEL !$OMP master !$ ocean_nthreads = omp_get_num_threads() @@ -1285,27 +1286,10 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & !$ 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 fms_affinity_set('OCEAN', ocean_omp_hyper_thread, ocean_nthreads) !$ call omp_set_num_threads(ocean_nthreads) -!$ base_cpu = get_cpu_affinity() -!$OMP PARALLEL private(adder) -!$ 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_get_thread_num() -!$ endif -!$ 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 +!$ write(6,*) "MOM_domains_mod OMPthreading ", fms_affinity_get(), omp_get_thread_num(), omp_get_num_threads() +!$ call flush(6) !$ endif #endif call log_param(param_file, mdl, "!SYMMETRIC_MEMORY_", MOM_dom%symmetric, & From ccd4cbf307cdddceab8bb791ce82d4fc314d9712 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 1 Jul 2020 12:37:00 -0400 Subject: [PATCH 15/91] Testing: Explicit OpenMP CPU affinity FMS affinity operations, often used in OpenMP directives, require explicit CPU affinities such that the number of available CPUs matches the number of requested PEs. To accommodate this, we explicit configure OpenMP to use cpu=0 for our ARM tests. --- .testing/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.testing/Makefile b/.testing/Makefile index daac0802f2..bc03358649 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -310,7 +310,7 @@ $(eval $(call STAT_RULE,symmetric,symmetric,$(REPORT_COVERAGE),,,1)) $(eval $(call STAT_RULE,asymmetric,asymmetric,,,,1)) $(eval $(call STAT_RULE,target,target,,,,1)) $(eval $(call STAT_RULE,repro,repro,,,,1)) -$(eval $(call STAT_RULE,openmp,openmp,,,,1)) +$(eval $(call STAT_RULE,openmp,openmp,,,GOMP_CPU_AFFINITY=0,1)) $(eval $(call STAT_RULE,layout,symmetric,,LAYOUT=2$(,)1,,2)) $(eval $(call STAT_RULE,rotate,symmetric,,ROTATE_INDEX=True\nINDEX_TURNS=1,,1)) $(eval $(call STAT_RULE,nan,symmetric,,,MALLOC_PERTURB_=256,1)) From d64be2073796b4d1e76ddec95d713e8c8394ebc4 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 1 Jul 2020 15:05:04 -0400 Subject: [PATCH 16/91] Removed #ifdef debugging blocks Removed old debugging code in blocks of code surrounded by #ifdef statements and removed unnecessary #ifdef around other blocks of debugging code. MOM6 standards discourage the use of CPP macros except for a limited set of uses related to memory where this is unavoidable, so this commit is bringing MOM6 closer to its stated standards. All answers and output are identical. --- .../vertical/MOM_CVMix_KPP.F90 | 6 - .../vertical/MOM_kappa_shear.F90 | 272 ++---------------- .../vertical/MOM_regularize_layers.F90 | 151 +--------- 3 files changed, 26 insertions(+), 403 deletions(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index f9115b1041..e0889360b9 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -627,7 +627,6 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, & 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*US%s_to_T) @@ -635,7 +634,6 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, & call hchksum(Kt, "KPP in: Kt",G%HI,haloshift=0, scale=US%Z2_T_to_m2_s) call hchksum(Ks, "KPP in: Ks",G%HI,haloshift=0, scale=US%Z2_T_to_m2_s) endif -#endif nonLocalTrans(:,:) = 0.0 @@ -862,12 +860,10 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, & enddo ! j -#ifdef __DO_SAFETY_CHECKS__ if (CS%debug) then call hchksum(Kt, "KPP out: Kt", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) call hchksum(Ks, "KPP out: Ks", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) endif -#endif ! send diagnostics to post_data if (CS%id_OBLdepth > 0) call post_data(CS%id_OBLdepth, CS%OBLdepth, CS%diag) @@ -952,14 +948,12 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl real :: WST -#ifdef __DO_SAFETY_CHECKS__ if (CS%debug) then 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) endif -#endif ! some constants GoRho = US%L_T_to_m_s**2*US%m_to_Z * GV%g_Earth / GV%Rho0 diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index 7db9be0018..096781f8cf 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -19,9 +19,6 @@ module MOM_kappa_shear implicit none ; private #include -#ifdef use_netCDF -#include -#endif public Calculate_kappa_shear, Calc_kappa_shear_vertex, kappa_shear_init public kappa_shear_is_used, kappa_shear_at_vertex @@ -99,9 +96,6 @@ module MOM_kappa_shear ! integer :: id_clock_project, id_clock_KQ, id_clock_avg, id_clock_setup -#undef DEBUG -#undef ADD_DIAGNOSTICS - contains !> Subroutine for calculating shear-driven diffusivity and TKE in tracer columns @@ -177,15 +171,6 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & ! interpolating back to the original index space [nondim]. integer :: is, ie, js, je, i, j, k, nz, nzc - ! Diagnostics that should be deleted? -#ifdef ADD_DIAGNOSTICS - real, dimension(SZK_(GV)+1) :: & ! Additional diagnostics. - I_Ld2_1d, dz_Int_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 is = G%isc ; ie = G%iec; js = G%jsc ; je = G%jec ; nz = GV%ke use_temperature = .false. ; if (associated(tv%T)) use_temperature = .true. @@ -195,9 +180,6 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & dz_massless = 0.1*sqrt(k0dt) !$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, & -#endif !$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 @@ -295,15 +277,9 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & do K=1,nzc+1 ; kappa(K) = kappa_2d(i,K) ; enddo endif -#ifdef ADD_DIAGNOSTICS - call kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & - dz, u0xdz, v0xdz, T0xdz, S0xdz, kappa_avg, & - tke_avg, tv, CS, GV, US, I_Ld2_1d, dz_Int_1d) -#else call kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & dz, u0xdz, v0xdz, T0xdz, S0xdz, kappa_avg, & tke_avg, tv, CS, GV, US) -#endif ! call cpu_clock_begin(id_clock_setup) ! Extrapolate from the vertically reduced grid back to the original layers. @@ -329,18 +305,10 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & endif enddo endif -#ifdef ADD_DIAGNOSTICS - do K=1,nz+1 - I_Ld2_2d(i,K) = I_Ld2_1d(K) ; dz_Int_2d(i,K) = dz_Int_1d(K) - 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) = 0.0 ; tke_2d(i,K) = 0.0 -#ifdef ADD_DIAGNOSTICS - I_Ld2_2d(i,K) = 0.0 ; dz_Int_2d(i,K) = 0.0 -#endif enddo endif ; enddo ! i-loop @@ -348,9 +316,6 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & kappa_io(i,j,K) = G%mask2dT(i,j) * kappa_2d(i,K) tke_io(i,j,K) = G%mask2dT(i,j) * tke_2d(i,K) kv_io(i,j,K) = ( G%mask2dT(i,j) * kappa_2d(i,K) ) * 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 enddo ! end of j-loop @@ -362,10 +327,6 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & 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 Calculate_kappa_shear @@ -451,14 +412,6 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ 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, dz_Int_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 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. @@ -469,9 +422,6 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ 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 @@ -597,15 +547,9 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ do K=1,nzc+1 ; kappa(K) = kappa_2d(I,K,J2) ; enddo endif -#ifdef ADD_DIAGNOSTICS - call kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & - dz, u0xdz, v0xdz, T0xdz, S0xdz, kappa_avg, & - tke_avg, tv, CS, GV, US, I_Ld2_1d, dz_Int_1d) -#else call kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & dz, u0xdz, v0xdz, T0xdz, S0xdz, kappa_avg, & tke_avg, tv, CS, GV, US) -#endif ! call cpu_clock_begin(Id_clock_setup) ! Extrapolate from the vertically reduced grid back to the original layers. if (nz == nzc) then @@ -628,27 +572,16 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ endif enddo endif -#ifdef ADD_DIAGNOSTICS - do K=1,nz+1 - I_Ld2_2d(i,K) = I_Ld2_1d(K) ; dz_Int_2d(i,K) = dz_Int_1d(K) - 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) = 0.0 -#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. @@ -666,10 +599,6 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ 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 @@ -794,23 +723,10 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & ! to estimate the maximum permitted time step. I.e., ! the resolution is 1/2^dt_refinements. integer :: k, itt, itt_dt -#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, & - N2_debug, & ! A version of N2 for debugging [T-2 ~> s-2] - ksrc_av ! The average through the iterations of k_src [T-1 ~> 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 + + ! This calculation of N2 is for debugging only. + ! real, dimension(SZK_(GV)+1) :: & + ! N2_debug, & ! A version of N2 for debugging [T-2 ~> s-2] Ri_crit = CS%Rino_crit gR0 = GV%Rho0 * GV%g_Earth @@ -916,45 +832,12 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & do K=1,nzc+1 ; dbuoy_dT(K) = -g_R0 ; dbuoy_dS(K) = 0.0 ; enddo endif -#ifdef DEBUG - N2_debug(1) = 0.0 ; N2_debug(nzc+1) = 0.0 - do K=2,nzc - N2_debug(K) = max((dbuoy_dT(K) * (T0xdz(k-1)*Idz(k-1) - T0xdz(k)*Idz(k)) + & - dbuoy_dS(K) * (S0xdz(k-1)*Idz(k-1) - S0xdz(k)*Idz(k))) * & - I_dz_int(K), 0.0) - enddo - do k=1,nzc - u_it1(k,0) = u0xdz(k)*Idz(k) ; v_it1(k,0) = v0xdz(k)*Idz(k) - T_it1(k,0) = T0xdz(k)*Idz(k) ; S_it1(k,0) = S0xdz(k)*Idz(k) - enddo - do K=1,nzc+1 - kprev_it1(K,0) = kappa(K) ; kappa_it1(K,0) = kappa(K) - tke_it1(K,0) = 0.0 - N2_it1(K,0) = N2_debug(K) ; Sh2_it1(K,0) = S2(K) ; ksrc_it1(K,0) = K_src(K) - enddo - do k=nzc+1,GV%ke - u_it1(k,0) = 0.0 ; v_it1(k,0) = 0.0 - T_it1(k,0) = 0.0 ; S_it1(k,0) = 0.0 - kprev_it1(K+1,0) = 0.0 ; kappa_it1(K+1,0) = 0.0 ; tke_it1(K+1,0) = 0.0 - N2_it1(K+1,0) = 0.0 ; Sh2_it1(K+1,0) = 0.0 ; ksrc_it1(K+1,0) = 0.0 - enddo - do itt=1,max_debug_itt - dt_it1(itt) = 0.0 - do k=1,GV%ke - u_it1(k,itt) = 0.0 ; v_it1(k,itt) = 0.0 - T_it1(k,itt) = 0.0 ; S_it1(k,itt) = 0.0 - rho_it1(k,itt) = 0.0 - enddo - do K=1,GV%ke+1 - kprev_it1(K,itt) = 0.0 ; kappa_it1(K,itt) = 0.0 ; tke_it1(K,itt) = 0.0 - N2_it1(K,itt) = 0.0 ; Sh2_it1(K,itt) = 0.0 - ksrc_it1(K,itt) = 0.0 - dkappa_it1(K,itt) = 0.0 ; wt_it1(K,itt) = 0.0 - K_Q_it1(K,itt) = 0.0 ; d_dkappa_it1(K,itt) = 0.0 - enddo - enddo - do K=1,GV%ke+1 ; ksrc_av(K) = 0.0 ; enddo -#endif + ! N2_debug(1) = 0.0 ; N2_debug(nzc+1) = 0.0 + ! do K=2,nzc + ! N2_debug(K) = max((dbuoy_dT(K) * (T0xdz(k-1)*Idz(k-1) - T0xdz(k)*Idz(k)) + & + ! dbuoy_dS(K) * (S0xdz(k-1)*Idz(k-1) - S0xdz(k)*Idz(k))) * & + ! I_dz_int(K), 0.0) + ! enddo ! This call just calculates N2 and S2. call calculate_projected_state(kappa, u, v, T, Sal, 0.0, nzc, dz, I_dz_int, & @@ -981,12 +864,6 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & ! ---------------------------------------------------- ! Calculate new values of u, v, rho, N^2 and S. ! ---------------------------------------------------- -#ifdef DEBUG - do K=1,nzc+1 - Ri_k(K) = 1e3 ; if (S2(K) > 1e-3*N2(K)) Ri_k(K) = N2(K) / S2(K) - if (itt > 1) then ; tke_prev(K) = tke(K) ; else ; tke_prev(K) = 0.0 ; endif - enddo -#endif ! call cpu_clock_begin(id_clock_KQ) call find_kappa_tke(N2, S2, kappa, Idz, dz_Int, I_L2_bdry, f2, & @@ -1099,9 +976,6 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & ! This would be here but does nothing. ! kappa_avg(K) = kappa_avg(K) + kappa_mid(K)*dt_wt tke_avg(K) = tke_avg(K) + dt_wt*tke(K) -#ifdef DEBUG - tke_pred(K) = tke(K) ; kappa_pred(K) = 0.0 ; kappa(K) = 0.0 -#endif enddo ! call cpu_clock_end(id_clock_avg) else @@ -1157,63 +1031,10 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & ! call cpu_clock_end(id_clock_project) endif -#ifdef DEBUG - if (itt <= max_debug_itt) then - dt_it1(itt) = dt_now - dk_wt_it1(itt) = 0.0 ; dkpos_wt_it1(itt) = 0.0 ; dkneg_wt_it1(itt) = 0.0 - k_mag(itt) = 0.0 - wt_itt = 1.0/real(itt) ; wt_tot = 0.0 - do K=1,nzc+1 - ksrc_av(K) = (1.0-wt_itt)*ksrc_av(K) + wt_itt*K_src(K) - wt_tot = wt_tot + dz_Int(K) * ksrc_av(K) - enddo - ! Use the 1/0=0 convention. - I_wt_tot = 0.0 ; if (wt_tot > 0.0) I_wt_tot = 1.0/wt_tot - - do K=1,nzc+1 - wt(K) = (dz_Int(K)*ksrc_av(K)) * I_wt_tot - k_mag(itt) = k_mag(itt) + wt(K)*kappa_mid(K) - dkappa_it1(K,itt) = kappa_pred(K) - kappa_out(K) - dk_wt_it1(itt) = dk_wt_it1(itt) + wt(K)*dkappa_it1(K,itt) - if (dkappa_it1(K,itt) > 0.0) then - dkpos_wt_it1(itt) = dkpos_wt_it1(itt) + wt(K)*dkappa_it1(K,itt) - else - dkneg_wt_it1(itt) = dkneg_wt_it1(itt) + wt(K)*dkappa_it1(K,itt) - endif - wt_it1(K,itt) = wt(K) - enddo - endif - do K=1,nzc+1 - 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) - enddo - if (itt <= max_debug_itt) then - do k=1,nzc - u_it1(k,itt) = u(k) ; v_it1(k,itt) = v(k) - T_it1(k,itt) = T(k) ; S_it1(k,itt) = Sal(k) - enddo - do K=1,nzc+1 - kprev_it1(K,itt) = kappa_out(K) - kappa_it1(K,itt) = kappa_mid(K) ; tke_it1(K,itt) = 0.5*(tke(K)+tke_pred(K)) - N2_it1(K,itt)=N2(K) ; Sh2_it1(K,itt)=S2(K) - ksrc_it1(K,itt) = kappa_src(K) - K_Q_it1(K,itt) = kappa_out(K) / (TKE(K)) - if (itt > 1) then - 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)), US%m2_s_to_Z2_T*1e-100) - enddo - endif -#endif - if (dt_rem <= 0.0) exit enddo ! end itt loop -#ifdef ADD_DIAGNOSTICS if (present(I_Ld2_1d)) then do K=1,GV%ke+1 ; I_Ld2_1d(K) = 0.0 ; enddo do K=2,nzc ; if (TKE(K) > 0.0) & @@ -1224,7 +1045,6 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & do K=1,nzc+1 ; dz_Int_1d(K) = dz_Int(K) ; enddo do K=nzc+2,GV%ke ; dz_Int_1d(K) = 0.0 ; enddo endif -#endif end subroutine kappa_shear_column @@ -1474,18 +1294,14 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & integer :: ks_kappa, ke_kappa, ke_tke ! The ranges of k-indices that are or integer :: ks_kappa_prev, ke_kappa_prev ! were being worked on. integer :: itt, k, k2 -#ifdef DEBUG - integer :: max_debug_itt ; parameter(max_debug_itt=20) + + ! These variables are used only for debugging. + logical, parameter :: debug_soln = .false. real :: K_err_lin, Q_err_lin, TKE_src_norm real, dimension(nz+1) :: & I_Ld2_debug, & ! A separate version of I_Ld2 for debugging [Z-2 ~> m-2]. kappa_prev, & ! The value of kappa at the start of the current iteration [Z2 T-1 ~> m2 s-1]. TKE_prev ! The value of TKE at the start of the current iteration [Z2 T-2 ~> 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 - integer :: it2 -#endif c_N2 = CS%C_N**2 ; c_S2 = CS%C_S**2 q0 = CS%TKE_bg ; kappa0 = CS%kappa_0 @@ -1529,7 +1345,7 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & ! TKE_decay(K) = c_n*sqrt(N2(K)) + c_s*sqrt(S2(K)) ! The expression in JHL. TKE_decay(K) = sqrt(c_n2*N2(K) + c_s2*S2(K)) if ((kappa(K) > 0.0) .and. (K_Q(K) > 0.0)) then - TKE(K) = kappa(K) / K_Q(K) + TKE(K) = kappa(K) / K_Q(K) ! Perhaps take the max with TKE_min else TKE(K) = TKE_min endif @@ -1564,9 +1380,7 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & ! Calculate TKE ! ---------------------------------------------------- -#ifdef DEBUG - do K=1,nz+1 ; kappa_prev(K) = kappa(K) ; TKE_prev(K) = TKE(K) ; enddo -#endif + if (debug_soln) then ; do K=1,nz+1 ; kappa_prev(K) = kappa(K) ; TKE_prev(K) = TKE(K) ; enddo ; endif if (.not.do_Newton) then ! Use separate steps of the TKE and kappa equations, that are @@ -1792,25 +1606,20 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & dQ(ke_kappa+1) = dQ(ke_kappa+1) / (1.0 - cQ(ke_kappa+2)*e1(ke_kappa+2)) TKE(ke_kappa+1) = max(TKE(ke_kappa+1) + dQ(ke_kappa+1), TKE_min) do k=ke_kappa+2,nz+1 -#ifdef DEBUG - if (K < nz+1) then + if (debug_soln .and. (K < nz+1)) then ! Ignore this source? aQ(k) = (0.5*(kappa(K)+kappa(K+1))+kappa0) * Idz(k) - tke_src_norm = (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_norm = (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))) endif -#endif dK(K) = 0.0 ! Ensure that TKE+dQ will not drop below 0.5*TKE. dQ(K) = max(e1(K)*dQ(K-1),-0.5*TKE(K)) TKE(K) = max(TKE(K) + dQ(K), TKE_min) if (abs(dQ(K)) < roundoff*TKE(K)) exit enddo -#ifdef DEBUG - do K2=K+1,ke_kappa_prev+1 ; dQ(K2) = 0.0 ; dK(K2) = 0.0 ; enddo - do K=K2,nz+1 ; if (dQ(K) == 0.0) exit ; dQ(K) = 0.0 ; dK(K) = 0.0 ; enddo -#endif + if (debug_soln) then ; do K2=K+1,nz+1 ; dQ(K2) = 0.0 ; dK(K2) = 0.0 ; enddo ; endif endif if (.not. abort_Newton) then do K=ke_kappa,2,-1 @@ -1837,10 +1646,9 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & dK(1) = 0.0 endif -#ifdef DEBUG ! Check these solutions for consistency. ! The unit conversions here have not been carefully tested. - do K=2,nz + if (debug_soln) then ; 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 ! dz_Int*TKE_decay*TKE. The exception is where, either 1) the decay term has been @@ -1863,8 +1671,8 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & 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)) - enddo -#endif + enddo ; endif + endif ! End of the Newton's method solver. ! Test kappa for convergence... @@ -1904,34 +1712,10 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & do K=2,nz ; K_Q(K) = kappa(K) / max(TKE(K), TKE_min) ; enddo endif -#ifdef DEBUG - if (itt <= max_debug_itt) then - do K=1,nz+1 - kprev_it1(K,itt) = kappa_prev(K) - kappa_it1(K,itt) = kappa(K) ; tke_it1(K,itt) = tke(K) - dkappa_it1(K,itt) = kappa(K) - kappa_prev(K) - dkappa_norm_it1(K,itt) = (kappa(K) - kappa_prev(K)) / & - (kappa0 + 0.5*(kappa(K) + kappa_prev(K))) - K_Q_it1(K,itt) = kappa(K) / max(TKE(K),TKE_min) - d_dkappa_it1(K,itt) = 0.0 - if (itt > 1) then ; if (abs(dkappa_it1(K,itt-1)) > 1e-20*US%m2_s_to_Z2_T) & - d_dkappa_it1(K,itt) = dkappa_it1(K,itt) / dkappa_it1(K,itt-1) - endif - enddo - endif -#endif - if (within_tolerance) exit enddo -#ifdef DEBUG - do it2=itt+1,max_debug_itt ; do K=1,nz+1 - kprev_it1(K,it2) = 0.0 ; kappa_it1(K,it2) = 0.0 ; tke_it1(K,it2) = 0.0 - dkappa_it1(K,it2) = 0.0 ; K_Q_it1(K,it2) = 0.0 ; d_dkappa_it1(K,it2) = 0.0 - enddo ; enddo -#endif - if (do_Newton) then ! K_Q needs to be calculated. do K=1,ks_kappa-1 ; K_Q(K) = 0.0 ; enddo do K=ks_kappa,ke_kappa ; K_Q(K) = kappa(K) / TKE(K) ; enddo @@ -2127,16 +1911,10 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) CS%diag => diag - CS%id_Kd_shear = register_diag_field('ocean_model','Kd_shear',diag%axesTi,Time, & + CS%id_Kd_shear = register_diag_field('ocean_model','Kd_shear', diag%axesTi, Time, & 'Shear-driven Diapycnal Diffusivity', 'm2 s-1', conversion=US%Z2_T_to_m2_s) - CS%id_TKE = register_diag_field('ocean_model','TKE_shear',diag%axesTi,Time, & + CS%id_TKE = register_diag_field('ocean_model','TKE_shear', diag%axesTi, Time, & 'Shear-driven Turbulent Kinetic Energy', 'm2 s-2', conversion=US%Z_to_m**2*US%s_to_T**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', 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', conversion=US%Z_to_m) -#endif end function kappa_shear_init diff --git a/src/parameterizations/vertical/MOM_regularize_layers.F90 b/src/parameterizations/vertical/MOM_regularize_layers.F90 index f8a96c894b..f21faa359d 100644 --- a/src/parameterizations/vertical/MOM_regularize_layers.F90 +++ b/src/parameterizations/vertical/MOM_regularize_layers.F90 @@ -18,7 +18,6 @@ module MOM_regularize_layers implicit none ; private #include -#undef DEBUG_CODE public regularize_layers, regularize_layers_init @@ -58,18 +57,6 @@ module MOM_regularize_layers 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 - integer :: id_def_rat_u_1b = -1, id_def_rat_v_1b = -1 - integer :: id_def_rat_u_2 = -1, id_def_rat_u_2b = -1 - 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 @@ -148,17 +135,6 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: & e ! The interface depths [H ~> m or kg m-2], positive upward. -#ifdef DEBUG_CODE - real, dimension(SZIB_(G),SZJ_(G)) :: & - def_rat_u_1b, def_rat_u_2, def_rat_u_2b, def_rat_u_3, def_rat_u_3b - real, dimension(SZI_(G),SZJB_(G)) :: & - def_rat_v_1b, def_rat_v_2, def_rat_v_2b, def_rat_v_3, def_rat_v_3b - 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 [H ~> m or kg m-2], positive upward. -#endif - real, dimension(SZI_(G),SZK_(G)+1) :: & e_filt, e_2d ! The interface depths [H ~> m or kg m-2], positive upward. real, dimension(SZI_(G),SZK_(G)) :: & @@ -229,12 +205,6 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) h_neglect = GV%H_subroundoff debug = (debug .or. CS%debug) -#ifdef DEBUG_CODE - debug = .true. - if (CS%id_def_rat_2 > 0) then ! Calculate over a slightly larger domain. - is = G%isc-1 ; ie = G%iec+1 ; js = G%jsc-1 ; je = G%jec+1 - endif -#endif I_dtol = 1.0 / max(CS%h_def_tol2 - CS%h_def_tol1, 1e-40) I_dtol34 = 1.0 / max(CS%h_def_tol4 - CS%h_def_tol3, 1e-40) @@ -249,11 +219,8 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) e(i,j,K+1) = e(i,j,K) - h(i,j,k) enddo ; enddo ; enddo -#ifdef DEBUG_CODE - call find_deficit_ratios(e, def_rat_u, def_rat_v, G, GV, CS, def_rat_u_1b, def_rat_v_1b, 1, h) -#else call find_deficit_ratios(e, def_rat_u, def_rat_v, G, GV, CS, h=h) -#endif + ! Determine which columns are problematic do j=js,je ; do_j(j) = .false. ; enddo do j=js,je ; do i=is,ie @@ -262,49 +229,6 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) if (def_rat_h(i,j) > CS%h_def_tol1) do_j(j) = .true. enddo ; enddo -#ifdef DEBUG_CODE - if ((CS%id_def_rat_3 > 0) .or. (CS%id_e3 > 0) .or. & - (CS%id_def_rat_u_3 > 0) .or. (CS%id_def_rat_u_3b > 0) .or. & - (CS%id_def_rat_v_3 > 0) .or. (CS%id_def_rat_v_3b > 0) ) then - do j=js-1,je+1 ; do i=is-1,ie+1 - ef(i,j,1) = 0.0 - enddo ; enddo - do K=2,nz+1 ; do j=js,je ; do i=is,ie - 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)) - 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)) - 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)) - 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)) - endif - - wt = 1.0 - ef(i,j,k) = (1.0 - 0.5*wt) * e(i,j,K) + & - wt * 0.125 * ((e_e + e_w) + (e_n + e_s)) - enddo ; enddo ; enddo - call find_deficit_ratios(ef, def_rat_u_3, def_rat_v_3, G, GV, CS, def_rat_u_3b, def_rat_v_3b) - - ! Determine which columns are problematic - do j=js,je ; do i=is,ie - def_rat_h3(i,j) = max(def_rat_u_3(I-1,j), def_rat_u_3(I,j), & - def_rat_v_3(i,J-1), def_rat_v_3(i,J)) - enddo ; enddo - - if (CS%id_e3 > 0) call post_data(CS%id_e3, ef, CS%diag) - if (CS%id_def_rat_3 > 0) call post_data(CS%id_def_rat_3, def_rat_h3, CS%diag) - if (CS%id_def_rat_u_3 > 0) call post_data(CS%id_def_rat_u_3, def_rat_u_3, CS%diag) - if (CS%id_def_rat_u_3b > 0) call post_data(CS%id_def_rat_u_3b, def_rat_u_3b, CS%diag) - if (CS%id_def_rat_v_3 > 0) call post_data(CS%id_def_rat_v_3, def_rat_v_3, CS%diag) - if (CS%id_def_rat_v_3b > 0) call post_data(CS%id_def_rat_v_3b, def_rat_v_3b, CS%diag) - endif -#endif - - ! Now restructure the layers. !$OMP parallel do default(private) shared(is,ie,js,je,nz,do_j,def_rat_h,CS,nkmb,G,GV,US, & !$OMP e,I_dtol,h,tv,debug,h_neglect,p_ref_cv,ea, & @@ -682,40 +606,6 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) if (CS%id_def_rat > 0) call post_data(CS%id_def_rat, def_rat_h, CS%diag) -#ifdef DEBUG_CODE - if (CS%id_e1 > 0) call post_data(CS%id_e1, e, CS%diag) - if (CS%id_def_rat_u > 0) call post_data(CS%id_def_rat_u, def_rat_u, CS%diag) - if (CS%id_def_rat_u_1b > 0) call post_data(CS%id_def_rat_u_1b, def_rat_u_1b, CS%diag) - if (CS%id_def_rat_v > 0) call post_data(CS%id_def_rat_v, def_rat_v, CS%diag) - if (CS%id_def_rat_v_1b > 0) call post_data(CS%id_def_rat_v_1b, def_rat_v_1b, CS%diag) - - if ((CS%id_def_rat_2 > 0) .or. & - (CS%id_def_rat_u_2 > 0) .or. (CS%id_def_rat_u_2b > 0) .or. & - (CS%id_def_rat_v_2 > 0) .or. (CS%id_def_rat_v_2b > 0) ) then - do j=js-1,je+1 ; do i=is-1,ie+1 - e(i,j,1) = 0.0 - enddo ; enddo - do K=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1 - e(i,j,K+1) = e(i,j,K) - h(i,j,k) - enddo ; enddo ; enddo - - call find_deficit_ratios(e, def_rat_u_2, def_rat_v_2, G, GV, CS, def_rat_u_2b, def_rat_v_2b, h=h) - - ! Determine which columns are problematic - do j=js,je ; do i=is,ie - def_rat_h2(i,j) = max(def_rat_u_2(I-1,j), def_rat_u_2(I,j), & - def_rat_v_2(i,J-1), def_rat_v_2(i,J)) - enddo ; enddo - - if (CS%id_def_rat_2 > 0) call post_data(CS%id_def_rat_2, def_rat_h2, CS%diag) - if (CS%id_e2 > 0) call post_data(CS%id_e2, e, CS%diag) - if (CS%id_def_rat_u_2 > 0) call post_data(CS%id_def_rat_u_2, def_rat_u_2, CS%diag) - if (CS%id_def_rat_u_2b > 0) call post_data(CS%id_def_rat_u_2b, def_rat_u_2b, CS%diag) - if (CS%id_def_rat_v_2 > 0) call post_data(CS%id_def_rat_v_2, def_rat_v_2, CS%diag) - if (CS%id_def_rat_v_2b > 0) call post_data(CS%id_def_rat_v_2b, def_rat_v_2b, CS%diag) - endif -#endif - end subroutine regularize_surface !> This subroutine determines the amount by which the harmonic mean @@ -958,45 +848,6 @@ subroutine regularize_layers_init(Time, G, GV, param_file, diag, CS) CS%id_def_rat = register_diag_field('ocean_model', 'deficit_ratio', diag%axesT1, & Time, 'Max face thickness deficit ratio', 'nondim') -#ifdef DEBUG_CODE - CS%id_def_rat_2 = register_diag_field('ocean_model', 'deficit_rat2', diag%axesT1, & - Time, 'Corrected thickness deficit ratio', 'nondim') - CS%id_def_rat_3 = register_diag_field('ocean_model', 'deficit_rat3', diag%axesT1, & - Time, 'Filtered thickness deficit ratio', 'nondim') - CS%id_e1 = register_diag_field('ocean_model', 'er_1', diag%axesTi, & - Time, 'Intial interface depths before remapping', 'm') - CS%id_e2 = register_diag_field('ocean_model', 'er_2', diag%axesTi, & - Time, 'Intial interface depths after remapping', 'm') - CS%id_e3 = register_diag_field('ocean_model', 'er_3', diag%axesTi, & - Time, 'Intial interface depths filtered', 'm') - - CS%id_def_rat_u = register_diag_field('ocean_model', 'defrat_u', diag%axesCu1, & - Time, 'U-point thickness deficit ratio', 'nondim') - CS%id_def_rat_u_1b = register_diag_field('ocean_model', 'defrat_u_1b', diag%axesCu1, & - Time, 'U-point 2-layer thickness deficit ratio', 'nondim') - CS%id_def_rat_u_2 = register_diag_field('ocean_model', 'defrat_u_2', diag%axesCu1, & - Time, 'U-point corrected thickness deficit ratio', 'nondim') - CS%id_def_rat_u_2b = register_diag_field('ocean_model', 'defrat_u_2b', diag%axesCu1, & - Time, 'U-point corrected 2-layer thickness deficit ratio', 'nondim') - CS%id_def_rat_u_3 = register_diag_field('ocean_model', 'defrat_u_3', diag%axesCu1, & - Time, 'U-point filtered thickness deficit ratio', 'nondim') - CS%id_def_rat_u_3b = register_diag_field('ocean_model', 'defrat_u_3b', diag%axesCu1, & - Time, 'U-point filtered 2-layer thickness deficit ratio', 'nondim') - - CS%id_def_rat_v = register_diag_field('ocean_model', 'defrat_v', diag%axesCv1, & - Time, 'V-point thickness deficit ratio', 'nondim') - CS%id_def_rat_v_1b = register_diag_field('ocean_model', 'defrat_v_1b', diag%axesCv1, & - Time, 'V-point 2-layer thickness deficit ratio', 'nondim') - CS%id_def_rat_v_2 = register_diag_field('ocean_model', 'defrat_v_2', diag%axesCv1, & - Time, 'V-point corrected thickness deficit ratio', 'nondim') - CS%id_def_rat_v_2b = register_diag_field('ocean_model', 'defrat_v_2b', diag%axesCv1, & - Time, 'V-point corrected 2-layer thickness deficit ratio', 'nondim') - CS%id_def_rat_v_3 = register_diag_field('ocean_model', 'defrat_v_3', diag%axesCv1, & - Time, 'V-point filtered thickness deficit ratio', 'nondim') - CS%id_def_rat_v_3b = register_diag_field('ocean_model', 'defrat_v_3b', diag%axesCv1, & - Time, 'V-point filtered 2-layer thickness deficit ratio', 'nondim') -#endif - if (CS%allow_clocks_in_omp_loops) then id_clock_EOS = cpu_clock_id('(Ocean regularize_layers EOS)', grain=CLOCK_ROUTINE) endif From af55cce17ee655dde99b167deae34f452e4cea9d Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Tue, 30 Jun 2020 18:26:03 -0800 Subject: [PATCH 17/91] OBC code for slope_x, slope_y. --- src/core/MOM.F90 | 8 +- src/core/MOM_isopycnal_slopes.F90 | 44 +++++++++- .../lateral/MOM_lateral_mixing_coeffs.F90 | 84 ++++++++++++++----- src/user/Kelvin_initialization.F90 | 27 +++--- 4 files changed, 122 insertions(+), 41 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 15d8e5222d..4a98dbea6f 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -994,7 +994,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & call enable_averages(dt_thermo, Time_local+real_to_time(US%T_to_s*(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, US, CS%VarMix) + call calc_slope_functions(h, CS%tv, dt, G, GV, US, CS%VarMix, OBC=CS%OBC) 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) @@ -1067,7 +1067,7 @@ 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, US, CS%VarMix) + call calc_slope_functions(h, CS%tv, dt, G, GV, US, CS%VarMix, OBC=CS%OBC) call thickness_diffuse(h, CS%uhtr, CS%vhtr, CS%tv, dt, G, GV, US, & CS%MEKE, CS%VarMix, CS%CDp, CS%thickness_diffuse_CSp) @@ -1479,7 +1479,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS call pass_var(CS%h, G%Domain) call calc_resoln_function(CS%h, CS%tv, G, GV, US, CS%VarMix) call calc_depth_function(G, CS%VarMix) - call calc_slope_functions(CS%h, CS%tv, dt_offline, G, GV, US, CS%VarMix) + call calc_slope_functions(CS%h, CS%tv, dt_offline, G, GV, US, CS%VarMix, OBC=CS%OBC) endif call tracer_hordiff(CS%h, dt_offline, CS%MEKE, CS%VarMix, G, GV, US, & CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) @@ -1505,7 +1505,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS call pass_var(CS%h, G%Domain) call calc_resoln_function(CS%h, CS%tv, G, GV, US, CS%VarMix) call calc_depth_function(G, CS%VarMix) - call calc_slope_functions(CS%h, CS%tv, dt_offline, G, GV, US, CS%VarMix) + call calc_slope_functions(CS%h, CS%tv, dt_offline, G, GV, US, CS%VarMix, OBC=CS%OBC) endif call tracer_hordiff(CS%h, dt_offline, CS%MEKE, CS%VarMix, G, GV, US, & CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index fa60fb821d..b0a66b9488 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -8,6 +8,8 @@ module MOM_isopycnal_slopes use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use MOM_EOS, only : int_specific_vol_dp, calculate_density_derivs +use MOM_open_boundary, only : ocean_OBC_type +use MOM_open_boundary, only : OBC_DIRECTION_E, OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S implicit none ; private @@ -24,7 +26,7 @@ module MOM_isopycnal_slopes !> Calculate isopycnal slopes, and optionally return N2 used in calculation. 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) + slope_x, slope_y, N2_u, N2_v, halo, OBC) !, 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 @@ -44,6 +46,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & optional, intent(inout) :: N2_v !< Brunt-Vaisala frequency squared at !! interfaces between u-points [T-2 ~> s-2] integer, optional, intent(in) :: halo !< Halo width over which to compute + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. ! 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. @@ -102,6 +105,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & integer, dimension(2) :: EOSdom_u, EOSdom_v ! Domains for the equation of state calculations at u and v points integer :: is, ie, js, je, nz, IsdB integer :: i, j, k + logical :: local_open_u_BC, local_open_v_BC if (present(halo)) then is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo @@ -118,6 +122,13 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & L_to_Z = 1.0 / Z_to_L dz_neglect = GV%H_subroundoff * H_to_Z + local_open_u_BC = .false. + local_open_v_BC = .false. + if (present(OBC)) then ; if (associated(OBC)) then + local_open_u_BC = OBC%open_u_BCs_exist_globally + local_open_v_BC = OBC%open_v_BCs_exist_globally + endif ; endif + use_EOS = associated(tv%eqn_of_state) present_N2_u = PRESENT(N2_u) @@ -167,7 +178,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & !$OMP parallel do default(none) shared(nz,is,ie,js,je,IsdB,use_EOS,G,GV,US,pres,T,S,tv,h,e, & !$OMP h_neglect,dz_neglect,Z_to_L,L_to_Z,H_to_Z,h_neglect2, & - !$OMP present_N2_u,G_Rho0,N2_u,slope_x,EOSdom_u) & + !$OMP present_N2_u,G_Rho0,N2_u,slope_x,EOSdom_u,local_open_u_BC) & !$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, & @@ -247,6 +258,19 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & else ! With .not.use_EOS, the layers are constant density. slope_x(I,j,K) = (Z_to_L*(e(i,j,K)-e(i+1,j,K))) * G%IdxCu(I,j) endif + if (local_open_u_BC) then + if (OBC%segment(OBC%segnum_u(I,j))%open) then + slope_x(I,j,K) = 0. + ! This and/or the masking code below is to make slopes match inside + ! land mask. Might not be necessary except for DEBUG output. +! if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then +! slope_x(I+1,j,K) = 0. +! else +! slope_x(I-1,j,K) = 0. +! endif + endif + slope_x(I,j,K) = slope_x(I,j,k) * max(g%mask2dT(i,j),g%mask2dT(i+1,j)) + endif enddo ! I enddo ; enddo ! end of j-loop @@ -256,7 +280,8 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & ! Calculate the meridional isopycnal slope. !$OMP parallel do default(none) shared(nz,is,ie,js,je,IsdB,use_EOS,G,GV,US,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,EOSdom_v) & + !$OMP h_neglect2,present_N2_v,G_Rho0,N2_v,slope_y,EOSdom_v, & + !$OMP local_open_v_BC) & !$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, & @@ -333,6 +358,19 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & else ! With .not.use_EOS, the layers are constant density. slope_y(i,J,K) = (Z_to_L*(e(i,j,K)-e(i,j+1,K))) * G%IdyCv(i,J) endif + if (local_open_v_BC) then + if (OBC%segment(OBC%segnum_v(i,J))%open) then + slope_y(i,J,K) = 0. + ! This and/or the masking code below is to make slopes match inside + ! land mask. Might not be necessary except for DEBUG output. +! if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then +! slope_y(i,J+1,K) = 0. +! else +! slope_y(i,J-1,K) = 0. +! endif + endif + slope_y(i,J,K) = slope_y(i,J,k) * max(g%mask2dT(i,j),g%mask2dT(i,j+1)) + endif enddo ! i enddo ; enddo ! end of j-loop diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 0f07701eda..c227bdfdb7 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -3,20 +3,21 @@ module MOM_lateral_mixing_coeffs ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_debugging, only : hchksum, uvchksum -use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg -use MOM_diag_mediator, only : register_diag_field, safe_alloc_ptr, post_data -use MOM_diag_mediator, only : diag_ctrl, time_type, query_averaging_enabled -use MOM_domains, only : create_group_pass, do_group_pass -use MOM_domains, only : group_pass_type, pass_var, pass_vector -use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_debugging, only : hchksum, uvchksum +use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg +use MOM_diag_mediator, only : register_diag_field, safe_alloc_ptr, post_data +use MOM_diag_mediator, only : diag_ctrl, time_type, query_averaging_enabled +use MOM_domains, only : create_group_pass, do_group_pass +use MOM_domains, only : group_pass_type, pass_var, pass_vector +use MOM_file_parser, only : get_param, log_version, param_file_type 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 +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 +use MOM_open_boundary, only : ocean_OBC_type implicit none ; private @@ -432,7 +433,7 @@ 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, US, CS) +subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS, OBC) type(ocean_grid_type), intent(inout) :: 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 @@ -440,6 +441,7 @@ subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS) type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables real, intent(in) :: dt !< Time increment [T ~> s] type(VarMix_CS), pointer :: CS !< Variable mixing coefficients + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. ! Local variables real, dimension(SZI_(G), SZJ_(G), SZK_(G)+1) :: & e ! The interface heights relative to mean sea level [Z ~> m]. @@ -453,12 +455,12 @@ subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS) call find_eta(h, tv, G, GV, US, e, halo_size=2) if (CS%use_stored_slopes) then 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, CS%slope_x, CS%slope_y, N2_u, N2_v, G, GV, US, CS) + CS%slope_x, CS%slope_y, N2_u, N2_v, 1, OBC=OBC) + call calc_Visbeck_coeffs(h, CS%slope_x, CS%slope_y, N2_u, N2_v, G, GV, US, CS, OBC=OBC) ! 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, US, CS, e, .true.) + call calc_slope_functions_using_just_e(h, G, GV, US, CS, e, .true., OBC=OBC) endif endif @@ -476,7 +478,7 @@ subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS) end subroutine calc_slope_functions !> Calculates factors used when setting diffusivity coefficients similar to Visbeck et al. -subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS) +subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS, OBC) 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 [H ~> m or kg m-2] @@ -488,6 +490,7 @@ subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS) !! at v-points [T-2 ~> s-2] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(VarMix_CS), pointer :: CS !< Variable mixing coefficients + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. ! Local variables real :: S2 ! Interface slope squared [nondim] @@ -500,6 +503,7 @@ subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS) real :: H_u(SZIB_(G)), H_v(SZI_(G)) real :: S2_u(SZIB_(G), SZJ_(G)) real :: S2_v(SZI_(G), SZJB_(G)) + logical :: local_open_u_BC, local_open_v_BC if (.not. associated(CS)) call MOM_error(FATAL, "calc_slope_function:"// & "Module must be initialized before it is used.") @@ -511,6 +515,13 @@ subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + local_open_u_BC = .false. + local_open_v_BC = .false. + if (present(OBC)) then ; if (associated(OBC)) then + local_open_u_BC = OBC%open_u_BCs_exist_globally + local_open_v_BC = OBC%open_v_BCs_exist_globally + endif ; endif + S2max = CS%Visbeck_S_max**2 !$OMP parallel do default(shared) @@ -523,7 +534,8 @@ subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, 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 parallel do default(shared) private(S2,H_u,Hdn,Hup,H_geom,N2,wNE,wSE,wSW,wNW) + !$OMP parallel do default(shared) private(S2,H_u,Hdn,Hup,H_geom,N2,wNE,wSE,wSW,wNW, & + !$OMP local_open_u_BC) do j = js,je do I=is-1,ie CS%SN_u(I,j) = 0. ; H_u(I) = 0. ; S2_u(I,j) = 0. @@ -556,10 +568,16 @@ subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS) else CS%SN_u(I,j) = 0. endif + if (local_open_u_BC) then + if (OBC%segment(OBC%segnum_u(I,j))%open) then + CS%SN_u(i,J) = 0. + endif + endif enddo enddo - !$OMP parallel do default(shared) private(S2,H_v,Hdn,Hup,H_geom,N2,wNE,wSE,wSW,wNW) + !$OMP parallel do default(shared) private(S2,H_v,Hdn,Hup,H_geom,N2,wNE,wSE,wSW,wNW, & + !$OMP local_open_u_BC) do J = js-1,je do i=is,ie CS%SN_v(i,J) = 0. ; H_v(i) = 0. ; S2_v(i,J) = 0. @@ -592,6 +610,11 @@ subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS) else CS%SN_v(i,J) = 0. endif + if (local_open_v_BC) then + if (OBC%segment(OBC%segnum_v(i,J))%open) then + CS%SN_v(i,J) = 0. + endif + endif enddo enddo @@ -613,7 +636,7 @@ 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, US, CS, e, calculate_slopes) +subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slopes, OBC) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure 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 @@ -622,6 +645,7 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop 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 + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. ! Local variables 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) @@ -637,6 +661,7 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop integer :: i, j, k, kb_max real :: S2N2_u_local(SZIB_(G), SZJ_(G),SZK_(G)) real :: S2N2_v_local(SZI_(G), SZJB_(G),SZK_(G)) + logical :: local_open_u_BC, local_open_v_BC if (.not. associated(CS)) call MOM_error(FATAL, "calc_slope_function:"// & "Module must be initialized before it is used.") @@ -648,6 +673,13 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + local_open_u_BC = .false. + local_open_v_BC = .false. + if (present(OBC)) then ; if (associated(OBC)) then + local_open_u_BC = OBC%open_u_BCs_exist_globally + local_open_v_BC = OBC%open_v_BCs_exist_globally + endif ; endif + one_meter = 1.0 * GV%m_to_H h_neglect = GV%H_subroundoff H_cutoff = real(2*nz) * (GV%Angstrom_H + h_neglect) @@ -723,6 +755,11 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop else CS%SN_u(I,j) = 0.0 endif + if (local_open_u_BC) then + if (OBC%segment(OBC%segnum_u(I,j))%open) then + CS%SN_u(I,j) = 0. + endif + endif enddo enddo !$OMP parallel do default(shared) @@ -740,6 +777,11 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop else CS%SN_v(I,j) = 0.0 endif + if (local_open_v_BC) then + if (OBC%segment(OBC%segnum_v(I,j))%open) then + CS%SN_v(I,j) = 0. + endif + endif enddo enddo diff --git a/src/user/Kelvin_initialization.F90 b/src/user/Kelvin_initialization.F90 index a3215294fc..227c814b3c 100644 --- a/src/user/Kelvin_initialization.F90 +++ b/src/user/Kelvin_initialization.F90 @@ -242,20 +242,21 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, 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(GV%g_Earth * 0.5 * (G%bathyT(i+1,j) + G%bathyT(i,j))) + ! Use inside bathymetry + cff = sqrt(GV%g_Earth * G%bathyT(i+1,j) ) val2 = fac * exp(- US%T_to_s*CS%F_0 * US%m_to_L*y / cff) segment%eta(I,j) = val2 * cos(omega * time_sec) segment%normal_vel_bt(I,j) = (val2 * (val1 * cff * cosa / & - (0.5 * (G%bathyT(i+1,j) + G%bathyT(i,j)))) ) + (G%bathyT(i+1,j) )) ) if (segment%nudged) then do k=1,nz segment%nudged_normal_vel(I,j,k) = (val2 * (val1 * cff * cosa / & - (0.5 * (G%bathyT(i+1,j) + G%bathyT(i,j)))) ) + (G%bathyT(i+1,j))) ) enddo elseif (segment%specified) then do k=1,nz segment%normal_vel(I,j,k) = (val2 * (val1 * cff * cosa / & - (0.5 * (G%bathyT(i+1,j) + G%bathyT(i,j)))) ) + (G%bathyT(i+1,j) )) ) segment%normal_trans(I,j,k) = segment%normal_vel(I,j,k) * h(i+1,j,k) * G%dyCu(I,j) enddo endif @@ -285,16 +286,16 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) y1 = 1000. * G%geoLatBu(I,J) x = (x1 - CS%coast_offset1) * cosa + y1 * sina y = - (x1 - CS%coast_offset1) * sina + y1 * cosa - cff =sqrt(GV%g_Earth * 0.5 * (G%bathyT(i+1,j) + G%bathyT(i,j))) + cff =sqrt(GV%g_Earth * G%bathyT(i+1,j) ) val2 = fac * exp(- US%T_to_s*CS%F_0 * US%m_to_L*y / cff) if (CS%mode == 0) then ; do k=1,nz segment%tangential_vel(I,J,k) = (val1 * val2 * cff * sina) / & - ( 0.25*((G%bathyT(i,j) + G%bathyT(i+1,j+1)) + (G%bathyT(i+1,j) + G%bathyT(i,j+1))) ) + ( 0.5*(G%bathyT(i+1,j+1) + G%bathyT(i+1,j) ) ) enddo ; endif enddo ; enddo endif - else + else ! Must be south isd = segment%HI%isd ; ied = segment%HI%ied JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB do J=JsdB,JedB ; do i=isd,ied @@ -303,20 +304,20 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, 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(GV%g_Earth * 0.5 * (G%bathyT(i,j+1) + G%bathyT(i,j))) + cff = sqrt(GV%g_Earth * G%bathyT(i,j+1) ) val2 = fac * exp(- 0.5 * (G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J)) * US%m_to_L*y / cff) segment%eta(I,j) = val2 * cos(omega * time_sec) segment%normal_vel_bt(I,j) = US%L_T_to_m_s * (val1 * cff * sina / & - (0.5*(G%bathyT(i+1,j) + G%bathyT(i,j)))) * val2 + (G%bathyT(i,j+1) )) * val2 if (segment%nudged) then do k=1,nz segment%nudged_normal_vel(I,j,k) = US%L_T_to_m_s * (val1 * cff * sina / & - (0.5*(G%bathyT(i+1,j) + G%bathyT(i,j)))) * val2 + (G%bathyT(i,j+1) )) * val2 enddo elseif (segment%specified) then do k=1,nz segment%normal_vel(I,j,k) = US%L_T_to_m_s * (val1 * cff * sina / & - (0.5*(G%bathyT(i+1,j) + G%bathyT(i,j)))) * val2 + (G%bathyT(i,j+1) )) * val2 segment%normal_trans(i,J,k) = segment%normal_vel(i,J,k) * h(i,j+1,k) * G%dxCv(i,J) enddo endif @@ -344,11 +345,11 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) y1 = 1000. * G%geoLatBu(I,J) x = (x1 - CS%coast_offset1) * cosa + y1 * sina y = - (x1 - CS%coast_offset1) * sina + y1 * cosa - cff = sqrt(GV%g_Earth * 0.5 * (G%bathyT(i,j+1) + G%bathyT(i,j))) + cff = sqrt(GV%g_Earth * G%bathyT(i,j+1) ) val2 = fac * exp(- 0.5 * (G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J)) * US%m_to_L*y / cff) if (CS%mode == 0) then ; do k=1,nz segment%tangential_vel(I,J,k) = ((val1 * val2 * cff * sina) / & - ( 0.25*((G%bathyT(i,j) + G%bathyT(i+1,j+1)) + (G%bathyT(i+1,j) + G%bathyT(i,j+1))) )) + ( 0.5*((G%bathyT(i+1,j+1)) + G%bathyT(i,j+1))) ) enddo ; endif enddo ; enddo endif From 650683ce9425e2e173bd40404e1f23abcf535f72 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 2 Jul 2020 07:46:17 -0400 Subject: [PATCH 18/91] +Aligned newlines with module documentation Modified doc_module so that new lines are added only when modules are documented, and are added in all parameter_doc files in which modules are documented. All answers and output are identical, but there are white space changes in MOM_parameter_doc and SIS_parameter_doc files. --- src/framework/MOM_document.F90 | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/framework/MOM_document.F90 b/src/framework/MOM_document.F90 index 1a732533b0..28ba9c1ac1 100644 --- a/src/framework/MOM_document.F90 +++ b/src/framework/MOM_document.F90 @@ -776,7 +776,9 @@ subroutine doc_module(doc, modname, desc, log_to_all, all_default, layoutMod, de call open_doc_file(doc) if (doc%filesAreOpen) then - call writeMessageAndDesc(doc, '', '') ! Blank line for delineation + ! Add a blank line for delineation + call writeMessageAndDesc(doc, '', '', valueWasDefault=all_default, & + layoutParam=layoutMod, debuggingParam=debuggingMod) mesg = "! === module "//trim(modname)//" ===" call writeMessageAndDesc(doc, mesg, desc, valueWasDefault=all_default, indent=0, & layoutParam=layoutMod, debuggingParam=debuggingMod) @@ -786,8 +788,10 @@ subroutine doc_module(doc, modname, desc, log_to_all, all_default, layoutMod, de repeat_doc = .false. if (present(layoutMod)) then ; if (layoutMod) repeat_doc = .true. ; endif if (present(debuggingMod)) then ; if (debuggingMod) repeat_doc = .true. ; endif - if (repeat_doc) & + if (repeat_doc) then + call writeMessageAndDesc(doc, '', '', valueWasDefault=all_default) call writeMessageAndDesc(doc, mesg, desc, valueWasDefault=all_default, indent=0) + endif endif ; endif endif end subroutine doc_module From 515f3292cc34c0a7d9ab9f2f18752c83c1073df2 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Thu, 2 Jul 2020 10:19:28 -0800 Subject: [PATCH 19/91] Added halo updates for OBC radiation speeds. --- src/core/MOM_open_boundary.F90 | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index bf3d24a790..c0e64db491 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -9,7 +9,7 @@ module MOM_open_boundary use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE use MOM_diag_mediator, only : diag_ctrl, time_type use MOM_domains, only : pass_var, pass_vector -use MOM_domains, only : To_All, SCALAR_PAIR, CGRID_NE +use MOM_domains, only : To_All, SCALAR_PAIR, CGRID_NE, CORNER use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe use MOM_error_handler, only : NOTE use MOM_file_parser, only : get_param, log_version, param_file_type, log_param @@ -1598,6 +1598,11 @@ subroutine open_boundary_init(G, GV, US, param_file, OBC, restart_CSp) if (.not.associated(OBC)) return id_clock_pass = cpu_clock_id('(Ocean OBC halo updates)', grain=CLOCK_ROUTINE) + if (OBC%radiation_BCs_exist_globally) call pass_vector(OBC%rx_normal, OBC%ry_normal, G%Domain, & + To_All+Scalar_Pair) + if (OBC%oblique_BCs_exist_globally) call pass_vector(OBC%rx_oblique, OBC%ry_oblique, G%Domain, & + To_All+Scalar_Pair) + if (associated(OBC%cff_normal)) call pass_var(OBC%cff_normal, G%Domain, position=CORNER) ! The rx_normal and ry_normal arrays used with radiation OBCs are currently in units of grid ! points per timestep, but if this were to be corrected to [L T-1 ~> m s-1] or [T-1 ~> s-1] to From 2c1864998181c77f699657db76f9701b51dda98e Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Thu, 2 Jul 2020 19:28:12 -0800 Subject: [PATCH 20/91] Fixing the OMP issue? --- src/core/MOM_isopycnal_slopes.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index b0a66b9488..84df62b801 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -281,7 +281,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & !$OMP parallel do default(none) shared(nz,is,ie,js,je,IsdB,use_EOS,G,GV,US,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,EOSdom_v, & - !$OMP local_open_v_BC) & + !$OMP local_open_v_BC,OBC%segnum_u,OBC%segnum_v) & !$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, & From 209389a99b72ad8f973d4c4300bf7f1bbbdd521b Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Thu, 2 Jul 2020 19:31:35 -0800 Subject: [PATCH 21/91] Was hoping this would fix flux_y, but no. --- src/tracer/MOM_tracer_advect.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index 5868d60b46..6a362d4fd5 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -459,13 +459,13 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & if (segment%direction == OBC_DIRECTION_W) then T_tmp(i,m) = segment%tr_Reg%Tr(m)%tres(i,j,k) else - T_tmp(I+1,m) = segment%tr_Reg%Tr(m)%tres(i,j,k) + T_tmp(i+1,m) = segment%tr_Reg%Tr(m)%tres(i,j,k) endif else if (segment%direction == OBC_DIRECTION_W) then T_tmp(i,m) = segment%tr_Reg%Tr(m)%OBC_inflow_conc else - T_tmp(I+1,m) = segment%tr_Reg%Tr(m)%OBC_inflow_conc + T_tmp(i+1,m) = segment%tr_Reg%Tr(m)%OBC_inflow_conc endif endif enddo @@ -913,7 +913,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & endif ! Implementation of PPM-H3 - Tp = Tr(m)%t(i,j_up+1,k) ; Tc = Tr(m)%t(i,j_up,k) ; Tm = Tr(m)%t(i,j_up-1,k) + Tp = T_tmp(i,m,j_up+1) ; Tc = T_tmp(i,m,j_up) ; Tm = T_tmp(i,m,j_up-1) if (useHuynh) then aL = ( 5.*Tc + ( 2.*Tm - Tp ) )/6. ! H3 estimate @@ -955,7 +955,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & !aR = Tr(m)%t(i,j,k) + 0.5 * slope_y(i,m,j) !flux_y(i,m,J) = vhh(i,J)*(aR - 0.5 * slope_y(i,m,j)*CFL(i)) ! Alternative implementation of PLM - Tc = Tr(m)%t(i,j,k) + Tc = T_tmp(i,m,j) flux_y(i,m,J) = vhh(i,J)*( Tc + 0.5 * slope_y(i,m,j) * ( 1. - CFL(i) ) ) ! Original implementation of PLM !flux_y(i,m,J) = vhh(i,J)*(Tr(m)%t(i,j,k) + slope_y(i,m,j)*ts2(i)) @@ -968,7 +968,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & !aL = Tr(m)%t(i,j+1,k) - 0.5 * slope_y(i,m,j+1) !flux_y(i,m,J) = vhh(i,J)*( aL + 0.5 * slope_y(i,m,j+1)*CFL(i) ) ! Alternative implementation of PLM - Tc = Tr(m)%t(i,j+1,k) + Tc = T_tmp(i,m,j+1) flux_y(i,m,J) = vhh(i,J)*( Tc - 0.5 * slope_y(i,m,j+1) * ( 1. - CFL(i) ) ) ! Original implementation of PLM !flux_y(i,m,J) = vhh(i,J)*(Tr(m)%t(i,j+1,k) - slope_y(i,m,j+1)*ts2(i)) From d1cd69623b93625127b1399d38fed372100f5255 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 3 Jul 2020 04:03:30 -0400 Subject: [PATCH 22/91] +Add like_default optional argument to log_param Added the new optional argument like_default to the log_param and doc_param routines to help control where the documentation appears. This new argument is used for logging EPBL_USTAR_MIN, the diagnosed output value of MAXIMUM_DEPTH when the input value is negative, and the diagnosed number of columns where sponges occur with MOM_ALE_sponge. An '!' was also added to the logging of EPBL_USTAR_MIN. All answers are bitwise identical but there are minor changes in the contents of some MOM_parameter_doc.short files. --- src/framework/MOM_document.F90 | 42 ++++++++++++---- src/framework/MOM_file_parser.F90 | 50 ++++++++++++------- .../MOM_fixed_initialization.F90 | 2 +- .../vertical/MOM_ALE_sponge.F90 | 12 ++--- .../vertical/MOM_energetic_PBL.F90 | 5 +- 5 files changed, 75 insertions(+), 36 deletions(-) diff --git a/src/framework/MOM_document.F90 b/src/framework/MOM_document.F90 index 28ba9c1ac1..15d0839ee9 100644 --- a/src/framework/MOM_document.F90 +++ b/src/framework/MOM_document.F90 @@ -85,7 +85,7 @@ end subroutine doc_param_none !> This subroutine handles parameter documentation for logicals. subroutine doc_param_logical(doc, varname, desc, units, val, default, & - layoutParam, debuggingParam) + layoutParam, debuggingParam, like_default) 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 @@ -95,6 +95,8 @@ subroutine doc_param_logical(doc, varname, desc, units, val, default, & 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. + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as though + !! it has the default value, even if there is no default. ! This subroutine handles parameter documentation for logicals. character(len=mLen) :: mesg logical :: equalsDefault @@ -110,6 +112,7 @@ subroutine doc_param_logical(doc, varname, desc, units, val, default, & endif equalsDefault = .false. + if (present(like_default)) equalsDefault = like_default if (present(default)) then if (val .eqv. default) equalsDefault = .true. if (default) then @@ -127,7 +130,7 @@ 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) + layoutParam, debuggingParam, like_default) 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 @@ -137,6 +140,8 @@ subroutine doc_param_logical_array(doc, varname, desc, units, vals, default, & 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. + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as though + !! it has the default value, even if there is no default. ! This subroutine handles parameter documentation for arrays of logicals. integer :: i character(len=mLen) :: mesg @@ -158,7 +163,7 @@ subroutine doc_param_logical_array(doc, varname, desc, units, vals, default, & mesg = define_string(doc, varname, valstring, units) - equalsDefault = .false. + equalsDefault = .false. if (present(default)) then equalsDefault = .true. do i=1,size(vals) ; if (vals(i) .neqv. default) equalsDefault = .false. ; enddo @@ -168,6 +173,7 @@ subroutine doc_param_logical_array(doc, varname, desc, units, vals, default, & mesg = trim(mesg)//" default = "//STRING_FALSE endif endif + if (present(like_default)) then ; if (like_default) equalsDefault = .true. ; endif if (mesgHasBeenDocumented(doc, varName, mesg)) return ! Avoid duplicates call writeMessageAndDesc(doc, mesg, desc, equalsDefault, & @@ -177,7 +183,7 @@ 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) + layoutParam, debuggingParam, like_default) 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 @@ -187,6 +193,8 @@ subroutine doc_param_int(doc, varname, desc, units, val, default, & 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. + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as though + !! it has the default value, even if there is no default. ! This subroutine handles parameter documentation for integers. character(len=mLen) :: mesg character(len=doc%commentColumn) :: valstring @@ -200,6 +208,7 @@ subroutine doc_param_int(doc, varname, desc, units, val, default, & mesg = define_string(doc, varname, valstring, units) equalsDefault = .false. + if (present(like_default)) equalsDefault = like_default if (present(default)) then if (val == default) equalsDefault = .true. mesg = trim(mesg)//" default = "//(trim(int_string(default))) @@ -213,7 +222,7 @@ 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) + layoutParam, debuggingParam, like_default) 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 @@ -223,6 +232,8 @@ subroutine doc_param_int_array(doc, varname, desc, units, vals, default, & 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. + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as though + !! it has the default value, even if there is no default. ! This subroutine handles parameter documentation for arrays of integers. integer :: i character(len=mLen) :: mesg @@ -246,6 +257,7 @@ subroutine doc_param_int_array(doc, varname, desc, units, vals, default, & do i=1,size(vals) ; if (vals(i) /= default) equalsDefault = .false. ; enddo mesg = trim(mesg)//" default = "//(trim(int_string(default))) endif + if (present(like_default)) then ; if (like_default) equalsDefault = .true. ; endif if (mesgHasBeenDocumented(doc, varName, mesg)) return ! Avoid duplicates call writeMessageAndDesc(doc, mesg, desc, equalsDefault, & @@ -255,7 +267,7 @@ 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) +subroutine doc_param_real(doc, varname, desc, units, val, default, debuggingParam, like_default) 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 @@ -264,6 +276,8 @@ subroutine doc_param_real(doc, varname, desc, units, val, default, debuggingPara 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. + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as though + !! it has the default value, even if there is no default. ! This subroutine handles parameter documentation for reals. character(len=mLen) :: mesg character(len=doc%commentColumn) :: valstring @@ -277,6 +291,7 @@ subroutine doc_param_real(doc, varname, desc, units, val, default, debuggingPara mesg = define_string(doc, varname, valstring, units) equalsDefault = .false. + if (present(like_default)) equalsDefault = like_default if (present(default)) then if (val == default) equalsDefault = .true. mesg = trim(mesg)//" default = "//trim(real_string(default)) @@ -288,7 +303,7 @@ subroutine doc_param_real(doc, varname, desc, units, val, default, debuggingPara 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) +subroutine doc_param_real_array(doc, varname, desc, units, vals, default, debuggingParam, like_default) 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 @@ -297,6 +312,8 @@ subroutine doc_param_real_array(doc, varname, desc, units, vals, default, debugg 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. + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as though + !! it has the default value, even if there is no default. ! This subroutine handles parameter documentation for arrays of reals. integer :: i character(len=mLen) :: mesg @@ -317,6 +334,7 @@ subroutine doc_param_real_array(doc, varname, desc, units, vals, default, debugg do i=1,size(vals) ; if (vals(i) /= default) equalsDefault = .false. ; enddo mesg = trim(mesg)//" default = "//trim(real_string(default)) endif + if (present(like_default)) then ; if (like_default) equalsDefault = .true. ; endif if (mesgHasBeenDocumented(doc, varName, mesg)) return ! Avoid duplicates call writeMessageAndDesc(doc, mesg, desc, equalsDefault, debuggingParam=debuggingParam) @@ -326,7 +344,7 @@ 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) + layoutParam, debuggingParam, like_default) 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 @@ -337,6 +355,8 @@ subroutine doc_param_char(doc, varname, desc, units, val, default, & 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. + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as though + !! it has the default value, even if there is no default. ! This subroutine handles parameter documentation for character strings. character(len=mLen) :: mesg logical :: equalsDefault @@ -348,6 +368,7 @@ subroutine doc_param_char(doc, varname, desc, units, val, default, & mesg = define_string(doc, varname, '"'//trim(val)//'"', units) equalsDefault = .false. + if (present(like_default)) equalsDefault = like_default if (present(default)) then if (trim(val) == trim(default)) equalsDefault = .true. mesg = trim(mesg)//' default = "'//trim(adjustl(default))//'"' @@ -412,7 +433,7 @@ subroutine doc_closeBlock(doc, blockName) end subroutine doc_closeBlock !> This subroutine handles parameter documentation for time-type variables. -subroutine doc_param_time(doc, varname, desc, val, default, units, debuggingParam) +subroutine doc_param_time(doc, varname, desc, val, default, units, debuggingParam, like_default) 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 @@ -421,6 +442,8 @@ subroutine doc_param_time(doc, varname, desc, val, default, units, debuggingPara type(time_type), optional, intent(in) :: default !< The default value of this parameter character(len=*), optional, intent(in) :: units !< The units of the parameter being documented logical, optional, intent(in) :: debuggingParam !< If present and true, this is a debugging parameter. + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as though + !! it has the default value, even if there is no default. ! Local varables character(len=mLen) :: mesg ! The output message @@ -439,6 +462,7 @@ subroutine doc_param_time(doc, varname, desc, val, default, units, debuggingPara endif equalsDefault = .false. + if (present(like_default)) equalsDefault = like_default if (present(default)) then if (val == default) equalsDefault = .true. mesg = trim(mesg)//" default = "//trim(time_string(default)) diff --git a/src/framework/MOM_file_parser.F90 b/src/framework/MOM_file_parser.F90 index a07d828e5b..2e7a14dbe4 100644 --- a/src/framework/MOM_file_parser.F90 +++ b/src/framework/MOM_file_parser.F90 @@ -1289,7 +1289,7 @@ 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) + default, layoutParam, debuggingParam, like_default) 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 @@ -1303,6 +1303,8 @@ subroutine log_param_int(CS, modulename, varname, value, desc, units, & !! 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) :: like_default !< If present and true, log this parameter as + !! though it has the default value, even if there is no default. character(len=240) :: mesg, myunits @@ -1315,13 +1317,13 @@ subroutine log_param_int(CS, modulename, varname, value, desc, units, & myunits=" "; if (present(units)) write(myunits(1:240),'(A)') trim(units) if (present(desc)) & call doc_param(CS%doc, varname, desc, myunits, value, default, & - layoutParam=layoutParam, debuggingParam=debuggingParam) + layoutParam=layoutParam, debuggingParam=debuggingParam, like_default=like_default) 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) + units, default, layoutParam, debuggingParam, like_default) 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 @@ -1335,6 +1337,8 @@ subroutine log_param_int_array(CS, modulename, varname, value, desc, & !! 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) :: like_default !< If present and true, log this parameter as + !! though it has the default value, even if there is no default. character(len=1320) :: mesg character(len=240) :: myunits @@ -1348,13 +1352,13 @@ subroutine log_param_int_array(CS, modulename, varname, value, desc, & myunits=" "; if (present(units)) write(myunits(1:240),'(A)') trim(units) if (present(desc)) & call doc_param(CS%doc, varname, desc, myunits, value, default, & - layoutParam=layoutParam, debuggingParam=debuggingParam) + layoutParam=layoutParam, debuggingParam=debuggingParam, like_default=like_default) 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) + default, debuggingParam, like_default) 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 @@ -1366,6 +1370,8 @@ subroutine log_param_real(CS, modulename, varname, value, desc, units, & 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 + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as + !! though it has the default value, even if there is no default. character(len=240) :: mesg, myunits @@ -1379,13 +1385,13 @@ subroutine log_param_real(CS, modulename, varname, value, desc, units, & myunits="not defined"; if (present(units)) write(myunits(1:240),'(A)') trim(units) if (present(desc)) & call doc_param(CS%doc, varname, desc, myunits, value, default, & - debuggingParam=debuggingParam) + debuggingParam=debuggingParam, like_default=like_default) 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, debuggingParam) + units, default, debuggingParam, like_default) 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 @@ -1397,6 +1403,8 @@ subroutine log_param_real_array(CS, modulename, varname, value, desc, & 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 + logical, optional, intent(in) :: like_default !< If present and true, log this parameter as + !! though it has the default value, even if there is no default. character(len=1320) :: mesg character(len=240) :: myunits @@ -1414,13 +1422,13 @@ subroutine log_param_real_array(CS, modulename, varname, value, desc, & myunits="not defined"; if (present(units)) write(myunits(1:240),'(A)') trim(units) if (present(desc)) & call doc_param(CS%doc, varname, desc, myunits, value, default, & - debuggingParam=debuggingParam) + debuggingParam=debuggingParam, like_default=like_default) 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) + units, default, layoutParam, debuggingParam, like_default) 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 @@ -1434,6 +1442,8 @@ subroutine log_param_logical(CS, modulename, varname, value, desc, & !! 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) :: like_default !< If present and true, log this parameter as + !! though it has the default value, even if there is no default. character(len=240) :: mesg, myunits @@ -1450,13 +1460,13 @@ subroutine log_param_logical(CS, modulename, varname, value, desc, & myunits="Boolean"; if (present(units)) write(myunits(1:240),'(A)') trim(units) if (present(desc)) & call doc_param(CS%doc, varname, desc, myunits, value, default, & - layoutParam=layoutParam, debuggingParam=debuggingParam) + layoutParam=layoutParam, debuggingParam=debuggingParam, like_default=like_default) 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) + default, layoutParam, debuggingParam, like_default) 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 @@ -1470,6 +1480,8 @@ subroutine log_param_char(CS, modulename, varname, value, desc, units, & !! 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) :: like_default !< If present and true, log this parameter as + !! though it has the default value, even if there is no default. character(len=240) :: mesg, myunits @@ -1483,14 +1495,14 @@ subroutine log_param_char(CS, modulename, varname, value, desc, units, & myunits=" "; if (present(units)) write(myunits(1:240),'(A)') trim(units) if (present(desc)) & call doc_param(CS%doc, varname, desc, myunits, value, default, & - layoutParam=layoutParam, debuggingParam=debuggingParam) + layoutParam=layoutParam, debuggingParam=debuggingParam, like_default=like_default) end subroutine log_param_char !> This subroutine writes the value of a time-type parameter to a log file, !! 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) + default, timeunit, layoutParam, debuggingParam, log_date, like_default) 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 @@ -1508,6 +1520,8 @@ subroutine log_param_time(CS, modulename, varname, value, desc, units, & !! 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) :: like_default !< If present and true, log this parameter as + !! though it has the default value, even if there is no default. ! Local variables real :: real_time, real_default @@ -1543,10 +1557,10 @@ subroutine log_param_time(CS, modulename, varname, value, desc, units, & default_string = convert_date_to_string(default) call doc_param(CS%doc, varname, desc, myunits, date_string, & default=default_string, layoutParam=layoutParam, & - debuggingParam=debuggingParam) + debuggingParam=debuggingParam, like_default=like_default) else call doc_param(CS%doc, varname, desc, myunits, date_string, & - layoutParam=layoutParam, debuggingParam=debuggingParam) + layoutParam=layoutParam, debuggingParam=debuggingParam, like_default=like_default) endif elseif (use_timeunit) then if (present(units)) then @@ -1566,12 +1580,12 @@ subroutine log_param_time(CS, modulename, varname, value, desc, units, & real_default = (86400.0/timeunit)*days + secs/timeunit if (ticks > 0) real_default = real_default + & real(ticks) / (timeunit*get_ticks_per_second()) - call doc_param(CS%doc, varname, desc, myunits, real_time, real_default) + call doc_param(CS%doc, varname, desc, myunits, real_time, real_default, like_default=like_default) else - call doc_param(CS%doc, varname, desc, myunits, real_time) + call doc_param(CS%doc, varname, desc, myunits, real_time, like_default=like_default) endif else - call doc_param(CS%doc, varname, desc, value, default, units=units) + call doc_param(CS%doc, varname, desc, value, default, units=units, like_default=like_default) endif endif diff --git a/src/initialization/MOM_fixed_initialization.F90 b/src/initialization/MOM_fixed_initialization.F90 index 1ddf6f2345..b075da4141 100644 --- a/src/initialization/MOM_fixed_initialization.F90 +++ b/src/initialization/MOM_fixed_initialization.F90 @@ -249,7 +249,7 @@ subroutine MOM_initialize_topography(D, max_depth, G, PF, US) else max_depth = diagnoseMaximumDepth(D,G) call log_param(PF, mdl, "!MAXIMUM_DEPTH", max_depth*Z_to_m, & - "The (diagnosed) maximum depth of the ocean.", units="m") + "The (diagnosed) maximum depth of the ocean.", units="m", like_default=.true.) endif if (trim(config) /= "DOME") then call limit_topography(D, G, PF, max_depth, US) diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index 5088a92d6e..27aa43274b 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -256,7 +256,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ answers_2018=CS%remap_answers_2018) call log_param(param_file, mdl, "!Total sponge columns at h points", total_sponge_cols, & - "The total number of columns where sponges are applied at h points.") + "The total number of columns where sponges are applied at h points.", like_default=.true.) if (CS%sponge_uv) then @@ -300,7 +300,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ 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.") + "The total number of columns where sponges are applied at u points.", like_default=.true.) ! v points CS%num_col_v = 0 ; !CS%fldno_v = 0 @@ -336,7 +336,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ 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.") + "The total number of columns where sponges are applied at v points.", like_default=.true.) endif end subroutine initialize_ALE_sponge_fixed @@ -484,7 +484,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) call initialize_remapping(CS%remap_cs, remapScheme, boundary_extrapolation=bndExtrapolation, & answers_2018=CS%remap_answers_2018) call log_param(param_file, mdl, "!Total sponge columns at h points", total_sponge_cols, & - "The total number of columns where sponges are applied at h points.") + "The total number of columns where sponges are applied at h points.", like_default=.true.) if (CS%sponge_uv) then 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 @@ -513,7 +513,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) 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.") + "The total number of columns where sponges are applied at u points.", like_default=.true.) ! v points CS%num_col_v = 0 ; !CS%fldno_v = 0 do J=CS%jscB,CS%jecB; do i=CS%isc,CS%iec @@ -538,7 +538,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) 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.") + "The total number of columns where sponges are applied at v points.", like_default=.true.) endif end subroutine initialize_ALE_sponge_varying diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 32c2797394..5a9e67bfd9 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -2339,9 +2339,10 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) !/ Logging parameters ! This gives a minimum decay scale that is typically much less than Angstrom. CS%ustar_min = 2e-4*CS%omega*(GV%Angstrom_Z + GV%H_to_Z*GV%H_subroundoff) - call log_param(param_file, mdl, "EPBL_USTAR_MIN", CS%ustar_min*US%Z_to_m*US%s_to_T, & + call log_param(param_file, mdl, "!EPBL_USTAR_MIN", CS%ustar_min*US%Z_to_m*US%s_to_T, & "The (tiny) minimum friction velocity used within the "//& - "ePBL code, derived from OMEGA and ANGSTROM.", units="m s-1") + "ePBL code, derived from OMEGA and ANGSTROM.", units="m s-1", & + like_default=.true.) !/ Checking output flags From e9c1f6c7e726ff9e9c7067cc15346d43db66dcce Mon Sep 17 00:00:00 2001 From: Graeme MacGilchrist Date: Fri, 3 Jul 2020 09:55:35 -0400 Subject: [PATCH 23/91] altered OpenMP directive for diagnostic --- src/diagnostics/MOM_diagnostics.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 7d390159bb..f26e7fc815 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -622,7 +622,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & endif if (CS%id_drho_dT > 0 .or. CS%id_drho_dS > 0) then - !$OMP parallel do default(none) shared(tv,Rcv,is,ie,js,je,nz,pressure_1d,h,GV) + !$OMP parallel do default(shared) private(pressure_1d) do j=js,je pressure_1d(:) = 0. ! Start at p=0 Pa at surface do k=1,nz From 029af686e9453f2671bbf622fd44fc366415d818 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 6 Jul 2020 06:29:38 -0400 Subject: [PATCH 24/91] +Set all_default for 4 log_version calls Added code to determine whether all parameters in the MOM_grid, MOM_restart, MOM_write_cputime and MOM_tracer_registry modules are being used with their default settings, and added all_default arguments to the log_version calls for these modules. All answers and output are identical, but there are white space changes in MOM_parameter_doc.short and SIS_parameter_doc.short files. --- src/core/MOM_grid.F90 | 4 ++-- src/framework/MOM_restart.F90 | 22 +++++++++++++++++++--- src/framework/MOM_write_cputime.F90 | 13 ++++++++++--- src/tracer/MOM_tracer_registry.F90 | 2 +- 4 files changed, 32 insertions(+), 9 deletions(-) diff --git a/src/core/MOM_grid.F90 b/src/core/MOM_grid.F90 index f6c8b44986..8844c65f40 100644 --- a/src/core/MOM_grid.F90 +++ b/src/core/MOM_grid.F90 @@ -210,10 +210,10 @@ subroutine MOM_grid_init(G, param_file, US, HI, global_indexing, bathymetry_at_v ! Read all relevant parameters and write them to the model log. + call get_param(param_file, mod_nm, "REFERENCE_HEIGHT", G%Z_ref, default=0.0, do_not_log=.true.) call log_version(param_file, mod_nm, version, & "Parameters providing information about the lateral grid.", & - log_to_all=.true., layout=.true.) - + log_to_all=.true., layout=.true., all_default=(G%Z_ref==0.0)) call get_param(param_file, mod_nm, "NIBLOCK", niblock, "The number of blocks "// & "in the x-direction on each processor (for openmp).", default=1, & diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index c918f3a9ee..ed29b99b55 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -1511,6 +1511,7 @@ subroutine restart_init(param_file, CS, restart_root) ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "MOM_restart" ! This module's name. + logical :: all_default ! If true, all parameters are using their default values. if (associated(CS)) then call MOM_error(WARNING, "restart_init called with an associated control structure.") @@ -1518,10 +1519,25 @@ subroutine restart_init(param_file, CS, restart_root) endif allocate(CS) + ! Determine whether all paramters are set to their default values. + call get_param(param_file, mdl, "PARALLEL_RESTARTFILES", CS%parallel_restartfiles, & + default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "LARGE_FILE_SUPPORT", CS%large_file_support, & + default=.true., do_not_log=.true.) + call get_param(param_file, mdl, "MAX_FIELDS", CS%max_fields, default=100, do_not_log=.true.) + call get_param(param_file, mdl, "RESTART_CHECKSUMS_REQUIRED", CS%checksum_required, & + default=.true., do_not_log=.true.) + all_default = ((.not.CS%parallel_restartfiles) .and. (CS%large_file_support) .and. & + (CS%max_fields == 100) .and. (CS%checksum_required)) + if (.not.present(restart_root)) then + call get_param(param_file, mdl, "RESTARTFILE", CS%restartfile, & + default="MOM.res", do_not_log=.true.) + all_default = (all_default .and. (trim(CS%restartfile) == trim("MOM.res"))) + endif + ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "") - call get_param(param_file, mdl, "PARALLEL_RESTARTFILES", & - CS%parallel_restartfiles, & + call log_version(param_file, mdl, version, "", all_default=all_default) + call get_param(param_file, mdl, "PARALLEL_RESTARTFILES", CS%parallel_restartfiles, & "If true, each processor writes its own restart file, "//& "otherwise a single restart file is generated", & default=.false.) diff --git a/src/framework/MOM_write_cputime.F90 b/src/framework/MOM_write_cputime.F90 index 7a2fb36608..1f0e001073 100644 --- a/src/framework/MOM_write_cputime.F90 +++ b/src/framework/MOM_write_cputime.F90 @@ -60,9 +60,10 @@ subroutine MOM_write_cputime_init(param_file, directory, Input_start_time, CS) ! Local variables integer :: new_cputime ! The CPU time returned by SYSTEM_CLOCK -! 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_write_cputime' ! This module's name. + logical :: all_default ! If true, all parameters are using their default values. if (.not.associated(CS)) then allocate(CS) @@ -71,7 +72,13 @@ subroutine MOM_write_cputime_init(param_file, directory, Input_start_time, CS) endif ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "") + + ! Determine whether all paramters are set to their default values. + call get_param(param_file, mdl, "MAXCPU", CS%maxcpu, default=-1.0, do_not_log=.true.) + call get_param(param_file, mdl, "CPU_TIME_FILE", CS%CPUfile, default="CPU_stats", do_not_log=.true.) + all_default = (CS%maxcpu == -1.0) .and. (trim(CS%CPUfile) == trim("CPU_stats")) + + call log_version(param_file, mdl, version, "", all_default=all_default) call get_param(param_file, mdl, "MAXCPU", CS%maxcpu, & "The maximum amount of cpu time per processor for which "//& "MOM should run before saving a restart file and "//& diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index 16ee280355..5097501b61 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -869,7 +869,7 @@ subroutine tracer_registry_init(param_file, Reg) else ; return ; endif ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "") + call log_version(param_file, mdl, version, "", all_default=.true.) init_calls = init_calls + 1 if (init_calls > 1) then From 153417fbb95d056e7085dceb8c8d6f2745fd845b Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Mon, 6 Jul 2020 14:20:52 -0400 Subject: [PATCH 25/91] Correted OMP directives for two OBC variables - Members of a type cannot be individually labelled as shared/private - One variable was converted to shared since it was defiend in a non-OMP section and then labelled as private which meant it was uninitialized. --- src/core/MOM_isopycnal_slopes.F90 | 5 +++-- src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 | 6 ++---- 2 files changed, 5 insertions(+), 6 deletions(-) diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index 84df62b801..58bc196744 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -178,7 +178,8 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & !$OMP parallel do default(none) shared(nz,is,ie,js,je,IsdB,use_EOS,G,GV,US,pres,T,S,tv,h,e, & !$OMP h_neglect,dz_neglect,Z_to_L,L_to_Z,H_to_Z,h_neglect2, & - !$OMP present_N2_u,G_Rho0,N2_u,slope_x,EOSdom_u,local_open_u_BC) & + !$OMP present_N2_u,G_Rho0,N2_u,slope_x,EOSdom_u,local_open_u_BC, & + !$OMP OBC) & !$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, & @@ -281,7 +282,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & !$OMP parallel do default(none) shared(nz,is,ie,js,je,IsdB,use_EOS,G,GV,US,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,EOSdom_v, & - !$OMP local_open_v_BC,OBC%segnum_u,OBC%segnum_v) & + !$OMP local_open_v_BC,OBC) & !$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, & diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index c227bdfdb7..e0def91821 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -534,8 +534,7 @@ subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS, O ! calculate the first-mode gravity wave speed and then blend the equatorial ! and midlatitude deformation radii, using calc_resoln_function as a template. - !$OMP parallel do default(shared) private(S2,H_u,Hdn,Hup,H_geom,N2,wNE,wSE,wSW,wNW, & - !$OMP local_open_u_BC) + !$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. @@ -576,8 +575,7 @@ subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS, O enddo enddo - !$OMP parallel do default(shared) private(S2,H_v,Hdn,Hup,H_geom,N2,wNE,wSE,wSW,wNW, & - !$OMP local_open_u_BC) + !$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. From 5736bcf90a4b2f3aba0d88d31e5204ff838d1a3e Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 7 Jul 2020 11:41:52 -0400 Subject: [PATCH 26/91] Fixed trailing whtiespace for #1148 --- config_src/solo_driver/MOM_driver.F90 | 4 ++-- src/framework/MOM_domains.F90 | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/config_src/solo_driver/MOM_driver.F90 b/config_src/solo_driver/MOM_driver.F90 index 6e5115bc62..f180cd9717 100644 --- a/config_src/solo_driver/MOM_driver.F90 +++ b/config_src/solo_driver/MOM_driver.F90 @@ -252,13 +252,13 @@ program MOM_main endif endif -!$ call fms_affinity_init +!$ call fms_affinity_init !$ call fms_affinity_set('OCEAN', use_hyper_thread, ocean_nthreads) !$ call omp_set_num_threads(ocean_nthreads) !$OMP PARALLEL !$ write(6,*) "ocean_solo OMPthreading ", fms_affinity_get(), omp_get_thread_num(), omp_get_num_threads() !$ call flush(6) -!$OMP END PARALLEL +!$OMP END PARALLEL ! Read ocean_solo restart, which can override settings from the namelist. if (file_exists(trim(dirs%restart_input_dir)//'ocean_solo.res')) then diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index 24dbd0a011..7cf9df39f1 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -1274,7 +1274,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & default=.false.) #ifndef NOT_SET_AFFINITY -!$ call fms_affinity_init +!$ call fms_affinity_init !$OMP PARALLEL !$OMP master !$ ocean_nthreads = omp_get_num_threads() From 50197105372fa8e5a4ab053173f7d70f2a5e0f8b Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Thu, 30 Apr 2020 16:26:24 +0000 Subject: [PATCH 27/91] Adds the Stanley version of EOS - Stanley et al., 2020, adds the Brankart modification to volume mean density via linear corrections involving SGS sample variances and covariances of T and S. This commit adds the new interfaces that allow a call to calculate_density to include the variances and covariance as arguments. This correction sits above the particular EOS and thus can use any EOS so long as second derivatives are available within the EOS module. --- src/equation_of_state/MOM_EOS.F90 | 152 ++++++++++++++++++++++++++++++ 1 file changed, 152 insertions(+) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index c584b68c89..44d34ce475 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -60,6 +60,8 @@ module MOM_EOS !> Calculates density of sea water from T, S and P interface calculate_density module procedure calculate_density_scalar, calculate_density_array, calculate_density_1d + module procedure calculate_stanley_density_scalar, calculate_stanley_density_array + module procedure calculate_stanley_density_1d end interface calculate_density !> Calculates specific volume of sea water from T, S and P @@ -193,6 +195,43 @@ subroutine calculate_density_scalar(T, S, pressure, rho, EOS, rho_ref, scale) end subroutine calculate_density_scalar +!> Calls the appropriate subroutine to calculate density of sea water for scalar inputs +!! including the variance of T, S and covariance of T-S. +!! The calculation uses only the second order correction in a series as discussed +!! in Stanley et al., 2020. +!! If rho_ref is present, the anomaly with respect to rho_ref is returned. The +!! density can be rescaled using rho_ref. +subroutine calculate_stanley_density_scalar(T, S, pressure, Tvar, TScov, Svar, rho, EOS, rho_ref, scale) + real, intent(in) :: T !< Potential temperature referenced to the surface [degC] + real, intent(in) :: S !< Salinity [ppt] + real, intent(in) :: Tvar !< Variance of potential temperature referenced to the surface [degC2] + real, intent(in) :: TScov !< Covariance of potential temperature and salinity [degC ppt] + real, intent(in) :: Svar !< Variance of salinity [ppt2] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: rho !< Density (in-situ if pressure is local) [kg m-3] or [R ~> kg m-3] + type(EOS_type), pointer :: EOS !< Equation of state structure + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density + !! from kg m-3 to the desired units [R m3 kg-1] + ! Local variables + real :: d2RdTT, d2RdST, d2RdSS, d2RdSp, d2RdTp ! Second derivatives of density wrt T,S,p + + if (.not.associated(EOS)) call MOM_error(FATAL, & + "calculate_density_scalar called with an unassociated EOS_type EOS.") + + ! Branching to the correct EOS happens within each of these calls + ! and will appropriately error if the second derivatives are not available. + call calculate_density_second_derivs_scalar(T, S, pressure, d2RdSS, d2RdST, d2RdTT, & + d2RdSp, d2RdTp, EOS) + call calculate_density_scalar(T, S, pressure, rho, EOS, rho_ref) + + ! Equation 25 of Stanley et al., 2020. + rho = rho + ( 0.5 * d2RdTT * Tvar + ( d2RdST * TScov + 0.5 * d2RdSS * Svar ) ) + + if (present(scale)) rho = scale * rho + +end subroutine calculate_stanley_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, scale) @@ -234,6 +273,49 @@ subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_re end subroutine calculate_density_array +!> Calls the appropriate subroutine to calculate the density of sea water for 1-D array inputs +!! including the variance of T, S and covariance of T-S. +!! The calculation uses only the second order correction in a series as discussed +!! in Stanley et al., 2020. +!! If rho_ref is present, the anomaly with respect to rho_ref is returned. +subroutine calculate_stanley_density_array(T, S, pressure, Tvar, TScov, Svar, rho, start, npts, EOS, rho_ref, scale) + 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(in) :: Tvar !< Variance of potential temperature referenced to the surface [degC2] + real, dimension(:), intent(in) :: TScov !< Covariance of potential temperature and salinity [degC ppt] + real, dimension(:), intent(in) :: Svar !< Variance of salinity [ppt2] + real, dimension(:), intent(inout) :: rho !< Density (in-situ if pressure is local) [kg m-3] or [R ~> 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 [kg m-3]. + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density + !! from kg m-3 to the desired units [R m3 kg-1] + ! Local variables + real, dimension(size(T)) :: d2RdTT, d2RdST, d2RdSS, d2RdSp, d2RdTp ! Second derivatives of density wrt T,S,p + integer :: j + + if (.not.associated(EOS)) call MOM_error(FATAL, & + "calculate_density_array called with an unassociated EOS_type EOS.") + + ! Branching to the correct EOS happens within each of these calls + ! and will appropriately error if the second derivatives are not available. + call calculate_density_second_derivs_array(T, S, pressure, d2RdSS, d2RdST, d2RdTT, & + d2RdSp, d2RdTp, start, npts, EOS) + call calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_ref) + + ! Equation 25 of Stanley et al., 2020. + do j=start,start+npts-1 + rho(j) = rho(j) + ( 0.5 * d2RdTT(j) * Tvar(j) + ( d2RdST(j) * TScov(j) + 0.5 * d2RdSS(j) * Svar(j) ) ) + enddo + + if (present(scale)) then ; if (scale /= 1.0) then ; do j=start,start+npts-1 + rho(j) = scale * rho(j) + enddo ; endif ; endif + +end subroutine calculate_stanley_density_array + !> Calls the appropriate subroutine to calculate the density of sea water for 1-D array inputs, !! potentially limiting the domain of indices that are worked on. !! If rho_ref is present, the anomaly with respect to rho_ref is returned. @@ -288,6 +370,75 @@ subroutine calculate_density_1d(T, S, pressure, rho, EOS, dom, rho_ref, scale) end subroutine calculate_density_1d +!> Calls the appropriate subroutine to calculate the density of sea water for 1-D array inputs +!! including the variance of T, S and covariance of T-S, +!! potentially limiting the domain of indices that are worked on. +!! The calculation uses only the second order correction in a series as discussed +!! in Stanley et al., 2020. +!! If rho_ref is present, the anomaly with respect to rho_ref is returned. +subroutine calculate_stanley_density_1d(T, S, pressure, Tvar, TScov, Svar, rho, EOS, dom, rho_ref, scale) + 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 [R L2 T-2 ~> Pa] + real, dimension(:), intent(in) :: Tvar !< Variance of potential temperature referenced to the surface [degC2] + real, dimension(:), intent(in) :: TScov !< Covariance of potential temperature and salinity [degC ppt] + real, dimension(:), intent(in) :: Svar !< Variance of salinity [ppt2] + real, dimension(:), intent(inout) :: rho !< Density (in-situ if pressure is local) [R ~> kg m-3] + type(EOS_type), pointer :: EOS !< Equation of state structure + integer, dimension(2), optional, intent(in) :: dom !< The domain of indices to work on, taking + !! into account that arrays start at 1. + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3] + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density + !! in combination with scaling given by US [various] + ! Local variables + real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] + real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] + real :: rho_unscale ! A factor to convert density from R to kg m-3 [kg m-3 R-1 ~> 1] + real :: rho_reference ! rho_ref converted to [kg m-3] + real, dimension(size(rho)) :: pres ! Pressure converted to [Pa] + real, dimension(size(T)) :: d2RdTT, d2RdST, d2RdSS, d2RdSp, d2RdTp ! Second derivatives of density wrt T,S,p + integer :: i, is, ie, npts + + if (.not.associated(EOS)) call MOM_error(FATAL, & + "calculate_density_1d called with an unassociated EOS_type EOS.") + + if (present(dom)) then + is = dom(1) ; ie = dom(2) ; npts = 1 + ie - is + else + is = 1 ; ie = size(rho) ; npts = 1 + ie - is + endif + + p_scale = EOS%RL2_T2_to_Pa + rho_unscale = EOS%R_to_kg_m3 + + if ((p_scale == 1.0) .and. (rho_unscale == 1.0)) then + call calculate_density_array(T, S, pressure, rho, is, npts, EOS, rho_ref=rho_ref) + call calculate_density_second_derivs_array(T, S, pressure, d2RdSS, d2RdST, d2RdTT, & + d2RdSp, d2RdTp, is, npts, EOS) + else ! This is the same as above, but with some extra work to rescale variables. + do i=is,ie ; pres(i) = p_scale * pressure(i) ; enddo + call calculate_density_second_derivs_array(T, S, pres, d2RdSS, d2RdST, d2RdTT, & + d2RdSp, d2RdTp, is, npts, EOS) + if (present(rho_ref)) then ! This is the same as above, but with some extra work to rescale variables. + rho_reference = rho_unscale*rho_ref + call calculate_density_array(T, S, pres, rho, is, npts, EOS, rho_ref=rho_reference) + else ! There is rescaling of variables, but rho_ref is not present. Passing a 0 value of rho_ref + ! changes answers at roundoff for some equations of state, like Wright and UNESCO. + call calculate_density_array(T, S, pres, rho, is, npts, EOS) + endif + endif + do i=is,ie + rho(i) = rho(i) + ( d2RdTT(i) * Tvar(i) + ( d2RdST(i) * TScov(i) + d2RdSS(i) * Svar(i) ) ) + enddo + + rho_scale = EOS%kg_m3_to_R + if (present(scale)) rho_scale = rho_scale * scale + if (rho_scale /= 1.0) then ; do i=is,ie + rho(i) = rho_scale * rho(i) + enddo ; endif + +end subroutine calculate_stanley_density_1d + !> Calls the appropriate subroutine to calculate the specific volume of sea water !! for 1-D array inputs. subroutine calculate_spec_vol_array(T, S, pressure, specvol, start, npts, EOS, spv_ref, scale) @@ -2166,6 +2317,7 @@ subroutine int_density_dz_generic_ppm(T, T_t, T_b, S, S_t, S_b, & T5(n) = t0 + t1 * xi + t2 * xi**2 enddo +stop if (rho_scale /= 1.0) then call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) else From 3006b9c4979ddd76f30cd126ccdd9c0537e2dca3 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Thu, 30 Apr 2020 17:12:30 +0000 Subject: [PATCH 28/91] Renamed pressure_gradient_plm() to TS_PLM_edge_values() - The routines pressure_gradient_plm() and pressure_gradient_ppm() were poorly named and had comments referring to the pressure gradient calculation even though the only calculate edge values in the vertical for T/S using ALE functions. The routines are actually more general and can be used outside of the PGF. The comments have been shortened and no longer refer to the PGF. --- src/ALE/MOM_ALE.F90 | 27 +++++------- src/core/MOM_PressureForce_analytic_FV.F90 | 41 +++---------------- .../MOM_state_initialization.F90 | 4 +- 3 files changed, 18 insertions(+), 54 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index c4bf6ea7f0..1d9c66001b 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -110,8 +110,8 @@ module MOM_ALE public ALE_build_grid public ALE_regrid_accelerated public ALE_remap_scalar -public pressure_gradient_plm -public pressure_gradient_ppm +public TS_PLM_edge_values +public TS_PPM_edge_values public adjustGridForIntegrity public ALE_initRegridding public ALE_getCoordinate @@ -1006,12 +1006,9 @@ subroutine ALE_remap_scalar(CS, G, GV, nk_src, h_src, s_src, h_dst, s_dst, all_c end subroutine ALE_remap_scalar -!> Use plm reconstruction for pressure gradient (determine edge values) -!! By using a PLM (limited piecewise linear method) reconstruction, this -!! routine determines the edge values for the salinity and temperature -!! within each layer. These edge values are returned and are used to compute -!! the pressure gradient (by computing the densities). -subroutine pressure_gradient_plm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_extrap ) +!> Calculate edge values (top and bottom of layer) for T and S consistent with a PLM reconstruction +!! in the vertical direction. Boundary reconstructions are PCM unless bdry_extrap is true. +subroutine TS_PLM_edge_values( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_extrap ) type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(ALE_CS), intent(inout) :: CS !< module control structure @@ -1078,15 +1075,11 @@ subroutine pressure_gradient_plm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_ext enddo ; enddo -end subroutine pressure_gradient_plm +end subroutine TS_PLM_edge_values - -!> Use ppm reconstruction for pressure gradient (determine edge values) -!> By using a PPM (limited piecewise linear method) reconstruction, this -!> routine determines the edge values for the salinity and temperature -!> within each layer. These edge values are returned and are used to compute -!> the pressure gradient (by computing the densities). -subroutine pressure_gradient_ppm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_extrap ) +!> Calculate edge values (top and bottom of layer) for T and S consistent with a PPM reconstruction +!! in the vertical direction. Boundary reconstructions are PCM unless bdry_extrap is true. +subroutine TS_PPM_edge_values( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_extrap ) type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(ALE_CS), intent(inout) :: CS !< module control structure @@ -1168,7 +1161,7 @@ subroutine pressure_gradient_ppm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_ext enddo ; enddo -end subroutine pressure_gradient_ppm +end subroutine TS_PPM_edge_values !> Initializes regridding for the main ALE algorithm diff --git a/src/core/MOM_PressureForce_analytic_FV.F90 b/src/core/MOM_PressureForce_analytic_FV.F90 index 59214dd914..03ed0def88 100644 --- a/src/core/MOM_PressureForce_analytic_FV.F90 +++ b/src/core/MOM_PressureForce_analytic_FV.F90 @@ -18,13 +18,13 @@ module MOM_PressureForce_AFV use MOM_EOS, only : int_density_dz_generic_plm, int_density_dz_generic_ppm use MOM_EOS, only : int_spec_vol_dp_generic_plm use MOM_EOS, only : int_density_dz_generic, int_spec_vol_dp_generic -use MOM_ALE, only : pressure_gradient_plm, pressure_gradient_ppm, ALE_CS +use MOM_ALE, only : TS_PLM_edge_values, TS_PPM_edge_values, ALE_CS implicit none ; private #include -public PressureForce_AFV, PressureForce_AFV_init, PressureForce_AFV_end +public 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 @@ -61,35 +61,6 @@ module MOM_PressureForce_AFV contains -!> Thin interface between the model and the Boussinesq and non-Boussinesq -!! pressure force routines. -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 - 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 [L T-2 ~> m s-2] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: PFv !< Meridional acceleration [L T-2 ~> 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 [R L2 T-2 ~> Pa]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: pbce !< The baroclinic pressure - !! anomaly in each layer due to eta anomalies - !! [L2 T-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 or compressibility compensation. - - if (GV%Boussinesq) then - 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, US, CS, ALE_CSp, p_atm, pbce, eta) - endif - -end subroutine PressureForce_AFV - !> \brief Non-Boussinesq analytically-integrated finite volume form of pressure gradient !! !! Determines the acceleration due to hydrostatic pressure forces, using @@ -251,9 +222,9 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p ! 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 TS_PLM_edge_values(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 TS_PPM_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) endif endif @@ -628,9 +599,9 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at ! 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 TS_PLM_edge_values(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 TS_PPM_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) endif endif diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 33929737a7..6ca98da171 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -40,7 +40,6 @@ module MOM_state_initialization 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 use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_type, EOS_domain use MOM_EOS, only : int_specific_vol_dp, convert_temp_salt_for_TEOS10 use user_initialization, only : user_initialize_thickness, user_initialize_velocity @@ -91,6 +90,7 @@ module MOM_state_initialization use MOM_tracer_Z_init, only : find_interfaces, tracer_Z_init_array, determine_temperature use MOM_ALE, only : ALE_initRegridding, ALE_CS, ALE_initThicknessToCoord use MOM_ALE, only : ALE_remap_scalar, ALE_build_grid, ALE_regrid_accelerated +use MOM_ALE, only : TS_PLM_edge_values use MOM_regridding, only : regridding_CS, set_regrid_params, getCoordinateResolution use MOM_regridding, only : regridding_main use MOM_remapping, only : remapping_CS, initialize_remapping @@ -1149,7 +1149,7 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read_params) ! Find edge values of T and S used in reconstructions if ( associated(ALE_CSp) ) then ! This should only be associated if we are in ALE mode - call pressure_gradient_plm(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, .true.) + call TS_PLM_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, .true.) else ! call MOM_error(FATAL, "trim_for_ice: Does not work without ALE mode") do k=1,G%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec From 7e8ac759cf12afb79abdc1510f93674090e09ee7 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 1 May 2020 18:43:44 +0000 Subject: [PATCH 29/91] Break out density integrals into a new module - The integrals of density routines used (mostly) by the PGF calculation were part of MOM_EOS. Originally, when writing the analytic FV PGF paper, this was the right place to put the integrals. The additional variants using the ALE reconstruction functions mean that it is cleaner to have these routines sit in a layer above EOS and ALE. --- src/core/MOM_PressureForce_Montgomery.F90 | 5 +- src/core/MOM_PressureForce_analytic_FV.F90 | 18 +- src/core/MOM_density_integrals.F90 | 1725 +++++++++++++++++ src/core/MOM_interface_heights.F90 | 6 +- src/core/MOM_isopycnal_slopes.F90 | 2 +- src/diagnostics/MOM_diagnostics.F90 | 5 +- src/equation_of_state/MOM_EOS.F90 | 1293 +----------- .../MOM_state_initialization.F90 | 5 +- .../MOM_tracer_initialization_from_Z.F90 | 2 +- 9 files changed, 1766 insertions(+), 1295 deletions(-) create mode 100644 src/core/MOM_density_integrals.F90 diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index 99268460df..07cbf3adf4 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -3,6 +3,7 @@ module MOM_PressureForce_Mont ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_density_integrals, only : int_specific_vol_dp use MOM_diag_mediator, only : post_data, register_diag_field use MOM_diag_mediator, only : safe_alloc_ptr, diag_ctrl, time_type use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe @@ -13,7 +14,7 @@ module MOM_PressureForce_Mont use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use MOM_EOS, only : calculate_density, calculate_density_derivs -use MOM_EOS, only : int_specific_vol_dp, query_compressible +use MOM_EOS, only : query_compressible implicit none ; private @@ -188,7 +189,7 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb !$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) + 0.0, G%HI, tv%eqn_of_state, US, dz_geo(:,:,k), halo_size=1) enddo !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do k=1,nz ; do i=Isq,Ieq+1 diff --git a/src/core/MOM_PressureForce_analytic_FV.F90 b/src/core/MOM_PressureForce_analytic_FV.F90 index 03ed0def88..05dac0c0c3 100644 --- a/src/core/MOM_PressureForce_analytic_FV.F90 +++ b/src/core/MOM_PressureForce_analytic_FV.F90 @@ -14,10 +14,10 @@ module MOM_PressureForce_AFV use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use MOM_EOS, only : calculate_density, calculate_density_derivs -use MOM_EOS, only : int_density_dz, int_specific_vol_dp -use MOM_EOS, only : int_density_dz_generic_plm, int_density_dz_generic_ppm -use MOM_EOS, only : int_spec_vol_dp_generic_plm -use MOM_EOS, only : int_density_dz_generic, int_spec_vol_dp_generic +use MOM_density_integrals, only : int_density_dz, int_specific_vol_dp +use MOM_density_integrals, only : int_density_dz_generic_plm, int_density_dz_generic_ppm +use MOM_density_integrals, only : int_spec_vol_dp_generic_plm +use MOM_density_integrals, only : int_density_dz_generic_pcm, int_spec_vol_dp_generic_pcm use MOM_ALE, only : TS_PLM_edge_values, TS_PPM_edge_values, ALE_CS implicit none ; private @@ -237,7 +237,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p if ( CS%Recon_Scheme == 1 ) then 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), intx_dza(:,:,k), inty_dza(:,:,k), & + tv%eqn_of_state, US, dza(:,:,k), intp_dza(:,:,k), intx_dza(:,:,k), inty_dza(:,:,k), & useMassWghtInterp=CS%useMassWghtInterp) elseif ( CS%Recon_Scheme == 2 ) then call MOM_error(FATAL, "PressureForce_AFV_nonBouss: "//& @@ -250,7 +250,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p else call int_specific_vol_dp(tv_tmp%T(:,:,k), tv_tmp%S(:,:,k), p(:,:,K), & p(:,:,K+1), alpha_ref, G%HI, tv%eqn_of_state, & - dza(:,:,k), intp_dza(:,:,k), intx_dza(:,:,k), & + US, dza(:,:,k), intp_dza(:,:,k), intx_dza(:,:,k), & inty_dza(:,:,k), bathyP=p(:,:,nz+1), dP_tiny=dp_neglect, & useMassWghtInterp=CS%useMassWghtInterp) endif @@ -642,17 +642,17 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at if ( CS%Recon_Scheme == 1 ) then 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, dz_neglect, G%bathyT, & - G%HI, tv%eqn_of_state, dpa, intz_dpa, intx_dpa, inty_dpa, & + G%HI, tv%eqn_of_state, US, 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), & tv%S(:,:,k), S_t(:,:,k), S_b(:,:,k), e(:,:,K), e(:,:,K+1), & - rho_ref, CS%Rho0, GV%g_Earth, G%HI, tv%eqn_of_state, dpa, & + rho_ref, CS%Rho0, GV%g_Earth, G%HI, tv%eqn_of_state, US, 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, tv%eqn_of_state, dpa, & + rho_ref, CS%Rho0, GV%g_Earth, G%HI, tv%eqn_of_state, US, dpa, & intz_dpa, intx_dpa, inty_dpa, G%bathyT, dz_neglect, CS%useMassWghtInterp) endif !$OMP parallel do default(shared) diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 new file mode 100644 index 0000000000..4cd9c8fc48 --- /dev/null +++ b/src/core/MOM_density_integrals.F90 @@ -0,0 +1,1725 @@ +!> Provides integrals of density +module MOM_density_integrals + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_EOS, only : EOS_type +use MOM_EOS, only : EOS_quadrature +use MOM_EOS, only : analytic_int_density_dz +use MOM_EOS, only : analytic_int_specific_vol_dp +use MOM_EOS, only : calculate_density +use MOM_EOS, only : calculate_spec_vol +use MOM_EOS, only : calculate_specific_vol_derivs +use MOM_EOS, only : calculate_density_second_derivs + +use MOM_EOS_linear, only : calculate_density_linear, calculate_spec_vol_linear +use MOM_EOS_linear, only : calculate_density_derivs_linear +use MOM_EOS_linear, only : calculate_specvol_derivs_linear, int_density_dz_linear +use MOM_EOS_linear, only : calculate_density_second_derivs_linear +use MOM_EOS_linear, only : calculate_compress_linear, int_spec_vol_dp_linear +use MOM_EOS_Wright, only : calculate_density_wright, calculate_spec_vol_wright +use MOM_EOS_Wright, only : calculate_density_derivs_wright +use MOM_EOS_Wright, only : calculate_specvol_derivs_wright, int_density_dz_wright +use MOM_EOS_Wright, only : calculate_compress_wright, int_spec_vol_dp_wright +use MOM_EOS_Wright, only : calculate_density_second_derivs_wright +use MOM_EOS_UNESCO, only : calculate_density_unesco, calculate_spec_vol_unesco +use MOM_EOS_UNESCO, only : calculate_density_derivs_unesco, calculate_density_unesco +use MOM_EOS_UNESCO, only : calculate_compress_unesco +use MOM_EOS_NEMO, only : calculate_density_nemo +use MOM_EOS_NEMO, only : calculate_density_derivs_nemo, calculate_density_nemo +use MOM_EOS_NEMO, only : calculate_compress_nemo +use MOM_EOS_TEOS10, only : calculate_density_teos10, calculate_spec_vol_teos10 +use MOM_EOS_TEOS10, only : calculate_density_derivs_teos10 +use MOM_EOS_TEOS10, only : calculate_specvol_derivs_teos10 +use MOM_EOS_TEOS10, only : calculate_density_second_derivs_teos10 +use MOM_EOS_TEOS10, only : calculate_compress_teos10 +use MOM_EOS_TEOS10, only : gsw_sp_from_sr, gsw_pt_from_ct +use MOM_TFreeze, only : calculate_TFreeze_linear, calculate_TFreeze_Millero +use MOM_TFreeze, only : calculate_TFreeze_teos10 +use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_hor_index, only : hor_index_type +use MOM_string_functions, only : uppercase +use MOM_unit_scaling, only : unit_scale_type + +use MOM_EOS, only : EOS_LINEAR, EOS_UNESCO, EOS_WRIGHT, EOS_TEOS10, EOS_NEMO + +implicit none ; private + +#include + +public int_density_dz +public int_density_dz_generic_pcm +public int_density_dz_generic_plm +public int_density_dz_generic_ppm +public int_specific_vol_dp +public int_spec_vol_dp_generic_pcm +public int_spec_vol_dp_generic_plm +public find_depth_of_pressure_in_cell + +contains + +!> Calls the appropriate subroutine to calculate 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 Boole'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. +subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, US, & + dza, intp_dza, intx_dza, inty_dza, halo_size, & + bathyP, dP_tiny, useMassWghtInterp) + 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 [R L2 T-2 ~> Pa] or [Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: p_b !< Pressure at the bottom of the layer [R L2 T-2 ~> Pa] or [Pa] + real, intent(in) :: alpha_ref !< A mean specific volume that is subtracted out + !! to reduce the magnitude of each of the integrals [R-1 ~> 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 + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(inout) :: dza !< The change in the geopotential anomaly across + !! the layer [L2 T-2 ~> m2 s-2] or [m2 s-2] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of the + !! geopotential anomaly relative to the anomaly at the bottom of the + !! layer [R L4 T-4 ~> Pa m2 s-2] or [Pa m2 s-2] + real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & + optional, intent(inout) :: 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 [L2 T-2 ~> m2 s-2] or [m2 s-2] + real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & + optional, intent(inout) :: 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 [L2 T-2 ~> m2 s-2] or [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 [R L2 T-2 ~> Pa] or [Pa] + real, optional, intent(in) :: dP_tiny !< A minuscule pressure change with + !! the same units as p_t [R L2 T-2 ~> Pa] or [Pa] + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting + !! to interpolate T/S for top and bottom integrals. + + if (EOS_quadrature(EOS)) then + call int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, & + dza, intp_dza, intx_dza, inty_dza, halo_size, & + bathyP, dP_tiny, useMassWghtInterp) + else + call analytic_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) + endif + +end subroutine int_specific_vol_dp + + +!> This subroutine calculates analytical and nearly-analytical integrals of +!! pressure anomalies across layers, which are required for calculating the +!! finite-volume form pressure accelerations in a Boussinesq model. +subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, US, dpa, & + intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp) + type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structures for the arrays + 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) :: z_t !< Height at the top of the layer in depth units [Z ~> m] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: z_b !< Height at the bottom of the layer [Z ~> m] + real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that is + !! subtracted out to reduce the magnitude of each of the + !! integrals. + real, intent(in) :: rho_0 !< A density [R ~> kg m-3] or [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 + !! [L2 Z-1 T-2 ~> m s-2] or [m2 Z-1 s-2 ~> m s-2] + type(EOS_type), pointer :: EOS !< Equation of state structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(inout) :: dpa !< The change in the pressure anomaly + !! across the layer [R L2 T-2 ~> Pa] or [Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(inout) :: intz_dpa !< The integral through the thickness of the + !! layer of the pressure anomaly relative to the + !! anomaly at the top of the layer [R L2 Z T-2 ~> Pa m] + real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & + optional, intent(inout) :: 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 [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & + optional, intent(inout) :: 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 [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] + real, optional, intent(in) :: dz_neglect !< A minuscule thickness change [Z ~> m] + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to + !! interpolate T/S for top and bottom integrals. + + if (EOS_quadrature(EOS)) then + call int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, US, dpa, & + intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp) + else + call analytic_int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, dpa, & + intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp) + endif + +end subroutine int_density_dz + + +!> 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. +subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & + EOS, US, dpa, intz_dpa, intx_dpa, inty_dpa, & + bathyT, dz_neglect, useMassWghtInterp) + type(hor_index_type), intent(in) :: HI !< Horizontal index type for input variables. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + 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 [ppt] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: z_b !< Height at the bottom of the layer [Z ~> m] + real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that is + !! subtracted out to reduce the magnitude + !! of each of the integrals. + real, intent(in) :: rho_0 !< A density [R ~> kg m-3] or [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 + !! [L2 Z-1 T-2 ~> m s-2] or [m2 Z-1 s-2 ~> m s-2] + type(EOS_type), pointer :: EOS !< Equation of state structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(inout) :: dpa !< The change in the pressure anomaly + !! across the layer [R L2 T-2 ~> Pa] or [Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(inout) :: intz_dpa !< The integral through the thickness of the + !! layer of the pressure anomaly relative to the + !! anomaly at the top of the layer [R L2 Z T-2 ~> Pa m] + real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & + optional, intent(inout) :: 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 [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & + optional, intent(inout) :: 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 [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] + real, optional, intent(in) :: dz_neglect !< A minuscule thickness change [Z ~> m] + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to + !! interpolate T/S for top and bottom integrals. + ! Local variables + real :: T5(5), S5(5) ! Temperatures and salinities at five quadrature points [degC] and [ppt] + real :: p5(5) ! Pressures at five quadrature points, never rescaled from Pa [Pa] + real :: r5(5) ! Densities at five quadrature points [R ~> kg m-3] or [kg m-3] + real :: rho_anom ! The depth averaged density anomaly [R ~> kg m-3] or [kg m-3] + real :: w_left, w_right ! Left and right weights [nondim] + real, parameter :: C1_90 = 1.0/90.0 ! Rational constants. + real :: GxRho ! The gravitational acceleration times density and unit conversion factors [Pa Z-1 ~> kg m-2 s-2] + real :: I_Rho ! The inverse of the Boussinesq density [R-1 ~> m3 kg-1] or [m3 kg-1] + real :: rho_scale ! A scaling factor for densities from kg m-3 to R [R m3 kg-1 ~> 1] + real :: rho_ref_mks ! The reference density in MKS units, never rescaled from kg m-3 [kg m-3] + 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 [R L2 T-2 ~> Pa] or [Pa] + logical :: do_massWeight ! Indicates whether to do mass weighting. + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, m, n + + ! These array bounds work for the indexing convention of the input arrays, but + ! on the computational domain defined for the output arrays. + Isq = HI%IscB ; Ieq = HI%IecB + Jsq = HI%JscB ; Jeq = HI%JecB + is = HI%isc ; ie = HI%iec + js = HI%jsc ; je = HI%jec + + rho_scale = US%kg_m3_to_R + GxRho = US%RL2_T2_to_Pa * G_e * rho_0 + rho_ref_mks = rho_ref * US%R_to_kg_m3 + I_Rho = 1.0 / rho_0 + + do_massWeight = .false. + if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then + do_massWeight = .true. + if (.not.present(bathyT)) call MOM_error(FATAL, "int_density_dz_generic: "//& + "bathyT must be present if useMassWghtInterp is present and true.") + if (.not.present(dz_neglect)) call MOM_error(FATAL, "int_density_dz_generic: "//& + "dz_neglect must be present if useMassWghtInterp is present and true.") + endif ; endif + + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + dz = z_t(i,j) - z_b(i,j) + do n=1,5 + T5(n) = T(i,j) ; S5(n) = S(i,j) + p5(n) = -GxRho*(z_t(i,j) - 0.25*real(n-1)*dz) + enddo + if (rho_scale /= 1.0) then + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + else + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks) + endif + + ! Use Boole's rule to estimate the pressure anomaly change. + rho_anom = C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) + dpa(i,j) = G_e*dz*rho_anom + ! Use a Boole's-rule-like fifth-order accurate estimate of the double integral of + ! the pressure anomaly. + if (present(intz_dpa)) intz_dpa(i,j) = 0.5*G_e*dz**2 * & + (rho_anom - C1_90*(16.0*(r5(4)-r5(2)) + 7.0*(r5(5)-r5(1))) ) + enddo ; enddo + + if (present(intx_dpa)) then ; do j=js,je ; do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., -bathyT(i,j)-z_t(i+1,j), -bathyT(i+1,j)-z_t(i,j)) + if (hWght > 0.) then + hL = (z_t(i,j) - z_b(i,j)) + dz_neglect + hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) + do m=2,4 + ! T, S, and z are interpolated in the horizontal. The z interpolation + ! is linear, but for T and S it may be thickness weighted. + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i+1,j) - z_b(i+1,j)) + T5(1) = wtT_L*T(i,j) + wtT_R*T(i+1,j) + S5(1) = wtT_L*S(i,j) + wtT_R*S(i+1,j) + p5(1) = -GxRho*(wt_L*z_t(i,j) + wt_R*z_t(i+1,j)) + do n=2,5 + T5(n) = T5(1) ; S5(n) = S5(1) ; p5(n) = p5(n-1) + GxRho*0.25*dz + enddo + if (rho_scale /= 1.0) then + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + else + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks) + endif + + ! Use Boole's rule to estimate the pressure anomaly change. + intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3))) + enddo + ! Use Boole's rule to integrate the bottom pressure anomaly values in x. + intx_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & + 12.0*intz(3)) + enddo ; enddo ; endif + + if (present(inty_dpa)) then ; do J=Jsq,Jeq ; do i=is,ie + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., -bathyT(i,j)-z_t(i,j+1), -bathyT(i,j+1)-z_t(i,j)) + if (hWght > 0.) then + hL = (z_t(i,j) - z_b(i,j)) + dz_neglect + hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) + do m=2,4 + ! T, S, and z are interpolated in the horizontal. The z interpolation + ! is linear, but for T and S it may be thickness weighted. + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i,j+1) - z_b(i,j+1)) + T5(1) = wtT_L*T(i,j) + wtT_R*T(i,j+1) + S5(1) = wtT_L*S(i,j) + wtT_R*S(i,j+1) + p5(1) = -GxRho*(wt_L*z_t(i,j) + wt_R*z_t(i,j+1)) + do n=2,5 + T5(n) = T5(1) ; S5(n) = S5(1) + p5(n) = p5(n-1) + GxRho*0.25*dz + enddo + if (rho_scale /= 1.0) then + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + else + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks) + endif + + ! Use Boole's rule to estimate the pressure anomaly change. + intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3))) + enddo + ! Use Boole's rule to integrate the values. + inty_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & + 12.0*intz(3)) + enddo ; enddo ; endif +end subroutine int_density_dz_generic_pcm + + +!> 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, HI, EOS, US, dpa, & + intz_dpa, intx_dpa, inty_dpa, useMassWghtInterp) + type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structures for the input arrays + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: T_t !< Potential temperature at the cell top [degC] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: T_b !< Potential temperature at the cell bottom [degC] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: S_t !< Salinity at the cell top [ppt] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: S_b !< Salinity at the cell bottom [ppt] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: z_t !< The geometric height at the top of the layer [Z ~> m] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: z_b !< The geometric height at the bottom of the layer [Z ~> m] + real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that is subtracted + !! out to reduce the magnitude of each of the integrals. + real, intent(in) :: rho_0 !< A density [R ~> kg m-3] or [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 [L2 Z-1 T-2 ~> m s-2] + real, intent(in) :: dz_subroundoff !< A minuscule thickness change [Z ~> m] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] + type(EOS_type), pointer :: EOS !< Equation of state structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(inout) :: dpa !< The change in the pressure anomaly across the layer [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(inout) :: intz_dpa !< The integral through the thickness of the layer of + !! the pressure anomaly relative to the anomaly at the + !! top of the layer [R L2 Z T-2 ~> Pa Z] + real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & + optional, intent(inout) :: 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 [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & + optional, intent(inout) :: 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 [R L2 T-2 ~> 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 +! potentially dodgy assumption here is that rho_0 is used both in the denominator +! of the accelerations, and in the pressure used to calculated density (the +! latter being -z*rho_0*G_e). These two uses could be separated if need be. +! +! 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. + + ! Local variables + real :: T5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Temperatures along a line of subgrid locations [degC] + real :: S5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Salinities along a line of subgrid locations [ppt] + real :: p5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Pressures along a line of subgrid locations, never + ! rescaled from Pa [Pa] + real :: r5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Densities anomalies along a line of subgrid + ! locations [R ~> kg m-3] or [kg m-3] + real :: T15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Temperatures at an array of subgrid locations [degC] + real :: S15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Salinities at an array of subgrid locations [ppt] + real :: p15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Pressures at an array of subgrid locations [Pa] + real :: r15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Densities at an array of subgrid locations + ! [R ~> kg m-3] or [kg m-3] + real :: wt_t(5), wt_b(5) ! Top and bottom weights [nondim] + real :: rho_anom ! A density anomaly [R ~> kg m-3] or [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 [R L2 T-2 ~> Pa] or [Pa] + real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] + real :: GxRho ! The gravitational acceleration times density and unit conversion factors [Pa Z-1 ~> kg m-2 s-2] + real :: I_Rho ! The inverse of the Boussinesq density [R-1 ~> m3 kg-1] or [m3 kg-1] + real :: rho_scale ! A scaling factor for densities from kg m-3 to R [R m3 kg-1 ~> 1] + real :: rho_ref_mks ! The reference density in MKS units, never rescaled from kg m-3 [kg m-3] + real :: dz(HI%iscB:HI%iecB+1) ! Layer thicknesses at tracer points [Z ~> m] + real :: dz_x(5,HI%iscB:HI%iecB) ! Layer thicknesses along an x-line of subrid locations [Z ~> m] + real :: dz_y(5,HI%isc:HI%iec) ! Layer thicknesses along a y-line of subrid locations [Z ~> m] + real :: weight_t, weight_b ! Non-dimensional weights of the top and bottom [nondim] + real :: massWeightToggle ! A non-dimensional toggle factor (0 or 1) [nondim] + 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 :: pos + + Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB + + rho_scale = US%kg_m3_to_R + GxRho = US%RL2_T2_to_Pa * G_e * rho_0 + rho_ref_mks = rho_ref * US%R_to_kg_m3 + I_Rho = 1.0 / rho_0 + massWeightToggle = 0. + if (present(useMassWghtInterp)) then + if (useMassWghtInterp) massWeightToggle = 1. + endif + + do n = 1, 5 + wt_t(n) = 0.25 * real(5-n) + wt_b(n) = 1.0 - wt_t(n) + enddo + + ! 1. Compute vertical integrals + do j=Jsq,Jeq+1 + do i = Isq,Ieq+1 + dz(i) = z_t(i,j) - z_b(i,j) + do n=1,5 + p5(i*5+n) = -GxRho*(z_t(i,j) - 0.25*real(n-1)*dz(i)) + ! Salinity and temperature points are linearly interpolated + S5(i*5+n) = wt_t(n) * S_t(i,j) + wt_b(n) * S_b(i,j) + T5(i*5+n) = wt_t(n) * T_t(i,j) + wt_b(n) * T_b(i,j) + enddo + enddo + if (rho_scale /= 1.0) then + call calculate_density(T5, S5, p5, r5, 1, (ieq-isq+2)*5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + else + call calculate_density(T5, S5, p5, r5, 1, (ieq-isq+2)*5, EOS, rho_ref=rho_ref_mks) + endif + + do i=isq,ieq+1 + ! Use Boole's rule to estimate the pressure anomaly change. + rho_anom = C1_90*(7.0*(r5(i*5+1)+r5(i*5+5)) + 32.0*(r5(i*5+2)+r5(i*5+4)) + 12.0*r5(i*5+3)) + dpa(i,j) = G_e*dz(i)*rho_anom + if (present(intz_dpa)) then + ! Use a Boole's-rule-like fifth-order accurate estimate of + ! the double integral of the pressure anomaly. + intz_dpa(i,j) = 0.5*G_e*dz(i)**2 * & + (rho_anom - C1_90*(16.0*(r5(i*5+4)-r5(i*5+2)) + 7.0*(r5(i*5+5)-r5(i*5+1))) ) + endif + enddo + enddo ! end loops on j + + ! 2. Compute horizontal integrals in the x direction + if (present(intx_dpa)) then ; do j=HI%jsc,HI%jec + do I=Isq,Ieq + ! Corner values of T and S + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, almost like thickness + ! weighting. + ! Note: To work in terrain following coordinates we could offset + ! this distance by the layer thickness to replicate other models. + hWght = massWeightToggle * & + max(0., -bathyT(i,j)-z_t(i+1,j), -bathyT(i+1,j)-z_t(i,j)) + if (hWght > 0.) then + hL = (z_t(i,j) - z_b(i,j)) + dz_subroundoff + hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_subroundoff + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1./( hWght*(hR + hL) + hL*hR ) + Ttl = ( (hWght*hR)*T_t(i+1,j) + (hWght*hL + hR*hL)*T_t(i,j) ) * iDenom + Ttr = ( (hWght*hL)*T_t(i,j) + (hWght*hR + hR*hL)*T_t(i+1,j) ) * iDenom + Tbl = ( (hWght*hR)*T_b(i+1,j) + (hWght*hL + hR*hL)*T_b(i,j) ) * iDenom + Tbr = ( (hWght*hL)*T_b(i,j) + (hWght*hR + hR*hL)*T_b(i+1,j) ) * iDenom + Stl = ( (hWght*hR)*S_t(i+1,j) + (hWght*hL + hR*hL)*S_t(i,j) ) * iDenom + Str = ( (hWght*hL)*S_t(i,j) + (hWght*hR + hR*hL)*S_t(i+1,j) ) * iDenom + Sbl = ( (hWght*hR)*S_b(i+1,j) + (hWght*hL + hR*hL)*S_b(i,j) ) * iDenom + Sbr = ( (hWght*hL)*S_b(i,j) + (hWght*hR + hR*hL)*S_b(i+1,j) ) * iDenom + else + Ttl = T_t(i,j); Tbl = T_b(i,j); Ttr = T_t(i+1,j); Tbr = T_b(i+1,j) + Stl = S_t(i,j); Sbl = S_b(i,j); Str = S_t(i+1,j); Sbr = S_b(i+1,j) + endif + + do m=2,4 + w_left = 0.25*real(5-m) ; w_right = 1.0-w_left + dz_x(m,i) = w_left*(z_t(i,j) - z_b(i,j)) + w_right*(z_t(i+1,j) - z_b(i+1,j)) + + ! Salinity and temperature points are linearly interpolated in + ! the horizontal. The subscript (1) refers to the top value in + ! the vertical profile while subscript (5) refers to the bottom + ! value in the vertical profile. + pos = i*15+(m-2)*5 + T15(pos+1) = w_left*Ttl + w_right*Ttr + T15(pos+5) = w_left*Tbl + w_right*Tbr + + S15(pos+1) = w_left*Stl + w_right*Str + S15(pos+5) = w_left*Sbl + w_right*Sbr + + p15(pos+1) = -GxRho*(w_left*z_t(i,j) + w_right*z_t(i+1,j)) + + ! Pressure + do n=2,5 + p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_x(m,i) + enddo + + ! Salinity and temperature (linear interpolation in the vertical) + do n=2,4 + weight_t = 0.25 * real(5-n) + weight_b = 1.0 - weight_t + S15(pos+n) = weight_t * S15(pos+1) + weight_b * S15(pos+5) + T15(pos+n) = weight_t * T15(pos+1) + weight_b * T15(pos+5) + enddo + enddo + enddo + + if (rho_scale /= 1.0) then + call calculate_density(T15, S15, p15, r15, 1, 15*(ieq-isq+1), EOS, rho_ref=rho_ref_mks, scale=rho_scale) + else + call calculate_density(T15, S15, p15, r15, 1, 15*(ieq-isq+1), EOS, rho_ref=rho_ref_mks) + endif + + do I=Isq,Ieq + intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) + + ! Use Boole's rule to estimate the pressure anomaly change. + do m = 2,4 + pos = i*15+(m-2)*5 + intz(m) = G_e*dz_x(m,i)*( C1_90*(7.0*(r15(pos+1)+r15(pos+5)) + 32.0*(r15(pos+2)+r15(pos+4)) + & + 12.0*r15(pos+3))) + enddo + ! Use Boole's rule to integrate the bottom pressure anomaly values in x. + intx_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & + 12.0*intz(3)) + enddo + enddo ; endif + + ! 3. Compute horizontal integrals in the y direction + if (present(inty_dpa)) then ; do J=Jsq,Jeq + do i=HI%isc,HI%iec + ! Corner values of T and S + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, almost like thickness + ! weighting. + ! Note: To work in terrain following coordinates we could offset + ! this distance by the layer thickness to replicate other models. + hWght = massWeightToggle * & + max(0., -bathyT(i,j)-z_t(i,j+1), -bathyT(i,j+1)-z_t(i,j)) + if (hWght > 0.) then + hL = (z_t(i,j) - z_b(i,j)) + dz_subroundoff + hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_subroundoff + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1./( hWght*(hR + hL) + hL*hR ) + Ttl = ( (hWght*hR)*T_t(i,j+1) + (hWght*hL + hR*hL)*T_t(i,j) ) * iDenom + Ttr = ( (hWght*hL)*T_t(i,j) + (hWght*hR + hR*hL)*T_t(i,j+1) ) * iDenom + Tbl = ( (hWght*hR)*T_b(i,j+1) + (hWght*hL + hR*hL)*T_b(i,j) ) * iDenom + Tbr = ( (hWght*hL)*T_b(i,j) + (hWght*hR + hR*hL)*T_b(i,j+1) ) * iDenom + Stl = ( (hWght*hR)*S_t(i,j+1) + (hWght*hL + hR*hL)*S_t(i,j) ) * iDenom + Str = ( (hWght*hL)*S_t(i,j) + (hWght*hR + hR*hL)*S_t(i,j+1) ) * iDenom + Sbl = ( (hWght*hR)*S_b(i,j+1) + (hWght*hL + hR*hL)*S_b(i,j) ) * iDenom + Sbr = ( (hWght*hL)*S_b(i,j) + (hWght*hR + hR*hL)*S_b(i,j+1) ) * iDenom + else + Ttl = T_t(i,j); Tbl = T_b(i,j); Ttr = T_t(i,j+1); Tbr = T_b(i,j+1) + Stl = S_t(i,j); Sbl = S_b(i,j); Str = S_t(i,j+1); Sbr = S_b(i,j+1) + endif + + do m=2,4 + w_left = 0.25*real(5-m) ; w_right = 1.0-w_left + dz_y(m,i) = w_left*(z_t(i,j) - z_b(i,j)) + w_right*(z_t(i,j+1) - z_b(i,j+1)) + + ! Salinity and temperature points are linearly interpolated in + ! the horizontal. The subscript (1) refers to the top value in + ! the vertical profile while subscript (5) refers to the bottom + ! value in the vertical profile. + pos = i*15+(m-2)*5 + T15(pos+1) = w_left*Ttl + w_right*Ttr + T15(pos+5) = w_left*Tbl + w_right*Tbr + + S15(pos+1) = w_left*Stl + w_right*Str + S15(pos+5) = w_left*Sbl + w_right*Sbr + + p15(pos+1) = -GxRho*(w_left*z_t(i,j) + w_right*z_t(i,j+1)) + + ! Pressure + do n=2,5 ; p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_y(m,i) ; enddo + + ! Salinity and temperature (linear interpolation in the vertical) + do n=2,4 + weight_t = 0.25 * real(5-n) + weight_b = 1.0 - weight_t + S15(pos+n) = weight_t * S15(pos+1) + weight_b * S15(pos+5) + T15(pos+n) = weight_t * T15(pos+1) + weight_b * T15(pos+5) + enddo + enddo + enddo + + if (rho_scale /= 1.0) then + call calculate_density(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & + r15(15*HI%isc+1:), 1, 15*(HI%iec-HI%isc+1), EOS, & + rho_ref=rho_ref_mks, scale=rho_scale) + else + call calculate_density(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & + r15(15*HI%isc+1:), 1, 15*(HI%iec-HI%isc+1), EOS, rho_ref=rho_ref_mks) + endif + do i=HI%isc,HI%iec + intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) + + ! Use Boole's rule to estimate the pressure anomaly change. + do m = 2,4 + pos = i*15+(m-2)*5 + intz(m) = G_e*dz_y(m,i)*( C1_90*(7.0*(r15(pos+1)+r15(pos+5)) + & + 32.0*(r15(pos+2)+r15(pos+4)) + & + 12.0*r15(pos+3))) + enddo + ! Use Boole's rule to integrate the values. + inty_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & + 12.0*intz(3)) + enddo + enddo ; endif + +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, US, P_b, z_out, z_tol) + real, intent(in) :: T_t !< Potential temperature at the cell top [degC] + real, intent(in) :: T_b !< Potential temperature 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 [R L2 T-2 ~> Pa] + real, intent(in) :: P_tgt !< Target pressure at height z_out, relative to g*rho_ref*z_out [R L2 T-2 ~> Pa] + real, intent(in) :: rho_ref !< Reference density with which calculation are anomalous to [R ~> kg m-3] + real, intent(in) :: G_e !< Gravitational acceleration [L2 Z-1 T-2 ~> m s-2] + type(EOS_type), pointer :: EOS !< Equation of state structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(out) :: P_b !< Pressure at the bottom of the cell [R L2 T-2 ~> 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 :: dp ! Pressure thickness of the layer [R L2 T-2 ~> Pa] + real :: F_guess, F_l, F_r ! Fractional positions [nondim] + real :: GxRho ! The product of the gravitational acceleration and reference density [R L2 Z-1 T-2 ~> Pa m-1] + real :: Pa, Pa_left, Pa_right, Pa_tol ! Pressure anomalies, P = integral of g*(rho-rho_ref) dz [R L2 T-2 ~> Pa] + character(len=240) :: msg + + GxRho = G_e * rho_ref + + ! Anomalous pressure difference across whole cell + dp = frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, 1.0, EOS) + + P_b = P_t + dp ! Anomalous pressure at bottom of cell + + if (P_tgt <= P_t ) then + z_out = z_t + return + endif + + if (P_tgt >= P_b) then + z_out = z_b + return + endif + + F_l = 0. + 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.0e-5*US%m_to_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 ) + + z_out = z_t + ( z_b - z_t ) * F_guess + Pa = frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, F_guess, EOS) - ( P_tgt - P_t ) + + if (PaPa_right) then + write(msg,*) Pa_left,Pa,Pa_right,P_t-P_tgt,P_b-P_tgt + call MOM_error(FATAL, 'find_depth_of_pressure_in_cell out of bounds positive: /n'//msg) + elseif (Pa>0.) then + Pa_right = Pa + F_r = F_guess + else ! Pa == 0 + return + endif + F_guess = F_l - Pa_left / (Pa_right - Pa_left) * (F_r - F_l) + + enddo + +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 !< Potential temperature at the cell top [degC] + real, intent(in) :: T_b !< Potential temperature 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 [R ~> 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 [L2 Z-1 T-2 ~> m s-2] + real, intent(in) :: pos !< The fractional vertical position, 0 to 1 [nondim] + type(EOS_type), pointer :: EOS !< Equation of state structure + real :: fract_dp_at_pos !< The change in pressure from the layer top to + !! fractional position pos [R L2 T-2 ~> Pa] + ! Local variables + real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] + real :: dz ! Distance from the layer top [Z ~> m] + real :: top_weight, bottom_weight ! Fractional weights at quadrature points [nondim] + real :: rho_ave ! Average density [R ~> kg m-3] + real, dimension(5) :: T5 ! Temperatures at quadrature points [degC] + real, dimension(5) :: S5 ! Salinities at quadrature points [ppt] + real, dimension(5) :: p5 ! Pressures at quadrature points [R L2 T-2 ~> Pa] + real, dimension(5) :: rho5 ! Densities at quadrature points [R ~> kg m-3] + integer :: n + + do n=1,5 + ! Evaluate density at five quadrature points + bottom_weight = 0.25*real(n-1) * pos + top_weight = 1.0 - bottom_weight + ! Salinity and temperature points are linearly interpolated + S5(n) = top_weight * S_t + bottom_weight * S_b + T5(n) = top_weight * T_t + bottom_weight * T_b + p5(n) = ( top_weight * z_t + bottom_weight * z_b ) * ( G_e * rho_ref ) + enddo + call calculate_density(T5, S5, p5, rho5, EOS) + rho5(:) = rho5(:) !- rho_ref ! Work with anomalies relative to rho_ref + + ! Use Boole's rule to estimate the average density + rho_ave = C1_90*(7.0*(rho5(1)+rho5(5)) + 32.0*(rho5(2)+rho5(4)) + 12.0*rho5(3)) + + dz = ( z_t - z_b ) * pos + frac_dp_at_pos = G_e * dz * rho_ave +end function frac_dp_at_pos + + +!> 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, HI, & + EOS, US, dpa, intz_dpa, intx_dpa, inty_dpa) + type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structures for the input arrays + 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) :: T_t !< Potential temperature at the cell top [degC] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: T_b !< Potential temperature at the cell bottom [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) :: S_t !< Salinity at the cell top [ppt] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: S_b !< Salinity at the cell bottom [ppt] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: z_t !< Height at the top of the layer [Z ~> m] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: z_b !< Height at the bottom of the layer [Z ~> m] + real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that is + !! subtracted out to reduce the magnitude of each of the integrals. + real, intent(in) :: rho_0 !< A density [R ~> kg m-3] or [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 + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(inout) :: dpa !< The change in the pressure anomaly across the layer [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(inout) :: intz_dpa !< The integral through the thickness of the layer of + !! the pressure anomaly relative to the anomaly at the + !! top of the layer [R L2 Z T-2 ~> Pa m] + real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & + optional, intent(inout) :: 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 [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & + optional, intent(inout) :: 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 [R L2 T-2 ~> 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 +! potentially dodgy assumption here is that rho_0 is used both in the denominator +! of the accelerations, and in the pressure used to calculated density (the +! latter being -z*rho_0*G_e). These two uses could be separated if need be. +! +! 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. + +!### Please note that this subroutine has not been verified to work properly! + + ! Local variables + real :: T5(5), S5(5) + real :: p5(5) ! Pressures at five quadrature points, never rescaled from Pa [Pa] + real :: r5(5) ! Density anomalies from rho_ref at quadrature points [R ~> kg m-3] or [kg m-3] + real :: rho_anom ! The integrated density anomaly [R ~> kg m-3] or [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 [R L2 T-2 ~> Pa] or [Pa] + real, parameter :: C1_90 = 1.0/90.0 ! Rational constants. + real :: GxRho ! The gravitational acceleration times density and unit conversion factors [Pa Z-1 ~> kg m-2 s-2] + real :: I_Rho ! The inverse of the Boussinesq density [R-1 ~> m3 kg-1] or [m3 kg-1] + real :: rho_scale ! A scaling factor for densities from kg m-3 to R [R m3 kg-1 ~> 1] + real :: rho_ref_mks ! The reference density in MKS units, never rescaled from kg m-3 [kg m-3] + real :: dz + real :: weight_t, weight_b + 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 + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, m, n + real, dimension(4) :: x, y + real, dimension(9) :: S_node, T_node, p_node, r_node + + + call MOM_error(FATAL, & + "int_density_dz_generic_ppm: the implementation is not done yet, contact developer") + + ! These array bounds work for the indexing convention of the input arrays, but + ! on the computational domain defined for the output arrays. + Isq = HI%IscB ; Ieq = HI%IecB + Jsq = HI%JscB ; Jeq = HI%JecB + is = HI%isc ; ie = HI%iec + js = HI%jsc ; je = HI%jec + + rho_scale = US%kg_m3_to_R + GxRho = US%RL2_T2_to_Pa * G_e * rho_0 + rho_ref_mks = rho_ref * US%R_to_kg_m3 + I_Rho = 1.0 / rho_0 + + ! 1. Compute vertical integrals + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + dz = z_t(i,j) - z_b(i,j) + + ! Coefficients of the parabola for S + s0 = S_t(i,j) + s1 = 6.0 * S(i,j) - 4.0 * S_t(i,j) - 2.0 * S_b(i,j) + s2 = 3.0 * ( S_t(i,j) + S_b(i,j) - 2.0*S(i,j) ) + + ! Coefficients of the parabola for T + t0 = T_t(i,j) + t1 = 6.0 * T(i,j) - 4.0 * T_t(i,j) - 2.0 * T_b(i,j) + t2 = 3.0 * ( T_t(i,j) + T_b(i,j) - 2.0*T(i,j) ) + + do n=1,5 + p5(n) = -GxRho*(z_t(i,j) - 0.25*real(n-1)*dz) + + ! Parabolic reconstruction for T and S + xi = 0.25 * ( n - 1 ) + S5(n) = s0 + s1 * xi + s2 * xi**2 + T5(n) = t0 + t1 * xi + t2 * xi**2 + enddo + + if (rho_scale /= 1.0) then + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + else + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks) + endif + + ! Use Boole's rule to estimate the pressure anomaly change. + rho_anom = C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) + + dpa(i,j) = G_e*dz*rho_anom + + ! Use a Boole's-rule-like fifth-order accurate estimate of + ! the double integral of the pressure anomaly. + if (present(intz_dpa)) intz_dpa(i,j) = 0.5*G_e*dz**2 * & + (rho_anom - C1_90*(16.0*(r5(4)-r5(2)) + 7.0*(r5(5)-r5(1))) ) + + enddo ; enddo ! end loops on j and i + + ! 2. Compute horizontal integrals in the x direction + if (present(intx_dpa)) then ; do j=js,je ; do I=Isq,Ieq + intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) + do m=2,4 + w_left = 0.25*real(5-m) ; w_right = 1.0-w_left + dz = w_left*(z_t(i,j) - z_b(i,j)) + w_right*(z_t(i+1,j) - z_b(i+1,j)) + + ! Salinity and temperature points are linearly interpolated in + ! the horizontal. The subscript (1) refers to the top value in + ! the vertical profile while subscript (5) refers to the bottom + ! value in the vertical profile. + T_top = w_left*T_t(i,j) + w_right*T_t(i+1,j) + T_mid = w_left*T(i,j) + w_right*T(i+1,j) + T_bot = w_left*T_b(i,j) + w_right*T_b(i+1,j) + + S_top = w_left*S_t(i,j) + w_right*S_t(i+1,j) + S_mid = w_left*S(i,j) + w_right*S(i+1,j) + S_bot = w_left*S_b(i,j) + w_right*S_b(i+1,j) + + p5(1) = -GxRho*(w_left*z_t(i,j) + w_right*z_t(i+1,j)) + + ! Pressure + do n=2,5 + p5(n) = p5(n-1) + GxRho*0.25*dz + enddo + + ! Coefficients of the parabola for S + s0 = S_top + s1 = 6.0 * S_mid - 4.0 * S_top - 2.0 * S_bot + s2 = 3.0 * ( S_top + S_bot - 2.0*S_mid ) + + ! Coefficients of the parabola for T + t0 = T_top + t1 = 6.0 * T_mid - 4.0 * T_top - 2.0 * T_bot + t2 = 3.0 * ( T_top + T_bot - 2.0*T_mid ) + + do n=1,5 + ! Parabolic reconstruction for T and S + xi = 0.25 * ( n - 1 ) + S5(n) = s0 + s1 * xi + s2 * xi**2 + T5(n) = t0 + t1 * xi + t2 * xi**2 + enddo + +stop + if (rho_scale /= 1.0) then + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + else + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks) + endif + + ! Use Boole's rule to estimate the pressure anomaly change. + intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + & + 12.0*r5(3)) ) + enddo + intx_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & + 12.0*intz(3)) + + ! Use Gauss quadrature rule to compute integral + + ! The following coordinates define the quadrilateral on which the integral + ! is computed + x(1) = 1.0 + x(2) = 0.0 + x(3) = 0.0 + x(4) = 1.0 + y(1) = z_t(i+1,j) + y(2) = z_t(i,j) + y(3) = z_b(i,j) + y(4) = z_b(i+1,j) + + T_node = 0.0 + p_node = 0.0 + + ! Nodal values for S + + ! Parabolic reconstruction on the left + s0 = S_t(i,j) + s1 = 6.0 * S(i,j) - 4.0 * S_t(i,j) - 2.0 * S_b(i,j) + s2 = 3.0 * ( S_t(i,j) + S_b(i,j) - 2.0 * S(i,j) ) + S_node(2) = s0 + S_node(6) = s0 + 0.5 * s1 + 0.25 * s2 + S_node(3) = s0 + s1 + s2 + + ! Parabolic reconstruction on the left + s0 = S_t(i+1,j) + s1 = 6.0 * S(i+1,j) - 4.0 * S_t(i+1,j) - 2.0 * S_b(i+1,j) + s2 = 3.0 * ( S_t(i+1,j) + S_b(i+1,j) - 2.0 * S(i+1,j) ) + S_node(1) = s0 + S_node(8) = s0 + 0.5 * s1 + 0.25 * s2 + S_node(4) = s0 + s1 + s2 + + S_node(5) = 0.5 * ( S_node(2) + S_node(1) ) + S_node(9) = 0.5 * ( S_node(6) + S_node(8) ) + S_node(7) = 0.5 * ( S_node(3) + S_node(4) ) + + if (rho_scale /= 1.0) then + call calculate_density( T_node, S_node, p_node, r_node, 1, 9, EOS, rho_ref=rho_ref_mks, scale=rho_scale ) + else + call calculate_density( T_node, S_node, p_node, r_node, 1, 9, EOS, rho_ref=rho_ref_mks) + endif + r_node = r_node - rho_ref + + call compute_integral_quadratic( x, y, r_node, intx_dpa(i,j) ) + + intx_dpa(i,j) = intx_dpa(i,j) * G_e + + enddo ; enddo ; endif + + ! 3. Compute horizontal integrals in the y direction + if (present(inty_dpa)) then + call MOM_error(WARNING, "int_density_dz_generic_ppm still needs to be written for inty_dpa!") + do J=Jsq,Jeq ; do i=is,ie + + inty_dpa(i,j) = 0.0 + + enddo ; enddo + endif + +end subroutine int_density_dz_generic_ppm + + +!> 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 + real, dimension(9) :: weight, xi, eta ! integration points + real :: f_k + real :: dxdxi, dxdeta + real :: dydxi, dydeta + real, dimension(4) :: phiiso, dphiisodxi, dphiisodeta + real, dimension(9) :: phi, dphidxi, dphideta + real :: jacobian_k + real :: t + + ! Quadrature rule (4 points) + !weight(:) = 1.0 + !xi(1) = - sqrt(3.0) / 3.0 + !xi(2) = sqrt(3.0) / 3.0 + !xi(3) = sqrt(3.0) / 3.0 + !xi(4) = - sqrt(3.0) / 3.0 + !eta(1) = - sqrt(3.0) / 3.0 + !eta(2) = - sqrt(3.0) / 3.0 + !eta(3) = sqrt(3.0) / 3.0 + !eta(4) = sqrt(3.0) / 3.0 + + ! Quadrature rule (9 points) + t = sqrt(3.0/5.0) + weight(1) = 25.0/81.0 ; xi(1) = -t ; eta(1) = t + weight(2) = 40.0/81.0 ; xi(2) = .0 ; eta(2) = t + weight(3) = 25.0/81.0 ; xi(3) = t ; eta(3) = t + weight(4) = 40.0/81.0 ; xi(4) = -t ; eta(4) = .0 + weight(5) = 64.0/81.0 ; xi(5) = .0 ; eta(5) = .0 + weight(6) = 40.0/81.0 ; xi(6) = t ; eta(6) = .0 + weight(7) = 25.0/81.0 ; xi(7) = -t ; eta(7) = -t + weight(8) = 40.0/81.0 ; xi(8) = .0 ; eta(8) = -t + weight(9) = 25.0/81.0 ; xi(9) = t ; eta(9) = -t + + integral = 0.0 + + ! Integration loop + do k = 1,9 + + ! Evaluate shape functions and gradients for isomorphism + call evaluate_shape_bilinear( xi(k), eta(k), phiiso, & + dphiisodxi, dphiisodeta ) + + ! Determine gradient of global coordinate at integration point + dxdxi = 0.0 + dxdeta = 0.0 + dydxi = 0.0 + dydeta = 0.0 + + do i = 1,4 + dxdxi = dxdxi + x(i) * dphiisodxi(i) + dxdeta = dxdeta + x(i) * dphiisodeta(i) + dydxi = dydxi + y(i) * dphiisodxi(i) + dydeta = dydeta + y(i) * dphiisodeta(i) + enddo + + ! Evaluate Jacobian at integration point + jacobian_k = dxdxi*dydeta - dydxi*dxdeta + + ! Evaluate shape functions for interpolation + call evaluate_shape_quadratic( xi(k), eta(k), phi, dphidxi, dphideta ) + + ! Evaluate function at integration point + f_k = 0.0 + do i = 1,9 + f_k = f_k + f(i) * phi(i) + enddo + + integral = integral + weight(k) * f_k * jacobian_k + + enddo ! end integration loop + +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 ) + real, intent(in) :: xi !< The x position to evaluate + real, intent(in) :: eta !< The z position to evaluate + real, dimension(4), intent(inout) :: phi !< The weights of the four corners at this point + real, dimension(4), intent(inout) :: dphidxi !< The x-gradient of the weights of the four + !! corners at this point + real, dimension(4), intent(inout) :: 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) + ! | | + ! | | + ! | | + ! | | + ! (-1,-1) 3 o------------o 4 (1,-1) + ! + + phi(1) = 0.25 * ( 1 + xi ) * ( 1 + eta ) + phi(2) = 0.25 * ( 1 - xi ) * ( 1 + eta ) + phi(3) = 0.25 * ( 1 - xi ) * ( 1 - eta ) + phi(4) = 0.25 * ( 1 + xi ) * ( 1 - eta ) + + dphidxi(1) = 0.25 * ( 1 + eta ) + dphidxi(2) = - 0.25 * ( 1 + eta ) + dphidxi(3) = - 0.25 * ( 1 - eta ) + dphidxi(4) = 0.25 * ( 1 - eta ) + + dphideta(1) = 0.25 * ( 1 + xi ) + dphideta(2) = 0.25 * ( 1 - xi ) + dphideta(3) = - 0.25 * ( 1 - xi ) + dphideta(4) = - 0.25 * ( 1 + xi ) + +end subroutine evaluate_shape_bilinear + + +!> 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 !< The x position to evaluate + real, intent(in) :: eta !< The z position to evaluate + real, dimension(9), intent(inout) :: phi !< The weights of the 9 bilinear quadrature points + !! at this point + real, dimension(9), intent(inout) :: dphidxi !< The x-gradient of the weights of the 9 bilinear + !! quadrature points corners at this point + real, dimension(9), intent(inout) :: 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) + ! | | + ! | 9 (0,0) | + ! (-1,0) 6 o o o 8 (1,0) + ! | | + ! | | + ! (-1,-1) 3 o------o------o 4 (1,-1) + ! 7 (0,-1) + ! + + 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 ) + phi(3) = 0.25 * xi * ( 1 - xi ) * eta * ( 1 - eta ) + phi(4) = - 0.25 * xi * ( 1 + xi ) * eta * ( 1 - eta ) + phi(5) = 0.5 * ( 1 + xi ) * ( 1 - xi ) * eta * ( 1 + eta ) + phi(6) = - 0.5 * xi * ( 1 - xi ) * ( 1 - eta ) * ( 1 + eta ) + phi(7) = - 0.5 * ( 1 - xi ) * ( 1 + xi ) * eta * ( 1 - eta ) + phi(8) = 0.5 * xi * ( 1 + xi ) * ( 1 - eta ) * ( 1 + eta ) + phi(9) = ( 1 - xi ) * ( 1 + xi ) * ( 1 - eta ) * ( 1 + eta ) + + !dphidxi(1) = 0.25 * ( 1 + 2*xi ) * eta * ( 1 + eta ) + !dphidxi(2) = - 0.25 * ( 1 - 2*xi ) * eta * ( 1 + eta ) + !dphidxi(3) = 0.25 * ( 1 - 2*xi ) * eta * ( 1 - eta ) + !dphidxi(4) = - 0.25 * ( 1 + 2*xi ) * eta * ( 1 - eta ) + !dphidxi(5) = - xi * eta * ( 1 + eta ) + !dphidxi(6) = - 0.5 * ( 1 - 2*xi ) * ( 1 - eta ) * ( 1 + eta ) + !dphidxi(7) = xi * eta * ( 1 - eta ) + !dphidxi(8) = 0.5 * ( 1 + 2*xi ) * ( 1 - eta ) * ( 1 + eta ) + !dphidxi(9) = - 2 * xi * ( 1 - eta ) * ( 1 + eta ) + + !dphideta(1) = 0.25 * xi * ( 1 + xi ) * ( 1 + 2*eta ) + !dphideta(2) = - 0.25 * xi * ( 1 - xi ) * ( 1 + 2*eta ) + !dphideta(3) = 0.25 * xi * ( 1 - xi ) * ( 1 - 2*eta ) + !dphideta(4) = - 0.25 * xi * ( 1 + xi ) * ( 1 - 2*eta ) + !dphideta(5) = 0.5 * ( 1 + xi ) * ( 1 - xi ) * ( 1 + 2*eta ) + !dphideta(6) = xi * ( 1 - xi ) * eta + !dphideta(7) = - 0.5 * ( 1 - xi ) * ( 1 + xi ) * ( 1 - 2*eta ) + !dphideta(8) = - xi * ( 1 + xi ) * eta + !dphideta(9) = - 2 * ( 1 - xi ) * ( 1 + xi ) * eta + +end subroutine evaluate_shape_quadratic + + +!> This subroutine calculates integrals of specific volume anomalies in +!! pressure across layers, 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 Boole's rule quadrature to do the integrals. +subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, dza, & + intp_dza, intx_dza, inty_dza, halo_size, & + 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 [degC] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + 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 [R L2 T-2 ~> Pa] or [Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: p_b !< Pressure below the layer [R L2 T-2 ~> Pa] or [Pa] + real, intent(in) :: alpha_ref !< A mean specific volume that is subtracted out + !! to reduce the magnitude of each of the integrals [R-1 ~> 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 + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(inout) :: dza !< The change in the geopotential anomaly + !! across the layer [L2 T-2 ~> m2 s-2] or [m2 s-2] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of + !! the geopotential anomaly relative to the anomaly at the bottom of the + !! layer [R L4 T-4 ~> Pa m2 s-2] or [Pa m2 s-2] + real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & + optional, intent(inout) :: 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 [L2 T-2 ~> m2 s-2] or [m2 s-2] + real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & + optional, intent(inout) :: 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 [L2 T-2 ~> m2 s-2] or [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 [R L2 T-2 ~> Pa] or [Pa] + real, optional, intent(in) :: dP_neglect !< A minuscule pressure change with + !! the same units as p_t [R L2 T-2 ~> Pa] or [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 +! Boole'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 :: T5(5) ! Temperatures at five quadrature points [degC] + real :: S5(5) ! Salinities at five quadrature points [ppt] + real :: p5(5) ! Pressures at five quadrature points, scaled back to Pa if necessary [Pa] + real :: a5(5) ! Specific volumes at five quadrature points [R-1 ~> m3 kg-1] or [m3 kg-1] + real :: alpha_anom ! The depth averaged specific density anomaly [R-1 ~> m3 kg-1] + real :: dp ! The pressure change through a layer [R L2 T-2 ~> Pa] + real :: hWght ! A pressure-thickness below topography [R L2 T-2 ~> Pa] + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [R L2 T-2 ~> Pa] + real :: alpha_ref_mks ! The reference specific volume in MKS units, never rescaled from m3 kg-1 [m3 kg-1] + real :: iDenom ! The inverse of the denominator in the weights [T4 R-2 L-4 ~> 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 [L2 T-2 ~> m2 s-2] + real :: RL2_T2_to_Pa ! A unit conversion factor from the rescaled units of pressure to Pa [Pa T2 R-1 L-2 ~> 1] + real :: SV_scale ! A multiplicative factor by which to scale specific + ! volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] + 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 + + Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB + halo = 0 ; if (present(halo_size)) halo = MAX(halo_size,0) + ish = HI%isc-halo ; ieh = HI%iec+halo ; jsh = HI%jsc-halo ; jeh = HI%jec+halo + if (present(intx_dza)) then ; ish = MIN(Isq,ish) ; ieh = MAX(Ieq+1,ieh); endif + if (present(inty_dza)) then ; jsh = MIN(Jsq,jsh) ; jeh = MAX(Jeq+1,jeh); endif + + SV_scale = US%R_to_kg_m3 + RL2_T2_to_Pa = US%RL2_T2_to_Pa + alpha_ref_mks = alpha_ref * US%kg_m3_to_R + + do_massWeight = .false. + if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then + do_massWeight = .true. + if (.not.present(bathyP)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& + "bathyP must be present if useMassWghtInterp is present and true.") + if (.not.present(dP_neglect)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& + "dP_neglect must be present if useMassWghtInterp is present and true.") + endif ; endif + + do j=jsh,jeh ; do i=ish,ieh + dp = p_b(i,j) - p_t(i,j) + do n=1,5 + T5(n) = T(i,j) ; S5(n) = S(i,j) + p5(n) = RL2_T2_to_Pa * (p_b(i,j) - 0.25*real(n-1)*dp) + enddo + + if (SV_scale /= 1.0) then + call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks, scale=SV_scale) + else + call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks) + endif + + ! Use Boole's rule to estimate the interface height anomaly change. + alpha_anom = C1_90*(7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4)) + 12.0*a5(3)) + dza(i,j) = dp*alpha_anom + ! Use a Boole's-rule-like fifth-order accurate estimate of the double integral of + ! the interface height anomaly. + if (present(intp_dza)) intp_dza(i,j) = 0.5*dp**2 * & + (alpha_anom - C1_90*(16.0*(a5(4)-a5(2)) + 7.0*(a5(5)-a5(1))) ) + enddo ; enddo + + if (present(intx_dza)) then ; do j=HI%jsc,HI%jec ; do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intp(1) = dza(i,j) ; intp(5) = dza(i+1,j) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness weighted. + p5(1) = RL2_T2_to_Pa * (wt_L*p_b(i,j) + wt_R*p_b(i+1,j)) + dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i+1,j) - p_t(i+1,j)) + T5(1) = wtT_L*T(i,j) + wtT_R*T(i+1,j) + S5(1) = wtT_L*S(i,j) + wtT_R*S(i+1,j) + + do n=2,5 + T5(n) = T5(1) ; S5(n) = S5(1) ; p5(n) = p5(n-1) - RL2_T2_to_Pa * 0.25*dp + enddo + if (SV_scale /= 1.0) then + call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks, scale=SV_scale) + else + call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks) + endif + + ! Use Boole's rule to estimate the interface height anomaly change. + intp(m) = dp*( C1_90*(7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4)) + & + 12.0*a5(3))) + enddo + ! Use Boole's rule to integrate the interface height anomaly values in x. + intx_dza(i,j) = C1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + & + 12.0*intp(3)) + enddo ; enddo ; endif + + if (present(inty_dza)) then ; do J=Jsq,Jeq ; do i=HI%isc,HI%iec + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intp(1) = dza(i,j) ; intp(5) = dza(i,j+1) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness weighted. + p5(1) = RL2_T2_to_Pa * (wt_L*p_b(i,j) + wt_R*p_b(i,j+1)) + dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i,j+1) - p_t(i,j+1)) + T5(1) = wtT_L*T(i,j) + wtT_R*T(i,j+1) + S5(1) = wtT_L*S(i,j) + wtT_R*S(i,j+1) + do n=2,5 + T5(n) = T5(1) ; S5(n) = S5(1) ; p5(n) = RL2_T2_to_Pa * (p5(n-1) - 0.25*dp) + enddo + if (SV_scale /= 1.0) then + call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks, scale=SV_scale) + else + call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks) + endif + + ! Use Boole's rule to estimate the interface height anomaly change. + intp(m) = dp*( C1_90*(7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4)) + & + 12.0*a5(3))) + enddo + ! Use Boole's rule to integrate the interface height anomaly values in y. + inty_dza(i,j) = C1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + & + 12.0*intp(3)) + enddo ; enddo ; endif + +end subroutine int_spec_vol_dp_generic_pcm + +!> This subroutine calculates integrals of specific volume anomalies in +!! pressure across layers, 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 Boole's rule quadrature to do the integrals. +subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, & + dP_neglect, bathyP, HI, EOS, US, dza, & + 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 [degC] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + 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 [ppt] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + 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 [R L2 T-2 ~> Pa] or [Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: p_b !< Pressure below the layer [R L2 T-2 ~> Pa] or [Pa] + real, intent(in) :: alpha_ref !< A mean specific volume that is subtracted out + !! to reduce the magnitude of each of the integrals [R-1 ~> 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 ! Pa] or [Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] or [Pa] + type(EOS_type), pointer :: EOS !< Equation of state structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(inout) :: dza !< The change in the geopotential anomaly + !! across the layer [L2 T-2 ~> m2 s-2] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of + !! the geopotential anomaly relative to the anomaly at the bottom of the + !! layer [R L4 T-4 ~> Pa m2 s-2] or [Pa m2 s-2] + real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & + optional, intent(inout) :: 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 [L2 T-2 ~> m2 s-2] or [m2 s-2] + real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & + optional, intent(inout) :: 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 [L2 T-2 ~> m2 s-2] or [m2 s-2] + 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 +! Boole'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. + + real :: T5(5) ! Temperatures at five quadrature points [degC] + real :: S5(5) ! Salinities at five quadrature points [ppt] + real :: p5(5) ! Pressures at five quadrature points, scaled back to Pa as necessary [Pa] + real :: a5(5) ! Specific volumes at five quadrature points [R-1 ~> m3 kg-1] or [m3 kg-1] + real :: T15(15) ! Temperatures at fifteen interior quadrature points [degC] + real :: S15(15) ! Salinities at fifteen interior quadrature points [ppt] + real :: p15(15) ! Pressures at fifteen quadrature points, scaled back to Pa as necessary [Pa] + real :: a15(15) ! Specific volumes at fifteen quadrature points [R-1 ~> m3 kg-1] or [m3 kg-1] + real :: wt_t(5), wt_b(5) ! Weights of top and bottom values at quadrature points [nondim] + real :: T_top, T_bot, S_top, S_bot, P_top, P_bot + + real :: alpha_anom ! The depth averaged specific density anomaly [m3 kg-1] + real :: dp ! The pressure change through a layer [R L2 T-2 ~> Pa] + real :: dp_90(2:4) ! The pressure change through a layer divided by 90 [R L2 T-2 ~> Pa] + real :: hWght ! A pressure-thickness below topography [R L2 T-2 ~> Pa] + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [R L2 T-2 ~> Pa] + real :: alpha_ref_mks ! The reference specific volume in MKS units, never rescaled from m3 kg-1 [m3 kg-1] + real :: iDenom ! The inverse of the denominator in the weights [T4 R-2 L-4 ~> 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 [L2 T-2 ~> m2 s-2] + real :: RL2_T2_to_Pa ! A unit conversion factor from the rescaled units of pressure to Pa [Pa T2 R-1 L-2 ~> 1] + real :: SV_scale ! A multiplicative factor by which to scale specific + ! volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] + 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 + + Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB + + do_massWeight = .false. + if (present(useMassWghtInterp)) do_massWeight = useMassWghtInterp + + SV_scale = US%R_to_kg_m3 + RL2_T2_to_Pa = US%RL2_T2_to_Pa + alpha_ref_mks = alpha_ref * US%kg_m3_to_R + + do n = 1, 5 ! Note that these are reversed from int_density_dz. + wt_t(n) = 0.25 * real(n-1) + wt_b(n) = 1.0 - wt_t(n) + enddo + + ! 1. Compute vertical integrals + do j=Jsq,Jeq+1; do i=Isq,Ieq+1 + dp = p_b(i,j) - p_t(i,j) + do n=1,5 ! T, S and p are linearly interpolated in the vertical. + p5(n) = RL2_T2_to_Pa * (wt_t(n) * p_t(i,j) + wt_b(n) * p_b(i,j)) + S5(n) = wt_t(n) * S_t(i,j) + wt_b(n) * S_b(i,j) + T5(n) = wt_t(n) * T_t(i,j) + wt_b(n) * T_b(i,j) + enddo + if (SV_scale /= 1.0) then + call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks, scale=SV_scale) + else + call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks) + endif + + ! Use Boole's rule to estimate the interface height anomaly change. + alpha_anom = C1_90*((7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4))) + 12.0*a5(3)) + dza(i,j) = dp*alpha_anom + ! Use a Boole's-rule-like fifth-order accurate estimate of the double integral of + ! the interface height anomaly. + if (present(intp_dza)) intp_dza(i,j) = 0.5*dp**2 * & + (alpha_anom - C1_90*(16.0*(a5(4)-a5(2)) + 7.0*(a5(5)-a5(1))) ) + enddo ; enddo + + ! 2. Compute horizontal integrals in the x direction + if (present(intx_dza)) then ; do j=HI%jsc,HI%jec ; do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, almost like thickness + ! weighting. Note: To work in terrain following coordinates we could + ! offset this distance by the layer thickness to replicate other models. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness weighted. + P_top = wt_L*p_t(i,j) + wt_R*p_t(i+1,j) + P_bot = wt_L*p_b(i,j) + wt_R*p_b(i+1,j) + T_top = wtT_L*T_t(i,j) + wtT_R*T_t(i+1,j) + T_bot = wtT_L*T_b(i,j) + wtT_R*T_b(i+1,j) + S_top = wtT_L*S_t(i,j) + wtT_R*S_t(i+1,j) + S_bot = wtT_L*S_b(i,j) + wtT_R*S_b(i+1,j) + dp_90(m) = C1_90*(P_bot - P_top) + + ! Salinity, temperature and pressure with linear interpolation in the vertical. + pos = (m-2)*5 + do n=1,5 + p15(pos+n) = RL2_T2_to_Pa * (wt_t(n) * P_top + wt_b(n) * P_bot) + S15(pos+n) = wt_t(n) * S_top + wt_b(n) * S_bot + T15(pos+n) = wt_t(n) * T_top + wt_b(n) * T_bot + enddo + enddo + + if (SV_scale /= 1.0) then + call calculate_spec_vol(T15, S15, p15, a15, 1, 15, EOS, alpha_ref_mks, scale=SV_scale) + else + call calculate_spec_vol(T15, S15, p15, a15, 1, 15, EOS, alpha_ref_mks) + endif + + intp(1) = dza(i,j) ; intp(5) = dza(i+1,j) + do m=2,4 + ! Use Boole's rule to estimate the interface height anomaly change. + ! The integrals at the ends of the segment are already known. + pos = (m-2)*5 + intp(m) = dp_90(m)*((7.0*(a15(pos+1)+a15(pos+5)) + & + 32.0*(a15(pos+2)+a15(pos+4))) + 12.0*a15(pos+3)) + enddo + ! Use Boole's rule to integrate the interface height anomaly values in x. + intx_dza(I,j) = C1_90*((7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4))) + & + 12.0*intp(3)) + enddo ; enddo ; endif + + ! 3. Compute horizontal integrals in the y direction + if (present(inty_dza)) then ; do J=Jsq,Jeq ; do i=HI%isc,HI%iec + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, like thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness weighted. + P_top = wt_L*p_t(i,j) + wt_R*p_t(i,j+1) + P_bot = wt_L*p_b(i,j) + wt_R*p_b(i,j+1) + T_top = wtT_L*T_t(i,j) + wtT_R*T_t(i,j+1) + T_bot = wtT_L*T_b(i,j) + wtT_R*T_b(i,j+1) + S_top = wtT_L*S_t(i,j) + wtT_R*S_t(i,j+1) + S_bot = wtT_L*S_b(i,j) + wtT_R*S_b(i,j+1) + dp_90(m) = C1_90*(P_bot - P_top) + + ! Salinity, temperature and pressure with linear interpolation in the vertical. + pos = (m-2)*5 + do n=1,5 + p15(pos+n) = RL2_T2_to_Pa * (wt_t(n) * P_top + wt_b(n) * P_bot) + S15(pos+n) = wt_t(n) * S_top + wt_b(n) * S_bot + T15(pos+n) = wt_t(n) * T_top + wt_b(n) * T_bot + enddo + enddo + + if (SV_scale /= 1.0) then + call calculate_spec_vol(T15, S15, p15, a15, 1, 15, EOS, alpha_ref_mks, scale=SV_scale) + else + call calculate_spec_vol(T15, S15, p15, a15, 1, 15, EOS, alpha_ref_mks) + endif + + intp(1) = dza(i,j) ; intp(5) = dza(i,j+1) + do m=2,4 + ! Use Boole's rule to estimate the interface height anomaly change. + ! The integrals at the ends of the segment are already known. + pos = (m-2)*5 + intp(m) = dp_90(m) * ((7.0*(a15(pos+1)+a15(pos+5)) + & + 32.0*(a15(pos+2)+a15(pos+4))) + 12.0*a15(pos+3)) + enddo + ! Use Boole's rule to integrate the interface height anomaly values in x. + inty_dza(i,J) = C1_90*((7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4))) + & + 12.0*intp(3)) + enddo ; enddo ; endif + +end subroutine int_spec_vol_dp_generic_plm + +end module MOM_density_integrals + +!> \namespace mom_density_integrals +!! diff --git a/src/core/MOM_interface_heights.F90 b/src/core/MOM_interface_heights.F90 index fc775d938f..b8cf161148 100644 --- a/src/core/MOM_interface_heights.F90 +++ b/src/core/MOM_interface_heights.F90 @@ -9,7 +9,7 @@ module MOM_interface_heights 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 +use MOM_density_integrals, only : int_specific_vol_dp implicit none ; private @@ -109,7 +109,7 @@ subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m) !$OMP do 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=halo) + 0.0, G%HI, tv%eqn_of_state, US, dz_geo(:,:,k), halo_size=halo) enddo !$OMP do do j=jsv,jev @@ -214,7 +214,7 @@ subroutine find_eta_2d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m) !$OMP do 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=halo) + G%HI, tv%eqn_of_state, US, dz_geo(:,:,k), halo_size=halo) enddo !$OMP do do j=js,je ; do k=1,nz ; do i=is,ie diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index 58bc196744..7a33dc7d77 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -7,7 +7,7 @@ module MOM_isopycnal_slopes 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 +use MOM_EOS, only : calculate_density_derivs use MOM_open_boundary, only : ocean_OBC_type use MOM_open_boundary, only : OBC_DIRECTION_E, OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index f26e7fc815..d51173c16b 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -6,6 +6,7 @@ module MOM_diagnostics ! This file is part of MOM6. See LICENSE.md for the license. use MOM_coms, only : reproducing_sum +use MOM_density_integrals, only : int_density_dz 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 @@ -15,7 +16,7 @@ module MOM_diagnostics use MOM_diag_mediator, only : diag_save_grids, diag_restore_grids, diag_copy_storage_to_diag use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type use MOM_domains, only : To_North, To_East -use MOM_EOS, only : calculate_density, calculate_density_derivs, int_density_dz, EOS_domain +use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_domain use MOM_EOS, only : gsw_sp_from_sr, gsw_pt_from_ct use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_version, param_file_type @@ -863,7 +864,7 @@ subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, US, CS) 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%Rho0, GV%g_Earth, & - G%HI, tv%eqn_of_state, dpress) + G%HI, tv%eqn_of_state, US, dpress) do j=js,je ; do i=is,ie mass(i,j) = mass(i,j) + dpress(i,j) * IG_Earth enddo ; enddo diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 44d34ce475..b3cfcab83f 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -42,10 +42,8 @@ module MOM_EOS public calculate_density_second_derivs public EOS_init, EOS_manual_init, EOS_end, EOS_allocate, EOS_domain public EOS_use_linear, calculate_spec_vol -public int_density_dz, int_specific_vol_dp -public int_density_dz_generic_plm, int_density_dz_generic_ppm -public int_spec_vol_dp_generic_plm !, int_spec_vol_dz_generic_ppm -public int_density_dz_generic, int_spec_vol_dp_generic +public analytic_int_density_dz, analytic_int_specific_vol_dp +public EOS_quadrature public find_depth_of_pressure_in_cell public calculate_TFreeze public convert_temp_salt_for_TEOS10 @@ -1141,7 +1139,7 @@ end function EOS_domain !! 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. -subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & +subroutine analytic_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) type(hor_index_type), intent(in) :: HI !< The horizontal index structure @@ -1189,9 +1187,7 @@ subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & "int_specific_vol_dp called with an unassociated EOS_type EOS.") if (EOS%EOS_quadrature) then - call int_spec_vol_dp_generic(T, S, p_t, p_b, alpha_ref, HI, EOS, & - dza, intp_dza, intx_dza, inty_dza, halo_size, & - bathyP, dP_tiny, useMassWghtInterp) + call MOM_error(FATAL, "EOS_quadrature is set!") else ; select case (EOS%form_of_EOS) case (EOS_LINEAR) call int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, EOS%kg_m3_to_R*EOS%Rho_T0_S0, & @@ -1203,17 +1199,15 @@ subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & inty_dza, halo_size, bathyP, dP_tiny, useMassWghtInterp, & SV_scale=EOS%R_to_kg_m3, pres_scale=EOS%RL2_T2_to_Pa) case default - call int_spec_vol_dp_generic(T, S, p_t, p_b, alpha_ref, HI, EOS, & - dza, intp_dza, intx_dza, inty_dza, halo_size, & - bathyP, dP_tiny, useMassWghtInterp) + call MOM_error(FATAL, "Set EOS_QUADRATURE!") end select ; endif -end subroutine int_specific_vol_dp +end subroutine analytic_int_specific_vol_dp !> This subroutine calculates analytical and nearly-analytical integrals of !! pressure anomalies across layers, which are required for calculating the !! finite-volume form pressure accelerations in a Boussinesq model. -subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, dpa, & +subroutine analytic_int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, dpa, & intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp) type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structure real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & @@ -1262,8 +1256,7 @@ subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, dpa, & "int_density_dz called with an unassociated EOS_type EOS.") if (EOS%EOS_quadrature) then - call int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, dpa, & - intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp) + call MOM_error(FATAL, "EOS_quadrature is set!") else ; select case (EOS%form_of_EOS) case (EOS_LINEAR) rho_scale = EOS%kg_m3_to_R @@ -1289,11 +1282,10 @@ subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, dpa, & dz_neglect, useMassWghtInterp) endif case default - call int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, dpa, & - intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp) + call MOM_error(FATAL, "Use EOS_QUADRATURE!") end select ; endif -end subroutine int_density_dz +end subroutine analytic_int_density_dz !> Returns true if the equation of state is compressible (i.e. has pressure dependence) logical function query_compressible(EOS) @@ -1487,526 +1479,6 @@ subroutine EOS_use_linear(Rho_T0_S0, dRho_dT, dRho_dS, EOS, use_quadrature) end subroutine EOS_use_linear -!> 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. -subroutine int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & - EOS, dpa, intz_dpa, intx_dpa, inty_dpa, & - bathyT, dz_neglect, useMassWghtInterp) - type(hor_index_type), intent(in) :: HI !< Horizontal index type for variables. - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - 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 [ppt] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: z_b !< Height at the bottom of the layer [Z ~> m] - real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that is - !! subtracted out to reduce the magnitude - !! of each of the integrals. - real, intent(in) :: rho_0 !< A density [R ~> kg m-3] or [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 - !! [L2 Z-1 T-2 ~> m s-2] or [m2 Z-1 s-2 ~> m s-2] - type(EOS_type), pointer :: EOS !< Equation of state structure - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(inout) :: dpa !< The change in the pressure anomaly - !! across the layer [R L2 T-2 ~> Pa] or [Pa] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - optional, intent(inout) :: intz_dpa !< The integral through the thickness of the - !! layer of the pressure anomaly relative to the - !! anomaly at the top of the layer [R L2 Z T-2 ~> Pa m] - real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & - optional, intent(inout) :: 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 [R L2 T-2 ~> Pa] - real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & - optional, intent(inout) :: 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 [R L2 T-2 ~> Pa] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%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. - ! Local variables - real :: T5(5), S5(5) ! Temperatures and salinities at five quadrature points [degC] and [ppt] - real :: p5(5) ! Pressures at five quadrature points, never rescaled from Pa [Pa] - real :: r5(5) ! Densities at five quadrature points [R ~> kg m-3] or [kg m-3] - real :: rho_anom ! The depth averaged density anomaly [R ~> kg m-3] or [kg m-3] - real :: w_left, w_right ! Left and right weights [nondim] - real, parameter :: C1_90 = 1.0/90.0 ! Rational constants. - real :: GxRho ! The gravitational acceleration times density and unit conversion factors [Pa Z-1 ~> kg m-2 s-2] - real :: I_Rho ! The inverse of the Boussinesq density [R-1 ~> m3 kg-1] or [m3 kg-1] - real :: rho_scale ! A scaling factor for densities from kg m-3 to R [R m3 kg-1 ~> 1] - real :: rho_ref_mks ! The reference density in MKS units, never rescaled from kg m-3 [kg m-3] - 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 [R L2 T-2 ~> Pa] or [Pa] - logical :: do_massWeight ! Indicates whether to do mass weighting. - integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, m, n - - ! These array bounds work for the indexing convention of the input arrays, but - ! on the computational domain defined for the output arrays. - Isq = HI%IscB ; Ieq = HI%IecB - Jsq = HI%JscB ; Jeq = HI%JecB - is = HI%isc ; ie = HI%iec - js = HI%jsc ; je = HI%jec - - rho_scale = EOS%kg_m3_to_R - GxRho = EOS%RL2_T2_to_Pa * G_e * rho_0 - rho_ref_mks = rho_ref * EOS%R_to_kg_m3 - I_Rho = 1.0 / rho_0 - - do_massWeight = .false. - if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then - do_massWeight = .true. - if (.not.present(bathyT)) call MOM_error(FATAL, "int_density_dz_generic: "//& - "bathyT must be present if useMassWghtInterp is present and true.") - if (.not.present(dz_neglect)) call MOM_error(FATAL, "int_density_dz_generic: "//& - "dz_neglect must be present if useMassWghtInterp is present and true.") - endif ; endif - - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - dz = z_t(i,j) - z_b(i,j) - do n=1,5 - T5(n) = T(i,j) ; S5(n) = S(i,j) - p5(n) = -GxRho*(z_t(i,j) - 0.25*real(n-1)*dz) - enddo - if (rho_scale /= 1.0) then - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) - else - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks) - endif - - ! Use Bode's rule to estimate the pressure anomaly change. - rho_anom = C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) - dpa(i,j) = G_e*dz*rho_anom - ! Use a Bode's-rule-like fifth-order accurate estimate of the double integral of - ! the pressure anomaly. - if (present(intz_dpa)) intz_dpa(i,j) = 0.5*G_e*dz**2 * & - (rho_anom - C1_90*(16.0*(r5(4)-r5(2)) + 7.0*(r5(5)-r5(1))) ) - enddo ; enddo - - if (present(intx_dpa)) then ; do j=js,je ; do I=Isq,Ieq - ! hWght is the distance measure by which the cell is violation of - ! hydrostatic consistency. For large hWght we bias the interpolation of - ! T & S along the top and bottom integrals, akin to thickness weighting. - hWght = 0.0 - if (do_massWeight) & - hWght = max(0., -bathyT(i,j)-z_t(i+1,j), -bathyT(i+1,j)-z_t(i,j)) - if (hWght > 0.) then - hL = (z_t(i,j) - z_b(i,j)) + dz_neglect - hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_neglect - hWght = hWght * ( (hL-hR)/(hL+hR) )**2 - iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) - hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom - hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom - else - hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 - endif - - intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) - do m=2,4 - ! T, S, and z are interpolated in the horizontal. The z interpolation - ! is linear, but for T and S it may be thickness weighted. - wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L - wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR - dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i+1,j) - z_b(i+1,j)) - T5(1) = wtT_L*T(i,j) + wtT_R*T(i+1,j) - S5(1) = wtT_L*S(i,j) + wtT_R*S(i+1,j) - p5(1) = -GxRho*(wt_L*z_t(i,j) + wt_R*z_t(i+1,j)) - do n=2,5 - T5(n) = T5(1) ; S5(n) = S5(1) ; p5(n) = p5(n-1) + GxRho*0.25*dz - enddo - if (rho_scale /= 1.0) then - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) - else - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks) - endif - - ! Use Bode's rule to estimate the pressure anomaly change. - intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3))) - enddo - ! Use Bode's rule to integrate the bottom pressure anomaly values in x. - intx_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & - 12.0*intz(3)) - enddo ; enddo ; endif - - if (present(inty_dpa)) then ; do J=Jsq,Jeq ; do i=is,ie - ! hWght is the distance measure by which the cell is violation of - ! hydrostatic consistency. For large hWght we bias the interpolation of - ! T & S along the top and bottom integrals, akin to thickness weighting. - hWght = 0.0 - if (do_massWeight) & - hWght = max(0., -bathyT(i,j)-z_t(i,j+1), -bathyT(i,j+1)-z_t(i,j)) - if (hWght > 0.) then - hL = (z_t(i,j) - z_b(i,j)) + dz_neglect - hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_neglect - hWght = hWght * ( (hL-hR)/(hL+hR) )**2 - iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) - hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom - hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom - else - hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 - endif - - intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) - do m=2,4 - ! T, S, and z are interpolated in the horizontal. The z interpolation - ! is linear, but for T and S it may be thickness weighted. - wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L - wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR - dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i,j+1) - z_b(i,j+1)) - T5(1) = wtT_L*T(i,j) + wtT_R*T(i,j+1) - S5(1) = wtT_L*S(i,j) + wtT_R*S(i,j+1) - p5(1) = -GxRho*(wt_L*z_t(i,j) + wt_R*z_t(i,j+1)) - do n=2,5 - T5(n) = T5(1) ; S5(n) = S5(1) - p5(n) = p5(n-1) + GxRho*0.25*dz - enddo - if (rho_scale /= 1.0) then - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) - else - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks) - endif - - ! Use Bode's rule to estimate the pressure anomaly change. - intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3))) - enddo - ! Use Bode's rule to integrate the values. - inty_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & - 12.0*intz(3)) - enddo ; enddo ; endif -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, HI, EOS, dpa, & - intz_dpa, intx_dpa, inty_dpa, useMassWghtInterp) - type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structures for the arrays - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: T_t !< Potential temperatue at the cell top [degC] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: T_b !< Potential temperatue at the cell bottom [degC] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: S_t !< Salinity at the cell top [ppt] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: S_b !< Salinity at the cell bottom [ppt] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: z_t !< The geometric height at the top of the layer [Z ~> m] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: z_b !< The geometric height at the bottom of the layer [Z ~> m] - real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that is subtracted - !! out to reduce the magnitude of each of the integrals. - real, intent(in) :: rho_0 !< A density [R ~> kg m-3] or [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 [L2 Z-1 T-2 ~> m s-2] - real, intent(in) :: dz_subroundoff !< A miniscule thickness change [Z ~> m] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] - type(EOS_type), pointer :: EOS !< Equation of state structure - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(inout) :: dpa !< The change in the pressure anomaly across the layer [R L2 T-2 ~> Pa] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - optional, intent(inout) :: intz_dpa !< The integral through the thickness of the layer of - !! the pressure anomaly relative to the anomaly at the - !! top of the layer [R L2 Z T-2 ~> Pa Z] - real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & - optional, intent(inout) :: 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 [R L2 T-2 ~> Pa] - real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & - optional, intent(inout) :: 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 [R L2 T-2 ~> 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 -! potentially dodgy assumtion here is that rho_0 is used both in the denominator -! of the accelerations, and in the pressure used to calculated density (the -! latter being -z*rho_0*G_e). These two uses could be separated if need be. -! -! 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. - - ! Local variables - real :: T5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Temperatures along a line of subgrid locations [degC] - real :: S5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Salinities along a line of subgrid locations [ppt] - real :: p5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Pressures along a line of subgrid locations, never - ! rescaled from Pa [Pa] - real :: r5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Densities anomalies along a line of subgrid - ! locations [R ~> kg m-3] or [kg m-3] - real :: T15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Temperatures at an array of subgrid locations [degC] - real :: S15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Salinities at an array of subgrid locations [ppt] - real :: p15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Pressures at an array of subgrid locations [Pa] - real :: r15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Densities at an array of subgrid locations - ! [R ~> kg m-3] or [kg m-3] - real :: wt_t(5), wt_b(5) ! Top and bottom weights [nondim] - real :: rho_anom ! A density anomaly [R ~> kg m-3] or [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 [R L2 T-2 ~> Pa] or [Pa] - real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] - real :: GxRho ! The gravitational acceleration times density and unit conversion factors [Pa Z-1 ~> kg m-2 s-2] - real :: I_Rho ! The inverse of the Boussinesq density [R-1 ~> m3 kg-1] or [m3 kg-1] - real :: rho_scale ! A scaling factor for densities from kg m-3 to R [R m3 kg-1 ~> 1] - real :: rho_ref_mks ! The reference density in MKS units, never rescaled from kg m-3 [kg m-3] - real :: dz(HI%iscB:HI%iecB+1) ! Layer thicknesses at tracer points [Z ~> m] - real :: dz_x(5,HI%iscB:HI%iecB) ! Layer thicknesses along an x-line of subrid locations [Z ~> m] - real :: dz_y(5,HI%isc:HI%iec) ! Layer thicknesses along a y-line of subrid locations [Z ~> m] - real :: weight_t, weight_b ! Nondimensional weights of the top and bottom [nondim] - real :: massWeightToggle ! A nondimensional toggle factor (0 or 1) [nondim] - 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 :: pos - - Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB - - rho_scale = EOS%kg_m3_to_R - GxRho = EOS%RL2_T2_to_Pa * G_e * rho_0 - rho_ref_mks = rho_ref * EOS%R_to_kg_m3 - I_Rho = 1.0 / rho_0 - massWeightToggle = 0. - if (present(useMassWghtInterp)) then - if (useMassWghtInterp) massWeightToggle = 1. - endif - - do n = 1, 5 - wt_t(n) = 0.25 * real(5-n) - wt_b(n) = 1.0 - wt_t(n) - enddo - - ! ============================= - ! 1. Compute vertical integrals - ! ============================= - do j=Jsq,Jeq+1 - do i = Isq,Ieq+1 - dz(i) = z_t(i,j) - z_b(i,j) - do n=1,5 - p5(i*5+n) = -GxRho*(z_t(i,j) - 0.25*real(n-1)*dz(i)) - ! Salinity and temperature points are linearly interpolated - S5(i*5+n) = wt_t(n) * S_t(i,j) + wt_b(n) * S_b(i,j) - T5(i*5+n) = wt_t(n) * T_t(i,j) + wt_b(n) * T_b(i,j) - enddo - enddo - if (rho_scale /= 1.0) then - call calculate_density_array(T5, S5, p5, r5, 1, (ieq-isq+2)*5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) - else - call calculate_density_array(T5, S5, p5, r5, 1, (ieq-isq+2)*5, EOS, rho_ref=rho_ref_mks) - endif - - do i=isq,ieq+1 - ! Use Bode's rule to estimate the pressure anomaly change. - rho_anom = C1_90*(7.0*(r5(i*5+1)+r5(i*5+5)) + 32.0*(r5(i*5+2)+r5(i*5+4)) + 12.0*r5(i*5+3)) - dpa(i,j) = G_e*dz(i)*rho_anom - if (present(intz_dpa)) then - ! Use a Bode's-rule-like fifth-order accurate estimate of - ! the double integral of the pressure anomaly. - intz_dpa(i,j) = 0.5*G_e*dz(i)**2 * & - (rho_anom - C1_90*(16.0*(r5(i*5+4)-r5(i*5+2)) + 7.0*(r5(i*5+5)-r5(i*5+1))) ) - endif - enddo - enddo ! end loops on j - - - ! ================================================== - ! 2. Compute horizontal integrals in the x direction - ! ================================================== - if (present(intx_dpa)) then ; do j=HI%jsc,HI%jec - do I=Isq,Ieq - ! Corner values of T and S - ! hWght is the distance measure by which the cell is violation of - ! hydrostatic consistency. For large hWght we bias the interpolation - ! of T,S along the top and bottom integrals, almost like thickness - ! weighting. - ! Note: To work in terrain following coordinates we could offset - ! this distance by the layer thickness to replicate other models. - hWght = massWeightToggle * & - max(0., -bathyT(i,j)-z_t(i+1,j), -bathyT(i+1,j)-z_t(i,j)) - if (hWght > 0.) then - hL = (z_t(i,j) - z_b(i,j)) + dz_subroundoff - hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_subroundoff - hWght = hWght * ( (hL-hR)/(hL+hR) )**2 - iDenom = 1./( hWght*(hR + hL) + hL*hR ) - Ttl = ( (hWght*hR)*T_t(i+1,j) + (hWght*hL + hR*hL)*T_t(i,j) ) * iDenom - Ttr = ( (hWght*hL)*T_t(i,j) + (hWght*hR + hR*hL)*T_t(i+1,j) ) * iDenom - Tbl = ( (hWght*hR)*T_b(i+1,j) + (hWght*hL + hR*hL)*T_b(i,j) ) * iDenom - Tbr = ( (hWght*hL)*T_b(i,j) + (hWght*hR + hR*hL)*T_b(i+1,j) ) * iDenom - Stl = ( (hWght*hR)*S_t(i+1,j) + (hWght*hL + hR*hL)*S_t(i,j) ) * iDenom - Str = ( (hWght*hL)*S_t(i,j) + (hWght*hR + hR*hL)*S_t(i+1,j) ) * iDenom - Sbl = ( (hWght*hR)*S_b(i+1,j) + (hWght*hL + hR*hL)*S_b(i,j) ) * iDenom - Sbr = ( (hWght*hL)*S_b(i,j) + (hWght*hR + hR*hL)*S_b(i+1,j) ) * iDenom - else - Ttl = T_t(i,j); Tbl = T_b(i,j); Ttr = T_t(i+1,j); Tbr = T_b(i+1,j) - Stl = S_t(i,j); Sbl = S_b(i,j); Str = S_t(i+1,j); Sbr = S_b(i+1,j) - endif - - do m=2,4 - w_left = 0.25*real(5-m) ; w_right = 1.0-w_left - dz_x(m,i) = w_left*(z_t(i,j) - z_b(i,j)) + w_right*(z_t(i+1,j) - z_b(i+1,j)) - - ! Salinity and temperature points are linearly interpolated in - ! the horizontal. The subscript (1) refers to the top value in - ! the vertical profile while subscript (5) refers to the bottom - ! value in the vertical profile. - pos = i*15+(m-2)*5 - T15(pos+1) = w_left*Ttl + w_right*Ttr - T15(pos+5) = w_left*Tbl + w_right*Tbr - - S15(pos+1) = w_left*Stl + w_right*Str - S15(pos+5) = w_left*Sbl + w_right*Sbr - - p15(pos+1) = -GxRho*(w_left*z_t(i,j) + w_right*z_t(i+1,j)) - - ! Pressure - do n=2,5 - p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_x(m,i) - enddo - - ! Salinity and temperature (linear interpolation in the vertical) - do n=2,4 - weight_t = 0.25 * real(5-n) - weight_b = 1.0 - weight_t - S15(pos+n) = weight_t * S15(pos+1) + weight_b * S15(pos+5) - T15(pos+n) = weight_t * T15(pos+1) + weight_b * T15(pos+5) - enddo - enddo - enddo - - if (rho_scale /= 1.0) then - call calculate_density(T15, S15, p15, r15, 1, 15*(ieq-isq+1), EOS, rho_ref=rho_ref_mks, scale=rho_scale) - else - call calculate_density(T15, S15, p15, r15, 1, 15*(ieq-isq+1), EOS, rho_ref=rho_ref_mks) - endif - - do I=Isq,Ieq - intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) - - ! Use Bode's rule to estimate the pressure anomaly change. - do m = 2,4 - pos = i*15+(m-2)*5 - intz(m) = G_e*dz_x(m,i)*( C1_90*(7.0*(r15(pos+1)+r15(pos+5)) + 32.0*(r15(pos+2)+r15(pos+4)) + & - 12.0*r15(pos+3))) - enddo - ! Use Bode's rule to integrate the bottom pressure anomaly values in x. - intx_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & - 12.0*intz(3)) - enddo - enddo ; endif - - ! ================================================== - ! 3. Compute horizontal integrals in the y direction - ! ================================================== - if (present(inty_dpa)) then ; do J=Jsq,Jeq - do i=HI%isc,HI%iec - ! Corner values of T and S - ! hWght is the distance measure by which the cell is violation of - ! hydrostatic consistency. For large hWght we bias the interpolation - ! of T,S along the top and bottom integrals, almost like thickness - ! weighting. - ! Note: To work in terrain following coordinates we could offset - ! this distance by the layer thickness to replicate other models. - hWght = massWeightToggle * & - max(0., -bathyT(i,j)-z_t(i,j+1), -bathyT(i,j+1)-z_t(i,j)) - if (hWght > 0.) then - hL = (z_t(i,j) - z_b(i,j)) + dz_subroundoff - hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_subroundoff - hWght = hWght * ( (hL-hR)/(hL+hR) )**2 - iDenom = 1./( hWght*(hR + hL) + hL*hR ) - Ttl = ( (hWght*hR)*T_t(i,j+1) + (hWght*hL + hR*hL)*T_t(i,j) ) * iDenom - Ttr = ( (hWght*hL)*T_t(i,j) + (hWght*hR + hR*hL)*T_t(i,j+1) ) * iDenom - Tbl = ( (hWght*hR)*T_b(i,j+1) + (hWght*hL + hR*hL)*T_b(i,j) ) * iDenom - Tbr = ( (hWght*hL)*T_b(i,j) + (hWght*hR + hR*hL)*T_b(i,j+1) ) * iDenom - Stl = ( (hWght*hR)*S_t(i,j+1) + (hWght*hL + hR*hL)*S_t(i,j) ) * iDenom - Str = ( (hWght*hL)*S_t(i,j) + (hWght*hR + hR*hL)*S_t(i,j+1) ) * iDenom - Sbl = ( (hWght*hR)*S_b(i,j+1) + (hWght*hL + hR*hL)*S_b(i,j) ) * iDenom - Sbr = ( (hWght*hL)*S_b(i,j) + (hWght*hR + hR*hL)*S_b(i,j+1) ) * iDenom - else - Ttl = T_t(i,j); Tbl = T_b(i,j); Ttr = T_t(i,j+1); Tbr = T_b(i,j+1) - Stl = S_t(i,j); Sbl = S_b(i,j); Str = S_t(i,j+1); Sbr = S_b(i,j+1) - endif - - do m=2,4 - w_left = 0.25*real(5-m) ; w_right = 1.0-w_left - dz_y(m,i) = w_left*(z_t(i,j) - z_b(i,j)) + w_right*(z_t(i,j+1) - z_b(i,j+1)) - - ! Salinity and temperature points are linearly interpolated in - ! the horizontal. The subscript (1) refers to the top value in - ! the vertical profile while subscript (5) refers to the bottom - ! value in the vertical profile. - pos = i*15+(m-2)*5 - T15(pos+1) = w_left*Ttl + w_right*Ttr - T15(pos+5) = w_left*Tbl + w_right*Tbr - - S15(pos+1) = w_left*Stl + w_right*Str - S15(pos+5) = w_left*Sbl + w_right*Sbr - - p15(pos+1) = -GxRho*(w_left*z_t(i,j) + w_right*z_t(i,j+1)) - - ! Pressure - do n=2,5 ; p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_y(m,i) ; enddo - - ! Salinity and temperature (linear interpolation in the vertical) - do n=2,4 - weight_t = 0.25 * real(5-n) - weight_b = 1.0 - weight_t - S15(pos+n) = weight_t * S15(pos+1) + weight_b * S15(pos+5) - T15(pos+n) = weight_t * T15(pos+1) + weight_b * T15(pos+5) - enddo - enddo - enddo - - if (rho_scale /= 1.0) then - call calculate_density_array(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & - r15(15*HI%isc+1:), 1, 15*(HI%iec-HI%isc+1), EOS, & - rho_ref=rho_ref_mks, scale=rho_scale) - else - call calculate_density_array(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & - r15(15*HI%isc+1:), 1, 15*(HI%iec-HI%isc+1), EOS, rho_ref=rho_ref_mks) - endif - do i=HI%isc,HI%iec - intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) - - ! Use Bode's rule to estimate the pressure anomaly change. - do m = 2,4 - pos = i*15+(m-2)*5 - intz(m) = G_e*dz_y(m,i)*( C1_90*(7.0*(r15(pos+1)+r15(pos+5)) + & - 32.0*(r15(pos+2)+r15(pos+4)) + & - 12.0*r15(pos+3))) - enddo - ! Use Bode's rule to integrate the values. - inty_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & - 12.0*intz(3)) - enddo - enddo ; endif - -end subroutine int_density_dz_generic_plm -! ========================================================================== -! Above is the routine where only the S and T profiles are modified -! The real topography is still used -! ========================================================================== - !> 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, z_tol) @@ -2130,274 +1602,6 @@ real function frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, pos, EO frac_dp_at_pos = G_e * dz * rho_ave end function frac_dp_at_pos - -! ========================================================================== -!> 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, HI, & - EOS, dpa, intz_dpa, intx_dpa, inty_dpa) - - type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structures for the arrays - 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) :: T_t !< Potential temperatue at the cell top [degC] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: T_b !< Potential temperatue at the cell bottom [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) :: S_t !< Salinity at the cell top [ppt] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: S_b !< Salinity at the cell bottom [ppt] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: z_t !< Height at the top of the layer [Z ~> m] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: z_b !< Height at the bottom of the layer [Z ~> m] - real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that is - !! subtracted out to reduce the magnitude of each of the integrals. - real, intent(in) :: rho_0 !< A density [R ~> kg m-3] or [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(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(inout) :: dpa !< The change in the pressure anomaly across the layer [R L2 T-2 ~> Pa] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - optional, intent(inout) :: intz_dpa !< The integral through the thickness of the layer of - !! the pressure anomaly relative to the anomaly at the - !! top of the layer [R L2 Z T-2 ~> Pa m] - real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & - optional, intent(inout) :: 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 [R L2 T-2 ~> Pa] - real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & - optional, intent(inout) :: 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 [R L2 T-2 ~> 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 -! potentially dodgy assumtion here is that rho_0 is used both in the denominator -! of the accelerations, and in the pressure used to calculated density (the -! latter being -z*rho_0*G_e). These two uses could be separated if need be. -! -! 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. - -!### Please note that this subroutine has not been verified to work properly! - - ! Local variables - real :: T5(5), S5(5) - real :: p5(5) ! Pressures at five quadrature points, never rescaled from Pa [Pa] - real :: r5(5) ! Density anomalies from rho_ref at quadrature points [R ~> kg m-3] or [kg m-3] - real :: rho_anom ! The integrated density anomaly [R ~> kg m-3] or [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 [R L2 T-2 ~> Pa] or [Pa] - real, parameter :: C1_90 = 1.0/90.0 ! Rational constants. - real :: GxRho ! The gravitational acceleration times density and unit conversion factors [Pa Z-1 ~> kg m-2 s-2] - real :: I_Rho ! The inverse of the Boussinesq density [R-1 ~> m3 kg-1] or [m3 kg-1] - real :: rho_scale ! A scaling factor for densities from kg m-3 to R [R m3 kg-1 ~> 1] - real :: rho_ref_mks ! The reference density in MKS units, never rescaled from kg m-3 [kg m-3] - real :: dz - real :: weight_t, weight_b - 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 - integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, m, n - real, dimension(4) :: x, y - real, dimension(9) :: S_node, T_node, p_node, r_node - - - call MOM_error(FATAL, & - "int_density_dz_generic_ppm: the implementation is not done yet, contact developer") - - ! These array bounds work for the indexing convention of the input arrays, but - ! on the computational domain defined for the output arrays. - Isq = HI%IscB ; Ieq = HI%IecB - Jsq = HI%JscB ; Jeq = HI%JecB - is = HI%isc ; ie = HI%iec - js = HI%jsc ; je = HI%jec - - rho_scale = EOS%kg_m3_to_R - GxRho = EOS%RL2_T2_to_Pa * G_e * rho_0 - rho_ref_mks = rho_ref * EOS%R_to_kg_m3 - I_Rho = 1.0 / rho_0 - - ! ============================= - ! 1. Compute vertical integrals - ! ============================= - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - dz = z_t(i,j) - z_b(i,j) - - ! Coefficients of the parabola for S - s0 = S_t(i,j) - s1 = 6.0 * S(i,j) - 4.0 * S_t(i,j) - 2.0 * S_b(i,j) - s2 = 3.0 * ( S_t(i,j) + S_b(i,j) - 2.0*S(i,j) ) - - ! Coefficients of the parabola for T - t0 = T_t(i,j) - t1 = 6.0 * T(i,j) - 4.0 * T_t(i,j) - 2.0 * T_b(i,j) - t2 = 3.0 * ( T_t(i,j) + T_b(i,j) - 2.0*T(i,j) ) - - do n=1,5 - p5(n) = -GxRho*(z_t(i,j) - 0.25*real(n-1)*dz) - - ! Parabolic reconstruction for T and S - xi = 0.25 * ( n - 1 ) - S5(n) = s0 + s1 * xi + s2 * xi**2 - T5(n) = t0 + t1 * xi + t2 * xi**2 - enddo - - if (rho_scale /= 1.0) then - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) - else - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks) - endif - - ! Use Bode's rule to estimate the pressure anomaly change. - rho_anom = C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) - - dpa(i,j) = G_e*dz*rho_anom - - ! Use a Bode's-rule-like fifth-order accurate estimate of - ! the double integral of the pressure anomaly. - if (present(intz_dpa)) intz_dpa(i,j) = 0.5*G_e*dz**2 * & - (rho_anom - C1_90*(16.0*(r5(4)-r5(2)) + 7.0*(r5(5)-r5(1))) ) - - enddo ; enddo ! end loops on j and i - - ! ================================================== - ! 2. Compute horizontal integrals in the x direction - ! ================================================== - if (present(intx_dpa)) then ; do j=js,je ; do I=Isq,Ieq - intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) - do m=2,4 - w_left = 0.25*real(5-m) ; w_right = 1.0-w_left - dz = w_left*(z_t(i,j) - z_b(i,j)) + w_right*(z_t(i+1,j) - z_b(i+1,j)) - - ! Salinity and temperature points are linearly interpolated in - ! the horizontal. The subscript (1) refers to the top value in - ! the vertical profile while subscript (5) refers to the bottom - ! value in the vertical profile. - T_top = w_left*T_t(i,j) + w_right*T_t(i+1,j) - T_mid = w_left*T(i,j) + w_right*T(i+1,j) - T_bot = w_left*T_b(i,j) + w_right*T_b(i+1,j) - - S_top = w_left*S_t(i,j) + w_right*S_t(i+1,j) - S_mid = w_left*S(i,j) + w_right*S(i+1,j) - S_bot = w_left*S_b(i,j) + w_right*S_b(i+1,j) - - p5(1) = -GxRho*(w_left*z_t(i,j) + w_right*z_t(i+1,j)) - - ! Pressure - do n=2,5 - p5(n) = p5(n-1) + GxRho*0.25*dz - enddo - - ! Coefficients of the parabola for S - s0 = S_top - s1 = 6.0 * S_mid - 4.0 * S_top - 2.0 * S_bot - s2 = 3.0 * ( S_top + S_bot - 2.0*S_mid ) - - ! Coefficients of the parabola for T - t0 = T_top - t1 = 6.0 * T_mid - 4.0 * T_top - 2.0 * T_bot - t2 = 3.0 * ( T_top + T_bot - 2.0*T_mid ) - - do n=1,5 - ! Parabolic reconstruction for T and S - xi = 0.25 * ( n - 1 ) - S5(n) = s0 + s1 * xi + s2 * xi**2 - T5(n) = t0 + t1 * xi + t2 * xi**2 - enddo - -stop - if (rho_scale /= 1.0) then - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) - else - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks) - endif - - ! Use Bode's rule to estimate the pressure anomaly change. - intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + & - 12.0*r5(3)) ) - enddo - intx_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & - 12.0*intz(3)) - - ! Use Gauss quadrature rule to compute integral - - ! The following coordinates define the quadrilateral on which the integral - ! is computed - x(1) = 1.0 - x(2) = 0.0 - x(3) = 0.0 - x(4) = 1.0 - y(1) = z_t(i+1,j) - y(2) = z_t(i,j) - y(3) = z_b(i,j) - y(4) = z_b(i+1,j) - - T_node = 0.0 - p_node = 0.0 - - ! Nodal values for S - - ! Parabolic reconstruction on the left - s0 = S_t(i,j) - s1 = 6.0 * S(i,j) - 4.0 * S_t(i,j) - 2.0 * S_b(i,j) - s2 = 3.0 * ( S_t(i,j) + S_b(i,j) - 2.0 * S(i,j) ) - S_node(2) = s0 - S_node(6) = s0 + 0.5 * s1 + 0.25 * s2 - S_node(3) = s0 + s1 + s2 - - ! Parabolic reconstruction on the left - s0 = S_t(i+1,j) - s1 = 6.0 * S(i+1,j) - 4.0 * S_t(i+1,j) - 2.0 * S_b(i+1,j) - s2 = 3.0 * ( S_t(i+1,j) + S_b(i+1,j) - 2.0 * S(i+1,j) ) - S_node(1) = s0 - S_node(8) = s0 + 0.5 * s1 + 0.25 * s2 - S_node(4) = s0 + s1 + s2 - - S_node(5) = 0.5 * ( S_node(2) + S_node(1) ) - S_node(9) = 0.5 * ( S_node(6) + S_node(8) ) - S_node(7) = 0.5 * ( S_node(3) + S_node(4) ) - - if (rho_scale /= 1.0) then - call calculate_density( T_node, S_node, p_node, r_node, 1, 9, EOS, rho_ref=rho_ref_mks, scale=rho_scale ) - else - call calculate_density( T_node, S_node, p_node, r_node, 1, 9, EOS, rho_ref=rho_ref_mks) - endif - r_node = r_node - rho_ref - - call compute_integral_quadratic( x, y, r_node, intx_dpa(i,j) ) - - intx_dpa(i,j) = intx_dpa(i,j) * G_e - - enddo ; enddo ; endif - - ! ================================================== - ! 3. Compute horizontal integrals in the y direction - ! ================================================== - if (present(inty_dpa)) then - call MOM_error(WARNING, "int_density_dz_generic_ppm still needs to be written for inty_dpa!") - do J=Jsq,Jeq ; do i=is,ie - - inty_dpa(i,j) = 0.0 - - enddo ; enddo - endif - -end subroutine int_density_dz_generic_ppm - - - ! ============================================================================= !> Compute the integral of the quadratic function subroutine compute_integral_quadratic( x, y, f, integral ) @@ -2584,475 +1788,6 @@ subroutine evaluate_shape_quadratic ( xi, eta, phi, dphidxi, dphideta ) end subroutine evaluate_shape_quadratic ! ============================================================================== -!> This subroutine calculates integrals of specific volume anomalies in -!! pressure across layers, 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 quadrature to do the integrals. -subroutine int_spec_vol_dp_generic(T, S, p_t, p_b, alpha_ref, HI, EOS, dza, & - intp_dza, intx_dza, inty_dza, halo_size, & - 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 [degC] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - 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 [R L2 T-2 ~> Pa] or [Pa] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_b !< Pressure below the layer [R L2 T-2 ~> Pa] or [Pa] - real, intent(in) :: alpha_ref !< A mean specific volume that is subtracted out - !! to reduce the magnitude of each of the integrals [R-1 ~> 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(inout) :: dza !< The change in the geopotential anomaly - !! across the layer [L2 T-2 ~> m2 s-2] or [m2 s-2] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of - !! the geopotential anomaly relative to the anomaly at the bottom of the - !! layer [R L4 T-4 ~> Pa m2 s-2] or [Pa m2 s-2] - real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & - optional, intent(inout) :: 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 [L2 T-2 ~> m2 s-2] or [m2 s-2] - real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & - optional, intent(inout) :: 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 [L2 T-2 ~> m2 s-2] or [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 [R L2 T-2 ~> Pa] or [Pa] - real, optional, intent(in) :: dP_neglect !< A miniscule pressure change with - !! the same units as p_t [R L2 T-2 ~> Pa] or [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 :: T5(5) ! Temperatures at five quadrature points [degC] - real :: S5(5) ! Salinities at five quadrature points [ppt] - real :: p5(5) ! Pressures at five quadrature points, scaled back to Pa if necessary [Pa] - real :: a5(5) ! Specific volumes at five quadrature points [R-1 ~> m3 kg-1] or [m3 kg-1] - real :: alpha_anom ! The depth averaged specific density anomaly [R-1 ~> m3 kg-1] - real :: dp ! The pressure change through a layer [R L2 T-2 ~> Pa] - real :: hWght ! A pressure-thickness below topography [R L2 T-2 ~> Pa] - real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [R L2 T-2 ~> Pa] - real :: alpha_ref_mks ! The reference specific volume in MKS units, never rescaled from m3 kg-1 [m3 kg-1] - real :: iDenom ! The inverse of the denominator in the weights [T4 R-2 L-4 ~> 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 [L2 T-2 ~> m2 s-2] - real :: RL2_T2_to_Pa ! A unit conversion factor from the rescaled units of pressure to Pa [Pa T2 R-1 L-2 ~> 1] - real :: SV_scale ! A multiplicative factor by which to scale specific - ! volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] - 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 - - Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB - halo = 0 ; if (present(halo_size)) halo = MAX(halo_size,0) - ish = HI%isc-halo ; ieh = HI%iec+halo ; jsh = HI%jsc-halo ; jeh = HI%jec+halo - if (present(intx_dza)) then ; ish = MIN(Isq,ish) ; ieh = MAX(Ieq+1,ieh); endif - if (present(inty_dza)) then ; jsh = MIN(Jsq,jsh) ; jeh = MAX(Jeq+1,jeh); endif - - SV_scale = EOS%R_to_kg_m3 - RL2_T2_to_Pa = EOS%RL2_T2_to_Pa - alpha_ref_mks = alpha_ref * EOS%kg_m3_to_R - - do_massWeight = .false. - if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then - do_massWeight = .true. - if (.not.present(bathyP)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& - "bathyP must be present if useMassWghtInterp is present and true.") - if (.not.present(dP_neglect)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& - "dP_neglect must be present if useMassWghtInterp is present and true.") - endif ; endif - - do j=jsh,jeh ; do i=ish,ieh - dp = p_b(i,j) - p_t(i,j) - do n=1,5 - T5(n) = T(i,j) ; S5(n) = S(i,j) - p5(n) = RL2_T2_to_Pa * (p_b(i,j) - 0.25*real(n-1)*dp) - enddo - - if (SV_scale /= 1.0) then - call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks, scale=SV_scale) - else - call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks) - endif - - ! Use Bode's rule to estimate the interface height anomaly change. - alpha_anom = C1_90*(7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4)) + 12.0*a5(3)) - dza(i,j) = dp*alpha_anom - ! Use a Bode's-rule-like fifth-order accurate estimate of the double integral of - ! the interface height anomaly. - if (present(intp_dza)) intp_dza(i,j) = 0.5*dp**2 * & - (alpha_anom - C1_90*(16.0*(a5(4)-a5(2)) + 7.0*(a5(5)-a5(1))) ) - enddo ; enddo - - if (present(intx_dza)) then ; do j=HI%jsc,HI%jec ; do I=Isq,Ieq - ! hWght is the distance measure by which the cell is violation of - ! hydrostatic consistency. For large hWght we bias the interpolation of - ! T & S along the top and bottom integrals, akin to thickness weighting. - hWght = 0.0 - if (do_massWeight) & - hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) - if (hWght > 0.) then - hL = (p_b(i,j) - p_t(i,j)) + dP_neglect - hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect - hWght = hWght * ( (hL-hR)/(hL+hR) )**2 - iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) - hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom - hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom - else - hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 - endif - - intp(1) = dza(i,j) ; intp(5) = dza(i+1,j) - do m=2,4 - wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L - wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR - - ! T, S, and p are interpolated in the horizontal. The p interpolation - ! is linear, but for T and S it may be thickness wekghted. - p5(1) = RL2_T2_to_Pa * (wt_L*p_b(i,j) + wt_R*p_b(i+1,j)) - dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i+1,j) - p_t(i+1,j)) - T5(1) = wtT_L*T(i,j) + wtT_R*T(i+1,j) - S5(1) = wtT_L*S(i,j) + wtT_R*S(i+1,j) - - do n=2,5 - T5(n) = T5(1) ; S5(n) = S5(1) ; p5(n) = p5(n-1) - RL2_T2_to_Pa * 0.25*dp - enddo - if (SV_scale /= 1.0) then - call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks, scale=SV_scale) - else - call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks) - endif - - ! Use Bode's rule to estimate the interface height anomaly change. - intp(m) = dp*( C1_90*(7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4)) + & - 12.0*a5(3))) - enddo - ! Use Bode's rule to integrate the interface height anomaly values in x. - intx_dza(i,j) = C1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + & - 12.0*intp(3)) - enddo ; enddo ; endif - - if (present(inty_dza)) then ; do J=Jsq,Jeq ; do i=HI%isc,HI%iec - ! hWght is the distance measure by which the cell is violation of - ! hydrostatic consistency. For large hWght we bias the interpolation of - ! T & S along the top and bottom integrals, akin to thickness weighting. - hWght = 0.0 - if (do_massWeight) & - hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) - if (hWght > 0.) then - hL = (p_b(i,j) - p_t(i,j)) + dP_neglect - hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect - hWght = hWght * ( (hL-hR)/(hL+hR) )**2 - iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) - hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom - hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom - else - hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 - endif - - intp(1) = dza(i,j) ; intp(5) = dza(i,j+1) - do m=2,4 - wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L - wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR - - ! T, S, and p are interpolated in the horizontal. The p interpolation - ! is linear, but for T and S it may be thickness wekghted. - p5(1) = RL2_T2_to_Pa * (wt_L*p_b(i,j) + wt_R*p_b(i,j+1)) - dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i,j+1) - p_t(i,j+1)) - T5(1) = wtT_L*T(i,j) + wtT_R*T(i,j+1) - S5(1) = wtT_L*S(i,j) + wtT_R*S(i,j+1) - do n=2,5 - T5(n) = T5(1) ; S5(n) = S5(1) ; p5(n) = RL2_T2_to_Pa * (p5(n-1) - 0.25*dp) - enddo - if (SV_scale /= 1.0) then - call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks, scale=SV_scale) - else - call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks) - endif - - ! Use Bode's rule to estimate the interface height anomaly change. - intp(m) = dp*( C1_90*(7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4)) + & - 12.0*a5(3))) - enddo - ! Use Bode's rule to integrate the interface height anomaly values in y. - inty_dza(i,j) = C1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + & - 12.0*intp(3)) - enddo ; enddo ; endif - -end subroutine int_spec_vol_dp_generic - -!> This subroutine calculates integrals of specific volume anomalies in -!! pressure across layers, 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 quadrature to do the integrals. -subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, & - dP_neglect, bathyP, HI, EOS, dza, & - 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 [degC] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - 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 [ppt] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - 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 [R L2 T-2 ~> Pa] or [Pa] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_b !< Pressure below the layer [R L2 T-2 ~> Pa] or [Pa] - real, intent(in) :: alpha_ref !< A mean specific volume that is subtracted out - !! to reduce the magnitude of each of the integrals [R-1 ~> 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 ! Pa] or [Pa] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] or [Pa] - type(EOS_type), pointer :: EOS !< Equation of state structure - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(inout) :: dza !< The change in the geopotential anomaly - !! across the layer [L2 T-2 ~> m2 s-2] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of - !! the geopotential anomaly relative to the anomaly at the bottom of the - !! layer [R L4 T-4 ~> Pa m2 s-2] or [Pa m2 s-2] - real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & - optional, intent(inout) :: 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 [L2 T-2 ~> m2 s-2] or [m2 s-2] - real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & - optional, intent(inout) :: 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 [L2 T-2 ~> m2 s-2] or [m2 s-2] - 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. - - real :: T5(5) ! Temperatures at five quadrature points [degC] - real :: S5(5) ! Salinities at five quadrature points [ppt] - real :: p5(5) ! Pressures at five quadrature points, scaled back to Pa as necessary [Pa] - real :: a5(5) ! Specific volumes at five quadrature points [R-1 ~> m3 kg-1] or [m3 kg-1] - real :: T15(15) ! Temperatures at fifteen interior quadrature points [degC] - real :: S15(15) ! Salinities at fifteen interior quadrature points [ppt] - real :: p15(15) ! Pressures at fifteen quadrature points, scaled back to Pa as necessary [Pa] - real :: a15(15) ! Specific volumes at fifteen quadrature points [R-1 ~> m3 kg-1] or [m3 kg-1] - real :: wt_t(5), wt_b(5) ! Weights of top and bottom values at quadrature points [nondim] - real :: T_top, T_bot, S_top, S_bot, P_top, P_bot - - real :: alpha_anom ! The depth averaged specific density anomaly [m3 kg-1] - real :: dp ! The pressure change through a layer [R L2 T-2 ~> Pa] - real :: dp_90(2:4) ! The pressure change through a layer divided by 90 [R L2 T-2 ~> Pa] - real :: hWght ! A pressure-thickness below topography [R L2 T-2 ~> Pa] - real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [R L2 T-2 ~> Pa] - real :: alpha_ref_mks ! The reference specific volume in MKS units, never rescaled from m3 kg-1 [m3 kg-1] - real :: iDenom ! The inverse of the denominator in the weights [T4 R-2 L-4 ~> 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 [L2 T-2 ~> m2 s-2] - real :: RL2_T2_to_Pa ! A unit conversion factor from the rescaled units of pressure to Pa [Pa T2 R-1 L-2 ~> 1] - real :: SV_scale ! A multiplicative factor by which to scale specific - ! volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] - 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 - - Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB - - do_massWeight = .false. - if (present(useMassWghtInterp)) do_massWeight = useMassWghtInterp - - SV_scale = EOS%R_to_kg_m3 - RL2_T2_to_Pa = EOS%RL2_T2_to_Pa - alpha_ref_mks = alpha_ref * EOS%kg_m3_to_R - - do n = 1, 5 ! Note that these are reversed from int_density_dz. - wt_t(n) = 0.25 * real(n-1) - wt_b(n) = 1.0 - wt_t(n) - enddo - - ! ============================= - ! 1. Compute vertical integrals - ! ============================= - do j=Jsq,Jeq+1; do i=Isq,Ieq+1 - dp = p_b(i,j) - p_t(i,j) - do n=1,5 ! T, S and p are linearly interpolated in the vertical. - p5(n) = RL2_T2_to_Pa * (wt_t(n) * p_t(i,j) + wt_b(n) * p_b(i,j)) - S5(n) = wt_t(n) * S_t(i,j) + wt_b(n) * S_b(i,j) - T5(n) = wt_t(n) * T_t(i,j) + wt_b(n) * T_b(i,j) - enddo - if (SV_scale /= 1.0) then - call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks, scale=SV_scale) - else - call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks) - endif - - ! Use Bode's rule to estimate the interface height anomaly change. - alpha_anom = C1_90*((7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4))) + 12.0*a5(3)) - dza(i,j) = dp*alpha_anom - ! Use a Bode's-rule-like fifth-order accurate estimate of the double integral of - ! the interface height anomaly. - if (present(intp_dza)) intp_dza(i,j) = 0.5*dp**2 * & - (alpha_anom - C1_90*(16.0*(a5(4)-a5(2)) + 7.0*(a5(5)-a5(1))) ) - enddo ; enddo - - ! ================================================== - ! 2. Compute horizontal integrals in the x direction - ! ================================================== - if (present(intx_dza)) then ; do j=HI%jsc,HI%jec ; do I=Isq,Ieq - ! hWght is the distance measure by which the cell is violation of - ! hydrostatic consistency. For large hWght we bias the interpolation - ! of T,S along the top and bottom integrals, almost like thickness - ! weighting. Note: To work in terrain following coordinates we could - ! offset this distance by the layer thickness to replicate other models. - hWght = 0.0 - if (do_massWeight) & - hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) - if (hWght > 0.) then - hL = (p_b(i,j) - p_t(i,j)) + dP_neglect - hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect - hWght = hWght * ( (hL-hR)/(hL+hR) )**2 - iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) - hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom - hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom - else - hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 - endif - - do m=2,4 - wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L - wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR - - ! T, S, and p are interpolated in the horizontal. The p interpolation - ! is linear, but for T and S it may be thickness wekghted. - P_top = wt_L*p_t(i,j) + wt_R*p_t(i+1,j) - P_bot = wt_L*p_b(i,j) + wt_R*p_b(i+1,j) - T_top = wtT_L*T_t(i,j) + wtT_R*T_t(i+1,j) - T_bot = wtT_L*T_b(i,j) + wtT_R*T_b(i+1,j) - S_top = wtT_L*S_t(i,j) + wtT_R*S_t(i+1,j) - S_bot = wtT_L*S_b(i,j) + wtT_R*S_b(i+1,j) - dp_90(m) = C1_90*(P_bot - P_top) - - ! Salinity, temperature and pressure with linear interpolation in the vertical. - pos = (m-2)*5 - do n=1,5 - p15(pos+n) = RL2_T2_to_Pa * (wt_t(n) * P_top + wt_b(n) * P_bot) - S15(pos+n) = wt_t(n) * S_top + wt_b(n) * S_bot - T15(pos+n) = wt_t(n) * T_top + wt_b(n) * T_bot - enddo - enddo - - if (SV_scale /= 1.0) then - call calculate_spec_vol(T15, S15, p15, a15, 1, 15, EOS, alpha_ref_mks, scale=SV_scale) - else - call calculate_spec_vol(T15, S15, p15, a15, 1, 15, EOS, alpha_ref_mks) - endif - - intp(1) = dza(i,j) ; intp(5) = dza(i+1,j) - do m=2,4 - ! Use Bode's rule to estimate the interface height anomaly change. - ! The integrals at the ends of the segment are already known. - pos = (m-2)*5 - intp(m) = dp_90(m)*((7.0*(a15(pos+1)+a15(pos+5)) + & - 32.0*(a15(pos+2)+a15(pos+4))) + 12.0*a15(pos+3)) - enddo - ! Use Bode's rule to integrate the interface height anomaly values in x. - intx_dza(I,j) = C1_90*((7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4))) + & - 12.0*intp(3)) - enddo ; enddo ; endif - - ! ================================================== - ! 3. Compute horizontal integrals in the y direction - ! ================================================== - if (present(inty_dza)) then ; do J=Jsq,Jeq ; do i=HI%isc,HI%iec - ! hWght is the distance measure by which the cell is violation of - ! hydrostatic consistency. For large hWght we bias the interpolation - ! of T,S along the top and bottom integrals, like thickness weighting. - hWght = 0.0 - if (do_massWeight) & - hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) - if (hWght > 0.) then - hL = (p_b(i,j) - p_t(i,j)) + dP_neglect - hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect - hWght = hWght * ( (hL-hR)/(hL+hR) )**2 - iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) - hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom - hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom - else - hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 - endif - - do m=2,4 - wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L - wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR - - ! T, S, and p are interpolated in the horizontal. The p interpolation - ! is linear, but for T and S it may be thickness wekghted. - P_top = wt_L*p_t(i,j) + wt_R*p_t(i,j+1) - P_bot = wt_L*p_b(i,j) + wt_R*p_b(i,j+1) - T_top = wtT_L*T_t(i,j) + wtT_R*T_t(i,j+1) - T_bot = wtT_L*T_b(i,j) + wtT_R*T_b(i,j+1) - S_top = wtT_L*S_t(i,j) + wtT_R*S_t(i,j+1) - S_bot = wtT_L*S_b(i,j) + wtT_R*S_b(i,j+1) - dp_90(m) = C1_90*(P_bot - P_top) - - ! Salinity, temperature and pressure with linear interpolation in the vertical. - pos = (m-2)*5 - do n=1,5 - p15(pos+n) = RL2_T2_to_Pa * (wt_t(n) * P_top + wt_b(n) * P_bot) - S15(pos+n) = wt_t(n) * S_top + wt_b(n) * S_bot - T15(pos+n) = wt_t(n) * T_top + wt_b(n) * T_bot - enddo - enddo - - if (SV_scale /= 1.0) then - call calculate_spec_vol(T15, S15, p15, a15, 1, 15, EOS, alpha_ref_mks, scale=SV_scale) - else - call calculate_spec_vol(T15, S15, p15, a15, 1, 15, EOS, alpha_ref_mks) - endif - - intp(1) = dza(i,j) ; intp(5) = dza(i,j+1) - do m=2,4 - ! Use Bode's rule to estimate the interface height anomaly change. - ! The integrals at the ends of the segment are already known. - pos = (m-2)*5 - intp(m) = dp_90(m) * ((7.0*(a15(pos+1)+a15(pos+5)) + & - 32.0*(a15(pos+2)+a15(pos+4))) + 12.0*a15(pos+3)) - enddo - ! Use Bode's rule to integrate the interface height anomaly values in x. - inty_dza(i,J) = C1_90*((7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4))) + & - 12.0*intp(3)) - enddo ; enddo ; endif - -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, HI, kd, mask_z, EOS) integer, intent(in) :: kd !< The number of layers to work on @@ -3086,6 +1821,14 @@ subroutine convert_temp_salt_for_TEOS10(T, S, HI, kd, mask_z, EOS) enddo ; enddo ; enddo end subroutine convert_temp_salt_for_TEOS10 +!> Return value of EOS_quadrature +logical function EOS_quadrature(EOS) + type(EOS_type), pointer :: EOS !< Equation of state structure + + EOS_quadrature = EOS%EOS_quadrature + +end function EOS_quadrature + !> 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) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 6ca98da171..bd2b144e96 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -4,6 +4,7 @@ module MOM_state_initialization ! This file is part of MOM6. See LICENSE.md for the license. use MOM_debugging, only : hchksum, qchksum, uvchksum +use MOM_density_integrals, only : int_specific_vol_dp use MOM_coms, only : max_across_PEs, min_across_PEs, reproducing_sum use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_ROUTINE, CLOCK_LOOP @@ -41,7 +42,7 @@ module MOM_state_initialization use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : setVerticalGridAxes, verticalGrid_type use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_type, EOS_domain -use MOM_EOS, only : int_specific_vol_dp, convert_temp_salt_for_TEOS10 +use MOM_EOS, only : convert_temp_salt_for_TEOS10 use user_initialization, only : user_initialize_thickness, user_initialize_velocity use user_initialization, only : user_init_temperature_salinity use user_initialization, only : user_set_OBC_data @@ -970,7 +971,7 @@ subroutine convert_thickness(h, G, GV, US, tv) do itt=1,max_itt call int_specific_vol_dp(tv%T(:,:,k), tv%S(:,:,k), p_top, p_bot, 0.0, G%HI, & - tv%eqn_of_state, dz_geo) + tv%eqn_of_state, US, dz_geo) if (itt < max_itt) then ; do j=js,je call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_bot(:,j), rho, & tv%eqn_of_state, EOSdom) diff --git a/src/initialization/MOM_tracer_initialization_from_Z.F90 b/src/initialization/MOM_tracer_initialization_from_Z.F90 index 6011ebb9f8..1a4c5bd011 100644 --- a/src/initialization/MOM_tracer_initialization_from_Z.F90 +++ b/src/initialization/MOM_tracer_initialization_from_Z.F90 @@ -7,6 +7,7 @@ module MOM_tracer_initialization_from_Z use MOM_coms, only : max_across_PEs, min_across_PEs use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_ROUTINE, CLOCK_LOOP +use MOM_density_integrals, only : int_specific_vol_dp use MOM_domains, only : pass_var, pass_vector, sum_across_PEs, broadcast use MOM_domains, only : root_PE, To_All, SCALAR_PAIR, CGRID_NE, AGRID use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe @@ -24,7 +25,6 @@ module MOM_tracer_initialization_from_Z use MOM_variables, only : thermo_var_ptrs 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 implicit none ; private From 2e1d82369c8ae015e26954ffe3decc171ffe22fe Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 6 May 2020 17:36:30 +0000 Subject: [PATCH 30/91] Renamed ppoly_E to edge_values for a bit of clarity - ppoly_E meant something to someone a while ago but we felt it would be better to clean up the ALE APIs. This is a pre-cursor to switching to a more precise description of reconstructions. --- src/ALE/MOM_remapping.F90 | 12 +++--- src/ALE/P1M_functions.F90 | 40 +++++++++--------- src/ALE/P3M_functions.F90 | 54 ++++++++++++------------ src/ALE/PCM_functions.F90 | 6 +-- src/ALE/PLM_functions.F90 | 56 ++++++++++++------------- src/ALE/PPM_functions.F90 | 48 ++++++++++----------- src/ALE/PQM_functions.F90 | 88 +++++++++++++++++++-------------------- src/ALE/regrid_interp.F90 | 14 +++---- 8 files changed, 159 insertions(+), 159 deletions(-) diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index 65cf5b9d55..71ba83f3ba 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -1027,11 +1027,11 @@ real function average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefs, method, i0, x end function average_value_ppoly !> Measure totals and bounds on source grid -subroutine measure_input_bounds( n0, h0, u0, ppoly_E, h0tot, h0err, u0tot, u0err, u0min, u0max ) +subroutine measure_input_bounds( n0, h0, u0, edge_values, h0tot, h0err, u0tot, u0err, u0min, u0max ) 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,2), intent(in) :: ppoly_E !< Cell edge values on source grid + real, dimension(n0,2), intent(in) :: edge_values !< Cell edge values on source grid real, intent(out) :: h0tot !< Sum of cell widths real, intent(out) :: h0err !< Magnitude of round-off error in h0tot real, intent(out) :: u0tot !< Sum of cell widths times values @@ -1047,15 +1047,15 @@ subroutine measure_input_bounds( n0, h0, u0, ppoly_E, h0tot, h0err, u0tot, u0err h0err = 0. u0tot = h0(1) * u0(1) u0err = 0. - u0min = min( ppoly_E(1,1), ppoly_E(1,2) ) - u0max = max( ppoly_E(1,1), ppoly_E(1,2) ) + u0min = min( edge_values(1,1), edge_values(1,2) ) + u0max = max( edge_values(1,1), edge_values(1,2) ) do k = 2, n0 h0tot = h0tot + h0(k) h0err = h0err + eps * max(h0tot, h0(k)) u0tot = u0tot + h0(k) * u0(k) u0err = u0err + eps * max(abs(u0tot), abs(h0(k) * u0(k))) - u0min = min( u0min, ppoly_E(k,1), ppoly_E(k,2) ) - u0max = max( u0max, ppoly_E(k,1), ppoly_E(k,2) ) + u0min = min( u0min, edge_values(k,1), edge_values(k,2) ) + u0max = max( u0max, edge_values(k,1), edge_values(k,2) ) enddo end subroutine measure_input_bounds diff --git a/src/ALE/P1M_functions.F90 b/src/ALE/P1M_functions.F90 index f2c85d9872..d99c611229 100644 --- a/src/ALE/P1M_functions.F90 +++ b/src/ALE/P1M_functions.F90 @@ -24,11 +24,11 @@ module P1M_functions !! !! 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, answers_2018 ) +subroutine P1M_interpolation( N, h, u, edge_values, ppoly_coef, h_neglect, answers_2018 ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) [H] real, dimension(:), intent(in) :: u !< cell average properties (size N) [A] - real, dimension(:,:), intent(inout) :: ppoly_E !< Potentially modified edge values [A] + real, dimension(:,:), intent(inout) :: edge_values !< Potentially modified edge values [A] real, dimension(:,:), intent(inout) :: ppoly_coef !< Potentially modified !! piecewise polynomial coefficients, mainly [A] real, optional, intent(in) :: h_neglect !< A negligibly small width [H] @@ -39,17 +39,17 @@ subroutine P1M_interpolation( N, h, u, ppoly_E, ppoly_coef, h_neglect, answers_2 real :: u0_l, u0_r ! edge values (left and right) ! Bound edge values (routine found in 'edge_values.F90') - call bound_edge_values( N, h, u, ppoly_E, h_neglect, answers_2018 ) + call bound_edge_values( N, h, u, edge_values, h_neglect, answers_2018 ) ! Systematically average discontinuous edge values (routine found in ! 'edge_values.F90') - call average_discontinuous_edge_values( N, ppoly_E ) + call average_discontinuous_edge_values( N, edge_values ) ! Loop on interior cells to build interpolants do k = 1,N - u0_l = ppoly_E(k,1) - u0_r = ppoly_E(k,2) + u0_l = edge_values(k,1) + u0_r = edge_values(k,2) ppoly_coef(k,1) = u0_l ppoly_coef(k,2) = u0_r - u0_l @@ -65,12 +65,12 @@ end subroutine P1M_interpolation !! !! 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 ) +subroutine P1M_boundary_extrapolation( N, h, u, edge_values, ppoly_coef ) ! Arguments integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) [H] real, dimension(:), intent(in) :: u !< cell averages (size N) [A] - real, dimension(:,:), intent(inout) :: ppoly_E !< edge values of piecewise polynomials [A] + real, dimension(:,:), intent(inout) :: edge_values !< edge values of piecewise polynomials [A] real, dimension(:,:), intent(inout) :: ppoly_coef !< coefficients of piecewise polynomials, mainly [A] ! Local variables @@ -99,20 +99,20 @@ subroutine P1M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef ) ! by using the edge value in the neighboring cell. u0_r = u0 + 0.5 * slope - if ( (u1 - u0) * (ppoly_E(2,1) - u0_r) < 0.0 ) then - slope = 2.0 * ( ppoly_E(2,1) - u0 ) + if ( (u1 - u0) * (edge_values(2,1) - u0_r) < 0.0 ) then + slope = 2.0 * ( edge_values(2,1) - u0 ) endif ! Using the limited slope, the left edge value is reevaluated and ! the interpolant coefficients recomputed if ( h0 /= 0.0 ) then - ppoly_E(1,1) = u0 - 0.5 * slope + edge_values(1,1) = u0 - 0.5 * slope else - ppoly_E(1,1) = u0 + edge_values(1,1) = u0 endif - ppoly_coef(1,1) = ppoly_E(1,1) - ppoly_coef(1,2) = ppoly_E(1,2) - ppoly_E(1,1) + ppoly_coef(1,1) = edge_values(1,1) + ppoly_coef(1,2) = edge_values(1,2) - edge_values(1,1) ! ------------------------------------------ ! Right edge value in the left boundary cell @@ -127,18 +127,18 @@ subroutine P1M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef ) u0_l = u1 - 0.5 * slope - if ( (u1 - u0) * (u0_l - ppoly_E(N-1,2)) < 0.0 ) then - slope = 2.0 * ( u1 - ppoly_E(N-1,2) ) + if ( (u1 - u0) * (u0_l - edge_values(N-1,2)) < 0.0 ) then + slope = 2.0 * ( u1 - edge_values(N-1,2) ) endif if ( h1 /= 0.0 ) then - ppoly_E(N,2) = u1 + 0.5 * slope + edge_values(N,2) = u1 + 0.5 * slope else - ppoly_E(N,2) = u1 + edge_values(N,2) = u1 endif - ppoly_coef(N,1) = ppoly_E(N,1) - ppoly_coef(N,2) = ppoly_E(N,2) - ppoly_E(N,1) + ppoly_coef(N,1) = edge_values(N,1) + ppoly_coef(N,2) = edge_values(N,2) - edge_values(N,1) end subroutine P1M_boundary_extrapolation diff --git a/src/ALE/P3M_functions.F90 b/src/ALE/P3M_functions.F90 index 434668894b..e3a9f75a3c 100644 --- a/src/ALE/P3M_functions.F90 +++ b/src/ALE/P3M_functions.F90 @@ -25,11 +25,11 @@ module P3M_functions !! !! 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, answers_2018 ) +subroutine P3M_interpolation( N, h, u, edge_values, ppoly_S, ppoly_coef, h_neglect, answers_2018 ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) [H] real, dimension(:), intent(in) :: u !< cell averages (size N) in arbitrary units [A] - real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial [A] + real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial [A] real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial [A H-1]. real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial [A] real, optional, intent(in) :: h_neglect !< A negligibly small width for the @@ -41,7 +41,7 @@ subroutine P3M_interpolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect, ! 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_coef, h_neglect, answers_2018 ) + call P3M_limiter( N, h, u, edge_values, ppoly_S, ppoly_coef, h_neglect, answers_2018 ) end subroutine P3M_interpolation @@ -58,11 +58,11 @@ end subroutine P3M_interpolation !! 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, answers_2018 ) +subroutine P3M_limiter( N, h, u, edge_values, ppoly_S, ppoly_coef, h_neglect, answers_2018 ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) [H] real, dimension(:), intent(in) :: u !< cell averages (size N) in arbitrary units [A] - real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial [A] + real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial [A] real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial [A H-1] real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial [A] real, optional, intent(in) :: h_neglect !< A negligibly small width for @@ -86,10 +86,10 @@ subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect, answer eps = 1e-10 ! 1. Bound edge values (boundary cells are assumed to be local extrema) - call bound_edge_values( N, h, u, ppoly_E, hNeglect, answers_2018 ) + call bound_edge_values( N, h, u, edge_values, hNeglect, answers_2018 ) ! 2. Systematically average discontinuous edge values - call average_discontinuous_edge_values( N, ppoly_E ) + call average_discontinuous_edge_values( N, edge_values ) ! 3. Loop on cells and do the following @@ -99,8 +99,8 @@ subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect, answer do k = 1,N ! Get edge values, edge slopes and cell width - u0_l = ppoly_E(k,1) - u0_r = ppoly_E(k,2) + u0_l = edge_values(k,1) + u0_r = edge_values(k,2) u1_l = ppoly_S(k,1) u1_r = ppoly_S(k,2) @@ -151,7 +151,7 @@ subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect, answer endif ! Build cubic interpolant (compute the coefficients) - call build_cubic_interpolant( h, k, ppoly_E, ppoly_S, ppoly_coef ) + call build_cubic_interpolant( h, k, edge_values, ppoly_S, ppoly_coef ) ! Check whether cubic is monotonic monotonic = is_cubic_monotonic( ppoly_coef, k ) @@ -168,7 +168,7 @@ subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect, answer ppoly_S(k,2) = u1_r ! Recompute coefficients of cubic - call build_cubic_interpolant( h, k, ppoly_E, ppoly_S, ppoly_coef ) + call build_cubic_interpolant( h, k, edge_values, ppoly_S, ppoly_coef ) enddo ! loop on cells @@ -188,12 +188,12 @@ end subroutine P3M_limiter !! 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, & +subroutine P3M_boundary_extrapolation( N, h, u, edge_values, ppoly_S, ppoly_coef, & h_neglect, h_neglect_edge ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) [H] real, dimension(:), intent(in) :: u !< cell averages (size N) in arbitrary units [A] - real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial [A] + real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial [A] real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial [A H-1] real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial [A] real, optional, intent(in) :: h_neglect !< A negligibly small width for the @@ -235,7 +235,7 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & ! The right edge value in the boundary cell is taken to be the left ! edge value in the neighboring cell - u0_r = ppoly_E(i1,1) + u0_r = edge_values(i1,1) ! Given the right edge value and slope, we determine the left ! edge value and slope by computing the parabola as determined by @@ -253,13 +253,13 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & endif ! Store edge values and slope, build cubic and check monotonicity - ppoly_E(i0,1) = u0_l - ppoly_E(i0,2) = u0_r + edge_values(i0,1) = u0_l + edge_values(i0,2) = u0_r ppoly_S(i0,1) = u1_l 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_coef ) + call build_cubic_interpolant( h, i0, edge_values, ppoly_S, ppoly_coef ) monotonic = is_cubic_monotonic( ppoly_coef, i0 ) if ( .not.monotonic ) then @@ -268,7 +268,7 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & ! 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_coef ) + call build_cubic_interpolant( h, i0, edge_values, ppoly_S, ppoly_coef ) endif @@ -295,7 +295,7 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & ! The left edge value in the boundary cell is taken to be the right ! edge value in the neighboring cell - u0_l = ppoly_E(i0,2) + u0_l = edge_values(i0,2) ! Given the left edge value and slope, we determine the right ! edge value and slope by computing the parabola as determined by @@ -313,12 +313,12 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & endif ! Store edge values and slope, build cubic and check monotonicity - ppoly_E(i1,1) = u0_l - ppoly_E(i1,2) = u0_r + edge_values(i1,1) = u0_l + edge_values(i1,2) = u0_r ppoly_S(i1,1) = u1_l ppoly_S(i1,2) = u1_r - call build_cubic_interpolant( h, i1, ppoly_E, ppoly_S, ppoly_coef ) + call build_cubic_interpolant( h, i1, edge_values, ppoly_S, ppoly_coef ) monotonic = is_cubic_monotonic( ppoly_coef, i1 ) if ( .not.monotonic ) then @@ -327,7 +327,7 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & ! 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_coef ) + call build_cubic_interpolant( h, i1, edge_values, ppoly_S, ppoly_coef ) endif @@ -340,10 +340,10 @@ end subroutine P3M_boundary_extrapolation !! !! 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 ) +subroutine build_cubic_interpolant( h, k, edge_values, ppoly_S, ppoly_coef ) real, dimension(:), intent(in) :: h !< cell widths (size N) [H] integer, intent(in) :: k !< The index of the cell to work on - real, dimension(:,:), intent(in) :: ppoly_E !< Edge value of polynomial in arbitrary units [A] + real, dimension(:,:), intent(in) :: edge_values !< Edge value of polynomial in arbitrary units [A] real, dimension(:,:), intent(in) :: ppoly_S !< Edge slope of polynomial [A H-1] real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial [A] @@ -355,8 +355,8 @@ subroutine build_cubic_interpolant( h, k, ppoly_E, ppoly_S, ppoly_coef ) h_c = h(k) - u0_l = ppoly_E(k,1) - u0_r = ppoly_E(k,2) + u0_l = edge_values(k,1) + u0_r = edge_values(k,2) u1_l = ppoly_S(k,1) * h_c u1_r = ppoly_S(k,2) * h_c diff --git a/src/ALE/PCM_functions.F90 b/src/ALE/PCM_functions.F90 index 135f53a8a1..6608e85eda 100644 --- a/src/ALE/PCM_functions.F90 +++ b/src/ALE/PCM_functions.F90 @@ -15,10 +15,10 @@ module PCM_functions !! !! 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 ) +subroutine PCM_reconstruction( N, u, edge_values, 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, + real, dimension(:,:), intent(inout) :: edge_values !< 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. @@ -32,7 +32,7 @@ subroutine PCM_reconstruction( N, u, ppoly_E, ppoly_coef ) ! The edge values are equal to the cell average do k = 1,N - ppoly_E(k,:) = u(k) + edge_values(k,:) = u(k) enddo end subroutine PCM_reconstruction diff --git a/src/ALE/PLM_functions.F90 b/src/ALE/PLM_functions.F90 index ed82ad1e0b..e6bcbef331 100644 --- a/src/ALE/PLM_functions.F90 +++ b/src/ALE/PLM_functions.F90 @@ -15,11 +15,11 @@ module PLM_functions !! !! 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 ) +subroutine PLM_reconstruction( N, h, u, edge_values, 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, + real, dimension(:,:), intent(inout) :: edge_values !< 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. @@ -106,22 +106,22 @@ subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coef, h_neglect ) ! endif slp(k) = slope - ppoly_E(k,1) = u_c - 0.5 * slope - ppoly_E(k,2) = u_c + 0.5 * slope + edge_values(k,1) = u_c - 0.5 * slope + edge_values(k,2) = u_c + 0.5 * slope enddo ! end loop on interior cells ! Boundary cells use PCM. Extrapolation is handled in a later routine. slp(1) = 0. - ppoly_E(1,2) = u(1) + edge_values(1,2) = u(1) slp(N) = 0. - ppoly_E(N,1) = u(N) + edge_values(N,1) = u(N) ! This loop adjusts the slope so that edge values are monotonic. do K = 2, N-1 u_l = u(k-1) ; u_c = u(k) ; u_r = u(k+1) - e_r = ppoly_E(k-1,2) ! Right edge from cell k-1 - e_l = ppoly_E(k+1,1) ! Left edge from cell k + e_r = edge_values(k-1,2) ! Right edge from cell k-1 + e_l = edge_values(k+1,1) ! Left edge from cell k mslp(k) = abs(slp(k)) u_min = min(e_r, u_c) u_max = max(e_r, u_c) @@ -149,8 +149,8 @@ subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coef, h_neglect ) ! enddo ! end loop on interior cells ! Store and return edge values and polynomial coefficients. - ppoly_E(1,1) = u(1) - ppoly_E(1,2) = u(1) + edge_values(1,1) = u(1) + edge_values(1,2) = u(1) ppoly_coef(1,1) = u(1) ppoly_coef(1,2) = 0. do k = 2, N-1 @@ -172,8 +172,8 @@ subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coef, h_neglect ) stop 'Right edge out of bounds' endif - ppoly_E(k,1) = u_l - ppoly_E(k,2) = u_r + edge_values(k,1) = u_l + edge_values(k,2) = u_r 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 @@ -184,8 +184,8 @@ subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coef, h_neglect ) ppoly_coef(k,2) = ppoly_coef(k,2) * almost_one endif enddo - ppoly_E(N,1) = u(N) - ppoly_E(N,2) = u(N) + edge_values(N,1) = u(N) + edge_values(N,2) = u(N) ppoly_coef(N,1) = u(N) ppoly_coef(N,2) = 0. @@ -202,11 +202,11 @@ end subroutine PLM_reconstruction !! 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 ) +subroutine PLM_boundary_extrapolation( N, h, u, edge_values, 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, + real, dimension(:,:), intent(inout) :: edge_values !< 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. @@ -232,17 +232,17 @@ subroutine PLM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef, h_neglect ) u1 = u(2) ! The h2 scheme is used to compute the right edge value - ppoly_E(1,2) = (u0*h1 + u1*h0) / (h0 + h1) + edge_values(1,2) = (u0*h1 + u1*h0) / (h0 + h1) ! The standard PLM slope is computed as a first estimate for the ! reconstruction within the cell - slope = 2.0 * ( ppoly_E(1,2) - u0 ) + slope = 2.0 * ( edge_values(1,2) - u0 ) - ppoly_E(1,1) = u0 - 0.5 * slope - ppoly_E(1,2) = u0 + 0.5 * slope + edge_values(1,1) = u0 - 0.5 * slope + edge_values(1,2) = u0 + 0.5 * slope - ppoly_coef(1,1) = ppoly_E(1,1) - ppoly_coef(1,2) = ppoly_E(1,2) - ppoly_E(1,1) + ppoly_coef(1,1) = edge_values(1,1) + ppoly_coef(1,2) = edge_values(1,2) - edge_values(1,1) ! ------------------------------------------ ! Right edge value in the left boundary cell @@ -254,17 +254,17 @@ subroutine PLM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef, h_neglect ) u1 = u(N) ! The h2 scheme is used to compute the right edge value - ppoly_E(N,1) = (u0*h1 + u1*h0) / (h0 + h1) + edge_values(N,1) = (u0*h1 + u1*h0) / (h0 + h1) ! The standard PLM slope is computed as a first estimate for the ! reconstruction within the cell - slope = 2.0 * ( u1 - ppoly_E(N,1) ) + slope = 2.0 * ( u1 - edge_values(N,1) ) - ppoly_E(N,1) = u1 - 0.5 * slope - ppoly_E(N,2) = u1 + 0.5 * slope + edge_values(N,1) = u1 - 0.5 * slope + edge_values(N,2) = u1 + 0.5 * slope - ppoly_coef(N,1) = ppoly_E(N,1) - ppoly_coef(N,2) = ppoly_E(N,2) - ppoly_E(N,1) + ppoly_coef(N,1) = edge_values(N,1) + ppoly_coef(N,2) = edge_values(N,2) - edge_values(N,1) end subroutine PLM_boundary_extrapolation diff --git a/src/ALE/PPM_functions.F90 b/src/ALE/PPM_functions.F90 index 6d50703975..bbf93b4a81 100644 --- a/src/ALE/PPM_functions.F90 +++ b/src/ALE/PPM_functions.F90 @@ -25,11 +25,11 @@ module PPM_functions contains !> Builds quadratic polynomials coefficients from cell mean and edge values. -subroutine PPM_reconstruction( N, h, u, ppoly_E, ppoly_coef, h_neglect, answers_2018) +subroutine PPM_reconstruction( N, h, u, edge_values, ppoly_coef, h_neglect, answers_2018) integer, intent(in) :: N !< Number of cells real, dimension(N), intent(in) :: h !< Cell widths [H] real, dimension(N), intent(in) :: u !< Cell averages [A] - real, dimension(N,2), intent(inout) :: ppoly_E !< Edge values [A] + real, dimension(N,2), intent(inout) :: edge_values !< Edge values [A] real, dimension(N,3), intent(inout) :: ppoly_coef !< Polynomial coefficients, mainly [A] real, optional, intent(in) :: h_neglect !< A negligibly small width [H] logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. @@ -39,13 +39,13 @@ subroutine PPM_reconstruction( N, h, u, ppoly_E, ppoly_coef, h_neglect, answers_ real :: edge_l, edge_r ! Edge values (left and right) ! PPM limiter - call PPM_limiter_standard( N, h, u, ppoly_E, h_neglect, answers_2018 ) + call PPM_limiter_standard( N, h, u, edge_values, h_neglect, answers_2018 ) ! Loop over all cells do k = 1,N - edge_l = ppoly_E(k,1) - edge_r = ppoly_E(k,2) + edge_l = edge_values(k,1) + edge_r = edge_values(k,2) ! Store polynomial coefficients ppoly_coef(k,1) = edge_l @@ -59,11 +59,11 @@ end subroutine PPM_reconstruction !> Adjusts edge values using the standard PPM limiter (Colella & Woodward, JCP 1984) !! after first checking that the edge values are bounded by neighbors cell averages !! and that the edge values are monotonic between cell averages. -subroutine PPM_limiter_standard( N, h, u, ppoly_E, h_neglect, answers_2018 ) +subroutine PPM_limiter_standard( N, h, u, edge_values, h_neglect, answers_2018 ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) [H] real, dimension(:), intent(in) :: u !< cell average properties (size N) [A] - real, dimension(:,:), intent(inout) :: ppoly_E !< Potentially modified edge values [A] + real, dimension(:,:), intent(inout) :: edge_values !< Potentially modified edge values [A] real, optional, intent(in) :: h_neglect !< A negligibly small width [H] logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. @@ -74,10 +74,10 @@ subroutine PPM_limiter_standard( N, h, u, ppoly_E, h_neglect, answers_2018 ) real :: expr1, expr2 ! Bound edge values - call bound_edge_values( N, h, u, ppoly_E, h_neglect, answers_2018 ) + call bound_edge_values( N, h, u, edge_values, h_neglect, answers_2018 ) ! Make discontinuous edge values monotonic - call check_discontinuous_edge_values( N, u, ppoly_E ) + call check_discontinuous_edge_values( N, u, edge_values ) ! Loop on interior cells to apply the standard ! PPM limiter (Colella & Woodward, JCP 84) @@ -88,8 +88,8 @@ subroutine PPM_limiter_standard( N, h, u, ppoly_E, h_neglect, answers_2018 ) u_c = u(k) u_r = u(k+1) - edge_l = ppoly_E(k,1) - edge_r = ppoly_E(k,2) + edge_l = edge_values(k,1) + edge_r = edge_values(k,2) if ( (u_r - u_c)*(u_c - u_l) <= 0.0) then ! Flatten extremum @@ -116,21 +116,21 @@ subroutine PPM_limiter_standard( N, h, u, ppoly_E, h_neglect, answers_2018 ) edge_r = u_c endif - ppoly_E(k,1) = edge_l - ppoly_E(k,2) = edge_r + edge_values(k,1) = edge_l + edge_values(k,2) = edge_r enddo ! end loop on interior cells ! PCM within boundary cells - ppoly_E(1,:) = u(1) - ppoly_E(N,:) = u(N) + edge_values(1,:) = u(1) + edge_values(N,:) = u(N) end subroutine PPM_limiter_standard !------------------------------------------------------------------------------ !> Reconstruction by parabolas within boundary cells -subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef, h_neglect) +subroutine PPM_boundary_extrapolation( N, h, u, edge_values, ppoly_coef, h_neglect) !------------------------------------------------------------------------------ ! Reconstruction by parabolas within boundary cells. ! @@ -148,7 +148,7 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef, h_neglect) ! 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 +! edge_values : edge values 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 @@ -159,7 +159,7 @@ subroutine PPM_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) [H] real, dimension(:), intent(in) :: u !< cell averages (size N) [A] - real, dimension(:,:), intent(inout) :: ppoly_E !< edge values of piecewise polynomials [A] + real, dimension(:,:), intent(inout) :: edge_values !< edge values of piecewise polynomials [A] real, dimension(:,:), intent(inout) :: ppoly_coef !< coefficients of piecewise polynomials, mainly [A] real, optional, intent(in) :: h_neglect !< A negligibly small width for !! the purpose of cell reconstructions [H] @@ -199,7 +199,7 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef, h_neglect) ! The right edge value in the boundary cell is taken to be the left ! edge value in the neighboring cell - u0_r = ppoly_E(i1,1) + u0_r = edge_values(i1,1) ! Given the right edge value and slope, we determine the left ! edge value and slope by computing the parabola as determined by @@ -218,8 +218,8 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef, h_neglect) u0_r = 3.0 * u0 - 2.0 * u0_l endif - ppoly_E(i0,1) = u0_l - ppoly_E(i0,2) = u0_r + edge_values(i0,1) = u0_l + edge_values(i0,2) = u0_r a = u0_l b = 6.0 * u0 - 4.0 * u0_l - 2.0 * u0_r @@ -252,7 +252,7 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef, h_neglect) ! The left edge value in the boundary cell is taken to be the right ! edge value in the neighboring cell - u0_l = ppoly_E(i0,2) + u0_l = edge_values(i0,2) ! Given the left edge value and slope, we determine the right ! edge value and slope by computing the parabola as determined by @@ -271,8 +271,8 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef, h_neglect) u0_r = 3.0 * u1 - 2.0 * u0_l endif - ppoly_E(i1,1) = u0_l - ppoly_E(i1,2) = u0_r + edge_values(i1,1) = u0_l + edge_values(i1,2) = u0_r a = u0_l b = 6.0 * u1 - 4.0 * u0_l - 2.0 * u0_r diff --git a/src/ALE/PQM_functions.F90 b/src/ALE/PQM_functions.F90 index a2adeb0c13..630ecb34fc 100644 --- a/src/ALE/PQM_functions.F90 +++ b/src/ALE/PQM_functions.F90 @@ -17,12 +17,12 @@ module PQM_functions !! !! 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, answers_2018 ) +subroutine PQM_reconstruction( N, h, u, edge_values, edge_slopes, ppoly_coef, h_neglect, answers_2018 ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) [H] real, dimension(:), intent(in) :: u !< cell averages (size N) [A] - real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial [A] - real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial [A H-1] + real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial [A] + real, dimension(:,:), intent(inout) :: edge_slopes !< Edge slope of polynomial [A H-1] real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, mainly [A] real, optional, intent(in) :: h_neglect !< A negligibly small width for !! the purpose of cell reconstructions [H] @@ -36,16 +36,16 @@ subroutine PQM_reconstruction( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect, real :: a, b, c, d, e ! parabola coefficients ! PQM limiter - call PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect, answers_2018 ) + call PQM_limiter( N, h, u, edge_values, edge_slopes, h_neglect, answers_2018 ) ! Loop on cells to construct the cubic within each cell do k = 1,N - u0_l = ppoly_E(k,1) - u0_r = ppoly_E(k,2) + u0_l = edge_values(k,1) + u0_r = edge_values(k,2) - u1_l = ppoly_S(k,1) - u1_r = ppoly_S(k,2) + u1_l = edge_slopes(k,1) + u1_r = edge_slopes(k,2) h_c = h(k) @@ -72,12 +72,12 @@ end subroutine PQM_reconstruction !! !! 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, answers_2018 ) +subroutine PQM_limiter( N, h, u, edge_values, edge_slopes, h_neglect, answers_2018 ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) [H] real, dimension(:), intent(in) :: u !< cell average properties (size N) [A] - real, dimension(:,:), intent(inout) :: ppoly_E !< Potentially modified edge values [A] - real, dimension(:,:), intent(inout) :: ppoly_S !< Potentially modified edge slopes [A H-1] + real, dimension(:,:), intent(inout) :: edge_values !< Potentially modified edge values [A] + real, dimension(:,:), intent(inout) :: edge_slopes !< Potentially modified edge slopes [A H-1] real, optional, intent(in) :: h_neglect !< A negligibly small width for !! the purpose of cell reconstructions [H] logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. @@ -102,10 +102,10 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect, answers_2018 ) hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect ! Bound edge values - call bound_edge_values( N, h, u, ppoly_E, hNeglect, answers_2018 ) + call bound_edge_values( N, h, u, edge_values, hNeglect, answers_2018 ) ! Make discontinuous edge values monotonic (thru averaging) - call check_discontinuous_edge_values( N, u, ppoly_E ) + call check_discontinuous_edge_values( N, u, edge_values ) ! Loop on interior cells to apply the PQM limiter do k = 2,N-1 @@ -116,10 +116,10 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect, answers_2018 ) inflexion_r = 0 ! Get edge values, edge slopes and cell width - u0_l = ppoly_E(k,1) - u0_r = ppoly_E(k,2) - u1_l = ppoly_S(k,1) - u1_r = ppoly_S(k,2) + u0_l = edge_values(k,1) + u0_r = edge_values(k,2) + u1_l = edge_slopes(k,1) + u1_r = edge_slopes(k,2) ! Get cell widths and cell averages (boundary cells are assumed to ! be local extrema for the sake of slopes) @@ -320,19 +320,19 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect, answers_2018 ) endif ! clause to check where to collapse inflexion points ! Save edge values and edge slopes for reconstruction - ppoly_E(k,1) = u0_l - ppoly_E(k,2) = u0_r - ppoly_S(k,1) = u1_l - ppoly_S(k,2) = u1_r + edge_values(k,1) = u0_l + edge_values(k,2) = u0_r + edge_slopes(k,1) = u1_l + edge_slopes(k,2) = u1_r enddo ! end loop on interior cells ! Constant reconstruction within boundary cells - ppoly_E(1,:) = u(1) - ppoly_S(1,:) = 0.0 + edge_values(1,:) = u(1) + edge_slopes(1,:) = 0.0 - ppoly_E(N,:) = u(N) - ppoly_S(N,:) = 0.0 + edge_values(N,:) = u(N) + edge_slopes(N,:) = 0.0 end subroutine PQM_limiter @@ -351,11 +351,11 @@ end subroutine PQM_limiter !! !! 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 ) +subroutine PQM_boundary_extrapolation( N, h, u, edge_values, ppoly_coef ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) [H] real, dimension(:), intent(in) :: u !< cell averages (size N) [A] - real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial [A] + real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial [A] real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, mainly [A] ! Local variables integer :: i0, i1 @@ -389,7 +389,7 @@ subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef ) ! The right edge value in the boundary cell is taken to be the left ! edge value in the neighboring cell - u0_r = ppoly_E(i1,1) + u0_r = edge_values(i1,1) ! Given the right edge value and slope, we determine the left ! edge value and slope by computing the parabola as determined by @@ -408,8 +408,8 @@ subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef ) u0_r = 3.0 * u0 - 2.0 * u0_l endif - ppoly_E(i0,1) = u0_l - ppoly_E(i0,2) = u0_r + edge_values(i0,1) = u0_l + edge_values(i0,2) = u0_r a = u0_l b = 6.0 * u0 - 4.0 * u0_l - 2.0 * u0_r @@ -447,7 +447,7 @@ subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef ) ! The left edge value in the boundary cell is taken to be the right ! edge value in the neighboring cell - u0_l = ppoly_E(i0,2) + u0_l = edge_values(i0,2) ! Given the left edge value and slope, we determine the right ! edge value and slope by computing the parabola as determined by @@ -466,8 +466,8 @@ subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef ) u0_r = 3.0 * u1 - 2.0 * u0_l endif - ppoly_E(i1,1) = u0_l - ppoly_E(i1,2) = u0_r + edge_values(i1,1) = u0_l + edge_values(i1,2) = u0_r a = u0_l b = 6.0 * u1 - 4.0 * u0_l - 2.0 * u0_r @@ -498,12 +498,12 @@ end subroutine PQM_boundary_extrapolation !! !! 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 ) +subroutine PQM_boundary_extrapolation_v1( N, h, u, edge_values, edge_slopes, ppoly_coef, h_neglect ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) [H] real, dimension(:), intent(in) :: u !< cell averages (size N) [A] - real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial [A] - real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial [A H-1] + real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial [A] + real, dimension(:,:), intent(inout) :: edge_slopes !< Edge slope of polynomial [A H-1] real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, mainly [A] real, optional, intent(in) :: h_neglect !< A negligibly small width for !! the purpose of cell reconstructions [H] @@ -656,10 +656,10 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coef, endif ! Store edge values, edge slopes and coefficients - ppoly_E(i0,1) = u0_l - ppoly_E(i0,2) = u0_r - ppoly_S(i0,1) = u1_l - ppoly_S(i0,2) = u1_r + edge_values(i0,1) = u0_l + edge_values(i0,2) = u0_r + edge_slopes(i0,1) = u1_l + edge_slopes(i0,2) = u1_r a = u0_l b = h0 * u1_l @@ -809,10 +809,10 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coef, endif ! Store edge values, edge slopes and coefficients - ppoly_E(i1,1) = u0_l - ppoly_E(i1,2) = u0_r - ppoly_S(i1,1) = u1_l - ppoly_S(i1,2) = u1_r + edge_values(i1,1) = u0_l + edge_values(i1,2) = u0_r + edge_slopes(i1,1) = u1_l + edge_slopes(i1,2) = u1_r a = u0_l b = h1 * u1_l diff --git a/src/ALE/regrid_interp.F90 b/src/ALE/regrid_interp.F90 index 5a1d151487..1ab225474c 100644 --- a/src/ALE/regrid_interp.F90 +++ b/src/ALE/regrid_interp.F90 @@ -349,13 +349,13 @@ 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, & +function get_polynomial_coordinate( N, h, x_g, edge_values, ppoly_coefs, & target_value, degree, answers_2018 ) result ( x_tgt ) ! Arguments integer, intent(in) :: N !< Number of grid cells real, dimension(N), intent(in) :: h !< Grid cell thicknesses [H] real, dimension(N+1), intent(in) :: x_g !< Grid interface locations [H] - real, dimension(N,2), intent(in) :: ppoly_E !< Edge values of interpolating polynomials [A] + real, dimension(N,2), intent(in) :: edge_values !< Edge values of interpolating polynomials [A] real, dimension(N,DEGREE_MAX+1), intent(in) :: ppoly_coefs !< Coefficients of interpolating polynomials [A] real, intent(in) :: target_value !< Target value to find position for [A] integer, intent(in) :: degree !< Degree of the interpolating polynomials @@ -383,7 +383,7 @@ function get_polynomial_coordinate( N, h, x_g, ppoly_E, ppoly_coefs, & ! If the target value is outside the range of all values, we ! force the target coordinate to be equal to the lowest or ! largest value, depending on which bound is overtaken - if ( target_value <= ppoly_E(1,1) ) then + if ( target_value <= edge_values(1,1) ) then x_tgt = x_g(1) return ! return because there is no need to look further endif @@ -391,7 +391,7 @@ function get_polynomial_coordinate( N, h, x_g, ppoly_E, ppoly_coefs, & ! Since discontinuous edge values are allowed, we check whether the target ! value lies between two discontinuous edge values at interior interfaces do k = 2,N - if ( ( target_value >= ppoly_E(k-1,2) ) .AND. ( target_value <= ppoly_E(k,1) ) ) then + if ( ( target_value >= edge_values(k-1,2) ) .AND. ( target_value <= edge_values(k,1) ) ) then x_tgt = x_g(k) return ! return because there is no need to look further endif @@ -400,7 +400,7 @@ function get_polynomial_coordinate( N, h, x_g, ppoly_E, ppoly_coefs, & ! If the target value is outside the range of all values, we ! force the target coordinate to be equal to the lowest or ! largest value, depending on which bound is overtaken - if ( target_value >= ppoly_E(N,2) ) then + if ( target_value >= edge_values(N,2) ) then x_tgt = x_g(N+1) return ! return because there is no need to look further endif @@ -411,7 +411,7 @@ function get_polynomial_coordinate( N, h, x_g, ppoly_E, ppoly_coefs, & ! contains the target value. The variable k_found holds the index value ! of the cell where the taregt value lies. do k = 1,N - if ( ( target_value > ppoly_E(k,1) ) .AND. ( target_value < ppoly_E(k,2) ) ) then + if ( ( target_value > edge_values(k,1) ) .AND. ( target_value < edge_values(k,2) ) ) then k_found = k exit endif @@ -425,7 +425,7 @@ function get_polynomial_coordinate( N, h, x_g, ppoly_E, ppoly_coefs, & if ( k_found == -1 ) then write(mesg,*) 'Could not find target coordinate', target_value, 'in get_polynomial_coordinate. This is '//& 'caused by an inconsistent interpolant (perhaps not monotonically increasing):', & - target_value, ppoly_E(1,1), ppoly_E(N,2) + target_value, edge_values(1,1), edge_values(N,2) call MOM_error( FATAL, mesg ) endif From 05dbf8640242005f5d641259acb3c1338368f140 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 6 May 2020 21:43:36 +0000 Subject: [PATCH 31/91] Cleaned up unused use statements --- src/core/MOM_density_integrals.F90 | 51 +++++++----------------------- 1 file changed, 12 insertions(+), 39 deletions(-) diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index 4cd9c8fc48..0ac4906158 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -3,46 +3,19 @@ module MOM_density_integrals ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_EOS, only : EOS_type -use MOM_EOS, only : EOS_quadrature -use MOM_EOS, only : analytic_int_density_dz -use MOM_EOS, only : analytic_int_specific_vol_dp -use MOM_EOS, only : calculate_density -use MOM_EOS, only : calculate_spec_vol -use MOM_EOS, only : calculate_specific_vol_derivs -use MOM_EOS, only : calculate_density_second_derivs - -use MOM_EOS_linear, only : calculate_density_linear, calculate_spec_vol_linear -use MOM_EOS_linear, only : calculate_density_derivs_linear -use MOM_EOS_linear, only : calculate_specvol_derivs_linear, int_density_dz_linear -use MOM_EOS_linear, only : calculate_density_second_derivs_linear -use MOM_EOS_linear, only : calculate_compress_linear, int_spec_vol_dp_linear -use MOM_EOS_Wright, only : calculate_density_wright, calculate_spec_vol_wright -use MOM_EOS_Wright, only : calculate_density_derivs_wright -use MOM_EOS_Wright, only : calculate_specvol_derivs_wright, int_density_dz_wright -use MOM_EOS_Wright, only : calculate_compress_wright, int_spec_vol_dp_wright -use MOM_EOS_Wright, only : calculate_density_second_derivs_wright -use MOM_EOS_UNESCO, only : calculate_density_unesco, calculate_spec_vol_unesco -use MOM_EOS_UNESCO, only : calculate_density_derivs_unesco, calculate_density_unesco -use MOM_EOS_UNESCO, only : calculate_compress_unesco -use MOM_EOS_NEMO, only : calculate_density_nemo -use MOM_EOS_NEMO, only : calculate_density_derivs_nemo, calculate_density_nemo -use MOM_EOS_NEMO, only : calculate_compress_nemo -use MOM_EOS_TEOS10, only : calculate_density_teos10, calculate_spec_vol_teos10 -use MOM_EOS_TEOS10, only : calculate_density_derivs_teos10 -use MOM_EOS_TEOS10, only : calculate_specvol_derivs_teos10 -use MOM_EOS_TEOS10, only : calculate_density_second_derivs_teos10 -use MOM_EOS_TEOS10, only : calculate_compress_teos10 -use MOM_EOS_TEOS10, only : gsw_sp_from_sr, gsw_pt_from_ct -use MOM_TFreeze, only : calculate_TFreeze_linear, calculate_TFreeze_Millero -use MOM_TFreeze, only : calculate_TFreeze_teos10 -use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg -use MOM_file_parser, only : get_param, log_version, param_file_type -use MOM_hor_index, only : hor_index_type +use MOM_EOS, only : EOS_type +use MOM_EOS, only : EOS_quadrature +use MOM_EOS, only : analytic_int_density_dz +use MOM_EOS, only : analytic_int_specific_vol_dp +use MOM_EOS, only : calculate_density +use MOM_EOS, only : calculate_spec_vol +use MOM_EOS, only : calculate_specific_vol_derivs +use MOM_EOS, only : calculate_density_second_derivs +use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_hor_index, only : hor_index_type use MOM_string_functions, only : uppercase -use MOM_unit_scaling, only : unit_scale_type - -use MOM_EOS, only : EOS_LINEAR, EOS_UNESCO, EOS_WRIGHT, EOS_TEOS10, EOS_NEMO +use MOM_unit_scaling, only : unit_scale_type implicit none ; private From 7171c1aa09a27c056aa63f032c3b888cd1144201 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 6 May 2020 21:44:43 +0000 Subject: [PATCH 32/91] Tidied up logic for EOS_QUADRATURE - Undid nesting of if / select statemnent - Changed FATAL messages --- src/equation_of_state/MOM_EOS.F90 | 24 ++++++++++++++---------- 1 file changed, 14 insertions(+), 10 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index b3cfcab83f..9622ab4f38 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -1186,9 +1186,11 @@ subroutine analytic_int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & if (.not.associated(EOS)) call MOM_error(FATAL, & "int_specific_vol_dp called with an unassociated EOS_type EOS.") - if (EOS%EOS_quadrature) then - call MOM_error(FATAL, "EOS_quadrature is set!") - else ; select case (EOS%form_of_EOS) + ! We should never reach this point with quadrature. EOS_quadrature indicates that numerical + ! integration be used instead of analytic. This is a safety check. + if (EOS%EOS_quadrature) call MOM_error(FATAL, "EOS_quadrature is set!") + + select case (EOS%form_of_EOS) case (EOS_LINEAR) call int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, EOS%kg_m3_to_R*EOS%Rho_T0_S0, & EOS%kg_m3_to_R*EOS%dRho_dT, EOS%kg_m3_to_R*EOS%dRho_dS, dza, & @@ -1199,8 +1201,8 @@ subroutine analytic_int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & inty_dza, halo_size, bathyP, dP_tiny, useMassWghtInterp, & SV_scale=EOS%R_to_kg_m3, pres_scale=EOS%RL2_T2_to_Pa) case default - call MOM_error(FATAL, "Set EOS_QUADRATURE!") - end select ; endif + call MOM_error(FATAL, "No analytic integration option is available with this EOS!") + end select end subroutine analytic_int_specific_vol_dp @@ -1255,9 +1257,11 @@ subroutine analytic_int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, if (.not.associated(EOS)) call MOM_error(FATAL, & "int_density_dz called with an unassociated EOS_type EOS.") - if (EOS%EOS_quadrature) then - call MOM_error(FATAL, "EOS_quadrature is set!") - else ; select case (EOS%form_of_EOS) + ! We should never reach this point with quadrature. EOS_quadrature indicates that numerical + ! integration be used instead of analytic. This is a safety check. + if (EOS%EOS_quadrature) call MOM_error(FATAL, "EOS_quadrature is set!") + + select case (EOS%form_of_EOS) case (EOS_LINEAR) rho_scale = EOS%kg_m3_to_R if (rho_scale /= 1.0) then @@ -1282,8 +1286,8 @@ subroutine analytic_int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, dz_neglect, useMassWghtInterp) endif case default - call MOM_error(FATAL, "Use EOS_QUADRATURE!") - end select ; endif + call MOM_error(FATAL, "No analytic integration option is available with this EOS!") + end select end subroutine analytic_int_density_dz From 6a0b23d1a2751cebd748e7af98bb7dc718f4e5b1 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 6 May 2020 21:50:39 +0000 Subject: [PATCH 33/91] Removed find_depth_of_pressure_in_cell() from MOM_EOS - Function had been moved to density_integrals already but not deleted - Also ordered public statements in MOM_EOS to help find things. --- src/equation_of_state/MOM_EOS.F90 | 333 +----------------- .../MOM_state_initialization.F90 | 6 +- 2 files changed, 20 insertions(+), 319 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 9622ab4f38..583bb8fcbc 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -37,18 +37,27 @@ module MOM_EOS #include -public calculate_compress, calculate_density, query_compressible -public calculate_density_derivs, calculate_specific_vol_derivs -public calculate_density_second_derivs -public EOS_init, EOS_manual_init, EOS_end, EOS_allocate, EOS_domain -public EOS_use_linear, calculate_spec_vol -public analytic_int_density_dz, analytic_int_specific_vol_dp +public EOS_allocate +public EOS_domain +public EOS_end +public EOS_init +public EOS_manual_init public EOS_quadrature -public find_depth_of_pressure_in_cell +public EOS_use_linear +public analytic_int_density_dz +public analytic_int_specific_vol_dp +public calculate_compress +public calculate_density +public calculate_density_derivs +public calculate_density_second_derivs +public calculate_spec_vol +public calculate_specific_vol_derivs public calculate_TFreeze public convert_temp_salt_for_TEOS10 -public gsw_sp_from_sr, gsw_pt_from_ct public extract_member_EOS +public gsw_sp_from_sr +public gsw_pt_from_ct +public query_compressible ! 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 @@ -1483,314 +1492,6 @@ subroutine EOS_use_linear(Rho_T0_S0, dRho_dT, dRho_dS, EOS, use_quadrature) end subroutine EOS_use_linear -!> 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, 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 [R L2 T-2 ~> Pa] - real, intent(in) :: P_tgt !< Target pressure at height z_out, relative to g*rho_ref*z_out [R L2 T-2 ~> Pa] - real, intent(in) :: rho_ref !< Reference density with which calculation are anomalous to [R ~> kg m-3] - real, intent(in) :: G_e !< Gravitational acceleration [L2 Z-1 T-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 [R L2 T-2 ~> 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 :: dp ! Pressure thickness of the layer [R L2 T-2 ~> Pa] - real :: F_guess, F_l, F_r ! Fractional positions [nondim] - real :: GxRho ! The product of the gravitational acceleration and reference density [R L2 Z-1 T-2 ~> Pa m-1] - real :: Pa, Pa_left, Pa_right, Pa_tol ! Pressure anomalies, P = integral of g*(rho-rho_ref) dz [R L2 T-2 ~> Pa] - character(len=240) :: msg - - GxRho = G_e * rho_ref - - ! Anomalous pressure difference across whole cell - dp = frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, 1.0, EOS) - - P_b = P_t + dp ! Anomalous pressure at bottom of cell - - if (P_tgt <= P_t ) then - z_out = z_t - return - endif - - if (P_tgt >= P_b) then - z_out = z_b - return - endif - - F_l = 0. - 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.0e-5*EOS%m_to_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 ) - - z_out = z_t + ( z_b - z_t ) * F_guess - Pa = frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, F_guess, EOS) - ( P_tgt - P_t ) - - if (PaPa_right) then - write(msg,*) Pa_left,Pa,Pa_right,P_t-P_tgt,P_b-P_tgt - call MOM_error(FATAL, 'find_depth_of_pressure_in_cell out of bounds positive: /n'//msg) - elseif (Pa>0.) then - Pa_right = Pa - F_r = F_guess - else ! Pa == 0 - return - endif - F_guess = F_l - Pa_left / (Pa_right - Pa_left) * (F_r - F_l) - - enddo - -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 !< 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 [R ~> 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 [L2 Z-1 T-2 ~> m s-2] - real, intent(in) :: pos !< The fractional vertical position, 0 to 1 [nondim] - type(EOS_type), pointer :: EOS !< Equation of state structure - real :: fract_dp_at_pos !< The change in pressure from the layer top to - !! fractional position pos [R L2 T-2 ~> Pa] - ! Local variables - real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] - real :: dz ! Distance from the layer top [Z ~> m] - real :: top_weight, bottom_weight ! Fractional weights at quadrature points [nondim] - real :: rho_ave ! Average density [R ~> kg m-3] - real, dimension(5) :: T5 ! Tempratures at quadrature points [degC] - real, dimension(5) :: S5 ! Salinities at quadrature points [ppt] - real, dimension(5) :: p5 ! Pressures at quadrature points [R L2 T-2 ~> Pa] - real, dimension(5) :: rho5 ! Densities at quadrature points [R ~> kg m-3] - integer :: n - - do n=1,5 - ! Evalute density at five quadrature points - bottom_weight = 0.25*real(n-1) * pos - top_weight = 1.0 - bottom_weight - ! Salinity and temperature points are linearly interpolated - S5(n) = top_weight * S_t + bottom_weight * S_b - T5(n) = top_weight * T_t + bottom_weight * T_b - p5(n) = ( top_weight * z_t + bottom_weight * z_b ) * ( G_e * rho_ref ) - enddo - call calculate_density_1d(T5, S5, p5, rho5, EOS) - rho5(:) = rho5(:) !- rho_ref ! Work with anomalies relative to rho_ref - - ! Use Bode's rule to estimate the average density - rho_ave = C1_90*(7.0*(rho5(1)+rho5(5)) + 32.0*(rho5(2)+rho5(4)) + 12.0*rho5(3)) - - dz = ( z_t - z_b ) * pos - frac_dp_at_pos = G_e * dz * rho_ave -end function frac_dp_at_pos - -! ============================================================================= -!> 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 - real, dimension(9) :: weight, xi, eta ! integration points - real :: f_k - real :: dxdxi, dxdeta - real :: dydxi, dydeta - real, dimension(4) :: phiiso, dphiisodxi, dphiisodeta - real, dimension(9) :: phi, dphidxi, dphideta - real :: jacobian_k - real :: t - - ! Quadrature rule (4 points) - !weight(:) = 1.0 - !xi(1) = - sqrt(3.0) / 3.0 - !xi(2) = sqrt(3.0) / 3.0 - !xi(3) = sqrt(3.0) / 3.0 - !xi(4) = - sqrt(3.0) / 3.0 - !eta(1) = - sqrt(3.0) / 3.0 - !eta(2) = - sqrt(3.0) / 3.0 - !eta(3) = sqrt(3.0) / 3.0 - !eta(4) = sqrt(3.0) / 3.0 - - ! Quadrature rule (9 points) - t = sqrt(3.0/5.0) - weight(1) = 25.0/81.0 ; xi(1) = -t ; eta(1) = t - weight(2) = 40.0/81.0 ; xi(2) = .0 ; eta(2) = t - weight(3) = 25.0/81.0 ; xi(3) = t ; eta(3) = t - weight(4) = 40.0/81.0 ; xi(4) = -t ; eta(4) = .0 - weight(5) = 64.0/81.0 ; xi(5) = .0 ; eta(5) = .0 - weight(6) = 40.0/81.0 ; xi(6) = t ; eta(6) = .0 - weight(7) = 25.0/81.0 ; xi(7) = -t ; eta(7) = -t - weight(8) = 40.0/81.0 ; xi(8) = .0 ; eta(8) = -t - weight(9) = 25.0/81.0 ; xi(9) = t ; eta(9) = -t - - integral = 0.0 - - ! Integration loop - do k = 1,9 - - ! Evaluate shape functions and gradients for isomorphism - call evaluate_shape_bilinear( xi(k), eta(k), phiiso, & - dphiisodxi, dphiisodeta ) - - ! Determine gradient of global coordinate at integration point - dxdxi = 0.0 - dxdeta = 0.0 - dydxi = 0.0 - dydeta = 0.0 - - do i = 1,4 - dxdxi = dxdxi + x(i) * dphiisodxi(i) - dxdeta = dxdeta + x(i) * dphiisodeta(i) - dydxi = dydxi + y(i) * dphiisodxi(i) - dydeta = dydeta + y(i) * dphiisodeta(i) - enddo - - ! Evaluate Jacobian at integration point - jacobian_k = dxdxi*dydeta - dydxi*dxdeta - - ! Evaluate shape functions for interpolation - call evaluate_shape_quadratic( xi(k), eta(k), phi, dphidxi, dphideta ) - - ! Evaluate function at integration point - f_k = 0.0 - do i = 1,9 - f_k = f_k + f(i) * phi(i) - enddo - - integral = integral + weight(k) * f_k * jacobian_k - - enddo ! end integration loop - -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 ) - real, intent(in) :: xi !< The x position to evaluate - real, intent(in) :: eta !< The z position to evaluate - real, dimension(4), intent(inout) :: phi !< The weights of the four corners at this point - real, dimension(4), intent(inout) :: dphidxi !< The x-gradient of the weights of the four - !! corners at this point - real, dimension(4), intent(inout) :: 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) - ! | | - ! | | - ! | | - ! | | - ! (-1,-1) 3 o------------o 4 (1,-1) - ! - - phi(1) = 0.25 * ( 1 + xi ) * ( 1 + eta ) - phi(2) = 0.25 * ( 1 - xi ) * ( 1 + eta ) - phi(3) = 0.25 * ( 1 - xi ) * ( 1 - eta ) - phi(4) = 0.25 * ( 1 + xi ) * ( 1 - eta ) - - dphidxi(1) = 0.25 * ( 1 + eta ) - dphidxi(2) = - 0.25 * ( 1 + eta ) - dphidxi(3) = - 0.25 * ( 1 - eta ) - dphidxi(4) = 0.25 * ( 1 - eta ) - - dphideta(1) = 0.25 * ( 1 + xi ) - dphideta(2) = 0.25 * ( 1 - xi ) - dphideta(3) = - 0.25 * ( 1 - xi ) - dphideta(4) = - 0.25 * ( 1 + xi ) - -end subroutine evaluate_shape_bilinear - - -! ============================================================================= -!> 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 !< The x position to evaluate - real, intent(in) :: eta !< The z position to evaluate - real, dimension(9), intent(inout) :: phi !< The weights of the 9 bilinear quadrature points - !! at this point - real, dimension(9), intent(inout) :: dphidxi !< The x-gradient of the weights of the 9 bilinear - !! quadrature points corners at this point - real, dimension(9), intent(inout) :: 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) - ! | | - ! | 9 (0,0) | - ! (-1,0) 6 o o o 8 (1,0) - ! | | - ! | | - ! (-1,-1) 3 o------o------o 4 (1,-1) - ! 7 (0,-1) - ! - - 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 ) - phi(3) = 0.25 * xi * ( 1 - xi ) * eta * ( 1 - eta ) - phi(4) = - 0.25 * xi * ( 1 + xi ) * eta * ( 1 - eta ) - phi(5) = 0.5 * ( 1 + xi ) * ( 1 - xi ) * eta * ( 1 + eta ) - phi(6) = - 0.5 * xi * ( 1 - xi ) * ( 1 - eta ) * ( 1 + eta ) - phi(7) = - 0.5 * ( 1 - xi ) * ( 1 + xi ) * eta * ( 1 - eta ) - phi(8) = 0.5 * xi * ( 1 + xi ) * ( 1 - eta ) * ( 1 + eta ) - phi(9) = ( 1 - xi ) * ( 1 + xi ) * ( 1 - eta ) * ( 1 + eta ) - - !dphidxi(1) = 0.25 * ( 1 + 2*xi ) * eta * ( 1 + eta ) - !dphidxi(2) = - 0.25 * ( 1 - 2*xi ) * eta * ( 1 + eta ) - !dphidxi(3) = 0.25 * ( 1 - 2*xi ) * eta * ( 1 - eta ) - !dphidxi(4) = - 0.25 * ( 1 + 2*xi ) * eta * ( 1 - eta ) - !dphidxi(5) = - xi * eta * ( 1 + eta ) - !dphidxi(6) = - 0.5 * ( 1 - 2*xi ) * ( 1 - eta ) * ( 1 + eta ) - !dphidxi(7) = xi * eta * ( 1 - eta ) - !dphidxi(8) = 0.5 * ( 1 + 2*xi ) * ( 1 - eta ) * ( 1 + eta ) - !dphidxi(9) = - 2 * xi * ( 1 - eta ) * ( 1 + eta ) - - !dphideta(1) = 0.25 * xi * ( 1 + xi ) * ( 1 + 2*eta ) - !dphideta(2) = - 0.25 * xi * ( 1 - xi ) * ( 1 + 2*eta ) - !dphideta(3) = 0.25 * xi * ( 1 - xi ) * ( 1 - 2*eta ) - !dphideta(4) = - 0.25 * xi * ( 1 + xi ) * ( 1 - 2*eta ) - !dphideta(5) = 0.5 * ( 1 + xi ) * ( 1 - xi ) * ( 1 + 2*eta ) - !dphideta(6) = xi * ( 1 - xi ) * eta - !dphideta(7) = - 0.5 * ( 1 - xi ) * ( 1 + xi ) * ( 1 - 2*eta ) - !dphideta(8) = - xi * ( 1 + xi ) * eta - !dphideta(9) = - 2 * ( 1 - xi ) * ( 1 + xi ) * eta - -end subroutine evaluate_shape_quadratic -! ============================================================================== !> Convert T&S to Absolute Salinity and Conservative Temperature if using TEOS10 subroutine convert_temp_salt_for_TEOS10(T, S, HI, kd, mask_z, EOS) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index bd2b144e96..e451966364 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -5,12 +5,12 @@ module MOM_state_initialization use MOM_debugging, only : hchksum, qchksum, uvchksum use MOM_density_integrals, only : int_specific_vol_dp +use MOM_density_integrals, only : find_depth_of_pressure_in_cell use MOM_coms, only : max_across_PEs, min_across_PEs, reproducing_sum use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_ROUTINE, CLOCK_LOOP use MOM_domains, only : pass_var, pass_vector, sum_across_PEs, broadcast use MOM_domains, only : root_PE, To_All, SCALAR_PAIR, CGRID_NE, AGRID -use MOM_EOS, only : find_depth_of_pressure_in_cell 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 @@ -1219,7 +1219,7 @@ subroutine cut_off_column_top(nk, tv, GV, US, G_earth, depth, min_thickness, T, 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, GV%Rho0, G_earth, tv%eqn_of_state, & - P_b, z_out, z_tol=z_tol) + US, 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 @@ -2471,7 +2471,7 @@ subroutine MOM_state_init_tests(G, GV, US, tv) 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) + GV%Rho0, GV%g_Earth, tv%eqn_of_state, US, P_b, z_out) write(0,*) k, US%RL2_T2_to_Pa*P_t, US%RL2_T2_to_Pa*P_b, 0.5*US%RL2_T2_to_Pa*P_tot, & US%Z_to_m*e(K), US%Z_to_m*e(K+1), US%Z_to_m*z_out P_t = P_b From 5b59cdcef25d58d84ae78814c8fb6616b681f3fe Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 6 May 2020 22:16:02 +0000 Subject: [PATCH 34/91] Reordered function in MOM_density_integrals - Order was frustratingly illogical --- src/core/MOM_density_integrals.F90 | 380 ++++++++++++++--------------- 1 file changed, 190 insertions(+), 190 deletions(-) diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index 0ac4906158..76cee52dbd 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -33,68 +33,9 @@ module MOM_density_integrals contains !> Calls the appropriate subroutine to calculate analytical and nearly-analytical -!! integrals in pressure across layers of geopotential anomalies, which are +!! integrals in z across layers of pressure 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 Boole'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. -subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, US, & - dza, intp_dza, intx_dza, inty_dza, halo_size, & - bathyP, dP_tiny, useMassWghtInterp) - 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 [R L2 T-2 ~> Pa] or [Pa] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_b !< Pressure at the bottom of the layer [R L2 T-2 ~> Pa] or [Pa] - real, intent(in) :: alpha_ref !< A mean specific volume that is subtracted out - !! to reduce the magnitude of each of the integrals [R-1 ~> 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 - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(inout) :: dza !< The change in the geopotential anomaly across - !! the layer [L2 T-2 ~> m2 s-2] or [m2 s-2] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of the - !! geopotential anomaly relative to the anomaly at the bottom of the - !! layer [R L4 T-4 ~> Pa m2 s-2] or [Pa m2 s-2] - real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & - optional, intent(inout) :: 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 [L2 T-2 ~> m2 s-2] or [m2 s-2] - real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & - optional, intent(inout) :: 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 [L2 T-2 ~> m2 s-2] or [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 [R L2 T-2 ~> Pa] or [Pa] - real, optional, intent(in) :: dP_tiny !< A minuscule pressure change with - !! the same units as p_t [R L2 T-2 ~> Pa] or [Pa] - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting - !! to interpolate T/S for top and bottom integrals. - - if (EOS_quadrature(EOS)) then - call int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, & - dza, intp_dza, intx_dza, inty_dza, halo_size, & - bathyP, dP_tiny, useMassWghtInterp) - else - call analytic_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) - endif - -end subroutine int_specific_vol_dp - - -!> This subroutine calculates analytical and nearly-analytical integrals of -!! pressure anomalies across layers, which are required for calculating the -!! finite-volume form pressure accelerations in a Boussinesq model. +!! Boussinesq model. subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, US, dpa, & intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp) type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structures for the arrays @@ -148,9 +89,8 @@ subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, US, dpa, end subroutine int_density_dz -!> 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. +!> 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. subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & EOS, US, dpa, intz_dpa, intx_dpa, inty_dpa, & bathyT, dz_neglect, useMassWghtInterp) @@ -659,132 +599,6 @@ subroutine int_density_dz_generic_plm(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & 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, US, P_b, z_out, z_tol) - real, intent(in) :: T_t !< Potential temperature at the cell top [degC] - real, intent(in) :: T_b !< Potential temperature 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 [R L2 T-2 ~> Pa] - real, intent(in) :: P_tgt !< Target pressure at height z_out, relative to g*rho_ref*z_out [R L2 T-2 ~> Pa] - real, intent(in) :: rho_ref !< Reference density with which calculation are anomalous to [R ~> kg m-3] - real, intent(in) :: G_e !< Gravitational acceleration [L2 Z-1 T-2 ~> m s-2] - type(EOS_type), pointer :: EOS !< Equation of state structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, intent(out) :: P_b !< Pressure at the bottom of the cell [R L2 T-2 ~> 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 :: dp ! Pressure thickness of the layer [R L2 T-2 ~> Pa] - real :: F_guess, F_l, F_r ! Fractional positions [nondim] - real :: GxRho ! The product of the gravitational acceleration and reference density [R L2 Z-1 T-2 ~> Pa m-1] - real :: Pa, Pa_left, Pa_right, Pa_tol ! Pressure anomalies, P = integral of g*(rho-rho_ref) dz [R L2 T-2 ~> Pa] - character(len=240) :: msg - - GxRho = G_e * rho_ref - - ! Anomalous pressure difference across whole cell - dp = frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, 1.0, EOS) - - P_b = P_t + dp ! Anomalous pressure at bottom of cell - - if (P_tgt <= P_t ) then - z_out = z_t - return - endif - - if (P_tgt >= P_b) then - z_out = z_b - return - endif - - F_l = 0. - 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.0e-5*US%m_to_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 ) - - z_out = z_t + ( z_b - z_t ) * F_guess - Pa = frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, F_guess, EOS) - ( P_tgt - P_t ) - - if (PaPa_right) then - write(msg,*) Pa_left,Pa,Pa_right,P_t-P_tgt,P_b-P_tgt - call MOM_error(FATAL, 'find_depth_of_pressure_in_cell out of bounds positive: /n'//msg) - elseif (Pa>0.) then - Pa_right = Pa - F_r = F_guess - else ! Pa == 0 - return - endif - F_guess = F_l - Pa_left / (Pa_right - Pa_left) * (F_r - F_l) - - enddo - -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 !< Potential temperature at the cell top [degC] - real, intent(in) :: T_b !< Potential temperature 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 [R ~> 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 [L2 Z-1 T-2 ~> m s-2] - real, intent(in) :: pos !< The fractional vertical position, 0 to 1 [nondim] - type(EOS_type), pointer :: EOS !< Equation of state structure - real :: fract_dp_at_pos !< The change in pressure from the layer top to - !! fractional position pos [R L2 T-2 ~> Pa] - ! Local variables - real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] - real :: dz ! Distance from the layer top [Z ~> m] - real :: top_weight, bottom_weight ! Fractional weights at quadrature points [nondim] - real :: rho_ave ! Average density [R ~> kg m-3] - real, dimension(5) :: T5 ! Temperatures at quadrature points [degC] - real, dimension(5) :: S5 ! Salinities at quadrature points [ppt] - real, dimension(5) :: p5 ! Pressures at quadrature points [R L2 T-2 ~> Pa] - real, dimension(5) :: rho5 ! Densities at quadrature points [R ~> kg m-3] - integer :: n - - do n=1,5 - ! Evaluate density at five quadrature points - bottom_weight = 0.25*real(n-1) * pos - top_weight = 1.0 - bottom_weight - ! Salinity and temperature points are linearly interpolated - S5(n) = top_weight * S_t + bottom_weight * S_b - T5(n) = top_weight * T_t + bottom_weight * T_b - p5(n) = ( top_weight * z_t + bottom_weight * z_b ) * ( G_e * rho_ref ) - enddo - call calculate_density(T5, S5, p5, rho5, EOS) - rho5(:) = rho5(:) !- rho_ref ! Work with anomalies relative to rho_ref - - ! Use Boole's rule to estimate the average density - rho_ave = C1_90*(7.0*(rho5(1)+rho5(5)) + 32.0*(rho5(2)+rho5(4)) + 12.0*rho5(3)) - - dz = ( z_t - z_b ) * pos - frac_dp_at_pos = G_e * dz * rho_ave -end function frac_dp_at_pos - - !> 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, & @@ -1227,6 +1041,66 @@ subroutine evaluate_shape_quadratic ( xi, eta, phi, dphidxi, dphideta ) end subroutine evaluate_shape_quadratic +!> Calls the appropriate subroutine to calculate 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 Boole'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. +subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, US, & + dza, intp_dza, intx_dza, inty_dza, halo_size, & + bathyP, dP_tiny, useMassWghtInterp) + 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 [R L2 T-2 ~> Pa] or [Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: p_b !< Pressure at the bottom of the layer [R L2 T-2 ~> Pa] or [Pa] + real, intent(in) :: alpha_ref !< A mean specific volume that is subtracted out + !! to reduce the magnitude of each of the integrals [R-1 ~> 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 + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(inout) :: dza !< The change in the geopotential anomaly across + !! the layer [L2 T-2 ~> m2 s-2] or [m2 s-2] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of the + !! geopotential anomaly relative to the anomaly at the bottom of the + !! layer [R L4 T-4 ~> Pa m2 s-2] or [Pa m2 s-2] + real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & + optional, intent(inout) :: 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 [L2 T-2 ~> m2 s-2] or [m2 s-2] + real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & + optional, intent(inout) :: 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 [L2 T-2 ~> m2 s-2] or [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 [R L2 T-2 ~> Pa] or [Pa] + real, optional, intent(in) :: dP_tiny !< A minuscule pressure change with + !! the same units as p_t [R L2 T-2 ~> Pa] or [Pa] + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting + !! to interpolate T/S for top and bottom integrals. + + if (EOS_quadrature(EOS)) then + call int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, & + dza, intp_dza, intx_dza, inty_dza, halo_size, & + bathyP, dP_tiny, useMassWghtInterp) + else + call analytic_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) + endif + +end subroutine int_specific_vol_dp + + !> This subroutine calculates integrals of specific volume anomalies in !! pressure across layers, which are required for calculating the finite-volume !! form pressure accelerations in a non-Boussinesq model. There are essentially @@ -1692,6 +1566,132 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, end subroutine int_spec_vol_dp_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, US, P_b, z_out, z_tol) + real, intent(in) :: T_t !< Potential temperature at the cell top [degC] + real, intent(in) :: T_b !< Potential temperature 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 [R L2 T-2 ~> Pa] + real, intent(in) :: P_tgt !< Target pressure at height z_out, relative to g*rho_ref*z_out [R L2 T-2 ~> Pa] + real, intent(in) :: rho_ref !< Reference density with which calculation are anomalous to [R ~> kg m-3] + real, intent(in) :: G_e !< Gravitational acceleration [L2 Z-1 T-2 ~> m s-2] + type(EOS_type), pointer :: EOS !< Equation of state structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(out) :: P_b !< Pressure at the bottom of the cell [R L2 T-2 ~> 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 :: dp ! Pressure thickness of the layer [R L2 T-2 ~> Pa] + real :: F_guess, F_l, F_r ! Fractional positions [nondim] + real :: GxRho ! The product of the gravitational acceleration and reference density [R L2 Z-1 T-2 ~> Pa m-1] + real :: Pa, Pa_left, Pa_right, Pa_tol ! Pressure anomalies, P = integral of g*(rho-rho_ref) dz [R L2 T-2 ~> Pa] + character(len=240) :: msg + + GxRho = G_e * rho_ref + + ! Anomalous pressure difference across whole cell + dp = frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, 1.0, EOS) + + P_b = P_t + dp ! Anomalous pressure at bottom of cell + + if (P_tgt <= P_t ) then + z_out = z_t + return + endif + + if (P_tgt >= P_b) then + z_out = z_b + return + endif + + F_l = 0. + 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.0e-5*US%m_to_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 ) + + z_out = z_t + ( z_b - z_t ) * F_guess + Pa = frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, F_guess, EOS) - ( P_tgt - P_t ) + + if (PaPa_right) then + write(msg,*) Pa_left,Pa,Pa_right,P_t-P_tgt,P_b-P_tgt + call MOM_error(FATAL, 'find_depth_of_pressure_in_cell out of bounds positive: /n'//msg) + elseif (Pa>0.) then + Pa_right = Pa + F_r = F_guess + else ! Pa == 0 + return + endif + F_guess = F_l - Pa_left / (Pa_right - Pa_left) * (F_r - F_l) + + enddo + +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 !< Potential temperature at the cell top [degC] + real, intent(in) :: T_b !< Potential temperature 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 [R ~> 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 [L2 Z-1 T-2 ~> m s-2] + real, intent(in) :: pos !< The fractional vertical position, 0 to 1 [nondim] + type(EOS_type), pointer :: EOS !< Equation of state structure + real :: fract_dp_at_pos !< The change in pressure from the layer top to + !! fractional position pos [R L2 T-2 ~> Pa] + ! Local variables + real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] + real :: dz ! Distance from the layer top [Z ~> m] + real :: top_weight, bottom_weight ! Fractional weights at quadrature points [nondim] + real :: rho_ave ! Average density [R ~> kg m-3] + real, dimension(5) :: T5 ! Temperatures at quadrature points [degC] + real, dimension(5) :: S5 ! Salinities at quadrature points [ppt] + real, dimension(5) :: p5 ! Pressures at quadrature points [R L2 T-2 ~> Pa] + real, dimension(5) :: rho5 ! Densities at quadrature points [R ~> kg m-3] + integer :: n + + do n=1,5 + ! Evaluate density at five quadrature points + bottom_weight = 0.25*real(n-1) * pos + top_weight = 1.0 - bottom_weight + ! Salinity and temperature points are linearly interpolated + S5(n) = top_weight * S_t + bottom_weight * S_b + T5(n) = top_weight * T_t + bottom_weight * T_b + p5(n) = ( top_weight * z_t + bottom_weight * z_b ) * ( G_e * rho_ref ) + enddo + call calculate_density(T5, S5, p5, rho5, EOS) + rho5(:) = rho5(:) !- rho_ref ! Work with anomalies relative to rho_ref + + ! Use Boole's rule to estimate the average density + rho_ave = C1_90*(7.0*(rho5(1)+rho5(5)) + 32.0*(rho5(2)+rho5(4)) + 12.0*rho5(3)) + + dz = ( z_t - z_b ) * pos + frac_dp_at_pos = G_e * dz * rho_ave +end function frac_dp_at_pos + end module MOM_density_integrals !> \namespace mom_density_integrals From d3e17902e12e25635fc7324122c3a85090ce55e7 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 13 May 2020 15:23:46 +0000 Subject: [PATCH 35/91] Use SZ macros in declarations - When converting from the two hor_index types to one (HII and HIO became HI) I retained the HI%isd:... declaration statements. We normally use `SZI_(G)` or `SZI_(HI)` so this switches to that style. --- src/core/MOM_density_integrals.F90 | 140 ++++++++++++++--------------- 1 file changed, 70 insertions(+), 70 deletions(-) diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index 76cee52dbd..486189b7f6 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -39,13 +39,13 @@ module MOM_density_integrals subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, US, dpa, & intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp) type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structures for the arrays - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: T !< Potential temperature referenced to the surface [degC] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: S !< Salinity [ppt] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: z_b !< Height at the bottom of the layer [Z ~> m] real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that is !! subtracted out to reduce the magnitude of each of the @@ -57,22 +57,22 @@ subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, US, dpa, !! [L2 Z-1 T-2 ~> m s-2] or [m2 Z-1 s-2 ~> m s-2] type(EOS_type), pointer :: EOS !< Equation of state structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(inout) :: dpa !< The change in the pressure anomaly !! across the layer [R L2 T-2 ~> Pa] or [Pa] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & optional, intent(inout) :: intz_dpa !< The integral through the thickness of the !! layer of the pressure anomaly relative to the !! anomaly at the top of the layer [R L2 Z T-2 ~> Pa m] - real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & + real, dimension(SZIB_(HI),SZJ_(HI)), & optional, intent(inout) :: 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 [R L2 T-2 ~> Pa] - real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & + real, dimension(SZI_(HI),SZJB_(HI)), & optional, intent(inout) :: 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 [R L2 T-2 ~> Pa] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] real, optional, intent(in) :: dz_neglect !< A minuscule thickness change [Z ~> m] logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to @@ -95,13 +95,13 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & EOS, US, dpa, intz_dpa, intx_dpa, inty_dpa, & bathyT, dz_neglect, useMassWghtInterp) type(hor_index_type), intent(in) :: HI !< Horizontal index type for input variables. - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: T !< Potential temperature of the layer [degC] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: S !< Salinity of the layer [ppt] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: z_b !< Height at the bottom of the layer [Z ~> m] real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that is !! subtracted out to reduce the magnitude @@ -113,22 +113,22 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & !! [L2 Z-1 T-2 ~> m s-2] or [m2 Z-1 s-2 ~> m s-2] type(EOS_type), pointer :: EOS !< Equation of state structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(inout) :: dpa !< The change in the pressure anomaly !! across the layer [R L2 T-2 ~> Pa] or [Pa] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & optional, intent(inout) :: intz_dpa !< The integral through the thickness of the !! layer of the pressure anomaly relative to the !! anomaly at the top of the layer [R L2 Z T-2 ~> Pa m] - real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & + real, dimension(SZIB_(HI),SZJ_(HI)), & optional, intent(inout) :: 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 [R L2 T-2 ~> Pa] - real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & + real, dimension(SZI_(HI),SZJB_(HI)), & optional, intent(inout) :: 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 [R L2 T-2 ~> Pa] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] real, optional, intent(in) :: dz_neglect !< A minuscule thickness change [Z ~> m] logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to @@ -298,17 +298,17 @@ 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, HI, EOS, US, dpa, & intz_dpa, intx_dpa, inty_dpa, useMassWghtInterp) type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structures for the input arrays - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: T_t !< Potential temperature at the cell top [degC] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: T_b !< Potential temperature at the cell bottom [degC] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: S_t !< Salinity at the cell top [ppt] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: S_b !< Salinity at the cell bottom [ppt] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: z_t !< The geometric height at the top of the layer [Z ~> m] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: z_b !< The geometric height at the bottom of the layer [Z ~> m] real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that is subtracted !! out to reduce the magnitude of each of the integrals. @@ -316,21 +316,21 @@ subroutine int_density_dz_generic_plm(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & !! 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 [L2 Z-1 T-2 ~> m s-2] real, intent(in) :: dz_subroundoff !< A minuscule thickness change [Z ~> m] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] type(EOS_type), pointer :: EOS !< Equation of state structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(inout) :: dpa !< The change in the pressure anomaly across the layer [R L2 T-2 ~> Pa] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & optional, intent(inout) :: intz_dpa !< The integral through the thickness of the layer of !! the pressure anomaly relative to the anomaly at the !! top of the layer [R L2 Z T-2 ~> Pa Z] - real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & + real, dimension(SZIB_(HI),SZJ_(HI)), & optional, intent(inout) :: 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 [R L2 T-2 ~> Pa] - real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & + real, dimension(SZI_(HI),SZJB_(HI)), & optional, intent(inout) :: 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 [R L2 T-2 ~> Pa] @@ -605,21 +605,21 @@ 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, HI, & EOS, US, dpa, intz_dpa, intx_dpa, inty_dpa) type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structures for the input arrays - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: T !< Potential temperature referenced to the surface [degC] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: T_t !< Potential temperature at the cell top [degC] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: T_b !< Potential temperature at the cell bottom [degC] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: S !< Salinity [ppt] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: S_t !< Salinity at the cell top [ppt] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: S_b !< Salinity at the cell bottom [ppt] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: z_t !< Height at the top of the layer [Z ~> m] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: z_b !< Height at the bottom of the layer [Z ~> m] real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that is !! subtracted out to reduce the magnitude of each of the integrals. @@ -628,17 +628,17 @@ subroutine int_density_dz_generic_ppm(T, T_t, T_b, S, S_t, S_b, & real, intent(in) :: G_e !< The Earth's gravitational acceleration [m s-2] type(EOS_type), pointer :: EOS !< Equation of state structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(inout) :: dpa !< The change in the pressure anomaly across the layer [R L2 T-2 ~> Pa] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & optional, intent(inout) :: intz_dpa !< The integral through the thickness of the layer of !! the pressure anomaly relative to the anomaly at the !! top of the layer [R L2 Z T-2 ~> Pa m] - real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & + real, dimension(SZIB_(HI),SZJ_(HI)), & optional, intent(inout) :: 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 [R L2 T-2 ~> Pa] - real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & + real, dimension(SZI_(HI),SZJB_(HI)), & optional, intent(inout) :: 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 [R L2 T-2 ~> Pa] @@ -1051,13 +1051,13 @@ subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, US, & dza, intp_dza, intx_dza, inty_dza, halo_size, & bathyP, dP_tiny, useMassWghtInterp) type(hor_index_type), intent(in) :: HI !< The horizontal index structure - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: T !< Potential temperature referenced to the surface [degC] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: S !< Salinity [ppt] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: p_t !< Pressure at the top of the layer [R L2 T-2 ~> Pa] or [Pa] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: p_b !< Pressure at the bottom of the layer [R L2 T-2 ~> Pa] or [Pa] real, intent(in) :: alpha_ref !< A mean specific volume that is subtracted out !! to reduce the magnitude of each of the integrals [R-1 ~> m3 kg-1] @@ -1065,23 +1065,23 @@ subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, US, & !! alpha_ref, but this reduces the effects of roundoff. type(EOS_type), pointer :: EOS !< Equation of state structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(inout) :: dza !< The change in the geopotential anomaly across !! the layer [L2 T-2 ~> m2 s-2] or [m2 s-2] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of the !! geopotential anomaly relative to the anomaly at the bottom of the !! layer [R L4 T-4 ~> Pa m2 s-2] or [Pa m2 s-2] - real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & + real, dimension(SZIB_(HI),SZJ_(HI)), & optional, intent(inout) :: 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 [L2 T-2 ~> m2 s-2] or [m2 s-2] - real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & + real, dimension(SZI_(HI),SZJB_(HI)), & optional, intent(inout) :: 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 [L2 T-2 ~> m2 s-2] or [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), & + real, dimension(SZI_(HI),SZJ_(HI)), & optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] or [Pa] real, optional, intent(in) :: dP_tiny !< A minuscule pressure change with !! the same units as p_t [R L2 T-2 ~> Pa] or [Pa] @@ -1109,13 +1109,13 @@ subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, d intp_dza, intx_dza, inty_dza, halo_size, & 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), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: T !< Potential temperature of the layer [degC] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: S !< Salinity of the layer [ppt] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: p_t !< Pressure atop the layer [R L2 T-2 ~> Pa] or [Pa] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: p_b !< Pressure below the layer [R L2 T-2 ~> Pa] or [Pa] real, intent(in) :: alpha_ref !< A mean specific volume that is subtracted out !! to reduce the magnitude of each of the integrals [R-1 ~> m3 kg-1] @@ -1124,23 +1124,23 @@ subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, d !! answers do change. type(EOS_type), pointer :: EOS !< Equation of state structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(inout) :: dza !< The change in the geopotential anomaly !! across the layer [L2 T-2 ~> m2 s-2] or [m2 s-2] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of !! the geopotential anomaly relative to the anomaly at the bottom of the !! layer [R L4 T-4 ~> Pa m2 s-2] or [Pa m2 s-2] - real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & + real, dimension(SZIB_(HI),SZJ_(HI)), & optional, intent(inout) :: 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 [L2 T-2 ~> m2 s-2] or [m2 s-2] - real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & + real, dimension(SZI_(HI),SZJB_(HI)), & optional, intent(inout) :: 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 [L2 T-2 ~> m2 s-2] or [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), & + real, dimension(SZI_(HI),SZJ_(HI)), & optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] or [Pa] real, optional, intent(in) :: dP_neglect !< A minuscule pressure change with !! the same units as p_t [R L2 T-2 ~> Pa] or [Pa] @@ -1324,17 +1324,17 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, dP_neglect, bathyP, HI, EOS, US, dza, & 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), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: T_t !< Potential temperature at the top of the layer [degC] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: T_b !< Potential temperature at the bottom of the layer [degC] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: S_t !< Salinity at the top the layer [ppt] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: S_b !< Salinity at the bottom the layer [ppt] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: p_t !< Pressure atop the layer [R L2 T-2 ~> Pa] or [Pa] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: p_b !< Pressure below the layer [R L2 T-2 ~> Pa] or [Pa] real, intent(in) :: alpha_ref !< A mean specific volume that is subtracted out !! to reduce the magnitude of each of the integrals [R-1 ~> m3 kg-1] @@ -1343,22 +1343,22 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, !! answers do change. real, intent(in) :: dP_neglect ! Pa] or [Pa] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] or [Pa] type(EOS_type), pointer :: EOS !< Equation of state structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & intent(inout) :: dza !< The change in the geopotential anomaly !! across the layer [L2 T-2 ~> m2 s-2] - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + real, dimension(SZI_(HI),SZJ_(HI)), & optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of !! the geopotential anomaly relative to the anomaly at the bottom of the !! layer [R L4 T-4 ~> Pa m2 s-2] or [Pa m2 s-2] - real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & + real, dimension(SZIB_(HI),SZJ_(HI)), & optional, intent(inout) :: 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 [L2 T-2 ~> m2 s-2] or [m2 s-2] - real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & + real, dimension(SZI_(HI),SZJB_(HI)), & optional, intent(inout) :: 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 [L2 T-2 ~> m2 s-2] or [m2 s-2] From 3e1f6b6db2966e00b24021246b4e6db72558d623 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 15 May 2020 16:12:05 +0000 Subject: [PATCH 36/91] Implemented elemental PLM functions - This adds elemental functions for cellwise operations within the PLM construction procedure which allows the operations to be accessed from outside of the ALE functions on different array shapes but recover bitwise identical results. - The older subroutines now use the functions and some optimizations were obtained in the process. --- src/ALE/MOM_ALE.F90 | 77 +++++---- src/ALE/PLM_functions.F90 | 318 ++++++++++++++++++++------------------ 2 files changed, 217 insertions(+), 178 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 1d9c66001b..7c4453a292 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -52,6 +52,7 @@ module MOM_ALE use regrid_consts, only : coordinateUnits, coordinateMode, state_dependent use regrid_edge_values, only : edge_values_implicit_h4 use PLM_functions, only : PLM_reconstruction, PLM_boundary_extrapolation +use PLM_functions, only : PLM_extrapolate_slope, PLM_monotonized_slope, PLM_slope_wa use PPM_functions, only : PPM_reconstruction, PPM_boundary_extrapolation implicit none ; private @@ -110,6 +111,7 @@ module MOM_ALE public ALE_build_grid public ALE_regrid_accelerated public ALE_remap_scalar +public ALE_PLM_edge_values public TS_PLM_edge_values public TS_PPM_edge_values public adjustGridForIntegrity @@ -1026,12 +1028,31 @@ subroutine TS_PLM_edge_values( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_extrap logical, intent(in) :: bdry_extrap !< If true, use high-order boundary !! extrapolation within boundary cells + call ALE_PLM_edge_values( CS, G, GV, h, tv%S, bdry_extrap, S_t, S_b ) + call ALE_PLM_edge_values( CS, G, GV, h, tv%T, bdry_extrap, T_t, T_b ) + +end subroutine TS_PLM_edge_values + +!> Calculate edge values (top and bottom of layer) 3d scalar array. +!! Boundary reconstructions are PCM unless bdry_extrap is true. +subroutine ALE_PLM_edge_values( CS, G, GV, h, Q, bdry_extrap, Q_t, Q_b ) + type(ALE_CS), intent(in) :: CS !< module 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 thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: Q !< 3d scalar array + logical, intent(in) :: bdry_extrap !< If true, use high-order boundary + !! extrapolation within boundary cells + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: Q_t !< Scalar at the top edge of each layer + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: Q_b !< Scalar at the bottom edge of each layer ! Local variables integer :: i, j, k - real :: hTmp(GV%ke) - real :: tmp(GV%ke) - real, dimension(CS%nk,2) :: ppol_E !Edge value of polynomial - real, dimension(CS%nk,2) :: ppol_coefs !Coefficients of polynomial + real :: slp(GV%ke) + real :: mslp real :: h_neglect if (.not.CS%answers_2018) then @@ -1042,40 +1063,36 @@ subroutine TS_PLM_edge_values( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_extrap h_neglect = GV%kg_m2_to_H*1.0e-30 endif - ! 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) + slp(1) = 0. + do k = 2, GV%ke-1 + slp(k) = PLM_slope_wa(h(i,j,k-1), h(i,j,k), h(i,j,k+1), h_neglect, Q(i,j,k-1), Q(i,j,k), Q(i,j,k+1)) enddo + slp(GV%ke) = 0. - ! 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) + do k = 2, GV%ke-1 + mslp = PLM_monotonized_slope(Q(i,j,k-1), Q(i,j,k), Q(i,j,k+1), slp(k-1), slp(k), slp(k+1)) + Q_t(i,j,k) = Q(i,j,k) - 0.5 * mslp + Q_b(i,j,k) = Q(i,j,k) + 0.5 * mslp enddo + if (bdry_extrap) then + mslp = - PLM_extrapolate_slope(h(i,j,2), h(i,j,1), h_neglect, Q(i,j,2), Q(i,j,1)) + Q_t(i,j,1) = Q(i,j,1) - 0.5 * mslp + Q_b(i,j,1) = Q(i,j,1) + 0.5 * mslp + mslp = PLM_extrapolate_slope(h(i,j,GV%ke-1), h(i,j,GV%ke), h_neglect, Q(i,j,GV%ke-1), Q(i,j,GV%ke)) + Q_t(i,j,GV%ke) = Q(i,j,GV%ke) - 0.5 * mslp + Q_b(i,j,GV%ke) = Q(i,j,GV%ke) + 0.5 * mslp + else + Q_t(i,j,1) = Q(i,j,1) + Q_b(i,j,1) = Q(i,j,1) + Q_t(i,j,GV%ke) = Q(i,j,GV%ke) + Q_b(i,j,GV%ke) = Q(i,j,GV%ke) + endif enddo ; enddo -end subroutine TS_PLM_edge_values +end subroutine ALE_PLM_edge_values !> Calculate edge values (top and bottom of layer) for T and S consistent with a PPM reconstruction !! in the vertical direction. Boundary reconstructions are PCM unless bdry_extrap is true. diff --git a/src/ALE/PLM_functions.F90 b/src/ALE/PLM_functions.F90 index e6bcbef331..952202d325 100644 --- a/src/ALE/PLM_functions.F90 +++ b/src/ALE/PLM_functions.F90 @@ -5,12 +5,168 @@ module PLM_functions implicit none ; private -public PLM_reconstruction, PLM_boundary_extrapolation +public PLM_boundary_extrapolation +public PLM_extrapolate_slope +public PLM_monotonized_slope +public PLM_reconstruction +public PLM_slope_wa +public PLM_slope_cw real, parameter :: hNeglect_dflt = 1.E-30 !< Default negligible cell thickness contains +!> Returns a limited PLM slope following White and Adcroft, 2008. [units of u] +!! Note that this is not the same as the Colella and Woodward method. +real elemental pure function PLM_slope_wa(h_l, h_c, h_r, h_neglect, u_l, u_c, u_r) + real, intent(in) :: h_l !< Thickness of left cell [units of grid thickness] + real, intent(in) :: h_c !< Thickness of center cell [units of grid thickness] + real, intent(in) :: h_r !< Thickness of right cell [units of grid thickness] + real, intent(in) :: h_neglect !< A negligible thickness [units of grid thickness] + real, intent(in) :: u_l !< Value of left cell [units of u] + real, intent(in) :: u_c !< Value of center cell [units of u] + real, intent(in) :: u_r !< Value of right cell [units of u] + ! Local variables + real :: sigma_l, sigma_c, sigma_r, u_min, u_max + + ! Side differences + sigma_r = u_r - u_c + sigma_l = u_c - u_l + + ! Quasi-second order difference + sigma_c = 2.0 * ( u_r - u_l ) * ( h_c / ( h_l + 2.0*h_c + h_r + h_neglect) ) + + ! Limit slope so that reconstructions are bounded by neighbors + u_min = min( u_l, u_c, u_r ) + u_max = max( u_l, u_c, u_r ) + if ( (sigma_l * sigma_r) > 0.0 ) then + ! This limits the slope so that the edge values are bounded by the + ! two cell averages spanning the edge. + PLM_slope_wa = sign( min( abs(sigma_c), 2.*min( u_c - u_min, u_max - u_c ) ), sigma_c ) + else + ! Extrema in the mean values require a PCM reconstruction avoid generating + ! larger extreme values. + PLM_slope_wa = 0.0 + endif + + ! This block tests to see if roundoff causes edge values to be out of bounds + if (u_c - 0.5*abs(PLM_slope_wa) < u_min .or. u_c + 0.5*abs(PLM_slope_wa) > u_max) then + PLM_slope_wa = PLM_slope_wa * ( 1. - epsilon(PLM_slope_wa) ) + endif + + ! An attempt to avoid inconsistency when the values become unrepresentable. + if (abs(PLM_slope_wa) < 1.E-140) PLM_slope_wa = 0. + +end function PLM_slope_wa + +!> Returns a limited PLM slope following Colella and Woodward 1984. +real elemental pure function PLM_slope_cw(h_l, h_c, h_r, h_neglect, u_l, u_c, u_r) + real, intent(in) :: h_l !< Thickness of left cell [units of grid thickness] + real, intent(in) :: h_c !< Thickness of center cell [units of grid thickness] + real, intent(in) :: h_r !< Thickness of right cell [units of grid thickness] + real, intent(in) :: h_neglect !< A negligible thickness [units of grid thickness] + real, intent(in) :: u_l !< Value of left cell [units of u] + real, intent(in) :: u_c !< Value of center cell [units of u] + real, intent(in) :: u_r !< Value of right cell [units of u] + ! Local variables + real :: sigma_l, sigma_c, sigma_r, u_min, u_max, h_cn + + h_cn = h_c + h_neglect + + ! Side differences + sigma_r = u_r - u_c + sigma_l = u_c - u_l + + ! This is the second order slope given by equation 1.7 of + ! Piecewise Parabolic Method, Colella and Woodward (1984), + ! http://dx.doi.org/10.1016/0021-991(84)90143-8. + ! For uniform resolution it simplifies to ( u_r - u_l )/2 . + sigma_c = ( h_c / ( h_cn + ( h_l + h_r ) ) ) * ( & + ( 2.*h_l + h_c ) / ( h_r + h_cn ) * sigma_r & + + ( 2.*h_r + h_c ) / ( h_l + h_cn ) * sigma_l ) + + ! Limit slope so that reconstructions are bounded by neighbors + u_min = min( u_l, u_c, u_r ) + u_max = max( u_l, u_c, u_r ) + if ( (sigma_l * sigma_r) > 0.0 ) then + ! This limits the slope so that the edge values are bounded by the + ! two cell averages spanning the edge. + PLM_slope_cw = sign( min( abs(sigma_c), 2.*min( u_c - u_min, u_max - u_c ) ), sigma_c ) + else + ! Extrema in the mean values require a PCM reconstruction avoid generating + ! larger extreme values. + PLM_slope_cw = 0.0 + endif + + ! This block tests to see if roundoff causes edge values to be out of bounds + if (u_c - 0.5*abs(PLM_slope_cw) < u_min .or. u_c + 0.5*abs(PLM_slope_cw) > u_max) then + PLM_slope_cw = PLM_slope_cw * ( 1. - epsilon(PLM_slope_cw) ) + endif + + ! An attempt to avoid inconsistency when the values become unrepresentable. + if (abs(PLM_slope_cw) < 1.E-140) PLM_slope_cw = 0. + +end function PLM_slope_cw + +!> Returns a limited PLM slope following Colella and Woodward 1984. +real elemental pure function PLM_monotonized_slope(u_l, u_c, u_r, s_l, s_c, s_r) + real, intent(in) :: u_l !< Value of left cell [units of u] + real, intent(in) :: u_c !< Value of center cell [units of u] + real, intent(in) :: u_r !< Value of right cell [units of u] + real, intent(in) :: s_l !< PLM slope of left cell [units of u] + real, intent(in) :: s_c !< PLM slope of center cell [units of u] + real, intent(in) :: s_r !< PLM slope of right cell [units of u] + ! Local variables + real :: e_r, e_l, edge, almost_two, slp + + almost_two = 2. * ( 1. - epsilon(s_c) ) + + ! Edge values of neighbors abutting this cell + e_r = u_l + 0.5*s_l + e_l = u_r - 0.5*s_r + slp = abs(s_c) + + ! Check that left edge is between right edge of cell to the left and this cell mean + edge = u_c - 0.5 * s_c + if ( ( edge - e_r ) * ( u_c - edge ) < 0. ) then + edge = 0.5 * ( edge + e_r ) + slp = min( slp, abs( edge - u_c ) * almost_two ) + endif + + ! Check that right edge is between left edge of cell to the right and this cell mean + edge = u_c + 0.5 * s_c + if ( ( edge - u_c ) * ( e_l - edge ) < 0. ) then + edge = 0.5 * ( edge + e_l ) + slp = min( slp, abs( edge - u_c ) * almost_two ) + endif + + PLM_monotonized_slope = sign( slp, s_c ) + +end function PLM_monotonized_slope + +!> Returns a PLM slope using h2 extrapolation from a cell to the left. +!! Use the negative to extrapolate from the a cell to the right. +real elemental pure function PLM_extrapolate_slope(h_l, h_c, h_neglect, u_l, u_c) + real, intent(in) :: h_l !< Thickness of left cell [units of grid thickness] + real, intent(in) :: h_c !< Thickness of center cell [units of grid thickness] + real, intent(in) :: h_neglect !< A negligible thickness [units of grid thickness] + real, intent(in) :: u_l !< Value of left cell [units of u] + real, intent(in) :: u_c !< Value of center cell [units of u] + ! Local variables + real :: left_edge, hl, hc + + ! Avoid division by zero for vanished cells + hl = h_l + h_neglect + hc = h_c + h_neglect + + ! The h2 scheme is used to compute the left edge value + left_edge = (u_l*hc + u_c*hl) / (hl + hc) + + PLM_extrapolate_slope = 2.0 * ( u_c - left_edge ) + +end function PLM_extrapolate_slope + + !> Reconstruction by linear polynomials within each cell !! !! It is assumed that the size of the array 'u' is equal to the number of cells @@ -31,147 +187,43 @@ subroutine PLM_reconstruction( N, h, u, edge_values, ppoly_coef, h_neglect ) integer :: k ! loop index real :: u_l, u_c, u_r ! left, center and right cell averages real :: h_l, h_c, h_r, h_cn ! left, center and right cell widths - real :: sigma_l, sigma_c, sigma_r ! left, center and right - ! van Leer slopes real :: slope ! retained PLM slope real :: a, b ! auxiliary variables real :: u_min, u_max, e_l, e_r, edge - real :: almost_one, almost_two + real :: almost_one real, dimension(N) :: slp, mslp real :: hNeglect hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect almost_one = 1. - epsilon(slope) - almost_two = 2. * almost_one ! Loop on interior cells do k = 2,N-1 - - ! Get cell averages - u_l = u(k-1) ; u_c = u(k) ; u_r = u(k+1) - - ! Get cell widths - h_l = h(k-1) ; h_c = h(k) ; h_r = h(k+1) - h_cn = max( h_c, hNeglect ) ! To avoid division by zero - - ! Side differences - sigma_r = u_r - u_c - sigma_l = u_c - u_l - - ! This is the second order slope given by equation 1.7 of - ! Piecewise Parabolic Method, Colella and Woodward (1984), - ! http://dx.doi.org/10.1016/0021-991(84)90143-8. - ! For uniform resolution it simplifies to ( u_r - u_l )/2 . - ! sigma_c = ( h_c / ( h_cn + ( h_l + h_r ) ) ) * ( & - ! ( 2.*h_l + h_c ) / ( h_r + h_cn ) * sigma_r & - ! + ( 2.*h_r + h_c ) / ( h_l + h_cn ) * sigma_l ) - - ! This is the original estimate of the second order slope from Laurent - ! but multiplied by h_c - sigma_c = 2.0 * ( u_r - u_l ) * ( h_c / ( h_l + 2.0*h_c + h_r + hNeglect) ) - - if ( (sigma_l * sigma_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( u_l, u_c, u_r ) - u_max = max( u_l, u_c, u_r ) - slope = sign( min( abs(sigma_c), 2.*min( u_c - u_min, u_max - u_c ) ), sigma_c ) - else - ! Extrema in the mean values require a PCM reconstruction avoid generating - ! larger extreme values. - slope = 0.0 - 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 ) - u_max = max( u_l, u_c, u_r ) - if (u_c - 0.5*abs(slope) < u_min .or. u_c + 0.5*abs(slope) > u_max) then - slope = slope * almost_one - endif - - ! An attempt to avoid inconsistency when the values become unrepresentable. - if (abs(slope) < 1.E-140) slope = 0. - - ! Safety check - this block really should not be needed ... -! if (u_c - 0.5*abs(slope) < u_min .or. u_c + 0.5*abs(slope) > u_max) then -! write(0,*) 'l,c,r=',u_l,u_c,u_r -! write(0,*) 'min,max=',u_min,u_max -! write(0,*) 'slp=',slope -! sigma_l = u_c-0.5*abs(slope) -! sigma_r = u_c+0.5*abs(slope) -! write(0,*) 'lo,hi=',sigma_l,sigma_r -! write(0,*) 'elo,ehi=',sigma_l-u_min,sigma_r-u_max -! stop 'Limiter failed!' -! endif - - slp(k) = slope - edge_values(k,1) = u_c - 0.5 * slope - edge_values(k,2) = u_c + 0.5 * slope - + slp(k) = PLM_slope_wa(h(k-1), h(k), h(k+1), hNeglect, u(k-1), u(k), u(k+1)) enddo ! end loop on interior cells - ! Boundary cells use PCM. Extrapolation is handled in a later routine. + ! Boundary cells use PCM. Extrapolation is handled after monotonization. slp(1) = 0. - edge_values(1,2) = u(1) slp(N) = 0. - edge_values(N,1) = u(N) ! This loop adjusts the slope so that edge values are monotonic. do K = 2, N-1 - u_l = u(k-1) ; u_c = u(k) ; u_r = u(k+1) - e_r = edge_values(k-1,2) ! Right edge from cell k-1 - e_l = edge_values(k+1,1) ! Left edge from cell k - mslp(k) = abs(slp(k)) - u_min = min(e_r, u_c) - u_max = max(e_r, u_c) - edge = u_c - 0.5 * slp(k) - if ( ( edge - e_r ) * ( u_c - edge ) < 0. ) then - edge = 0.5 * ( edge + e_r ) ! * almost_one? - mslp(k) = min( mslp(k), abs( edge - u_c ) * almost_two ) - endif - edge = u_c + 0.5 * slp(k) - if ( ( edge - u_c ) * ( e_l - edge ) < 0. ) then - edge = 0.5 * ( edge + e_l ) ! * almost_one? - mslp(k) = min( mslp(k), abs( edge - u_c ) * almost_two ) - endif + mslp(k) = PLM_monotonized_slope( u(k-1), u(k), u(k+1), slp(k-1), slp(k), slp(k+1) ) enddo ! end loop on interior cells mslp(1) = 0. mslp(N) = 0. - ! Check that the above adjustment worked -! do K = 2, N-1 -! u_r = u(k-1) + 0.5 * sign( mslp(k-1), slp(k-1) ) ! Right edge from cell k-1 -! u_l = u(k) - 0.5 * sign( mslp(k), slp(k) ) ! Left edge from cell k -! if ( (u(k)-u(k-1)) * (u_l-u_r) < 0. ) then -! stop 'Adjustment failed!' -! endif -! enddo ! end loop on interior cells - ! Store and return edge values and polynomial coefficients. edge_values(1,1) = u(1) edge_values(1,2) = u(1) ppoly_coef(1,1) = u(1) ppoly_coef(1,2) = 0. do k = 2, N-1 - slope = sign( mslp(k), slp(k) ) + slope = mslp(k) u_l = u(k) - 0.5 * slope ! Left edge value of cell k u_r = u(k) + 0.5 * slope ! Right edge value of cell k - ! Check that final edge values are bounded - u_min = min( u(k-1), u(k) ) - u_max = max( u(k-1), u(k) ) - if (u_lu_max) then - write(0,*) 'u(k-1)=',u(k-1),'u(k)=',u(k),'slp=',slp(k),'u_l=',u_l - stop 'Left edge out of bounds' - endif - u_min = min( u(k+1), u(k) ) - u_max = max( u(k+1), u(k) ) - if (u_ru_max) then - write(0,*) 'u(k)=',u(k),'u(k+1)=',u(k+1),'slp=',slp(k),'u_r=',u_r - stop 'Right edge out of bounds' - endif - edge_values(k,1) = u_l edge_values(k,2) = u_r ppoly_coef(k,1) = u_l @@ -201,7 +253,6 @@ end subroutine PLM_reconstruction !! !! 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, edge_values, ppoly_coef, h_neglect ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) @@ -213,55 +264,26 @@ subroutine PLM_boundary_extrapolation( N, h, u, edge_values, ppoly_coef, h_negle real, optional, intent(in) :: h_neglect !< A negligibly small width for !! the purpose of cell reconstructions !! in the same units as h - ! Local variables - real :: u0, u1 ! cell averages - real :: h0, h1 ! corresponding cell widths real :: slope ! retained PLM slope real :: hNeglect hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect - ! ----------------------------------------- - ! Left edge value in the left boundary cell - ! ----------------------------------------- - h0 = h(1) + hNeglect - h1 = h(2) + hNeglect - - u0 = u(1) - u1 = u(2) - - ! The h2 scheme is used to compute the right edge value - edge_values(1,2) = (u0*h1 + u1*h0) / (h0 + h1) + ! Extrapolate from 2 to 1 to estimate slope + slope = - PLM_extrapolate_slope( h(2), h(1), hNeglect, u(2), u(1) ) - ! The standard PLM slope is computed as a first estimate for the - ! reconstruction within the cell - slope = 2.0 * ( edge_values(1,2) - u0 ) - - edge_values(1,1) = u0 - 0.5 * slope - edge_values(1,2) = u0 + 0.5 * slope + edge_values(1,1) = u(1) - 0.5 * slope + edge_values(1,2) = u(1) + 0.5 * slope ppoly_coef(1,1) = edge_values(1,1) ppoly_coef(1,2) = edge_values(1,2) - edge_values(1,1) - ! ------------------------------------------ - ! Right edge value in the left boundary cell - ! ------------------------------------------ - h0 = h(N-1) + hNeglect - h1 = h(N) + hNeglect - - u0 = u(N-1) - u1 = u(N) - - ! The h2 scheme is used to compute the right edge value - edge_values(N,1) = (u0*h1 + u1*h0) / (h0 + h1) - - ! The standard PLM slope is computed as a first estimate for the - ! reconstruction within the cell - slope = 2.0 * ( u1 - edge_values(N,1) ) + ! Extrapolate from N-1 to N to estimate slope + slope = PLM_extrapolate_slope( h(N-1), h(N), hNeglect, u(N-1), u(N) ) - edge_values(N,1) = u1 - 0.5 * slope - edge_values(N,2) = u1 + 0.5 * slope + edge_values(N,1) = u(N) - 0.5 * slope + edge_values(N,2) = u(N) + 0.5 * slope ppoly_coef(N,1) = edge_values(N,1) ppoly_coef(N,2) = edge_values(N,2) - edge_values(N,1) From 59308551e4380c93db1f82f3ad9f09c6bbc67ad7 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 15 May 2020 16:13:42 +0000 Subject: [PATCH 37/91] Add time for unit_tests - Out of curiosity I want to be sure these weren't implicated in the long initialization cost. --- src/core/MOM.F90 | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 4a98dbea6f..a9b9c7fec4 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -406,6 +406,7 @@ module MOM integer :: id_clock_ALE integer :: id_clock_other integer :: id_clock_offline_tracer +integer :: id_clock_unit_tests !>@} contains @@ -1720,7 +1721,10 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "If True, exercises unit tests at model start up.", & default=.false., debuggingParam=.true.) if (do_unit_tests) then + id_clock_unit_tests = cpu_clock_id('(Ocean unit tests)', grain=CLOCK_MODULE) + call cpu_clock_begin(id_clock_unit_tests) call unit_tests(verbosity) + call cpu_clock_end(id_clock_unit_tests) endif call get_param(param_file, "MOM", "SPLIT", CS%split, & From a9d0caa990458fdeb0df29aa8c3cdfc574830f42 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 20 May 2020 15:01:10 +0000 Subject: [PATCH 38/91] Fixed index capitalization in int_density_dz_generic_plm() - Soft index convention was not properly implemented in original PLM density integrals. Fixed to avoid confusion. --- src/core/MOM_density_integrals.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index 486189b7f6..862097eeb2 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -416,7 +416,7 @@ subroutine int_density_dz_generic_plm(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & call calculate_density(T5, S5, p5, r5, 1, (ieq-isq+2)*5, EOS, rho_ref=rho_ref_mks) endif - do i=isq,ieq+1 + do i=Isq,Ieq+1 ! Use Boole's rule to estimate the pressure anomaly change. rho_anom = C1_90*(7.0*(r5(i*5+1)+r5(i*5+5)) + 32.0*(r5(i*5+2)+r5(i*5+4)) + 12.0*r5(i*5+3)) dpa(i,j) = G_e*dz(i)*rho_anom @@ -507,7 +507,7 @@ subroutine int_density_dz_generic_plm(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & 12.0*r15(pos+3))) enddo ! Use Boole's rule to integrate the bottom pressure anomaly values in x. - intx_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & + intx_dpa(I,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & 12.0*intz(3)) enddo enddo ; endif @@ -591,7 +591,7 @@ subroutine int_density_dz_generic_plm(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & 12.0*r15(pos+3))) enddo ! Use Boole's rule to integrate the values. - inty_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & + inty_dpa(i,J) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & 12.0*intz(3)) enddo enddo ; endif From 7fbcb013e69fff1e0dc2fcbaae5086caa373d753 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 20 May 2020 15:04:58 +0000 Subject: [PATCH 39/91] Re-used pre-computed weights in int_density_dz_generic_plm() - Probably makes no difference but we re-computed weights repeatedly even though we'd pre-computed them (and used only once). - Reduces number of local variables. --- src/core/MOM_density_integrals.F90 | 17 ++++++----------- 1 file changed, 6 insertions(+), 11 deletions(-) diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index 862097eeb2..7e9891486b 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -373,7 +373,6 @@ subroutine int_density_dz_generic_plm(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & real :: dz(HI%iscB:HI%iecB+1) ! Layer thicknesses at tracer points [Z ~> m] real :: dz_x(5,HI%iscB:HI%iecB) ! Layer thicknesses along an x-line of subrid locations [Z ~> m] real :: dz_y(5,HI%isc:HI%iec) ! Layer thicknesses along a y-line of subrid locations [Z ~> m] - real :: weight_t, weight_b ! Non-dimensional weights of the top and bottom [nondim] real :: massWeightToggle ! A non-dimensional toggle factor (0 or 1) [nondim] real :: Ttl, Tbl, Ttr, Tbr ! Temperatures at the velocity cell corners [degC] real :: Stl, Sbl, Str, Sbr ! Salinities at the velocity cell corners [ppt] @@ -460,7 +459,7 @@ subroutine int_density_dz_generic_plm(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & endif do m=2,4 - w_left = 0.25*real(5-m) ; w_right = 1.0-w_left + w_left = wt_t(m) ; w_right = wt_b(m) dz_x(m,i) = w_left*(z_t(i,j) - z_b(i,j)) + w_right*(z_t(i+1,j) - z_b(i+1,j)) ! Salinity and temperature points are linearly interpolated in @@ -483,10 +482,8 @@ subroutine int_density_dz_generic_plm(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & ! Salinity and temperature (linear interpolation in the vertical) do n=2,4 - weight_t = 0.25 * real(5-n) - weight_b = 1.0 - weight_t - S15(pos+n) = weight_t * S15(pos+1) + weight_b * S15(pos+5) - T15(pos+n) = weight_t * T15(pos+1) + weight_b * T15(pos+5) + S15(pos+n) = wt_t(n) * S15(pos+1) + wt_b(n) * S15(pos+5) + T15(pos+n) = wt_t(n) * T15(pos+1) + wt_b(n) * T15(pos+5) enddo enddo enddo @@ -543,7 +540,7 @@ subroutine int_density_dz_generic_plm(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & endif do m=2,4 - w_left = 0.25*real(5-m) ; w_right = 1.0-w_left + w_left = wt_t(m) ; w_right = wt_b(m) dz_y(m,i) = w_left*(z_t(i,j) - z_b(i,j)) + w_right*(z_t(i,j+1) - z_b(i,j+1)) ! Salinity and temperature points are linearly interpolated in @@ -564,10 +561,8 @@ subroutine int_density_dz_generic_plm(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & ! Salinity and temperature (linear interpolation in the vertical) do n=2,4 - weight_t = 0.25 * real(5-n) - weight_b = 1.0 - weight_t - S15(pos+n) = weight_t * S15(pos+1) + weight_b * S15(pos+5) - T15(pos+n) = weight_t * T15(pos+1) + weight_b * T15(pos+5) + S15(pos+n) = wt_t(n) * S15(pos+1) + wt_b(n) * S15(pos+5) + T15(pos+n) = wt_t(n) * T15(pos+1) + wt_b(n) * T15(pos+5) enddo enddo enddo From d25a36b2126a3640f63aaa6ce2156d5c2162b5c7 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 20 May 2020 21:30:42 +0000 Subject: [PATCH 40/91] Adds the PPM form of PGF by quadrature - Removes (now) unused functions for quadrature and polynomial evaluation - Has been tested by setting the logical use_PPM=.false. - reproduces PLM mode bitwise --- src/core/MOM_PressureForce_analytic_FV.F90 | 5 +- src/core/MOM_density_integrals.F90 | 518 ++++++++------------- 2 files changed, 197 insertions(+), 326 deletions(-) diff --git a/src/core/MOM_PressureForce_analytic_FV.F90 b/src/core/MOM_PressureForce_analytic_FV.F90 index 05dac0c0c3..160fe1c20d 100644 --- a/src/core/MOM_PressureForce_analytic_FV.F90 +++ b/src/core/MOM_PressureForce_analytic_FV.F90 @@ -647,8 +647,9 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at elseif ( CS%Recon_Scheme == 2 ) then 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, tv%eqn_of_state, US, dpa, & - intz_dpa, intx_dpa, inty_dpa) + rho_ref, CS%Rho0, GV%g_Earth, dz_neglect, G%bathyT, & + G%HI, tv%eqn_of_state, US, dpa, intz_dpa, intx_dpa, inty_dpa, & + useMassWghtInterp=CS%useMassWghtInterp) endif else call int_density_dz(tv_tmp%T(:,:,k), tv_tmp%S(:,:,k), e(:,:,K), e(:,:,K+1), & diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index 7e9891486b..4c5120ba09 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -596,9 +596,9 @@ end subroutine int_density_dz_generic_plm !> 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, HI, & - EOS, US, dpa, intz_dpa, intx_dpa, inty_dpa) +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, dz_subroundoff, bathyT, HI, EOS, US, & + dpa, intz_dpa, intx_dpa, inty_dpa, useMassWghtInterp) type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structures for the input arrays real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: T !< Potential temperature referenced to the surface [degC] @@ -621,6 +621,9 @@ subroutine int_density_dz_generic_ppm(T, T_t, T_b, S, S_t, S_b, & real, intent(in) :: rho_0 !< A density [R ~> kg m-3] or [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] + real, intent(in) :: dz_subroundoff !< A minuscule thickness change [Z ~> m] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] type(EOS_type), pointer :: EOS !< Equation of state structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(HI),SZJ_(HI)), & @@ -637,6 +640,8 @@ subroutine int_density_dz_generic_ppm(T, T_t, T_b, S, S_t, S_b, & optional, intent(inout) :: 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 [R L2 T-2 ~> 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 @@ -645,75 +650,74 @@ subroutine int_density_dz_generic_ppm(T, T_t, T_b, S, S_t, S_b, & ! of the accelerations, and in the pressure used to calculated density (the ! latter being -z*rho_0*G_e). These two uses could be separated if need be. ! -! It is assumed that the salinity and temperature profiles are linear in the +! It is assumed that the salinity and temperature profiles are parabolic in the ! vertical. The top and bottom values within each layer are provided and -! a linear interpolation is used to compute intermediate values. - -!### Please note that this subroutine has not been verified to work properly! +! a parabolic interpolation is used to compute intermediate values. ! Local variables - real :: T5(5), S5(5) - real :: p5(5) ! Pressures at five quadrature points, never rescaled from Pa [Pa] - real :: r5(5) ! Density anomalies from rho_ref at quadrature points [R ~> kg m-3] or [kg m-3] - real :: rho_anom ! The integrated density anomaly [R ~> kg m-3] or [kg m-3] + real :: T5(5) ! Temperatures along a line of subgrid locations [degC] + real :: S5(5) ! Salinities along a line of subgrid locations [ppt] + real :: p5(5) ! Pressures at five quadrature points, never rescaled from Pa [Pa] + real :: r5(5) ! Density anomalies from rho_ref at quadrature points [R ~> kg m-3] or [kg m-3] + real :: wt_t(5), wt_b(5) ! Top and bottom weights [nondim] + real :: rho_anom ! The integrated density anomaly [R ~> kg m-3] or [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 [R L2 T-2 ~> Pa] or [Pa] + real :: intz(5) ! The gravitational acceleration times the integrals of density + ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa] or [Pa] real, parameter :: C1_90 = 1.0/90.0 ! Rational constants. - real :: GxRho ! The gravitational acceleration times density and unit conversion factors [Pa Z-1 ~> kg m-2 s-2] - real :: I_Rho ! The inverse of the Boussinesq density [R-1 ~> m3 kg-1] or [m3 kg-1] - real :: rho_scale ! A scaling factor for densities from kg m-3 to R [R m3 kg-1 ~> 1] + real :: GxRho ! The gravitational acceleration times density and unit conversion factors [Pa Z-1 ~> kg m-2 s-2] + real :: I_Rho ! The inverse of the Boussinesq density [R-1 ~> m3 kg-1] or [m3 kg-1] + real :: rho_scale ! A scaling factor for densities from kg m-3 to R [R m3 kg-1 ~> 1] real :: rho_ref_mks ! The reference density in MKS units, never rescaled from kg m-3 [kg m-3] - real :: dz - real :: weight_t, weight_b - 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 - integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, m, n - real, dimension(4) :: x, y - real, dimension(9) :: S_node, T_node, p_node, r_node - - - call MOM_error(FATAL, & - "int_density_dz_generic_ppm: the implementation is not done yet, contact developer") + real :: dz ! Layer thicknesses at tracer points [Z ~> m] + real :: massWeightToggle ! A non-dimensional toggle factor (0 or 1) [nondim] + real :: Ttl, Tbl, Tml, Ttr, Tbr, Tmr ! Temperatures at the velocity cell corners [degC] + real :: Stl, Sbl, Sml, Str, Sbr, Smr ! Salinities at the velocity cell corners [ppt] + real :: s6 ! PPM curvature coefficient for S [ppt] + real :: t6 ! PPM curvature coefficient for T [degC] + real :: T_top, T_mn, T_bot ! Left edge, cell mean and right edge values used in PPM reconstructions of T + real :: S_top, S_mn, S_bot ! Left edge, cell mean and right edge values used in PPM reconstructions of S + 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 + logical :: use_PPM - ! These array bounds work for the indexing convention of the input arrays, but - ! on the computational domain defined for the output arrays. - Isq = HI%IscB ; Ieq = HI%IecB - Jsq = HI%JscB ; Jeq = HI%JecB - is = HI%isc ; ie = HI%iec - js = HI%jsc ; je = HI%jec + Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB rho_scale = US%kg_m3_to_R GxRho = US%RL2_T2_to_Pa * G_e * rho_0 rho_ref_mks = rho_ref * US%R_to_kg_m3 I_Rho = 1.0 / rho_0 + massWeightToggle = 0. + if (present(useMassWghtInterp)) then + if (useMassWghtInterp) massWeightToggle = 1. + endif + + ! In event PPM calculation is bypassed with use_PPM=False + s6 = 0. + t6 = 0. + use_PPM = .true. ! This is a place-holder to allow later re-use of this function + + do n = 1, 5 + wt_t(n) = 0.25 * real(5-n) + wt_b(n) = 1.0 - wt_t(n) + enddo ! 1. Compute vertical integrals do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + if (use_PPM) then + ! Curvature coefficient of the parabolas + s6 = 3.0 * ( 2.0*S(i,j) - ( S_t(i,j) + S_b(i,j) ) ) + t6 = 3.0 * ( 2.0*T(i,j) - ( T_t(i,j) + T_b(i,j) ) ) + endif dz = z_t(i,j) - z_b(i,j) - - ! Coefficients of the parabola for S - s0 = S_t(i,j) - s1 = 6.0 * S(i,j) - 4.0 * S_t(i,j) - 2.0 * S_b(i,j) - s2 = 3.0 * ( S_t(i,j) + S_b(i,j) - 2.0*S(i,j) ) - - ! Coefficients of the parabola for T - t0 = T_t(i,j) - t1 = 6.0 * T(i,j) - 4.0 * T_t(i,j) - 2.0 * T_b(i,j) - t2 = 3.0 * ( T_t(i,j) + T_b(i,j) - 2.0*T(i,j) ) - do n=1,5 p5(n) = -GxRho*(z_t(i,j) - 0.25*real(n-1)*dz) - - ! Parabolic reconstruction for T and S - xi = 0.25 * ( n - 1 ) - S5(n) = s0 + s1 * xi + s2 * xi**2 - T5(n) = t0 + t1 * xi + t2 * xi**2 + ! Salinity and temperature points are reconstructed with PPM + S5(n) = wt_t(n) * S_t(i,j) + wt_b(n) * ( S_b(i,j) + s6 * wt_t(n) ) + T5(n) = wt_t(n) * T_t(i,j) + wt_b(n) * ( T_b(i,j) + t6 * wt_t(n) ) enddo - if (rho_scale /= 1.0) then call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) else @@ -722,319 +726,185 @@ subroutine int_density_dz_generic_ppm(T, T_t, T_b, S, S_t, S_b, & ! Use Boole's rule to estimate the pressure anomaly change. rho_anom = C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) - dpa(i,j) = G_e*dz*rho_anom - - ! Use a Boole's-rule-like fifth-order accurate estimate of - ! the double integral of the pressure anomaly. - if (present(intz_dpa)) intz_dpa(i,j) = 0.5*G_e*dz**2 * & - (rho_anom - C1_90*(16.0*(r5(4)-r5(2)) + 7.0*(r5(5)-r5(1))) ) - + if (present(intz_dpa)) then + ! Use a Boole's-rule-like fifth-order accurate estimate of + ! the double integral of the pressure anomaly. + intz_dpa(i,j) = 0.5*G_e*dz**2 * & + (rho_anom - C1_90*(16.0*(r5(4)-r5(2)) + 7.0*(r5(5)-r5(1))) ) + endif enddo ; enddo ! end loops on j and i ! 2. Compute horizontal integrals in the x direction - if (present(intx_dpa)) then ; do j=js,je ; do I=Isq,Ieq - intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) + if (present(intx_dpa)) then ; do j=HI%jsc,HI%jec ; do I=Isq,Ieq + ! Corner values of T and S + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, almost like thickness + ! weighting. + ! Note: To work in terrain following coordinates we could offset + ! this distance by the layer thickness to replicate other models. + hWght = massWeightToggle * & + max(0., -bathyT(i,j)-z_t(i+1,j), -bathyT(i+1,j)-z_t(i,j)) + if (hWght > 0.) then + hL = (z_t(i,j) - z_b(i,j)) + dz_subroundoff + hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_subroundoff + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1./( hWght*(hR + hL) + hL*hR ) + Ttl = ( (hWght*hR)*T_t(i+1,j) + (hWght*hL + hR*hL)*T_t(i,j) ) * iDenom + Tbl = ( (hWght*hR)*T_b(i+1,j) + (hWght*hL + hR*hL)*T_b(i,j) ) * iDenom + Tml = ( (hWght*hR)*T(i+1,j) + (hWght*hL + hR*hL)*T(i,j) ) * iDenom + Ttr = ( (hWght*hL)*T_t(i,j) + (hWght*hR + hR*hL)*T_t(i+1,j) ) * iDenom + Tbr = ( (hWght*hL)*T_b(i,j) + (hWght*hR + hR*hL)*T_b(i+1,j) ) * iDenom + Tmr = ( (hWght*hL)*T(i,j) + (hWght*hR + hR*hL)*T(i+1,j) ) * iDenom + Stl = ( (hWght*hR)*S_t(i+1,j) + (hWght*hL + hR*hL)*S_t(i,j) ) * iDenom + Sbl = ( (hWght*hR)*S_b(i+1,j) + (hWght*hL + hR*hL)*S_b(i,j) ) * iDenom + Sml = ( (hWght*hR)*S(i+1,j) + (hWght*hL + hR*hL)*S(i,j) ) * iDenom + Str = ( (hWght*hL)*S_t(i,j) + (hWght*hR + hR*hL)*S_t(i+1,j) ) * iDenom + Sbr = ( (hWght*hL)*S_b(i,j) + (hWght*hR + hR*hL)*S_b(i+1,j) ) * iDenom + Smr = ( (hWght*hL)*S(i,j) + (hWght*hR + hR*hL)*S(i+1,j) ) * iDenom + else + Ttl = T_t(i,j); Tbl = T_b(i,j); Ttr = T_t(i+1,j); Tbr = T_b(i+1,j) + Tml = T(i,j); Tmr = T(i+1,j) + Stl = S_t(i,j); Sbl = S_b(i,j); Str = S_t(i+1,j); Sbr = S_b(i+1,j) + Sml = S(i,j); Smr = S(i+1,j) + endif + do m=2,4 - w_left = 0.25*real(5-m) ; w_right = 1.0-w_left - dz = w_left*(z_t(i,j) - z_b(i,j)) + w_right*(z_t(i+1,j) - z_b(i+1,j)) + w_left = wt_t(m) ; w_right = wt_b(m) ! Salinity and temperature points are linearly interpolated in ! the horizontal. The subscript (1) refers to the top value in ! the vertical profile while subscript (5) refers to the bottom ! value in the vertical profile. - T_top = w_left*T_t(i,j) + w_right*T_t(i+1,j) - T_mid = w_left*T(i,j) + w_right*T(i+1,j) - T_bot = w_left*T_b(i,j) + w_right*T_b(i+1,j) - - S_top = w_left*S_t(i,j) + w_right*S_t(i+1,j) - S_mid = w_left*S(i,j) + w_right*S(i+1,j) - S_bot = w_left*S_b(i,j) + w_right*S_b(i+1,j) + T_top = w_left*Ttl + w_right*Ttr + T_mn = w_left*Tml + w_right*Tmr + T_bot = w_left*Tbl + w_right*Tbr - p5(1) = -GxRho*(w_left*z_t(i,j) + w_right*z_t(i+1,j)) + S_top = w_left*Stl + w_right*Str + S_mn = w_left*Sml + w_right*Smr + S_bot = w_left*Sbl + w_right*Sbr ! Pressure + dz = w_left*(z_t(i,j) - z_b(i,j)) + w_right*(z_t(i+1,j) - z_b(i+1,j)) + p5(1) = -GxRho*(w_left*z_t(i,j) + w_right*z_t(i+1,j)) do n=2,5 p5(n) = p5(n-1) + GxRho*0.25*dz enddo - ! Coefficients of the parabola for S - s0 = S_top - s1 = 6.0 * S_mid - 4.0 * S_top - 2.0 * S_bot - s2 = 3.0 * ( S_top + S_bot - 2.0*S_mid ) - - ! Coefficients of the parabola for T - t0 = T_top - t1 = 6.0 * T_mid - 4.0 * T_top - 2.0 * T_bot - t2 = 3.0 * ( T_top + T_bot - 2.0*T_mid ) - + ! Parabolic reconstructions in the vertical for T and S + if (use_PPM) then + ! Coefficients of the parabolas + s6 = 3.0 * ( 2.0*S(i,j) - ( S_t(i,j) + S_b(i,j) ) ) + t6 = 3.0 * ( 2.0*T(i,j) - ( T_t(i,j) + T_b(i,j) ) ) + endif do n=1,5 - ! Parabolic reconstruction for T and S - xi = 0.25 * ( n - 1 ) - S5(n) = s0 + s1 * xi + s2 * xi**2 - T5(n) = t0 + t1 * xi + t2 * xi**2 + S5(n) = wt_t(n) * S_top + wt_b(n) * ( S_bot + s6 * wt_t(n) ) + T5(n) = wt_t(n) * T_top + wt_b(n) * ( T_bot + t6 * wt_t(n) ) enddo -stop if (rho_scale /= 1.0) then call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) else call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks) endif - ! Use Boole's rule to estimate the pressure anomaly change. - intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + & - 12.0*r5(3)) ) - enddo - intx_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & - 12.0*intz(3)) - - ! Use Gauss quadrature rule to compute integral - - ! The following coordinates define the quadrilateral on which the integral - ! is computed - x(1) = 1.0 - x(2) = 0.0 - x(3) = 0.0 - x(4) = 1.0 - y(1) = z_t(i+1,j) - y(2) = z_t(i,j) - y(3) = z_b(i,j) - y(4) = z_b(i+1,j) - - T_node = 0.0 - p_node = 0.0 - - ! Nodal values for S - - ! Parabolic reconstruction on the left - s0 = S_t(i,j) - s1 = 6.0 * S(i,j) - 4.0 * S_t(i,j) - 2.0 * S_b(i,j) - s2 = 3.0 * ( S_t(i,j) + S_b(i,j) - 2.0 * S(i,j) ) - S_node(2) = s0 - S_node(6) = s0 + 0.5 * s1 + 0.25 * s2 - S_node(3) = s0 + s1 + s2 - - ! Parabolic reconstruction on the left - s0 = S_t(i+1,j) - s1 = 6.0 * S(i+1,j) - 4.0 * S_t(i+1,j) - 2.0 * S_b(i+1,j) - s2 = 3.0 * ( S_t(i+1,j) + S_b(i+1,j) - 2.0 * S(i+1,j) ) - S_node(1) = s0 - S_node(8) = s0 + 0.5 * s1 + 0.25 * s2 - S_node(4) = s0 + s1 + s2 - - S_node(5) = 0.5 * ( S_node(2) + S_node(1) ) - S_node(9) = 0.5 * ( S_node(6) + S_node(8) ) - S_node(7) = 0.5 * ( S_node(3) + S_node(4) ) - - if (rho_scale /= 1.0) then - call calculate_density( T_node, S_node, p_node, r_node, 1, 9, EOS, rho_ref=rho_ref_mks, scale=rho_scale ) - else - call calculate_density( T_node, S_node, p_node, r_node, 1, 9, EOS, rho_ref=rho_ref_mks) - endif - r_node = r_node - rho_ref - - call compute_integral_quadratic( x, y, r_node, intx_dpa(i,j) ) + ! Use Boole's rule to estimate the pressure anomaly change. + intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) ) + enddo ! m + intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) - intx_dpa(i,j) = intx_dpa(i,j) * G_e + ! Use Boole's rule to integrate the bottom pressure anomaly values in x. + intx_dpa(I,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + 12.0*intz(3)) enddo ; enddo ; endif ! 3. Compute horizontal integrals in the y direction - if (present(inty_dpa)) then - call MOM_error(WARNING, "int_density_dz_generic_ppm still needs to be written for inty_dpa!") - do J=Jsq,Jeq ; do i=is,ie + if (present(inty_dpa)) then ; do J=Jsq,Jeq ; do i=HI%isc,HI%iec + ! Corner values of T and S + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, almost like thickness + ! weighting. + ! Note: To work in terrain following coordinates we could offset + ! this distance by the layer thickness to replicate other models. + hWght = massWeightToggle * & + max(0., -bathyT(i,j)-z_t(i,j+1), -bathyT(i,j+1)-z_t(i,j)) + if (hWght > 0.) then + hL = (z_t(i,j) - z_b(i,j)) + dz_subroundoff + hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_subroundoff + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1./( hWght*(hR + hL) + hL*hR ) + Ttl = ( (hWght*hR)*T_t(i,j+1) + (hWght*hL + hR*hL)*T_t(i,j) ) * iDenom + Tbl = ( (hWght*hR)*T_b(i,j+1) + (hWght*hL + hR*hL)*T_b(i,j) ) * iDenom + Tml = ( (hWght*hR)*T(i,j+1) + (hWght*hL + hR*hL)*T(i,j) ) * iDenom + Ttr = ( (hWght*hL)*T_t(i,j) + (hWght*hR + hR*hL)*T_t(i,j+1) ) * iDenom + Tbr = ( (hWght*hL)*T_b(i,j) + (hWght*hR + hR*hL)*T_b(i,j+1) ) * iDenom + Tmr = ( (hWght*hL)*T(i,j) + (hWght*hR + hR*hL)*T(i,j+1) ) * iDenom + Stl = ( (hWght*hR)*S_t(i,j+1) + (hWght*hL + hR*hL)*S_t(i,j) ) * iDenom + Sbl = ( (hWght*hR)*S_b(i,j+1) + (hWght*hL + hR*hL)*S_b(i,j) ) * iDenom + Sml = ( (hWght*hR)*S(i,j+1) + (hWght*hL + hR*hL)*S(i,j) ) * iDenom + Str = ( (hWght*hL)*S_t(i,j) + (hWght*hR + hR*hL)*S_t(i,j+1) ) * iDenom + Sbr = ( (hWght*hL)*S_b(i,j) + (hWght*hR + hR*hL)*S_b(i,j+1) ) * iDenom + Smr = ( (hWght*hL)*S(i,j) + (hWght*hR + hR*hL)*S(i,j+1) ) * iDenom + else + Ttl = T_t(i,j); Tbl = T_b(i,j); Ttr = T_t(i,j+1); Tbr = T_b(i,j+1) + Tml = T(i,j); Tmr = T(i,j+1) + Stl = S_t(i,j); Sbl = S_b(i,j); Str = S_t(i,j+1); Sbr = S_b(i,j+1) + Sml = S(i,j); Smr = S(i,j+1) + endif - inty_dpa(i,j) = 0.0 + do m=2,4 + w_left = wt_t(m) ; w_right = wt_b(m) - enddo ; enddo - endif + ! Salinity and temperature points are linearly interpolated in + ! the horizontal. The subscript (1) refers to the top value in + ! the vertical profile while subscript (5) refers to the bottom + ! value in the vertical profile. + T_top = w_left*Ttl + w_right*Ttr + T_mn = w_left*Tml + w_right*Tmr + T_bot = w_left*Tbl + w_right*Tbr -end subroutine int_density_dz_generic_ppm + S_top = w_left*Stl + w_right*Str + S_mn = w_left*Sml + w_right*Smr + S_bot = w_left*Sbl + w_right*Sbr + ! Pressure + dz = w_left*(z_t(i,j) - z_b(i,j)) + w_right*(z_t(i,j+1) - z_b(i,j+1)) + p5(1) = -GxRho*(w_left*z_t(i,j) + w_right*z_t(i,j+1)) + do n=2,5 + p5(n) = p5(n-1) + GxRho*0.25*dz + enddo -!> 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 + if (use_PPM) then + ! Coefficients of the parabolas + s6 = 3.0 * ( 2.0*S(i,j) - ( S_t(i,j) + S_b(i,j) ) ) + t6 = 3.0 * ( 2.0*T(i,j) - ( T_t(i,j) + T_b(i,j) ) ) + endif - ! Local variables - integer :: i, k - real, dimension(9) :: weight, xi, eta ! integration points - real :: f_k - real :: dxdxi, dxdeta - real :: dydxi, dydeta - real, dimension(4) :: phiiso, dphiisodxi, dphiisodeta - real, dimension(9) :: phi, dphidxi, dphideta - real :: jacobian_k - real :: t - - ! Quadrature rule (4 points) - !weight(:) = 1.0 - !xi(1) = - sqrt(3.0) / 3.0 - !xi(2) = sqrt(3.0) / 3.0 - !xi(3) = sqrt(3.0) / 3.0 - !xi(4) = - sqrt(3.0) / 3.0 - !eta(1) = - sqrt(3.0) / 3.0 - !eta(2) = - sqrt(3.0) / 3.0 - !eta(3) = sqrt(3.0) / 3.0 - !eta(4) = sqrt(3.0) / 3.0 - - ! Quadrature rule (9 points) - t = sqrt(3.0/5.0) - weight(1) = 25.0/81.0 ; xi(1) = -t ; eta(1) = t - weight(2) = 40.0/81.0 ; xi(2) = .0 ; eta(2) = t - weight(3) = 25.0/81.0 ; xi(3) = t ; eta(3) = t - weight(4) = 40.0/81.0 ; xi(4) = -t ; eta(4) = .0 - weight(5) = 64.0/81.0 ; xi(5) = .0 ; eta(5) = .0 - weight(6) = 40.0/81.0 ; xi(6) = t ; eta(6) = .0 - weight(7) = 25.0/81.0 ; xi(7) = -t ; eta(7) = -t - weight(8) = 40.0/81.0 ; xi(8) = .0 ; eta(8) = -t - weight(9) = 25.0/81.0 ; xi(9) = t ; eta(9) = -t - - integral = 0.0 - - ! Integration loop - do k = 1,9 - - ! Evaluate shape functions and gradients for isomorphism - call evaluate_shape_bilinear( xi(k), eta(k), phiiso, & - dphiisodxi, dphiisodeta ) - - ! Determine gradient of global coordinate at integration point - dxdxi = 0.0 - dxdeta = 0.0 - dydxi = 0.0 - dydeta = 0.0 - - do i = 1,4 - dxdxi = dxdxi + x(i) * dphiisodxi(i) - dxdeta = dxdeta + x(i) * dphiisodeta(i) - dydxi = dydxi + y(i) * dphiisodxi(i) - dydeta = dydeta + y(i) * dphiisodeta(i) - enddo + ! Parabolic reconstructions in the vertical for T and S + do n=1,5 + S5(n) = wt_t(n) * S_top + wt_b(n) * ( S_bot + s6 * wt_t(n) ) + T5(n) = wt_t(n) * T_top + wt_b(n) * ( T_bot + t6 * wt_t(n) ) + enddo - ! Evaluate Jacobian at integration point - jacobian_k = dxdxi*dydeta - dydxi*dxdeta + if (rho_scale /= 1.0) then + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + else + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks) + endif - ! Evaluate shape functions for interpolation - call evaluate_shape_quadratic( xi(k), eta(k), phi, dphidxi, dphideta ) + ! Use Boole's rule to estimate the pressure anomaly change. + intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) ) + enddo ! m + intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) - ! Evaluate function at integration point - f_k = 0.0 - do i = 1,9 - f_k = f_k + f(i) * phi(i) - enddo + ! Use Boole's rule to integrate the bottom pressure anomaly values in y. + inty_dpa(i,J) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + 12.0*intz(3)) - integral = integral + weight(k) * f_k * jacobian_k - - enddo ! end integration loop - -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 ) - real, intent(in) :: xi !< The x position to evaluate - real, intent(in) :: eta !< The z position to evaluate - real, dimension(4), intent(inout) :: phi !< The weights of the four corners at this point - real, dimension(4), intent(inout) :: dphidxi !< The x-gradient of the weights of the four - !! corners at this point - real, dimension(4), intent(inout) :: 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) - ! | | - ! | | - ! | | - ! | | - ! (-1,-1) 3 o------------o 4 (1,-1) - ! - - phi(1) = 0.25 * ( 1 + xi ) * ( 1 + eta ) - phi(2) = 0.25 * ( 1 - xi ) * ( 1 + eta ) - phi(3) = 0.25 * ( 1 - xi ) * ( 1 - eta ) - phi(4) = 0.25 * ( 1 + xi ) * ( 1 - eta ) - - dphidxi(1) = 0.25 * ( 1 + eta ) - dphidxi(2) = - 0.25 * ( 1 + eta ) - dphidxi(3) = - 0.25 * ( 1 - eta ) - dphidxi(4) = 0.25 * ( 1 - eta ) - - dphideta(1) = 0.25 * ( 1 + xi ) - dphideta(2) = 0.25 * ( 1 - xi ) - dphideta(3) = - 0.25 * ( 1 - xi ) - dphideta(4) = - 0.25 * ( 1 + xi ) - -end subroutine evaluate_shape_bilinear - - -!> 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 !< The x position to evaluate - real, intent(in) :: eta !< The z position to evaluate - real, dimension(9), intent(inout) :: phi !< The weights of the 9 bilinear quadrature points - !! at this point - real, dimension(9), intent(inout) :: dphidxi !< The x-gradient of the weights of the 9 bilinear - !! quadrature points corners at this point - real, dimension(9), intent(inout) :: 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) - ! | | - ! | 9 (0,0) | - ! (-1,0) 6 o o o 8 (1,0) - ! | | - ! | | - ! (-1,-1) 3 o------o------o 4 (1,-1) - ! 7 (0,-1) - ! - - 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 ) - phi(3) = 0.25 * xi * ( 1 - xi ) * eta * ( 1 - eta ) - phi(4) = - 0.25 * xi * ( 1 + xi ) * eta * ( 1 - eta ) - phi(5) = 0.5 * ( 1 + xi ) * ( 1 - xi ) * eta * ( 1 + eta ) - phi(6) = - 0.5 * xi * ( 1 - xi ) * ( 1 - eta ) * ( 1 + eta ) - phi(7) = - 0.5 * ( 1 - xi ) * ( 1 + xi ) * eta * ( 1 - eta ) - phi(8) = 0.5 * xi * ( 1 + xi ) * ( 1 - eta ) * ( 1 + eta ) - phi(9) = ( 1 - xi ) * ( 1 + xi ) * ( 1 - eta ) * ( 1 + eta ) - - !dphidxi(1) = 0.25 * ( 1 + 2*xi ) * eta * ( 1 + eta ) - !dphidxi(2) = - 0.25 * ( 1 - 2*xi ) * eta * ( 1 + eta ) - !dphidxi(3) = 0.25 * ( 1 - 2*xi ) * eta * ( 1 - eta ) - !dphidxi(4) = - 0.25 * ( 1 + 2*xi ) * eta * ( 1 - eta ) - !dphidxi(5) = - xi * eta * ( 1 + eta ) - !dphidxi(6) = - 0.5 * ( 1 - 2*xi ) * ( 1 - eta ) * ( 1 + eta ) - !dphidxi(7) = xi * eta * ( 1 - eta ) - !dphidxi(8) = 0.5 * ( 1 + 2*xi ) * ( 1 - eta ) * ( 1 + eta ) - !dphidxi(9) = - 2 * xi * ( 1 - eta ) * ( 1 + eta ) - - !dphideta(1) = 0.25 * xi * ( 1 + xi ) * ( 1 + 2*eta ) - !dphideta(2) = - 0.25 * xi * ( 1 - xi ) * ( 1 + 2*eta ) - !dphideta(3) = 0.25 * xi * ( 1 - xi ) * ( 1 - 2*eta ) - !dphideta(4) = - 0.25 * xi * ( 1 + xi ) * ( 1 - 2*eta ) - !dphideta(5) = 0.5 * ( 1 + xi ) * ( 1 - xi ) * ( 1 + 2*eta ) - !dphideta(6) = xi * ( 1 - xi ) * eta - !dphideta(7) = - 0.5 * ( 1 - xi ) * ( 1 + xi ) * ( 1 - 2*eta ) - !dphideta(8) = - xi * ( 1 + xi ) * eta - !dphideta(9) = - 2 * ( 1 - xi ) * ( 1 + xi ) * eta - -end subroutine evaluate_shape_quadratic + enddo ; enddo ; endif +end subroutine int_density_dz_generic_ppm !> Calls the appropriate subroutine to calculate analytical and nearly-analytical !! integrals in pressure across layers of geopotential anomalies, which are From d945d70dfd3b99a6048271c655dea7262114c65c Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Mon, 15 Jun 2020 19:23:42 +0000 Subject: [PATCH 41/91] Fixed line length issue in documentation --- src/core/MOM_density_integrals.F90 | 9 ++++++--- src/equation_of_state/MOM_EOS.F90 | 2 +- 2 files changed, 7 insertions(+), 4 deletions(-) diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index 4c5120ba09..87f09309e2 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -1441,9 +1441,12 @@ subroutine find_depth_of_pressure_in_cell(T_t, T_b, S_t, S_b, z_t, z_b, P_t, P_t 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 [R L2 T-2 ~> Pa] - real, intent(in) :: P_tgt !< Target pressure at height z_out, relative to g*rho_ref*z_out [R L2 T-2 ~> Pa] - real, intent(in) :: rho_ref !< Reference density with which calculation are anomalous to [R ~> kg m-3] + real, intent(in) :: P_t !< Anomalous pressure of top of cell, relative + !! to g*rho_ref*z_t [R L2 T-2 ~> Pa] + real, intent(in) :: P_tgt !< Target pressure at height z_out, relative + !! to g*rho_ref*z_out [R L2 T-2 ~> Pa] + real, intent(in) :: rho_ref !< Reference density with which calculation + !! are anomalous to [R ~> kg m-3] real, intent(in) :: G_e !< Gravitational acceleration [L2 Z-1 T-2 ~> m s-2] type(EOS_type), pointer :: EOS !< Equation of state structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 583bb8fcbc..84858aabcd 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -387,7 +387,7 @@ subroutine calculate_stanley_density_1d(T, S, pressure, Tvar, TScov, Svar, rho, 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 [R L2 T-2 ~> Pa] - real, dimension(:), intent(in) :: Tvar !< Variance of potential temperature referenced to the surface [degC2] + real, dimension(:), intent(in) :: Tvar !< Variance of potential temperature [degC2] real, dimension(:), intent(in) :: TScov !< Covariance of potential temperature and salinity [degC ppt] real, dimension(:), intent(in) :: Svar !< Variance of salinity [ppt2] real, dimension(:), intent(inout) :: rho !< Density (in-situ if pressure is local) [R ~> kg m-3] From aaa0487769162b102f406b5b01041ec2a02701bb Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Mon, 15 Jun 2020 20:15:01 +0000 Subject: [PATCH 42/91] Fixed openmp in MOM_ALE.F90 - Use of new PLM functions led to out of date directives --- src/ALE/MOM_ALE.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 7c4453a292..f130c2977a 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -1063,7 +1063,7 @@ subroutine ALE_PLM_edge_values( CS, G, GV, h, Q, bdry_extrap, Q_t, Q_b ) h_neglect = GV%kg_m2_to_H*1.0e-30 endif - !$OMP parallel do default(shared) private(hTmp,ppol_E,ppol_coefs,tmp) + !$OMP parallel do default(shared) private(slp,mslp) do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1 slp(1) = 0. do k = 2, GV%ke-1 From 80da001b2519faf90f9913a9f0c537f835691af2 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 17 Jun 2020 00:23:15 +0000 Subject: [PATCH 43/91] Updated to int_density_dz_generic_ppm() to use k and tv arguments - Now passing in 3D structures and tv so that we can access other fields in tv%. - Corrected calculation of curvatures s6, t6 for interpolated interior line integrals. - Tested with use_PPM=.false. and PLM edge values. - Using PLM edge values with use_PPM=.true. does give different answers because t6,s6 are non-zero albeit tiny. This is due to FP truncation errors. --- src/core/MOM_PressureForce_analytic_FV.F90 | 5 +- src/core/MOM_density_integrals.F90 | 136 ++++++++++----------- 2 files changed, 69 insertions(+), 72 deletions(-) diff --git a/src/core/MOM_PressureForce_analytic_FV.F90 b/src/core/MOM_PressureForce_analytic_FV.F90 index 160fe1c20d..0f22f46897 100644 --- a/src/core/MOM_PressureForce_analytic_FV.F90 +++ b/src/core/MOM_PressureForce_analytic_FV.F90 @@ -645,10 +645,9 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at G%HI, tv%eqn_of_state, US, 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), & - tv%S(:,:,k), S_t(:,:,k), S_b(:,:,k), e(:,:,K), e(:,:,K+1), & + call int_density_dz_generic_ppm( k, tv, T_t, T_b, S_t, S_b, e, & rho_ref, CS%Rho0, GV%g_Earth, dz_neglect, G%bathyT, & - G%HI, tv%eqn_of_state, US, dpa, intz_dpa, intx_dpa, inty_dpa, & + G%HI, GV, tv%eqn_of_state, US, dpa, intz_dpa, intx_dpa, inty_dpa, & useMassWghtInterp=CS%useMassWghtInterp) endif else diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index 87f09309e2..efd8afcb2b 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -15,7 +15,9 @@ module MOM_density_integrals use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_hor_index, only : hor_index_type use MOM_string_functions, only : uppercase +use MOM_variables, only : thermo_var_ptrs use MOM_unit_scaling, only : unit_scale_type +use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -594,28 +596,25 @@ subroutine int_density_dz_generic_plm(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & end subroutine int_density_dz_generic_plm -!> Compute pressure gradient force integrals for the case where T and S +!> Compute pressure gradient force integrals for layer "k" and 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, dz_subroundoff, bathyT, HI, EOS, US, & +subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & + rho_ref, rho_0, G_e, dz_subroundoff, bathyT, HI, GV, EOS, US, & dpa, intz_dpa, intx_dpa, inty_dpa, useMassWghtInterp) + integer, intent(in) :: k !< Layer index to calculate integrals for type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structures for the input arrays - real, dimension(SZI_(HI),SZJ_(HI)), & - intent(in) :: T !< Potential temperature referenced to the surface [degC] - real, dimension(SZI_(HI),SZJ_(HI)), & + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & intent(in) :: T_t !< Potential temperature at the cell top [degC] - real, dimension(SZI_(HI),SZJ_(HI)), & + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & intent(in) :: T_b !< Potential temperature at the cell bottom [degC] - real, dimension(SZI_(HI),SZJ_(HI)), & - intent(in) :: S !< Salinity [ppt] - real, dimension(SZI_(HI),SZJ_(HI)), & + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & intent(in) :: S_t !< Salinity at the cell top [ppt] - real, dimension(SZI_(HI),SZJ_(HI)), & + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & intent(in) :: S_b !< Salinity at the cell bottom [ppt] - real, dimension(SZI_(HI),SZJ_(HI)), & - intent(in) :: z_t !< Height at the top of the layer [Z ~> m] - real, dimension(SZI_(HI),SZJ_(HI)), & - intent(in) :: z_b !< Height at the bottom of the layer [Z ~> m] + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)+1), & + intent(in) :: e !< Height of interfaces [Z ~> m] real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that is !! subtracted out to reduce the magnitude of each of the integrals. real, intent(in) :: rho_0 !< A density [R ~> kg m-3] or [kg m-3], that is used to calculate @@ -708,15 +707,15 @@ subroutine int_density_dz_generic_ppm(T, T_t, T_b, S, S_t, S_b, z_t, z_b, & do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 if (use_PPM) then ! Curvature coefficient of the parabolas - s6 = 3.0 * ( 2.0*S(i,j) - ( S_t(i,j) + S_b(i,j) ) ) - t6 = 3.0 * ( 2.0*T(i,j) - ( T_t(i,j) + T_b(i,j) ) ) + s6 = 3.0 * ( 2.0*tv%S(i,j,k) - ( S_t(i,j,k) + S_b(i,j,k) ) ) + t6 = 3.0 * ( 2.0*tv%T(i,j,k) - ( T_t(i,j,k) + T_b(i,j,k) ) ) endif - dz = z_t(i,j) - z_b(i,j) + dz = e(i,j,K) - e(i,j,K+1) do n=1,5 - p5(n) = -GxRho*(z_t(i,j) - 0.25*real(n-1)*dz) + p5(n) = -GxRho*(e(i,j,K) - 0.25*real(n-1)*dz) ! Salinity and temperature points are reconstructed with PPM - S5(n) = wt_t(n) * S_t(i,j) + wt_b(n) * ( S_b(i,j) + s6 * wt_t(n) ) - T5(n) = wt_t(n) * T_t(i,j) + wt_b(n) * ( T_b(i,j) + t6 * wt_t(n) ) + S5(n) = wt_t(n) * S_t(i,j,k) + wt_b(n) * ( S_b(i,j,k) + s6 * wt_t(n) ) + T5(n) = wt_t(n) * T_t(i,j,k) + wt_b(n) * ( T_b(i,j,k) + t6 * wt_t(n) ) enddo if (rho_scale /= 1.0) then call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) @@ -745,29 +744,29 @@ subroutine int_density_dz_generic_ppm(T, T_t, T_b, S, S_t, S_b, z_t, z_b, & ! Note: To work in terrain following coordinates we could offset ! this distance by the layer thickness to replicate other models. hWght = massWeightToggle * & - max(0., -bathyT(i,j)-z_t(i+1,j), -bathyT(i+1,j)-z_t(i,j)) + max(0., -bathyT(i,j)-e(i+1,j,K), -bathyT(i+1,j)-e(i,j,K)) if (hWght > 0.) then - hL = (z_t(i,j) - z_b(i,j)) + dz_subroundoff - hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_subroundoff + hL = (e(i,j,K) - e(i,j,K+1)) + dz_subroundoff + hR = (e(i+1,j,K) - e(i+1,j,K+1)) + dz_subroundoff hWght = hWght * ( (hL-hR)/(hL+hR) )**2 iDenom = 1./( hWght*(hR + hL) + hL*hR ) - Ttl = ( (hWght*hR)*T_t(i+1,j) + (hWght*hL + hR*hL)*T_t(i,j) ) * iDenom - Tbl = ( (hWght*hR)*T_b(i+1,j) + (hWght*hL + hR*hL)*T_b(i,j) ) * iDenom - Tml = ( (hWght*hR)*T(i+1,j) + (hWght*hL + hR*hL)*T(i,j) ) * iDenom - Ttr = ( (hWght*hL)*T_t(i,j) + (hWght*hR + hR*hL)*T_t(i+1,j) ) * iDenom - Tbr = ( (hWght*hL)*T_b(i,j) + (hWght*hR + hR*hL)*T_b(i+1,j) ) * iDenom - Tmr = ( (hWght*hL)*T(i,j) + (hWght*hR + hR*hL)*T(i+1,j) ) * iDenom - Stl = ( (hWght*hR)*S_t(i+1,j) + (hWght*hL + hR*hL)*S_t(i,j) ) * iDenom - Sbl = ( (hWght*hR)*S_b(i+1,j) + (hWght*hL + hR*hL)*S_b(i,j) ) * iDenom - Sml = ( (hWght*hR)*S(i+1,j) + (hWght*hL + hR*hL)*S(i,j) ) * iDenom - Str = ( (hWght*hL)*S_t(i,j) + (hWght*hR + hR*hL)*S_t(i+1,j) ) * iDenom - Sbr = ( (hWght*hL)*S_b(i,j) + (hWght*hR + hR*hL)*S_b(i+1,j) ) * iDenom - Smr = ( (hWght*hL)*S(i,j) + (hWght*hR + hR*hL)*S(i+1,j) ) * iDenom + Ttl = ( (hWght*hR)*T_t(i+1,j,k) + (hWght*hL + hR*hL)*T_t(i,j,k) ) * iDenom + Tbl = ( (hWght*hR)*T_b(i+1,j,k) + (hWght*hL + hR*hL)*T_b(i,j,k) ) * iDenom + Tml = ( (hWght*hR)*tv%T(i+1,j,k)+ (hWght*hL + hR*hL)*tv%T(i,j,k) ) * iDenom + Ttr = ( (hWght*hL)*T_t(i,j,k) + (hWght*hR + hR*hL)*T_t(i+1,j,k) ) * iDenom + Tbr = ( (hWght*hL)*T_b(i,j,k) + (hWght*hR + hR*hL)*T_b(i+1,j,k) ) * iDenom + Tmr = ( (hWght*hL)*tv%T(i,j,k) + (hWght*hR + hR*hL)*tv%T(i+1,j,k) ) * iDenom + Stl = ( (hWght*hR)*S_t(i+1,j,k) + (hWght*hL + hR*hL)*S_t(i,j,k) ) * iDenom + Sbl = ( (hWght*hR)*S_b(i+1,j,k) + (hWght*hL + hR*hL)*S_b(i,j,k) ) * iDenom + Sml = ( (hWght*hR)*tv%S(i+1,j,k) + (hWght*hL + hR*hL)*tv%S(i,j,k) ) * iDenom + Str = ( (hWght*hL)*S_t(i,j,k) + (hWght*hR + hR*hL)*S_t(i+1,j,k) ) * iDenom + Sbr = ( (hWght*hL)*S_b(i,j,k) + (hWght*hR + hR*hL)*S_b(i+1,j,k) ) * iDenom + Smr = ( (hWght*hL)*tv%S(i,j,k) + (hWght*hR + hR*hL)*tv%S(i+1,j,k) ) * iDenom else - Ttl = T_t(i,j); Tbl = T_b(i,j); Ttr = T_t(i+1,j); Tbr = T_b(i+1,j) - Tml = T(i,j); Tmr = T(i+1,j) - Stl = S_t(i,j); Sbl = S_b(i,j); Str = S_t(i+1,j); Sbr = S_b(i+1,j) - Sml = S(i,j); Smr = S(i+1,j) + Ttl = T_t(i,j,k); Tbl = T_b(i,j,k); Ttr = T_t(i+1,j,k); Tbr = T_b(i+1,j,k) + Tml = tv%T(i,j,k); Tmr = tv%T(i+1,j,k) + Stl = S_t(i,j,k); Sbl = S_b(i,j,k); Str = S_t(i+1,j,k); Sbr = S_b(i+1,j,k) + Sml = tv%S(i,j,k); Smr = tv%S(i+1,j,k) endif do m=2,4 @@ -786,8 +785,8 @@ subroutine int_density_dz_generic_ppm(T, T_t, T_b, S, S_t, S_b, z_t, z_b, & S_bot = w_left*Sbl + w_right*Sbr ! Pressure - dz = w_left*(z_t(i,j) - z_b(i,j)) + w_right*(z_t(i+1,j) - z_b(i+1,j)) - p5(1) = -GxRho*(w_left*z_t(i,j) + w_right*z_t(i+1,j)) + dz = w_left*(e(i,j,K) - e(i,j,K+1)) + w_right*(e(i+1,j,K) - e(i+1,j,K+1)) + p5(1) = -GxRho*(w_left*e(i,j,K) + w_right*e(i+1,j,K)) do n=2,5 p5(n) = p5(n-1) + GxRho*0.25*dz enddo @@ -795,8 +794,8 @@ subroutine int_density_dz_generic_ppm(T, T_t, T_b, S, S_t, S_b, z_t, z_b, & ! Parabolic reconstructions in the vertical for T and S if (use_PPM) then ! Coefficients of the parabolas - s6 = 3.0 * ( 2.0*S(i,j) - ( S_t(i,j) + S_b(i,j) ) ) - t6 = 3.0 * ( 2.0*T(i,j) - ( T_t(i,j) + T_b(i,j) ) ) + s6 = 3.0 * ( 2.0*S_mn - ( S_top + S_bot ) ) + t6 = 3.0 * ( 2.0*T_mn - ( T_top + T_bot ) ) endif do n=1,5 S5(n) = wt_t(n) * S_top + wt_b(n) * ( S_bot + s6 * wt_t(n) ) @@ -829,29 +828,29 @@ subroutine int_density_dz_generic_ppm(T, T_t, T_b, S, S_t, S_b, z_t, z_b, & ! Note: To work in terrain following coordinates we could offset ! this distance by the layer thickness to replicate other models. hWght = massWeightToggle * & - max(0., -bathyT(i,j)-z_t(i,j+1), -bathyT(i,j+1)-z_t(i,j)) + max(0., -bathyT(i,j)-e(i,j+1,K), -bathyT(i,j+1)-e(i,j,K)) if (hWght > 0.) then - hL = (z_t(i,j) - z_b(i,j)) + dz_subroundoff - hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_subroundoff + hL = (e(i,j,K) - e(i,j,K+1)) + dz_subroundoff + hR = (e(i,j+1,K) - e(i,j+1,K+1)) + dz_subroundoff hWght = hWght * ( (hL-hR)/(hL+hR) )**2 iDenom = 1./( hWght*(hR + hL) + hL*hR ) - Ttl = ( (hWght*hR)*T_t(i,j+1) + (hWght*hL + hR*hL)*T_t(i,j) ) * iDenom - Tbl = ( (hWght*hR)*T_b(i,j+1) + (hWght*hL + hR*hL)*T_b(i,j) ) * iDenom - Tml = ( (hWght*hR)*T(i,j+1) + (hWght*hL + hR*hL)*T(i,j) ) * iDenom - Ttr = ( (hWght*hL)*T_t(i,j) + (hWght*hR + hR*hL)*T_t(i,j+1) ) * iDenom - Tbr = ( (hWght*hL)*T_b(i,j) + (hWght*hR + hR*hL)*T_b(i,j+1) ) * iDenom - Tmr = ( (hWght*hL)*T(i,j) + (hWght*hR + hR*hL)*T(i,j+1) ) * iDenom - Stl = ( (hWght*hR)*S_t(i,j+1) + (hWght*hL + hR*hL)*S_t(i,j) ) * iDenom - Sbl = ( (hWght*hR)*S_b(i,j+1) + (hWght*hL + hR*hL)*S_b(i,j) ) * iDenom - Sml = ( (hWght*hR)*S(i,j+1) + (hWght*hL + hR*hL)*S(i,j) ) * iDenom - Str = ( (hWght*hL)*S_t(i,j) + (hWght*hR + hR*hL)*S_t(i,j+1) ) * iDenom - Sbr = ( (hWght*hL)*S_b(i,j) + (hWght*hR + hR*hL)*S_b(i,j+1) ) * iDenom - Smr = ( (hWght*hL)*S(i,j) + (hWght*hR + hR*hL)*S(i,j+1) ) * iDenom + Ttl = ( (hWght*hR)*T_t(i,j+1,k) + (hWght*hL + hR*hL)*T_t(i,j,k) ) * iDenom + Tbl = ( (hWght*hR)*T_b(i,j+1,k) + (hWght*hL + hR*hL)*T_b(i,j,k) ) * iDenom + Tml = ( (hWght*hR)*tv%T(i,j+1,k)+ (hWght*hL + hR*hL)*tv%T(i,j,k) ) * iDenom + Ttr = ( (hWght*hL)*T_t(i,j,k) + (hWght*hR + hR*hL)*T_t(i,j+1,k) ) * iDenom + Tbr = ( (hWght*hL)*T_b(i,j,k) + (hWght*hR + hR*hL)*T_b(i,j+1,k) ) * iDenom + Tmr = ( (hWght*hL)*tv%T(i,j,k) + (hWght*hR + hR*hL)*tv%T(i,j+1,k) ) * iDenom + Stl = ( (hWght*hR)*S_t(i,j+1,k) + (hWght*hL + hR*hL)*S_t(i,j,k) ) * iDenom + Sbl = ( (hWght*hR)*S_b(i,j+1,k) + (hWght*hL + hR*hL)*S_b(i,j,k) ) * iDenom + Sml = ( (hWght*hR)*tv%S(i,j+1,k)+ (hWght*hL + hR*hL)*tv%S(i,j,k) ) * iDenom + Str = ( (hWght*hL)*S_t(i,j,k) + (hWght*hR + hR*hL)*S_t(i,j+1,k) ) * iDenom + Sbr = ( (hWght*hL)*S_b(i,j,k) + (hWght*hR + hR*hL)*S_b(i,j+1,k) ) * iDenom + Smr = ( (hWght*hL)*tv%S(i,j,k) + (hWght*hR + hR*hL)*tv%S(i,j+1,k) ) * iDenom else - Ttl = T_t(i,j); Tbl = T_b(i,j); Ttr = T_t(i,j+1); Tbr = T_b(i,j+1) - Tml = T(i,j); Tmr = T(i,j+1) - Stl = S_t(i,j); Sbl = S_b(i,j); Str = S_t(i,j+1); Sbr = S_b(i,j+1) - Sml = S(i,j); Smr = S(i,j+1) + Ttl = T_t(i,j,k); Tbl = T_b(i,j,k); Ttr = T_t(i,j+1,k); Tbr = T_b(i,j+1,k) + Tml = tv%T(i,j,k); Tmr = tv%T(i,j+1,k) + Stl = S_t(i,j,k); Sbl = S_b(i,j,k); Str = S_t(i,j+1,k); Sbr = S_b(i,j+1,k) + Sml = tv%S(i,j,k); Smr = tv%S(i,j+1,k) endif do m=2,4 @@ -870,19 +869,18 @@ subroutine int_density_dz_generic_ppm(T, T_t, T_b, S, S_t, S_b, z_t, z_b, & S_bot = w_left*Sbl + w_right*Sbr ! Pressure - dz = w_left*(z_t(i,j) - z_b(i,j)) + w_right*(z_t(i,j+1) - z_b(i,j+1)) - p5(1) = -GxRho*(w_left*z_t(i,j) + w_right*z_t(i,j+1)) + dz = w_left*(e(i,j,K) - e(i,j,K+1)) + w_right*(e(i,j+1,K) - e(i,j+1,K+1)) + p5(1) = -GxRho*(w_left*e(i,j,K) + w_right*e(i,j+1,K)) do n=2,5 p5(n) = p5(n-1) + GxRho*0.25*dz enddo + ! Parabolic reconstructions in the vertical for T and S if (use_PPM) then ! Coefficients of the parabolas - s6 = 3.0 * ( 2.0*S(i,j) - ( S_t(i,j) + S_b(i,j) ) ) - t6 = 3.0 * ( 2.0*T(i,j) - ( T_t(i,j) + T_b(i,j) ) ) + s6 = 3.0 * ( 2.0*S_mn - ( S_top + S_bot ) ) + t6 = 3.0 * ( 2.0*T_mn - ( T_top + T_bot ) ) endif - - ! Parabolic reconstructions in the vertical for T and S do n=1,5 S5(n) = wt_t(n) * S_top + wt_b(n) * ( S_bot + s6 * wt_t(n) ) T5(n) = wt_t(n) * T_top + wt_b(n) * ( T_bot + t6 * wt_t(n) ) From 783983e3e9f2d8977d93e0123a99778381cf5855 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 17 Jun 2020 00:36:39 +0000 Subject: [PATCH 44/91] Renamed MOM_PressureGradient_AFV - Since the majority of code is not about the analytic integration I thought it time to rename this module --- ...MOM_PressureForce_analytic_FV.F90 => MOM_PressureForce_FV.F90} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename src/core/{MOM_PressureForce_analytic_FV.F90 => MOM_PressureForce_FV.F90} (100%) diff --git a/src/core/MOM_PressureForce_analytic_FV.F90 b/src/core/MOM_PressureForce_FV.F90 similarity index 100% rename from src/core/MOM_PressureForce_analytic_FV.F90 rename to src/core/MOM_PressureForce_FV.F90 From e8336777c9bf291299a70c3236997213b7174d64 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 17 Jun 2020 00:42:02 +0000 Subject: [PATCH 45/91] After renaming module, change _AFV_ to _FV_ - Continuation of rename of module --- src/core/MOM_PressureForce.F90 | 20 +++++------ src/core/MOM_PressureForce_FV.F90 | 55 ++++++++++++++++--------------- 2 files changed, 38 insertions(+), 37 deletions(-) diff --git a/src/core/MOM_PressureForce.F90 b/src/core/MOM_PressureForce.F90 index 6902e13341..f8690ca0cd 100644 --- a/src/core/MOM_PressureForce.F90 +++ b/src/core/MOM_PressureForce.F90 @@ -7,9 +7,9 @@ module MOM_PressureForce use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_PressureForce_AFV, only : PressureForce_AFV_Bouss, PressureForce_AFV_nonBouss -use MOM_PressureForce_AFV, only : PressureForce_AFV_init, PressureForce_AFV_end -use MOM_PressureForce_AFV, only : PressureForce_AFV_CS +use MOM_PressureForce_FV, only : PressureForce_FV_Bouss, PressureForce_FV_nonBouss +use MOM_PressureForce_FV, only : PressureForce_FV_init, PressureForce_FV_end +use MOM_PressureForce_FV, only : PressureForce_FV_CS 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 @@ -28,10 +28,10 @@ module MOM_PressureForce 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. - logical :: blocked_AFV !< If true, used the blocked version of the ANALYTIC_FV_PGF + logical :: blocked_FV !< If true, used the blocked version of the ANALYTIC_FV_PGF !! code. The value of this parameter should not change answers. !> Control structure for the analytically integrated finite volume pressure force - type(PressureForce_AFV_CS), pointer :: PressureForce_AFV_CSp => NULL() + type(PressureForce_FV_CS), pointer :: PressureForce_FV_CSp => NULL() !> Control structure for the Montgomery potential form of pressure force type(PressureForce_Mont_CS), pointer :: PressureForce_Mont_CSp => NULL() end type PressureForce_CS @@ -64,10 +64,10 @@ subroutine PressureForce(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, e if (CS%Analytic_FV_PGF) then if (GV%Boussinesq) then - call PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS%PressureForce_AFV_CSp, & + call PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS%PressureForce_FV_CSp, & ALE_CSp, p_atm, pbce, eta) else - call PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS%PressureForce_AFV_CSp, & + call PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS%PressureForce_FV_CSp, & ALE_CSp, p_atm, pbce, eta) endif else @@ -111,8 +111,8 @@ subroutine PressureForce_init(Time, G, GV, US, param_file, diag, CS, tides_CSp) "described in Adcroft et al., O. Mod. (2008).", default=.true.) if (CS%Analytic_FV_PGF) then - call PressureForce_AFV_init(Time, G, GV, US, param_file, diag, & - CS%PressureForce_AFV_CSp, tides_CSp) + call PressureForce_FV_init(Time, G, GV, US, param_file, diag, & + CS%PressureForce_FV_CSp, tides_CSp) else call PressureForce_Mont_init(Time, G, GV, US, param_file, diag, & CS%PressureForce_Mont_CSp, tides_CSp) @@ -125,7 +125,7 @@ subroutine PressureForce_end(CS) type(PressureForce_CS), pointer :: CS !< Pressure force control structure if (CS%Analytic_FV_PGF) then - call PressureForce_AFV_end(CS%PressureForce_AFV_CSp) + call PressureForce_FV_end(CS%PressureForce_FV_CSp) else call PressureForce_Mont_end(CS%PressureForce_Mont_CSp) endif diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 0f22f46897..9f6ad779d0 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -1,5 +1,5 @@ -!> Analytically integrated finite volume pressure gradient -module MOM_PressureForce_AFV +!> Finite volume pressure gradient (integrated by quadrature or analytically) +module MOM_PressureForce_FV ! This file is part of MOM6. See LICENSE.md for the license. @@ -24,8 +24,8 @@ module MOM_PressureForce_AFV #include -public PressureForce_AFV_init, PressureForce_AFV_end -public PressureForce_AFV_Bouss, PressureForce_AFV_nonBouss +public PressureForce_FV_init, PressureForce_FV_end +public PressureForce_FV_Bouss, PressureForce_FV_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 @@ -33,7 +33,7 @@ module MOM_PressureForce_AFV ! vary with the Boussinesq approximation, the Boussinesq variant is given first. !> Finite volume pressure gradient control structure -type, public :: PressureForce_AFV_CS ; private +type, public :: PressureForce_FV_CS ; private logical :: tides !< If true, apply tidal momentum forcing. real :: Rho0 !< The density used in the Boussinesq !! approximation [R ~> kg m-3]. @@ -57,7 +57,7 @@ module MOM_PressureForce_AFV integer :: id_e_tidal = -1 !< Diagnostic identifier type(tidal_forcing_CS), pointer :: tides_CSp => NULL() !< Tides control structure -end type PressureForce_AFV_CS +end type PressureForce_FV_CS contains @@ -70,7 +70,7 @@ module MOM_PressureForce_AFV !! 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) +subroutine PressureForce_FV_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 type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -78,7 +78,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: PFu !< Zonal acceleration [L T-2 ~> m s-2] real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: PFv !< Meridional acceleration [L T-2 ~> m s-2] - type(PressureForce_AFV_CS), pointer :: CS !< Finite volume PGF control structure + type(PressureForce_FV_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 [R L2 T-2 ~> Pa]. @@ -157,7 +157,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p EOSdom(1) = Isq - (G%isd-1) ; EOSdom(2) = G%iec+1 - (G%isd-1) if (.not.associated(CS)) call MOM_error(FATAL, & - "MOM_PressureForce_AFV_nonBouss: Module must be initialized before it is used.") + "MOM_PressureForce_FV_nonBouss: Module must be initialized before it is used.") use_p_atm = .false. if (present(p_atm)) then ; if (associated(p_atm)) use_p_atm = .true. ; endif @@ -240,7 +240,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p tv%eqn_of_state, US, dza(:,:,k), intp_dza(:,:,k), intx_dza(:,:,k), inty_dza(:,:,k), & useMassWghtInterp=CS%useMassWghtInterp) elseif ( CS%Recon_Scheme == 2 ) then - call MOM_error(FATAL, "PressureForce_AFV_nonBouss: "//& + call MOM_error(FATAL, "PressureForce_FV_nonBouss: "//& "int_spec_vol_dp_generic_ppm does not exist yet.") ! call int_spec_vol_dp_generic_ppm ( tv%T(:,:,k), T_t(:,:,k), T_b(:,:,k), & ! tv%S(:,:,k), S_t(:,:,k), S_b(:,:,k), p(:,:,K), p(:,:,K+1), & @@ -397,7 +397,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p if (CS%id_e_tidal>0) call post_data(CS%id_e_tidal, e_tidal, CS%diag) -end subroutine PressureForce_AFV_nonBouss +end subroutine PressureForce_FV_nonBouss !> \brief Boussinesq analytically-integrated finite volume form of pressure gradient !! @@ -407,7 +407,7 @@ end subroutine PressureForce_AFV_nonBouss !! 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) +subroutine PressureForce_FV_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 type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -415,7 +415,7 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: PFu !< Zonal acceleration [L T-2 ~> m s-2] real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: PFv !< Meridional acceleration [L T-2 ~> m s-2] - type(PressureForce_AFV_CS), pointer :: CS !< Finite volume PGF control structure + type(PressureForce_FV_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 [R L2 T-2 ~> Pa]. @@ -486,7 +486,7 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at EOSdom(1) = Isq - (G%isd-1) ; EOSdom(2) = G%iec+1 - (G%isd-1) if (.not.associated(CS)) call MOM_error(FATAL, & - "MOM_PressureForce_AFV_Bouss: Module must be initialized before it is used.") + "MOM_PressureForce_FV_Bouss: Module must be initialized before it is used.") use_p_atm = .false. if (present(p_atm)) then ; if (associated(p_atm)) use_p_atm = .true. ; endif @@ -739,17 +739,17 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_at if (CS%id_e_tidal>0) call post_data(CS%id_e_tidal, e_tidal, CS%diag) -end subroutine PressureForce_AFV_Bouss +end subroutine PressureForce_FV_Bouss !> Initializes the finite volume pressure gradient control structure -subroutine PressureForce_AFV_init(Time, G, GV, US, param_file, diag, CS, tides_CSp) +subroutine PressureForce_FV_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 + type(PressureForce_FV_CS), pointer :: CS !< Finite volume PGF control structure type(tidal_forcing_CS), optional, pointer :: tides_CSp !< Tides control structure ! This include declares and sets the variable "version". # include "version_variable.h" @@ -767,7 +767,7 @@ subroutine PressureForce_AFV_init(Time, G, GV, US, param_file, diag, CS, tides_C if (associated(tides_CSp)) CS%tides_CSp => tides_CSp endif - mdl = "MOM_PressureForce_AFV" + mdl = "MOM_PressureForce_FV" call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "RHO_0", CS%Rho0, & "The mean ocean density used with BOUSSINESQ true to "//& @@ -782,7 +782,7 @@ subroutine PressureForce_AFV_init(Time, G, GV, US, param_file, diag, CS, tides_C "If False, use the layered isopycnal algorithm.", default=.false. ) call get_param(param_file, mdl, "MASS_WEIGHT_IN_PRESSURE_GRADIENT", CS%useMassWghtInterp, & "If true, use mass weighting when interpolating T/S for "//& - "integrals near the bathymetry in AFV pressure gradient "//& + "integrals near the bathymetry in FV pressure gradient "//& "calculations.", default=.false.) call get_param(param_file, mdl, "RECONSTRUCT_FOR_PRESSURE", CS%reconstruct, & "If True, use vertical reconstruction of T & S within "//& @@ -812,20 +812,21 @@ subroutine PressureForce_AFV_init(Time, G, GV, US, param_file, diag, CS, tides_C call log_param(param_file, mdl, "GFS / G_EARTH", CS%GFS_scale) -end subroutine PressureForce_AFV_init +end subroutine PressureForce_FV_init !> Deallocates the finite volume pressure gradient control structure -subroutine PressureForce_AFV_end(CS) - type(PressureForce_AFV_CS), pointer :: CS !< Finite volume pressure control structure that +subroutine PressureForce_FV_end(CS) + type(PressureForce_FV_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 +end subroutine PressureForce_FV_end -!> \namespace mom_pressureforce_afv +!> \namespace mom_pressureforce_fv !! !! Provides the Boussinesq and non-Boussinesq forms of horizontal accelerations -!! due to pressure gradients using a 2nd-order analytically vertically integrated -!! finite volume form, as described by Adcroft et al., 2008. +!! due to pressure gradients using a vertically integrated finite volume form, +!! as described by Adcroft et al., 2008. Integration in the vertical is made +!! either by quadrature or analytically. !! !! This form eliminates the thermobaric instabilities that had been a problem with !! previous forms of the pressure gradient force calculation, as described by @@ -839,4 +840,4 @@ end subroutine PressureForce_AFV_end !! ocean models. Ocean Modelling, 8, 279-300. !! http://dx.doi.org/10.1016/j.ocemod.2004.01.001 -end module MOM_PressureForce_AFV +end module MOM_PressureForce_FV From 660150feefa83bbf692ec385c5e762857efbcb77 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 17 Jun 2020 00:51:12 +0000 Subject: [PATCH 46/91] Removed conditional scaling from int_density_dz_generic_ppm() - This routine was suffering from if's inside loops. I've removed this one since it was just obfuscation, pretending to care about performance and actually reducing it. --- src/core/MOM_density_integrals.F90 | 18 +++--------------- 1 file changed, 3 insertions(+), 15 deletions(-) diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index efd8afcb2b..bc2fd49257 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -717,11 +717,7 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & S5(n) = wt_t(n) * S_t(i,j,k) + wt_b(n) * ( S_b(i,j,k) + s6 * wt_t(n) ) T5(n) = wt_t(n) * T_t(i,j,k) + wt_b(n) * ( T_b(i,j,k) + t6 * wt_t(n) ) enddo - if (rho_scale /= 1.0) then - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) - else - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks) - endif + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) ! Use Boole's rule to estimate the pressure anomaly change. rho_anom = C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) @@ -802,11 +798,7 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & T5(n) = wt_t(n) * T_top + wt_b(n) * ( T_bot + t6 * wt_t(n) ) enddo - if (rho_scale /= 1.0) then - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) - else - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks) - endif + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) ! Use Boole's rule to estimate the pressure anomaly change. intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) ) @@ -886,11 +878,7 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & T5(n) = wt_t(n) * T_top + wt_b(n) * ( T_bot + t6 * wt_t(n) ) enddo - if (rho_scale /= 1.0) then - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) - else - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks) - endif + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) ! Use Boole's rule to estimate the pressure anomaly change. intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) ) From 7ae38fe90dc7e8ed6cf3973ea597a17c879e501c Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 17 Jun 2020 02:49:18 +0000 Subject: [PATCH 47/91] Adds SGS variance to tv and adds Brankart effect to PGF - Makes use of the Stanley equation of state to include effects of SGS temperature variance, salinity variance and T-S covariance. --- src/core/MOM_density_integrals.F90 | 45 +++++++++++++++++++++++++++--- src/core/MOM_variables.F90 | 8 +++++- 2 files changed, 48 insertions(+), 5 deletions(-) diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index bc2fd49257..b312d0d73b 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -656,6 +656,9 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & ! Local variables real :: T5(5) ! Temperatures along a line of subgrid locations [degC] real :: S5(5) ! Salinities along a line of subgrid locations [ppt] + real :: T25(5) ! SGS temperature variance along a line of subgrid locations [degC2] + real :: TS5(5) ! SGS temperature-salinity covariance along a line of subgrid locations [degC ppt] + real :: S25(5) ! SGS salinity variance along a line of subgrid locations [ppt2] real :: p5(5) ! Pressures at five quadrature points, never rescaled from Pa [Pa] real :: r5(5) ! Density anomalies from rho_ref at quadrature points [R ~> kg m-3] or [kg m-3] real :: wt_t(5), wt_b(5) ! Top and bottom weights [nondim] @@ -680,7 +683,9 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & 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 - logical :: use_PPM + logical :: use_PPM ! If false, assume zero curvature in reconstruction, i.e. PLM + logical :: use_stanley_eos ! True is SGS variance fields exist in tv. + logical :: use_varT, use_varS, use_covarTS Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB @@ -698,6 +703,14 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & t6 = 0. use_PPM = .true. ! This is a place-holder to allow later re-use of this function + use_varT = allocated(tv%varT) + use_covarTS = allocated(tv%covarTS) + use_varS = allocated(tv%varS) + use_stanley_eos = use_varT .or. use_covarTS .or. use_varS + T25(:) = 0. + TS5(:) = 0. + S25(:) = 0. + do n = 1, 5 wt_t(n) = 0.25 * real(5-n) wt_b(n) = 1.0 - wt_t(n) @@ -717,7 +730,15 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & S5(n) = wt_t(n) * S_t(i,j,k) + wt_b(n) * ( S_b(i,j,k) + s6 * wt_t(n) ) T5(n) = wt_t(n) * T_t(i,j,k) + wt_b(n) * ( T_b(i,j,k) + t6 * wt_t(n) ) enddo - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + if (use_stanley_eos) then + if (use_varT) T25(:) = tv%varT(i,j,k) + if (use_covarTS) TS5(:) = tv%covarTS(i,j,k) + if (use_varT) S25(:) = tv%varS(i,j,k) + call calculate_density(T5, S5, p5, T25, TS5, S25, r5, & + 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + else + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + endif ! Use Boole's rule to estimate the pressure anomaly change. rho_anom = C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) @@ -798,7 +819,15 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & T5(n) = wt_t(n) * T_top + wt_b(n) * ( T_bot + t6 * wt_t(n) ) enddo - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + if (use_stanley_eos) then + if (use_varT) T25(:) = w_left*tv%varT(i,j,k) + w_right*tv%varT(i+1,j,k) + if (use_covarTS) TS5(:) = w_left*tv%covarTS(i,j,k) + w_right*tv%covarTS(i+1,j,k) + if (use_varT) S25(:) = w_left*tv%varS(i,j,k) + w_right*tv%varS(i+1,j,k) + call calculate_density(T5, S5, p5, T25, TS5, S25, r5, & + 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + else + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + endif ! Use Boole's rule to estimate the pressure anomaly change. intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) ) @@ -878,7 +907,15 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & T5(n) = wt_t(n) * T_top + wt_b(n) * ( T_bot + t6 * wt_t(n) ) enddo - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + if (use_stanley_eos) then + if (use_varT) T25(:) = w_left*tv%varT(i,j,k) + w_right*tv%varT(i,j+1,k) + if (use_covarTS) TS5(:) = w_left*tv%covarTS(i,j,k) + w_right*tv%covarTS(i,j+1,k) + if (use_varT) S25(:) = w_left*tv%varS(i,j,k) + w_right*tv%varS(i,j+1,k) + call calculate_density(T5, S5, p5, T25, TS5, S25, r5, & + 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + else + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + endif ! Use Boole's rule to estimate the pressure anomaly change. intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) ) diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 97e5b36db5..e3a5c6f23e 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -80,7 +80,7 @@ module MOM_variables type, public :: thermo_var_ptrs ! If allocated, the following variables have nz layers. real, pointer :: T(:,:,:) => NULL() !< Potential temperature [degC]. - real, pointer :: S(:,:,:) => NULL() !< Salnity [PSU] or [gSalt/kg], generically [ppt]. + real, pointer :: S(:,:,:) => NULL() !< Salinity [PSU] or [gSalt/kg], generically [ppt]. real, pointer :: p_surf(:,:) => NULL() !< Ocean surface pressure used in equation of state !! calculations [R L2 T-2 ~> Pa] type(EOS_type), pointer :: eqn_of_state => NULL() !< Type that indicates the @@ -116,6 +116,12 @@ module MOM_variables !< Any internal or geothermal heat sources that !! have been applied to the ocean since the last call to !! calculate_surface_state [degC R Z ~> degC kg m-2]. + ! The following variables are most normally not used but when they are they + ! will be either set by parameterizations or prognostic. + real, allocatable :: varT(:,:,:) !< SGS variance of potential temperature [degC2]. + real, allocatable :: varS(:,:,:) !< SGS variance of salinity [ppt2]. + real, allocatable :: covarTS(:,:,:) !< SGS covariance of salinity and potential temperauter + !! [degC ppt]. end type thermo_var_ptrs !> Pointers to all of the prognostic variables allocated in MOM_variables.F90 and MOM.F90. From b7afafb328903d9d7a194447d55ff79f1a8ab774 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Fri, 2 Aug 2019 15:10:04 -0600 Subject: [PATCH 48/91] Adds the deterministic part of the Stanley param. --- .../lateral/MOM_thickness_diffuse.F90 | 44 ++++++++++++++++++- 1 file changed, 42 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 7d5fc8b846..ee2a100cab 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -10,6 +10,7 @@ module MOM_thickness_diffuse use MOM_domains, only : pass_var, CORNER, pass_vector use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_domain +use MOM_EOS, only : calculate_density_second_derivs use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type use MOM_interface_heights, only : find_eta @@ -19,7 +20,6 @@ module MOM_thickness_diffuse 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 @@ -77,6 +77,9 @@ module MOM_thickness_diffuse !! than the streamfunction for the GM source term. logical :: use_GM_work_bug !< If true, use the incorrect sign for the !! top-level work tendency on the top layer. + logical :: use_Stanley !< If true, use a correction to the horizontal density gradient + !! when computing the Ferrari et al., 2010 streamfunction. + type(diag_ctrl), pointer :: diag => NULL() !< structure used to regulate timing of diagnostics real, pointer :: GMwork(:,:) => NULL() !< Work by thickness diffusivity [R Z L2 T-3 ~> W m-2] real, pointer :: diagSlopeX(:,:,:) => NULL() !< Diagnostic: zonal neutral slope [nondim] @@ -668,6 +671,10 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV real :: G_rho0 ! g/Rho0 [L2 R-1 Z-1 T-2 ~> m4 kg-1 s-2]. real :: N2_floor ! A floor for N2 to avoid degeneracy in the elliptic solver ! times unit conversion factors [T-2 L2 Z-2 ~> s-2] + real :: dbeta_dS, dbeta_dT, dalpha_dT, dalpha_dS, dbeta_dP, dalpha_dP ! derivatives for EOS. + real :: dT2 ! length scale times temp. derivative, squared. + real :: dTdy2, dTdx2 ! pot. temp. derivatives, squared. + 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 @@ -848,6 +855,20 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! This is the gradient of density along geopotentials. drdx = ((wtA * drdiA + wtB * drdiB) / (wtA + wtB) - & drdz * (e(i,j,K)-e(i+1,j,K))) * G%IdxCu(I,j) + ! Correction to the horizontal density gradient due to the nonlinear EOS + if (CS%use_Stanley) then + ! Calculate dT/dx and dT/dy at u-points + dTdy2 = 0.0625*(G%IdyCv(i,J)*(T(i,j+1,k-1)-T(i,j,k-1))+ & + G%IdyCv(i,J-1)*(T(i,j,k-1)-T(i,j-1,k-1))+ & + G%IdyCv(i+1,J)*(T(i+1,j+1,k-1)-T(i+1,j,k-1))+ & + G%IdyCv(i+1,J-1)*(T(i+1,j,k-1)-T(i+1,j-1,k-1)))**2 + dT2 = (T(i+1,j,k-1)-T(i,j,k-1))**2 + (G%dyCu(I,j)**2)*dTdy2 + + call calculate_density_second_derivs(T_u(I), S_u(I), pres_u(I),dbeta_dS, & + dbeta_dT, dalpha_dT, dbeta_dP, dalpha_dP, tv%eqn_of_state) + + drdx = drdx + (dT2*dalpha_dT) + endif ! This estimate of slope is accurate for small slopes, but bounded ! to be between -1 and 1. @@ -1028,7 +1049,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV endif calc_derivatives = use_EOS .and. (k >= nk_linear) .and. & - (find_work .or. .not. present_slope_y) + (find_work .or. .not. present_slope_y .or. CS%use_FGNV_streamfn) if (calc_derivatives) then do i=is,ie @@ -1100,6 +1121,21 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV drdy = ((wtA * drdjA + wtB * drdjB) / (wtA + wtB) - & drdz * (e(i,j,K)-e(i,j+1,K))) * G%IdyCv(i,J) + ! Correction to the horizontal density gradient due to the nonlinear EOS + if (CS%use_Stanley) then + ! Calculate dT/dx and dT/dy at v-points + dTdx2 = 0.0625*(G%IdxCv(i,J)*(T(i+1,j,k-1)-T(i,j,k-1))+ & + G%IdxCv(i,J-1)*(T(i,j,k-1)-T(i-1,j,k-1))+ & + G%IdxCv(i+1,J)*(T(i+1,j+1,k-1)-T(i,j+1,k-1))+ & + G%IdxCv(i+1,J-1)*(T(i,j+1,k-1)-T(i-1,j+1,k-1)))**2 + dT2 = (T(i,j+1,k-1)-T(i,j,k-1))**2 + (G%dxCv(I,j)**2)*dTdx2 + + call calculate_density_second_derivs(T_v(I), S_v(I), pres_v(I),dbeta_dS, & + dbeta_dT, dalpha_dT, dbeta_dP, dalpha_dP, tv%eqn_of_state) + + drdy = drdy + (dT2*dalpha_dT) + endif + ! This estimate of slope is accurate for small slopes, but bounded ! to be between -1 and 1. mag_grad2 = drdy**2 + (US%L_to_Z*drdz)**2 @@ -1887,6 +1923,10 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) "streamfunction formulation, expressed as a fraction of planetary "//& "rotation, OMEGA. This should be tiny but non-zero to avoid degeneracy.", & default=1.e-15, units="nondim", do_not_log=.not.CS%use_FGNV_streamfn) + call get_param(param_file, mdl, "USE_STANLEY", CS%use_Stanley, & + "If true, use a correction to the horizontal density gradient \n"// & + "when computing the Ferrari et al., 2010 streamfunction.", & + default=.false.) call get_param(param_file, mdl, "OMEGA", omega, & "The rotation rate of the earth.", & default=7.2921e-5, units="s-1", scale=US%T_to_s, do_not_log=.not.CS%use_FGNV_streamfn) From f462c4d1311ae55f398fc265803f8b35e9249cda Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Thu, 23 Jan 2020 15:35:24 +0000 Subject: [PATCH 49/91] Re-wrote Stanley parameterization using vertical weights - This now calculates the gradient of SGS temperature variance using the same discretization as used for the gradient of density along coordinate surfaces. - Added run-time coefficient for Stanley parameterization - Fixed openmp directives. - Alters halo over which vert_fill_TS() is called. - Add Stanley parameter to tc2 to test new code. --- .testing/tc2/MOM_input | 4 + .../lateral/MOM_thickness_diffuse.F90 | 118 +++++++++++------- 2 files changed, 74 insertions(+), 48 deletions(-) diff --git a/.testing/tc2/MOM_input b/.testing/tc2/MOM_input index 6678c00578..5c5f45bd11 100644 --- a/.testing/tc2/MOM_input +++ b/.testing/tc2/MOM_input @@ -426,6 +426,10 @@ KHTH = 1.0 ! [m2 s-1] default = 0.0 ! The background horizontal thickness diffusivity. KHTH_MAX = 900.0 ! [m2 s-1] default = 0.0 ! The maximum horizontal thickness diffusivity. +STANLEY_DET_COEFF = 0.5 ! [nondim] default = -1.0 + ! The coefficient correlating SGS temperature variance with the mean temperature + ! gradient in the deterministic part of the Stanley parameterization. Negative + ! values disable the scheme. ! === module MOM_mixed_layer_restrat === FOX_KEMPER_ML_RESTRAT_COEF = 5.0 ! [nondim] default = 0.0 diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index ee2a100cab..ad00acc88c 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -77,8 +77,9 @@ module MOM_thickness_diffuse !! than the streamfunction for the GM source term. logical :: use_GM_work_bug !< If true, use the incorrect sign for the !! top-level work tendency on the top layer. - logical :: use_Stanley !< If true, use a correction to the horizontal density gradient - !! when computing the Ferrari et al., 2010 streamfunction. + real :: Stanley_det_coeff !< The coefficient correlating SGS temperature variance with the mean + !! temperature gradient in the deterministic part of the Stanley parameterization. + !! Negative values disable the scheme." [nondim] type(diag_ctrl), pointer :: diag => NULL() !< structure used to regulate timing of diagnostics real, pointer :: GMwork(:,:) => NULL() !< Work by thickness diffusivity [R Z L2 T-3 ~> W m-2] @@ -602,10 +603,13 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV h_avail_rsum ! The running sum of h_avail above an interface [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZIB_(G)) :: & drho_dT_u, & ! The derivative of density with temperature at u points [R degC-1 ~> kg m-3 degC-1] - drho_dS_u ! The derivative of density with salinity at u points [R ppt-1 ~> kg m-3 ppt-1]. + drho_dS_u, & ! The derivative of density with salinity at u points [R ppt-1 ~> kg m-3 ppt-1]. + drho_dT_dT_u ! The second derivative of density with temperature at u points [R degC-2 ~> kg m-3 degC-2] + real, dimension(SZIB_(G)) :: scrap ! An array to pass to calculate_density_second_derivs() that will be ingored. real, dimension(SZI_(G)) :: & drho_dT_v, & ! The derivative of density with temperature at v points [R degC-1 ~> kg m-3 degC-1] - drho_dS_v ! The derivative of density with salinity at v points [R ppt-1 ~> kg m-3 ppt-1]. + drho_dS_v, & ! The derivative of density with salinity at v points [R ppt-1 ~> kg m-3 ppt-1]. + drho_dT_dT_v ! The second derivative of density with temperature at v points [R degC-2 ~> kg m-3 degC-2] real :: uhtot(SZIB_(G), SZJ_(G)) ! The vertical sum of uhD [H L2 T-1 ~> m3 s-1 or kg s-1]. real :: vhtot(SZI_(G), SZJB_(G)) ! The vertical sum of vhD [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZIB_(G)) :: & @@ -671,9 +675,8 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV real :: G_rho0 ! g/Rho0 [L2 R-1 Z-1 T-2 ~> m4 kg-1 s-2]. real :: N2_floor ! A floor for N2 to avoid degeneracy in the elliptic solver ! times unit conversion factors [T-2 L2 Z-2 ~> s-2] - real :: dbeta_dS, dbeta_dT, dalpha_dT, dalpha_dS, dbeta_dP, dalpha_dP ! derivatives for EOS. - real :: dT2 ! length scale times temp. derivative, squared. - real :: dTdy2, dTdx2 ! pot. temp. derivatives, squared. + real :: dTdi2, dTdj2 ! pot. temp. differences, squared. + real, dimension(SZI_(G), SZJ_(G), SZK_(G)) :: Tsgs2 ! Sub-grid temperature variance [degC2] 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 @@ -683,7 +686,8 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! state calculations at u-points. integer, dimension(2) :: EOSdom_v ! The shifted I-computational domain to use for equation of ! state calculations at v-points. - integer :: is, ie, js, je, nz, IsdB + logical :: use_Stanley + integer :: is, ie, js, je, nz, IsdB, halo integer :: i, j, k is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke ; IsdB = G%IsdB @@ -701,6 +705,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV present_int_slope_v = PRESENT(int_slope_v) present_slope_x = PRESENT(slope_x) present_slope_y = PRESENT(slope_y) + use_Stanley = CS%Stanley_det_coeff >= 0. nk_linear = max(GV%nkml, 1) @@ -714,15 +719,18 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV find_work = (associated(CS%GMwork) .or. find_work) if (use_EOS) then - call vert_fill_TS(h, tv%T, tv%S, CS%kappa_smooth*dt, T, S, G, GV, 1, larger_h_denom=.true.) + halo = 1 ! Default halo to fill is 1 + if (use_Stanley) halo = 2 ! Need wider valid halo for gradients of T + call vert_fill_TS(h, tv%T, tv%S, CS%kappa_smooth*dt, T, S, G, GV, halo, larger_h_denom=.true.) endif if (CS%use_FGNV_streamfn .and. .not. associated(cg1)) call MOM_error(FATAL, & "cg1 must be associated when using FGNV streamfunction.") -!$OMP parallel default(none) shared(is,ie,js,je,h_avail_rsum,pres,h_avail,I4dt, & -!$OMP G,GV,tv,h,h_frac,nz,uhtot,Work_u,vhtot,Work_v, & -!$OMP diag_sfn_x, diag_sfn_y, diag_sfn_unlim_x, diag_sfn_unlim_y ) +!$OMP parallel default(none) shared(is,ie,js,je,h_avail_rsum,pres,h_avail,I4dt, use_Stanley, & +!$OMP CS,G,GV,tv,h,h_frac,nz,uhtot,Work_u,vhtot,Work_v,Tsgs2,T, & +!$OMP diag_sfn_x, diag_sfn_y, diag_sfn_unlim_x, diag_sfn_unlim_y ) & +!$OMP private(dTdi2,dTdj2) ! Find the maximum and minimum permitted streamfunction. !$OMP do do j=js-1,je+1 ; do i=is-1,ie+1 @@ -735,6 +743,20 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV h_frac(i,j,1) = 1.0 pres(i,j,2) = pres(i,j,1) + (GV%g_Earth*GV%H_to_RZ) * h(i,j,1) enddo ; enddo + if (use_Stanley) then +!$OMP do + do k=1, nz ; do j=js-1,je+1 ; do i=is-1,ie+1 + ! SGS variance in i-direction [degC2] + dTdi2 = ( ( G%mask2dCu(I ,j) * G%IdxCu(I ,j) * ( T(i+1,j,k) - T(i,j,k) ) & + + G%mask2dCu(I-1,j) * G%IdxCu(I-1,j) * ( T(i,j,k) - T(i-1,j,k) ) & + ) * G%dxT(i,j) * 0.5 )**2 + ! SGS variance in j-direction [degC2] + dTdj2 = ( ( G%mask2dCv(i,J ) * G%IdyCv(i,J ) * ( T(i,j+1,k) - T(i,j,k) ) & + + G%mask2dCv(i,J-1) * G%IdyCv(i,J-1) * ( T(i,j,k) - T(i,j-1,k) ) & + ) * G%dyT(i,j) * 0.5 )**2 + Tsgs2(i,j,k) = CS%Stanley_det_coeff * 0.5 * ( dTdi2 + dTdj2 ) + enddo ; enddo ; enddo + endif !$OMP do do j=js-1,je+1 do k=2,nz ; do i=is-1,ie+1 @@ -766,9 +788,11 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV !$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,EOSdom_u, & +!$OMP use_stanley, Tsgs2, & !$OMP present_slope_x,G_rho0,Slope_x_PE,hN2_x_PE) & !$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 drho_dT_dT_u,scrap, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & !$OMP drdx,mag_grad2,Slope,slope2_Ratio_u,hN2_u, & !$OMP Sfn_unlim_u,drdi_u,drdkDe_u,h_harm,c2_h_u, & @@ -782,7 +806,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV endif calc_derivatives = use_EOS .and. (k >= nk_linear) .and. & - (find_work .or. .not. present_slope_x .or. CS%use_FGNV_streamfn) + (find_work .or. .not. present_slope_x .or. CS%use_FGNV_streamfn .or. use_Stanley) ! Calculate the zonal fluxes and gradients. if (calc_derivatives) then @@ -794,6 +818,13 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV call calculate_density_derivs(T_u, S_u, pres_u, drho_dT_u, drho_dS_u, & tv%eqn_of_state, EOSdom_u) endif + if (use_Stanley) then + ! The second line below would correspond to arguments + ! drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, drho_dT_dP, & + call calculate_density_second_derivs(T_u, S_u, pres_u, & + scrap, scrap, drho_dT_dT_u, scrap, scrap, & + (is-IsdB+1)-1, ie-is+2, tv%eqn_of_state, scale=US%kg_m3_to_R) + endif do I=is-1,ie if (calc_derivatives) then @@ -812,7 +843,12 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV elseif (find_work) then ! This is used in pure stacked SW mode drdkDe_u(I,K) = drdkR * e(i+1,j,K) - drdkL * e(i,j,K) endif - + if (use_Stanley) then + ! Correction to the horizontal density gradient due to nonlinearity in + ! the EOS rectifying SGS temperature anomalies + drdiA = drdiA + drho_dT_dT_u(I) * ( Tsgs2(i+1,j,k-1)-Tsgs2(i,j,k-1) ) + drdiB = drdiB + drho_dT_dT_u(I) * ( Tsgs2(i+1,j,k)-Tsgs2(i,j,k) ) + endif if (find_work) drdi_u(I,k) = drdiB if (k > nk_linear) then @@ -855,20 +891,6 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! This is the gradient of density along geopotentials. drdx = ((wtA * drdiA + wtB * drdiB) / (wtA + wtB) - & drdz * (e(i,j,K)-e(i+1,j,K))) * G%IdxCu(I,j) - ! Correction to the horizontal density gradient due to the nonlinear EOS - if (CS%use_Stanley) then - ! Calculate dT/dx and dT/dy at u-points - dTdy2 = 0.0625*(G%IdyCv(i,J)*(T(i,j+1,k-1)-T(i,j,k-1))+ & - G%IdyCv(i,J-1)*(T(i,j,k-1)-T(i,j-1,k-1))+ & - G%IdyCv(i+1,J)*(T(i+1,j+1,k-1)-T(i+1,j,k-1))+ & - G%IdyCv(i+1,J-1)*(T(i+1,j,k-1)-T(i+1,j-1,k-1)))**2 - dT2 = (T(i+1,j,k-1)-T(i,j,k-1))**2 + (G%dyCu(I,j)**2)*dTdy2 - - call calculate_density_second_derivs(T_u(I), S_u(I), pres_u(I),dbeta_dS, & - dbeta_dT, dalpha_dT, dbeta_dP, dalpha_dP, tv%eqn_of_state) - - drdx = drdx + (dT2*dalpha_dT) - endif ! This estimate of slope is accurate for small slopes, but bounded ! to be between -1 and 1. @@ -1034,9 +1056,11 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV !$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,EOSdom_v,& +!$OMP use_stanley, Tsgs2, & !$OMP present_slope_y,G_rho0,Slope_y_PE,hN2_y_PE) & !$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 drho_dT_dT_v,scrap, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & !$OMP drdy,mag_grad2,Slope,slope2_Ratio_v,hN2_v, & !$OMP Sfn_unlim_v,drdj_v,drdkDe_v,h_harm,c2_h_v, & @@ -1049,7 +1073,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV endif calc_derivatives = use_EOS .and. (k >= nk_linear) .and. & - (find_work .or. .not. present_slope_y .or. CS%use_FGNV_streamfn) + (find_work .or. .not. present_slope_y .or. CS%use_FGNV_streamfn .or. use_Stanley) if (calc_derivatives) then do i=is,ie @@ -1060,6 +1084,13 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV call calculate_density_derivs(T_v, S_v, pres_v, drho_dT_v, drho_dS_v, & tv%eqn_of_state, EOSdom_v) endif + if (use_Stanley) then + ! The second line below would correspond to arguments + ! drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, drho_dT_dP, & + call calculate_density_second_derivs(T_v, S_v, pres_v, & + scrap, scrap, drho_dT_dT_v, scrap, scrap, & + is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + endif do i=is,ie if (calc_derivatives) then ! Estimate the horizontal density gradients along layers. @@ -1077,6 +1108,12 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV elseif (find_work) then ! This is used in pure stacked SW mode drdkDe_v(i,K) = drdkR * e(i,j+1,K) - drdkL * e(i,j,K) endif + if (use_Stanley) then + ! Correction to the horizontal density gradient due to nonlinearity in + ! the EOS rectifying SGS temperature anomalies + drdjA = drdjA + drho_dT_dT_v(I) * ( Tsgs2(i,j+1,k-1)-Tsgs2(i,j,k-1) ) + drdjB = drdjB + drho_dT_dT_v(I) * ( Tsgs2(i,j+1,k)-Tsgs2(i,j,k) ) + endif if (find_work) drdj_v(i,k) = drdjB @@ -1121,21 +1158,6 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV drdy = ((wtA * drdjA + wtB * drdjB) / (wtA + wtB) - & drdz * (e(i,j,K)-e(i,j+1,K))) * G%IdyCv(i,J) - ! Correction to the horizontal density gradient due to the nonlinear EOS - if (CS%use_Stanley) then - ! Calculate dT/dx and dT/dy at v-points - dTdx2 = 0.0625*(G%IdxCv(i,J)*(T(i+1,j,k-1)-T(i,j,k-1))+ & - G%IdxCv(i,J-1)*(T(i,j,k-1)-T(i-1,j,k-1))+ & - G%IdxCv(i+1,J)*(T(i+1,j+1,k-1)-T(i,j+1,k-1))+ & - G%IdxCv(i+1,J-1)*(T(i,j+1,k-1)-T(i-1,j+1,k-1)))**2 - dT2 = (T(i,j+1,k-1)-T(i,j,k-1))**2 + (G%dxCv(I,j)**2)*dTdx2 - - call calculate_density_second_derivs(T_v(I), S_v(I), pres_v(I),dbeta_dS, & - dbeta_dT, dalpha_dT, dbeta_dP, dalpha_dP, tv%eqn_of_state) - - drdy = drdy + (dT2*dalpha_dT) - endif - ! This estimate of slope is accurate for small slopes, but bounded ! to be between -1 and 1. mag_grad2 = drdy**2 + (US%L_to_Z*drdz)**2 @@ -1923,10 +1945,10 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) "streamfunction formulation, expressed as a fraction of planetary "//& "rotation, OMEGA. This should be tiny but non-zero to avoid degeneracy.", & default=1.e-15, units="nondim", do_not_log=.not.CS%use_FGNV_streamfn) - call get_param(param_file, mdl, "USE_STANLEY", CS%use_Stanley, & - "If true, use a correction to the horizontal density gradient \n"// & - "when computing the Ferrari et al., 2010 streamfunction.", & - default=.false.) + call get_param(param_file, mdl, "STANLEY_DET_COEFF", CS%Stanley_det_coeff, & + "The coefficient correlating SGS temperature variance with the mean "//& + "temperature gradient in the deterministic part of the Stanley parameterization. "//& + "Negative values disable the scheme.", units="nondim", default=-1.0) call get_param(param_file, mdl, "OMEGA", omega, & "The rotation rate of the earth.", & default=7.2921e-5, units="s-1", scale=US%T_to_s, do_not_log=.not.CS%use_FGNV_streamfn) From 75a20d8d9e2db7ea73072b017b2e016899e2231f Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Thu, 18 Jun 2020 14:53:48 +0000 Subject: [PATCH 50/91] Added STANLEY_PRM_DET_COEFF run time parameter - Renamed STANLEY_DET_COEFF to STANLEY_PRM_DET_COEFF to indicate this is for the Stanley parameterization as opposed to a related approach by Stanley for implementing the Brankart PGF correction. --- .testing/tc2/MOM_input | 2 +- src/parameterizations/lateral/MOM_thickness_diffuse.F90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.testing/tc2/MOM_input b/.testing/tc2/MOM_input index 5c5f45bd11..bef1dc9aef 100644 --- a/.testing/tc2/MOM_input +++ b/.testing/tc2/MOM_input @@ -426,7 +426,7 @@ KHTH = 1.0 ! [m2 s-1] default = 0.0 ! The background horizontal thickness diffusivity. KHTH_MAX = 900.0 ! [m2 s-1] default = 0.0 ! The maximum horizontal thickness diffusivity. -STANLEY_DET_COEFF = 0.5 ! [nondim] default = -1.0 +STANLEY_PRM_DET_COEFF = 0.5 ! [nondim] default = -1.0 ! The coefficient correlating SGS temperature variance with the mean temperature ! gradient in the deterministic part of the Stanley parameterization. Negative ! values disable the scheme. diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index ad00acc88c..e0a2fcdef9 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -1945,7 +1945,7 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) "streamfunction formulation, expressed as a fraction of planetary "//& "rotation, OMEGA. This should be tiny but non-zero to avoid degeneracy.", & default=1.e-15, units="nondim", do_not_log=.not.CS%use_FGNV_streamfn) - call get_param(param_file, mdl, "STANLEY_DET_COEFF", CS%Stanley_det_coeff, & + call get_param(param_file, mdl, "STANLEY_PRM_DET_COEFF", CS%Stanley_det_coeff, & "The coefficient correlating SGS temperature variance with the mean "//& "temperature gradient in the deterministic part of the Stanley parameterization. "//& "Negative values disable the scheme.", units="nondim", default=-1.0) From c94e0cbdbd93512ad90956f83713c832398b8108 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Thu, 18 Jun 2020 14:56:31 +0000 Subject: [PATCH 51/91] Adds the T variance Stanley component to PGF - PGF_STANLEY_T2_DET_COEFF>=0. now adds the temperature variance contribution to the Brankart correction using the Stanley linearization of the EOS and parameterization of SGS variance. --- .testing/tc2/MOM_input | 1 + src/core/MOM_PressureForce_FV.F90 | 27 ++++++++++++++++++++++++--- src/core/MOM_density_integrals.F90 | 12 ++++++------ src/core/MOM_variables.F90 | 8 ++++---- 4 files changed, 35 insertions(+), 13 deletions(-) diff --git a/.testing/tc2/MOM_input b/.testing/tc2/MOM_input index bef1dc9aef..d5a904d841 100644 --- a/.testing/tc2/MOM_input +++ b/.testing/tc2/MOM_input @@ -430,6 +430,7 @@ STANLEY_PRM_DET_COEFF = 0.5 ! [nondim] default = -1.0 ! The coefficient correlating SGS temperature variance with the mean temperature ! gradient in the deterministic part of the Stanley parameterization. Negative ! values disable the scheme. +PGF_STANLEY_T2_DET_COEFF = 0.5 ! === module MOM_mixed_layer_restrat === FOX_KEMPER_ML_RESTRAT_COEF = 5.0 ! [nondim] default = 0.0 diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 9f6ad779d0..132b403cf4 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -54,7 +54,9 @@ module MOM_PressureForce_FV integer :: Recon_Scheme !< Order of the polynomial of the reconstruction of T & S !! for the finite volume pressure gradient calculation. !! By the default (1) is for a piecewise linear method - + real :: Stanley_T2_det_coeff !< The coefficient correlating SGS temperature variance with + !! the mean temperature gradient in the deterministic part of + !! the Stanley form of the Brankart correction. integer :: id_e_tidal = -1 !< Diagnostic identifier type(tidal_forcing_CS), pointer :: tides_CSp => NULL() !< Tides control structure end type PressureForce_FV_CS @@ -474,7 +476,7 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm 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 :: dTdi2, dTdj2 ! Differences in T variance [degC2] real, parameter :: C1_6 = 1.0/6.0 integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb @@ -495,6 +497,21 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm use_ALE = .false. if (associated(ALE_CSp)) use_ALE = CS%reconstruct .and. use_EOS + if (CS%Stanley_T2_det_coeff>=0.) then + if (.not. associated(tv%varT)) call safe_alloc_ptr(tv%varT, G%isd, G%ied, G%jsd, G%jed, GV%ke) + do k=1, nz ; do j=js-1,je+1 ; do i=is-1,ie+1 + ! SGS variance in i-direction [degC2] + dTdi2 = ( ( G%mask2dCu(I ,j) * G%IdxCu(I ,j) * ( tv%T(i+1,j,k) - tv%T(i,j,k) ) & + + G%mask2dCu(I-1,j) * G%IdxCu(I-1,j) * ( tv%T(i,j,k) - tv%T(i-1,j,k) ) & + ) * G%dxT(i,j) * 0.5 )**2 + ! SGS variance in j-direction [degC2] + dTdj2 = ( ( G%mask2dCv(i,J ) * G%IdyCv(i,J ) * ( tv%T(i,j+1,k) - tv%T(i,j,k) ) & + + G%mask2dCv(i,J-1) * G%IdyCv(i,J-1) * ( tv%T(i,j,k) - tv%T(i,j-1,k) ) & + ) * G%dyT(i,j) * 0.5 )**2 + tv%varT(i,j,k) = CS%Stanley_T2_det_coeff * 0.5 * ( dTdi2 + dTdj2 ) + enddo ; enddo ; enddo + endif + h_neglect = GV%H_subroundoff dz_neglect = GV%H_subroundoff * GV%H_to_Z I_Rho0 = 1.0 / GV%Rho0 @@ -801,7 +818,11 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, tides_CS "boundary cells is extrapolated, rather than using PCM "//& "in these cells. If true, the same order polynomial is "//& "used as is used for the interior cells.", default=.true.) - + call get_param(param_file, mdl, "PGF_STANLEY_T2_DET_COEFF", CS%Stanley_T2_det_coeff, & + "The coefficient correlating SGS temperature variance with "// & + "the mean temperature gradient in the deterministic part of "// & + "the Stanley form of the Brankart correction. "// & + "Negative values disable the scheme.", units="nondim", default=-1.0) 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', conversion=US%Z_to_m) diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index b312d0d73b..d8eb2d80f8 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -703,9 +703,9 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & t6 = 0. use_PPM = .true. ! This is a place-holder to allow later re-use of this function - use_varT = allocated(tv%varT) - use_covarTS = allocated(tv%covarTS) - use_varS = allocated(tv%varS) + use_varT = associated(tv%varT) + use_covarTS = associated(tv%covarTS) + use_varS = associated(tv%varS) use_stanley_eos = use_varT .or. use_covarTS .or. use_varS T25(:) = 0. TS5(:) = 0. @@ -733,7 +733,7 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & if (use_stanley_eos) then if (use_varT) T25(:) = tv%varT(i,j,k) if (use_covarTS) TS5(:) = tv%covarTS(i,j,k) - if (use_varT) S25(:) = tv%varS(i,j,k) + if (use_varS) S25(:) = tv%varS(i,j,k) call calculate_density(T5, S5, p5, T25, TS5, S25, r5, & 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) else @@ -822,7 +822,7 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & if (use_stanley_eos) then if (use_varT) T25(:) = w_left*tv%varT(i,j,k) + w_right*tv%varT(i+1,j,k) if (use_covarTS) TS5(:) = w_left*tv%covarTS(i,j,k) + w_right*tv%covarTS(i+1,j,k) - if (use_varT) S25(:) = w_left*tv%varS(i,j,k) + w_right*tv%varS(i+1,j,k) + if (use_varS) S25(:) = w_left*tv%varS(i,j,k) + w_right*tv%varS(i+1,j,k) call calculate_density(T5, S5, p5, T25, TS5, S25, r5, & 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) else @@ -910,7 +910,7 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & if (use_stanley_eos) then if (use_varT) T25(:) = w_left*tv%varT(i,j,k) + w_right*tv%varT(i,j+1,k) if (use_covarTS) TS5(:) = w_left*tv%covarTS(i,j,k) + w_right*tv%covarTS(i,j+1,k) - if (use_varT) S25(:) = w_left*tv%varS(i,j,k) + w_right*tv%varS(i,j+1,k) + if (use_varS) S25(:) = w_left*tv%varS(i,j,k) + w_right*tv%varS(i,j+1,k) call calculate_density(T5, S5, p5, T25, TS5, S25, r5, & 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) else diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index e3a5c6f23e..a290515306 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -118,10 +118,10 @@ module MOM_variables !! calculate_surface_state [degC R Z ~> degC kg m-2]. ! The following variables are most normally not used but when they are they ! will be either set by parameterizations or prognostic. - real, allocatable :: varT(:,:,:) !< SGS variance of potential temperature [degC2]. - real, allocatable :: varS(:,:,:) !< SGS variance of salinity [ppt2]. - real, allocatable :: covarTS(:,:,:) !< SGS covariance of salinity and potential temperauter - !! [degC ppt]. + real, pointer :: varT(:,:,:) !< SGS variance of potential temperature [degC2]. + real, pointer :: varS(:,:,:) !< SGS variance of salinity [ppt2]. + real, pointer :: covarTS(:,:,:) !< SGS covariance of salinity and potential temperauter + !! [degC ppt]. end type thermo_var_ptrs !> Pointers to all of the prognostic variables allocated in MOM_variables.F90 and MOM.F90. From 073b4223192758c0bb496902d94f1554ca1f7c2b Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Sat, 20 Jun 2020 03:49:13 +0000 Subject: [PATCH 52/91] Nullified new pointers in tv - After starting with allocatables and switching to pointers I'd forgotten to nullify them. --- src/core/MOM_variables.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index a290515306..26c2344f44 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -118,10 +118,10 @@ module MOM_variables !! calculate_surface_state [degC R Z ~> degC kg m-2]. ! The following variables are most normally not used but when they are they ! will be either set by parameterizations or prognostic. - real, pointer :: varT(:,:,:) !< SGS variance of potential temperature [degC2]. - real, pointer :: varS(:,:,:) !< SGS variance of salinity [ppt2]. - real, pointer :: covarTS(:,:,:) !< SGS covariance of salinity and potential temperauter - !! [degC ppt]. + real, pointer :: varT(:,:,:) => NULL() !< SGS variance of potential temperature [degC2]. + real, pointer :: varS(:,:,:) => NULL() !< SGS variance of salinity [ppt2]. + real, pointer :: covarTS(:,:,:) => NULL() !< SGS covariance of salinity and potential + !! temperature [degC ppt]. end type thermo_var_ptrs !> Pointers to all of the prognostic variables allocated in MOM_variables.F90 and MOM.F90. From b7341c2ed1ec09725e5a1f205fa118b0902d0cea Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Mon, 6 Jul 2020 19:34:22 -0400 Subject: [PATCH 53/91] Correct scaling for second derivs in Stanley param - Passing the scale= to calculate_density_second_derivs() was the double scaling the density contribution from SGS variance in the Stanley parameterization. --- src/parameterizations/lateral/MOM_thickness_diffuse.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index e0a2fcdef9..b59ab34c91 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -823,7 +823,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, drho_dT_dP, & call calculate_density_second_derivs(T_u, S_u, pres_u, & scrap, scrap, drho_dT_dT_u, scrap, scrap, & - (is-IsdB+1)-1, ie-is+2, tv%eqn_of_state, scale=US%kg_m3_to_R) + (is-IsdB+1)-1, ie-is+2, tv%eqn_of_state) endif do I=is-1,ie @@ -1089,7 +1089,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, drho_dT_dP, & call calculate_density_second_derivs(T_v, S_v, pres_v, & scrap, scrap, drho_dT_dT_v, scrap, scrap, & - is, ie-is+1, tv%eqn_of_state, scale=US%kg_m3_to_R) + is, ie-is+1, tv%eqn_of_state) endif do i=is,ie if (calc_derivatives) then From 6356092d902eb697ede213d591d347791faecde0 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 7 Jul 2020 08:49:38 -0400 Subject: [PATCH 54/91] Corrected indentation in MOM_EOS - select case statements were indented as if once inside a loop. --- src/equation_of_state/MOM_EOS.F90 | 31 +++++++++++++++---------------- 1 file changed, 15 insertions(+), 16 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 84858aabcd..3427e46a7b 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -252,27 +252,26 @@ subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_re real, optional, intent(in) :: rho_ref !< A reference density [kg m-3] real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density !! in combination with scaling given by US [various] - integer :: j if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_array called with an unassociated EOS_type EOS.") - select case (EOS%form_of_EOS) - case (EOS_LINEAR) - call calculate_density_linear(T, S, pressure, rho, start, npts, & - EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, rho_ref) - case (EOS_UNESCO) - call calculate_density_unesco(T, S, pressure, rho, start, npts, rho_ref) - case (EOS_WRIGHT) - call calculate_density_wright(T, S, pressure, rho, start, npts, rho_ref) - case (EOS_TEOS10) - call calculate_density_teos10(T, S, pressure, rho, start, npts, rho_ref) - case (EOS_NEMO) - call calculate_density_nemo(T, S, pressure, rho, start, npts, rho_ref) - case default - call MOM_error(FATAL, "calculate_density_array: EOS%form_of_EOS is not valid.") - end select + select case (EOS%form_of_EOS) + case (EOS_LINEAR) + call calculate_density_linear(T, S, pressure, rho, start, npts, & + EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, rho_ref) + case (EOS_UNESCO) + call calculate_density_unesco(T, S, pressure, rho, start, npts, rho_ref) + case (EOS_WRIGHT) + call calculate_density_wright(T, S, pressure, rho, start, npts, rho_ref) + case (EOS_TEOS10) + call calculate_density_teos10(T, S, pressure, rho, start, npts, rho_ref) + case (EOS_NEMO) + call calculate_density_nemo(T, S, pressure, rho, start, npts, rho_ref) + case default + call MOM_error(FATAL, "calculate_density_array: EOS%form_of_EOS is not valid.") + end select if (present(scale)) then ; if (scale /= 1.0) then ; do j=start,start+npts-1 rho(j) = scale * rho(j) From 7544c7917fa6c37548b5baae85172710da8270ca Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 7 Jul 2020 08:52:41 -0400 Subject: [PATCH 55/91] Fixed pressure scaling for calculate_stanley_density_array() - The pressure scaling was wrong when trying to call calculate_density_second_derivs_array() from within calculate_stanley_density_array() because the latter should not do any scaling but the former always did. I had to call the lower level functions provided by WRIGHT, TEOS10, etc to avoid get the scaling tests to pass. --- src/core/MOM_density_integrals.F90 | 1 - src/equation_of_state/MOM_EOS.F90 | 27 ++++++++++++++++++++------- 2 files changed, 20 insertions(+), 8 deletions(-) diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index d8eb2d80f8..9e86a94ec1 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -10,7 +10,6 @@ module MOM_density_integrals use MOM_EOS, only : calculate_density use MOM_EOS, only : calculate_spec_vol use MOM_EOS, only : calculate_specific_vol_derivs -use MOM_EOS, only : calculate_density_second_derivs use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_hor_index, only : hor_index_type diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 3427e46a7b..7f70281783 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -291,7 +291,7 @@ subroutine calculate_stanley_density_array(T, S, pressure, Tvar, TScov, Svar, rh real, dimension(:), intent(in) :: Tvar !< Variance of potential temperature referenced to the surface [degC2] real, dimension(:), intent(in) :: TScov !< Covariance of potential temperature and salinity [degC ppt] real, dimension(:), intent(in) :: Svar !< Variance of salinity [ppt2] - real, dimension(:), intent(inout) :: rho !< Density (in-situ if pressure is local) [kg m-3] or [R ~> kg m-3] + real, dimension(:), intent(inout) :: 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 @@ -305,15 +305,28 @@ subroutine calculate_stanley_density_array(T, S, pressure, Tvar, TScov, Svar, rh if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_array called with an unassociated EOS_type EOS.") - ! Branching to the correct EOS happens within each of these calls - ! and will appropriately error if the second derivatives are not available. - call calculate_density_second_derivs_array(T, S, pressure, d2RdSS, d2RdST, d2RdTT, & - d2RdSp, d2RdTp, start, npts, EOS) - call calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_ref) + select case (EOS%form_of_EOS) + case (EOS_LINEAR) + call calculate_density_linear(T, S, pressure, rho, start, npts, & + EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, rho_ref) + call calculate_density_second_derivs_linear(T, S, pressure, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP, start, npts) + case (EOS_WRIGHT) + call calculate_density_wright(T, S, pressure, rho, start, npts, rho_ref) + call calculate_density_second_derivs_wright(T, S, pressure, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP, start, npts) + case (EOS_TEOS10) + call calculate_density_teos10(T, S, pressure, rho, start, npts, rho_ref) + call calculate_density_second_derivs_teos10(T, S, pressure, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP, start, npts) + case default + call MOM_error(FATAL, "calculate_stanley_density_array: EOS%form_of_EOS is not valid.") + end select ! Equation 25 of Stanley et al., 2020. do j=start,start+npts-1 - rho(j) = rho(j) + ( 0.5 * d2RdTT(j) * Tvar(j) + ( d2RdST(j) * TScov(j) + 0.5 * d2RdSS(j) * Svar(j) ) ) + rho(j) = rho(j) & + + ( 0.5 * d2RdTT(j) * Tvar(j) + ( d2RdST(j) * TScov(j) + 0.5 * d2RdSS(j) * Svar(j) ) ) enddo if (present(scale)) then ; if (scale /= 1.0) then ; do j=start,start+npts-1 From 31b7e0a14a792864d2aadaeddb4d2d133566bf65 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 7 Jul 2020 17:11:03 -0400 Subject: [PATCH 56/91] Re-factored int_density_dz_generic_plm() - In preparing to add Brankartc terms to PLM form of presure gradient I'm adapting the routine to look like the PPM routine which takes 3D arguments but only works on layer "k". --- src/core/MOM_PressureForce_FV.F90 | 8 +-- src/core/MOM_density_integrals.F90 | 94 ++++++++++++++++-------------- 2 files changed, 53 insertions(+), 49 deletions(-) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 132b403cf4..4da503f498 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -657,12 +657,12 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm ! 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), S_t(:,:,k), S_b(:,:,k),& - e(:,:,K), e(:,:,K+1), rho_ref, CS%Rho0, GV%g_Earth, dz_neglect, G%bathyT, & - G%HI, tv%eqn_of_state, US, dpa, intz_dpa, intx_dpa, inty_dpa, & + call int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, & + rho_ref, CS%Rho0, GV%g_Earth, dz_neglect, G%bathyT, & + G%HI, GV, tv%eqn_of_state, US, dpa, intz_dpa, intx_dpa, inty_dpa, & useMassWghtInterp=CS%useMassWghtInterp) elseif ( CS%Recon_Scheme == 2 ) then - call int_density_dz_generic_ppm( k, tv, T_t, T_b, S_t, S_b, e, & + call int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & rho_ref, CS%Rho0, GV%g_Earth, dz_neglect, G%bathyT, & G%HI, GV, tv%eqn_of_state, US, dpa, intz_dpa, intx_dpa, inty_dpa, & useMassWghtInterp=CS%useMassWghtInterp) diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index 9e86a94ec1..bd2ef2fd48 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -295,22 +295,23 @@ end subroutine int_density_dz_generic_pcm !> 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, HI, EOS, US, dpa, & +subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & + rho_0, G_e, dz_subroundoff, bathyT, HI, GV, EOS, US, dpa, & intz_dpa, intx_dpa, inty_dpa, useMassWghtInterp) + integer, intent(in) :: k !< Layer index to calculate integrals for type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structures for the input arrays - real, dimension(SZI_(HI),SZJ_(HI)), & + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & intent(in) :: T_t !< Potential temperature at the cell top [degC] - real, dimension(SZI_(HI),SZJ_(HI)), & + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & intent(in) :: T_b !< Potential temperature at the cell bottom [degC] - real, dimension(SZI_(HI),SZJ_(HI)), & + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & intent(in) :: S_t !< Salinity at the cell top [ppt] - real, dimension(SZI_(HI),SZJ_(HI)), & + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & intent(in) :: S_b !< Salinity at the cell bottom [ppt] - real, dimension(SZI_(HI),SZJ_(HI)), & - intent(in) :: z_t !< The geometric height at the top of the layer [Z ~> m] - real, dimension(SZI_(HI),SZJ_(HI)), & - intent(in) :: z_b !< The geometric height at the bottom of the layer [Z ~> m] + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)+1), & + intent(in) :: e !< Height of interfaces [Z ~> m] real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that is subtracted !! out to reduce the magnitude of each of the integrals. real, intent(in) :: rho_0 !< A density [R ~> kg m-3] or [kg m-3], that is used to calculate @@ -402,12 +403,12 @@ subroutine int_density_dz_generic_plm(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & ! 1. Compute vertical integrals do j=Jsq,Jeq+1 do i = Isq,Ieq+1 - dz(i) = z_t(i,j) - z_b(i,j) + dz(i) = e(i,j,K) - e(i,j,K+1) do n=1,5 - p5(i*5+n) = -GxRho*(z_t(i,j) - 0.25*real(n-1)*dz(i)) + p5(i*5+n) = -GxRho*(e(i,j,K) - 0.25*real(n-1)*dz(i)) ! Salinity and temperature points are linearly interpolated - S5(i*5+n) = wt_t(n) * S_t(i,j) + wt_b(n) * S_b(i,j) - T5(i*5+n) = wt_t(n) * T_t(i,j) + wt_b(n) * T_b(i,j) + S5(i*5+n) = wt_t(n) * S_t(i,j,k) + wt_b(n) * S_b(i,j,k) + T5(i*5+n) = wt_t(n) * T_t(i,j,k) + wt_b(n) * T_b(i,j,k) enddo enddo if (rho_scale /= 1.0) then @@ -440,28 +441,28 @@ subroutine int_density_dz_generic_plm(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & ! Note: To work in terrain following coordinates we could offset ! this distance by the layer thickness to replicate other models. hWght = massWeightToggle * & - max(0., -bathyT(i,j)-z_t(i+1,j), -bathyT(i+1,j)-z_t(i,j)) + max(0., -bathyT(i,j)-e(i+1,j,K), -bathyT(i+1,j)-e(i,j,K)) if (hWght > 0.) then - hL = (z_t(i,j) - z_b(i,j)) + dz_subroundoff - hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_subroundoff + hL = (e(i,j,K) - e(i,j,K+1)) + dz_subroundoff + hR = (e(i+1,j,K) - e(i+1,j,K+1)) + dz_subroundoff hWght = hWght * ( (hL-hR)/(hL+hR) )**2 iDenom = 1./( hWght*(hR + hL) + hL*hR ) - Ttl = ( (hWght*hR)*T_t(i+1,j) + (hWght*hL + hR*hL)*T_t(i,j) ) * iDenom - Ttr = ( (hWght*hL)*T_t(i,j) + (hWght*hR + hR*hL)*T_t(i+1,j) ) * iDenom - Tbl = ( (hWght*hR)*T_b(i+1,j) + (hWght*hL + hR*hL)*T_b(i,j) ) * iDenom - Tbr = ( (hWght*hL)*T_b(i,j) + (hWght*hR + hR*hL)*T_b(i+1,j) ) * iDenom - Stl = ( (hWght*hR)*S_t(i+1,j) + (hWght*hL + hR*hL)*S_t(i,j) ) * iDenom - Str = ( (hWght*hL)*S_t(i,j) + (hWght*hR + hR*hL)*S_t(i+1,j) ) * iDenom - Sbl = ( (hWght*hR)*S_b(i+1,j) + (hWght*hL + hR*hL)*S_b(i,j) ) * iDenom - Sbr = ( (hWght*hL)*S_b(i,j) + (hWght*hR + hR*hL)*S_b(i+1,j) ) * iDenom + Ttl = ( (hWght*hR)*T_t(i+1,j,k) + (hWght*hL + hR*hL)*T_t(i,j,k) ) * iDenom + Ttr = ( (hWght*hL)*T_t(i,j,k) + (hWght*hR + hR*hL)*T_t(i+1,j,k) ) * iDenom + Tbl = ( (hWght*hR)*T_b(i+1,j,k) + (hWght*hL + hR*hL)*T_b(i,j,k) ) * iDenom + Tbr = ( (hWght*hL)*T_b(i,j,k) + (hWght*hR + hR*hL)*T_b(i+1,j,k) ) * iDenom + Stl = ( (hWght*hR)*S_t(i+1,j,k) + (hWght*hL + hR*hL)*S_t(i,j,k) ) * iDenom + Str = ( (hWght*hL)*S_t(i,j,k) + (hWght*hR + hR*hL)*S_t(i+1,j,k) ) * iDenom + Sbl = ( (hWght*hR)*S_b(i+1,j,k) + (hWght*hL + hR*hL)*S_b(i,j,k) ) * iDenom + Sbr = ( (hWght*hL)*S_b(i,j,k) + (hWght*hR + hR*hL)*S_b(i+1,j,k) ) * iDenom else - Ttl = T_t(i,j); Tbl = T_b(i,j); Ttr = T_t(i+1,j); Tbr = T_b(i+1,j) - Stl = S_t(i,j); Sbl = S_b(i,j); Str = S_t(i+1,j); Sbr = S_b(i+1,j) + Ttl = T_t(i,j,k); Tbl = T_b(i,j,k); Ttr = T_t(i+1,j,k); Tbr = T_b(i+1,j,k) + Stl = S_t(i,j,k); Sbl = S_b(i,j,k); Str = S_t(i+1,j,k); Sbr = S_b(i+1,j,k) endif do m=2,4 w_left = wt_t(m) ; w_right = wt_b(m) - dz_x(m,i) = w_left*(z_t(i,j) - z_b(i,j)) + w_right*(z_t(i+1,j) - z_b(i+1,j)) + dz_x(m,i) = w_left*(e(i,j,K) - e(i,j,K+1)) + w_right*(e(i+1,j,K) - e(i+1,j,K+1)) ! Salinity and temperature points are linearly interpolated in ! the horizontal. The subscript (1) refers to the top value in @@ -474,7 +475,7 @@ subroutine int_density_dz_generic_plm(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & S15(pos+1) = w_left*Stl + w_right*Str S15(pos+5) = w_left*Sbl + w_right*Sbr - p15(pos+1) = -GxRho*(w_left*z_t(i,j) + w_right*z_t(i+1,j)) + p15(pos+1) = -GxRho*(w_left*e(i,j,K) + w_right*e(i+1,j,K)) ! Pressure do n=2,5 @@ -521,28 +522,28 @@ subroutine int_density_dz_generic_plm(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & ! Note: To work in terrain following coordinates we could offset ! this distance by the layer thickness to replicate other models. hWght = massWeightToggle * & - max(0., -bathyT(i,j)-z_t(i,j+1), -bathyT(i,j+1)-z_t(i,j)) + max(0., -bathyT(i,j)-e(i,j+1,K), -bathyT(i,j+1)-e(i,j,K)) if (hWght > 0.) then - hL = (z_t(i,j) - z_b(i,j)) + dz_subroundoff - hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_subroundoff + hL = (e(i,j,K) - e(i,j,K+1)) + dz_subroundoff + hR = (e(i,j+1,K) - e(i,j+1,K+1)) + dz_subroundoff hWght = hWght * ( (hL-hR)/(hL+hR) )**2 iDenom = 1./( hWght*(hR + hL) + hL*hR ) - Ttl = ( (hWght*hR)*T_t(i,j+1) + (hWght*hL + hR*hL)*T_t(i,j) ) * iDenom - Ttr = ( (hWght*hL)*T_t(i,j) + (hWght*hR + hR*hL)*T_t(i,j+1) ) * iDenom - Tbl = ( (hWght*hR)*T_b(i,j+1) + (hWght*hL + hR*hL)*T_b(i,j) ) * iDenom - Tbr = ( (hWght*hL)*T_b(i,j) + (hWght*hR + hR*hL)*T_b(i,j+1) ) * iDenom - Stl = ( (hWght*hR)*S_t(i,j+1) + (hWght*hL + hR*hL)*S_t(i,j) ) * iDenom - Str = ( (hWght*hL)*S_t(i,j) + (hWght*hR + hR*hL)*S_t(i,j+1) ) * iDenom - Sbl = ( (hWght*hR)*S_b(i,j+1) + (hWght*hL + hR*hL)*S_b(i,j) ) * iDenom - Sbr = ( (hWght*hL)*S_b(i,j) + (hWght*hR + hR*hL)*S_b(i,j+1) ) * iDenom + Ttl = ( (hWght*hR)*T_t(i,j+1,k) + (hWght*hL + hR*hL)*T_t(i,j,k) ) * iDenom + Ttr = ( (hWght*hL)*T_t(i,j,k) + (hWght*hR + hR*hL)*T_t(i,j+1,k) ) * iDenom + Tbl = ( (hWght*hR)*T_b(i,j+1,k) + (hWght*hL + hR*hL)*T_b(i,j,k) ) * iDenom + Tbr = ( (hWght*hL)*T_b(i,j,k) + (hWght*hR + hR*hL)*T_b(i,j+1,k) ) * iDenom + Stl = ( (hWght*hR)*S_t(i,j+1,k) + (hWght*hL + hR*hL)*S_t(i,j,k) ) * iDenom + Str = ( (hWght*hL)*S_t(i,j,k) + (hWght*hR + hR*hL)*S_t(i,j+1,k) ) * iDenom + Sbl = ( (hWght*hR)*S_b(i,j+1,k) + (hWght*hL + hR*hL)*S_b(i,j,k) ) * iDenom + Sbr = ( (hWght*hL)*S_b(i,j,k) + (hWght*hR + hR*hL)*S_b(i,j+1,k) ) * iDenom else - Ttl = T_t(i,j); Tbl = T_b(i,j); Ttr = T_t(i,j+1); Tbr = T_b(i,j+1) - Stl = S_t(i,j); Sbl = S_b(i,j); Str = S_t(i,j+1); Sbr = S_b(i,j+1) + Ttl = T_t(i,j,k); Tbl = T_b(i,j,k); Ttr = T_t(i,j+1,k); Tbr = T_b(i,j+1,k) + Stl = S_t(i,j,k); Sbl = S_b(i,j,k); Str = S_t(i,j+1,k); Sbr = S_b(i,j+1,k) endif do m=2,4 w_left = wt_t(m) ; w_right = wt_b(m) - dz_y(m,i) = w_left*(z_t(i,j) - z_b(i,j)) + w_right*(z_t(i,j+1) - z_b(i,j+1)) + dz_y(m,i) = w_left*(e(i,j,K) - e(i,j,K+1)) + w_right*(e(i,j+1,K) - e(i,j+1,K+1)) ! Salinity and temperature points are linearly interpolated in ! the horizontal. The subscript (1) refers to the top value in @@ -555,10 +556,12 @@ subroutine int_density_dz_generic_plm(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & S15(pos+1) = w_left*Stl + w_right*Str S15(pos+5) = w_left*Sbl + w_right*Sbr - p15(pos+1) = -GxRho*(w_left*z_t(i,j) + w_right*z_t(i,j+1)) + p15(pos+1) = -GxRho*(w_left*e(i,j,K) + w_right*e(i,j+1,K)) ! Pressure - do n=2,5 ; p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_y(m,i) ; enddo + do n=2,5 + p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_y(m,i) + enddo ! Salinity and temperature (linear interpolation in the vertical) do n=2,4 @@ -576,6 +579,7 @@ subroutine int_density_dz_generic_plm(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & call calculate_density(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & r15(15*HI%isc+1:), 1, 15*(HI%iec-HI%isc+1), EOS, rho_ref=rho_ref_mks) endif + do i=HI%isc,HI%iec intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) From 5d4f1eb11a987e5b60b298dde7276b74d7a15fa8 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 7 Jul 2020 17:53:29 -0400 Subject: [PATCH 57/91] Implement Brankart terms in PLM form of PGF - The Brankart PGF terms are now implemented in the PLM recontruction routines, just as they were for the PPM form. --- src/core/MOM_density_integrals.F90 | 87 +++++++++++++++++++++++++----- 1 file changed, 75 insertions(+), 12 deletions(-) diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index bd2ef2fd48..d7d9c95b34 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -353,12 +353,18 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & ! Local variables real :: T5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Temperatures along a line of subgrid locations [degC] real :: S5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Salinities along a line of subgrid locations [ppt] + real :: T25((5*HI%iscB+1):(5*(HI%iecB+2))) ! SGS temperature variance along a line of subgrid locations [degC2] + real :: TS5((5*HI%iscB+1):(5*(HI%iecB+2))) ! SGS temp-salt covariance along a line of subgrid locations [degC ppt] + real :: S25((5*HI%iscB+1):(5*(HI%iecB+2))) ! SGS salinity variance along a line of subgrid locations [ppt2] real :: p5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Pressures along a line of subgrid locations, never ! rescaled from Pa [Pa] real :: r5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Densities anomalies along a line of subgrid ! locations [R ~> kg m-3] or [kg m-3] real :: T15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Temperatures at an array of subgrid locations [degC] real :: S15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Salinities at an array of subgrid locations [ppt] + real :: T215((15*HI%iscB+1):(15*(HI%iecB+1))) ! SGS temperature variance along a line of subgrid locations [degC2] + real :: TS15((15*HI%iscB+1):(15*(HI%iecB+1))) ! SGS temp-salt covariance along a line of subgrid locations [degC ppt] + real :: S215((15*HI%iscB+1):(15*(HI%iecB+1))) ! SGS salinity variance along a line of subgrid locations [ppt2] real :: p15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Pressures at an array of subgrid locations [Pa] real :: r15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Densities at an array of subgrid locations ! [R ~> kg m-3] or [kg m-3] @@ -381,6 +387,8 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & 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] + logical :: use_stanley_eos ! True is SGS variance fields exist in tv. + logical :: use_varT, use_varS, use_covarTS integer :: Isq, Ieq, Jsq, Jeq, i, j, m, n integer :: pos @@ -395,6 +403,17 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & if (useMassWghtInterp) massWeightToggle = 1. endif + use_varT = associated(tv%varT) + use_covarTS = associated(tv%covarTS) + use_varS = associated(tv%varS) + use_stanley_eos = use_varT .or. use_covarTS .or. use_varS + T25(:) = 0. + TS5(:) = 0. + S25(:) = 0. + T215(:) = 0. + TS15(:) = 0. + S215(:) = 0. + do n = 1, 5 wt_t(n) = 0.25 * real(5-n) wt_b(n) = 1.0 - wt_t(n) @@ -410,11 +429,25 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & S5(i*5+n) = wt_t(n) * S_t(i,j,k) + wt_b(n) * S_b(i,j,k) T5(i*5+n) = wt_t(n) * T_t(i,j,k) + wt_b(n) * T_b(i,j,k) enddo + if (use_varT) T25(i*5+1:i*5+5) = tv%varT(i,j,k) + if (use_covarTS) TS5(i*5+1:i*5+5) = tv%covarTS(i,j,k) + if (use_varS) S25(i*5+1:i*5+5) = tv%varS(i,j,k) enddo - if (rho_scale /= 1.0) then - call calculate_density(T5, S5, p5, r5, 1, (ieq-isq+2)*5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + if (use_Stanley_eos) then + if (rho_scale /= 1.0) then + call calculate_density(T5, S5, p5, T25, TS5, S25, r5, 1, (ieq-isq+2)*5, EOS, & + rho_ref=rho_ref_mks, scale=rho_scale) + else + call calculate_density(T5, S5, p5, T25, TS5, S25, r5, 1, (ieq-isq+2)*5, EOS, & + rho_ref=rho_ref_mks) + endif else - call calculate_density(T5, S5, p5, r5, 1, (ieq-isq+2)*5, EOS, rho_ref=rho_ref_mks) + if (rho_scale /= 1.0) then + call calculate_density(T5, S5, p5, r5, 1, (ieq-isq+2)*5, EOS, rho_ref=rho_ref_mks, & + scale=rho_scale) + else + call calculate_density(T5, S5, p5, r5, 1, (ieq-isq+2)*5, EOS, rho_ref=rho_ref_mks) + endif endif do i=Isq,Ieq+1 @@ -487,13 +520,27 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & S15(pos+n) = wt_t(n) * S15(pos+1) + wt_b(n) * S15(pos+5) T15(pos+n) = wt_t(n) * T15(pos+1) + wt_b(n) * T15(pos+5) enddo + if (use_varT) T215(pos+1:pos+5) = w_left*tv%varT(i,j,k) + w_right*tv%varT(i+1,j,k) + if (use_covarTS) TS15(pos+1:pos+5) = w_left*tv%covarTS(i,j,k) + w_right*tv%covarTS(i+1,j,k) + if (use_varS) S215(pos+1:pos+5) = w_left*tv%varS(i,j,k) + w_right*tv%varS(i+1,j,k) enddo enddo - if (rho_scale /= 1.0) then - call calculate_density(T15, S15, p15, r15, 1, 15*(ieq-isq+1), EOS, rho_ref=rho_ref_mks, scale=rho_scale) + if (use_stanley_eos) then + if (rho_scale /= 1.0) then + call calculate_density(T15, S15, p15, T215, TS15, S215, r15, 1, 15*(ieq-isq+1), EOS, & + rho_ref=rho_ref_mks, scale=rho_scale) + else + call calculate_density(T15, S15, p15, T215, TS15, S215, r15, 1, 15*(ieq-isq+1), EOS, & + rho_ref=rho_ref_mks) + endif else - call calculate_density(T15, S15, p15, r15, 1, 15*(ieq-isq+1), EOS, rho_ref=rho_ref_mks) + if (rho_scale /= 1.0) then + call calculate_density(T15, S15, p15, r15, 1, 15*(ieq-isq+1), EOS, rho_ref=rho_ref_mks, & + scale=rho_scale) + else + call calculate_density(T15, S15, p15, r15, 1, 15*(ieq-isq+1), EOS, rho_ref=rho_ref_mks) + endif endif do I=Isq,Ieq @@ -568,16 +615,32 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & S15(pos+n) = wt_t(n) * S15(pos+1) + wt_b(n) * S15(pos+5) T15(pos+n) = wt_t(n) * T15(pos+1) + wt_b(n) * T15(pos+5) enddo + if (use_varT) T215(pos+1:pos+5) = w_left*tv%varT(i,j,k) + w_right*tv%varT(i,j+1,k) + if (use_covarTS) TS15(pos+1:pos+5) = w_left*tv%covarTS(i,j,k) + w_right*tv%covarTS(i,j+1,k) + if (use_varS) S215(pos+1:pos+5) = w_left*tv%varS(i,j,k) + w_right*tv%varS(i,j+1,k) enddo enddo - if (rho_scale /= 1.0) then - call calculate_density(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & - r15(15*HI%isc+1:), 1, 15*(HI%iec-HI%isc+1), EOS, & - rho_ref=rho_ref_mks, scale=rho_scale) + if (use_stanley_eos) then + if (rho_scale /= 1.0) then + call calculate_density(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & + T215(15*HI%isc+1:), TS15(15*HI%isc+1:), S215(15*HI%isc+1:), & + r15(15*HI%isc+1:), 1, 15*(HI%iec-HI%isc+1), EOS, & + rho_ref=rho_ref_mks, scale=rho_scale) + else + call calculate_density(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & + T215(15*HI%isc+1:), TS15(15*HI%isc+1:), S215(15*HI%isc+1:), & + r15(15*HI%isc+1:), 1, 15*(HI%iec-HI%isc+1), EOS, rho_ref=rho_ref_mks) + endif else - call calculate_density(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & - r15(15*HI%isc+1:), 1, 15*(HI%iec-HI%isc+1), EOS, rho_ref=rho_ref_mks) + if (rho_scale /= 1.0) then + call calculate_density(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & + r15(15*HI%isc+1:), 1, 15*(HI%iec-HI%isc+1), EOS, & + rho_ref=rho_ref_mks, scale=rho_scale) + else + call calculate_density(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & + r15(15*HI%isc+1:), 1, 15*(HI%iec-HI%isc+1), EOS, rho_ref=rho_ref_mks) + endif endif do i=HI%isc,HI%iec From ee1232a3a13da44ec1156a6568a6e9b56521e6c3 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 8 Jul 2020 16:39:06 -0400 Subject: [PATCH 58/91] Cleaned up tc2 MOM_input - Added documentation lines for PGF_STANLEY_T2_DET_COEFF --- .testing/tc2/MOM_input | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/.testing/tc2/MOM_input b/.testing/tc2/MOM_input index d5a904d841..1818390192 100644 --- a/.testing/tc2/MOM_input +++ b/.testing/tc2/MOM_input @@ -297,6 +297,10 @@ BOUND_CORIOLIS = True ! [Boolean] default = False ! v-points, and similarly at v-points. This option would ! have no effect on the SADOURNY Coriolis scheme if it ! were possible to use centered difference thickness fluxes. +PGF_STANLEY_T2_DET_COEFF = 0.5 ! [nondim] default = -1.0 + ! The coefficient correlating SGS temperature variance with the mean temperature + ! gradient in the deterministic part of the Stanley form of the Brankart + ! correction. Negative values disable the scheme. ! === module MOM_hor_visc === LAPLACIAN = True @@ -430,7 +434,6 @@ STANLEY_PRM_DET_COEFF = 0.5 ! [nondim] default = -1.0 ! The coefficient correlating SGS temperature variance with the mean temperature ! gradient in the deterministic part of the Stanley parameterization. Negative ! values disable the scheme. -PGF_STANLEY_T2_DET_COEFF = 0.5 ! === module MOM_mixed_layer_restrat === FOX_KEMPER_ML_RESTRAT_COEF = 5.0 ! [nondim] default = 0.0 From f0bab127117a700716f100ed11b776b2857220cf Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 10 Jul 2020 16:47:05 -0400 Subject: [PATCH 59/91] Added comments to highlight a dimensionally problematic constant - Per feedback to #1156 --- src/ALE/PLM_functions.F90 | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/ALE/PLM_functions.F90 b/src/ALE/PLM_functions.F90 index 952202d325..07b27a6912 100644 --- a/src/ALE/PLM_functions.F90 +++ b/src/ALE/PLM_functions.F90 @@ -55,6 +55,8 @@ real elemental pure function PLM_slope_wa(h_l, h_c, h_r, h_neglect, u_l, u_c, u_ endif ! An attempt to avoid inconsistency when the values become unrepresentable. + ! ### The following 1.E-140 is dimensionally inconsistent. A newer version of + ! PLM is progress that will avoid the need for such rounding. if (abs(PLM_slope_wa) < 1.E-140) PLM_slope_wa = 0. end function PLM_slope_wa @@ -104,6 +106,8 @@ real elemental pure function PLM_slope_cw(h_l, h_c, h_r, h_neglect, u_l, u_c, u_ endif ! An attempt to avoid inconsistency when the values become unrepresentable. + ! ### The following 1.E-140 is dimensionally inconsistent. A newer version of + ! PLM is progress that will avoid the need for such rounding. if (abs(PLM_slope_cw) < 1.E-140) PLM_slope_cw = 0. end function PLM_slope_cw From e8adc48a36dfe4b12459651ee2893b6670c0e2a1 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 10 Jul 2020 17:31:53 -0400 Subject: [PATCH 60/91] Corrected scaling in _1d and _scalar EOS functions - Per feedback on #1156, corrected scaling for calculate_stanley_density_scalar() and calculate_stanley_density_1d(). --- src/equation_of_state/MOM_EOS.F90 | 78 ++++++++++++++++++++----------- 1 file changed, 50 insertions(+), 28 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 7f70281783..40ac04e9e8 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -183,7 +183,7 @@ subroutine calculate_density_scalar(T, S, pressure, rho, EOS, rho_ref, scale) select case (EOS%form_of_EOS) case (EOS_LINEAR) call calculate_density_linear(T, S, p_scale*pressure, rho, & - EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, rho_ref) + EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, rho_ref) case (EOS_UNESCO) call calculate_density_unesco(T, S, p_scale*pressure, rho, rho_ref) case (EOS_WRIGHT) @@ -222,20 +222,38 @@ subroutine calculate_stanley_density_scalar(T, S, pressure, Tvar, TScov, Svar, r !! from kg m-3 to the desired units [R m3 kg-1] ! Local variables real :: d2RdTT, d2RdST, d2RdSS, d2RdSp, d2RdTp ! Second derivatives of density wrt T,S,p + real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] + real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] if (.not.associated(EOS)) call MOM_error(FATAL, & - "calculate_density_scalar called with an unassociated EOS_type EOS.") + "calculate_stanley_density_scalar called with an unassociated EOS_type EOS.") - ! Branching to the correct EOS happens within each of these calls - ! and will appropriately error if the second derivatives are not available. - call calculate_density_second_derivs_scalar(T, S, pressure, d2RdSS, d2RdST, d2RdTT, & - d2RdSp, d2RdTp, EOS) - call calculate_density_scalar(T, S, pressure, rho, EOS, rho_ref) + p_scale = EOS%RL2_T2_to_Pa + + select case (EOS%form_of_EOS) + case (EOS_LINEAR) + call calculate_density_linear(T, S, p_scale*pressure, rho, & + EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, rho_ref) + call calculate_density_second_derivs_linear(T, S, pressure, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP) + case (EOS_WRIGHT) + call calculate_density_wright(T, S, p_scale*pressure, rho, rho_ref) + call calculate_density_second_derivs_wright(T, S, pressure, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP) + case (EOS_TEOS10) + call calculate_density_teos10(T, S, p_scale*pressure, rho, rho_ref) + call calculate_density_second_derivs_teos10(T, S, pressure, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP) + case default + call MOM_error(FATAL, "calculate_stanley_density_scalar: EOS is not valid.") + end select ! Equation 25 of Stanley et al., 2020. rho = rho + ( 0.5 * d2RdTT * Tvar + ( d2RdST * TScov + 0.5 * d2RdSS * Svar ) ) - if (present(scale)) rho = scale * rho + rho_scale = EOS%kg_m3_to_R + if (present(scale)) rho_scale = rho_scale * scale + rho = rho_scale * rho end subroutine calculate_stanley_density_scalar @@ -412,8 +430,6 @@ subroutine calculate_stanley_density_1d(T, S, pressure, Tvar, TScov, Svar, rho, ! Local variables real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] - real :: rho_unscale ! A factor to convert density from R to kg m-3 [kg m-3 R-1 ~> 1] - real :: rho_reference ! rho_ref converted to [kg m-3] real, dimension(size(rho)) :: pres ! Pressure converted to [Pa] real, dimension(size(T)) :: d2RdTT, d2RdST, d2RdSS, d2RdSp, d2RdTp ! Second derivatives of density wrt T,S,p integer :: i, is, ie, npts @@ -428,26 +444,32 @@ subroutine calculate_stanley_density_1d(T, S, pressure, Tvar, TScov, Svar, rho, endif p_scale = EOS%RL2_T2_to_Pa - rho_unscale = EOS%R_to_kg_m3 + do i=is,ie + pres(i) = p_scale * pressure(i) + enddo - if ((p_scale == 1.0) .and. (rho_unscale == 1.0)) then - call calculate_density_array(T, S, pressure, rho, is, npts, EOS, rho_ref=rho_ref) - call calculate_density_second_derivs_array(T, S, pressure, d2RdSS, d2RdST, d2RdTT, & - d2RdSp, d2RdTp, is, npts, EOS) - else ! This is the same as above, but with some extra work to rescale variables. - do i=is,ie ; pres(i) = p_scale * pressure(i) ; enddo - call calculate_density_second_derivs_array(T, S, pres, d2RdSS, d2RdST, d2RdTT, & - d2RdSp, d2RdTp, is, npts, EOS) - if (present(rho_ref)) then ! This is the same as above, but with some extra work to rescale variables. - rho_reference = rho_unscale*rho_ref - call calculate_density_array(T, S, pres, rho, is, npts, EOS, rho_ref=rho_reference) - else ! There is rescaling of variables, but rho_ref is not present. Passing a 0 value of rho_ref - ! changes answers at roundoff for some equations of state, like Wright and UNESCO. - call calculate_density_array(T, S, pres, rho, is, npts, EOS) - endif - endif + select case (EOS%form_of_EOS) + case (EOS_LINEAR) + call calculate_density_linear(T, S, pres, rho, 1, npts, & + EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, rho_ref) + call calculate_density_second_derivs_linear(T, S, pres, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP, 1, npts) + case (EOS_WRIGHT) + call calculate_density_wright(T, S, pres, rho, 1, npts, rho_ref) + call calculate_density_second_derivs_wright(T, S, pres, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP, 1, npts) + case (EOS_TEOS10) + call calculate_density_teos10(T, S, pres, rho, 1, npts, rho_ref) + call calculate_density_second_derivs_teos10(T, S, pres, d2RdSS, d2RdST, & + d2RdTT, d2RdSp, d2RdTP, 1, npts) + case default + call MOM_error(FATAL, "calculate_stanley_density_scalar: EOS is not valid.") + end select + + ! Equation 25 of Stanley et al., 2020. do i=is,ie - rho(i) = rho(i) + ( d2RdTT(i) * Tvar(i) + ( d2RdST(i) * TScov(i) + d2RdSS(i) * Svar(i) ) ) + rho(i) = rho(i) & + + ( 0.5 * d2RdTT(i) * Tvar(i) + ( d2RdST(i) * TScov(i) + 0.5 * d2RdSS(i) * Svar(i) ) ) enddo rho_scale = EOS%kg_m3_to_R From ec0946c9c9d7e0f50a78451be67bc80ab8bd91dd Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 10 Jul 2020 17:36:57 -0400 Subject: [PATCH 61/91] Removed unused member in PressureForce_CS - Per feedback on #1156. --- src/core/MOM_PressureForce.F90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/core/MOM_PressureForce.F90 b/src/core/MOM_PressureForce.F90 index f8690ca0cd..1963a8a773 100644 --- a/src/core/MOM_PressureForce.F90 +++ b/src/core/MOM_PressureForce.F90 @@ -28,8 +28,6 @@ module MOM_PressureForce 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. - logical :: blocked_FV !< If true, used the blocked version of the ANALYTIC_FV_PGF - !! code. The value of this parameter should not change answers. !> Control structure for the analytically integrated finite volume pressure force type(PressureForce_FV_CS), pointer :: PressureForce_FV_CSp => NULL() !> Control structure for the Montgomery potential form of pressure force From 4307fa5e528778bd8668ee8caedfee2a0b5edfe6 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 10 Jul 2020 17:38:52 -0400 Subject: [PATCH 62/91] Added FATAL if trying to use parameterization in non-Boussinesq mode - Per feedback on #1156 --- src/core/MOM_PressureForce_FV.F90 | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 4da503f498..6c01580e29 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -160,6 +160,9 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ if (.not.associated(CS)) call MOM_error(FATAL, & "MOM_PressureForce_FV_nonBouss: Module must be initialized before it is used.") + if (CS%Stanley_T2_det_coeff>=0.) call MOM_error(FATAL, & + "MOM_PressureForce_FV_nonBouss: The Stanley parameterization is not yet"//& + "implemented in non-Boussinesq mode.") use_p_atm = .false. if (present(p_atm)) then ; if (associated(p_atm)) use_p_atm = .true. ; endif From b3a584d437ec716ad84f1afd78621b02dd5f1bbd Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 10 Jul 2020 17:44:31 -0400 Subject: [PATCH 63/91] (*)Set maximum value of au_visc Set a hard-coded maximum value of CS%a_u and CS%a_v of 1e37 m s-1 so that these can be represented in diagnostics that are written with 32-bit floating point numbers. These values are so large that all answers are bitwise identical in the MOM6-examples test cases, but it is possible that answers could change. --- .../vertical/MOM_vert_friction.F90 | 33 ++++++++++--------- 1 file changed, 18 insertions(+), 15 deletions(-) diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 6e1fd8fac9..b1a37c7d5e 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -629,6 +629,8 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) 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 [H ~> m or kg m-2]. + real :: a_cpl_max ! The maximum drag doefficient across interfaces, set so that it will be + ! representable as a 32-bit float in MKS units [Z T-1 ~> m s-1] 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]. @@ -648,6 +650,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) "Module must be initialized before it is used.") h_neglect = GV%H_subroundoff + a_cpl_max = 1.0e37 * US%m_to_Z * US%T_to_s 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 @@ -811,13 +814,13 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, 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_cpl(I,K) + CS%a_u(I,j,K) = min(a_cpl_max, forces%frac_shelf_u(I,j) * a_shelf(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_cpl(I,K)) + & -! (1.0-forces%frac_shelf_u(I,j)) * a_cpl(I,K) +! CS%a_u(I,j,K) = min(a_cpl_max, 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_cpl(I,K) + CS%a_u(I,j,K) = min(a_cpl_max, 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? @@ -827,7 +830,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) CS%h_u(I,j,k) = hvel(I,k) + h_neglect endif ; enddo ; enddo else - 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+1 ; do I=Isq,Ieq ; if (do_i(I)) CS%a_u(I,j,K) = min(a_cpl_max, 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) + h_neglect ; enddo ; enddo endif @@ -979,13 +982,13 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, 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_cpl(i,K) + CS%a_v(i,J,K) = min(a_cpl_max, forces%frac_shelf_v(i,J) * a_shelf(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_cpl(i,K)) + & -! (1.0-forces%frac_shelf_v(i,J)) * a_cpl(i,K) +! CS%a_v(i,J,K) = min(a_cpl_max, 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_cpl(i,K) + CS%a_v(i,J,K) = min(a_cpl_max, 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? @@ -995,7 +998,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) CS%h_v(i,J,k) = hvel(i,k) + h_neglect endif ; enddo ; enddo else - 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+1 ; do i=is,ie ; if (do_i(i)) CS%a_v(i,J,K) = min(a_cpl_max, 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) + h_neglect ; enddo ; enddo endif @@ -1109,10 +1112,10 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, nz = G%ke h_neglect = GV%H_subroundoff - ! 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. if (CS%answers_2018) then + ! 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 else I_amax = 0.0 From 553166ae8e8a871a0d1e39a091cbe707ef8a3159 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 10 Jul 2020 17:51:59 -0400 Subject: [PATCH 64/91] Added comments for local variables - Per feedback on #1156. --- src/ALE/PLM_functions.F90 | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/src/ALE/PLM_functions.F90 b/src/ALE/PLM_functions.F90 index 07b27a6912..da60f9614a 100644 --- a/src/ALE/PLM_functions.F90 +++ b/src/ALE/PLM_functions.F90 @@ -27,7 +27,9 @@ real elemental pure function PLM_slope_wa(h_l, h_c, h_r, h_neglect, u_l, u_c, u_ real, intent(in) :: u_c !< Value of center cell [units of u] real, intent(in) :: u_r !< Value of right cell [units of u] ! Local variables - real :: sigma_l, sigma_c, sigma_r, u_min, u_max + real :: sigma_l, sigma_c, sigma_r ! Left, central and right slope estimates as + ! differences across the cell [units of u] + real :: u_min, u_max ! Minimum and maximum value across cell [units of u] ! Side differences sigma_r = u_r - u_c @@ -71,7 +73,10 @@ real elemental pure function PLM_slope_cw(h_l, h_c, h_r, h_neglect, u_l, u_c, u_ real, intent(in) :: u_c !< Value of center cell [units of u] real, intent(in) :: u_r !< Value of right cell [units of u] ! Local variables - real :: sigma_l, sigma_c, sigma_r, u_min, u_max, h_cn + real :: sigma_l, sigma_c, sigma_r ! Left, central and right slope estimates as + ! differences across the cell [units of u] + real :: u_min, u_max ! Minimum and maximum value across cell [units of u] + real :: h_cn ! Thickness of center cell [units of grid thickness] h_cn = h_c + h_neglect @@ -121,7 +126,9 @@ real elemental pure function PLM_monotonized_slope(u_l, u_c, u_r, s_l, s_c, s_r) real, intent(in) :: s_c !< PLM slope of center cell [units of u] real, intent(in) :: s_r !< PLM slope of right cell [units of u] ! Local variables - real :: e_r, e_l, edge, almost_two, slp + real :: e_r, e_l, edge ! Right, left and temporary edge values [units of u] + real :: almost_two ! The number 2, almost. + real :: slp ! Magnitude of PLM central slope [units of u] almost_two = 2. * ( 1. - epsilon(s_c) ) @@ -157,7 +164,8 @@ real elemental pure function PLM_extrapolate_slope(h_l, h_c, h_neglect, u_l, u_c real, intent(in) :: u_l !< Value of left cell [units of u] real, intent(in) :: u_c !< Value of center cell [units of u] ! Local variables - real :: left_edge, hl, hc + real :: left_edge ! Left edge value [units of u] + real :: hl, hc ! Left and central cell thicknesses [units of grid thickness] ! Avoid division by zero for vanished cells hl = h_l + h_neglect From 8df3e7f550b41018365a428f22cd762804e68050 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 14 Jul 2020 09:36:02 -0400 Subject: [PATCH 65/91] +Eliminate uhbt_IC and ubt_IC from restart files Eliminated the unused variables CS%uhbt_IC and CS%vhbt_IC from the barotropic control structure and from the MOM6 restart files. Also placed a logical test for CS%Gradual_BT_ICs around all references to CS%ubt_IC and CS%vbt_IC and eliminated these variables from the restart files when they would not be used. Additionally some unused arguments were removed from internal subroutines and some spelling or index case errors were corrected. All answers are bitwise identical, but the MOM6 restart files have fewer variables and some unused entries in the MOM_parameter_doc files have changed. --- src/core/MOM_barotropic.F90 | 356 +++++++++++++++++++----------------- 1 file changed, 193 insertions(+), 163 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 50ad121b77..4e4233bc38 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -108,9 +108,6 @@ module MOM_barotropic real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: lin_drag_u !< A spatially varying linear drag coefficient acting on the zonal barotropic flow !! [H T-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 L2 T-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 [L T-1 ~> m s-1]. @@ -121,9 +118,6 @@ module MOM_barotropic real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: lin_drag_v !< A spatially varying linear drag coefficient acting on the zonal barotropic flow !! [H T-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 L2 T-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 [L T-1 ~> m s-1]. @@ -258,9 +252,8 @@ module MOM_barotropic !! 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 :: 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 @@ -313,6 +306,7 @@ module MOM_barotropic integer :: id_BTC_ubt_EE = -1, id_BTC_ubt_WW = -1 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_BTC_FA_u_rat0 = -1, id_BTC_FA_v_rat0 = -1, id_BTC_FA_h_rat0 = -1 integer :: id_uhbt0 = -1, id_vhbt0 = -1 !>@} @@ -486,6 +480,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, vbt_st, & ! The meridional barotropic velocity at the start of timestep [L T-1 ~> m s-1]. vbt_dt ! The meridional barotropic velocity tendency [L T-2 ~> m s-2]. real, dimension(SZI_(G),SZJ_(G)) :: & + tmp_h, & ! A temporary array at h points. 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 [H ~> m or kg m-2]. @@ -592,11 +587,12 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! End of wide-sized variables. real, dimension(SZIBW_(CS),SZJW_(CS)) :: & - ubt_prev, uhbt_prev, ubt_sum_prev, uhbt_sum_prev, ubt_wtd_prev ! for OBC + ubt_prev, ubt_sum_prev, ubt_wtd_prev, & ! Previous velocities stored for OBCs [L T-1 ~> m s-1] + uhbt_prev, uhbt_sum_prev ! Previous transports stored for OBCs [L2 H T-1 ~> m3 s-1] real, dimension(SZIW_(CS),SZJBW_(CS)) :: & - vbt_prev, vhbt_prev, vbt_sum_prev, vhbt_sum_prev, vbt_wtd_prev ! for OBC - - real :: mass_to_Z ! The depth unit converison divided by the mean density (Rho0) [Z m-1 R-1 ~> m3 kg-1]. + vbt_prev, vbt_sum_prev, vbt_wtd_prev, & ! Previous velocities stored for OBCs [L T-1 ~> m s-1] + vhbt_prev, vhbt_sum_prev ! Previous transports stored for OBCs [L2 H T-1 ~> m3 s-1] + real :: mass_to_Z ! The depth unit conversion divided by the mean density (Rho0) [Z m-1 R-1 ~> m3 kg-1]. real :: mass_accel_to_Z ! The inverse of the mean density (Rho0) [R-1 ~> m3 kg-1]. real :: visc_rem ! A work variable that may equal visc_rem_[uv]. Nondim. real :: vel_prev ! The previous velocity [L T-1 ~> m s-1]. @@ -612,9 +608,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, real :: dgeo_de ! The constant of proportionality between geopotential and ! sea surface height. It is a nondimensional number of ! order 1. For stability, this may be made larger - ! than physical problem would suggest. - real :: Instep ! The inverse of the number of barotropic time steps - ! to take. + ! than the 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 [nondim] integer :: nstep ! The number of barotropic time steps to take. type(time_type) :: & @@ -649,7 +644,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, 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 [T ~> s]. - real :: trans_wt1, trans_wt2 ! weight used to compute ubt_trans and vbt_trans + real :: trans_wt1, trans_wt2 ! The weights used to compute ubt_trans and vbt_trans integer :: nfilter logical :: apply_OBCs, apply_OBC_flather, apply_OBC_open @@ -911,7 +906,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, !$OMP parallel do default(shared) do J=CS%jsdw-1,CS%jedw ; do i=CS%isdw,CS%iedw Cor_ref_v(i,J) = 0.0 ; BT_force_v(i,J) = 0.0 ; vbt(i,J) = 0.0 - Datv(i,J) = 0.0 ; bt_rem_v(i,J) = 0.0 ; vhbt0(I,j) = 0.0 + Datv(i,J) = 0.0 ; bt_rem_v(i,J) = 0.0 ; vhbt0(i,J) = 0.0 enddo ; enddo ! Copy input arrays into their wide-halo counterparts. @@ -1065,11 +1060,11 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie - uhbt0(I,j) = uhbt(I,j) - find_uhbt(ubt(I,j), BTCL_u(I,j), US) + uhbt0(I,j) = uhbt(I,j) - find_uhbt(ubt(I,j), BTCL_u(I,j)) enddo ; enddo !$OMP parallel do default(shared) do J=js-1,je ; do i=is,ie - vhbt0(i,J) = vhbt(i,J) - find_vhbt(vbt(i,J), BTCL_v(i,J), US) + vhbt0(i,J) = vhbt(i,J) - find_vhbt(vbt(i,J), BTCL_v(i,J)) enddo ; enddo else !$OMP parallel do default(shared) @@ -1328,15 +1323,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre) if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre) -!$OMP parallel default(none) shared(is,ie,js,je,nz,av_rem_u,av_rem_v,CS,visc_rem_u, & -!$OMP visc_rem_v,bt_rem_u,G,GV,nstep,bt_rem_v,Instep, & -!$OMP find_etaav,jsvf,jevf,isvf,ievf,eta_sum,eta_wtd, & -!$OMP ubt_sum,uhbt_sum,PFu_bt_sum,Coru_bt_sum,ubt_wtd,& -!$OMP ubt_trans,vbt_sum,vhbt_sum,PFv_bt_sum, & -!$OMP Corv_bt_sum,vbt_wtd,vbt_trans,eta_src,dt,dtbt, & -!$OMP Rayleigh_u, Rayleigh_v, & -!$OMP use_BT_Cont,BTCL_u,uhbt0,BTCL_v,vhbt0,eta,Idt,US) & -!$OMP private(u_max_cor,v_max_cor,eta_cor_max,Htot) + !$OMP parallel default(shared) private(u_max_cor,v_max_cor,eta_cor_max,Htot) !$OMP do do j=js-1,je+1 ; do I=is-1,ie ; av_rem_u(I,j) = 0.0 ; enddo ; enddo !$OMP do @@ -1406,7 +1393,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, do j=jsvf-1,jevf+1 ; do i=isvf-1,ievf+1 eta_wtd(i,j) = 0.0 enddo ; enddo - endif + endif !$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 @@ -1417,7 +1404,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, 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 - vbt_wtd(i,J) = 0.0 ; vbt_trans(I,j) = 0.0 + vbt_wtd(i,J) = 0.0 ; vbt_trans(i,J) = 0.0 enddo ; enddo ! Set the mass source, after first initializing the halos to 0. @@ -1427,19 +1414,17 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, do j=js,je ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then if (CS%eta_cor(i,j) > 0.0) then ! Limit the source (outward) correction to be a fraction the mass that - ! can be transported out of the cell by velocities with a CFL number of - ! CFL_cor. + ! can be transported out of the cell by velocities with a CFL number of CFL_cor. u_max_cor = G%dxT(i,j) * (CS%maxCFL_BT_cont*Idt) v_max_cor = G%dyT(i,j) * (CS%maxCFL_BT_cont*Idt) eta_cor_max = dt * (CS%IareaT(i,j) * & - (((find_uhbt(u_max_cor, BTCL_u(I,j), US) + uhbt0(I,j)) - & - (find_uhbt(-u_max_cor, BTCL_u(I-1,j), US) + uhbt0(I-1,j))) + & - ((find_vhbt(v_max_cor, BTCL_v(i,J), US) + vhbt0(i,J)) - & - (find_vhbt(-v_max_cor, BTCL_v(i,J-1), US) + vhbt0(i,J-1))) )) + (((find_uhbt(u_max_cor, BTCL_u(I,j)) + uhbt0(I,j)) - & + (find_uhbt(-u_max_cor, BTCL_u(I-1,j)) + uhbt0(I-1,j))) + & + ((find_vhbt(v_max_cor, BTCL_v(i,J)) + vhbt0(i,J)) - & + (find_vhbt(-v_max_cor, BTCL_v(i,J-1)) + vhbt0(i,J-1))) )) CS%eta_cor(i,j) = min(CS%eta_cor(i,j), max(0.0, eta_cor_max)) else - ! Limit the sink (inward) correction to the amount of mass that is already - ! inside the cell. + ! 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%Z_to_H + eta(i,j) @@ -1682,11 +1667,11 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (use_BT_cont) then !GOMP do do j=jsv-1,jev+1 ; do I=isv-2,iev+1 - uhbt(I,j) = find_uhbt(ubt(I,j), BTCL_u(I,j), US) + uhbt0(I,j) + uhbt(I,j) = find_uhbt(ubt(I,j), BTCL_u(I,j)) + uhbt0(I,j) enddo ; enddo !GOMP do do J=jsv-2,jev+1 ; do i=isv-1,iev+1 - vhbt(i,J) = find_vhbt(vbt(i,J), BTCL_v(i,J), US) + vhbt0(i,J) + vhbt(i,J) = find_vhbt(vbt(i,J), BTCL_v(i,J)) + vhbt0(i,J) enddo ; enddo !GOMP do do j=jsv-1,jev+1 ; do i=isv-1,iev+1 @@ -1751,9 +1736,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (CS%BT_OBC%apply_u_OBCs) then ! save the old value of ubt and uhbt !GOMP parallel do default(shared) - do J=jsv-joff,jev+joff ; do i=isv-1,iev - ubt_prev(i,J) = ubt(i,J) ; uhbt_prev(i,J) = uhbt(i,J) - ubt_sum_prev(i,J) = ubt_sum(i,J) ; uhbt_sum_prev(i,J) = uhbt_sum(i,J) ; ubt_wtd_prev(i,J) = ubt_wtd(i,J) + do j=jsv-joff,jev+joff ; do I=isv-1,iev + ubt_prev(I,j) = ubt(I,j) ; uhbt_prev(I,j) = uhbt(I,j) + ubt_sum_prev(I,j) = ubt_sum(I,j) ; uhbt_sum_prev(I,j) = uhbt_sum(I,j) ; ubt_wtd_prev(I,j) = ubt_wtd(I,j) enddo ; enddo endif @@ -1798,17 +1783,17 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, vbt_trans(i,J) = trans_wt1*vbt(i,J) + trans_wt2*vel_prev if (CS%linear_wave_drag) then - v_accel_bt(I,j) = v_accel_bt(I,j) + wt_accel(n) * & + v_accel_bt(i,J) = v_accel_bt(i,J) + wt_accel(n) * & ((Cor_v(i,J) + PFv(i,J)) - vbt(i,J)*Rayleigh_v(i,J)) else - v_accel_bt(I,j) = v_accel_bt(I,j) + wt_accel(n) * (Cor_v(i,J) + PFv(i,J)) + v_accel_bt(i,J) = v_accel_bt(i,J) + wt_accel(n) * (Cor_v(i,J) + PFv(i,J)) endif enddo ; enddo if (use_BT_cont) then !GOMP do do J=jsv-1,jev ; do i=isv-1,iev+1 - vhbt(i,J) = find_vhbt(vbt_trans(i,J), BTCL_v(i,J), US) + vhbt0(i,J) + vhbt(i,J) = find_vhbt(vbt_trans(i,J), BTCL_v(i,J)) + vhbt0(i,J) enddo ; enddo else !GOMP do @@ -1865,7 +1850,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (use_BT_cont) then !GOMP do do j=jsv,jev ; do I=isv-1,iev - uhbt(I,j) = find_uhbt(ubt_trans(I,j), BTCL_u(I,j), US) + uhbt0(I,j) + uhbt(I,j) = find_uhbt(ubt_trans(I,j), BTCL_u(I,j)) + uhbt0(I,j) enddo ; enddo else !GOMP do @@ -1873,10 +1858,10 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, uhbt(I,j) = Datu(I,j)*ubt_trans(I,j) + uhbt0(I,j) enddo ; enddo endif - if (CS%BT_OBC%apply_u_OBCs) then ! copy back the value for u-points on the boundary. + if (CS%BT_OBC%apply_u_OBCs) then ! copy back the value for u-points on the boundary. !GOMP do do j=jsv,jev ; do I=isv-1,iev ; if (OBC%segnum_u(I,j) /= OBC_NONE) then - ubt(I,j) = ubt_prev(I,j); uhbt(I,j) = uhbt_prev(I,j) + ubt(I,j) = ubt_prev(I,j) ; uhbt(I,j) = uhbt_prev(I,j) endif ; enddo ; enddo endif else @@ -1924,7 +1909,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (use_BT_cont) then !GOMP do do j=jsv-1,jev+1 ; do I=isv-1,iev - uhbt(I,j) = find_uhbt(ubt_trans(I,j), BTCL_u(I,j), US) + uhbt0(I,j) + uhbt(I,j) = find_uhbt(ubt_trans(I,j), BTCL_u(I,j)) + uhbt0(I,j) enddo ; enddo else !GOMP do @@ -1935,7 +1920,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (CS%BT_OBC%apply_u_OBCs) then ! copy back the value for u-points on the boundary. !GOMP do do j=jsv-1,jev+1 ; do I=isv-1,iev ; if (OBC%segnum_u(I,j) /= OBC_NONE) then - ubt(I,j) = ubt_prev(I,j); uhbt(I,j) = uhbt_prev(I,j) + ubt(I,j) = ubt_prev(I,j) ; uhbt(I,j) = uhbt_prev(I,j) endif ; enddo ; enddo endif @@ -1983,16 +1968,16 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, vbt_trans(i,J) = trans_wt1*vbt(i,J) + trans_wt2*vel_prev if (CS%linear_wave_drag) then - v_accel_bt(I,j) = v_accel_bt(I,j) + wt_accel(n) * & + v_accel_bt(i,J) = v_accel_bt(i,J) + wt_accel(n) * & ((Cor_v(i,J) + PFv(i,J)) - vbt(i,J)*Rayleigh_v(i,J)) else - v_accel_bt(I,j) = v_accel_bt(I,j) + wt_accel(n) * (Cor_v(i,J) + PFv(i,J)) + v_accel_bt(i,J) = v_accel_bt(i,J) + wt_accel(n) * (Cor_v(i,J) + PFv(i,J)) endif enddo ; enddo if (use_BT_cont) then !GOMP do do J=jsv-1,jev ; do i=isv,iev - vhbt(i,J) = find_vhbt(vbt_trans(i,J), BTCL_v(i,J), US) + vhbt0(i,J) + vhbt(i,J) = find_vhbt(vbt_trans(i,J), BTCL_v(i,J)) + vhbt0(i,J) enddo ; enddo else !GOMP do @@ -2009,6 +1994,24 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif !GOMP end parallel + if (CS%debug_bt) then + write(mesg,'("BT vel update ",I4)') n + call uvchksum(trim(mesg)//" PF[uv]", PFu, PFv, CS%debug_BT_HI, haloshift=iev-ie, & + scale=US%L_T_to_m_s*US%s_to_T) + call uvchksum(trim(mesg)//" Cor_[uv]", Cor_u, Cor_v, CS%debug_BT_HI, haloshift=iev-ie, & + scale=US%L_T_to_m_s*US%s_to_T) + call uvchksum(trim(mesg)//" BT_force_[uv]", BT_force_u, BT_force_v, CS%debug_BT_HI, haloshift=iev-ie, & + scale=US%L_T_to_m_s*US%s_to_T) + call uvchksum(trim(mesg)//" BT_rem_[uv]", BT_rem_u, BT_rem_v, CS%debug_BT_HI, haloshift=iev-ie) + call uvchksum(trim(mesg)//" [uv]bt", ubt, vbt, CS%debug_BT_HI, haloshift=iev-ie, & + scale=US%L_T_to_m_s) + call uvchksum(trim(mesg)//" [uv]bt_trans", ubt_trans, vbt_trans, CS%debug_BT_HI, haloshift=iev-ie, & + scale=US%L_T_to_m_s) + call uvchksum(trim(mesg)//" [uv]hbt", uhbt, vhbt, CS%debug_BT_HI, haloshift=iev-ie, & + scale=US%s_to_T*US%L_to_m**2*GV%H_to_m) + endif + + !GOMP parallel default(shared) if (find_PF) then !GOMP do @@ -2091,6 +2094,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, scale=US%s_to_T*US%L_to_m**2*GV%H_to_m) endif + !$OMP parallel do default(shared) do j=jsv,jev ; do i=isv,iev eta(i,j) = (eta(i,j) + eta_src(i,j)) + (dtbt * CS%IareaT(i,j)) * & @@ -2273,22 +2277,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! Calculate diagnostic quantities. if (query_averaging_enabled(CS%diag)) then - do j=js,je ; do I=is-1,ie ; CS%ubt_IC(I,j) = ubt_wtd(I,j) ; enddo ; enddo - do J=js-1,je ; do i=is,ie ; CS%vbt_IC(i,J) = vbt_wtd(i,J) ; enddo ; enddo - if (use_BT_cont) then - do j=js,je ; do I=is-1,ie - CS%uhbt_IC(I,j) = find_uhbt(ubt_wtd(I,j), BTCL_u(I,j), US) + uhbt0(I,j) - enddo ; enddo - do J=js-1,je ; do i=is,ie - CS%vhbt_IC(i,J) = find_vhbt(vbt_wtd(i,J), BTCL_v(i,J), US) + vhbt0(i,J) - enddo ; enddo - else - do j=js,je ; do I=is-1,ie - CS%uhbt_IC(I,j) = ubt_wtd(I,j) * Datu(I,j) + uhbt0(I,j) - enddo ; enddo - do J=js-1,je ; do i=is,ie - CS%vhbt_IC(i,J) = vbt_wtd(i,J) * Datv(i,J) + vhbt0(i,J) - enddo ; enddo + if (CS%gradual_BT_ICs) then + do j=js,je ; do I=is-1,ie ; CS%ubt_IC(I,j) = ubt_wtd(I,j) ; enddo ; enddo + do J=js-1,je ; do i=is,ie ; CS%vbt_IC(i,J) = vbt_wtd(i,J) ; enddo ; enddo endif ! Offer various barotropic terms for averaging. @@ -2364,12 +2355,69 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (CS%id_BTC_FA_u_WW > 0) call post_data(CS%id_BTC_FA_u_WW, BT_cont%FA_u_WW, CS%diag) if (CS%id_BTC_uBT_EE > 0) call post_data(CS%id_BTC_uBT_EE, BT_cont%uBT_EE, CS%diag) if (CS%id_BTC_uBT_WW > 0) call post_data(CS%id_BTC_uBT_WW, BT_cont%uBT_WW, CS%diag) + if (CS%id_BTC_FA_u_rat0 > 0) then + tmp_u(:,:) = 0.0 + do j=js,je ; do I=is-1,ie + if ((G%mask2dCu(I,j) > 0.0) .and. (BT_cont%FA_u_W0(I,j) > 0.0)) then + tmp_u(I,j) = (BT_cont%FA_u_E0(I,j)/ BT_cont%FA_u_W0(I,j)) + else + tmp_u(I,j) = 1.0 + endif + enddo ; enddo + call post_data(CS%id_BTC_FA_u_rat0, tmp_u, CS%diag) + endif if (CS%id_BTC_FA_v_NN > 0) call post_data(CS%id_BTC_FA_v_NN, BT_cont%FA_v_NN, CS%diag) if (CS%id_BTC_FA_v_N0 > 0) call post_data(CS%id_BTC_FA_v_N0, BT_cont%FA_v_N0, CS%diag) if (CS%id_BTC_FA_v_S0 > 0) call post_data(CS%id_BTC_FA_v_S0, BT_cont%FA_v_S0, CS%diag) if (CS%id_BTC_FA_v_SS > 0) call post_data(CS%id_BTC_FA_v_SS, BT_cont%FA_v_SS, CS%diag) if (CS%id_BTC_vBT_NN > 0) call post_data(CS%id_BTC_vBT_NN, BT_cont%vBT_NN, CS%diag) if (CS%id_BTC_vBT_SS > 0) call post_data(CS%id_BTC_vBT_SS, BT_cont%vBT_SS, CS%diag) + if (CS%id_BTC_FA_v_rat0 > 0) then + tmp_v(:,:) = 0.0 + do J=js-1,je ; do i=is,ie + if ((G%mask2dCv(i,J) > 0.0) .and. (BT_cont%FA_v_S0(i,J) > 0.0)) then + tmp_v(i,J) = (BT_cont%FA_v_N0(i,J)/ BT_cont%FA_v_S0(i,J)) + else + tmp_v(i,J) = 1.0 + endif + enddo ; enddo + call post_data(CS%id_BTC_FA_v_rat0, tmp_v, CS%diag) + endif + if (CS%id_BTC_FA_h_rat0 > 0) then + tmp_h(:,:) = 0.0 + do j=js,je ; do i=is,ie + tmp_h(i,j) = 1.0 + if ((G%mask2dCu(I,j) > 0.0) .and. (BT_cont%FA_u_W0(I,j) > 0.0) .and. (BT_cont%FA_u_E0(I,j) > 0.0)) then + if (BT_cont%FA_u_W0(I,j) > BT_cont%FA_u_E0(I,j)) then + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_u_W0(I,j)/ BT_cont%FA_u_E0(I,j))) + else + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_u_E0(I,j)/ BT_cont%FA_u_W0(I,j))) + endif + endif + if ((G%mask2dCu(I-1,j) > 0.0) .and. (BT_cont%FA_u_W0(I-1,j) > 0.0) .and. (BT_cont%FA_u_E0(I-1,j) > 0.0)) then + if (BT_cont%FA_u_W0(I-1,j) > BT_cont%FA_u_E0(I-1,j)) then + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_u_W0(I-1,j)/ BT_cont%FA_u_E0(I-1,j))) + else + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_u_E0(I-1,j)/ BT_cont%FA_u_W0(I-1,j))) + endif + endif + if ((G%mask2dCv(i,J) > 0.0) .and. (BT_cont%FA_v_S0(i,J) > 0.0) .and. (BT_cont%FA_v_N0(i,J) > 0.0)) then + if (BT_cont%FA_v_S0(i,J) > BT_cont%FA_v_N0(i,J)) then + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_v_S0(i,J)/ BT_cont%FA_v_N0(i,J))) + else + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_v_N0(i,J)/ BT_cont%FA_v_S0(i,J))) + endif + endif + if ((G%mask2dCv(i,J-1) > 0.0) .and. (BT_cont%FA_v_S0(i,J-1) > 0.0) .and. (BT_cont%FA_v_N0(i,J-1) > 0.0)) then + if (BT_cont%FA_v_S0(i,J-1) > BT_cont%FA_v_N0(i,J-1)) then + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_v_S0(i,J-1)/ BT_cont%FA_v_N0(i,J-1))) + else + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_v_N0(i,J-1)/ BT_cont%FA_v_S0(i,J-1))) + endif + endif + enddo ; enddo + call post_data(CS%id_BTC_FA_h_rat0, tmp_h, CS%diag) + endif endif else if (CS%id_frhatu1 > 0) CS%frhatu1(:,:,:) = CS%frhatu(:,:,:) @@ -2615,7 +2663,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, if (.not. OBC%segment(OBC%segnum_u(I,j))%specified) then if (use_BT_cont) then - uhbt(I,j) = find_uhbt(vel_trans, BTCL_u(I,j), US) + uhbt0(I,j) + uhbt(I,j) = find_uhbt(vel_trans, BTCL_u(I,j)) + uhbt0(I,j) else uhbt(I,j) = Datu(I,j)*vel_trans + uhbt0(I,j) endif @@ -2633,7 +2681,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, vel_trans = vbt(i,J) elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then if (OBC%segment(OBC%segnum_v(i,J))%Flather) then - cfl = dtbt * BT_OBC%Cg_v(i,J) * G%IdyCv(I,j) ! CFL + 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 = eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i,j-1)) ! internal @@ -2649,7 +2697,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, endif elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then if (OBC%segment(OBC%segnum_v(i,J))%Flather) then - cfl = dtbt * BT_OBC%Cg_v(i,J) * G%IdyCv(I,j) ! CFL + 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 = eta(i,j+1) + (0.5-cfl)*(eta(i,j+1)-eta(i,j+2)) ! internal @@ -2667,7 +2715,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, if (.not. OBC%segment(OBC%segnum_v(i,J))%specified) then if (use_BT_cont) then - vhbt(i,J) = find_vhbt(vel_trans, BTCL_v(i,J), US) + vhbt0(i,J) + vhbt(i,J) = find_vhbt(vel_trans, BTCL_v(i,J)) + vhbt0(i,J) else vhbt(i,J) = vel_trans*Datv(i,J) + vhbt0(i,J) endif @@ -3159,12 +3207,11 @@ subroutine btcalc(h, G, GV, CS, h_u, h_v, may_use_default, OBC) end subroutine btcalc !> The function find_uhbt determines the zonal transport for a given velocity. -function find_uhbt(u, BTC, US) result(uhbt) +function find_uhbt(u, BTC) result(uhbt) real, intent(in) :: u !< The local zonal velocity [L T-1 ~> 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. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real :: uhbt !< The zonal barotropic transport [L2 H T-1 ~> m3 s-1] @@ -3302,12 +3349,11 @@ function uhbt_to_ubt(uhbt, BTC, US, guess) result(ubt) end function uhbt_to_ubt !> The function find_vhbt determines the meridional transport for a given velocity. -function find_vhbt(v, BTC, US) result(vhbt) +function find_vhbt(v, BTC) result(vhbt) real, intent(in) :: v !< The local meridional velocity [L T-1 ~> 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. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real :: vhbt !< The meridional barotropic transport [L2 H T-1 ~> m3 s-1] if (v == 0.0) then @@ -3324,7 +3370,7 @@ function find_vhbt(v, BTC, US) result(vhbt) end function find_vhbt -!> The function find_vhbt determines the meridional transport for a given velocity. +!> The function find_dvhbt_dv determines the marginal meridional face area for a given velocity. function find_dvhbt_dv(v, BTC, US) result(dvhbt_dv) real, intent(in) :: v !< The local meridional velocity [L T-1 ~> m s-1] type(local_BT_cont_v_type), intent(in) :: BTC !< A structure containing various fields that @@ -3839,8 +3885,6 @@ subroutine bt_mass_source(h, eta, set_cor, G, GV, CS) real :: d_eta ! The difference between estimates of the total ! thicknesses [H ~> m or kg m-2]. integer :: is, ie, js, je, nz, i, j, k - real, parameter :: frac_cor = 0.25 - real, parameter :: slow_rate = 0.125 if (.not.associated(CS)) call MOM_error(FATAL, "bt_mass_source: "// & "Module MOM_barotropic must be initialized before it is used.") @@ -3982,7 +4026,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, "BT_cont_type variables to set limits determined by "//& "MAXCFL_BT_CONT on the CFL number of the velocities "//& "that are likely to be driven by the corrective mass fluxes.", & - default=.true.) !, do_not_log=.not.CS%bound_BT_corr) + default=.true., do_not_log=.not.CS%bound_BT_corr) call get_param(param_file, mdl, "ADJUST_BT_CONT", CS%adjust_BT_cont, & "If true, adjust the curve fit to the BT_cont type "//& "that is used by the barotropic solver to match the "//& @@ -4021,24 +4065,21 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, layoutParam=.true.) call get_param(param_file, mdl, "USE_BT_CONT_TYPE", use_BT_cont_type, & - "If true, use a structure with elements that describe "//& - "effective face areas from the summed continuity solver "//& - "as a function the barotropic flow in coupling between "//& - "the barotropic and baroclinic flow. This is only used "//& - "if SPLIT is true. \n", default=.true.) - call get_param(param_file, mdl, "NONLINEAR_BT_CONTINUITY", & - CS%Nonlinear_continuity, & + "If true, use a structure with elements that describe "//& + "effective face areas from the summed continuity solver "//& + "as a function the barotropic flow in coupling between "//& + "the barotropic and baroclinic flow. This is only used "//& + "if SPLIT is true.", default=.true.) + call get_param(param_file, mdl, "NONLINEAR_BT_CONTINUITY", CS%Nonlinear_continuity, & "If true, use nonlinear transports in the barotropic "//& "continuity equation. This does not apply if "//& - "USE_BT_CONT_TYPE is true.", default=.false.) - CS%Nonlin_cont_update_period = 1 - if (CS%Nonlinear_continuity) & - call get_param(param_file, mdl, "NONLIN_BT_CONT_UPDATE_PERIOD", & - CS%Nonlin_cont_update_period, & + "USE_BT_CONT_TYPE is true.", default=.false., do_not_log=use_BT_cont_type) + call get_param(param_file, mdl, "NONLIN_BT_CONT_UPDATE_PERIOD", CS%Nonlin_cont_update_period, & "If NONLINEAR_BT_CONTINUITY is true, this is the number "//& "of barotropic time steps between updates to the face "//& - "areas, or 0 to update only before the barotropic stepping.",& - units="nondim", default=1) + "areas, or 0 to update only before the barotropic stepping.", & + units="nondim", default=1, do_not_log=.not.CS%Nonlinear_continuity) + call get_param(param_file, mdl, "BT_PROJECT_VELOCITY", CS%BT_project_velocity,& "If true, step the barotropic velocity first and project "//& "out the velocity tendency by 1+BEBT when calculating the "//& @@ -4055,22 +4096,21 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, call get_param(param_file, mdl, "DYNAMIC_SURFACE_PRESSURE", CS%dynamic_psurf, & "If true, add a dynamic pressure due to a viscous ice "//& "shelf, for instance.", default=.false.) - if (CS%dynamic_psurf) then - call get_param(param_file, mdl, "ICE_LENGTH_DYN_PSURF", CS%ice_strength_length, & + call get_param(param_file, mdl, "ICE_LENGTH_DYN_PSURF", CS%ice_strength_length, & "The length scale at which the Rayleigh damping rate due "//& "to the ice strength should be the same as if a Laplacian "//& "were applied, if DYNAMIC_SURFACE_PRESSURE is true.", & - units="m", default=1.0e4, scale=US%m_to_L) - call get_param(param_file, mdl, "DEPTH_MIN_DYN_PSURF", CS%Dmin_dyn_psurf, & - "The minimum depth to use in limiting the size of the "//& - "dynamic surface pressure for stability, if "//& - "DYNAMIC_SURFACE_PRESSURE is true..", & - units="m", default=1.0e-6, scale=US%m_to_Z) - call get_param(param_file, mdl, "CONST_DYN_PSURF", CS%const_dyn_psurf, & + units="m", default=1.0e4, scale=US%m_to_L, do_not_log=.not.CS%dynamic_psurf) + call get_param(param_file, mdl, "DEPTH_MIN_DYN_PSURF", CS%Dmin_dyn_psurf, & + "The minimum depth to use in limiting the size of the "//& + "dynamic surface pressure for stability, if "//& + "DYNAMIC_SURFACE_PRESSURE is true..", & + units="m", default=1.0e-6, scale=US%m_to_Z, do_not_log=.not.CS%dynamic_psurf) + call get_param(param_file, mdl, "CONST_DYN_PSURF", CS%const_dyn_psurf, & "The constant that scales the dynamic surface pressure, "//& "if DYNAMIC_SURFACE_PRESSURE is true. Stable values "//& - "are < ~1.0.", units="nondim", default=0.9) - endif + "are < ~1.0.", units="nondim", default=0.9, do_not_log=.not.CS%dynamic_psurf) + call get_param(param_file, mdl, "BT_CORIOLIS_SCALE", CS%BT_Coriolis_scale, & "A factor by which the barotropic Coriolis anomaly terms are scaled.", & units="nondim", default=1.0) @@ -4295,7 +4335,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, CS%IdxCu(I,j) = G%IdxCu(I,j) ; CS%dy_Cu(I,j) = G%dy_Cu(I,j) enddo ; enddo do J=G%JsdB,G%JedB ; do i=G%isd,G%ied - CS%IdyCv(I,j) = G%IdyCv(I,j) ; CS%dx_Cv(i,J) = G%dx_Cv(i,J) + CS%IdyCv(i,J) = G%IdyCv(i,J) ; CS%dx_Cv(i,J) = G%dx_Cv(i,J) enddo ; enddo call create_group_pass(pass_static_data, CS%IareaT, CS%BT_domain, To_All) call create_group_pass(pass_static_data, CS%bathyT, CS%BT_domain, To_All) @@ -4385,7 +4425,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, call log_param(param_file, mdl, "DTBT as used", CS%dtbt*US%T_to_s) call log_param(param_file, mdl, "estimated maximum DTBT", CS%dtbt_max*US%T_to_s) - ! ubtav, vbtav, ubt_IC, vbt_IC, uhbt_IC, and vhbt_IC are allocated and + ! ubtav and vbtav, and perhaps ubt_IC and vbt_IC, are allocated and ! initialized in register_barotropic_restarts. if (GV%Boussinesq) then @@ -4488,6 +4528,9 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, 'BTCont type far east velocity', 'm s-1', conversion=US%L_T_to_m_s) CS%id_BTC_ubt_WW = register_diag_field('ocean_model', 'BTC_ubt_WW', diag%axesCu1, Time, & 'BTCont type far west velocity', 'm s-1', conversion=US%L_T_to_m_s) + ! This is a specialized diagnostic that is not being made widely available (yet). + ! CS%id_BTC_FA_u_rat0 = register_diag_field('ocean_model', 'BTC_FA_u_rat0', diag%axesCu1, Time, & + ! 'BTCont type ratio of near east and west face areas', 'nondim') CS%id_BTC_FA_v_NN = register_diag_field('ocean_model', 'BTC_FA_v_NN', diag%axesCv1, Time, & 'BTCont type far north face area', 'm2', conversion=US%L_to_m*GV%H_to_m) CS%id_BTC_FA_v_N0 = register_diag_field('ocean_model', 'BTC_FA_v_N0', diag%axesCv1, Time, & @@ -4500,6 +4543,11 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, 'BTCont type far north velocity', 'm s-1', conversion=US%L_T_to_m_s) CS%id_BTC_vbt_SS = register_diag_field('ocean_model', 'BTC_vbt_SS', diag%axesCv1, Time, & 'BTCont type far south velocity', 'm s-1', conversion=US%L_T_to_m_s) + ! This is a specialized diagnostic that is not being made widely available (yet). + ! CS%id_BTC_FA_v_rat0 = register_diag_field('ocean_model', 'BTC_FA_v_rat0', diag%axesCv1, Time, & + ! 'BTCont type ratio of near north and south face areas', 'nondim') + ! CS%id_BTC_FA_h_rat0 = register_diag_field('ocean_model', 'BTC_FA_h_rat0', diag%axesT1, Time, & + ! 'BTCont type maximum ratios of near face areas around cells', 'nondim') endif CS%id_uhbt0 = register_diag_field('ocean_model', 'uhbt0', diag%axesCu1, Time, & 'Barotropic zonal transport difference', 'm3 s-1', conversion=GV%H_to_m*US%L_to_m**2*US%s_to_T) @@ -4523,20 +4571,21 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, (US%m_to_L*US%s_to_T_restart) /= (US%m_to_L_restart*US%s_to_T)) then vel_rescale = (US%m_to_L*US%s_to_T_restart) / (US%m_to_L_restart*US%s_to_T) do j=js,je ; do I=is-1,ie ; CS%ubtav(I,j) = vel_rescale * CS%ubtav(I,j) ; enddo ; enddo - do J=js-1,je ; do i=is,ie ; CS%vbtav(i,J) = vel_rescale * CS%vbtav(I,j) ; enddo ; enddo + do J=js-1,je ; do i=is,ie ; CS%vbtav(i,J) = vel_rescale * CS%vbtav(i,J) ; enddo ; enddo endif - if (.NOT.query_initialized(CS%ubt_IC,"ubt_IC",restart_CS) .or. & - .NOT.query_initialized(CS%vbt_IC,"vbt_IC",restart_CS)) then - do j=js,je ; do I=is-1,ie ; CS%ubt_IC(I,j) = CS%ubtav(I,j) ; enddo ; enddo - do J=js-1,je ; do i=is,ie ; CS%vbt_IC(i,J) = CS%vbtav(i,J) ; enddo ; enddo - elseif ((US%s_to_T_restart*US%m_to_L_restart /= 0.0) .and. & - (US%m_to_L*US%s_to_T_restart) /= (US%m_to_L_restart*US%s_to_T)) then - vel_rescale = (US%m_to_L*US%s_to_T_restart) / (US%m_to_L_restart*US%s_to_T) - do j=js,je ; do I=is-1,ie ; CS%ubt_IC(I,j) = vel_rescale * CS%ubt_IC(I,j) ; enddo ; enddo - do J=js-1,je ; do i=is,ie ; CS%vbt_IC(i,J) = vel_rescale * CS%vbt_IC(I,j) ; enddo ; enddo + if (CS%gradual_BT_ICs) then + if (.NOT.query_initialized(CS%ubt_IC,"ubt_IC",restart_CS) .or. & + .NOT.query_initialized(CS%vbt_IC,"vbt_IC",restart_CS)) then + do j=js,je ; do I=is-1,ie ; CS%ubt_IC(I,j) = CS%ubtav(I,j) ; enddo ; enddo + do J=js-1,je ; do i=is,ie ; CS%vbt_IC(i,J) = CS%vbtav(i,J) ; enddo ; enddo + elseif ((US%s_to_T_restart*US%m_to_L_restart /= 0.0) .and. & + (US%m_to_L*US%s_to_T_restart) /= (US%m_to_L_restart*US%s_to_T)) then + vel_rescale = (US%m_to_L*US%s_to_T_restart) / (US%m_to_L_restart*US%s_to_T) + do j=js,je ; do I=is-1,ie ; CS%ubt_IC(I,j) = vel_rescale * CS%ubt_IC(I,j) ; enddo ; enddo + do J=js-1,je ; do i=is,ie ; CS%vbt_IC(i,J) = vel_rescale * CS%vbt_IC(i,J) ; enddo ; enddo + endif endif - ! Calculate other constants which are used for btstep. if (.not.CS%nonlin_stress) then @@ -4551,7 +4600,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, 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)) + 2.0*Mean_SL) - else ! Both neighboring H points are masked out so IDatv(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 @@ -4567,21 +4616,8 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, enddo ; enddo endif - if (.NOT.query_initialized(CS%uhbt_IC,"uhbt_IC",restart_CS) .or. & - .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 ((US%s_to_T_restart * US%m_to_L_restart * GV%m_to_H_restart /= 0.0) .and. & - ((US%s_to_T_restart * US%m_to_L**2 * GV%m_to_H) /= & - (US%s_to_T * US%m_to_L_restart**2 * GV%m_to_H_restart))) then - uH_rescale = (US%s_to_T_restart * US%m_to_L**2 * GV%m_to_H) / & - (US%s_to_T * US%m_to_L_restart**2 * 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) - call create_group_pass(pass_bt_hbt_btav, CS%uhbt_IC, CS%vhbt_IC, G%Domain) + if (CS%gradual_BT_ICs) & + call create_group_pass(pass_bt_hbt_btav, CS%ubt_IC, CS%vbt_IC, G%Domain) call create_group_pass(pass_bt_hbt_btav, CS%ubtav, CS%vbtav, G%Domain) call do_group_pass(pass_bt_hbt_btav, G%Domain) @@ -4649,7 +4685,7 @@ subroutine register_barotropic_restarts(HI, GV, param_file, CS, restart_CS) ! Local variables type(vardesc) :: vd(3) - real :: slow_rate + character(len=40) :: mdl = "MOM_barotropic" ! This module's name. integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed @@ -4662,12 +4698,20 @@ subroutine register_barotropic_restarts(HI, GV, param_file, CS, restart_CS) endif allocate(CS) + call get_param(param_file, mdl, "GRADUAL_BT_ICS", CS%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.", & + default=.false., do_not_log=.true.) + ALLOC_(CS%ubtav(IsdB:IedB,jsd:jed)) ; CS%ubtav(:,:) = 0.0 ALLOC_(CS%vbtav(isd:ied,JsdB:JedB)) ; CS%vbtav(:,:) = 0.0 - ALLOC_(CS%ubt_IC(IsdB:IedB,jsd:jed)) ; CS%ubt_IC(:,:) = 0.0 - ALLOC_(CS%vbt_IC(isd:ied,JsdB:JedB)) ; CS%vbt_IC(:,:) = 0.0 - ALLOC_(CS%uhbt_IC(IsdB:IedB,jsd:jed)) ; CS%uhbt_IC(:,:) = 0.0 - ALLOC_(CS%vhbt_IC(isd:ied,JsdB:JedB)) ; CS%vhbt_IC(:,:) = 0.0 + if (CS%gradual_BT_ICs) then + ALLOC_(CS%ubt_IC(IsdB:IedB,jsd:jed)) ; CS%ubt_IC(:,:) = 0.0 + ALLOC_(CS%vbt_IC(isd:ied,JsdB:JedB)) ; CS%vbt_IC(:,:) = 0.0 + endif vd(2) = var_desc("ubtav","m s-1","Time mean barotropic zonal velocity", & hor_grid='u', z_grid='1') @@ -4675,30 +4719,16 @@ subroutine register_barotropic_restarts(HI, GV, param_file, CS, restart_CS) hor_grid='v', z_grid='1') call register_restart_pair(CS%ubtav, CS%vbtav, vd(2), vd(3), .false., restart_CS) - vd(2) = var_desc("ubt_IC", "m s-1", & - longname="Next initial condition for the barotropic zonal velocity", & - hor_grid='u', z_grid='1') - vd(3) = var_desc("vbt_IC", "m s-1", & - longname="Next initial condition for the barotropic meridional velocity",& - hor_grid='v', z_grid='1') - call register_restart_pair(CS%ubt_IC, CS%vbt_IC, vd(2), vd(3), .false., restart_CS) - - if (GV%Boussinesq) then - 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", & - longname="Next initial condition for the barotropic meridional transport",& - hor_grid='v', z_grid='1') - else - vd(2) = var_desc("uhbt_IC", "kg s-1", & - longname="Next initial condition for the barotropic zonal transport", & + if (CS%gradual_BT_ICs) then + vd(2) = var_desc("ubt_IC", "m s-1", & + longname="Next initial condition for the barotropic zonal velocity", & hor_grid='u', z_grid='1') - vd(3) = var_desc("vhbt_IC", "kg s-1", & - longname="Next initial condition for the barotropic meridional transport",& + vd(3) = var_desc("vbt_IC", "m s-1", & + longname="Next initial condition for the barotropic meridional velocity",& hor_grid='v', z_grid='1') + call register_restart_pair(CS%ubt_IC, CS%vbt_IC, vd(2), vd(3), .false., restart_CS) endif - call register_restart_pair(CS%uhbt_IC, CS%vhbt_IC, vd(2), vd(3), .false., restart_CS) + call register_restart_field(CS%dtbt, "DTBT", .false., restart_CS, & longname="Barotropic timestep", units="seconds") From 14d63487c43f8fba017a2f330a1b9c6b77e32d5e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 14 Jul 2020 10:13:10 -0400 Subject: [PATCH 66/91] +Add the new parameter INTEGRAL_BT_CONTINUITY Add the new runtime parameter INTEGRAL_BT_CONTINUITY which enables the use of the time-integrated barotropic velocity to determine the cumulative transport since the start of the barotropic stepping. This new option works in all of the MOM6-examples test cases with a SPLIT=True and USE_BT_CONT_TYPE=True. By default all answers are bitwise identical, but there are changes to the entries in the MOM_parameter_doc files. --- src/core/MOM_barotropic.F90 | 226 ++++++++++++++++++++++++++++++++---- 1 file changed, 206 insertions(+), 20 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 4e4233bc38..458599aed5 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -186,6 +186,11 @@ module MOM_barotropic !! otherwise the Arakawa & Hsu scheme is used. If !! the deformation radius is not resolved Sadourny's !! scheme should probably be used. + logical :: integral_bt_cont !< If true, use the time-integrated velocity over the barotropic steps + !! to determine the integrated transports used to update the continuity + !! equation. Otherwise the transports are the sum of the transports + !! based on ]a series of instantaneous velocities and the BT_CONT_TYPE + !! for transports. This is only valid if a BT_CONT_TYPE is 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 @@ -504,7 +509,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ubt_old, & ! The starting value of ubt in a barotropic step [L T-1 ~> m s-1]. ubt_first, & ! The starting value of ubt in a series of barotropic steps [L T-1 ~> m s-1]. ubt_sum, & ! The sum of ubt over the time steps [L T-1 ~> m s-1]. + ubt_int, & ! The running time integral of ubt over the time steps [L ~> m]. uhbt_sum, & ! The sum of uhbt over the time steps [H L2 T-1 ~> m3 s-1 or kg s-1]. + uhbt_int, & ! The running time integral of uhbt over the time steps [H L2 ~> m3]. ubt_wtd, & ! A weighted sum used to find the filtered final ubt [L T-1 ~> m s-1]. ubt_trans, & ! The latest value of ubt used for a transport [L T-1 ~> m s-1]. azon, bzon, & ! _zon & _mer are the values of the Coriolis force which @@ -537,7 +544,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, vbt_old, & ! The starting value of vbt in a barotropic step [L T-1 ~> m s-1]. vbt_first, & ! The starting value of ubt in a series of barotropic steps [L T-1 ~> m s-1]. vbt_sum, & ! The sum of vbt over the time steps [L T-1 ~> m s-1]. + vbt_int, & ! The running time integral of vbt over the time steps [L ~> m]. vhbt_sum, & ! The sum of vhbt over the time steps [H L2 T-1 ~> m3 s-1 or kg s-1]. + vhbt_int, & ! The running time integral of vhbt over the time steps [H L2 ~> m3]. vbt_wtd, & ! A weighted sum used to find the filtered final vbt [L T-1 ~> m s-1]. vbt_trans, & ! The latest value of vbt used for a transport [L T-1 ~> m s-1]. Cor_v, & ! The meridional Coriolis acceleration [L T-2 ~> m s-2]. @@ -562,6 +571,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, real, dimension(SZIW_(CS),SZJW_(CS)) :: & 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_IC, & ! A local copy of the initial 2-D eta field (eta_in) [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 [H ~> m or kg m-2]. @@ -588,10 +598,14 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, real, dimension(SZIBW_(CS),SZJW_(CS)) :: & ubt_prev, ubt_sum_prev, ubt_wtd_prev, & ! Previous velocities stored for OBCs [L T-1 ~> m s-1] - uhbt_prev, uhbt_sum_prev ! Previous transports stored for OBCs [L2 H T-1 ~> m3 s-1] + uhbt_prev, uhbt_sum_prev, & ! Previous transports stored for OBCs [L2 H T-1 ~> m3 s-1] + ubt_int_prev, & ! Previous value of time-integrated velocity stored for OBCs [L ~> m] + uhbt_int_prev ! Previous value of time-integrated transport stored for OBCs [L2 H ~> m3] real, dimension(SZIW_(CS),SZJBW_(CS)) :: & vbt_prev, vbt_sum_prev, vbt_wtd_prev, & ! Previous velocities stored for OBCs [L T-1 ~> m s-1] - vhbt_prev, vhbt_sum_prev ! Previous transports stored for OBCs [L2 H T-1 ~> m3 s-1] + vhbt_prev, vhbt_sum_prev, & ! Previous transports stored for OBCs [L2 H T-1 ~> m3 s-1] + vbt_int_prev, & ! Previous value of time-integrated velocity stored for OBCs [L ~> m] + vhbt_int_prev ! Previous value of time-integrated transport stored for OBCs [L2 H ~> m3] real :: mass_to_Z ! The depth unit conversion divided by the mean density (Rho0) [Z m-1 R-1 ~> m3 kg-1]. real :: mass_accel_to_Z ! The inverse of the mean density (Rho0) [R-1 ~> m3 kg-1]. real :: visc_rem ! A work variable that may equal visc_rem_[uv]. Nondim. @@ -621,6 +635,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! velocity point [H ~> m or kg m-2] logical :: do_hifreq_output ! If true, output occurs every barotropic step. logical :: use_BT_cont, do_ave, find_etaav, find_PF, find_Cor + logical :: integral_BT_cont ! If true, update the continuity directly from the initial + ! condition using the time-integrated barotropic velocity. logical :: ice_is_rigid, nonblock_setup, interp_eta_PF logical :: project_velocity, add_uh0 @@ -639,6 +655,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, real :: accel_underflow ! An acceleration that is so small it should be zeroed out [L T-2 ~> m s-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 :: Idt2 ! The inverse square of the time interval of this call [T-2 ~> s-2]. + real :: Idtbt ! The inverse of the barotropic time step [T-1 ~> s-1] 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 @@ -669,10 +687,13 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, h_neglect = GV%H_subroundoff Idt = 1.0 / dt + Idt2 = Idt**2 accel_underflow = CS%vel_underflow * Idt use_BT_cont = .false. if (present(BT_cont)) use_BT_cont = (associated(BT_cont)) + integral_BT_cont = use_BT_cont .and. CS%integral_BT_cont + interp_eta_PF = .false. if (present(eta_PF_start)) interp_eta_PF = (associated(eta_PF_start)) @@ -736,6 +757,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! Set the actual barotropic time step. Instep = 1.0 / real(nstep) dtbt = dt * Instep + Idtbt = 1.0 / dtbt bebt = CS%bebt be_proj = CS%bebt mass_accel_to_Z = 1.0 / GV%Rho0 @@ -779,6 +801,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, else call create_group_pass(CS%pass_eta_bt_rem, eta_PF, CS%BT_Domain) endif + if (integral_BT_cont) & + call create_group_pass(CS%pass_eta_bt_rem, eta_IC, CS%BT_Domain) call create_group_pass(CS%pass_eta_bt_rem, eta_src, CS%BT_Domain) ! The following halo updates are not needed without wide halos. RWH ! We do need them after all. @@ -799,6 +823,11 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif call create_group_pass(CS%pass_eta_ubt, eta, CS%BT_Domain) call create_group_pass(CS%pass_eta_ubt, ubt, vbt, CS%BT_Domain) + if (integral_BT_cont) then + call create_group_pass(CS%pass_eta_ubt, ubt_int, vbt_int, CS%BT_Domain) + ! This might only be needed with OBCs. + call create_group_pass(CS%pass_eta_ubt, uhbt_int, vhbt_int, CS%BT_Domain) + endif call create_group_pass(CS%pass_ubt_Cor, ubt_Cor, vbt_Cor, G%Domain) ! These passes occur at the end of the routine, as data is being readied to @@ -892,6 +921,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (interp_eta_PF) then eta_PF_1(i,j) = 0.0 ; d_eta_PF(i,j) = 0.0 endif + if (integral_BT_cont) then + eta_IC(i,j) = 0.0 + endif p_surf_dyn(i,j) = 0.0 if (CS%dynamic_psurf) dyn_coef_eta(i,j) = 0.0 enddo ; enddo @@ -924,6 +956,12 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, eta_PF(i,j) = eta_PF_in(i,j) enddo ; enddo endif + if (integral_BT_cont) then + !$OMP parallel do default(shared) + do j=G%jsd,G%jed ; do i=G%isd,G%ied + eta_IC(i,j) = eta_in(i,j) + enddo ; enddo + endif !$OMP parallel do default(shared) private(visc_rem) do k=1,nz ; do j=js,je ; do I=is-1,ie @@ -1094,10 +1132,12 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, !$OMP parallel do default(shared) do j=jsvf-1,jevf+1 ; do I=isvf-2,ievf+1 ubt(I,j) = 0.0 ; uhbt(I,j) = 0.0 ; u_accel_bt(I,j) = 0.0 + ubt_int(I,j) = 0.0 ; uhbt_int(I,j) = 0.0 enddo ; enddo !$OMP parallel do default(shared) do J=jsvf-2,jevf+1 ; do i=isvf-1,ievf+1 vbt(i,J) = 0.0 ; vhbt(i,J) = 0.0 ; v_accel_bt(i,J) = 0.0 + vbt_int(i,J) = 0.0 ; vhbt_int(i,J) = 0.0 enddo ; enddo !$OMP parallel do default(shared) do j=js,je ; do k=1,nz ; do I=is-1,ie @@ -1662,9 +1702,36 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, call find_face_areas(Datu, Datv, G, GV, US, CS, MS, eta, 1+iev-ie) endif + if (integral_BT_cont) then + !GOMP parallel do default(shared) + do j=jsv-1,jev+1 ; do I=isv-2,iev+1 + ubt_int_prev(I,j) = ubt_int(I,j) ; uhbt_int_prev(I,j) = uhbt_int(I,j) + enddo ; enddo + !GOMP parallel do default(shared) + do J=jsv-2,jev+1 ; do i=isv-1,iev+1 + vbt_int_prev(i,J) = vbt_int(i,J) ; vhbt_int_prev(i,J) = vhbt_int(i,J) + enddo ; enddo + endif + !GOMP parallel default(shared) if (CS%dynamic_psurf .or. .not.project_velocity) then - if (use_BT_cont) then + if (integral_BT_cont) then + !GOMP do + do j=jsv-1,jev+1 ; do I=isv-2,iev+1 + uhbt_int(I,j) = find_uhbt_int(ubt_int(I,j) + dtbt*ubt(I,j), BTCL_u(I,j), dt, Idt2) + & + n*dtbt*uhbt0(I,j) + enddo ; enddo + !GOMP do + do J=jsv-2,jev+1 ; do i=isv-1,iev+1 + vhbt_int(i,J) = find_vhbt_int(vbt_int(i,J) + dtbt*vbt(i,J), BTCL_v(i,J), dt, Idt2) + & + n*dtbt*vhbt0(i,J) + enddo ; enddo + !GOMP do + do j=jsv-1,jev+1 ; do i=isv-1,iev+1 + eta_pred(i,j) = (eta_IC(i,j) + n*eta_src(i,j)) + CS%IareaT(i,j) * & + ((uhbt_int(I-1,j) - uhbt_int(I,j)) + (vhbt_int(i,J-1) - vhbt_int(i,J))) + enddo ; enddo + elseif (use_BT_cont) then !GOMP do do j=jsv-1,jev+1 ; do I=isv-2,iev+1 uhbt(I,j) = find_uhbt(ubt(I,j), BTCL_u(I,j)) + uhbt0(I,j) @@ -1739,6 +1806,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, do j=jsv-joff,jev+joff ; do I=isv-1,iev ubt_prev(I,j) = ubt(I,j) ; uhbt_prev(I,j) = uhbt(I,j) ubt_sum_prev(I,j) = ubt_sum(I,j) ; uhbt_sum_prev(I,j) = uhbt_sum(I,j) ; ubt_wtd_prev(I,j) = ubt_wtd(I,j) + !Avoid this? ubt_int_prev(I,j) = ubt_int(I,j) ; uhbt_int_prev(I,j) = uhbt_int(I,j) enddo ; enddo endif @@ -1747,6 +1815,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, do J=jsv-1,jev ; do i=isv-ioff,iev+ioff vbt_prev(i,J) = vbt(i,J) ; vhbt_prev(i,J) = vhbt(i,J) vbt_sum_prev(i,J) = vbt_sum(i,J) ; vhbt_sum_prev(i,J) = vhbt_sum(i,J) ; vbt_wtd_prev(i,J) = vbt_wtd(i,J) + !Avoid this? vbt_int_prev(i,J) = vbt_int(i,J) ; vhbt_int_prev(i,J) = vhbt_int(i,J) enddo ; enddo endif endif @@ -1790,7 +1859,16 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif enddo ; enddo - if (use_BT_cont) then + if (integral_BT_cont) then + !GOMP do + do J=jsv-1,jev ; do i=isv-1,iev+1 + vbt_int(i,J) = vbt_int(i,J) + dtbt * vbt_trans(i,J) + vhbt_int(i,J) = find_vhbt_int(vbt_int(i,J), BTCL_v(i,J), dt, Idt2) + & + n*dtbt*vhbt0(i,J) + ! I do not know whether this is accurate enough. + vhbt(i,J) = (vhbt_int(i,J) - vhbt_int_prev(i,J)) * Idtbt + enddo ; enddo + elseif (use_BT_cont) then !GOMP do do J=jsv-1,jev ; do i=isv-1,iev+1 vhbt(i,J) = find_vhbt(vbt_trans(i,J), BTCL_v(i,J)) + vhbt0(i,J) @@ -1847,7 +1925,16 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif enddo ; enddo - if (use_BT_cont) then + if (integral_BT_cont) then + !GOMP do + do j=jsv,jev ; do I=isv-1,iev + ubt_int(I,j) = ubt_int(I,j) + dtbt * ubt_trans(I,j) + uhbt_int(I,j) = find_uhbt_int(ubt_int(I,j), BTCL_u(I,j), dt, Idt2) + & + n*dtbt*uhbt0(I,j) + ! I do not know whether this is accurate enough. + uhbt(I,j) = (uhbt_int(I,j) - uhbt_int_prev(I,j)) * Idtbt + enddo ; enddo + elseif (use_BT_cont) then !GOMP do do j=jsv,jev ; do I=isv-1,iev uhbt(I,j) = find_uhbt(ubt_trans(I,j), BTCL_u(I,j)) + uhbt0(I,j) @@ -1906,7 +1993,16 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif enddo ; enddo - if (use_BT_cont) then + if (integral_BT_cont) then + !GOMP do + do j=jsv-1,jev+1 ; do I=isv-1,iev + ubt_int(I,j) = ubt_int(I,j) + dtbt * ubt_trans(I,j) + uhbt_int(I,j) = find_uhbt_int(ubt_int(I,j), BTCL_u(I,j), dt, Idt2) + & + n*dtbt*uhbt0(I,j) + ! I do not know whether this is accurate enough. + uhbt(I,j) = (uhbt_int(I,j) - uhbt_int_prev(I,j)) * Idtbt + enddo ; enddo + elseif (use_BT_cont) then !GOMP do do j=jsv-1,jev+1 ; do I=isv-1,iev uhbt(I,j) = find_uhbt(ubt_trans(I,j), BTCL_u(I,j)) + uhbt0(I,j) @@ -1974,7 +2070,16 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, v_accel_bt(i,J) = v_accel_bt(i,J) + wt_accel(n) * (Cor_v(i,J) + PFv(i,J)) endif enddo ; enddo - if (use_BT_cont) then + if (integral_BT_cont) then + !GOMP do + do J=jsv-1,jev ; do i=isv,iev + vbt_int(i,J) = vbt_int(i,J) + dtbt * vbt_trans(i,J) + vhbt_int(i,J) = find_vhbt_int(vbt_int(i,J), BTCL_v(i,J), dt, Idt2) + & + n*dtbt*vhbt0(i,J) + ! I do not know whether this is accurate enough. + vhbt(i,J) = (vhbt_int(i,J) - vhbt_int_prev(i,J)) * Idtbt + enddo ; enddo + elseif (use_BT_cont) then !GOMP do do J=jsv-1,jev ; do i=isv,iev vhbt(i,J) = find_vhbt(vbt_trans(i,J), BTCL_v(i,J)) + vhbt0(i,J) @@ -2009,6 +2114,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, scale=US%L_T_to_m_s) call uvchksum(trim(mesg)//" [uv]hbt", uhbt, vhbt, CS%debug_BT_HI, haloshift=iev-ie, & scale=US%s_to_T*US%L_to_m**2*GV%H_to_m) + if (integral_BT_cont) & + call uvchksum(trim(mesg)//" [uv]hbt_int", uhbt_int, vhbt_int, CS%debug_BT_HI, haloshift=iev-ie, & + scale=US%L_to_m**2*GV%H_to_m) endif @@ -2037,12 +2145,14 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, !GOMP do do j=js,je ; do I=is-1,ie ubt_sum(I,j) = ubt_sum(I,j) + wt_trans(n) * ubt_trans(I,j) + !This already happened: ubt_int(I,j) = ubt_int(I,j) + dtbt * ubt_trans(I,j) uhbt_sum(I,j) = uhbt_sum(I,j) + wt_trans(n) * uhbt(I,j) ubt_wtd(I,j) = ubt_wtd(I,j) + wt_vel(n) * ubt(I,j) enddo ; enddo !GOMP do do J=js-1,je ; do i=is,ie vbt_sum(i,J) = vbt_sum(i,J) + wt_trans(n) * vbt_trans(i,J) + !This already happened: vbt_int(i,J) = vbt_int(i,J) + dtbt * vbt_trans(i,J) vhbt_sum(i,J) = vhbt_sum(i,J) + wt_trans(n) * vhbt(i,J) vbt_wtd(i,J) = vbt_wtd(i,J) + wt_vel(n) * vbt(i,J) enddo ; enddo @@ -2076,14 +2186,18 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (CS%BT_OBC%apply_u_OBCs) then ; do j=js,je ; do I=is-1,ie if (OBC%segnum_u(I,j) /= OBC_NONE) then ubt_sum(I,j) = ubt_sum(I,j) + wt_trans(n) * ubt_trans(I,j) + ubt_int(I,j) = ubt_int_prev(I,j) + dtbt * ubt_trans(I,j) uhbt_sum(I,j) = uhbt_sum(I,j) + wt_trans(n) * uhbt(I,j) + uhbt_int(I,j) = uhbt_int_prev(I,j) + dtbt * uhbt(I,j) ubt_wtd(I,j) = ubt_wtd(I,j) + wt_vel(n) * ubt(I,j) endif enddo ; enddo ; endif if (CS%BT_OBC%apply_v_OBCs) then ; do J=js-1,je ; do i=is,ie if (OBC%segnum_v(i,J) /= OBC_NONE) then vbt_sum(i,J) = vbt_sum(i,J) + wt_trans(n) * vbt_trans(i,J) + vbt_int(i,J) = vbt_int_prev(i,J) + dtbt * vbt_trans(i,J) vhbt_sum(i,J) = vhbt_sum(i,J) + wt_trans(n) * vhbt(i,J) + vhbt_int(i,J) = vhbt_int_prev(i,J) + dtbt * vhbt(i,J) vbt_wtd(i,J) = vbt_wtd(i,J) + wt_vel(n) * vbt(i,J) endif enddo ; enddo ; endif @@ -2092,15 +2206,27 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (CS%debug_bt) then call uvchksum("BT [uv]hbt just after OBC", uhbt, vhbt, CS%debug_BT_HI, haloshift=iev-ie, & scale=US%s_to_T*US%L_to_m**2*GV%H_to_m) + if (integral_BT_cont) & + call uvchksum("BT [uv]hbt_int just after OBC", uhbt_int, vhbt_int, CS%debug_BT_HI, & + haloshift=iev-ie, scale=US%L_to_m**2*GV%H_to_m) endif - !$OMP parallel do default(shared) - do j=jsv,jev ; do i=isv,iev - eta(i,j) = (eta(i,j) + eta_src(i,j)) + (dtbt * CS%IareaT(i,j)) * & - ((uhbt(I-1,j) - uhbt(I,j)) + (vhbt(i,J-1) - vhbt(i,J))) - eta_wtd(i,j) = eta_wtd(i,j) + eta(i,j) * wt_eta(n) - enddo ; enddo + if (integral_BT_cont) then + !$OMP parallel do default(shared) + do j=jsv,jev ; do i=isv,iev + eta(i,j) = (eta_IC(i,j) + n*eta_src(i,j)) + CS%IareaT(i,j) * & + ((uhbt_int(I-1,j) - uhbt_int(I,j)) + (vhbt_int(i,J-1) - vhbt_int(i,J))) + eta_wtd(i,j) = eta_wtd(i,j) + eta(i,j) * wt_eta(n) + enddo ; enddo + else + !$OMP parallel do default(shared) + do j=jsv,jev ; do i=isv,iev + eta(i,j) = (eta(i,j) + eta_src(i,j)) + (dtbt * CS%IareaT(i,j)) * & + ((uhbt(I-1,j) - uhbt(I,j)) + (vhbt(i,J-1) - vhbt(i,J))) + eta_wtd(i,j) = eta_wtd(i,j) + eta(i,j) * wt_eta(n) + enddo ; enddo + endif if (do_hifreq_output) then time_step_end = time_bt_start + real_to_time(n*US%T_to_s*dtbt) @@ -3229,6 +3355,33 @@ function find_uhbt(u, BTC) result(uhbt) end function find_uhbt + +!> The function find_uhbt_int determines the time-integrated zonal transport for a given +!! time-integrated velocity. +function find_uhbt_int(u_int, BTC, dt_bc, Idt2) result(uhbt_int) + real, intent(in) :: u_int !< The local time-integrated zonal velocity [L ~> m] + 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, intent(in) :: dt_bc !< The baroclinic timestep used to set up BTC [T ~> s]. + real, intent(in) :: Idt2 !< The squared inverse of dt_bc [T-2 ~> s-2]. + + real :: uhbt_int !< The time integrated zonal barotropic transport [L2 H ~> m3] + + if (u_int == 0.0) then + uhbt_int = 0.0 + elseif (u_int < BTC%uBT_EE*dt_bc) then + uhbt_int = (u_int - BTC%uBT_EE*dt_bc) * BTC%FA_u_EE + BTC%uh_EE*dt_bc + elseif (u_int < 0.0) then + uhbt_int = u_int * (BTC%FA_u_E0 + BTC%uh_crvE*Idt2 * u_int**2) + elseif (u_int <= BTC%uBT_WW*dt_bc) then + uhbt_int = u_int * (BTC%FA_u_W0 + BTC%uh_crvW*Idt2 * u_int**2) + else ! (u_int > BTC%uBT_WW*dt_bc) + uhbt_int = (u_int - BTC%uBT_WW*dt_bc) * BTC%FA_u_WW + BTC%uh_WW*dt_bc + endif + +end function find_uhbt_int + !> The function find_duhbt_du determines the marginal zonal face area for a given velocity. function find_duhbt_du(u, BTC, US) result(duhbt_du) real, intent(in) :: u !< The local zonal velocity [L T-1 ~> m s-1] @@ -3370,6 +3523,31 @@ function find_vhbt(v, BTC) result(vhbt) end function find_vhbt +!> The function find_vhbt_int determines the time-integrated meridional transport for a given +!! time-integrated velocity. +function find_vhbt_int(v_int, BTC, dt_bc, Idt2) result(vhbt_int) + real, intent(in) :: v_int !< The local time-integrated meridional velocity [L ~> m] + 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, intent(in) :: dt_bc !< The baroclinic timestep used to set up BTC [T ~> s]. + real, intent(in) :: Idt2 !< The squared inverse of dt_bc [T-2 ~> s-2]. + real :: vhbt_int !< The time integrated meridional barotropic transport [L2 H ~> m3] + + if (v_int == 0.0) then + vhbt_int = 0.0 + elseif (v_int < BTC%vBT_NN*dt_bc) then + vhbt_int = (v_int - BTC%vBT_NN*dt_bc) * BTC%FA_v_NN + BTC%vh_NN*dt_bc + elseif (v_int < 0.0) then + vhbt_int = v_int * (BTC%FA_v_N0 + BTC%vh_crvN*Idt2 * v_int**2) + elseif (v_int <= BTC%vBT_SS*dt_bc) then + vhbt_int = v_int * (BTC%FA_v_S0 + BTC%vh_crvS*Idt2 * v_int**2) + else ! (v_int > BTC%vBT_SS*dt_bc) + vhbt_int = (v_int - BTC%vBT_SS*dt_bc) * BTC%FA_v_SS + BTC%vh_SS*dt_bc + endif + +end function find_vhbt_int + !> The function find_dvhbt_dv determines the marginal meridional face area for a given velocity. function find_dvhbt_dv(v, BTC, US) result(dvhbt_dv) real, intent(in) :: v !< The local meridional velocity [L T-1 ~> m s-1] @@ -4017,6 +4195,19 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, "Use the split time stepping if true.", default=.true.) if (.not.CS%split) return + call get_param(param_file, mdl, "USE_BT_CONT_TYPE", use_BT_cont_type, & + "If true, use a structure with elements that describe "//& + "effective face areas from the summed continuity solver "//& + "as a function the barotropic flow in coupling between "//& + "the barotropic and baroclinic flow. This is only used "//& + "if SPLIT is true.", default=.true.) + call get_param(param_file, mdl, "INTEGRAL_BT_CONTINUITY", CS%integral_bt_cont, & + "If true, use the time-integrated velocity over the barotropic steps "//& + "to determine the integrated transports used to update the continuity "//& + "equation. Otherwise the transports are the sum of the transports based on "//& + "a series of instantaneous velocities and the BT_CONT_TYPE for transports. "//& + "This is only valid if USE_BT_CONT_TYPE = True.", & + default=.false., do_not_log=.not.use_BT_cont_type) call get_param(param_file, mdl, "BOUND_BT_CORRECTION", CS%bound_BT_corr, & "If true, the corrective pseudo mass-fluxes into the "//& "barotropic solver are limited to values that require "//& @@ -4030,7 +4221,8 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, call get_param(param_file, mdl, "ADJUST_BT_CONT", CS%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.", default=.false.) + "transport about which the flow is being linearized.", & + default=.false., do_not_log=.not.use_BT_cont_type) call get_param(param_file, mdl, "GRADUAL_BT_ICS", CS%gradual_BT_ICs, & "If true, adjust the initial conditions for the "//& "barotropic solver to the values from the layered "//& @@ -4064,12 +4256,6 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, "The barotropic y-halo size that is actually used.", & layoutParam=.true.) - call get_param(param_file, mdl, "USE_BT_CONT_TYPE", use_BT_cont_type, & - "If true, use a structure with elements that describe "//& - "effective face areas from the summed continuity solver "//& - "as a function the barotropic flow in coupling between "//& - "the barotropic and baroclinic flow. This is only used "//& - "if SPLIT is true.", default=.true.) call get_param(param_file, mdl, "NONLINEAR_BT_CONTINUITY", CS%Nonlinear_continuity, & "If true, use nonlinear transports in the barotropic "//& "continuity equation. This does not apply if "//& From 6374aaf77a8edcae4e310c1c95bf21aa84a4ecd6 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 14 Jul 2020 12:32:28 -0400 Subject: [PATCH 67/91] +Add find_duhbt_dubt_int Added the new subroutines find_duhbt_dubt_int and find_dvhbt_dvbt_int, and use the time-integrated forms to set the inverse face area, the transport correction for consistency between the transport from the initial barotropic velocity and the summed layer transports, and the maximum corrective mass source when INTEGRAL_BT_CONT=True. Also only log BT_CONT_CORR_BOUNDS when BOUND_BT_CORR is set to true. By default, all answers are bitwise identical, but there are minor changes to the entries in the MOM_parameter_doc files. --- src/core/MOM_barotropic.F90 | 120 +++++++++++++++++++++++++++++------- 1 file changed, 99 insertions(+), 21 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 458599aed5..f136f3ef2c 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -650,6 +650,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, real :: H_eff_dx2 ! The effective total thickness divided by the grid spacing ! squared [H L-2 ~> m-1 or kg m-4]. real :: u_max_cor, v_max_cor ! The maximum corrective velocities [L T-1 ~> m s-1]. + real :: uint_cor, vint_cor ! The maximum time-integrated corrective velocities [L ~> m]. 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 [L T-2 ~> m s-2]. @@ -1080,22 +1081,31 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, vbt(i,J) = vbt(i,J) + CS%frhatv(i,J,k) * v_vh0(i,J,k) enddo ; enddo ; enddo endif - if (use_BT_cont) then - if (CS%adjust_BT_cont) then - ! Use the additional input transports to broaden the fits - ! over which the bt_cont_type applies. - - ! Fill in the halo data for ubt, vbt, uhbt, and vhbt. - if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre) - if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre) - call pass_vector(ubt, vbt, CS%BT_Domain, complete=.false., halo=1+ievf-ie) - call pass_vector(uhbt, vhbt, CS%BT_Domain, complete=.true., halo=1+ievf-ie) - if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre) - if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre) - - call adjust_local_BT_cont_types(ubt, uhbt, vbt, vhbt, BTCL_u, BTCL_v, & - G, US, MS, 1+ievf-ie) - endif + if ((use_BT_cont .or. integral_BT_cont) .and. CS%adjust_BT_cont) then + ! Use the additional input transports to broaden the fits + ! over which the bt_cont_type applies. + + ! Fill in the halo data for ubt, vbt, uhbt, and vhbt. + if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre) + if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre) + call pass_vector(ubt, vbt, CS%BT_Domain, complete=.false., halo=1+ievf-ie) + call pass_vector(uhbt, vhbt, CS%BT_Domain, complete=.true., halo=1+ievf-ie) + if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre) + if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre) + + call adjust_local_BT_cont_types(ubt, uhbt, vbt, vhbt, BTCL_u, BTCL_v, & + G, US, MS, 1+ievf-ie) + endif + if (integral_BT_cont) then + !$OMP parallel do default(shared) + do j=js,je ; do I=is-1,ie + uhbt0(I,j) = uhbt(I,j) - find_uhbt_int(dt*ubt(I,j), BTCL_u(I,j), dt, Idt2) * Idt + enddo ; enddo + !$OMP parallel do default(shared) + do J=js-1,je ; do i=is,ie + vhbt0(i,J) = vhbt(i,J) - find_vhbt_int(dt*vbt(i,J), BTCL_v(i,J), dt, Idt2) * Idt + enddo ; enddo + elseif (use_BT_cont) then !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie uhbt0(I,j) = uhbt(I,j) - find_uhbt(ubt(I,j), BTCL_u(I,j)) @@ -1177,6 +1187,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif if (Htot_avg*CS%dy_Cu(I,j) <= 0.0) then CS%IDatu(I,j) = 0.0 + elseif (integral_BT_cont) then + CS%IDatu(I,j) = CS%dy_Cu(I,j) / (max(find_duhbt_du_int(ubt(I,j)*dt, BTCL_u(I,j), US, dt, Idt2), & + CS%dy_Cu(I,j)*Htot_avg) ) elseif (use_BT_cont) then ! Reconsider the max and whether there should be some scaling. CS%IDatu(I,j) = CS%dy_Cu(I,j) / (max(find_duhbt_du(ubt(I,j), BTCL_u(I,j), US), & CS%dy_Cu(I,j)*Htot_avg) ) @@ -1200,6 +1213,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif if (Htot_avg*CS%dx_Cv(i,J) <= 0.0) then CS%IDatv(i,J) = 0.0 + elseif (integral_BT_cont) then + CS%IDatv(i,J) = CS%dx_Cv(i,J) / (max(find_dvhbt_dv_int(vbt(i,J)*dt, BTCL_v(i,J), US, dt, Idt2), & + CS%dx_Cv(i,J)*Htot_avg) ) elseif (use_BT_cont) then ! Reconsider the max and whether there should be some scaling. CS%IDatv(i,J) = CS%dx_Cv(i,J) / (max(find_dvhbt_dv(vbt(i,J), BTCL_v(i,J), US), & CS%dx_Cv(i,J)*Htot_avg) ) @@ -1363,7 +1379,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre) if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre) - !$OMP parallel default(shared) private(u_max_cor,v_max_cor,eta_cor_max,Htot) + !$OMP parallel default(shared) private(u_max_cor,uint_cor,v_max_cor,vint_cor,eta_cor_max,Htot) !$OMP do do j=js-1,je+1 ; do I=is-1,ie ; av_rem_u(I,j) = 0.0 ; enddo ; enddo !$OMP do @@ -1450,18 +1466,28 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! Set the mass source, after first initializing the halos to 0. !$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 + if (CS%bound_BT_corr) then ; if ((use_BT_Cont.or.integral_BT_cont) .and. CS%BT_cont_bounds) then do j=js,je ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then if (CS%eta_cor(i,j) > 0.0) then ! Limit the source (outward) correction to be a fraction the mass that ! can be transported out of the cell by velocities with a CFL number of CFL_cor. - u_max_cor = G%dxT(i,j) * (CS%maxCFL_BT_cont*Idt) - v_max_cor = G%dyT(i,j) * (CS%maxCFL_BT_cont*Idt) - eta_cor_max = dt * (CS%IareaT(i,j) * & + if (integral_BT_cont) then + uint_cor = G%dxT(i,j) * CS%maxCFL_BT_cont + vint_cor = G%dyT(i,j) * CS%maxCFL_BT_cont + eta_cor_max = (CS%IareaT(i,j) * & + (((find_uhbt_int(uint_cor, BTCL_u(I,j), dt, Idt2) + dt*uhbt0(I,j)) - & + (find_uhbt_int(-uint_cor, BTCL_u(I-1,j), dt, Idt2) + dt*uhbt0(I-1,j))) + & + ((find_vhbt_int(vint_cor, BTCL_v(i,J), dt, Idt2) + dt*vhbt0(i,J)) - & + (find_vhbt_int(-vint_cor, BTCL_v(i,J-1), dt, Idt2) + dt*vhbt0(i,J-1))) )) + else ! (use_BT_Cont) then + u_max_cor = G%dxT(i,j) * (CS%maxCFL_BT_cont*Idt) + v_max_cor = G%dyT(i,j) * (CS%maxCFL_BT_cont*Idt) + eta_cor_max = dt * (CS%IareaT(i,j) * & (((find_uhbt(u_max_cor, BTCL_u(I,j)) + uhbt0(I,j)) - & (find_uhbt(-u_max_cor, BTCL_u(I-1,j)) + uhbt0(I-1,j))) + & ((find_vhbt(v_max_cor, BTCL_v(i,J)) + vhbt0(i,J)) - & (find_vhbt(-v_max_cor, BTCL_v(i,J-1)) + vhbt0(i,J-1))) )) + endif CS%eta_cor(i,j) = min(CS%eta_cor(i,j), max(0.0, eta_cor_max)) else ! Limit the sink (inward) correction to the amount of mass that is already inside the cell. @@ -3406,6 +3432,32 @@ function find_duhbt_du(u, BTC, US) result(duhbt_du) end function find_duhbt_du +!> The function find_duhbt_du_int determines the marginal zonal face area for a given +!! time-integrated velocity. +function find_duhbt_du_int(u_int, BTC, US, dt_bc, Idt2) result(duhbt_du) + real, intent(in) :: u_int !< The local zonal time-integrated velocity [L ~> m] + 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. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(in) :: dt_bc !< The baroclinic timestep used to set up BTC [T ~> s]. + real, intent(in) :: Idt2 !< The squared inverse of dt_bc [T-2 ~> s-2]. + + real :: duhbt_du !< The zonal barotropic face area [L H ~> m2] + + if (u_int == 0.0) then + duhbt_du = 0.5*(BTC%FA_u_E0 + BTC%FA_u_W0) ! Note the potential discontinuity here. + elseif (u_int < BTC%uBT_EE*dt_bc) then + duhbt_du = BTC%FA_u_EE + elseif (u_int < 0.0) then + duhbt_du = (BTC%FA_u_E0 + 3.0*(BTC%uh_crvE*Idt2) * u_int**2) + elseif (u_int <= BTC%uBT_WW*dt_bc) then + duhbt_du = (BTC%FA_u_W0 + 3.0*(BTC%uh_crvW*Idt2) * u_int**2) + else ! (u_int > BTC%uBT_WW*dt_bc) + duhbt_du = BTC%FA_u_WW + endif + +end function find_duhbt_du_int !> This function inverts the transport function to determine the barotopic !! velocity that is consistent with a given transport. @@ -3571,6 +3623,32 @@ function find_dvhbt_dv(v, BTC, US) result(dvhbt_dv) end function find_dvhbt_dv +!> The function find_dvhbt_dv_int determines the marginal meridional face area for a given +!! time-integrated velocity. +function find_dvhbt_dv_int(v_int, BTC, US, dt_bc, Idt2) result(dvhbt_dv) + real, intent(in) :: v_int !< The local time-integrated meridional velocity [L ~> m] + 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. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(in) :: dt_bc !< The baroclinic timestep used to set up BTC [T ~> s]. + real, intent(in) :: Idt2 !< The squared inverse of dt_bc [T-2 ~> s-2]. + real :: dvhbt_dv !< The meridional barotropic face area [L H ~> m2] + + if (v_int == 0.0) then + dvhbt_dv = 0.5*(BTC%FA_v_N0 + BTC%FA_v_S0) ! Note the potential discontinuity here. + elseif (v_int < BTC%vBT_NN*dt_bc) then + dvhbt_dv = BTC%FA_v_NN + elseif (v_int < 0.0) then + dvhbt_dv = BTC%FA_v_N0 + 3.0*(BTC%vh_crvN*Idt2) * v_int**2 + elseif (v_int <= BTC%vBT_SS*dt_bc) then + dvhbt_dv = BTC%FA_v_S0 + 3.0*(BTC%vh_crvS*Idt2) * v_int**2 + else ! (v_int > BTC%vBT_SS*dt_bc) + dvhbt_dv = BTC%FA_v_SS + endif + +end function find_dvhbt_dv_int + !> This function inverts the transport function to determine the barotopic !! velocity that is consistent with a given transport. function vhbt_to_vbt(vhbt, BTC, US, guess) result(vbt) From 4743f8cec6fc0c73bf0745f7469965a26f11d201 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 14 Jul 2020 18:53:00 -0400 Subject: [PATCH 68/91] +Implemented integral_BT_cont options for OBCs Added code to implement new integral_BT_cont options within the barotropic open boundary condition code. A number of new arguments were added to apply_velocity_OBCS. In addition, the handling of updates to ubt_sum, uhbt_sum and ubt_wtd with open boundary conditions were simplified. There are minor answer changes if INTEGRAL_BT_CONTINUITY=True, but all answers in the existing MOM6-examples tess cases are bitwise identical. --- src/core/MOM_barotropic.F90 | 98 +++++++++++++++++++++++-------------- 1 file changed, 60 insertions(+), 38 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index f136f3ef2c..f5e3fad882 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -635,8 +635,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! velocity point [H ~> m or kg m-2] logical :: do_hifreq_output ! If true, output occurs every barotropic step. logical :: use_BT_cont, do_ave, find_etaav, find_PF, find_Cor - logical :: integral_BT_cont ! If true, update the continuity directly from the initial - ! condition using the time-integrated barotropic velocity. + logical :: integral_BT_cont ! If true, update the barotropic continuity equation directly + ! from the initial condition using the time-integrated barotropic velocity. logical :: ice_is_rigid, nonblock_setup, interp_eta_PF logical :: project_velocity, add_uh0 @@ -2185,46 +2185,31 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, !GOMP end parallel if (apply_OBCs) then - if (CS%BT_OBC%apply_u_OBCs) then ! copy back the value for u-points on the boundary. - !GOMP parallel do default(shared) - do j=js,je ; do I=is-1,ie - if (OBC%segnum_u(I,j) /= OBC_NONE) then - ubt_sum(I,j) = ubt_sum_prev(I,j) ; uhbt_sum(I,j) = uhbt_sum_prev(I,j) - ubt_wtd(I,j) = ubt_wtd_prev(I,j) - endif - enddo ; enddo - endif - - if (CS%BT_OBC%apply_v_OBCs) then ! copy back the value for v-points on the boundary. - !GOMP parallel do default(shared) - do J=js-1,je ; do I=is,ie - if (OBC%segnum_v(i,J) /= OBC_NONE) then - vbt_sum(i,J) = vbt_sum_prev(i,J) ; vhbt_sum(i,J) = vhbt_sum_prev(i,J) - vbt_wtd(i,J) = vbt_wtd_prev(i,J) - endif - enddo ; enddo - endif call apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, & ubt_trans, vbt_trans, eta, ubt_old, vbt_old, CS%BT_OBC, & - G, MS, US, iev-ie, dtbt, bebt, use_BT_cont, Datu, Datv, BTCL_u, BTCL_v, & - uhbt0, vhbt0) + G, MS, US, iev-ie, dtbt, bebt, use_BT_cont, integral_BT_cont, & + n*dtbt, dt, Datu, Datv, BTCL_u, BTCL_v, uhbt0, vhbt0, & + ubt_int_prev, vbt_int_prev, uhbt_int_prev, vhbt_int_prev) + if (CS%BT_OBC%apply_u_OBCs) then ; do j=js,je ; do I=is-1,ie if (OBC%segnum_u(I,j) /= OBC_NONE) then - ubt_sum(I,j) = ubt_sum(I,j) + wt_trans(n) * ubt_trans(I,j) + ! Update the summed and integrated quantities from the saved previous values. + ubt_sum(I,j) = ubt_sum_prev(I,j) + wt_trans(n) * ubt_trans(I,j) ubt_int(I,j) = ubt_int_prev(I,j) + dtbt * ubt_trans(I,j) - uhbt_sum(I,j) = uhbt_sum(I,j) + wt_trans(n) * uhbt(I,j) + uhbt_sum(I,j) = uhbt_sum_prev(I,j) + wt_trans(n) * uhbt(I,j) uhbt_int(I,j) = uhbt_int_prev(I,j) + dtbt * uhbt(I,j) - ubt_wtd(I,j) = ubt_wtd(I,j) + wt_vel(n) * ubt(I,j) + ubt_wtd(I,j) = ubt_wtd_prev(I,j) + wt_vel(n) * ubt(I,j) endif enddo ; enddo ; endif if (CS%BT_OBC%apply_v_OBCs) then ; do J=js-1,je ; do i=is,ie if (OBC%segnum_v(i,J) /= OBC_NONE) then - vbt_sum(i,J) = vbt_sum(i,J) + wt_trans(n) * vbt_trans(i,J) + ! Update the summed and integrated quantities from the saved previous values. + vbt_sum(i,J) = vbt_sum_prev(i,J) + wt_trans(n) * vbt_trans(i,J) vbt_int(i,J) = vbt_int_prev(i,J) + dtbt * vbt_trans(i,J) - vhbt_sum(i,J) = vhbt_sum(i,J) + wt_trans(n) * vhbt(i,J) + vhbt_sum(i,J) = vhbt_sum_prev(i,J) + wt_trans(n) * vhbt(i,J) vhbt_int(i,J) = vhbt_int_prev(i,J) + dtbt * vhbt(i,J) - vbt_wtd(i,J) = vbt_wtd(i,J) + wt_vel(n) * vbt(i,J) + vbt_wtd(i,J) = vbt_wtd_prev(i,J) + wt_vel(n) * vbt(i,J) endif enddo ; enddo ; endif endif @@ -2706,8 +2691,9 @@ end subroutine set_dtbt !! velocities and mass transports, as developed by Mehmet Ilicak. subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, & eta, ubt_old, vbt_old, BT_OBC, & - G, MS, US, halo, dtbt, bebt, use_BT_cont, Datu, Datv, & - BTCL_u, BTCL_v, uhbt0, vhbt0) + G, MS, US, halo, dtbt, bebt, use_BT_cont, integral_BT_cont, & + dt_elapsed, dt_baroclinic, Datu, Datv, BTCL_u, BTCL_v, & + uhbt0, vhbt0, ubt_int, vbt_int, uhbt_int_prev, vhbt_int_prev) type(ocean_OBC_type), pointer :: OBC !< An associated pointer to an OBC type. 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 @@ -2739,6 +2725,13 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, !! in determining the transport. logical, intent(in) :: use_BT_cont !< If true, use the BT_cont_types to calculate !! transports. + logical, intent(in) :: integral_BT_cont ! If true, update the barotropic continuity + !! equation directly from the initial condition + !! using the time-integrated barotropic velocity. + real, intent(in) :: dt_elapsed !< The amount of time in the barotropic stepping + !! that will have elapsed [T ~> s]. + real, intent(in) :: dt_baroclinic !< The baroclinic timestep for this cycle of + !! updates to the barotropic solver [T ~> s] real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: Datu !< A fixed estimate of the face areas at u points !! [H L ~> m2 or kg m-1]. real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: Datv !< A fixed estimate of the face areas at v points @@ -2757,6 +2750,14 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, !! the barotropic functions agree with the sum !! of the layer transports !! [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: ubt_int !< The time-integrated zonal barotropic + !! velocity [L T-1 ~> m s-1]. + real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: uhbt_int_prev !< The time-integrated zonal barotropic + !! transport [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vbt_int !< The time-integrated meridional barotropic + !! velocity [L T-1 ~> m s-1]. + real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vhbt_int_prev !< The time-integrated meridional barotropic + !! transport [H L2 T-1 ~> m3 s-1 or kg s-1]. ! Local variables real :: vel_prev ! The previous velocity [L T-1 ~> m s-1]. @@ -2767,14 +2768,23 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, real :: cfl ! The CFL number at the point in question [nondim] real :: u_inlet ! The zonal inflow velocity [L T-1 ~> m s-1] real :: v_inlet ! The meridional inflow velocity [L T-1 ~> m s-1] - real :: h_in + real :: uhbt_int_new ! The updated time-integrated zonal transport [H L2 ~> m3] + real :: vhbt_int_new ! The updated time-integrated meridional transport [H L2 ~> m3] + real :: h_in ! The inflow thickess [H ~> m or kg m-2]. real :: cff, Cx, Cy, tau real :: dhdt, dhdx, dhdy + real :: Idt2 ! The inverse square of the baroclinic time interval [T-2 ~> s-2]. + real :: Idtbt ! The inverse of the barotropic time step [T-1 ~> s-1] integer :: i, j, is, ie, js, je real, dimension(SZIB_(G),SZJB_(G)) :: grad real, parameter :: eps = 1.0e-20 is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo + if (.not.(BT_OBC%apply_u_OBCs .or. BT_OBC%apply_v_OBCs)) return + + Idtbt = 1.0 / dtbt + Idt2 = (1.0 / dt_baroclinic)**2 + if (BT_OBC%apply_u_OBCs) then do j=js,je ; do I=is-1,ie ; if (OBC%segnum_u(I,j) /= OBC_NONE) then if (OBC%segment(OBC%segnum_u(I,j))%specified) then @@ -2814,7 +2824,12 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, endif if (.not. OBC%segment(OBC%segnum_u(I,j))%specified) then - if (use_BT_cont) then + !Need: ubt_int, uhbt_int_prev, dt, Idt2, n, Idtbt. + if (integral_BT_cont) then + uhbt_int_new = find_uhbt_int(ubt_int(I,j) + dtbt*vel_trans, BTCL_u(I,j), dt_baroclinic, Idt2) + & + dt_elapsed*uhbt0(I,j) + uhbt(I,j) = (uhbt_int_new - uhbt_int_prev(I,j)) * Idtbt + elseif (use_BT_cont) then uhbt(I,j) = find_uhbt(vel_trans, BTCL_u(I,j)) + uhbt0(I,j) else uhbt(I,j) = Datu(I,j)*vel_trans + uhbt0(I,j) @@ -2866,10 +2881,15 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, endif if (.not. OBC%segment(OBC%segnum_v(i,J))%specified) then - if (use_BT_cont) then - vhbt(i,J) = find_vhbt(vel_trans, BTCL_v(i,J)) + vhbt0(i,J) + !Need: vbt_int, vhbt_int_prev. + if (integral_BT_cont) then + vhbt_int_new = find_vhbt_int(vbt_int(i,J) + dtbt*vel_trans, BTCL_v(i,J), dt_baroclinic, Idt2) + & + dt_elapsed*vhbt0(i,J) + vhbt(i,J) = (vhbt_int_new - vhbt_int_prev(i,J)) * Idtbt + elseif (use_BT_cont) then + vhbt(i,J) = find_vhbt(vel_trans, BTCL_v(i,J)) + vhbt0(i,J) else - vhbt(i,J) = vel_trans*Datv(i,J) + vhbt0(i,J) + vhbt(i,J) = vel_trans*Datv(i,J) + vhbt0(i,J) endif endif @@ -3873,8 +3893,10 @@ subroutine set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, BT_Domain end subroutine set_local_BT_cont_types -!> Adjust_local_BT_cont_types sets up reordered versions of the BT_cont type -!! in the local_BT_cont types, which have wide halos properly filled in. +!> Adjust_local_BT_cont_types expands the range of velocities with a cubic curve +!! translating velocities into transports to match the inital values of velocities and +!! summed transports when the velocities are larger than the first guesses of the cubic +!! transition velocities used to set up the local_BT_cont types. subroutine adjust_local_BT_cont_types(ubt, uhbt, vbt, vhbt, BTCL_u, BTCL_v, & G, US, MS, halo) type(memory_size_type), intent(in) :: MS !< A type that describes the memory sizes of the argument arrays. From 2a73d7dafe251e65e5a33b5533697b4342d94b52 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Tue, 14 Jul 2020 15:26:10 -0800 Subject: [PATCH 69/91] +Adding a halo update for tracer reservoirs. --- src/core/MOM_open_boundary.F90 | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index c0e64db491..31f037c66e 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -1590,7 +1590,7 @@ subroutine open_boundary_init(G, GV, US, param_file, OBC, restart_CSp) ! Local variables real :: vel2_rescale ! A rescaling factor for squared velocities from the representation in ! a restart file to the internal representation in this run. - integer :: i, j, k, isd, ied, jsd, jed, nz + integer :: i, j, k, isd, ied, jsd, jed, nz, m integer :: IsdB, IedB, JsdB, JedB 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 @@ -1603,6 +1603,11 @@ subroutine open_boundary_init(G, GV, US, param_file, OBC, restart_CSp) if (OBC%oblique_BCs_exist_globally) call pass_vector(OBC%rx_oblique, OBC%ry_oblique, G%Domain, & To_All+Scalar_Pair) if (associated(OBC%cff_normal)) call pass_var(OBC%cff_normal, G%Domain, position=CORNER) + if (associated(OBC%tres_x) .or. associated(OBC%tres_y)) then + do m=1,OBC%ntr + call pass_vector(OBC%tres_x(:,:,:,m), OBC%tres_y(:,:,:,m), G%Domain, To_All+Scalar_Pair) + enddo + endif ! The rx_normal and ry_normal arrays used with radiation OBCs are currently in units of grid ! points per timestep, but if this were to be corrected to [L T-1 ~> m s-1] or [T-1 ~> s-1] to @@ -4711,7 +4716,8 @@ subroutine open_boundary_register_restarts(HI, GV, OBC, Reg, param_file, restart endif ! Still painfully inefficient, now in four dimensions. - if (any(OBC%tracer_x_reservoirs_used)) then + ! Allocating both for now so that the pass_vector works. + if (any(OBC%tracer_x_reservoirs_used) .or. any(OBC%tracer_y_reservoirs_used)) then allocate(OBC%tres_x(HI%isdB:HI%iedB,HI%jsd:HI%jed,GV%ke,OBC%ntr)) OBC%tres_x(:,:,:,:) = 0.0 do m=1,OBC%ntr @@ -4727,8 +4733,8 @@ subroutine open_boundary_register_restarts(HI, GV, OBC, Reg, param_file, restart endif endif enddo - endif - if (any(OBC%tracer_y_reservoirs_used)) then +! endif +! if (any(OBC%tracer_y_reservoirs_used)) then allocate(OBC%tres_y(HI%isd:HI%ied,HI%jsdB:HI%jedB,GV%ke,OBC%ntr)) OBC%tres_y(:,:,:,:) = 0.0 do m=1,OBC%ntr From 37a7ee0da1bd0860debe98b4a7110958dc7f4b88 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 16 Jul 2020 12:57:24 -0400 Subject: [PATCH 70/91] +Reuse find_uhbt with INTEGRAL_BT_CONT Revised the dimensions of the entries in the local_BT_Cont types when INTEGRAL_BT_CONT=True for efficiency and to enable find_uhbt and other routines to be used regardless of the value of INTEGRAL_BT_CONT. Some arguments that are no longer needed have been removed from some subroutines. All answers are bitwise identical in the MOM6-examples test suite, but changes to the order of arithmetic leads to changes from the previous version when INTEGRAL_BT_CONT=True, and the rescaling is controlled via new optional arguments to internal routines. --- src/core/MOM_barotropic.F90 | 452 ++++++++++++++++-------------------- 1 file changed, 196 insertions(+), 256 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index f5e3fad882..9e62e84f3b 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -327,14 +327,20 @@ module MOM_barotropic !! drawing from nearby to the west [H L ~> 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 L ~> m2 or kg m-1]. - real :: uBT_WW !< uBT_WW is the barotropic velocity [L T-1 ~> m s-1], beyond which the marginal + real :: uBT_WW !< uBT_WW is the barotropic velocity [L T-1 ~> m s-1], or with INTEGRAL_BT_CONTINUITY + !! the time-integrated barotropic velocity [L ~> m], 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 [L T-1 ~> m s-1], beyond which the marginal + real :: uBT_EE !< uBT_EE is a barotropic velocity [L T-1 ~> m s-1], or with INTEGRAL_BT_CONTINUITY + !! the time-integrated barotropic velocity [L ~> m], 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 T2 L-1 ~> s2 or kg s2 m-3]. - real :: uh_crvE !< The curvature of face area with velocity for flow from the east [H T2 L-1 ~> s2 or kg s2 m-3]. - real :: uh_WW !< The zonal transport when ubt=ubt_WW [H L2 T-1 ~> m3 s-1 or kg s-1]. - real :: uh_EE !< The zonal transport when ubt=ubt_EE [H L2 T-1 ~> m3 s-1 or kg s-1]. + real :: uh_crvW !< The curvature of face area with velocity for flow from the west [H T2 L-1 ~> s2 or kg s2 m-3] + !! or [H L-1 ~> 1 or kg m-3] with INTEGRAL_BT_CONTINUITY. + real :: uh_crvE !< The curvature of face area with velocity for flow from the east [H T2 L-1 ~> s2 or kg s2 m-3] + !! or [H L-1 ~> 1 or kg m-3] with INTEGRAL_BT_CONTINUITY. + real :: uh_WW !< The zonal transport when ubt=ubt_WW [H L2 T-1 ~> m3 s-1 or kg s-1], or the equivalent + !! time-integrated transport with INTEGRAL_BT_CONTINUITY [H L2 ~> m3 or kg]. + real :: uh_EE !< The zonal transport when ubt=ubt_EE [H L2 T-1 ~> m3 s-1 or kg s-1], or the equivalent + !! time-integrated transport with INTEGRAL_BT_CONTINUITY [H L2 ~> m3 or kg]. end type local_BT_cont_u_type !> A desciption of the functional dependence of transport at a v-point @@ -347,14 +353,20 @@ module MOM_barotropic !! drawing from nearby to the south [H L ~> 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 L ~> m2 or kg m-1]. - real :: vBT_SS !< vBT_SS is the barotropic velocity [L T-1 ~> m s-1], beyond which the marginal + real :: vBT_SS !< vBT_SS is the barotropic velocity [L T-1 ~> m s-1], or with INTEGRAL_BT_CONTINUITY + !! the time-integrated barotropic velocity [L ~> m], 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 [L T-1 ~> m s-1], beyond which the marginal + real :: vBT_NN !< vBT_NN is the barotropic velocity [L T-1 ~> m s-1], or with INTEGRAL_BT_CONTINUITY + !! the time-integrated barotropic velocity [L ~> m], 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 T2 L-1 ~> s2 or kg s2 m-3]. - real :: vh_crvN !< The curvature of face area with velocity for flow from the north [H T2 L-1 ~> s2 or kg s2 m-3]. - real :: vh_SS !< The meridional transport when vbt=vbt_SS [H L2 T-1 ~> m3 s-1 or kg s-1]. - real :: vh_NN !< The meridional transport when vbt=vbt_NN [H L2 T-1 ~> m3 s-1 or kg s-1]. + real :: vh_crvS !< The curvature of face area with velocity for flow from the south [H T2 L-1 ~> s2 or kg s2 m-3] + !! or [H L-1 ~> 1 or kg m-3] with INTEGRAL_BT_CONTINUITY. + real :: vh_crvN !< The curvature of face area with velocity for flow from the north [H T2 L-1 ~> s2 or kg s2 m-3] + !! or [H L-1 ~> 1 or kg m-3] with INTEGRAL_BT_CONTINUITY. + real :: vh_SS !< The meridional transport when vbt=vbt_SS [H L2 T-1 ~> m3 s-1 or kg s-1], or the equivalent + !! time-integrated transport with INTEGRAL_BT_CONTINUITY [H L2 ~> m3 or kg]. + real :: vh_NN !< The meridional transport when vbt=vbt_NN [H L2 T-1 ~> m3 s-1 or kg s-1], or the equivalent + !! time-integrated transport with INTEGRAL_BT_CONTINUITY [H L2 ~> m3 or kg]. end type local_BT_cont_v_type !> A container for passing around active tracer point memory limits @@ -656,7 +668,6 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, real :: accel_underflow ! An acceleration that is so small it should be zeroed out [L T-2 ~> m s-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 :: Idt2 ! The inverse square of the time interval of this call [T-2 ~> s-2]. real :: Idtbt ! The inverse of the barotropic time step [T-1 ~> s-1] real, allocatable, dimension(:) :: wt_vel, wt_eta, wt_accel, wt_trans, wt_accel2 @@ -688,14 +699,12 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, h_neglect = GV%H_subroundoff Idt = 1.0 / dt - Idt2 = Idt**2 accel_underflow = CS%vel_underflow * Idt use_BT_cont = .false. if (present(BT_cont)) use_BT_cont = (associated(BT_cont)) integral_BT_cont = use_BT_cont .and. CS%integral_BT_cont - interp_eta_PF = .false. if (present(eta_PF_start)) interp_eta_PF = (associated(eta_PF_start)) @@ -826,8 +835,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, call create_group_pass(CS%pass_eta_ubt, ubt, vbt, CS%BT_Domain) if (integral_BT_cont) then call create_group_pass(CS%pass_eta_ubt, ubt_int, vbt_int, CS%BT_Domain) - ! This might only be needed with OBCs. - call create_group_pass(CS%pass_eta_ubt, uhbt_int, vhbt_int, CS%BT_Domain) + ! This is only needed with integral_BT_cont, OBCs and multiple barotropic steps between halo updates. + if (apply_OBC_open) & + call create_group_pass(CS%pass_eta_ubt, uhbt_int, vhbt_int, CS%BT_Domain) endif call create_group_pass(CS%pass_ubt_Cor, ubt_Cor, vbt_Cor, G%Domain) @@ -1035,7 +1045,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! Calculate the open areas at the velocity points. ! The halo updates are needed before Datu is first used, either in set_up_BT_OBC or ubt_Cor. - if (use_BT_cont) then + if (integral_BT_cont) then + call set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, CS%BT_Domain, 1+ievf-ie, dt_baroclinic=dt) + elseif (use_BT_cont) then call set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, CS%BT_Domain, 1+ievf-ie) else if (CS%Nonlinear_continuity) then @@ -1048,7 +1060,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! Set up fields related to the open boundary conditions. if (apply_OBCs) then call set_up_BT_OBC(OBC, eta, CS%BT_OBC, CS%BT_Domain, G, GV, US, MS, ievf-ie, use_BT_cont, & - Datu, Datv, BTCL_u, BTCL_v) + integral_BT_cont, dt, Datu, Datv, BTCL_u, BTCL_v) endif ! Determine the difference between the sum of the layer fluxes and the @@ -1093,17 +1105,22 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre) if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre) - call adjust_local_BT_cont_types(ubt, uhbt, vbt, vhbt, BTCL_u, BTCL_v, & - G, US, MS, 1+ievf-ie) + if (integral_BT_cont) then + call adjust_local_BT_cont_types(ubt, uhbt, vbt, vhbt, BTCL_u, BTCL_v, & + G, US, MS, halo=1+ievf-ie, dt_baroclinic=dt) + else + call adjust_local_BT_cont_types(ubt, uhbt, vbt, vhbt, BTCL_u, BTCL_v, & + G, US, MS, halo=1+ievf-ie) + endif endif if (integral_BT_cont) then !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie - uhbt0(I,j) = uhbt(I,j) - find_uhbt_int(dt*ubt(I,j), BTCL_u(I,j), dt, Idt2) * Idt + uhbt0(I,j) = uhbt(I,j) - find_uhbt(dt*ubt(I,j), BTCL_u(I,j)) * Idt enddo ; enddo !$OMP parallel do default(shared) do J=js-1,je ; do i=is,ie - vhbt0(i,J) = vhbt(i,J) - find_vhbt_int(dt*vbt(i,J), BTCL_v(i,J), dt, Idt2) * Idt + vhbt0(i,J) = vhbt(i,J) - find_vhbt(dt*vbt(i,J), BTCL_v(i,J)) * Idt enddo ; enddo elseif (use_BT_cont) then !$OMP parallel do default(shared) @@ -1188,10 +1205,10 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (Htot_avg*CS%dy_Cu(I,j) <= 0.0) then CS%IDatu(I,j) = 0.0 elseif (integral_BT_cont) then - CS%IDatu(I,j) = CS%dy_Cu(I,j) / (max(find_duhbt_du_int(ubt(I,j)*dt, BTCL_u(I,j), US, dt, Idt2), & + CS%IDatu(I,j) = CS%dy_Cu(I,j) / (max(find_duhbt_du(ubt(I,j)*dt, BTCL_u(I,j)), & CS%dy_Cu(I,j)*Htot_avg) ) elseif (use_BT_cont) then ! Reconsider the max and whether there should be some scaling. - CS%IDatu(I,j) = CS%dy_Cu(I,j) / (max(find_duhbt_du(ubt(I,j), BTCL_u(I,j), US), & + CS%IDatu(I,j) = CS%dy_Cu(I,j) / (max(find_duhbt_du(ubt(I,j), BTCL_u(I,j)), & CS%dy_Cu(I,j)*Htot_avg) ) else CS%IDatu(I,j) = 1.0 / Htot_avg @@ -1214,10 +1231,10 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (Htot_avg*CS%dx_Cv(i,J) <= 0.0) then CS%IDatv(i,J) = 0.0 elseif (integral_BT_cont) then - CS%IDatv(i,J) = CS%dx_Cv(i,J) / (max(find_dvhbt_dv_int(vbt(i,J)*dt, BTCL_v(i,J), US, dt, Idt2), & + CS%IDatv(i,J) = CS%dx_Cv(i,J) / (max(find_dvhbt_dv(vbt(i,J)*dt, BTCL_v(i,J)), & CS%dx_Cv(i,J)*Htot_avg) ) elseif (use_BT_cont) then ! Reconsider the max and whether there should be some scaling. - CS%IDatv(i,J) = CS%dx_Cv(i,J) / (max(find_dvhbt_dv(vbt(i,J), BTCL_v(i,J), US), & + CS%IDatv(i,J) = CS%dx_Cv(i,J) / (max(find_dvhbt_dv(vbt(i,J), BTCL_v(i,J)), & CS%dx_Cv(i,J)*Htot_avg) ) else CS%IDatv(i,J) = 1.0 / Htot_avg @@ -1475,10 +1492,10 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, uint_cor = G%dxT(i,j) * CS%maxCFL_BT_cont vint_cor = G%dyT(i,j) * CS%maxCFL_BT_cont eta_cor_max = (CS%IareaT(i,j) * & - (((find_uhbt_int(uint_cor, BTCL_u(I,j), dt, Idt2) + dt*uhbt0(I,j)) - & - (find_uhbt_int(-uint_cor, BTCL_u(I-1,j), dt, Idt2) + dt*uhbt0(I-1,j))) + & - ((find_vhbt_int(vint_cor, BTCL_v(i,J), dt, Idt2) + dt*vhbt0(i,J)) - & - (find_vhbt_int(-vint_cor, BTCL_v(i,J-1), dt, Idt2) + dt*vhbt0(i,J-1))) )) + (((find_uhbt(uint_cor, BTCL_u(I,j)) + dt*uhbt0(I,j)) - & + (find_uhbt(-uint_cor, BTCL_u(I-1,j)) + dt*uhbt0(I-1,j))) + & + ((find_vhbt(vint_cor, BTCL_v(i,J)) + dt*vhbt0(i,J)) - & + (find_vhbt(-vint_cor, BTCL_v(i,J-1)) + dt*vhbt0(i,J-1))) )) else ! (use_BT_Cont) then u_max_cor = G%dxT(i,j) * (CS%maxCFL_BT_cont*Idt) v_max_cor = G%dyT(i,j) * (CS%maxCFL_BT_cont*Idt) @@ -1744,13 +1761,11 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (integral_BT_cont) then !GOMP do do j=jsv-1,jev+1 ; do I=isv-2,iev+1 - uhbt_int(I,j) = find_uhbt_int(ubt_int(I,j) + dtbt*ubt(I,j), BTCL_u(I,j), dt, Idt2) + & - n*dtbt*uhbt0(I,j) + uhbt_int(I,j) = find_uhbt(ubt_int(I,j) + dtbt*ubt(I,j), BTCL_u(I,j)) + n*dtbt*uhbt0(I,j) enddo ; enddo !GOMP do do J=jsv-2,jev+1 ; do i=isv-1,iev+1 - vhbt_int(i,J) = find_vhbt_int(vbt_int(i,J) + dtbt*vbt(i,J), BTCL_v(i,J), dt, Idt2) + & - n*dtbt*vhbt0(i,J) + vhbt_int(i,J) = find_vhbt(vbt_int(i,J) + dtbt*vbt(i,J), BTCL_v(i,J)) + n*dtbt*vhbt0(i,J) enddo ; enddo !GOMP do do j=jsv-1,jev+1 ; do i=isv-1,iev+1 @@ -1832,7 +1847,6 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, do j=jsv-joff,jev+joff ; do I=isv-1,iev ubt_prev(I,j) = ubt(I,j) ; uhbt_prev(I,j) = uhbt(I,j) ubt_sum_prev(I,j) = ubt_sum(I,j) ; uhbt_sum_prev(I,j) = uhbt_sum(I,j) ; ubt_wtd_prev(I,j) = ubt_wtd(I,j) - !Avoid this? ubt_int_prev(I,j) = ubt_int(I,j) ; uhbt_int_prev(I,j) = uhbt_int(I,j) enddo ; enddo endif @@ -1841,7 +1855,6 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, do J=jsv-1,jev ; do i=isv-ioff,iev+ioff vbt_prev(i,J) = vbt(i,J) ; vhbt_prev(i,J) = vhbt(i,J) vbt_sum_prev(i,J) = vbt_sum(i,J) ; vhbt_sum_prev(i,J) = vhbt_sum(i,J) ; vbt_wtd_prev(i,J) = vbt_wtd(i,J) - !Avoid this? vbt_int_prev(i,J) = vbt_int(i,J) ; vhbt_int_prev(i,J) = vhbt_int(i,J) enddo ; enddo endif endif @@ -1889,9 +1902,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, !GOMP do do J=jsv-1,jev ; do i=isv-1,iev+1 vbt_int(i,J) = vbt_int(i,J) + dtbt * vbt_trans(i,J) - vhbt_int(i,J) = find_vhbt_int(vbt_int(i,J), BTCL_v(i,J), dt, Idt2) + & - n*dtbt*vhbt0(i,J) - ! I do not know whether this is accurate enough. + vhbt_int(i,J) = find_vhbt(vbt_int(i,J), BTCL_v(i,J)) + n*dtbt*vhbt0(i,J) + ! Estimate the mass flux within a single timestep to take the filtered average. vhbt(i,J) = (vhbt_int(i,J) - vhbt_int_prev(i,J)) * Idtbt enddo ; enddo elseif (use_BT_cont) then @@ -1955,9 +1967,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, !GOMP do do j=jsv,jev ; do I=isv-1,iev ubt_int(I,j) = ubt_int(I,j) + dtbt * ubt_trans(I,j) - uhbt_int(I,j) = find_uhbt_int(ubt_int(I,j), BTCL_u(I,j), dt, Idt2) + & - n*dtbt*uhbt0(I,j) - ! I do not know whether this is accurate enough. + uhbt_int(I,j) = find_uhbt(ubt_int(I,j), BTCL_u(I,j)) + n*dtbt*uhbt0(I,j) + ! Estimate the mass flux within a single timestep to take the filtered average. uhbt(I,j) = (uhbt_int(I,j) - uhbt_int_prev(I,j)) * Idtbt enddo ; enddo elseif (use_BT_cont) then @@ -2023,9 +2034,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, !GOMP do do j=jsv-1,jev+1 ; do I=isv-1,iev ubt_int(I,j) = ubt_int(I,j) + dtbt * ubt_trans(I,j) - uhbt_int(I,j) = find_uhbt_int(ubt_int(I,j), BTCL_u(I,j), dt, Idt2) + & - n*dtbt*uhbt0(I,j) - ! I do not know whether this is accurate enough. + uhbt_int(I,j) = find_uhbt(ubt_int(I,j), BTCL_u(I,j)) + n*dtbt*uhbt0(I,j) + ! Estimate the mass flux within a single timestep to take the filtered average. uhbt(I,j) = (uhbt_int(I,j) - uhbt_int_prev(I,j)) * Idtbt enddo ; enddo elseif (use_BT_cont) then @@ -2100,9 +2110,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, !GOMP do do J=jsv-1,jev ; do i=isv,iev vbt_int(i,J) = vbt_int(i,J) + dtbt * vbt_trans(i,J) - vhbt_int(i,J) = find_vhbt_int(vbt_int(i,J), BTCL_v(i,J), dt, Idt2) + & - n*dtbt*vhbt0(i,J) - ! I do not know whether this is accurate enough. + vhbt_int(i,J) = find_vhbt(vbt_int(i,J), BTCL_v(i,J)) + n*dtbt*vhbt0(i,J) + ! Estimate the mass flux within a single timestep to take the filtered average. vhbt(i,J) = (vhbt_int(i,J) - vhbt_int_prev(i,J)) * Idtbt enddo ; enddo elseif (use_BT_cont) then @@ -2171,14 +2180,12 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, !GOMP do do j=js,je ; do I=is-1,ie ubt_sum(I,j) = ubt_sum(I,j) + wt_trans(n) * ubt_trans(I,j) - !This already happened: ubt_int(I,j) = ubt_int(I,j) + dtbt * ubt_trans(I,j) uhbt_sum(I,j) = uhbt_sum(I,j) + wt_trans(n) * uhbt(I,j) ubt_wtd(I,j) = ubt_wtd(I,j) + wt_vel(n) * ubt(I,j) enddo ; enddo !GOMP do do J=js-1,je ; do i=is,ie vbt_sum(i,J) = vbt_sum(i,J) + wt_trans(n) * vbt_trans(i,J) - !This already happened: vbt_int(i,J) = vbt_int(i,J) + dtbt * vbt_trans(i,J) vhbt_sum(i,J) = vhbt_sum(i,J) + wt_trans(n) * vhbt(i,J) vbt_wtd(i,J) = vbt_wtd(i,J) + wt_vel(n) * vbt(i,J) enddo ; enddo @@ -2187,10 +2194,10 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (apply_OBCs) then call apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, & - ubt_trans, vbt_trans, eta, ubt_old, vbt_old, CS%BT_OBC, & - G, MS, US, iev-ie, dtbt, bebt, use_BT_cont, integral_BT_cont, & - n*dtbt, dt, Datu, Datv, BTCL_u, BTCL_v, uhbt0, vhbt0, & - ubt_int_prev, vbt_int_prev, uhbt_int_prev, vhbt_int_prev) + ubt_trans, vbt_trans, eta, ubt_old, vbt_old, CS%BT_OBC, & + G, MS, US, iev-ie, dtbt, bebt, use_BT_cont, integral_BT_cont, & + n*dtbt, Datu, Datv, BTCL_u, BTCL_v, uhbt0, vhbt0, & + ubt_int_prev, vbt_int_prev, uhbt_int_prev, vhbt_int_prev) if (CS%BT_OBC%apply_u_OBCs) then ; do j=js,je ; do I=is-1,ie if (OBC%segnum_u(I,j) /= OBC_NONE) then @@ -2689,11 +2696,10 @@ end subroutine set_dtbt !> The following 4 subroutines apply the open boundary conditions. !! This subroutine applies the open boundary conditions on barotropic !! velocities and mass transports, as developed by Mehmet Ilicak. -subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, & - eta, ubt_old, vbt_old, BT_OBC, & - G, MS, US, halo, dtbt, bebt, use_BT_cont, integral_BT_cont, & - dt_elapsed, dt_baroclinic, Datu, Datv, BTCL_u, BTCL_v, & - uhbt0, vhbt0, ubt_int, vbt_int, uhbt_int_prev, vhbt_int_prev) +subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, eta, & + ubt_old, vbt_old, BT_OBC, G, MS, US, halo, dtbt, bebt, & + use_BT_cont, integral_BT_cont, dt_elapsed, Datu, Datv, & + BTCL_u, BTCL_v, uhbt0, vhbt0, ubt_int, vbt_int, uhbt_int, vhbt_int) type(ocean_OBC_type), pointer :: OBC !< An associated pointer to an OBC type. 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 @@ -2730,8 +2736,6 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, !! using the time-integrated barotropic velocity. real, intent(in) :: dt_elapsed !< The amount of time in the barotropic stepping !! that will have elapsed [T ~> s]. - real, intent(in) :: dt_baroclinic !< The baroclinic timestep for this cycle of - !! updates to the barotropic solver [T ~> s] real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: Datu !< A fixed estimate of the face areas at u points !! [H L ~> m2 or kg m-1]. real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: Datv !< A fixed estimate of the face areas at v points @@ -2751,12 +2755,12 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, !! of the layer transports !! [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: ubt_int !< The time-integrated zonal barotropic - !! velocity [L T-1 ~> m s-1]. - real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: uhbt_int_prev !< The time-integrated zonal barotropic + !! velocity before this update [L T-1 ~> m s-1]. + real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: uhbt_int !< The time-integrated zonal barotropic !! transport [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vbt_int !< The time-integrated meridional barotropic - !! velocity [L T-1 ~> m s-1]. - real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vhbt_int_prev !< The time-integrated meridional barotropic + !! velocity before this update [L T-1 ~> m s-1]. + real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vhbt_int !< The time-integrated meridional barotropic !! transport [H L2 T-1 ~> m3 s-1 or kg s-1]. ! Local variables @@ -2773,7 +2777,6 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, real :: h_in ! The inflow thickess [H ~> m or kg m-2]. real :: cff, Cx, Cy, tau real :: dhdt, dhdx, dhdy - real :: Idt2 ! The inverse square of the baroclinic time interval [T-2 ~> s-2]. real :: Idtbt ! The inverse of the barotropic time step [T-1 ~> s-1] integer :: i, j, is, ie, js, je real, dimension(SZIB_(G),SZJB_(G)) :: grad @@ -2783,7 +2786,6 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, if (.not.(BT_OBC%apply_u_OBCs .or. BT_OBC%apply_v_OBCs)) return Idtbt = 1.0 / dtbt - Idt2 = (1.0 / dt_baroclinic)**2 if (BT_OBC%apply_u_OBCs) then do j=js,je ; do I=is-1,ie ; if (OBC%segnum_u(I,j) /= OBC_NONE) then @@ -2824,11 +2826,10 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, endif if (.not. OBC%segment(OBC%segnum_u(I,j))%specified) then - !Need: ubt_int, uhbt_int_prev, dt, Idt2, n, Idtbt. if (integral_BT_cont) then - uhbt_int_new = find_uhbt_int(ubt_int(I,j) + dtbt*vel_trans, BTCL_u(I,j), dt_baroclinic, Idt2) + & - dt_elapsed*uhbt0(I,j) - uhbt(I,j) = (uhbt_int_new - uhbt_int_prev(I,j)) * Idtbt + uhbt_int_new = find_uhbt(ubt_int(I,j) + dtbt*vel_trans, BTCL_u(I,j)) + & + dt_elapsed*uhbt0(I,j) + uhbt(I,j) = (uhbt_int_new - uhbt_int(I,j)) * Idtbt elseif (use_BT_cont) then uhbt(I,j) = find_uhbt(vel_trans, BTCL_u(I,j)) + uhbt0(I,j) else @@ -2881,11 +2882,10 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, endif if (.not. OBC%segment(OBC%segnum_v(i,J))%specified) then - !Need: vbt_int, vhbt_int_prev. if (integral_BT_cont) then - vhbt_int_new = find_vhbt_int(vbt_int(i,J) + dtbt*vel_trans, BTCL_v(i,J), dt_baroclinic, Idt2) + & - dt_elapsed*vhbt0(i,J) - vhbt(i,J) = (vhbt_int_new - vhbt_int_prev(i,J)) * Idtbt + vhbt_int_new = find_vhbt(vbt_int(i,J) + dtbt*vel_trans, BTCL_v(i,J)) + & + dt_elapsed*vhbt0(i,J) + vhbt(i,J) = (vhbt_int_new - vhbt_int(i,J)) * Idtbt elseif (use_BT_cont) then vhbt(i,J) = find_vhbt(vel_trans, BTCL_v(i,J)) + vhbt0(i,J) else @@ -2901,7 +2901,8 @@ end subroutine apply_velocity_OBCs !> This subroutine sets up the private structure used to apply the open !! boundary conditions, as developed by Mehmet Ilicak. -subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_BT_cont, Datu, Datv, BTCL_u, BTCL_v) +subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_BT_cont, & + integral_BT_cont, dt_baroclinic, Datu, Datv, BTCL_u, BTCL_v) type(ocean_OBC_type), pointer :: OBC !< An associated pointer to an OBC type. type(memory_size_type), intent(in) :: MS !< A type that describes the memory sizes of the !! argument arrays. @@ -2917,6 +2918,11 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B 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. + logical, intent(in) :: integral_BT_cont ! If true, update the barotropic continuity + !! equation directly from the initial condition + !! using the time-integrated barotropic velocity. + real, intent(in) :: dt_baroclinic !< The baroclinic timestep for this cycle of + !! updates to the barotropic solver [T ~> s] real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: Datu !< A fixed estimate of the face areas at u points !! [H L ~> m2 or kg m-1]. real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: Datv !< A fixed estimate of the face areas at v points @@ -2929,18 +2935,19 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B !! v-points. ! Local variables + real :: I_dt ! The inverse of the time interval of this call [T-1 ~> s-1]. integer :: i, j, k, is, ie, js, je, n, nz, Isq, Ieq, Jsq, Jeq integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB integer :: isdw, iedw, jsdw, jedw logical :: OBC_used type(OBC_segment_type), pointer :: segment !< Open boundary segment - is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo 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 isdw = MS%isdw ; iedw = MS%iedw ; jsdw = MS%jsdw ; jedw = MS%jedw + I_dt = 1.0 / dt_baroclinic if ((isdw < isd) .or. (jsdw < jsd)) then call MOM_error(FATAL, "set_up_BT_OBC: Open boundary conditions are not "//& @@ -2984,8 +2991,10 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B do j=js,je ; do I=is-1,ie ; if (OBC%segnum_u(I,j) /= OBC_NONE) then ! Can this go in segment loop above? Is loop above wrong for wide halos?? if (OBC%segment(OBC%segnum_u(I,j))%specified) then - if (use_BT_cont) then - BT_OBC%ubt_outer(I,j) = uhbt_to_ubt(BT_OBC%uhbt(I,j), BTCL_u(I,j), US) + if (integral_BT_cont) then + BT_OBC%ubt_outer(I,j) = uhbt_to_ubt(BT_OBC%uhbt(I,j)*dt_baroclinic, BTCL_u(I,j)) * I_dt + elseif (use_BT_cont) then + BT_OBC%ubt_outer(I,j) = uhbt_to_ubt(BT_OBC%uhbt(I,j), BTCL_u(I,j)) else if (Datu(I,j) > 0.0) BT_OBC%ubt_outer(I,j) = BT_OBC%uhbt(I,j) / Datu(I,j) endif @@ -3036,8 +3045,10 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B do J=js-1,je ; do i=is,ie ; if (OBC%segnum_v(i,J) /= OBC_NONE) then ! Can this go in segment loop above? Is loop above wrong for wide halos?? if (OBC%segment(OBC%segnum_v(i,J))%specified) then - if (use_BT_cont) then - BT_OBC%vbt_outer(i,J) = vhbt_to_vbt(BT_OBC%vhbt(i,J), BTCL_v(i,J), US) + if (integral_BT_cont) then + BT_OBC%vbt_outer(i,J) = vhbt_to_vbt(BT_OBC%vhbt(i,J)*dt_baroclinic, BTCL_v(i,J)) * I_dt + elseif (use_BT_cont) then + BT_OBC%vbt_outer(i,J) = vhbt_to_vbt(BT_OBC%vhbt(i,J), BTCL_v(i,J)) else if (Datv(i,J) > 0.0) BT_OBC%vbt_outer(i,J) = BT_OBC%vhbt(i,J) / Datv(i,J) endif @@ -3378,14 +3389,17 @@ subroutine btcalc(h, G, GV, CS, h_u, h_v, may_use_default, OBC) end subroutine btcalc -!> The function find_uhbt determines the zonal transport for a given velocity. +!> The function find_uhbt determines the zonal transport for a given velocity, or with +!! INTEGRAL_BT_CONT=True it determines the time-integrated zonal transport for a given +!! time-integrated velocity. function find_uhbt(u, BTC) result(uhbt) - real, intent(in) :: u !< The local zonal velocity [L T-1 ~> m s-1] + real, intent(in) :: u !< The local zonal velocity [L T-1 ~> m s-1] or time integrated velocity [L ~> m] 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. + !! with the layers' continuity equations. The dimensions of some + !! of the elements in this type vary depending on INTEGRAL_BT_CONT. - real :: uhbt !< The zonal barotropic transport [L2 H T-1 ~> m3 s-1] + real :: uhbt !< The zonal barotropic transport [L2 H T-1 ~> m3 s-1] or time integrated transport [L2 H ~> m3] if (u == 0.0) then uhbt = 0.0 @@ -3401,41 +3415,14 @@ function find_uhbt(u, BTC) result(uhbt) end function find_uhbt - -!> The function find_uhbt_int determines the time-integrated zonal transport for a given -!! time-integrated velocity. -function find_uhbt_int(u_int, BTC, dt_bc, Idt2) result(uhbt_int) - real, intent(in) :: u_int !< The local time-integrated zonal velocity [L ~> m] - 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, intent(in) :: dt_bc !< The baroclinic timestep used to set up BTC [T ~> s]. - real, intent(in) :: Idt2 !< The squared inverse of dt_bc [T-2 ~> s-2]. - - real :: uhbt_int !< The time integrated zonal barotropic transport [L2 H ~> m3] - - if (u_int == 0.0) then - uhbt_int = 0.0 - elseif (u_int < BTC%uBT_EE*dt_bc) then - uhbt_int = (u_int - BTC%uBT_EE*dt_bc) * BTC%FA_u_EE + BTC%uh_EE*dt_bc - elseif (u_int < 0.0) then - uhbt_int = u_int * (BTC%FA_u_E0 + BTC%uh_crvE*Idt2 * u_int**2) - elseif (u_int <= BTC%uBT_WW*dt_bc) then - uhbt_int = u_int * (BTC%FA_u_W0 + BTC%uh_crvW*Idt2 * u_int**2) - else ! (u_int > BTC%uBT_WW*dt_bc) - uhbt_int = (u_int - BTC%uBT_WW*dt_bc) * BTC%FA_u_WW + BTC%uh_WW*dt_bc - endif - -end function find_uhbt_int - -!> The function find_duhbt_du determines the marginal zonal face area for a given velocity. -function find_duhbt_du(u, BTC, US) result(duhbt_du) - real, intent(in) :: u !< The local zonal velocity [L T-1 ~> m s-1] +!> The function find_duhbt_du determines the marginal zonal face area for a given velocity, or +!! with INTEGRAL_BT_CONT=True for a given time-integrated velocity. +function find_duhbt_du(u, BTC) result(duhbt_du) + real, intent(in) :: u !< The local zonal velocity [L T-1 ~> m s-1] or time integrated velocity [L ~> m] 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. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - + !! with the layers' continuity equations. The dimensions of some + !! of the elements in this type vary depending on INTEGRAL_BT_CONT. real :: duhbt_du !< The zonal barotropic face area [L H ~> m2] if (u == 0.0) then @@ -3452,51 +3439,30 @@ function find_duhbt_du(u, BTC, US) result(duhbt_du) end function find_duhbt_du -!> The function find_duhbt_du_int determines the marginal zonal face area for a given -!! time-integrated velocity. -function find_duhbt_du_int(u_int, BTC, US, dt_bc, Idt2) result(duhbt_du) - real, intent(in) :: u_int !< The local zonal time-integrated velocity [L ~> m] - 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. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, intent(in) :: dt_bc !< The baroclinic timestep used to set up BTC [T ~> s]. - real, intent(in) :: Idt2 !< The squared inverse of dt_bc [T-2 ~> s-2]. - - real :: duhbt_du !< The zonal barotropic face area [L H ~> m2] - - if (u_int == 0.0) then - duhbt_du = 0.5*(BTC%FA_u_E0 + BTC%FA_u_W0) ! Note the potential discontinuity here. - elseif (u_int < BTC%uBT_EE*dt_bc) then - duhbt_du = BTC%FA_u_EE - elseif (u_int < 0.0) then - duhbt_du = (BTC%FA_u_E0 + 3.0*(BTC%uh_crvE*Idt2) * u_int**2) - elseif (u_int <= BTC%uBT_WW*dt_bc) then - duhbt_du = (BTC%FA_u_W0 + 3.0*(BTC%uh_crvW*Idt2) * u_int**2) - else ! (u_int > BTC%uBT_WW*dt_bc) - duhbt_du = BTC%FA_u_WW - endif - -end function find_duhbt_du_int - !> This function inverts the transport function to determine the barotopic -!! velocity that is consistent with a given transport. -function uhbt_to_ubt(uhbt, BTC, US, guess) result(ubt) +!! velocity that is consistent with a given transport, or if INTEGRAL_BT_CONT=True +!! this finds the time-integrated velocity that is consistent with a time-integrated transport. +function uhbt_to_ubt(uhbt, BTC, guess) result(ubt) real, intent(in) :: uhbt !< The barotropic zonal transport that should be inverted for, - !! [H L2 T-1 ~> m3 s-1 or kg s-1]. + !! [H L2 T-1 ~> m3 s-1 or kg s-1] or the time-integrated + !! transport [H L2 ~> m3 or kg]. 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. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, optional, intent(in) :: guess !< A guess at what ubt will be [L T-1 ~> m s-1]. The result - !! is not allowed to be dramatically larger than guess. - real :: ubt !< The result - The velocity that gives uhbt transport [L T-1 ~> m s-1]. + !! layers' continuity equations. The dimensions of some + !! of the elements in this type vary depending on INTEGRAL_BT_CONT. + real, optional, intent(in) :: guess !< A guess at what ubt will be [L T-1 ~> m s-1] or [L ~> m]. + !! The result is not allowed to be dramatically larger than guess. + real :: ubt !< The result - The velocity that gives uhbt transport [L T-1 ~> m s-1] + !! or the time-integrated velocity [L ~> m]. ! Local variables - real :: ubt_min, ubt_max, uhbt_err, derr_du - real :: uherr_min, uherr_max + real :: ubt_min, ubt_max ! Bounding values of vbt [L T-1 ~> m s-1] or [L ~> m] + real :: uhbt_err ! The transport error [H L2 T-1 ~> m3 s-1 or kg s-1] or [H L2 ~> m3 or kg]. + real :: derr_du ! The change in transport error with vbt, i.e. the face area [H L ~> m2 or kg m-1]. + real :: uherr_min, uherr_max ! The bounding values of the transport error [H L2 T-1 ~> m3 s-1 or kg s-1] + ! or [H L2 ~> m3 or kg]. real, parameter :: tol = 1.0e-10 ! A fractional match tolerance [nondim] - real :: dvel ! Temporary variable used in the limiting the velocity [L T-1 ~> m s-1]. + real :: dvel ! Temporary variable used in the limiting the velocity [L T-1 ~> m s-1] or [L ~> m]. real :: vsr ! Temporary variable used in the limiting the velocity [nondim]. real, parameter :: vs1 = 1.25 ! Nondimensional parameters used in limiting real, parameter :: vs2 = 2.0 ! the velocity, starting at vs1, with the @@ -3564,7 +3530,7 @@ function uhbt_to_ubt(uhbt, BTC, US, guess) result(ubt) if (dvel > 0.0) then ! Limit the velocity if (dvel < 40.0 * (abs(guess)*(vs2-vs1)) ) then vsr = vs2 - (vs2-vs1) * exp(-dvel / (abs(guess)*(vs2-vs1))) - else ! The exp be less than 4e-18 anyway in this case, so neglect it. + else ! The exp is less than 4e-18 anyway in this case, so neglect it. vsr = vs2 endif ubt = SIGN(vsr * guess, ubt) @@ -3573,13 +3539,16 @@ function uhbt_to_ubt(uhbt, BTC, US, guess) result(ubt) end function uhbt_to_ubt -!> The function find_vhbt determines the meridional transport for a given velocity. +!> The function find_vhbt determines the meridional transport for a given velocity, or with +!! INTEGRAL_BT_CONT=True it determines the time-integrated meridional transport for a given +!! time-integrated velocity. function find_vhbt(v, BTC) result(vhbt) - real, intent(in) :: v !< The local meridional velocity [L T-1 ~> m s-1] + real, intent(in) :: v !< The local meridional velocity [L T-1 ~> m s-1] or time integrated velocity [L ~> m] 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 meridional barotropic transport [L2 H T-1 ~> m3 s-1] + !! with the layers' continuity equations. The dimensions of some + !! of the elements in this type vary depending on INTEGRAL_BT_CONT. + real :: vhbt !< The meridional barotropic transport [L2 H T-1 ~> m3 s-1] or time integrated transport [L2 H ~> m3] if (v == 0.0) then vhbt = 0.0 @@ -3595,38 +3564,14 @@ function find_vhbt(v, BTC) result(vhbt) end function find_vhbt -!> The function find_vhbt_int determines the time-integrated meridional transport for a given -!! time-integrated velocity. -function find_vhbt_int(v_int, BTC, dt_bc, Idt2) result(vhbt_int) - real, intent(in) :: v_int !< The local time-integrated meridional velocity [L ~> m] +!> The function find_dvhbt_dv determines the marginal meridional face area for a given velocity, or +!! with INTEGRAL_BT_CONT=True for a given time-integrated velocity. +function find_dvhbt_dv(v, BTC) result(dvhbt_dv) + real, intent(in) :: v !< The local meridional velocity [L T-1 ~> m s-1] or time integrated velocity [L ~> m] 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, intent(in) :: dt_bc !< The baroclinic timestep used to set up BTC [T ~> s]. - real, intent(in) :: Idt2 !< The squared inverse of dt_bc [T-2 ~> s-2]. - real :: vhbt_int !< The time integrated meridional barotropic transport [L2 H ~> m3] - - if (v_int == 0.0) then - vhbt_int = 0.0 - elseif (v_int < BTC%vBT_NN*dt_bc) then - vhbt_int = (v_int - BTC%vBT_NN*dt_bc) * BTC%FA_v_NN + BTC%vh_NN*dt_bc - elseif (v_int < 0.0) then - vhbt_int = v_int * (BTC%FA_v_N0 + BTC%vh_crvN*Idt2 * v_int**2) - elseif (v_int <= BTC%vBT_SS*dt_bc) then - vhbt_int = v_int * (BTC%FA_v_S0 + BTC%vh_crvS*Idt2 * v_int**2) - else ! (v_int > BTC%vBT_SS*dt_bc) - vhbt_int = (v_int - BTC%vBT_SS*dt_bc) * BTC%FA_v_SS + BTC%vh_SS*dt_bc - endif - -end function find_vhbt_int - -!> The function find_dvhbt_dv determines the marginal meridional face area for a given velocity. -function find_dvhbt_dv(v, BTC, US) result(dvhbt_dv) - real, intent(in) :: v !< The local meridional velocity [L T-1 ~> 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. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + !! with the layers' continuity equations. The dimensions of some + !! of the elements in this type vary depending on INTEGRAL_BT_CONT. real :: dvhbt_dv !< The meridional barotropic face area [L H ~> m2] if (v == 0.0) then @@ -3643,50 +3588,30 @@ function find_dvhbt_dv(v, BTC, US) result(dvhbt_dv) end function find_dvhbt_dv -!> The function find_dvhbt_dv_int determines the marginal meridional face area for a given -!! time-integrated velocity. -function find_dvhbt_dv_int(v_int, BTC, US, dt_bc, Idt2) result(dvhbt_dv) - real, intent(in) :: v_int !< The local time-integrated meridional velocity [L ~> m] - 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. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, intent(in) :: dt_bc !< The baroclinic timestep used to set up BTC [T ~> s]. - real, intent(in) :: Idt2 !< The squared inverse of dt_bc [T-2 ~> s-2]. - real :: dvhbt_dv !< The meridional barotropic face area [L H ~> m2] - - if (v_int == 0.0) then - dvhbt_dv = 0.5*(BTC%FA_v_N0 + BTC%FA_v_S0) ! Note the potential discontinuity here. - elseif (v_int < BTC%vBT_NN*dt_bc) then - dvhbt_dv = BTC%FA_v_NN - elseif (v_int < 0.0) then - dvhbt_dv = BTC%FA_v_N0 + 3.0*(BTC%vh_crvN*Idt2) * v_int**2 - elseif (v_int <= BTC%vBT_SS*dt_bc) then - dvhbt_dv = BTC%FA_v_S0 + 3.0*(BTC%vh_crvS*Idt2) * v_int**2 - else ! (v_int > BTC%vBT_SS*dt_bc) - dvhbt_dv = BTC%FA_v_SS - endif - -end function find_dvhbt_dv_int - !> This function inverts the transport function to determine the barotopic -!! velocity that is consistent with a given transport. -function vhbt_to_vbt(vhbt, BTC, US, guess) result(vbt) +!! velocity that is consistent with a given transport, or if INTEGRAL_BT_CONT=True +!! this finds the time-integrated velocity that is consistent with a time-integrated transport. +function vhbt_to_vbt(vhbt, BTC, guess) result(vbt) real, intent(in) :: vhbt !< The barotropic meridional transport that should be - !! inverted for [H L2 T-1 ~> m3 s-1 or kg s-1]. + !! inverted for [H L2 T-1 ~> m3 s-1 or kg s-1] or the + !! time-integrated transport [H L2 ~> m3 or kg]. 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. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, optional, intent(in) :: guess !< A guess at what vbt will be. The result is not allowed - !! to be dramatically larger than guess [L T-1 ~> m s-1]. - real :: vbt !< The result - The velocity that gives vhbt transport [L T-1 ~> m s-1]. + !! with the layers' continuity equations. The dimensions of some + !! of the elements in this type vary depending on INTEGRAL_BT_CONT. + real, optional, intent(in) :: guess !< A guess at what vbt will be [L T-1 ~> m s-1] or [L ~> m]. + !! The result is not allowed to be dramatically larger than guess. + real :: vbt !< The result - The velocity that gives vhbt transport [L T-1 ~> m s-1] + !! or the time-integrated velocity [L ~> m]. ! Local variables - real :: vbt_min, vbt_max, vhbt_err, derr_dv - real :: vherr_min, vherr_max + real :: vbt_min, vbt_max ! Bounding values of vbt [L T-1 ~> m s-1] or [L ~> m] + real :: vhbt_err ! The transport error [H L2 T-1 ~> m3 s-1 or kg s-1] or [H L2 ~> m3 or kg]. + real :: derr_dv ! The change in transport error with vbt, i.e. the face area [H L ~> m2 or kg m-1]. + real :: vherr_min, vherr_max ! The bounding values of the transport error [H L2 T-1 ~> m3 s-1 or kg s-1] + ! or [H L2 ~> m3 or kg]. real, parameter :: tol = 1.0e-10 ! A fractional match tolerance [nondim] - real :: dvel ! Temporary variable used in the limiting the velocity [L T-1 ~> m s-1]. + real :: dvel ! Temporary variable used in the limiting the velocity [L T-1 ~> m s-1] or [L ~> m]. real :: vsr ! Temporary variable used in the limiting the velocity [nondim]. real, parameter :: vs1 = 1.25 ! Nondimensional parameters used in limiting real, parameter :: vs2 = 2.0 ! the velocity, starting at vs1, with the @@ -3754,7 +3679,7 @@ function vhbt_to_vbt(vhbt, BTC, US, guess) result(vbt) if (dvel > 0.0) then ! Limit the velocity if (dvel < 40.0 * (abs(guess)*(vs2-vs1)) ) then vsr = vs2 - (vs2-vs1) * exp(-dvel / (abs(guess)*(vs2-vs1))) - else ! The exp be less than 4e-18 anyway in this case, so neglect it. + else ! The exp is less than 4e-18 anyway in this case, so neglect it. vsr = vs2 endif vbt = SIGN(guess * vsr, vbt) @@ -3765,7 +3690,7 @@ end function vhbt_to_vbt !> This subroutine sets up reordered versions of the BT_cont type in the !! local_BT_cont types, which have wide halos properly filled in. -subroutine set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, BT_Domain, halo) +subroutine set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, BT_Domain, halo, dt_baroclinic) 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 @@ -3780,16 +3705,26 @@ subroutine set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, BT_Domain type(MOM_domain_type), intent(inout) :: BT_Domain !< The domain to use for updating !! the halos of wide arrays. integer, optional, intent(in) :: halo !< The extra halo size to use here. + real, optional, intent(in) :: dt_baroclinic !< The baroclinic time step + !! [T ~> s], which is provided if + !! INTEGRAL_BT_CONTINUITY is true. ! Local variables real, dimension(SZIBW_(MS),SZJW_(MS)) :: & - u_polarity, uBT_EE, uBT_WW, FA_u_EE, FA_u_E0, FA_u_W0, FA_u_WW + u_polarity, & ! An array used to test for halo update polarity [nondim] + uBT_EE, uBT_WW, & ! Zonal velocities at which the form of the fit changes [L T-1 ~> m s-1] + FA_u_EE, FA_u_E0, FA_u_W0, FA_u_WW ! Zonal face areas [H L ~> m2 or kg m-1] real, dimension(SZIW_(MS),SZJBW_(MS)) :: & - v_polarity, vBT_NN, vBT_SS, FA_v_NN, FA_v_N0, FA_v_S0, FA_v_SS + v_polarity, & ! An array used to test for halo update polarity [nondim] + vBT_NN, vBT_SS, & ! Meridional velocities at which the form of the fit changes [L T-1 ~> m s-1] + FA_v_NN, FA_v_N0, FA_v_S0, FA_v_SS ! Meridional face areas [H L ~> m2 or kg m-1] + real :: dt ! The baroclinic timestep [T ~> s] or 1.0 [nondim] real, parameter :: C1_3 = 1.0/3.0 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) + dt = 1.0 ; if (present(dt_baroclinic)) dt = dt_baroclinic ! Copy the BT_cont arrays into symmetric, potentially wide haloed arrays. !$OMP parallel default(none) shared(is,ie,js,je,hs,u_polarity,uBT_EE,uBT_WW,FA_u_EE, & @@ -3847,7 +3782,7 @@ subroutine set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, BT_Domain do j=js-hs,je+hs ; do I=is-hs-1,ie+hs BTCL_u(I,j)%FA_u_EE = FA_u_EE(I,j) ; BTCL_u(I,j)%FA_u_E0 = FA_u_E0(I,j) BTCL_u(I,j)%FA_u_W0 = FA_u_W0(I,j) ; BTCL_u(I,j)%FA_u_WW = FA_u_WW(I,j) - BTCL_u(I,j)%uBT_EE = uBT_EE(I,j) ; BTCL_u(I,j)%uBT_WW = uBT_WW(I,j) + BTCL_u(I,j)%uBT_EE = dt*uBT_EE(I,j) ; BTCL_u(I,j)%uBT_WW = dt*uBT_WW(I,j) ! Check for reversed polarity in the tripolar halo regions. if (u_polarity(I,j) < 0.0) then call swap(BTCL_u(I,j)%FA_u_EE, BTCL_u(I,j)%FA_u_WW) @@ -3870,7 +3805,7 @@ subroutine set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, BT_Domain do J=js-hs-1,je+hs ; do i=is-hs,ie+hs BTCL_v(i,J)%FA_v_NN = FA_v_NN(i,J) ; BTCL_v(i,J)%FA_v_N0 = FA_v_N0(i,J) BTCL_v(i,J)%FA_v_S0 = FA_v_S0(i,J) ; BTCL_v(i,J)%FA_v_SS = FA_v_SS(i,J) - BTCL_v(i,J)%vBT_NN = vBT_NN(i,J) ; BTCL_v(i,J)%vBT_SS = vBT_SS(i,J) + BTCL_v(i,J)%vBT_NN = dt*vBT_NN(i,J) ; BTCL_v(i,J)%vBT_SS = dt*vBT_SS(i,J) ! Check for reversed polarity in the tripolar halo regions. if (v_polarity(i,J) < 0.0) then call swap(BTCL_v(i,J)%FA_v_NN, BTCL_v(i,J)%FA_v_SS) @@ -3898,7 +3833,7 @@ end subroutine set_local_BT_cont_types !! summed transports when the velocities are larger than the first guesses of the cubic !! transition velocities used to set up the local_BT_cont types. subroutine adjust_local_BT_cont_types(ubt, uhbt, vbt, vhbt, BTCL_u, BTCL_v, & - G, US, MS, halo) + G, US, MS, halo, dt_baroclinic) 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 [L T-1 ~> m s-1]. @@ -3917,73 +3852,78 @@ subroutine adjust_local_BT_cont_types(ubt, uhbt, vbt, vhbt, BTCL_u, BTCL_v, & type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, optional, intent(in) :: halo !< The extra halo size to use here. + real, optional, intent(in) :: dt_baroclinic !< The baroclinic time step [T ~> s], which is + !! provided if INTEGRAL_BT_CONTINUITY is true. ! Local variables real, dimension(SZIBW_(MS),SZJW_(MS)) :: & u_polarity, uBT_EE, uBT_WW, FA_u_EE, FA_u_E0, FA_u_W0, FA_u_WW real, dimension(SZIW_(MS),SZJBW_(MS)) :: & v_polarity, vBT_NN, vBT_SS, FA_v_NN, FA_v_N0, FA_v_S0, FA_v_SS + real :: dt ! The baroclinic timestep [T ~> s] or 1.0 [nondim] real, parameter :: C1_3 = 1.0/3.0 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) + dt = 1.0 ; if (present(dt_baroclinic)) dt = dt_baroclinic !$OMP parallel do default(shared) do j=js-hs,je+hs ; do I=is-hs-1,ie+hs - if ((ubt(I,j) > BTCL_u(I,j)%uBT_WW) .and. (uhbt(I,j) > BTCL_u(I,j)%uh_WW)) then + if ((dt*ubt(I,j) > BTCL_u(I,j)%uBT_WW) .and. (dt*uhbt(I,j) > BTCL_u(I,j)%uh_WW)) then ! Expand the cubic fit to use this new point. ubt is negative. - BTCL_u(I,j)%ubt_WW = ubt(I,j) + BTCL_u(I,j)%ubt_WW = dt * ubt(I,j) if (3.0*uhbt(I,j) < 2.0*ubt(I,j) * BTCL_u(I,j)%FA_u_W0) then ! No further bounding is needed. - BTCL_u(I,j)%uh_crvW = (uhbt(I,j) - ubt(I,j) * BTCL_u(I,j)%FA_u_W0) / ubt(I,j)**3 + BTCL_u(I,j)%uh_crvW = (uhbt(I,j) - ubt(I,j) * BTCL_u(I,j)%FA_u_W0) / (dt**2 * ubt(I,j)**3) else ! This should not happen often! BTCL_u(I,j)%FA_u_W0 = 1.5*uhbt(I,j) / ubt(I,j) - BTCL_u(I,j)%uh_crvW = -0.5*uhbt(I,j) / ubt(I,j)**3 + BTCL_u(I,j)%uh_crvW = -0.5*uhbt(I,j) / (dt**2 * ubt(I,j)**3) endif - BTCL_u(I,j)%uh_WW = uhbt(I,j) + BTCL_u(I,j)%uh_WW = dt * uhbt(I,j) ! I don't know whether this is helpful. ! BTCL_u(I,j)%FA_u_WW = min(BTCL_u(I,j)%FA_u_WW, uhbt(I,j) / ubt(I,j)) - elseif ((ubt(I,j) < BTCL_u(I,j)%uBT_EE) .and. (uhbt(I,j) < BTCL_u(I,j)%uh_EE)) then + elseif ((dt*ubt(I,j) < BTCL_u(I,j)%uBT_EE) .and. (dt*uhbt(I,j) < BTCL_u(I,j)%uh_EE)) then ! Expand the cubic fit to use this new point. ubt is negative. - BTCL_u(I,j)%ubt_EE = ubt(I,j) + BTCL_u(I,j)%ubt_EE = dt * ubt(I,j) if (3.0*uhbt(I,j) < 2.0*ubt(I,j) * BTCL_u(I,j)%FA_u_E0) then ! No further bounding is needed. - BTCL_u(I,j)%uh_crvE = (uhbt(I,j) - ubt(I,j) * BTCL_u(I,j)%FA_u_E0) / ubt(I,j)**3 + BTCL_u(I,j)%uh_crvE = (uhbt(I,j) - ubt(I,j) * BTCL_u(I,j)%FA_u_E0) / (dt**2 * ubt(I,j)**3) else ! This should not happen often! BTCL_u(I,j)%FA_u_E0 = 1.5*uhbt(I,j) / ubt(I,j) - BTCL_u(I,j)%uh_crvE = -0.5*uhbt(I,j) / ubt(I,j)**3 + BTCL_u(I,j)%uh_crvE = -0.5*uhbt(I,j) / (dt**2 * ubt(I,j)**3) endif - BTCL_u(I,j)%uh_EE = uhbt(I,j) + BTCL_u(I,j)%uh_EE = dt * uhbt(I,j) ! I don't know whether this is helpful. ! BTCL_u(I,j)%FA_u_EE = min(BTCL_u(I,j)%FA_u_EE, uhbt(I,j) / ubt(I,j)) endif enddo ; enddo !$OMP parallel do default(shared) do J=js-hs-1,je+hs ; do i=is-hs,ie+hs - if ((vbt(i,J) > BTCL_v(i,J)%vBT_SS) .and. (vhbt(i,J) > BTCL_v(i,J)%vh_SS)) then + if ((dt*vbt(i,J) > BTCL_v(i,J)%vBT_SS) .and. (dt*vhbt(i,J) > BTCL_v(i,J)%vh_SS)) then ! Expand the cubic fit to use this new point. vbt is negative. - BTCL_v(i,J)%vbt_SS = vbt(i,J) + BTCL_v(i,J)%vbt_SS = dt * vbt(i,J) if (3.0*vhbt(i,J) < 2.0*vbt(i,J) * BTCL_v(i,J)%FA_v_S0) then ! No further bounding is needed. - BTCL_v(i,J)%vh_crvS = (vhbt(i,J) - vbt(i,J) * BTCL_v(i,J)%FA_v_S0) / vbt(i,J)**3 + BTCL_v(i,J)%vh_crvS = (vhbt(i,J) - vbt(i,J) * BTCL_v(i,J)%FA_v_S0) / (dt**2 * vbt(i,J)**3) else ! This should not happen often! BTCL_v(i,J)%FA_v_S0 = 1.5*vhbt(i,J) / (vbt(i,J)) - BTCL_v(i,J)%vh_crvS = -0.5*vhbt(i,J) / vbt(i,J)**3 + BTCL_v(i,J)%vh_crvS = -0.5*vhbt(i,J) / (dt**2 * vbt(i,J)**3) endif - BTCL_v(i,J)%vh_SS = vhbt(i,J) + BTCL_v(i,J)%vh_SS = dt * vhbt(i,J) ! I don't know whether this is helpful. ! BTCL_v(i,J)%FA_v_SS = min(BTCL_v(i,J)%FA_v_SS, vhbt(i,J) / vbt(i,J)) - elseif ((vbt(i,J) < BTCL_v(i,J)%vBT_NN) .and. (vhbt(i,J) < BTCL_v(i,J)%vh_NN)) then + elseif ((dt*vbt(i,J) < BTCL_v(i,J)%vBT_NN) .and. (dt*vhbt(i,J) < BTCL_v(i,J)%vh_NN)) then ! Expand the cubic fit to use this new point. vbt is negative. - BTCL_v(i,J)%vbt_NN = vbt(i,J) + BTCL_v(i,J)%vbt_NN = dt * vbt(i,J) if (3.0*vhbt(i,J) < 2.0*vbt(i,J) * BTCL_v(i,J)%FA_v_N0) then ! No further bounding is needed. - BTCL_v(i,J)%vh_crvN = (vhbt(i,J) - vbt(i,J) * BTCL_v(i,J)%FA_v_N0) / vbt(i,J)**3 + BTCL_v(i,J)%vh_crvN = (vhbt(i,J) - vbt(i,J) * BTCL_v(i,J)%FA_v_N0) / (dt**2 * vbt(i,J)**3) else ! This should not happen often! BTCL_v(i,J)%FA_v_N0 = 1.5*vhbt(i,J) / (vbt(i,J)) - BTCL_v(i,J)%vh_crvN = -0.5*vhbt(i,J) / vbt(i,J)**3 + BTCL_v(i,J)%vh_crvN = -0.5*vhbt(i,J) / (dt**2 * vbt(i,J)**3) endif - BTCL_v(i,J)%vh_NN = vhbt(i,J) + BTCL_v(i,J)%vh_NN = dt * vhbt(i,J) ! I don't know whether this is helpful. ! BTCL_v(i,J)%FA_v_NN = min(BTCL_v(i,J)%FA_v_NN, vhbt(i,J) / vbt(i,J)) endif From e218354871e481a0608f6c7b7f6189adffc6918c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 16 Jul 2020 13:47:05 -0400 Subject: [PATCH 71/91] (*?)Revised ice_shelf_driver.F90 so it compiles Revised ice_shelf_driver.F90 so that it compiles successfully and is similar to MOM_driver.F90 where possible. In addition, deleted the files MOM_surface_forcing.F90 and user_surface_forcing.F90 in the ice_solo_driver directory, as these are unused and out-of-date versions of the equivalent files in the solo_driver directory. Some of the changes are not as streamlines as they could be if the solo_ice_shelf code used its own version of diag_mediator, or if the interface to diag_mediator were revised so that some of its ocean-specific arguments are optional. There is no test-case exercising this code, but at least it now compiles, whereas it did not compile before. --- .../ice_solo_driver/MOM_surface_forcing.F90 | 1203 ----------------- .../ice_solo_driver/ice_shelf_driver.F90 | 396 +++--- .../ice_solo_driver/user_surface_forcing.F90 | 338 ----- 3 files changed, 226 insertions(+), 1711 deletions(-) delete mode 100644 config_src/ice_solo_driver/MOM_surface_forcing.F90 delete mode 100644 config_src/ice_solo_driver/user_surface_forcing.F90 diff --git a/config_src/ice_solo_driver/MOM_surface_forcing.F90 b/config_src/ice_solo_driver/MOM_surface_forcing.F90 deleted file mode 100644 index 79bf924ca3..0000000000 --- a/config_src/ice_solo_driver/MOM_surface_forcing.F90 +++ /dev/null @@ -1,1203 +0,0 @@ -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 temperature and * -!* fresh water. These subroutines will be 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 * -!* taux[][] and tauy[][]. Often wind_forcing must be tailored for * -!* a particular application - either by specifying file and variable * -!* names or by providing appropriate internal expressions for the * -!* stresses. * -!* * -!* buoyancy_forcing determines the surface fluxes of buoyancy, * -!* temperature, and fresh water, as is appropriate. A restoring * -!* boundary condition is implemented, but the code for any other * -!* boundary condition will usually be modified - either to specify * -!* file and variable names and which time level to read, or to set * -!* an internal expression for the 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, 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_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 -use MOM_diag_mediator, only : post_data, query_averaging_enabled -use MOM_diag_mediator, only : register_diag_field, diag_ctrl, safe_alloc_ptr -use MOM_domains, only : pass_var, pass_vector, AGRID, To_South, To_West, To_All -use MOM_error_handler, only : callTree_enter, callTree_leave -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_string_functions, only : uppercase -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 : set_net_mass_forcing, copy_common_forcing_fields -use MOM_forcing_type, only : set_derived_forcing_fields -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 : file_exists, MOM_read_data, MOM_read_vector, slasher -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_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 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 -use user_revise_forcing, only : user_revise_forcing_CS - -implicit none ; private - -#include - -public set_forcing -public surface_forcing_init -public forcing_diagnostics -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. -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 [R ~> kg m-3] - real :: G_Earth !< gravitational acceleration [L2 Z-1 T-2 ~> m s-2] - real :: Flux_const !< piston velocity for surface restoring [Z T-1 ~> m s-1] - real :: latent_heat_fusion !< latent heat of fusion times [Q ~> J kg-1] - real :: latent_heat_vapor !< latent heat of vaporization [Q ~> J kg-1] - - real :: gust_const !< constant unresolved background gustiness for ustar [R L Z T-1 ~> Pa] - logical :: read_gust_2d !< if true, use 2-dimensional gustiness supplied from a file - real, pointer :: gust(:,:) => NULL() !< spatially varying unresolved background gustiness [R L Z T-1 ~> 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 [R ~> 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 - - ! 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 - - real :: wind_scale !< value by which wind-stresses are scaled, ND. - 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(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) :: longwavedown_file = '' !< The file from which the downward longwave heat flux is read - character(len=200) :: shortwavedown_file = '' !< The file from which the downward 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) :: precip_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) :: freshdischarge_file = '' !< The file from which the runoff and calving are 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 - - 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(MESO_surface_forcing_CS), pointer :: MESO_forcing_CSp => NULL() - !!@} -end type surface_forcing_CS - -integer :: id_clock_forcing - -contains - -!> 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 !< 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(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 :: 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 - - call cpu_clock_begin(id_clock_forcing) - - day_center = day_start + day_interval/2 - call get_time(day_interval, intdt) - dt = real(intdt) - - if (CS%first_call_set_forcing) then - ! Allocate memory for the mechanical and thermodyanmic forcing fields. - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., press=.true.) - - call allocate_forcing_type(G, fluxes, ustar=.true.) - if (trim(CS%buoy_config) /= "NONE") then - if ( CS%use_temperature ) then - call allocate_forcing_type(G, fluxes, water=.true., heat=.true., press=.true.) - if (CS%restorebuoy) then - call safe_alloc_ptr(CS%T_Restore,isd, ied, jsd, jed) - call safe_alloc_ptr(fluxes%heat_added, isd, ied, jsd, jed) - call safe_alloc_ptr(CS%S_Restore, isd, ied, jsd, jed) - endif - else ! CS%use_temperature false. - call safe_alloc_ptr(fluxes%buoy, isd, ied, jsd, jed) - - if (CS%restorebuoy) call safe_alloc_ptr(CS%Dens_Restore, isd, ied, jsd, jed) - endif ! endif for CS%use_temperature - endif - endif - - ! calls to various wind options - 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) - elseif (trim(CS%wind_config) == "2gyre") then - call wind_forcing_2gyre(sfc_state, forces, day_center, G, CS) - elseif (trim(CS%wind_config) == "1gyre") then - call wind_forcing_1gyre(sfc_state, forces, day_center, G, CS) - elseif (trim(CS%wind_config) == "gyres") then - call wind_forcing_gyres(sfc_state, forces, day_center, G, CS) - elseif (trim(CS%wind_config) == "zero") then - call wind_forcing_zero(sfc_state, forces, day_center, G, CS) - elseif (trim(CS%wind_config) == "MESO") then - call MOM_error(FATAL, "MESO forcing is not available with the ice-shelf"//& - "version of MOM_surface_forcing.") -! call MESO_wind_forcing(sfc_state, forces, day_center, G, CS%MESO_forcing_CSp) - elseif (trim(CS%wind_config) == "USER") then - call USER_wind_forcing(sfc_state, forces, day_center, G, 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") - else - call MOM_error(FATAL, & - "MOM_surface_forcing:Unrecognized wind config "//trim(CS%wind_config)) - endif - endif - if ((CS%variable_buoyforce .or. CS%first_call_set_forcing) .and. & - (.not.CS%adiabatic)) then - if (trim(CS%buoy_config) == "file") then - call buoyancy_forcing_from_files(sfc_state, fluxes, day_center, dt, G, US, CS) - elseif (trim(CS%buoy_config) == "zero") then - call buoyancy_forcing_zero(sfc_state, fluxes, day_center, dt, G, CS) - elseif (trim(CS%buoy_config) == "linear") then - call buoyancy_forcing_linear(sfc_state, fluxes, day_center, dt, G, US, CS) - elseif (trim(CS%buoy_config) == "MESO") then - call MOM_error(FATAL, "MESO forcing is not available with the ice-shelf"//& - "version of MOM_surface_forcing.") -! call MESO_buoyancy_forcing(sfc_state, fluxes, day_center, dt, G, CS%MESO_forcing_CSp) - elseif (trim(CS%buoy_config) == "USER") then - call USER_buoyancy_forcing(sfc_state, fluxes, day_center, dt, G, CS%user_forcing_CSp) - elseif (trim(CS%buoy_config) == "NONE") then - call MOM_mesg("MOM_surface_forcing: buoyancy forcing has been set to omitted.") - elseif (CS%variable_buoyforce .and. .not.CS%first_call_set_forcing) then - call MOM_error(FATAL, & - "MOM_surface_forcing: Variable buoy defined with no buoy config.") - else - call MOM_error(FATAL, & - "MOM_surface_forcing: Unrecognized buoy config "//trim(CS%buoy_config)) - endif - endif - - if (associated(CS%tracer_flow_CSp)) then - call call_tracer_set_forcing(sfc_state, fluxes, day_start, day_interval, G, CS%tracer_flow_CSp) - endif - - ! Allow for user-written code to alter the fluxes after all the above - call user_alter_forcing(sfc_state, fluxes, day_center, G, CS%urf_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, US, CS%Rho0) - endif - - if ((CS%variable_buoyforce .or. CS%first_call_set_forcing) .and. & - (.not.CS%adiabatic)) then - call set_net_mass_forcing(fluxes, forces, G, US) - endif - - CS%first_call_set_forcing = .false. - - 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 !< 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 !< 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 - - if ( CS%use_temperature ) then - call allocate_forcing_type(G, fluxes, water=.true., heat=.true., & - ustar=.true., press=.true.) - - ! surface restoring fields - if (CS%restorebuoy) then - call safe_alloc_ptr(CS%T_Restore,isd,ied,jsd,jed) - call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) - call safe_alloc_ptr(CS%S_Restore,isd,ied,jsd,jed) - endif - - else ! CS%use_temperature false. - call safe_alloc_ptr(fluxes%buoy,isd,ied,jsd,jed) - - call allocate_forcing_type(G, fluxes, water=.true., heat=.true., & - ustar=.true., press=.true.) - - if (CS%restorebuoy) call safe_alloc_ptr(CS%Dens_Restore,isd,ied,jsd,jed) - - endif ! endif for CS%use_temperature - -end subroutine buoyancy_forcing_allocate - - -! 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 !< 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 - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - - call callTree_enter("wind_forcing_zero, 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. - PI = 4.0*atan(1.0) - - do j=js,je ; do I=Isq,Ieq - forces%taux(I,j) = 0.0 - enddo ; enddo - - do J=Jsq,Jeq ; do i=is,ie - forces%tauy(i,J) = 0.0 - enddo ; enddo - - if (CS%read_gust_2d) then - if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt(US%L_to_Z*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(US%L_to_Z*CS%gust_const/CS%Rho0) - enddo ; enddo ; endif - endif - - call callTree_leave("wind_forcing_zero") -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 !< 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 - - 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) - - do j=js,je ; do I=Isq,Ieq - forces%taux(I,j) = 0.1*US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * & - (1.0 - cos(2.0*PI*(G%geoLatCu(I,j)-CS%South_lat) / CS%len_lat)) - enddo ; enddo - - do J=Jsq,Jeq ; do i=is,ie - forces%tauy(i,J) = 0.0 - enddo ; enddo - - call callTree_leave("wind_forcing_2gyre") -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 !< 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 - - 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) - - do j=js,je ; do I=Isq,Ieq - forces%taux(I,j) = -0.2*US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * & - cos(PI*(G%geoLatCu(I,j)-CS%South_lat)/CS%len_lat) - enddo ; enddo - - do J=Jsq,Jeq ; do i=is,ie - forces%tauy(i,J) = 0.0 - enddo ; enddo - - call callTree_leave("wind_forcing_1gyre") -end subroutine wind_forcing_1gyre - - -!> 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 !< 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 - - 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] - PI = 4.0*atan(1.0) - - do j=jsd,jed ; do I=IsdB,IedB - y = (G%geoLatCu(I,j)-CS%South_lat)/CS%len_lat - forces%taux(I,j) = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z * (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=JsdB,JedB ; do i=isd,ied - forces%tauy(i,J) = 0.0 - enddo ; enddo - - ! set the friction velocity - do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt(US%L_to_S * (CS%gust_const/CS%Rho0 + & - 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) ) - enddo ; enddo - - call callTree_leave("wind_forcing_gyres") -end subroutine wind_forcing_gyres - -!> 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 !< 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 [Pa]. - real :: Pa_conversion ! A unit conversion factor from Pa to the internal wind stress - ! units [R Z L T-2 Pa-1 ~> 1] - integer :: days, seconds - - 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 - Pa_conversion = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z - - call get_time(day,seconds,days) - time_lev = days - 365*floor(real(days) / 365.0) +1 - - if (time_lev /= CS%wind_last_lev_read) then - filename = trim(CS%inputdir) // trim(CS%wind_file) -! if (is_root_pe()) & -! write(*,'("Wind_forcing Reading time level ",I," last was ",I,".")')& -! time_lev-1,CS%wind_last_lev_read-1 - select case ( uppercase(CS%wind_stagger(1:1)) ) - case ("A") - temp_x(:,:) = 0.0 ; temp_y(:,:) = 0.0 - call MOM_read_vector(filename, CS%stress_x_var, CS%stress_y_var, & - temp_x(:,:), temp_y(:,:), G%Domain, stagger=AGRID, & - timelevel=time_lev, scale=Pa_conversion) - - call pass_vector(temp_x, temp_y, G%Domain, To_All, AGRID) - do j=js,je ; do I=Isq,Ieq - forces%taux(I,j) = 0.5 * CS%wind_scale * (temp_x(i,j) + temp_x(i+1,j)) - enddo ; enddo - do J=Jsq,Jeq ; do i=is,ie - forces%tauy(i,J) = 0.5 * CS%wind_scale * (temp_y(i,j) + temp_y(i,j+1)) - enddo ; enddo - - if (CS%read_gust_2d) then - do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt(US%L_to_Z * (CS%gust(i,j) + & - sqrt(temp_x(i,j)*temp_x(i,j) + temp_y(i,j)*temp_y(i,j)) ) / CS%Rho0) - enddo ; enddo - else - do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt(US%L_to_Z * (CS%gust_const/CS%Rho0 + & - sqrt(temp_x(i,j)*temp_x(i,j) + temp_y(i,j)*temp_y(i,j)) / CS%Rho0) ) - enddo ; enddo - endif - case ("C") - call MOM_read_vector(filename,CS%stress_x_var, CS%stress_y_var, & - forces%taux(:,:), forces%tauy(:,:), & - G%Domain, timelevel=time_lev, & - scale=Pa_conversion) - if (CS%wind_scale /= 1.0) then - do j=js,je ; do I=Isq,Ieq - forces%taux(I,j) = CS%wind_scale * forces%taux(I,j) - enddo ; enddo - do J=Jsq,Jeq ; do i=is,ie - forces%tauy(i,J) = CS%wind_scale * forces%tauy(i,J) - enddo ; enddo - endif - - 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( (CS%gust(i,j) + & - 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)))) * US%L_to_Z / CS%Rho0 ) - enddo ; enddo - else - do j=js, je ; do i=is, ie - forces%ustar(i,j) = sqrt(US%L_to_Z * (CS%gust_const/CS%Rho0 + & - 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) ) - enddo ; enddo - endif - case default - call MOM_error(FATAL, "wind_forcing_from_file: Unrecognized stagger "//& - trim(CS%wind_stagger)//" is not 'A' or 'C'.") - end select - CS%wind_last_lev_read = time_lev - endif ! time_lev /= CS%wind_last_lev_read - - call callTree_leave("wind_forcing_from_file") -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, US, CS) - 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 !< Time used for determining 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(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 :: rhoXcp ! mean density times the heat capacity [Q R degC-1 ~> 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 - ! be reset, depending on the time. - integer :: time_lev_monthly ! With fields from a file, this must - ! be reset, depending on the time. - integer :: days, seconds - 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 [degC]. - SSS_anom, & ! Instantaneous sea surface salinity anomalies from a target - ! (observed) value [ppt]. - SSS_mean ! A (mean?) salinity about which to normalize local salinity - ! anomalies when calculating restorative precipitation - ! anomalies [ppt]. - - call callTree_enter("buoyancy_forcing_from_files, MOM_surface_forcing.F90") - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - - ! allocate and initialize arrays - call buoyancy_forcing_allocate(fluxes, G, CS) - - if (CS%use_temperature) rhoXcp = CS%Rho0 * fluxes%C_p - Irho0 = 1.0/(US%R_to_kg_m3*CS%Rho0) - - ! Read the file containing the buoyancy forcing. - call get_time(day,seconds,days) - - time_lev = days - 365*floor(real(days) / 365.0) - - if (time_lev < 31) then ; time_lev_monthly = 0 - else if (time_lev < 59) then ; time_lev_monthly = 1 - else if (time_lev < 90) then ; time_lev_monthly = 2 - else if (time_lev < 120) then ; time_lev_monthly = 3 - else if (time_lev < 151) then ; time_lev_monthly = 4 - else if (time_lev < 181) then ; time_lev_monthly = 5 - else if (time_lev < 212) then ; time_lev_monthly = 6 - else if (time_lev < 243) then ; time_lev_monthly = 7 - else if (time_lev < 273) then ; time_lev_monthly = 8 - else if (time_lev < 304) then ; time_lev_monthly = 9 - else if (time_lev < 334) then ; time_lev_monthly = 10 - else ; time_lev_monthly = 11 - endif - - time_lev = time_lev+1 - time_lev_monthly = time_lev_monthly+1 - - if (time_lev /= CS%buoy_last_lev_read) then - -! if (is_root_pe()) & -! write(*,'("buoyancy_forcing : Reading time level ",I3,", last was ",I3,".")')& -! time_lev,CS%buoy_last_lev_read - - - call MOM_read_data(trim(CS%inputdir)//trim(CS%longwavedown_file), "lwdn_sfc", & - fluxes%LW(:,:), G%Domain, timelevel=time_lev, scale=US%W_m2_to_QRZ_T) - call MOM_read_data(trim(CS%inputdir)//trim(CS%longwaveup_file), "lwup_sfc", & - temp(:,:), G%Domain, timelevel=time_lev, scale=US%W_m2_to_QRZ_T) - do j=js,je ; do i=is,ie ; fluxes%LW(i,j) = fluxes%LW(i,j) - temp(i,j) ; enddo ; enddo - - call MOM_read_data(trim(CS%inputdir)//trim(CS%evaporation_file), "evap", & - fluxes%evap(:,:), G%Domain, timelevel=time_lev, scale=-US%kg_m2s_to_RZ_T) - do j=js,je ; do i=is,ie - fluxes%latent(i,j) = CS%latent_heat_vapor*fluxes%evap(i,j) - fluxes%latent_evap_diag(i,j) = fluxes%latent(i,j) - enddo ; enddo - - call MOM_read_data(trim(CS%inputdir)//trim(CS%sensibleheat_file), "shflx", & - fluxes%sens(:,:), G%Domain, timelevel=time_lev, scale=-US%W_m2_to_QRZ_T) - - call MOM_read_data(trim(CS%inputdir)//trim(CS%shortwavedown_file), "swdn_sfc", & - fluxes%sw(:,:), G%Domain, timelevel=time_lev, scale=US%W_m2_to_QRZ_T) - call MOM_read_data(trim(CS%inputdir)//trim(CS%shortwaveup_file), "swup_sfc", & - temp(:,:), G%Domain, timelevel=time_lev, scale=US%W_m2_to_QRZ_T) - do j=js,je ; do i=is,ie - fluxes%sw(i,j) = fluxes%sw(i,j) - temp(i,j) - enddo ; enddo - - call MOM_read_data(trim(CS%inputdir)//trim(CS%snow_file), "snow", & - fluxes%fprec(:,:), G%Domain, timelevel=time_lev, scale=US%kg_m2s_to_RZ_T) - call MOM_read_data(trim(CS%inputdir)//trim(CS%precip_file), "precip", & - fluxes%lprec(:,:), G%Domain, timelevel=time_lev, scale=US%kg_m2s_to_RZ_T) - do j=js,je ; do i=is,ie - fluxes%lprec(i,j) = fluxes%lprec(i,j) - fluxes%fprec(i,j) - enddo ; enddo - - call MOM_read_data(trim(CS%inputdir)//trim(CS%freshdischarge_file), "disch_w", & - temp(:,:), G%Domain, timelevel=time_lev_monthly, scale=US%kg_m2s_to_RZ_T) - do j=js,je ; do i=is,ie - fluxes%lrunoff(i,j) = temp(i,j)*US%m_to_L**2*G%IareaT(i,j) - enddo ; enddo - call MOM_read_data(trim(CS%inputdir)//trim(CS%freshdischarge_file), "disch_s", & - temp(:,:), G%Domain, timelevel=time_lev_monthly, scale=US%kg_m2s_to_RZ_T) - do j=js,je ; do i=is,ie - fluxes%frunoff(i,j) = temp(i,j)*US%m_to_L**2*G%IareaT(i,j) - enddo ; enddo - -! Read the SST and SSS fields for damping. - if (CS%restorebuoy) then - call MOM_read_data(trim(CS%inputdir)//trim(CS%SSTrestore_file), "TEMP", & - CS%T_Restore(:,:), G%Domain, timelevel=time_lev_monthly) - call MOM_read_data(trim(CS%inputdir)//trim(CS%salinityrestore_file), "SALT", & - CS%S_Restore(:,:), G%Domain, timelevel=time_lev_monthly) - endif - CS%buoy_last_lev_read = time_lev - - ! mask out land points and compute heat content of water fluxes - ! assume liquid precip enters ocean at SST - ! assume frozen precip enters ocean at 0degC - ! assume liquid runoff enters ocean at SST - ! assume solid runoff (calving) enters ocean at 0degC - do j=js,je ; do i=is,ie - fluxes%evap(i,j) = fluxes%evap(i,j) * G%mask2dT(i,j) - fluxes%lprec(i,j) = fluxes%lprec(i,j) * G%mask2dT(i,j) - fluxes%fprec(i,j) = fluxes%fprec(i,j) * G%mask2dT(i,j) - fluxes%lrunoff(i,j) = fluxes%lrunoff(i,j) * G%mask2dT(i,j) - fluxes%frunoff(i,j) = fluxes%frunoff(i,j) * G%mask2dT(i,j) - fluxes%LW(i,j) = fluxes%LW(i,j) * G%mask2dT(i,j) - fluxes%sens(i,j) = fluxes%sens(i,j) * G%mask2dT(i,j) - fluxes%sw(i,j) = fluxes%sw(i,j) * G%mask2dT(i,j) - fluxes%latent(i,j) = fluxes%latent(i,j) * G%mask2dT(i,j) - - fluxes%heat_content_lrunoff(i,j) = fluxes%C_p * fluxes%lrunoff(i,j)*sfc_state%SST(i,j) - fluxes%latent_evap_diag(i,j) = fluxes%latent_evap_diag(i,j) * G%mask2dT(i,j) - fluxes%latent_fprec_diag(i,j) = -fluxes%fprec(i,j)*CS%latent_heat_fusion - fluxes%latent_frunoff_diag(i,j) = -fluxes%frunoff(i,j)*CS%latent_heat_fusion - enddo ; enddo - - endif ! time_lev /= CS%buoy_last_lev_read - - if (CS%restorebuoy) then - if (CS%use_temperature) then - do j=js,je ; do i=is,ie - 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) - fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const) * & - (CS%S_Restore(i,j) - sfc_state%SSS(i,j)) / & - (0.5*(sfc_state%SSS(i,j) + CS%S_Restore(i,j))) - else - fluxes%heat_added(i,j) = 0.0 - fluxes%vprec(i,j) = 0.0 - endif - enddo ; enddo - else - do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0) then - fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & - (CS%G_Earth * CS%Flux_const / CS%Rho0) - else - fluxes%buoy(i,j) = 0.0 - endif - enddo ; enddo - endif - else ! not RESTOREBUOY - if (.not.CS%use_temperature) then - call MOM_error(FATAL, "buoyancy_forcing in MOM_surface_forcing: "// & - "The fluxes need to be defined without RESTOREBUOY.") - endif - endif ! end RESTOREBUOY - - call callTree_leave("buoyancy_forcing_from_files") -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 !< 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 [s] - 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 - - integer :: i, j, is, ie, js, je - - call callTree_enter("buoyancy_forcing_zero, MOM_surface_forcing.F90") - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - - ! allocate and initialize arrays - call buoyancy_forcing_allocate(fluxes, G, CS) - - if (CS%use_temperature) then - do j=js,je ; do i=is,ie - fluxes%evap(i,j) = 0.0 - fluxes%lprec(i,j) = 0.0 - fluxes%fprec(i,j) = 0.0 - fluxes%lrunoff(i,j) = 0.0 - fluxes%frunoff(i,j) = 0.0 - fluxes%lw(i,j) = 0.0 - fluxes%latent(i,j) = 0.0 - fluxes%sens(i,j) = 0.0 - fluxes%sw(i,j) = 0.0 - fluxes%heat_content_lrunoff(i,j) = 0.0 - fluxes%latent_evap_diag(i,j) = 0.0 - fluxes%latent_fprec_diag(i,j) = 0.0 - fluxes%latent_frunoff_diag(i,j) = 0.0 - enddo ; enddo - else - do j=js,je ; do i=is,ie - fluxes%buoy(i,j) = 0.0 - enddo ; enddo - endif - - 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, US, CS) - 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 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(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 :: y, T_restore, S_restore - integer :: i, j, is, ie, js, je - - call callTree_enter("buoyancy_forcing_linear, MOM_surface_forcing.F90") - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - - ! allocate and initialize arrays - call buoyancy_forcing_allocate(fluxes, G, CS) - - ! This case has no surface buoyancy forcing. - if (CS%use_temperature) then - do j=js,je ; do i=is,ie - fluxes%evap(i,j) = 0.0 - fluxes%lprec(i,j) = 0.0 - fluxes%fprec(i,j) = 0.0 - fluxes%lrunoff(i,j) = 0.0 - fluxes%frunoff(i,j) = 0.0 - fluxes%lw(i,j) = 0.0 - fluxes%latent(i,j) = 0.0 - fluxes%sens(i,j) = 0.0 - fluxes%sw(i,j) = 0.0 - fluxes%heat_content_lrunoff(i,j) = 0.0 - fluxes%latent_evap_diag(i,j) = 0.0 - fluxes%latent_fprec_diag(i,j) = 0.0 - fluxes%latent_frunoff_diag(i,j) = 0.0 - enddo ; enddo - else - do j=js,je ; do i=is,ie - fluxes%buoy(i,j) = 0.0 - enddo ; enddo - endif - - if (CS%restorebuoy) then - if (CS%use_temperature) then - do j=js,je ; do i=is,ie - y = (G%geoLatCu(I,j)-CS%South_lat)/CS%len_lat - T_restore = CS%T_south + (CS%T_north-CS%T_south)*y - S_restore = CS%S_south + (CS%S_north-CS%S_south)*y - if (G%mask2dT(i,j) > 0) then - fluxes%heat_added(i,j) = G%mask2dT(i,j) * & - ((T_Restore - sfc_state%SST(i,j)) * ((CS%Rho0 * fluxes%C_p) * CS%Flux_const)) - fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const) * & - (S_Restore - sfc_state%SSS(i,j)) / & - (0.5*(sfc_state%SSS(i,j) + S_Restore)) - else - fluxes%heat_added(i,j) = 0.0 - fluxes%vprec(i,j) = 0.0 - endif - enddo ; enddo - else - call MOM_error(FATAL, "buoyancy_forcing_linear in MOM_surface_forcing: "// & - "RESTOREBUOY to linear not written yet.") - !do j=js,je ; do i=is,ie - ! if (G%mask2dT(i,j) > 0) then - ! fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & - ! (CS%G_Earth * CS%Flux_const / CS%Rho0) - ! else - ! fluxes%buoy(i,j) = 0.0 - ! endif - !enddo ; enddo - endif - else ! not RESTOREBUOY - if (.not.CS%use_temperature) then - call MOM_error(FATAL, "buoyancy_forcing_linear in MOM_surface_forcing: "// & - "The fluxes need to be defined without RESTOREBUOY.") - endif - endif ! end RESTOREBUOY - - 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 !< 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 !< 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 - - call save_restart(directory, Time, 1, G, CS%restart_CSp, time_stamped) - -end subroutine forcing_save_restart - -!> 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 !< 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 -! This include declares and sets the variable "version". -#include "version_variable.h" - character(len=40) :: mdl = "MOM_surface_forcing" ! This module's name. - character(len=60) :: axis_units - character(len=200) :: filename, gust_file ! The name of the gustiness input file. - - 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_MODULE) - call cpu_clock_begin(id_clock_forcing) - - CS%diag => diag - if (associated(tracer_flow_CSp)) CS%tracer_flow_CSp => tracer_flow_CSp - - ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "") - call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & - "If true, Temperature and salinity are used as state "//& - "variables.", default=.true.) - call get_param(param_file, mdl, "INPUTDIR", CS%inputdir, & - "The directory in which all input files are found.", & - default=".") - CS%inputdir = slasher(CS%inputdir) - - call get_param(param_file, mdl, "ADIABATIC", CS%adiabatic, & - "There are no diapycnal mass fluxes if ADIABATIC is "//& - "true. This assumes that KD = KDML = 0.0 and that "//& - "there is no buoyancy forcing, but makes the model "//& - "faster by eliminating subroutine calls.", default=.false.) - call get_param(param_file, mdl, "VARIABLE_WINDS", CS%variable_winds, & - "If true, the winds vary in time after the initialization.", & - default=.true.) - call get_param(param_file, mdl, "VARIABLE_BUOYFORCE", CS%variable_buoyforce, & - "If true, the buoyancy forcing varies in time after the "//& - "initialization of the model.", default=.true.) - - call get_param(param_file, mdl, "BUOY_CONFIG", CS%buoy_config, & - "The character string that indicates how buoyancy forcing "//& - "is specified. Valid options include (file), (zero), "//& - "(linear), (USER), and (NONE).", default="zero") - if (trim(CS%buoy_config) == "file") then - call get_param(param_file, mdl, "LONGWAVEDOWN_FILE", CS%longwavedown_file, & - "The file with the downward longwave heat flux, in "//& - "variable lwdn_sfc.", fail_if_missing=.true.) - call get_param(param_file, mdl, "LONGWAVEUP_FILE", CS%longwaveup_file, & - "The file with the upward longwave heat flux, in "//& - "variable lwup_sfc.", fail_if_missing=.true.) - call get_param(param_file, mdl, "EVAPORATION_FILE", CS%evaporation_file, & - "The file with the evaporative moisture flux, in "//& - "variable evap.", fail_if_missing=.true.) - call get_param(param_file, mdl, "SENSIBLEHEAT_FILE", CS%sensibleheat_file, & - "The file with the sensible heat flux, in "//& - "variable shflx.", fail_if_missing=.true.) - call get_param(param_file, mdl, "SHORTWAVEUP_FILE", CS%shortwaveup_file, & - "The file with the upward shortwave heat flux.", & - fail_if_missing=.true.) - call get_param(param_file, mdl, "SHORTWAVEDOWN_FILE", CS%shortwavedown_file, & - "The file with the downward shortwave heat flux.", & - fail_if_missing=.true.) - call get_param(param_file, mdl, "SNOW_FILE", CS%snow_file, & - "The file with the downward frozen precip flux, in "//& - "variable snow.", fail_if_missing=.true.) - call get_param(param_file, mdl, "PRECIP_FILE", CS%precip_file, & - "The file with the downward total precip flux, in "//& - "variable precip.", fail_if_missing=.true.) - call get_param(param_file, mdl, "FRESHDISCHARGE_FILE", CS%freshdischarge_file, & - "The file with the fresh and frozen runoff/calving fluxes, "//& - "invariables disch_w and disch_s.", fail_if_missing=.true.) - call get_param(param_file, mdl, "SSTRESTORE_FILE", CS%SSTrestore_file, & - "The file with the SST toward which to restore in "//& - "variable TEMP.", fail_if_missing=.true.) - call get_param(param_file, mdl, "SALINITYRESTORE_FILE", CS%salinityrestore_file, & - "The file with the surface salinity toward which to "//& - "restore in variable SALT.", fail_if_missing=.true.) - endif - call get_param(param_file, mdl, "WIND_CONFIG", CS%wind_config, & - "The character string that indicates how wind forcing "//& - "is specified. Valid options include (file), (2gyre), "//& - "(1gyre), (gyres), (zero), and (USER).", default="zero") - if (trim(CS%wind_config) == "file") then - call get_param(param_file, mdl, "WIND_FILE", CS%wind_file, & - "The file in which the wind stresses are found in "//& - "variables STRESS_X and STRESS_Y.", fail_if_missing=.true.) - call get_param(param_file, mdl, "WINDSTRESS_X_VAR",CS%stress_x_var, & - "The name of the x-wind stress variable in WIND_FILE.", & - default="STRESS_X") - call get_param(param_file, mdl, "WINDSTRESS_Y_VAR", CS%stress_y_var, & - "The name of the y-wind stress variable in WIND_FILE.", & - default="STRESS_Y") - call get_param(param_file, mdl, "WIND_STAGGER",CS%wind_stagger, & - "A character indicating how the wind stress components "//& - "are staggered in WIND_FILE. This may be A or C for now.", & - default="C") - call get_param(param_file, mdl, "WINDSTRESS_SCALE", CS%wind_scale, & - "A value by which the wind stresses in WIND_FILE are rescaled.", & - default=1.0, units="nondim") - endif - if (trim(CS%wind_config) == "gyres") then - call get_param(param_file, mdl, "TAUX_CONST", CS%gyres_taux_const, & - "With the gyres wind_config, the constant offset in the "//& - "zonal wind stress profile: "//& - " A in taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L).", & - units="Pa", default=0.0) - call get_param(param_file, mdl, "TAUX_SIN_AMP",CS%gyres_taux_sin_amp, & - "With the gyres wind_config, the sine amplitude in the "//& - "zonal wind stress profile: "//& - " B in taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L).", & - units="Pa", default=0.0) - call get_param(param_file, mdl, "TAUX_COS_AMP",CS%gyres_taux_cos_amp, & - "With the gyres wind_config, the cosine amplitude in "//& - "the zonal wind stress profile: "//& - " C in taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L).", & - units="Pa", default=0.0) - call get_param(param_file, mdl, "TAUX_N_PIS",CS%gyres_taux_n_pis, & - "With the gyres wind_config, the number of gyres in "//& - "the zonal wind stress profile: "//& - " n in taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L).", & - units="nondim", default=0.0) - endif - call get_param(param_file, mdl, "SOUTHLAT", CS%south_lat, & - "The southern latitude of the domain or the equivalent "//& - "starting value for the y-axis.", units=axis_units, default=0.) - call get_param(param_file, mdl, "LENLAT", CS%len_lat, & - "The latitudinal or y-direction length of the domain.", & - units=axis_units, fail_if_missing=.true.) - call get_param(param_file, mdl, "RHO_0", CS%Rho0, & - "The mean ocean density used with BOUSSINESQ true to "//& - "calculate accelerations and the mass for conservation "//& - "properties, or with BOUSSINSEQ false to convert some "//& - "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) - call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & - "If true, the buoyancy fluxes drive the model back "//& - "toward some specified surface state with a rate "//& - "given by FLUXCONST.", default= .false.) - call get_param(param_file, mdl, "LATENT_HEAT_FUSION", CS%latent_heat_fusion, & - "The latent heat of fusion.", default=hlf, & - units="J/kg", scale=US%J_kg_to_Q) - call get_param(param_file, mdl, "LATENT_HEAT_VAPORIZATION", CS%latent_heat_vapor, & - "The latent heat of fusion.", default=hlv, units="J/kg", scale=US%J_kg_to_Q) - if (CS%restorebuoy) then - call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & - "The constant that relates the restoring surface fluxes to the relative "//& - "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & - default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0) - if (trim(CS%buoy_config) == "linear") then - call get_param(param_file, mdl, "SST_NORTH", CS%T_north, & - "With buoy_config linear, the sea surface temperature "//& - "at the northern end of the domain toward which to "//& - "to restore.", units="deg C", default=0.0) - call get_param(param_file, mdl, "SST_SOUTH", CS%T_south, & - "With buoy_config linear, the sea surface temperature "//& - "at the southern end of the domain toward which to "//& - "to restore.", units="deg C", default=0.0) - call get_param(param_file, mdl, "SSS_NORTH", CS%S_north, & - "With buoy_config linear, the sea surface salinity "//& - "at the northern end of the domain toward which to "//& - "to restore.", units="PSU", default=35.0) - call get_param(param_file, mdl, "SSS_SOUTH", CS%S_south, & - "With buoy_config linear, the sea surface salinity "//& - "at the southern end of the domain toward which to "//& - "to restore.", units="PSU", default=35.0) - endif - endif - call get_param(param_file, mdl, "G_EARTH", CS%G_Earth, & - "The gravitational acceleration of the Earth.", & - units="m s-2", default = 9.80, scale=US%m_to_L**2*US%Z_to_m*US%T_to_s**2) - - call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & - "The background gustiness in the winds.", & - units="Pa", default=0.0, scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) - call get_param(param_file, mdl, "READ_GUST_2D", CS%read_gust_2d, & - "If true, use a 2-dimensional gustiness supplied from "//& - "an input file", default=.false.) - if (CS%read_gust_2d) then - call get_param(param_file, mdl, "GUST_2D_FILE", gust_file, & - "The file in which the wind gustiness is found in "//& - "variable gustiness.", fail_if_missing=.true.) - call safe_alloc_ptr(CS%gust,G%isd,G%ied,G%jsd,G%jed) ; CS%gust(:,:) = 0.0 - filename = trim(CS%inputdir) // trim(gust_file) - call MOM_read_data(filename,'gustiness',CS%gust,G%domain, timelevel=1, & - scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) ! units in file should be Pa - endif - call get_param(param_file, mdl, "AXIS_UNITS", axis_units, default="degrees") - -! All parameter settings are now known. - - if (trim(CS%wind_config) == "USER" .or. trim(CS%buoy_config) == "USER" ) then - call USER_surface_forcing_init(Time, G, param_file, diag, CS%user_forcing_CSp) - elseif (trim(CS%wind_config) == "MESO" .or. trim(CS%buoy_config) == "MESO" ) then - call MOM_error(FATAL, "MESO forcing is not available with the ice-shelf"//& - "version of MOM_surface_forcing.") - endif - - 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") - 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 user_revise_forcing_init(param_file, CS%urf_CS) - - 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 !< 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) - - if (associated(CS)) deallocate(CS) - CS => NULL() - -end subroutine surface_forcing_end - -end module MOM_surface_forcing diff --git a/config_src/ice_solo_driver/ice_shelf_driver.F90 b/config_src/ice_solo_driver/ice_shelf_driver.F90 index f2c5099544..9113b60c64 100644 --- a/config_src/ice_solo_driver/ice_shelf_driver.F90 +++ b/config_src/ice_solo_driver/ice_shelf_driver.F90 @@ -1,4 +1,4 @@ -program SHELF_main +program Shelf_main ! This file is part of MOM6. See LICENSE.md for the license. @@ -21,92 +21,104 @@ program SHELF_main !* * !********+*********+*********+*********+*********+*********+*********+** - use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end - use MOM_cpu_clock, only : CLOCK_COMPONENT - use MOM_diag_mediator, only : enable_averaging, disable_averaging, diag_mediator_end - use MOM_diag_mediator, only : diag_mediator_close_registration, diag_mediator_end - use MOM_domains, only : MOM_infra_init, MOM_infra_end - use MOM_error_handler, only : MOM_error, MOM_mesg, WARNING, FATAL, is_root_pe - use MOM_file_parser, only : get_param, log_param, log_version, param_file_type - use MOM_file_parser, only : close_param_file -! use MOM_grid, only : ocean_grid_type - use MOM_get_input, only : Get_MOM_Input, directories - use MOM_io, only : file_exists, open_file, close_file - use MOM_io, only : check_nml_error, io_infra_init, io_infra_end - use MOM_io, only : APPEND_FILE, ASCII_FILE, READONLY_FILE, SINGLE_FILE - use MOM_restart, only : save_restart -! use MOM_sum_output, only : write_energy, accumulate_net_input -! use MOM_sum_output, only : MOM_sum_output_init, sum_output_CS - use MOM_string_functions, only : uppercase -! use MOM_surface_forcing, only : set_forcing, average_forcing -! 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 : 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_write_cputime, only : write_cputime, MOM_write_cputime_init - use MOM_write_cputime, only : write_cputime_start_clock, write_cputime_CS + use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end + use MOM_cpu_clock, only : CLOCK_COMPONENT + use MOM_debugging, only : MOM_debugging_init + use MOM_diag_mediator, only : diag_mediator_init, diag_mediator_infrastructure_init + use MOM_diag_mediator, only : enable_averaging, disable_averaging, diag_mediator_end + use MOM_diag_mediator, only : diag_ctrl, diag_mediator_close_registration + use MOM_domains, only : MOM_infra_init, MOM_infra_end + use MOM_domains, only : MOM_domains_init, clone_MOM_domain, pass_var + use MOM_dyn_horgrid, only : dyn_horgrid_type, create_dyn_horgrid, destroy_dyn_horgrid + use MOM_error_handler, only : MOM_error, MOM_mesg, WARNING, FATAL, is_root_pe + use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint + use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type + use MOM_file_parser, only : close_param_file + use MOM_fixed_initialization, only : MOM_initialize_fixed + use MOM_get_input, only : Get_MOM_Input, directories + use MOM_grid, only : ocean_grid_type, MOM_grid_init, MOM_grid_end + use MOM_hor_index, only : hor_index_type, hor_index_init + use MOM_io, only : MOM_io_init, file_exists, open_file, close_file + use MOM_io, only : check_nml_error, io_infra_init, io_infra_end + use MOM_io, only : APPEND_FILE, ASCII_FILE, READONLY_FILE, SINGLE_FILE + use MOM_open_boundary, only : ocean_OBC_type + use MOM_restart, only : save_restart + use MOM_string_functions,only : uppercase + 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, NO_CALENDAR + 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_verticalGrid, only : verticalGrid_type, verticalGridInit, verticalGridEnd + use MOM_write_cputime, only : write_cputime, MOM_write_cputime_init + use MOM_write_cputime, only : write_cputime_start_clock, write_cputime_CS use MOM_ice_shelf, only : initialize_ice_shelf, ice_shelf_end, ice_shelf_CS use MOM_ice_shelf, only : ice_shelf_save_restart, solo_step_ice_shelf -! , add_shelf_flux_forcing, add_shelf_flux_IOB + implicit none #include - -! type(forcing) :: fluxes ! A structure that will be uninitialized till i figure out - ! whether i can make the argument optional - -! type(ocean_grid_type), pointer :: grid ! A pointer to a structure containing - ! metrics and related information. logical :: use_ice_shelf = .false. ! If .true., use the ice shelf model for ! part of the domain. - logical :: permit_restart = .true. ! This is .true. if incremental restart - ! files may be saved. - integer :: m, n - - integer :: nmax=2000000000; ! nmax is the number of iterations - ! after which to stop so that the - ! simulation does not exceed its CPU - ! time limit. nmax is determined by - ! evaluating the CPU time used between - ! successive calls to write_energy. - ! Initially it is set to be very large. - type(directories) :: dirs ! A structure containing several relevant directory paths. - - type(time_type), target :: Time ! A copy of the model's time. - ! Other modules can set pointers to this and - ! change it to manage diagnostics. - - type(time_type) :: Master_Time ! The ocean model's master clock. No other - ! modules are ever given access to this. - - type(time_type) :: Time1 ! The value of the ocean model's time at the - ! start of a call to step_MOM. - - type(time_type) :: Start_time ! The start time of the simulation. + ! This is .true. if incremental restart files may be saved. + logical :: permit_incr_restart = .true. + + integer :: ns ! Running number of external timesteps. + integer :: ns_ice ! Running number of internal timesteps in solo_step_ice_shelf. + + ! nmax is the number of iterations after which to stop so that the 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 + + ! A structure containing several relevant directory paths. + type(directories) :: dirs + + ! A suite of time types for use by the solo ice model. + type(time_type), target :: Time ! A copy of the model's time. + ! Other modules can set pointers to this and + ! change it to manage diagnostics. + type(time_type) :: Master_Time ! The ocean model's master clock. No other + ! modules are ever given access to this. + type(time_type) :: Time1 ! The value of the ocean model's time at the + ! start of a call to step_MOM. + type(time_type) :: Start_time ! The start time of the simulation. type(time_type) :: segment_start_time ! The start time of this run segment. + type(time_type) :: Time_end ! End time for the segment or experiment. + type(time_type) :: restart_time ! The next time to write restart files. + type(time_type) :: Time_step_shelf ! A time_type version of time_step. + type(time_type) :: time_chg ! An amount of time to adjust the segment_start_time + ! and elapsed time to avoid roundoff problems. - type(time_type) :: Time_end ! End time for the segment or experiment. + real :: elapsed_time = 0.0 ! Elapsed time in this run [s]. - type(time_type) :: restart_time ! The next time to write restart files. - - type(time_type) :: Time_step_shelf ! A time_type version of time_step. + logical :: elapsed_time_master ! If true, elapsed time is used to set the + ! model's master clock (Time). This is needed + ! if Time_step_shelf is not an exact + ! representation of time_step. + real :: time_step ! The time step [s] - real :: elapsed_time = 0.0 ! Elapsed time in this run in seconds. (years?) + ! A pointer to a structure containing metrics and related information. + type(ocean_grid_type), pointer :: ocn_grid - logical :: elapsed_time_master ! If true, elapsed time is used to set the - ! model's master clock (Time). This is needed - ! if Time_step_shelf is not an exact - ! representation of time_step. + type(dyn_horgrid_type), pointer :: dG => NULL() ! A dynamic version of the horizontal grid + type(hor_index_type), pointer :: HI => NULL() ! A hor_index_type for array extents + type(verticalGrid_type), pointer :: GV => NULL() ! Pointer to the ocean vertical grid structure - real :: time_step ! The time step (in years??? seconds???) + !> Pointer to the MOM open boundary condition type + type(ocean_OBC_type), pointer :: OBC => NULL() + ! A pointer to a structure containing dimensional unit scaling factors. + type(unit_scale_type), pointer :: US + type(diag_ctrl), pointer :: & + diag => NULL() ! A pointer to the diagnostic regulatory structure integer :: Restart_control ! An integer that is bit-tested to determine whether ! incremental restart files are saved and whether they @@ -114,41 +126,40 @@ program SHELF_main ! 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. - 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. - integer :: date_init(6)=0 ! The start date of the whole simulation. - integer :: date(6)=-1 ! Possibly the start date of this run segment. + integer :: CPU_steps ! The number of steps between writing CPU time. + integer :: date_init(6)=0 ! The start date of the whole simulation. + integer :: date(6)=-1 ! Possibly the start date of this run segment. integer :: years=0, months=0, days=0 ! These may determine the segment run integer :: hours=0, minutes=0, seconds=0 ! length, if read from a namelist. - integer :: yr, mon, day, hr, min, sec ! Temp variables for writing the date. - type(param_file_type) :: param_file ! The structure indicating the file(s) - ! containing all run-time parameters. - character(len=9) :: month + integer :: yr, mon, day, hr, mins, sec ! Temp variables for writing the date. + type(param_file_type) :: param_file ! The structure indicating the file(s) + ! containing all run-time parameters. + character(len=9) :: month character(len=16) :: calendar = 'julian' integer :: calendar_type=-1 integer :: unit, io_status, ierr - logical :: unit_in_use + logical :: symmetric + logical :: unit_in_use integer :: initClock, mainClock, termClock -! type(ice_shelf_CS), pointer :: MOM_CSp => NULL() -! type(surface_forcing_CS), pointer :: surface_forcing_CSp => NULL() -! type(sum_output_CS), pointer :: sum_output_CSp => NULL() type(write_cputime_CS), pointer :: write_CPU_CSp => NULL() type(ice_shelf_CS), pointer :: ice_shelf_CSp => NULL() !----------------------------------------------------------------------- - character(len=4), parameter :: vers_num = 'v2.0' -! This include declares and sets the variable "version". -#include "version_variable.h" - character(len=40) :: mdl = "SHELF_main (ice_shelf_driver)" ! This module's name. + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mod_name = "SHELF_main (ice_shelf_driver)" ! This module's name. namelist /ice_solo_nml/ date_init, calendar, months, days, hours, minutes, seconds - !======================================================================= + !===================================================================== call write_cputime_start_clock(write_CPU_CSp) @@ -160,15 +171,16 @@ program SHELF_main termClock = cpu_clock_id( 'Termination' ) call cpu_clock_begin(initClock) - call MOM_mesg('======== Model being driven by ice_shelf_driver ========') + call MOM_mesg('======== Model being driven by ice_shelf_driver ========', 2) + call callTree_waypoint("Program Shelf_main, ice_shelf_driver.F90") if (file_exists('input.nml')) then ! Provide for namelist specification of the run length and calendar data. call open_file(unit, 'input.nml', form=ASCII_FILE, action=READONLY_FILE) read(unit, ice_solo_nml, iostat=io_status) call close_file(unit) + ierr = check_nml_error(io_status,'ice_solo_nml') if (years+months+days+hours+minutes+seconds > 0) then - ierr = check_nml_error(io_status,'ice_solo_nml') if (is_root_pe()) write(*,ice_solo_nml) endif endif @@ -184,38 +196,40 @@ program SHELF_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 - call MOM_error(FATAL,'MOM_driver: Invalid namelist value '//trim(calendar)//' for calendar') + 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,'Shelf_driver: Invalid namelist value '//trim(calendar)//' for calendar') else - call MOM_error(FATAL,'MOM_driver: No namelist value for calendar') + call MOM_error(FATAL,'Shelf_driver: No namelist value for calendar') endif endif call set_calendar_type(calendar_type) + if (sum(date_init) > 0) then 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,0) + Start_time = real_to_time(0.0) endif call Get_MOM_Input(param_file, dirs) + ! Determining the internal unit scaling factors for this run. + call unit_scaling_init(param_file, US) ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "") + call log_version(param_file, mod_name, version, "") - call get_param(param_file, mdl, "ICE_SHELF", use_ice_shelf, & + call get_param(param_file, mod_name, "ICE_SHELF", use_ice_shelf, & "If true, call the code to apply an ice shelf model over "//& "some of the domain.", default=.false.) - if (.not.use_ice_shelf) call MOM_error(FATAL, & - "shelf_driver: ICE_SHELF must be defined.") + if (.not.use_ice_shelf) call MOM_error(FATAL, "Shelf_driver: Run stops unless ICE_SHELF is true.") - call get_param(param_file, mdl, "ICE_VELOCITY_TIMESTEP", time_step, & + call get_param(param_file, mod_name, "ICE_VELOCITY_TIMESTEP", time_step, & "The time step for changing forcing, coupling with other "//& "components, or potentially writing certain diagnostics.", & units="s", fail_if_missing=.true.) @@ -224,39 +238,70 @@ program SHELF_main ! In this case, the segment starts at a time fixed by ocean_solo.res segment_start_time = set_date(date(1),date(2),date(3),date(4),date(5),date(6)) Time = segment_start_time - call initialize_ice_shelf (Time, ice_shelf_CSp) else - ! In this case, the segment starts at a time read from the MOM restart file - ! or left as Start_time by MOM_initialize. + ! In this case, the segment starts at Start_time. Time = Start_time - call initialize_ice_shelf (Time, ice_shelf_CSp) endif + + ! This is the start of the code that is the counterpart of MOM_initialization. + call callTree_waypoint("Start of ice shelf initialization.") + + call MOM_debugging_init(param_file) + call diag_mediator_infrastructure_init() + call MOM_io_init(param_file) + + ! Set up the ocean model domain and grid; the ice model grid is set in initialize_ice_shelf, + ! but the grids have strong commonalities in this configuration, and the ocean grid is required + ! to set up the diag mediator control structure. + call MOM_domains_init(ocn_grid%domain, param_file) + call hor_index_init(ocn_grid%Domain, HI, param_file) + call create_dyn_horgrid(dG, HI) + call clone_MOM_domain(ocn_grid%Domain, dG%Domain) + + ! Initialize the ocean grid and topography. + call MOM_initialize_fixed(dG, US, OBC, param_file, .true., dirs%output_directory) + call MOM_grid_init(ocn_grid, param_file, US, HI) + call copy_dyngrid_to_MOM_grid(dG, ocn_grid, US) + call destroy_dyn_horgrid(dG) + + ! Initialize the diag mediator. The ocean's vertical grid is not really used here, but at + ! present the interface to diag_mediator_init assumes the presence of ocean-specific information. + call verticalGridInit(param_file, GV, US) + call diag_mediator_init(ocn_grid, GV, US, GV%ke, param_file, diag, doc_file_dir=dirs%output_directory) + + call callTree_waypoint("returned from diag_mediator_init()") + + call initialize_ice_shelf(param_file, ocn_grid, Time, ice_shelf_CSp, diag) + + ! This is the end of the code that is the counterpart of MOM_initialization. + call callTree_waypoint("End of ice shelf initialization.") + Master_Time = Time ! grid => ice_shelf_CSp%grid segment_start_time = Time elapsed_time = 0.0 - Time_step_shelf = set_time(int(floor(time_step+0.5))) + Time_step_shelf = real_to_time(time_step) elapsed_time_master = (abs(time_step - time_type_to_real(Time_step_shelf)) > 1.0e-12*time_step) if (elapsed_time_master) & - call MOM_mesg("Using real elapsed time for the master clock.") + call MOM_mesg("Using real elapsed time for the master clock.", 2) ! Determine the segment end time, either from the namelist file or parsed input file. - call get_param(param_file, mdl, "TIMEUNIT", Time_unit, & + call get_param(param_file, mod_name, "TIMEUNIT", Time_unit, & "The time unit for DAYMAX and RESTINT.", & units="s", default=86400.0) if (years+months+days+hours+minutes+seconds > 0) then Time_end = increment_date(Time, years, months, days, hours, minutes, seconds) - call MOM_mesg('Segment run length determied from ice_solo_nml.', 2) - call get_param(param_file, mdl, "DAYMAX", daymax, & + call MOM_mesg('Segment run length determined from ice_solo_nml.', 2) + call get_param(param_file, mod_name, "DAYMAX", daymax, & "The final time of the whole simulation, in units of "//& "TIMEUNIT seconds. This also sets the potential end "//& "time of the present run segment if the end time is "//& "not set (as it was here) via ocean_solo_nml in input.nml.", & timeunit=Time_unit, default=Time_end) else - call get_param(param_file, mdl, "DAYMAX", daymax, & + call get_param(param_file, mod_name, "DAYMAX", daymax, & "The final time of the whole simulation, in units of "//& "TIMEUNIT seconds. This also sets the potential end "//& "time of the present run segment if the end time is "//& @@ -265,58 +310,62 @@ 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 (Time >= Time_end) call MOM_error(FATAL, & - "MOM_driver: The run has been started at or after the end time of the run.") + "Shelf_driver: The run has been started at or after the end time of the run.") - call get_param(param_file, mdl, "RESTART_CONTROL", Restart_control, & + call get_param(param_file, mod_name, "RESTART_CONTROL", Restart_control, & "An integer whose bits encode which restart files are "//& "written. Add 2 (bit 1) for a time-stamped file, and odd "//& "(bit 0) for a non-time-stamped file. A non-time-stamped "//& "restart file is saved at the end of the run segment "//& "for any non-negative value.", default=1) - call get_param(param_file, mdl, "RESTINT", restint, & + call get_param(param_file, mod_name, "RESTINT", restint, & "The interval between saves of the restart file in units "//& "of TIMEUNIT. Use 0 (the default) to not save "//& - "incremental restart files at all.", default=set_time(0), & + "incremental restart files at all.", default=real_to_time(0.0), & timeunit=Time_unit) - call log_param(param_file, mdl, "ELAPSED TIME AS MASTER", elapsed_time_master) + call get_param(param_file, mod_name, "WRITE_CPU_STEPS", cpu_steps, & + "The number of coupled timesteps between writing the cpu "//& + "time. If this is not positive, do not check cpu time, and "//& + "the segment run-length can not be set via an elapsed CPU time.", & + default=1000) -! i don't think we'll use this... - call MOM_write_cputime_init(param_file, dirs%output_directory, Start_time, & - write_CPU_CSp) - call MOM_mesg("Done MOM_write_cputime_init.", 5) + call log_param(param_file, mod_name, "ELAPSED TIME AS MASTER", elapsed_time_master) + if (cpu_steps > 0) & + call MOM_write_cputime_init(param_file, dirs%output_directory, Start_time, & + write_CPU_CSp) ! Close the param_file. No further parsing of input is possible after this. call close_param_file(param_file) -! call diag_mediator_close_registration(diag) + call diag_mediator_close_registration(diag) ! Write out a time stamp file. - call open_file(unit, 'time_stamp.out', form=ASCII_FILE, action=APPEND_FILE, & - threading=SINGLE_FILE) - call get_date(Time, date(1), date(2), date(3), date(4), date(5), date(6)) - month = month_name(date(2)) - if (is_root_pe()) write(unit,'(6i4,2x,a3)') date, month(1:3) - call get_date(Time_end, date(1), date(2), date(3), date(4), date(5), date(6)) - month = month_name(date(2)) - if (is_root_pe()) write(unit,'(6i4,2x,a3)') date, month(1:3) - call close_file(unit) - - call write_cputime(Time, 0, nmax, write_CPU_CSp) + if (calendar_type /= NO_CALENDAR) then + call open_file(unit, 'time_stamp.out', form=ASCII_FILE, action=APPEND_FILE, & + threading=SINGLE_FILE) + call get_date(Time, date(1), date(2), date(3), date(4), date(5), date(6)) + month = month_name(date(2)) + if (is_root_pe()) write(unit,'(6i4,2x,a3)') date, month(1:3) + call get_date(Time_end, date(1), date(2), date(3), date(4), date(5), date(6)) + month = month_name(date(2)) + if (is_root_pe()) write(unit,'(6i4,2x,a3)') date, month(1:3) + call close_file(unit) + endif + + if (cpu_steps > 0) call write_cputime(Time, 0, nmax, write_CPU_CSp) if (((.not.BTEST(Restart_control,1)) .and. (.not.BTEST(Restart_control,0))) & - .or. (Restart_control < 0)) permit_restart = .false. + .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) + (1 + ((Time + Time_step_shelf) - Start_time) / restint) else ! Set the time so late that there is no intermediate restart. - restart_time = Time_end + Time_step_ocean - permit_restart = .false. + restart_time = Time_end + Time_step_shelf + permit_incr_restart = .false. endif call cpu_clock_end(initClock) !end initialization @@ -325,66 +374,72 @@ program SHELF_main !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! MAIN LOOP !!!!!!!!!!!!!!!!!!!!!!!!!!!!! - n = 1 ; m = 1 - do while ((n < nmax) .and. (Time < Time_end)) + ns = 1 ; ns_ice = 1 + do while ((ns < nmax) .and. (Time < Time_end)) + call callTree_enter("Main loop, Shelf_driver.F90", ns) ! This call steps the model over a time time_step. Time1 = Master_Time ; Time = Master_Time - call solo_step_ice_shelf(ice_shelf_CSp, Time_step_shelf, m, Time) + call solo_step_ice_shelf(ice_shelf_CSp, Time_step_shelf, ns_ice, Time) -! Time = Time + Time_step_ocean -! This is here to enable fractional-second time steps. +! Time = Time + Time_step_shelf +! This is here to enable fractional-second time steps. elapsed_time = elapsed_time + time_step 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 loose 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_shelf endif Time = Master_Time + if (cpu_steps > 0) then ; if (MOD(ns, cpu_steps) == 0) then + call write_cputime(Time, ns, nmax, write_CPU_CSp) + endif ; endif + ! See if it is time to write out a restart file - timestamped or not. - if (permit_restart) then - if (Time + (Time_step_shelf/2) > restart_time) then - if (BTEST(Restart_control,1)) then - call ice_shelf_save_restart(ice_shelf_CSp, Time, dirs%restart_output_dir, .true.) - endif - if (BTEST(Restart_control,0)) then - call ice_shelf_save_restart(ice_shelf_CSp, Time, dirs%restart_output_dir) - endif - restart_time = restart_time + restint + if ((permit_incr_restart) .and. (Time + (Time_step_shelf/2) > restart_time)) then + if (BTEST(Restart_control,1)) then + call ice_shelf_save_restart(ice_shelf_CSp, Time, dirs%restart_output_dir, .true.) endif + if (BTEST(Restart_control,0)) then + call ice_shelf_save_restart(ice_shelf_CSp, Time, dirs%restart_output_dir) + endif + restart_time = restart_time + restint endif - enddo !!!!!!! end loop + ns = ns + 1 + call callTree_leave("Main loop") + enddo call cpu_clock_end(mainClock) call cpu_clock_begin(termClock) if (Restart_control>=0) then call ice_shelf_save_restart(ice_shelf_CSp, Time, & dirs%restart_output_dir) - ! Write ocean solo restart file. + + ! Write ice shelf solo restart file. call open_file(unit, trim(dirs%restart_output_dir)//'shelf.res', nohdrs=.true.) if (is_root_pe())then write(unit, '(i6,8x,a)') calendar_type, & '(Calendar: no_calendar=0, thirty_day_months=1, julian=2, gregorian=3, noleap=4)' - call get_date(Start_time, yr, mon, day, hr, min, sec) - write(unit, '(6i6,8x,a)') yr, mon, day, hr, min, sec, & + call get_date(Start_time, yr, mon, day, hr, mins, sec) + write(unit, '(6i6,8x,a)') yr, mon, day, hr, mins, sec, & 'Model start time: year, month, day, hour, minute, second' - call get_date(Time, yr, mon, day, hr, min, sec) - write(unit, '(6i6,8x,a)') yr, mon, day, hr, min, sec, & + 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 @@ -402,11 +457,12 @@ program SHELF_main close(unit) endif - call diag_mediator_end(Time, ice_shelf_CSp%diag, end_diag_manager=.true.) + call callTree_waypoint("End Shelf_main") + call diag_mediator_end(Time, diag, end_diag_manager=.true.) call cpu_clock_end(termClock) call io_infra_end ; call MOM_infra_end call ice_shelf_end(ice_shelf_CSp) -end program SHELF_main +end program Shelf_main diff --git a/config_src/ice_solo_driver/user_surface_forcing.F90 b/config_src/ice_solo_driver/user_surface_forcing.F90 deleted file mode 100644 index 64c4b4ce0a..0000000000 --- a/config_src/ice_solo_driver/user_surface_forcing.F90 +++ /dev/null @@ -1,338 +0,0 @@ -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, 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 -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, 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 - ! 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 [R ~> kg m-3]. - real :: G_Earth ! The gravitational acceleration [L2 Z-1 T-2 ~> m s-2]. - real :: Flux_const ! The restoring rate at the surface [Z T-1 ~> m s-1]. - real :: gust_const ! A constant unresolved background gustiness - ! that contributes to ustar [R Z L T-1 ~> 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 - -!> This subroutine sets the surface wind stresses, forces%taux and forces%tauy, in [R Z L T-2 ~> 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 !< The time of 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(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 [R Z L T-2 ~> Pa]. -! In addition, this subroutine can be used to set the surface friction velocity, -! forces%ustar [Z T-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 - - ! 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_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 [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 - ! Change this to the desired expression. - forces%taux(I,j) = G%mask2dCu(I,j) * 0.0*US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z - 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 [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(US%L_to_Z * (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, US, CS) - 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(in) :: G !< The ocean's grid structure - 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 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 [R Z T-1 ~> kg m-2 s-1] and positive for water moving into the ocean. - - 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 [R ~> kg m-3]. - real :: rhoXcp ! The mean density times the heat capacity [Q R degC-1 ~> J m-3 degC-1]. - real :: buoy_rest_const ! A constant relating density anomalies to the - ! restoring buoyancy flux [L2 T-3 R-1 ~> 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 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 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] - ! 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) - - ! vprec will be set later, if it is needed for salinity restoring. - fluxes%vprec(i,j) = 0.0 - - ! Heat fluxes are in units of [Q R Z T-1 ~> 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) - fluxes%sw(i,j) = 0.0 * G%mask2dT(i,j) - 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 [L2 T-3 ~> 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 - endif - - if (CS%restorebuoy) then - if (CS%use_temperature) then - 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: " // & - "Temperature and salinity restoring used without modification." ) - - rhoXcp = CS%Rho0 * fluxes%C_p - do j=js,je ; do i=is,ie - ! 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_added(i,j) = (G%mask2dT(i,j) * (rhoXcp * CS%Flux_const)) * & - (Temp_restore - sfc_state%SST(i,j)) - 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 - else - ! 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: " // & - "Buoyancy restoring used without modification." ) - - ! The -1 is because density has the opposite sign to buoyancy. - 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 [R ~> kg m-3] that is being restored toward. - density_restore = 1030.0*US%kg_m3_to_R - - fluxes%buoy(i,j) = G%mask2dT(i,j) * buoy_rest_const * & - (density_restore - sfc_state%sfc_density(i,j)) - enddo ; enddo - endif - endif ! end RESTOREBUOY - -end subroutine USER_buoyancy_forcing - -!> This subroutine initializes the USER_surface_forcing module -subroutine USER_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(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 - call MOM_error(WARNING, "USER_surface_forcing_init called with an associated "// & - "control structure.") - return - endif - allocate(CS) - CS%diag => diag - - ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "") - call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & - "If true, Temperature and salinity are used as state "//& - "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, scale=US%m_to_L**2*US%Z_to_m*US%T_to_s**2) - call get_param(param_file, mdl, "RHO_0", CS%Rho0, & - "The mean ocean density used with BOUSSINESQ true to "//& - "calculate accelerations and the mass for conservation "//& - "properties, or with BOUSSINSEQ false to convert some "//& - "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0, scale=US%R_to_kg_m3) - call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & - "The background gustiness in the winds.", & - units="Pa", default=0.0, scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) - - call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & - "If true, the buoyancy fluxes drive the model back "//& - "toward some specified surface state with a rate "//& - "given by FLUXCONST.", default= .false.) - if (CS%restorebuoy) then - call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & - "The constant that relates the restoring surface fluxes to the relative "//& - "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & - default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0) - endif - -end subroutine USER_surface_forcing_init - -end module user_surface_forcing From f5df25d23ef2913eb16e6a81de9609a878af0ca0 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Mon, 20 Jul 2020 10:54:12 -0400 Subject: [PATCH 72/91] Move FMS tag to 2019.01.03 - FMS tag 2019.01.03 fixes problems for EMC allowing the newer FV3 to work with MOM6 which is not yet compatible with FMS2020. --- .testing/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.testing/Makefile b/.testing/Makefile index bc03358649..d1ceb16577 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -20,7 +20,7 @@ MKMF := $(abspath $(DEPS)/mkmf/bin/mkmf) # FMS framework FMS_URL ?= https://github.com/NOAA-GFDL/FMS.git -FMS_COMMIT ?= 2019.01.02 +FMS_COMMIT ?= 2019.01.03 FMS := $(DEPS)/fms #--- From 535b43ca3bac44215dfa9251817fd5d6f8306573 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 22 Jul 2020 11:03:12 -0400 Subject: [PATCH 73/91] Avoid using uninitialized arrays Modified recent additions to avoid using uninitialized arrays. This was not detected in tests of the previous PR because the arrays that were created from uninitialized arrays were themselves never used, so there are no answer changes but there were errors with intolerant compiler settings. Also corrected the dOxygen syntax in a comment and corrected some openMP directives that had been triggering warnings or errors. All answers are bitwise identical. --- src/core/MOM_CoriolisAdv.F90 | 2 +- src/core/MOM_barotropic.F90 | 58 +++++++++++-------- .../vertical/MOM_vert_friction.F90 | 4 +- 3 files changed, 38 insertions(+), 26 deletions(-) diff --git a/src/core/MOM_CoriolisAdv.F90 b/src/core/MOM_CoriolisAdv.F90 index 2f96839ed5..f470338c4e 100644 --- a/src/core/MOM_CoriolisAdv.F90 +++ b/src/core/MOM_CoriolisAdv.F90 @@ -256,7 +256,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) enddo ; enddo !$OMP parallel do default(private) shared(u,v,h,uh,vh,CAu,CAv,G,CS,AD,Area_h,Area_q,& - !$OMP RV,PV,is,ie,js,je,Isq,Ieq,Jsq,Jeq,nz,h_neglect,h_tiny,OBC) + !$OMP RV,PV,is,ie,js,je,Isq,Ieq,Jsq,Jeq,nz,h_neglect,h_tiny,OBC,eps_vel) do k=1,nz ! Here the second order accurate layer potential vorticities, q, diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 9e62e84f3b..7f34f18998 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -1156,16 +1156,27 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif ! Calculate the initial barotropic velocities from the layer's velocities. - !$OMP parallel do default(shared) - do j=jsvf-1,jevf+1 ; do I=isvf-2,ievf+1 - ubt(I,j) = 0.0 ; uhbt(I,j) = 0.0 ; u_accel_bt(I,j) = 0.0 - ubt_int(I,j) = 0.0 ; uhbt_int(I,j) = 0.0 - enddo ; enddo - !$OMP parallel do default(shared) - do J=jsvf-2,jevf+1 ; do i=isvf-1,ievf+1 - vbt(i,J) = 0.0 ; vhbt(i,J) = 0.0 ; v_accel_bt(i,J) = 0.0 - vbt_int(i,J) = 0.0 ; vhbt_int(i,J) = 0.0 - enddo ; enddo + if (integral_BT_cont) then + !$OMP parallel do default(shared) + do j=jsvf-1,jevf+1 ; do I=isvf-2,ievf+1 + ubt(I,j) = 0.0 ; uhbt(I,j) = 0.0 ; u_accel_bt(I,j) = 0.0 + ubt_int(I,j) = 0.0 ; uhbt_int(I,j) = 0.0 + enddo ; enddo + !$OMP parallel do default(shared) + do J=jsvf-2,jevf+1 ; do i=isvf-1,ievf+1 + vbt(i,J) = 0.0 ; vhbt(i,J) = 0.0 ; v_accel_bt(i,J) = 0.0 + vbt_int(i,J) = 0.0 ; vhbt_int(i,J) = 0.0 + enddo ; enddo + else + !$OMP parallel do default(shared) + do j=jsvf-1,jevf+1 ; do I=isvf-2,ievf+1 + ubt(I,j) = 0.0 ; uhbt(I,j) = 0.0 ; u_accel_bt(I,j) = 0.0 + enddo ; enddo + !$OMP parallel do default(shared) + do J=jsvf-2,jevf+1 ; do i=isvf-1,ievf+1 + vbt(i,J) = 0.0 ; vhbt(i,J) = 0.0 ; v_accel_bt(i,J) = 0.0 + enddo ; enddo + endif !$OMP parallel do default(shared) do j=js,je ; do k=1,nz ; do I=is-1,ie ubt(I,j) = ubt(I,j) + wt_u(I,j,k) * U_in(I,j,k) @@ -2203,20 +2214,24 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (OBC%segnum_u(I,j) /= OBC_NONE) then ! Update the summed and integrated quantities from the saved previous values. ubt_sum(I,j) = ubt_sum_prev(I,j) + wt_trans(n) * ubt_trans(I,j) - ubt_int(I,j) = ubt_int_prev(I,j) + dtbt * ubt_trans(I,j) uhbt_sum(I,j) = uhbt_sum_prev(I,j) + wt_trans(n) * uhbt(I,j) - uhbt_int(I,j) = uhbt_int_prev(I,j) + dtbt * uhbt(I,j) ubt_wtd(I,j) = ubt_wtd_prev(I,j) + wt_vel(n) * ubt(I,j) + if (integral_BT_cont) then + uhbt_int(I,j) = uhbt_int_prev(I,j) + dtbt * uhbt(I,j) + ubt_int(I,j) = ubt_int_prev(I,j) + dtbt * ubt_trans(I,j) + endif endif enddo ; enddo ; endif if (CS%BT_OBC%apply_v_OBCs) then ; do J=js-1,je ; do i=is,ie if (OBC%segnum_v(i,J) /= OBC_NONE) then ! Update the summed and integrated quantities from the saved previous values. vbt_sum(i,J) = vbt_sum_prev(i,J) + wt_trans(n) * vbt_trans(i,J) - vbt_int(i,J) = vbt_int_prev(i,J) + dtbt * vbt_trans(i,J) vhbt_sum(i,J) = vhbt_sum_prev(i,J) + wt_trans(n) * vhbt(i,J) - vhbt_int(i,J) = vhbt_int_prev(i,J) + dtbt * vhbt(i,J) vbt_wtd(i,J) = vbt_wtd_prev(i,J) + wt_vel(n) * vbt(i,J) + if (integral_BT_cont) then + vbt_int(i,J) = vbt_int_prev(i,J) + dtbt * vbt_trans(i,J) + vhbt_int(i,J) = vhbt_int_prev(i,J) + dtbt * vhbt(i,J) + endif endif enddo ; enddo ; endif endif @@ -2731,7 +2746,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, !! in determining the transport. logical, intent(in) :: use_BT_cont !< If true, use the BT_cont_types to calculate !! transports. - logical, intent(in) :: integral_BT_cont ! If true, update the barotropic continuity + logical, intent(in) :: integral_BT_cont !< If true, update the barotropic continuity !! equation directly from the initial condition !! using the time-integrated barotropic velocity. real, intent(in) :: dt_elapsed !< The amount of time in the barotropic stepping @@ -2918,7 +2933,7 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B 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. - logical, intent(in) :: integral_BT_cont ! If true, update the barotropic continuity + logical, intent(in) :: integral_BT_cont !< If true, update the barotropic continuity !! equation directly from the initial condition !! using the time-integrated barotropic velocity. real, intent(in) :: dt_baroclinic !< The baroclinic timestep for this cycle of @@ -3774,11 +3789,8 @@ subroutine set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, BT_Domain if (id_clock_pass_pre > 0) call cpu_clock_end(id_clock_pass_pre) if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre) -!$OMP parallel default(none) shared(is,ie,js,je,hs,BTCL_u,FA_u_EE,FA_u_E0,FA_u_W0, & -!$OMP FA_u_WW,uBT_EE,uBT_WW,u_polarity,BTCL_v, & -!$OMP FA_v_NN,FA_v_N0,FA_v_S0,FA_v_SS,vBT_NN,vBT_SS, & -!$OMP v_polarity ) -!$OMP do + !$OMP parallel default(shared) + !$OMP do do j=js-hs,je+hs ; do I=is-hs-1,ie+hs BTCL_u(I,j)%FA_u_EE = FA_u_EE(I,j) ; BTCL_u(I,j)%FA_u_E0 = FA_u_E0(I,j) BTCL_u(I,j)%FA_u_W0 = FA_u_W0(I,j) ; BTCL_u(I,j)%FA_u_WW = FA_u_WW(I,j) @@ -3801,7 +3813,7 @@ subroutine set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, BT_Domain if (abs(BTCL_u(I,j)%uBT_EE) > 0.0) BTCL_u(I,j)%uh_crvE = & (C1_3 * (BTCL_u(I,j)%FA_u_EE - BTCL_u(I,j)%FA_u_E0)) / BTCL_u(I,j)%uBT_EE**2 enddo ; enddo -!$OMP do + !$OMP do do J=js-hs-1,je+hs ; do i=is-hs,ie+hs BTCL_v(i,J)%FA_v_NN = FA_v_NN(i,J) ; BTCL_v(i,J)%FA_v_N0 = FA_v_N0(i,J) BTCL_v(i,J)%FA_v_S0 = FA_v_S0(i,J) ; BTCL_v(i,J)%FA_v_SS = FA_v_SS(i,J) @@ -3824,7 +3836,7 @@ subroutine set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, BT_Domain if (abs(BTCL_v(i,J)%vBT_NN) > 0.0) BTCL_v(i,J)%vh_crvN = & (C1_3 * (BTCL_v(i,J)%FA_v_NN - BTCL_v(i,J)%FA_v_N0)) / BTCL_v(i,J)%vBT_NN**2 enddo ; enddo -!$OMP end parallel + !$OMP end parallel end subroutine set_local_BT_cont_types diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index b1a37c7d5e..f03cee72b8 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -679,7 +679,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) endif !$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 OBC,h_neglect,dt,I_valBL,Kv_u,a_cpl_max) & !$OMP firstprivate(i_hbbl) do j=G%Jsc,G%Jec do I=Isq,Ieq ; do_i(I) = (G%mask2dCu(I,j) > 0) ; enddo @@ -846,7 +846,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) ! Now work on v-points. !$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 OBC,h_neglect,dt,I_valBL,Kv_v,a_cpl_max) & !$OMP firstprivate(i_hbbl) do J=Jsq,Jeq do i=is,ie ; do_i(i) = (G%mask2dCv(i,J) > 0) ; enddo From 2a9248af4f790f44626bc145b4da78b10e1ae664 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 22 Jul 2020 17:12:30 -0400 Subject: [PATCH 74/91] Added missing openMP directives Added some missing openMP directives that had been triggering warnings or errors, and could have created problems with more extensive testing. Also set some unset array bounds in the ice_shelf_dynamics code. All answers are bitwise identical in all working test cases. --- src/diagnostics/MOM_wave_speed.F90 | 3 ++- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 1 + src/parameterizations/vertical/MOM_kappa_shear.F90 | 6 +++--- 3 files changed, 6 insertions(+), 4 deletions(-) diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index 9da2963c16..b3321cdace 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -806,7 +806,8 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos, better_spee min_h_frac = tol_Hfrac / real(nz) !$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_pres,tv,cn,g_Rho0,nmodes) + !$OMP Z_to_pres,tv,cn,g_Rho0,nmodes,cg1_min2,better_est, & + !$OMP c1_thresh,tol_solve,tol_merge) 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 diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index be3ae1ecde..0c9fe4e77e 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -1405,6 +1405,7 @@ subroutine ice_shelf_advect_thickness_y(CS, G, LB, time_step, hmask, h0, h_after real :: h_face ! Thickness at a face for transport [Z ~> m] real :: slope_lim ! The value of the slope limiter, in the range of 0 to 2 [nondim] + ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh ! hmask coded values: 1) fully covered; 2) partly covered - no export; 3) Specified boundary condition ! relevant u_face_mask coded values: 1) Normal interior point; 4) Specified flux BC diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index 096781f8cf..04e67f0be5 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -396,8 +396,8 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ 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 + real :: I_hwt ! The inverse of the masked thickness weights [H-1 ~> m-1 or m2 kg-1]. + real :: I_Prandtl ! The inverse of the turbulent Prandtl number [nondim]. 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 @@ -422,7 +422,7 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ 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, & - !$OMP tv,G,GV,US,CS,kappa_io,dz_massless,k0dt,p_surf,dt,tke_io,kv_io) + !$OMP tv,G,GV,US,CS,kappa_io,dz_massless,k0dt,p_surf,dt,tke_io,kv_io,I_Prandtl) do J=JsB,JeB J2 = mod(J,2)+1 ; J2m1 = 3-J2 ! = mod(J-1,2)+1 From 5680fe5acda729514280956616fcd0f57c8b91ee Mon Sep 17 00:00:00 2001 From: "brandon.reichl" Date: Mon, 27 Jul 2020 08:12:32 -0400 Subject: [PATCH 75/91] Fixing loop bound error in MOM_PressureForce_Montgomery.F90 The "for" loop at L510 should be to nz instead of nz+1. Due to array allocation sizes, this loop was extending beyond the shope of the argument arrays. --- src/core/MOM_PressureForce_Montgomery.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index 07cbf3adf4..cade4e074d 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -507,7 +507,7 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, ! 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(shared) - do k=1,nz+1 ; do j=Jsq,Jeq+1 + 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_star(:,j,k), & tv%eqn_of_state, EOSdom) do i=Isq,Ieq+1 ; rho_star(i,j,k) = G_Rho0*rho_star(i,j,k) ; enddo From 652975250eabd5ef1365e7e3496bf4bd418dec3d Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Mon, 27 Jul 2020 10:27:15 -0400 Subject: [PATCH 76/91] Testing: tc4 installs python-netCDF4 via venv (#1166) Squash merge of following commits: * Testing: tc4 installs python-netCDF4 via venv Currently, users are expected to have numpy and netcdf4 python modules in order to generate the necessary netCDF input files. This fails in environments where these modules are unavailable. This patch now installs the modules into a virtual environment which are accessible when generating the tc4 inputs. This solution is local to tc4 but could be extended to other tests as needed. * Testing: remove Python numpy and netCDF4 modules The numpy and netCDF4 packages are no longer needed since tc4 now installs these locally. * Test: Install virtualenv for Python2 tc4 was using the venv module which appears to be python3-specific, and Travis Ubuntu defaults to python2. Also virtualenv was not installed in either case. This patch adds python-virtualenv to the install packages and uses the virtualenv module. * Test: Add python-dev for ARM64 numpy Travis ARM nodes need to build numpy natively when installed by pip, and thus require Python headers. These are provided by the python-dev package. * Test: Revert to Py3 for tc4 generation scripts Reverting the python 2 support (default for Travis) to use Python 3 syntax. The main reason is that Python 3 includes venv (equivalent to virtualenv) as its standard library, and is therefore guaranteed to exist if Python 3 exists. Python 3's virtualenv must be independently installed, which cannot be confirmed. This will cause problems for people without Python 3, but this is probably the best solution, or at least the starting point for a more general solution. * Test: Adding python3-venv to Travis Ubuntu apparently requires an explicit install of python3-venv despite it being part of the standard library. Go figure... * Test: Arm64 tc4 Configuration support Arm64 Ubuntu environments require explicit installations which are otherwise provided on x86 Ubuntu: * Python 3 Pip must be installed (python3-pip) * Wheel installation must be explicitly installed * Cython is required for numpy * Numpy must be explicitly built before installing python-netCDF4 * Test: tc4 common Python local-env Build times for setting up the virtual environments can be very expensive on the Arm64 Ubuntu nodes, so we now create a shared directory for launching the environments. * Test: Use '.' in place of 'source' for Make * Test: Test for required Python modules in tc4 We have reworked the Makefile to conditionally test for required Python modules in tc4. If unavailable, we install these in a virtual environment. This does not address many scenarios, such as if Python 3 is missing, venv is missing (as in Ubuntu), or handle the situation if they do not exist. It assumes that either the modules exist, or that they can be installed by venv. This should be seen as an iterative step to get things working on Travis x86 and Arm64, as well as GFDL's Gaea and most user Linux platforms. * Test: Explicit python execs for tc4 input build This resolves some issues with python2/3 resolution and limited support of various platforms for module support. Specifically, older platform with basic Python 3 support may not also have numpy support. In this case, we can defer back to Python 2 (or whatever the system Python may be). * Test: Setup Python venv at build time This patch moves the Python virtual environment configuration to the main Makefile, which is setup at build time, rather than in the model configuration Makefile, which will typically not have internet access if run on a compute node. As before, the venv will only be setup when the numpy and netCDF4 modules are unavailable. A minor bug in the logic of the check has also been fixed. --- .testing/Makefile | 54 ++++++++++++++++++++++++++++++++++++++--- .testing/tc4/.gitignore | 4 +++ .testing/tc4/Makefile | 7 +++++- .travis.yml | 1 + 4 files changed, 61 insertions(+), 5 deletions(-) create mode 100644 .testing/tc4/.gitignore diff --git a/.testing/Makefile b/.testing/Makefile index d1ceb16577..ab978fdadc 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -92,11 +92,34 @@ TARGET_SOURCE = $(call SOURCE,build/target_codebase/src) \ $(wildcard build/target_codebase/config_src/ext*/*.F90) FMS_SOURCE = $(call SOURCE,$(DEPS)/fms/src) +#--- +# Python preprocessing environment configuration + +HAS_NUMPY = $(shell python -c "import numpy" 2> /dev/null && echo "yes") +HAS_NETCDF4 = $(shell python -c "import netCDF4" 2> /dev/null && echo "yes") + +USE_VENV = +ifneq ($(HAS_NUMPY), yes) + USE_VENV = yes +endif +ifneq ($(HAS_NETCDF4), yes) + USE_VENV = yes +endif + +# When disabled, activation is a null operation (`true`) +VENV_PATH = +VENV_ACTIVATE = true +ifeq ($(USE_VENV), yes) + VENV_PATH = work/local-env + VENV_ACTIVATE = . $(VENV_PATH)/bin/activate +endif + + #--- # Rules .PHONY: all build.regressions -all: $(foreach b,$(BUILDS),build/$(b)/MOM6) +all: $(foreach b,$(BUILDS),build/$(b)/MOM6) $(VENV_PATH) build.regressions: $(foreach b,symmetric target,build/$(b)/MOM6) # Executable @@ -184,6 +207,18 @@ $(LIST_PATHS) $(MKMF): cd $(DEPS)/mkmf; git checkout $(MKMF_COMMIT) +#--- +# Python preprocessing +# NOTE: Some less mature environments (e.g. Arm64 Ubuntu) require explicit +# installation of numpy before netCDF4, as well as wheel and cython support. +work/local-env: + python3 -m venv $@ + . $@/bin/activate \ + && pip3 install wheel \ + && pip3 install cython \ + && pip3 install numpy \ + && pip3 install netCDF4 + #---- # Testing @@ -264,7 +299,6 @@ $(eval $(call CMP_RULE,regression,symmetric target)) # TODO: chksum_diag parsing of restart files - #--- # Test run output files @@ -281,7 +315,13 @@ work/%/$(1)/ocean.stats work/%/$(1)/chksum_diag: build/$(2)/MOM6 if [ $(3) ]; then find build/$(2) -name *.gcda -exec rm -f '{}' \; ; fi mkdir -p $$(@D) cp -rL $$*/* $$(@D) - cd $$(@D) && if [ -f Makefile ]; then $(MAKE); fi + if [ -f $$(@D)/Makefile ]; then \ + $$(VENV_ACTIVATE) \ + && cd $$(@D) \ + && $(MAKE); \ + else \ + cd $$(@D); \ + fi mkdir -p $$(@D)/RESTART echo -e "$(4)" > $$(@D)/MOM_override cd $$(@D) \ @@ -327,7 +367,13 @@ work/%/restart/ocean.stats: build/symmetric/MOM6 rm -rf $(@D) mkdir -p $(@D) cp -rL $*/* $(@D) - cd work/$*/restart && if [ -f Makefile ]; then $(MAKE); fi + if [ -f $(@D)/Makefile ]; then \ + $(VENV_ACTIVATE) \ + && cd work/$*/restart \ + && $(MAKE); \ + else \ + cd work/$*/restart; \ + fi mkdir -p $(@D)/RESTART # Generate the half-period input namelist # TODO: Assumes that runtime set by DAYMAX, will fail if set by input.nml diff --git a/.testing/tc4/.gitignore b/.testing/tc4/.gitignore new file mode 100644 index 0000000000..29f62fb208 --- /dev/null +++ b/.testing/tc4/.gitignore @@ -0,0 +1,4 @@ +ocean_hgrid.nc +sponge.nc +temp_salt_ic.nc +topog.nc diff --git a/.testing/tc4/Makefile b/.testing/tc4/Makefile index c332bbd7e6..a9aa395b9c 100644 --- a/.testing/tc4/Makefile +++ b/.testing/tc4/Makefile @@ -1,3 +1,8 @@ -ocean_hgrid.nc topog.nc temp_salt_ic.nc sponge.nc: +OUT=ocean_hgrid.nc sponge.nc temp_salt_ic.nc topog.nc + +$(OUT): python build_grid.py python build_data.py + +clean: + rm -rf $(OUT) diff --git a/.travis.yml b/.travis.yml index 6bf509ce8c..10816b7122 100644 --- a/.travis.yml +++ b/.travis.yml @@ -14,6 +14,7 @@ addons: - mpich libmpich-dev - doxygen graphviz flex bison cmake - python-numpy python-netcdf4 + - python3 python3-dev python3-venv python3-pip - bc jobs: From 4c030e613a66e57ef6bdd14504fb5ae877af473c Mon Sep 17 00:00:00 2001 From: Hemant Khatri Date: Wed, 29 Jul 2020 08:44:37 -0400 Subject: [PATCH 77/91] Momentum budget terms multiplied by fractional layer-thicknesses (#1163) Squash merge: * New diagnostics for barotropic momentum budget calculations are created. In these, different budget terms multiplied by fractional layer thicknesses are saved. Thus, these terms can be added over the whole to obtain the barotropic momentum budget. 'btstep' subroutine in MOM_barotropic module is modified to return fractional thicknesses. Pressure force acceleration multiplied by fractional thickness as diagnostics are added in this commit. * More thickness weighted diagnostics * Implemented Andrew Shao's suggestions * More fractional thickness multiplied diagnostics * Some barotropic diagnostics obtained from fractional thickness multiplied momentum budget terms * Removed trailing spaces * All fractional-thickness multiplied diagnostics implemented * define diagnostic variables as pointers * Shorter initialization of 2D arrays * Modifications in vertical friction diagnostics * Diagnostics initialization as pointers to save memory allocation * Vertical friction module * Removed commented lines and trailing spaces * Diagnostic description change * Fractional thickness-weighted diagnostics for acceleration due to relative vorticity and gradient of kinetic energy * Modifications in vertical friction diagnostics (fractional thickness-weighted) * Modifications in diag_hfrac_u and diag_hfrac_v calls * Made allocation of hfrac at u/v points optional. These arrays are only allocated if any of the relevant diagnostics are called. * Fractional-thickness weighted 3D diagnostics are now commented out as we do not the proper grid remapping option. * Initialization of 2D diagnostic arrays changed from pointer type to allocatable array style. * Trailing spaces removed and line lengths reduced to be under 120 characters * Comment modified Reviewed by Robert Hallberg --- src/core/MOM_CoriolisAdv.F90 | 154 ++++++++++++++ src/core/MOM_barotropic.F90 | 15 +- src/core/MOM_dynamics_split_RK2.F90 | 193 +++++++++++++++++- src/core/MOM_variables.F90 | 2 + src/diagnostics/MOM_diagnostics.F90 | 93 +++++++++ .../lateral/MOM_hor_visc.F90 | 83 +++++++- .../vertical/MOM_vert_friction.F90 | 84 +++++++- 7 files changed, 614 insertions(+), 10 deletions(-) diff --git a/src/core/MOM_CoriolisAdv.F90 b/src/core/MOM_CoriolisAdv.F90 index f470338c4e..cf274d32a9 100644 --- a/src/core/MOM_CoriolisAdv.F90 +++ b/src/core/MOM_CoriolisAdv.F90 @@ -74,6 +74,10 @@ module MOM_CoriolisAdv !>@{ Diagnostic IDs integer :: id_rv = -1, id_PV = -1, id_gKEu = -1, id_gKEv = -1 integer :: id_rvxu = -1, id_rvxv = -1 + ! integer :: id_hf_gKEu = -1, id_hf_gKEv = -1 + integer :: id_hf_gKEu_2d = -1, id_hf_gKEv_2d = -1 + ! integer :: id_hf_rvxu = -1, id_hf_rvxv = -1 + integer :: id_hf_rvxu_2d = -1, id_hf_rvxv_2d = -1 !>@} end type CoriolisAdv_CS @@ -211,6 +215,16 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) real :: QUHeff,QVHeff ! More temporary variables [H L2 T-1 s-1 ~> m3 s-2 or kg s-2]. integer :: i, j, k, n, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz +! Diagnostics for fractional thickness-weighted terms + real, allocatable, dimension(:,:) :: & + hf_gKEu_2d, hf_gKEv_2d, & ! Depth sum of hf_gKEu, hf_gKEv [L T-2 ~> m s-2]. + hf_rvxu_2d, hf_rvxv_2d ! Depth sum of hf_rvxu, hf_rvxv [L T-2 ~> m s-2]. + !real, allocatable, dimension(:,:,:) :: & + ! hf_gKEu, hf_gKEv, & ! accel. due to KE gradient x fract. thickness [L T-2 ~> m s-2]. + ! hf_rvxu, hf_rvxv ! accel. due to RV x fract. thickness [L T-2 ~> m s-2]. + ! 3D diagnostics hf_gKEu etc. are commented because there is no clarity on proper remapping grid option. + ! The code is retained for degugging purposes in the future. + ! 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+2,js-1:je+1), u(is-1:ie+1,js-1:je+2), h(is-1:ie+2,js-1:je+2), @@ -828,6 +842,82 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS) if (CS%id_gKEv>0) call post_data(CS%id_gKEv, AD%gradKEv, CS%diag) if (CS%id_rvxu > 0) call post_data(CS%id_rvxu, AD%rv_x_u, CS%diag) if (CS%id_rvxv > 0) call post_data(CS%id_rvxv, AD%rv_x_v, CS%diag) + + ! Diagnostics for terms multiplied by fractional thicknesses + + ! 3D diagnostics hf_gKEu etc. are commented because there is no clarity on proper remapping grid option. + ! The code is retained for degugging purposes in the future. + !if (CS%id_hf_gKEu > 0) then + ! allocate(hf_gKEu(G%IsdB:G%IedB,G%jsd:G%jed,G%ke)) + ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ! hf_gKEu(I,j,k) = AD%gradKEu(I,j,k) * AD%diag_hfrac_u(I,j,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_gKEu, hf_gKEu, CS%diag) + !endif + + !if (CS%id_hf_gKEv > 0) then + ! allocate(hf_gKEv(G%isd:G%ied,G%JsdB:G%JedB,G%ke)) + ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ! hf_gKEv(i,J,k) = AD%gradKEv(i,J,k) * AD%diag_hfrac_v(i,J,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_gKEv, hf_gKEv, CS%diag) + !endif + + if (CS%id_hf_gKEu_2d > 0) then + allocate(hf_gKEu_2d(G%IsdB:G%IedB,G%jsd:G%jed)) + hf_gKEu_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + hf_gKEu_2d(I,j) = hf_gKEu_2d(I,j) + AD%gradKEu(I,j,k) * AD%diag_hfrac_u(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_gKEu_2d, hf_gKEu_2d, CS%diag) + deallocate(hf_gKEu_2d) + endif + + if (CS%id_hf_gKEv_2d > 0) then + allocate(hf_gKEv_2d(G%isd:G%ied,G%JsdB:G%JedB)) + hf_gKEv_2d(:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + hf_gKEv_2d(i,J) = hf_gKEv_2d(i,J) + AD%gradKEv(i,J,k) * AD%diag_hfrac_v(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_gKEv_2d, hf_gKEv_2d, CS%diag) + deallocate(hf_gKEv_2d) + endif + + !if (CS%id_hf_rvxv > 0) then + ! allocate(hf_rvxv(G%IsdB:G%IedB,G%jsd:G%jed,G%ke)) + ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ! hf_rvxv(I,j,k) = AD%rv_x_v(I,j,k) * AD%diag_hfrac_u(I,j,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_rvxv, hf_rvxv, CS%diag) + !endif + + !if (CS%id_hf_rvxu > 0) then + ! allocate(hf_rvxu(G%isd:G%ied,G%JsdB:G%JedB,G%ke)) + ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ! hf_rvxu(i,J,k) = AD%rv_x_u(i,J,k) * AD%diag_hfrac_v(i,J,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_rvxu, hf_rvxu, CS%diag) + !endif + + if (CS%id_hf_rvxv_2d > 0) then + allocate(hf_rvxv_2d(G%IsdB:G%IedB,G%jsd:G%jed)) + hf_rvxv_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + hf_rvxv_2d(I,j) = hf_rvxv_2d(I,j) + AD%rv_x_v(I,j,k) * AD%diag_hfrac_u(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_rvxv_2d, hf_rvxv_2d, CS%diag) + deallocate(hf_rvxv_2d) + endif + + if (CS%id_hf_rvxu_2d > 0) then + allocate(hf_rvxu_2d(G%isd:G%ied,G%JsdB:G%JedB)) + hf_rvxu_2d(:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + hf_rvxu_2d(i,J) = hf_rvxu_2d(i,J) + AD%rv_x_u(i,J,k) * AD%diag_hfrac_v(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_rvxu_2d, hf_rvxu_2d, CS%diag) + deallocate(hf_rvxu_2d) + endif endif end subroutine CorAdCalc @@ -1087,6 +1177,70 @@ subroutine CoriolisAdv_init(Time, G, GV, US, param_file, diag, AD, CS) 'Zonal Acceleration from Relative Vorticity', 'm-1 s-2', conversion=US%L_T2_to_m_s2) if (CS%id_rvxv > 0) call safe_alloc_ptr(AD%rv_x_v,IsdB,IedB,jsd,jed,nz) + !CS%id_hf_gKEu = register_diag_field('ocean_model', 'hf_gKEu', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Zonal Acceleration from Grad. Kinetic Energy', & + ! 'm-1 s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_gKEu > 0) then + ! call safe_alloc_ptr(AD%gradKEu,IsdB,IedB,jsd,jed,nz) + ! call safe_alloc_ptr(AD%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + !endif + + !CS%id_hf_gKEv = register_diag_field('ocean_model', 'hf_gKEv', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Meridional Acceleration from Grad. Kinetic Energy', & + ! 'm-1 s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_gKEv > 0) then + ! call safe_alloc_ptr(AD%gradKEv,isd,ied,JsdB,JedB,nz) + ! call safe_alloc_ptr(AD%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + !endif + + CS%id_hf_gKEu_2d = register_diag_field('ocean_model', 'hf_gKEu_2d', diag%axesCuL, Time, & + 'Depth-sum Fractional Thickness-weighted Zonal Acceleration from Grad. Kinetic Energy', & + 'm-1 s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_gKEu_2d > 0) then + call safe_alloc_ptr(AD%gradKEu,IsdB,IedB,jsd,jed,nz) + call safe_alloc_ptr(AD%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + endif + + CS%id_hf_gKEv_2d = register_diag_field('ocean_model', 'hf_gKEv_2d', diag%axesCvL, Time, & + 'Depth-sum Fractional Thickness-weighted Meridional Acceleration from Grad. Kinetic Energy', & + 'm-1 s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_gKEv_2d > 0) then + call safe_alloc_ptr(AD%gradKEv,isd,ied,JsdB,JedB,nz) + call safe_alloc_ptr(AD%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + endif + + !CS%id_hf_rvxu = register_diag_field('ocean_model', 'hf_rvxu', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Meridional Acceleration from Relative Vorticity', & + ! 'm-1 s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_rvxu > 0) then + ! call safe_alloc_ptr(AD%rv_x_u,isd,ied,JsdB,JedB,nz) + ! call safe_alloc_ptr(AD%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + !endif + + !CS%id_hf_rvxv = register_diag_field('ocean_model', 'hf_rvxv', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Zonal Acceleration from Relative Vorticity', & + ! 'm-1 s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_rvxv > 0) then + ! call safe_alloc_ptr(AD%rv_x_v,IsdB,IedB,jsd,jed,nz) + ! call safe_alloc_ptr(AD%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + !endif + + CS%id_hf_rvxu_2d = register_diag_field('ocean_model', 'hf_rvxu_2d', diag%axesCvL, Time, & + 'Fractional Thickness-weighted Meridional Acceleration from Relative Vorticity', & + 'm-1 s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_rvxu_2d > 0) then + call safe_alloc_ptr(AD%rv_x_u,isd,ied,JsdB,JedB,nz) + call safe_alloc_ptr(AD%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + endif + + CS%id_hf_rvxv_2d = register_diag_field('ocean_model', 'hf_rvxv_2d', diag%axesCuL, Time, & + 'Depth-sum Fractional Thickness-weighted Zonal Acceleration from Relative Vorticity', & + 'm-1 s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_rvxv_2d > 0) then + call safe_alloc_ptr(AD%rv_x_v,IsdB,IedB,jsd,jed,nz) + call safe_alloc_ptr(AD%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + endif + end subroutine CoriolisAdv_init !> Destructor for coriolisadv_cs diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 7f34f18998..db85bb40e2 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -27,6 +27,7 @@ module MOM_barotropic 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 +use MOM_variables, only : accel_diag_ptrs implicit none ; private @@ -405,7 +406,7 @@ module MOM_barotropic 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, & + visc_rem_u, visc_rem_v, etaav, ADp, 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. @@ -458,6 +459,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, 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(accel_diag_ptrs), optional, pointer :: ADp !< Acceleration diagnostic pointers 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 @@ -2583,6 +2585,17 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (CS%id_frhatv1 > 0) CS%frhatv1(:,:,:) = CS%frhatv(:,:,:) endif + if ((present(ADp)) .and. (associated(ADp%diag_hfrac_u))) then + do k=1,nz ; do j=js,je ; do I=is-1,ie + ADp%diag_hfrac_u(I,j,k) = CS%frhatu(I,j,k) + enddo ; enddo ; enddo + endif + if ((present(ADp)) .and. (associated(ADp%diag_hfrac_v))) then + do k=1,nz ; do J=js-1,je ; do i=is,ie + ADp%diag_hfrac_v(i,J,k) = CS%frhatv(i,J,k) + enddo ; enddo ; enddo + endif + if (G%nonblocking_updates) then if (find_etaav) call complete_group_pass(CS%pass_etaav, G%Domain) call complete_group_pass(CS%pass_ubta_uhbta, G%Domain) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 276c3c330f..64a9c18b97 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -160,10 +160,16 @@ module MOM_dynamics_split_RK2 integer :: id_umo_2d = -1, id_vmo_2d = -1 integer :: id_PFu = -1, id_PFv = -1 integer :: id_CAu = -1, id_CAv = -1 + ! integer :: id_hf_PFu = -1, id_hf_PFv = -1 + integer :: id_hf_PFu_2d = -1, id_hf_PFv_2d = -1 + ! integer :: id_hf_CAu = -1, id_hf_CAv = -1 + integer :: id_hf_CAu_2d = -1, id_hf_CAv_2d = -1 ! Split scheme only. integer :: id_uav = -1, id_vav = -1 integer :: id_u_BT_accel = -1, id_v_BT_accel = -1 + ! integer :: id_hf_u_BT_accel = -1, id_hf_v_BT_accel = -1 + integer :: id_hf_u_BT_accel_2d = -1, id_hf_v_BT_accel_2d = -1 !>@} type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the @@ -318,6 +324,19 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s u_av, & ! The zonal velocity time-averaged over a time step [L T-1 ~> m s-1]. v_av, & ! The meridional velocity time-averaged over a time step [L T-1 ~> m s-1]. h_av ! The layer thickness time-averaged over a time step [H ~> m or kg m-2]. + + ! real, allocatable, dimension(:,:,:) :: & + ! hf_PFu, hf_PFv, & ! Pressure force accel. x fract. thickness [L T-2 ~> m s-2]. + ! hf_CAu, hf_CAv, & ! Coriolis force accel. x fract. thickness [L T-2 ~> m s-2]. + ! hf_u_BT_accel, hf_v_BT_accel ! barotropic correction accel. x fract. thickness [L T-2 ~> m s-2]. + ! 3D diagnostics hf_PFu etc. are commented because there is no clarity on proper remapping grid option. + ! The code is retained for degugging purposes in the future. + + real, allocatable, dimension(:,:) :: & + hf_PFu_2d, hf_PFv_2d, & ! Depth integeral of hf_PFu, hf_PFv [L T-2 ~> m s-2]. + hf_CAu_2d, hf_CAv_2d, & ! Depth integeral of hf_CAu, hf_CAv [L T-2 ~> m s-2]. + hf_u_BT_accel_2d, hf_v_BT_accel_2d ! Depth integeral of hf_u_BT_accel, hf_v_BT_accel + real :: dt_pred ! The time step for the predictor part of the baroclinic time stepping [T ~> s]. logical :: dyn_p_surf @@ -532,7 +551,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s ! 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, US, CS%barotropic_CSp, CS%visc_rem_u, CS%visc_rem_v, & + G, GV, US, CS%barotropic_CSp, CS%visc_rem_u, CS%visc_rem_v, ADp=CS%ADp, & 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) @@ -682,7 +701,8 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s call cpu_clock_begin(id_clock_horvisc) call horizontal_viscosity(u_av, v_av, h_av, CS%diffu, CS%diffv, & MEKE, Varmix, G, GV, US, CS%hor_visc_CSp, & - OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp) + OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp, & + ADp=CS%ADp) call cpu_clock_end(id_clock_horvisc) if (showCallTree) call callTree_wayPoint("done with horizontal_viscosity (step_MOM_dyn_split_RK2)") @@ -733,8 +753,8 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s 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, & + CS%visc_rem_u, CS%visc_rem_v, etaav=eta_av, ADp=CS%ADp, & + 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) do j=js,je ; do i=is,ie ; eta(i,j) = eta_pred(i,j) ; enddo ; enddo @@ -860,6 +880,109 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s if (CS%id_u_BT_accel > 0) call post_data(CS%id_u_BT_accel, CS%u_accel_bt, CS%diag) if (CS%id_v_BT_accel > 0) call post_data(CS%id_v_BT_accel, CS%v_accel_bt, CS%diag) + ! Diagnostics for terms multiplied by fractional thicknesses + + ! 3D diagnostics hf_PFu etc. are commented because there is no clarity on proper remapping grid option. + ! The code is retained for degugging purposes in the future. + !if (CS%id_hf_PFu > 0) then + ! allocate(hf_PFu(G%IsdB:G%IedB,G%jsd:G%jed,G%ke)) + ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ! hf_PFu(I,j,k) = CS%PFu(I,j,k) * CS%ADp%diag_hfrac_u(I,j,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_PFu, hf_PFu, CS%diag) + !endif + !if (CS%id_hf_PFv > 0) then + ! allocate(hf_PFv(G%isd:G%ied,G%JsdB:G%JedB,G%ke)) + ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ! hf_PFv(i,J,k) = CS%PFv(i,J,k) * CS%ADp%diag_hfrac_v(i,J,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_PFv, hf_PFv, CS%diag) + !endif + if (CS%id_hf_PFu_2d > 0) then + allocate(hf_PFu_2d(G%IsdB:G%IedB,G%jsd:G%jed)) + hf_PFu_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + hf_PFu_2d(I,j) = hf_PFu_2d(I,j) + CS%PFu(I,j,k) * CS%ADp%diag_hfrac_u(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_PFu_2d, hf_PFu_2d, CS%diag) + deallocate(hf_PFu_2d) + endif + if (CS%id_hf_PFv_2d > 0) then + allocate(hf_PFv_2d(G%isd:G%ied,G%JsdB:G%JedB)) + hf_PFv_2d(:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + hf_PFv_2d(i,J) = hf_PFv_2d(i,J) + CS%PFv(i,J,k) * CS%ADp%diag_hfrac_v(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_PFv_2d, hf_PFv_2d, CS%diag) + deallocate(hf_PFv_2d) + endif + + !if (CS%id_hf_CAu > 0) then + ! allocate(hf_CAu(G%IsdB:G%IedB,G%jsd:G%jed,G%ke)) + ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ! hf_CAu(I,j,k) = CS%CAu(I,j,k) * CS%ADp%diag_hfrac_u(I,j,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_CAu, hf_CAu, CS%diag) + !endif + !if (CS%id_hf_CAv > 0) then + ! allocate(hf_CAv(G%isd:G%ied,G%JsdB:G%JedB,G%ke)) + ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ! hf_CAv(i,J,k) = CS%CAv(i,J,k) * CS%ADp%diag_hfrac_v(i,J,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_CAv, hf_CAv, CS%diag) + !endif + if (CS%id_hf_CAu_2d > 0) then + allocate(hf_CAu_2d(G%IsdB:G%IedB,G%jsd:G%jed)) + hf_CAu_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + hf_CAu_2d(I,j) = hf_CAu_2d(I,j) + CS%CAu(I,j,k) * CS%ADp%diag_hfrac_u(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_CAu_2d, hf_CAu_2d, CS%diag) + deallocate(hf_CAu_2d) + endif + if (CS%id_hf_CAv_2d > 0) then + allocate(hf_CAv_2d(G%isd:G%ied,G%JsdB:G%JedB)) + hf_CAv_2d(:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + hf_CAv_2d(i,J) = hf_CAv_2d(i,J) + CS%CAv(i,J,k) * CS%ADp%diag_hfrac_v(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_CAv_2d, hf_CAv_2d, CS%diag) + deallocate(hf_CAv_2d) + endif + + !if (CS%id_hf_u_BT_accel > 0) then + ! allocate(hf_u_BT_accel(G%IsdB:G%IedB,G%jsd:G%jed,G%ke)) + ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ! hf_u_BT_accel(I,j,k) = CS%u_accel_bt(I,j,k) * CS%ADp%diag_hfrac_u(I,j,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_u_BT_accel, hf_u_BT_accel, CS%diag) + !endif + !if (CS%id_hf_v_BT_accel > 0) then + ! allocate(hf_v_BT_accel(G%isd:G%ied,G%JsdB:G%JedB,G%ke)) + ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ! hf_v_BT_accel(i,J,k) = CS%v_accel_bt(i,J,k) * CS%ADp%diag_hfrac_v(i,J,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_v_BT_accel, hf_v_BT_accel, CS%diag) + !endif + if (CS%id_hf_u_BT_accel_2d > 0) then + allocate(hf_u_BT_accel_2d(G%IsdB:G%IedB,G%jsd:G%jed)) + hf_u_BT_accel_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + hf_u_BT_accel_2d(I,j) = hf_u_BT_accel_2d(I,j) + CS%u_accel_bt(I,j,k) * CS%ADp%diag_hfrac_u(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_u_BT_accel_2d, hf_u_BT_accel_2d, CS%diag) + deallocate(hf_u_BT_accel_2d) + endif + if (CS%id_hf_v_BT_accel_2d > 0) then + allocate(hf_v_BT_accel_2d(G%isd:G%ied,G%JsdB:G%JedB)) + hf_v_BT_accel_2d(:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + hf_v_BT_accel_2d(i,J) = hf_v_BT_accel_2d(i,J) + CS%v_accel_bt(i,J,k) * CS%ADp%diag_hfrac_v(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_v_BT_accel_2d, hf_v_BT_accel_2d, CS%diag) + deallocate(hf_v_BT_accel_2d) + endif + if (CS%debug) then call MOM_state_chksum("Corrector ", u, v, h, uh, vh, G, GV, US, symmetric=sym) call uvchksum("Corrector avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) @@ -1110,7 +1233,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param if (use_tides) call tidal_forcing_init(Time, G, param_file, CS%tides_CSp) call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, & CS%tides_CSp) - call hor_visc_init(Time, G, US, param_file, diag, CS%hor_visc_CSp, MEKE) + call hor_visc_init(Time, G, US, param_file, diag, CS%hor_visc_CSp, MEKE, ADp=CS%ADp) 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, & @@ -1232,6 +1355,46 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param CS%id_PFv = register_diag_field('ocean_model', 'PFv', diag%axesCvL, Time, & 'Meridional Pressure Force Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + !CS%id_hf_PFu = register_diag_field('ocean_model', 'hf_PFu', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Zonal Pressure Force Acceleration', 'm s-2', & + ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if(CS%id_hf_PFu > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + !CS%id_hf_PFv = register_diag_field('ocean_model', 'hf_PFv', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Meridional Pressure Force Acceleration', 'm s-2', & + ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if(CS%id_hf_PFv > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + + !CS%id_hf_CAu = register_diag_field('ocean_model', 'hf_CAu', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Zonal Coriolis and Advective Acceleration', 'm s-2', & + ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if(CS%id_hf_CAu > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + !CS%id_hf_CAv = register_diag_field('ocean_model', 'hf_CAv', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Meridional Coriolis and Advective Acceleration', 'm s-2', & + ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if(CS%id_hf_CAv > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + + CS%id_hf_PFu_2d = register_diag_field('ocean_model', 'hf_PFu_2d', diag%axesCu1, Time, & + 'Depth-sum Fractional Thickness-weighted Zonal Pressure Force Acceleration', 'm s-2', & + conversion=US%L_T2_to_m_s2) + if(CS%id_hf_PFu_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + CS%id_hf_PFv_2d = register_diag_field('ocean_model', 'hf_PFv_2d', diag%axesCv1, Time, & + 'Depth-sum Fractional Thickness-weighted Meridional Pressure Force Acceleration', 'm s-2', & + conversion=US%L_T2_to_m_s2) + if(CS%id_hf_PFv_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + + CS%id_hf_CAu_2d = register_diag_field('ocean_model', 'hf_CAu_2d', diag%axesCu1, Time, & + 'Depth-sum Fractional Thickness-weighted Zonal Coriolis and Advective Acceleration', 'm s-2', & + conversion=US%L_T2_to_m_s2) + if(CS%id_hf_CAu_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + CS%id_hf_CAv_2d = register_diag_field('ocean_model', 'hf_CAv_2d', diag%axesCv1, Time, & + 'Depth-sum Fractional Thickness-weighted Meridional Coriolis and Advective Acceleration', 'm s-2', & + conversion=US%L_T2_to_m_s2) + if(CS%id_hf_CAv_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + CS%id_uav = register_diag_field('ocean_model', 'uav', diag%axesCuL, Time, & 'Barotropic-step Averaged Zonal Velocity', 'm s-1', conversion=US%L_T_to_m_s) CS%id_vav = register_diag_field('ocean_model', 'vav', diag%axesCvL, Time, & @@ -1242,6 +1405,26 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param CS%id_v_BT_accel = register_diag_field('ocean_model', 'v_BT_accel', diag%axesCvL, Time, & 'Barotropic Anomaly Meridional Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + !CS%id_hf_u_BT_accel = register_diag_field('ocean_model', 'hf_u_BT_accel', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Barotropic Anomaly Zonal Acceleration', 'm s-2', & + ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if(CS%id_hf_u_BT_accel > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + !CS%id_hf_v_BT_accel = register_diag_field('ocean_model', 'hf_v_BT_accel', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Barotropic Anomaly Meridional Acceleration', 'm s-2', & + ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if(CS%id_hf_v_BT_accel > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + + CS%id_hf_u_BT_accel_2d = register_diag_field('ocean_model', 'hf_u_BT_accel_2d', diag%axesCu1, Time, & + 'Depth-sum Fractional Thickness-weighted Barotropic Anomaly Zonal Acceleration', 'm s-2', & + conversion=US%L_T2_to_m_s2) + if(CS%id_hf_u_BT_accel_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + CS%id_hf_v_BT_accel_2d = register_diag_field('ocean_model', 'hf_v_BT_accel_2d', diag%axesCv1, Time, & + 'Depth-sum Fractional Thickness-weighted Barotropic Anomaly Meridional Acceleration', 'm s-2', & + conversion=US%L_T2_to_m_s2) + if(CS%id_hf_v_BT_accel_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + id_clock_Cor = cpu_clock_id('(Ocean Coriolis & mom advection)', grain=CLOCK_MODULE) id_clock_continuity = cpu_clock_id('(Ocean continuity equation)', grain=CLOCK_MODULE) id_clock_pres = cpu_clock_id('(Ocean pressure force)', grain=CLOCK_MODULE) diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 26c2344f44..0b225f0bf7 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -185,6 +185,8 @@ module MOM_variables real, pointer :: rv_x_v(:,:,:) => NULL() !< rv_x_v = rv * v at u [L T-2 ~> m s-2] real, pointer :: rv_x_u(:,:,:) => NULL() !< rv_x_u = rv * u at v [L T-2 ~> m s-2] + real, pointer :: diag_hfrac_u(:,:,:) => NULL() !< Fractional layer thickness at u points + real, pointer :: diag_hfrac_v(:,:,:) => NULL() !< Fractional layer thickness at v points end type accel_diag_ptrs !> Pointers to arrays with transports, which can later be used for derived diagnostics, like energy balances. diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index d51173c16b..3936a788d0 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -71,6 +71,9 @@ module MOM_diagnostics dv_dt => NULL(), & !< net j-acceleration [L T-2 ~> m s-2] dh_dt => NULL(), & !< thickness rate of change [H T-1 ~> m s-1 or kg m-2 s-1] p_ebt => NULL() !< Equivalent barotropic modal structure [nondim] + ! hf_du_dt => NULL(), hf_dv_dt => NULL() !< du_dt, dv_dt x fract. thickness [L T-2 ~> m s-2]. + ! 3D diagnostics hf_du(dv)_dt are commented because there is no clarity on proper remapping grid option. + ! The code is retained for degugging purposes in the future. real, pointer, dimension(:,:,:) :: h_Rlay => NULL() !< Layer thicknesses in potential density !! coordinates [H ~> m or kg m-2] @@ -110,6 +113,8 @@ module MOM_diagnostics 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 + ! integer :: id_hf_du_dt = -1, id_hf_dv_dt = -1 + integer :: id_hf_du_dt_2d = -1, id_hf_dv_dt_2d = -1 integer :: id_col_ht = -1, id_dh_dt = -1 integer :: id_KE = -1, id_dKEdt = -1 integer :: id_PE_to_KE = -1, id_KE_Coradv = -1 @@ -233,6 +238,9 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & real :: work_2d(SZI_(G),SZJ_(G)) ! A 2-d temporary work array. real :: rho_in_situ(SZI_(G)) ! In situ density [R ~> kg m-3] + real, allocatable, dimension(:,:) :: & + hf_du_dt_2d, hf_dv_dt_2d ! z integeral of hf_du_dt, hf_dv_dt [L T-2 ~> m s-2]. + ! tmp array for surface properties real :: surface_field(SZI_(G),SZJ_(G)) real :: pressure_1d(SZI_(G)) ! Temporary array for pressure when calling EOS [R L2 T-2 ~> Pa] @@ -272,6 +280,44 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & if (CS%id_dh_dt>0) call post_data(CS%id_dh_dt, CS%dh_dt, CS%diag, alt_h = diag_pre_sync%h_state) + !! Diagnostics for terms multiplied by fractional thicknesses + + ! 3D diagnostics hf_du(dv)_dt are commented because there is no clarity on proper remapping grid option. + ! The code is retained for degugging purposes in the future. + !if (CS%id_hf_du_dt > 0) then + ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ! CS%hf_du_dt(I,j,k) = CS%du_dt(I,j,k) * ADp%diag_hfrac_u(I,j,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_du_dt, CS%hf_du_dt, CS%diag, alt_h = diag_pre_sync%h_state) + !endif + + !if (CS%id_hf_dv_dt > 0) then + ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ! CS%hf_dv_dt(i,J,k) = CS%dv_dt(i,J,k) * ADp%diag_hfrac_v(i,J,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_dv_dt, CS%hf_dv_dt, CS%diag, alt_h = diag_pre_sync%h_state) + !endif + + if (CS%id_hf_du_dt_2d > 0) then + allocate(hf_du_dt_2d(G%IsdB:G%IedB,G%jsd:G%jed)) + hf_du_dt_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + hf_du_dt_2d(I,j) = hf_du_dt_2d(I,j) + CS%du_dt(I,j,k) * ADp%diag_hfrac_u(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_du_dt_2d, hf_du_dt_2d, CS%diag) + deallocate(hf_du_dt_2d) + endif + + if (CS%id_hf_dv_dt_2d > 0) then + allocate(hf_dv_dt_2d(G%isd:G%ied,G%JsdB:G%JedB)) + hf_dv_dt_2d(:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + hf_dv_dt_2d(i,J) = hf_dv_dt_2d(i,J) + CS%dv_dt(i,J,k) * ADp%diag_hfrac_v(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_dv_dt_2d, hf_dv_dt_2d, CS%diag) + deallocate(hf_dv_dt_2d) + endif + call diag_restore_grids(CS%diag) call calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS) @@ -1644,6 +1690,50 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag call register_time_deriv(lbound(MIS%h), MIS%h, CS%dh_dt, CS) endif + !CS%id_hf_du_dt = register_diag_field('ocean_model', 'hf_dudt', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Zonal Acceleration', 'm s-2', v_extensive=.true., & + ! conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_du_dt > 0) then + ! call safe_alloc_ptr(CS%hf_du_dt,IsdB,IedB,jsd,jed,nz) + ! if (.not.associated(CS%du_dt)) then + ! call safe_alloc_ptr(CS%du_dt,IsdB,IedB,jsd,jed,nz) + ! call register_time_deriv(lbound(MIS%u), MIS%u, CS%du_dt, CS) + ! endif + ! call safe_alloc_ptr(ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + !endif + + !CS%id_hf_dv_dt = register_diag_field('ocean_model', 'hf_dvdt', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Meridional Acceleration', 'm s-2', v_extensive=.true., & + ! conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_dv_dt > 0) then + ! call safe_alloc_ptr(CS%hf_dv_dt,isd,ied,JsdB,JedB,nz) + ! if (.not.associated(CS%dv_dt)) then + ! call safe_alloc_ptr(CS%dv_dt,isd,ied,JsdB,JedB,nz) + ! call register_time_deriv(lbound(MIS%v), MIS%v, CS%dv_dt, CS) + ! endif + ! call safe_alloc_ptr(ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + !endif + + CS%id_hf_du_dt_2d = register_diag_field('ocean_model', 'hf_dudt_2d', diag%axesCu1, Time, & + 'Depth-sum Fractional Thickness-weighted Zonal Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_du_dt_2d > 0) then + if (.not.associated(CS%du_dt)) then + call safe_alloc_ptr(CS%du_dt,IsdB,IedB,jsd,jed,nz) + call register_time_deriv(lbound(MIS%u), MIS%u, CS%du_dt, CS) + endif + call safe_alloc_ptr(ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + endif + + CS%id_hf_dv_dt_2d = register_diag_field('ocean_model', 'hf_dvdt_2d', diag%axesCv1, Time, & + 'Depth-sum Fractional Thickness-weighted Meridional Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_dv_dt_2d > 0) then + if (.not.associated(CS%dv_dt)) then + call safe_alloc_ptr(CS%dv_dt,isd,ied,JsdB,JedB,nz) + call register_time_deriv(lbound(MIS%v), MIS%v, CS%dv_dt, CS) + endif + call safe_alloc_ptr(ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + endif + ! layer thickness variables !if (GV%nk_rho_varies > 0) then CS%id_h_Rlay = register_diag_field('ocean_model', 'h_rho', diag%axesTL, Time, & @@ -2178,6 +2268,9 @@ subroutine MOM_diagnostics_end(CS, ADp) if (associated(ADp%du_other)) deallocate(ADp%du_other) if (associated(ADp%dv_other)) deallocate(ADp%dv_other) + if (associated(ADp%diag_hfrac_u)) deallocate(ADp%diag_hfrac_u) + if (associated(ADp%diag_hfrac_v)) deallocate(ADp%diag_hfrac_v) + do m=1,CS%num_time_deriv ; deallocate(CS%prev_val(m)%p) ; enddo deallocate(CS) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 7c1405308f..4e9897f6eb 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -19,6 +19,7 @@ module MOM_hor_visc use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_S, OBC_NONE use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type +use MOM_variables, only : accel_diag_ptrs implicit none ; private @@ -174,9 +175,16 @@ module MOM_hor_visc type(diag_ctrl), pointer :: diag => NULL() !< structure to regulate diagnostics + ! real, pointer :: hf_diffu(:,:,:) => NULL() ! Zonal hor. visc. accel. x fract. thickness [L T-2 ~> m s-2]. + ! real, pointer :: hf_diffv(:,:,:) => NULL() ! Merdional hor. visc. accel. x fract. thickness [L T-2 ~> m s-2]. + ! 3D diagnostics hf_diffu(diffv) are commented because there is no clarity on proper remapping grid option. + ! The code is retained for degugging purposes in the future. + !>@{ !! Diagnostic id integer :: id_diffu = -1, id_diffv = -1 + ! integer :: id_hf_diffu = -1, id_hf_diffv = -1 + integer :: id_hf_diffu_2d = -1, id_hf_diffv_2d = -1 integer :: id_Ah_h = -1, id_Ah_q = -1 integer :: id_Kh_h = -1, id_Kh_q = -1 integer :: id_GME_coeff_h = -1, id_GME_coeff_q = -1 @@ -203,7 +211,7 @@ module MOM_hor_visc !! 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, US, & - CS, OBC, BT, TD) + CS, OBC, BT, TD, ADp) 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)), & @@ -230,6 +238,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !! barotropic velocities. type(thickness_diffuse_CS), optional, pointer :: TD !< Pointer to a structure containing !! thickness diffusivities. + type(accel_diag_ptrs), optional, pointer :: ADp !< Acceleration diagnostic pointers + ! Local variables real, dimension(SZIB_(G),SZJ_(G)) :: & Del2u, & ! The u-compontent of the Laplacian of velocity [L-1 T-1 ~> m-1 s-1] @@ -263,6 +273,9 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, grad_d2vel_mag_h, & ! Magnitude of the Laplacian of the velocity vector, squared [L-2 T-2 ~> m-2 s-2] boundary_mask_h ! A mask that zeroes out cells with at least one land edge [nondim] + real, allocatable, dimension(:,:) :: hf_diffu_2d ! Depth sum of hf_diffu [L T-2 ~> m s-2] + real, allocatable, dimension(:,:) :: hf_diffv_2d ! Depth sum of hf_diffv [L T-2 ~> m s-2] + real, dimension(SZIB_(G),SZJB_(G)) :: & dvdx, dudy, & ! components in the shearing strain [T-1 ~> s-1] dDel2vdx, dDel2udy, & ! Components in the biharmonic equivalent of the shearing strain [L-2 T-1 ~> m-2 s-1] @@ -1307,12 +1320,47 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, call post_data(CS%id_FrictWorkIntz, FrictWorkIntz, CS%diag) endif + ! Diagnostics for terms multiplied by fractional thicknesses + + ! 3D diagnostics hf_diffu(diffv) are commented because there is no clarity on proper remapping grid option. + ! The code is retained for degugging purposes in the future. + !if (present(ADp) .and. (CS%id_hf_diffu > 0)) then + ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ! CS%hf_diffu(I,j,k) = diffu(I,j,k) * ADp%diag_hfrac_u(I,j,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_diffu, CS%hf_diffu, CS%diag) + !endif + !if (present(ADp) .and. (CS%id_hf_diffv > 0)) then + ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ! CS%hf_diffv(i,J,k) = diffv(i,J,k) * ADp%diag_hfrac_v(i,J,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_diffv, CS%hf_diffv, CS%diag) + !endif + if (present(ADp) .and. (CS%id_hf_diffu_2d > 0)) then + allocate(hf_diffu_2d(G%IsdB:G%IedB,G%jsd:G%jed)) + hf_diffu_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + hf_diffu_2d(I,j) = hf_diffu_2d(I,j) + diffu(I,j,k) * ADp%diag_hfrac_u(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_diffu_2d, hf_diffu_2d, CS%diag) + deallocate(hf_diffu_2d) + endif + if (present(ADp) .and. (CS%id_hf_diffv_2d > 0)) then + allocate(hf_diffv_2d(G%isd:G%ied,G%JsdB:G%JedB)) + hf_diffv_2d(:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + hf_diffv_2d(i,J) = hf_diffv_2d(i,J) + diffv(i,J,k) * ADp%diag_hfrac_v(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_diffv_2d, hf_diffv_2d, CS%diag) + deallocate(hf_diffv_2d) + endif + end subroutine horizontal_viscosity !> 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, US, param_file, diag, CS, MEKE) +subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE, ADp) type(time_type), intent(in) :: Time !< Current model time. type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -1321,6 +1369,7 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) 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 type(MEKE_type), pointer :: MEKE !< MEKE data + type(accel_diag_ptrs), optional, pointer :: ADp !< Acceleration diagnostic pointers ! Local variables real, dimension(SZIB_(G),SZJ_(G)) :: u0u, u0v real, dimension(SZI_(G),SZJB_(G)) :: v0u, v0v @@ -2016,6 +2065,36 @@ subroutine hor_visc_init(Time, G, US, param_file, diag, CS, MEKE) CS%id_diffv = register_diag_field('ocean_model', 'diffv', diag%axesCvL, Time, & 'Meridional Acceleration from Horizontal Viscosity', 'm s-2', conversion=US%L_T2_to_m_s2) + !CS%id_hf_diffu = register_diag_field('ocean_model', 'hf_diffu', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Zonal Acceleration from Horizontal Viscosity', 'm s-2', & + ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if ((CS%id_hf_diffu > 0) .and. (present(ADp))) then + ! call safe_alloc_ptr(CS%hf_diffu,G%IsdB,G%IedB,G%jsd,G%jed,G%ke) + ! call safe_alloc_ptr(ADp%diag_hfrac_u,G%IsdB,G%IedB,G%jsd,G%jed,G%ke) + !endif + + !CS%id_hf_diffv = register_diag_field('ocean_model', 'hf_diffv', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Meridional Acceleration from Horizontal Viscosity', 'm s-2', & + ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if ((CS%id_hf_diffv > 0) .and. (present(ADp))) then + ! call safe_alloc_ptr(CS%hf_diffv,G%isd,G%ied,G%JsdB,G%JedB,G%ke) + ! call safe_alloc_ptr(ADp%diag_hfrac_v,G%isd,G%ied,G%JsdB,G%JedB,G%ke) + !endif + + CS%id_hf_diffu_2d = register_diag_field('ocean_model', 'hf_diffu_2d', diag%axesCu1, Time, & + 'Depth-sum Fractional Thickness-weighted Zonal Acceleration from Horizontal Viscosity', 'm s-2', & + conversion=US%L_T2_to_m_s2) + if ((CS%id_hf_diffu_2d > 0) .and. (present(ADp))) then + call safe_alloc_ptr(ADp%diag_hfrac_u,G%IsdB,G%IedB,G%jsd,G%jed,G%ke) + endif + + CS%id_hf_diffv_2d = register_diag_field('ocean_model', 'hf_diffv_2d', diag%axesCv1, Time, & + 'Depth-sum Fractional Thickness-weighted Meridional Acceleration from Horizontal Viscosity', 'm s-2', & + conversion=US%L_T2_to_m_s2) + if ((CS%id_hf_diffv_2d > 0) .and. (present(ADp))) then + call safe_alloc_ptr(ADp%diag_hfrac_v,G%isd,G%ied,G%JsdB,G%JedB,G%ke) + endif + if (CS%biharmonic) then CS%id_Ah_h = register_diag_field('ocean_model', 'Ahh', diag%axesTL, Time, & 'Biharmonic Horizontal Viscosity at h Points', 'm4 s-1', conversion=US%L_to_m**4*US%s_to_T, & diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index f03cee72b8..c6a6f37b39 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -124,10 +124,18 @@ module MOM_vert_friction 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 + ! integer :: id_hf_du_dt_visc = -1, id_hf_dv_dt_visc = -1 + integer :: id_hf_du_dt_visc_2d = -1, id_hf_dv_dt_visc_2d = -1 !>@} type(PointAccel_CS), pointer :: PointAccel_CSp => NULL() !< A pointer to the control structure !! for recording accelerations leading to velocity truncations + + ! real, pointer :: hf_du_dt_visc(:,:,:) => NULL() ! Zonal friction accel. x fract. thickness [L T-2 ~> m s-2]. + ! real, pointer :: hf_dv_dt_visc(:,:,:) => NULL() ! Merdional friction accel. x fract. thickness [L T-2 ~> m s-2]. + ! 3D diagnostics hf_du(dv)_dt_visc are commented because there is no clarity on proper remapping grid option. + ! The code is retained for degugging purposes in the future. + end type vertvisc_CS contains @@ -202,11 +210,14 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & real :: surface_stress(SZIB_(G))! The same as stress, unless the wind stress ! stress is applied as a body force [H L T-1 ~> m2 s-1 or kg m-1 s-1]. + real, allocatable, dimension(:,:) :: hf_du_dt_visc_2d ! Depth sum of hf_du_dt_visc [L T-2 ~> m s-2] + real, allocatable, dimension(:,:) :: hf_dv_dt_visc_2d ! Depth sum of hf_dv_dt_visc [L T-2 ~> m s-2] + logical :: do_i(SZIB_(G)) logical :: DoStokesMixing - integer :: i, j, k, is, ie, Isq, Ieq, Jsq, Jeq, nz, n - is = G%isc ; ie = G%iec + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, n + 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 if (.not.associated(CS)) call MOM_error(FATAL,"MOM_vert_friction(visc): "// & @@ -453,6 +464,41 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & if (present(tauy_bot) .and. (CS%id_tauy_bot > 0)) & call post_data(CS%id_tauy_bot, tauy_bot, CS%diag) + ! Diagnostics for terms multiplied by fractional thicknesses + + ! 3D diagnostics hf_du(dv)_dt_visc are commented because there is no clarity on proper remapping grid option. + ! The code is retained for degugging purposes in the future. + !if (CS%id_hf_du_dt_visc > 0) then + ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ! CS%hf_du_dt_visc(I,j,k) = ADp%du_dt_visc(I,j,k) * ADp%diag_hfrac_u(I,j,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_du_dt_visc, CS%hf_du_dt_visc, CS%diag) + !endif + !if (CS%id_hf_dv_dt_visc > 0) then + ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ! CS%hf_dv_dt_visc(i,J,k) = ADp%dv_dt_visc(i,J,k) * ADp%diag_hfrac_v(i,J,k) + ! enddo ; enddo ; enddo + ! call post_data(CS%id_hf_dv_dt_visc, CS%hf_dv_dt_visc, CS%diag) + !endif + if (CS%id_hf_du_dt_visc_2d > 0) then + allocate(hf_du_dt_visc_2d(G%IsdB:G%IedB,G%jsd:G%jed)) + hf_du_dt_visc_2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + hf_du_dt_visc_2d(I,j) = hf_du_dt_visc_2d(I,j) + ADp%du_dt_visc(I,j,k) * ADp%diag_hfrac_u(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_du_dt_visc_2d, hf_du_dt_visc_2d, CS%diag) + deallocate(hf_du_dt_visc_2d) + endif + if (CS%id_hf_dv_dt_visc_2d > 0) then + allocate(hf_dv_dt_visc_2d(G%isd:G%ied,G%JsdB:G%JedB)) + hf_dv_dt_visc_2d(:,:) = 0.0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + hf_dv_dt_visc_2d(i,J) = hf_dv_dt_visc_2d(i,J) + ADp%dv_dt_visc(i,J,k) * ADp%diag_hfrac_v(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_hf_dv_dt_visc_2d, hf_dv_dt_visc_2d, CS%diag) + deallocate(hf_dv_dt_visc_2d) + endif + end subroutine vertvisc !> Calculate the fraction of momentum originally in a layer that remains @@ -1760,6 +1806,40 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & Time, 'Meridional Bottom Stress from Ocean to Earth', 'Pa', & conversion=US%RZ_to_kg_m2*US%L_T2_to_m_s2) + !CS%id_hf_du_dt_visc = register_diag_field('ocean_model', 'hf_du_dt_visc', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Zonal Acceleration from Vertical Viscosity', 'm s-2', & + ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_du_dt_visc > 0) then + ! call safe_alloc_ptr(CS%hf_du_dt_visc,IsdB,IedB,jsd,jed,nz) + ! call safe_alloc_ptr(ADp%du_dt_visc,IsdB,IedB,jsd,jed,nz) + ! call safe_alloc_ptr(ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + !endif + + !CS%id_hf_dv_dt_visc = register_diag_field('ocean_model', 'hf_dv_dt_visc', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Meridional Acceleration from Vertical Viscosity', 'm s-2', & + ! v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_dv_dt_visc > 0) then + ! call safe_alloc_ptr(CS%hf_dv_dt_visc,isd,ied,JsdB,JedB,nz) + ! call safe_alloc_ptr(ADp%dv_dt_visc,isd,ied,JsdB,JedB,nz) + ! call safe_alloc_ptr(ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + !endif + + CS%id_hf_du_dt_visc_2d = register_diag_field('ocean_model', 'hf_du_dt_visc_2d', diag%axesCu1, Time, & + 'Depth-sum Fractional Thickness-weighted Zonal Acceleration from Vertical Viscosity', 'm s-2', & + conversion=US%L_T2_to_m_s2) + if (CS%id_hf_du_dt_visc_2d > 0) then + call safe_alloc_ptr(ADp%du_dt_visc,IsdB,IedB,jsd,jed,nz) + call safe_alloc_ptr(ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + endif + + CS%id_hf_dv_dt_visc_2d = register_diag_field('ocean_model', 'hf_dv_dt_visc_2d', diag%axesCv1, Time, & + 'Depth-sum Fractional Thickness-weighted Meridional Acceleration from Vertical Viscosity', 'm s-2', & + conversion=US%L_T2_to_m_s2) + if (CS%id_hf_dv_dt_visc_2d > 0) then + call safe_alloc_ptr(ADp%dv_dt_visc,isd,ied,JsdB,JedB,nz) + call safe_alloc_ptr(ADp%diag_hfrac_v,isd,ied,Jsd,JedB,nz) + endif + if ((len_trim(CS%u_trunc_file) > 0) .or. (len_trim(CS%v_trunc_file) > 0)) & call PointAccel_init(MIS, Time, G, param_file, diag, dirs, CS%PointAccel_CSp) From 16a0a06566866cdf576320b0909841847a37430f Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 29 Jul 2020 21:25:37 -0400 Subject: [PATCH 78/91] OBC: H-dimensionality fixes This patch fixes three dimensionality errors in the OBC segments. - We add a missing GV%m_to_H conversion for time-dependent eta segments. - The `adjustSegmentEtaToFitBathymetry` function depends on the `segment%Htot` field when computing the dz_src cell spacings. While the calculation primarily assumes that all quantities scale as Z, the segment%Htot field scales as H, which was causing dimensionality errors. We resolve this by converting Htot from Z to H whenever it is used in the calculation. - Segment barotropic velocitys based on transports were limited to a hard-coded thickness of 1e-12, which was not scaled. We have added H-dimensional scaling to these constants. --- src/core/MOM_open_boundary.F90 | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 31f037c66e..35d559ab52 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -3947,7 +3947,8 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) G%dyCu(I,j) normal_trans_bt(I,j) = normal_trans_bt(I,j) + segment%normal_trans(I,j,k) enddo - segment%normal_vel_bt(I,j) = normal_trans_bt(I,j) / (max(segment%Htot(I,j),1.e-12) * G%dyCu(I,j)) + segment%normal_vel_bt(I,j) = normal_trans_bt(I,j) & + / (max(segment%Htot(I,j), 1.e-12 * GV%m_to_H) * 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 @@ -3960,7 +3961,8 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) G%dxCv(i,J) normal_trans_bt(i,J) = normal_trans_bt(i,J) + segment%normal_trans(i,J,k) enddo - segment%normal_vel_bt(i,J) = normal_trans_bt(i,J) / (max(segment%Htot(i,J),1.e-12) * G%dxCv(i,J)) + segment%normal_vel_bt(i,J) = normal_trans_bt(i,J) & + / (max(segment%Htot(i,J), 1.e-12 * GV%m_to_H) * 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. & @@ -4028,13 +4030,14 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) if (OBC%ramp) then do j=js_obc2,je_obc do i=is_obc2,ie_obc - segment%eta(i,j) = OBC%ramp_value * segment%field(m)%buffer_dst(i,j,1) + segment%eta(i,j) = GV%m_to_H * OBC%ramp_value & + * segment%field(m)%buffer_dst(i,j,1) enddo enddo else do j=js_obc2,je_obc do i=is_obc2,ie_obc - segment%eta(i,j) = segment%field(m)%buffer_dst(i,j,1) + segment%eta(i,j) = GV%m_to_H * segment%field(m)%buffer_dst(i,j,1) enddo enddo endif @@ -4883,8 +4886,8 @@ subroutine adjustSegmentEtaToFitBathymetry(G, GV, US, segment,fld) ! The normal slope at the boundary is zero by a ! previous call to open_boundary_impose_normal_slope do k=nz+1,1,-1 - if (-eta(i,j,k) > segment%Htot(i,j) + hTolerance) then - eta(i,j,k) = -segment%Htot(i,j) + if (-eta(i,j,k) > segment%Htot(i,j)*GV%H_to_Z + hTolerance) then + eta(i,j,k) = -segment%Htot(i,j)*GV%H_to_Z contractions = contractions + 1 endif enddo @@ -4902,10 +4905,10 @@ subroutine adjustSegmentEtaToFitBathymetry(G, GV, US, segment,fld) ! The whole column is dilated to accommodate deeper topography than ! the bathymetry would indicate. - if (-eta(i,j,nz+1) < segment%Htot(i,j) - hTolerance) then + if (-eta(i,j,nz+1) < (segment%Htot(i,j) * GV%H_to_Z) - hTolerance) then dilations = dilations + 1 ! expand bottom-most cell only - eta(i,j,nz+1) = -segment%Htot(i,j) + eta(i,j,nz+1) = -(segment%Htot(i,j) * GV%H_to_Z) segment%field(fld)%dz_src(i,j,nz)= eta(i,j,nz)-eta(i,j,nz+1) ! if (eta(i,j,1) <= eta(i,j,nz+1)) then ! do k=1,nz ; segment%field(fld)%dz_src(i,j,k) = (eta(i,j,1) + G%bathyT(i,j)) / real(nz) ; enddo From 46714ecfc2a5e1a6d798758c300f10d8ae3899ca Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 30 Jul 2020 10:56:15 -0400 Subject: [PATCH 79/91] OBC: Removal of segment zero The current OBC segment list includes a "segment zero" which corresponds to when the segment maps (segnum_u, segnum_v) point to OBC_NONE, which is set to zero. The purpose of this "segment zero" seems to be for avoiding invalid references, so that OBC%segment(OBC%segnum_[uv](i,j)) always returns a valid result, included when set to OBC_NONE. This results in reading and setting values which are unused or unneeded. This patch replaces these redundant accesses to segment zero with various conditional blocks for avoiding these accesses. --- src/core/MOM_barotropic.F90 | 15 ++- src/core/MOM_continuity_PPM.F90 | 109 +++++++++++++----- src/core/MOM_isopycnal_slopes.F90 | 49 ++++---- src/core/MOM_open_boundary.F90 | 9 +- .../lateral/MOM_lateral_mixing_coeffs.F90 | 36 ++++-- .../vertical/MOM_set_diffusivity.F90 | 44 ++++--- 6 files changed, 178 insertions(+), 84 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 7f34f18998..ae43868341 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -687,6 +687,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, integer :: is, ie, js, je, nz, Isq, Ieq, Jsq, Jeq integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB integer :: ioff, joff + integer :: l_seg if (.not.associated(CS)) call MOM_error(FATAL, & "btstep: Module MOM_barotropic must be initialized before it is used.") @@ -2324,9 +2325,12 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (CS%BT_OBC%apply_u_OBCs) then ! copy back the value for u-points on the boundary. !GOMP parallel do default(shared) do j=js,je ; do I=is-1,ie - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then + l_seg = OBC%segnum_u(I,j) + if (l_seg == OBC_NONE) cycle + + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_E) then e_anom(i+1,j) = e_anom(i,j) - elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then + elseif (OBC%segment(l_seg)%direction == OBC_DIRECTION_W) then e_anom(i,j) = e_anom(i+1,j) endif enddo ; enddo @@ -2335,9 +2339,12 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (CS%BT_OBC%apply_v_OBCs) then ! copy back the value for v-points on the boundary. !GOMP parallel do default(shared) do J=js-1,je ; do I=is,ie - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then + l_seg = OBC%segnum_v(i,J) + if (l_seg == OBC_NONE) cycle + + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_N) then e_anom(i,j+1) = e_anom(i,j) - elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then + elseif (OBC%segment(l_seg)%direction == OBC_DIRECTION_S) then e_anom(i,j) = e_anom(i,j+1) endif enddo ; enddo diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index c594d31494..995827959d 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -263,6 +263,7 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, uhbt, OBC, & real :: du_lim ! The velocity change that give a relative CFL of 1 [L T-1 ~> m s-1]. real :: dx_E, dx_W ! Effective x-grid spacings to the east and west [L ~> m]. integer :: i, j, k, ish, ieh, jsh, jeh, n, nz + integer :: l_seg logical :: 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 => NULL() @@ -303,7 +304,8 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, uhbt, OBC, & !$OMP uh,dt,US,G,GV,CS,local_specified_BC,OBC,uhbt,set_BT_cont, & !$OMP CFL_dt,I_dt,u_cor,BT_cont, local_Flather_OBC) & !$OMP private(do_I,duhdu,du,du_max_CFL,du_min_CFL,uh_tot_0,duhdu_tot_0, & -!$OMP is_simple,FAuI,visc_rem_max,I_vrm,du_lim,dx_E,dx_W,any_simple_OBC ) & +!$OMP is_simple,FAuI,visc_rem_max,I_vrm,du_lim,dx_E,dx_W, & +!$OMP any_simple_OBC,l_seg) & !$OMP firstprivate(visc_rem) do j=jsh,jeh do I=ish-1,ieh ; do_I(I) = .true. ; visc_rem_max(I) = 0.0 ; enddo @@ -318,8 +320,12 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, uhbt, OBC, & dt, G, US, j, ish, ieh, do_I, CS%vol_CFL, OBC) if (local_specified_BC) then do I=ish-1,ieh - if (OBC%segment(OBC%segnum_u(I,j))%specified) & - uh(I,j,k) = OBC%segment(OBC%segnum_u(I,j))%normal_trans(I,j,k) + l_seg = OBC%segnum_u(I,j) + + if (l_seg /= OBC_NONE) then + if (OBC%segment(l_seg)%specified) & + uh(I,j,k) = OBC%segment(l_seg)%normal_trans(I,j,k) + endif enddo endif enddo @@ -408,9 +414,13 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, uhbt, OBC, & any_simple_OBC = .false. if (present(uhbt) .or. set_BT_cont) then if (local_specified_BC .or. local_Flather_OBC) then ; do I=ish-1,ieh + l_seg = OBC%segnum_u(I,j) + ! Avoid reconciling barotropic/baroclinic transports if transport is specified - is_simple = OBC%segment(OBC%segnum_u(I,j))%specified - do_I(I) = .not.(OBC%segnum_u(I,j) /= OBC_NONE .and. is_simple) + is_simple = .false. + if (l_seg /= OBC_NONE) & + is_simple = OBC%segment(l_seg)%specified + do_I(I) = .not. (l_seg /= OBC_NONE .and. is_simple) any_simple_OBC = any_simple_OBC .or. is_simple enddo ; else ; do I=ish-1,ieh do_I(I) = .true. @@ -425,8 +435,12 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, uhbt, OBC, & if (present(u_cor)) then ; do k=1,nz do I=ish-1,ieh ; u_cor(I,j,k) = u(I,j,k) + du(I) * visc_rem(I,k) ; enddo if (local_specified_BC) then ; do I=ish-1,ieh - if (OBC%segment(OBC%segnum_u(I,j))%specified) & - u_cor(I,j,k) = OBC%segment(OBC%segnum_u(I,j))%normal_vel(I,j,k) + l_seg = OBC%segnum_u(I,j) + + if (l_seg /= OBC_NONE) then + if (OBC%segment(l_seg)%specified) & + u_cor(I,j,k) = OBC%segment(l_seg)%normal_vel(I,j,k) + endif enddo ; endif enddo ; endif ! u-corrected @@ -438,9 +452,15 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, uhbt, OBC, & visc_rem_max, j, ish, ieh, do_I) if (any_simple_OBC) then do I=ish-1,ieh - do_I(I) = OBC%segment(OBC%segnum_u(I,j))%specified + l_seg = OBC%segnum_u(I,j) + + do_I(I) = .false. + if (l_seg /= OBC_NONE) & + do_I(I) = OBC%segment(l_seg)%specified + if (do_I(I)) FAuI(I) = GV%H_subroundoff*G%dy_Cu(I,j) enddo + ! NOTE: do_I(I) should prevent access to segment OBC_NONE do k=1,nz ; do I=ish-1,ieh ; if (do_I(I)) then if ((abs(OBC%segment(OBC%segnum_u(I,j))%normal_vel(I,j,k)) > 0.0) .and. & (OBC%segment(OBC%segnum_u(I,j))%specified)) & @@ -529,6 +549,7 @@ subroutine zonal_flux_layer(u, h, h_L, h_R, uh, duhdu, visc_rem, dt, G, US, j, & ! with the same units as h_in. real :: h_marg ! The marginal thickness of a flux [H ~> m or kg m-2]. integer :: i + integer :: l_seg logical :: local_open_BC local_open_BC = .false. @@ -561,13 +582,17 @@ subroutine zonal_flux_layer(u, h, h_L, h_R, uh, duhdu, visc_rem, dt, G, US, j, & if (local_open_BC) then do I=ish-1,ieh ; if (do_I(I)) then - if (OBC%segment(OBC%segnum_u(I,j))%open) then - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then - uh(I) = G%dy_Cu(I,j) * u(I) * h(i) - duhdu(I) = G%dy_Cu(I,j) * h(i) * visc_rem(I) - else - uh(I) = G%dy_Cu(I,j) * u(I) * h(i+1) - duhdu(I) = G%dy_Cu(I,j) * h(i+1) * visc_rem(I) + l_seg = OBC%segnum_u(I,j) + + if (l_seg /= OBC_NONE) then + if (OBC%segment(l_seg)%open) then + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_E) then + uh(I) = G%dy_Cu(I,j) * u(I) * h(i) + duhdu(I) = G%dy_Cu(I,j) * h(i) * visc_rem(I) + else + uh(I) = G%dy_Cu(I,j) * u(I) * h(i+1) + duhdu(I) = G%dy_Cu(I,j) * h(i+1) * visc_rem(I) + endif endif endif endif ; enddo @@ -1062,6 +1087,7 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, vhbt, OBC, & real :: dv_lim ! The velocity change that give a relative CFL of 1 [L T-1 ~> m s-1]. real :: dy_N, dy_S ! Effective y-grid spacings to the north and south [L ~> m]. integer :: i, j, k, ish, ieh, jsh, jeh, n, nz + integer :: l_seg logical :: 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 => NULL() @@ -1103,7 +1129,7 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, vhbt, OBC, & !$OMP set_BT_cont,CFL_dt,I_dt,v_cor,BT_cont, local_Flather_OBC ) & !$OMP private(do_I,dvhdv,dv,dv_max_CFL,dv_min_CFL,vh_tot_0, & !$OMP dvhdv_tot_0,visc_rem_max,I_vrm,dv_lim,dy_N, & -!$OMP is_simple,FAvi,dy_S,any_simple_OBC ) & +!$OMP is_simple,FAvi,dy_S,any_simple_OBC,l_seg) & !$OMP firstprivate(visc_rem) do J=jsh-1,jeh do i=ish,ieh ; do_I(i) = .true. ; visc_rem_max(I) = 0.0 ; enddo @@ -1118,8 +1144,12 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, vhbt, OBC, & dt, G, US, J, ish, ieh, do_I, CS%vol_CFL, OBC) if (local_specified_BC) then do i=ish,ieh - if (OBC%segment(OBC%segnum_v(i,J))%specified) & - vh(i,J,k) = OBC%segment(OBC%segnum_v(i,J))%normal_trans(i,J,k) + l_seg = OBC%segnum_v(i,J) + + if (l_seg /= OBC_NONE) then + if (OBC%segment(l_seg)%specified) & + vh(i,J,k) = OBC%segment(l_seg)%normal_trans(i,J,k) + endif enddo endif enddo ! k-loop @@ -1204,9 +1234,13 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, vhbt, OBC, & any_simple_OBC = .false. if (present(vhbt) .or. set_BT_cont) then if (local_specified_BC .or. local_Flather_OBC) then ; do i=ish,ieh + l_seg = OBC%segnum_v(i,J) + ! Avoid reconciling barotropic/baroclinic transports if transport is specified - is_simple = OBC%segment(OBC%segnum_v(i,J))%specified - do_I(i) = .not.(OBC%segnum_v(i,J) /= OBC_NONE .and. is_simple) + is_simple = .false. + if (l_seg /= OBC_NONE) & + is_simple = OBC%segment(l_seg)%specified + do_I(i) = .not.(l_seg /= OBC_NONE .and. is_simple) any_simple_OBC = any_simple_OBC .or. is_simple enddo ; else ; do i=ish,ieh do_I(i) = .true. @@ -1221,8 +1255,12 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, vhbt, OBC, & if (present(v_cor)) then ; do k=1,nz do i=ish,ieh ; v_cor(i,J,k) = v(i,J,k) + dv(i) * visc_rem(i,k) ; enddo if (local_specified_BC) then ; do i=ish,ieh - if (OBC%segment(OBC%segnum_v(i,J))%specified) & - v_cor(i,J,k) = OBC%segment(OBC%segnum_v(i,J))%normal_vel(i,J,k) + l_seg = OBC%segnum_v(i,J) + + if (l_seg /= OBC_NONE) then + if (OBC%segment(OBC%segnum_v(i,J))%specified) & + v_cor(i,J,k) = OBC%segment(OBC%segnum_v(i,J))%normal_vel(i,J,k) + endif enddo ; endif enddo ; endif ! v-corrected endif @@ -1233,9 +1271,15 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, vhbt, OBC, & visc_rem_max, J, ish, ieh, do_I) if (any_simple_OBC) then do i=ish,ieh - do_I(i) = (OBC%segment(OBC%segnum_v(i,J))%specified) + l_seg = OBC%segnum_v(i,J) + + do_I(I) = .false. + if(l_seg /= OBC_NONE) & + do_I(i) = (OBC%segment(l_seg)%specified) + if (do_I(i)) FAvi(i) = GV%H_subroundoff*G%dx_Cv(i,J) enddo + ! NOTE: do_I(I) should prevent access to segment OBC_NONE do k=1,nz ; do i=ish,ieh ; if (do_I(i)) then if ((abs(OBC%segment(OBC%segnum_v(i,J))%normal_vel(i,J,k)) > 0.0) .and. & (OBC%segment(OBC%segnum_v(i,J))%specified)) & @@ -1327,6 +1371,7 @@ subroutine merid_flux_layer(v, h, h_L, h_R, vh, dvhdv, visc_rem, dt, G, US, J, & ! 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 + integer :: l_seg logical :: local_open_BC local_open_BC = .false. @@ -1360,13 +1405,17 @@ subroutine merid_flux_layer(v, h, h_L, h_R, vh, dvhdv, visc_rem, dt, G, US, J, & if (local_open_BC) then do i=ish,ieh ; if (do_I(i)) then - if (OBC%segment(OBC%segnum_v(i,J))%open) then - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then - vh(i) = G%dx_Cv(i,J) * v(i) * h(i,j) - dvhdv(i) = G%dx_Cv(i,J) * h(i,j) * visc_rem(i) - else - vh(i) = G%dx_Cv(i,J) * v(i) * h(i,j+1) - dvhdv(i) = G%dx_Cv(i,J) * h(i,j+1) * visc_rem(i) + l_seg = OBC%segnum_v(i,J) + + if (l_seg /= OBC_NONE) then + if (OBC%segment(l_seg)%open) then + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_N) then + vh(i) = G%dx_Cv(i,J) * v(i) * h(i,j) + dvhdv(i) = G%dx_Cv(i,J) * h(i,j) * visc_rem(i) + else + vh(i) = G%dx_Cv(i,J) * v(i) * h(i,j+1) + dvhdv(i) = G%dx_Cv(i,J) * h(i,j+1) * visc_rem(i) + endif endif endif endif ; enddo diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index 7a33dc7d77..c134366cd0 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -8,7 +8,7 @@ module MOM_isopycnal_slopes use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use MOM_EOS, only : calculate_density_derivs -use MOM_open_boundary, only : ocean_OBC_type +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE use MOM_open_boundary, only : OBC_DIRECTION_E, OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S implicit none ; private @@ -105,6 +105,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & integer, dimension(2) :: EOSdom_u, EOSdom_v ! Domains for the equation of state calculations at u and v points integer :: is, ie, js, je, nz, IsdB integer :: i, j, k + integer :: l_seg logical :: local_open_u_BC, local_open_v_BC if (present(halo)) then @@ -183,7 +184,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & !$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 drdx,mag_grad2,Slope,slope2_Ratio,l_seg) do j=js,je ; do K=nz,2,-1 if (.not.(use_EOS)) then drdiA = 0.0 ; drdiB = 0.0 @@ -260,15 +261,18 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & slope_x(I,j,K) = (Z_to_L*(e(i,j,K)-e(i+1,j,K))) * G%IdxCu(I,j) endif if (local_open_u_BC) then - if (OBC%segment(OBC%segnum_u(I,j))%open) then - slope_x(I,j,K) = 0. - ! This and/or the masking code below is to make slopes match inside - ! land mask. Might not be necessary except for DEBUG output. -! if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then -! slope_x(I+1,j,K) = 0. -! else -! slope_x(I-1,j,K) = 0. -! endif + l_seg = OBC%segnum_u(I,j) + if (l_seg /= OBC_NONE) then + if (OBC%segment(l_seg)%open) then + slope_x(I,j,K) = 0. + ! This and/or the masking code below is to make slopes match inside + ! land mask. Might not be necessary except for DEBUG output. +! if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then +! slope_x(I+1,j,K) = 0. +! else +! slope_x(I-1,j,K) = 0. +! endif + endif endif slope_x(I,j,K) = slope_x(I,j,k) * max(g%mask2dT(i,j),g%mask2dT(i+1,j)) endif @@ -286,7 +290,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & !$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) + !$OMP drdy,mag_grad2,Slope,slope2_Ratio,l_seg) do j=js-1,je ; do K=nz,2,-1 if (.not.(use_EOS)) then drdjA = 0.0 ; drdjB = 0.0 @@ -360,15 +364,18 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & slope_y(i,J,K) = (Z_to_L*(e(i,j,K)-e(i,j+1,K))) * G%IdyCv(i,J) endif if (local_open_v_BC) then - if (OBC%segment(OBC%segnum_v(i,J))%open) then - slope_y(i,J,K) = 0. - ! This and/or the masking code below is to make slopes match inside - ! land mask. Might not be necessary except for DEBUG output. -! if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then -! slope_y(i,J+1,K) = 0. -! else -! slope_y(i,J-1,K) = 0. -! endif + l_seg = OBC%segnum_v(i,J) + if (l_seg /= OBC_NONE) then + if (OBC%segment(l_seg)%open) then + slope_y(i,J,K) = 0. + ! This and/or the masking code below is to make slopes match inside + ! land mask. Might not be necessary except for DEBUG output. +! if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then +! slope_y(i,J+1,K) = 0. +! else +! slope_y(i,J-1,K) = 0. +! endif + endif endif slope_y(i,J,K) = slope_y(i,J,k) * max(g%mask2dT(i,j),g%mask2dT(i,j+1)) endif diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 31f037c66e..b09cdc50c6 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -445,9 +445,8 @@ subroutine open_boundary_config(G, US, param_file, OBC) 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 - allocate(OBC%segment(0:OBC%number_of_segments)) - do l=0,OBC%number_of_segments + allocate(OBC%segment(1:OBC%number_of_segments)) + do l=1,OBC%number_of_segments OBC%segment(l)%Flather = .false. OBC%segment(l)%radiation = .false. OBC%segment(l)%radiation_tan = .false. @@ -4971,7 +4970,7 @@ subroutine rotate_OBC_config(OBC_in, G_in, OBC, G, turns) ! Segment rotation allocate(OBC%segment(0:OBC%number_of_segments)) - do l = 0, OBC%number_of_segments + do l = 1, OBC%number_of_segments call rotate_OBC_segment_config(OBC_in%segment(l), G_in, OBC%segment(l), G, turns) ! Data up to setup_[uv]_point_obc is needed for allocate_obc_segment_data! call allocate_OBC_segment_data(OBC, OBC%segment(l)) @@ -5168,7 +5167,7 @@ subroutine rotate_OBC_init(OBC_in, G, GV, US, param_file, tv, restart_CSp, OBC) "If true, Temperature and salinity are used as state "//& "variables.", default=.true., do_not_log=.true.) - do l = 0, OBC%number_of_segments + do l = 1, OBC%number_of_segments call rotate_OBC_segment_data(OBC_in%segment(l), OBC%segment(l), G%HI%turns) enddo diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index e0def91821..9a0a994450 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -17,7 +17,7 @@ module MOM_lateral_mixing_coeffs 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 -use MOM_open_boundary, only : ocean_OBC_type +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE implicit none ; private @@ -499,6 +499,7 @@ subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS, O 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 + integer :: l_seg real :: S2max, wNE, wSE, wSW, wNW real :: H_u(SZIB_(G)), H_v(SZI_(G)) real :: S2_u(SZIB_(G), SZJ_(G)) @@ -568,8 +569,12 @@ subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS, O CS%SN_u(I,j) = 0. endif if (local_open_u_BC) then - if (OBC%segment(OBC%segnum_u(I,j))%open) then - CS%SN_u(i,J) = 0. + l_seg = OBC%segnum_u(I,j) + + if (l_seg /= OBC_NONE) then + if (OBC%segment(l_seg)%open) then + CS%SN_u(i,J) = 0. + endif endif endif enddo @@ -609,8 +614,12 @@ subroutine calc_Visbeck_coeffs(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, CS, O CS%SN_v(i,J) = 0. endif if (local_open_v_BC) then - if (OBC%segment(OBC%segnum_v(i,J))%open) then - CS%SN_v(i,J) = 0. + l_seg = OBC%segnum_v(i,J) + + if (l_seg /= OBC_NONE) then + if (OBC%segment(OBC%segnum_v(i,J))%open) then + CS%SN_v(i,J) = 0. + endif endif endif enddo @@ -657,6 +666,7 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop 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 + integer :: l_seg real :: S2N2_u_local(SZIB_(G), SZJ_(G),SZK_(G)) real :: S2N2_v_local(SZI_(G), SZJB_(G),SZK_(G)) logical :: local_open_u_BC, local_open_v_BC @@ -754,8 +764,12 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop CS%SN_u(I,j) = 0.0 endif if (local_open_u_BC) then - if (OBC%segment(OBC%segnum_u(I,j))%open) then - CS%SN_u(I,j) = 0. + l_seg = OBC%segnum_u(I,j) + + if (l_seg /= OBC_NONE) then + if (OBC%segment(l_seg)%open) then + CS%SN_u(I,j) = 0. + endif endif endif enddo @@ -776,8 +790,12 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop CS%SN_v(I,j) = 0.0 endif if (local_open_v_BC) then - if (OBC%segment(OBC%segnum_v(I,j))%open) then - CS%SN_v(I,j) = 0. + l_seg = OBC%segnum_v(I,j) + + if (l_seg /= OBC_NONE) then + if (OBC%segment(OBC%segnum_v(I,j))%open) then + CS%SN_v(I,j) = 0. + endif endif endif enddo diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 86f828e5fa..42babae7d8 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -1677,7 +1677,9 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS, OBC) logical :: domore, do_i(SZI_(G)) integer :: i, j, k, is, ie, js, je, nz + integer :: l_seg logical :: local_open_u_BC, local_open_v_BC + logical :: has_obc local_open_u_BC = .false. local_open_v_BC = .false. @@ -1718,15 +1720,21 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS, OBC) do k=nz,1,-1 domore = .false. do i=is,ie ; if (do_i(i)) then + ! Determine if grid point is an OBC + has_obc = .false. if (local_open_v_BC) then - if (OBC%segment(OBC%segnum_v(i,J))%open) then - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then - hvel = GV%H_to_Z*h(i,j,k) - else - hvel = GV%H_to_Z*h(i,j+1,k) - endif + l_seg = OBC%segnum_v(i,J) + if (l_seg /= OBC_NONE) then + has_obc = OBC%segment(l_seg)%open + endif + endif + + ! Compute h based on OBC state + if (has_obc) then + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_N) then + hvel = GV%H_to_Z*h(i,j,k) else - hvel = 0.5*GV%H_to_Z*(h(i,j,k) + h(i,j+1,k)) + hvel = GV%H_to_Z*h(i,j+1,k) endif else hvel = 0.5*GV%H_to_Z*(h(i,j,k) + h(i,j+1,k)) @@ -1760,15 +1768,21 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS, OBC) endif ; enddo do k=nz,1,-1 ; domore = .false. do I=is-1,ie ; if (do_i(I)) then + ! Determine if grid point is an OBC + has_obc = .false. if (local_open_u_BC) then - if (OBC%segment(OBC%segnum_u(I,j))%open) then - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then - hvel = GV%H_to_Z*h(i,j,k) - else - hvel = GV%H_to_Z*h(i+1,j,k) - endif - else - hvel = 0.5*GV%H_to_Z*(h(i,j,k) + h(i+1,j,k)) + l_seg = OBC%segnum_u(I,j) + if (l_seg /= OBC_NONE) then + has_obc = OBC%segment(l_seg)%open + endif + endif + + ! Compute h based on OBC state + if (has_obc) then + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_E) then + hvel = GV%H_to_Z*h(i,j,k) + else ! OBC_DIRECTION_W + hvel = GV%H_to_Z*h(i+1,j,k) endif else hvel = 0.5*GV%H_to_Z*(h(i,j,k) + h(i+1,j,k)) From a243225b3e8a18b74b3ebbdc58ac80f231be2408 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 30 Jul 2020 15:14:26 -0400 Subject: [PATCH 80/91] OBC: Remove segment 0 refs in mask_outside_OBCs There were a few remaining segnum_[uv] references in MOM_open_boundary which could reference segment zero. This patch fixes those references. --- src/core/MOM_open_boundary.F90 | 29 +++++++++++++++++++++-------- 1 file changed, 21 insertions(+), 8 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index b09cdc50c6..74cad3cf0c 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -4416,6 +4416,7 @@ subroutine mask_outside_OBCs(G, US, param_file, OBC) ! Local variables integer :: isd, ied, IsdB, IedB, jsd, jed, JsdB, JedB, n integer :: i, j + integer :: l_seg logical :: fatal_error = .False. real :: min_depth integer, parameter :: cin = 3, cout = 4, cland = -1, cedge = -2 @@ -4457,38 +4458,50 @@ subroutine mask_outside_OBCs(G, US, param_file, OBC) enddo do j=G%jsd,G%jed ; do i=G%IsdB+1,G%IedB-1 - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then + l_seg = OBC%segnum_u(I,j) + if (l_seg == OBC_NONE) cycle + + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_W) then if (color(i,j) == 0.0) color(i,j) = cout if (color(i+1,j) == 0.0) color(i+1,j) = cin - elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then + elseif (OBC%segment(l_seg)%direction == OBC_DIRECTION_E) then if (color(i,j) == 0.0) color(i,j) = cin if (color(i+1,j) == 0.0) color(i+1,j) = cout endif enddo ; enddo do J=G%JsdB+1,G%JedB-1 ; do i=G%isd,G%ied - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then + l_seg = OBC%segnum_v(i,J) + if (l_seg == OBC_NONE) cycle + + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_S) then if (color(i,j) == 0.0) color(i,j) = cout if (color(i,j+1) == 0.0) color(i,j+1) = cin - elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then + elseif (OBC%segment(l_seg)%direction == OBC_DIRECTION_N) then if (color(i,j) == 0.0) color(i,j) = cin if (color(i,j+1) == 0.0) color(i,j+1) = cout endif enddo ; enddo do J=G%JsdB+1,G%JedB-1 ; do i=G%isd,G%ied - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then + l_seg = OBC%segnum_v(i,J) + if (l_seg == OBC_NONE) cycle + + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_S) then if (color2(i,j) == 0.0) color2(i,j) = cout if (color2(i,j+1) == 0.0) color2(i,j+1) = cin - elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then + elseif (OBC%segment(l_seg)%direction == OBC_DIRECTION_N) then if (color2(i,j) == 0.0) color2(i,j) = cin if (color2(i,j+1) == 0.0) color2(i,j+1) = cout endif enddo ; enddo do j=G%jsd,G%jed ; do i=G%IsdB+1,G%IedB-1 - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then + l_seg = OBC%segnum_u(I,j) + if (l_seg == OBC_NONE) cycle + + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_W) then if (color2(i,j) == 0.0) color2(i,j) = cout if (color2(i+1,j) == 0.0) color2(i+1,j) = cin - elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then + elseif (OBC%segment(l_seg)%direction == OBC_DIRECTION_E) then if (color2(i,j) == 0.0) color2(i,j) = cin if (color2(i+1,j) == 0.0) color2(i+1,j) = cout endif From 1daad4469b4bc63763546789b7cd8a57ef73e58e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 31 Jul 2020 14:48:52 -0400 Subject: [PATCH 81/91] (*)Improve make_frazil Improve the handling of very thin layers in make_frazil. This does not change answers for typical values of ANGSTROM, but can avoid problems that can arise when ANGSTROM=0. All answers in the existing MOM6-examples test cases are bitwise identical. --- src/parameterizations/vertical/MOM_diabatic_aux.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 91085047c9..ee9a7bacff 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -195,14 +195,14 @@ subroutine make_frazil(h, tv, G, GV, US, CS, p_surf, halo) endif hc = (tv%C_p*GV%H_to_RZ) * h(i,j,k) - if (h(i,j,k) <= 10.0*GV%Angstrom_H) then + if (h(i,j,k) <= 10.0*(GV%Angstrom_H + GV%H_subroundoff)) 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)) tv%T(i,j,k) = T_freeze(i) endif - else - if (fraz_col(i) + hc * (T_freeze(i) - tv%T(i,j,k)) <= 0.0) then + elseif ((fraz_col(i) > 0.0) .or. (tv%T(i,j,k) < T_freeze(i))) then + if (fraz_col(i) + hc * (T_freeze(i) - tv%T(i,j,k)) < 0.0) then tv%T(i,j,k) = tv%T(i,j,k) - fraz_col(i) / hc fraz_col(i) = 0.0 else From 948e2926f5c3288283266faf6bc5ca8d6bd25c3d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 31 Jul 2020 14:50:03 -0400 Subject: [PATCH 82/91] (*)Improve advective CFL calculation with tiny h Improved handling of massless layers in the calculation of the advective CFL numbers used in PPM tracer advection by using an Adcroft reciprocal instead of adding a small value in the denominator. Although all answers are bitwise identical in the existing MOM6-examples test cases, this can avoid problems with tracer advection when ANGSTROM is 0 or very small like those that were recently found in analogous SIS2 code. --- src/tracer/MOM_tracer_advect.F90 | 104 ++++++++++++------------------- 1 file changed, 40 insertions(+), 64 deletions(-) diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index 6a362d4fd5..e9c8fb0e7b 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -140,16 +140,15 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & !$OMP hprev,domore_k,js,je,is,ie,uhtr,vhtr,G,GV,h_end,& !$OMP uh_neglect,vh_neglect,ntr,Tr,h_prev_opt) -! This initializes the halos of uhr and vhr because pass_vector might do -! calculations on them, even though they are never used. -!$OMP do - + ! This initializes the halos of uhr and vhr because pass_vector might do + ! calculations on them, even though they are never used. + !$OMP do do k=1,nz do j=jsd,jed ; do I=IsdB,IedB ; uhr(I,j,k) = 0.0 ; enddo ; enddo do J=jsdB,jedB ; do i=Isd,Ied ; vhr(i,J,k) = 0.0 ; enddo ; enddo do j=jsd,jed ; do i=Isd,Ied ; hprev(i,j,k) = 0.0 ; enddo ; enddo domore_k(k)=1 -! Put the remaining (total) thickness fluxes into uhr and vhr. + ! Put the remaining (total) thickness fluxes into uhr and vhr. do j=js,je ; do I=is-1,ie ; uhr(I,j,k) = uhtr(I,j,k) ; enddo ; enddo do J=js-1,je ; do i=is,ie ; vhr(i,J,k) = vhtr(i,J,k) ; enddo ; enddo if (.not. present(h_prev_opt)) then @@ -173,17 +172,17 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & enddo -!$OMP do + !$OMP do do j=jsd,jed ; do I=isd,ied-1 - uh_neglect(I,j) = GV%H_subroundoff*MIN(G%areaT(i,j),G%areaT(i+1,j)) + uh_neglect(I,j) = GV%H_subroundoff * MIN(G%areaT(i,j), G%areaT(i+1,j)) enddo ; enddo -!$OMP do + !$OMP do do J=jsd,jed-1 ; do i=isd,ied - vh_neglect(i,J) = GV%H_subroundoff*MIN(G%areaT(i,j),G%areaT(i,j+1)) + vh_neglect(i,J) = GV%H_subroundoff * MIN(G%areaT(i,j), G%areaT(i,j+1)) enddo ; enddo -!$OMP do ! initialize diagnostic fluxes and tendencies + !$OMP do do m=1,ntr if (associated(Tr(m)%ad_x)) then do k=1,nz ; do j=jsd,jed ; do i=isd,ied @@ -207,7 +206,7 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & do J=jsd,jed ; do i=isd,ied ; Tr(m)%ad2d_y(i,J) = 0.0 ; enddo ; enddo endif enddo -!$OMP end parallel + !$OMP end parallel isv = is ; iev = ie ; jsv = js ; jev = je @@ -222,8 +221,7 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & ! Reevaluate domore_u & domore_v unless the valid range is the same size as ! before. Also, do this if there is Strang splitting. if ((nsten_halo > 1) .or. (itt==1)) then -!$OMP parallel do default(none) shared(nz,domore_k,jsv,jev,domore_u,isv,iev,stencil, & -!$OMP uhr,domore_v,vhr) + !$OMP parallel do default(shared) do k=1,nz ; if (domore_k(k) > 0) then do j=jsv,jev ; if (.not.domore_u(j,k)) then do i=isv+stencil-1,iev-stencil; if (uhr(I,j,k) /= 0.0) then @@ -256,9 +254,7 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & ! for all the transport to happen. The sum over domore_k keeps the processors ! synchronized. This may not be very efficient, but it should be reliable. -!$OMP parallel default(private) shared(nz,domore_k,x_first,Tr,hprev,uhr,uh_neglect, & -!$OMP OBC,domore_u,ntr,Idt,isv,iev,jsv,jev,stencil, & -!$OMP G,GV,CS,vhr,vh_neglect,domore_v,US) + !$OMP parallel default(shared) if (x_first) then @@ -305,7 +301,7 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & endif ! x_first -!$OMP end parallel + !$OMP end parallel ! If the advection just isn't finishing after max_iter, move on. if (itt >= max_iter) then @@ -385,6 +381,7 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & CFL ! The absolute value of the advective upwind-cell CFL number [nondim]. real :: min_h ! The minimum thickness that can be realized during ! any of the passes [H ~> m or kg m-2]. + real :: tiny_h ! The smallest numerically invertable 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 [H ~> m or kg m-2]. logical :: do_i(SZIB_(G),SZJ_(G)) ! If true, work on given points. @@ -406,16 +403,15 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & if (usePPM .and. .not. useHuynh) stencil = 2 min_h = 0.1*GV%Angstrom_H + tiny_h = tiny(min_h) h_neglect = GV%H_subroundoff -! do I=is-1,ie ; ts2(I) = 0.0 ; enddo do I=is-1,ie ; CFL(I) = 0.0 ; enddo do j=js,je ; if (domore_u(j,k)) then domore_u(j,k) = .false. - ! Calculate the i-direction profiles (slopes) of each tracer that - ! is being advected. + ! Calculate the i-direction profiles (slopes) of each tracer that is being advected. if (usePLMslope) then do m=1,ntr ; do i=is-stencil,ie+stencil !if (ABS(Tr(m)%t(i+1,j,k)-Tr(m)%t(i,j,k)) < & @@ -490,33 +486,33 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & ! in the cell plus whatever part of its half of the mass flux that ! the flux through the other side does not require. do I=is-1,ie - if (uhr(I,j,k) == 0.0) then + if ((uhr(I,j,k) == 0.0) .or. & + ((uhr(I,j,k) < 0.0) .and. (hprev(i+1,j,k) <= tiny_h)) .or. & + ((uhr(I,j,k) > 0.0) .and. (hprev(i,j,k) <= tiny_h)) ) then uhh(I) = 0.0 CFL(I) = 0.0 elseif (uhr(I,j,k) < 0.0) then hup = hprev(i+1,j,k) - G%areaT(i+1,j)*min_h - hlos = MAX(0.0,uhr(I+1,j,k)) + hlos = MAX(0.0, uhr(I+1,j,k)) if ((((hup - hlos) + uhr(I,j,k)) < 0.0) .and. & ((0.5*hup + uhr(I,j,k)) < 0.0)) then - uhh(I) = MIN(-0.5*hup,-hup+hlos,0.0) + uhh(I) = MIN(-0.5*hup, -hup+hlos, 0.0) domore_u(j,k) = .true. else uhh(I) = uhr(I,j,k) endif - !ts2(I) = 0.5*(1.0 + uhh(I) / (hprev(i+1,j,k) + h_neglect*G%areaT(i+1,j))) - CFL(I) = - uhh(I) / (hprev(i+1,j,k) + h_neglect*G%areaT(i+1,j)) ! CFL is positive + CFL(I) = - uhh(I) / (hprev(i+1,j,k)) ! CFL is positive else hup = hprev(i,j,k) - G%areaT(i,j)*min_h - hlos = MAX(0.0,-uhr(I-1,j,k)) + hlos = MAX(0.0, -uhr(I-1,j,k)) if ((((hup - hlos) - uhr(I,j,k)) < 0.0) .and. & ((0.5*hup - uhr(I,j,k)) < 0.0)) then - uhh(I) = MAX(0.5*hup,hup-hlos,0.0) + uhh(I) = MAX(0.5*hup, hup-hlos, 0.0) domore_u(j,k) = .true. else uhh(I) = uhr(I,j,k) endif - !ts2(I) = 0.5*(1.0 - uhh(I) / (hprev(i,j,k) + h_neglect*G%areaT(i,j))) - CFL(I) = uhh(I) / (hprev(i,j,k) + h_neglect*G%areaT(i,j)) ! CFL is positive + CFL(I) = uhh(I) / (hprev(i,j,k)) ! CFL is positive endif enddo @@ -545,11 +541,11 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & dA = aR - aL ; mA = 0.5*( aR + aL ) if (G%mask2dCu(I_up,j)*G%mask2dCu(I_up-1,j)*(Tp-Tc)*(Tc-Tm) <= 0.) then - aL = Tc ; aR = Tc ! PCM for local extremum and bounadry cells + aL = Tc ; aR = Tc ! PCM for local extremum and bounadry cells elseif ( dA*(Tc-mA) > (dA*dA)/6. ) then - aL = 3.*Tc - 2.*aR + aL = 3.*Tc - 2.*aR elseif ( dA*(Tc-mA) < - (dA*dA)/6. ) then - aR = 3.*Tc - 2.*aL + aR = 3.*Tc - 2.*aL endif a6 = 6.*Tc - 3. * (aR + aL) ! Curvature @@ -570,28 +566,17 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & !aR = Tr(m)%t(i,j,k) + 0.5 * slope_x(i,m) !flux_x(I,j,m) = uhh(I)*( aR - 0.5 * (aR-aL) * CFL(I) ) ! Alternative implementation of PLM - !aR = Tr(m)%t(i,j,k) + 0.5 * slope_x(i,m) - !flux_x(I,j,m) = uhh(I)*( aR - 0.5 * slope_x(i,m) * CFL(I) ) - ! Alternative implementation of PLM Tc = T_tmp(i,m) flux_x(I,j,m) = uhh(I)*( Tc + 0.5 * slope_x(i,m) * ( 1. - CFL(I) ) ) - ! Original implementation of PLM - !flux_x(I,j,m) = uhh(I)*(Tr(m)%t(i,j,k) + slope_x(i,m)*ts2(I)) else ! Indirect implementation of PLM !aL = Tr(m)%t(i+1,j,k) - 0.5 * slope_x(i+1,m) !aR = Tr(m)%t(i+1,j,k) + 0.5 * slope_x(i+1,m) !flux_x(I,j,m) = uhh(I)*( aL + 0.5 * (aR-aL) * CFL(I) ) ! Alternative implementation of PLM - !aL = Tr(m)%t(i+1,j,k) - 0.5 * slope_x(i+1,m) - !flux_x(I,j,m) = uhh(I)*( aL + 0.5 * slope_x(i+1,m) * CFL(I) ) - ! Alternative implementation of PLM Tc = T_tmp(i+1,m) flux_x(I,j,m) = uhh(I)*( Tc - 0.5 * slope_x(i+1,m) * ( 1. - CFL(I) ) ) - ! Original implementation of PLM - !flux_x(I,j,m) = uhh(I)*(Tr(m)%t(i+1,j,k) - slope_x(i+1,m)*ts2(I)) endif - !ts2(I) = 0.5*(1.0 - uhh(I)/(hprev(i,j,k)+h_neglect*G%areaT(i,j))) enddo ; enddo endif ! usePPM @@ -760,6 +745,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & CFL ! The absolute value of the advective upwind-cell CFL number [nondim]. real :: min_h ! The minimum thickness that can be realized during ! any of the passes [H ~> m or kg m-2]. + real :: tiny_h ! The smallest numerically invertable 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 [H ~> m or kg m-2]. logical :: do_j_tr(SZJ_(G)) ! If true, calculate the tracer profiles. @@ -777,8 +763,8 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & if (usePPM .and. .not. useHuynh) stencil = 2 min_h = 0.1*GV%Angstrom_H + tiny_h = tiny(min_h) h_neglect = GV%H_subroundoff - !do i=is,ie ; ts2(i) = 0.0 ; enddo ! We conditionally perform work on tracer points: calculating the PLM slope, ! and updating tracer concentration within a cell @@ -822,7 +808,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & ! make a copy of the tracers in case values need to be overridden for OBCs - do j=G%jsd,G%jed; do m=1,ntr; do i=G%isd,G%ied + do j=G%jsd,G%jed ; do m=1,ntr ; do i=G%isd,G%ied T_tmp(i,m,j) = Tr(m)%t(i,j,k) enddo ; enddo ; enddo @@ -873,33 +859,33 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & domore_v(J,k) = .false. do i=is,ie - if (vhr(i,J,k) == 0.0) then + if ((vhr(i,J,k) == 0.0) .or. & + ((vhr(i,J,k) < 0.0) .and. (hprev(i,j+1,k) <= tiny_h)) .or. & + ((vhr(i,J,k) > 0.0) .and. (hprev(i,j,k) <= tiny_h)) ) then vhh(i,J) = 0.0 CFL(i) = 0.0 elseif (vhr(i,J,k) < 0.0) then hup = hprev(i,j+1,k) - G%areaT(i,j+1)*min_h - hlos = MAX(0.0,vhr(i,J+1,k)) + hlos = MAX(0.0, vhr(i,J+1,k)) if ((((hup - hlos) + vhr(i,J,k)) < 0.0) .and. & ((0.5*hup + vhr(i,J,k)) < 0.0)) then - vhh(i,J) = MIN(-0.5*hup,-hup+hlos,0.0) + vhh(i,J) = MIN(-0.5*hup, -hup+hlos, 0.0) domore_v(J,k) = .true. else vhh(i,J) = vhr(i,J,k) endif - !ts2(i) = 0.5*(1.0 + vhh(i,J) / (hprev(i,j+1,k) + h_neglect*G%areaT(i,j+1)) - CFL(i) = - vhh(i,J) / (hprev(i,j+1,k) + h_neglect*G%areaT(i,j+1)) ! CFL is positive + CFL(i) = - vhh(i,J) / hprev(i,j+1,k) ! CFL is positive else hup = hprev(i,j,k) - G%areaT(i,j)*min_h - hlos = MAX(0.0,-vhr(i,J-1,k)) + hlos = MAX(0.0, -vhr(i,J-1,k)) if ((((hup - hlos) - vhr(i,J,k)) < 0.0) .and. & ((0.5*hup - vhr(i,J,k)) < 0.0)) then - vhh(i,J) = MAX(0.5*hup,hup-hlos,0.0) + vhh(i,J) = MAX(0.5*hup, hup-hlos, 0.0) domore_v(J,k) = .true. else vhh(i,J) = vhr(i,J,k) endif - !ts2(i) = 0.5*(1.0 - vhh(i,J) / (hprev(i,j,k) + h_neglect*G%areaT(i,j))) - CFL(i) = vhh(i,J) / (hprev(i,j,k) + h_neglect*G%areaT(i,j)) ! CFL is positive + CFL(i) = vhh(i,J) / hprev(i,j,k) ! CFL is positive endif enddo @@ -952,26 +938,16 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & !aR = Tr(m)%t(i,j,k) + 0.5 * slope_y(i,m,j) !flux_y(i,m,J) = vhh(i,J)*( aR - 0.5 * (aR-aL) * CFL(i) ) ! Alternative implementation of PLM - !aR = Tr(m)%t(i,j,k) + 0.5 * slope_y(i,m,j) - !flux_y(i,m,J) = vhh(i,J)*(aR - 0.5 * slope_y(i,m,j)*CFL(i)) - ! Alternative implementation of PLM Tc = T_tmp(i,m,j) flux_y(i,m,J) = vhh(i,J)*( Tc + 0.5 * slope_y(i,m,j) * ( 1. - CFL(i) ) ) - ! Original implementation of PLM - !flux_y(i,m,J) = vhh(i,J)*(Tr(m)%t(i,j,k) + slope_y(i,m,j)*ts2(i)) else ! Indirect implementation of PLM !aL = Tr(m)%t(i,j+1,k) - 0.5 * slope_y(i,m,j+1) !aR = Tr(m)%t(i,j+1,k) + 0.5 * slope_y(i,m,j+1) !flux_y(i,m,J) = vhh(i,J)*( aL + 0.5 * (aR-aL) * CFL(i) ) ! Alternative implementation of PLM - !aL = Tr(m)%t(i,j+1,k) - 0.5 * slope_y(i,m,j+1) - !flux_y(i,m,J) = vhh(i,J)*( aL + 0.5 * slope_y(i,m,j+1)*CFL(i) ) - ! Alternative implementation of PLM Tc = T_tmp(i,m,j+1) flux_y(i,m,J) = vhh(i,J)*( Tc - 0.5 * slope_y(i,m,j+1) * ( 1. - CFL(i) ) ) - ! Original implementation of PLM - !flux_y(i,m,J) = vhh(i,J)*(Tr(m)%t(i,j+1,k) - slope_y(i,m,j+1)*ts2(i)) endif enddo ; enddo endif ! usePPM From cbbf84847384f2860bf8de765b5c1cb34687cb75 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 31 Jul 2020 15:02:28 -0400 Subject: [PATCH 83/91] Infrastructure calls via framework directory Revised module use statements and some infrastructure calls to go via the MOM6 framework directory rather than directly calling FMS infrastructure routines. All answers are bitwise identical. --- .../MOM_surface_forcing_gfdl.F90 | 4 +-- src/ice_shelf/MOM_ice_shelf.F90 | 1 - src/ice_shelf/MOM_ice_shelf_state.F90 | 1 - .../MOM_state_initialization.F90 | 20 ++++-------- src/tracer/MOM_generic_tracer.F90 | 32 +++++++++---------- src/tracer/MOM_offline_aux.F90 | 3 +- src/tracer/MOM_offline_main.F90 | 3 +- src/tracer/RGC_tracer.F90 | 5 ++- 8 files changed, 26 insertions(+), 43 deletions(-) diff --git a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 index a04ee426e6..7075fb7c10 100644 --- a/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing_gfdl.F90 @@ -9,10 +9,8 @@ module MOM_surface_forcing_gfdl 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_diag_mediator, only : diag_ctrl, 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 diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 6b68cb3deb..66fd873f67 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -51,7 +51,6 @@ module MOM_ice_shelf 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 implicit none ; private #include diff --git a/src/ice_shelf/MOM_ice_shelf_state.F90 b/src/ice_shelf/MOM_ice_shelf_state.F90 index b3e88697f2..a3784b5a34 100644 --- a/src/ice_shelf/MOM_ice_shelf_state.F90 +++ b/src/ice_shelf/MOM_ice_shelf_state.F90 @@ -12,7 +12,6 @@ module MOM_ice_shelf_state 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 diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index e451966364..a201e4a85f 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -18,23 +18,17 @@ module MOM_state_initialization use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type, isPointInCell use MOM_interface_heights, only : find_eta -use MOM_io, only : file_exists -use MOM_io, only : MOM_read_data, MOM_read_vector -use MOM_io, only : slasher -use MOM_open_boundary, only : ocean_OBC_type, open_boundary_init +use MOM_io, only : file_exists, field_size, MOM_read_data, MOM_read_vector, slasher +use MOM_open_boundary, only : ocean_OBC_type, open_boundary_init, set_tracer_data use MOM_open_boundary, only : OBC_NONE, OBC_SIMPLE -use MOM_open_boundary, only : open_boundary_query -use MOM_open_boundary, only : set_tracer_data -use MOM_open_boundary, only : open_boundary_test_extern_h -use MOM_open_boundary, only : fill_temp_salt_segments -use MOM_open_boundary, only : update_OBC_segment_data +use MOM_open_boundary, only : open_boundary_query, open_boundary_test_extern_h +use MOM_open_boundary, only : fill_temp_salt_segments, update_OBC_segment_data !use MOM_open_boundary, only : set_3D_OBC_data use MOM_grid_initialize, only : initialize_masks, set_grid_metrics use MOM_restart, only : restore_state, determine_is_new_run, MOM_restart_CS use MOM_sponge, only : set_up_sponge_field, set_up_sponge_ML_density use MOM_sponge, only : initialize_sponge, sponge_CS -use MOM_ALE_sponge, only : set_up_ALE_sponge_field, initialize_ALE_sponge -use MOM_ALE_sponge, only : ALE_sponge_CS +use MOM_ALE_sponge, only : set_up_ALE_sponge_field, initialize_ALE_sponge, ALE_sponge_CS use MOM_string_functions, only : uppercase, lowercase use MOM_time_manager, only : time_type use MOM_tracer_registry, only : tracer_registry_type @@ -44,8 +38,7 @@ module MOM_state_initialization use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_type, EOS_domain use MOM_EOS, only : convert_temp_salt_for_TEOS10 use user_initialization, only : user_initialize_thickness, user_initialize_velocity -use user_initialization, only : user_init_temperature_salinity -use user_initialization, only : user_set_OBC_data +use user_initialization, only : user_init_temperature_salinity, user_set_OBC_data use user_initialization, only : user_initialize_sponges use DOME_initialization, only : DOME_initialize_thickness use DOME_initialization, only : DOME_set_OBC_data @@ -97,7 +90,6 @@ module MOM_state_initialization use MOM_remapping, only : remapping_CS, initialize_remapping use MOM_remapping, only : remapping_core_h use MOM_horizontal_regridding, only : horiz_interp_and_extrap_tracer -use fms_io_mod, only : field_size implicit none ; private diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index 7d2310b42f..66c0e33bac 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -13,10 +13,8 @@ module MOM_generic_tracer #define _ALLOCATED allocated #endif - ! ### These imports should not reach into FMS directly ### - use mpp_mod, only: stdout, mpp_error, FATAL,WARNING,NOTE - use field_manager_mod, only: fm_get_index,fm_string_len + use field_manager_mod, only: fm_string_len use generic_tracer, only: generic_tracer_register, generic_tracer_get_diag_list use generic_tracer, only: generic_tracer_init, generic_tracer_source, generic_tracer_register_diag @@ -108,7 +106,7 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) ! Local variables logical :: register_MOM_generic_tracer - character(len=fm_string_len), parameter :: sub_name = 'register_MOM_generic_tracer' + character(len=128), parameter :: sub_name = 'register_MOM_generic_tracer' character(len=200) :: inputdir ! The directory where NetCDF input files are. ! These can be overridden later in via the field manager? @@ -122,7 +120,7 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) register_MOM_generic_tracer = .false. if (associated(CS)) then - call mpp_error(WARNING, "register_MOM_generic_tracer called with an "// & + call MOM_error(WARNING, "register_MOM_generic_tracer called with an "// & "associated control structure.") return endif @@ -185,7 +183,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 MOM_error(FATAL, trim(sub_name)//& ": No tracer in the list.") ! For each tracer name get its T_prog index and get its fields @@ -247,7 +245,7 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, type(ALE_sponge_CS), pointer :: ALE_sponge_CSp !< Pointer to the control structure for the !! ALE sponges. - character(len=fm_string_len), parameter :: sub_name = 'initialize_MOM_generic_tracer' + character(len=128), parameter :: sub_name = 'initialize_MOM_generic_tracer' logical :: OK integer :: i, j, k, isc, iec, jsc, jec, nk type(g_tracer_type), pointer :: g_tracer,g_tracer_next @@ -265,7 +263,7 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, 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 MOM_error(FATAL, trim(sub_name)//& ": No tracer in the list.") !For each tracer name get its fields g_tracer=>CS%g_tracer_list @@ -426,7 +424,7 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, ! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) ! Local variables - character(len=fm_string_len), parameter :: sub_name = 'MOM_generic_tracer_column_physics' + character(len=128), parameter :: sub_name = 'MOM_generic_tracer_column_physics' type(g_tracer_type), pointer :: g_tracer, g_tracer_next character(len=fm_string_len) :: g_tracer_name @@ -443,7 +441,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 MOM_error(FATAL,& trim(sub_name)//": No tracer in the list.") #ifdef _USE_MOM6_DIAG @@ -587,7 +585,7 @@ function MOM_generic_tracer_stock(h, stocks, G, GV, CS, names, units, stock_inde type(g_tracer_type), pointer :: g_tracer, g_tracer_next real, dimension(:,:,:,:), pointer :: tr_field real, dimension(:,:,:), pointer :: tr_ptr - character(len=fm_string_len), parameter :: sub_name = 'MOM_generic_tracer_stock' + character(len=128), parameter :: sub_name = 'MOM_generic_tracer_stock' 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 @@ -660,7 +658,7 @@ function MOM_generic_tracer_min_max(ind_start, got_minmax, gmin, gmax, xgmin, yg type(g_tracer_type), pointer :: g_tracer, g_tracer_next real, dimension(:,:,:,:), pointer :: tr_field real, dimension(:,:,:), pointer :: tr_ptr - character(len=fm_string_len), parameter :: sub_name = 'MOM_generic_tracer_min_max' + character(len=128), parameter :: sub_name = 'MOM_generic_tracer_min_max' real, dimension(:,:,:),pointer :: grid_tmask integer :: isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau @@ -728,7 +726,7 @@ subroutine MOM_generic_tracer_surface_state(sfc_state, h, G, CS) ! Local variables real :: sosga - character(len=fm_string_len), parameter :: sub_name = 'MOM_generic_tracer_surface_state' + character(len=128), parameter :: sub_name = 'MOM_generic_tracer_surface_state' real, dimension(G%isd:G%ied,G%jsd:G%jed,1:G%ke,1) :: rho0 real, dimension(G%isd:G%ied,G%jsd:G%jed,1:G%ke) :: dzt type(g_tracer_type), pointer :: g_tracer @@ -750,7 +748,7 @@ subroutine MOM_generic_tracer_surface_state(sfc_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 MOM_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 @@ -767,7 +765,7 @@ subroutine MOM_generic_flux_init(verbosity) integer :: ind character(len=fm_string_len) :: g_tracer_name,longname, package,units,old_package,file_in,file_out real :: const_init_value - character(len=fm_string_len), parameter :: sub_name = 'MOM_generic_flux_init' + character(len=128), parameter :: sub_name = 'MOM_generic_flux_init' type(g_tracer_type), pointer :: g_tracer_list,g_tracer,g_tracer_next if (.not. g_registered) then @@ -777,7 +775,7 @@ subroutine MOM_generic_flux_init(verbosity) call generic_tracer_get_list(g_tracer_list) if (.NOT. associated(g_tracer_list)) then - call mpp_error(WARNING, trim(sub_name)// ": No generic tracer in the list.") + call MOM_error(WARNING, trim(sub_name)// ": No generic tracer in the list.") return endif @@ -812,7 +810,7 @@ subroutine MOM_generic_tracer_get(name,member,array, CS) type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. real, dimension(:,:,:), pointer :: array_ptr - character(len=fm_string_len), parameter :: sub_name = 'MOM_generic_tracer_get' + character(len=128), parameter :: sub_name = 'MOM_generic_tracer_get' call g_tracer_get_pointer(CS%g_tracer_list,name,member,array_ptr) array(:,:,:) = array_ptr(:,:,:) diff --git a/src/tracer/MOM_offline_aux.F90 b/src/tracer/MOM_offline_aux.F90 index 21db2cfff4..119ad555da 100644 --- a/src/tracer/MOM_offline_aux.F90 +++ b/src/tracer/MOM_offline_aux.F90 @@ -4,7 +4,6 @@ module MOM_offline_aux ! This file is part of MOM6. See LICENSE.md for the license. -use mpp_domains_mod, only : CENTER, CORNER, NORTH, EAST use data_override_mod, only : data_override_init, data_override use MOM_time_manager, only : time_type, operator(-) use MOM_debugging, only : check_column_integrals @@ -12,7 +11,7 @@ module MOM_offline_aux use MOM_diag_vkernels, only : reintegrate_column use MOM_error_handler, only : callTree_enter, callTree_leave, MOM_error, FATAL, WARNING, is_root_pe use MOM_grid, only : ocean_grid_type -use MOM_io, only : MOM_read_data, MOM_read_vector +use MOM_io, only : MOM_read_data, MOM_read_vector, CENTER use MOM_verticalGrid, only : verticalGrid_type use MOM_file_parser, only : get_param, log_version, param_file_type use astronomy_mod, only : orbital_time, diurnal_solar, daily_mean_solar diff --git a/src/tracer/MOM_offline_main.F90 b/src/tracer/MOM_offline_main.F90 index b7af9849b3..3895e8a116 100644 --- a/src/tracer/MOM_offline_main.F90 +++ b/src/tracer/MOM_offline_main.F90 @@ -4,7 +4,6 @@ module MOM_offline_main ! This file is part of MOM6. See LICENSE.md for the license. -use mpp_domains_mod, only : CENTER, CORNER, NORTH, EAST use MOM_ALE, only : ALE_CS, ALE_main_offline, ALE_offline_inputs use MOM_checksums, only : hchksum, uvchksum use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end @@ -20,7 +19,7 @@ module MOM_offline_main use MOM_file_parser, only : read_param, get_param, log_version, param_file_type use MOM_forcing_type, only : forcing use MOM_grid, only : ocean_grid_type -use MOM_io, only : MOM_read_data, MOM_read_vector +use MOM_io, only : MOM_read_data, MOM_read_vector, CENTER use MOM_offline_aux, only : update_offline_from_arrays, update_offline_from_files use MOM_offline_aux, only : next_modulo_time, offline_add_diurnal_sw use MOM_offline_aux, only : update_h_horizontal_flux, update_h_vertical_flux, limit_mass_flux_3d diff --git a/src/tracer/RGC_tracer.F90 b/src/tracer/RGC_tracer.F90 index 028718f379..44c6c2e5a1 100644 --- a/src/tracer/RGC_tracer.F90 +++ b/src/tracer/RGC_tracer.F90 @@ -19,7 +19,7 @@ module RGC_tracer use MOM_forcing_type, only : forcing use MOM_hor_index, only : hor_index_type use MOM_grid, only : ocean_grid_type -use MOM_io, only : file_exists, read_data, slasher, vardesc, var_desc, query_vardesc +use MOM_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, get_ALE_sponge_nz_data use MOM_sponge, only : set_up_sponge_field, sponge_CS @@ -207,8 +207,7 @@ subroutine initialize_RGC_tracer(restart, day, G, GV, h, diag, OBC, CS, & CS%tracer_IC_file) do m=1,NTR call query_vardesc(CS%tr_desc(m), name, caller="initialize_RGC_tracer") - call read_data(CS%tracer_IC_file, trim(name), & - CS%tr(:,:,:,m), domain=G%Domain%mpp_domain) + call MOM_read_data(CS%tracer_IC_file, trim(name), CS%tr(:,:,:,m), G%Domain) enddo else do m=1,NTR From bba60af8efe150e65accdb2b2621614b707f8316 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Tue, 4 Aug 2020 12:06:41 -0400 Subject: [PATCH 84/91] Move call to initialize_segment_data to MOM_state_initialization --- src/core/MOM_open_boundary.F90 | 96 +++++++++++-------- .../MOM_state_initialization.F90 | 4 +- 2 files changed, 58 insertions(+), 42 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 9b650f8598..f94060fc39 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -62,6 +62,7 @@ module MOM_open_boundary public update_OBC_ramp public rotate_OBC_config public rotate_OBC_init +public initialize_segment_data 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 @@ -268,7 +269,7 @@ module MOM_open_boundary real :: rx_max !< The maximum magnitude of the baroclinic radiation velocity (or speed of !! characteristics) in units of grid points per timestep [nondim]. 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(remapping_CS), pointer :: remap_CS=> NULL() !< 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 normal phase speed for EW radiation OBCs in units of @@ -341,6 +342,11 @@ subroutine open_boundary_config(G, US, param_file, OBC) character(len=100) :: segment_str ! The contents (rhs) for parameter "segment_param_str" character(len=200) :: config1 ! String for OBC_USER_CONFIG real :: Lscale_in, Lscale_out ! parameters controlling tracer values at the boundaries [L ~> m] + character(len=128) :: inputdir + logical :: answers_2018, default_2018_answers + logical :: check_reconstruction, check_remapping, force_bounds_in_subcell + character(len=32) :: remappingScheme + allocate(OBC) call get_param(param_file, mdl, "OBC_NUMBER_OF_SEGMENTS", OBC%number_of_segments, & @@ -497,7 +503,7 @@ subroutine open_boundary_config(G, US, param_file, OBC) enddo ! if (open_boundary_query(OBC, needs_ext_seg_data=.true.)) & - call initialize_segment_data(G, OBC, param_file) + ! call initialize_segment_data(G, OBC, param_file) if (open_boundary_query(OBC, apply_open_OBC=.true.)) then call get_param(param_file, mdl, "OBC_RADIATION_MAX", OBC%rx_max, & @@ -540,6 +546,46 @@ subroutine open_boundary_config(G, US, param_file, OBC) if (Lscale_out>0.) OBC%segment(l)%Tr_InvLscale_out = 1.0/Lscale_out enddo + ! There is a problem with the order of the OBC initialization + ! with respect to ALE_init. Currently handling this by copying the + ! param file so that I can use it later in step_MOM in order to finish + ! initializing segments on the first step. + + ! Is the above comment still relevant ? + + call get_param(param_file, mdl, "REMAPPING_SCHEME", remappingScheme, & + "This sets the reconstruction scheme used "//& + "for vertical remapping for all variables. "//& + "It can be one of the following schemes: \n"//& + trim(remappingSchemesDoc), default=remappingDefaultScheme,do_not_log=.true.) + call get_param(param_file, mdl, "FATAL_CHECK_RECONSTRUCTIONS", check_reconstruction, & + "If true, cell-by-cell reconstructions are checked for "//& + "consistency and if non-monotonicity or an inconsistency is "//& + "detected then a FATAL error is issued.", default=.false.,do_not_log=.true.) + call get_param(param_file, mdl, "FATAL_CHECK_REMAPPING", check_remapping, & + "If true, the results of remapping are checked for "//& + "conservation and new extrema and if an inconsistency is "//& + "detected then a FATAL error is issued.", default=.false.,do_not_log=.true.) + call get_param(param_file, mdl, "BRUSHCUTTER_MODE", OBC%brushcutter_mode, & + "If true, read external OBC data on the supergrid.", & + default=.false.) + call get_param(param_file, mdl, "REMAP_BOUND_INTERMEDIATE_VALUES", force_bounds_in_subcell, & + "If true, the values on the intermediate grid used for remapping "//& + "are forced to be bounded, which might not be the case due to "//& + "round off.", default=.false.,do_not_log=.true.) + call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & + "This sets the default value for the various _2018_ANSWERS parameters.", & + default=.false.) + call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", answers_2018, & + "If true, use the order of arithmetic and expressions that recover the "//& + "answers from the end of 2018. Otherwise, use updated and more robust "//& + "forms of the same expressions.", default=default_2018_answers) + + allocate(OBC%remap_CS) + call initialize_remapping(OBC%remap_CS, remappingScheme, boundary_extrapolation = .false., & + check_reconstruction=check_reconstruction, check_remapping=check_remapping, & + force_bounds_in_subcell=force_bounds_in_subcell, answers_2018=answers_2018) + endif ! OBC%number_of_segments > 0 ! Safety check @@ -564,7 +610,7 @@ end subroutine open_boundary_config 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_grid_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 @@ -576,10 +622,7 @@ subroutine initialize_segment_data(G, OBC, PF) character(len=32), dimension(MAX_OBC_FIELDS) :: fields ! segment field names character(len=128) :: inputdir type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list - character(len=32) :: remappingScheme character(len=256) :: mesg ! Message for error messages. - logical :: check_reconstruction, check_remapping, force_bounds_in_subcell - logical :: answers_2018, default_2018_answers integer, dimension(4) :: siz,siz2 integer :: is, ie, js, je integer :: isd, ied, jsd, jed @@ -599,39 +642,6 @@ subroutine initialize_segment_data(G, OBC, PF) call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") inputdir = slasher(inputdir) - call get_param(PF, mdl, "REMAPPING_SCHEME", remappingScheme, & - "This sets the reconstruction scheme used "//& - "for vertical remapping for all variables. "//& - "It can be one of the following schemes: \n"//& - trim(remappingSchemesDoc), default=remappingDefaultScheme,do_not_log=.true.) - call get_param(PF, mdl, "FATAL_CHECK_RECONSTRUCTIONS", check_reconstruction, & - "If true, cell-by-cell reconstructions are checked for "//& - "consistency and if non-monotonicity or an inconsistency is "//& - "detected then a FATAL error is issued.", default=.false.,do_not_log=.true.) - call get_param(PF, mdl, "FATAL_CHECK_REMAPPING", check_remapping, & - "If true, the results of remapping are checked for "//& - "conservation and new extrema and if an inconsistency is "//& - "detected then a FATAL error is issued.", default=.false.,do_not_log=.true.) - call get_param(PF, mdl, "REMAP_BOUND_INTERMEDIATE_VALUES", force_bounds_in_subcell, & - "If true, the values on the intermediate grid used for remapping "//& - "are forced to be bounded, which might not be the case due to "//& - "round off.", default=.false.,do_not_log=.true.) - call get_param(PF, mdl, "BRUSHCUTTER_MODE", OBC%brushcutter_mode, & - "If true, read external OBC data on the supergrid.", & - default=.false.) - call get_param(PF, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.false.) - call get_param(PF, mdl, "REMAPPING_2018_ANSWERS", answers_2018, & - "If true, use the order of arithmetic and expressions that recover the "//& - "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers) - - allocate(OBC%remap_CS) - call initialize_remapping(OBC%remap_CS, remappingScheme, boundary_extrapolation = .false., & - check_reconstruction=check_reconstruction, check_remapping=check_remapping, & - force_bounds_in_subcell=force_bounds_in_subcell, answers_2018=answers_2018) - if (OBC%user_BCs_set_globally) return ! Try this here just for the documentation. It is repeated below. @@ -4966,6 +4976,8 @@ subroutine rotate_OBC_config(OBC_in, G_in, OBC, G, turns) integer :: l + if (OBC_in%number_of_segments==0) return + ! Scalar and logical transfer OBC%number_of_segments = OBC_in%number_of_segments OBC%ke = OBC_in%ke @@ -5023,8 +5035,10 @@ subroutine rotate_OBC_config(OBC_in, G_in, OBC, G, turns) OBC%OBC_pe = OBC_in%OBC_pe ! remap_CS is set up by initialize_segment_data, so we copy the fields here. - allocate(OBC%remap_CS) - OBC%remap_CS = OBC_in%remap_CS + if (ASSOCIATED(OBC_in%remap_CS)) then + allocate(OBC%remap_CS) + OBC%remap_CS = OBC_in%remap_CS + endif ! TODO: The OBC registry seems to be a list of "registered" OBC types. ! It does not appear to be used, so for now we skip this record. diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index e451966364..f53ff89a1e 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -24,7 +24,7 @@ module MOM_state_initialization use MOM_open_boundary, only : ocean_OBC_type, open_boundary_init use MOM_open_boundary, only : OBC_NONE, OBC_SIMPLE use MOM_open_boundary, only : open_boundary_query -use MOM_open_boundary, only : set_tracer_data +use MOM_open_boundary, only : set_tracer_data, initialize_segment_data use MOM_open_boundary, only : open_boundary_test_extern_h use MOM_open_boundary, only : fill_temp_salt_segments use MOM_open_boundary, only : update_OBC_segment_data @@ -563,6 +563,8 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & ! This controls user code for setting open boundary data if (associated(OBC)) then + call initialize_segment_data(G, OBC, PF) ! call initialize_segment_data(G, OBC, param_file) +! call open_boundary_config(G, US, PF, OBC) ! Call this once to fill boundary arrays from fixed values if (.not. OBC%needs_IO_for_data) & call update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) From 7be08832127b4669db8644cfc261ba82163d3a5d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 7 Aug 2020 08:13:03 -0400 Subject: [PATCH 85/91] (*)Set dSV_dT and dSV_dS with unassociated fluxes Set dSV_dT and dSV_dS if present in applyBoundaryFluxesInOut, even if boundary fluxes are not associated. With this change, setting BUOY_CONFIG='NONE' and BUOY_CONFIG='zero' both work and give similar (but not identical) answers in some test cases with an ePBL boundary layer parameterization, whereas before answers were tainted with uninitialized values when BUOY_CONFIG='NONE'. All answers in the existing MOM6-examples test suite are bitwise identical, but answers can change in other cases. --- .../vertical/MOM_diabatic_aux.F90 | 15 +++++++++------ .../vertical/MOM_vert_friction.F90 | 2 +- 2 files changed, 10 insertions(+), 7 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 91085047c9..bf2e86cb80 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -822,19 +822,18 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke - ! Only apply forcing if fluxes%sw is associated. - if (.not.associated(fluxes%sw)) return - -#define _OLD_ALG_ Idt = 1.0 / dt calculate_energetics = (present(cTKE) .and. present(dSV_dT) .and. present(dSV_dS)) calculate_buoyancy = present(SkinBuoyFlux) if (calculate_buoyancy) SkinBuoyFlux(:,:) = 0.0 + if (present(cTKE)) cTKE(:,:,:) = 0.0 g_Hconv2 = (US%L_to_Z**2*GV%g_Earth * GV%H_to_RZ) * GV%H_to_RZ EOSdom(:) = EOS_domain(G%HI) - if (present(cTKE)) cTKE(:,:,:) = 0.0 + ! Only apply forcing if fluxes%sw is associated. + if (.not.associated(fluxes%sw) .and. .not.calculate_energetics) return + if (calculate_buoyancy) then SurfPressure(:) = 0.0 GoRho = US%L_to_Z**2*GV%g_Earth / GV%Rho0 @@ -874,7 +873,6 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t h2d(i,k) = h(i,j,k) T2d(i,k) = tv%T(i,j,k) enddo ; enddo - if (nsw>0) call extract_optics_slice(optics, j, G, GV, opacity=opacityBand, opacity_scale=(1.0/GV%m_to_H)) if (calculate_energetics) then ! The partial derivatives of specific volume with temperature and @@ -898,6 +896,11 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t pen_TKE_2d(:,:) = 0.0 endif + ! Nothing more is done on this j-slice if there is no buoyancy forcing. + if (.not.associated(fluxes%sw)) cycle + + if (nsw>0) call extract_optics_slice(optics, j, G, GV, opacity=opacityBand, opacity_scale=(1.0/GV%m_to_H)) + ! 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 ~> m or kg m-2] over time step diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index c6a6f37b39..1a4fb58e02 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -1143,12 +1143,12 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, 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 :: z2 ! A copy of z_i [nondim] + real :: botfn ! A function that is 1 at the bottom and small far from it [nondim] real :: topfn ! A function that is 1 at the top and small far from it [nondim] real :: kv_top ! A viscosity associated with the top boundary layer [Z2 T-1 ~> m2 s-1] logical :: do_shelf, do_OBCs integer :: i, k, is, ie, max_nk integer :: nz - real :: botfn a_cpl(:,:) = 0.0 Kv_tot(:,:) = 0.0 From feed9ba82b9ebe6805ce691e77190b2f5ba4f7ee Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 7 Aug 2020 08:13:40 -0400 Subject: [PATCH 86/91] (*)Fix an indexing bug in int_density_dz_linear Corrected a horizontal indexing bug in int_density_dz_linear that caused the ISOMIP/layer test case to fail. This bug was first introduced with PR#732 on March 8, 2018. This bug fix will change answers with a linear equation of state and the finite volume pressure gradient force, however it does not change any of the verified answers in the MOM6-examples regression suite. --- src/equation_of_state/MOM_EOS_linear.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/equation_of_state/MOM_EOS_linear.F90 b/src/equation_of_state/MOM_EOS_linear.F90 index e3a5443840..47a2bf21b0 100644 --- a/src/equation_of_state/MOM_EOS_linear.F90 +++ b/src/equation_of_state/MOM_EOS_linear.F90 @@ -473,7 +473,7 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HI, & hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom - intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) + intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) do m=2,4 wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR From 3c10ae18a72b3096ea69b81dc3906931eefa9a6f Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Mon, 10 Aug 2020 10:46:31 -0400 Subject: [PATCH 87/91] Remove outdated comments --- src/core/MOM_open_boundary.F90 | 7 ------- 1 file changed, 7 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index f94060fc39..37ebeda1fa 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -546,13 +546,6 @@ subroutine open_boundary_config(G, US, param_file, OBC) if (Lscale_out>0.) OBC%segment(l)%Tr_InvLscale_out = 1.0/Lscale_out enddo - ! There is a problem with the order of the OBC initialization - ! with respect to ALE_init. Currently handling this by copying the - ! param file so that I can use it later in step_MOM in order to finish - ! initializing segments on the first step. - - ! Is the above comment still relevant ? - call get_param(param_file, mdl, "REMAPPING_SCHEME", remappingScheme, & "This sets the reconstruction scheme used "//& "for vertical remapping for all variables. "//& From 1638c0bf01e358d043475f4149dfa06cac2d8668 Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Fri, 14 Aug 2020 18:15:20 -0400 Subject: [PATCH 88/91] Initialize OBC segments for OBGC tracers - This update queries the obgc modules (generic_tracers) for the OBC source files and var names for each generic tracers and initializes the segment fields accoringly. - With this update the obgc tracers should NOT appear in OBC_SEGMENT_XXX_DATA in MOM parameter files (MOM_override). - The default source file name is obgc_obc.nc - The default source file var name is the generic_tracer name - These can be overriden by field_table mechanism. E.g., "namelists","ocean_mod","generic_CFC" cfc11_obc_src_field_name = salt cfc12_obc_src_field_name = salt / --- src/core/MOM_open_boundary.F90 | 69 ++++++++++++++++++++++++++++--- src/tracer/MOM_generic_tracer.F90 | 13 +++--- 2 files changed, 71 insertions(+), 11 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index c786c58116..32c0f9a6cf 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -59,6 +59,7 @@ module MOM_open_boundary public register_obgc_segments public fill_temp_salt_segments public fill_obgc_segments +public set_obgc_segments_props public open_boundary_register_restarts public update_segment_tracer_reservoirs public update_OBC_ramp @@ -317,6 +318,15 @@ module MOM_open_boundary !! When locked=.true.,no more boundaries can be registered. end type OBC_registry_type +!> Type to carry OBC information needed for setting segments for OBGC tracers +type, private :: external_tracers_segments_props + type(external_tracers_segments_props), pointer :: next => NULL() + character(len=128) :: tracer_name + character(len=128) :: tracer_src_file + character(len=128) :: tracer_src_field +end type external_tracers_segments_props +type(external_tracers_segments_props), pointer, save :: obgc_segments_props => NULL() !< Linked-list of obgc tracers properties +integer, save :: num_obgc_tracers = 0 !< Keeps the total number of obgc tracers integer :: id_clock_pass !< A CPU time clock character(len=40) :: mdl = "MOM_open_boundary" !< This module's name. @@ -609,7 +619,7 @@ subroutine initialize_segment_data(G, OBC, PF) 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 + integer :: n,m,num_fields,mm character(len=256) :: segstr, filename character(len=20) :: segnam, suffix character(len=32) :: varnam, fieldname @@ -625,6 +635,7 @@ subroutine initialize_segment_data(G, OBC, PF) integer, dimension(:), allocatable :: saved_pelist integer :: current_pe integer, dimension(1) :: single_pelist + type(external_tracers_segments_props), pointer :: obgc_segments_props_list =>NULL() !will be able to dynamically switch between sub-sampling refined grid data or model grid is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -677,8 +688,9 @@ subroutine initialize_segment_data(G, OBC, PF) cycle ! cycle to next segment endif - allocate(segment%field(num_fields)) - segment%num_fields = num_fields + !There are num_obgc_tracers obgc tracers are there that are not listed in param file + segment%num_fields = num_fields +num_obgc_tracers + allocate(segment%field(segment%num_fields)) segment%temp_segment_data_exists=.false. segment%salt_segment_data_exists=.false. @@ -691,8 +703,21 @@ subroutine initialize_segment_data(G, OBC, PF) IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB - do m=1,num_fields - call parse_segment_data_str(trim(segstr), var=trim(fields(m)), value=value, filenam=filename, fieldnam=fieldname) + obgc_segments_props_list => obgc_segments_props !Get a pointer to the saved type + do m=1,segment%num_fields + if(m .le. num_fields) then + call parse_segment_data_str(trim(segstr), var=trim(fields(m)), value=value, filenam=filename, fieldnam=fieldname) + else + call get_obgc_segments_props(obgc_segments_props_list,fields(m),filename,fieldname) + do mm=1,num_fields + if(trim(fields(m))==trim(fields(mm))) then + if (is_root_pe()) & + call MOM_error(FATAL,"MOM_open_boundary:initialize_segment_data(): obgc tracer " //trim(fields(m))// & +" appears in OBC_SEGMENT_XXX_DATA string in MOM6 param file. This is not supported!") + endif + enddo + endif + if (trim(filename) /= 'none') then OBC%update_OBC = .true. ! Data is assumed to be time-dependent if we are reading from file OBC%needs_IO_for_data = .true. ! At least one segment is using I/O for OBC data @@ -3297,7 +3322,7 @@ function get_tracer_index(OBC_seg,tr_name) integer :: get_tracer_index, it get_tracer_index=-1 it=1 - do while(allocated(OBC_seg%tr_Reg%Tr(it)%t)) + do while(associated(OBC_seg%tr_Reg%Tr(it)%t)) if (trim(OBC_seg%tr_Reg%Tr(it)%name) == trim(tr_name)) then get_tracer_index=it exit @@ -4395,6 +4420,38 @@ subroutine register_temp_salt_segments(GV, OBC, tr_Reg, param_file) end subroutine register_temp_salt_segments +!> Sets the OBC properties of external obgc tracers, such as their source file and field name +subroutine set_obgc_segments_props(tr_name,obc_src_file_name,obc_src_field_name) + character(len=*), intent(in) :: tr_name !< Tracer name + character(len=*), intent(in) :: obc_src_file_name !< OBC source file name + character(len=*), intent(in) :: obc_src_field_name !< name of the field in the source file + + type(external_tracers_segments_props),pointer :: node_ptr => NULL() + allocate(node_ptr) + node_ptr%tracer_name = trim(tr_name) + node_ptr%tracer_src_file = trim(obc_src_file_name) + node_ptr%tracer_src_field = trim(obc_src_field_name) + !Reversed Linked List implementation! Make this new node to be the head of the list. + node_ptr%next => obgc_segments_props + obgc_segments_props => node_ptr + num_obgc_tracers = num_obgc_tracers+1 +end subroutine set_obgc_segments_props + +!> Get the OBC properties of external obgc tracers, such as their source file and field name +subroutine get_obgc_segments_props(node, tr_name,obc_src_file_name,obc_src_field_name) + type(external_tracers_segments_props),pointer :: node + character(len=*), intent(out) :: tr_name !< Tracer name + character(len=*), intent(out) :: obc_src_file_name !< OBC source file name + character(len=*), intent(out) :: obc_src_field_name !< name of the field in the source file + + tr_name=trim(node%tracer_name) + obc_src_file_name=trim(node%tracer_src_file) + obc_src_field_name=trim(node%tracer_src_field) + !pop the head. + node => node%next + +end subroutine get_obgc_segments_props + subroutine register_obgc_segments(GV, OBC, tr_Reg, param_file, tr_name) type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(ocean_OBC_type), pointer :: OBC !< Open boundary structure diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index 224a56f63c..c948e545fe 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -13,9 +13,6 @@ module MOM_generic_tracer #define _ALLOCATED allocated #endif - ! ### These imports should not reach into FMS directly ### - use field_manager_mod, only: fm_string_len - use generic_tracer, only: generic_tracer_register, generic_tracer_get_diag_list use generic_tracer, only: generic_tracer_init, generic_tracer_source, generic_tracer_register_diag use generic_tracer, only: generic_tracer_coupler_get, generic_tracer_coupler_set @@ -27,7 +24,8 @@ module MOM_generic_tracer use g_tracer_utils, only: g_tracer_get_next,g_tracer_type,g_tracer_is_prog,g_tracer_flux_init use g_tracer_utils, only: g_tracer_send_diag,g_tracer_get_values use g_tracer_utils, only: g_tracer_get_pointer,g_tracer_get_alias,g_tracer_set_csdiag - + use g_tracer_utils, only: g_tracer_get_obc_segment_props + use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : diag_ctrl, get_diag_time_end use MOM_error_handler, only : MOM_error, FATAL, WARNING, NOTE, is_root_pe @@ -47,7 +45,8 @@ module MOM_generic_tracer 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, register_obgc_segments, fill_obgc_segments + use MOM_open_boundary, only : ocean_OBC_type, register_obgc_segments, fill_obgc_segments + use MOM_open_boundary, only : set_obgc_segments_props use MOM_verticalGrid, only : verticalGrid_type @@ -56,6 +55,7 @@ module MOM_generic_tracer !> An state hidden in module data that is very much not allowed in MOM6 ! ### This needs to be fixed logical :: g_registered = .false. + integer, parameter :: fm_string_len=128 !>string lengths used in obgc packages public register_MOM_generic_tracer, initialize_MOM_generic_tracer public MOM_generic_tracer_column_physics, MOM_generic_tracer_surface_state @@ -118,6 +118,7 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS, integer :: ntau, k,i,j,axes(3) type(g_tracer_type), pointer :: g_tracer,g_tracer_next character(len=fm_string_len) :: g_tracer_name,longname,units + character(len=fm_string_len) :: obc_src_file_name,obc_src_field_name real, dimension(:,:,:,:), pointer :: tr_field real, dimension(:,:,:), pointer :: tr_ptr real, dimension(HI%isd:HI%ied, HI%jsd:HI%jed,GV%ke) :: grid_tmask @@ -209,6 +210,8 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS, registry_diags=.false., & !### CHANGE TO TRUE? restart_CS=restart_CS, mandatory=.not.CS%tracers_may_reinit) if (associated(CS%OBC)) & + call g_tracer_get_obc_segment_props(g_tracer,g_tracer_name,obc_src_file_name,obc_src_field_name) + call set_obgc_segments_props(g_tracer_name,obc_src_file_name,obc_src_field_name) call register_obgc_segments(GV, CS%OBC, tr_Reg, param_file, g_tracer_name) else call register_restart_field(tr_ptr, g_tracer_name, .not.CS%tracers_may_reinit, & From d0c431b603141b3797b59659564e6c8e7b65a7bb Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Tue, 1 Sep 2020 10:42:55 -0400 Subject: [PATCH 89/91] Add OBC reservoirs for ocean_BGC tracers - This update adds OBC reservoirs for all obgc tracers that are registered to have OBC. - This fixes restart issue with obgc tracers in test runs --- src/core/MOM_open_boundary.F90 | 63 ++++++++++++++++--------------- src/tracer/MOM_generic_tracer.F90 | 16 +++++--- 2 files changed, 43 insertions(+), 36 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 32c0f9a6cf..c41068e1fa 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -83,6 +83,7 @@ module MOM_open_boundary integer :: fid !< handle from FMS associated with segment data on disk integer :: fid_dz !< handle from FMS associated with segment thicknesses on disk character(len=8) :: name !< a name identifier for the segment data + character(len=8) :: genre !< a family identifier for the segment data real, dimension(:,:,:), allocatable :: buffer_src !< 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 @@ -708,6 +709,7 @@ subroutine initialize_segment_data(G, OBC, PF) if(m .le. num_fields) then call parse_segment_data_str(trim(segstr), var=trim(fields(m)), value=value, filenam=filename, fieldnam=fieldname) else + segment%field(m)%genre='obgc' call get_obgc_segments_props(obgc_segments_props_list,fields(m),filename,fieldname) do mm=1,num_fields if(trim(fields(m))==trim(fields(mm))) then @@ -1372,7 +1374,7 @@ end function interpret_int_expr 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 ) + subroutine parse_segment_data_str(segment_str, var, value, filenam, fieldnam, fields, num_fields, debug, has_var ) 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 @@ -1384,14 +1386,16 @@ subroutine parse_segment_data_str(segment_str, var, value, filenam, fieldnam, fi 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 + logical, optional, intent(out) :: has_var !< .true. if var is found in segment_str ! Local variables character(len=128) :: word1, word2, word3, method integer :: lword, nfields, n, m - logical :: continue,dbg + logical :: continue,dbg,has character(len=32), dimension(MAX_OBC_FIELDS) :: flds nfields=0 continue=.true. + has=.false. dbg=.false. if (PRESENT(debug)) dbg=debug @@ -1419,11 +1423,13 @@ subroutine parse_segment_data_str(segment_str, var, value, filenam, fieldnam, fi do n=1,nfields if (trim(var)==trim(flds(n))) then m=n + has=.true. exit endif enddo + if (PRESENT(has_var)) has_var=has if (m==0) then - call abort() + return ! Why call abort() ? endif ! Process first word which will start with the fieldname @@ -1505,15 +1511,8 @@ subroutine parse_for_tracer_reservoirs(OBC, PF, use_temperature) else OBC%tracer_y_reservoirs_used(2) = .true. endif - endif - if (fields(m) == 'gtr1') then - if (segment%is_E_or_W_2) then - OBC%tracer_x_reservoirs_used(2) = .true. - else - OBC%tracer_y_reservoirs_used(2) = .true. - endif - endif - endif + endif + endif enddo ! Alternately, set first two to true if use_temperature is true if (use_temperature) then @@ -1525,6 +1524,23 @@ subroutine parse_for_tracer_reservoirs(OBC, PF, use_temperature) OBC%tracer_y_reservoirs_used(2) = .true. endif endif + !Add reservoirs for external/obgc tracers + !There is a diconnect in the above logic between tracer index and reservoir index. + !It arbitarily assigns reservoir indexes 1&2 to tracers T&S, + !so we need to start from 3 for the rest of tracers, hence the m+2 in the following. + !num_fields is the number of vars in segstr (6 of them now, U,V,SSH,TEMP,SALT,dye) + !but OBC%tracer_x_reservoirs_used is allocated to size Reg%ntr, which is the total number of tracers + !(t,s,dye,obgc1,obcg2,obgc3,... 6 of them by chance) + do m=1,num_obgc_tracers + !This logic assumes all external tarcers need a reservoir + !The segments for tracers are not initialized yet (that happens later in initialize_segment_data()) + !so we cannot query to determine if this tracer needs a reservoir. + if (segment%is_E_or_W_2) then + OBC%tracer_x_reservoirs_used(m+2) = .true. + else + OBC%tracer_y_reservoirs_used(m+2) = .true. + endif + enddo enddo return @@ -4125,10 +4141,10 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) else segment%tr_Reg%Tr(2)%OBC_inflow_conc = segment%field(m)%value endif - elseif (trim(segment%field(m)%name) == 'gtr1') then - nt=get_tracer_index(segment,'gtr1') + elseif (trim(segment%field(m)%genre) == 'obgc') then + nt=get_tracer_index(segment,trim(segment%field(m)%name)) if(nt .lt. 0) then - call MOM_error(FATAL,"update_OBC_segment_data: Did not find tracer gtr1!") + call MOM_error(FATAL,"update_OBC_segment_data: Did not find tracer "//trim(segment%field(m)%name)) endif if (associated(segment%field(m)%buffer_dst)) then do k=1,nz; do j=js_obc2, je_obc; do i=is_obc2,ie_obc @@ -4469,12 +4485,8 @@ subroutine register_obgc_segments(GV, OBC, tr_Reg, param_file, tr_name) do n=1, OBC%number_of_segments segment=>OBC%segment(n) if (.not. segment%on_pe) cycle - !For testing activate only one particular tracer for OBC - !This could be later generalized to all or a list of tracers - if(trim(tr_name) == 'gtr1') then - call tracer_name_lookup(tr_Reg, tr_ptr, tr_name) - call register_segment_tracer(tr_ptr, param_file, GV, segment, OBC_array=.True.) - endif + call tracer_name_lookup(tr_Reg, tr_ptr, tr_name) + call register_segment_tracer(tr_ptr, param_file, GV, segment, OBC_array=.True.) enddo end subroutine register_obgc_segments @@ -4484,34 +4496,25 @@ subroutine fill_obgc_segments(G, OBC, tr_ptr, tr_name) type(ocean_OBC_type), pointer :: OBC !< Open boundary structure real, dimension(:,:,:), pointer :: tr_ptr !< Pointer to tracer field character(len=*), intent(in) :: tr_name!< Tracer name - ! Local variables integer :: isd, ied, IsdB, IedB, jsd, jed, JsdB, JedB, n, nz, nt integer :: i, j, k type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list if (.not. associated(OBC)) return - - if(trim(tr_name) /= 'gtr1') return !Test for one particular tracer - call pass_var(tr_ptr, G%Domain) - nz = G%ke - do n=1, OBC%number_of_segments segment => OBC%segment(n) if (.not. segment%on_pe) cycle - nt=get_tracer_index(segment,tr_name) if(nt .lt. 0) then call MOM_error(FATAL,"fill_obgc_segments: Did not find tracer "// tr_name) endif - isd = segment%HI%isd ; ied = segment%HI%ied jsd = segment%HI%jsd ; jed = segment%HI%jed IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB - ! Fill with Tracer values if (segment%is_E_or_W) then I=segment%HI%IsdB diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index c948e545fe..0de68fa6ed 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -110,7 +110,7 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS, ! Local variables logical :: register_MOM_generic_tracer - + logical :: obc_has character(len=128), parameter :: sub_name = 'register_MOM_generic_tracer' character(len=200) :: inputdir ! The directory where NetCDF input files are. ! These can be overridden later in via the field manager? @@ -210,9 +210,12 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS, registry_diags=.false., & !### CHANGE TO TRUE? restart_CS=restart_CS, mandatory=.not.CS%tracers_may_reinit) if (associated(CS%OBC)) & - call g_tracer_get_obc_segment_props(g_tracer,g_tracer_name,obc_src_file_name,obc_src_field_name) - call set_obgc_segments_props(g_tracer_name,obc_src_file_name,obc_src_field_name) - call register_obgc_segments(GV, CS%OBC, tr_Reg, param_file, g_tracer_name) + call g_tracer_get_obc_segment_props(g_tracer,g_tracer_name,obc_has ,& + obc_src_file_name,obc_src_field_name ) + if(obc_has) then + call set_obgc_segments_props(g_tracer_name,obc_src_file_name,obc_src_field_name) + call register_obgc_segments(GV, CS%OBC, tr_Reg, param_file, g_tracer_name) + endif else call register_restart_field(tr_ptr, g_tracer_name, .not.CS%tracers_may_reinit, & restart_CS, longname=longname, units=units) @@ -254,7 +257,7 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, !! ALE sponges. character(len=128), parameter :: sub_name = 'initialize_MOM_generic_tracer' - logical :: OK + logical :: OK,obc_has integer :: i, j, k, isc, iec, jsc, jec, nk type(g_tracer_type), pointer :: g_tracer,g_tracer_next character(len=fm_string_len) :: g_tracer_name @@ -356,7 +359,8 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, endif endif - call fill_obgc_segments(G, CS%OBC, tr_ptr, g_tracer_name) + call g_tracer_get_obc_segment_props(g_tracer,g_tracer_name,obc_has ) + if(obc_has) call fill_obgc_segments(G, CS%OBC, tr_ptr, g_tracer_name) !traverse the linked list till hit NULL call g_tracer_get_next(g_tracer, g_tracer_next) if (.NOT. associated(g_tracer_next)) exit From d06e1444984e6be7bda5c5efe5a00519b0f9185a Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Fri, 9 Oct 2020 15:45:41 -0400 Subject: [PATCH 90/91] Fix to fill OBC segments only for prognostic tracers --- src/tracer/MOM_generic_tracer.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index 0de68fa6ed..466890349b 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -360,7 +360,7 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, endif call g_tracer_get_obc_segment_props(g_tracer,g_tracer_name,obc_has ) - if(obc_has) call fill_obgc_segments(G, CS%OBC, tr_ptr, g_tracer_name) + if(obc_has .and. g_tracer_is_prog(g_tracer)) call fill_obgc_segments(G, CS%OBC, tr_ptr, g_tracer_name) !traverse the linked list till hit NULL call g_tracer_get_next(g_tracer, g_tracer_next) if (.NOT. associated(g_tracer_next)) exit From 8acd7d04915c5211281941d005c808526a921470 Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Tue, 27 Jul 2021 19:47:37 -0400 Subject: [PATCH 91/91] Fixes and set OBC_update period - These are some fixes towards understanding the restart issue for OBC models. - Also, introduce a time period for OBC_segment update --- src/core/MOM.F90 | 38 ++++++++++- src/core/MOM_open_boundary.F90 | 65 +++++++++++-------- .../MOM_state_initialization.F90 | 7 +- 3 files changed, 77 insertions(+), 33 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 69c759e4e2..95a6c090ce 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -259,6 +259,9 @@ module MOM !! 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. + real :: update_OBC_period!< The time interval between OBC updates + type(time_type) :: update_OBC_interval !< A time_time representation of update_OBC_period. + type(time_type) :: update_OBC_time !< The next time OBC is applied. real, dimension(:,:,:), pointer :: & @@ -1021,7 +1024,6 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & call disable_averaging(CS%diag) endif - if (CS%do_dynamics .and. CS%split) then !--------------------------- start SPLIT ! This section uses a split time stepping scheme for the dynamic equations, ! basically the stacked shallow water equations with viscosity. @@ -1035,6 +1037,17 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & endif endif + !OBC hack + if(associated(CS%OBC)) then + CS%OBC%update_OBC = .false. + if (CS%update_OBC_period == 0.0) CS%OBC%update_OBC = .true. + if (CS%update_OBC_period > 0.0) then + if (Time_local >= CS%update_OBC_time) then !### Change >= to > here. + CS%OBC%update_OBC = .true. + CS%update_OBC_time = CS%update_OBC_time + CS%update_OBC_interval + endif + endif + endif 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, US, CS%dyn_split_RK2_CSp, calc_dtbt, CS%VarMix, & @@ -1882,6 +1895,15 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "DTBT will be set every dynamics time step. The default "//& "is set by DT_THERM. This is only used if SPLIT is true.", & units="s", default=default_val, do_not_read=(dtbt > 0.0)) + !OBC hack + CS%update_OBC_period = -1.0 + call get_param(param_file, "MOM", "UPDATE_OBC_PERIOD", CS%update_OBC_period, & + "The period between recalculations OBC updates. "//& + "If DTBT_RESET_PERIOD is negative, DTBT is set based "//& + "only on information available at initialization. If 0, "//& + "OBC updates every dynamics time step. The default "//& + "is set by DT_THERM. This is only used if SPLIT is true.", & + units="s", default=default_val, do_not_read=(dtbt > 0.0)) endif ! This is here in case these values are used inappropriately. @@ -2541,7 +2563,6 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & 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) call thickness_diffuse_init(Time, G, GV, US, param_file, diag, CS%CDp, CS%thickness_diffuse_CSp) - 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, & @@ -2562,6 +2583,19 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & CS%dtbt_reset_time = CS%dtbt_reset_time - CS%dtbt_reset_interval endif endif + !OBC hack + if (associated(CS%OBC) .and. CS%update_OBC_period > 0.0) then + CS%update_OBC_interval = real_to_time(CS%update_OBC_period) + ! Set update_OBC_time to be the next even multiple of update_OBC_interval. + CS%update_OBC_time = Time_init + CS%update_OBC_interval * & + ((Time - Time_init) / CS%update_OBC_interval) + if ((CS%update_OBC_time > Time) .and. CS%OBC%update_OBC) then + ! Back up dtbt_reset_time one interval to force dtbt to be calculated, + ! because the restart was not aligned with the interval to recalculate + ! dtbt, and dtbt was not read from a restart file. + CS%update_OBC_time = CS%update_OBC_time - CS%update_OBC_interval + endif + endif elseif (CS%use_RK2) then 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, & diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index c41068e1fa..ab4a59db89 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -66,6 +66,7 @@ module MOM_open_boundary public rotate_OBC_config public rotate_OBC_init public initialize_segment_data +public setup_OBC_tracer_reservoirs 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 @@ -82,7 +83,7 @@ module MOM_open_boundary type, public :: OBC_segment_data_type integer :: fid !< handle from FMS associated with segment data on disk integer :: fid_dz !< handle from FMS associated with segment thicknesses on disk - character(len=8) :: name !< a name identifier for the segment data + character(len=32) :: name !< a name identifier for the segment data character(len=8) :: genre !< a family identifier for the segment data real, dimension(:,:,:), allocatable :: buffer_src !< buffer for segment data located at cell faces !! and on the original vertical grid @@ -329,7 +330,6 @@ module MOM_open_boundary type(external_tracers_segments_props), pointer, save :: obgc_segments_props => NULL() !< Linked-list of obgc tracers properties integer, save :: num_obgc_tracers = 0 !< Keeps the total number of obgc tracers integer :: id_clock_pass !< A CPU time clock - character(len=40) :: mdl = "MOM_open_boundary" !< This module's name. ! This include declares and sets the variable "version". #include "version_variable.h" @@ -1911,8 +1911,8 @@ subroutine open_boundary_impose_land_mask(OBC, G, areaCu, areaCv, US) end subroutine open_boundary_impose_land_mask !> Make sure the OBC tracer reservoirs are initialized. -subroutine setup_OBC_tracer_reservoirs(G, OBC) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure +subroutine setup_OBC_tracer_reservoirs(Gke, OBC) + integer, intent(in) :: Gke !< Ocean grid ke type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure ! Local variables type(OBC_segment_type), pointer :: segment => NULL() @@ -1925,7 +1925,7 @@ subroutine setup_OBC_tracer_reservoirs(G, OBC) I = segment%HI%IsdB do m=1,OBC%ntr if (associated(segment%tr_Reg%Tr(m)%tres)) then - do k=1,G%ke + do k=1,Gke do j=segment%HI%jsd,segment%HI%jed OBC%tres_x(I,j,k,m) = segment%tr_Reg%Tr(m)%t(i,j,k) enddo @@ -1936,7 +1936,7 @@ subroutine setup_OBC_tracer_reservoirs(G, OBC) J = segment%HI%JsdB do m=1,OBC%ntr if (associated(segment%tr_Reg%Tr(m)%tres)) then - do k=1,G%ke + do k=1,Gke do i=segment%HI%isd,segment%HI%ied OBC%tres_y(i,J,k,m) = segment%tr_Reg%Tr(m)%t(i,J,k) enddo @@ -3618,6 +3618,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) if (.not. associated(OBC)) return + call MOM_error(NOTE,"update_OBC_segment_data: called! ") do n = 1, OBC%number_of_segments segment => OBC%segment(n) @@ -4537,7 +4538,7 @@ subroutine fill_obgc_segments(G, OBC, tr_ptr, tr_name) endif segment%tr_Reg%Tr(nt)%tres(:,:,:) = segment%tr_Reg%Tr(nt)%t(:,:,:) enddo - call setup_OBC_tracer_reservoirs(G, OBC) !This will redo the T&S + !call setup_OBC_tracer_reservoirs(G%ke, OBC) !This will redo the T&S end subroutine fill_obgc_segments subroutine fill_temp_salt_segments(G, OBC, tv) @@ -4596,7 +4597,7 @@ subroutine fill_temp_salt_segments(G, OBC, tv) segment%tr_Reg%Tr(2)%tres(:,:,:) = segment%tr_Reg%Tr(2)%t(:,:,:) enddo - call setup_OBC_tracer_reservoirs(G, OBC) + !call setup_OBC_tracer_reservoirs(G%ke, OBC) end subroutine fill_temp_salt_segments !> Find the region outside of all open boundary segments and @@ -4856,7 +4857,7 @@ subroutine open_boundary_register_restarts(HI, GV, OBC, Reg, param_file, restart ! Local variables type(vardesc) :: vd(2) integer :: m, n - character(len=100) :: mesg + character(len=256) :: mesg,longname type(OBC_segment_type), pointer :: segment=>NULL() if (.not. associated(OBC)) & @@ -4924,37 +4925,41 @@ subroutine open_boundary_register_restarts(HI, GV, OBC, Reg, param_file, restart ! Still painfully inefficient, now in four dimensions. ! Allocating both for now so that the pass_vector works. - if (any(OBC%tracer_x_reservoirs_used) .or. any(OBC%tracer_y_reservoirs_used)) then + if (any(OBC%tracer_x_reservoirs_used)) then allocate(OBC%tres_x(HI%isdB:HI%iedB,HI%jsd:HI%jed,GV%ke,OBC%ntr)) OBC%tres_x(:,:,:,:) = 0.0 do m=1,OBC%ntr if (OBC%tracer_x_reservoirs_used(m)) then - if (modulo(HI%turns, 2) /= 0) then - write(mesg,'("tres_y_",I3.3)') m - vd(1) = var_desc(mesg,"Conc", "Tracer concentration for NS OBCs",'v','L') - call register_restart_field(OBC%tres_x(:,:,:,m), vd(1), .false., restart_CSp) - else +! if (modulo(HI%turns, 2) /= 0) then +! write(mesg,'("tres_y_",I3.3)') m +! longname="Tracer concentration for NS OBCs for "//trim(Reg%Tr(m)%name) +! vd(1) = var_desc(mesg,"Conc", longname,'v','L') +! call register_restart_field(OBC%tres_x(:,:,:,m), vd(1), .false., restart_CSp) +! else write(mesg,'("tres_x_",I3.3)') m - vd(1) = var_desc(mesg,"Conc", "Tracer concentration for EW OBCs",'u','L') + longname="Tracer concentration for EW OBCs for "//trim(Reg%Tr(m)%name) + vd(1) = var_desc(mesg,"Conc", longname,'u','L') call register_restart_field(OBC%tres_x(:,:,:,m), vd(1), .false., restart_CSp) - endif +! endif endif enddo -! endif -! if (any(OBC%tracer_y_reservoirs_used)) then + endif + if (any(OBC%tracer_y_reservoirs_used)) then allocate(OBC%tres_y(HI%isd:HI%ied,HI%jsdB:HI%jedB,GV%ke,OBC%ntr)) OBC%tres_y(:,:,:,:) = 0.0 do m=1,OBC%ntr if (OBC%tracer_y_reservoirs_used(m)) then - if (modulo(HI%turns, 2) /= 0) then - write(mesg,'("tres_x_",I3.3)') m - vd(1) = var_desc(mesg,"Conc", "Tracer concentration for EW OBCs",'u','L') - call register_restart_field(OBC%tres_y(:,:,:,m), vd(1), .false., restart_CSp) - else +! if (modulo(HI%turns, 2) /= 0) then +! write(mesg,'("tres_x_",I3.3)') m +! longname="Tracer concentration for EW OBCs for "//trim(Reg%Tr(m)%name) +! vd(1) = var_desc(mesg,"Conc", longname,'u','L') +! call register_restart_field(OBC%tres_y(:,:,:,m), vd(1), .false., restart_CSp) +! else write(mesg,'("tres_y_",I3.3)') m - vd(1) = var_desc(mesg,"Conc", "Tracer concentration for NS OBCs",'v','L') + longname="Tracer concentration for NS OBCs for "//trim(Reg%Tr(m)%name) + vd(1) = var_desc(mesg,"Conc", longname,'v','L') call register_restart_field(OBC%tres_y(:,:,:,m), vd(1), .false., restart_CSp) - endif +! endif endif enddo endif @@ -5005,7 +5010,9 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) u_L_in = min(0.0, (idir*uhr(I,j,k))*segment%Tr_InvLscale_in / & ((h(i+ishift,j,k) + GV%H_subroundoff)*G%dyCu(I,j))) fac1 = 1.0 + (u_L_out-u_L_in) - segment%tr_Reg%Tr(m)%tres(I,j,k) = (1.0/fac1)*(segment%tr_Reg%Tr(m)%tres(I,j,k) + & + segment%tr_Reg%Tr(m)%tres(I,j,k) = (1.0/fac1)*(segment%tr_Reg%Tr(m)%tres(I,j,k) + & !NOT reproduce across restart + !segment%tr_Reg%Tr(m)%tres(I,j,k) = (1.0/fac1)*(OBC%tres_x(I,j,k,m) + & !NOT reproduce + !segment%tr_Reg%Tr(m)%tres(I,j,k) = (1.0/fac1)*(segment%tr_Reg%Tr(m)%t(I,j,k) + & !Reproduce (u_L_out*Reg%Tr(m)%t(I+ishift,j,k) - & u_L_in*segment%tr_Reg%Tr(m)%t(I,j,k))) if (associated(OBC%tres_x)) OBC%tres_x(I,j,k,m) = segment%tr_Reg%Tr(m)%tres(I,j,k) @@ -5030,7 +5037,9 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) v_L_in = min(0.0, (jdir*vhr(i,J,k))*segment%Tr_InvLscale_in / & ((h(i,j+jshift,k) + GV%H_subroundoff)*G%dxCv(i,J))) fac1 = 1.0 + (v_L_out-v_L_in) - segment%tr_Reg%Tr(m)%tres(i,J,k) = (1.0/fac1)*(segment%tr_Reg%Tr(m)%tres(i,J,k) + & + segment%tr_Reg%Tr(m)%tres(i,J,k) = (1.0/fac1)*(segment%tr_Reg%Tr(m)%tres(i,J,k) + & !NOT reproduce across restart + !segment%tr_Reg%Tr(m)%tres(i,J,k) = (1.0/fac1)*(OBC%tres_y(i,J,k,m) + & !NOT reproduce + !segment%tr_Reg%Tr(m)%tres(i,J,k) = (1.0/fac1)*(segment%tr_Reg%Tr(m)%t(i,J,k) + & !Reproduce (v_L_out*Reg%Tr(m)%t(i,J+jshift,k) - & v_L_in*segment%tr_Reg%Tr(m)%t(i,J,k))) if (associated(OBC%tres_y)) OBC%tres_y(i,J,k,m) = segment%tr_Reg%Tr(m)%tres(i,J,k) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index b613648c7c..a08d4883c8 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -24,7 +24,7 @@ module MOM_state_initialization use MOM_open_boundary, only : open_boundary_query use MOM_open_boundary, only : set_tracer_data, initialize_segment_data use MOM_open_boundary, only : open_boundary_test_extern_h -use MOM_open_boundary, only : fill_temp_salt_segments +use MOM_open_boundary, only : fill_temp_salt_segments,setup_OBC_tracer_reservoirs use MOM_open_boundary, only : update_OBC_segment_data !use MOM_open_boundary, only : set_3D_OBC_data use MOM_grid_initialize, only : initialize_masks, set_grid_metrics @@ -380,9 +380,10 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & end select endif endif ! not from_Z_file. - if (use_temperature .and. use_OBC) & + if (use_temperature .and. use_OBC) then call fill_temp_salt_segments(G, OBC, tv) - + call setup_OBC_tracer_reservoirs(G%ke, OBC) + endif ! The thicknesses in halo points might be needed to initialize the velocities. if (new_sim) call pass_var(h, G%Domain)