module RM PROCESS More...

Functions/Subroutines
subroutine, public	prc_setup
	Setup Processor topology. More...

Variables
integer, parameter, public	prc_w = 1
	[node direction] west More...

integer, parameter, public	prc_n = 2
	[node direction] north More...

integer, parameter, public	prc_e = 3
	[node direction] east More...

integer, parameter, public	prc_s = 4
	[node direction] south More...

integer, parameter, public	prc_nw = 5
	[node direction] northwest More...

integer, parameter, public	prc_ne = 6
	[node direction] northeast More...

integer, parameter, public	prc_sw = 7
	[node direction] southwest More...

integer, parameter, public	prc_se = 8
	[node direction] southeast More...

integer, public	prc_num_x = 1
	x length of 2D processor topology More...

integer, public	prc_num_y = 1
	y length of 2D processor topology More...

integer, dimension(:,:), allocatable, public	prc_2drank
	node index in 2D topology More...

integer, dimension(8), public	prc_next = -1
	node ID of 8 neighbour process More...

logical, public	prc_has_w

logical, public	prc_has_n

logical, public	prc_has_e

logical, public	prc_has_s

Detailed Description

module RM PROCESS

Description: MPI process management module for regional model

Author: Team SCALE

Function/Subroutine Documentation

◆ prc_setup()

subroutine, public scale_rm_process::prc_setup ( )

Setup Processor topology.

Definition at line 67 of file scale_rm_process.F90.

Referenced by mod_rm_driver::scalerm(), and mod_rm_prep::scalerm_prep().

     use scale_process, only: &
        prc_mpistop,              &
        prc_masterrank,           &
        prc_mpi_alive,            &
        prc_abort_comm_world,     &
        prc_universal_comm_world, &
        prc_universal_nprocs,     &
        prc_universal_myrank,     &
        prc_universal_ismaster,   &
        prc_global_comm_world,    &
        prc_global_nprocs,        &
        prc_global_myrank,        &
        prc_global_ismaster,      &
        prc_local_comm_world,     &
        prc_nprocs,               &
        prc_myrank,               &
        prc_ismaster
     implicit none
 
     logical :: prc_periodic_x   = .true.  
     logical :: prc_periodic_y   = .true.  
     logical :: prc_cart_reorder = .false. 
 
     namelist / param_prc / &
        prc_num_x,      &
        prc_num_y,      &
        prc_periodic_x, &
        prc_periodic_y, &
        prc_cart_reorder
 
     logical :: period(2)
     integer :: divide(2)
     integer :: coords_w(2)
     integer :: coords_n(2)
     integer :: coords_e(2)
     integer :: coords_s(2)
     integer :: next_coords(2)
     integer :: iptbl
     integer :: next(8)
 
     integer :: ierr
     integer :: p
     !---------------------------------------------------------------------------
 
     if( io_l ) write(io_fid_log,*)
     if( io_l ) write(io_fid_log,*) '++++++ Module[PROCESS] / Categ[ATMOS-RM COMM] / Origin[SCALElib]'
 
     if ( io_l ) then
        write(io_fid_log,*)            ''
        write(io_fid_log,*)            '++++++ Start MPI'
        write(io_fid_log,'(1x,A,I12)') '*** UNIVERSAL_COMM_WORLD        : ', prc_universal_comm_world
        write(io_fid_log,'(1x,A,I12)') '*** total process [UNIVERSAL]   : ', prc_universal_nprocs
        write(io_fid_log,'(1x,A,I12)') '*** my process ID [UNIVERSAL]   : ', prc_universal_myrank
        write(io_fid_log,'(1x,A,L12)') '*** master rank?  [UNIVERSAL]   : ', prc_universal_ismaster
        write(io_fid_log,'(1x,A,I12)') '*** GLOBAL_COMM_WORLD           : ', prc_global_comm_world
        write(io_fid_log,'(1x,A,I12)') '*** total process [GLOBAL]      : ', prc_global_nprocs
        write(io_fid_log,'(1x,A,I12)') '*** my process ID [GLOBAL]      : ', prc_global_myrank
        write(io_fid_log,'(1x,A,L12)') '*** master rank?  [GLOBAL]      : ', prc_global_ismaster
        write(io_fid_log,'(1x,A,I12)') '*** LOCAL_COMM_WORLD            : ', prc_local_comm_world
        write(io_fid_log,'(1x,A,I12)') '*** total process [LOCAL]       : ', prc_nprocs
        write(io_fid_log,'(1x,A,I12)') '*** my process ID [LOCAL]       : ', prc_myrank
        write(io_fid_log,'(1x,A,L12)') '*** master rank?  [LOCAL]       : ', prc_ismaster
        write(io_fid_log,'(1x,A,I12)') '*** ABORT_COMM_WORLD            : ', prc_abort_comm_world
        write(io_fid_log,'(1x,A,I12)') '*** master rank ID [each world] : ', prc_masterrank
     endif
 
     !--- read namelist
     rewind(io_fid_conf)
     read(io_fid_conf,nml=param_prc,iostat=ierr)
     if( ierr < 0 ) then !--- missing
        if( io_l ) write(io_fid_log,*) '*** Not found namelist. Default used.'
     elseif( ierr > 0 ) then !--- fatal error
        write(*,*) 'xxx Not appropriate names in namelist PARAM_PRC. Check!'
        call prc_mpistop
     endif
     if( io_lnml ) write(io_fid_log,nml=param_prc)
 
     if( io_l ) write(io_fid_log,*)
     if( io_l ) write(io_fid_log,*) '*** Process Allocation ***'
     if( io_l ) write(io_fid_log,*) '*** No. of Node   :', prc_num_x," x ",prc_num_y
 
     if ( prc_num_x*prc_num_y /= prc_nprocs ) then
        write(*,*) 'xxx total number of node does not match that requested. Check!'
        call prc_mpistop
     endif
 
     if ( mod(prc_nprocs,prc_num_x) /= 0 ) then
        write(*,*) 'xxx number of requested node cannot devide to 2D. Check!'
        call prc_mpistop
     endif
 
     ! set communication topology
     allocate( prc_2drank(-1:prc_nprocs-1,2) )
     prc_2drank(:,:) = -1
 
     do p = 0, prc_nprocs-1
        prc_2drank(p,1) = mod(p,prc_num_x)
        prc_2drank(p,2) = (p-prc_2drank(p,1)) / prc_num_x
     enddo
 
     divide(1) = prc_num_y
     divide(2) = prc_num_x
     period(1) = prc_periodic_y
     period(2) = prc_periodic_x
     if ( prc_mpi_alive ) then
        call mpi_cart_create(prc_local_comm_world,2,divide,period,prc_cart_reorder,iptbl,ierr)
        call mpi_cart_shift(iptbl,0,1,prc_next(prc_s),prc_next(prc_n),ierr) ! next rank search Down/Up
        call mpi_cart_shift(iptbl,1,1,prc_next(prc_w),prc_next(prc_e),ierr) ! next rank search Left/Right
 
        ! get neighbor_coordinates
        prc_has_w = prc_next(prc_w) /= mpi_proc_null
        if( prc_has_w ) call mpi_cart_coords(iptbl,prc_next(prc_w),2,coords_w,ierr)
        prc_has_n = prc_next(prc_n) /= mpi_proc_null
        if( prc_has_n ) call mpi_cart_coords(iptbl,prc_next(prc_n),2,coords_n,ierr)
        prc_has_e = prc_next(prc_e) /= mpi_proc_null
        if( prc_has_e ) call mpi_cart_coords(iptbl,prc_next(prc_e),2,coords_e,ierr)
        prc_has_s = prc_next(prc_s) /= mpi_proc_null
        if( prc_has_s ) call mpi_cart_coords(iptbl,prc_next(prc_s),2,coords_s,ierr)
        ! next rank search NorthWest
        if (      .NOT. prc_has_n &
             .OR. .NOT. prc_has_w ) then
           prc_next(prc_nw) = mpi_proc_null
        else
           next_coords(1) = coords_n(1)
           next_coords(2) = coords_w(2)
           call mpi_cart_rank(iptbl, next_coords, prc_next(prc_nw), ierr)
        endif
        ! next rank search NorthEast
        if (      .NOT. prc_has_n &
             .OR. .NOT. prc_has_e ) then
           prc_next(prc_ne) = mpi_proc_null
        else
           next_coords(1) = coords_n(1)
           next_coords(2) = coords_e(2)
           call mpi_cart_rank(iptbl, next_coords, prc_next(prc_ne), ierr)
        endif
        ! next rank search SouthWest
        if (      .NOT. prc_has_s &
             .OR. .NOT. prc_has_w ) then
           prc_next(prc_sw) = mpi_proc_null
        else
           next_coords(1) = coords_s(1)
           next_coords(2) = coords_w(2)
           call mpi_cart_rank(iptbl, next_coords, prc_next(prc_sw), ierr)
        endif
        ! next rank search SouthEast
        if (      .NOT. prc_has_s &
             .OR. .NOT. prc_has_e ) then
           prc_next(prc_se) = mpi_proc_null
        else
           next_coords(1) = coords_s(1)
           next_coords(2) = coords_e(2)
           call mpi_cart_rank(iptbl, next_coords, prc_next(prc_se), ierr)
        endif
        call mpi_comm_free(iptbl,ierr)
     endif
 
     next(:) = max(prc_next(:),-1) ! avoid if MPI_PROC_NULL < -1
 
     if( io_l ) write(io_fid_log,*) '*** Node topology :'
     if( io_l ) write(io_fid_log,'(1x,A,I5,A,I5,A,I5,A,A,I5,A,I5,A,I5,A,A,I5,A,I5,A,I5,A)') &
     '***  NW(',next(prc_nw),',',prc_2drank(next(prc_nw),1),',',prc_2drank(next(prc_nw),2),')', &
       ' -  N(',next(prc_n) ,',',prc_2drank(next(prc_n) ,1),',',prc_2drank(next(prc_n) ,2),')', &
       ' - NE(',next(prc_ne),',',prc_2drank(next(prc_ne),1),',',prc_2drank(next(prc_ne),2),')'
     if( io_l ) write(io_fid_log,'(1x,A)') '***                                  |'
     if( io_l ) write(io_fid_log,'(1x,A,I5,A,I5,A,I5,A,A,I5,A,I5,A,I5,A,A,I5,A,I5,A,I5,A)') &
     '***   W(',next(prc_w),',',prc_2drank(next(prc_w),1),',',prc_2drank(next(prc_w),2),')', &
       ' -  P(',prc_myrank ,',',prc_2drank(prc_myrank, 1),',',prc_2drank(prc_myrank, 2),')', &
       ' -  E(',next(prc_e),',',prc_2drank(next(prc_e),1),',',prc_2drank(next(prc_e),2),')'
     if( io_l ) write(io_fid_log,'(1x,A)') '***                                  |'
     if( io_l ) write(io_fid_log,'(1x,A,I5,A,I5,A,I5,A,A,I5,A,I5,A,I5,A,A,I5,A,I5,A,I5,A)') &
     '***  SW(',next(prc_sw),',',prc_2drank(next(prc_sw),1),',',prc_2drank(next(prc_sw),2),')', &
       ' -  S(',next(prc_s) ,',',prc_2drank(next(prc_s) ,1),',',prc_2drank(next(prc_s) ,2),')', &
       ' - SE(',next(prc_se),',',prc_2drank(next(prc_se),1),',',prc_2drank(next(prc_se),2),')'
 
     return