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