scale-rm_pp.F90

Go to the documentation of this file.

!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
program scalerm_pp
  !-----------------------------------------------------------------------------
  !
  !++ used modules
  !
  use scale_precision
  use scale_io
  use scale_prof

  use scale_prc, only: &
     prc_domain_nlim,     &
     prc_mpistart,        &
     prc_abort,         &
     prc_mpifinish,       &
     prc_mpisplit,        &
     prc_universal_setup, &
     prc_global_setup,    &
     prc_global_root,     &
     prc_errhandler_setup
  use scale_fpm, only: &
     fpm_init
  use mod_rm_prep, only: &
     rm_prep
  use mod_rm_driver, only: &
     rm_driver
  !-----------------------------------------------------------------------------
  implicit none
  !-----------------------------------------------------------------------------
  !
  !++ included parameters
  !
  !-----------------------------------------------------------------------------
  !
  !++ parameters & variables
  !
  !=============================================================================

  logical               :: EXECUTE_PREPROCESS           = .true.  ! execute preprocess tools?
  logical               :: EXECUTE_MODEL                = .false. ! execute main model?
  integer               :: NUM_BULKJOB                  = 1       ! number of bulk jobs
  integer               :: NUM_DOMAIN                   = 1       ! number of domains
  integer               :: NUM_FAIL_TOLERANCE           = 1       ! tolerance number of failure processes
  integer               :: FREQ_FAIL_CHECK              = 0       ! 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_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
  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       ! = global_nprocs
  character(len=H_LONG) :: dummy1     (prc_domain_nlim) = ""
  integer               :: intercomm_parent_null                  ! NULL inter communicator with parent
  integer               :: intercomm_child_null                   ! NULL inter communicator with child
  character(len=H_LONG) :: bulk_prefix                            ! dirname of each member

  logical               :: use_fpm = .false.                      ! switch for fpm module

  integer               :: local_comm       ! assigned local communicator
  integer               :: intercomm_parent ! inter communicator with parent
  integer               :: intercomm_child  ! inter communicator with child
  character(len=H_LONG) :: local_cnf_fname  ! config file for local domain

  integer :: fid, ierr
  !-----------------------------------------------------------

  ! start MPI
  call prc_mpistart( universal_comm ) ! [OUT]

  call prc_universal_setup( universal_comm,   & ! [IN]
                            universal_nprocs, & ! [OUT]
                            universal_master  ) ! [OUT]

  if( universal_master ) write(*,*) '*** Start Launch System for SCALE-RM'

  !--- 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)
  freq_fail_check = 0 ! force 0, coz no time integrations

  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

  if ( mod(universal_nprocs,num_bulkjob) /= 0 ) then !--- fatal error
     if( universal_master ) write(*,*) 'xxx Total Num of Processes must be divisible by NUM_BULKJOB. Check!'
     if( universal_master ) write(*,*) 'xxx Total Num of Processes = ', universal_nprocs
     if( universal_master ) write(*,*) 'xxx            NUM_BULKJOB = ', num_bulkjob
     call prc_abort
  endif

  global_nprocs = universal_nprocs / num_bulkjob
  prc_bulkjob(1:num_bulkjob) = global_nprocs
  if ( num_bulkjob > 1 ) then
     if( universal_master ) write(*,'(1x,A,I5)') "*** TOTAL BULK JOB NUMBER   = ", num_bulkjob
     if( universal_master ) write(*,'(1x,A,I5)') "*** PROCESS NUM of EACH JOB = ", global_nprocs

     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 NUM_BLUKJOB number'
           write(*,*) '    set to be: NUM_FAIL_TOLERANCE <= NUM_BLUKJOB'
           call prc_abort
        endif
     endif
  endif

  ! communicator split for bulk/ensemble
  call prc_mpisplit( universal_comm,        & ! [IN]
                     num_bulkjob,           & ! [IN]
                     prc_bulkjob(:),        & ! [IN]
                     dummy1(:),            & ! [IN]  dummy
                     log_split,             & ! [IN]
                     .true.,                & ! [IN]  flag bulk_split
                     .false.,               & ! [IN]  no reordering
                     global_comm,           & ! [OUT]
                     intercomm_parent_null, & ! [OUT] null
                     intercomm_child_null,  & ! [OUT] null
                     bulk_prefix            ) ! [OUT] dir name instead of file name

  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( global_comm,      & ! [IN]
                     num_domain,       & ! [IN]
                     prc_domains(:),   & ! [IN]
                     conf_files(:),   & ! [IN]
                     log_split,        & ! [IN]
                     .false.,          & ! [IN] flag bulk_split
                     color_reorder,    & ! [IN]
                     local_comm,       & ! [OUT]
                     intercomm_parent, & ! [OUT]
                     intercomm_child,  & ! [OUT]
                     local_cnf_fname   ) ! [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

  if ( num_bulkjob > 1 ) then
     local_cnf_fname = trim(bulk_prefix)//"/"//trim(local_cnf_fname)
  endif

  if ( execute_preprocess ) then
     call rm_prep( local_comm,            & ! [IN]
                   intercomm_parent_null, & ! [IN]
                   intercomm_child_null,  & ! [IN]
                   local_cnf_fname        ) ! [IN]
  endif

  if ( execute_model ) then
     call rm_driver( local_comm,       & ! [IN]
                     intercomm_parent, & ! [IN]
                     intercomm_child,  & ! [IN]
                     local_cnf_fname   ) ! [IN]
  endif

  ! stop MPI
  call prc_mpifinish

  if( universal_master ) write(*,*) '*** End   Launch System for SCALE-RM'

  stop
end program scalerm_pp