Line data Source code
1 : module parallel_mod
2 : ! ---------------------------
3 : use shr_kind_mod, only: r8=>shr_kind_r8
4 : ! ---------------------------
5 : use dimensions_mod, only : nmpi_per_node, nlev, qsize_d, ntrac_d
6 : ! ---------------------------
7 : use spmd_utils, only: MPI_STATUS_SIZE, MPI_MAX_ERROR_STRING, MPI_TAG_UB
8 :
9 : implicit none
10 : private
11 :
12 : integer, public, parameter :: ORDERED = 1
13 : integer, public, parameter :: FAST = 2
14 : integer, public, parameter :: BNDRY_TAG_BASE = 0
15 : integer, public, parameter :: THREAD_TAG_BITS = 9
16 : integer, public, parameter :: MAX_ACTIVE_MSG = (MPI_TAG_UB/2**THREAD_TAG_BITS) - 1
17 : integer, public, parameter :: HME_status_size = MPI_STATUS_SIZE
18 :
19 : integer, public, parameter :: HME_BNDRY_P2P = 1
20 : integer, public, parameter :: HME_BNDRY_MASHM = 2
21 : integer, public, parameter :: HME_BNDRY_A2A = 3
22 : integer, public, parameter :: HME_BNDRY_A2AO = 4
23 :
24 : integer, public, parameter :: nrepro_vars = MAX(10, nlev*qsize_d, nlev*ntrac_d)
25 :
26 : integer, public :: MaxNumberFrames
27 : integer, public :: numframes
28 : integer, public :: useframes
29 : logical, public :: PartitionForNodes
30 : logical, public :: PartitionForFrames
31 :
32 : ! Namelist-selectable type of boundary comms (AUTO,P2P,A2A,MASHM)
33 : integer, public :: boundaryCommMethod
34 :
35 : integer, public, allocatable :: status(:,:)
36 : integer, public, allocatable :: Rrequest(:)
37 : integer, public, allocatable :: Srequest(:)
38 :
39 : real(r8), public, allocatable :: FrameWeight(:)
40 : integer, public, allocatable :: FrameIndex(:)
41 : integer, public, allocatable :: FrameCount(:)
42 : integer, public :: nComPoints
43 : integer, public :: nPackPoints
44 :
45 : real(r8), public, allocatable :: global_shared_buf(:,:)
46 : real(r8), public :: global_shared_sum(nrepro_vars)
47 :
48 : ! ==================================================
49 : ! Define type parallel_t for distributed memory info
50 : ! ==================================================
51 : type, public :: parallel_t
52 : integer :: rank ! local rank
53 : integer :: root ! local root
54 : integer :: nprocs ! number of processes in group
55 : integer :: comm ! communicator
56 : integer :: intracomm ! Intra-node communicator
57 : integer :: commGraphFull ! distributed graph topo communicator for all neighbors
58 : integer :: commGraphInter ! distributed graph topo communicator for off-node neighbors
59 : integer :: commGraphIntra ! distributed graph topo communicator for on-node neighbors
60 : integer :: groupGraphFull
61 : logical :: masterproc
62 : end type
63 :
64 : type (parallel_t), public :: par ! info for distributed memory programming
65 :
66 : ! ===================================================
67 : ! Module Interfaces
68 : ! ===================================================
69 :
70 : public :: initmpi
71 : public :: syncmp
72 : public :: copy_par
73 :
74 : interface assignment ( = )
75 : module procedure copy_par
76 : end interface
77 :
78 : CONTAINS
79 :
80 : ! ================================================
81 : ! copy_par: copy constructor for parallel_t type
82 : !
83 : !
84 : ! Overload assignment operator for parallel_t
85 : ! ================================================
86 :
87 1113600 : subroutine copy_par(par2,par1)
88 : type(parallel_t), intent(out) :: par2
89 : type(parallel_t), intent(in) :: par1
90 :
91 1113600 : par2%rank = par1%rank
92 1113600 : par2%root = par1%root
93 1113600 : par2%nprocs = par1%nprocs
94 1113600 : par2%comm = par1%comm
95 1113600 : par2%intracomm = par1%intracomm
96 1113600 : par2%commGraphFull = par1%commGraphFull
97 1113600 : par2%commGraphInter = par1%commGraphInter
98 1113600 : par2%commGraphIntra = par1%commGraphIntra
99 1113600 : par2%groupGraphFull = par1%groupGraphFull
100 1113600 : par2%masterproc = par1%masterproc
101 :
102 1113600 : end subroutine copy_par
103 :
104 : ! ================================================
105 : ! initmpi:
106 : ! Initializes the parallel (message passing)
107 : ! environment, returns a parallel_t structure..
108 : ! ================================================
109 :
110 1536 : function initmpi(npes_homme) result(par)
111 : use cam_logfile, only: iulog
112 : use cam_abortutils, only: endrun
113 : use spmd_utils, only: mpicom, MPI_COMM_NULL, MPI_MAX_PROCESSOR_NAME
114 : use spmd_utils, only: MPI_CHARACTER, MPI_INTEGER, MPI_BAND, iam, npes
115 :
116 : integer, intent(in) :: npes_homme
117 :
118 : type(parallel_t) :: par
119 :
120 : integer :: ierr,tmp
121 : integer :: FrameNumber
122 : logical :: running ! state of MPI at beginning of initmpi call
123 : character(len=MPI_MAX_PROCESSOR_NAME) :: my_name
124 1536 : character(len=MPI_MAX_PROCESSOR_NAME), allocatable :: the_names(:)
125 :
126 : integer, allocatable :: tarray(:)
127 : integer :: namelen, i
128 : integer :: color
129 :
130 : !================================================
131 : ! Basic MPI initialization
132 : ! ================================================
133 :
134 1536 : call MPI_initialized(running, ierr)
135 :
136 1536 : if (.not.running) then
137 0 : call endrun('initmpi: MPI not initialized for SE dycore')
138 : end if
139 :
140 1536 : par%root = 0
141 1536 : par%masterproc = .FALSE.
142 1536 : nmpi_per_node = 2
143 1536 : PartitionForNodes = .TRUE.
144 :
145 : ! The SE dycore needs to split from CAM communicator for npes > par%nprocs
146 1536 : color = iam / npes_homme
147 1536 : call mpi_comm_split(mpicom, color, iam, par%comm, ierr)
148 1536 : if (iam < npes_homme) then
149 1536 : call MPI_comm_size(par%comm, par%nprocs, ierr)
150 1536 : call MPI_comm_rank(par%comm, par%rank, ierr)
151 1536 : if ( par%nprocs /= npes_homme) then
152 0 : call endrun('INITMPI: SE communicator count mismatch')
153 : end if
154 :
155 1536 : if(par%rank == par%root) then
156 2 : par%masterproc = .TRUE.
157 : end if
158 : else
159 0 : par%rank = 0
160 0 : par%nprocs = 0
161 0 : par%comm = MPI_COMM_NULL
162 : end if
163 :
164 1536 : if (par%masterproc) then
165 2 : write(iulog, '(a,i0)')'initmpi: Number of MPI processes: ', par%nprocs
166 : end if
167 :
168 1536 : if (iam < npes_homme) then
169 : ! ================================================
170 : ! Determine where this MPI process is running
171 : ! then use this information to determined the
172 : ! number of MPI processes per node
173 : ! ================================================
174 1536 : my_name(:) = ''
175 1536 : call MPI_Get_Processor_Name(my_name, namelen, ierr)
176 :
177 4608 : allocate(the_names(par%nprocs))
178 1181184 : do i = 1, par%nprocs
179 1181184 : the_names(i)(:) = ''
180 : end do
181 :
182 : ! ================================================
183 : ! Collect all the machine names
184 : ! ================================================
185 : call MPI_Allgather(my_name, MPI_MAX_PROCESSOR_NAME, MPI_CHARACTER, &
186 1536 : the_names,MPI_MAX_PROCESSOR_NAME,MPI_CHARACTER,par%comm,ierr)
187 :
188 : ! ======================================================================
189 : ! Calculate how many other MPI processes are on my node
190 : ! ======================================================================
191 1536 : nmpi_per_node = 0
192 1181184 : do i = 1, par%nprocs
193 1181184 : if(TRIM(ADJUSTL(my_name)) .eq. TRIM(ADJUSTL(the_names(i)))) then
194 196608 : nmpi_per_node = nmpi_per_node + 1
195 : end if
196 : end do
197 :
198 : ! =======================================================================
199 : ! Verify that everybody agrees on this number otherwise do not do
200 : ! the multi-level partitioning
201 : ! =======================================================================
202 1536 : call MPI_Allreduce(nmpi_per_node,tmp,1,MPI_INTEGER,MPI_BAND,par%comm,ierr)
203 1536 : if(tmp /= nmpi_per_node) then
204 0 : if (par%masterproc) then
205 0 : write(iulog,*)'initmpi: disagrement accross nodes for nmpi_per_node'
206 : end if
207 0 : nmpi_per_node = 1
208 0 : PartitionForNodes = .FALSE.
209 : else
210 1536 : PartitionForNodes = .TRUE.
211 : end if
212 :
213 1536 : if(PartitionForFrames .and. par%masterproc) then
214 0 : write(iulog,*)'initmpi: FrameWeight: ', FrameWeight
215 : end if
216 :
217 1536 : deallocate(the_names)
218 : end if
219 :
220 1536 : end function initmpi
221 :
222 : ! =====================================
223 : ! syncmp:
224 : !
225 : ! sychronize message passing domains
226 : !
227 : ! =====================================
228 3072 : subroutine syncmp(par)
229 : use cam_abortutils, only: endrun
230 : use spmd_utils, only: MPI_MAX_ERROR_STRING, MPI_ERROR
231 :
232 : type (parallel_t), intent(in) :: par
233 :
234 : integer :: errorcode, errorlen, ierr
235 : character(len=MPI_MAX_ERROR_STRING) :: errorstring
236 :
237 3072 : call MPI_barrier(par%comm, ierr)
238 :
239 3072 : if(ierr == MPI_ERROR) then
240 0 : errorcode = ierr
241 0 : call MPI_Error_String(errorcode, errorstring, errorlen, ierr)
242 0 : call endrun(errorstring)
243 : end if
244 3072 : end subroutine syncmp
245 :
246 0 : end module parallel_mod
|
