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
|
