Line data Source code
1 : !--------------------------------------------------------------------------------
2 : ! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
3 : ! This file is part of FLEUR and available as free software under the conditions
4 : ! of the MIT license as expressed in the LICENSE file in more detail.
5 : !--------------------------------------------------------------------------------
6 : MODULE m_types_mpi
7 : TYPE t_mpi
8 : !k-point parallelism
9 : INTEGER :: mpi_comm !< replaces MPI_COMM_WORLD
10 : INTEGER :: irank !< rank of task in mpi_comm
11 : INTEGER :: isize !< no of tasks in mpi_comm
12 : INTEGER, ALLOCATABLE :: k_list(:)
13 : INTEGER, ALLOCATABLE :: coulomb_owner(:)
14 : !Eigenvalue parallelism
15 : INTEGER :: sub_comm !< Sub-Communicator for eigenvalue parallelization (all PE working on same k-point)
16 : INTEGER :: n_rank !< rank in sub_comm
17 : INTEGER :: n_size !< PE per kpoint, i.e. "isize" for eigenvalue parallelization
18 : INTEGER, ALLOCATABLE :: ev_list(:)
19 : !Communicator for PE on same node
20 : INTEGER :: mpi_comm_same_node
21 : logical :: l_set_root_comm = .false. ! only create root comm once
22 : logical :: l_mpi_multithreaded = .false.
23 : integer :: root_comm ! communicator between all n_rank = 0
24 : !Communicator for diagonalization
25 : INTEGER :: diag_sub_comm
26 : LOGICAL :: pe_diag=.true.
27 : !If the k-point loop is not balanced this is needed
28 : INTEGER :: max_length_k_list
29 :
30 : CONTAINS
31 : procedure :: set_errhandler => t_mpi_set_errhandler
32 : procedure :: is_root => mpi_is_root
33 : procedure :: set_root_comm => t_mpi_set_root_comm
34 : END TYPE t_mpi
35 :
36 : INTERFACE juDFT_win_create
37 : MODULE PROCEDURE juDFT_win_create_real, juDFT_win_create_cmplx, juDFT_win_create_int, &
38 : juDFT_win_create_real_3D, juDFT_win_create_cmplx_3D
39 : END INTERFACE juDFT_win_create
40 :
41 : PRIVATE
42 : PUBLIC :: juDFT_win_create, judft_comm_split, judft_comm_split_type, t_mpi, calcIndexBounds
43 : contains
44 12 : subroutine t_mpi_set_root_comm(fmpi)
45 : implicit none
46 : class(t_mpi), intent(inout) :: fmpi
47 :
48 12 : if(.not. fmpi%l_set_root_comm ) then
49 6 : call judft_comm_split(fmpi%mpi_comm, fmpi%n_rank, 0, fmpi%root_comm)
50 6 : fmpi%l_set_root_comm = .True.
51 : endif
52 12 : end subroutine t_mpi_set_root_comm
53 :
54 54 : function mpi_is_root(mpi) result(is_root)
55 : implicit none
56 : class(t_mpi), intent(in) :: mpi
57 : logical :: is_root
58 54 : is_root = mpi%irank == 0
59 54 : end function mpi_is_root
60 :
61 672 : subroutine juDFT_win_create_real(base, size, disp_unit, info, comm, win)
62 : use m_judft
63 : #ifdef CPP_MPI
64 : use mpi
65 : #endif
66 : implicit none
67 : real, POINTER, ASYNCHRONOUS, intent(inout) :: base(:)
68 : integer, intent(in) :: disp_unit, info, comm
69 : integer, intent(inout) :: win
70 :
71 : #ifdef CPP_MPI
72 : INTEGER(KIND=MPI_ADDRESS_KIND) :: SIZE
73 : integer :: err, err_handler
74 :
75 224 : call timestart("MPI_WIN_CREATE")
76 224 : CALL MPI_WIN_CREATE(base, size, disp_unit, info, comm, win, err)
77 224 : if(err /= 0) call judft_error("Can't create MPI_Win for real_data_ptr")
78 224 : call timestop("MPI_WIN_CREATE")
79 :
80 224 : call timestart("MPI_Win_create_errhandler")
81 224 : call MPI_Win_create_errhandler(judft_mpi_error_handler, err_handler, err)
82 224 : if(err /= 0) call judft_error("Can't create Error handler")
83 224 : call timestop("MPI_Win_create_errhandler")
84 :
85 224 : call timestart("MPI_WIN_SET_ERRHANDLER")
86 224 : CALL MPI_WIN_SET_ERRHANDLER(win, err_handler, err)
87 224 : if(err /= 0) call judft_error("Can't assign Error handler to Win")
88 224 : call timestop("MPI_WIN_SET_ERRHANDLER")
89 : #else
90 : INTEGER :: SIZE
91 : #endif
92 224 : end subroutine juDFT_win_create_real
93 :
94 0 : subroutine juDFT_win_create_real_3D(base, size, disp_unit, info, comm, win)
95 : use m_judft
96 : #ifdef CPP_MPI
97 : use mpi
98 : #endif
99 : implicit none
100 : real, POINTER, ASYNCHRONOUS, intent(inout) :: base(:,:,:)
101 : integer, intent(in) :: disp_unit, info, comm
102 : integer, intent(inout) :: win
103 :
104 : #ifdef CPP_MPI
105 : INTEGER(KIND=MPI_ADDRESS_KIND) :: SIZE
106 : integer :: err, err_handler
107 :
108 0 : call timestart("MPI_WIN_CREATE")
109 0 : CALL MPI_WIN_CREATE(base, size, disp_unit, info, comm, win, err)
110 0 : if(err /= 0) call judft_error("Can't create MPI_Win for real_data_ptr")
111 0 : call timestop("MPI_WIN_CREATE")
112 :
113 0 : call timestart("MPI_Win_create_errhandler")
114 0 : call MPI_Win_create_errhandler(judft_mpi_error_handler, err_handler, err)
115 0 : if(err /= 0) call judft_error("Can't create Error handler")
116 0 : call timestop("MPI_Win_create_errhandler")
117 :
118 0 : call timestart("MPI_WIN_SET_ERRHANDLER")
119 0 : CALL MPI_WIN_SET_ERRHANDLER(win, err_handler, err)
120 0 : if(err /= 0) call judft_error("Can't assign Error handler to Win")
121 0 : call timestop("MPI_WIN_SET_ERRHANDLER")
122 : #else
123 : INTEGER :: SIZE
124 : #endif
125 0 : end subroutine juDFT_win_create_real_3D
126 :
127 270 : subroutine juDFT_win_create_cmplx(base, size, disp_unit, info, comm, win)
128 : use m_judft
129 : #ifdef CPP_MPI
130 : use mpi
131 : #endif
132 : implicit none
133 : complex, POINTER, ASYNCHRONOUS, intent(inout):: base(:)
134 : integer, intent(in) :: disp_unit, info, comm
135 : integer, intent(inout) :: win
136 :
137 : #ifdef CPP_MPI
138 : INTEGER(KIND=MPI_ADDRESS_KIND) :: SIZE
139 : integer :: err, err_handler
140 :
141 90 : CALL MPI_WIN_CREATE(base, size, disp_unit, info, comm, win, err)
142 90 : if(err /= 0) call judft_error("Can't create MPI_Win for cmplx_data_ptr")
143 :
144 90 : call MPI_Win_create_errhandler(judft_mpi_error_handler, err_handler, err)
145 90 : if(err /= 0) call judft_error("Can't create Error handler")
146 :
147 90 : CALL MPI_WIN_SET_ERRHANDLER(win, err_handler, err)
148 90 : if(err /= 0) call judft_error("Can't assign Error handler to Win")
149 : #else
150 : INTEGER :: SIZE
151 : #endif
152 90 : end subroutine juDFT_win_create_cmplx
153 :
154 0 : subroutine juDFT_win_create_cmplx_3D(base, size, disp_unit, info, comm, win)
155 : use m_judft
156 : #ifdef CPP_MPI
157 : use mpi
158 : #endif
159 : implicit none
160 : complex, POINTER, ASYNCHRONOUS, intent(inout):: base(:,:,:)
161 : integer, intent(in) :: disp_unit, info, comm
162 : integer, intent(inout) :: win
163 :
164 : #ifdef CPP_MPI
165 : INTEGER(KIND=MPI_ADDRESS_KIND) :: SIZE
166 : integer :: err, err_handler
167 :
168 0 : CALL MPI_WIN_CREATE(base, size, disp_unit, info, comm, win, err)
169 0 : if(err /= 0) call judft_error("Can't create MPI_Win for cmplx_data_ptr")
170 :
171 0 : call MPI_Win_create_errhandler(judft_mpi_error_handler, err_handler, err)
172 0 : if(err /= 0) call judft_error("Can't create Error handler")
173 :
174 0 : CALL MPI_WIN_SET_ERRHANDLER(win, err_handler, err)
175 0 : if(err /= 0) call judft_error("Can't assign Error handler to Win")
176 : #else
177 : INTEGER :: SIZE
178 : #endif
179 0 : end subroutine juDFT_win_create_cmplx_3D
180 :
181 462 : subroutine juDFT_win_create_int(base, size, disp_unit, info, comm, win)
182 : use m_judft
183 : #ifdef CPP_MPI
184 : use mpi
185 : #endif
186 : implicit none
187 : integer, POINTER, ASYNCHRONOUS, intent(inout) :: base(:)
188 : integer, intent(in) :: disp_unit, info, comm
189 : integer, intent(inout) :: win
190 :
191 : #ifdef CPP_MPI
192 : INTEGER(KIND=MPI_ADDRESS_KIND) :: SIZE
193 : integer :: err, err_handler
194 :
195 154 : CALL MPI_WIN_CREATE(base, size, disp_unit, info, comm, win, err)
196 154 : if(err /= 0) call judft_error("Can't create MPI_Win for cmplx_data_ptr")
197 :
198 154 : call MPI_Win_create_errhandler(judft_mpi_error_handler, err_handler, err)
199 154 : if(err /= 0) call judft_error("Can't create Error handler")
200 :
201 154 : CALL MPI_WIN_SET_ERRHANDLER(win, err_handler, err)
202 154 : if(err /= 0) call judft_error("Can't assign Error handler to Win")
203 : #else
204 : INTEGER :: SIZE
205 : #endif
206 154 : end subroutine juDFT_win_create_int
207 :
208 1272 : subroutine judft_comm_split(comm, color, key, new_comm)
209 : use m_judft
210 : #ifdef CPP_MPI
211 : use mpi
212 : #endif
213 : implicit none
214 : integer, intent(in) :: comm, color, key
215 : integer, intent(inout) :: new_comm
216 : #ifdef CPP_MPI
217 : integer :: ierr, err_handler
218 :
219 424 : CALL MPI_COMM_SPLIT(comm,color,key,new_comm,ierr)
220 424 : if(ierr /= 0) call judft_error("Can't split comm")
221 :
222 424 : call MPI_Comm_create_errhandler(judft_mpi_error_handler, err_handler, ierr)
223 424 : if(ierr /= 0) call judft_error("Can't create Error handler")
224 :
225 424 : call MPI_Comm_Set_Errhandler(new_comm, err_handler, ierr)
226 424 : if(ierr /= 0) call judft_error("Can't assign Error handler to new_comm")
227 : #endif
228 424 : end subroutine judft_comm_split
229 :
230 480 : subroutine judft_comm_split_type(comm, split_type, key, info, new_comm)
231 : use m_judft
232 : #ifdef CPP_MPI
233 : use mpi
234 : #endif
235 : implicit none
236 : integer, intent(in) :: comm, split_type, key, info
237 : integer, intent(inout) :: new_comm
238 : integer :: ierr, err_handler
239 :
240 : #ifdef CPP_MPI
241 160 : call MPI_comm_split_type(comm, split_type, key, info, new_comm, ierr)
242 160 : if(ierr /= 0) call judft_error("Can't split comm")
243 :
244 160 : call MPI_Comm_create_errhandler(judft_mpi_error_handler, err_handler, ierr)
245 160 : if(ierr /= 0) call judft_error("Can't create Error handler")
246 :
247 160 : call MPI_Comm_Set_Errhandler(new_comm, err_handler, ierr)
248 160 : if(ierr /= 0) call judft_error("Can't assign Error handler to new_comm")
249 : #endif
250 160 : end subroutine judft_comm_split_type
251 :
252 480 : subroutine t_mpi_set_errhandler(self)
253 : use m_judft
254 : #ifdef CPP_MPI
255 : use mpi
256 : #endif
257 : implicit none
258 : class(t_mpi), intent(in) :: self
259 :
260 : #ifdef CPP_MPI
261 : integer :: err_handler, ierr
262 :
263 160 : call MPI_Comm_create_errhandler(judft_mpi_error_handler, err_handler, ierr)
264 160 : if(ierr /= 0) call judft_error("Can't create Error handler")
265 :
266 160 : call MPI_Comm_Set_Errhandler(MPI_COMM_WORLD, err_handler, ierr)
267 160 : if(ierr /= 0) call judft_error("Can't assign Error handler to MPI_COMM_WORLD")
268 :
269 160 : call MPI_Comm_Set_Errhandler(self%mpi_comm, err_handler, ierr)
270 160 : if(ierr /= 0) call judft_error("Can't assign Error handler to self%mpi_comm")
271 :
272 160 : call MPI_Comm_Set_Errhandler(self%sub_comm, err_handler, ierr)
273 160 : if(ierr /= 0) call judft_error("Can't assign Error handler to self%sub_comm")
274 : #endif
275 160 : end subroutine t_mpi_set_errhandler
276 :
277 0 : subroutine judft_mpi_error_handler(comm, error_code)
278 : #ifdef CPP_MPI
279 : use mpi
280 : #endif
281 : use m_judft
282 : implicit none
283 : integer :: comm, error_code
284 : integer :: str_len, ierr
285 : character(len=3000) :: error_str
286 :
287 : #ifdef CPP_MPI
288 0 : call MPI_ERROR_STRING(error_code, error_str, str_len, ierr)
289 : call judft_error("MPI failed with Error_code = " // int2str(error_code) // new_line("A") // &
290 0 : error_str(1:str_len))
291 : #endif
292 0 : end subroutine judft_mpi_error_handler
293 :
294 1016 : SUBROUTINE calcIndexBounds(fmpi,firstIndexOverall, lastIndexOverall, firstIndexRank, lastIndexRank)
295 :
296 : IMPLICIT NONE
297 :
298 : TYPE(t_mpi), INTENT(IN) :: fmpi
299 : INTEGER, INTENT(IN) :: firstIndexOverall, lastIndexOverall
300 : INTEGER, INTENT(OUT) :: firstIndexRank, lastIndexRank
301 :
302 : INTEGER :: chunkSize, leftoverSize, length
303 :
304 1016 : length = lastIndexOverall - firstIndexOverall + 1
305 1016 : chunkSize = length / fmpi%isize
306 1016 : leftoverSize = MODULO(length, fmpi%isize)
307 1016 : IF (fmpi%irank < leftoverSize) THEN
308 112 : firstIndexRank = fmpi%irank*(chunkSize + 1) + firstIndexOverall
309 112 : lastIndexRank = (fmpi%irank + 1)*(chunkSize + 1) + firstIndexOverall - 1
310 : ELSE
311 904 : firstIndexRank = leftoverSize*(chunkSize + 1) + firstIndexOverall + (fmpi%irank - leftoverSize)*chunkSize
312 904 : lastIndexRank = (firstIndexRank + chunkSize) - 1
313 : ENDIF
314 1016 : END SUBROUTINE calcIndexBounds
315 :
316 0 : END MODULE m_types_mpi
|
