Branch data Line data Source code
1 : : !!****m* ABINIT/m_mpi_scheduler
2 : : !! NAME
3 : : !! m_mpi_scheduler
4 : : !!
5 : : !! FUNCTION
6 : : !! This module contains the mpi scheduler for spin dynamics
7 : : !! It provide the function to assign site to mpi nodes, and methods for scattering (TODO),
8 : : !! and gathering data from nodes.
9 : : !!
10 : : !! Datatypes:
11 : : !!
12 : : !! * mpi_scheduler_t
13 : : !!
14 : : !! Subroutines:
15 : : !! TODO: add this when F2003 doc style is determined.
16 : : !!
17 : : !!
18 : : !! COPYRIGHT
19 : : !! Copyright (C) 2001-2026 ABINIT group (hexu)
20 : : !! This file is distributed under the terms of the
21 : : !! GNU General Public License, see ~abinit/COPYING
22 : : !! or http://www.gnu.org/copyleft/gpl.txt .
23 : : !! For the initials of contributors, see ~abinit/doc/developers/contributors.txt .
24 : : !!
25 : : !! SOURCE
26 : :
27 : : #if defined HAVE_CONFIG_H
28 : : #include "config.h"
29 : : #endif
30 : : #include "abi_common.h"
31 : :
32 : :
33 : : module m_mpi_scheduler
34 : : use defs_basis
35 : : use m_xmpi
36 : : use m_errors
37 : : use m_abicore
38 : :
39 : : implicit none
40 : : !!***
41 : :
42 : :
43 : : private
44 : :
45 : : type, public :: mb_mpi_info_t
46 : : integer :: master =0
47 : : logical :: iam_master =.False.
48 : : integer :: my_rank, comm, nproc, ierr
49 : : contains
50 : : procedure :: initialize => mb_mpi_info_t_initialize
51 : : end type mb_mpi_info_t
52 : :
53 : : type, public :: mpi_scheduler_t
54 : : integer :: nproc, ntasks, irank,master, comm, istart, iend, ntask, nblock
55 : : ! ntasks: total number of tasks
56 : : ! istart: first task id in this proc
57 : : ! iend: last task id in this proc
58 : : ! ntask: number of tasks in this proc
59 : : ! nblock: sometimes it is useful to group task into blocks(eg. each spin has 3 components and its better to put them together.)
60 : : integer, allocatable :: istart_list(:), iend_list(:), ntask_list(:)
61 : : ! istart_list: istart for all nodes
62 : : ! iend_list: iend for all nodes
63 : : ! ntask_list: ntast for all nodes
64 : : contains
65 : : procedure :: initialize => mpi_scheduler_t_initialize
66 : : procedure :: finalize => mpi_scheduler_t_finalize
67 : : procedure :: get_iproc => mpi_scheduler_t_get_iproc
68 : : procedure :: get_istart
69 : : procedure :: get_iend
70 : : procedure :: get_ntask
71 : : procedure :: gatherv_dp1d ! helper function to gather 1d real(dp) array from nodes.
72 : : procedure :: gatherv_dp2d ! helper function to gather 2d real(dp) array from nodes.
73 : : procedure :: allgatherv_dp1d ! helper function to gather 1d real(dp) array from nodes.
74 : : procedure :: allgatherv_dp2d ! helper function to gather 2d real(dp) array from nodes.
75 : : ! procedure :: allgatherv_dp2d_inplace ! helper function to gather 2d real(dp) array from nodes.
76 : : ! disabled because an openmpi I tried does not support this.
77 : :
78 : : end type mpi_scheduler_t
79 : :
80 : : public :: init_mpi_info
81 : :
82 : : contains
83 : : ! logical :: iam_master
84 : : ! iam_master=xmpi_comm_rank(xmpi_world)==0
85 : :
86 : : !integer :: master, my_rank, comm, nproc, ierr
87 : : !logical :: iam_master
88 : : !call init_mpi_info(master, iam_master, my_rank, comm, nproc)
89 : 1149777 : subroutine init_mpi_info(master, iam_master, my_rank, comm, nproc)
90 : : integer, intent(inout) :: master
91 : : logical, intent(inout) :: iam_master
92 : : integer, intent(inout) :: my_rank, comm, nproc
93 : 1149777 : master=0
94 : 1149777 : comm = xmpi_world
95 : 1149777 : nproc = xmpi_comm_size(comm)
96 : 1149777 : my_rank = xmpi_comm_rank(comm)
97 : 1149777 : iam_master = (my_rank == master)
98 : 1149777 : end subroutine init_mpi_info
99 : :
100 : :
101 : : !----------------------------------------------------------------------
102 : : !> @brief initialize mpi info type
103 : : !----------------------------------------------------------------------
104 : 0 : subroutine mb_mpi_info_t_initialize(self)
105 : : class (mb_mpi_info_t):: self
106 : 0 : self%master = 0
107 : 0 : self%comm = xmpi_world
108 : 0 : self%nproc = xmpi_comm_size(self%comm)
109 : 0 : self%my_rank = xmpi_comm_rank(self%comm)
110 : 0 : self%iam_master = (self%my_rank == self%master)
111 : 0 : end subroutine mb_mpi_info_t_initialize
112 : :
113 : :
114 : : !----------------------------------------------------------------------
115 : : !> @brief assign ntasks to ranks in mpi comm.
116 : : !> @param[in] ntasks: number of tasks to be done. e.g. number of spins to be moved.
117 : : !> @param[in] master: the id of master node
118 : : !> @param[in] comm: the communicator
119 : : !> @param[in] nblock: the task should be divided so that nblock are together.
120 : : !> e.g. for 3*nspin tasks, nblock=3 will assure that the 3 direction of one
121 : : !> spin is together.
122 : : !----------------------------------------------------------------------
123 : :
124 : 30 : subroutine mpi_scheduler_t_initialize(self, ntasks, master, comm, nblock)
125 : : !
126 : : ! ntask: number of tasks
127 : : ! nblock: number of subtask per task. TODO: should improve the naming.
128 : : class(mpi_scheduler_t), intent(inout) :: self
129 : : integer, intent(in) :: ntasks
130 : : integer, intent(in) :: master, comm
131 : : integer, optional, intent(in):: nblock
132 : : integer :: i,nmore, n, ierr
133 : :
134 [ + + ]: 10 : if( present(nblock)) then
135 : 2 : self%nblock=nblock
136 : : else
137 : 8 : self%nblock=1
138 : : end if
139 : 10 : call xmpi_bcast(self%nblock, master, comm, ierr)
140 : :
141 : 10 : self%master=master
142 : : !call MPI_COMM_SIZE(comm, self%nproc, ierr)
143 : 10 : self%nproc = xmpi_comm_size(comm)
144 : : !call MPI_COMM_RANK(comm, self%iproc, ierr)
145 : 10 : self%irank=xmpi_comm_rank(comm)
146 : 10 : self%comm=comm
147 : 10 : self%ntasks = ntasks
148 : 10 : call xmpi_bcast(self%ntasks, self%master, comm, ierr )
149 [ + - ]: 10 : if (.not. allocated(self%istart_list)) then
150 [ - + + - : 30 : ABI_MALLOC(self%istart_list, (self%nproc))
+ - + - -
+ - + -
+ ]
151 : : end if
152 : :
153 [ + - ]: 10 : if (.not. allocated(self%iend_list)) then
154 [ - + + - : 30 : ABI_MALLOC(self%iend_list, (self%nproc) )
+ - + - -
+ - + -
+ ]
155 : : end if
156 : :
157 [ + - ]: 10 : if (.not. allocated(self%ntask_list)) then
158 [ - + + - : 30 : ABI_MALLOC(self%ntask_list, (self%nproc))
+ - + - -
+ - + -
+ ]
159 : : endif
160 : :
161 : : ! number of procs which has one more
162 : 10 : nmore=mod(self%ntasks, self%nproc)
163 : :
164 [ + - ]: 10 : if(nmore==0) then
165 : 10 : n=(self%ntasks-nmore)/self%nproc
166 [ + + ]: 20 : do i = 1, self%nproc
167 : 10 : self%istart_list(i)= 1+(i-1)*n
168 : 10 : self%iend_list(i)=i*n
169 : 20 : self%ntask_list(i)=n
170 : : end do
171 : : else
172 : 0 : n=(self%ntasks-nmore)/self%nproc
173 [ # # ]: 0 : do i = 1, nmore
174 : 0 : self%ntask_list(i)=n+1
175 : 0 : self%istart_list(i)= 1+(i-1) *(n+1)
176 : 0 : self%iend_list(i)=self%istart_list(i)+self%ntask_list(i)-1
177 : : end do
178 : :
179 [ # # ]: 0 : do i = nmore+1, self%nproc
180 : 0 : self%ntask_list(i)=n
181 : 0 : self%istart_list(i)= self%iend_list(i-1)+1
182 : 0 : self%iend_list(i)=self%istart_list(i)+self%ntask_list(i)-1
183 : : end do
184 : : end if
185 : :
186 [ + + ]: 20 : do i=1, self%nproc
187 : 10 : self%ntask_list(i)=self%ntask_list(i) * self%nblock
188 : 10 : self%istart_list(i) = (self%istart_list(i)-1) *self%nblock + 1
189 : 20 : self%iend_list(i) = self%iend_list(i)*self%nblock
190 : : end do
191 : :
192 : 10 : self%istart=self%istart_list(self%irank + 1)
193 : 10 : self%iend=self%iend_list(self%irank + 1)
194 : 10 : self%ntask=self%ntask_list(self%irank + 1)
195 : :
196 : 10 : end subroutine mpi_scheduler_t_initialize
197 : :
198 : :
199 : :
200 : : !----------------------------------------------------------------------
201 : : !> @brief find the proc id of which the index of task belong to
202 : : !>
203 : : !> @param[in] i: the index of task
204 : : !> @param[out] iproc: the id of process which is in charge of the task
205 : : !----------------------------------------------------------------------
206 : 0 : function mpi_scheduler_t_get_iproc(self, i) result(iproc)
207 : : class(mpi_scheduler_t), intent(in) :: self
208 : : integer, intent(in) :: i
209 : : integer :: iproc
210 : 0 : iproc=i/(self%ntasks/self%nproc)
211 : 0 : end function mpi_scheduler_t_get_iproc
212 : :
213 : : !----------------------------------------------------------------------
214 : : !> @brief get the start of the id of work for the rank
215 : : !>
216 : : !> @param[in] rank: the id of the rank
217 : : !> @param[out] i: the starting id of work
218 : : !----------------------------------------------------------------------
219 : 0 : function get_istart(self, rank) result(i)
220 : : class(mpi_scheduler_t), intent(in) :: self
221 : : integer, optional, intent(in):: rank
222 : : integer :: i, r
223 [ # # ]: 0 : if (present(rank)) then
224 : 0 : r=rank
225 : : else
226 : 0 : r=self%irank
227 : : end if
228 : 0 : i=self%istart_list(r+1)
229 : 0 : end function get_istart
230 : :
231 : : !----------------------------------------------------------------------
232 : : !> @brief get the end of the id of work for the rank
233 : : !>
234 : : !> @param[in] rank: the id of the rank
235 : : !> @param[out] i: the end id of work
236 : : !----------------------------------------------------------------------
237 : 0 : function get_iend(self, rank) result(i)
238 : : class(mpi_scheduler_t), intent(in) :: self
239 : : integer, optional, intent(in):: rank
240 : : integer :: i, r
241 [ # # ]: 0 : if (present(rank)) then
242 : 0 : r=rank
243 : : else
244 : 0 : r=self%irank
245 : : end if
246 : 0 : i=self%iend_list(r+1)
247 : 0 : end function get_iend
248 : :
249 : : !----------------------------------------------------------------------
250 : : !> @brief get the number of work for the rank
251 : : !>
252 : : !> @param[in] rank: the id of the rank
253 : : !> @param[out] i: the number of works assigned to this rank
254 : : !----------------------------------------------------------------------
255 : 0 : function get_ntask(self, rank) result(i)
256 : : class(mpi_scheduler_t), intent(in) :: self
257 : : integer, optional, intent(in):: rank
258 : : integer :: i, r
259 [ # # ]: 0 : if (present(rank)) then
260 : 0 : r=rank
261 : : else
262 : 0 : r=self%irank
263 : : end if
264 : 0 : i=self%ntask_list(r+1)
265 : 0 : end function get_ntask
266 : :
267 : : !----------------------------------------------------------------------
268 : : !> @brief helper function to gather real(dp) 1D array to master node
269 : : !>
270 : : !> @param[in] data: the data array to be gathered
271 : : !> @param[out] buffer: a buffer to be used for the gathering.
272 : : !----------------------------------------------------------------------
273 : 0 : subroutine gatherv_dp1d(self, data, buffer)
274 : : class(mpi_scheduler_t), intent(inout) :: self
275 : : real(dp), intent(inout) :: data(self%ntasks)
276 : : real(dp), intent(inout) :: buffer(self%ntasks)
277 : : integer :: ierr
278 : : call xmpi_gatherv(data(self%istart: self%iend), &
279 : : & self%ntask, &
280 : : & buffer,&
281 : : & self%ntask_list, &
282 : : & self%istart_list-1, &
283 [ # # # # ]: 0 : & self%master, self%comm, ierr )
284 [ # # ]: 0 : data(:)=buffer(:)
285 : 0 : end subroutine gatherv_dp1d
286 : :
287 : : !----------------------------------------------------------------------
288 : : !> @brief helper function to gather real(dp) 2D array to master node
289 : : !>
290 : : !> @param[in] data: the data array to be gathered
291 : : !> @param[out] buffer: a buffer to be used for the gathering.
292 : : !----------------------------------------------------------------------
293 : 0 : subroutine gatherv_dp2d(self, data, nrow, buffer)
294 : : class(mpi_scheduler_t), intent(inout) :: self
295 : : integer, intent(in) :: nrow
296 : : real(dp), intent(inout) :: data(nrow,self%ntasks), buffer(nrow, self%ntasks)
297 : : integer :: ierr
298 : : call xmpi_gatherv(data(:,self%istart:self%iend), &
299 : : & self%ntask*nrow, &
300 : : & buffer, &
301 : : & self%ntask_list*nrow, &
302 : : & (self%istart_list-1)*nrow, &
303 [ # # # # : 0 : & self%master, self%comm, ierr)
# # # # ]
304 [ # # # # ]: 0 : data(:,:)=buffer(:,:)
305 : 0 : end subroutine gatherv_dp2d
306 : :
307 : : !----------------------------------------------------------------------
308 : : !> @brief helper function to gather real(dp) 1D array to master node
309 : : !> and bcast to every node
310 : : !> @param[in] data: the data array to be gathered
311 : : !> @param[out] buffer: a buffer to be used for the gathering.
312 : : !----------------------------------------------------------------------
313 : 0 : subroutine allgatherv_dp1d(self, data, buffer)
314 : : class(mpi_scheduler_t), intent(inout) :: self
315 : : real(dp), intent(inout) :: data(self%ntasks)
316 : : real(dp), intent(inout) :: buffer(self%ntasks)
317 : : integer :: ierr
318 : : call xmpi_allgatherv(data(self%istart: self%iend), &
319 : : & self%ntask, &
320 : : & buffer,&
321 : : & self%ntask_list, &
322 : : & self%istart_list-1, &
323 [ # # # # ]: 0 : & self%comm, ierr )
324 [ # # ]: 0 : data(:)=buffer(:)
325 : 0 : end subroutine allgatherv_dp1d
326 : :
327 : :
328 : : !----------------------------------------------------------------------
329 : : !> @brief helper function to gather real(dp) 2D array to master node
330 : : !> and bcast to every node
331 : : !> @param[in] data: the data array to be gathered
332 : : !> @param[out] buffer: a buffer to be used for the gathering.
333 : : !----------------------------------------------------------------------
334 : 4004 : subroutine allgatherv_dp2d(self, data, nrow, buffer)
335 : : class(mpi_scheduler_t), intent(inout) :: self
336 : : integer, intent(in) :: nrow
337 : : real(dp), intent(inout) :: data(nrow,self%ntasks), buffer(nrow, self%ntasks)
338 : : integer :: ierr
339 : :
340 : : !xmpi_allgatherv_int2d(xval,nelem,recvbuf,recvcounts,displs,spaceComm,ier)
341 : : call xmpi_allgatherv(data(:,self%istart:self%iend), &
342 : : & self%ntask*nrow, &
343 : : & buffer, &
344 : : & self%ntask_list*nrow, &
345 : : & (self%istart_list-1)*nrow, &
346 [ + - + + : 12012 : & self%comm, ierr)
+ - + + ]
347 [ + + + + ]: 3463460 : data(:,:)=buffer(:,:)
348 : 4004 : end subroutine allgatherv_dp2d
349 : :
350 : :
351 : : ! subroutine allgatherv_dp2d_inplace(self, data, nrow)
352 : : ! class(mpi_scheduler_t), intent(inout) :: self
353 : : ! integer, intent(in) :: nrow
354 : : ! real(dp), intent(inout) :: data(nrow,self%ntasks)
355 : : ! integer :: ierr
356 : : !
357 : : ! !xmpi_allgatherv_int2d(xval,nelem,recvbuf,recvcounts,displs,spaceComm,ier)
358 : : ! call xmpi_allgatherv(xmpi_in_place, &
359 : : ! & self%ntask*nrow, &
360 : : ! & data, &
361 : : ! & self%ntask_list*nrow, &
362 : : ! & (self%istart_list-1)*nrow, &
363 : : ! & self%comm, ierr)
364 : : ! end subroutine allgatherv_dp2d_inplace
365 : :
366 : : !----------------------------------------------------------------------
367 : : !> @brief free memory used
368 : : !----------------------------------------------------------------------
369 : 11 : subroutine mpi_scheduler_t_finalize(self)
370 : : class(mpi_scheduler_t), intent(inout) :: self
371 [ + + ]: 11 : if (allocated(self%istart_list)) then
372 : 10 : ABI_FREE(self%istart_list)
373 : : endif
374 [ + + ]: 11 : if (allocated(self%iend_list)) then
375 : 10 : ABI_FREE(self%iend_list)
376 : : endif
377 [ + + ]: 11 : if (allocated(self%ntask_list)) then
378 : 10 : ABI_FREE(self%ntask_list)
379 : : endif
380 : 11 : end subroutine mpi_scheduler_t_finalize
381 : :
382 : :
383 [ # # # # : 0 : end module m_mpi_scheduler
# # # # #
# # # # #
# # # # ]
|
