mo_common_read_config.F90

Go to the documentation of this file.

!> \file mo_common_read_config.f90
!> \brief   \copybrief mo_common_read_config
!> \details \copydetails mo_common_read_config
 
!> \brief Reading of main model configurations.
!> \details This routine reads the configurations of namelists commonly used by mHM, mRM and MPR
!> \authors Matthias Zink
!> \date Dec 2012
!> \copyright Copyright 2005-\today, the mHM Developers, Luis Samaniego, Sabine Attinger: All rights reserved.
!! mHM is released under the LGPLv3+ license \license_note
!> \ingroup f_common
MODULE mo_common_read_config
 
  USE mo_kind, ONLY : i4, dp
  use mo_message, only: error_message
 
  IMPLICIT NONE
 
  PRIVATE
 
  PUBLIC :: common_read_config, set_land_cover_scenes_id
 
  ! ------------------------------------------------------------------
 
CONTAINS
 
 
  !> \brief Read main configurations commonly used by mHM, mRM and MPR
  !> \details Read the main configurations commonly used by mHM, mRM and MPR, namely:
  !! project_description, directories_general, mainconfig, processSelection, LCover
  !> \changelog
  !! - Robert Schweppe Dec  2018
  !!   - refactoring and restructuring
  !! - Sebastian Müller Mar 2023
  !!   - added check_L0Domain
  !> \authors Matthias Zink
  !> \date Dec 2012
  subroutine common_read_config(file_namelist, unamelist)
 
    use mo_common_constants, only : maxnlcovers, maxnodomains
    use mo_common_variables, only : conventions, lc_year_end, lc_year_start, lcfilename, contact, &
                                    dircommonfiles, dirconfigout, dirlcover, dirmorpho, dirout, &
                                    mhmfilerestartout, mrmfilerestartout, &
                                    filelatlon, history, iflag_cordinate_sys, mhm_details, domainmeta, nlcoverscene, &
                                    nprocesses, nuniquel0domains, processmatrix, project_details, resolutionhydrology, &
                                    setup_description, simulation_type, write_restart
    use mo_nml, only : close_nml, open_nml, position_nml
    use mo_string_utils, only : num2str
 
    implicit none
 
    !> name of file
    character(*), intent(in) :: file_namelist
 
    !> id of file
    integer, intent(in) :: unamelist
 
    ! Choosen process description number
    integer(i4), dimension(nProcesses) :: processcase
 
    character(256), dimension(maxNoDomains) :: dir_morpho
 
    character(256), dimension(maxNoDomains) :: mhm_file_restartout
 
    character(256), dimension(maxNoDomains) :: mrm_file_restartout
 
    character(256), dimension(maxNoDomains) :: dir_lcover
 
    character(256), dimension(maxNoDomains) :: dir_out
 
    character(256), dimension(maxNoDomains) :: file_latlon
 
    real(dp), dimension(maxNoDomains) :: resolution_hydrology
 
    integer(i4), dimension(maxNoDomains) :: l0domain
 
    integer(i4), dimension(maxNoDomains) :: read_opt_domain_data
 
    ! starting year LCover
    integer(i4), dimension(maxNLCovers) :: lcoveryearstart
 
    ! ending year LCover
    integer(i4), dimension(maxNLCovers) :: lcoveryearend
 
    ! filename of Lcover file
    character(256), dimension(maxNLCovers) :: lcoverfname
 
    integer(i4) :: i, newdomainid, domainid, idomain, ndomains
 
    ! flag to advance nuniqueL0Domain counter
    logical :: addcounter
 
 
    ! define namelists
    ! namelist directories
    namelist /project_description/ project_details, setup_description, simulation_type, &
            conventions, contact, mhm_details, history
    namelist /directories_general/ dirconfigout, dircommonfiles, &
            dir_morpho, dir_lcover, &
            dir_out, mhm_file_restartout, mrm_file_restartout, &
            file_latlon
    ! namelist spatial & temporal resolution, optimization information
    namelist /mainconfig/ iflag_cordinate_sys, resolution_hydrology, ndomains, l0domain, write_restart, &
            read_opt_domain_data
    ! namelist process selection
    namelist /processselection/ processcase
 
    ! namelist for land cover scenes
    namelist/lcover/nlcoverscene, lcoveryearstart, lcoveryearend, lcoverfname
 
    !===============================================================
    !  Read namelist main directories
    !===============================================================
    call open_nml(file_namelist, unamelist, quiet = .true.)
 
    !===============================================================
    !  Read namelist specifying the project description
    !===============================================================
    call position_nml('project_description', unamelist)
    read(unamelist, nml = project_description)
 
    !===============================================================
    !  Read namelist specifying the model configuration
    !===============================================================
    call position_nml('mainconfig', unamelist)
    read(unamelist, nml = mainconfig)
 
    call init_domain_variable(ndomains, read_opt_domain_data(1:ndomains), domainmeta)
 
    if (ndomains .GT. maxnodomains) then
      call error_message('***ERROR: Number of domains is resticted to ', trim(num2str(maxnodomains)), '!')
    end if
 
    call check_l0domain(l0domain, ndomains)
 
    ! allocate patharray sizes
    allocate(resolutionhydrology(domainmeta%nDomains))
    allocate(dirmorpho(domainmeta%nDomains))
    allocate(mhmfilerestartout(domainmeta%nDomains))
    allocate(mrmfilerestartout(domainmeta%nDomains))
    allocate(dirlcover(domainmeta%nDomains))
    allocate(dirout(domainmeta%nDomains))
    allocate(filelatlon(domainmeta%nDomains))
    allocate(domainmeta%L0DataFrom(domainmeta%nDomains))
    allocate(domainmeta%optidata(domainmeta%nDomains))
    allocate(domainmeta%doRouting(domainmeta%nDomains))
 
    nuniquel0domains = 0_i4
    do idomain = 1, domainmeta%nDomains
      domainid = domainmeta%indices(idomain)
      resolutionhydrology(idomain) = resolution_hydrology(domainid)
      ! if a domain uses the same L0 data as a previous one, write
      ! the index into domainMeta%L0DataFrom
      newdomainid = l0domain(domainid)
      domainmeta%L0DataFrom(idomain) = idomain
      !
      addcounter = .true.
      do i = 1, idomain - 1
        if (newdomainid == domainmeta%indices(i)) then
          domainmeta%L0DataFrom(idomain) = i
          addcounter = .false.
        end if
      end do
      if (addcounter) nuniquel0domains = nuniquel0domains + 1_i4
    end do
 
    ! check for possible options
    if(.NOT. (iflag_cordinate_sys == 0 .OR. iflag_cordinate_sys == 1)) then
      call error_message('***ERROR: coordinate system for the model run should be 0 or 1')
    end if
 
    !===============================================================
    ! Read land cover
    !===============================================================
    call position_nml('LCover', unamelist)
    read(unamelist, nml = lcover)
 
    ! put land cover scenes to corresponding file name and LuT
    ! this is done already here for MPR, which does not check for the time periods
    allocate(lcfilename(nlcoverscene))
    allocate(lc_year_start(nlcoverscene))
    allocate(lc_year_end(nlcoverscene))
    lcfilename(:) = lcoverfname(1 : nlcoverscene)
    lc_year_start(:) = lcoveryearstart(1 : nlcoverscene)
    lc_year_end(:) = lcoveryearend(1 : nlcoverscene)
 
    !===============================================================
    ! Read namelist for mainpaths
    !===============================================================
    call position_nml('directories_general', unamelist)
    read(unamelist, nml = directories_general)
 
    do idomain = 1, domainmeta%nDomains
      domainid = domainmeta%indices(idomain)
      domainmeta%optidata(idomain) = read_opt_domain_data(domainid)
      dirmorpho(idomain)           = dir_morpho(domainid)
      mhmfilerestartout(idomain)   = mhm_file_restartout(domainid)
      mrmfilerestartout(idomain)   = mrm_file_restartout(domainid)
      dirlcover(idomain)           = dir_lcover(domainid)
      dirout(idomain)              = dir_out(domainid)
      filelatlon(idomain)          = file_latlon(domainid)
    end do
 
    ! ToDo: add test if opti_function matches at least one domainMeta%optidata
    ! as soon as common and common_mRM_mHM are merged, if that is the plan
 
 
    !===============================================================
    ! Read process selection list
    !===============================================================
    ! init the processCase matrix to 0 to be backward compatible
    ! if cases were added later (then there would be no values if not init here)
    processcase = 0_i4
    call position_nml('processselection', unamelist)
    read(unamelist, nml = processselection)
 
    processmatrix = 0_i4
    processmatrix(:, 1) = processcase
    if (processmatrix(8, 1) == 0) then
      domainmeta%doRouting(:) = .false.
    else
      domainmeta%doRouting(:) = .true.
    end if
 
    call close_nml(unamelist)
 
  end subroutine common_read_config
 
 
  !> \brief Set land cover scenes IDs
  !> \changelog
  !! - Robert Schweppe Dec  2018
  !!   - refactoring and restructuring
  !> \authors Matthias Zink
  !> \date Dec 2012
  subroutine set_land_cover_scenes_id(sim_Per, LCyear_Id)
 
    use mo_common_constants, only : nodata_i4
    use mo_common_types, only: period
    use mo_common_variables, only : lc_year_end, lc_year_start, domainmeta, nlcoverscene
    use mo_string_utils, only : num2str
 
    implicit none
 
    type(period), dimension(:), intent(in) :: sim_per !< simulation period
    integer(i4), dimension(:, :), allocatable, intent(inout) :: lcyear_id !< land cover year ID
 
    integer(i4) :: ii, idomain
 
 
    ! countercheck if land cover covers simulation period
    if (lc_year_start(1) .GT. minval(sim_per(1 : domainmeta%nDomains)%yStart)) then
      call error_message('***ERROR: Land cover for warming period is missing!', raise=.false.)
      call error_message('   SimStart   : ', trim(num2str(minval(sim_per(1 : domainmeta%nDomains)%yStart))), raise=.false.)
      call error_message('   LCoverStart: ', trim(num2str(lc_year_start(1))))
    end if
    if (lc_year_end(nlcoverscene) .LT. maxval(sim_per(1 : domainmeta%nDomains)%yEnd)) then
      call error_message('***ERROR: Land cover period shorter than modelling period!', raise=.false.)
      call error_message('   SimEnd   : ', trim(num2str(maxval(sim_per(1 : domainmeta%nDomains)%yEnd))), raise=.false.)
      call error_message('   LCoverEnd: ', trim(num2str(lc_year_end(nlcoverscene))))
    end if
    !
    allocate(lcyear_id(minval(sim_per(1 : domainmeta%nDomains)%yStart) : maxval(sim_per(1 : domainmeta%nDomains)%yEnd), &
                   domainmeta%nDomains))
    lcyear_id = nodata_i4
    do idomain = 1, domainmeta%nDomains
      do ii = 1, nlcoverscene
        ! land cover before model period or land cover after model period
        if ((lc_year_end(ii) .LT. sim_per(idomain)%yStart) .OR. &
                (lc_year_start(ii) .GT. sim_per(idomain)%yEnd)) then
          cycle
          ! land cover period fully covers model period
        else if ((lc_year_start(ii) .LE. sim_per(idomain)%yStart) .AND. &
                (lc_year_end(ii) .GE. sim_per(idomain)%yEnd)) then
          lcyear_id(sim_per(idomain)%yStart : sim_per(idomain)%yEnd, idomain) = ii
          exit
          ! land cover period covers beginning of model period
        else if ((lc_year_start(ii) .LE. sim_per(idomain)%yStart) .AND. &
                (lc_year_end(ii) .LT. sim_per(idomain)%yEnd)) then
          lcyear_id(sim_per(idomain)%yStart : lc_year_end(ii), idomain) = ii
          ! land cover period covers end of model period
        else if ((lc_year_start(ii) .GT. sim_per(idomain)%yStart) .AND. &
                (lc_year_end(ii) .GE. sim_per(idomain)%yEnd)) then
          lcyear_id(lc_year_start(ii) : sim_per(idomain)%yEnd, idomain) = ii
          ! land cover period covers part of model_period
        else
          lcyear_id(lc_year_start(ii) : lc_year_end(ii), idomain) = ii
        end if
      end do
    end do
 
 
  end subroutine set_land_cover_scenes_id
 
 
  !> \brief Initialization of the domain variables
  !> \details Initialization of the domain variable for all domain loops and if activated for parallelization
  !! In case of MPI parallelization domainMeta%overAllNumberOfDomains is a
  !! variable where the number of domains from the namelist is stored. By this
  !! every process knows the total number of domains. Then, in a loop the
  !! domains are distributed onto the processes. There is a master process
  !! and several subprocesses. The master process only reads the confings in the
  !! mHM driver.
  !!
  !! The subprocesses get a number of domains. domainMeta%nDomain refers
  !! to the number of domains assigned to a specific process. It is a local
  !! variable and therefore has a different value for each process.
  !!
  !! In case more domains are there than processes, currently the domains
  !! are distributed round robin, i.e. like cards in a card game.
  !!
  !! In case less domains than processes exist, all remaining processes
  !! are assigned to the routing domains round robin. In that case the
  !! local communicator is of interest: It is a group of processes assigned
  !! to a routing domain again with a master process
  !! (domainMeta%isMasterInComLocal) and subprocesses. This communicator can
  !! in future be passed to the routing parallelization.
  !> \author Maren Kaluza
  !> \date Sep 2019
  subroutine init_domain_variable(nDomains, optiData, domainMeta)
    use mo_common_types, only: domain_meta
#ifdef MPI
    use mo_common_variables, only: comm
    use mpi_f08
#endif
    integer(i4),       intent(in)    :: nDomains !< number of domains
    integer(i4), dimension(:), intent(in) :: optiData !< optimization data
    type(domain_meta), intent(inout) :: domainMeta !< domain meta info
 
    integer             :: ierror
    integer(i4)         :: nproc
    integer(i4)         :: rank
    integer(i4)         :: iDomain
    integer(i4)         :: colDomain, colMasters
 
    domainmeta%overallNumberOfDomains = ndomains
#ifdef MPI
    ! find number of processes nproc
    call mpi_comm_size(comm, nproc, ierror)
    ! find the number the process is referred to, called rank
    call mpi_comm_rank(comm, rank, ierror)
    if (nproc < 2) then
      call error_message('at least 2 processes are required')
    end if
    ! if there are more processes than domains
    if (nproc > domainmeta%overallNumberOfDomains + 1) then
      domainmeta%nDomains = 0
      ! master reads only metadata of all domains
      if (rank == 0) then
        call init_domain_variable_for_master(domainmeta, colmasters, coldomain)
      ! all other nodes read metadata but also data of assigned domains
      else
        ! currently each domain gets one process except it is a routing domain.
        ! in that case the remaining processes are distributed round robin to
        ! the routing domains.
        call distribute_processes_to_domains_according_to_role(optidata, rank, &
                                               domainmeta, colmasters, coldomain)
      end if
      ! two communicators are created, i.e. groups of processes that talk about
      ! a certain topic:
      ! comMaster is the communicator of all processes that need to read all
      ! data. These are the processes that are masters in the comLocal plus the
      ! master over all processes. comLocal is a communicator for a group of
      ! processes assigned to the same domain.
      call mpi_comm_split(comm, colmasters, rank, domainmeta%comMaster, ierror)
      call mpi_comm_split(comm, coldomain, rank, domainmeta%comLocal, ierror)
      call mpi_comm_size(domainmeta%comMaster, nproc, ierror)
    else
      ! in case of more domains than processes, distribute domains round robin
      ! onto the processes
      call mpi_comm_dup(comm, domainmeta%comMaster, ierror)
      domainmeta%isMasterInComLocal = .true.
      domainmeta%nDomains = 0
      ! master reads only metadata of all domains
      if (rank == 0) then
        domainmeta%nDomains = domainmeta%overallNumberOfDomains
        allocate(domainmeta%indices(domainmeta%nDomains))
        do idomain = 1, domainmeta%nDomains
          domainmeta%indices(idomain) = idomain
        end do
      ! all other nodes read metadata but also data of assigned domains
      else
        call distributedomainsroundrobin(nproc, rank, domainmeta)
      end if
    end if ! round robin
#else
    domainmeta%nDomains = ndomains
    allocate(domainmeta%indices(domainmeta%nDomains))
    do idomain = 1, domainmeta%nDomains
      domainmeta%indices(idomain) = idomain
    end do
#endif
 
  end subroutine init_domain_variable
 
#ifdef MPI
  subroutine init_domain_variable_for_master(domainMeta, colMasters, colDomain)
    use mo_common_types, only: domain_meta
    type(domain_meta), intent(inout) :: domainMeta
    integer(i4),       intent(out)   :: colMasters
    integer(i4),       intent(out)   :: colDomain
    !local
    integer(i4) :: iDomain
 
    domainmeta%nDomains = domainmeta%overallNumberOfDomains
    allocate(domainmeta%indices(domainmeta%nDomains))
    do idomain = 1, domainmeta%nDomains
      domainmeta%indices(idomain) = idomain
    end do
    colmasters = 1
    coldomain = 0
    domainmeta%isMasterInComLocal = .true.
 
  end subroutine init_domain_variable_for_master
 
  subroutine distributedomainsroundrobin(nproc, rank, domainMeta)
    use mo_common_types, only: domain_meta
    integer(i4),       intent(in)    :: nproc
    integer(i4),       intent(in)    :: rank
    type(domain_meta), intent(inout) :: domainMeta
 
    integer(i4) :: iDomain, iProcDomain
 
    do idomain = 1 , domainmeta%overallNumberOfDomains
      if (rank == (modulo(idomain + nproc - 2, (nproc - 1)) + 1)) then
        domainmeta%nDomains = domainmeta%nDomains + 1
      end if
    end do
    allocate(domainmeta%indices(domainmeta%nDomains))
    iprocdomain = 0
    do idomain = 1 , domainmeta%overallNumberOfDomains
      if (rank == (modulo(idomain + nproc - 2, (nproc - 1)) + 1)) then
        iprocdomain = iprocdomain + 1
        domainmeta%indices(iprocdomain) = idomain
      end if
    end do
  end subroutine distributedomainsroundrobin
 
  subroutine distribute_processes_to_domains_according_to_role(optiData, rank, &
                                               domainMeta, colMasters, colDomain)
    use mo_common_types, only: domain_meta
    integer(i4), dimension(:), intent(in)    :: optiData
    integer(i4),               intent(in)    :: rank
    type(domain_meta),         intent(inout) :: domainMeta
    integer(i4),               intent(out)   :: colMasters
    integer(i4),               intent(out)   :: colDomain
 
    ! local
    integer(i4) :: nDomainsAll, nTreeDomains, i, iDomain
    integer(i4), dimension(:), allocatable :: treeDomainList
 
    ndomainsall = domainmeta%overallNumberOfDomains
    ntreedomains = 0
    do idomain = 1, ndomainsall
      !ToDo: should also routing but not opti domains be counted?
      if (optidata(idomain) == 1) then
        ntreedomains = ntreedomains + 1
      end if
    end do
    allocate(treedomainlist(ntreedomains))
    i = 0
    do idomain = 1, ndomainsall
      if (optidata(idomain) == 1) then
        i = i + 1
        treedomainlist(i) = idomain
      end if
    end do
    if (rank < ndomainsall + 1) then
      colmasters = 1
      coldomain = rank
      domainmeta%isMasterInComLocal = .true.
      domainmeta%nDomains = 1
      allocate(domainmeta%indices(domainmeta%nDomains))
      domainmeta%indices(1) = rank
    else
      colmasters = 0
      if (ntreedomains > 0) then
        coldomain = treedomainlist(mod(rank, ntreedomains) + 1)
      else
        coldomain = 1
      end if
      domainmeta%isMasterInComLocal = .false.
      domainmeta%nDomains = 1
      allocate(domainmeta%indices(domainmeta%nDomains))
      ! ToDo : temporary solution, this should either not read data at all
      ! or data corresponding to the master process
      domainmeta%indices(1) = 1
    end if
    deallocate(treedomainlist)
  end subroutine
#endif
 
  ! \brief check the L0Domain variable from the namelist
  !> \authors Sebastian Müller
  !> \date Mar 2023
  subroutine check_l0domain(L0Domain, nDomains)
    use mo_common_constants, only : maxnodomains
    use mo_string_utils, only : num2str
 
    integer(i4), dimension(maxNoDomains), intent(in) ::L0Domain !< given L0Domain variable
    integer(i4), intent(in) :: nDomains !< number of domains
 
    integer(i4) :: i
 
    do i = 1, ndomains
      if (l0domain(i) < 0) call error_message( &
        "L0Domain values need to be positive: ", &
        "L0Domain(", trim(adjustl(num2str(i))), ") = ", trim(adjustl(num2str(l0domain(i)))))
      if (l0domain(i) > i) call error_message( &
        "L0Domain values need to be less or equal to the domain index: ", &
        "L0Domain(", trim(adjustl(num2str(i))), ") = ", trim(adjustl(num2str(l0domain(i)))))
      ! check for increasing values
      if (i > 1) then
        if (l0domain(i) < l0domain(i-1)) call error_message( &
          "L0Domain values need to be increasing: ", &
          "L0Domain(", trim(adjustl(num2str(i-1))), ") = ", trim(adjustl(num2str(l0domain(i-1)))), &
          ", L0Domain(", trim(adjustl(num2str(i))), ") = ", trim(adjustl(num2str(l0domain(i)))))
      end if
      ! if lower, check that the reference domain uses its own L0Data
      if (l0domain(i) < i) then
        if (l0domain(l0domain(i)) /= l0domain(i)) call error_message( &
          "L0Domain values should be taken from a domain with its own L0 data: ", &
          "L0Domain(", trim(adjustl(num2str(i))), ") = ", trim(adjustl(num2str(l0domain(i)))), &
          ", L0Domain(", trim(adjustl(num2str(l0domain(i)))), ") = ", trim(adjustl(num2str(l0domain(l0domain(i))))))
      end if
    end do
 
  end subroutine check_l0domain
 
END MODULE mo_common_read_config