Line data Source code
1 : !--------------------------------------------------------------------------------------------------!
2 : ! CP2K: A general program to perform molecular dynamics simulations !
3 : ! Copyright 2000-2024 CP2K developers group <https://cp2k.org> !
4 : ! !
5 : ! SPDX-License-Identifier: GPL-2.0-or-later !
6 : !--------------------------------------------------------------------------------------------------!
7 :
8 : ! **************************************************************************************************
9 : !> \brief Auxiliary routines necessary to redistribute an fm_matrix from a
10 : !> given blacs_env to another
11 : !> \par History
12 : !> 12.2012 created [Mauro Del Ben]
13 : ! **************************************************************************************************
14 : MODULE rpa_communication
15 : USE cp_blacs_env, ONLY: cp_blacs_env_create,&
16 : cp_blacs_env_release,&
17 : cp_blacs_env_type
18 : USE cp_dbcsr_api, ONLY: dbcsr_type,&
19 : dbcsr_type_no_symmetry
20 : USE cp_dbcsr_operations, ONLY: copy_fm_to_dbcsr,&
21 : cp_dbcsr_m_by_n_from_template
22 : USE cp_fm_struct, ONLY: cp_fm_struct_create,&
23 : cp_fm_struct_release,&
24 : cp_fm_struct_type
25 : USE cp_fm_types, ONLY: cp_fm_create,&
26 : cp_fm_get_info,&
27 : cp_fm_release,&
28 : cp_fm_set_all,&
29 : cp_fm_type
30 : USE group_dist_types, ONLY: create_group_dist,&
31 : get_group_dist,&
32 : group_dist_d1_type,&
33 : release_group_dist
34 : USE kinds, ONLY: dp
35 : USE message_passing, ONLY: mp_para_env_type,&
36 : mp_request_null,&
37 : mp_request_type,&
38 : mp_waitall
39 : USE mp2_ri_grad_util, ONLY: fm2array,&
40 : prepare_redistribution
41 : USE mp2_types, ONLY: integ_mat_buffer_type
42 : USE util, ONLY: get_limit
43 : #include "./base/base_uses.f90"
44 :
45 : IMPLICIT NONE
46 :
47 : PRIVATE
48 :
49 : TYPE index_map
50 : INTEGER, DIMENSION(:, :), ALLOCATABLE :: map
51 : END TYPE
52 :
53 : CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'rpa_communication'
54 :
55 : PUBLIC :: gamma_fm_to_dbcsr, &
56 : communicate_buffer
57 :
58 : CONTAINS
59 :
60 : ! **************************************************************************************************
61 : !> \brief Redistribute RPA-AXK Gamma_3 density matrices: from fm to dbcsr
62 : !> \param fm_mat_Gamma_3 ... ia*dime_RI sized density matrix (fm type on para_env_RPA)
63 : !> \param dbcsr_Gamma_3 ... redistributed Gamma_3 (dbcsr array): dimen_RI of i*a: i*a on subgroup, L distributed in RPA_group
64 : !> \param para_env_RPA ...
65 : !> \param para_env_sub ...
66 : !> \param homo ...
67 : !> \param virtual ...
68 : !> \param mo_coeff_o ... dbcsr on a subgroup
69 : !> \param ngroup ...
70 : !> \param my_group_L_start ...
71 : !> \param my_group_L_end ...
72 : !> \param my_group_L_size ...
73 : !> \author Vladimir Rybkin, 07/2016
74 : ! **************************************************************************************************
75 2 : SUBROUTINE gamma_fm_to_dbcsr(fm_mat_Gamma_3, dbcsr_Gamma_3, para_env_RPA, para_env_sub, &
76 : homo, virtual, mo_coeff_o, ngroup, my_group_L_start, my_group_L_end, &
77 : my_group_L_size)
78 : TYPE(cp_fm_type), INTENT(INOUT) :: fm_mat_Gamma_3
79 : TYPE(dbcsr_type), ALLOCATABLE, DIMENSION(:) :: dbcsr_Gamma_3
80 : TYPE(mp_para_env_type), INTENT(IN) :: para_env_RPA
81 : TYPE(mp_para_env_type), INTENT(IN), POINTER :: para_env_sub
82 : INTEGER, INTENT(IN) :: homo, virtual
83 : TYPE(dbcsr_type), INTENT(INOUT) :: mo_coeff_o
84 : INTEGER, INTENT(IN) :: ngroup, my_group_L_start, &
85 : my_group_L_end, my_group_L_size
86 :
87 : CHARACTER(LEN=*), PARAMETER :: routineN = 'gamma_fm_to_dbcsr'
88 :
89 : INTEGER :: dimen_ia, dummy_proc, handle, i_global, i_local, iaia, iib, iii, itmp(2), &
90 : j_global, j_local, jjb, jjj, kkb, my_ia_end, my_ia_size, my_ia_start, mypcol, myprow, &
91 : ncol_local, npcol, nprow, nrow_local, number_of_rec, number_of_send, proc_receive, &
92 : proc_send, proc_shift, rec_counter, rec_iaia_end, rec_iaia_size, rec_iaia_start, &
93 : rec_pcol, rec_prow, ref_send_pcol, ref_send_prow, send_counter, send_pcol, send_prow, &
94 : size_rec_buffer, size_send_buffer
95 2 : INTEGER, ALLOCATABLE, DIMENSION(:) :: iii_vet, map_rec_size, map_send_size
96 2 : INTEGER, ALLOCATABLE, DIMENSION(:, :) :: grid_2_mepos, grid_ref_2_send_pos, &
97 2 : group_grid_2_mepos, indices_map_my, &
98 2 : mepos_2_grid, mepos_2_grid_group
99 2 : INTEGER, DIMENSION(:), POINTER :: col_indices, row_indices
100 : REAL(KIND=dp) :: part_ia
101 2 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: Gamma_2D
102 : TYPE(cp_blacs_env_type), POINTER :: blacs_env
103 : TYPE(cp_fm_struct_type), POINTER :: fm_struct
104 : TYPE(cp_fm_type) :: fm_ia
105 2 : TYPE(group_dist_d1_type) :: gd_ia
106 2 : TYPE(index_map), ALLOCATABLE, DIMENSION(:) :: indices_rec
107 : TYPE(integ_mat_buffer_type), ALLOCATABLE, &
108 2 : DIMENSION(:) :: buffer_rec, buffer_send
109 2 : TYPE(mp_request_type), ALLOCATABLE, DIMENSION(:) :: req_send
110 :
111 2 : CALL timeset(routineN, handle)
112 :
113 2 : dimen_ia = virtual*homo
114 :
115 : ! Prepare sizes for a 2D array
116 2 : CALL create_group_dist(gd_ia, para_env_sub%num_pe, dimen_ia)
117 2 : CALL get_group_dist(gd_ia, para_env_sub%mepos, my_ia_start, my_ia_end, my_ia_size)
118 :
119 : ! Make a 2D array intermediate
120 :
121 : CALL prepare_redistribution(para_env_RPA, para_env_sub, ngroup, &
122 : group_grid_2_mepos, mepos_2_grid_group)
123 :
124 : ! fm_mat_Gamma_3 is released here
125 : CALL fm2array(Gamma_2D, my_ia_size, my_ia_start, my_ia_end, &
126 : my_group_L_size, my_group_L_start, my_group_L_end, &
127 : group_grid_2_mepos, mepos_2_grid_group, &
128 : para_env_sub%num_pe, ngroup, &
129 2 : fm_mat_Gamma_3)
130 :
131 : ! create sub blacs env
132 2 : NULLIFY (blacs_env)
133 2 : CALL cp_blacs_env_create(blacs_env=blacs_env, para_env=para_env_sub)
134 :
135 : ! create the fm_ia buffer matrix
136 2 : NULLIFY (fm_struct)
137 : CALL cp_fm_struct_create(fm_struct, context=blacs_env, nrow_global=homo, &
138 2 : ncol_global=virtual, para_env=para_env_sub)
139 2 : CALL cp_fm_create(fm_ia, fm_struct, name="fm_ia")
140 :
141 : ! release structure
142 2 : CALL cp_fm_struct_release(fm_struct)
143 : ! release blacs_env
144 2 : CALL cp_blacs_env_release(blacs_env)
145 :
146 : ! get array information
147 : CALL cp_fm_get_info(matrix=fm_ia, &
148 : nrow_local=nrow_local, &
149 : ncol_local=ncol_local, &
150 : row_indices=row_indices, &
151 2 : col_indices=col_indices)
152 2 : myprow = fm_ia%matrix_struct%context%mepos(1)
153 2 : mypcol = fm_ia%matrix_struct%context%mepos(2)
154 2 : nprow = fm_ia%matrix_struct%context%num_pe(1)
155 2 : npcol = fm_ia%matrix_struct%context%num_pe(2)
156 :
157 : ! 0) create array containing the processes position and supporting infos
158 8 : ALLOCATE (grid_2_mepos(0:nprow - 1, 0:npcol - 1))
159 6 : grid_2_mepos = 0
160 6 : ALLOCATE (mepos_2_grid(2, 0:para_env_sub%num_pe - 1))
161 : ! fill the info array
162 2 : grid_2_mepos(myprow, mypcol) = para_env_sub%mepos
163 : ! sum infos
164 2 : CALL para_env_sub%sum(grid_2_mepos)
165 6 : CALL para_env_sub%allgather([myprow, mypcol], mepos_2_grid)
166 :
167 : ! loop over local index range and define the sending map
168 6 : ALLOCATE (map_send_size(0:para_env_sub%num_pe - 1))
169 4 : map_send_size = 0
170 2 : dummy_proc = 0
171 154 : DO iaia = my_ia_start, my_ia_end
172 152 : i_global = (iaia - 1)/virtual + 1
173 152 : j_global = MOD(iaia - 1, virtual) + 1
174 152 : send_prow = fm_ia%matrix_struct%g2p_row(i_global)
175 152 : send_pcol = fm_ia%matrix_struct%g2p_col(j_global)
176 152 : proc_send = grid_2_mepos(send_prow, send_pcol)
177 154 : map_send_size(proc_send) = map_send_size(proc_send) + 1
178 : END DO
179 :
180 : ! loop over local data of fm_ia and define the receiving map
181 6 : ALLOCATE (map_rec_size(0:para_env_sub%num_pe - 1))
182 4 : map_rec_size = 0
183 2 : part_ia = REAL(dimen_ia, KIND=dp)/REAL(para_env_sub%num_pe, KIND=dp)
184 :
185 10 : DO iiB = 1, nrow_local
186 8 : i_global = row_indices(iiB)
187 162 : DO jjB = 1, ncol_local
188 152 : j_global = col_indices(jjB)
189 152 : iaia = (i_global - 1)*virtual + j_global
190 152 : proc_receive = INT(REAL(iaia - 1, KIND=dp)/part_ia)
191 152 : proc_receive = MAX(0, proc_receive)
192 152 : proc_receive = MIN(proc_receive, para_env_sub%num_pe - 1)
193 : DO
194 152 : itmp = get_limit(dimen_ia, para_env_sub%num_pe, proc_receive)
195 152 : IF (iaia >= itmp(1) .AND. iaia <= itmp(2)) EXIT
196 0 : IF (iaia < itmp(1)) proc_receive = proc_receive - 1
197 152 : IF (iaia > itmp(2)) proc_receive = proc_receive + 1
198 : END DO
199 160 : map_rec_size(proc_receive) = map_rec_size(proc_receive) + 1
200 : END DO
201 : END DO
202 :
203 : ! allocate the buffer for sending data
204 2 : number_of_send = 0
205 2 : DO proc_shift = 1, para_env_sub%num_pe - 1
206 0 : proc_send = MODULO(para_env_sub%mepos + proc_shift, para_env_sub%num_pe)
207 2 : IF (map_send_size(proc_send) > 0) THEN
208 0 : number_of_send = number_of_send + 1
209 : END IF
210 : END DO
211 : ! allocate the structure that will hold the messages to be sent
212 4 : ALLOCATE (buffer_send(number_of_send))
213 : ! and the map from the grid of processess to the message position
214 6 : ALLOCATE (grid_ref_2_send_pos(0:nprow - 1, 0:npcol - 1))
215 6 : grid_ref_2_send_pos = 0
216 : ! finally allocate each message
217 2 : send_counter = 0
218 2 : DO proc_shift = 1, para_env_sub%num_pe - 1
219 0 : proc_send = MODULO(para_env_sub%mepos + proc_shift, para_env_sub%num_pe)
220 0 : size_send_buffer = map_send_size(proc_send)
221 2 : IF (map_send_size(proc_send) > 0) THEN
222 0 : send_counter = send_counter + 1
223 : ! allocate the sending buffer (msg)
224 0 : ALLOCATE (buffer_send(send_counter)%msg(size_send_buffer))
225 0 : buffer_send(send_counter)%proc = proc_send
226 : ! get the pointer to prow, pcol of the process that has
227 : ! to receive this message
228 0 : ref_send_prow = mepos_2_grid(1, proc_send)
229 0 : ref_send_pcol = mepos_2_grid(2, proc_send)
230 : ! save the rank of the process that has to receive this message
231 0 : grid_ref_2_send_pos(ref_send_prow, ref_send_pcol) = send_counter
232 : END IF
233 : END DO
234 :
235 : ! allocate the buffer for receiving data
236 : number_of_rec = 0
237 2 : DO proc_shift = 1, para_env_sub%num_pe - 1
238 0 : proc_receive = MODULO(para_env_sub%mepos - proc_shift, para_env_sub%num_pe)
239 2 : IF (map_rec_size(proc_receive) > 0) THEN
240 0 : number_of_rec = number_of_rec + 1
241 : END IF
242 : END DO
243 :
244 : ! allocate the structure that will hold the messages to be received
245 : ! and relative indeces
246 4 : ALLOCATE (buffer_rec(number_of_rec))
247 4 : ALLOCATE (indices_rec(number_of_rec))
248 : ! finally allocate each message and fill the array of indeces
249 2 : rec_counter = 0
250 2 : DO proc_shift = 1, para_env_sub%num_pe - 1
251 0 : proc_receive = MODULO(para_env_sub%mepos - proc_shift, para_env_sub%num_pe)
252 0 : size_rec_buffer = map_rec_size(proc_receive)
253 2 : IF (map_rec_size(proc_receive) > 0) THEN
254 0 : rec_counter = rec_counter + 1
255 : ! prepare the buffer for receive
256 0 : ALLOCATE (buffer_rec(rec_counter)%msg(size_rec_buffer))
257 0 : buffer_rec(rec_counter)%proc = proc_receive
258 : ! create the indices array
259 0 : ALLOCATE (indices_rec(rec_counter)%map(2, size_rec_buffer))
260 0 : indices_rec(rec_counter)%map = 0
261 0 : CALL get_group_dist(gd_ia, proc_receive, rec_iaia_start, rec_iaia_end, rec_iaia_size)
262 0 : iii = 0
263 0 : DO iaia = rec_iaia_start, rec_iaia_end
264 0 : i_global = (iaia - 1)/virtual + 1
265 0 : j_global = MOD(iaia - 1, virtual) + 1
266 0 : rec_prow = fm_ia%matrix_struct%g2p_row(i_global)
267 0 : rec_pcol = fm_ia%matrix_struct%g2p_col(j_global)
268 0 : IF (grid_2_mepos(rec_prow, rec_pcol) /= para_env_sub%mepos) CYCLE
269 0 : iii = iii + 1
270 0 : i_local = fm_ia%matrix_struct%g2l_row(i_global)
271 0 : j_local = fm_ia%matrix_struct%g2l_col(j_global)
272 0 : indices_rec(rec_counter)%map(1, iii) = i_local
273 0 : indices_rec(rec_counter)%map(2, iii) = j_local
274 : END DO
275 : END IF
276 : END DO
277 :
278 : ! and create the index map for my local data
279 2 : IF (map_rec_size(para_env_sub%mepos) > 0) THEN
280 2 : size_rec_buffer = map_rec_size(para_env_sub%mepos)
281 6 : ALLOCATE (indices_map_my(2, size_rec_buffer))
282 458 : indices_map_my = 0
283 : iii = 0
284 154 : DO iaia = my_ia_start, my_ia_end
285 152 : i_global = (iaia - 1)/virtual + 1
286 152 : j_global = MOD(iaia - 1, virtual) + 1
287 152 : rec_prow = fm_ia%matrix_struct%g2p_row(i_global)
288 152 : rec_pcol = fm_ia%matrix_struct%g2p_col(j_global)
289 152 : IF (grid_2_mepos(rec_prow, rec_pcol) /= para_env_sub%mepos) CYCLE
290 152 : iii = iii + 1
291 152 : i_local = fm_ia%matrix_struct%g2l_row(i_global)
292 152 : j_local = fm_ia%matrix_struct%g2l_col(j_global)
293 152 : indices_map_my(1, iii) = i_local
294 154 : indices_map_my(2, iii) = j_local
295 : END DO
296 : END IF
297 :
298 : ! Allocate dbcsr_Gamma_3
299 89 : ALLOCATE (dbcsr_Gamma_3(my_group_L_size))
300 :
301 : ! auxiliary vector of indices for the send buffer
302 4 : ALLOCATE (iii_vet(number_of_send))
303 : ! vector for the send requests
304 4 : ALLOCATE (req_send(number_of_send))
305 : ! loop over auxiliary basis function and redistribute into a fm
306 : ! and then compy the fm into a dbcsr matrix
307 :
308 : !DO kkB = 1, ncol_local
309 85 : DO kkB = 1, my_group_L_size
310 : ! zero the matries of the buffers and post the messages to be received
311 83 : CALL cp_fm_set_all(matrix=fm_ia, alpha=0.0_dp)
312 83 : rec_counter = 0
313 83 : DO proc_shift = 1, para_env_sub%num_pe - 1
314 0 : proc_receive = MODULO(para_env_sub%mepos - proc_shift, para_env_sub%num_pe)
315 83 : IF (map_rec_size(proc_receive) > 0) THEN
316 0 : rec_counter = rec_counter + 1
317 0 : buffer_rec(rec_counter)%msg = 0.0_dp
318 : CALL para_env_sub%irecv(buffer_rec(rec_counter)%msg, proc_receive, &
319 0 : buffer_rec(rec_counter)%msg_req)
320 : END IF
321 : END DO
322 : ! fill the sending buffer and send the messages
323 83 : DO send_counter = 1, number_of_send
324 83 : buffer_send(send_counter)%msg = 0.0_dp
325 : END DO
326 83 : iii_vet = 0
327 : jjj = 0
328 6391 : DO iaia = my_ia_start, my_ia_end
329 6308 : i_global = (iaia - 1)/virtual + 1
330 6308 : j_global = MOD(iaia - 1, virtual) + 1
331 6308 : send_prow = fm_ia%matrix_struct%g2p_row(i_global)
332 6308 : send_pcol = fm_ia%matrix_struct%g2p_col(j_global)
333 6308 : proc_send = grid_2_mepos(send_prow, send_pcol)
334 : ! we don't need to send to ourselves
335 6391 : IF (grid_2_mepos(send_prow, send_pcol) == para_env_sub%mepos) THEN
336 : ! filling fm_ia with local data
337 6308 : jjj = jjj + 1
338 6308 : i_local = indices_map_my(1, jjj)
339 6308 : j_local = indices_map_my(2, jjj)
340 : fm_ia%local_data(i_local, j_local) = &
341 6308 : Gamma_2D(iaia - my_ia_start + 1, kkB)
342 :
343 : ELSE
344 0 : send_counter = grid_ref_2_send_pos(send_prow, send_pcol)
345 0 : iii_vet(send_counter) = iii_vet(send_counter) + 1
346 0 : iii = iii_vet(send_counter)
347 : buffer_send(send_counter)%msg(iii) = &
348 0 : Gamma_2D(iaia - my_ia_start + 1, kkB)
349 : END IF
350 : END DO
351 83 : req_send = mp_request_null
352 83 : send_counter = 0
353 83 : DO proc_shift = 1, para_env_sub%num_pe - 1
354 0 : proc_send = MODULO(para_env_sub%mepos + proc_shift, para_env_sub%num_pe)
355 83 : IF (map_send_size(proc_send) > 0) THEN
356 0 : send_counter = send_counter + 1
357 : CALL para_env_sub%isend(buffer_send(send_counter)%msg, proc_send, &
358 0 : buffer_send(send_counter)%msg_req)
359 0 : req_send(send_counter) = buffer_send(send_counter)%msg_req
360 : END IF
361 : END DO
362 :
363 : ! receive the messages and fill the fm_ia
364 83 : rec_counter = 0
365 83 : DO proc_shift = 1, para_env_sub%num_pe - 1
366 0 : proc_receive = MODULO(para_env_sub%mepos - proc_shift, para_env_sub%num_pe)
367 0 : size_rec_buffer = map_rec_size(proc_receive)
368 83 : IF (map_rec_size(proc_receive) > 0) THEN
369 0 : rec_counter = rec_counter + 1
370 : ! wait for the message
371 0 : CALL buffer_rec(rec_counter)%msg_req%wait()
372 0 : DO iii = 1, size_rec_buffer
373 0 : i_local = indices_rec(rec_counter)%map(1, iii)
374 0 : j_local = indices_rec(rec_counter)%map(2, iii)
375 0 : fm_ia%local_data(i_local, j_local) = buffer_rec(rec_counter)%msg(iii)
376 : END DO
377 : END IF
378 : END DO
379 :
380 : ! wait all
381 83 : CALL mp_waitall(req_send(:))
382 :
383 : ! now create the DBCSR matrix and copy fm_ia into it
384 : CALL cp_dbcsr_m_by_n_from_template(dbcsr_Gamma_3(kkB), template=mo_coeff_o, &
385 83 : m=homo, n=virtual, sym=dbcsr_type_no_symmetry)
386 85 : CALL copy_fm_to_dbcsr(fm_ia, dbcsr_Gamma_3(kkB), keep_sparsity=.FALSE.)
387 :
388 : END DO
389 :
390 : ! Deallocate memory
391 :
392 2 : DEALLOCATE (Gamma_2d)
393 2 : DEALLOCATE (iii_vet)
394 2 : DEALLOCATE (req_send)
395 2 : IF (map_rec_size(para_env_sub%mepos) > 0) THEN
396 2 : DEALLOCATE (indices_map_my)
397 : END IF
398 2 : DO rec_counter = 1, number_of_rec
399 0 : DEALLOCATE (indices_rec(rec_counter)%map)
400 2 : DEALLOCATE (buffer_rec(rec_counter)%msg)
401 : END DO
402 2 : DEALLOCATE (indices_rec)
403 2 : DEALLOCATE (buffer_rec)
404 2 : DO send_counter = 1, number_of_send
405 2 : DEALLOCATE (buffer_send(send_counter)%msg)
406 : END DO
407 2 : DEALLOCATE (buffer_send)
408 2 : DEALLOCATE (map_send_size)
409 2 : DEALLOCATE (map_rec_size)
410 2 : DEALLOCATE (grid_2_mepos)
411 2 : DEALLOCATE (mepos_2_grid)
412 2 : CALL release_group_dist(gd_ia)
413 :
414 : ! release buffer matrix
415 2 : CALL cp_fm_release(fm_ia)
416 :
417 2 : CALL timestop(handle)
418 :
419 10 : END SUBROUTINE gamma_fm_to_dbcsr
420 :
421 : ! **************************************************************************************************
422 : !> \brief ...
423 : !> \param para_env ...
424 : !> \param num_entries_rec ...
425 : !> \param num_entries_send ...
426 : !> \param buffer_rec ...
427 : !> \param buffer_send ...
428 : !> \param req_array ...
429 : !> \param do_indx ...
430 : !> \param do_msg ...
431 : ! **************************************************************************************************
432 752 : SUBROUTINE communicate_buffer(para_env, num_entries_rec, num_entries_send, buffer_rec, buffer_send, &
433 : req_array, do_indx, do_msg)
434 :
435 : TYPE(mp_para_env_type), INTENT(IN) :: para_env
436 : INTEGER, ALLOCATABLE, DIMENSION(:), INTENT(IN) :: num_entries_rec, num_entries_send
437 : TYPE(integ_mat_buffer_type), ALLOCATABLE, &
438 : DIMENSION(:), INTENT(INOUT) :: buffer_rec, buffer_send
439 : TYPE(mp_request_type), DIMENSION(:, :), POINTER :: req_array
440 : LOGICAL, INTENT(IN), OPTIONAL :: do_indx, do_msg
441 :
442 : CHARACTER(LEN=*), PARAMETER :: routineN = 'communicate_buffer'
443 :
444 : INTEGER :: handle, imepos, rec_counter, send_counter
445 : LOGICAL :: my_do_indx, my_do_msg
446 :
447 752 : CALL timeset(routineN, handle)
448 :
449 752 : my_do_indx = .TRUE.
450 752 : IF (PRESENT(do_indx)) my_do_indx = do_indx
451 752 : my_do_msg = .TRUE.
452 752 : IF (PRESENT(do_msg)) my_do_msg = do_msg
453 :
454 752 : IF (para_env%num_pe > 1) THEN
455 :
456 752 : send_counter = 0
457 752 : rec_counter = 0
458 :
459 2256 : DO imepos = 0, para_env%num_pe - 1
460 2256 : IF (num_entries_rec(imepos) > 0) THEN
461 715 : rec_counter = rec_counter + 1
462 715 : IF (my_do_indx) THEN
463 715 : CALL para_env%irecv(buffer_rec(imepos)%indx, imepos, req_array(rec_counter, 3), tag=4)
464 : END IF
465 715 : IF (my_do_msg) THEN
466 715 : CALL para_env%irecv(buffer_rec(imepos)%msg, imepos, req_array(rec_counter, 4), tag=7)
467 : END IF
468 : END IF
469 : END DO
470 :
471 2256 : DO imepos = 0, para_env%num_pe - 1
472 2256 : IF (num_entries_send(imepos) > 0) THEN
473 715 : send_counter = send_counter + 1
474 715 : IF (my_do_indx) THEN
475 715 : CALL para_env%isend(buffer_send(imepos)%indx, imepos, req_array(send_counter, 1), tag=4)
476 : END IF
477 715 : IF (my_do_msg) THEN
478 715 : CALL para_env%isend(buffer_send(imepos)%msg, imepos, req_array(send_counter, 2), tag=7)
479 : END IF
480 : END IF
481 : END DO
482 :
483 752 : IF (my_do_indx) THEN
484 752 : CALL mp_waitall(req_array(1:send_counter, 1))
485 752 : CALL mp_waitall(req_array(1:rec_counter, 3))
486 : END IF
487 :
488 752 : IF (my_do_msg) THEN
489 752 : CALL mp_waitall(req_array(1:send_counter, 2))
490 752 : CALL mp_waitall(req_array(1:rec_counter, 4))
491 : END IF
492 :
493 : ELSE
494 :
495 0 : buffer_rec(0)%indx(:, :) = buffer_send(0)%indx
496 0 : buffer_rec(0)%msg(:) = buffer_send(0)%msg
497 :
498 : END IF
499 :
500 752 : CALL timestop(handle)
501 :
502 752 : END SUBROUTINE communicate_buffer
503 :
504 0 : END MODULE rpa_communication
|
