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_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_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
  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=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_myrank, & ! [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_bulk( universal_comm, & ! [IN]
                          num_bulkjob,    & ! [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]
                          intercomm_parent, & ! [OUT]
                          intercomm_child   ) ! [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 )
 
  call io_set_universalrank( universal_myrank, & ! [IN]
                             id_bulkjob,       & ! [IN]
                             id_domain         ) ! [IN]
 
  !--- start main routine
 
  if ( num_bulkjob > 1 ) then
     write(local_cnf_fname,'(I4.4,2A)') id_bulkjob, "/", trim(conf_files(id_domain))
  else
     local_cnf_fname = trim(conf_files(id_domain))
  endif
 
  if ( execute_preprocess ) then
     call rm_prep( local_comm,     & ! [IN]
                   prc_comm_null,  & ! [IN]
                   prc_comm_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