From 82df597b74d469eef322be9f2ab8eb8df958e8e9 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Wed, 29 Nov 2017 10:57:29 -0900 Subject: [PATCH 01/20] New dyed_channel OBC option - adds to MOM_parameter_doc.all - has both dye and supercritical-type flow input - dyed_obc and dyed_channel have NUM_DYE_TRACERS dyes, runtime parameter - only invoke vertical diffusion for nz > 1 --- .../MOM_state_initialization.F90 | 4 + src/tracer/dye_example.F90 | 42 +++--- src/tracer/dyed_obc_tracer.F90 | 82 ++++++++---- src/user/dyed_channel_initialization.F90 | 124 ++++++++++++++++++ src/user/dyed_obcs_initialization.F90 | 21 ++- src/user/supercritical_initialization.F90 | 5 - 6 files changed, 216 insertions(+), 62 deletions(-) create mode 100644 src/user/dyed_channel_initialization.F90 diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index f70ebe9be9..67d26d2a34 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -75,6 +75,7 @@ module MOM_state_initialization use Rossby_front_2d_initialization, only : Rossby_front_initialize_velocity use SCM_idealized_hurricane, only : SCM_idealized_hurricane_TS_init use SCM_CVmix_tests, only: SCM_CVmix_tests_TS_init +use dyed_channel_initialization, only : dyed_channel_set_OBC_data use dyed_obcs_initialization, only : dyed_obcs_set_OBC_data use supercritical_initialization, only : supercritical_set_OBC_data use soliton_initialization, only : soliton_initialize_velocity @@ -535,6 +536,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & "A string that sets how the user code is invoked to set open\n"//& " boundary data: \n"//& " DOME - specified inflow on northern boundary\n"//& + " dyed_channel - supercritical with dye on the inflow boundary\n"//& " dyed_obcs - circle_obcs with dyes on the open boundaries\n"//& " Kelvin - barotropic Kelvin wave forcing on the western boundary\n"//& " shelfwave - Flather with shelf wave forcing on western boundary\n"//& @@ -543,6 +545,8 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & " USER - user specified", default="none") if (trim(config) == "DOME") then call DOME_set_OBC_data(OBC, tv, G, GV, PF, tracer_Reg) + elseif (trim(config) == "dyed_channel") then + call dyed_channel_set_OBC_data(OBC, G, GV, PF, tracer_Reg) elseif (trim(config) == "dyed_obcs") then call dyed_obcs_set_OBC_data(OBC, G, GV, PF, tracer_Reg) elseif (trim(config) == "Kelvin") then diff --git a/src/tracer/dye_example.F90 b/src/tracer/dye_example.F90 index 87bae7bd6b..da7439f6a8 100644 --- a/src/tracer/dye_example.F90 +++ b/src/tracer/dye_example.F90 @@ -2,27 +2,27 @@ module regional_dyes ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr -use MOM_diag_mediator, only : diag_ctrl -use MOM_diag_to_Z, only : register_Z_tracer, diag_to_Z_CS -use MOM_error_handler, only : MOM_error, FATAL, WARNING -use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_forcing_type, only : forcing -use MOM_grid, only : ocean_grid_type -use MOM_hor_index, only : hor_index_type -use MOM_io, only : file_exists, read_data, slasher, vardesc, var_desc, query_vardesc -use MOM_open_boundary, only : ocean_OBC_type -use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS -use MOM_sponge, only : set_up_sponge_field, sponge_CS -use MOM_time_manager, only : time_type, get_time -use MOM_tracer_registry, only : register_tracer, tracer_registry_type -use MOM_tracer_registry, only : add_tracer_diagnostics, add_tracer_OBC_values -use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut -use MOM_tracer_Z_init, only : tracer_Z_init -use MOM_variables, only : surface -use MOM_verticalGrid, only : verticalGrid_type - -use coupler_types_mod, only : coupler_type_set_data, ind_csurf +use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr +use MOM_diag_mediator, only : diag_ctrl +use MOM_diag_to_Z, only : register_Z_tracer, diag_to_Z_CS +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type +use MOM_io, only : file_exists, read_data, slasher, vardesc, var_desc, query_vardesc +use MOM_open_boundary, only : ocean_OBC_type +use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS +use MOM_sponge, only : set_up_sponge_field, sponge_CS +use MOM_time_manager, only : time_type, get_time +use MOM_tracer_registry, only : register_tracer, tracer_registry_type +use MOM_tracer_registry, only : add_tracer_diagnostics, add_tracer_OBC_values +use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut +use MOM_tracer_Z_init, only : tracer_Z_init +use MOM_variables, only : surface +use MOM_verticalGrid, only : verticalGrid_type + +use coupler_types_mod, only : coupler_type_set_data, ind_csurf use atmos_ocean_fluxes_mod, only : aof_set_coupler_flux implicit none ; private diff --git a/src/tracer/dyed_obc_tracer.F90 b/src/tracer/dyed_obc_tracer.F90 index 435bcf5a2a..21c0a4009a 100644 --- a/src/tracer/dyed_obc_tracer.F90 +++ b/src/tracer/dyed_obc_tracer.F90 @@ -30,14 +30,12 @@ module dyed_obc_tracer public register_dyed_obc_tracer, initialize_dyed_obc_tracer public dyed_obc_tracer_column_physics, dyed_obc_tracer_end -! ntr is the number of tracers in this module. -integer, parameter :: NTR = 4 - type p3d real, dimension(:,:,:), pointer :: p => NULL() end type p3d type, public :: dyed_obc_tracer_CS ; private + integer :: ntr ! The number of tracers that are actually used. logical :: coupled_tracers = .false. ! These tracers are not offered to the ! coupler. character(len=200) :: tracer_IC_file ! The full path to the IC file, or " " @@ -46,23 +44,23 @@ module dyed_obc_tracer type(tracer_registry_type), pointer :: tr_Reg => NULL() real, pointer :: tr(:,:,:,:) => NULL() ! The array of tracers used in this ! subroutine, in g m-3? - type(p3d), dimension(NTR) :: & + type(p3d), allocatable, dimension(:) :: & tr_adx, &! Tracer zonal advective fluxes in g m-3 m3 s-1. tr_ady, &! Tracer meridional advective fluxes in g m-3 m3 s-1. tr_dfx, &! Tracer zonal diffusive fluxes in g m-3 m3 s-1. tr_dfy ! Tracer meridional diffusive fluxes in g m-3 m3 s-1. - real :: land_val(NTR) = -1.0 ! The value of tr used where land is masked out. - integer, dimension(NTR) :: ind_tr ! Indices returned by aof_set_coupler_flux - ! if it is used and the surface tracer concentrations are to be - ! provided to the coupler. + integer, allocatable, dimension(:) :: & + ind_tr, & ! Indices returned by aof_set_coupler_flux if it is used and the + ! surface tracer concentrations are to be provided to the coupler. + id_tracer, id_tr_adx, id_tr_ady, & + id_tr_dfx, id_tr_dfy type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the ! timing of diagnostic output. - integer, dimension(NTR) :: id_tracer = -1, id_tr_adx = -1, id_tr_ady = -1 - integer, dimension(NTR) :: id_tr_dfx = -1, id_tr_dfy = -1 + type(MOM_restart_CS), pointer :: restart_CSp => NULL() - type(vardesc) :: tr_desc(NTR) + type(vardesc), allocatable :: tr_desc(:) end type dyed_obc_tracer_CS contains @@ -84,6 +82,8 @@ function register_dyed_obc_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) #include "version_variable.h" character(len=40) :: mdl = "dyed_obc_tracer" ! This module's name. character(len=200) :: inputdir + character(len=48) :: var_name ! The variable's name. + character(len=48) :: desc_name ! The variable's descriptor. real, pointer :: tr_ptr(:,:,:) => NULL() logical :: register_dyed_obc_tracer integer :: isd, ied, jsd, jed, nz, m @@ -98,6 +98,27 @@ function register_dyed_obc_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "NUM_DYE_TRACERS", CS%ntr, & + "The number of dye tracers in this run. Each tracer \n"//& + "should have a separate boundary segment.", default=0) + allocate(CS%tr_adx(CS%ntr), & + CS%tr_ady(CS%ntr), & + CS%tr_dfx(CS%ntr), & + CS%tr_dfy(CS%ntr)) + allocate(CS%ind_tr(CS%ntr), & + CS%id_tracer(CS%ntr), & + CS%id_tr_adx(CS%ntr), & + CS%id_tr_ady(CS%ntr), & + CS%id_tr_dfx(CS%ntr), & + CS%id_tr_dfy(CS%ntr)) + allocate(CS%tr_desc(CS%ntr)) + + CS%id_tracer(:) = -1 + CS%id_tr_adx(:) = -1 + CS%id_tr_ady(:) = -1 + CS%id_tr_dfx(:) = -1 + CS%id_tr_dfy(:) = -1 + call get_param(param_file, mdl, "dyed_obc_TRACER_IC_FILE", CS%tracer_IC_file, & "The name of a file from which to read the initial \n"//& "conditions for the dyed_obc tracers, or blank to initialize \n"//& @@ -110,11 +131,11 @@ function register_dyed_obc_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) CS%tracer_IC_file) endif - allocate(CS%tr(isd:ied,jsd:jed,nz,NTR)) ; CS%tr(:,:,:,:) = 0.0 + allocate(CS%tr(isd:ied,jsd:jed,nz,CS%ntr)) ; CS%tr(:,:,:,:) = 0.0 - do m=1,NTR - write(name,'("dye_",I1.1)') m - write(longname,'("Concentration of dyed_obc Tracer ",I1.1)') m + do m=1,CS%ntr + write(name,'("dye_",I2.2)') m + write(longname,'("Concentration of dyed_obc Tracer ",I2.2)') m CS%tr_desc(m) = var_desc(name, units="kg kg-1", longname=longname, caller=mdl) ! This is needed to force the compiler not to do a copy in the registration @@ -135,10 +156,11 @@ function register_dyed_obc_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) enddo CS%tr_Reg => tr_Reg + CS%restart_CSp => restart_CS register_dyed_obc_tracer = .true. end function register_dyed_obc_tracer -!> This subroutine initializes the NTR tracer fields in tr(:,:,:,:) +!> This subroutine initializes the CS%ntr tracer fields in tr(:,:,:,:) !! and it sets up the tracer output. subroutine initialize_dyed_obc_tracer(restart, day, G, GV, h, diag, OBC, CS, & diag_to_Z_CSp) @@ -162,7 +184,7 @@ subroutine initialize_dyed_obc_tracer(restart, day, G, GV, h, diag, OBC, CS, & OBC_tr1_v => NULL() ! specify the values of tracer 1 that should come ! in through u- and v- points through the open ! boundary conditions, in the same units as tr. - character(len=16) :: name ! A variable's name in a NetCDF file. + character(len=24) :: name ! A variable's name in a NetCDF file. character(len=72) :: longname ! The long name of that variable. character(len=48) :: units ! The dimensions of the variable. character(len=48) :: flux_units ! The units for tracer fluxes, usually @@ -175,6 +197,7 @@ subroutine initialize_dyed_obc_tracer(restart, day, G, GV, h, diag, OBC, CS, & integer :: IsdB, IedB, JsdB, JedB if (.not.associated(CS)) return + if (CS%ntr < 1) return is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB @@ -189,12 +212,12 @@ subroutine initialize_dyed_obc_tracer(restart, day, G, GV, h, diag, OBC, CS, & if (.not.file_exists(CS%tracer_IC_file, G%Domain)) & call MOM_error(FATAL, "dyed_obc_initialize_tracer: Unable to open "// & CS%tracer_IC_file) - do m=1,NTR + do m=1,CS%ntr call query_vardesc(CS%tr_desc(m), name, caller="initialize_dyed_obc_tracer") call MOM_read_data(CS%tracer_IC_file, trim(name), CS%tr(:,:,:,m), G%Domain) enddo else - do m=1,NTR + do m=1,CS%ntr do k=1,nz ; do j=js,je ; do i=is,ie CS%tr(i,j,k,m) = 0.0 enddo ; enddo ; enddo @@ -206,7 +229,7 @@ subroutine initialize_dyed_obc_tracer(restart, day, G, GV, h, diag, OBC, CS, & if (GV%Boussinesq) then ; flux_units = "kg kg-1 m3 s-1" else ; flux_units = "kg s-1" ; endif - do m=1,NTR + do m=1,CS%ntr ! Register the tracer for the restart file. call query_vardesc(CS%tr_desc(m), name, units=units, longname=longname, & caller="initialize_dyed_obc_tracer") @@ -277,23 +300,24 @@ subroutine dyed_obc_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (.not.associated(CS)) return + if (CS%ntr < 1) return if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then - do m=1,NTR + do m=1,CS%ntr do k=1,nz ;do j=js,je ; do i=is,ie - h_work(i,j,k) = h_old(i,j,k) + h_work(i,j,k) = h_old(i,j,k) enddo ; enddo ; enddo; call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m) , dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth) - call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) + if (nz > 1) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) enddo else - do m=1,NTR - call tracer_vertdiff(h_old, ea, eb, dt, CS%tr(:,:,:,m), G, GV) + do m=1,CS%ntr + if (nz > 1) call tracer_vertdiff(h_old, ea, eb, dt, CS%tr(:,:,:,m), G, GV) enddo endif - do m=1,NTR + do m=1,CS%ntr if (CS%id_tracer(m)>0) & call post_data(CS%id_tracer(m),CS%tr(:,:,:,m),CS%diag) if (CS%id_tr_adx(m)>0) & @@ -315,7 +339,7 @@ subroutine dyed_obc_tracer_end(CS) if (associated(CS)) then if (associated(CS%tr)) deallocate(CS%tr) - do m=1,NTR + do m=1,CS%ntr if (associated(CS%tr_adx(m)%p)) deallocate(CS%tr_adx(m)%p) if (associated(CS%tr_ady(m)%p)) deallocate(CS%tr_ady(m)%p) if (associated(CS%tr_dfx(m)%p)) deallocate(CS%tr_dfx(m)%p) @@ -328,7 +352,8 @@ end subroutine dyed_obc_tracer_end !> \namespace dyed_obc_tracer !! * -!! By Kate Hedstrom, 2017, copied from DOME tracers. * +!! By Kate Hedstrom, 2017, copied from DOME tracers and also * +!! dye_example. * !! * !! This file contains an example of the code that is needed to set * !! up and use a set of dynamically passive tracers. These tracers * @@ -341,7 +366,6 @@ end subroutine dyed_obc_tracer_end !! chemistry along with diapycnal mixing (included here because some * !! tracers may float or swim vertically or dye diapycnal processes). * !! * -!! * !! Macros written all in capital letters are defined in MOM_memory.h. * !! * !! A small fragment of the grid is shown below: * diff --git a/src/user/dyed_channel_initialization.F90 b/src/user/dyed_channel_initialization.F90 new file mode 100644 index 0000000000..a025344cac --- /dev/null +++ b/src/user/dyed_channel_initialization.F90 @@ -0,0 +1,124 @@ +module dyed_channel_initialization + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_dyn_horgrid, only : dyn_horgrid_type +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_get_input, only : directories +use MOM_grid, only : ocean_grid_type +use MOM_io, only : vardesc, var_desc +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_SIMPLE +use MOM_open_boundary, only : OBC_segment_type, register_segment_tracer +use MOM_tracer_registry, only : tracer_registry_type, add_tracer_OBC_values +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public dyed_channel_set_OBC_data + +integer :: ntr = 0 + +contains + +!> This subroutine sets the dye and flow properties at open boundary conditions. +subroutine dyed_channel_set_OBC_data(OBC, G, GV, param_file, tr_Reg) + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies + !! whether, where, and what open boundary + !! conditions are used. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file + !! to parse for model parameter values. + type(tracer_registry_type), pointer :: tr_Reg !< Tracer registry. + +! Local variables + character(len=40) :: mdl = "dyed_channel_set_OBC_data" ! This subroutine's name. + character(len=80) :: name, longname + real :: zonal_flow + integer :: i, j, k, l, itt, isd, ied, jsd, jed, m, n, nz + integer :: IsdB, IedB, JsdB, JedB + real :: dye + type(OBC_segment_type), pointer :: segment + type(vardesc), allocatable, dimension(:) :: tr_desc + + nz = G%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + if (.not.associated(OBC)) call MOM_error(FATAL, 'dyed_channel_initialization.F90: '// & + 'dyed_channel_set_OBC_data() was called but OBC type was not initialized!') + + call get_param(param_file, mdl, "SUPERCRITICAL_ZONAL_FLOW", zonal_flow, & + "Constant zonal flow imposed at upstream open boundary.", & + units="m/s", default=8.57) + + do l=1, OBC%number_of_segments + segment => OBC%segment(l) + if (.not. segment%on_pe) cycle + if (segment%gradient) cycle + if (segment%oblique .and. .not. segment%nudged .and. .not. segment%Flather) cycle + + if (segment%is_E_or_W) then + jsd = segment%HI%jsd ; jed = segment%HI%jed + IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB + do k=1,G%ke + do j=jsd,jed ; do I=IsdB,IedB + if (segment%specified .or. segment%nudged) then + segment%normal_vel(I,j,k) = zonal_flow + endif + if (segment%specified) then + segment%normal_trans(I,j,k) = zonal_flow * G%dyCu(I,j) + endif + enddo ; enddo + enddo + do j=jsd,jed ; do I=IsdB,IedB + segment%normal_vel_bt(I,j) = zonal_flow + enddo ; enddo + else + isd = segment%HI%isd ; ied = segment%HI%ied + JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB + do J=JsdB,JedB ; do i=isd,ied + segment%normal_vel_bt(i,J) = 0.0 + enddo ; enddo + endif + enddo + + call get_param(param_file, mdl, "NUM_DYE_TRACERS", ntr, & + "The number of dye tracers in this run. Each tracer \n"//& + "should have a separate boundary segment.", default=0, & + do_not_log=.true.) + + if (OBC%number_of_segments .lt. ntr) then + call MOM_error(WARNING, "Error in dyed_obc segment setup") + return !!! Need a better error message here + endif + allocate(tr_desc(ntr)) + +! ! Set the inflow values of the dyes, one per segment. +! ! We know the order: north, south, east, west + do m=1,ntr + write(name,'("dye_",I1.1)') m + write(longname,'("Concentration of dyed_obc Tracer ",I1.1, " on segment ",I1.1)') m, m + tr_desc(m) = var_desc(name, units="kg kg-1", longname=longname, caller=mdl) + + do n=1,OBC%number_of_segments + if (n == m) then + dye = 1.0 + else + dye = 0.0 + endif + call register_segment_tracer(tr_desc(m), param_file, GV, & + OBC%segment(n), OBC_scalar=dye) + enddo + enddo + deallocate(tr_desc) + +end subroutine dyed_channel_set_OBC_data + +!> \namespace dyed_channel_initialization +!! Setting dyes, one for painting the inflow on each side. +end module dyed_channel_initialization diff --git a/src/user/dyed_obcs_initialization.F90 b/src/user/dyed_obcs_initialization.F90 index e1acea3948..8e490890d1 100644 --- a/src/user/dyed_obcs_initialization.F90 +++ b/src/user/dyed_obcs_initialization.F90 @@ -3,7 +3,7 @@ module dyed_obcs_initialization ! This file is part of MOM6. See LICENSE.md for the license. use MOM_dyn_horgrid, only : dyn_horgrid_type -use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type @@ -20,7 +20,7 @@ module dyed_obcs_initialization public dyed_obcs_set_OBC_data -integer, parameter :: NTR = 4 +integer :: ntr = 0 contains @@ -42,7 +42,7 @@ subroutine dyed_obcs_set_OBC_data(OBC, G, GV, param_file, tr_Reg) integer :: IsdB, IedB, JsdB, JedB real :: dye type(OBC_segment_type), pointer :: segment - type(vardesc) :: tr_desc(NTR) + type(vardesc), allocatable, dimension(:) :: tr_desc is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -50,19 +50,25 @@ subroutine dyed_obcs_set_OBC_data(OBC, G, GV, param_file, tr_Reg) if (.not.associated(OBC)) return - if (OBC%number_of_segments .ne. 4) then - print *, 'Error in dyed_obcs segment setup' + call get_param(param_file, mdl, "NUM_DYE_TRACERS", ntr, & + "The number of dye tracers in this run. Each tracer \n"//& + "should have a separate boundary segment.", default=0, & + do_not_log=.true.) + + if (OBC%number_of_segments .lt. ntr) then + call MOM_error(WARNING, "Error in dyed_obc segment setup") return !!! Need a better error message here endif + allocate(tr_desc(ntr)) ! ! Set the inflow values of the dyes, one per segment. ! ! We know the order: north, south, east, west - do m=1,NTR + do m=1,ntr write(name,'("dye_",I1.1)') m write(longname,'("Concentration of dyed_obc Tracer ",I1.1, " on segment ",I1.1)') m, m tr_desc(m) = var_desc(name, units="kg kg-1", longname=longname, caller=mdl) - do n=1,NTR + do n=1,OBC%number_of_segments if (n == m) then dye = 1.0 else @@ -72,6 +78,7 @@ subroutine dyed_obcs_set_OBC_data(OBC, G, GV, param_file, tr_Reg) OBC%segment(n), OBC_scalar=dye) enddo enddo + deallocate(tr_desc) end subroutine dyed_obcs_set_OBC_data diff --git a/src/user/supercritical_initialization.F90 b/src/user/supercritical_initialization.F90 index 862b078750..f0104dd333 100644 --- a/src/user/supercritical_initialization.F90 +++ b/src/user/supercritical_initialization.F90 @@ -68,11 +68,6 @@ subroutine supercritical_set_OBC_data(OBC, G, param_file) else isd = segment%HI%isd ; ied = segment%HI%ied JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB -! do k=1,G%ke -! do J=JsdB,JedB ; do i=isd,ied -! segment%normal_vel(i,J,k) = 0.0 -! enddo ; enddo -! enddo do J=JsdB,JedB ; do i=isd,ied segment%normal_vel_bt(i,J) = 0.0 enddo ; enddo From 8e4348caf5dbda06566b950e1f9561aa3c7f040e Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Thu, 30 Nov 2017 15:07:32 -0900 Subject: [PATCH 02/20] Fix up dyed_channel for both tracers and time-dependence - Needs OBC tracer registry - Needs boundary update call --- src/core/MOM_boundary_update.F90 | 26 ++- .../MOM_state_initialization.F90 | 5 +- src/user/dyed_channel_initialization.F90 | 160 +++++++++++++----- src/user/dyed_obcs_initialization.F90 | 4 +- src/user/shelfwave_initialization.F90 | 2 +- 5 files changed, 139 insertions(+), 58 deletions(-) diff --git a/src/core/MOM_boundary_update.F90 b/src/core/MOM_boundary_update.F90 index d56f3ed589..abcfcc8807 100644 --- a/src/core/MOM_boundary_update.F90 +++ b/src/core/MOM_boundary_update.F90 @@ -22,6 +22,8 @@ module MOM_boundary_update use Kelvin_initialization, only : Kelvin_OBC_end, Kelvin_OBC_CS use shelfwave_initialization, only : shelfwave_set_OBC_data, register_shelfwave_OBC use shelfwave_initialization, only : shelfwave_OBC_end, shelfwave_OBC_CS +use dyed_channel_initialization, only : dyed_channel_update_flow, register_dyed_channel_OBC +use dyed_channel_initialization, only : dyed_channel_OBC_end, dyed_channel_OBC_CS implicit none ; private @@ -35,10 +37,12 @@ module MOM_boundary_update logical :: use_Kelvin = .false. logical :: use_tidal_bay = .false. logical :: use_shelfwave = .false. + logical :: use_dyed_channel = .false. type(file_OBC_CS), pointer :: file_OBC_CSp => NULL() type(Kelvin_OBC_CS), pointer :: Kelvin_OBC_CSp => NULL() type(tidal_bay_OBC_CS), pointer :: tidal_bay_OBC_CSp => NULL() type(shelfwave_OBC_CS), pointer :: shelfwave_OBC_CSp => NULL() + type(dyed_channel_OBC_CS), pointer :: dyed_channel_OBC_CSp => NULL() end type update_OBC_CS integer :: id_clock_pass @@ -78,6 +82,9 @@ subroutine call_OBC_register(param_file, CS, OBC) call get_param(param_file, mdl, "USE_SHELFWAVE_OBC", CS%use_shelfwave, & "If true, use the shelfwave open boundary.", & default=.false.) + call get_param(param_file, mdl, "USE_DYED_CHANNEL_OBC", CS%use_dyed_channel, & + "If true, use the dyed channel open boundary.", & + default=.false.) if (CS%use_files) CS%use_files = & register_file_OBC(param_file, CS%file_OBC_CSp, & @@ -91,18 +98,21 @@ subroutine call_OBC_register(param_file, CS, OBC) if (CS%use_shelfwave) CS%use_shelfwave = & register_shelfwave_OBC(param_file, CS%shelfwave_OBC_CSp, & OBC%OBC_Reg) + if (CS%use_dyed_channel) CS%use_dyed_channel = & + register_dyed_channel_OBC(param_file, CS%dyed_channel_OBC_CSp, & + OBC%OBC_Reg) end subroutine call_OBC_register !> Calls appropriate routine to update the open boundary conditions. subroutine update_OBC_data(OBC, G, GV, tv, h, CS, Time) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< layer thickness - type(ocean_OBC_type), pointer :: OBC !< Open boundary structure - type(update_OBC_CS), pointer :: CS !< Control structure for OBCs - type(time_type), intent(in) :: Time !< Model time + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< layer thickness + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + type(update_OBC_CS), pointer :: CS !< Control structure for OBCs + type(time_type), intent(in) :: Time !< Model time ! Local variables logical :: read_OBC_eta = .false. logical :: read_OBC_uv = .false. @@ -126,6 +136,8 @@ subroutine update_OBC_data(OBC, G, GV, tv, h, CS, Time) call Kelvin_set_OBC_data(OBC, CS%Kelvin_OBC_CSp, G, h, Time) if (CS%use_shelfwave) & call shelfwave_set_OBC_data(OBC, CS%shelfwave_OBC_CSp, G, h, Time) + if (CS%use_dyed_channel) & + call dyed_channel_update_flow(OBC, CS%dyed_channel_OBC_CSp, G, Time) if (OBC%needs_IO_for_data) & call update_OBC_segment_data(G, GV, OBC, tv, h, Time) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 67d26d2a34..3cfb739bca 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -75,7 +75,7 @@ module MOM_state_initialization use Rossby_front_2d_initialization, only : Rossby_front_initialize_velocity use SCM_idealized_hurricane, only : SCM_idealized_hurricane_TS_init use SCM_CVmix_tests, only: SCM_CVmix_tests_TS_init -use dyed_channel_initialization, only : dyed_channel_set_OBC_data +use dyed_channel_initialization, only : dyed_channel_set_OBC_tracer_data use dyed_obcs_initialization, only : dyed_obcs_set_OBC_data use supercritical_initialization, only : supercritical_set_OBC_data use soliton_initialization, only : soliton_initialize_velocity @@ -546,7 +546,8 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & if (trim(config) == "DOME") then call DOME_set_OBC_data(OBC, tv, G, GV, PF, tracer_Reg) elseif (trim(config) == "dyed_channel") then - call dyed_channel_set_OBC_data(OBC, G, GV, PF, tracer_Reg) + call dyed_channel_set_OBC_tracer_data(OBC, G, GV, PF, tracer_Reg) + OBC%update_OBC = .true. elseif (trim(config) == "dyed_obcs") then call dyed_obcs_set_OBC_data(OBC, G, GV, PF, tracer_Reg) elseif (trim(config) == "Kelvin") then diff --git a/src/user/dyed_channel_initialization.F90 b/src/user/dyed_channel_initialization.F90 index a025344cac..0974d15671 100644 --- a/src/user/dyed_channel_initialization.F90 +++ b/src/user/dyed_channel_initialization.F90 @@ -10,6 +10,8 @@ module dyed_channel_initialization use MOM_io, only : vardesc, var_desc use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_SIMPLE use MOM_open_boundary, only : OBC_segment_type, register_segment_tracer +use MOM_open_boundary, only : OBC_registry_type, register_OBC +use MOM_time_manager, only : time_type, set_time, time_type_to_real use MOM_tracer_registry, only : tracer_registry_type, add_tracer_OBC_values use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type @@ -18,14 +20,59 @@ module dyed_channel_initialization #include -public dyed_channel_set_OBC_data +public dyed_channel_set_OBC_tracer_data, dyed_channel_OBC_end +public register_dyed_channel_OBC, dyed_channel_update_flow + +!> Control structure for tidal bay open boundaries. +type, public :: dyed_channel_OBC_CS ; private + real :: zonal_flow = 8.57 !< Maximum inflow + real :: frequency = 0.0 !< Inflow frequency +end type dyed_channel_OBC_CS integer :: ntr = 0 contains +!> Add dyed channel to OBC registry. +function register_dyed_channel_OBC(param_file, CS, OBC_Reg) + type(param_file_type), intent(in) :: param_file !< parameter file. + type(dyed_channel_OBC_CS), pointer :: CS !< tidal bay control structure. + type(OBC_registry_type), pointer :: OBC_Reg !< OBC registry. + logical :: register_dyed_channel_OBC + character(len=32) :: casename = "dyed channel" !< This case's name. + character(len=40) :: mdl = "register_dyed_channel_OBC" ! This subroutine's name. + + if (associated(CS)) then + call MOM_error(WARNING, "register_dyed_channel_OBC called with an "// & + "associated control structure.") + return + endif + allocate(CS) + + call get_param(param_file, mdl, "SUPERCRITICAL_ZONAL_FLOW", CS%zonal_flow, & + "Constant zonal flow imposed at upstream open boundary.", & + units="m/s", default=8.57) + call get_param(param_file, mdl, "CHANNEL_FLOW_FREQUENCY", CS%frequency, & + "Frequency of oscillating zonal flow.", & + units="s-1", default=0.0) + + ! Register the open boundaries. + call register_OBC(casename, param_file, OBC_Reg) + register_dyed_channel_OBC = .true. + +end function register_dyed_channel_OBC + +!> Clean up the dyed_channel OBC from registry. +subroutine dyed_channel_OBC_end(CS) + type(dyed_channel_OBC_CS), pointer :: CS !< tidal bay control structure. + + if (associated(CS)) then + deallocate(CS) + endif +end subroutine dyed_channel_OBC_end + !> This subroutine sets the dye and flow properties at open boundary conditions. -subroutine dyed_channel_set_OBC_data(OBC, G, GV, param_file, tr_Reg) +subroutine dyed_channel_set_OBC_tracer_data(OBC, G, GV, param_file, tr_Reg) type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies !! whether, where, and what open boundary !! conditions are used. @@ -36,25 +83,71 @@ subroutine dyed_channel_set_OBC_data(OBC, G, GV, param_file, tr_Reg) type(tracer_registry_type), pointer :: tr_Reg !< Tracer registry. ! Local variables - character(len=40) :: mdl = "dyed_channel_set_OBC_data" ! This subroutine's name. + character(len=40) :: mdl = "dyed_channel_set_OBC_tracer_data" ! This subroutine's name. character(len=80) :: name, longname - real :: zonal_flow - integer :: i, j, k, l, itt, isd, ied, jsd, jed, m, n, nz + integer :: i, j, k, l, itt, isd, ied, jsd, jed, m, n integer :: IsdB, IedB, JsdB, JedB real :: dye type(OBC_segment_type), pointer :: segment type(vardesc), allocatable, dimension(:) :: tr_desc - nz = G%ke - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - if (.not.associated(OBC)) call MOM_error(FATAL, 'dyed_channel_initialization.F90: '// & 'dyed_channel_set_OBC_data() was called but OBC type was not initialized!') - call get_param(param_file, mdl, "SUPERCRITICAL_ZONAL_FLOW", zonal_flow, & - "Constant zonal flow imposed at upstream open boundary.", & - units="m/s", default=8.57) + call get_param(param_file, mdl, "NUM_DYE_TRACERS", ntr, & + "The number of dye tracers in this run. Each tracer \n"//& + "should have a separate boundary segment.", default=0, & + do_not_log=.true.) + + if (OBC%number_of_segments .lt. ntr) then + call MOM_error(WARNING, "Error in dyed_obc segment setup") + return !!! Need a better error message here + endif + allocate(tr_desc(ntr)) + +! ! Set the inflow values of the dyes, one per segment. +! ! We know the order: north, south, east, west + do m=1,ntr + write(name,'("dye_",I2.2)') m + write(longname,'("Concentration of dyed_obc Tracer ",I2.2, " on segment ",I2.2)') m, m + tr_desc(m) = var_desc(name, units="kg kg-1", longname=longname, caller=mdl) + + do n=1,OBC%number_of_segments + if (n == m) then + dye = 1.0 + else + dye = 0.0 + endif + call register_segment_tracer(tr_desc(m), param_file, GV, & + OBC%segment(n), OBC_scalar=dye) + enddo + enddo + deallocate(tr_desc) + +end subroutine dyed_channel_set_OBC_tracer_data + +!> This subroutine updates the long-channel flow +subroutine dyed_channel_update_flow(OBC, CS, G, Time) + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies + !! whether, where, and what open boundary + !! conditions are used. + type(dyed_channel_OBC_CS), pointer :: CS !< tidal bay control structure. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(time_type), intent(in) :: Time !< model time. + +! Local variables + character(len=40) :: mdl = "dyed_channel_update_flow" ! This subroutine's name. + character(len=80) :: name, longname + real :: flow, time_sec, PI + integer :: i, j, k, l, itt, isd, ied, jsd, jed, m, n + integer :: IsdB, IedB, JsdB, JedB + type(OBC_segment_type), pointer :: segment + + if (.not.associated(OBC)) call MOM_error(FATAL, 'dyed_channel_initialization.F90: '// & + 'dyed_channel_update_flow() was called but OBC type was not initialized!') + + time_sec = time_type_to_real(Time) + PI = 4.0*atan(1.0) do l=1, OBC%number_of_segments segment => OBC%segment(l) @@ -65,18 +158,23 @@ subroutine dyed_channel_set_OBC_data(OBC, G, GV, param_file, tr_Reg) if (segment%is_E_or_W) then jsd = segment%HI%jsd ; jed = segment%HI%jed IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB + if (CS%frequency == 0.0) then + flow = CS%zonal_flow + else + flow = CS%zonal_flow * cos(2 * PI * CS%frequency * time_sec) + endif do k=1,G%ke do j=jsd,jed ; do I=IsdB,IedB if (segment%specified .or. segment%nudged) then - segment%normal_vel(I,j,k) = zonal_flow + segment%normal_vel(I,j,k) = flow endif if (segment%specified) then - segment%normal_trans(I,j,k) = zonal_flow * G%dyCu(I,j) + segment%normal_trans(I,j,k) = flow * G%dyCu(I,j) endif enddo ; enddo enddo do j=jsd,jed ; do I=IsdB,IedB - segment%normal_vel_bt(I,j) = zonal_flow + segment%normal_vel_bt(I,j) = flow enddo ; enddo else isd = segment%HI%isd ; ied = segment%HI%ied @@ -87,37 +185,7 @@ subroutine dyed_channel_set_OBC_data(OBC, G, GV, param_file, tr_Reg) endif enddo - call get_param(param_file, mdl, "NUM_DYE_TRACERS", ntr, & - "The number of dye tracers in this run. Each tracer \n"//& - "should have a separate boundary segment.", default=0, & - do_not_log=.true.) - - if (OBC%number_of_segments .lt. ntr) then - call MOM_error(WARNING, "Error in dyed_obc segment setup") - return !!! Need a better error message here - endif - allocate(tr_desc(ntr)) - -! ! Set the inflow values of the dyes, one per segment. -! ! We know the order: north, south, east, west - do m=1,ntr - write(name,'("dye_",I1.1)') m - write(longname,'("Concentration of dyed_obc Tracer ",I1.1, " on segment ",I1.1)') m, m - tr_desc(m) = var_desc(name, units="kg kg-1", longname=longname, caller=mdl) - - do n=1,OBC%number_of_segments - if (n == m) then - dye = 1.0 - else - dye = 0.0 - endif - call register_segment_tracer(tr_desc(m), param_file, GV, & - OBC%segment(n), OBC_scalar=dye) - enddo - enddo - deallocate(tr_desc) - -end subroutine dyed_channel_set_OBC_data +end subroutine dyed_channel_update_flow !> \namespace dyed_channel_initialization !! Setting dyes, one for painting the inflow on each side. diff --git a/src/user/dyed_obcs_initialization.F90 b/src/user/dyed_obcs_initialization.F90 index 8e490890d1..b608395a3f 100644 --- a/src/user/dyed_obcs_initialization.F90 +++ b/src/user/dyed_obcs_initialization.F90 @@ -64,8 +64,8 @@ subroutine dyed_obcs_set_OBC_data(OBC, G, GV, param_file, tr_Reg) ! ! Set the inflow values of the dyes, one per segment. ! ! We know the order: north, south, east, west do m=1,ntr - write(name,'("dye_",I1.1)') m - write(longname,'("Concentration of dyed_obc Tracer ",I1.1, " on segment ",I1.1)') m, m + write(name,'("dye_",I2.2)') m + write(longname,'("Concentration of dyed_obc Tracer ",I2.2, " on segment ",I2.2)') m, m tr_desc(m) = var_desc(name, units="kg kg-1", longname=longname, caller=mdl) do n=1,OBC%number_of_segments diff --git a/src/user/shelfwave_initialization.F90 b/src/user/shelfwave_initialization.F90 index 5e1aaaa576..a0d1850ecb 100644 --- a/src/user/shelfwave_initialization.F90 +++ b/src/user/shelfwave_initialization.F90 @@ -132,7 +132,7 @@ subroutine shelfwave_set_OBC_data(OBC, CS, G, h, Time) real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< layer thickness. type(time_type), intent(in) :: Time !< model time. - ! The following variables are used to set up the transport in the tidal_bay example. + ! The following variables are used to set up the transport in the shelfwave example. real :: my_amp, time_sec real :: cos_wt, cos_ky, sin_wt, sin_ky, omega, alpha real :: x, y, jj, kk, ll From 8d82440b02ed37b41625f9e652007ee3a1179382 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Mon, 4 Dec 2017 12:00:20 -0900 Subject: [PATCH 03/20] Comment out unneeded exchange in OBC. - Exchange is not needed because we set OBC values in halos. - Also added check for nz==1 in vertical diffusion. --- src/core/MOM_dynamics_split_RK2.F90 | 7 ++++--- src/tracer/MOM_tracer_diabatic.F90 | 8 +++++++- 2 files changed, 11 insertions(+), 4 deletions(-) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 1ef72e238c..72f4b7c178 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -569,10 +569,9 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & call cpu_clock_end(id_clock_continuity) if (showCallTree) call callTree_wayPoint("done with continuity (step_MOM_dyn_split_RK2)") + call do_group_pass(CS%pass_hp_uv, G%Domain, clock=id_clock_pass) if (associated(CS%OBC)) then - ! These should be done with a pass that excludes uh & vh. - call do_group_pass(CS%pass_hp_uv, G%Domain, clock=id_clock_pass) if (CS%debug) & call uvchksum("Pre OBC avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym) @@ -581,9 +580,11 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & if (CS%debug) & call uvchksum("Post OBC avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym) + + ! These should be done with a pass that excludes uh & vh. +! call do_group_pass(CS%pass_hp_uv, G%Domain, clock=id_clock_pass) endif - call do_group_pass(CS%pass_hp_uv, G%Domain, clock=id_clock_pass) if (G%nonblocking_updates) then call start_group_pass(CS%pass_av_uvh, G%Domain, clock=id_clock_pass) endif diff --git a/src/tracer/MOM_tracer_diabatic.F90 b/src/tracer/MOM_tracer_diabatic.F90 index 4a88d7f2e3..02f44e44dd 100644 --- a/src/tracer/MOM_tracer_diabatic.F90 +++ b/src/tracer/MOM_tracer_diabatic.F90 @@ -65,6 +65,12 @@ subroutine tracer_vertdiff(h_old, ea, eb, dt, tr, G, GV, & integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + if (nz == 1) then + call MOM_error(WARNING, "MOM_tracer_diabatic.F90, tracer_vertdiff called "//& + "with only one vertical level") + return + endif + if (present(convert_flux_in)) convert_flux = convert_flux_in h_neglect = GV%H_subroundoff sink_dist = 0.0 @@ -413,7 +419,7 @@ subroutine applyTracerBoundaryFluxesInOut(G, GV, Tr, dt, fluxes, h, evap_CFL_lim do i = 1, min(numberOfGroundings, maxGroundings) write(mesg(1:45),'(3es15.3)') G%geoLonT( iGround(i), jGround(i) ), & G%geoLatT( iGround(i), jGround(i)) , hGrounding(i) - call MOM_error(WARNING, "MOM_tracer_vertical.F90, applyTracerBoundaryFluxesInOut(): "//& + call MOM_error(WARNING, "MOM_tracer_diabatic.F90, applyTracerBoundaryFluxesInOut(): "//& "Tracer created. x,y,dh= "//trim(mesg), all_print=.true.) enddo From badf2483b1e6b56070e49da8ae8afa28d6ac8a34 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Tue, 12 Dec 2017 11:36:46 -0900 Subject: [PATCH 04/20] Added option for mean + oscillating flow to dyed channel. --- src/user/dyed_channel_initialization.F90 | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/src/user/dyed_channel_initialization.F90 b/src/user/dyed_channel_initialization.F90 index 0974d15671..f6b3e0f9a8 100644 --- a/src/user/dyed_channel_initialization.F90 +++ b/src/user/dyed_channel_initialization.F90 @@ -25,8 +25,9 @@ module dyed_channel_initialization !> Control structure for tidal bay open boundaries. type, public :: dyed_channel_OBC_CS ; private - real :: zonal_flow = 8.57 !< Maximum inflow - real :: frequency = 0.0 !< Inflow frequency + real :: zonal_flow = 8.57 !< Mean inflow + real :: tidal_amp = 0.0 !< Sloshing amplitude + real :: frequency = 0.0 !< Sloshing frequency end type dyed_channel_OBC_CS integer :: ntr = 0 @@ -49,9 +50,12 @@ function register_dyed_channel_OBC(param_file, CS, OBC_Reg) endif allocate(CS) - call get_param(param_file, mdl, "SUPERCRITICAL_ZONAL_FLOW", CS%zonal_flow, & - "Constant zonal flow imposed at upstream open boundary.", & + call get_param(param_file, mdl, "CHANNEL_MEAN_FLOW", CS%zonal_flow, & + "Mean zonal flow imposed at upstream open boundary.", & units="m/s", default=8.57) + call get_param(param_file, mdl, "CHANNEL_TIDAL_AMP", CS%tidal_amp, & + "Sloshing amplitude imposed at upstream open boundary.", & + units="m/s", default=0.0) call get_param(param_file, mdl, "CHANNEL_FLOW_FREQUENCY", CS%frequency, & "Frequency of oscillating zonal flow.", & units="s-1", default=0.0) @@ -161,7 +165,7 @@ subroutine dyed_channel_update_flow(OBC, CS, G, Time) if (CS%frequency == 0.0) then flow = CS%zonal_flow else - flow = CS%zonal_flow * cos(2 * PI * CS%frequency * time_sec) + flow = CS%zonal_flow + CS%tidal_amp * cos(2 * PI * CS%frequency * time_sec) endif do k=1,G%ke do j=jsd,jed ; do I=IsdB,IedB From 2d0cce2bc67aa2d760c4e9b4684c120a67012b5d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 14 Dec 2017 16:23:56 -0500 Subject: [PATCH 05/20] +(*)Only call diag_update_remap_grids if needed Added a new function, transport_remap_grid_needed, that indicates whether it is necessary to calculate the diagnostic grids for transports, and then only call diag_update_remap_grids if it is necessary. Without this change, the model will fail to run if no transports are being remapped but any other diagnostic fields are being remapped. If the model does run, all answers are bitwise identical. --- src/core/MOM.F90 | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index c618a2c353..a16f51c139 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -766,7 +766,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS) endif ! Store pre-dynamics state for proper diagnostic remapping if mass transports requested - if (CS%id_uhtr > 0 .or. CS%id_vhtr > 0 .or. CS%id_umo > 0 .or. CS%id_vmo > 0) then + if (transport_remap_grid_needed(CS)) then do k=1,nz ; do j=jsd,jed ; do i=isd,ied h_pre_dyn(i,j,k) = h(i,j,k) if (associated(CS%tv%T)) T_pre_dyn(i,j,k) = CS%tv%T(i,j,k) @@ -2746,7 +2746,8 @@ subroutine post_transport_diagnostics(G, GV, CS, diag, dt_trans, h, h_pre_dyn, T ! Post mass transports, including SGS ! Build the remap grids using the layer thicknesses from before the dynamics - call diag_update_remap_grids(diag, alt_h = h_pre_dyn, alt_T = T_pre_dyn, alt_S = S_pre_dyn) + if (transport_remap_grid_needed(CS)) & + call diag_update_remap_grids(diag, alt_h = h_pre_dyn, alt_T = T_pre_dyn, alt_S = S_pre_dyn) H_to_kg_m2_dt = GV%H_to_kg_m2 / dt_trans if (CS%id_umo_2d > 0) then @@ -2783,6 +2784,17 @@ subroutine post_transport_diagnostics(G, GV, CS, diag, dt_trans, h, h_pre_dyn, T end subroutine post_transport_diagnostics +!> Indicate whether it is necessary to save and recalculate the grid for finding +!! remapped transports. +function transport_remap_grid_needed(CS) result(needed) + type(MOM_control_struct), intent(in) :: CS !< control structure + logical :: needed + + needed = .false. + needed = needed .or. (CS%id_uhtr > 0) .or. (CS%id_vhtr > 0) + needed = needed .or. (CS%id_umo > 0) .or. (CS%id_vmo > 0) +end function transport_remap_grid_needed + !> Post diagnostics of temperatures and salinities, their fluxes, and tendencies. subroutine post_TS_diagnostics(CS, G, GV, tv, diag, dt) type(MOM_control_struct), intent(inout) :: CS !< control structure From 9eb14534b31ec2547fb75b4db49373c71f6583db Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 14 Dec 2017 16:24:42 -0500 Subject: [PATCH 06/20] Rescale thickness weighting in global means Rescaled thickness weighting in global_layer_mean and global_volume_mean to avoid overflow or underflow for extreme values of H_to_m. This does not change answers, but makes the code more robust. All answers are bitwise identical. --- src/framework/MOM_spatial_means.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/framework/MOM_spatial_means.F90 b/src/framework/MOM_spatial_means.F90 index 3d8120660d..15643292d1 100644 --- a/src/framework/MOM_spatial_means.F90 +++ b/src/framework/MOM_spatial_means.F90 @@ -73,7 +73,7 @@ function global_layer_mean(var, h, G, GV) tmpForSumming(:,:,:) = 0. ; weight(:,:,:) = 0. do k=1,nz ; do j=js,je ; do i=is,ie - weight(i,j,k) = h(i,j,k) * (G%areaT(i,j) * G%mask2dT(i,j)) + weight(i,j,k) = (GV%H_to_m * h(i,j,k)) * (G%areaT(i,j) * G%mask2dT(i,j)) tmpForSumming(i,j,k) = var(i,j,k) * weight(i,j,k) enddo ; enddo ; enddo @@ -101,7 +101,7 @@ function global_volume_mean(var, h, G, GV) tmpForSumming(:,:) = 0. ; sum_weight(:,:) = 0. do k=1,nz ; do j=js,je ; do i=is,ie - weight_here = h(i,j,k) * (G%areaT(i,j) * G%mask2dT(i,j)) + weight_here = (GV%H_to_m * h(i,j,k)) * (G%areaT(i,j) * G%mask2dT(i,j)) tmpForSumming(i,j) = tmpForSumming(i,j) + var(i,j,k) * weight_here sum_weight(i,j) = sum_weight(i,j) + weight_here enddo ; enddo ; enddo From af794e66858450daff1fdc279d42824a8b9030dc Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 14 Dec 2017 16:25:44 -0500 Subject: [PATCH 07/20] Changed argument name in int_density_dz_generic_plm Corrected a required argument name and comment in int_density_dz_generic_plm from H_subroundoff to dz_subroundoff to reflect the fact that the argument dz_neglect is a geometric height difference, not a thickness (in m or kg m-2 or whatever) difference. Also added a fatal argument if anyone very tries to use int_density_dz_generic_plm_analytic, which from inspection simply can not be right, but thankfully appears not to be used ever. All answers are bitwise identical. --- src/equation_of_state/MOM_EOS.F90 | 36 ++++++++++++++++++++++--------- 1 file changed, 26 insertions(+), 10 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index d4604b42e3..65d80d0009 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -1065,18 +1065,27 @@ end subroutine int_density_dz_generic_cell ! ========================================================================== -! Compute pressure gradient force integrals for the case where T and S -! are linear profiles. +!> 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, H_subroundoff, bathyT, HII, HIO, EOS, dpa, & + rho_0, G_e, dz_subroundoff, bathyT, HII, HIO, EOS, dpa, & intz_dpa, intx_dpa, inty_dpa, & useMassWghtInterp) type(hor_index_type), intent(in) :: HII, HIO real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: T_t, T_b, S_t, S_b, z_t, z_b - real, intent(in) :: rho_ref, rho_0, G_e, H_subroundoff - real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), intent(in) :: bathyT + intent(in) :: T_t, T_b, S_t, S_b + real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + intent(in) :: z_t !< The geometric height at the top + !! of the layer, usually in m + real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + intent(in) :: z_b !< The geometric height at the bpttom + !! of the layer, usually in m + real, intent(in) :: rho_ref, rho_0, G_e + real, intent(in) :: dz_subroundoff !< A miniscule thickness + !! change in the same units as z_t + real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + intent(in) :: bathyT !< The depth of the bathymetry in m type(EOS_type), pointer :: EOS !< Equation of state structure real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & intent(out) :: dpa @@ -1214,8 +1223,8 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & hWght = massWeightingToggle * & max(0., -bathyT(iin,jin)-z_t(iin+1,jin), -bathyT(iin+1,jin)-z_t(iin,jin)) if (hWght > 0.) then - hL = (z_t(iin,jin) - z_b(iin,jin)) + H_subroundoff - hR = (z_t(iin+1,jin) - z_b(iin+1,jin)) + H_subroundoff + hL = (z_t(iin,jin) - z_b(iin,jin)) + dz_subroundoff + hR = (z_t(iin+1,jin) - z_b(iin+1,jin)) + dz_subroundoff hWght = hWght * ( (hL-hR)/(hL+hR) )**2 iDenom = 1./( hWght*(hR + hL) + hL*hR ) Ttl = ( (hWght*hR)*T_t(iin+1,jin) + (hWght*hL + hR*hL)*T_t(iin,jin) ) * iDenom @@ -1295,8 +1304,8 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & hWght = massWeightingToggle * & max(0., -bathyT(i,j)-z_t(iin,jin+1), -bathyT(i,j+1)-z_t(iin,jin)) if (hWght > 0.) then - hL = (z_t(iin,jin) - z_b(iin,jin)) + H_subroundoff - hR = (z_t(iin,jin+1) - z_b(iin,jin+1)) + H_subroundoff + hL = (z_t(iin,jin) - z_b(iin,jin)) + dz_subroundoff + hR = (z_t(iin,jin+1) - z_b(iin,jin+1)) + dz_subroundoff hWght = hWght * ( (hL-hR)/(hL+hR) )**2 iDenom = 1./( hWght*(hR + hL) + hL*hR ) Ttl = ( (hWght*hR)*T_t(iin,jin+1) + (hWght*hL + hR*hL)*T_t(iin,jin) ) * iDenom @@ -1791,6 +1800,9 @@ subroutine int_density_dz_generic_plm_analytic (T_t, T_b, S_t, S_b, z_t, & Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB + call MOM_error(FATAL, "I believe that int_density_dz_generic_plm_analytic "//& + "has serious bugs and should not be used in its current form. - R. Hallberg") + GxRho = G_e * rho_0 I_Rho = 1.0 / rho_0 @@ -1828,6 +1840,10 @@ subroutine int_density_dz_generic_plm_analytic (T_t, T_b, S_t, S_b, z_t, & 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))) ) + + !### The fact that this this expression does not use T and that + !### an optional variable is assigned, even if it is not present + !### strongly suggests that this code is wrong. intz_dpa(i,j) = ( 0.5 * (S_b(i,j)+1000.0-rho_ref) + & (1.0/3.0) * dS ) * G_e * dz**2 From 0ef9f6a54672f3c6b63af7e115e8c62fe68fc077 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 14 Dec 2017 16:28:17 -0500 Subject: [PATCH 08/20] (*)Eliminated LARGE_VAL from MOM_entrain_diffusive Replaced the hard-coded parameter LARGE_VAL inside of MOM_entrain_diffusive with an equivalent parameter that is rescaled appropriately when H_TO_M is changed. All answers are bitwise identical when H_TO_M=1, but answers can change slightly for very small values of H_TO_M. All existing test cases are bitwise identical. --- src/parameterizations/vertical/MOM_entrain_diffusive.F90 | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 index b931366668..3da47e51e6 100644 --- a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 +++ b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 @@ -1740,7 +1740,7 @@ subroutine determine_Ea_kb(h_bl, dtKd_kb, Sref, I_dSkbp1, Ent_bl, ea_kbp1, & ! method might be used for the next iteration. logical, dimension(SZI_(G)) :: redo_i ! If true, more work is needed on this column. logical :: do_any - real, parameter :: LARGE_VAL = 1.0e30 + real :: large_err ! A large error measure, in H2. integer :: i, it integer, parameter :: MAXIT = 30 @@ -1749,6 +1749,7 @@ subroutine determine_Ea_kb(h_bl, dtKd_kb, Sref, I_dSkbp1, Ent_bl, ea_kbp1, & "unless BULKMIXEDLAYER is defined.") endif tolerance = GV%m_to_H * CS%Tolerance_Ent + large_err = GV%m_to_H**2 * 1.0e30 do i=is,ie ; redo_i(i) = do_i(i) ; enddo @@ -1758,7 +1759,7 @@ subroutine determine_Ea_kb(h_bl, dtKd_kb, Sref, I_dSkbp1, Ent_bl, ea_kbp1, & ! These were previously calculated and provide good limits and estimates ! of the errors there. By construction the errors increase with R*ea_kbp1. E_min(i) = min_eakb(i) ; E_max(i) = max_eakb(i) - error_minE(i) = -LARGE_VAL ; error_maxE(i) = LARGE_VAL + error_minE(i) = -large_err ; error_maxE(i) = large_err false_position(i) = .true. ! Used to alternate between false_position and ! bisection when Newton's method isn't working. if (present(err_min_eakb0)) error_minE(i) = err_min_eakb0(i) - E_min(i) * ea_kbp1(i) @@ -1823,7 +1824,7 @@ subroutine determine_Ea_kb(h_bl, dtKd_kb, Sref, I_dSkbp1, Ent_bl, ea_kbp1, & ! remain bracketed between Rmin and Rmax. Ent(i) = Ent(i) - err(i) / derror_dE(i) elseif (false_position(i) .and. & - (error_maxE(i) - error_minE(i) < 0.9*LARGE_VAL)) then + (error_maxE(i) - error_minE(i) < 0.9*large_err)) then ! Use the false postion method if there are decent error estimates. Ent(i) = E_min(i) + (E_max(i)-E_min(i)) * & (-error_minE(i)/(error_maxE(i) - error_minE(i))) From fc79daab87c6c467cde41b145a238d0505c7c41b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 14 Dec 2017 16:36:02 -0500 Subject: [PATCH 09/20] (*)Corrected the calculation of MEKE%GM_src Corrected the accumulation of one of the work terms contributing to GMwork and MEKE%GM_src so that it now gives answers that are robust to changes in H_TO_M. Also corrected the units written out with 6 diagnostic diffusivities, so available_diags files will change. Answers remain unchanged if H_TO_M=1, and no test case solutions change. --- .../lateral/MOM_thickness_diffuse.F90 | 27 ++++++++++--------- 1 file changed, 14 insertions(+), 13 deletions(-) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index b3bdf4715a..7cb8f0abcb 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -1076,9 +1076,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV do j=js,je ; do I=is-1,ie ; uhD(I,j,1) = -uhtot(I,j) ; enddo ; enddo do J=js-1,je ; do i=is,ie ; vhD(i,J,1) = -vhtot(i,J) ; enddo ; enddo else -!$OMP parallel do default(none) shared(is,ie,js,je,pres,T,S,IsdB,tv,uhD,uhtot, & -!$OMP Work_u,G_scale,use_EOS,e) & -!$OMP private(pres_u,T_u,S_u,drho_dT_u,drho_dS_u,drdiB) + !$OMP parallel do default(shared) private(pres_u,T_u,S_u,drho_dT_u,drho_dS_u,drdiB) do j=js,je if (use_EOS) then do I=is-1,ie @@ -1096,12 +1094,14 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV drdiB = drho_dT_u(I) * (T(i+1,j,1)-T(i,j,1)) + & drho_dS_u(I) * (S(i+1,j,1)-S(i,j,1)) endif - Work_u(I,j) = Work_u(I,j) + G_scale * ( (uhD(I,j,1) * drdiB) * 0.25 * & - ((e(i,j,1) + e(i,j,2)) + (e(i+1,j,1) + e(i+1,j,2))) ) + Work_u(I,j) = Work_u(I,j) + ( G_scale * H_to_m ) * & + ( (uhD(I,j,1) * drdiB) * 0.25 * & + ((e(i,j,1) + e(i,j,2)) + (e(i+1,j,1) + e(i+1,j,2))) ) enddo enddo + !$OMP parallel do default(shared) private(pres_v,T_v,S_v,drho_dT_v,drho_dS_v,drdjB) do J=js-1,je if (use_EOS) then do i=is,ie @@ -1119,8 +1119,9 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV drdjB = drho_dT_v(i) * (T(i,j+1,1)-T(i,j,1)) + & drho_dS_v(i) * (S(i,j+1,1)-S(i,j,1)) endif - Work_v(i,J) = Work_v(i,J) - G_scale * ( (vhD(i,J,1) * drdjB) * 0.25 * & - ((e(i,j,1) + e(i,j,2)) + (e(i,j+1,1) + e(i,j+1,2))) ) + Work_v(i,J) = Work_v(i,J) - ( G_scale * H_to_m ) * & + ( (vhD(i,J,1) * drdjB) * 0.25 * & + ((e(i,j,1) + e(i,j,2)) + (e(i,j+1,1) + e(i,j+1,2))) ) enddo enddo endif @@ -1781,22 +1782,22 @@ subroutine thickness_diffuse_init(Time, G, GV, param_file, diag, CDp, CS) if (CS%id_GMwork > 0) call safe_alloc_ptr(CS%GMwork,G%isd,G%ied,G%jsd,G%jed) CS%id_KH_u = register_diag_field('ocean_model', 'KHTH_u', diag%axesCui, Time, & - 'Parameterized mesoscale eddy advection diffusivity at U-point', 'm s-2') + 'Parameterized mesoscale eddy advection diffusivity at U-point', 'm2 s-1') CS%id_KH_v = register_diag_field('ocean_model', 'KHTH_v', diag%axesCvi, Time, & - 'Parameterized mesoscale eddy advection diffusivity at V-point', 'm s-2') + 'Parameterized mesoscale eddy advection diffusivity at V-point', 'm2 s-1') CS%id_KH_t = register_diag_field('ocean_model', 'KHTH_t', diag%axesTL, Time, & - 'Ocean Tracer Diffusivity due to Parameterized Mesoscale Advection', 'm s-2',& + 'Ocean Tracer Diffusivity due to Parameterized Mesoscale Advection', 'm2 s-1',& cmor_field_name='diftrblo', & cmor_long_name='Ocean Tracer Diffusivity due to Parameterized Mesoscale Advection', & cmor_units='m2 s-1', & cmor_standard_name='ocean_tracer_diffusivity_due_to_parameterized_mesoscale_advection') CS%id_KH_u1 = register_diag_field('ocean_model', 'KHTH_u1', diag%axesCu1, Time, & - 'Parameterized mesoscale eddy advection diffusivity at U-points (2-D)', 'm s-2') + 'Parameterized mesoscale eddy advection diffusivity at U-points (2-D)', 'm2 s-1') CS%id_KH_v1 = register_diag_field('ocean_model', 'KHTH_v1', diag%axesCv1, Time, & - 'Parameterized mesoscale eddy advection diffusivity at V-points (2-D)', 'm s-2') + 'Parameterized mesoscale eddy advection diffusivity at V-points (2-D)', 'm2 s-1') CS%id_KH_t1 = register_diag_field('ocean_model', 'KHTH_t1', diag%axesT1, Time,& - 'Parameterized mesoscale eddy advection diffusivity at T-points (2-D)', 'm s-2') + 'Parameterized mesoscale eddy advection diffusivity at T-points (2-D)', 'm2 s-1') CS%id_slope_x = register_diag_field('ocean_model', 'neutral_slope_x', diag%axesCui, Time, & 'Zonal slope of neutral surface', 'nondim') From 2f8599ee4f90d70a8aa01374f841b0ca12749ec2 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 14 Dec 2017 16:37:22 -0500 Subject: [PATCH 10/20] (*)Corrected the calculation of SkinBuoyFlux Corrected the unit conversion from H to m inside of the calculation of SkinBuoyFlux, so it now works properly when H_to_m is not 1. Also cleaned up this calculation to avoid the use of array syntax in calculations. This will change answers in test cases that use some variants of ePBL with H_TO_M not equal to 1, but answers do not change in existing test cases. --- src/core/MOM_forcing_type.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 566efc2b9b..1b99905538 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -873,7 +873,7 @@ subroutine calculateBuoyancyFlux1d(G, GV, fluxes, optics, h, Temp, Salt, tv, j, dRhodT, dRhodS, start, npts, tv%eqn_of_state) ! Adjust netSalt to reflect dilution effect of FW flux - netSalt(G%isc:G%iec) = netSalt(G%isc:G%iec) - Salt(G%isc:G%iec,j,1) * netH(G%isc:G%iec) * GV%H_to_m ! ppt H/s + netSalt(G%isc:G%iec) = netSalt(G%isc:G%iec) - Salt(G%isc:G%iec,j,1) * netH(G%isc:G%iec) ! ppt H/s ! Add in the SW heating for purposes of calculating the net ! surface buoyancy flux affecting the top layer. From cacbdf40b19ad8d28db936eb7f6d557f88c51161 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 14 Dec 2017 16:39:40 -0500 Subject: [PATCH 11/20] (*)Corrected the modal structure calculation Corrected the calculation of the modal structure when H_to_m is not 1. This particular code failed because remapping_core_h requires that the input and output grids use the same units. This can change answers, but does not change any of the existing test cases. --- src/diagnostics/MOM_wave_speed.F90 | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index 1770ebb4f1..fbd0ce2daa 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -34,7 +34,7 @@ module MOM_wave_speed !! can be overridden by optional arguments. type(remapping_CS) :: remapping_CS !< Used for vertical remapping when calculating equivalent barotropic !! mode structure. - type(diag_ctrl), pointer :: diag !< Diagnostics control structure + type(diag_ctrl), pointer :: diag !< Diagnostics control structure end type wave_speed_CS contains @@ -42,9 +42,9 @@ module MOM_wave_speed !> Calculates the wave speed of the first baroclinic mode. subroutine wave_speed(h, tv, G, GV, cg1, CS, full_halos, use_ebt_mode, & mono_N2_column_fraction, mono_N2_depth, modal_structure) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness (m or kg/m2) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness in units of H (m or kg/m2) type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables real, dimension(SZI_(G),SZJ_(G)), intent(out) :: cg1 !< First mode internal wave speed (m/s) type(wave_speed_CS), pointer :: CS !< Control structure for MOM_wave_speed @@ -443,7 +443,10 @@ subroutine wave_speed(h, tv, G, GV, cg1, CS, full_halos, use_ebt_mode, & else mode_struct(1:kc)=0. endif - call remapping_core_h(CS%remapping_CS, kc, Hc, mode_struct, nz, h(i,j,:), modal_structure(i,j,:)) + ! Note that remapping_core_h requires that the same units be used + ! for both the source and target grid thicknesses. + call remapping_core_h(CS%remapping_CS, kc, Hc, mode_struct, & + nz, GV%H_to_m*h(i,j,:), modal_structure(i,j,:)) endif else cg1(i,j) = 0.0 From 2c5197e8496d49adeecc48d1bda70a4cfef5b8b0 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 14 Dec 2017 16:41:25 -0500 Subject: [PATCH 12/20] Corrected Coef_x chksum scaling Corrected the rescaling of Coef_x and Coef_y when doing checksums and only report these checksums if the arrays are in use. All answers are bitwise identical. --- src/tracer/MOM_tracer_hor_diff.F90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 321601b61f..a09efe2b69 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -472,8 +472,10 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, CS, Reg, tv, do_online_fla if (CS%debug) then call uvchksum("After tracer diffusion khdt_[xy]", khdt_x, khdt_y, & G%HI, haloshift=0, symmetric=.true.) - call uvchksum("After tracer diffusion Coef_[xy]", Coef_x, Coef_y, & - G%HI, haloshift=0, symmetric=.true., scale=GV%H_to_m) + if (CS%use_neutral_diffusion) then + call uvchksum("After tracer diffusion Coef_[xy]", Coef_x, Coef_y, & + G%HI, haloshift=0, symmetric=.true.) + endif endif if (CS%id_khdt_x > 0) call post_data(CS%id_khdt_x, khdt_x, CS%diag) From ecdfd9678cb6d2543f41130b768aee6bdbe9aee5 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 14 Dec 2017 16:44:41 -0500 Subject: [PATCH 13/20] (*)Corrected pressure gradient thickness rescaling Changed H_subroundoff to dz_neglect in a call to int_density_dz_generic_plm, reflecting the fact that this particular argument is for an actual vertical geopotential height difference, which will not scale the same way as the internal representation of thickness. This changes answers if H_TO_M is not 1, but answers are bitwise identical in all existing test cases. --- src/core/MOM_PressureForce_analytic_FV.F90 | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/core/MOM_PressureForce_analytic_FV.F90 b/src/core/MOM_PressureForce_analytic_FV.F90 index 9e5e675b95..52e0b6bb93 100644 --- a/src/core/MOM_PressureForce_analytic_FV.F90 +++ b/src/core/MOM_PressureForce_analytic_FV.F90 @@ -471,6 +471,7 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm, p real :: I_Rho0 ! 1/Rho0. real :: G_Rho0 ! G_Earth / Rho0 in m4 s-2 kg-1. real :: Rho_ref ! The reference density in kg m-3. + real :: dz_neglect ! A minimal thickness in m, like e. logical :: use_p_atm ! If true, use the atmospheric pressure. logical :: use_ALE ! If true, use an ALE pressure reconstruction. logical :: use_EOS ! If true, density is calculated from T & S using an @@ -500,6 +501,7 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm, p PRScheme = pressureReconstructionScheme(ALE_CSp) h_neglect = GV%H_subroundoff + dz_neglect = GV%H_subroundoff * GV%H_to_m I_Rho0 = 1.0/GV%Rho0 G_Rho0 = GV%g_Earth/GV%Rho0 rho_ref = CS%Rho0 @@ -617,9 +619,9 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm, p endif endif -!$OMP parallel do default(none) shared(use_p_atm,rho_ref,G,GV,e, & -!$OMP p_atm,nz,use_EOS,use_ALE,PRScheme,T_t,T_b,S_t, & -!$OMP S_b,CS,tv,tv_tmp,h,PFu,I_Rho0,h_neglect,PFv,dM)& +!$OMP parallel do default(none) shared(use_p_atm,rho_ref,G,GV,e,p_atm,nz,use_EOS,& +!$OMP use_ALE,PRScheme,T_t,T_b,S_t,S_b,CS,tv,tv_tmp, & +!$OMP h,PFu,I_Rho0,h_neglect,dz_neglect,PFv,dM)& !$OMP private(is_bk,ie_bk,js_bk,je_bk,Isq_bk,Ieq_bk,Jsq_bk, & !$OMP Jeq_bk,ioff_bk,joff_bk,pa_bk, & !$OMP intx_pa_bk,inty_pa_bk,dpa_bk,intz_dpa_bk, & @@ -668,7 +670,7 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm, p 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, & - GV%H_subroundoff, G%bathyT, G%HI, G%Block(n), & + dz_neglect, G%bathyT, G%HI, G%Block(n), & tv%eqn_of_state, dpa_bk, intz_dpa_bk, intx_dpa_bk, inty_dpa_bk, & useMassWghtInterp = CS%useMassWghtInterp) elseif ( PRScheme == PRESSURE_RECONSTRUCTION_PPM ) then From 2e5acb2b1c02b83fac41ad1043e187b7d7f26045 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 14 Dec 2017 16:59:02 -0500 Subject: [PATCH 14/20] (*)Fixed a thickness unit inconsistency in ePBL Corrected an expression that combined two variables with units of H and m in ePBL. This code is only exercised with certain options for the shape of the diffusivity, and all existing test cases are bitwise identical. --- .../vertical/MOM_energetic_PBL.F90 | 23 ++++++++++--------- 1 file changed, 12 insertions(+), 11 deletions(-) diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 91f4ce2714..6b1c14fdf7 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -638,9 +638,9 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & Kd(i,K) = 0.0 enddo ; enddo do i=is,ie - CS%ML_depth(i,j) = h(i,1)*GV%H_to_m - !CS%ML_depth2(i,j) = h(i,1)*GV%H_to_m - sfc_connected(i) = .true. + CS%ML_depth(i,j) = h(i,1)*GV%H_to_m + !CS%ML_depth2(i,j) = h(i,1)*GV%H_to_m + sfc_connected(i) = .true. enddo if (debug) then @@ -680,7 +680,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & iL_Ekman = absf(i)/U_star iL_Obukhov = buoy_flux(i,j)*vonkar/U_Star**3 - if (CS%Mstar_Mode.eq.CS%CONST_MSTAR) then + if (CS%Mstar_Mode == CS%CONST_MSTAR) then mech_TKE(i) = (dt*CS%mstar*GV%Rho0)*((U_Star**3)) conv_PErel(i) = 0.0 @@ -774,14 +774,14 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & if (CS%Mstar_Mode.gt.0) then ! Note the value of mech_TKE(i) now must be iterated over, so it is moved here ! First solve for the TKE to PE length scale - if (CS%MSTAR_MODE.eq.CS%MLD_o_OBUKHOV) then + if (CS%MSTAR_MODE == CS%MLD_o_OBUKHOV) then MLD_over_Stab = MLD_guess / Stab_Scale - CS%MSTAR_XINT - if ((MLD_over_Stab) .le. 0.0) then + if ((MLD_over_Stab) <= 0.0) then !Asymptote to 0 as MLD_over_Stab -> -infinity (always) MSTAR_mix = (CS%MSTAR_B*(MLD_over_Stab)+CS%MSTAR_A)**(CS%MSTAR_N) else if (CS%MSTAR_CAP>=0.) then - if (CS%MSTAR_FLATCAP .OR. (MLD_over_Stab .le.CS%MSTAR_XINT_UP)) then + if (CS%MSTAR_FLATCAP .OR. (MLD_over_Stab <= CS%MSTAR_XINT_UP)) then !If using flat cap (or if using asymptotic cap ! but within linear regime we can make use of same code) MSTAR_mix = min(CS%MSTAR_CAP, & @@ -797,10 +797,11 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & MSTAR_mix = CS%MSTAR_SLOPE*(MLD_over_Stab)+CS%MSTAR_AT_XINT endif endif - elseif (CS%MSTAR_MODE.eq.CS%EKMAN_o_OBUKHOV) then + elseif (CS%MSTAR_MODE == CS%EKMAN_o_OBUKHOV) then + !### Please refrain from using the construct A / B / C in place of A/(B*C). mstar_STAB = CS%MSTAR_COEF*sqrt(Bf_Stable/u_star**2/(absf(i)+1.e-10)) mstar_ROT = CS%C_EK*log(max(1.,u_star/(absf(i)+1.e-10)/mld_guess)) - if ( CS%MSTAR_CAP.le.0.0) then !No cap. + if ( CS%MSTAR_CAP <= 0.0) then !No cap. MSTAR_MIX = max(mstar_STAB,& ! 1st term if balance of rotation and stabilizing ! the balance is f(L_Ekman,L_Obukhov) min(& ! 2nd term for forced stratification limited @@ -907,7 +908,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & I_MLD = 1.0 / MLD_guess ; h_rsum = 0.0 MixLen_shape(1) = 1.0 do K=2,nz+1 - h_rsum = h_rsum + h(i,k-1) + h_rsum = h_rsum + h(i,k-1)*GV%H_to_m if (CS%MixLenExponent==2.0)then MixLen_shape(K) = CS%transLay_scale + (1.0 - CS%transLay_scale) * & (max(0.0, (MLD_guess - h_rsum)*I_MLD) )**2!CS%MixLenExponent @@ -1417,7 +1418,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & do k=2,nz if (FIRST_OBL) then !Breaks when OBL found if (Vstar_Used(k) > 1.e-10 .and. k < nz) then - MLD_FOUND = MLD_FOUND+h(i,k-1)*GV%H_to_m + MLD_FOUND = MLD_FOUND + h(i,k-1)*GV%H_to_m else FIRST_OBL = .false. if (MLD_FOUND-CS%MLD_tol > MLD_guess) then From 60d957e279cc5ac93cac19376319c39d02ca9dc8 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 14 Dec 2017 16:59:39 -0500 Subject: [PATCH 15/20] (*)Corrected the calculation of SkinBuoyFlux Corrected the unit conversion from H to m inside of the calculation of SkinBuoyFlux, so it now works properly when H_to_m is not 1. Also cleaned up this calculation to avoid the use of array syntax in calculations. This will change answers in test cases that use some variants of ePBL with H_TO_M not equal to 1, but answers do not change in existing test cases. --- .../vertical/MOM_diabatic_aux.F90 | 39 ++++++++++--------- 1 file changed, 20 insertions(+), 19 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index b7369d10b2..9588ac3a5c 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -1265,25 +1265,26 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, dt, fluxes, optics, h, tv, & ! 1) Answers will change due to round-off ! 2) Be sure to save their values BEFORE fluxes are used. if (Calculate_Buoyancy) then - drhodt(:) = 0.0 - drhods(:) = 0.0 - netPen(:,:) = 0.0 - ! Sum over bands and attenuate as a function of depth - ! netPen is the netSW as a function of depth - call sumSWoverBands(G, GV, h2d(:,:), optics%opacity_band(:,:,j,:), nsw, j, dt, & - H_limit_fluxes, .true., pen_SW_bnd_rate, netPen) - ! Density derivatives - call calculate_density_derivs(T2d(:,1), tv%S(:,j,1), SurfPressure, & - dRhodT, dRhodS, start, npts, tv%eqn_of_state) - ! 1. Adjust netSalt to reflect dilution effect of FW flux - ! 2. Add in the SW heating for purposes of calculating the net - ! surface buoyancy flux affecting the top layer. - ! 3. Convert to a buoyancy flux, excluding penetrating SW heating - ! BGR-Jul 5, 2017: The contribution of SW heating here needs investigated for ePBL. - SkinBuoyFlux(G%isc:G%iec,j) = - GoRho * ( dRhodS(G%isc:G%iec) * (netSalt_rate(G%isc:G%iec) & - - tv%S(G%isc:G%iec,j,1) * netMassInOut_rate(G%isc:G%iec)* GV%H_to_m )& - + dRhodT(G%isc:G%iec) * ( netHeat_rate(G%isc:G%iec) + & - netPen(G%isc:G%iec,1))) * GV%H_to_m ! m^2/s^3 + drhodt(:) = 0.0 + drhods(:) = 0.0 + netPen(:,:) = 0.0 + ! Sum over bands and attenuate as a function of depth + ! netPen is the netSW as a function of depth + call sumSWoverBands(G, GV, h2d(:,:), optics%opacity_band(:,:,j,:), nsw, j, dt, & + H_limit_fluxes, .true., pen_SW_bnd_rate, netPen) + ! Density derivatives + call calculate_density_derivs(T2d(:,1), tv%S(:,j,1), SurfPressure, & + dRhodT, dRhodS, start, npts, tv%eqn_of_state) + ! 1. Adjust netSalt to reflect dilution effect of FW flux + ! 2. Add in the SW heating for purposes of calculating the net + ! surface buoyancy flux affecting the top layer. + ! 3. Convert to a buoyancy flux, excluding penetrating SW heating + ! BGR-Jul 5, 2017: The contribution of SW heating here needs investigated for ePBL. + do i=is,ie + SkinBuoyFlux(i,j) = - GoRho * GV%H_to_m * ( & + dRhodS(i) * (netSalt_rate(i) - tv%S(i,j,1)*netMassInOut_rate(i)) + & + dRhodT(i) * ( netHeat_rate(i) + netPen(i,1)) ) ! m^2/s^3 + enddo endif enddo ! j-loop finish From 1dddb0e6c81226e8749226269362d711c8d7aeb8 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 14 Dec 2017 17:00:14 -0500 Subject: [PATCH 16/20] (*)Changed the value for miniscule TKE in bulk ML Changed the value for a tiny amount of TKE from 1e-300 to 1e-150 to avoid underflow when H_to_m is much less than 1 in one sensitivity calculation as a part of an iteration in the mechanical entrainment portion of the bulk mixed layer code. This does not change any answer in existing test cases. --- .../vertical/MOM_bulk_mixed_layer.F90 | 38 ++++++++----------- 1 file changed, 16 insertions(+), 22 deletions(-) diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index 29e65e9a32..7b2b39f242 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -76,7 +76,7 @@ module MOM_bulk_mixed_layer ! released mean kinetic energy becomes TKE, nondim. real :: Hmix_min ! The minimum mixed layer thickness in m. real :: H_limit_fluxes ! When the total ocean depth is less than this - ! value, in H, scale away all surface forcing to + ! value, in m, scale away all surface forcing to ! avoid boiling the ocean. real :: ustar_min ! A minimum value of ustar to avoid numerical ! problems, in m s-1. If the value is small enough, @@ -433,6 +433,8 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & integer :: i, j, k, is, ie, js, je, nz, nkmb, n integer :: nsw ! The number of bands of penetrating shortwave radiation. + real :: H_limit_fluxes ! CS%H_limit fluxes converted to units of H. + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (.not. associated(CS)) call MOM_error(FATAL, "MOM_mixed_layer: "//& @@ -451,13 +453,13 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & Irho0 = 1.0 / GV%Rho0 dt__diag = dt ; if (present(dt_diag)) dt__diag = dt_diag - Idt = 1.0/dt + Idt = 1.0 / dt Idt_diag = 1.0 / dt__diag write_diags = .true. ; if (present(last_call)) write_diags = last_call + H_limit_fluxes = CS%H_limit_fluxes * GV%m_to_H p_ref(:) = 0.0 ; p_ref_cv(:) = tv%P_Ref - nsw = CS%nsw if (CS%limit_det .or. (CS%id_Hsfc_min > 0)) then @@ -522,21 +524,14 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & endif max_BL_det(:) = -1 -!$OMP parallel default(none) shared(is,ie,js,je,nz,h_3d,u_3d,v_3d,nkmb,G,GV,nsw,optics, & -!$OMP CS,tv,fluxes,Irho0,dt,Idt_diag,Ih,write_diags, & -!$OMP hmbl_prev,h_sum,Hsfc_min,Hsfc_max,dt__diag, & -!$OMP Hsfc_used,Inkmlm1,Inkml,ea,eb,h_miss,Hml, & -!$OMP id_clock_EOS,id_clock_resort,id_clock_adjustment, & -!$OMP id_clock_conv,id_clock_mech,id_clock_detrain,aggregate_FW_forcing ) & -!$OMP firstprivate(dKE_CA,cTKE,h_CA,max_BL_det,p_ref,p_ref_cv) & -!$OMP private(h,h_orig,u,v,eps,T,S,opacity_band,d_ea,d_eb, & -!$OMP dR0_dT,dR0_dS,dRcv_dT,dRcv_dS,R0,Rcv,ksort, & -!$OMP RmixConst,TKE_river,netMassInOut, NetMassOut, & -!$OMP Net_heat, Net_salt, htot,TKE,Pen_SW_bnd,Ttot,Stot, uhtot,& -!$OMP vhtot, R0_tot, Rcv_tot,Conv_en,dKE_FC,Idecay_len_TKE, & -!$OMP cMKE,Hsfc,dHsfc,dHD,H_nbr,kU_Star,absf_x_H, & -!$OMP ebml,eaml) -!$OMP do + !$OMP parallel default(shared) firstprivate(dKE_CA,cTKE,h_CA,max_BL_det,p_ref,p_ref_cv) & + !$OMP private(h,u,v,h_orig,eps,T,S,opacity_band,d_ea,d_eb,R0,Rcv,ksort, & + !$OMP dR0_dT,dR0_dS,dRcv_dT,dRcv_dS,htot,Ttot,Stot,TKE,Conv_en, & + !$OMP RmixConst,TKE_river,Pen_SW_bnd,netMassInOut,NetMassOut, & + !$OMP Net_heat,Net_salt,uhtot,vhtot,R0_tot,Rcv_tot,dKE_FC, & + !$OMP Idecay_len_TKE,cMKE,Hsfc,dHsfc,dHD,H_nbr,kU_Star, & + !$OMP absf_x_H,ebml,eaml) + !$OMP do do j=js,je ! Copy the thicknesses and other fields to 2-d arrays. do k=1,nz ; do i=is,ie @@ -626,7 +621,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & ! net_salt = salt ( g(salt)/m2 for non-Bouss and ppt*m/s for Bouss ) via surface fluxes ! Pen_SW_bnd = components to penetrative shortwave radiation call extractFluxes1d(G, GV, fluxes, optics, nsw, j, dt, & - CS%H_limit_fluxes, CS%use_river_heat_content, CS%use_calving_heat_content, & + H_limit_fluxes, CS%use_river_heat_content, CS%use_calving_heat_content, & h(:,1:), T(:,1:), netMassInOut, netMassOut, Net_heat, Net_salt, Pen_SW_bnd,& tv, aggregate_FW_forcing) @@ -660,7 +655,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & cMKE, Idt_diag, nsw, Pen_SW_bnd, opacity_band, TKE, & Idecay_len_TKE, j, ksort, G, GV, CS) - call absorbRemainingSW(G, GV, h(:,1:), opacity_band, nsw, j, dt, CS%H_limit_fluxes, & + call absorbRemainingSW(G, GV, h(:,1:), opacity_band, nsw, j, dt, H_limit_fluxes, & CS%correct_absorption, CS%absorb_all_SW, & T(:,1:), Pen_SW_bnd, eps, ksort, htot, Ttot) @@ -1824,7 +1819,7 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & endif TKE(i) = TKE_full_ent - if (TKE(i) <= 0.0) TKE(i) = 1e-300 + if (TKE(i) <= 0.0) TKE(i) = 1.0e-150 else ! The layer is only partially entrained. The amount that will be ! entrained is determined iteratively. No further layers will be @@ -3736,7 +3731,6 @@ subroutine bulkmixedlayer_init(Time, G, GV, param_file, diag, CS) "The surface fluxes are scaled away when the total ocean \n"//& "depth is less than DEPTH_LIMIT_FLUXES.", & units="m", default=0.1*CS%Hmix_min) - CS%H_limit_fluxes = CS%H_limit_fluxes * GV%m_to_H call get_param(param_file, mdl, "OMEGA",CS%omega, & "The rotation rate of the earth.", units="s-1", & default=7.2921e-5) From 918ae3f5849cc991f8a8c6e05d057d4eece4c7ae Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 14 Dec 2017 20:29:54 -0500 Subject: [PATCH 17/20] +Added optional h_neglect arguments to remapping code Added new optional arguments for the thicknesses to neglect to all of the remapping code where a neglected thickness is used. The subroutines that were changed include: remapping_core_h, remapping_core_w, build_reconstructions_1d, {PCM, PLM,PPM,PQM}_reconstruction, {PLM,PPM}_boundary_extrapolation, edge_values_..., edge_slopes_..., build_and_interpolate_grid, remapByProjection, remapByDeltaZ, integrateReconOnInterval, build_{rho,hycom1,SLight}_column, and build_rho_column_iteratively. The internal work routines P3M_interpolation and {PPM,P3M}_limiter have new required arguments. Also, to accomodate the new optional h_neglect arguments, internally h_neglect was renamed hNeglect in many places. This change will enable this code to reproduce across changes in the internal representation of thickness, once the optional arguments are used. All answers are bitwise identical. --- src/ALE/MOM_remapping.F90 | 314 +++++++++++++++++++++------------ src/ALE/P1M_functions.F90 | 19 +- src/ALE/P3M_functions.F90 | 107 ++++++----- src/ALE/PLM_functions.F90 | 36 ++-- src/ALE/PPM_functions.F90 | 51 +++--- src/ALE/PQM_functions.F90 | 138 ++++++++------- src/ALE/coord_hycom.F90 | 20 ++- src/ALE/coord_rho.F90 | 47 +++-- src/ALE/coord_slight.F90 | 24 ++- src/ALE/regrid_edge_slopes.F90 | 109 +++++++----- src/ALE/regrid_edge_values.F90 | 134 ++++++++------ src/ALE/regrid_interp.F90 | 206 +++++++++++---------- 12 files changed, 737 insertions(+), 468 deletions(-) diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index 6e404ff2dd..a7879ae063 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -71,7 +71,7 @@ module MOM_remapping ! outside of the range 0 to 1. #define __USE_ROUNDOFF_SAFE_ADJUSTMENTS__ -real, parameter :: h_neglect = 1.E-30 !< A dimensional (H units) number that can be +real, parameter :: hNeglect_dflt = 1.E-30 !< A dimensional (H units) number that can be !! added to thicknesses in a denominator without !! changing the numerical result, except where !! a division by zero would otherwise occur. @@ -179,7 +179,7 @@ end function isPosSumErrSignificant !> Remaps column of values u0 on grid h0 to grid h1 !! assuming the top edge is aligned. -subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1) +subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, h_neglect, h_neglect_edge) type(remapping_CS), intent(in) :: CS !< Remapping control structure integer, intent(in) :: n0 !< Number of cells on source grid real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid @@ -187,6 +187,12 @@ subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1) integer, intent(in) :: n1 !< Number of cells on target grid real, dimension(n1), intent(in) :: h1 !< Cell widths on target grid real, dimension(n1), intent(out) :: u1 !< Cell averages on target grid + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions + !! in the same units as h0. + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width + !! for the purpose of edge value + !! calculations in the same units as h0. ! Local variables integer :: iMethod real, dimension(n0,2) :: ppoly_r_E !Edge value of polynomial @@ -194,8 +200,13 @@ subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1) real, dimension(n0,CS%degree+1) :: ppoly_r_coefficients !Coefficients of polynomial integer :: k real :: eps, h0tot, h0err, h1tot, h1err, u0tot, u0err, u0min, u0max, u1tot, u1err, u1min, u1max, uh_err + real :: hNeglect, hNeglect_edge - call build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefficients, ppoly_r_E, ppoly_r_S, iMethod ) + hNeglect = 1.0e-30 ; if (present(h_neglect)) hNeglect = h_neglect + hNeglect_edge = 1.0e-10 ; if (present(h_neglect_edge)) hNeglect_edge = h_neglect_edge + + call build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefficients, ppoly_r_E, ppoly_r_S, iMethod, & + hNeglect, hNeglect_edge ) if (CS%check_reconstruction) call check_reconstructions_1d(n0, h0, u0, CS%degree, & CS%boundary_extrapolation, ppoly_r_coefficients, ppoly_r_E, ppoly_r_S) @@ -244,14 +255,20 @@ end subroutine remapping_core_h !> Remaps column of values u0 on grid h0 to implied grid h1 !! where the interfaces of h1 differ from those of h0 by dx. -subroutine remapping_core_w( CS, n0, h0, u0, n1, dx, u1 ) +subroutine remapping_core_w( CS, n0, h0, u0, n1, dx, u1, h_neglect, h_neglect_edge ) type(remapping_CS), intent(in) :: CS !< Remapping control structure integer, intent(in) :: n0 !< Number of cells on source grid real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid integer, intent(in) :: n1 !< Number of cells on target grid - real, dimension(n1+1), intent(in) :: dx !< Cell widths on target grid + real, dimension(n1+1), intent(in) :: dx !< Cell widths on target grid real, dimension(n1), intent(out) :: u1 !< Cell averages on target grid + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions + !! in the same units as h0. + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width + !! for the purpose of edge value + !! calculations in the same units as h0. ! Local variables integer :: iMethod real, dimension(n0,2) :: ppoly_r_E !Edge value of polynomial @@ -261,8 +278,13 @@ subroutine remapping_core_w( CS, n0, h0, u0, n1, dx, u1 ) real :: eps, h0tot, h0err, h1tot, h1err real :: u0tot, u0err, u0min, u0max, u1tot, u1err, u1min, u1max, uh_err real, dimension(n1) :: h1 !< Cell widths on target grid + real :: hNeglect, hNeglect_edge + + hNeglect = 1.0e-30 ; if (present(h_neglect)) hNeglect = h_neglect + hNeglect_edge = 1.0e-10 ; if (present(h_neglect_edge)) hNeglect_edge = h_neglect_edge - call build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefficients, ppoly_r_E, ppoly_r_S, iMethod ) + call build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefficients, ppoly_r_E, ppoly_r_S, iMethod,& + hNeglect, hNeglect_edge ) if (CS%check_reconstruction) call check_reconstructions_1d(n0, h0, u0, CS%degree, & CS%boundary_extrapolation, ppoly_r_coefficients, ppoly_r_E, ppoly_r_S) @@ -277,8 +299,8 @@ subroutine remapping_core_w( CS, n0, h0, u0, n1, dx, u1 ) enddo call remap_via_sub_cells( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients, n1, h1, iMethod, & CS%force_bounds_in_subcell,u1, uh_err ) -! call remapByDeltaZ( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients, n1, dx, iMethod, u1 ) -! call remapByProjection( n0, h0, u0, CS%ppoly_r, n1, h1, iMethod, u1 ) +! call remapByDeltaZ( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients, n1, dx, iMethod, u1, hNeglect ) +! call remapByProjection( n0, h0, u0, CS%ppoly_r, n1, h1, iMethod, u1, hNeglect ) if (CS%check_remapping) then ! Check errors and bounds @@ -319,15 +341,24 @@ subroutine remapping_core_w( CS, n0, h0, u0, n1, dx, u1 ) end subroutine remapping_core_w !> Creates polynomial reconstructions of u0 on the source grid h0. -subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefficients, ppoly_r_E, ppoly_r_S, iMethod ) - type(remapping_CS), intent(in) :: CS - integer, intent(in) :: n0 !< Number of cells on source grid - real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid - real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid - real, dimension(n0,CS%degree+1), intent(out) :: ppoly_r_coefficients !< Coefficients of polynomial - real, dimension(n0,2), intent(out) :: ppoly_r_E !< Edge value of polynomial - real, dimension(n0,2), intent(out) :: ppoly_r_S !< Edge slope of polynomial - integer, intent(out) :: iMethod !< Integration method +subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefficients, & + ppoly_r_E, ppoly_r_S, iMethod, h_neglect, & + h_neglect_edge ) + type(remapping_CS), intent(in) :: CS + integer, intent(in) :: n0 !< Number of cells on source grid + real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid + real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid + real, dimension(n0,CS%degree+1), & + intent(out) :: ppoly_r_coefficients !< Coefficients of polynomial + real, dimension(n0,2), intent(out) :: ppoly_r_E !< Edge value of polynomial + real, dimension(n0,2), intent(out) :: ppoly_r_S !< Edge slope of polynomial + integer, intent(out) :: iMethod !< Integration method + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions + !! in the same units as h0. + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width + !! for the purpose of edge value + !! calculations in the same units as h0. ! Local variables integer :: local_remapping_scheme integer :: remapping_scheme !< Remapping scheme @@ -352,39 +383,41 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefficients, ppoly call PCM_reconstruction( n0, u0, ppoly_r_E, ppoly_r_coefficients) iMethod = INTEGRATION_PCM case ( REMAPPING_PLM ) - call PLM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients ) + call PLM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients, h_neglect ) if ( CS%boundary_extrapolation ) then - call PLM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients) + call PLM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients, h_neglect) end if iMethod = INTEGRATION_PLM case ( REMAPPING_PPM_H4 ) - call edge_values_explicit_h4( n0, h0, u0, ppoly_r_E ) - call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients ) + call edge_values_explicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge ) + call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients, h_neglect ) if ( CS%boundary_extrapolation ) then - call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients ) + call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients, h_neglect ) end if iMethod = INTEGRATION_PPM case ( REMAPPING_PPM_IH4 ) - call edge_values_implicit_h4( n0, h0, u0, ppoly_r_E ) - call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients ) + call edge_values_implicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge ) + call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients, h_neglect ) if ( CS%boundary_extrapolation ) then - call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients ) + call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients, h_neglect ) end if iMethod = INTEGRATION_PPM case ( REMAPPING_PQM_IH4IH3 ) - call edge_values_implicit_h4( n0, h0, u0, ppoly_r_E ) - call edge_slopes_implicit_h3( n0, h0, u0, ppoly_r_S ) - call PQM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_S, ppoly_r_coefficients ) + call edge_values_implicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge ) + call edge_slopes_implicit_h3( n0, h0, u0, ppoly_r_S, h_neglect ) + call PQM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_S, ppoly_r_coefficients, h_neglect ) if ( CS%boundary_extrapolation ) then - call PQM_boundary_extrapolation_v1( n0, h0, u0, ppoly_r_E, ppoly_r_S, ppoly_r_coefficients ) + call PQM_boundary_extrapolation_v1( n0, h0, u0, ppoly_r_E, ppoly_r_S, & + ppoly_r_coefficients, h_neglect ) end if iMethod = INTEGRATION_PQM case ( REMAPPING_PQM_IH6IH5 ) - call edge_values_implicit_h6( n0, h0, u0, ppoly_r_E ) - call edge_slopes_implicit_h5( n0, h0, u0, ppoly_r_S ) - call PQM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_S, ppoly_r_coefficients ) + call edge_values_implicit_h6( n0, h0, u0, ppoly_r_E, h_neglect_edge ) + call edge_slopes_implicit_h5( n0, h0, u0, ppoly_r_S, h_neglect ) + call PQM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_S, ppoly_r_coefficients, h_neglect ) if ( CS%boundary_extrapolation ) then - call PQM_boundary_extrapolation_v1( n0, h0, u0, ppoly_r_E, ppoly_r_S, ppoly_r_coefficients ) + call PQM_boundary_extrapolation_v1( n0, h0, u0, ppoly_r_E, ppoly_r_S, & + ppoly_r_coefficients, h_neglect ) end if iMethod = INTEGRATION_PQM case default @@ -468,7 +501,7 @@ end subroutine check_reconstructions_1d !> Remaps column of n0 values u0 on grid h0 to grid h1 with n1 cells by calculating !! the n0+n1+1 sub-integrals of the intersection of h0 and h1, and the summing the -!! appropriate integrals into the h1*u1 values. +!! appropriate integrals into the h1*u1 values. h0 and h1 must have the same units. subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefficients, n1, h1, method, & force_bounds_in_subcell, u1, uh_err, ah_sub, aisub_src, aiss, aise ) integer, intent(in) :: n0 !< Number of cells in source grid @@ -1042,7 +1075,8 @@ end subroutine measure_output_bounds !> Remaps column of values u0 on grid h0 to grid h1 by integrating !! over the projection of each h1 cell onto the h0 grid. -subroutine remapByProjection( n0, h0, u0, ppoly0_E, ppoly0_coefficients, n1, h1, method, u1 ) +subroutine remapByProjection( n0, h0, u0, ppoly0_E, ppoly0_coefficients, & + n1, h1, method, u1, h_neglect ) integer, intent(in) :: n0 !< Number of cells in source grid real, intent(in) :: h0(:) !< Source grid widths (size n0) real, intent(in) :: u0(:) !< Source cell averages (size n0) @@ -1052,6 +1086,9 @@ subroutine remapByProjection( n0, h0, u0, ppoly0_E, ppoly0_coefficients, n1, h1, real, intent(in) :: h1(:) !< Target grid widths (size n1) integer, intent(in) :: method !< Remapping scheme to use real, intent(out) :: u1(:) !< Target cell averages (size n1) + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions + !! in the same units as h. ! Local variables integer :: iTarget real :: xL, xR ! coordinates of target cell edges @@ -1070,7 +1107,7 @@ subroutine remapByProjection( n0, h0, u0, ppoly0_E, ppoly0_coefficients, n1, h1, xR = xL + h1(iTarget) call integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefficients, method, & - xL, xR, h1(iTarget), u1(iTarget), jStart, xStart ) + xL, xR, h1(iTarget), u1(iTarget), jStart, xStart, h_neglect ) end do ! end iTarget loop on target grid cells @@ -1086,7 +1123,8 @@ end subroutine remapByProjection !! where !! F(k) = dx1(k) qAverage !! and where qAverage is the average qOld in the region zOld(k) to zNew(k). -subroutine remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefficients, n1, dx1, method, u1, h1 ) +subroutine remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefficients, n1, dx1, & + method, u1, h1, h_neglect ) integer, intent(in) :: n0 !< Number of cells in source grid real, intent(in) :: h0(:) !< Source grid widths (size n0) real, intent(in) :: u0(:) !< Source cell averages (size n0) @@ -1097,6 +1135,9 @@ subroutine remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefficients, n1, dx1, me integer :: method !< Remapping scheme to use real, intent(out) :: u1(:) !< Target cell averages (size n1) real, optional, intent(out) :: h1(:) !< Target grid widths (size n1) + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions + !! in the same units as h. ! Local variables integer :: iTarget real :: xL, xR ! coordinates of target cell edges @@ -1161,7 +1202,7 @@ end subroutine remapByDeltaZ !> Integrate the reconstructed column profile over a single cell subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefficients, method, & - xL, xR, hC, uAve, jStart, xStart ) + xL, xR, hC, uAve, jStart, xStart, h_neglect ) integer, intent(in) :: n0 !< Number of cells in source grid real, intent(in) :: h0(:) !< Source grid sizes (size n0) real, intent(in) :: u0(:) !< Source cell averages @@ -1175,6 +1216,9 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefficients, !< On exit, contains index of last cell used real, intent(inout) :: xStart !< The left edge position of cell jStart !< On first entry should be 0. + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions + !! in the same units as h. ! Local variables integer :: j, k integer :: jL, jR ! indexes of source cells containing target @@ -1187,8 +1231,11 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefficients, real :: hAct ! The distance actually used in the integration ! (notionally xR - xL) which differs due to roundoff. real :: x0_2, x1_2, x02px12, x0px1 ! Used in evaluation of integrated polynomials + real :: hNeglect ! A negligible thicness in the same units as h. real, parameter :: r_3 = 1.0/3.0 ! Used in evaluation of integrated polynomials + hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect + q = -1.E30 x0jLl = -1.E30 x0jRl = -1.E30 @@ -1240,7 +1287,7 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefficients, uAve = 0.5 * ( ppoly0_E(jL,1) + ppoly0_E(jL,2) ) else ! WHY IS THIS NOT WRITTEN AS xi0 = ( xL - x0jLl ) / h0(jL) ---AJA - xi0 = xL / ( h0(jL) + h_neglect ) - x0jLl / ( h0(jL) + h_neglect ) + xi0 = xL / ( h0(jL) + hNeglect ) - x0jLl / ( h0(jL) + hNeglect ) select case ( method ) case ( INTEGRATION_PCM ) @@ -1299,11 +1346,11 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefficients, ! ! Determine normalized coordinates #ifdef __USE_ROUNDOFF_SAFE_ADJUSTMENTS__ - xi0 = max( 0., min( 1., ( xL - x0jLl ) / ( h0(jL) + h_neglect ) ) ) - xi1 = max( 0., min( 1., ( xR - x0jLl ) / ( h0(jL) + h_neglect ) ) ) + xi0 = max( 0., min( 1., ( xL - x0jLl ) / ( h0(jL) + hNeglect ) ) ) + xi1 = max( 0., min( 1., ( xR - x0jLl ) / ( h0(jL) + hNeglect ) ) ) #else - xi0 = xL / h0(jL) - x0jLl / ( h0(jL) + h_neglect ) - xi1 = xR / h0(jL) - x0jLl / ( h0(jL) + h_neglect ) + xi0 = xL / h0(jL) - x0jLl / ( h0(jL) + hNeglect ) + xi1 = xR / h0(jL) - x0jLl / ( h0(jL) + hNeglect ) #endif hAct = h0(jL) * ( xi1 - xi0 ) @@ -1355,9 +1402,9 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefficients, ! Integrate from xL up to right boundary of cell jL #ifdef __USE_ROUNDOFF_SAFE_ADJUSTMENTS__ - xi0 = max( 0., min( 1., ( xL - x0jLl ) / ( h0(jL) + h_neglect ) ) ) + xi0 = max( 0., min( 1., ( xL - x0jLl ) / ( h0(jL) + hNeglect ) ) ) #else - xi0 = (xL - x0jLl) / ( h0(jL) + h_neglect ) + xi0 = (xL - x0jLl) / ( h0(jL) + hNeglect ) #endif xi1 = 1.0 @@ -1401,9 +1448,9 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefficients, ! Integrate from left boundary of cell jR up to xR xi0 = 0.0 #ifdef __USE_ROUNDOFF_SAFE_ADJUSTMENTS__ - xi1 = max( 0., min( 1., ( xR - x0jRl ) / ( h0(jR) + h_neglect ) ) ) + xi1 = max( 0., min( 1., ( xR - x0jRl ) / ( h0(jR) + hNeglect ) ) ) #else - xi1 = (xR - x0jRl) / ( h0(jR) + h_neglect ) + xi1 = (xR - x0jRl) / ( h0(jR) + hNeglect ) #endif hAct = hAct + h0(jR) * ( xi1 - xi0 ) @@ -1557,10 +1604,12 @@ logical function remapping_unit_tests(verbose) type(remapping_CS) :: CS !< Remapping control structure real, allocatable, dimension(:,:) :: ppoly0_E, ppoly0_S, ppoly0_coefficients integer :: i - real :: err + real :: err, h_neglect, h_neglect_edge logical :: thisTest, v v = verbose + h_neglect = hNeglect_dflt + h_neglect_edge = 1.0e-10 write(*,*) '==== MOM_remapping: remapping_unit_tests =================' remapping_unit_tests = .false. ! Normally return false @@ -1587,7 +1636,7 @@ logical function remapping_unit_tests(verbose) if (verbose) call dumpGrid(n0,h0,x0,u0) call dzFromH1H2( n0, h0, n1, h1, dx1 ) - call remapping_core_w( CS, n0, h0, u0, n1, dx1, u1 ) + call remapping_core_w( CS, n0, h0, u0, n1, dx1, u1, h_neglect, h_neglect_edge) do i=1,n1 err=u1(i)-8.*(0.5*real(1+n1)-real(i)) if (abs(err)>real(n1-1)*epsilon(err)) thisTest = .true. @@ -1606,12 +1655,12 @@ logical function remapping_unit_tests(verbose) ppoly0_S(:,:) = 0.0 ppoly0_coefficients(:,:) = 0.0 - call edge_values_explicit_h4( n0, h0, u0, ppoly0_E ) - call PPM_reconstruction( n0, h0, u0, ppoly0_E, ppoly0_coefficients ) - call PPM_boundary_extrapolation( n0, h0, u0, ppoly0_E, ppoly0_coefficients ) + call edge_values_explicit_h4( n0, h0, u0, ppoly0_E, h_neglect=1e-10 ) + call PPM_reconstruction( n0, h0, u0, ppoly0_E, ppoly0_coefficients, h_neglect ) + call PPM_boundary_extrapolation( n0, h0, u0, ppoly0_E, ppoly0_coefficients, h_neglect ) u1(:) = 0. call remapByProjection( n0, h0, u0, ppoly0_E, ppoly0_coefficients, & - n1, h1, INTEGRATION_PPM, u1 ) + n1, h1, INTEGRATION_PPM, u1, h_neglect ) do i=1,n1 err=u1(i)-8.*(0.5*real(1+n1)-real(i)) if (abs(err)>2.*epsilon(err)) thisTest = .true. @@ -1623,7 +1672,7 @@ logical function remapping_unit_tests(verbose) u1(:) = 0. call remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefficients, & n1, x1-x0(1:n1+1), & - INTEGRATION_PPM, u1, hn1 ) + INTEGRATION_PPM, u1, hn1, h_neglect ) if (verbose) write(*,*) 'h1 (by delta)' if (verbose) call dumpGrid(n1,h1,x1,u1) hn1=hn1-h1 @@ -1640,7 +1689,7 @@ logical function remapping_unit_tests(verbose) dx2(n0+2:n2+1) = x2(n0+2:n2+1) - x0(n0+1) call remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefficients, & n2, dx2, & - INTEGRATION_PPM, u2, hn2 ) + INTEGRATION_PPM, u2, hn2, h_neglect ) if (verbose) write(*,*) 'h2' if (verbose) call dumpGrid(n2,h2,x2,u2) if (verbose) write(*,*) 'hn2' @@ -1683,72 +1732,119 @@ logical function remapping_unit_tests(verbose) allocate(ppoly0_E(5,2)) allocate(ppoly0_S(5,2)) - call PCM_reconstruction(3, (/1.,2.,4./), ppoly0_E(1:3,:), ppoly0_coefficients(1:3,:) ) - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 3, ppoly0_E(:,1), (/1.,2.,4./), 'PCM: left edges') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 3, ppoly0_E(:,2), (/1.,2.,4./), 'PCM: right edges') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 3, ppoly0_coefficients(:,1), (/1.,2.,4./), 'PCM: P0') - - call PLM_reconstruction(3, (/1.,1.,1./), (/1.,3.,5./), ppoly0_E(1:3,:), ppoly0_coefficients(1:3,:) ) - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 3, ppoly0_E(:,1), (/1.,2.,5./), 'Unlim PLM: left edges') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 3, ppoly0_E(:,2), (/1.,4.,5./), 'Unlim PLM: right edges') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 3, ppoly0_coefficients(:,1), (/1.,2.,5./), 'Unlim PLM: P0') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 3, ppoly0_coefficients(:,2), (/0.,2.,0./), 'Unlim PLM: P1') - - call PLM_reconstruction(3, (/1.,1.,1./), (/1.,2.,7./), ppoly0_E(1:3,:), ppoly0_coefficients(1:3,:) ) - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 3, ppoly0_E(:,1), (/1.,1.,7./), 'Left lim PLM: left edges') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 3, ppoly0_E(:,2), (/1.,3.,7./), 'Left lim PLM: right edges') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 3, ppoly0_coefficients(:,1), (/1.,1.,7./), 'Left lim PLM: P0') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 3, ppoly0_coefficients(:,2), (/0.,2.,0./), 'Left lim PLM: P1') - - call PLM_reconstruction(3, (/1.,1.,1./), (/1.,6.,7./), ppoly0_E(1:3,:), ppoly0_coefficients(1:3,:) ) - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 3, ppoly0_E(:,1), (/1.,5.,7./), 'Right lim PLM: left edges') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 3, ppoly0_E(:,2), (/1.,7.,7./), 'Right lim PLM: right edges') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 3, ppoly0_coefficients(:,1), (/1.,5.,7./), 'Right lim PLM: P0') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 3, ppoly0_coefficients(:,2), (/0.,2.,0./), 'Right lim PLM: P1') - - call PLM_reconstruction(3, (/1.,2.,3./), (/1.,4.,9./), ppoly0_E(1:3,:), ppoly0_coefficients(1:3,:) ) - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 3, ppoly0_E(:,1), (/1.,2.,9./), 'Non-uniform line PLM: left edges') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 3, ppoly0_E(:,2), (/1.,6.,9./), 'Non-uniform line PLM: right edges') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 3, ppoly0_coefficients(:,1), (/1.,2.,9./), 'Non-uniform line PLM: P0') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 3, ppoly0_coefficients(:,2), (/0.,4.,0./), 'Non-uniform line PLM: P1') - - call edge_values_explicit_h4( 5, (/1.,1.,1.,1.,1./), (/1.,3.,5.,7.,9./), ppoly0_E ) + call PCM_reconstruction(3, (/1.,2.,4./), ppoly0_E(1:3,:), & + ppoly0_coefficients(1:3,:) ) + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_E(:,1), (/1.,2.,4./), 'PCM: left edges') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_E(:,2), (/1.,2.,4./), 'PCM: right edges') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_coefficients(:,1), (/1.,2.,4./), 'PCM: P0') + + call PLM_reconstruction(3, (/1.,1.,1./), (/1.,3.,5./), ppoly0_E(1:3,:), & + ppoly0_coefficients(1:3,:), h_neglect ) + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_E(:,1), (/1.,2.,5./), 'Unlim PLM: left edges') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_E(:,2), (/1.,4.,5./), 'Unlim PLM: right edges') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_coefficients(:,1), (/1.,2.,5./), 'Unlim PLM: P0') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_coefficients(:,2), (/0.,2.,0./), 'Unlim PLM: P1') + + call PLM_reconstruction(3, (/1.,1.,1./), (/1.,2.,7./), ppoly0_E(1:3,:), & + ppoly0_coefficients(1:3,:), h_neglect ) + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_E(:,1), (/1.,1.,7./), 'Left lim PLM: left edges') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_E(:,2), (/1.,3.,7./), 'Left lim PLM: right edges') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_coefficients(:,1), (/1.,1.,7./), 'Left lim PLM: P0') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_coefficients(:,2), (/0.,2.,0./), 'Left lim PLM: P1') + + call PLM_reconstruction(3, (/1.,1.,1./), (/1.,6.,7./), ppoly0_E(1:3,:), & + ppoly0_coefficients(1:3,:), h_neglect ) + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_E(:,1), (/1.,5.,7./), 'Right lim PLM: left edges') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_E(:,2), (/1.,7.,7./), 'Right lim PLM: right edges') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_coefficients(:,1), (/1.,5.,7./), 'Right lim PLM: P0') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_coefficients(:,2), (/0.,2.,0./), 'Right lim PLM: P1') + + call PLM_reconstruction(3, (/1.,2.,3./), (/1.,4.,9./), ppoly0_E(1:3,:), & + ppoly0_coefficients(1:3,:), h_neglect ) + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_E(:,1), (/1.,2.,9./), 'Non-uniform line PLM: left edges') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_E(:,2), (/1.,6.,9./), 'Non-uniform line PLM: right edges') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_coefficients(:,1), (/1.,2.,9./), 'Non-uniform line PLM: P0') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 3, ppoly0_coefficients(:,2), (/0.,4.,0./), 'Non-uniform line PLM: P1') + + call edge_values_explicit_h4( 5, (/1.,1.,1.,1.,1./), (/1.,3.,5.,7.,9./), ppoly0_E, & + h_neglect=1e-10 ) thisTest = test_answer(v, 5, ppoly0_E(:,1), (/0.,2.,4.,6.,8./), 'Line H4: left edges') ! Currently fails due to roundoff thisTest = test_answer(v, 5, ppoly0_E(:,2), (/2.,4.,6.,8.,10./), 'Line H4: right edges') ! Currently fails due to roundoff ppoly0_E(:,1) = (/0.,2.,4.,6.,8./) ppoly0_E(:,2) = (/2.,4.,6.,8.,10./) - call PPM_reconstruction(5, (/1.,1.,1.,1.,1./), (/1.,3.,5.,7.,9./), ppoly0_E(1:5,:), ppoly0_coefficients(1:5,:) ) - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 5, ppoly0_coefficients(:,1), (/1.,2.,4.,6.,9./), 'Line PPM: P0') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 5, ppoly0_coefficients(:,2), (/0.,2.,2.,2.,0./), 'Line PPM: P1') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 5, ppoly0_coefficients(:,3), (/0.,0.,0.,0.,0./), 'Line PPM: P2') - - call edge_values_explicit_h4( 5, (/1.,1.,1.,1.,1./), (/1.,1.,7.,19.,37./), ppoly0_E ) + call PPM_reconstruction(5, (/1.,1.,1.,1.,1./), (/1.,3.,5.,7.,9./), ppoly0_E(1:5,:), & + ppoly0_coefficients(1:5,:), h_neglect ) + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 5, ppoly0_coefficients(:,1), (/1.,2.,4.,6.,9./), 'Line PPM: P0') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 5, ppoly0_coefficients(:,2), (/0.,2.,2.,2.,0./), 'Line PPM: P1') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 5, ppoly0_coefficients(:,3), (/0.,0.,0.,0.,0./), 'Line PPM: P2') + + call edge_values_explicit_h4( 5, (/1.,1.,1.,1.,1./), (/1.,1.,7.,19.,37./), ppoly0_E, & + h_neglect=1e-10 ) thisTest = test_answer(v, 5, ppoly0_E(:,1), (/3.,0.,3.,12.,27./), 'Parabola H4: left edges') ! Currently fails due to roundoff thisTest = test_answer(v, 5, ppoly0_E(:,2), (/0.,3.,12.,27.,48./), 'Parabola H4: right edges') ! Currently fails due to roundoff ppoly0_E(:,1) = (/0.,0.,3.,12.,27./) ppoly0_E(:,2) = (/0.,3.,12.,27.,48./) - call PPM_reconstruction(5, (/1.,1.,1.,1.,1./), (/0.,1.,7.,19.,37./), ppoly0_E(1:5,:), ppoly0_coefficients(1:5,:) ) - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 5, ppoly0_E(:,1), (/0.,0.,3.,12.,37./), 'Parabola PPM: left edges') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 5, ppoly0_E(:,2), (/0.,3.,12.,27.,37./), 'Parabola PPM: right edges') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 5, ppoly0_coefficients(:,1), (/0.,0.,3.,12.,37./), 'Parabola PPM: P0') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 5, ppoly0_coefficients(:,2), (/0.,0.,6.,12.,0./), 'Parabola PPM: P1') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 5, ppoly0_coefficients(:,3), (/0.,3.,3.,3.,0./), 'Parabola PPM: P2') + call PPM_reconstruction(5, (/1.,1.,1.,1.,1./), (/0.,1.,7.,19.,37./), ppoly0_E(1:5,:), & + ppoly0_coefficients(1:5,:), h_neglect ) + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 5, ppoly0_E(:,1), (/0.,0.,3.,12.,37./), 'Parabola PPM: left edges') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 5, ppoly0_E(:,2), (/0.,3.,12.,27.,37./), 'Parabola PPM: right edges') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 5, ppoly0_coefficients(:,1), (/0.,0.,3.,12.,37./), 'Parabola PPM: P0') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 5, ppoly0_coefficients(:,2), (/0.,0.,6.,12.,0./), 'Parabola PPM: P1') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 5, ppoly0_coefficients(:,3), (/0.,3.,3.,3.,0./), 'Parabola PPM: P2') ppoly0_E(:,1) = (/0.,0.,6.,10.,15./) ppoly0_E(:,2) = (/0.,6.,12.,17.,15./) - call PPM_reconstruction(5, (/1.,1.,1.,1.,1./), (/0.,5.,7.,16.,15./), ppoly0_E(1:5,:), ppoly0_coefficients(1:5,:) ) - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 5, ppoly0_E(:,1), (/0.,3.,6.,16.,15./), 'Limits PPM: left edges') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 5, ppoly0_E(:,2), (/0.,6.,9.,16.,15./), 'Limits PPM: right edges') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 5, ppoly0_coefficients(:,1), (/0.,3.,6.,16.,15./), 'Limits PPM: P0') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 5, ppoly0_coefficients(:,2), (/0.,6.,0.,0.,0./), 'Limits PPM: P1') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 5, ppoly0_coefficients(:,3), (/0.,-3.,3.,0.,0./), 'Limits PPM: P2') - - call PLM_reconstruction(4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), ppoly0_E(1:4,:), ppoly0_coefficients(1:4,:) ) - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 4, ppoly0_E(1:4,1), (/5.,5.,3.,1./), 'PPM: left edges h=0110') - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 4, ppoly0_E(1:4,2), (/5.,3.,1.,1./), 'PPM: right edges h=0110') - call remap_via_sub_cells( 4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), ppoly0_E(1:4,:), ppoly0_coefficients(1:4,:), & + call PPM_reconstruction(5, (/1.,1.,1.,1.,1./), (/0.,5.,7.,16.,15./), ppoly0_E(1:5,:), & + ppoly0_coefficients(1:5,:), h_neglect ) + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 5, ppoly0_E(:,1), (/0.,3.,6.,16.,15./), 'Limits PPM: left edges') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 5, ppoly0_E(:,2), (/0.,6.,9.,16.,15./), 'Limits PPM: right edges') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 5, ppoly0_coefficients(:,1), (/0.,3.,6.,16.,15./), 'Limits PPM: P0') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 5, ppoly0_coefficients(:,2), (/0.,6.,0.,0.,0./), 'Limits PPM: P1') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 5, ppoly0_coefficients(:,3), (/0.,-3.,3.,0.,0./), 'Limits PPM: P2') + + call PLM_reconstruction(4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), ppoly0_E(1:4,:), & + ppoly0_coefficients(1:4,:), h_neglect ) + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 4, ppoly0_E(1:4,1), (/5.,5.,3.,1./), 'PPM: left edges h=0110') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 4, ppoly0_E(1:4,2), (/5.,3.,1.,1./), 'PPM: right edges h=0110') + call remap_via_sub_cells( 4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), ppoly0_E(1:4,:), & + ppoly0_coefficients(1:4,:), & 2, (/1.,1./), INTEGRATION_PLM, .false., u2, err ) - remapping_unit_tests = remapping_unit_tests .or. test_answer(v, 2, u2, (/4.,2./), 'PLM: remapped h=0110->h=11') + remapping_unit_tests = remapping_unit_tests .or. & + test_answer(v, 2, u2, (/4.,2./), 'PLM: remapped h=0110->h=11') deallocate(ppoly0_E, ppoly0_S, ppoly0_coefficients) diff --git a/src/ALE/P1M_functions.F90 b/src/ALE/P1M_functions.F90 index 5873c6c440..a7a7635800 100644 --- a/src/ALE/P1M_functions.F90 +++ b/src/ALE/P1M_functions.F90 @@ -41,7 +41,7 @@ module P1M_functions !------------------------------------------------------------------------------ ! p1m interpolation !------------------------------------------------------------------------------ -subroutine P1M_interpolation( N, h, u, ppoly_E, ppoly_coefficients ) +subroutine P1M_interpolation( N, h, u, ppoly_E, ppoly_coefficients, h_neglect ) ! ------------------------------------------------------------------------------ ! Linearly interpolate between edge values. ! The resulting piecewise interpolant is stored in 'ppoly'. @@ -57,18 +57,23 @@ subroutine P1M_interpolation( N, h, u, ppoly_E, ppoly_coefficients ) ! ------------------------------------------------------------------------------ ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell widths (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: ppoly_E - real, dimension(:,:), intent(inout) :: ppoly_coefficients + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell average properties (size N) + real, dimension(:,:), intent(inout) :: ppoly_E !< Potentially modified edge values, + !! with the same units as u. + real, dimension(:,:), intent(inout) :: ppoly_coefficients !< Potentially modified + !! piecewise polynomial coefficients, mainly + !! with the same units as u. + real, optional, intent(in) :: h_neglect !< A negligibly small width + !! in the same units as h. ! Local variables integer :: k ! loop index real :: u0_l, u0_r ! edge values (left and right) ! Bound edge values (routine found in 'edge_values.F90') - call bound_edge_values( N, h, u, ppoly_E ) + call bound_edge_values( N, h, u, ppoly_E, h_neglect ) ! Systematically average discontinuous edge values (routine found in ! 'edge_values.F90') diff --git a/src/ALE/P3M_functions.F90 b/src/ALE/P3M_functions.F90 index 7e8c16a9d0..ecc7136ead 100644 --- a/src/ALE/P3M_functions.F90 +++ b/src/ALE/P3M_functions.F90 @@ -22,14 +22,16 @@ module P3M_functions public P3M_interpolation public P3M_boundary_extrapolation -real, parameter :: h_neglect = 1.E-30 +real, parameter :: hNeglect_dflt = 1.E-30 +real, parameter :: hNeglect_edge_dflt = 1.E-10 contains !------------------------------------------------------------------------------ ! p3m interpolation ! ----------------------------------------------------------------------------- -subroutine P3M_interpolation( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients ) +subroutine P3M_interpolation( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, & + h_neglect ) !------------------------------------------------------------------------------ ! Cubic interpolation between edges. ! @@ -47,7 +49,9 @@ subroutine P3M_interpolation( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients ) real, dimension(:,:), intent(inout) :: ppoly_E !Edge value of polynomial real, dimension(:,:), intent(inout) :: ppoly_S !Edge slope of polynomial real, dimension(:,:), intent(inout) :: ppoly_coefficients !Coefficients of polynomial - + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions + !! in the same units as h. ! Call the limiter for p3m, which takes care of everything from ! computing the coefficients of the cubic to monotonizing it. @@ -55,7 +59,7 @@ subroutine P3M_interpolation( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients ) ! 'P3M_interpolation' first but we do that to provide an homogeneous ! interface. - call P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients ) + call P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, h_neglect ) end subroutine P3M_interpolation @@ -63,7 +67,7 @@ end subroutine P3M_interpolation !------------------------------------------------------------------------------ ! p3m limiter ! ----------------------------------------------------------------------------- -subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients ) +subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, h_neglect ) !------------------------------------------------------------------------------ ! The p3m limiter operates as follows: ! @@ -84,25 +88,29 @@ subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients ) real, dimension(:,:), intent(inout) :: ppoly_E !Edge value of polynomial real, dimension(:,:), intent(inout) :: ppoly_S !Edge slope of polynomial real, dimension(:,:), intent(inout) :: ppoly_coefficients !Coefficients of polynomial - -! real, dimension(:,:), intent(inout) :: ppoly_coefficients + real, optional, intent(in) :: h_neglect !< A negligibly small width for + !! the purpose of cell reconstructions + !! in the same units as h. ! Local variables - integer :: k ! loop index - integer :: monotonic ! boolean indicating whether the cubic is monotonic - real :: u0_l, u0_r ! edge values - real :: u1_l, u1_r ! edge slopes - real :: u_l, u_c, u_r ! left, center and right cell averages - real :: h_l, h_c, h_r ! 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 :: eps + integer :: k ! loop index + integer :: monotonic ! boolean indicating whether the cubic is monotonic + real :: u0_l, u0_r ! edge values + real :: u1_l, u1_r ! edge slopes + real :: u_l, u_c, u_r ! left, center and right cell averages + real :: h_l, h_c, h_r ! 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 :: eps + real :: hNeglect + + hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect eps = 1e-10 ! 1. Bound edge values (boundary cells are assumed to be local extrema) - call bound_edge_values( N, h, u, ppoly_E ) + call bound_edge_values( N, h, u, ppoly_E, hNeglect ) ! 2. Systematically average discontinuous edge values call average_discontinuous_edge_values( N, ppoly_E ) @@ -142,9 +150,9 @@ subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients ) end if ! Compute limited slope - sigma_l = 2.0 * ( u_c - u_l ) / ( h_c + h_neglect ) - sigma_c = 2.0 * ( u_r - u_l ) / ( h_l + 2.0*h_c + h_r + h_neglect ) - sigma_r = 2.0 * ( u_r - u_c ) / ( h_c + h_neglect ) + sigma_l = 2.0 * ( u_c - u_l ) / ( h_c + hNeglect ) + sigma_c = 2.0 * ( u_r - u_l ) / ( h_l + 2.0*h_c + h_r + hNeglect ) + sigma_r = 2.0 * ( u_r - u_c ) / ( h_c + hNeglect ) if ( (sigma_l * sigma_r) .GT. 0.0 ) then slope = sign( min(abs(sigma_l),abs(sigma_c),abs(sigma_r)), sigma_c ) @@ -154,12 +162,12 @@ subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients ) ! If the slopes are close to zero in machine precision and in absolute ! value, we set the slope to zero. This prevents asymmetric representation - ! near extrema. - if ( abs(u1_l*h_c) .LT. eps ) then + ! near extrema. These expressions are both nondimensional. + if ( abs(u1_l*h_c) < eps ) then u1_l = 0.0 end if - if ( abs(u1_r*h_c) .LT. eps ) then + if ( abs(u1_r*h_c) < eps ) then u1_r = 0.0 end if @@ -201,7 +209,8 @@ end subroutine P3M_limiter !------------------------------------------------------------------------------ ! p3m boundary extrapolation ! ----------------------------------------------------------------------------- -subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients ) +subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, & + h_neglect, h_neglect_edge ) !------------------------------------------------------------------------------ ! The following explanations apply to the left boundary cell. The same ! reasoning holds for the right boundary cell. @@ -222,25 +231,33 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coeffici real, dimension(:,:), intent(inout) :: ppoly_E !Edge value of polynomial real, dimension(:,:), intent(inout) :: ppoly_S !Edge slope of polynomial real, dimension(:,:), intent(inout) :: ppoly_coefficients !Coefficients of polynomial + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions + !! in the same units as h. + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width + !! for the purpose of finding edge values + !! in the same units as h. ! Local variables - integer :: i0, i1 - integer :: monotonic - real :: u0, u1 - real :: h0, h1 - real :: b, c, d - real :: u0_l, u0_r - real :: u1_l, u1_r - real :: eps - real :: slope - - eps = 1e-10 + integer :: i0, i1 + integer :: monotonic + real :: u0, u1 + real :: h0, h1 + real :: b, c, d + real :: u0_l, u0_r + real :: u1_l, u1_r + real :: slope + real :: hNeglect, hNeglect_edge + + hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect + hNeglect_edge = hNeglect_edge_dflt + if (present(h_neglect_edge)) hNeglect_edge = h_neglect_edge ! ----- Left boundary ----- i0 = 1 i1 = 2 - h0 = h(i0) + eps - h1 = h(i1) + eps + h0 = h(i0) + hNeglect_edge + h1 = h(i1) + hNeglect_edge u0 = u(i0) u1 = u(i1) @@ -250,7 +267,7 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coeffici u1_r = b / h1 ! derivative evaluated at xi = 0.0, expressed w.r.t. x ! Limit the right slope by the PLM limited slope - slope = 2.0 * ( u1 - u0 ) / ( h0 + h_neglect ) + slope = 2.0 * ( u1 - u0 ) / ( h0 + hNeglect ) if ( abs(u1_r) .GT. abs(slope) ) then u1_r = slope end if @@ -263,7 +280,7 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coeffici ! edge value and slope by computing the parabola as determined by ! the right edge value and slope and the boundary cell average u0_l = 3.0 * u0 + 0.5 * h0*u1_r - 2.0 * u0_r - u1_l = ( - 6.0 * u0 - 2.0 * h0*u1_r + 6.0 * u0_r) / ( h0 + h_neglect ) + u1_l = ( - 6.0 * u0 - 2.0 * h0*u1_r + 6.0 * u0_r) / ( h0 + hNeglect ) ! Check whether the edge values are monotonic. For example, if the left edge ! value is larger than the right edge value while the slope is positive, the @@ -297,8 +314,8 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coeffici ! ----- Right boundary ----- i0 = N-1 i1 = N - h0 = h(i0) + eps - h1 = h(i1) + eps + h0 = h(i0) + hNeglect_edge + h1 = h(i1) + hNeglect_edge u0 = u(i0) u1 = u(i1) @@ -307,10 +324,10 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coeffici b = ppoly_coefficients(i0,2) c = ppoly_coefficients(i0,3) d = ppoly_coefficients(i0,4) - u1_l = (b + 2*c + 3*d) / ( h0 + h_neglect ) ! derivative evaluated at xi = 1.0 + u1_l = (b + 2*c + 3*d) / ( h0 + hNeglect ) ! derivative evaluated at xi = 1.0 ! Limit the left slope by the PLM limited slope - slope = 2.0 * ( u1 - u0 ) / ( h1 + h_neglect ) + slope = 2.0 * ( u1 - u0 ) / ( h1 + hNeglect ) if ( abs(u1_l) .GT. abs(slope) ) then u1_l = slope end if @@ -323,7 +340,7 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coeffici ! edge value and slope by computing the parabola as determined by ! the left edge value and slope and the boundary cell average u0_r = 3.0 * u1 - 0.5 * h1*u1_l - 2.0 * u0_l - u1_r = ( 6.0 * u1 - 2.0 * h1*u1_l - 6.0 * u0_l) / ( h1 + h_neglect ) + u1_r = ( 6.0 * u1 - 2.0 * h1*u1_l - 6.0 * u0_l) / ( h1 + hNeglect ) ! Check whether the edge values are monotonic. For example, if the right edge ! value is smaller than the left edge value while the slope is positive, the diff --git a/src/ALE/PLM_functions.F90 b/src/ALE/PLM_functions.F90 index 24efc5dfff..83eea1518b 100644 --- a/src/ALE/PLM_functions.F90 +++ b/src/ALE/PLM_functions.F90 @@ -16,14 +16,14 @@ module PLM_functions public PLM_reconstruction, PLM_boundary_extrapolation -real, parameter :: h_neglect = 1.E-30 +real, parameter :: hNeglect_dflt = 1.E-30 contains !------------------------------------------------------------------------------ ! PLM_reconstruction ! ----------------------------------------------------------------------------- -subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coefficients ) +subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coefficients, h_neglect ) !------------------------------------------------------------------------------ ! Reconstruction by linear polynomials within each cell. ! @@ -43,6 +43,9 @@ subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coefficients ) real, dimension(:), intent(in) :: u ! cell averages (size N) real, dimension(:,:), intent(inout) :: ppoly_E real, dimension(:,:), intent(inout) :: ppoly_coefficients + real, optional, intent(in) :: h_neglect !< A negligibly small width for + !! the purpose of cell reconstructions + !! in the same units as h ! Local variables integer :: k ! loop index @@ -55,6 +58,9 @@ subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coefficients ) real :: u_min, u_max, e_l, e_r, edge real :: almost_one, almost_two 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 @@ -67,7 +73,7 @@ subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coefficients ) ! Get cell widths h_l = h(k-1) ; h_c = h(k) ; h_r = h(k+1) - h_cn = max( h_c, h_neglect ) ! To avoid division by zero + h_cn = max( h_c, hNeglect ) ! To avoid division by zero ! Side differences sigma_r = u_r - u_c @@ -83,7 +89,7 @@ subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coefficients ) ! 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 + h_neglect) ) + 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 @@ -209,7 +215,7 @@ end subroutine PLM_reconstruction !------------------------------------------------------------------------------ ! plm boundary extrapolation ! ----------------------------------------------------------------------------- -subroutine PLM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients ) +subroutine PLM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients, h_neglect ) !------------------------------------------------------------------------------ ! Reconstruction by linear polynomials within boundary cells. ! The left and right edge values in the left and right boundary cells, @@ -233,17 +239,23 @@ subroutine PLM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients ) real, dimension(:), intent(in) :: u ! cell averages (size N) real, dimension(:,:), intent(inout) :: ppoly_E real, dimension(:,:), intent(inout) :: ppoly_coefficients + real, optional, intent(in) :: h_neglect !< A negligibly small width for + !! the purpose of cell reconstructions + !! in the same units as h ! Local variables - real :: u0, u1 ! cell averages - real :: h0, h1 ! corresponding cell widths - real :: slope ! retained PLM slope + 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) + h_neglect - h1 = h(2) + h_neglect + h0 = h(1) + hNeglect + h1 = h(2) + hNeglect u0 = u(1) u1 = u(2) @@ -264,8 +276,8 @@ subroutine PLM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients ) ! ------------------------------------------ ! Right edge value in the left boundary cell ! ------------------------------------------ - h0 = h(N-1) + h_neglect - h1 = h(N) + h_neglect + h0 = h(N-1) + hNeglect + h1 = h(N) + hNeglect u0 = u(N-1) u1 = u(N) diff --git a/src/ALE/PPM_functions.F90 b/src/ALE/PPM_functions.F90 index 24205c32a1..4dd6699722 100644 --- a/src/ALE/PPM_functions.F90 +++ b/src/ALE/PPM_functions.F90 @@ -20,23 +20,25 @@ module PPM_functions !! to avoid division by zero. !! @note This is a dimensional parameter and should really include a unit !! conversion. -real, parameter :: h_neglect = 1.E-30 +real, parameter :: hNeglect_dflt = 1.E-30 contains !> Builds quadratic polynomials coefficients from cell mean and edge values. -subroutine PPM_reconstruction( N, h, u, ppoly_E, ppoly_coefficients) +subroutine PPM_reconstruction( N, h, u, ppoly_E, ppoly_coefficients, h_neglect) integer, intent(in) :: N !< Number of cells real, dimension(N), intent(in) :: h !< Cell widths real, dimension(N), intent(in) :: u !< Cell averages real, dimension(N,2), intent(inout) :: ppoly_E !< Edge values real, dimension(N,3), intent(inout) :: ppoly_coefficients !< Polynomial coefficients + real, optional, intent(in) :: h_neglect !< A negligibly small width + !! in the same units as h. ! Local variables integer :: k ! Loop index real :: edge_l, edge_r ! Edge values (left and right) ! PPM limiter - call PPM_limiter_standard( N, h, u, ppoly_E ) + call PPM_limiter_standard( N, h, u, ppoly_E, h_neglect ) ! Loop over all cells do k = 1,N @@ -56,11 +58,14 @@ 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 ) - integer, intent(in) :: N ! Number of cells - real, dimension(N), intent(in) :: h ! Cell widths - real, dimension(N), intent(in) :: u ! Cell averages - real, dimension(N,2), intent(inout) :: ppoly_E !< Edge values +subroutine PPM_limiter_standard( N, h, u, ppoly_E, h_neglect ) + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell average properties (size N) + real, dimension(:,:), intent(inout) :: ppoly_E !< Potentially modified edge values, + !! with the same units as u. + real, optional, intent(in) :: h_neglect !< A negligibly small width + !! in the same units as h. ! Local variables integer :: k ! Loop index real :: u_l, u_c, u_r ! Cell averages (left, center and right) @@ -68,7 +73,7 @@ subroutine PPM_limiter_standard( N, h, u, ppoly_E ) real :: expr1, expr2 ! Bound edge values - call bound_edge_values( N, h, u, ppoly_E ) + call bound_edge_values( N, h, u, ppoly_E, h_neglect ) ! Make discontinuous edge values monotonic call check_discontinuous_edge_values( N, u, ppoly_E ) @@ -124,7 +129,7 @@ end subroutine PPM_limiter_standard !------------------------------------------------------------------------------ ! ppm boundary extrapolation ! ----------------------------------------------------------------------------- -subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients) +subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients, h_neglect) !------------------------------------------------------------------------------ ! Reconstruction by parabolas within boundary cells. ! @@ -155,16 +160,22 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients) real, dimension(:), intent(in) :: u ! cell averages (size N) real, dimension(:,:), intent(inout) :: ppoly_E real, dimension(:,:), intent(inout) :: ppoly_coefficients + real, optional, intent(in) :: h_neglect !< A negligibly small width for + !! the purpose of cell reconstructions + !! in the same units as h. ! Local variables - integer :: i0, i1 - real :: u0, u1 - real :: h0, h1 - real :: a, b, c - real :: u0_l, u0_r - real :: u1_l, u1_r - real :: slope - real :: exp1, exp2 + integer :: i0, i1 + real :: u0, u1 + real :: h0, h1 + real :: a, b, c + real :: u0_l, u0_r + real :: u1_l, u1_r + real :: slope + real :: exp1, exp2 + real :: hNeglect + + hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect ! ----- Left boundary ----- i0 = 1 @@ -177,7 +188,7 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients) ! Compute the left edge slope in neighboring cell and express it in ! the global coordinate system b = ppoly_coefficients(i1,2) - u1_r = b *((h0+h_neglect)/(h1+h_neglect)) ! derivative evaluated at xi = 0.0, + u1_r = b *((h0+hNeglect)/(h1+hNeglect)) ! derivative evaluated at xi = 0.0, ! expressed w.r.t. xi (local coord. system) ! Limit the right slope by the PLM limited slope @@ -231,7 +242,7 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients) b = ppoly_coefficients(i0,2) c = ppoly_coefficients(i0,3) u1_l = (b + 2*c) ! derivative evaluated at xi = 1.0 - u1_l = u1_l * ((h1+h_neglect)/(h0+h_neglect)) + u1_l = u1_l * ((h1+hNeglect)/(h0+hNeglect)) ! Limit the left slope by the PLM limited slope slope = 2.0 * ( u1 - u0 ) diff --git a/src/ALE/PQM_functions.F90 b/src/ALE/PQM_functions.F90 index e4fc03092c..707cd9f40f 100644 --- a/src/ALE/PQM_functions.F90 +++ b/src/ALE/PQM_functions.F90 @@ -17,14 +17,14 @@ module PQM_functions public PQM_reconstruction, PQM_boundary_extrapolation, PQM_boundary_extrapolation_v1 -real, parameter :: h_neglect = 1.E-30 +real, parameter :: hNeglect_dflt = 1.E-30 contains !------------------------------------------------------------------------------ ! PQM_reconstruction ! ----------------------------------------------------------------------------- -subroutine PQM_reconstruction( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients ) +subroutine PQM_reconstruction( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, h_neglect ) !------------------------------------------------------------------------------ ! Reconstruction by quartic polynomials within each cell. ! @@ -43,6 +43,9 @@ subroutine PQM_reconstruction( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients ) real, dimension(:,:), intent(inout) :: ppoly_E !Edge value of polynomial real, dimension(:,:), intent(inout) :: ppoly_S !Edge slope of polynomial real, dimension(:,:), intent(inout) :: ppoly_coefficients !Coefficients of polynomial + real, optional, intent(in) :: h_neglect !< A negligibly small width for + !! the purpose of cell reconstructions + !! in the same units as h ! Local variables integer :: k ! loop index @@ -52,7 +55,7 @@ subroutine PQM_reconstruction( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients ) real :: a, b, c, d, e ! parabola coefficients ! PQM limiter - call PQM_limiter( N, h, u, ppoly_E, ppoly_S ) + call PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect ) ! Loop on cells to construct the cubic within each cell do k = 1,N @@ -86,7 +89,7 @@ end subroutine PQM_reconstruction !------------------------------------------------------------------------------ ! Limit pqm ! ----------------------------------------------------------------------------- -subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S ) +subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect ) !------------------------------------------------------------------------------ ! Standard PQM limiter (White & Adcroft, JCP 2008). ! @@ -99,31 +102,38 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S ) !------------------------------------------------------------------------------ ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell widths (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: ppoly_E !Edge value of polynomial - real, dimension(:,:), intent(inout) :: ppoly_S !Edge slope of polynomial + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell average properties (size N) + real, dimension(:,:), intent(inout) :: ppoly_E !< Potentially modified edge values, + !! with the same units as u. + real, dimension(:,:), intent(inout) :: ppoly_S !< Potentially modified edge slopes, + !! with the same units as u. + real, optional, intent(in) :: h_neglect !< A negligibly small width for + !! the purpose of cell reconstructions + !! in the same units as h ! Local variables - integer :: k ! loop index - integer :: inflexion_l - integer :: inflexion_r - real :: u0_l, u0_r ! edge values - real :: u1_l, u1_r ! edge slopes - real :: u_l, u_c, u_r ! left, center and right cell averages - real :: h_l, h_c, h_r ! 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, c, d, e - real :: alpha1, alpha2, alpha3 - real :: rho, sqrt_rho - real :: gradient1, gradient2 - real :: x1, x2 + integer :: k ! loop index + integer :: inflexion_l + integer :: inflexion_r + real :: u0_l, u0_r ! edge values + real :: u1_l, u1_r ! edge slopes + real :: u_l, u_c, u_r ! left, center and right cell averages + real :: h_l, h_c, h_r ! 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, c, d, e + real :: alpha1, alpha2, alpha3 + real :: rho, sqrt_rho + real :: gradient1, gradient2 + real :: x1, x2 + real :: hNeglect + + hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect ! Bound edge values - call bound_edge_values( N, h, u, ppoly_E ) + call bound_edge_values( N, h, u, ppoly_E, hNeglect ) ! Make discontinuous edge values monotonic (thru averaging) call check_discontinuous_edge_values( N, u, ppoly_E ) @@ -152,9 +162,9 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S ) u_r = u(k+1) ! Compute limited slope - sigma_l = 2.0 * ( u_c - u_l ) / ( h_c + h_neglect ) - sigma_c = 2.0 * ( u_r - u_l ) / ( h_l + 2.0*h_c + h_r + h_neglect ) - sigma_r = 2.0 * ( u_r - u_c ) / ( h_c + h_neglect ) + sigma_l = 2.0 * ( u_c - u_l ) / ( h_c + hNeglect ) + sigma_c = 2.0 * ( u_r - u_l ) / ( h_l + 2.0*h_c + h_r + hNeglect ) + sigma_r = 2.0 * ( u_r - u_c ) / ( h_c + hNeglect ) if ( (sigma_l * sigma_r) .GT. 0.0 ) then slope = sign( min(abs(sigma_l),abs(sigma_c),abs(sigma_r)), sigma_c ) @@ -292,8 +302,8 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S ) ! We modify the edge slopes so that both inflexion points ! collapse onto the left edge - u1_l = ( 10.0 * u_c - 2.0 * u0_r - 8.0 * u0_l ) / (3.0*h_c + h_neglect ) - u1_r = ( -10.0 * u_c + 6.0 * u0_r + 4.0 * u0_l ) / ( h_c + h_neglect ) + u1_l = ( 10.0 * u_c - 2.0 * u0_r - 8.0 * u0_l ) / (3.0*h_c + hNeglect ) + u1_r = ( -10.0 * u_c + 6.0 * u0_r + 4.0 * u0_l ) / ( h_c + hNeglect ) ! One of the modified slopes might be inconsistent. When that happens, ! the inconsistent slope is set equal to zero and the opposite edge value @@ -303,13 +313,13 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S ) u1_l = 0.0 u0_r = 5.0 * u_c - 4.0 * u0_l - u1_r = 20.0 * (u_c - u0_l) / ( h_c + h_neglect ) + u1_r = 20.0 * (u_c - u0_l) / ( h_c + hNeglect ) else if ( u1_r * slope .LT. 0.0 ) then u1_r = 0.0 u0_l = (5.0*u_c - 3.0*u0_r) / 2.0 - u1_l = 10.0 * (-u_c + u0_r) / (3.0 * h_c + h_neglect) + u1_l = 10.0 * (-u_c + u0_r) / (3.0 * h_c + hNeglect) end if @@ -317,8 +327,8 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S ) ! We modify the edge slopes so that both inflexion points ! collapse onto the right edge - u1_r = ( -10.0 * u_c + 8.0 * u0_r + 2.0 * u0_l ) / (3.0 * h_c + h_neglect) - u1_l = ( 10.0 * u_c - 4.0 * u0_r - 6.0 * u0_l ) / (h_c + h_neglect) + u1_r = ( -10.0 * u_c + 8.0 * u0_r + 2.0 * u0_l ) / (3.0 * h_c + hNeglect) + u1_l = ( 10.0 * u_c - 4.0 * u0_r - 6.0 * u0_l ) / (h_c + hNeglect) ! One of the modified slopes might be inconsistent. When that happens, ! the inconsistent slope is set equal to zero and the opposite edge value @@ -328,13 +338,13 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S ) u1_l = 0.0 u0_r = ( 5.0 * u_c - 3.0 * u0_l ) / 2.0 - u1_r = 10.0 * (u_c - u0_l) / (3.0 * h_c + h_neglect) + u1_r = 10.0 * (u_c - u0_l) / (3.0 * h_c + hNeglect) else if ( u1_r * slope .LT. 0.0 ) then u1_r = 0.0 u0_l = 5.0 * u_c - 4.0 * u0_r - u1_l = 20.0 * ( -u_c + u0_r ) / (h_c + h_neglect) + u1_l = 20.0 * ( -u_c + u0_r ) / (h_c + hNeglect) end if @@ -520,7 +530,7 @@ end subroutine PQM_boundary_extrapolation !------------------------------------------------------------------------------ ! pqm boundary extrapolation using rational function ! ----------------------------------------------------------------------------- -subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients ) +subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, h_neglect ) !------------------------------------------------------------------------------ ! Reconstruction by parabolas within boundary cells. ! @@ -550,23 +560,29 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff real, dimension(:,:), intent(inout) :: ppoly_E !Edge value of polynomial real, dimension(:,:), intent(inout) :: ppoly_S !Edge slope of polynomial real, dimension(:,:), intent(inout) :: ppoly_coefficients !Coefficients of polynomial + real, optional, intent(in) :: h_neglect !< A negligibly small width for + !! the purpose of cell reconstructions + !! in the same units as h. ! Local variables - integer :: i0, i1 - integer :: inflexion_l - integer :: inflexion_r - real :: u0, u1, um - real :: h0, h1 - real :: a, b, c, d, e - real :: ar, br, beta - real :: u0_l, u0_r - real :: u1_l, u1_r - real :: u_plm - real :: slope - real :: alpha1, alpha2, alpha3 - real :: rho, sqrt_rho - real :: gradient1, gradient2 - real :: x1, x2 + integer :: i0, i1 + integer :: inflexion_l + integer :: inflexion_r + real :: u0, u1, um + real :: h0, h1 + real :: a, b, c, d, e + real :: ar, br, beta + real :: u0_l, u0_r + real :: u1_l, u1_r + real :: u_plm + real :: slope + real :: alpha1, alpha2, alpha3 + real :: rho, sqrt_rho + real :: gradient1, gradient2 + real :: x1, x2 + real :: hNeglect + + hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect ! ----- Left boundary (TOP) ----- i0 = 1 @@ -579,7 +595,7 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff ! Compute real slope and express it w.r.t. local coordinate system ! within boundary cell - slope = 2.0 * ( u1 - u0 ) / ( ( h0 + h1 ) + h_neglect ) + slope = 2.0 * ( u1 - u0 ) / ( ( h0 + h1 ) + hNeglect ) slope = slope * h0 ! The right edge value and slope of the boundary cell are taken to be the @@ -588,12 +604,12 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff b = ppoly_coefficients(i1,2) u0_r = a ! edge value - u1_r = b / (h1 + h_neglect) ! edge slope (w.r.t. global coord.) + u1_r = b / (h1 + hNeglect) ! edge slope (w.r.t. global coord.) ! Compute coefficient for rational function based on mean and right ! edge value and slope if (u1_r.ne.0.) then ! HACK by AJA - beta = 2.0 * ( u0_r - um ) / ( (h0 + h_neglect)*u1_r) - 1.0 + beta = 2.0 * ( u0_r - um ) / ( (h0 + hNeglect)*u1_r) - 1.0 else beta = 0. endif ! HACK by AJA @@ -612,10 +628,10 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff ! compute corresponding slope. if ( abs(um-u0_l) .lt. abs(um-u_plm) ) then u1_l = 2.0 * ( br - ar*beta) - u1_l = u1_l / (h0 + h_neglect) + u1_l = u1_l / (h0 + hNeglect) else u0_l = u_plm - u1_l = slope / (h0 + h_neglect) + u1_l = slope / (h0 + hNeglect) end if ! Monotonize quartic @@ -673,8 +689,8 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff ! We modify the edge slopes so that both inflexion points ! collapse onto the left edge - u1_l = ( 10.0 * um - 2.0 * u0_r - 8.0 * u0_l ) / (3.0*h0 + h_neglect) - u1_r = ( -10.0 * um + 6.0 * u0_r + 4.0 * u0_l ) / (h0 + h_neglect) + u1_l = ( 10.0 * um - 2.0 * u0_r - 8.0 * u0_l ) / (3.0*h0 + hNeglect) + u1_r = ( -10.0 * um + 6.0 * u0_r + 4.0 * u0_l ) / (h0 + hNeglect) ! One of the modified slopes might be inconsistent. When that happens, ! the inconsistent slope is set equal to zero and the opposite edge value @@ -684,13 +700,13 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff u1_l = 0.0 u0_r = 5.0 * um - 4.0 * u0_l - u1_r = 20.0 * (um - u0_l) / ( h0 + h_neglect ) + u1_r = 20.0 * (um - u0_l) / ( h0 + hNeglect ) else if ( u1_r * slope .LT. 0.0 ) then u1_r = 0.0 u0_l = (5.0*um - 3.0*u0_r) / 2.0 - u1_l = 10.0 * (-um + u0_r) / (3.0 * h0 + h_neglect ) + u1_l = 10.0 * (-um + u0_r) / (3.0 * h0 + hNeglect ) end if diff --git a/src/ALE/coord_hycom.F90 b/src/ALE/coord_hycom.F90 index 64189869c7..b3d2ba3238 100644 --- a/src/ALE/coord_hycom.F90 +++ b/src/ALE/coord_hycom.F90 @@ -93,20 +93,30 @@ subroutine set_hycom_params(CS, max_interface_depths, max_layer_thickness, inter end subroutine set_hycom_params !> Build a HyCOM coordinate column -subroutine build_hycom1_column(CS, eqn_of_state, nz, depth, h, T, S, p_col, z_col, z_col_new) +subroutine build_hycom1_column(CS, eqn_of_state, nz, depth, h, T, S, p_col, & + z_col, z_col_new, zScale, h_neglect, h_neglect_edge) type(hycom_CS), intent(in) :: CS !< Coordinate control structure type(EOS_type), pointer :: eqn_of_state !< Equation of state structure integer, intent(in) :: nz !< Number of levels real, intent(in) :: depth !< Depth of ocean bottom (positive in H) real, dimension(nz), intent(in) :: T, S !< T and S for column - real, dimension(nz), intent(in) :: h !< Layer thicknesses, in m + real, dimension(nz), intent(in) :: h !< Layer thicknesses, (in m or H) real, dimension(nz), intent(in) :: p_col !< Layer pressure in Pa real, dimension(nz+1), intent(in) :: z_col ! Interface positions relative to the surface in H units (m or kg m-2) real, dimension(nz+1), intent(inout) :: z_col_new !< Absolute positions of interfaces + real, optional, intent(in) :: zScale !< Scaling factor from the input thicknesses in m + !! to desired units for zInterface, perhaps m_to_H. + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions + !! in the same units as h. + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width + !! for the purpose of edge value calculations + !! in the same units as h0. ! Local variables integer :: k real, dimension(nz) :: rho_col, h_col_new ! Layer quantities + real :: z_scale real :: stretching ! z* stretching, converts z* to z. real :: nominal_z ! Nominal depth of interface is using z* (m or Pa) real :: hNew @@ -116,6 +126,8 @@ subroutine build_hycom1_column(CS, eqn_of_state, nz, depth, h, T, S, p_col, z_co maximum_depths_set = allocated(CS%max_interface_depths) maximum_h_set = allocated(CS%max_layer_thickness) + z_scale = 1.0 ; if (present(zScale)) z_scale = zScale + ! Work bottom recording potential density call calculate_density(T, S, p_col, rho_col, 1, nz, eqn_of_state) ! This ensures the potential density profile is monotonic @@ -127,14 +139,14 @@ subroutine build_hycom1_column(CS, eqn_of_state, nz, depth, h, T, S, p_col, z_co ! Interpolates for the target interface position with the rho_col profile ! Based on global density profile, interpolate to generate a new grid call build_and_interpolate_grid(CS%interp_CS, rho_col, nz, h(:), z_col, & - CS%target_density, nz, h_col_new, z_col_new) + CS%target_density, nz, h_col_new, z_col_new, h_neglect, h_neglect_edge) ! Sweep down the interfaces and make sure that the interface is at least ! as deep as a nominal target z* grid nominal_z = 0. stretching = z_col(nz+1) / depth ! Stretches z* to z do k = 2, nz+1 - nominal_z = nominal_z + CS%coordinateResolution(k-1) * stretching + nominal_z = nominal_z + (z_scale * CS%coordinateResolution(k-1)) * stretching z_col_new(k) = max( z_col_new(k), nominal_z ) z_col_new(k) = min( z_col_new(k), z_col(nz+1) ) enddo diff --git a/src/ALE/coord_rho.F90 b/src/ALE/coord_rho.F90 index c7e8007d26..bee6832f77 100644 --- a/src/ALE/coord_rho.F90 +++ b/src/ALE/coord_rho.F90 @@ -38,7 +38,6 @@ module coord_rho integer, parameter :: NB_REGRIDDING_ITERATIONS = 1 !> Deviation tolerance between succesive grids in regridding iterations real, parameter :: DEVIATION_TOLERANCE = 1e-10 -! This CPP macro embeds some safety checks public init_coord_rho, set_rho_params, build_rho_column, old_inflate_layers_1d, end_coord_rho @@ -88,15 +87,23 @@ end subroutine set_rho_params !! !! 1. Density profiles are calculated on the source grid. !! 2. Positions of target densities (for interfaces) are found by interpolation. -subroutine build_rho_column(CS, nz, depth, h, T, S, eqn_of_state, z_interface) - type(rho_CS), intent(in) :: CS !< coord_rho control structure - integer, intent(in) :: nz !< Number of levels on source grid (i.e. length of h, T, S) - real, intent(in) :: depth !< Depth of ocean bottom (positive in m) - real, dimension(nz), intent(in) :: h !< Layer thicknesses, in m - real, dimension(nz), intent(in) :: T !< T for source column - real, dimension(nz), intent(in) :: S !< S for source column - type(EOS_type), pointer :: eqn_of_state !< Equation of state structure - real, dimension(CS%nk+1), intent(inout) :: z_interface !< Absolute positions of interfaces +subroutine build_rho_column(CS, nz, depth, h, T, S, eqn_of_state, z_interface, & + h_neglect, h_neglect_edge) + type(rho_CS), intent(in) :: CS !< coord_rho control structure + integer, intent(in) :: nz !< Number of levels on source grid (i.e. length of h, T, S) + real, intent(in) :: depth !< Depth of ocean bottom (positive in m) + real, dimension(nz), intent(in) :: h !< Layer thicknesses, in H + real, dimension(nz), intent(in) :: T !< T for source column + real, dimension(nz), intent(in) :: S !< S for source column + type(EOS_type), pointer :: eqn_of_state !< Equation of state structure + real, dimension(CS%nk+1), & + intent(inout) :: z_interface !< Absolute positions of interfaces + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions + !! in the same units as h0. + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width + !! for the purpose of edge value calculations + !! in the same units as h0. ! Local variables integer :: k, count_nonzero_layers integer, dimension(nz) :: mapping @@ -123,7 +130,8 @@ subroutine build_rho_column(CS, nz, depth, h, T, S, eqn_of_state, z_interface) ! Based on source column density profile, interpolate to generate a new grid call build_and_interpolate_grid(CS%interp_CS, densities, count_nonzero_layers, & - h_nv, xTmp, CS%target_density, CS%nk, h_new, x1) + h_nv, xTmp, CS%target_density, CS%nk, h_new, & + x1, h_neglect, h_neglect_edge) ! Inflate vanished layers call old_inflate_layers_1d(CS%min_thickness, CS%nk, h_new) @@ -160,8 +168,9 @@ subroutine build_rho_column(CS, nz, depth, h, T, S, eqn_of_state, z_interface) end subroutine build_rho_column -subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_state, zInterface) - !< Iteratively uild a rho coordinate column +subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_state, & + zInterface, h_neglect, h_neglect_edge) + !< Iteratively build a rho coordinate column !! !! The algorithm operates as follows within each column: !! @@ -182,6 +191,12 @@ subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_ real, dimension(nz), intent(in) :: T, S !< T and S for column type(EOS_type), pointer :: eqn_of_state !< Equation of state structure real, dimension(nz+1), intent(inout) :: zInterface !< Absolute positions of interfaces + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions + !! in the same units as h + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width + !! for the purpose of edge value calculations + !! in the same units as h ! Local variables integer :: k, m @@ -230,7 +245,7 @@ subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_ ! One regridding iteration ! Based on global density profile, interpolate to generate a new grid call build_and_interpolate_grid(CS%interp_CS, densities, count_nonzero_layers, & - hTmp, xTmp, CS%target_density, nz, h1, x1) + hTmp, xTmp, CS%target_density, nz, h1, x1, h_neglect, h_neglect_edge) call old_inflate_layers_1d( CS%min_thickness, nz, h1 ) x1(1) = 0.0 ; do k = 1,nz ; x1(k+1) = x1(k) + h1(k) ; end do @@ -240,10 +255,10 @@ subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_ h1(k) = x1(k+1) - x1(k) end do - call remapping_core_h(remapCS, nz, h0, S, nz, h1, Tmp) + call remapping_core_h(remapCS, nz, h0, S, nz, h1, Tmp, h_neglect, h_neglect_edge) S_tmp(:) = Tmp(:) - call remapping_core_h(remapCS, nz, h0, T, nz, h1, Tmp) + call remapping_core_h(remapCS, nz, h0, T, nz, h1, Tmp, h_neglect, h_neglect_edge) T_tmp(:) = Tmp(:) ! Compute the deviation between two successive grids diff --git a/src/ALE/coord_slight.F90 b/src/ALE/coord_slight.F90 index da8bde731d..93f5b9c393 100644 --- a/src/ALE/coord_slight.F90 +++ b/src/ALE/coord_slight.F90 @@ -150,7 +150,8 @@ end subroutine set_slight_params !> Build a SLight coordinate column subroutine build_slight_column(CS, eqn_of_state, H_to_Pa, m_to_H, H_subroundoff, & - nz, depth, h_col, T_col, S_col, p_col, z_col, z_col_new) + nz, depth, h_col, T_col, S_col, p_col, z_col, z_col_new, & + h_neglect, h_neglect_edge) type(slight_CS), intent(in) :: CS !< Coordinate control structure type(EOS_type), pointer :: eqn_of_state !< Equation of state structure real, intent(in) :: H_to_Pa !< GV%H_to_Pa @@ -163,6 +164,12 @@ subroutine build_slight_column(CS, eqn_of_state, H_to_Pa, m_to_H, H_subroundoff, real, dimension(nz), intent(in) :: p_col !< Layer quantities real, dimension(nz+1), intent(in) :: z_col !< Interface positions relative to the surface in H units (m or kg m-2) real, dimension(nz+1), intent(inout) :: z_col_new !< Absolute positions of interfaces + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions + !! in the same units as h_col. + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width + !! for the purpose of edge value calculations + !! in the same units as h_col. ! Local variables real, dimension(nz) :: rho_col ! Layer quantities @@ -214,7 +221,8 @@ subroutine build_slight_column(CS, eqn_of_state, H_to_Pa, m_to_H, H_subroundoff, ! Find the locations of the target potential densities, flagging ! locations in apparently unstable regions as not reliable. call rho_interfaces_col(rho_col, h_col, z_col, CS%target_density, nz, & - z_col_new, CS, reliable, debug=.true.) + z_col_new, CS, reliable, debug=.true., & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) ! Ensure that the interfaces are at least CS%min_thickness apart. if (CS%min_thickness > 0.0) then @@ -443,7 +451,7 @@ end subroutine build_slight_column !> Finds the new interface locations in a column of water that match the !! prescribed target densities. subroutine rho_interfaces_col(rho_col, h_col, z_col, rho_tgt, nz, z_col_new, & - CS, reliable, debug) + CS, reliable, debug, h_neglect, h_neglect_edge) integer, intent(in) :: nz !< Number of layers real, dimension(nz), intent(in) :: rho_col !< Initial layer reference densities. real, dimension(nz), intent(in) :: h_col !< Initial layer thicknesses. @@ -453,7 +461,13 @@ subroutine rho_interfaces_col(rho_col, h_col, z_col, rho_tgt, nz, z_col_new, & type(slight_CS), intent(in) :: CS !< Coordinate control structure logical, dimension(nz+1), intent(inout) :: reliable !< If true, the interface positions !! are well defined from a stable region. - logical, optional, intent(in) :: debug !< If present and true, do debugging checks. + logical, optional, intent(in) :: debug !< If present and true, do debugging checks. + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions + !! in the same units as h_col. + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width + !! for the purpose of edge value calculations + !! in the same units as h_col. real, dimension(nz+1) :: ru_max_int ! The maximum and minimum densities in real, dimension(nz+1) :: ru_min_int ! an unstable region around an interface. @@ -500,7 +514,7 @@ subroutine rho_interfaces_col(rho_col, h_col, z_col, rho_tgt, nz, z_col_new, & ! This sets up the piecewise polynomials based on the rho_col profile. call regridding_set_ppolys(CS%interp_CS, rho_col, nz, h_col, ppoly_i_E, ppoly_i_S, & - ppoly_i_coefficients, ppoly_degree) + ppoly_i_coefficients, ppoly_degree, h_neglect, h_neglect_edge) ! Determine the density ranges of unstably stratified segments. ! Interfaces that start out in an unstably stratified segment can diff --git a/src/ALE/regrid_edge_slopes.F90 b/src/ALE/regrid_edge_slopes.F90 index c6b438a0ac..f8781aa937 100644 --- a/src/ALE/regrid_edge_slopes.F90 +++ b/src/ALE/regrid_edge_slopes.F90 @@ -23,15 +23,15 @@ module regrid_edge_slopes public edge_slopes_implicit_h3 public edge_slopes_implicit_h5 -real, parameter :: h_neglect = 1.E-30 +! Specifying a dimensional parameter value, as is done here, is a terrible idea. +real, parameter :: hNeglect_dflt = 1.E-30 contains !------------------------------------------------------------------------------ -! Compute ih4 edge slopes (implicit third order accurate) -!------------------------------------------------------------------------------ -subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes ) +!> Compute ih4 edge slopes (implicit third order accurate) +subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect ) ! ----------------------------------------------------------------------------- ! Compute edge slopes based on third-order implicit estimates. Note that ! the estimates are fourth-order accurate on uniform grids @@ -59,10 +59,13 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes ) ! ----------------------------------------------------------------------------- ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell averages (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: edge_slopes + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell average properties (size N) + real, dimension(:,:), intent(inout) :: edge_slopes !< Returned edge slopes, with the + !! same units as u divided by the units of h. + real, optional, intent(in) :: h_neglect !< A negligibly small width + !! in the same units as h. ! Local variables integer :: i, j ! loop indexes @@ -81,6 +84,11 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes ) tri_u, & ! trid. system (upper diagonal) tri_b, & ! trid. system (unknowns vector) tri_x ! trid. system (rhs) + real :: hNeglect ! A negligible thicness in the same units as h. + real :: hNeglect3 ! hNeglect^3 in the same units as h^3. + + hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect + hNeglect3 = hNeglect**3 ! Loop on cells (except last one) do i = 1,N-1 @@ -99,9 +107,9 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes ) d = 4.0 * h0h1 * ( h0 + h1 ) + h1_3 + h0_3 ! Coefficients - alpha = h1 * (h0_2 + h0h1 - h1_2) / ( d + h_neglect ) - beta = h0 * (h1_2 + h0h1 - h0_2) / ( d + h_neglect ) - a = -12.0 * h0h1 / ( d + h_neglect ) + alpha = h1 * (h0_2 + h0h1 - h1_2) / ( d + hNeglect3 ) + beta = h0 * (h1_2 + h0h1 - h0_2) / ( d + hNeglect3 ) + a = -12.0 * h0h1 / ( d + hNeglect3 ) b = -a tri_l(i+1) = alpha @@ -178,9 +186,8 @@ end subroutine edge_slopes_implicit_h3 !------------------------------------------------------------------------------ -! Compute ih5 edge values (implicit fifth order accurate) -!------------------------------------------------------------------------------ -subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes ) +!> Compute ih5 edge values (implicit fifth order accurate) +subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect ) ! ----------------------------------------------------------------------------- ! Fifth-order implicit estimates of edge values are based on a four-cell, ! three-edge stencil. A tridiagonal system is set up and is based on @@ -215,10 +222,13 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes ) ! ----------------------------------------------------------------------------- ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell averages (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: edge_slopes + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell average properties (size N) + real, dimension(:,:), intent(inout) :: edge_slopes !< Returned edge slopes, with the + !! same units as u divided by the units of h. + real, optional, intent(in) :: h_neglect !< A negligibly small width + !! in the same units as h. ! Local variables integer :: i, j, k ! loop indexes @@ -247,6 +257,9 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes ) tri_u, & ! trid. system (upper diagonal) tri_b, & ! trid. system (unknowns vector) tri_x ! trid. system (rhs) + real :: hNeglect ! A negligible thicness in the same units as h. + + hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect ! Loop on cells (except last one) do k = 2,N-2 @@ -277,11 +290,11 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes ) g_5 = g_4 * g g_6 = g_3 * g_3 - d2 = ( h1_2 - g_2 ) / ( h0 + h_neglect ) - d3 = ( h1_3 - g_3 ) / ( h0 + h_neglect ) - d4 = ( h1_4 - g_4 ) / ( h0 + h_neglect ) - d5 = ( h1_5 - g_5 ) / ( h0 + h_neglect ) - d6 = ( h1_6 - g_6 ) / ( h0 + h_neglect ) + d2 = ( h1_2 - g_2 ) / ( h0 + hNeglect ) + d3 = ( h1_3 - g_3 ) / ( h0 + hNeglect ) + d4 = ( h1_4 - g_4 ) / ( h0 + hNeglect ) + d5 = ( h1_5 - g_5 ) / ( h0 + hNeglect ) + d6 = ( h1_6 - g_6 ) / ( h0 + hNeglect ) g = h2 + h3 g_2 = g * g @@ -290,11 +303,11 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes ) g_5 = g_4 * g g_6 = g_3 * g_3 - n2 = ( g_2 - h2_2 ) / ( h3 + h_neglect ) - n3 = ( g_3 - h2_3 ) / ( h3 + h_neglect ) - n4 = ( g_4 - h2_4 ) / ( h3 + h_neglect ) - n5 = ( g_5 - h2_5 ) / ( h3 + h_neglect ) - n6 = ( g_6 - h2_6 ) / ( h3 + h_neglect ) + n2 = ( g_2 - h2_2 ) / ( h3 + hNeglect ) + n3 = ( g_3 - h2_3 ) / ( h3 + hNeglect ) + n4 = ( g_4 - h2_4 ) / ( h3 + hNeglect ) + n5 = ( g_5 - h2_5 ) / ( h3 + hNeglect ) + n6 = ( g_6 - h2_6 ) / ( h3 + hNeglect ) ! Compute matrix entries Asys(1,1) = 0.0 @@ -390,11 +403,11 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes ) h0ph1_3 = h0ph1_2 * h0ph1 h0ph1_4 = h0ph1_2 * h0ph1_2 - d2 = ( h1_2 - g_2 ) / ( h0 + h_neglect ) - d3 = ( h1_3 - g_3 ) / ( h0 + h_neglect ) - d4 = ( h1_4 - g_4 ) / ( h0 + h_neglect ) - d5 = ( h1_5 - g_5 ) / ( h0 + h_neglect ) - d6 = ( h1_6 - g_6 ) / ( h0 + h_neglect ) + d2 = ( h1_2 - g_2 ) / ( h0 + hNeglect ) + d3 = ( h1_3 - g_3 ) / ( h0 + hNeglect ) + d4 = ( h1_4 - g_4 ) / ( h0 + hNeglect ) + d5 = ( h1_5 - g_5 ) / ( h0 + hNeglect ) + d6 = ( h1_6 - g_6 ) / ( h0 + hNeglect ) g = h2 + h3 g_2 = g * g @@ -403,11 +416,11 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes ) g_5 = g_4 * g g_6 = g_3 * g_3 - n2 = ( g_2 - h2_2 ) / ( h3 + h_neglect ) - n3 = ( g_3 - h2_3 ) / ( h3 + h_neglect ) - n4 = ( g_4 - h2_4 ) / ( h3 + h_neglect ) - n5 = ( g_5 - h2_5 ) / ( h3 + h_neglect ) - n6 = ( g_6 - h2_6 ) / ( h3 + h_neglect ) + n2 = ( g_2 - h2_2 ) / ( h3 + hNeglect ) + n3 = ( g_3 - h2_3 ) / ( h3 + hNeglect ) + n4 = ( g_4 - h2_4 ) / ( h3 + hNeglect ) + n5 = ( g_5 - h2_5 ) / ( h3 + hNeglect ) + n6 = ( g_6 - h2_6 ) / ( h3 + hNeglect ) ! Compute matrix entries Asys(1,1) = 0.0 @@ -530,11 +543,11 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes ) h2ph3_3 = h2ph3_2 * h2ph3 h2ph3_4 = h2ph3_2 * h2ph3_2 - d2 = ( h1_2 - g_2 ) / ( h0 + h_neglect ) - d3 = ( h1_3 - g_3 ) / ( h0 + h_neglect ) - d4 = ( h1_4 - g_4 ) / ( h0 + h_neglect ) - d5 = ( h1_5 - g_5 ) / ( h0 + h_neglect ) - d6 = ( h1_6 - g_6 ) / ( h0 + h_neglect ) + d2 = ( h1_2 - g_2 ) / ( h0 + hNeglect ) + d3 = ( h1_3 - g_3 ) / ( h0 + hNeglect ) + d4 = ( h1_4 - g_4 ) / ( h0 + hNeglect ) + d5 = ( h1_5 - g_5 ) / ( h0 + hNeglect ) + d6 = ( h1_6 - g_6 ) / ( h0 + hNeglect ) g = h2 + h3 g_2 = g * g @@ -543,11 +556,11 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes ) g_5 = g_4 * g g_6 = g_3 * g_3 - n2 = ( g_2 - h2_2 ) / ( h3 + h_neglect ) - n3 = ( g_3 - h2_3 ) / ( h3 + h_neglect ) - n4 = ( g_4 - h2_4 ) / ( h3 + h_neglect ) - n5 = ( g_5 - h2_5 ) / ( h3 + h_neglect ) - n6 = ( g_6 - h2_6 ) / ( h3 + h_neglect ) + n2 = ( g_2 - h2_2 ) / ( h3 + hNeglect ) + n3 = ( g_3 - h2_3 ) / ( h3 + hNeglect ) + n4 = ( g_4 - h2_4 ) / ( h3 + hNeglect ) + n5 = ( g_5 - h2_5 ) / ( h3 + hNeglect ) + n6 = ( g_6 - h2_6 ) / ( h3 + hNeglect ) ! Compute matrix entries Asys(1,1) = 0.0 diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index c3035e36d2..fafb873a6c 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -33,15 +33,19 @@ module regrid_edge_values ! extrapolation. The are needed only in the case where thicknesses vanish ! to a small enough values such that the eigenvalues of the matrix can not ! be separated. -real, parameter :: hNegligible = 1.e-10 ! A cut-off minimum thickness for sum(h) -real, parameter :: hMinFrac = 1.e-5 ! A minimum fraction for min(h)/(sum(h) +! Specifying a dimensional parameter value, as is done here, is a terrible idea. +real, parameter :: hNeglect_edge_dflt = 1.e-10 ! The default value for cut-off minimum + ! thickness for sum(h) in edge value inversions +real, parameter :: hNeglect_dflt = 1.e-30 ! The default value for cut-off minimum + ! thickness for sum(h) in other calculations +real, parameter :: hMinFrac = 1.e-5 ! A minimum fraction for min(h)/sum(h) contains !------------------------------------------------------------------------------ ! Bound edge values by neighboring cell averages !------------------------------------------------------------------------------ -subroutine bound_edge_values( N, h, u, edge_values ) +subroutine bound_edge_values( N, h, u, edge_values, h_neglect ) ! ------------------------------------------------------------------------------ ! In this routine, we loop on all cells to bound their left and right ! edge values by the cell averages. That is, the left edge value must lie @@ -54,10 +58,13 @@ subroutine bound_edge_values( N, h, u, edge_values ) ! ------------------------------------------------------------------------------ ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell widths (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: edge_values + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell average properties (size N) + real, dimension(:,:), intent(inout) :: edge_values !< Potentially modified edge values, + !! with the same units as u. + real, optional, intent(in) :: h_neglect !< A negligibly small width + !! in the same units as h. ! Local variables integer :: k ! loop index @@ -69,6 +76,9 @@ subroutine bound_edge_values( N, h, u, edge_values ) ! van Leer slopes real :: slope ! retained PLM slope + real :: hNeglect ! A negligible thicness in the same units as h. + + hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect ! Loop on cells to bound edge value do k = 1,N @@ -104,9 +114,9 @@ subroutine bound_edge_values( N, h, u, edge_values ) u0_l = edge_values(k,1) u0_r = edge_values(k,2) - sigma_l = 2.0 * ( u_c - u_l ) / ( h_c + 1.E-30 ) - sigma_c = 2.0 * ( u_r - u_l ) / ( h_l + 2.0*h_c + h_r + 1.E-30 ) - sigma_r = 2.0 * ( u_r - u_c ) / ( h_c + 1.E-30 ) + sigma_l = 2.0 * ( u_c - u_l ) / ( h_c + hNeglect ) + sigma_c = 2.0 * ( u_r - u_l ) / ( h_l + 2.0*h_c + h_r + hNeglect ) + sigma_r = 2.0 * ( u_r - u_c ) / ( h_c + hNeglect ) if ( (sigma_l * sigma_r) .GT. 0.0 ) then slope = sign( min(abs(sigma_l),abs(sigma_c),abs(sigma_r)), sigma_c ) @@ -230,9 +240,8 @@ end subroutine check_discontinuous_edge_values !------------------------------------------------------------------------------ -! Compute h2 edge values (explicit second order accurate) -!------------------------------------------------------------------------------ -subroutine edge_values_explicit_h2( N, h, u, edge_values ) +!> Compute h2 edge values (explicit second order accurate) +subroutine edge_values_explicit_h2( N, h, u, edge_values, h_neglect ) ! ------------------------------------------------------------------------------ ! Compute edge values based on second-order explicit estimates. ! These estimates are based on a straight line spanning two cells and evaluated @@ -247,15 +256,21 @@ subroutine edge_values_explicit_h2( N, h, u, edge_values ) ! ------------------------------------------------------------------------------ ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell widths (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: edge_values + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell average properties (size N) + real, dimension(:,:), intent(inout) :: edge_values !< Returned edge values, with the + !! same units as u; the second index size is 2. + real, optional, intent(in) :: h_neglect !< A negligibly small width + !! in the same units as h. ! Local variables integer :: k ! loop index real :: h0, h1 ! cell widths real :: u0, u1 ! cell averages + real :: hNeglect ! A negligible thicness in the same units as h. + + hNeglect = hNeglect_edge_dflt ; if (present(h_neglect)) hNeglect = h_neglect ! Loop on interior cells do k = 2,N @@ -265,8 +280,8 @@ subroutine edge_values_explicit_h2( N, h, u, edge_values ) ! Avoid singularities when h0+h1=0 if (h0+h1==0.) then - h0 = hNegligible - h1 = hNegligible + h0 = hNeglect + h1 = hNeglect endif u0 = u(k-1) @@ -289,9 +304,8 @@ end subroutine edge_values_explicit_h2 !------------------------------------------------------------------------------ -! Compute h4 edge values (explicit fourth order accurate) -!------------------------------------------------------------------------------ -subroutine edge_values_explicit_h4( N, h, u, edge_values ) +!> Compute h4 edge values (explicit fourth order accurate) +subroutine edge_values_explicit_h4( N, h, u, edge_values, h_neglect ) ! ----------------------------------------------------------------------------- ! Compute edge values based on fourth-order explicit estimates. ! These estimates are based on a cubic interpolant spanning four cells @@ -312,10 +326,13 @@ subroutine edge_values_explicit_h4( N, h, u, edge_values ) ! ----------------------------------------------------------------------------- ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell widths (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: edge_values + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell average properties (size N) + real, dimension(:,:), intent(inout) :: edge_values !< Returned edge values, with the + !! same units as u; the second index size is 2. + real, optional, intent(in) :: h_neglect !< A negligibly small width + !! in the same units as h. ! Local variables integer :: i, j @@ -326,6 +343,9 @@ subroutine edge_values_explicit_h4( N, h, u, edge_values ) real, dimension(5) :: x ! used to compute edge real, dimension(4,4) :: A ! values near the boundaries real, dimension(4) :: B, C + real :: hNeglect ! A negligible thicness in the same units as h. + + hNeglect = hNeglect_edge_dflt ; if (present(h_neglect)) hNeglect = h_neglect ! Loop on interior cells do i = 3,N-1 @@ -337,7 +357,7 @@ subroutine edge_values_explicit_h4( N, h, u, edge_values ) ! Avoid singularities when consecutive pairs of h vanish if (h0+h1==0. .or. h1+h2==0. .or. h2+h3==0.) then - f1 = max( hNegligible, h0+h1+h2+h3 ) + f1 = max( hNeglect, h0+h1+h2+h3 ) h0 = max( hMinFrac*f1, h(i-2) ) h1 = max( hMinFrac*f1, h(i-1) ) h2 = max( hMinFrac*f1, h(i) ) @@ -383,7 +403,7 @@ subroutine edge_values_explicit_h4( N, h, u, edge_values ) end do ! end loop on interior cells ! Determine first two edge values - f1 = max( hNegligible, hMinFrac*sum(h(1:4)) ) + f1 = max( hNeglect, hMinFrac*sum(h(1:4)) ) x(1) = 0.0 do i = 2,5 x(i) = x(i-1) + max(f1, h(i-1)) @@ -421,7 +441,7 @@ subroutine edge_values_explicit_h4( N, h, u, edge_values ) #endif ! Determine last two edge values - f1 = max( hNegligible, hMinFrac*sum(h(N-3:N)) ) + f1 = max( hNeglect, hMinFrac*sum(h(N-3:N)) ) x(1) = 0.0 do i = 2,5 x(i) = x(i-1) + max(f1, h(N-5+i)) @@ -469,9 +489,8 @@ end subroutine edge_values_explicit_h4 !------------------------------------------------------------------------------ -! Compute ih4 edge values (implicit fourth order accurate) -!------------------------------------------------------------------------------ -subroutine edge_values_implicit_h4( N, h, u, edge_values ) +!> Compute ih4 edge values (implicit fourth order accurate) +subroutine edge_values_implicit_h4( N, h, u, edge_values, h_neglect ) ! ----------------------------------------------------------------------------- ! Compute edge values based on fourth-order implicit estimates. ! @@ -497,10 +516,13 @@ subroutine edge_values_implicit_h4( N, h, u, edge_values ) ! ----------------------------------------------------------------------------- ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell widths (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: edge_values + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell average properties (size N) + real, dimension(:,:), intent(inout) :: edge_values !< Returned edge values, with the + !! same units as u; the second index size is 2. + real, optional, intent(in) :: h_neglect !< A negligibly small width + !! in the same units as h. ! Local variables integer :: i, j ! loop indexes @@ -517,6 +539,9 @@ subroutine edge_values_implicit_h4( N, h, u, edge_values ) tri_u, & ! trid. system (upper diagonal) tri_b, & ! trid. system (unknowns vector) tri_x ! trid. system (rhs) + real :: hNeglect ! A negligible thicness in the same units as h. + + hNeglect = hNeglect_edge_dflt ; if (present(h_neglect)) hNeglect = h_neglect ! Loop on cells (except last one) do i = 1,N-1 @@ -527,8 +552,8 @@ subroutine edge_values_implicit_h4( N, h, u, edge_values ) ! Avoid singularities when h0+h1=0 if (h0+h1==0.) then - h0 = hNegligible - h1 = hNegligible + h0 = hNeglect + h1 = hNeglect endif ! Auxiliary calculations @@ -553,7 +578,7 @@ subroutine edge_values_implicit_h4( N, h, u, edge_values ) end do ! end loop on cells ! Boundary conditions: left boundary - h0 = max( hNegligible, hMinFrac*sum(h(1:4)) ) + h0 = max( hNeglect, hMinFrac*sum(h(1:4)) ) x(1) = 0.0 do i = 2,5 x(i) = x(i-1) + max( h0, h(i-1) ) @@ -576,7 +601,7 @@ subroutine edge_values_implicit_h4( N, h, u, edge_values ) tri_b(1) = evaluation_polynomial( Csys, 4, x(1) ) ! first edge value ! Boundary conditions: right boundary - h0 = max( hNegligible, hMinFrac*sum(h(N-3:N)) ) + h0 = max( hNeglect, hMinFrac*sum(h(N-3:N)) ) x(1) = 0.0 do i = 2,5 x(i) = x(i-1) + max( h0, h(N-5+i) ) @@ -612,9 +637,8 @@ end subroutine edge_values_implicit_h4 !------------------------------------------------------------------------------ -! Compute ih6 edge values (implicit sixth order accurate) -!------------------------------------------------------------------------------ -subroutine edge_values_implicit_h6( N, h, u, edge_values ) +!> Compute ih6 edge values (implicit sixth order accurate) +subroutine edge_values_implicit_h6( N, h, u, edge_values, h_neglect ) ! ----------------------------------------------------------------------------- ! Sixth-order implicit estimates of edge values are based on a four-cell, ! three-edge stencil. A tridiagonal system is set up and is based on @@ -649,10 +673,13 @@ subroutine edge_values_implicit_h6( N, h, u, edge_values ) ! ----------------------------------------------------------------------------- ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell widths (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: edge_values + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell average properties (size N) + real, dimension(:,:), intent(inout) :: edge_values !< Returned edge values, with the + !! same units as u; the second index size is 2. + real, optional, intent(in) :: h_neglect !< A negligibly small width + !! in the same units as h. ! Local variables integer :: i, j, k ! loop indexes @@ -681,6 +708,9 @@ subroutine edge_values_implicit_h6( N, h, u, edge_values ) tri_u, & ! trid. system (upper diagonal) tri_b, & ! trid. system (unknowns vector) tri_x ! trid. system (rhs) + real :: hNeglect ! A negligible thicness in the same units as h. + + hNeglect = hNeglect_edge_dflt ; if (present(h_neglect)) hNeglect = h_neglect ! Loop on cells (except last one) do k = 2,N-2 @@ -693,7 +723,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_values ) ! Avoid singularities when h0=0 or h3=0 if (h0*h3==0.) then - g = max( hNegligible, h0+h1+h2+h3 ) + g = max( hNeglect, h0+h1+h2+h3 ) h0 = max( hMinFrac*g, h0 ) h1 = max( hMinFrac*g, h1 ) h2 = max( hMinFrac*g, h2 ) @@ -810,7 +840,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_values ) ! Avoid singularities when h0=0 or h3=0 if (h0*h3==0.) then - g = max( hNegligible, h0+h1+h2+h3 ) + g = max( hNeglect, h0+h1+h2+h3 ) h0 = max( hMinFrac*g, h0 ) h1 = max( hMinFrac*g, h1 ) h2 = max( hMinFrac*g, h2 ) @@ -922,7 +952,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_values ) tri_b(2) = a * u(1) + b * u(2) + c * u(3) + d * u(4) ! Boundary conditions: left boundary - g = max( hNegligible, hMinFrac*sum(h(1:6)) ) + g = max( hNeglect, hMinFrac*sum(h(1:6)) ) x(1) = 0.0 do i = 2,7 x(i) = x(i-1) + max( g, h(i-1) ) @@ -955,7 +985,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_values ) ! Avoid singularities when h0=0 or h3=0 if (h0*h3==0.) then - g = max( hNegligible, h0+h1+h2+h3 ) + g = max( hNeglect, h0+h1+h2+h3 ) h0 = max( hMinFrac*g, h0 ) h1 = max( hMinFrac*g, h1 ) h2 = max( hMinFrac*g, h2 ) @@ -1067,7 +1097,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_values ) tri_b(N) = a * u(N-3) + b * u(N-2) + c * u(N-1) + d * u(N) ! Boundary conditions: right boundary - g = max( hNegligible, hMinFrac*sum(h(N-5:N)) ) + g = max( hNeglect, hMinFrac*sum(h(N-5:N)) ) x(1) = 0.0 do i = 2,7 x(i) = x(i-1) + max( g, h(N-7+i) ) diff --git a/src/ALE/regrid_interp.F90 b/src/ALE/regrid_interp.F90 index 8495b48791..6858e0cded 100644 --- a/src/ALE/regrid_interp.F90 +++ b/src/ALE/regrid_interp.F90 @@ -71,22 +71,28 @@ module regrid_interp !! a third-order PPM ih4 scheme). In these cases, we resort to the simplest !! continuous linear scheme (P1M h2). subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & - ppoly0_coefficients, degree) + ppoly0_coefs, degree, h_neglect, h_neglect_edge) type(interp_CS_type),intent(in) :: CS !< Interpolation control structure real, dimension(:), intent(in) :: densities !< Actual cell densities integer, intent(in) :: n0 !< Number of cells on source grid real, dimension(:), intent(in) :: h0 !< cell widths on source grid - real, dimension(:,:),intent(inout) :: ppoly0_E !< Edge value of polynomial - real, dimension(:,:),intent(inout) :: ppoly0_S !< Edge slope of polynomial - real, dimension(:,:),intent(inout) :: ppoly0_coefficients !< Coefficients of polynomial - integer, intent(inout) :: degree !< The degree of the polynomials + real, dimension(:,:),intent(inout) :: ppoly0_E !< Edge value of polynomial + real, dimension(:,:),intent(inout) :: ppoly0_S !< Edge slope of polynomial + real, dimension(:,:),intent(inout) :: ppoly0_coefs !< Coefficients of polynomial + integer, intent(inout) :: degree !< The degree of the polynomials + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions + !! in the same units as h0. + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width + !! for the purpose of edge value calculations + !! in the same units as h0. logical :: extrapolate ! Reset piecewise polynomials ppoly0_E(:,:) = 0.0 ppoly0_S(:,:) = 0.0 - ppoly0_coefficients(:,:) = 0.0 + ppoly0_coefs(:,:) = 0.0 extrapolate = CS%boundary_extrapolation @@ -95,146 +101,156 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & case ( INTERPOLATION_P1M_H2 ) degree = DEGREE_1 - call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) - call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then - call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) end if case ( INTERPOLATION_P1M_H4 ) degree = DEGREE_1 if ( n0 >= 4 ) then - call edge_values_explicit_h4( n0, h0, densities, ppoly0_E ) + call edge_values_explicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge ) else - call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) + call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) end if - call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then - call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) end if case ( INTERPOLATION_P1M_IH4 ) degree = DEGREE_1 if ( n0 >= 4 ) then - call edge_values_implicit_h4( n0, h0, densities, ppoly0_E ) + call edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge ) else - call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) + call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) end if - call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then - call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) end if case ( INTERPOLATION_PLM ) degree = DEGREE_1 - call PLM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call PLM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then - call PLM_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call PLM_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) end if case ( INTERPOLATION_PPM_H4 ) if ( n0 >= 4 ) then degree = DEGREE_2 - call edge_values_explicit_h4( n0, h0, densities, ppoly0_E ) - call PPM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call edge_values_explicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge ) + call PPM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then - call PPM_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call PPM_boundary_extrapolation( n0, h0, densities, ppoly0_E, & + ppoly0_coefs, h_neglect ) end if else degree = DEGREE_1 - call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) - call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then - call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) end if end if case ( INTERPOLATION_PPM_IH4 ) if ( n0 >= 4 ) then degree = DEGREE_2 - call edge_values_implicit_h4( n0, h0, densities, ppoly0_E ) - call PPM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge ) + call PPM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then - call PPM_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call PPM_boundary_extrapolation( n0, h0, densities, ppoly0_E, & + ppoly0_coefs, h_neglect ) end if else degree = DEGREE_1 - call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) - call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then - call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) end if end if case ( INTERPOLATION_P3M_IH4IH3 ) if ( n0 >= 4 ) then degree = DEGREE_3 - call edge_values_implicit_h4( n0, h0, densities, ppoly0_E ) - call edge_slopes_implicit_h3( n0, h0, densities, ppoly0_S ) - call P3M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_S, ppoly0_coefficients ) + call edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge ) + call edge_slopes_implicit_h3( n0, h0, densities, ppoly0_S, h_neglect ) + call P3M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_S, & + ppoly0_coefs, h_neglect ) if (extrapolate) then - call P3M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_S, ppoly0_coefficients ) + call P3M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_S, & + ppoly0_coefs, h_neglect, h_neglect_edge ) end if else degree = DEGREE_1 - call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) - call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then - call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) end if end if case ( INTERPOLATION_P3M_IH6IH5 ) if ( n0 >= 6 ) then degree = DEGREE_3 - call edge_values_implicit_h6( n0, h0, densities, ppoly0_E ) - call edge_slopes_implicit_h5( n0, h0, densities, ppoly0_S ) - call P3M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_S, ppoly0_coefficients ) + call edge_values_implicit_h6( n0, h0, densities, ppoly0_E, h_neglect_edge ) + call edge_slopes_implicit_h5( n0, h0, densities, ppoly0_S, h_neglect ) + call P3M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_S, & + ppoly0_coefs, h_neglect ) if (extrapolate) then - call P3M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_S, ppoly0_coefficients ) + call P3M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_S, & + ppoly0_coefs, h_neglect, h_neglect_edge ) end if else degree = DEGREE_1 - call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) - call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then - call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) end if end if case ( INTERPOLATION_PQM_IH4IH3 ) if ( n0 >= 4 ) then degree = DEGREE_4 - call edge_values_implicit_h4( n0, h0, densities, ppoly0_E ) - call edge_slopes_implicit_h3( n0, h0, densities, ppoly0_S ) - call PQM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_S, ppoly0_coefficients ) + call edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge ) + call edge_slopes_implicit_h3( n0, h0, densities, ppoly0_S, h_neglect ) + call PQM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_S, & + ppoly0_coefs, h_neglect ) if (extrapolate) then - call PQM_boundary_extrapolation_v1( n0, h0, densities, ppoly0_E, ppoly0_S, ppoly0_coefficients ) + call PQM_boundary_extrapolation_v1( n0, h0, densities, ppoly0_E, ppoly0_S, & + ppoly0_coefs, h_neglect ) end if else degree = DEGREE_1 - call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) - call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then - call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) end if end if case ( INTERPOLATION_PQM_IH6IH5 ) if ( n0 >= 6 ) then degree = DEGREE_4 - call edge_values_implicit_h6( n0, h0, densities, ppoly0_E ) - call edge_slopes_implicit_h5( n0, h0, densities, ppoly0_S ) - call PQM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_S, ppoly0_coefficients ) + call edge_values_implicit_h6( n0, h0, densities, ppoly0_E, h_neglect_edge ) + call edge_slopes_implicit_h5( n0, h0, densities, ppoly0_S, h_neglect ) + call PQM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_S, & + ppoly0_coefs, h_neglect ) if (extrapolate) then - call PQM_boundary_extrapolation_v1( n0, h0, densities, ppoly0_E, ppoly0_S, ppoly0_coefficients ) + call PQM_boundary_extrapolation_v1( n0, h0, densities, ppoly0_E, ppoly0_S, & + ppoly0_coefs, h_neglect ) end if else degree = DEGREE_1 - call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) - call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then - call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefficients ) + call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) end if end if end select @@ -245,18 +261,19 @@ end subroutine regridding_set_ppolys !! Given the grid 'grid0' and the piecewise polynomial interpolant !! 'ppoly0' (possibly discontinuous), the coordinates of the new grid 'grid1' !! are determined by finding the corresponding target interface densities. -subroutine interpolate_grid( n0, h0, x0, ppoly0_E, ppoly0_coefficients, target_values, degree, n1, h1, x1 ) +subroutine interpolate_grid( n0, h0, x0, ppoly0_E, ppoly0_coefs, & + target_values, degree, n1, h1, x1 ) ! Arguments - integer, intent(in) :: n0 !< Number of points on source grid - real, dimension(:), intent(in) :: h0 !< Thicknesses of source grid cells - real, dimension(:), intent(in) :: x0 !< Source interface positions - real, dimension(:,:), intent(in) :: ppoly0_E !< Edge values of interpolating polynomials - real, dimension(:,:), intent(in) :: ppoly0_coefficients !< Coefficients of interpolating polynomials - real, dimension(:), intent(in) :: target_values !< Target values of interfaces - integer, intent(in) :: degree !< Degree of interpolating polynomials - integer, intent(in) :: n1 !< Number of points on target grid - real, dimension(:), intent(inout) :: h1 !< Thicknesses of target grid cells - real, dimension(:), intent(inout) :: x1 !< Target interface positions + integer, intent(in) :: n0 !< Number of points on source grid + real, dimension(:), intent(in) :: h0 !< Thicknesses of source grid cells + real, dimension(:), intent(in) :: x0 !< Source interface positions + real, dimension(:,:), intent(in) :: ppoly0_E !< Edge values of interpolating polynomials + real, dimension(:,:), intent(in) :: ppoly0_coefs !< Coefficients of interpolating polynomials + real, dimension(:), intent(in) :: target_values !< Target values of interfaces + integer, intent(in) :: degree !< Degree of interpolating polynomials + integer, intent(in) :: n1 !< Number of points on target grid + real, dimension(:), intent(inout) :: h1 !< Thicknesses of target grid cells + real, dimension(:), intent(inout) :: x1 !< Target interface positions ! Local variables integer :: k ! loop index @@ -270,26 +287,37 @@ subroutine interpolate_grid( n0, h0, x0, ppoly0_E, ppoly0_coefficients, target_v ! Find coordinates for interior target values do k = 2,n1 t = target_values(k) - x1(k) = get_polynomial_coordinate ( n0, h0, x0, ppoly0_E, ppoly0_coefficients, t, degree ) + x1(k) = get_polynomial_coordinate ( n0, h0, x0, ppoly0_E, ppoly0_coefs, t, degree ) h1(k-1) = x1(k) - x1(k-1) end do h1(n1) = x1(n1+1) - x1(n1) end subroutine interpolate_grid -subroutine build_and_interpolate_grid(CS, densities, n0, h0, x0, target_values, n1, h1, x1) - type(interp_CS_type), intent(in) :: CS - real, dimension(:), intent(in) :: densities, target_values - integer, intent(in) :: n0, n1 - real, dimension(:), intent(in) :: h0, x0 - real, dimension(:), intent(inout) :: h1, x1 +subroutine build_and_interpolate_grid(CS, densities, n0, h0, x0, target_values, & + n1, h1, x1, h_neglect, h_neglect_edge) + type(interp_CS_type), intent(in) :: CS !< A control structure for regrid_interp + real, dimension(:), intent(in) :: densities !< Input cell densities, in kg m-3 + real, dimension(:), intent(in) :: target_values !< Target values of interfaces + integer, intent(in) :: n0 !< The number of points on the input grid + real, dimension(:), intent(in) :: h0 !< Initial cell widths + real, dimension(:), intent(in) :: x0 !< Source interface positions + integer, intent(in) :: n1 !< The number of points on the output grid + real, dimension(:), intent(inout) :: h1 !< Output cell widths + real, dimension(:), intent(inout) :: x1 !< Target interface positions + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions + !! in the same units as h0. + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width + !! for the purpose of edge value calculations + !! in the same units as h0. real, dimension(n0,2) :: ppoly0_E, ppoly0_S real, dimension(n0,DEGREE_MAX+1) :: ppoly0_C integer :: degree call regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, ppoly0_C, & - degree) + degree, h_neglect, h_neglect_edge) call interpolate_grid(n0, h0, x0, ppoly0_E, ppoly0_C, target_values, degree, & n1, h1, x1) end subroutine build_and_interpolate_grid @@ -310,16 +338,16 @@ 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_coefficients, & +function get_polynomial_coordinate ( N, h, x_g, ppoly_E, ppoly_coefs, & target_value, degree ) result ( x_tgt ) ! Arguments - integer, intent(in) :: N !< Number of grid cells - real, dimension(:), intent(in) :: h !< Grid cell thicknesses - real, dimension(:), intent(in) :: x_g !< Grid interface locations - real, dimension(:,:), intent(in) :: ppoly_E !< Edge values of interpolating polynomials - real, dimension(:,:), intent(in) :: ppoly_coefficients !< Coefficients of interpolating polynomials - real, intent(in) :: target_value !< Target value to find position for - integer, intent(in) :: degree !< Degree of the interpolating polynomials + integer, intent(in) :: N !< Number of grid cells + real, dimension(:), intent(in) :: h !< Grid cell thicknesses + real, dimension(:), intent(in) :: x_g !< Grid interface locations + real, dimension(:,:), intent(in) :: ppoly_E !< Edge values of interpolating polynomials + real, dimension(:,:), intent(in) :: ppoly_coefs !< Coefficients of interpolating polynomials + real, intent(in) :: target_value !< Target value to find position for + integer, intent(in) :: degree !< Degree of the interpolating polynomials real :: x_tgt !< The position of x_g at which target_value is found. @@ -398,7 +426,7 @@ function get_polynomial_coordinate ( N, h, x_g, ppoly_E, ppoly_coefficients, & ! the found cell a(:) = 0.0 do i = 1,degree+1 - a(i) = ppoly_coefficients(k_found,i) + a(i) = ppoly_coefs(k_found,i) end do ! Guess value to start Newton-Raphson iterations (middle of cell) @@ -468,14 +496,14 @@ end function interpolation_scheme subroutine set_interp_scheme(CS, interp_scheme) type(interp_CS_type), intent(inout) :: CS - character(len=*), intent(in) :: interp_scheme + character(len=*), intent(in) :: interp_scheme CS%interpolation_scheme = interpolation_scheme(interp_scheme) end subroutine set_interp_scheme subroutine set_interp_extrap(CS, extrapolation) type(interp_CS_type), intent(inout) :: CS - logical, intent(in) :: extrapolation + logical, intent(in) :: extrapolation CS%boundary_extrapolation = extrapolation end subroutine set_interp_extrap From 28441a3580bbd8826a3ed828445739c5b419a3d8 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 18 Dec 2017 13:57:40 -0500 Subject: [PATCH 18/20] +(*)Set h_neglect in code calling remapping Set values of h_neglect and h_neglect edge that are consistent with the internal representation of thickness in MOM6, and added these arguments to the underlying regridding code. Altered routines include ALE_regrid_accelerated, pressure_gradient_plm, pressure_gradient_ppm, remap_all_state_vars, ALE_remap_scalar, build_rho_grid, build_grid_HyCOM1, and build_grid_SLight. Also shortened some internal variable names. All answers are bitwise identical in the test cases. --- src/ALE/MOM_ALE.F90 | 168 +++++++++++++++++++++++-------------- src/ALE/MOM_regridding.F90 | 36 +++++++- 2 files changed, 138 insertions(+), 66 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 0e269123d8..84407140ec 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -748,6 +748,14 @@ subroutine ALE_regrid_accelerated(CS, G, GV, h_orig, tv, n, h_new, u, v) ! we have to keep track of the total dzInterface if for some reason ! we're using the old remapping algorithm for u/v real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: dzInterface, dzIntTotal + real :: h_neglect, h_neglect_edge + + !### Try replacing both of these with GV%H_subroundoff + if (GV%Boussinesq) then + h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 + else + h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 + endif nz = GV%ke @@ -779,8 +787,10 @@ subroutine ALE_regrid_accelerated(CS, G, GV, h_orig, tv, n, h_new, u, v) ! we need to use remapping_core because there isn't a tracer registry set up in ! the state initialization routine do j = G%jsc,G%jec ; do i = G%isc,G%iec - call remapping_core_h(CS%remapCS, nz, h_orig(i,j,:), tv%S(i,j,:), nz, h_new(i,j,:), tv_local%S(i,j,:)) - call remapping_core_h(CS%remapCS, nz, h_orig(i,j,:), tv%T(i,j,:), nz, h_new(i,j,:), tv_local%T(i,j,:)) + call remapping_core_h(CS%remapCS, nz, h_orig(i,j,:), tv%S(i,j,:), nz, h_new(i,j,:), & + tv_local%S(i,j,:), h_neglect, h_neglect_edge) + call remapping_core_h(CS%remapCS, nz, h_orig(i,j,:), tv%T(i,j,:), nz, h_new(i,j,:), & + tv_local%T(i,j,:), h_neglect, h_neglect_edge) enddo ; enddo @@ -824,6 +834,7 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, real, dimension(SZI_(G), SZJ_(G)) :: work_2d real :: Idt, ppt2mks real, dimension(GV%ke) :: h2 + real :: h_neglect, h_neglect_edge logical :: show_call_tree show_call_tree = .false. @@ -837,6 +848,13 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, "be remapped") endif + !### Try replacing both of these with GV%H_subroundoff + if (GV%Boussinesq) then + h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 + else + h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 + endif + nz = GV%ke ppt2mks = 0.001 @@ -854,12 +872,9 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, endif ! Remap tracer -!$OMP parallel default(none) shared(G,GV,h_old,h_new,dxInterface,CS_remapping,nz,Reg,u,v,ntr,show_call_tree, & -!$OMP dt,CS_ALE,work_conc,work_cont,work_2d,Idt,ppt2mks) & -!$OMP private(h1,h2,dx,u_column) if (ntr>0) then if (show_call_tree) call callTree_waypoint("remapping tracers (remap_all_state_vars)") -!$OMP do + !$OMP parallel do default(shared) private(h1,h2,u_column) do m=1,ntr ! For each tracer do j = G%jsc,G%jec @@ -870,7 +885,8 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, ! Build the start and final grids h1(:) = h_old(i,j,:) h2(:) = h_new(i,j,:) - call remapping_core_h(CS_remapping, nz, h1, Reg%Tr(m)%t(i,j,:), nz, h2, u_column) + call remapping_core_h(CS_remapping, nz, h1, Reg%Tr(m)%t(i,j,:), nz, h2, & + u_column, h_neglect, h_neglect_edge) ! Intermediate steps for tendency of tracer concentration and tracer content. ! Note: do not merge the two if-tests, since do_tendency_diag(:) is not @@ -951,7 +967,7 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, ! Remap u velocity component if ( present(u) ) then -!$OMP do + !$OMP parallel do default(shared) private(h1,h2,dx,u_column) do j = G%jsc,G%jec do I = G%iscB,G%iecB if (G%mask2dCu(I,j)>0.) then @@ -965,7 +981,8 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, else h2(:) = 0.5 * ( h_new(i,j,:) + h_new(i+1,j,:) ) endif - call remapping_core_h(CS_remapping, nz, h1, u(I,j,:), nz, h2, u_column) + call remapping_core_h(CS_remapping, nz, h1, u(I,j,:), nz, h2, & + u_column, h_neglect, h_neglect_edge) u(I,j,:) = u_column(:) endif enddo @@ -976,7 +993,7 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, ! Remap v velocity component if ( present(v) ) then -!$OMP do + !$OMP parallel do default(shared) private(h1,h2,dx,u_column) do J = G%jscB,G%jecB do i = G%isc,G%iec if (G%mask2dCv(i,j)>0.) then @@ -990,13 +1007,13 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, else h2(:) = 0.5 * ( h_new(i,j,:) + h_new(i,j+1,:) ) endif - call remapping_core_h(CS_remapping, nz, h1, v(i,J,:), nz, h2, u_column) + call remapping_core_h(CS_remapping, nz, h1, v(i,J,:), nz, h2, & + u_column, h_neglect, h_neglect_edge) v(i,J,:) = u_column(:) endif enddo enddo endif -!$OMP end parallel if (show_call_tree) call callTree_waypoint("v remapped (remap_all_state_vars)") if (show_call_tree) call callTree_leave("remap_all_state_vars()") @@ -1024,6 +1041,7 @@ subroutine ALE_remap_scalar(CS, G, GV, nk_src, h_src, s_src, h_dst, s_dst, all_c ! Local variables integer :: i, j, k, n_points real :: dx(GV%ke+1) + real :: h_neglect, h_neglect_edge logical :: ignore_vanished_layers, use_remapping_core_w ignore_vanished_layers = .false. @@ -1032,32 +1050,35 @@ subroutine ALE_remap_scalar(CS, G, GV, nk_src, h_src, s_src, h_dst, s_dst, all_c if (present(old_remap)) use_remapping_core_w = old_remap n_points = nk_src -!$OMP parallel default(none) shared(CS,G,GV,h_src,s_src,h_dst,s_dst & -!$OMP ,ignore_vanished_layers, use_remapping_core_w, nk_src ) & -!$OMP firstprivate(n_points,dx) -!$OMP do - do j = G%jsc,G%jec - do i = G%isc,G%iec - if (G%mask2dT(i,j)>0.) then - if (ignore_vanished_layers) then - n_points = 0 - do k = 1, nk_src - if (h_src(i,j,k)>0.) n_points = n_points + 1 - enddo - s_dst(i,j,:) = 0. - endif - if (use_remapping_core_w) then - call dzFromH1H2( n_points, h_src(i,j,1:n_points), GV%ke, h_dst(i,j,:), dx ) - call remapping_core_w(CS, n_points, h_src(i,j,1:n_points), s_src(i,j,1:n_points), GV%ke, dx, s_dst(i,j,:)) - else - call remapping_core_h(CS, n_points, h_src(i,j,1:n_points), s_src(i,j,1:n_points), GV%ke, h_dst(i,j,:), s_dst(i,j,:)) - endif - else + !### Try replacing both of these with GV%H_subroundoff + if (GV%Boussinesq) then + h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 + else + h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 + endif + + !$OMP parallel do default(shared) firstprivate(n_points,dx) + do j = G%jsc,G%jec ; do i = G%isc,G%iec + if (G%mask2dT(i,j) > 0.) then + if (ignore_vanished_layers) then + n_points = 0 + do k = 1, nk_src + if (h_src(i,j,k)>0.) n_points = n_points + 1 + enddo s_dst(i,j,:) = 0. endif - enddo - enddo -!$OMP end parallel + if (use_remapping_core_w) then + call dzFromH1H2( n_points, h_src(i,j,1:n_points), GV%ke, h_dst(i,j,:), dx ) + call remapping_core_w(CS, n_points, h_src(i,j,1:n_points), s_src(i,j,1:n_points), & + GV%ke, dx, s_dst(i,j,:), h_neglect, h_neglect_edge) + else + call remapping_core_h(CS, n_points, h_src(i,j,1:n_points), s_src(i,j,1:n_points), & + GV%ke, h_dst(i,j,:), s_dst(i,j,:), h_neglect, h_neglect_edge) + endif + else + s_dst(i,j,:) = 0. + endif + enddo ; enddo end subroutine ALE_remap_scalar @@ -1083,25 +1104,35 @@ subroutine pressure_gradient_plm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h ) real :: hTmp(GV%ke) real :: tmp(GV%ke) real, dimension(CS%nk,2) :: ppoly_linear_E !Edge value of polynomial - real, dimension(CS%nk,CS%degree_linear+1) :: ppoly_linear_coefficients !Coefficients of polynomial + real, dimension(CS%nk,CS%degree_linear+1) :: ppoly_linear_coefs !Coefficients of polynomial + real :: h_neglect + + !### Replace this with GV%H_subroundoff + !### Omit the rescaling by H_to_m here. It should not be needed. + if (GV%Boussinesq) then + h_neglect = GV%m_to_H*1.0e-30 * GV%H_to_m + else + h_neglect = GV%kg_m2_to_H*1.0e-30 * GV%H_to_m + endif ! NOTE: the variables 'CS%grid_generic' and 'CS%ppoly_linear' are declared at ! the module level. ! Determine reconstruction within each column -!$OMP parallel do default(none) shared(G,GV,h,tv,CS,S_t,S_b,T_t,T_b) & -!$OMP private(hTmp,ppoly_linear_E,ppoly_linear_coefficients,tmp) +!$OMP parallel do default(none) shared(G,GV,h,tv,CS,S_t,S_b,T_t,T_b,h_neglect) & +!$OMP private(hTmp,ppoly_linear_E,ppoly_linear_coefs,tmp) do j = G%jsc-1,G%jec+1 do i = G%isc-1,G%iec+1 ! Build current grid + !### Omit the rescaling by H_to_m here. It should not be needed. hTmp(:) = h(i,j,:)*GV%H_to_m tmp(:) = tv%S(i,j,:) ! Reconstruct salinity profile - ppoly_linear_E = 0.0 - ppoly_linear_coefficients = 0.0 - call PLM_reconstruction( GV%ke, hTmp, tmp, ppoly_linear_E, ppoly_linear_coefficients ) + ppoly_linear_E(:,:) = 0.0 + ppoly_linear_coefs(:,:) = 0.0 + call PLM_reconstruction( GV%ke, hTmp, tmp, ppoly_linear_E, ppoly_linear_coefs, h_neglect ) if (CS%boundary_extrapolation_for_pressure) call & - PLM_boundary_extrapolation( GV%ke, hTmp, tmp, ppoly_linear_E, ppoly_linear_coefficients ) + PLM_boundary_extrapolation( GV%ke, hTmp, tmp, ppoly_linear_E, ppoly_linear_coefs, h_neglect ) do k = 1,GV%ke S_t(i,j,k) = ppoly_linear_E(k,1) @@ -1109,12 +1140,12 @@ subroutine pressure_gradient_plm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h ) end do ! Reconstruct temperature profile - ppoly_linear_E = 0.0 - ppoly_linear_coefficients = 0.0 + ppoly_linear_E(:,:) = 0.0 + ppoly_linear_coefs(:,:) = 0.0 tmp(:) = tv%T(i,j,:) - call PLM_reconstruction( GV%ke, hTmp, tmp, ppoly_linear_E, ppoly_linear_coefficients ) + call PLM_reconstruction( GV%ke, hTmp, tmp, ppoly_linear_E, ppoly_linear_coefs, h_neglect ) if (CS%boundary_extrapolation_for_pressure) call & - PLM_boundary_extrapolation( GV%ke, hTmp, tmp, ppoly_linear_E, ppoly_linear_coefficients ) + PLM_boundary_extrapolation( GV%ke, hTmp, tmp, ppoly_linear_E, ppoly_linear_coefs, h_neglect ) do k = 1,GV%ke T_t(i,j,k) = ppoly_linear_E(k,1) @@ -1150,29 +1181,40 @@ subroutine pressure_gradient_ppm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h ) real, dimension(CS%nk,2) :: & ppoly_parab_E !Edge value of polynomial real, dimension(CS%nk,CS%degree_parab+1) :: & - ppoly_parab_coefficients !Coefficients of polynomial + ppoly_parab_coefs !Coefficients of polynomial + real :: h_neglect + !### Replace this with GV%H_subroundoff + !### Omit the rescaling by H_to_m here. It should not be needed. + if (GV%Boussinesq) then + h_neglect = GV%m_to_H*1.0e-30 * GV%H_to_m + else + h_neglect = GV%kg_m2_to_H*1.0e-30 * GV%H_to_m + endif ! NOTE: the variables 'CS%grid_generic' and 'CS%ppoly_parab' are declared at ! the module level. ! Determine reconstruction within each column -!$OMP parallel do default(none) shared(G,GV,h,tv,CS,S_t,S_b,T_t,T_b) & -!$OMP private(hTmp,tmp,ppoly_parab_E,ppoly_parab_coefficients) +!$OMP parallel do default(none) shared(G,GV,h,tv,CS,S_t,S_b,T_t,T_b,h_neglect) & +!$OMP private(hTmp,tmp,ppoly_parab_E,ppoly_parab_coefs) do j = G%jsc-1,G%jec+1 do i = G%isc-1,G%iec+1 ! Build current grid + !### Omit the rescaling by H_to_m here. It should not be needed. hTmp(:) = h(i,j,:) * GV%H_to_m tmp(:) = tv%S(i,j,:) ! Reconstruct salinity profile - ppoly_parab_E = 0.0 - ppoly_parab_coefficients = 0.0 - call edge_values_implicit_h4( GV%ke, hTmp, tmp, ppoly_parab_E ) - call PPM_reconstruction( GV%ke, hTmp, tmp, ppoly_parab_E, ppoly_parab_coefficients ) + ppoly_parab_E(:,:) = 0.0 + ppoly_parab_coefs(:,:) = 0.0 + !### Try to replace the following value of h_neglect with GV%H_subroundoff. + call edge_values_implicit_h4( GV%ke, hTmp, tmp, ppoly_parab_E, h_neglect=1.0e-10) !###*GV%m_to_H ) + call PPM_reconstruction( GV%ke, hTmp, tmp, ppoly_parab_E, ppoly_parab_coefs, h_neglect ) if (CS%boundary_extrapolation_for_pressure) call & - PPM_boundary_extrapolation( GV%ke, hTmp, tmp, ppoly_parab_E, ppoly_parab_coefficients ) + PPM_boundary_extrapolation( GV%ke, hTmp, tmp, ppoly_parab_E, & + ppoly_parab_coefs, h_neglect ) do k = 1,GV%ke S_t(i,j,k) = ppoly_parab_E(k,1) @@ -1180,13 +1222,15 @@ subroutine pressure_gradient_ppm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h ) end do ! Reconstruct temperature profile - ppoly_parab_E = 0.0 - ppoly_parab_coefficients = 0.0 + ppoly_parab_E(:,:) = 0.0 + ppoly_parab_coefs(:,:) = 0.0 tmp(:) = tv%T(i,j,:) - call edge_values_implicit_h4( GV%ke, hTmp, tmp, ppoly_parab_E ) - call PPM_reconstruction( GV%ke, hTmp, tmp, ppoly_parab_E, ppoly_parab_coefficients ) + !### Try to replace the following value of h_neglect with GV%H_subroundoff. + call edge_values_implicit_h4( GV%ke, hTmp, tmp, ppoly_parab_E, h_neglect=1.0e-10) !###*GV%m_to_H ) + call PPM_reconstruction( GV%ke, hTmp, tmp, ppoly_parab_E, ppoly_parab_coefs, h_neglect ) if (CS%boundary_extrapolation_for_pressure) call & - PPM_boundary_extrapolation( GV%ke, hTmp, tmp, ppoly_parab_E, ppoly_parab_coefficients ) + PPM_boundary_extrapolation( GV%ke, hTmp, tmp, ppoly_parab_E, & + ppoly_parab_coefs, h_neglect ) do k = 1,GV%ke T_t(i,j,k) = ppoly_parab_E(k,1) @@ -1348,13 +1392,13 @@ subroutine ALE_initThicknessToCoord( CS, G, GV, h ) type(ALE_CS), intent(inout) :: CS !< module control structure type(ocean_grid_type), intent(in) :: G !< module grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: h !< layer thickness + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: h !< layer thickness in H ! Local variables integer :: i, j, k do j = G%jsd,G%jed ; do i = G%isd,G%ied - h(i,j,:) = getStaticThickness( CS%regridCS, 0., G%bathyT(i,j) ) + h(i,j,:) = GV%m_to_H * getStaticThickness( CS%regridCS, 0., G%bathyT(i,j) ) enddo; enddo end subroutine ALE_initThicknessToCoord diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index f9b563d4f0..e9f755746e 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -1290,10 +1290,18 @@ subroutine build_rho_grid( G, GV, h, tv, dzInterface, remapCS, CS ) integer :: i, j, k real :: nominalDepth, totalThickness real, dimension(SZK_(GV)+1) :: zOld, zNew + real :: h_neglect, h_neglect_edge #ifdef __DO_SAFETY_CHECKS__ real :: dh #endif + !### Try replacing both of these with GV%H_subroundoff + if (GV%Boussinesq) then + h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 + else + h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 + endif + nz = GV%ke if (.not.CS%target_density_set) call MOM_error(FATAL, "build_rho_grid: "//& @@ -1313,7 +1321,8 @@ subroutine build_rho_grid( G, GV, h, tv, dzInterface, remapCS, CS ) nominalDepth = G%bathyT(i,j)*GV%m_to_H call build_rho_column(CS%rho_CS, nz, nominalDepth, h(i, j, :), & - tv%T(i, j, :), tv%S(i, j, :), tv%eqn_of_state, zNew) + tv%T(i, j, :), tv%S(i, j, :), tv%eqn_of_state, zNew, & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) if (CS%integrate_downward_for_e) then zOld(1) = 0. @@ -1397,6 +1406,14 @@ subroutine build_grid_HyCOM1( G, GV, h, tv, dzInterface, CS ) real, dimension(SZK_(GV)) :: p_col ! Layer pressure in Pa integer :: i, j, k, nz real :: depth + real :: h_neglect, h_neglect_edge + + !### Try replacing both of these with GV%H_subroundoff + if (GV%Boussinesq) then + h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 + else + h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 + endif nz = GV%ke @@ -1417,7 +1434,9 @@ subroutine build_grid_HyCOM1( G, GV, h, tv, dzInterface, CS ) enddo call build_hycom1_column(CS%hycom_CS, tv%eqn_of_state, nz, depth, & - h(i, j, :), tv%T(i, j, :), tv%S(i, j, :), p_col, z_col, z_col_new) + h(i, j, :), tv%T(i, j, :), tv%S(i, j, :), p_col, & + z_col, z_col_new, zScale=GV%m_to_H, & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) ! Calculate the final change in grid position after blending new and old grids call filtered_grid_motion( CS, nz, z_col, z_col_new, dz_col ) @@ -1510,6 +1529,14 @@ subroutine build_grid_SLight( G, GV, h, tv, dzInterface, CS ) real, dimension(SZK_(GV)) :: p_col ! Layer pressure in Pa real :: depth integer :: i, j, k, nz + real :: h_neglect, h_neglect_edge + + !### Try replacing both of these with GV%H_subroundoff + if (GV%Boussinesq) then + h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 + else + h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 + endif nz = GV%ke @@ -1529,8 +1556,9 @@ subroutine build_grid_SLight( G, GV, h, tv, dzInterface, CS ) enddo call build_slight_column(CS%slight_CS, tv%eqn_of_state, GV%H_to_Pa, GV%m_to_H, & - GV%H_subroundoff, nz, depth, & - h(i, j, :), tv%T(i, j, :), tv%S(i, j, :), p_col, z_col, z_col_new) + GV%H_subroundoff, nz, depth, h(i, j, :), & + tv%T(i, j, :), tv%S(i, j, :), p_col, z_col, z_col_new, & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) ! Calculate the final change in grid position after blending new and old grids call filtered_grid_motion( CS, nz, z_col, z_col_new, dz_col ) From 5450210a2d52cd7878f051cc0aa82f48abd837b7 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 18 Dec 2017 15:16:16 -0500 Subject: [PATCH 19/20] (*)Rescale h_neglect in neutral_diffusion Rescale the negligible thickness used in some of the neutral_diffusion routines, including adding a new optional argument for edge remapping, so that answers do not change with the value of H_TO_M. Also reformatted many of the unit test calls to avoid overly long lines. All answers are bitwise identical when H_TO_M=1, and no test cases answers change. --- src/tracer/MOM_neutral_diffusion.F90 | 197 ++++++++++++++++++--------- 1 file changed, 129 insertions(+), 68 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 05b6164108..e47049fe1e 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -361,6 +361,14 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, EOS, CS) real, dimension(SZK_(G),2) :: ppoly_r_S ! Reconstruction slopes integer :: iMethod real, dimension(SZI_(G)) :: ref_pres ! Reference pressure used to calculate alpha/beta + real :: h_neglect, h_neglect_edge + + !### Try replacing both of these with GV%H_subroundoff + if (GV%Boussinesq) then + h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 + else + h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 + endif ! If doing along isopycnal diffusion (as opposed to neutral diffusion, set the reference pressure) if (CS%ref_pres>=0.) ref_pres(:) = CS%ref_pres @@ -385,13 +393,13 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, EOS, CS) ! Interpolate state to interface do i = G%isc-1, G%iec+1 if (CS%continuous_reconstruction) then - call interface_scalar(G%ke, h(i,j,:), T(i,j,:), CS%Tint(i,j,:), 2) - call interface_scalar(G%ke, h(i,j,:), S(i,j,:), CS%Sint(i,j,:), 2) + call interface_scalar(G%ke, h(i,j,:), T(i,j,:), CS%Tint(i,j,:), 2, h_neglect) + call interface_scalar(G%ke, h(i,j,:), S(i,j,:), CS%Sint(i,j,:), 2, h_neglect) else call build_reconstructions_1d( CS%remap_CS, G%ke, h(i,j,:), T(i,j,:), CS%ppoly_coeffs_T(i,j,:,:), & - CS%T_i(i,j,:,:), ppoly_r_S, iMethod ) + CS%T_i(i,j,:,:), ppoly_r_S, iMethod, h_neglect, h_neglect_edge ) call build_reconstructions_1d( CS%remap_CS, G%ke, h(i,j,:), S(i,j,:), CS%ppoly_coeffs_S(i,j,:,:), & - CS%S_i(i,j,:,:), ppoly_r_S, iMethod ) + CS%S_i(i,j,:,:), ppoly_r_S, iMethod, h_neglect, h_neglect_edge ) endif enddo @@ -491,6 +499,11 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, Tracer, m, dt, name, CS) real, dimension(G%ke) :: dTracer ! change in tracer concentration due to ndiffusion integer :: i, j, k, ks, nk real :: ppt2mks, Idt, convert + real :: h_neglect, h_neglect_edge + + !### Try replacing both of these with GV%H_subroundoff + h_neglect_edge = GV%m_to_H*1.0e-10 + h_neglect = GV%m_to_H*1.0e-30 nk = GV%ke @@ -522,7 +535,7 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, Tracer, m, dt, name, CS) CS%uPoL(I,j,:), CS%uPoR(I,j,:), & CS%uKoL(I,j,:), CS%uKoR(I,j,:), & CS%uhEff(I,j,:), uFlx(I,j,:), & - CS%continuous_reconstruction, CS%remap_CS) + CS%continuous_reconstruction, h_neglect, CS%remap_CS, h_neglect_edge) endif enddo ; enddo @@ -534,7 +547,7 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, Tracer, m, dt, name, CS) CS%vPoL(i,J,:), CS%vPoR(i,J,:), & CS%vKoL(i,J,:), CS%vKoR(i,J,:), & CS%vhEff(i,J,:), vFlx(i,J,:), & - CS%continuous_reconstruction, CS%remap_CS) + CS%continuous_reconstruction, h_neglect, CS%remap_CS, h_neglect_edge) endif enddo ; enddo @@ -629,13 +642,14 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, Tracer, m, dt, name, CS) end subroutine neutral_diffusion !> Returns interface scalar, Si, for a column of layer values, S. -subroutine interface_scalar(nk, h, S, Si, i_method) +subroutine interface_scalar(nk, h, S, Si, i_method, h_neglect) integer, intent(in) :: nk !< Number of levels real, dimension(nk), intent(in) :: h !< Layer thickness (H units) real, dimension(nk), intent(in) :: S !< Layer scalar (conc, e.g. ppt) real, dimension(nk+1), intent(inout) :: Si !< Interface scalar (conc, e.g. ppt) integer, intent(in) :: i_method !< =1 use average of PLM edges !! =2 use continuous PPM edge interpolation + real, intent(in) :: h_neglect !< A negligibly small thickness (H units) ! Local variables integer :: k, km2, kp1 real, dimension(nk) :: diff @@ -657,7 +671,7 @@ subroutine interface_scalar(nk, h, S, Si, i_method) ! equation 1.6 in Colella & Woodward, 1984: JCP 54, 174-201. km2 = max(1, k-2) kp1 = min(nk, k+1) - Si(k) = ppm_edge(h(km2), h(k-1), h(k), h(kp1), S(k-1), S(k), diff(k-1), diff(k)) + Si(k) = ppm_edge(h(km2), h(k-1), h(k), h(kp1), S(k-1), S(k), diff(k-1), diff(k), h_neglect) enddo endif Si(nk+1) = S(nk) + 0.5 * diff(nk) @@ -666,7 +680,7 @@ end subroutine interface_scalar !> Returns the PPM quasi-fourth order edge value at k+1/2 following !! equation 1.6 in Colella & Woodward, 1984: JCP 54, 174-201. -real function ppm_edge(hkm1, hk, hkp1, hkp2, Ak, Akp1, Pk, Pkp1) +real function ppm_edge(hkm1, hk, hkp1, hkp2, Ak, Akp1, Pk, Pkp1, h_neglect) real, intent(in) :: hkm1 !< Width of cell k-1 real, intent(in) :: hk !< Width of cell k real, intent(in) :: hkp1 !< Width of cell k+1 @@ -675,10 +689,10 @@ real function ppm_edge(hkm1, hk, hkp1, hkp2, Ak, Akp1, Pk, Pkp1) real, intent(in) :: Akp1 !< Average scalar value of cell k+1 real, intent(in) :: Pk !< PLM slope for cell k real, intent(in) :: Pkp1 !< PLM slope for cell k+1 + real, intent(in) :: h_neglect !< A negligibly small thickness (H units) ! Local variables real :: R_hk_hkp1, R_2hk_hkp1, R_hk_2hkp1, f1, f2, f3, f4 - real, parameter :: h_neglect = 1.e-30 R_hk_hkp1 = hk + hkp1 if (R_hk_hkp1 <= 0.) then @@ -1769,7 +1783,8 @@ subroutine calc_delta_rho(deg, T_ref, S_ref, alpha_ref, beta_ref, P_top, P_bot, end subroutine calc_delta_rho !> Returns a single column of neutral diffusion fluxes of a tracer. -subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, KoR, hEff, Flx, continuous, remap_CS) +subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, KoR, & + hEff, Flx, continuous, h_neglect, remap_CS, h_neglect_edge) integer, intent(in) :: nk !< Number of levels integer, intent(in) :: nsurf !< Number of neutral surfaces integer, intent(in) :: deg !< Degree of polynomial reconstructions @@ -1786,7 +1801,13 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K real, dimension(nsurf-1), intent(in) :: hEff !< Effective thickness between two neutral surfaces (Pa) real, dimension(nsurf-1), intent(inout) :: Flx !< Flux of tracer between pairs of neutral layers (conc H) logical, intent(in) :: continuous !< True if using continuous reconstruction + real, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions + !! in the same units as h0. type(remapping_CS), optional, intent(in) :: remap_CS + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width + !! for the purpose of edge value calculations + !! in the same units as h0. ! Local variables integer :: k_sublayer, klb, klt, krb, krt, k real :: T_right_top, T_right_bottom, T_right_layer @@ -1809,8 +1830,8 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K ! Setup reconstruction edge values if (continuous) then - call interface_scalar(nk, hl, Tl, Til, 2) - call interface_scalar(nk, hr, Tr, Tir, 2) + call interface_scalar(nk, hl, Tl, Til, 2, h_neglect) + call interface_scalar(nk, hr, Tr, Tir, 2, h_neglect) call ppm_left_right_edge_values(nk, Tl, Til, aL_l, aR_l) call ppm_left_right_edge_values(nk, Tr, Tir, aL_r, aR_r) else @@ -1819,8 +1840,10 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K Tid_l(:,:) = 0. Tid_r(:,:) = 0. - call build_reconstructions_1d( remap_CS, nk, hl, Tl, ppoly_r_coeffs_l, Tid_l, ppoly_r_S_l, iMethod ) - call build_reconstructions_1d( remap_CS, nk, hr, Tr, ppoly_r_coeffs_r, Tid_r, ppoly_r_S_r, iMethod ) + call build_reconstructions_1d( remap_CS, nk, hl, Tl, ppoly_r_coeffs_l, Tid_l, & + ppoly_r_S_l, iMethod, h_neglect, h_neglect_edge ) + call build_reconstructions_1d( remap_CS, nk, hr, Tr, ppoly_r_coeffs_r, Tid_r, & + ppoly_r_S_r, iMethod, h_neglect, h_neglect_edge ) endif do k_sublayer = 1, nsurf-1 @@ -1929,47 +1952,80 @@ logical function ndiff_unit_tests_continuous(verbose) real, dimension(2*nk+1) :: Flx ! Test flux integer :: k logical :: v + real :: h_neglect, h_neglect_edge + + h_neglect_edge = 1.0e-10 ; h_neglect = 1.0e-30 v = verbose ndiff_unit_tests_continuous = .false. ! Normally return false write(*,*) '==== MOM_neutral_diffusion: ndiff_unit_tests_continuous =' - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_fv_diff(v,1.,1.,1., 0.,1.,2., 1., 'FV: Straight line on uniform grid') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_fv_diff(v,1.,1.,0., 0.,4.,8., 7., 'FV: Vanished right cell') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_fv_diff(v,0.,1.,1., 0.,4.,8., 7., 'FV: Vanished left cell') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_fv_diff(v,1.,2.,4., 0.,3.,9., 4., 'FV: Stretched grid') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_fv_diff(v,2.,0.,2., 0.,1.,2., 0., 'FV: Vanished middle cell') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_fv_diff(v,0.,1.,0., 0.,1.,2., 2., 'FV: Vanished on both sides') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_fv_diff(v,1.,0.,0., 0.,1.,2., 0., 'FV: Two vanished cell sides') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_fv_diff(v,0.,0.,0., 0.,1.,2., 0., 'FV: All vanished cells') - - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_fvlsq_slope(v,1.,1.,1., 0.,1.,2., 1., 'LSQ: Straight line on uniform grid') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_fvlsq_slope(v,1.,1.,0., 0.,1.,2., 1., 'LSQ: Vanished right cell') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_fvlsq_slope(v,0.,1.,1., 0.,1.,2., 1., 'LSQ: Vanished left cell') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_fvlsq_slope(v,1.,2.,4., 0.,3.,9., 2., 'LSQ: Stretched grid') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_fvlsq_slope(v,1.,0.,1., 0.,1.,2., 2., 'LSQ: Vanished middle cell') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_fvlsq_slope(v,0.,1.,0., 0.,1.,2., 0., 'LSQ: Vanished on both sides') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_fvlsq_slope(v,1.,0.,0., 0.,1.,2., 0., 'LSQ: Two vanished cell sides') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_fvlsq_slope(v,0.,0.,0., 0.,1.,2., 0., 'LSQ: All vanished cells') - - call interface_scalar(4, (/10.,10.,10.,10./), (/24.,18.,12.,6./), Tio, 1) - !ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_data1d(5, Tio, (/27.,21.,15.,9.,3./), 'Linear profile, interface temperatures') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_data1d(v,5, Tio, (/24.,22.5,15.,7.5,6./), 'Linear profile, linear interface temperatures') - call interface_scalar(4, (/10.,10.,10.,10./), (/24.,18.,12.,6./), Tio, 2) - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_data1d(v,5, Tio, (/24.,22.,15.,8.,6./), 'Linear profile, PPM interface temperatures') - - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_ifndp(v,-1.0, 0., 1.0, 1.0, 0.5, 'Check mid-point') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_ifndp(v, 0.0, 0., 1.0, 1.0, 0.0, 'Check bottom') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_ifndp(v, 0.1, 0., 1.1, 1.0, 0.0, 'Check below') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_ifndp(v,-1.0, 0., 0.0, 1.0, 1.0, 'Check top') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_ifndp(v,-1.0, 0., -0.1, 1.0, 1.0, 'Check above') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_ifndp(v,-1.0, 0., 3.0, 1.0, 0.25, 'Check 1/4') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_ifndp(v,-3.0, 0., 1.0, 1.0, 0.75, 'Check 3/4') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_ifndp(v, 1.0, 0., 1.0, 1.0, 0.0, 'Check dRho=0 below') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_ifndp(v,-1.0, 0., -1.0, 1.0, 1.0, 'Check dRho=0 above') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_ifndp(v, 0.0, 0., 0.0, 1.0, 0.5, 'Check dRho=0 mid') - ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_ifndp(v,-2.0, .5, 5.0, 0.5, 0.5, 'Check dP=0') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fv_diff(v,1.,1.,1., 0.,1.,2., 1., 'FV: Straight line on uniform grid') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fv_diff(v,1.,1.,0., 0.,4.,8., 7., 'FV: Vanished right cell') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fv_diff(v,0.,1.,1., 0.,4.,8., 7., 'FV: Vanished left cell') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fv_diff(v,1.,2.,4., 0.,3.,9., 4., 'FV: Stretched grid') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fv_diff(v,2.,0.,2., 0.,1.,2., 0., 'FV: Vanished middle cell') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fv_diff(v,0.,1.,0., 0.,1.,2., 2., 'FV: Vanished on both sides') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fv_diff(v,1.,0.,0., 0.,1.,2., 0., 'FV: Two vanished cell sides') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fv_diff(v,0.,0.,0., 0.,1.,2., 0., 'FV: All vanished cells') + + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fvlsq_slope(v,1.,1.,1., 0.,1.,2., 1., 'LSQ: Straight line on uniform grid') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fvlsq_slope(v,1.,1.,0., 0.,1.,2., 1., 'LSQ: Vanished right cell') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fvlsq_slope(v,0.,1.,1., 0.,1.,2., 1., 'LSQ: Vanished left cell') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fvlsq_slope(v,1.,2.,4., 0.,3.,9., 2., 'LSQ: Stretched grid') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fvlsq_slope(v,1.,0.,1., 0.,1.,2., 2., 'LSQ: Vanished middle cell') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fvlsq_slope(v,0.,1.,0., 0.,1.,2., 0., 'LSQ: Vanished on both sides') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fvlsq_slope(v,1.,0.,0., 0.,1.,2., 0., 'LSQ: Two vanished cell sides') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_fvlsq_slope(v,0.,0.,0., 0.,1.,2., 0., 'LSQ: All vanished cells') + + call interface_scalar(4, (/10.,10.,10.,10./), (/24.,18.,12.,6./), Tio, 1, h_neglect) + !ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + ! test_data1d(5, Tio, (/27.,21.,15.,9.,3./), 'Linear profile, interface temperatures') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_data1d(v,5, Tio, (/24.,22.5,15.,7.5,6./), 'Linear profile, linear interface temperatures') + call interface_scalar(4, (/10.,10.,10.,10./), (/24.,18.,12.,6./), Tio, 2, h_neglect) + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_data1d(v,5, Tio, (/24.,22.,15.,8.,6./), 'Linear profile, PPM interface temperatures') + + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_ifndp(v,-1.0, 0., 1.0, 1.0, 0.5, 'Check mid-point') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_ifndp(v, 0.0, 0., 1.0, 1.0, 0.0, 'Check bottom') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_ifndp(v, 0.1, 0., 1.1, 1.0, 0.0, 'Check below') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_ifndp(v,-1.0, 0., 0.0, 1.0, 1.0, 'Check top') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_ifndp(v,-1.0, 0., -0.1, 1.0, 1.0, 'Check above') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_ifndp(v,-1.0, 0., 3.0, 1.0, 0.25, 'Check 1/4') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_ifndp(v,-3.0, 0., 1.0, 1.0, 0.75, 'Check 3/4') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_ifndp(v, 1.0, 0., 1.0, 1.0, 0.0, 'Check dRho=0 below') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_ifndp(v,-1.0, 0., -1.0, 1.0, 1.0, 'Check dRho=0 above') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_ifndp(v, 0.0, 0., 0.0, 1.0, 0.5, 'Check dRho=0 mid') + ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. & + test_ifndp(v,-2.0, .5, 5.0, 0.5, 0.5, 'Check dP=0') ! Identical columns call find_neutral_surface_positions_continuous(3, & @@ -1993,12 +2049,14 @@ logical function ndiff_unit_tests_continuous(verbose) (/0.,0.,10.,10.,20.,20.,30.,30./), '... right positions') call neutral_surface_flux(3, 2*3+2, 2, (/10.,10.,10./), (/10.,10.,10./), & ! nk, hL, hR (/20.,16.,12./), (/20.,16.,12./), & ! Tl, Tr - PiLRo, PiRLo, KoL, KoR, hEff, Flx, .true.) + PiLRo, PiRLo, KoL, KoR, hEff, Flx, .true., & + h_neglect, h_neglect_edge=h_neglect_edge) ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_data1d(v, 7, Flx, & (/0.,0.,0.,0.,0.,0.,0./), 'Identical columns, rho flux (=0)') call neutral_surface_flux(3, 2*3+2, 2, (/10.,10.,10./), (/10.,10.,10./), & ! nk, hL, hR (/-1.,-1.,-1./), (/1.,1.,1./), & ! Sl, Sr - PiLRo, PiRLo, KoL, KoR, hEff, Flx, .true.) + PiLRo, PiRLo, KoL, KoR, hEff, Flx, .true., & + h_neglect, h_neglect_edge=h_neglect_edge) ndiff_unit_tests_continuous = ndiff_unit_tests_continuous .or. test_data1d(v, 7, Flx, & (/0.,20.,0.,20.,0.,20.,0./), 'Identical columns, S flux') @@ -2163,6 +2221,7 @@ logical function ndiff_unit_tests_discontinuous(verbose) real, dimension(nk,2) :: poly_T_l, poly_T_r, poly_S, poly_slope ! Linear reconstruction for T real, dimension(nk,2) :: dRdT, dRdS integer :: iMethod + real :: h_neglect, h_neglect_edge integer :: k logical :: v @@ -2171,6 +2230,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) ndiff_unit_tests_discontinuous = .false. ! Normally return false write(*,*) '==== MOM_neutral_diffusion: ndiff_unit_tests_discontinuous =' + h_neglect = 1.0e-30 ; h_neglect_edge = 1.0e-10 + ! Unit tests for find_neutral_surface_positions_discontinuous ! Salinity is 0 for all these tests Sl(:) = 0. ; Sr(:) = 0. ; poly_S(:,:) = 0. ; SiL(:,:) = 0. ; SiR(:,:) = 0. @@ -2182,8 +2243,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) do k = 1,nk ; Pres_l(k+1) = Pres_l(k) + hL(k) ; Pres_r(k+1) = Pres_r(k) + hR(k) ; enddo ! Identical columns Tl = (/20.,16.,12./) ; Tr = (/20.,16.,12./) - call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod ) - call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) + call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod, h_neglect, h_neglect_edge ) + call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod, h_neglect, h_neglect_edge ) call find_neutral_surface_positions_discontinuous(nk, 1, Pres_l, TiL, SiL, dRdT, dRdS, & Pres_r, TiR, SiR, dRdT, dRdS, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & @@ -2194,8 +2255,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/0.,10.,0.,0.,0.,10.,0.,0.,0.,10.,0.,0./), & ! hEff 'Identical columns') Tl = (/20.,16.,12./) ; Tr = (/18.,14.,10./) - call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod ) - call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) + call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod, h_neglect, h_neglect_edge ) + call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod, h_neglect, h_neglect_edge ) call find_neutral_surface_positions_discontinuous(nk, 1, Pres_l, TiL, SiL, dRdT, dRdS, & Pres_r, TiR, SiR, dRdT, dRdS, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & @@ -2206,8 +2267,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/0.0, 5.0, 0.0, 5.0, 0.0, 5.0, 0.0, 5.0, 0.0, 5.0, 0.0/), & ! hEff 'Right column slightly cooler') Tl = (/18.,14.,10./) ; Tr = (/20.,16.,12./) ; - call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod ) - call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) + call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod, h_neglect, h_neglect_edge ) + call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod, h_neglect, h_neglect_edge ) call find_neutral_surface_positions_discontinuous(nk, 1, Pres_l, TiL, SiL, dRdT, dRdS, & Pres_r, TiR, SiR, dRdT, dRdS, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & @@ -2218,8 +2279,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/0.0, 5.0, 0.0, 5.0, 0.0, 5.0, 0.0, 5.0, 0.0, 5.0, 0.0/), & ! hEff 'Left column slightly cooler') Tl = (/20.,16.,12./) ; Tr = (/14.,10.,6./) - call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod ) - call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) + call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod, h_neglect, h_neglect_edge ) + call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod, h_neglect, h_neglect_edge ) call find_neutral_surface_positions_discontinuous(nk, 1, Pres_l, TiL, SiL, dRdT, dRdS, & Pres_r, TiR, SiR, dRdT, dRdS, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & @@ -2230,8 +2291,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/0.0, 0.0, 0.0, 5.0, 0.0, 5.0, 0.0, 5.0, 0.0, 0.0, 0.0/), & ! hEff 'Right column somewhat cooler') Tl = (/20.,16.,12./) ; Tr = (/8.,6.,4./) - call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod ) - call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) + call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod, h_neglect, h_neglect_edge ) + call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod, h_neglect, h_neglect_edge ) call find_neutral_surface_positions_discontinuous(nk, 1, Pres_l, TiL, SiL, dRdT, dRdS, & Pres_r, TiR, SiR, dRdT, dRdS, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & @@ -2242,8 +2303,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/), & ! hEff 'Right column much cooler') Tl = (/14.,14.,10./) ; Tr = (/14.,14.,10./) - call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod ) - call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) + call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod, h_neglect, h_neglect_edge ) + call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod, h_neglect, h_neglect_edge ) call find_neutral_surface_positions_discontinuous(nk, 1, Pres_l, TiL, SiL, dRdT, dRdS, & Pres_r, TiR, SiR, dRdT, dRdS, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & @@ -2254,8 +2315,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/0.,10.,0.,0.,0.,10.,0.,0.,0.,10.,0.,0./), & ! hEff 'Identical columns with mixed layer') Tl = (/20.,16.,12./) ; Tr = (/14.,14.,10./) - call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod ) - call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) + call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod, h_neglect, h_neglect_edge ) + call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod, h_neglect, h_neglect_edge ) call find_neutral_surface_positions_discontinuous(nk, 1, Pres_l, TiL, SiL, dRdT, dRdS, & Pres_r, TiR, SiR, dRdT, dRdS, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & @@ -2266,8 +2327,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 5.0, 0.0/), & ! hEff 'Right column with mixed layer') Tl = (/14.,14.,6./) ; Tr = (/12.,16.,8./) - call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod ) - call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod ) + call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod, h_neglect, h_neglect_edge ) + call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod, h_neglect, h_neglect_edge ) call find_neutral_surface_positions_discontinuous(nk, 1, Pres_l, TiL, SiL, dRdT, dRdS, & Pres_r, TiR, SiR, dRdT, dRdS, PoL, PoR, KoL, KoR, hEff) ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. test_nsp(v, 12, KoL, KoR, PoL, PoR, hEff, & From 9974b02c254949abc389cb5e0fcb394e18cad0b8 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 18 Dec 2017 18:23:21 -0500 Subject: [PATCH 20/20] (*)Initialize thicknesses directly to H units Perform the conversion of thicknesses into the internal H unit representation inside of all of the intialization routines, allowing things like ALE remapping to work correctly during initialization. This affects a large number of routines for initializing thickness, temperatures and salinities, and velocities. With these changes (and changes to ALE), all MOM6 test cases now give the same initial values regardless of the scaling of H. All answers in the existing test cases are bitwise identical. --- .../MOM_state_initialization.F90 | 98 +++++++------ src/user/DOME2d_initialization.F90 | 41 +++--- src/user/DOME_initialization.F90 | 6 +- src/user/ISOMIP_initialization.F90 | 34 ++--- src/user/Neverland_initialization.F90 | 6 +- src/user/Phillips_initialization.F90 | 6 +- src/user/Rossby_front_2d_initialization.F90 | 52 +++---- src/user/SCM_CVmix_tests.F90 | 8 +- src/user/SCM_idealized_hurricane.F90 | 5 +- src/user/adjustment_initialization.F90 | 129 +++++++++--------- src/user/baroclinic_zone_initialization.F90 | 12 +- src/user/benchmark_initialization.F90 | 6 +- src/user/circle_obcs_initialization.F90 | 18 +-- src/user/external_gwave_initialization.F90 | 12 +- src/user/lock_exchange_initialization.F90 | 4 +- src/user/seamount_initialization.F90 | 16 +-- src/user/sloshing_initialization.F90 | 9 +- src/user/soliton_initialization.F90 | 11 +- src/user/user_initialization.F90 | 19 ++- 19 files changed, 256 insertions(+), 236 deletions(-) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 56e49a3fc9..09e0881607 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -164,6 +164,8 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & type(EOS_type), pointer :: eos => NULL() logical :: debug ! If true, write debugging output. logical :: debug_obc ! If true, do debugging calls related to OBCs. + logical :: debug_layers = .false. + character(len=80) :: mesg ! This include declares and sets the variable "version". #include "version_variable.h" integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz @@ -284,7 +286,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & just_read_params=just_read) case ("lock_exchange"); call lock_exchange_initialize_thickness(h, G, GV, & PF, just_read_params=just_read) - case ("external_gwave"); call external_gwave_initialize_thickness(h, G, & + case ("external_gwave"); call external_gwave_initialize_thickness(h, G, GV, & PF, just_read_params=just_read) case ("DOME2D"); call DOME2d_initialize_thickness(h, G, GV, PF, & just_read_params=just_read) @@ -294,12 +296,12 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & just_read_params=just_read) case ("seamount"); call seamount_initialize_thickness(h, G, GV, PF, & just_read_params=just_read) - case ("soliton"); call soliton_initialize_thickness(h, G) + case ("soliton"); call soliton_initialize_thickness(h, G, GV) case ("phillips"); call Phillips_initialize_thickness(h, G, GV, PF, & just_read_params=just_read) case ("rossby_front"); call Rossby_front_initialize_thickness(h, G, GV, & PF, just_read_params=just_read) - case ("USER"); call user_initialize_thickness(h, G, PF, tv%T, & + case ("USER"); call user_initialize_thickness(h, G, GV, PF, & just_read_params=just_read) case default ; call MOM_error(FATAL, "MOM_initialize_state: "//& "Unrecognized layer thickness configuration "//trim(config)) @@ -341,19 +343,19 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & case ("linear"); call initialize_temp_salt_linear(tv%T, tv%S, G, PF, & just_read_params=just_read) case ("DOME2D"); call DOME2d_initialize_temperature_salinity ( tv%T, & - tv%S, h, G, PF, eos, just_read_params=just_read) + tv%S, h, G, GV, PF, eos, just_read_params=just_read) case ("ISOMIP"); call ISOMIP_initialize_temperature_salinity ( tv%T, & tv%S, h, G, GV, PF, eos, just_read_params=just_read) case ("adjustment2d"); call adjustment_initialize_temperature_salinity ( tv%T, & - tv%S, h, G, PF, eos, just_read_params=just_read) + tv%S, h, G, GV, PF, eos, just_read_params=just_read) case ("baroclinic_zone"); call baroclinic_zone_init_temperature_salinity( tv%T, & - tv%S, h, G, PF, just_read_params=just_read) + tv%S, h, G, GV, PF, just_read_params=just_read) case ("sloshing"); call sloshing_initialize_temperature_salinity(tv%T, & - tv%S, h, G, PF, eos, just_read_params=just_read) + tv%S, h, G, GV, PF, eos, just_read_params=just_read) case ("seamount"); call seamount_initialize_temperature_salinity(tv%T, & tv%S, h, G, GV, PF, eos, just_read_params=just_read) case ("rossby_front"); call Rossby_front_initialize_temperature_salinity ( tv%T, & - tv%S, h, G, PF, eos, just_read_params=just_read) + tv%S, h, G, GV, PF, eos, just_read_params=just_read) case ("SCM_ideal_hurr"); call SCM_idealized_hurricane_TS_init ( tv%T, & tv%S, h, G, GV, PF, just_read_params=just_read) case ("SCM_CVmix_tests"); call SCM_CVmix_tests_TS_init (tv%T, & @@ -418,22 +420,10 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & "units of m to kg m-2 or vice versa, depending on whether \n"//& "BOUSSINESQ is defined. This does not apply if a restart \n"//& "file is read.", default=.not.GV%Boussinesq, do_not_log=just_read) - if (new_sim) then - if (GV%Boussinesq .or. convert) then - ! Convert h from m to thickness units (H) - do k=1,nz ; do j=js,je ; do i=is,ie - h(i,j,k) = h(i,j,k)*GV%m_to_H - enddo ; enddo ; enddo - else - do k=1,nz ; do j=js,je ; do i=is,ie - h(i,j,k) = h(i,j,k)*GV%kg_m2_to_H - enddo ; enddo ; enddo - endif - if (convert .and. .not.GV%Boussinesq) & - ! Convert thicknesses from geomtric distances to mass-per-unit-area. - call convert_thickness(h, G, GV, tv) - endif + if (new_sim .and. convert .and. .not.GV%Boussinesq) & + ! Convert thicknesses from geomtric distances to mass-per-unit-area. + call convert_thickness(h, G, GV, tv) ! Remove the mass that would be displaced by an ice shelf or inverse barometer. call get_param(PF, mdl, "DEPRESS_INITIAL_SURFACE", depress_sfc, & @@ -489,6 +479,13 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & call hchksum(h, "MOM_initialize_state: h ", G%HI, haloshift=1, scale=GV%H_to_m) if ( use_temperature ) call hchksum(tv%T, "MOM_initialize_state: T ", G%HI, haloshift=1) if ( use_temperature ) call hchksum(tv%S, "MOM_initialize_state: S ", G%HI, haloshift=1) + if ( use_temperature .and. debug_layers) then ; do k=1,nz + write(mesg,'("MOM_IS: T[",I2,"]")') k + call hchksum(tv%T(:,:,k), mesg, G%HI, haloshift=1) + write(mesg,'("MOM_IS: S[",I2,"]")') k + call hchksum(tv%S(:,:,k), mesg, G%HI, haloshift=1) + enddo ; endif + endif call get_param(PF, mdl, "SPONGE", use_sponge, & @@ -607,8 +604,6 @@ subroutine initialize_thickness_from_file(h, G, GV, param_file, file_has_thickne ! This subroutine reads the layer thicknesses from file. real :: eta(SZI_(G),SZJ_(G),SZK_(G)+1) integer :: inconsistent = 0 - real :: dilate ! The amount by which each layer is dilated to agree - ! with the bottom depth and free surface height, nondim. logical :: correct_thickness logical :: just_read ! If true, just read parameters but set nothing. character(len=20) :: verticalCoordinate character(len=40) :: mdl = "initialize_thickness_from_file" ! This subroutine's name. @@ -635,8 +630,12 @@ subroutine initialize_thickness_from_file(h, G, GV, param_file, file_has_thickne " initialize_thickness_from_file: Unable to open "//trim(filename)) if (file_has_thickness) then + !### Consider adding a parameter to use to rescale h. if (just_read) return ! All run-time parameters have been read, so return. call MOM_read_data(filename, "h", h(:,:,:), G%Domain) + do k=1,nz ; do j=js,je ; do i=is,ie + h(i,j,k) = GV%m_to_H * h(i,j,k) + enddo ; enddo ; enddo else call get_param(param_file, mdl, "ADJUST_THICKNESS", correct_thickness, & "If true, all mass below the bottom removed if the \n"//& @@ -652,9 +651,9 @@ subroutine initialize_thickness_from_file(h, G, GV, param_file, file_has_thickne do k=nz,1,-1 ; do j=js,je ; do i=is,ie if (eta(i,j,K) < (eta(i,j,K+1) + GV%Angstrom_z)) then eta(i,j,K) = eta(i,j,K+1) + GV%Angstrom_z - h(i,j,k) = GV%Angstrom_z + h(i,j,k) = GV%Angstrom else - h(i,j,k) = eta(i,j,K) - eta(i,j,K+1) + h(i,j,k) = GV%m_to_H * (eta(i,j,K) - eta(i,j,K+1)) endif enddo ; enddo ; enddo @@ -690,8 +689,8 @@ end subroutine initialize_thickness_from_file subroutine adjustEtaToFitBathymetry(G, GV, eta, h) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G), SZK_(G)+1), intent(inout) :: eta - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(inout) :: h !< Layer thicknesses, in m + real, dimension(SZI_(G),SZJ_(G), SZK_(G)+1), intent(inout) :: eta !< Interface heights, in m + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(inout) :: h !< Layer thicknesses, in H ! Local variables integer :: i, j, k, is, ie, js, je, nz, contractions, dilations real, parameter :: hTolerance = 0.1 !< Tolerance to exceed adjustment criteria (m) @@ -714,6 +713,8 @@ subroutine adjustEtaToFitBathymetry(G, GV, eta, h) call MOM_error(WARNING, 'adjustEtaToFitBathymetry: '//mesg) endif + ! To preserve previous answers, delay converting thicknesses to units of H + ! until the end of this routine. do k=nz,1,-1 ; do j=js,je ; do i=is,ie ! Collapse layers to thinnest possible if the thickness less than ! the thinnest possible (or negative). @@ -721,7 +722,7 @@ subroutine adjustEtaToFitBathymetry(G, GV, eta, h) eta(i,j,K) = eta(i,j,K+1) + GV%Angstrom_z h(i,j,k) = GV%Angstrom_z else - h(i,j,k) = eta(i,j,K) - eta(i,j,K+1) + h(i,j,k) = (eta(i,j,K) - eta(i,j,K+1)) endif enddo ; enddo ; enddo @@ -738,9 +739,15 @@ subroutine adjustEtaToFitBathymetry(G, GV, eta, h) dilate = (eta(i,j,1)+G%bathyT(i,j)) / (eta(i,j,1)-eta(i,j,nz+1)) do k=1,nz ; h(i,j,k) = h(i,j,k) * dilate ; enddo endif - do k=nz, 2, -1; eta(i,j,K) = eta(i,j,K+1) + h(i,j,k); enddo + do k=nz,2,-1 ; eta(i,j,K) = eta(i,j,K+1) + h(i,j,k) ; enddo endif enddo ; enddo + + ! Now convert thicknesses to units of H. + do k=1,nz ; do j=js,je ; do i=is,ie + h(i,j,k) = h(i,j,k)*GV%m_to_H + enddo ; enddo ; enddo + call sum_across_PEs(dilations) if ((dilations > 0) .and. (is_root_pe())) then write(mesg,'("Thickness initial conditions were dilated ",'// & @@ -756,7 +763,7 @@ subroutine initialize_thickness_uniform(h, G, GV, param_file, just_read_params) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized, in m. + intent(out) :: h !< The thickness that is being initialized, in H. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. logical, optional, intent(in) :: just_read_params !< If present and true, this call will @@ -803,9 +810,9 @@ subroutine initialize_thickness_uniform(h, G, GV, param_file, just_read_params) eta1D(K) = e0(K) if (eta1D(K) < (eta1D(K+1) + GV%Angstrom_z)) then eta1D(K) = eta1D(K+1) + GV%Angstrom_z - h(i,j,k) = GV%Angstrom_z + h(i,j,k) = GV%Angstrom else - h(i,j,k) = eta1D(K) - eta1D(K+1) + h(i,j,k) = GV%m_to_H * (eta1D(K) - eta1D(K+1)) endif enddo enddo ; enddo @@ -819,7 +826,7 @@ subroutine initialize_thickness_list(h, G, GV, param_file, just_read_params) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized, in m. + intent(out) :: h !< The thickness that is being initialized, in H. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. logical, optional, intent(in) :: just_read_params !< If present and true, this call will @@ -889,9 +896,9 @@ subroutine initialize_thickness_list(h, G, GV, param_file, just_read_params) eta1D(K) = e0(K) if (eta1D(K) < (eta1D(K+1) + GV%Angstrom_z)) then eta1D(K) = eta1D(K+1) + GV%Angstrom_z - h(i,j,k) = GV%Angstrom_z + h(i,j,k) = GV%Angstrom else - h(i,j,k) = eta1D(K) - eta1D(K+1) + h(i,j,k) = GV%m_to_H * (eta1D(K) - eta1D(K+1)) endif enddo enddo ; enddo @@ -1959,7 +1966,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, PF, just_read_params) ! type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(out) :: h !< Layer thicknesses being initialized, in m + intent(out) :: h !< Layer thicknesses being initialized, in H type(thermo_var_ptrs), intent(inout) :: tv !< A structure pointing to various thermodynamic !! variables including temperature and salinity type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure @@ -2016,7 +2023,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, PF, just_read_params) real, dimension(:), allocatable :: z_edges_in, z_in, Rb real, dimension(:,:,:), allocatable, target :: temp_z, salt_z, mask_z real, dimension(:,:,:), allocatable :: rho_z - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: zi + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: zi ! Interface heights in m. real, dimension(SZI_(G),SZJ_(G)) :: nlevs real, dimension(SZI_(G)) :: press @@ -2025,7 +2032,8 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, PF, just_read_params) real, dimension(:), allocatable :: hTarget real, dimension(:,:), allocatable :: area_shelf_h real, dimension(:,:), allocatable, target :: frac_shelf_h - real, dimension(:,:,:), allocatable :: tmpT1dIn, tmpS1dIn, h1, tmp_mask_in + real, dimension(:,:,:), allocatable :: tmpT1dIn, tmpS1dIn, tmp_mask_in + real, dimension(:,:,:), allocatable :: h1 ! Thicknesses in H. real :: zTopOfCell, zBottomOfCell type(regridding_CS) :: regridCS ! Regridding parameters and work arrays type(remapping_CS) :: remapCS ! Remapping parameters and work arrays @@ -2229,11 +2237,11 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, PF, just_read_params) tmpT1dIn(i,j,k) = -99.9 tmpS1dIn(i,j,k) = -99.9 endif - h1(i,j,k) = zTopOfCell - zBottomOfCell + h1(i,j,k) = GV%m_to_H * (zTopOfCell - zBottomOfCell) if (h1(i,j,k)>0.) nPoints = nPoints + 1 zTopOfCell = zBottomOfCell ! Bottom becomes top for next value of k enddo - h1(i,j,kd) = h1(i,j,kd) + ( zTopOfCell + G%bathyT(i,j) ) ! In case data is deeper than model + h1(i,j,kd) = h1(i,j,kd) + GV%m_to_H * ( zTopOfCell + G%bathyT(i,j) ) ! In case data is deeper than model endif ! mask2dT enddo ; enddo deallocate( tmp_mask_in ) @@ -2256,7 +2264,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, PF, just_read_params) zTopOfCell = 0. ; zBottomOfCell = 0. do k = 1, nz zBottomOfCell = max( zTopOfCell - hTarget(k), -G%bathyT(i,j) ) - h(i,j,k) = zTopOfCell - zBottomOfCell + h(i,j,k) = GV%m_to_H * (zTopOfCell - zBottomOfCell) zTopOfCell = zBottomOfCell ! Bottom becomes top for next value of k enddo else @@ -2315,9 +2323,9 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, PF, just_read_params) do k=nz,1,-1 ; do j=js,je ; do i=is,ie if (zi(i,j,K) < (zi(i,j,K+1) + GV%Angstrom_z)) then zi(i,j,K) = zi(i,j,K+1) + GV%Angstrom_z - h(i,j,k) = GV%Angstrom_z + h(i,j,k) = GV%Angstrom else - h(i,j,k) = zi(i,j,K) - zi(i,j,K+1) + h(i,j,k) = GV%m_to_H * (zi(i,j,K) - zi(i,j,K+1)) endif enddo ; enddo ; enddo inconsistent=0 diff --git a/src/user/DOME2d_initialization.F90 b/src/user/DOME2d_initialization.F90 index 2456b2dbc8..108c468c5c 100644 --- a/src/user/DOME2d_initialization.F90 +++ b/src/user/DOME2d_initialization.F90 @@ -90,7 +90,7 @@ subroutine DOME2d_initialize_thickness ( h, G, GV, param_file, just_read_params type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized, in m. + intent(out) :: h !< The thickness that is being initialized, in H. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. logical, optional, intent(in) :: just_read_params !< If present and true, this call will @@ -150,17 +150,17 @@ subroutine DOME2d_initialize_thickness ( h, G, GV, param_file, just_read_params eta1D(k) = e0(k) if (eta1D(k) < (eta1D(k+1) + GV%Angstrom_z)) then eta1D(k) = eta1D(k+1) + GV%Angstrom_z - h(i,j,k) = GV%Angstrom_z + h(i,j,k) = GV%Angstrom else - h(i,j,k) = eta1D(k) - eta1D(k+1) + h(i,j,k) = GV%m_to_H * (eta1D(k) - eta1D(k+1)) endif enddo - x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon - if ( x <= dome2d_width_bay ) then - h(i,j,1:nz-1) = GV%Angstrom_Z - h(i,j,nz) = dome2d_depth_bay * G%max_depth - (nz-1) * GV%Angstrom_Z - endif + x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon + if ( x <= dome2d_width_bay ) then + h(i,j,1:nz-1) = GV%Angstrom + h(i,j,nz) = GV%m_to_H * dome2d_depth_bay * G%max_depth - (nz-1) * GV%Angstrom + endif enddo ; enddo @@ -172,16 +172,16 @@ subroutine DOME2d_initialize_thickness ( h, G, GV, param_file, just_read_params ! eta1D(k) = e0(k) ! if (eta1D(k) < (eta1D(k+1) + min_thickness)) then ! eta1D(k) = eta1D(k+1) + min_thickness - ! h(i,j,k) = min_thickness + ! h(i,j,k) = GV%m_to_H * min_thickness ! else - ! h(i,j,k) = eta1D(k) - eta1D(k+1) + ! h(i,j,k) = GV%m_to_H * (eta1D(k) - eta1D(k+1)) ! endif ! enddo ! ! x = G%geoLonT(i,j) / G%len_lon ! if ( x <= dome2d_width_bay ) then - ! h(i,j,1:nz-1) = min_thickness - ! h(i,j,nz) = dome2d_depth_bay * G%max_depth - (nz-1) * min_thickness + ! h(i,j,1:nz-1) = GV%m_to_H * min_thickness + ! h(i,j,nz) = GV%m_to_H * (dome2d_depth_bay * G%max_depth - (nz-1) * min_thickness) ! endif ! ! enddo ; enddo @@ -194,9 +194,9 @@ subroutine DOME2d_initialize_thickness ( h, G, GV, param_file, just_read_params eta1D(k) = e0(k) if (eta1D(k) < (eta1D(k+1) + min_thickness)) then eta1D(k) = eta1D(k+1) + min_thickness - h(i,j,k) = min_thickness + h(i,j,k) = GV%m_to_H * min_thickness else - h(i,j,k) = eta1D(k) - eta1D(k+1) + h(i,j,k) = GV%m_to_H * (eta1D(k) - eta1D(k+1)) endif enddo enddo ; enddo @@ -204,7 +204,7 @@ subroutine DOME2d_initialize_thickness ( h, G, GV, param_file, just_read_params case ( REGRIDDING_SIGMA ) do j=js,je ; do i=is,ie delta_h = G%bathyT(i,j) / nz - h(i,j,:) = delta_h + h(i,j,:) = GV%m_to_H * delta_h enddo ; enddo case default @@ -217,16 +217,17 @@ end subroutine DOME2d_initialize_thickness !> Initialize temperature and salinity in the 2d DOME configuration -subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, param_file, & +subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, GV, param_file, & eqn_of_state, just_read_params) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: T !< Potential temperature (degC) real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: S !< Salinity (ppt) - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Layer thickness (m or Pa) + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Layer thickness in units of H (m or kg m-2) type(param_file_type), intent(in) :: param_file !< Parameter file structure type(EOS_type), pointer :: eqn_of_state !< Equation of state structure logical, optional, intent(in) :: just_read_params !< If present and true, this call will - !! only read parameters without changing h. + !! only read parameters without changing T & S. ! Local variables integer :: i, j, k, is, ie, js, je, nz @@ -275,7 +276,7 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, param_file, & do j=js,je ; do i=is,ie xi0 = 0.0 do k = 1,nz - xi1 = xi0 + h(i,j,k) / G%max_depth + xi1 = xi0 + (GV%H_to_m * h(i,j,k)) / G%max_depth S(i,j,k) = 34.0 + 0.5 * S_range * (xi0 + xi1) xi0 = xi1 enddo @@ -286,7 +287,7 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, param_file, & do j=js,je ; do i=is,ie xi0 = 0.0 do k = 1,nz - xi1 = xi0 + h(i,j,k) / G%max_depth + xi1 = xi0 + (GV%H_to_m * h(i,j,k)) / G%max_depth S(i,j,k) = 34.0 + 0.5 * S_range * (xi0 + xi1) xi0 = xi1 enddo diff --git a/src/user/DOME_initialization.F90 b/src/user/DOME_initialization.F90 index 35287e14f2..99c5f3de5c 100644 --- a/src/user/DOME_initialization.F90 +++ b/src/user/DOME_initialization.F90 @@ -77,7 +77,7 @@ subroutine DOME_initialize_thickness(h, G, GV, param_file, just_read_params) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized, in m. + intent(out) :: h !< The thickness that is being initialized, in H. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. logical, optional, intent(in) :: just_read_params !< If present and true, this call will @@ -115,9 +115,9 @@ subroutine DOME_initialize_thickness(h, G, GV, param_file, just_read_params) eta1D(K) = e0(K) if (eta1D(K) < (eta1D(K+1) + GV%Angstrom_z)) then eta1D(K) = eta1D(K+1) + GV%Angstrom_z - h(i,j,k) = GV%Angstrom_z + h(i,j,k) = GV%Angstrom else - h(i,j,k) = eta1D(K) - eta1D(K+1) + h(i,j,k) = GV%m_to_H * (eta1D(K) - eta1D(K+1)) endif enddo enddo ; enddo diff --git a/src/user/ISOMIP_initialization.F90 b/src/user/ISOMIP_initialization.F90 index f91808bd59..639c4839ce 100644 --- a/src/user/ISOMIP_initialization.F90 +++ b/src/user/ISOMIP_initialization.F90 @@ -138,7 +138,7 @@ subroutine ISOMIP_initialize_thickness ( h, G, GV, param_file, tv, just_read_par type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized, in m. + intent(out) :: h !< The thickness that is being initialized, in H. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any @@ -211,9 +211,9 @@ subroutine ISOMIP_initialize_thickness ( h, G, GV, param_file, tv, just_read_par eta1D(k) = e0(k) if (eta1D(k) < (eta1D(k+1) + GV%Angstrom_z)) then eta1D(k) = eta1D(k+1) + GV%Angstrom_z - h(i,j,k) = GV%Angstrom_z + h(i,j,k) = GV%Angstrom else - h(i,j,k) = eta1D(k) - eta1D(k+1) + h(i,j,k) = GV%m_to_H * (eta1D(k) - eta1D(k+1)) endif enddo enddo ; enddo @@ -226,9 +226,9 @@ subroutine ISOMIP_initialize_thickness ( h, G, GV, param_file, tv, just_read_par eta1D(k) = -G%max_depth * real(k-1) / real(nz) if (eta1D(k) < (eta1D(k+1) + min_thickness)) then eta1D(k) = eta1D(k+1) + min_thickness - h(i,j,k) = min_thickness + h(i,j,k) = GV%m_to_H * min_thickness else - h(i,j,k) = eta1D(k) - eta1D(k+1) + h(i,j,k) = GV%m_to_H * (eta1D(k) - eta1D(k+1)) endif enddo enddo ; enddo @@ -237,7 +237,7 @@ subroutine ISOMIP_initialize_thickness ( h, G, GV, param_file, tv, just_read_par if (just_read) return ! All run-time parameters have been read, so return. do j=js,je ; do i=is,ie delta_h = G%bathyT(i,j) / dfloat(nz) - h(i,j,:) = delta_h + h(i,j,:) = GV%m_to_H * delta_h end do ; end do case default @@ -255,11 +255,11 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, param_file, type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: T !< Potential temperature (degC) real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: S !< Salinity (ppt) - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Layer thickness (m or Pa) + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Layer thickness in H (m or kg m-2) type(param_file_type), intent(in) :: param_file !< Parameter file structure type(EOS_type), pointer :: eqn_of_state !< Equation of state structure logical, optional, intent(in) :: just_read_params !< If present and true, this call will - !! only read parameters without changing h. + !! only read parameters without changing T & S. ! Local variables integer :: i, j, k, is, ie, js, je, nz, itt @@ -309,12 +309,12 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, param_file, S_range = S_range / G%max_depth ! Convert S_range into dS/dz T_range = T_range / G%max_depth ! Convert T_range into dT/dz do j=js,je ; do i=is,ie - xi0 = -G%bathyT(i,j); + xi0 = -G%bathyT(i,j) do k = nz,1,-1 - xi0 = xi0 + 0.5 * h(i,j,k) ! Depth in middle of layer + xi0 = xi0 + 0.5 * h(i,j,k) * GV%H_to_m ! Depth in middle of layer S(i,j,k) = S_sur + S_range * xi0 T(i,j,k) = T_sur + T_range * xi0 - xi0 = xi0 + 0.5 * h(i,j,k) ! Depth at top of layer + xi0 = xi0 + 0.5 * h(i,j,k) * GV%H_to_m ! Depth at top of layer enddo enddo ; enddo @@ -346,13 +346,13 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, G, GV, param_file, T_range = T_range / G%max_depth ! Convert T_range into dT/dz do j=js,je ; do i=is,ie - xi0 = 0.0; + xi0 = 0.0 do k = 1,nz !T0(k) = T_Ref; S0(k) = S_Ref - xi1 = xi0 + 0.5 * h(i,j,k); - S0(k) = S_sur + S_range * xi1; - T0(k) = T_sur + T_range * xi1; - xi0 = xi0 + h(i,j,k); + xi1 = xi0 + 0.5 * h(i,j,k) * GV%H_to_m + S0(k) = S_sur + S_range * xi1 + T0(k) = T_sur + T_range * xi1 + xi0 = xi0 + h(i,j,k) * GV%H_to_m !write(*,*)'S,T,xi0,xi1,k',S0(k),T0(k),xi0,xi1,k enddo @@ -584,7 +584,7 @@ subroutine ISOMIP_initialize_sponges(G, GV, tv, PF, use_ALE, CSp, ACSp) S_range = S_range / G%max_depth ! Convert S_range into dS/dz T_range = T_range / G%max_depth ! Convert T_range into dT/dz do j=js,je ; do i=is,ie - xi0 = -G%bathyT(i,j); + xi0 = -G%bathyT(i,j) do k = nz,1,-1 xi0 = xi0 + 0.5 * h(i,j,k) ! Depth in middle of layer S(i,j,k) = S_sur + S_range * xi0 diff --git a/src/user/Neverland_initialization.F90 b/src/user/Neverland_initialization.F90 index ed4ee5081c..d22d7457ab 100644 --- a/src/user/Neverland_initialization.F90 +++ b/src/user/Neverland_initialization.F90 @@ -110,7 +110,7 @@ subroutine Neverland_initialize_thickness(h, G, GV, param_file, eqn_of_state, P_ 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, intent(out), dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h !< The thickness that is being - !! initialized. + !! initialized, in H. type(param_file_type), intent(in) :: param_file !< A structure indicating the open !! file to parse for model !! parameter values. @@ -141,8 +141,8 @@ subroutine Neverland_initialize_thickness(h, G, GV, param_file, eqn_of_state, P_ do j=js,je ; do i=is,ie e_interface = -G%bathyT(i,j) do k=nz,1,-1 - h(i,j,k) = max( GV%Angstrom_z, e0(k) - e_interface ) - e_interface = max( e0(k), e_interface - h(i,j,k) ) + h(i,j,k) = max( GV%Angstrom, GV%m_to_H * (e0(k) - e_interface) ) + e_interface = max( e0(k), e_interface - GV%H_to_m * h(i,j,k) ) enddo enddo ; enddo diff --git a/src/user/Phillips_initialization.F90 b/src/user/Phillips_initialization.F90 index c6a9e160f6..163b85e1b5 100644 --- a/src/user/Phillips_initialization.F90 +++ b/src/user/Phillips_initialization.F90 @@ -35,7 +35,7 @@ subroutine Phillips_initialize_thickness(h, G, GV, param_file, just_read_params) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized, in m. + intent(out) :: h !< The thickness that is being initialized, in H. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. logical, optional, intent(in) :: just_read_params !< If present and true, this call will @@ -102,9 +102,9 @@ subroutine Phillips_initialize_thickness(h, G, GV, param_file, just_read_params) eta1D(K) = eta_im(j,K) if (eta1D(K) < (eta1D(K+1) + GV%Angstrom_z)) then eta1D(K) = eta1D(K+1) + GV%Angstrom_z - h(i,j,k) = GV%Angstrom_z + h(i,j,k) = GV%Angstrom else - h(i,j,k) = eta1D(K) - eta1D(K+1) + h(i,j,k) = GV%m_to_H * (eta1D(K) - eta1D(K+1)) endif enddo enddo ; enddo diff --git a/src/user/Rossby_front_2d_initialization.F90 b/src/user/Rossby_front_2d_initialization.F90 index 43bca2f117..0c63daaea8 100644 --- a/src/user/Rossby_front_2d_initialization.F90 +++ b/src/user/Rossby_front_2d_initialization.F90 @@ -42,7 +42,7 @@ subroutine Rossby_front_initialize_thickness(h, G, GV, param_file, just_read_par type(ocean_grid_type), intent(in) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized, in m. + intent(out) :: h !< The thickness that is being initialized, in H. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. logical, optional, intent(in) :: just_read_params !< If present and true, this call will @@ -84,7 +84,7 @@ subroutine Rossby_front_initialize_thickness(h, G, GV, param_file, just_read_par stretch = ( ( G%max_depth + eta ) / G%max_depth ) h0 = ( G%max_depth / real(nz) ) * stretch do k = 1, nz - h(i,j,k) = h0 + h(i,j,k) = h0 * GV%m_to_H enddo end do ; end do @@ -95,7 +95,7 @@ subroutine Rossby_front_initialize_thickness(h, G, GV, param_file, just_read_par stretch = ( ( G%max_depth + eta ) / G%max_depth ) h0 = ( G%max_depth / real(nz) ) * stretch do k = 1, nz - h(i,j,k) = h0 + h(i,j,k) = h0 * GV%m_to_H enddo end do ; end do @@ -109,16 +109,17 @@ end subroutine Rossby_front_initialize_thickness !> Initialization of temperature and salinity in the Rossby front test -subroutine Rossby_front_initialize_temperature_salinity(T, S, h, G, & +subroutine Rossby_front_initialize_temperature_salinity(T, S, h, G, GV, & param_file, eqn_of_state, just_read_params) type(ocean_grid_type), intent(in) :: G !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: T !< Potential temperature [deg C] real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: S !< Salinity [ppt] - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Thickness + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Thickness in H type(param_file_type), intent(in) :: param_file !< Parameter file handle type(EOS_type), pointer :: eqn_of_state !< Equation of state structure logical, optional, intent(in) :: just_read_params !< If present and true, this call will - !! only read parameters without changing h. + !! only read parameters without changing T & S. integer :: i, j, k, is, ie, js, je, nz real :: T_ref, S_ref ! Reference salinity and temerature within surface layer @@ -151,7 +152,7 @@ subroutine Rossby_front_initialize_temperature_salinity(T, S, h, G, & zi = 0. do k = 1, nz zi = zi - h(i,j,k) ! Bottom interface position - zc = zi - 0.5*h(i,j,k) ! Position of middle of cell + zc = GV%H_to_m * (zi - 0.5*h(i,j,k)) ! Position of middle of cell zc = min( zc, -Hml(G, G%geoLatT(i,j)) ) ! Bound by depth of mixed layer T(i,j,k) = T_ref + dTdz * zc ! Linear temperature profile enddo @@ -162,21 +163,26 @@ end subroutine Rossby_front_initialize_temperature_salinity !> Initialization of u and v in the Rossby front test subroutine Rossby_front_initialize_velocity(u, v, h, G, GV, param_file, just_read_params) - type(ocean_grid_type), intent(in) :: G !< Grid structure - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: u !< i-component of velocity [m/s] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: v !< j-component of velocity [m/s] - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Thickness [H] - type(param_file_type), intent(in) :: param_file !< A structure indicating the - !! open file to parse for model - !! parameter values. - logical, optional, intent(in) :: just_read_params !< If present and true, this call will - !! only read parameters without changing h. - - real :: y ! Non-dimensional coordinate across channel, 0..pi - real :: T_range ! Range of salinities and temperatures over the vertical - real :: dUdT ! Factor to convert dT/dy into dU/dz, g*alpha/f - real :: dRho_dT, zi, zc, zm, f, Ty, Dml, hAtU + type(ocean_grid_type), intent(in) :: G !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(out) :: u !< i-component of velocity [m/s] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(out) :: v !< j-component of velocity [m/s] + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), & + intent(in) :: h !< Thickness [H] + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file + !! to parse for model parameter values. + logical, optional, intent(in) :: just_read_params !< If present and true, this call + !! will only read parameters without setting u & v. + + real :: y ! Non-dimensional coordinate across channel, 0..pi + real :: T_range ! Range of salinities and temperatures over the vertical + real :: dUdT ! Factor to convert dT/dy into dU/dz, g*alpha/f + real :: dRho_dT + real :: Dml, zi, zc, zm ! Depths in units of m. + real :: f, Ty + real :: hAtU ! Interpolated layer thickness in units of m. integer :: i, j, k, is, ie, js, je, nz logical :: just_read ! If true, just read parameters but set nothing. character(len=40) :: verticalCoordinate @@ -204,7 +210,7 @@ subroutine Rossby_front_initialize_velocity(u, v, h, G, GV, param_file, just_rea Ty = dTdy( G, T_range, G%geoLatT(i,j) ) zi = 0. do k = 1, nz - hAtU = 0.5*(h(i,j,k)+h(i+1,j,k)) + hAtU = 0.5*(h(i,j,k)+h(i+1,j,k)) * GV%H_to_m zi = zi - hAtU ! Bottom interface position zc = zi - 0.5*hAtU ! Position of middle of cell zm = max( zc + Dml, 0. ) ! Height above bottom of mixed layer diff --git a/src/user/SCM_CVmix_tests.F90 b/src/user/SCM_CVmix_tests.F90 index be7f56ade2..74437a688f 100644 --- a/src/user/SCM_CVmix_tests.F90 +++ b/src/user/SCM_CVmix_tests.F90 @@ -102,17 +102,17 @@ subroutine SCM_CVmix_tests_TS_init(T, S, h, G, GV, param_file, just_read_params) do k=1,nz eta(K+1) = eta(K) - h(i,j,k)*GV%H_to_m ! Interface below layer (in m) zC = 0.5*( eta(K) + eta(K+1) ) ! Z of middle of layer (in m) - DZ = min(0., zC+UpperLayerTempMLD*GV%H_to_m) + DZ = min(0., zC + UpperLayerTempMLD) if (DZ.ge.0.0) then ! in Layer 1 T(i,j,k) = UpperLayerTemp else ! in Layer 2 - T(i,j,k) = LowerLayerTemp + LowerLayerdTdZ/GV%H_to_m * DZ + T(i,j,k) = LowerLayerTemp + LowerLayerdTdZ * DZ endif - DZ = min(0., zC+UpperLayerSaltMLD) + DZ = min(0., zC + UpperLayerSaltMLD) if (DZ.ge.0.0) then ! in Layer 1 S(i,j,k) = UpperLayerSalt else ! in Layer 2 - S(i,j,k) = LowerLayerSalt + LowerLayerdSdZ/GV%H_to_m * DZ + S(i,j,k) = LowerLayerSalt + LowerLayerdSdZ * DZ endif enddo ! k enddo ; enddo diff --git a/src/user/SCM_idealized_hurricane.F90 b/src/user/SCM_idealized_hurricane.F90 index e3ef6ad272..85b76c4ac5 100644 --- a/src/user/SCM_idealized_hurricane.F90 +++ b/src/user/SCM_idealized_hurricane.F90 @@ -50,7 +50,7 @@ subroutine SCM_idealized_hurricane_TS_init(T, S, h, G, GV, param_file, just_read type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: T !< Potential temperature (degC) real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: S !< Salinity (psu) - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Layer thickness (m or Pa) + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Layer thickness in H (m or Pa) type(param_file_type), intent(in) :: param_file !< Input parameter structure logical, optional, intent(in) :: just_read_params !< If present and true, this call will !! only read parameters without changing h. @@ -86,8 +86,7 @@ subroutine SCM_idealized_hurricane_TS_init(T, S, h, G, GV, param_file, just_read do k=1,nz eta(K+1) = eta(K) - h(i,j,k)*GV%H_to_m ! Interface below layer (in m) zC = 0.5*( eta(K) + eta(K+1) ) ! Z of middle of layer (in m) - T(i,j,k) = SST_ref + dTdz/GV%H_to_m & - * min(0., zC+MLD*GV%H_to_m) + T(i,j,k) = SST_ref + dTdz * min(0., zC + MLD) S(i,j,k) = S_ref enddo ! k enddo ; enddo diff --git a/src/user/adjustment_initialization.F90 b/src/user/adjustment_initialization.F90 index 795f85062d..0be1095d99 100644 --- a/src/user/adjustment_initialization.F90 +++ b/src/user/adjustment_initialization.F90 @@ -42,7 +42,7 @@ subroutine adjustment_initialize_thickness ( h, G, GV, param_file, just_read_par type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized, in m. + intent(out) :: h !< The thickness that is being initialized, in H. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. logical, optional, intent(in) :: just_read_params !< If present and true, this call will @@ -131,40 +131,40 @@ subroutine adjustment_initialize_thickness ( h, G, GV, param_file, just_read_par end do target_values = target_values - 1000. do j=js,je ; do i=is,ie - if (front_wave_length.ne.0.) then - y = ( 0.125 + G%geoLatT(i,j) / front_wave_length ) * ( 4. * acos(0.) ) - yy = 2. * ( G%geoLatT(i,j) - 0.5 * G%len_lat ) / adjustment_width - yy = min(1.0, yy); yy = max(-1.0, yy) - yy = yy * 2. * acos( 0. ) - y = front_wave_amp*sin(y) + front_wave_asym*sin(yy) + if (front_wave_length.ne.0.) then + y = ( 0.125 + G%geoLatT(i,j) / front_wave_length ) * ( 4. * acos(0.) ) + yy = 2. * ( G%geoLatT(i,j) - 0.5 * G%len_lat ) / adjustment_width + yy = min(1.0, yy); yy = max(-1.0, yy) + yy = yy * 2. * acos( 0. ) + y = front_wave_amp*sin(y) + front_wave_asym*sin(yy) + else + y = 0. + endif + x = ( ( G%geoLonT(i,j) - 0.5 * G%len_lon ) + y ) / adjustment_width + x = min(1.0, x); x = max(-1.0, x) + x = x * acos( 0. ) + delta_S = adjustment_deltaS * 0.5 * (1. - sin( x ) ) + do k=2,nz + if (dSdz.ne.0.) then + eta1D(k) = ( target_values(k) - ( S_ref + delta_S ) ) / dSdz else - y = 0. + eta1D(k) = e0(k) - (0.5*adjustment_delta) * sin( x ) endif - x = ( ( G%geoLonT(i,j) - 0.5 * G%len_lon ) + y ) / adjustment_width - x = min(1.0, x); x = max(-1.0, x) - x = x * acos( 0. ) - delta_S = adjustment_deltaS * 0.5 * (1. - sin( x ) ) - do k=2,nz - if (dSdz.ne.0.) then - eta1D(k) = ( target_values(k) - ( S_ref + delta_S ) ) / dSdz - else - eta1D(k) = e0(k) - (0.5*adjustment_delta) * sin( x ) - endif - eta1D(k) = max( eta1D(k), -G%max_depth ) - eta1D(k) = min( eta1D(k), 0. ) - enddo - eta1D(1)=0.; eta1D(nz+1)=-G%max_depth - do k=nz,1,-1 - if (eta1D(k) > 0.) then - eta1D(k) = max( eta1D(k+1) + min_thickness, 0. ) - h(i,j,k) = max( eta1D(k) - eta1D(k+1), min_thickness ) - elseif (eta1D(k) <= (eta1D(k+1) + min_thickness)) then - eta1D(k) = eta1D(k+1) + min_thickness - h(i,j,k) = min_thickness - else - h(i,j,k) = eta1D(k) - eta1D(k+1) - endif - enddo + eta1D(k) = max( eta1D(k), -G%max_depth ) + eta1D(k) = min( eta1D(k), 0. ) + enddo + eta1D(1)=0.; eta1D(nz+1)=-G%max_depth + do k=nz,1,-1 + if (eta1D(k) > 0.) then + eta1D(k) = max( eta1D(k+1) + min_thickness, 0. ) + h(i,j,k) = GV%m_to_H * max( eta1D(k) - eta1D(k+1), min_thickness ) + elseif (eta1D(k) <= (eta1D(k+1) + min_thickness)) then + eta1D(k) = eta1D(k+1) + min_thickness + h(i,j,k) = GV%m_to_H * min_thickness + else + h(i,j,k) = GV%m_to_H * (eta1D(k) - eta1D(k+1)) + endif + enddo enddo ; enddo case ( REGRIDDING_ZSTAR, REGRIDDING_SIGMA ) @@ -174,13 +174,13 @@ subroutine adjustment_initialize_thickness ( h, G, GV, param_file, just_read_par enddo do j=js,je ; do i=is,ie do k=nz,1,-1 - h(i,j,k) = eta1D(k) - eta1D(k+1) + h(i,j,k) = GV%m_to_H * (eta1D(k) - eta1D(k+1)) enddo enddo ; enddo case default call MOM_error(FATAL,"adjustment_initialize_thickness: "// & - "Unrecognized i.c. setup - set ADJUSTMENT_IC") + "Unrecognized i.c. setup - set ADJUSTMENT_IC") end select @@ -190,17 +190,18 @@ end subroutine adjustment_initialize_thickness !------------------------------------------------------------------------------ !> Initialization of temperature and salinity. !------------------------------------------------------------------------------ -subroutine adjustment_initialize_temperature_salinity ( T, S, h, G, param_file, & +subroutine adjustment_initialize_temperature_salinity ( T, S, h, G, GV, param_file, & eqn_of_state, just_read_params) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: T !< The temperature that is being initialized. real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: S !< The salinity that is being initialized. - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< The model thickness. + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< The model thicknesses in H (m or kg m-2). type(param_file_type), intent(in) :: param_file !< A structure indicating the !! open file to parse for model parameter values. type(EOS_type), pointer :: eqn_of_state !< Equation of state. logical, optional, intent(in) :: just_read_params !< If present and true, this call will - !! only read parameters without changing h. + !! only read parameters without changing T & S. integer :: i, j, k, is, ie, js, je, nz real :: x, y, yy @@ -256,31 +257,31 @@ subroutine adjustment_initialize_temperature_salinity ( T, S, h, G, param_file, case ( REGRIDDING_ZSTAR, REGRIDDING_SIGMA ) dSdz = -delta_S_strat/G%max_depth do j=js,je ; do i=is,ie - eta1d(nz+1)=-G%bathyT(i,j) - do k=nz,1,-1 - eta1d(k)=eta1d(k+1)+h(i,j,k) - enddo - if (front_wave_length.ne.0.) then - y = ( 0.125 + G%geoLatT(i,j) / front_wave_length ) * ( 4. * acos(0.) ) - yy = 2. * ( G%geoLatT(i,j) - 0.5 * G%len_lat ) / front_wave_length - yy = min(1.0, yy); yy = max(-1.0, yy) - yy = yy * 2. * acos( 0. ) - y = front_wave_amp*sin(y) + front_wave_asym*sin(yy) - else - y = 0. - endif - x = ( ( G%geoLonT(i,j) - 0.5 * G%len_lon ) + y ) / adjustment_width - x = min(1.0, x); x = max(-1.0, x) - x = x * acos( 0. ) - delta_S = adjustment_deltaS * 0.5 * (1. - sin( x ) ) - do k=1,nz - S(i,j,k) = S_ref + delta_S + 0.5 * ( eta1D(k)+eta1D(k+1) ) * dSdz - x = abs(S(i,j,k) - 0.5*real(nz-1)/real(nz)*S_range)/S_range*real(2*nz) - x = 1.-min(1., x) - T(i,j,k) = x - enddo - ! x=sum(T(i,j,:)*h(i,j,:)) - ! T(i,j,:)=T(i,j,:)/x*(G%max_depth*1.5/real(nz)) + eta1d(nz+1) = -G%bathyT(i,j) + do k=nz,1,-1 + eta1d(k) = eta1d(k+1) + h(i,j,k)*GV%H_to_m + enddo + if (front_wave_length.ne.0.) then + y = ( 0.125 + G%geoLatT(i,j) / front_wave_length ) * ( 4. * acos(0.) ) + yy = 2. * ( G%geoLatT(i,j) - 0.5 * G%len_lat ) / front_wave_length + yy = min(1.0, yy); yy = max(-1.0, yy) + yy = yy * 2. * acos( 0. ) + y = front_wave_amp*sin(y) + front_wave_asym*sin(yy) + else + y = 0. + endif + x = ( ( G%geoLonT(i,j) - 0.5 * G%len_lon ) + y ) / adjustment_width + x = min(1.0, x); x = max(-1.0, x) + x = x * acos( 0. ) + delta_S = adjustment_deltaS * 0.5 * (1. - sin( x ) ) + do k=1,nz + S(i,j,k) = S_ref + delta_S + 0.5 * ( eta1D(k)+eta1D(k+1) ) * dSdz + x = abs(S(i,j,k) - 0.5*real(nz-1)/real(nz)*S_range)/S_range*real(2*nz) + x = 1. - min(1., x) + T(i,j,k) = x + enddo + ! x=sum(T(i,j,:)*h(i,j,:)) + ! T(i,j,:)=T(i,j,:)/x*(G%max_depth*1.5/real(nz)) enddo ; enddo case ( REGRIDDING_LAYER, REGRIDDING_RHO ) diff --git a/src/user/baroclinic_zone_initialization.F90 b/src/user/baroclinic_zone_initialization.F90 index d90d9a4650..df51702416 100644 --- a/src/user/baroclinic_zone_initialization.F90 +++ b/src/user/baroclinic_zone_initialization.F90 @@ -6,6 +6,7 @@ module baroclinic_zone_initialization use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_file_parser, only : openParameterBlock, closeParameterBlock use MOM_grid, only : ocean_grid_type +use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -65,15 +66,16 @@ subroutine bcz_params(G, param_file, S_ref, dSdz, delta_S, dSdx, T_ref, dTdz, & end subroutine bcz_params !> Initialization of temperature and salinity with the baroclinic zone initial conditions -subroutine baroclinic_zone_init_temperature_salinity(T, S, h, G, param_file, & +subroutine baroclinic_zone_init_temperature_salinity(T, S, h, G, GV, param_file, & just_read_params) type(ocean_grid_type), intent(in) :: G !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: T !< Potential temperature [deg C] real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: S !< Salinity [ppt] - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Thickness + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< The model thicknesses in H (m or kg m-2) type(param_file_type), intent(in) :: param_file !< Parameter file handle logical, optional, intent(in) :: just_read_params !< If present and true, this call will - !! only read parameters without changing h. + !! only read parameters without changing T & S. integer :: i, j, k, is, ie, js, je, nz real :: T_ref, dTdz, dTdx, delta_T ! Parameters describing temperature distribution @@ -108,8 +110,8 @@ subroutine baroclinic_zone_init_temperature_salinity(T, S, h, G, param_file, & fn = xs endif do k = nz, 1, -1 - zc = zi + 0.5*h(i,j,k) ! Position of middle of cell - zi = zi + h(i,j,k) ! Top interface position + zc = zi + 0.5*h(i,j,k)*GV%H_to_m ! Position of middle of cell + zi = zi + h(i,j,k)*GV%H_to_m ! Top interface position T(i,j,k) = T_ref + dTdz * zc & ! Linear temperature stratification + dTdx * x & ! Linear gradient + delta_T * fn ! Smooth fn of width L_zone diff --git a/src/user/benchmark_initialization.F90 b/src/user/benchmark_initialization.F90 index 77072d10f9..7a1d3dc86b 100644 --- a/src/user/benchmark_initialization.F90 +++ b/src/user/benchmark_initialization.F90 @@ -79,7 +79,7 @@ subroutine benchmark_initialize_thickness(h, G, GV, param_file, eqn_of_state, & type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized, in m. + intent(out) :: h !< The thickness that is being initialized, in H. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. type(EOS_type), pointer :: eqn_of_state !< integer that selects the @@ -186,9 +186,9 @@ subroutine benchmark_initialize_thickness(h, G, GV, param_file, eqn_of_state, & if (eta1D(K) < eta1D(K+1) + GV%Angstrom_z) & eta1D(K) = eta1D(K+1) + GV%Angstrom_z - h(i,j,k) = max(eta1D(K) - eta1D(K+1), GV%Angstrom_z) + h(i,j,k) = max(GV%m_to_H * (eta1D(K) - eta1D(K+1)), GV%Angstrom) enddo - h(i,j,1) = max(0.0 - eta1D(2), GV%Angstrom_z) + h(i,j,1) = max(GV%m_to_H * (0.0 - eta1D(2)), GV%Angstrom) enddo ; enddo diff --git a/src/user/circle_obcs_initialization.F90 b/src/user/circle_obcs_initialization.F90 index 68f7d13535..ca89b812a6 100644 --- a/src/user/circle_obcs_initialization.F90 +++ b/src/user/circle_obcs_initialization.F90 @@ -25,7 +25,7 @@ subroutine circle_obcs_initialize_thickness(h, G, GV, param_file, just_read_para type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJ_(G), SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized, in m. + intent(out) :: h !< The thickness that is being initialized, in H. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. logical, optional, intent(in) :: just_read_params !< If present and true, this call will @@ -69,15 +69,15 @@ subroutine circle_obcs_initialize_thickness(h, G, GV, param_file, just_read_para eta1D(K) = e0(K) if (eta1D(K) < (eta1D(K+1) + GV%Angstrom_z)) then eta1D(K) = eta1D(K+1) + GV%Angstrom_z - h(i,j,k) = GV%Angstrom_z + h(i,j,k) = GV%Angstrom else - h(i,j,k) = eta1D(K) - eta1D(K+1) + h(i,j,k) = GV%m_to_H * (eta1D(K) - eta1D(K+1)) endif enddo enddo ; enddo ! Perturb base state by circular anomaly in center - k=Nz + k=nz latC = G%south_lat + 0.5*G%len_lat lonC = G%west_lon + 0.5*G%len_lon do j=js,je ; do i=is,ie @@ -85,14 +85,14 @@ subroutine circle_obcs_initialize_thickness(h, G, GV, param_file, just_read_para ! if (rad <= 6.*diskrad) h(i,j,k) = h(i,j,k)+10.0*exp( -0.5*( rad**2 ) ) rad = min( rad, 1. ) ! Flatten outside radius of diskrad rad = rad*(2.*asin(1.)) ! Map 0-1 to 0-pi - if (Nz==1) then + if (nz==1) then ! The model is barotropic - h(i,j,k) = h(i,j,k) + 1.0*0.5*(1.+cos(rad)) ! cosine bell + h(i,j,k) = h(i,j,k) + GV%m_to_H * 1.0*0.5*(1.+cos(rad)) ! cosine bell else ! The model is baroclinic - do k = 1, Nz - h(i,j,k) = h(i,j,k) - 0.5*(1.+cos(rad)) & ! cosine bell - * 5.0 * real( 2*k-Nz ) + do k = 1, nz + h(i,j,k) = h(i,j,k) - GV%m_to_H * 0.5*(1.+cos(rad)) & ! cosine bell + * 5.0 * real( 2*k-nz ) enddo endif enddo ; enddo diff --git a/src/user/external_gwave_initialization.F90 b/src/user/external_gwave_initialization.F90 index daf00d46f5..e54d3e488e 100644 --- a/src/user/external_gwave_initialization.F90 +++ b/src/user/external_gwave_initialization.F90 @@ -8,6 +8,7 @@ module external_gwave_initialization use MOM_grid, only : ocean_grid_type use MOM_tracer_registry, only : tracer_registry_type use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type implicit none ; private #include @@ -18,10 +19,11 @@ module external_gwave_initialization ! ----------------------------------------------------------------------------- !> This subroutine initializes layer thicknesses for the external_gwave experiment. -subroutine external_gwave_initialize_thickness(h, G, param_file, just_read_params) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(out) :: h !< The thickness that is being initialized, in m. +subroutine external_gwave_initialize_thickness(h, G, GV, param_file, just_read_params) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: h !< The thickness that is being initialized, in H. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. logical, optional, intent(in) :: just_read_params !< If present and true, this call will @@ -70,7 +72,7 @@ subroutine external_gwave_initialize_thickness(h, G, param_file, just_read_param enddo eta1D(nz+1) = -G%max_depth ! Force bottom interface to bottom do k=1,nz - h(i,j,k) = eta1D(K) - eta1D(K+1) + h(i,j,k) = GV%m_to_H * (eta1D(K) - eta1D(K+1)) enddo enddo ; enddo diff --git a/src/user/lock_exchange_initialization.F90 b/src/user/lock_exchange_initialization.F90 index 72835f6d2d..e897db7c7a 100644 --- a/src/user/lock_exchange_initialization.F90 +++ b/src/user/lock_exchange_initialization.F90 @@ -24,7 +24,7 @@ subroutine lock_exchange_initialize_thickness(h, G, GV, param_file, just_read_pa type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized, in m. + intent(out) :: h !< The thickness that is being initialized, in H. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. logical, optional, intent(in) :: just_read_params !< If present and true, this call will @@ -83,7 +83,7 @@ subroutine lock_exchange_initialize_thickness(h, G, GV, param_file, just_read_pa eta1D(K) = min( eta1D(K), eta1D(K-1) - GV%Angstrom_Z ) enddo do k=nz,1,-1 - h(i,j,k) = eta1D(K) - eta1D(K+1) + h(i,j,k) = GV%m_to_H * (eta1D(K) - eta1D(K+1)) enddo enddo ; enddo diff --git a/src/user/seamount_initialization.F90 b/src/user/seamount_initialization.F90 index c432d9fd30..46fb3d5a40 100644 --- a/src/user/seamount_initialization.F90 +++ b/src/user/seamount_initialization.F90 @@ -84,7 +84,7 @@ subroutine seamount_initialize_thickness ( h, G, GV, param_file, just_read_param type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized, in m. + intent(out) :: h !< The thickness that is being initialized, in H. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. logical, optional, intent(in) :: just_read_params !< If present and true, this call will @@ -153,9 +153,9 @@ subroutine seamount_initialize_thickness ( h, G, GV, param_file, just_read_param eta1D(k) = e0(k) if (eta1D(k) < (eta1D(k+1) + GV%Angstrom_z)) then eta1D(k) = eta1D(k+1) + GV%Angstrom_z - h(i,j,k) = GV%Angstrom_z + h(i,j,k) = GV%Angstrom else - h(i,j,k) = eta1D(k) - eta1D(k+1) + h(i,j,k) = GV%m_to_H * (eta1D(k) - eta1D(k+1)) endif enddo enddo ; enddo @@ -168,9 +168,9 @@ subroutine seamount_initialize_thickness ( h, G, GV, param_file, just_read_param eta1D(k) = -G%max_depth * real(k-1) / real(nz) if (eta1D(k) < (eta1D(k+1) + min_thickness)) then eta1D(k) = eta1D(k+1) + min_thickness - h(i,j,k) = min_thickness + h(i,j,k) = GV%m_to_H * min_thickness else - h(i,j,k) = eta1D(k) - eta1D(k+1) + h(i,j,k) = GV%m_to_H * (eta1D(k) - eta1D(k+1)) endif enddo enddo ; enddo @@ -179,7 +179,7 @@ subroutine seamount_initialize_thickness ( h, G, GV, param_file, just_read_param if (just_read) return ! All run-time parameters have been read, so return. do j=js,je ; do i=is,ie delta_h = G%bathyT(i,j) / dfloat(nz) - h(i,j,:) = delta_h + h(i,j,:) = GV%m_to_H * delta_h end do ; end do end select @@ -193,7 +193,7 @@ subroutine seamount_initialize_temperature_salinity ( T, S, h, G, GV, param_file type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: T !< Potential temperature (degC) real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: S !< Salinity (ppt) - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Layer thickness (m or Pa) + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Layer thickness in H (m or Pa) type(param_file_type), intent(in) :: param_file !< Parameter file structure type(EOS_type), pointer :: eqn_of_state !< Equation of state structure logical, optional, intent(in) :: just_read_params !< If present and true, this call will @@ -257,7 +257,7 @@ subroutine seamount_initialize_temperature_salinity ( T, S, h, G, GV, param_file do j=js,je ; do i=is,ie xi0 = 0.0 do k = 1,nz - xi1 = xi0 + h(i,j,k) / G%max_depth + xi1 = xi0 + GV%H_to_m * h(i,j,k) / G%max_depth select case ( trim(density_profile) ) case ('linear') !S(i,j,k) = S_surf + S_range * 0.5 * (xi0 + xi1) diff --git a/src/user/sloshing_initialization.F90 b/src/user/sloshing_initialization.F90 index 6a72c7bd9f..a8221f945c 100644 --- a/src/user/sloshing_initialization.F90 +++ b/src/user/sloshing_initialization.F90 @@ -69,7 +69,7 @@ subroutine sloshing_initialize_thickness ( h, G, GV, param_file, just_read_param type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized, in m. + intent(out) :: h !< The thickness that is being initialized, in H. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. logical, optional, intent(in) :: just_read_params !< If present and true, this call will @@ -169,7 +169,7 @@ subroutine sloshing_initialize_thickness ( h, G, GV, param_file, just_read_param ! 4. Define layers total_height = 0.0 do k = 1,nz - h(i,j,k) = z_inter(k) - z_inter(k+1) + h(i,j,k) = GV%m_to_H * (z_inter(k) - z_inter(k+1)) total_height = total_height + h(i,j,k) end do @@ -186,12 +186,13 @@ end subroutine sloshing_initialize_thickness !! reference surface layer salinity and temperature and a specified range. !! Note that the linear distribution is set up with respect to the layer !! number, not the physical position). -subroutine sloshing_initialize_temperature_salinity ( T, S, h, G, param_file, & +subroutine sloshing_initialize_temperature_salinity ( T, S, h, G, GV, param_file, & eqn_of_state, just_read_params) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: T !< Potential temperature (degC). real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: S !< Salinity (ppt). - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Layer thickness (m or Pa). + real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(in) :: h !< Layer thickness in H (m or Pa). type(param_file_type), intent(in) :: param_file !< A structure indicating the !! open file to parse for model !! parameter values. diff --git a/src/user/soliton_initialization.F90 b/src/user/soliton_initialization.F90 index af1b69060e..62b535defe 100644 --- a/src/user/soliton_initialization.F90 +++ b/src/user/soliton_initialization.F90 @@ -30,9 +30,11 @@ module soliton_initialization contains !> Initialization of thicknesses in Equatorial Rossby soliton test -subroutine soliton_initialize_thickness(h, G) - type(ocean_grid_type), intent(in) :: G !< Grid structure - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: h !< Thickness +subroutine soliton_initialize_thickness(h, G, GV) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: h !< The thickness that is being initialized, in H. integer :: i, j, k, is, ie, js, je, nz real :: x, y, x0, y0 @@ -54,8 +56,7 @@ subroutine soliton_initialize_thickness(h, G) y = G%geoLatT(i,j)-y0 val3 = exp(-val1*x) val4 = val2*((2.0*val3/(1.0+(val3*val3)))**2) - h(i,j,k) = 0.25*val4*(6.0*y*y+3.0)* & - exp(-0.5*y*y) + h(i,j,k) = GV%m_to_H * (0.25*val4 * (6.0*y*y+3.0) * exp(-0.5*y*y)) enddo end do ; end do diff --git a/src/user/user_initialization.F90 b/src/user/user_initialization.F90 index 130594edf1..5e394089af 100644 --- a/src/user/user_initialization.F90 +++ b/src/user/user_initialization.F90 @@ -72,16 +72,15 @@ subroutine USER_initialize_topography(D, G, param_file, max_depth) end subroutine USER_initialize_topography !> initialize thicknesses. -subroutine USER_initialize_thickness(h, G, param_file, T, just_read_params) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - real, intent(out), dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h !< The thicknesses being - !! initialized. - type(param_file_type), intent(in) :: param_file !< A structure indicating the - !! open file to parse for model - !! parameter values. - real, intent(in), dimension(SZI_(G),SZJ_(G), SZK_(G)) :: T !< Potential temperature. +subroutine USER_initialize_thickness(h, G, GV, param_file, just_read_params) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: h !< The thicknesses being initialized, in H. + type(param_file_type), intent(in) :: param_file !< A structure indicating the open + !! file to parse for model parameter values. logical, optional, intent(in) :: just_read_params !< If present and true, this call will - !! only read parameters without changing h. + !! only read parameters without changing h. logical :: just_read ! If true, just read parameters but set nothing. @@ -93,7 +92,7 @@ subroutine USER_initialize_thickness(h, G, param_file, T, just_read_params) if (just_read) return ! All run-time parameters have been read, so return. - h(:,:,1) = 0.0 + h(:,:,1) = 0.0 * GV%m_to_H if (first_call) call write_user_log(param_file)