mod_dg_launcher.F90

Go to the documentation of this file.

!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
module mod_dg_launcher
  !-----------------------------------------------------------------------------
  !
  !++ used modules
  !
  use scale_precision
  use scale_io
  use scale_prof
 
  !-----------------------------------------------------------------------------
  implicit none
  private
  !-----------------------------------------------------------------------------
  !
  !++ included parameters
  !
  !-----------------------------------------------------------------------------
  !
  !++ Public procedure
  !
  public :: launcher
 
  !-----------------------------------------------------------------------------
  !
  !++ parameters & variables
  !
  !=============================================================================
 
contains
  subroutine launcher( &
       EXECUTE_PREPROCESS, &
       EXECUTE_MODEL )
    use scale_prc, only: &
       prc_domain_nlim,     &
       prc_comm_null,       &
       prc_abort,           &
       prc_mpistart,        &
       prc_mpifinish,       &
       prc_mpisplit_bulk,   &
       prc_mpisplit_nest,   &
       prc_universal_setup, &
       prc_global_setup,    &
       prc_global_root,     &
       prc_errhandler_setup
    use scale_fpm, only: &
       fpm_init
    use mod_dg_prep, only: &
       dg_prep
    use mod_dg_driver, only: &
       dg_driver
    implicit none
 
    logical, intent(in) :: execute_preprocess ! execute preprocess tools?
    logical, intent(in) :: execute_model      ! execute main model?
 
    integer               :: num_bulkjob                  = 1       ! number of bulk job
    integer               :: num_bulkjob_once             = 1       ! number of bulk job for one iteration
    integer               :: num_iteration_bulk           = 1       ! number of iteration for bulk job
    integer               :: bulkjob_start_dirnum         = 0       ! start number of directory for bulk job
    logical               :: add_bulkjob_path             = .false. ! add path of the bulk job to files
    integer               :: num_domain                   = 1       ! number of domains
    integer               :: num_fail_tolerance           = 1       ! tolerance number of failure processes
    integer               :: freq_fail_check              = 5       ! FPM polling frequency per DT (0: no polling)
    integer               :: prc_domains(prc_domain_nlim) = 0       ! number of total process in each domain
    character(len=H_LONG) :: conf_files (prc_domain_nlim) = ""      ! name of configulation files
    logical               :: abort_all_jobs               = .false. ! abort all jobs or not?
    logical               :: log_split                    = .false. ! log-output for mpi splitting?
    logical               :: color_reorder                = .true.  ! coloring reorder for mpi splitting?
    logical               :: failure_prc_manage           = .false. ! use failure process management?
 
    namelist / param_launcher / &
!         EXECUTE_PREPROCESS, &
!         EXECUTE_MODEL,      &
         num_bulkjob,          &
         num_iteration_bulk,   &
         bulkjob_start_dirnum, &
         add_bulkjob_path,     &
         num_domain,           &
         num_fail_tolerance,   &
         freq_fail_check,      &
         prc_domains,          &
         conf_files,           &
         abort_all_jobs,       &
         log_split,            &
         color_reorder,        &
         failure_prc_manage
 
    integer               :: universal_comm                   ! universal communicator
    integer               :: universal_nprocs                 ! number of procs in universal communicator
    integer               :: universal_myrank                 ! my rank         in universal communicator
    logical               :: universal_master                 ! master process  in universal communicator?
    character(len=H_LONG) :: universal_cnf_fname              ! config file for launcher
 
    integer               :: global_comm                      ! communicator for each member
    integer               :: global_nprocs                    ! number of procs in global communicator
    integer               :: prc_bulkjob(prc_domain_nlim) = 0 ! number of procs in each bulk job = global_nprocs
    integer               :: id_bulkjob                       ! bulk job ID
 
    logical               :: use_fpm = .false.                ! switch for fpm module
 
    integer               :: local_comm                       ! assigned local communicator
    integer               :: id_domain                        ! domain ID
    integer               :: intercomm_parent                 ! inter communicator with parent
    integer               :: intercomm_child                  ! inter communicator with child
    character(len=5)      :: path                             ! path to config file for local domain
 
    integer :: itr
    integer :: fid, ierr
    !-----------------------------------------------------------
 
    ! start MPI
    call prc_mpistart( universal_comm ) ! [OUT]
 
    call prc_universal_setup( universal_comm,   & ! [IN]
                              universal_nprocs, & ! [OUT]
                              universal_myrank, & ! [OUT]
                              universal_master  ) ! [OUT]
 
    if( universal_master ) write(*,*) '*** Start Launch System for SCALE-DG'
 
    !--- read launcher config
 
    universal_cnf_fname = io_arg_getfname( universal_master )
 
    fid = io_cnf_open( universal_cnf_fname, & ! [IN]
                       universal_master     ) ! [IN]
 
    ! set default
    conf_files(1) = universal_cnf_fname
 
    ! read namelist
    rewind(fid)
    read(fid,nml=param_launcher,iostat=ierr)
    if ( ierr < 0 ) then !--- missing
       ! keep default setting (no members, no nesting)
    elseif( ierr > 0 ) then !--- fatal error
       if( universal_master ) write(*,*) 'xxx Not appropriate names in namelist PARAM_LAUNCHER. Check!'
       call prc_abort
    endif
 
    close(fid)
 
    if (      execute_preprocess &
         .OR. execute_model      ) then
       if( universal_master ) write(*,*) "*** Execute preprocess? : ", execute_preprocess
       if( universal_master ) write(*,*) "*** Execute model?      : ", execute_model
    else
       if( universal_master ) write(*,*) 'xxx No execution. please check PARAM_LAUNCHER. STOP'
       call prc_abort
    endif
 
    !--- split for bulk jobs
 
    global_nprocs = universal_nprocs
    if ( num_bulkjob > 1 ) then
 
       if ( num_bulkjob == 1 ) num_iteration_bulk = 1
       num_bulkjob_once = ceiling( real(num_bulkjob) / num_iteration_bulk )
       if ( mod(universal_nprocs,num_bulkjob_once) /= 0 ) then !--- fatal error
          if( universal_master ) write(*,*) 'xxx Total Num of Processes must be divisible by NUM_BULKJOB/NUM_ITERATION_BULK. Check!'
          if( universal_master ) write(*,*) 'xxx Total Num of Processes           = ', universal_nprocs
          if( universal_master ) write(*,*) 'xxx NUM_BULKJOB                      = ', num_bulkjob
          if( universal_master ) write(*,*) 'xxx NUM_ITERATION_BULK               = ', num_iteration_bulk
          if( universal_master ) write(*,*) 'xxx NUM_BULKJOB / NUM_ITERATION_BULK = ', num_bulkjob_once
          call prc_abort
       endif
 
       global_nprocs = universal_nprocs / num_bulkjob_once
 
       if( universal_master ) write(*,'(1x,A,I5)') "*** TOTAL # of BULK JOBS             = ", num_bulkjob
       if( universal_master ) write(*,'(1x,A,I5)') "*** # of BULK JOB for each iteration = ", num_bulkjob_once
       if( universal_master ) write(*,'(1x,A,I5)') "*** Total # of PROCESS               = ", universal_nprocs
       if( universal_master ) write(*,'(1x,A,I5)') "*** # of PROCESS of each JOB         = ", global_nprocs
 
       if ( bulkjob_start_dirnum < 0 ) then
          if( universal_master ) write(*,*) 'xxx BULKJOB_START_DIRNUM must >=0'
          call prc_abort
       end if
       if ( bulkjob_start_dirnum + num_bulkjob -1 > 9999 ) then
          if( universal_master ) write(*,*) 'xxx BULKJOB_START_DIRNUM + NUM_BULKJOB must <= 9999'
          call prc_abort
       end if
 
       if ( failure_prc_manage ) then
          if( universal_master ) write(*,'(1x,A)') "*** Available: Failure Process Management"
          use_fpm = .true.                    !--- available only in bulk job
          if ( num_fail_tolerance <= 0 ) then !--- fatal error
             if( universal_master ) write(*,*) 'xxx Num of Failure Processes must be positive number. Check!'
             if( universal_master ) write(*,*) 'xxx NUM_FAIL_TOLERANCE = ', num_fail_tolerance
             call prc_abort
          endif
 
          if ( num_fail_tolerance > num_bulkjob ) then !--- fatal error
             write(*,*) 'xxx NUM_FAIL_TOLERANCE is bigger than # of NUM_BLUKJOB'
             write(*,*) '    set to be: NUM_FAIL_TOLERANCE <= NUM_BLUKJOB'
             call prc_abort
          endif
 
          if ( num_domain > 1 ) then !--- avoid error in the current implementation
             if ( freq_fail_check >= 1 .or. num_fail_tolerance /= num_bulkjob ) then
                write(*,*) 'xxx Full function of FPM is not available with online nesting.'
                write(*,*) '    You can use this only to avoid job stop until all members finish.'
                write(*,*) '    for this purpose, set: FREQ_FAIL_CHECK    =  0'
                write(*,*) '                           NUM_FAIL_TOLERANCE == NUM_BULKJOB'
                call prc_abort
             endif
          endif
       endif
    endif
    prc_bulkjob(1:num_bulkjob) = global_nprocs
 
    ! communicator split for bulk/ensemble
    call prc_mpisplit_bulk( universal_comm,   & ! [IN]
                            num_bulkjob_once, & ! [IN]
                            prc_bulkjob(:),   & ! [IN]
                            log_split,        & ! [IN]
                            global_comm,      & ! [OUT]
                            id_bulkjob        ) ! [OUT]
 
    call prc_global_setup( abort_all_jobs, & ! [IN]
                           global_comm     ) ! [IN]
 
    !--- split for nesting
 
    if ( num_domain > 1 ) then
       if( universal_master ) write(*,'(1x,A,I5)') "*** TOTAL DOMAIN NUMBER     = ", num_domain
       if( universal_master ) write(*,'(1x,A,L5)') "*** Flag of ABORT ALL JOBS  = ", abort_all_jobs
    endif
 
    ! communicator split for nesting domains
    call prc_mpisplit_nest( global_comm,      & ! [IN]
                            num_domain,       & ! [IN]
                            prc_domains(:),   & ! [IN]
                            log_split,        & ! [IN]
                            color_reorder,    & ! [IN]
                            local_comm,       & ! [OUT]
                            id_domain         ) ! [OUT]
 
    !--- initialize FPM module & error handler
    call fpm_init( num_fail_tolerance, & ! [IN]
                   freq_fail_check,    & ! [IN]
                   universal_comm,     & ! [IN]
                   global_comm,        & ! [IN]
                   local_comm,         & ! [IN]
                   num_bulkjob,        & ! [IN]
                   prc_global_root,    & ! [IN]
                   use_fpm             ) ! [IN]
 
    call prc_errhandler_setup( use_fpm, universal_master )
 
    !--- start main routine
 
    do itr = 1, num_iteration_bulk
 
       if ( id_bulkjob > num_bulkjob ) exit
 
       if( universal_master .and. num_iteration_bulk > 1 ) then
          write(*,*)
          write(*,*) '*** BULK ITERATION COUNT : ', itr, '/', num_iteration_bulk
       end if
 
 
       call io_set_universalrank( universal_myrank, & ! [IN]
                                  id_bulkjob,       & ! [IN]
                                  id_domain         ) ! [IN]
 
       if ( num_bulkjob > 1 ) then
          write(path,'(I4.4,A)') id_bulkjob + bulkjob_start_dirnum, "/"
       else
          path = ""
       endif
 
       if ( execute_preprocess ) then
          call dg_prep( local_comm,            & ! [IN]
                        conf_files(id_domain), & ! [IN]
                        path,                  & ! [IN]
                        add_bulkjob_path       ) ! [IN]
       endif
 
       if ( execute_model ) then
          call dg_driver( local_comm,            & ! [IN]
                          conf_files(id_domain), & ! [IN]
                          path,                  & ! [IN]
                          add_bulkjob_path       ) ! [IN]
       endif
 
       id_bulkjob = id_bulkjob + num_bulkjob_once
 
    end do
 
    ! stop MPI
    call prc_mpifinish
 
    if( universal_master ) write(*,*) '*** End   Launch System for SCALE-DG'
 
  subroutine launcher( & …
  end subroutine launcher
 
end module mod_dg_launcher