From afe75e854fc12666d6886b1429d37514e67d5802 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 8 Jul 2021 16:25:20 -0400 Subject: [PATCH] +Add a restart registry lock & fix OBC call order Added code to lock the restart registry once all registration should have occurred or if the restart has been read, along with a new public interface, restart_registry_lock, to allow this lock to be set or unset. All calls to register restart fields now check the state of this lock and issue a fatal error if the registry is locked. This PR addresses MOM6 issue #1214. In the process of adding this restart lock, the new error messages revealed that some of the restart registration calls related to some types of open boundary conditions were not happening early enough. To avoid this, a new interface, register_DOME_OBC, was added to the DOME_initialization module and is being called from call_OBC_register, and a number of the OBC-related calls during the initialization were collected in the same (appropriate) place. Some OBC error messages were also corrected. All answers are bitwise identical, but there are two new public interfaces and the order of some OBC-related entries in the MOM_parameter_doc calls changed. --- src/core/MOM.F90 | 64 +++++++++++----------- src/core/MOM_boundary_update.F90 | 26 ++++++++- src/core/MOM_open_boundary.F90 | 26 +++++---- src/framework/MOM_restart.F90 | 93 +++++++++++++++++++++++++++++--- src/user/DOME_initialization.F90 | 50 ++++++++++------- 5 files changed, 191 insertions(+), 68 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 05c6fe6c43..dedcdcf68a 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -41,7 +41,7 @@ module MOM use MOM_io, only : slasher, file_exists, MOM_read_data use MOM_obsolete_params, only : find_obsolete_params use MOM_restart, only : register_restart_field, register_restart_pair -use MOM_restart, only : query_initialized, save_restart +use MOM_restart, only : query_initialized, save_restart, restart_registry_lock use MOM_restart, only : restart_init, is_new_run, determine_is_new_run, MOM_restart_CS use MOM_spatial_means, only : global_mass_integral use MOM_time_manager, only : time_type, real_to_time, time_type_to_real, operator(+) @@ -2152,8 +2152,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & if (associated(OBC_in)) then ! TODO: General OBC index rotations is not yet supported. if (modulo(turns, 4) /= 1) & - call MOM_error(FATAL, "OBC index rotation of 180 and 270 degrees is " & - // "not yet unsupported.") + call MOM_error(FATAL, "OBC index rotation of 180 and 270 degrees is not yet supported.") allocate(CS%OBC) call rotate_OBC_config(OBC_in, dG_in, CS%OBC, dG, turns) endif @@ -2174,8 +2173,6 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call MOM_timing_init(CS) - if (associated(CS%OBC)) call call_OBC_register(param_file, CS%update_OBC_CSp, US, CS%OBC) - call tracer_registry_init(param_file, CS%tracer_Reg) ! Allocate and initialize space for the primary time-varying MOM variables. @@ -2229,21 +2226,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & flux_scale=conv2salt, convergence_units='kg m-2 s-1', & convergence_scale=0.001*GV%H_to_kg_m2, CMOR_tendprefix="osalt", diag_form=2) endif - ! NOTE: register_temp_salt_segments includes allocation of tracer fields - ! along segments. Bit reproducibility requires that MOM_initialize_state - ! be called on the input index map, so we must setup both OBC and OBC_in. - ! - ! XXX: This call on OBC_in allocates the tracer fields on the unrotated - ! grid, but also incorrectly stores a pointer to a tracer_type for the - ! rotated registry (e.g. segment%tr_reg%Tr(n)%Tr) from CS%tracer_reg. - ! - ! While incorrect and potentially dangerous, it does not seem that this - ! pointer is used during initialization, so we leave it for now. - if (CS%rotate_index .and. associated(OBC_in)) & - call register_temp_salt_segments(GV, OBC_in, CS%tracer_Reg, param_file) - if (associated(CS%OBC)) & - call register_temp_salt_segments(GV, CS%OBC, CS%tracer_Reg, param_file) endif + if (use_frazil) then allocate(CS%tv%frazil(isd:ied,jsd:jed)) ; CS%tv%frazil(:,:) = 0.0 endif @@ -2336,11 +2320,38 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call mixedlayer_restrat_register_restarts(dG%HI, param_file, & CS%mixedlayer_restrat_CSp, restart_CSp) - if (associated(CS%OBC)) & + if (CS%rotate_index .and. associated(OBC_in) .and. use_temperature) then + ! NOTE: register_temp_salt_segments includes allocation of tracer fields + ! along segments. Bit reproducibility requires that MOM_initialize_state + ! be called on the input index map, so we must setup both OBC and OBC_in. + ! + ! XXX: This call on OBC_in allocates the tracer fields on the unrotated + ! grid, but also incorrectly stores a pointer to a tracer_type for the + ! rotated registry (e.g. segment%tr_reg%Tr(n)%Tr) from CS%tracer_reg. + ! + ! While incorrect and potentially dangerous, it does not seem that this + ! pointer is used during initialization, so we leave it for now. + call register_temp_salt_segments(GV, OBC_in, CS%tracer_Reg, param_file) + endif + + if (associated(CS%OBC)) then + ! Set up remaining information about open boundary conditions that is needed for OBCs. + call call_OBC_register(param_file, CS%update_OBC_CSp, US, CS%OBC, CS%tracer_Reg) + !### Package specific changes to OBCs need to go here? + + ! This is the equivalent to 2 calls to register_segment_tracer (per segment), which + ! could occur with the call to update_OBC_data or after the main initialization. + if (use_temperature) & + call register_temp_salt_segments(GV, CS%OBC, CS%tracer_Reg, param_file) + + ! This needs the number of tracers and to have called any code that sets whether + ! reservoirs are used. call open_boundary_register_restarts(dg%HI, GV, CS%OBC, CS%tracer_Reg, & param_file, restart_CSp, use_temperature) + endif call callTree_waypoint("restart registration complete (initialize_MOM)") + call restart_registry_lock(restart_CSp) ! Shift from using the temporary dynamic grid type to using the final ! (potentially static) ocean-specific grid type. @@ -2438,7 +2449,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & turns, CS%u, CS%v, CS%h, CS%T, CS%S) if (associated(sponge_in_CSp)) then - ! TODO: Implementation and testing of non-ALE spong rotation + ! TODO: Implementation and testing of non-ALE sponge rotation call MOM_error(FATAL, "Index rotation of non-ALE sponge is not yet implemented.") endif @@ -2478,19 +2489,11 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & endif if (use_ice_shelf .and. CS%debug) & - call hchksum(CS%frac_shelf_h, "MOM:frac_shelf_h", G%HI, & - haloshift=0) + call hchksum(CS%frac_shelf_h, "MOM:frac_shelf_h", G%HI, haloshift=0) call cpu_clock_end(id_clock_MOM_init) call callTree_waypoint("returned from MOM_initialize_state() (initialize_MOM)") -! ! Need this after MOM_initialize_state for DOME OBC stuff. -! if (associated(CS%OBC)) & -! call open_boundary_register_restarts(G%HI, GV, CS%OBC, CS%tracer_Reg, & -! param_file, restart_CSp, use_temperature) - -! call callTree_waypoint("restart registration complete (initialize_MOM)") - ! From this point, there may be pointers being set, so the final grid type ! that will persist throughout the run has to be used. @@ -2845,6 +2848,7 @@ subroutine finish_MOM_initialization(Time, dirs, CS, restart_CSp) if (CS%write_IC) then allocate(restart_CSp_tmp) restart_CSp_tmp = restart_CSp + call restart_registry_lock(restart_CSp_tmp, unlocked=.true.) allocate(z_interface(SZI_(G),SZJ_(G),SZK_(GV)+1)) call find_eta(CS%h, CS%tv, G, GV, US, z_interface, eta_to_m=1.0) call register_restart_field(z_interface, "eta", .true., restart_CSp_tmp, & diff --git a/src/core/MOM_boundary_update.F90 b/src/core/MOM_boundary_update.F90 index 2e25af2460..dc89f3f92c 100644 --- a/src/core/MOM_boundary_update.F90 +++ b/src/core/MOM_boundary_update.F90 @@ -17,6 +17,7 @@ module MOM_boundary_update use MOM_tracer_registry, only : tracer_registry_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type +use DOME_initialization, only : register_DOME_OBC use tidal_bay_initialization, only : tidal_bay_set_OBC_data, register_tidal_bay_OBC use tidal_bay_initialization, only : tidal_bay_OBC_end, tidal_bay_OBC_CS use Kelvin_initialization, only : Kelvin_set_OBC_data, register_Kelvin_OBC @@ -58,13 +59,15 @@ module MOM_boundary_update !> The following subroutines and associated definitions provide the !! machinery to register and call the subroutines that initialize !! open boundary conditions. -subroutine call_OBC_register(param_file, CS, US, OBC) +subroutine call_OBC_register(param_file, CS, US, OBC, tr_Reg) type(param_file_type), intent(in) :: param_file !< Parameter file to parse type(update_OBC_CS), pointer :: CS !< Control structure for OBCs type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + type(tracer_registry_type), pointer :: tr_Reg !< Tracer registry. ! Local variables + character(len=200) :: config character(len=40) :: mdl = "MOM_boundary_update" ! This module's name. ! This include declares and sets the variable "version". # include "version_variable.h" @@ -91,10 +94,29 @@ subroutine call_OBC_register(param_file, CS, US, OBC) call get_param(param_file, mdl, "USE_DYED_CHANNEL_OBC", CS%use_dyed_channel, & "If true, use the dyed channel open boundary.", & default=.false.) + call get_param(param_file, mdl, "OBC_USER_CONFIG", config, & + "A string that sets how the user code is invoked to set open boundary data: \n"//& + " DOME - specified inflow on northern boundary\n"//& + " dyed_channel - supercritical with dye on the inflow boundary\n"//& + " dyed_obcs - circle_obcs with dyes on the open boundaries\n"//& + " Kelvin - barotropic Kelvin wave forcing on the western boundary\n"//& + " shelfwave - Flather with shelf wave forcing on western boundary\n"//& + " supercritical - now only needed here for the allocations\n"//& + " tidal_bay - Flather with tidal forcing on eastern boundary\n"//& + " USER - user specified", default="none", do_not_log=.true.) if (CS%use_files) CS%use_files = & register_file_OBC(param_file, CS%file_OBC_CSp, US, & OBC%OBC_Reg) + + if (trim(config) == "DOME") then + call register_DOME_OBC(param_file, US, OBC, tr_Reg) +! elseif (trim(config) == "tidal_bay") then +! elseif (trim(config) == "Kelvin") then +! elseif (trim(config) == "shelfwave") then +! elseif (trim(config) == "dyed_channel") then + endif + if (CS%use_tidal_bay) CS%use_tidal_bay = & register_tidal_bay_OBC(param_file, CS%tidal_bay_OBC_CSp, US, & OBC%OBC_Reg) @@ -150,7 +172,7 @@ end subroutine OBC_register_end !> \namespace mom_boundary_update !! This module updates the open boundary arrays when time-varying. -!! It caused a circular dependency with the tidal_bay setup when +!! It caused a circular dependency with the tidal_bay and other setups when in !! MOM_open_boundary. !! !! A small fragment of the grid is shown below: diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index bd76f5a9aa..61e20d14a6 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -342,8 +342,6 @@ module MOM_open_boundary integer :: id_clock_pass !< A CPU time clock character(len=40) :: mdl = "MOM_open_boundary" !< This module's name. -! This include declares and sets the variable "version". -#include "version_variable.h" contains @@ -359,6 +357,7 @@ subroutine open_boundary_config(G, US, param_file, OBC) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< Parameter file handle type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure + ! Local variables integer :: l ! For looping over segments logical :: debug_OBC, debug, mask_outside, reentrant_x, reentrant_y @@ -370,6 +369,9 @@ subroutine open_boundary_config(G, US, param_file, OBC) logical :: answers_2018, default_2018_answers logical :: check_reconstruction, check_remapping, force_bounds_in_subcell character(len=32) :: remappingScheme +! This include declares and sets the variable "version". +# include "version_variable.h" + allocate(OBC) call get_param(param_file, mdl, "OBC_NUMBER_OF_SEGMENTS", OBC%number_of_segments, & @@ -4433,8 +4435,8 @@ subroutine register_OBC(name, param_file, Reg) Reg%OB(nobc)%name = name if (Reg%locked) call MOM_error(FATAL, & - "MOM register_tracer was called for variable "//trim(Reg%OB(nobc)%name)//& - " with a locked tracer registry.") + "MOM register_OBC was called for OBC "//trim(Reg%OB(nobc)%name)//& + " with a locked OBC registry.") end subroutine register_OBC @@ -4445,7 +4447,7 @@ subroutine OBC_registry_init(param_file, Reg) integer, save :: init_calls = 0 -#include "version_variable.h" +# include "version_variable.h" character(len=40) :: mdl = "MOM_open_boundary" ! This module's name. character(len=256) :: mesg ! Message for error messages. @@ -4453,7 +4455,7 @@ subroutine OBC_registry_init(param_file, Reg) else ; return ; endif ! Read all relevant parameters and write them to the model log. -! call log_version(param_file, mdl,s version, "") +! call log_version(param_file, mdl, version, "") init_calls = init_calls + 1 if (init_calls > 1) then @@ -4503,7 +4505,7 @@ subroutine segment_tracer_registry_init(param_file, segment) integer, save :: init_calls = 0 ! This include declares and sets the variable "version". -#include "version_variable.h" +# include "version_variable.h" character(len=40) :: mdl = "segment_tracer_registry_init" ! This routine's name. character(len=256) :: mesg ! Message for error messages. @@ -4527,6 +4529,8 @@ subroutine segment_tracer_registry_init(param_file, segment) end subroutine segment_tracer_registry_init +!> Register a tracer array that is active on an OBC segment, potentially also specifing how the +!! tracer inflow values are specified. subroutine register_segment_tracer(tr_ptr, param_file, GV, segment, & OBC_scalar, OBC_array) type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure @@ -4537,7 +4541,7 @@ subroutine register_segment_tracer(tr_ptr, param_file, GV, segment, & !! but it also means that any updates to this !! structure in the calling module will be !! available subsequently to the tracer registry. - type(param_file_type), intent(in) :: param_file !< file to parse for model parameter values + type(param_file_type), intent(in) :: param_file !< file to parse for model parameter values type(OBC_segment_type), intent(inout) :: segment !< current segment data structure real, optional, intent(in) :: OBC_scalar !< If present, use scalar value for segment tracer !! inflow concentration. @@ -4555,8 +4559,8 @@ subroutine register_segment_tracer(tr_ptr, param_file, GV, segment, & if (segment%tr_Reg%ntseg>=MAX_FIELDS_) then write(mesg,'("Increase MAX_FIELDS_ in MOM_memory.h to at least ",I3," to allow for & - &all the tracers being registered via register_tracer.")') segment%tr_Reg%ntseg+1 - call MOM_error(FATAL,"MOM register_tracer: "//mesg) + &all the tracers being registered via register_segment_tracer.")') segment%tr_Reg%ntseg+1 + call MOM_error(FATAL,"MOM register_segment_tracer: "//mesg) endif segment%tr_Reg%ntseg = segment%tr_Reg%ntseg + 1 ntseg = segment%tr_Reg%ntseg @@ -4570,7 +4574,7 @@ subroutine register_segment_tracer(tr_ptr, param_file, GV, segment, & segment%tr_Reg%Tr(ntseg)%name = tr_ptr%name if (segment%tr_Reg%locked) call MOM_error(FATAL, & - "MOM register_tracer was called for variable "//trim(segment%tr_Reg%Tr(ntseg)%name)//& + "MOM register_segment_tracer was called for variable "//trim(segment%tr_Reg%Tr(ntseg)%name)//& " with a locked tracer registry.") if (present(OBC_scalar)) segment%tr_Reg%Tr(ntseg)%OBC_inflow_conc = OBC_scalar ! initialize tracer value later diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index 74db4e0f95..b2641aa622 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -22,10 +22,9 @@ module MOM_restart implicit none ; private public restart_init, restart_end, restore_state, register_restart_field -public save_restart, query_initialized, restart_init_end, vardesc +public save_restart, query_initialized, restart_registry_lock, restart_init_end, vardesc public restart_files_exist, determine_is_new_run, is_new_run -public register_restart_field_as_obsolete -public register_restart_pair +public register_restart_field_as_obsolete, register_restart_pair !> A type for making arrays of pointers to 4-d arrays type p4d @@ -87,6 +86,8 @@ module MOM_restart !! in which case the checksums will not match and cause crash. character(len=240) :: restartfile !< The name or name root for MOM restart files. integer :: turns !< Number of quarter turns from input to model domain + logical :: locked = .false. !< If true this registry has been locked and no further restart + !! fields can be added without explicitly unlocking the registry. !> An array of descriptions of the registered fields type(field_restart), pointer :: restart_field(:) => NULL() @@ -155,6 +156,8 @@ subroutine register_restart_field_ptr3d(f_ptr, var_desc, mandatory, CS) if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "register_restart_field: Module must be initialized before it is used.") + call lock_check(CS, var_desc) + CS%novars = CS%novars+1 if (CS%novars > CS%max_fields) return ! This is an error that will be reported ! once the total number of fields is known. @@ -186,6 +189,8 @@ subroutine register_restart_field_ptr4d(f_ptr, var_desc, mandatory, CS) if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "register_restart_field: Module must be initialized before it is used.") + call lock_check(CS, var_desc) + CS%novars = CS%novars+1 if (CS%novars > CS%max_fields) return ! This is an error that will be reported ! once the total number of fields is known. @@ -217,6 +222,8 @@ subroutine register_restart_field_ptr2d(f_ptr, var_desc, mandatory, CS) if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "register_restart_field: Module must be initialized before it is used.") + call lock_check(CS, var_desc) + CS%novars = CS%novars+1 if (CS%novars > CS%max_fields) return ! This is an error that will be reported ! once the total number of fields is known. @@ -247,6 +254,8 @@ subroutine register_restart_field_ptr1d(f_ptr, var_desc, mandatory, CS) if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "register_restart_field: Module must be initialized before it is used.") + call lock_check(CS, var_desc) + CS%novars = CS%novars+1 if (CS%novars > CS%max_fields) return ! This is an error that will be reported ! once the total number of fields is known. @@ -277,6 +286,8 @@ subroutine register_restart_field_ptr0d(f_ptr, var_desc, mandatory, CS) if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "register_restart_field: Module must be initialized before it is used.") + call lock_check(CS, var_desc) + CS%novars = CS%novars+1 if (CS%novars > CS%max_fields) return ! This is an error that will be reported ! once the total number of fields is known. @@ -307,6 +318,8 @@ subroutine register_restart_pair_ptr2d(a_ptr, b_ptr, a_desc, b_desc, & logical, intent(in) :: mandatory !< If true, abort if field is missing type(MOM_restart_CS), pointer :: CS !< MOM restart control structure + call lock_check(CS, a_desc) + if (modulo(CS%turns, 2) /= 0) then call register_restart_field(b_ptr, a_desc, mandatory, CS) call register_restart_field(a_ptr, b_desc, mandatory, CS) @@ -327,6 +340,8 @@ subroutine register_restart_pair_ptr3d(a_ptr, b_ptr, a_desc, b_desc, & logical, intent(in) :: mandatory !< If true, abort if field is missing type(MOM_restart_CS), pointer :: CS !< MOM restart control structure + call lock_check(CS, a_desc) + if (modulo(CS%turns, 2) /= 0) then call register_restart_field(b_ptr, a_desc, mandatory, CS) call register_restart_field(a_ptr, b_desc, mandatory, CS) @@ -347,6 +362,8 @@ subroutine register_restart_pair_ptr4d(a_ptr, b_ptr, a_desc, b_desc, & logical, intent(in) :: mandatory !< If true, abort if field is missing type(MOM_restart_CS), pointer :: CS !< MOM restart control structure + call lock_check(CS, a_desc) + if (modulo(CS%turns, 2) /= 0) then call register_restart_field(b_ptr, a_desc, mandatory, CS) call register_restart_field(a_ptr, b_desc, mandatory, CS) @@ -379,6 +396,9 @@ subroutine register_restart_field_4d(f_ptr, name, mandatory, CS, longname, units if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart: " // & "register_restart_field_4d: Module must be initialized before "//& "it is used to register "//trim(name)) + + call lock_check(CS, name=name) + vd = var_desc(name, units=units, longname=longname, hor_grid=hor_grid, & z_grid=z_grid, t_grid=t_grid) @@ -406,6 +426,9 @@ subroutine register_restart_field_3d(f_ptr, name, mandatory, CS, longname, units if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart: " // & "register_restart_field_3d: Module must be initialized before "//& "it is used to register "//trim(name)) + + call lock_check(CS, name=name) + vd = var_desc(name, units=units, longname=longname, hor_grid=hor_grid, & z_grid=z_grid, t_grid=t_grid) @@ -435,6 +458,9 @@ subroutine register_restart_field_2d(f_ptr, name, mandatory, CS, longname, units "register_restart_field_2d: Module must be initialized before "//& "it is used to register "//trim(name)) zgrid = '1' ; if (present(z_grid)) zgrid = z_grid + + call lock_check(CS, name=name) + vd = var_desc(name, units=units, longname=longname, hor_grid=hor_grid, & z_grid=zgrid, t_grid=t_grid) @@ -463,6 +489,9 @@ subroutine register_restart_field_1d(f_ptr, name, mandatory, CS, longname, units "register_restart_field_3d: Module must be initialized before "//& "it is used to register "//trim(name)) hgrid = '1' ; if (present(hor_grid)) hgrid = hor_grid + + call lock_check(CS, name=name) + vd = var_desc(name, units=units, longname=longname, hor_grid=hgrid, & z_grid=z_grid, t_grid=t_grid) @@ -483,9 +512,13 @@ subroutine register_restart_field_0d(f_ptr, name, mandatory, CS, longname, units character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1, 's' if absent type(vardesc) :: vd + if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart: " // & "register_restart_field_0d: Module must be initialized before "//& "it is used to register "//trim(name)) + + call lock_check(CS, name=name) + vd = var_desc(name, units=units, longname=longname, hor_grid='1', & z_grid='1', t_grid=t_grid) @@ -502,6 +535,7 @@ function query_initialized_name(name, CS) result(query_initialized) logical :: query_initialized integer :: m, n + if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "query_initialized: Module must be initialized before it is used.") if (CS%novars > CS%max_fields) call restart_error(CS) @@ -533,6 +567,7 @@ function query_initialized_0d(f_ptr, CS) result(query_initialized) logical :: query_initialized integer :: m, n + if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "query_initialized: Module must be initialized before it is used.") if (CS%novars > CS%max_fields) call restart_error(CS) @@ -557,6 +592,7 @@ function query_initialized_1d(f_ptr, CS) result(query_initialized) logical :: query_initialized integer :: m, n + if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "query_initialized: Module must be initialized before it is used.") if (CS%novars > CS%max_fields) call restart_error(CS) @@ -582,6 +618,7 @@ function query_initialized_2d(f_ptr, CS) result(query_initialized) logical :: query_initialized integer :: m, n + if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "query_initialized: Module must be initialized before it is used.") if (CS%novars > CS%max_fields) call restart_error(CS) @@ -607,6 +644,7 @@ function query_initialized_3d(f_ptr, CS) result(query_initialized) logical :: query_initialized integer :: m, n + if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "query_initialized: Module must be initialized before it is used.") if (CS%novars > CS%max_fields) call restart_error(CS) @@ -632,6 +670,7 @@ function query_initialized_4d(f_ptr, CS) result(query_initialized) logical :: query_initialized integer :: m, n + if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "query_initialized: Module must be initialized before it is used.") if (CS%novars > CS%max_fields) call restart_error(CS) @@ -658,6 +697,7 @@ function query_initialized_0d_name(f_ptr, name, CS) result(query_initialized) logical :: query_initialized integer :: m, n + if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "query_initialized: Module must be initialized before it is used.") if (CS%novars > CS%max_fields) call restart_error(CS) @@ -691,6 +731,7 @@ function query_initialized_1d_name(f_ptr, name, CS) result(query_initialized) logical :: query_initialized integer :: m, n + if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "query_initialized: Module must be initialized before it is used.") if (CS%novars > CS%max_fields) call restart_error(CS) @@ -724,6 +765,7 @@ function query_initialized_2d_name(f_ptr, name, CS) result(query_initialized) logical :: query_initialized integer :: m, n + if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "query_initialized: Module must be initialized before it is used.") if (CS%novars > CS%max_fields) call restart_error(CS) @@ -757,6 +799,7 @@ function query_initialized_3d_name(f_ptr, name, CS) result(query_initialized) logical :: query_initialized integer :: m, n + if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "query_initialized: Module must be initialized before it is used.") if (CS%novars > CS%max_fields) call restart_error(CS) @@ -790,6 +833,7 @@ function query_initialized_4d_name(f_ptr, name, CS) result(query_initialized) logical :: query_initialized integer :: m, n + if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & "query_initialized: Module must be initialized before it is used.") if (CS%novars > CS%max_fields) call restart_error(CS) @@ -1235,6 +1279,9 @@ subroutine restore_state(filename, directory, day, G, CS) endif enddo + ! Lock the restart registry so that no further variables can be registered. + CS%locked = .true. + end subroutine restore_state !> restart_files_exist determines whether any restart files exist. @@ -1482,8 +1529,8 @@ subroutine restart_init(param_file, CS, restart_root) logical :: rotate_index -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "MOM_restart" ! This module's name. logical :: all_default ! If true, all parameters are using their default values. @@ -1555,13 +1602,47 @@ subroutine restart_init(param_file, CS, restart_root) allocate(CS%var_ptr3d(CS%max_fields)) allocate(CS%var_ptr4d(CS%max_fields)) + CS%locked = .false. + end subroutine restart_init -!> Indicate that all variables have now been registered. +!> Issue an error message if the restart_registry is locked. +subroutine lock_check(CS, var_desc, name) + type(MOM_restart_CS), intent(in) :: CS !< A MOM_restart_CS object (intent in) + type(vardesc), optional, intent(in) :: var_desc !< A structure with metadata about this variable + character(len=*), optional, intent(in) :: name !< variable name to be used in the restart file + + character(len=256) :: var_name ! A variable name. + + if (CS%locked) then + if (present(var_desc)) then + call query_vardesc(var_desc, name=var_name) + call MOM_error(FATAL, "Attempted to register "//trim(var_name)//" but the restart registry is locked.") + elseif (present(name)) then + call MOM_error(FATAL, "Attempted to register "//trim(name)//" but the restart registry is locked.") + else + call MOM_error(FATAL, "Attempted to register a variable but the restart registry is locked.") + endif + endif + +end subroutine lock_check + +!> Lock the restart registry so that an error is issued if any further restart variables are registered. +subroutine restart_registry_lock(CS, unlocked) + type(MOM_restart_CS), intent(inout) :: CS !< A MOM_restart_CS object (intent inout) + logical, optional, intent(in) :: unlocked !< If present and true, unlock the registry + + CS%locked = .true. + if (present(unlocked)) CS%locked = .not.unlocked +end subroutine restart_registry_lock + +!> Indicate that all variables have now been registered and lock the registry. subroutine restart_init_end(CS) type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object if (associated(CS)) then + CS%locked = .true. + if (CS%novars == 0) call restart_end(CS) endif diff --git a/src/user/DOME_initialization.F90 b/src/user/DOME_initialization.F90 index c56e2ab63f..81444704b3 100644 --- a/src/user/DOME_initialization.F90 +++ b/src/user/DOME_initialization.F90 @@ -26,7 +26,7 @@ module DOME_initialization public DOME_initialize_topography public DOME_initialize_thickness public DOME_initialize_sponges -public DOME_set_OBC_data +public DOME_set_OBC_data, register_DOME_OBC ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with @@ -241,6 +241,30 @@ subroutine DOME_initialize_sponges(G, GV, US, tv, PF, CSp) end subroutine DOME_initialize_sponges +!> Add DOME to the OBC registry and set up some variables that will be used to guide +!! code setting up the restart fieldss related to the OBCs. +subroutine register_DOME_OBC(param_file, US, OBC, tr_Reg) + type(param_file_type), intent(in) :: param_file !< parameter file. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(ocean_OBC_type), pointer :: OBC !< OBC registry. + type(tracer_registry_type), pointer :: tr_Reg !< Tracer registry. + + if (OBC%number_of_segments /= 1) then + call MOM_error(FATAL, 'Error in register_DOME_OBC - DOME should have 1 OBC segment', .true.) + endif + + ! Store this information for use in setting up the OBC restarts for tracer reservoirs. + OBC%ntr = tr_Reg%ntr + if (.not. associated(OBC%tracer_x_reservoirs_used)) then + allocate(OBC%tracer_x_reservoirs_used(OBC%ntr)) + allocate(OBC%tracer_y_reservoirs_used(OBC%ntr)) + OBC%tracer_x_reservoirs_used(:) = .false. + OBC%tracer_y_reservoirs_used(:) = .false. + OBC%tracer_y_reservoirs_used(1) = .true. + endif + +end subroutine register_DOME_OBC + !> This subroutine sets the properties of flow at open boundary conditions. !! This particular example is for the DOME inflow describe in Legg et al. 2006. subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, param_file, tr_Reg) @@ -276,8 +300,8 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, param_file, tr_Reg) real :: Ri_trans ! The shear Richardson number in the transition ! region of the specified shear profile. character(len=40) :: mdl = "DOME_set_OBC_data" ! This subroutine's name. - character(len=32) :: name - integer :: i, j, k, itt, is, ie, js, je, isd, ied, jsd, jed, m, nz, NTR + character(len=32) :: name ! The name of a tracer field. + integer :: i, j, k, itt, is, ie, js, je, isd, ied, jsd, jed, m, nz integer :: IsdB, IedB, JsdB, JedB type(OBC_segment_type), pointer :: segment => NULL() type(tracer_type), pointer :: tr_ptr => NULL() @@ -302,22 +326,10 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, param_file, tr_Reg) return !!! Need a better error message here endif - NTR = tr_Reg%NTR - - ! Stash this information away for the messy tracer restarts. - OBC%ntr = NTR - if (.not. associated(OBC%tracer_x_reservoirs_used)) then - allocate(OBC%tracer_x_reservoirs_used(NTR)) - allocate(OBC%tracer_y_reservoirs_used(NTR)) - OBC%tracer_x_reservoirs_used(:) = .false. - OBC%tracer_y_reservoirs_used(:) = .false. - OBC%tracer_y_reservoirs_used(1) = .true. - endif - segment => OBC%segment(1) if (.not. segment%on_pe) return - allocate(segment%field(NTR)) + allocate(segment%field(tr_Reg%ntr)) do k=1,nz rst = -1.0 @@ -393,9 +405,9 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, param_file, tr_Reg) call register_segment_tracer(tr_ptr, param_file, GV, & OBC%segment(1), OBC_array=.true.) - ! All tracers but the first have 0 concentration in their inflows. As this - ! is the default value, the following calls are unnecessary. - do m=2,NTR + ! All tracers but the first have 0 concentration in their inflows. As 0 is the + ! default value for the inflow concentrations, the following calls are unnecessary. + do m=2,tr_Reg%ntr if (m < 10) then ; write(name,'("tr_D",I1.1)') m else ; write(name,'("tr_D",I2.2)') m ; endif call tracer_name_lookup(tr_Reg, tr_ptr, name)