From ba54b935233ffe592e17592a88e4d2183281dbdb Mon Sep 17 00:00:00 2001 From: w-bonelli Date: Sun, 3 Mar 2024 17:20:37 -0500 Subject: [PATCH] wip --- src/ExchangeFactory.f90 | 189 +++++++------------- src/ExchangeRegistrar.f90 | 116 +++++++++++++ src/ModelFactory.f90 | 54 +++--- src/ModelRegistrar.f90 | 42 +++-- src/SimulationCreate.f90 | 352 ++++++++++++++++++-------------------- src/meson.build | 3 +- 6 files changed, 395 insertions(+), 361 deletions(-) create mode 100644 src/ExchangeRegistrar.f90 diff --git a/src/ExchangeFactory.f90 b/src/ExchangeFactory.f90 index 624ee3ca687..f9a9d95786a 100644 --- a/src/ExchangeFactory.f90 +++ b/src/ExchangeFactory.f90 @@ -2,7 +2,6 @@ module ExchangeFactoryModule use KindModule, only: I4B, LGP use ConstantsModule, only: LENMEMPATH, LINELENGTH use SimModule, only: store_error - use SimVariablesModule, only: iout, model_names, model_loc_idx use CharacterStringModule, only: CharacterStringType use ArrayHandlersModule, only: ifind use GwfGwfExchangeModule, only: register_gwfgwf @@ -16,6 +15,9 @@ module ExchangeFactoryModule use VirtualGwtExchangeModule, only: register_virtual_gwtgwt use VirtualGweExchangeModule, only: register_virtual_gwegwe use VirtualPrtExchangeModule, only: register_virtual_prtprt + use ExchangeRegistrarModule, only: register_exchange, & + register_actual_exchange, & + register_virtual_exchange implicit none private @@ -23,151 +25,80 @@ module ExchangeFactoryModule contains - subroutine create_exchanges(etypes, efiles, emnames_a, emnames_b, emempaths) - ! -- dummy + subroutine create_exchanges(& + exchange_types, & + exchange_filenames, & + exchange_mempaths, & + model1_names, & + model2_names) + ! dummy type(CharacterStringType), dimension(:), contiguous, & - pointer, intent(in) :: etypes !< exg types + pointer, intent(in) :: exchange_types !< exchange types type(CharacterStringType), dimension(:), contiguous, & - pointer, intent(in) :: efiles !< exg file names + pointer, intent(in) :: exchange_filenames !< exchange input file names type(CharacterStringType), dimension(:), contiguous, & - pointer, intent(in) :: emnames_a !< model a names + pointer, intent(in) :: exchange_mempaths !< exchange input memory paths type(CharacterStringType), dimension(:), contiguous, & - pointer, intent(in) :: emnames_b !< model b names + pointer, intent(in) :: model1_names !< model 1 names type(CharacterStringType), dimension(:), contiguous, & - pointer, intent(in) :: emempaths - ! -- local - integer(I4B) :: exg_id, n - integer(I4B) :: m1_id, m2_id - logical(LGP) :: both_remote, both_local - character(len=LINELENGTH) :: fname, name1, name2, exg_name - character(len=LENMEMPATH) :: exg_mempath - character(len=LINELENGTH) :: errmsg, exgtype - ! -- formats - character(len=*), parameter :: fmtmerr = "('Error in simulation control ', & - &'file. Could not find model: ', a)" + pointer, intent(in) :: model2_names !< model 2 names + ! local + integer(I4B) :: n + integer(I4B) :: id + character(len=LINELENGTH) :: name + character(len=LINELENGTH) :: errmsg + procedure(register_actual_exchange), pointer :: register_actual + procedure(register_virtual_exchange), pointer :: register_virtual - exg_id = 0 - do n = 1, size(etypes) - exgtype = etypes(n) - fname = efiles(n) - name1 = emnames_a(n) - name2 = emnames_b(n) - exg_mempath = emempaths(n) - exg_id = exg_id + 1 - - ! find model index in list - m1_id = ifind(model_names, name1) - if (m1_id < 0) then - write (errmsg, fmtmerr) trim(name1) - call store_error(errmsg, terminate=.true.) - end if - m2_id = ifind(model_names, name2) - if (m2_id < 0) then - write (errmsg, fmtmerr) trim(name2) - call store_error(errmsg, terminate=.true.) - end if - - ! both models on other process? then don't create it here... - both_remote = (model_loc_idx(m1_id) == -1 .and. & - model_loc_idx(m2_id) == -1) - both_local = (model_loc_idx(m1_id) > 0 .and. & - model_loc_idx(m2_id) > 0) - if (.not. both_remote) write (iout, '(4x,a,a,i0,a,i0,a,i0)') & - trim(exgtype), ' exchange ', exg_id, & - ' will be created to connect model ', m1_id, & - ' with model ', m2_id - - select case (exgtype) + id = 0 + do n = 1, size(exchange_types) + id = id + 1 + select case (etype) case ('GWF6-GWF6') - write (exg_name, '(a,i0)') 'GWF-GWF_', exg_id - if (.not. both_remote) & - call register_gwfgwf( & - fname, & - exg_name, & - exg_id, & - m1_id, & - m2_id, & - exg_mempath) - call register_virtual_gwfgwf( & - exg_name, & - exg_id, & - m1_id, & - m2_id) + write (name, '(a,i0)') 'GWF-GWF_', id + register_actual => register_gwfgwf + register_virtual => register_virtual_gwfgwf case ('GWT6-GWT6') - write (exg_name, '(a,i0)') 'GWT-GWT_', exg_id - if (.not. both_remote) & - call register_gwtgwt( & - fname, & - exg_name, & - exg_id, & - m1_id, & - m2_id, & - exg_mempath) - call register_virtual_gwtgwt( & - exg_name, & - exg_id, & - m1_id, & - m2_id) + write (name, '(a,i0)') 'GWT-GWT_', id + register_actual => register_gwtgwt + register_virtual => register_virtual_gwtgwt case ('GWE6-GWE6') - write (exg_name, '(a,i0)') 'GWE-GWE_', exg_id - if (.not. both_remote) & - call register_gwegwe( & - fname, & - exg_name, & - exg_id, & - m1_id, & - m2_id, & - exg_mempath) - call register_virtual_gwegwe( & - exg_name, & - exg_id, & - m1_id, & - m2_id) + write (name, '(a,i0)') 'GWE-GWE_', id + register_actual => register_gwegwe + register_virtual => register_virtual_gwegwe case ('GWF6-GWT6') - write (exg_name, '(a,i0)') 'GWF-GWT_', exg_id - if (both_local) & - call register_gwfgwt( & - fname, & - exg_name, & - exg_id, & - m1_id, & - m2_id, & - exg_mempath) + write (name, '(a,i0)') 'GWF-GWT_', id + register_actual => register_gwfgwt + register_virtual => null() case ('GWF6-GWE6') - write (exg_name, '(a,i0)') 'GWF-GWE_', exg_id - if (both_local) & - call register_gwfgwe( & - fname, & - exg_name, & - exg_id, & - m1_id, & - m2_id, & - exg_mempath) + write (name, '(a,i0)') 'GWF-GWE_', id + register_actual => register_gwfgwe + register_virtual => null() case ('GWF6-PRT6') - write (exg_name, '(a,i0)') 'GWF-PRT_', exg_id - if (both_local) & - call register_gwfprt( & - fname, & - exg_name, & - exg_id, & - m1_id, & - m2_id, & - exg_mempath) + write (name, '(a,i0)') 'GWF-PRT_', id + register_actual => register_gwfprt + register_virtual => null() case ('SWF6-GWF6') - write (exg_name, '(a,i0)') 'SWF-GWF_', exg_id - if (both_local) & - call register_swfgwf( & - fname, & - exg_name, & - exg_id, & - m1_id, & - m2_id, & - exg_mempath) + write (name, '(a,i0)') 'SWF-GWF_', id + register_actual => register_swfgwf + register_virtual => null() case default write (errmsg, '(a,a)') & - 'Unknown simulation exchange type: ', trim(exgtype) + 'Unknown simulation exchange type: ', trim(etype) call store_error(errmsg, terminate=.true.) end select + + ! register the exchange + call register_exchange(& + register_actual, & + register_virtual, & + id, & + name, & + exchange_types(n), & + exchange_filenames(n), & + exchange_mempaths(n), & + model1_names(n), & + model2_names(n)) end do end subroutine create_exchanges diff --git a/src/ExchangeRegistrar.f90 b/src/ExchangeRegistrar.f90 new file mode 100644 index 00000000000..fb9b08c1ba3 --- /dev/null +++ b/src/ExchangeRegistrar.f90 @@ -0,0 +1,116 @@ +module ExchangeRegistrarModule + use KindModule, only: I4B + use ConstantsModule, only: LINELENGTH + use ListsModule, only: basemodellist + use SimVariablesModule, only: iout, model_names, model_loc_idx + + implicit none + private + public :: register_exchange + public :: register_actual_exchange + public :: register_virtual_exchange + + interface + subroutine register_actual_exchange(id, name, file, model1_id, model2_id, mempath) + import I4B + integer(I4B), intent(in) :: id !< exchange id + character(len=*), intent(in) :: name !< exchange name + character(len=*), intent(in) :: file !< exchange input file + integer(I4B), intent(in) :: model1_id !< index of model 1 + integer(I4B), intent(in) :: model2_id !< index of model 2 + character(len=*), intent(in) :: mempath !< exchange input memory path + end subroutine + end interface + + interface + subroutine register_virtual_exchange(name, id, model1_id, model2_id) + import I4B + character(len=*), intent(in) :: name !< exchange name + integer(I4B), intent(in) :: id !< exchange id + integer(I4B), intent(in) :: model1_id !< index of model 1 + integer(I4B), intent(in) :: model2_id !< index of model 2 + end subroutine + end interface + +contains + + subroutine register_exchange(& + register_actual, & + register_virtual, & + exchange_id, & + exchange_name, & + exchange_type, & + exchange_file, & + exchange_mempath, & + model1_name, & + model2_name) + ! dummy + procedure(register_actual_exchange), pointer, & + intent(in) :: register_actual + procedure(register_virtual_exchange), pointer, & + intent(in) :: register_virtual + integer(I4B), intent(in) :: exchange_id + character(len=*), intent(in) :: exchange_name + character(len=*), intent(in) :: exchange_type + character(len=*), intent(in) :: exchange_file + character(len=*), intent(in) :: exchange_mempath + character(len=*), intent(in) :: model1_name + character(len=*), intent(in) :: model2_name + ! local + logical(LGP) :: both_local + logical(LGP) :: both_remote + logical(LGP) :: same_type + character(len=LINELENGTH) :: errmsg + ! formats + character(len=*), parameter :: fmtmerr = "('Error in simulation control ', & + &'file. Could not find model: ', a)" + + ! find model index in list + m1_id = ifind(model_names, model1_name) + if (m1_id < 0) then + write (errmsg, fmtmerr) trim(model1_name) + call store_error(errmsg, terminate=.true.) + end if + m2_id = ifind(model_names, model2_name) + if (m2_id < 0) then + write (errmsg, fmtmerr) trim(model2_name) + call store_error(errmsg, terminate=.true.) + end if + + ! both models on other process? then don't create it here... + both_remote = (model_loc_idx(m1_id) == -1 .and. & + model_loc_idx(m2_id) == -1) + both_local = (model_loc_idx(m1_id) > 0 .and. & + model_loc_idx(m2_id) > 0) + if (.not. both_remote) write (iout, '(4x,a,a,i0,a,i0,a,i0)') & + trim(exchange_type), ' exchange ', exchange_id, & + ' will be created to connect model ', m1_id, & + ' with model ', m2_id + + ! check if models are of the same type + same_type = exchange_name(1:3) == exchange_name(5:7) + + ! an actual exchange should be registered if the models + ! are the same type and at least one is local, or if the + ! models are not the same type and both are local + if ((same_type .and. .not. both_remote) .or. & + (.not. same_type .and. both_local)) & + call register_actual(& + exchange_file, & + exchange_name, & + exchange_id, & + m1_id, & + m2_id, & + exchange_mempath) + + ! if models are of the same type, register virtual exchange + if (same_type) & + call register_virtual(& + exchange_name, & + exchange_id, & + m1_id, & + m2_id) + + end subroutine register_exchange + +end module ExchangeRegistrarModule \ No newline at end of file diff --git a/src/ModelFactory.f90 b/src/ModelFactory.f90 index 3e7827a376c..8bcbde8cdc0 100644 --- a/src/ModelFactory.f90 +++ b/src/ModelFactory.f90 @@ -14,8 +14,8 @@ module ModelFactoryModule contains !> Create models - subroutine create_models(mtypes, mfnames, mnames) - ! -- modules + subroutine create_models(types, names, filenames) + ! modules ! START TEMPLATING use GwfModule, only: register_gwf use VirtualGwfModelModule, only: register_virtual_gwf @@ -28,36 +28,40 @@ subroutine create_models(mtypes, mfnames, mnames) use SwfModule, only: register_swf use VirtualSwfModelModule, only: register_virtual_swf ! END TEMPLATING - ! -- dummy + ! dummy type(CharacterStringType), dimension(:), contiguous, & - pointer, intent(in) :: mtypes !< model types + pointer, intent(in) :: types !< model types type(CharacterStringType), dimension(:), contiguous, & - pointer, intent(in) :: mfnames !< model file names + pointer, intent(in) :: names !< model names type(CharacterStringType), dimension(:), contiguous, & - pointer, intent(in) :: mnames !< model names - ! -- local - integer(I4B) :: n, im - character(len=LINELENGTH) :: errmsg, model_name, model_type, fname + pointer, intent(in) :: filenames !< model file names + ! local + integer(I4B) :: n + integer(I4B) :: id + character(len=LINELENGTH) :: mtype + character(len=LINELENGTH) :: mname + character(len=LINELENGTH) :: fname + character(len=LINELENGTH) :: errmsg procedure(register_actual_model), pointer :: ram procedure(register_virtual_model), pointer :: rvm - im = 0 - do n = 1, size(mtypes) - ! -- attributes for this model - model_type = mtypes(n) - fname = mfnames(n) - model_name = mnames(n) + id = 0 + do n = 1, size(types) + ! attributes for this model + mtype = types(n) + mname = names(n) + fname = filenames(n) ! make sure model name is valid - call check_model_name(model_type, model_name) + call check_model_name(mtype, mname) ! increment global model id - model_names(n) = model_name(1:LENMODELNAME) + model_names(n) = mname(1:LENMODELNAME) model_loc_idx(n) = -1 - ! -- pick the registration procedures for this model type - ! todo: hashmap not select case? (mtype -> register_*) - select case (model_type) + ! pick the registration procedures for this model type + ! todo: hashmap not select case? (mtype -> register_*) + select case (mtype) ! START TEMPLATING case ('GWF6') ram => register_gwf @@ -77,16 +81,16 @@ subroutine create_models(mtypes, mfnames, mnames) ! END TEMPLATING case default write (errmsg, '(a,a)') & - 'Unknown simulation model type: ', trim(model_type) + 'Unknown simulation model type: ', trim(mtype) call store_error(errmsg, terminate=.true.) end select - ! -- register the model - call register_model(ram, rvm, n, im, model_names(n), model_type, fname) + ! register the model + call register_model(ram, rvm, n, id, model_names(n), mtype, fname) end do - ! -- sanity check - if (simulation_mode == 'PARALLEL' .and. im == 0) then + ! sanity check + if (simulation_mode == 'PARALLEL' .and. id == 0) then write (errmsg, '(a, i0)') & 'No MODELS assigned to process ', proc_id call store_error(errmsg, terminate=.true.) diff --git a/src/ModelRegistrar.f90 b/src/ModelRegistrar.f90 index b1caecb430f..00e909cdc5d 100644 --- a/src/ModelRegistrar.f90 +++ b/src/ModelRegistrar.f90 @@ -10,7 +10,9 @@ module ModelRegistrarModule implicit none private - public :: register_model, register_actual_model, register_virtual_model + public :: register_model + public :: register_actual_model + public :: register_virtual_model interface subroutine register_actual_model(id, name, filename) @@ -35,30 +37,38 @@ subroutine register_virtual_model(id, name, model) !> @brief Register a model with the simulation. This entails registering !! the actual model, as well as a virtual model if it supports parallel. - subroutine register_model(ram, rvm, n, id, mname, mtype, filename) + subroutine register_model(& + register_actual, & + register_virtual, & + n, & + model_id, & + model_name, & + model_type, & + model_filename) ! -- dummy - procedure(register_actual_model), pointer, intent(in) :: ram - procedure(register_virtual_model), pointer, intent(in) :: rvm - integer(I4B), intent(in) :: n - integer(I4B), intent(inout) :: id !< model id (listed in mfsim.nam) - character(len=*), intent(in) :: mname !< model name - character(len=*), intent(in) :: mtype !< model type - character(len=*), intent(in) :: filename !< input file + procedure(register_actual_model), pointer, intent(in) :: register_actual + procedure(register_virtual_model), pointer, intent(in) :: register_virtual + integer(I4B), intent(in) :: n !< the global model index (accounting for all processes) + integer(I4B), intent(inout) :: model_id !< the local model index + character(len=*), intent(in) :: model_name !< the model's name + character(len=*), intent(in) :: model_type !< the model's type + character(len=*), intent(in) :: model_filename !< the model input file name ! -- local class(NumericalModelType), pointer :: model model => null() ! can be null for remote models if (model_ranks(n) == proc_id) then - id = id + 1 - write (iout, '(4x,2a,i0,a)') trim(mtype), ' model ', & + model_id = model_id + 1 + write (iout, '(4x,2a,i0,a)') trim(model_type), ' model ', & n, ' will be created' - call ram(n, mname, filename) - model => GetNumericalModelFromList(basemodellist, id) - model_loc_idx(n) = id + call register_actual(n, model_name, model_filename) + model => GetNumericalModelFromList(basemodellist, model_id) + model_loc_idx(n) = model_id end if - ! rvm will be null if the model doesn't support parallel - if (associated(rvm)) call rvm(n, mname, model) + ! proc pointer will be null if the model doesn't support parallel + if (associated(register_virtual)) & + call register_virtual(n, model_name, model) end subroutine register_model diff --git a/src/SimulationCreate.f90 b/src/SimulationCreate.f90 index f041f52cfca..67ebb07aa66 100644 --- a/src/SimulationCreate.f90 +++ b/src/SimulationCreate.f90 @@ -34,31 +34,16 @@ module SimulationCreateModule !> @brief Read the simulation name file and initialize the models, exchanges !< subroutine simulation_cr() - ! -- modules - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- Source simulation nam input context and create objects + ! Source simulation nam input context and create objects call source_simulation_nam() - ! - ! -- Return - return end subroutine simulation_cr !> @brief Deallocate simulation variables !< subroutine simulation_da() - ! -- modules use MemoryManagerModule, only: mem_deallocate - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- variables deallocate (model_names) deallocate (model_loc_idx) - ! - ! -- Return - return end subroutine simulation_da !> @brief Source the simulation name file @@ -69,66 +54,60 @@ end subroutine simulation_da !! !< subroutine source_simulation_nam() - ! -- dummy - ! -- local -! ------------------------------------------------------------------------------ - ! - ! -- Process OPTIONS block in namfile + ! Process OPTIONS block in namfile call options_create() - ! - ! -- Process TIMING block in namfile + + ! Process TIMING block in namfile call timing_create() - ! - ! -- Process MODELS block in namfile + + ! Process MODELS block in namfile call models_create() - ! - ! -- Process EXCHANGES block in namfile + + ! Process EXCHANGES block in namfile call exchanges_create() - ! - ! -- Process SOLUTION_GROUPS blocks in namfile + + ! Process SOLUTION_GROUPS blocks in namfile call solution_groups_create() - ! - ! -- Go through each model and make sure that it has been assigned to - ! a solution. + + ! Go through each model and make sure that it has been assigned to + ! a solution. call check_model_assignment() - ! - ! -- Go through each solution and assign exchanges accordingly + + ! Go through each solution and assign exchanges accordingly call assign_exchanges() - ! - ! -- Return - return + end subroutine source_simulation_nam !> @brief Set the simulation options !< subroutine options_create() - ! -- modules use MemoryHelperModule, only: create_mem_path use MemoryManagerModule, only: mem_setptr use SimVariablesModule, only: idm_context use MemoryManagerModule, only: mem_set_print_option use SimVariablesModule, only: isimcontinue, isimcheck - ! -- dummy - ! -- locals + ! locals character(len=LENMEMPATH) :: input_mempath - integer(I4B), pointer :: simcontinue, nocheck, maxerror + integer(I4B), pointer :: simcontinue + integer(I4B), pointer :: nocheck + integer(I4B), pointer :: maxerror character(len=:), pointer :: prmem character(len=LINELENGTH) :: errmsg - ! - ! -- set input memory path + + ! set input memory path input_mempath = create_mem_path('SIM', 'NAM', idm_context) - ! - ! -- set pointers to input context option params + + ! set pointers to input context option params call mem_setptr(simcontinue, 'CONTINUE', input_mempath) call mem_setptr(nocheck, 'NOCHECK', input_mempath) call mem_setptr(prmem, 'PRMEM', input_mempath) call mem_setptr(maxerror, 'MAXERRORS', input_mempath) - ! - ! -- update sim options + + ! update sim options isimcontinue = simcontinue isimcheck = nocheck call MaxErrors(maxerror) - ! + if (prmem /= '') then errmsg = '' call mem_set_print_option(iout, prmem, errmsg) @@ -136,85 +115,79 @@ subroutine options_create() call store_error(errmsg, .true.) end if end if - ! - ! -- log values to list file + + ! log values to list file if (iout > 0) then write (iout, '(/1x,a)') 'READING SIMULATION OPTIONS' - ! + if (isimcontinue == 1) then write (iout, '(4x, a)') & 'SIMULATION WILL CONTINUE EVEN IF THERE IS NONCONVERGENCE.' end if - ! + if (isimcheck == 0) then write (iout, '(4x, a)') & 'MODEL DATA WILL NOT BE CHECKED FOR ERRORS.' end if - ! + write (iout, '(4x, a, i0)') & 'MAXIMUM NUMBER OF ERRORS THAT WILL BE STORED IS ', maxerror - ! + if (prmem /= '') then write (iout, '(4x, a, a, a)') & 'MEMORY_PRINT_OPTION SET TO "', trim(prmem), '".' end if - ! + write (iout, '(1x,a)') 'END OF SIMULATION OPTIONS' end if - ! - ! -- return - return + end subroutine options_create !> @brief Set the timing module to be used for the simulation !< subroutine timing_create() - ! -- modules + ! modules use MemoryHelperModule, only: create_mem_path use MemoryManagerModule, only: mem_setptr use SimVariablesModule, only: idm_context use TdisModule, only: tdis_cr - ! -- dummy - ! -- locals + ! locals character(len=LENMEMPATH) :: input_mempath character(len=LENMEMPATH) :: tdis_input_mempath character(len=:), pointer :: tdis6 logical :: terminate = .true. - ! - ! -- set input memory path + + ! set input memory path input_mempath = create_mem_path('SIM', 'NAM', idm_context) tdis_input_mempath = create_mem_path('SIM', 'TDIS', idm_context) - ! + write (iout, '(/1x,a)') 'READING SIMULATION TIMING' - ! - ! -- set pointers to input context timing params + + ! set pointers to input context timing params call mem_setptr(tdis6, 'TDIS6', input_mempath) - ! - ! -- create timing + + ! create timing if (tdis6 /= '') then call tdis_cr(tdis6, tdis_input_mempath) else call store_error('TIMING block variable TDIS6 is unset'// & ' in simulation control input.', terminate) end if - ! + write (iout, '(1x,a)') 'END OF SIMULATION TIMING' - ! - ! -- return - return + end subroutine timing_create !> @brief Set the models to be used for the simulation !< subroutine models_create() - ! -- modules + ! modules use SimVariablesModule, only: idm_context use MemoryHelperModule, only: create_mem_path use MemoryManagerModule, only: mem_setptr, mem_allocate use ModelFactoryModule, only: create_models use ConstantsModule, only: LENMODELNAME - ! -- dummy - ! -- locals + ! locals character(len=LENMEMPATH) :: input_mempath type(CharacterStringType), dimension(:), contiguous, & pointer :: mtypes !< model types @@ -223,41 +196,40 @@ subroutine models_create() type(CharacterStringType), dimension(:), contiguous, & pointer :: mnames !< model names integer(I4B) :: nr_models_glob - ! - ! -- set input memory path + + ! set input memory path input_mempath = create_mem_path('SIM', 'NAM', idm_context) - ! - ! -- set pointers to input context model attribute arrays + + ! set pointers to input context model attribute arrays call mem_setptr(mtypes, 'MTYPE', input_mempath) call mem_setptr(mfnames, 'MFNAME', input_mempath) call mem_setptr(mnames, 'MNAME', input_mempath) - ! - ! -- allocate global arrays + + ! allocate global arrays nr_models_glob = size(mnames) call mem_allocate(model_ranks, nr_models_glob, 'MRANKS', input_mempath) allocate (model_names(nr_models_glob)) allocate (model_loc_idx(nr_models_glob)) - ! - ! -- assign models to cpu cores (in serial all to rank 0) + + ! assign models to cpu cores (in serial all to rank 0) call create_load_balance(model_ranks) - ! - ! -- create models + + ! create models write (iout, '(/1x,a)') 'READING SIMULATION MODELS' - call create_models(mtypes, mfnames, mnames) + call create_models(mtypes, mnames, mfnames) write (iout, '(1x,a)') 'END OF SIMULATION MODELS' - ! + end subroutine models_create !> @brief Set the exchanges to be used for the simulation !< subroutine exchanges_create() - ! -- modules + ! modules use MemoryHelperModule, only: create_mem_path use MemoryManagerModule, only: mem_setptr use SimVariablesModule, only: idm_context use ExchangeFactoryModule, only: create_exchanges - ! -- dummy - ! -- locals + ! locals character(len=LENMEMPATH) :: input_mempath type(CharacterStringType), dimension(:), contiguous, & pointer :: etypes !< exg types @@ -269,66 +241,63 @@ subroutine exchanges_create() pointer :: emnames_b !< model b names type(CharacterStringType), dimension(:), contiguous, & pointer :: emempaths - ! - ! -- set input memory path + + ! set input memory path input_mempath = create_mem_path('SIM', 'NAM', idm_context) - ! - ! -- set pointers to input context exchange attribute arrays + + ! set pointers to input context exchange attribute arrays call mem_setptr(etypes, 'EXGTYPE', input_mempath) call mem_setptr(efiles, 'EXGFILE', input_mempath) call mem_setptr(emnames_a, 'EXGMNAMEA', input_mempath) call mem_setptr(emnames_b, 'EXGMNAMEB', input_mempath) call mem_setptr(emempaths, 'EXGMEMPATHS', input_mempath) - ! - ! -- create exchanges + + ! create exchanges write (iout, '(/1x,a)') 'READING SIMULATION EXCHANGES' - call create_exchanges(etypes, efiles, emnames_a, emnames_b, emempaths) + call create_exchanges(etypes, efiles, emempaths, emnames_a, emnames_b) write (iout, '(1x,a)') 'END OF SIMULATION EXCHANGES' - ! + end subroutine exchanges_create !> @brief Check a solution_group to be used for the simulation !< subroutine solution_group_check(sgp, sgid, isgpsoln) - ! -- modules - ! -- dummy + ! dummy type(SolutionGroupType), pointer, intent(inout) :: sgp integer(I4B), intent(in) :: sgid integer(I4B), intent(in) :: isgpsoln - ! -- local + ! local character(len=LINELENGTH) :: errmsg logical :: terminate = .true. - ! -- formats + ! formats character(len=*), parameter :: fmterrmxiter = & "('MXITER is set to ', i0, ' but there is only one solution', & &' in SOLUTION GROUP ', i0, '. Set MXITER to 1 in simulation control', & &' file.')" - ! - ! -- error check completed group + + ! error check completed group if (sgid > 0) then - ! - ! -- Make sure there is a solution in this solution group + + ! Make sure there is a solution in this solution group if (isgpsoln == 0) then write (errmsg, '(a,i0)') & 'There are no solutions for solution group ', sgid call store_error(errmsg, terminate) end if - ! - ! -- If there is only one solution then mxiter should be 1. + + ! If there is only one solution then mxiter should be 1. if (isgpsoln == 1 .and. sgp%mxiter > 1) then write (errmsg, fmterrmxiter) sgp%mxiter, isgpsoln call store_error(errmsg, terminate) end if end if - ! - ! -- return - return + end subroutine solution_group_check !> @brief Set the solution_groups to be used for the simulation !< subroutine solution_groups_create() - ! -- modules + ! modules use MemoryManagerModule, only: mem_setptr use MemoryHelperModule, only: create_mem_path use SimVariablesModule, only: idm_context, simulation_mode @@ -339,8 +308,7 @@ subroutine solution_groups_create() use BaseModelModule, only: BaseModelType use BaseExchangeModule, only: BaseExchangeType use InputOutputModule, only: parseline, upcase - ! -- dummy - ! -- local + ! local character(len=LENMEMPATH) :: input_mempath type(CharacterStringType), dimension(:), contiguous, & pointer :: slntype @@ -349,7 +317,8 @@ subroutine solution_groups_create() type(CharacterStringType), dimension(:), contiguous, & pointer :: slnmnames integer(I4B), dimension(:), contiguous, pointer :: blocknum - character(len=LINELENGTH) :: stype, fname + character(len=LINELENGTH) :: stype + character(len=LINELENGTH) :: fname character(len=:), allocatable :: mnames type(SolutionGroupType), pointer :: sgp class(BaseSolutionType), pointer :: sp @@ -359,57 +328,56 @@ subroutine solution_groups_create() integer(I4B) :: sgid integer(I4B) :: glo_mid integer(I4B) :: loc_idx - integer(I4B) :: i, j, istat, mxiter + integer(I4B) :: i + integer(I4B) :: j + integer(I4B) :: istat + integer(I4B) :: mxiter integer(I4B) :: nwords character(len=LENMODELNAME), dimension(:), allocatable :: words character(len=:), allocatable :: parse_str character(len=LINELENGTH) :: errmsg logical :: terminate = .true. -! ------------------------------------------------------------------------------ - ! - ! -- set memory path + + ! set memory path input_mempath = create_mem_path('SIM', 'NAM', idm_context) - ! - ! -- set pointers to input context solution attribute arrays + + ! set pointers to input context solution attribute arrays call mem_setptr(slntype, 'SLNTYPE', input_mempath) call mem_setptr(slnfname, 'SLNFNAME', input_mempath) call mem_setptr(slnmnames, 'SLNMNAMES', input_mempath) call mem_setptr(blocknum, 'SOLUTIONGROUPNUM', input_mempath) - ! - ! -- open solution group logging block + + ! open solution group logging block write (iout, '(/1x,a)') 'READING SOLUTIONGROUP' - ! - ! -- initialize + + ! initialize sgid = 0 ! integer id of soln group, tracks with blocknum isoln = 0 ! cumulative solution number - ! - ! -- create solution groups + + ! create solution groups do i = 1, size(blocknum) - ! - ! -- allocate slnmnames string + ! allocate slnmnames string allocate (character(slnmnames(i)%strlen()) :: mnames) - ! - ! -- attributes for this solution + + ! attributes for this solution stype = slntype(i) fname = slnfname(i) mnames = slnmnames(i) if (blocknum(i) /= sgid) then - ! - ! -- check for new soln group + ! check for new soln group if (blocknum(i) == sgid + 1) then - ! - ! -- error check completed group + ! error check completed group call solution_group_check(sgp, sgid, isgpsoln) - ! - ! -- reinitialize + + ! reinitialize nullify (sgp) isgpsoln = 0 ! solution counter for this solution group - ! - ! -- set sgid + + ! set sgid sgid = blocknum(i) - ! - ! -- create new soln group and add to global list + + ! create new soln group and add to global list call solutiongroup_create(sgp, sgid) call AddSolutionGroupToList(solutiongrouplist, sgp) else @@ -419,30 +387,27 @@ subroutine solution_groups_create() call store_error(errmsg, terminate) end if end if - ! - ! -- + select case (stype) - ! case ('MXITER') read (fname, *, iostat=istat) mxiter if (istat == 0) then sgp%mxiter = mxiter end if case ('IMS6') - ! - ! -- increment solution counters + ! increment solution counters isoln = isoln + 1 isgpsoln = isgpsoln + 1 - ! - ! -- create soln and add to group + + ! create soln and add to group sp => create_ims_solution(simulation_mode, fname, isoln) call sgp%add_solution(isoln, sp) - ! - ! -- parse model names + + ! parse model names parse_str = trim(mnames)//' ' call parseline(parse_str, nwords, words) - ! - ! -- Find each model id and get model + + ! Find each model id and get model do j = 1, nwords call upcase(words(j)) glo_mid = ifind(model_names, words(j)) @@ -450,7 +415,7 @@ subroutine solution_groups_create() write (errmsg, '(a,a)') 'Invalid model name: ', trim(words(j)) call store_error(errmsg, terminate) end if - ! + loc_idx = model_loc_idx(glo_mid) if (loc_idx == -1) then if (simulation_mode == 'PARALLEL') then @@ -458,28 +423,27 @@ subroutine solution_groups_create() cycle end if end if - ! + mp => GetBaseModelFromList(basemodellist, loc_idx) - ! - ! -- Add the model to the solution + + ! Add the model to the solution call sp%add_model(mp) mp%idsoln = isoln end do case ('EMS6') - ! - ! -- increment solution counters + ! increment solution counters isoln = isoln + 1 isgpsoln = isgpsoln + 1 - ! - ! -- create soln and add to group + + ! create soln and add to group sp => create_ems_solution(simulation_mode, fname, isoln) call sgp%add_solution(isoln, sp) - ! - ! -- parse model names + + ! parse model names parse_str = trim(mnames)//' ' call parseline(parse_str, nwords, words) - ! - ! -- Find each model id and get model + + ! Find each model id and get model do j = 1, nwords call upcase(words(j)) glo_mid = ifind(model_names, words(j)) @@ -487,7 +451,7 @@ subroutine solution_groups_create() write (errmsg, '(a,a)') 'Invalid model name: ', trim(words(j)) call store_error(errmsg, terminate) end if - ! + loc_idx = model_loc_idx(glo_mid) if (loc_idx == -1) then if (simulation_mode == 'PARALLEL') then @@ -495,33 +459,31 @@ subroutine solution_groups_create() cycle end if end if - ! + mp => GetBaseModelFromList(basemodellist, loc_idx) - ! - ! -- Add the model to the solution + + ! Add the model to the solution call sp%add_model(mp) mp%idsoln = isoln end do case default end select - ! - ! -- clean up + + ! clean up deallocate (mnames) end do - ! - ! -- error check final group + + ! error check final group call solution_group_check(sgp, sgid, isgpsoln) - ! - ! -- close exchange logging block + + ! close exchange logging block write (iout, '(1x,a)') 'END OF SOLUTIONGROUP' - ! - ! -- Check and make sure at least one solution group was found + + ! Check and make sure at least one solution group was found if (solutiongrouplist%Count() == 0) then call store_error('There are no solution groups.', terminate) end if - ! - ! -- return - return + end subroutine solution_groups_create !> @brief Check for dangling models, and break with @@ -554,27 +516,28 @@ end subroutine check_model_assignment !! should be overridden to indicate if such a link exists. !< subroutine assign_exchanges() - ! -- local class(BaseSolutionType), pointer :: sp class(BaseExchangeType), pointer :: ep class(BaseModelType), pointer :: mp type(ListType), pointer :: models_in_solution - integer(I4B) :: is, ie, im + integer(I4B) :: is + integer(I4B) :: ie + integer(I4B) :: im do is = 1, basesolutionlist%Count() sp => GetBaseSolutionFromList(basesolutionlist, is) - ! - ! -- now loop over exchanges + + ! now loop over exchanges do ie = 1, baseexchangelist%Count() ep => GetBaseExchangeFromList(baseexchangelist, ie) - ! - ! -- and add when it affects (any model in) the solution matrix + + ! and add when it affects (any model in) the solution matrix models_in_solution => sp%get_models() do im = 1, models_in_solution%Count() mp => GetBaseModelFromList(models_in_solution, im) if (ep%connects_model(mp)) then - ! - ! -- add to solution (and only once) + + ! add to solution (and only once) call sp%add_exchange(ep) exit end if @@ -593,6 +556,7 @@ end subroutine assign_exchanges !< of the IDM. subroutine create_load_mask(mask_array) use SimVariablesModule, only: proc_id + ! dummy integer(I4B), dimension(:) :: mask_array ! local integer(I4B) :: i @@ -615,12 +579,20 @@ subroutine create_load_balance(mranks) use SimVariablesModule, only: idm_context use MemoryHelperModule, only: create_mem_path use MemoryManagerModule, only: mem_setptr + ! dummy integer(I4B), dimension(:) :: mranks ! local - integer(I4B) :: im, imm, ie, ip, cnt - integer(I4B) :: nr_models, nr_gwf_models, nr_gwt_models + integer(I4B) :: im + integer(I4B) :: imm + integer(I4B) :: ie + integer(I4B) :: ip + integer(I4B) :: cnt + integer(I4B) :: nr_models + integer(I4B) :: nr_gwf_models + integer(I4B) :: nr_gwt_models integer(I4B) :: nr_exchanges - integer(I4B) :: min_per_proc, nr_left + integer(I4B) :: min_per_proc + integer(I4B) :: nr_left integer(I4B) :: rank integer(I4B), dimension(:), allocatable :: nr_models_proc character(len=:), allocatable :: model_type_str diff --git a/src/meson.build b/src/meson.build index c42a85b9a45..d68a15eb468 100644 --- a/src/meson.build +++ b/src/meson.build @@ -360,7 +360,8 @@ modflow_sources = files( 'RunControlFactory.F90', 'ModelFactory.f90', 'ModelRegistrar.f90', - 'ExchangeFactory.f90' + 'ExchangeFactory.f90', + 'ExchangeRegistrar.f90' ) modflow_petsc_sources = files(