monc.F90

Go to the documentation of this file.

 
module monc_mod
  use datadefn_mod, only : long_string_length, string_length
  use monc_component_mod, only : component_descriptor_type
  use collections_mod, only : list_type, hashmap_type, map_type, iterator_type, mapentry_type, c_size, c_next_generic, &
       c_get_real, c_has_next, c_get_iterator, c_next_mapentry
  use conversions_mod, only : conv_to_string, conv_to_real, conv_is_logical, conv_to_logical
  use state_mod, only : model_state_type
  use registry_mod, only : get_all_registered_components, get_component_info, register_component, &
       execute_initialisation_callbacks, execute_finalisation_callbacks, init_registry, order_all_callbacks, &
       display_callbacks_in_order_at_each_stage
  use timestepper_mod, only : init_timestepper, timestep, finalise_timestepper
  use logging_mod, only : log_info, log_warn, log_error, log_debug, log_log, log_get_logging_level, log_set_logging_level, &
       log_master_log, initialise_logging
  use optionsdatabase_mod, only : load_command_line_into_options_database, options_get_integer, options_has_key, &
       options_get_string, options_get_logical, options_add
  use configuration_file_parser_mod, only : parse_configuration_file
  use configuration_checkpoint_netcdf_parser_mod, only : parse_configuration_checkpoint_netcdf
  use science_constants_mod, only : initialise_science_constants
  use mpi, only : mpi_comm_world, mpi_thread_multiple, mpi_thread_serialized, mpi_thread_single, mpi_thread_funneled, mpi_wtime
  use datadefn_mod, only : default_precision, init_data_defn
  implicit none
 
#ifndef TEST_MODE
  private
#endif
  abstract interface
 
     subroutine io_server_run_procedure(options_database, io_communicator_arg, provided_threading, &
          total_global_processes, continuation_run, io_configuration_file)
       import hashmap_type, long_string_length
       type(hashmap_type), intent(inout) :: options_database
       integer, intent(in) :: io_communicator_arg, provided_threading, total_global_processes
       logical, intent(in) :: continuation_run
       character(len=LONG_STRING_LENGTH), intent(in) :: io_configuration_file
     end subroutine io_server_run_procedure
  end interface
 
  public monc_core_bootstrap
 
contains
 
  subroutine monc_core_bootstrap(component_descriptions, io_server_run)
    type(list_type), intent(inout) :: component_descriptions
    procedure(io_server_run_procedure) :: io_server_run
 
    type(model_state_type) :: state
    integer :: ierr, myrank, size, io_server_placement_period, provided_threading, selected_threading_mode
    logical :: i_am_monc_process
    character(len=LONG_STRING_LENGTH) :: io_server_config_file
    
    selected_threading_mode=get_mpi_threading_mode()
    call mpi_init_thread(selected_threading_mode, provided_threading, ierr)
    if (selected_threading_mode .gt. provided_threading) then
      call log_master_log(log_error, "You have selected to thread at level '"//&
           trim(mpi_threading_level_to_string(selected_threading_mode))//&
           "' but the maximum level your MPI implementation can provide is '"//&
           trim(mpi_threading_level_to_string(provided_threading))//"'")
    end if    
    call load_model_configuration(state, state%options_database)
 
    state%io_server_enabled=determine_if_io_server_enabled(state%options_database)
    
    call init_data_defn()
    ! Set up the logging with comm world PIDs initially for logging from the configuration parsing
    call mpi_comm_rank(mpi_comm_world, myrank, ierr)
    call initialise_logging(myrank)
    
    call log_set_logging_level(options_get_integer(state%options_database, "logging"))
 
    ! Check options_database for conflicts
    !call perform_options_compatibility_checks(state%options_database)
 
    if (state%io_server_enabled) then
      call mpi_comm_size(mpi_comm_world, size, ierr)
      if (size==1) call log_log(log_error, &
           "Run with 1 process, With IO server enabled then the minimum process size is 2 (1 for IO, 1 for MONC)")
      call get_io_configuration(state%options_database, io_server_config_file, io_server_placement_period)
      call split_communicator_into_monc_and_io(io_server_placement_period, state%parallel%monc_communicator, &
           state%parallel%io_communicator, i_am_monc_process, state%parallel%corresponding_io_server_process)
      if (.not. i_am_monc_process) then        
        call io_server_run(state%options_database, state%parallel%io_communicator, provided_threading, &
             size, state%continuation_run, io_server_config_file)
      else  
        call monc_run(component_descriptions, state)
      end if
    else
      state%parallel%monc_communicator=mpi_comm_world
      call monc_run(component_descriptions, state)
    end if
 
    call mpi_finalize(ierr)
  end subroutine monc_core_bootstrap
 
  logical function determine_if_io_server_enabled(options_database)
    type(hashmap_type), intent(inout) :: options_database
 
    determine_if_io_server_enabled=options_get_logical(options_database, "enable_io_server")
    if (determine_if_io_server_enabled) then
      determine_if_io_server_enabled=options_get_logical(options_database, "iobridge_enabled")      
    end if    
  end function determine_if_io_server_enabled  
 
  subroutine load_model_configuration(state, options_database)
    type(model_state_type), intent(inout) :: state
    type(hashmap_type), intent(inout) :: options_database
 
    call load_command_line_into_options_database(options_database)
    if (options_has_key(options_database, "config")) then
      state%continuation_run=.false.
      call parse_configuration_file(options_database, options_get_string(options_database, "config"))
    else if (options_has_key(options_database, "checkpoint")) then
      state%continuation_run=.true.
      call parse_configuration_checkpoint_netcdf(options_database, &
           options_get_string(options_database, "checkpoint"), mpi_comm_world)
    else
      call log_master_log(log_error, "You must either provide a configuration file or checkpoint to restart from")
      call mpi_barrier(mpi_comm_world) ! All other processes barrier here to ensure 0 displays the message before quit
      stop
    end if
 
    ! Reload command line arguments to override any stuff in the configuration files
    call load_command_line_into_options_database(options_database)
 
  end subroutine load_model_configuration 
 
  subroutine perform_options_compatibility_checks(options_database)
    type(hashmap_type), intent(inout) :: options_database
 
    if (is_present_and_true(options_database, "conditional_diagnostics_column_enabled") .NEQV. &
        is_present_and_true(options_database, "conditional_diagnostics_whole_enabled")  ) then
 
      if ( .not. is_present_and_true(options_database, "conditional_diagnostics_column_enabled")) &
        call options_add(options_database, "conditional_diagnostics_column_enabled", .true.)
      if ( .not. is_present_and_true(options_database, "conditional_diagnostics_whole_enabled")) &
        call options_add(options_database, "conditional_diagnostics_whole_enabled", .true.)
 
      call log_master_log(log_info, "Only one conditional_diagnostics component is enabled, but both are required to function.")
      call log_master_log(log_info, "We assume you would like conditional_diagnostics enabled so have enabled the other, too.")
    end if
 
  end subroutine perform_options_compatibility_checks
 
  subroutine monc_run(component_descriptions, state)
    type(list_type), intent(inout) :: component_descriptions
    type(model_state_type), intent(inout) :: state
 
    integer :: ierr, total_size
    double precision :: end_time, timestepping_time, modeldump_time
 
    state%model_start_wtime=mpi_wtime()
    call mpi_comm_rank(state%parallel%monc_communicator, state%parallel%my_rank, ierr)
    call mpi_comm_size(state%parallel%monc_communicator, state%parallel%processes, ierr)
    call mpi_comm_size(mpi_comm_world, total_size, ierr)
 
    call initialise_logging(state%parallel%my_rank)
    
    call log_master_log(log_info,"MONC running with "//trim(conv_to_string(state%parallel%processes))//" processes, "// &
         trim(conv_to_string(total_size-state%parallel%processes))// " IO server(s)")
 
#ifdef DEBUG_MODE
    call log_master_log(log_warn,"MONC compiled with debug options, you probably want to recompile without for production runs")
#endif    
 
    call init_registry(state%options_database) ! Initialise the registry
 
    call fill_registry_with_components(state%options_database, component_descriptions)
    call initialise_science_constants(state)
    call order_all_callbacks()
    ! If the option has been provided then display the registered component information
    if (is_present_and_true(state%options_database, "registered") .and. state%parallel%my_rank==0) &
         call display_registed_components()    
    if (is_present_and_true(state%options_database, "showcallbacks") .and. state%parallel%my_rank==0) &
         call display_callbacks_in_order_at_each_stage()
 
    if (.not. is_present_and_true(state%options_database, "norun")) then
      ! Unless configured otherwise then run through the different stages of execution
      call perform_model_steps(state, timestepping_time, modeldump_time)
    end if
    call mpi_barrier(state%parallel%monc_communicator, ierr)
    end_time=mpi_wtime()
    if (state%parallel%my_rank==0) then
      call log_log(log_info, "Entire MONC run completed in "//trim(conv_to_string(int((end_time-state%model_start_wtime)*1000)))//&
           "ms (timestepping="//trim(conv_to_string(int(timestepping_time * 1000)))//"ms, modeldump="//&
           trim(conv_to_string(int(modeldump_time * 1000)))//"ms, misc="//trim(conv_to_string((&
           int((end_time-state%model_start_wtime) * 1000)) - (int(timestepping_time * 1000) + int(modeldump_time * 1000))))//"ms)")
    end if    
  end subroutine monc_run
 
  subroutine perform_model_steps(state, timestepping_time, modeldump_time)
    type(model_state_type), intent(inout) :: state
    double precision, intent(out) :: timestepping_time, modeldump_time
 
    integer :: logging_mod_level
    double precision :: start_time, end_time, start_iteration_time
 
    timestepping_time=0.0_default_precision
    modeldump_time=0.0_default_precision
 
    call init_timestepper()
 
    logging_mod_level = log_get_logging_level()
    call execute_initialisation_callbacks(state)
    state%continue_timestep=.true.
    start_time=mpi_wtime()
    do while (state%continue_timestep)
      if (state%update_dtm) state%dtm=state%dtm_new
      ! The start of a timestep
      if (logging_mod_level .ge. log_debug) start_iteration_time=mpi_wtime()
      call timestep(state) ! Call out to the timestepper to do the actual timestepping per component
      if (logging_mod_level .ge. log_debug .and. state%parallel%my_rank==0) &
           call display_timestep_information(state%timestep, start_iteration_time)
      if (state%continue_timestep) then
        state%timestep = state%timestep+1
        state%time = state%time + state%dtm
      end if
    end do
    end_time=mpi_wtime()
    state%timestep_runtime=end_time-start_time
    timestepping_time=timestepping_time+state%timestep_runtime
    call execute_finalisation_callbacks(state)
 
    call finalise_timestepper()
  end subroutine perform_model_steps
 
  subroutine display_timestep_information(timestep, start_time)
    integer, intent(in) :: timestep
    double precision, intent(in) :: start_time
 
    double precision :: end_time
 
    end_time=mpi_wtime()
    call log_log(log_debug, "Timestep "//trim(conv_to_string(timestep))//" completed in "//&
         trim(conv_to_string(int((end_time-start_time) * 1000)))//"ms")
  end subroutine display_timestep_information  
 
  subroutine fill_registry_with_components(options_database, component_descriptions)
    type(hashmap_type), intent(inout) :: options_database
    type(list_type), intent(inout) :: component_descriptions
 
    class(*), pointer :: raw_data
    type(iterator_type) :: iterator
 
    iterator=c_get_iterator(component_descriptions)
    do while (c_has_next(iterator))
      raw_data=>c_next_generic(iterator)
      select type(raw_data)
        type is (component_descriptor_type)
          call register_component(options_database, raw_data)
        class default
          call log_log(log_warn, "Can not register component due to corrupted data")
      end select
    end do
  end subroutine fill_registry_with_components
 
  logical function is_present_and_true(options_database, key)
    type(hashmap_type), intent(inout) :: options_database
    character(len=*), intent(in) :: key
    
    if (options_has_key(options_database, key)) then
      is_present_and_true=options_get_logical(options_database, key)
      return
    end if
    is_present_and_true=.false.
  end function is_present_and_true
 
  subroutine display_registed_components()
    type(map_type) :: registered_components
    type(iterator_type) :: iterator
    type(mapentry_type):: map_entry
 
    registered_components = get_all_registered_components()
    call log_log(log_info, "Registered components: "//conv_to_string(c_size(registered_components)))
    iterator=c_get_iterator(registered_components)
    do while (c_has_next(iterator))
      map_entry=c_next_mapentry(iterator)
      call log_log(log_info, trim(map_entry%key)//" "//trim(conv_to_string(c_get_real(map_entry))))
    end do    
  end subroutine display_registed_components
 
  subroutine split_communicator_into_monc_and_io(moncs_per_io, monc_communicator, io_communicator, &
       am_i_monc_process, corresponding_io_server_process)
    integer, intent(in) :: moncs_per_io
    integer, intent(out) :: monc_communicator, io_communicator, corresponding_io_server_process
    logical, intent(out) :: am_i_monc_process
 
    integer, dimension(:), allocatable :: members_monc_group, members_io_group
    integer :: total_ranks, monc_group, io_group, io_processes, monc_processes, i, io_index, &
         monc_index, my_rank, ierr, global_group, io_stride
 
    call mpi_comm_size(mpi_comm_world, total_ranks, ierr)
    call mpi_comm_rank(mpi_comm_world, my_rank, ierr)
 
    io_stride=moncs_per_io+1
    io_processes=get_number_io_processes(total_ranks, io_stride)
    monc_processes=total_ranks-io_processes
    allocate(members_io_group(io_processes), members_monc_group(monc_processes))
    io_index=1
    monc_index=1
    corresponding_io_server_process=-1
    am_i_monc_process=.true.
 
    do i=0, total_ranks-1
      if (mod(i, io_stride) == 0 .and. i .lt. total_ranks) then
        if (io_index .le. io_processes) then
          members_io_group(io_index)=i
        else
          members_monc_group(monc_index)=i
          monc_index=monc_index+1
        end if        
        io_index=io_index+1
        if (my_rank == i) am_i_monc_process=.false.
        if (my_rank .gt. i .and. my_rank .lt. i+io_stride) then
          corresponding_io_server_process=i
        end if
      else
        members_monc_group(monc_index)=i
        monc_index=monc_index+1
      end if
    end do
 
    if (.not. am_i_monc_process .and. my_rank .eq. total_ranks-1) then
      am_i_monc_process=.true.
      corresponding_io_server_process=my_rank-io_stride
    end if
 
    if (am_i_monc_process .and. corresponding_io_server_process .lt. 0) then
      call log_log(log_error, "MONC can not deduce its IO server rank, try with a different number of IO to MONC setting")
    end if    
 
    if (log_get_logging_level() .ge. log_debug) then
      call log_log(log_debug, "IO server assignment, rank="//conv_to_string(my_rank)//" IO server="//&
           conv_to_string(corresponding_io_server_process)//" am I a MONC="//conv_to_string(am_i_monc_process))
    end if    
 
    call mpi_comm_group(mpi_comm_world, global_group, ierr)
    call mpi_group_incl(global_group, monc_processes, members_monc_group, monc_group, ierr)
    call mpi_group_incl(global_group, io_processes, members_io_group, io_group, ierr)
    call mpi_comm_create(mpi_comm_world, monc_group, monc_communicator, ierr)
    call mpi_comm_create(mpi_comm_world, io_group, io_communicator, ierr)
    deallocate(members_io_group, members_monc_group)
  end subroutine split_communicator_into_monc_and_io
 
  integer function get_number_io_processes(total_ranks, moncs_per_io)
    integer, intent(in) :: total_ranks, moncs_per_io
 
    integer :: io_stride
 
    io_stride=moncs_per_io
    get_number_io_processes=total_ranks/io_stride
    if (get_number_io_processes * io_stride .lt. total_ranks-1) get_number_io_processes=get_number_io_processes+1
  end function get_number_io_processes
 
  subroutine get_io_configuration(options_database, ioserver_configuration_file, moncs_per_io_server)
    type(hashmap_type), intent(inout) :: options_database
    character(len=LONG_STRING_LENGTH), intent(out) :: ioserver_configuration_file
    integer, intent(out) :: moncs_per_io_server
   
    integer :: myrank, ierr
 
    ioserver_configuration_file=options_get_string(options_database, "ioserver_configuration_file")
    moncs_per_io_server=options_get_integer(options_database, "moncs_per_io_server")
 
    if (moncs_per_io_server == -1 .or. ioserver_configuration_file == "") then
      call mpi_comm_rank(mpi_comm_world, myrank, ierr)
      if (myrank == 0) call log_log(log_error, "To run an IO server you must provide the placement period and configuration file")
      call mpi_barrier(mpi_comm_world) ! All other processes barrier here to ensure 0 displays the message before quit
      stop
    end if
  end subroutine get_io_configuration  
 
  integer function get_mpi_threading_mode()
    character(len=STRING_LENGTH) :: thread_multiple_config_value
    integer :: status
 
    call get_environment_variable("MONC_THREAD_MULTIPLE", thread_multiple_config_value, status=status)
 
    if (status == 0 .and. conv_is_logical(trim(thread_multiple_config_value))) then
      if (conv_to_logical(trim(thread_multiple_config_value))) then
        get_mpi_threading_mode=mpi_thread_multiple
      else
        get_mpi_threading_mode=mpi_thread_serialized
      end if
    else
      get_mpi_threading_mode=mpi_thread_serialized
    end if
  end function get_mpi_threading_mode
 
  character(len=STRING_LENGTH) function mpi_threading_level_to_string(lvl)
    integer, intent(in) :: lvl
 
    if (lvl == mpi_thread_single) then
      mpi_threading_level_to_string="single"
    else if (lvl == mpi_thread_funneled) then
      mpi_threading_level_to_string="funneled"
    else if (lvl == mpi_thread_serialized) then
      mpi_threading_level_to_string="serialized"
    else if (lvl == mpi_thread_multiple) then
      mpi_threading_level_to_string="multiple"
    else
      mpi_threading_level_to_string="unknown"
    end if
  end function mpi_threading_level_to_string  
end module monc_mod