Line data Source code
1 : !--------------------------------------------------------------------------------------------------!
2 : ! CP2K: A general program to perform molecular dynamics simulations !
3 : ! Copyright 2000-2026 CP2K developers group <https://cp2k.org> !
4 : ! !
5 : ! SPDX-License-Identifier: GPL-2.0-or-later !
6 : !--------------------------------------------------------------------------------------------------!
7 :
8 : ! **************************************************************************************************
9 : !> \brief RI-methods for HFX and K-points.
10 : !> \auhtor Augustin Bussy (01.2023)
11 : ! **************************************************************************************************
12 :
13 : MODULE hfx_ri_kp
14 : USE admm_types, ONLY: get_admm_env
15 : USE atomic_kind_types, ONLY: atomic_kind_type,&
16 : get_atomic_kind_set
17 : USE basis_set_types, ONLY: get_gto_basis_set,&
18 : gto_basis_set_p_type
19 : USE bibliography, ONLY: Bussy2024,&
20 : cite_reference
21 : USE cell_types, ONLY: cell_type,&
22 : pbc,&
23 : real_to_scaled,&
24 : scaled_to_real
25 : USE cp_array_utils, ONLY: cp_1d_logical_p_type,&
26 : cp_2d_r_p_type,&
27 : cp_3d_r_p_type
28 : USE cp_blacs_env, ONLY: cp_blacs_env_create,&
29 : cp_blacs_env_release,&
30 : cp_blacs_env_type
31 : USE cp_control_types, ONLY: dft_control_type
32 : USE cp_dbcsr_api, ONLY: &
33 : dbcsr_add, dbcsr_clear, dbcsr_copy, dbcsr_create, dbcsr_distribution_get, &
34 : dbcsr_distribution_new, dbcsr_distribution_release, dbcsr_distribution_type, dbcsr_filter, &
35 : dbcsr_finalize, dbcsr_get_block_p, dbcsr_get_info, dbcsr_iterator_blocks_left, &
36 : dbcsr_iterator_next_block, dbcsr_iterator_start, dbcsr_iterator_stop, dbcsr_iterator_type, &
37 : dbcsr_p_type, dbcsr_put_block, dbcsr_release, dbcsr_type, dbcsr_type_no_symmetry, &
38 : dbcsr_type_symmetric
39 : USE cp_dbcsr_cholesky, ONLY: cp_dbcsr_cholesky_decompose,&
40 : cp_dbcsr_cholesky_invert
41 : USE cp_dbcsr_contrib, ONLY: dbcsr_dot
42 : USE cp_dbcsr_cp2k_link, ONLY: cp_dbcsr_alloc_block_from_nbl
43 : USE cp_dbcsr_diag, ONLY: cp_dbcsr_power
44 : USE cp_dbcsr_operations, ONLY: cp_dbcsr_dist2d_to_dist
45 : USE dbt_api, ONLY: &
46 : dbt_batched_contract_finalize, dbt_batched_contract_init, dbt_clear, dbt_contract, &
47 : dbt_copy, dbt_copy_matrix_to_tensor, dbt_copy_tensor_to_matrix, dbt_create, dbt_destroy, &
48 : dbt_distribution_destroy, dbt_distribution_new, dbt_distribution_type, dbt_filter, &
49 : dbt_finalize, dbt_get_block, dbt_get_info, dbt_get_stored_coordinates, &
50 : dbt_iterator_blocks_left, dbt_iterator_next_block, dbt_iterator_start, dbt_iterator_stop, &
51 : dbt_iterator_type, dbt_mp_environ_pgrid, dbt_pgrid_create, dbt_pgrid_destroy, &
52 : dbt_pgrid_type, dbt_put_block, dbt_scale, dbt_type
53 : USE distribution_2d_types, ONLY: distribution_2d_release,&
54 : distribution_2d_type
55 : USE hfx_ri, ONLY: get_idx_to_atom,&
56 : hfx_ri_pre_scf_calc_tensors
57 : USE hfx_types, ONLY: hfx_ri_type
58 : USE input_constants, ONLY: do_potential_short,&
59 : hfx_ri_do_2c_cholesky,&
60 : hfx_ri_do_2c_diag,&
61 : hfx_ri_do_2c_iter
62 : USE input_cp2k_hfx, ONLY: ri_pmat
63 : USE input_section_types, ONLY: section_vals_get_subs_vals,&
64 : section_vals_type,&
65 : section_vals_val_get,&
66 : section_vals_val_set
67 : USE iterate_matrix, ONLY: invert_hotelling
68 : USE kinds, ONLY: default_string_length,&
69 : dp,&
70 : int_8
71 : USE kpoint_types, ONLY: get_kpoint_info,&
72 : kpoint_type
73 : USE libint_2c_3c, ONLY: cutoff_screen_factor
74 : USE machine, ONLY: m_flush,&
75 : m_memory,&
76 : m_walltime
77 : USE mathlib, ONLY: erfc_cutoff
78 : USE message_passing, ONLY: mp_cart_type,&
79 : mp_para_env_type,&
80 : mp_request_type,&
81 : mp_waitall
82 : USE particle_methods, ONLY: get_particle_set
83 : USE particle_types, ONLY: particle_type
84 : USE physcon, ONLY: angstrom
85 : USE qs_environment_types, ONLY: get_qs_env,&
86 : qs_environment_type
87 : USE qs_force_types, ONLY: qs_force_type
88 : USE qs_integral_utils, ONLY: basis_set_list_setup
89 : USE qs_interactions, ONLY: init_interaction_radii_orb_basis
90 : USE qs_kind_types, ONLY: qs_kind_type
91 : USE qs_neighbor_list_types, ONLY: get_iterator_info,&
92 : neighbor_list_iterate,&
93 : neighbor_list_iterator_create,&
94 : neighbor_list_iterator_p_type,&
95 : neighbor_list_iterator_release,&
96 : neighbor_list_set_p_type,&
97 : release_neighbor_list_sets
98 : USE qs_scf_types, ONLY: qs_scf_env_type
99 : USE qs_tensors, ONLY: &
100 : build_2c_derivatives, build_2c_neighbor_lists, build_3c_derivatives, &
101 : build_3c_neighbor_lists, get_3c_iterator_info, get_tensor_occupancy, &
102 : neighbor_list_3c_destroy, neighbor_list_3c_iterate, neighbor_list_3c_iterator_create, &
103 : neighbor_list_3c_iterator_destroy
104 : USE qs_tensors_types, ONLY: create_2c_tensor,&
105 : create_3c_tensor,&
106 : create_tensor_batches,&
107 : distribution_2d_create,&
108 : distribution_3d_create,&
109 : distribution_3d_type,&
110 : neighbor_list_3c_iterator_type,&
111 : neighbor_list_3c_type
112 : USE util, ONLY: get_limit
113 : USE virial_types, ONLY: virial_type
114 : #include "./base/base_uses.f90"
115 :
116 : !$ USE OMP_LIB, ONLY: omp_get_num_threads
117 :
118 : IMPLICIT NONE
119 : PRIVATE
120 :
121 : PUBLIC :: hfx_ri_update_ks_kp, hfx_ri_update_forces_kp
122 :
123 : CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'hfx_ri_kp'
124 : CONTAINS
125 :
126 : ! **************************************************************************************************
127 : !> \brief I_1nitialize the ri_data for K-point. For now, we take the normal, usual existing ri_data
128 : !> and we adapt it to our needs
129 : !> \param dbcsr_template ...
130 : !> \param ri_data ...
131 : !> \param qs_env ...
132 : ! **************************************************************************************************
133 88 : SUBROUTINE adapt_ri_data_to_kp(dbcsr_template, ri_data, qs_env)
134 : TYPE(dbcsr_type), INTENT(INOUT) :: dbcsr_template
135 : TYPE(hfx_ri_type), INTENT(INOUT) :: ri_data
136 : TYPE(qs_environment_type), POINTER :: qs_env
137 :
138 : INTEGER :: i_img, i_RI, i_spin, iatom, natom, &
139 : nblks_RI, nimg, nkind, nspins
140 88 : INTEGER, ALLOCATABLE, DIMENSION(:) :: bsizes_RI_ext, dist1, dist2, dist3
141 : TYPE(dft_control_type), POINTER :: dft_control
142 : TYPE(mp_para_env_type), POINTER :: para_env
143 :
144 88 : NULLIFY (dft_control, para_env)
145 :
146 : !The main thing that we need to do is to allocate more space for the integrals, such that there
147 : !is room for each periodic image. Note that we only go in 1D, i.e. we store (mu^0 sigma^a|P^0),
148 : !and (P^0|Q^a) => the RI basis is always in the main cell.
149 :
150 : !Get kpoint info
151 88 : CALL get_qs_env(qs_env, dft_control=dft_control, natom=natom, para_env=para_env, nkind=nkind)
152 88 : nimg = ri_data%nimg
153 :
154 : !Along the RI direction we have basis elements spread accross ncell_RI images.
155 88 : nblks_RI = SIZE(ri_data%bsizes_RI_split)
156 264 : ALLOCATE (bsizes_RI_ext(nblks_RI*ri_data%ncell_RI))
157 642 : DO i_RI = 1, ri_data%ncell_RI
158 3264 : bsizes_RI_ext((i_RI - 1)*nblks_RI + 1:i_RI*nblks_RI) = ri_data%bsizes_RI_split(:)
159 : END DO
160 :
161 5676 : ALLOCATE (ri_data%t_3c_int_ctr_1(1, nimg))
162 : CALL create_3c_tensor(ri_data%t_3c_int_ctr_1(1, 1), dist1, dist2, dist3, &
163 : ri_data%pgrid_1, ri_data%bsizes_AO_split, bsizes_RI_ext, &
164 88 : ri_data%bsizes_AO_split, [1, 2], [3], name="(AO RI | AO)")
165 :
166 2354 : DO i_img = 2, nimg
167 2354 : CALL dbt_create(ri_data%t_3c_int_ctr_1(1, 1), ri_data%t_3c_int_ctr_1(1, i_img))
168 : END DO
169 88 : DEALLOCATE (dist1, dist2, dist3)
170 :
171 968 : ALLOCATE (ri_data%t_3c_int_ctr_2(1, 1))
172 : CALL create_3c_tensor(ri_data%t_3c_int_ctr_2(1, 1), dist1, dist2, dist3, &
173 : ri_data%pgrid_1, ri_data%bsizes_AO_split, bsizes_RI_ext, &
174 88 : ri_data%bsizes_AO_split, [1], [2, 3], name="(AO RI | AO)")
175 88 : DEALLOCATE (dist1, dist2, dist3)
176 :
177 : !We use full block sizes for the 2c quantities
178 88 : DEALLOCATE (bsizes_RI_ext)
179 88 : nblks_RI = SIZE(ri_data%bsizes_RI)
180 264 : ALLOCATE (bsizes_RI_ext(nblks_RI*ri_data%ncell_RI))
181 642 : DO i_RI = 1, ri_data%ncell_RI
182 1750 : bsizes_RI_ext((i_RI - 1)*nblks_RI + 1:i_RI*nblks_RI) = ri_data%bsizes_RI(:)
183 : END DO
184 :
185 3784 : ALLOCATE (ri_data%t_2c_inv(1, natom), ri_data%t_2c_int(1, natom), ri_data%t_2c_pot(1, natom))
186 : CALL create_2c_tensor(ri_data%t_2c_inv(1, 1), dist1, dist2, ri_data%pgrid_2d, &
187 : bsizes_RI_ext, bsizes_RI_ext, &
188 88 : name="(RI | RI)")
189 88 : DEALLOCATE (dist1, dist2)
190 88 : CALL dbt_create(ri_data%t_2c_inv(1, 1), ri_data%t_2c_int(1, 1))
191 88 : CALL dbt_create(ri_data%t_2c_inv(1, 1), ri_data%t_2c_pot(1, 1))
192 176 : DO iatom = 2, natom
193 88 : CALL dbt_create(ri_data%t_2c_inv(1, 1), ri_data%t_2c_inv(1, iatom))
194 88 : CALL dbt_create(ri_data%t_2c_inv(1, 1), ri_data%t_2c_int(1, iatom))
195 176 : CALL dbt_create(ri_data%t_2c_inv(1, 1), ri_data%t_2c_pot(1, iatom))
196 : END DO
197 :
198 440 : ALLOCATE (ri_data%kp_cost(natom, natom, nimg))
199 16566 : ri_data%kp_cost = 0.0_dp
200 :
201 : !We store the density and KS matrix in tensor format
202 88 : nspins = dft_control%nspins
203 12124 : ALLOCATE (ri_data%rho_ao_t(nspins, nimg), ri_data%ks_t(nspins, nimg))
204 : CALL create_2c_tensor(ri_data%rho_ao_t(1, 1), dist1, dist2, ri_data%pgrid_2d, &
205 : ri_data%bsizes_AO_split, ri_data%bsizes_AO_split, &
206 88 : name="(AO | AO)")
207 88 : DEALLOCATE (dist1, dist2)
208 :
209 88 : CALL dbt_create(dbcsr_template, ri_data%ks_t(1, 1))
210 :
211 88 : IF (nspins == 2) THEN
212 26 : CALL dbt_create(ri_data%rho_ao_t(1, 1), ri_data%rho_ao_t(2, 1))
213 26 : CALL dbt_create(ri_data%ks_t(1, 1), ri_data%ks_t(2, 1))
214 : END IF
215 2354 : DO i_img = 2, nimg
216 4980 : DO i_spin = 1, nspins
217 2626 : CALL dbt_create(ri_data%rho_ao_t(1, 1), ri_data%rho_ao_t(i_spin, i_img))
218 4892 : CALL dbt_create(ri_data%ks_t(1, 1), ri_data%ks_t(i_spin, i_img))
219 : END DO
220 : END DO
221 :
222 88 : END SUBROUTINE adapt_ri_data_to_kp
223 :
224 : ! **************************************************************************************************
225 : !> \brief The pre-scf steps for RI-HFX k-points calculation. Namely the calculation of the integrals
226 : !> \param dbcsr_template ...
227 : !> \param ri_data ...
228 : !> \param qs_env ...
229 : ! **************************************************************************************************
230 88 : SUBROUTINE hfx_ri_pre_scf_kp(dbcsr_template, ri_data, qs_env)
231 : TYPE(dbcsr_type), INTENT(INOUT) :: dbcsr_template
232 : TYPE(hfx_ri_type), INTENT(INOUT) :: ri_data
233 : TYPE(qs_environment_type), POINTER :: qs_env
234 :
235 : CHARACTER(LEN=*), PARAMETER :: routineN = 'hfx_ri_pre_scf_kp'
236 :
237 : INTEGER :: handle, i_img, iatom, natom, nimg, nkind
238 88 : TYPE(dbcsr_type), ALLOCATABLE, DIMENSION(:) :: t_2c_op_pot, t_2c_op_RI
239 88 : TYPE(dbt_type), ALLOCATABLE, DIMENSION(:, :) :: t_3c_int
240 : TYPE(dft_control_type), POINTER :: dft_control
241 :
242 88 : NULLIFY (dft_control)
243 :
244 88 : CALL timeset(routineN, handle)
245 :
246 88 : CALL get_qs_env(qs_env, dft_control=dft_control, natom=natom, nkind=nkind)
247 :
248 88 : CALL cleanup_kp(ri_data)
249 :
250 : !We do all the checks on what we allow in this initial implementation
251 88 : IF (ri_data%flavor /= ri_pmat) CPABORT("K-points RI-HFX only with RHO flavor")
252 88 : IF (ri_data%same_op) ri_data%same_op = .FALSE. !force the full calculation with RI metric
253 88 : IF (ABS(ri_data%eps_pgf_orb - dft_control%qs_control%eps_pgf_orb) > 1.0E-16_dp) THEN
254 0 : CPABORT("RI%EPS_PGF_ORB and QS%EPS_PGF_ORB must be identical for RI-HFX k-points")
255 : END IF
256 :
257 88 : CALL get_kp_and_ri_images(ri_data, qs_env)
258 88 : nimg = ri_data%nimg
259 :
260 : !Calculate the integrals
261 5060 : ALLOCATE (t_2c_op_pot(nimg), t_2c_op_RI(nimg))
262 5676 : ALLOCATE (t_3c_int(1, nimg))
263 88 : CALL hfx_ri_pre_scf_calc_tensors(qs_env, ri_data, t_2c_op_RI, t_2c_op_pot, t_3c_int, do_kpoints=.TRUE.)
264 :
265 : !Make sure the internals have the k-point format
266 88 : CALL adapt_ri_data_to_kp(dbcsr_template, ri_data, qs_env)
267 :
268 : !For each atom i, we calculate the inverse RI metric (P^0 | Q^0)^-1 without external bumping yet
269 : !Also store the off-diagonal integrals of the RI metric in case of forces, bumped from the left
270 264 : DO iatom = 1, natom
271 : CALL get_ext_2c_int(ri_data%t_2c_inv(1, iatom), t_2c_op_RI, iatom, iatom, 1, ri_data, qs_env, &
272 176 : do_inverse=.TRUE.)
273 : !for the forces:
274 : !off-diagonl RI metric bumped from the left
275 : CALL get_ext_2c_int(ri_data%t_2c_int(1, iatom), t_2c_op_RI, iatom, iatom, 1, ri_data, &
276 176 : qs_env, off_diagonal=.TRUE.)
277 176 : CALL apply_bump(ri_data%t_2c_int(1, iatom), iatom, ri_data, qs_env, from_left=.TRUE., from_right=.FALSE.)
278 :
279 : !RI metric with bumped off-diagonal blocks (but not inverted), depumed from left and right
280 : CALL get_ext_2c_int(ri_data%t_2c_pot(1, iatom), t_2c_op_RI, iatom, iatom, 1, ri_data, qs_env, &
281 176 : do_inverse=.TRUE., skip_inverse=.TRUE.)
282 : CALL apply_bump(ri_data%t_2c_pot(1, iatom), iatom, ri_data, qs_env, from_left=.TRUE., &
283 264 : from_right=.TRUE., debump=.TRUE.)
284 :
285 : END DO
286 :
287 2442 : DO i_img = 1, nimg
288 2442 : CALL dbcsr_release(t_2c_op_RI(i_img))
289 : END DO
290 :
291 4884 : ALLOCATE (ri_data%kp_mat_2c_pot(1, nimg))
292 2442 : DO i_img = 1, nimg
293 2354 : CALL dbcsr_create(ri_data%kp_mat_2c_pot(1, i_img), template=t_2c_op_pot(i_img))
294 2354 : CALL dbcsr_copy(ri_data%kp_mat_2c_pot(1, i_img), t_2c_op_pot(i_img))
295 2442 : CALL dbcsr_release(t_2c_op_pot(i_img))
296 : END DO
297 :
298 : !reorder the 3c integrals such that empty images are bunched up together
299 88 : CALL reorder_3c_ints(t_3c_int(1, :), ri_data)
300 :
301 : !Pre-contract all 3c integrals with the bumped inverse RI metric (P^0|Q^0)^-1,
302 : !and store in ri_data%t_3c_int_ctr_1
303 88 : CALL precontract_3c_ints(t_3c_int, ri_data, qs_env)
304 :
305 88 : CALL timestop(handle)
306 :
307 2530 : END SUBROUTINE hfx_ri_pre_scf_kp
308 :
309 : ! **************************************************************************************************
310 : !> \brief clean-up the KP specific data from ri_data
311 : !> \param ri_data ...
312 : ! **************************************************************************************************
313 88 : SUBROUTINE cleanup_kp(ri_data)
314 : TYPE(hfx_ri_type), INTENT(INOUT) :: ri_data
315 :
316 : INTEGER :: i, j
317 :
318 88 : IF (ALLOCATED(ri_data%kp_cost)) DEALLOCATE (ri_data%kp_cost)
319 88 : IF (ALLOCATED(ri_data%idx_to_img)) DEALLOCATE (ri_data%idx_to_img)
320 88 : IF (ALLOCATED(ri_data%img_to_idx)) DEALLOCATE (ri_data%img_to_idx)
321 88 : IF (ALLOCATED(ri_data%present_images)) DEALLOCATE (ri_data%present_images)
322 88 : IF (ALLOCATED(ri_data%img_to_RI_cell)) DEALLOCATE (ri_data%img_to_RI_cell)
323 88 : IF (ALLOCATED(ri_data%RI_cell_to_img)) DEALLOCATE (ri_data%RI_cell_to_img)
324 :
325 88 : IF (ALLOCATED(ri_data%kp_mat_2c_pot)) THEN
326 870 : DO j = 1, SIZE(ri_data%kp_mat_2c_pot, 2)
327 1712 : DO i = 1, SIZE(ri_data%kp_mat_2c_pot, 1)
328 1684 : CALL dbcsr_release(ri_data%kp_mat_2c_pot(i, j))
329 : END DO
330 : END DO
331 28 : DEALLOCATE (ri_data%kp_mat_2c_pot)
332 : END IF
333 :
334 88 : IF (ALLOCATED(ri_data%kp_t_3c_int)) THEN
335 870 : DO i = 1, SIZE(ri_data%kp_t_3c_int)
336 870 : CALL dbt_destroy(ri_data%kp_t_3c_int(i))
337 : END DO
338 870 : DEALLOCATE (ri_data%kp_t_3c_int)
339 : END IF
340 :
341 88 : IF (ALLOCATED(ri_data%t_2c_inv)) THEN
342 204 : DO j = 1, SIZE(ri_data%t_2c_inv, 2)
343 320 : DO i = 1, SIZE(ri_data%t_2c_inv, 1)
344 232 : CALL dbt_destroy(ri_data%t_2c_inv(i, j))
345 : END DO
346 : END DO
347 204 : DEALLOCATE (ri_data%t_2c_inv)
348 : END IF
349 :
350 88 : IF (ALLOCATED(ri_data%t_2c_int)) THEN
351 204 : DO j = 1, SIZE(ri_data%t_2c_int, 2)
352 320 : DO i = 1, SIZE(ri_data%t_2c_int, 1)
353 232 : CALL dbt_destroy(ri_data%t_2c_int(i, j))
354 : END DO
355 : END DO
356 204 : DEALLOCATE (ri_data%t_2c_int)
357 : END IF
358 :
359 88 : IF (ALLOCATED(ri_data%t_2c_pot)) THEN
360 204 : DO j = 1, SIZE(ri_data%t_2c_pot, 2)
361 320 : DO i = 1, SIZE(ri_data%t_2c_pot, 1)
362 232 : CALL dbt_destroy(ri_data%t_2c_pot(i, j))
363 : END DO
364 : END DO
365 204 : DEALLOCATE (ri_data%t_2c_pot)
366 : END IF
367 :
368 88 : IF (ALLOCATED(ri_data%t_3c_int_ctr_1)) THEN
369 990 : DO j = 1, SIZE(ri_data%t_3c_int_ctr_1, 2)
370 1892 : DO i = 1, SIZE(ri_data%t_3c_int_ctr_1, 1)
371 1804 : CALL dbt_destroy(ri_data%t_3c_int_ctr_1(i, j))
372 : END DO
373 : END DO
374 990 : DEALLOCATE (ri_data%t_3c_int_ctr_1)
375 : END IF
376 :
377 88 : IF (ALLOCATED(ri_data%t_3c_int_ctr_2)) THEN
378 176 : DO j = 1, SIZE(ri_data%t_3c_int_ctr_2, 2)
379 264 : DO i = 1, SIZE(ri_data%t_3c_int_ctr_2, 1)
380 176 : CALL dbt_destroy(ri_data%t_3c_int_ctr_2(i, j))
381 : END DO
382 : END DO
383 176 : DEALLOCATE (ri_data%t_3c_int_ctr_2)
384 : END IF
385 :
386 88 : IF (ALLOCATED(ri_data%rho_ao_t)) THEN
387 990 : DO j = 1, SIZE(ri_data%rho_ao_t, 2)
388 2134 : DO i = 1, SIZE(ri_data%rho_ao_t, 1)
389 2046 : CALL dbt_destroy(ri_data%rho_ao_t(i, j))
390 : END DO
391 : END DO
392 1232 : DEALLOCATE (ri_data%rho_ao_t)
393 : END IF
394 :
395 88 : IF (ALLOCATED(ri_data%ks_t)) THEN
396 990 : DO j = 1, SIZE(ri_data%ks_t, 2)
397 2134 : DO i = 1, SIZE(ri_data%ks_t, 1)
398 2046 : CALL dbt_destroy(ri_data%ks_t(i, j))
399 : END DO
400 : END DO
401 1232 : DEALLOCATE (ri_data%ks_t)
402 : END IF
403 :
404 88 : END SUBROUTINE cleanup_kp
405 :
406 : ! **************************************************************************************************
407 : !> \brief Prints a progress bar for the k-point RI-HFX triple loop
408 : !> \param b_img ...
409 : !> \param nimg ...
410 : !> \param iprint ...
411 : !> \param ri_data ...
412 : ! **************************************************************************************************
413 0 : SUBROUTINE print_progress_bar(b_img, nimg, iprint, ri_data)
414 : INTEGER, INTENT(IN) :: b_img, nimg
415 : INTEGER, INTENT(INOUT) :: iprint
416 : TYPE(hfx_ri_type), INTENT(INOUT) :: ri_data
417 :
418 : CHARACTER(LEN=default_string_length) :: bar
419 : INTEGER :: rep
420 :
421 0 : IF (ri_data%unit_nr > 0) THEN
422 0 : IF (b_img == 1) THEN
423 0 : WRITE (ri_data%unit_nr, '(/T6,A)', advance="no") '[-'
424 0 : CALL m_flush(ri_data%unit_nr)
425 : END IF
426 0 : IF (b_img > iprint*nimg/71) THEN
427 0 : rep = MAX(1, 71/nimg)
428 0 : bar = REPEAT("-", rep)
429 0 : WRITE (ri_data%unit_nr, '(A)', advance="no") TRIM(bar)
430 0 : CALL m_flush(ri_data%unit_nr)
431 0 : iprint = iprint + 1
432 : END IF
433 0 : IF (b_img == nimg) THEN
434 0 : rep = MAX(0, 1 + 71 - iprint*rep)
435 0 : bar = REPEAT("-", rep)
436 0 : WRITE (ri_data%unit_nr, '(A,A)') TRIM(bar), '-]'
437 0 : CALL m_flush(ri_data%unit_nr)
438 : END IF
439 : END IF
440 :
441 0 : END SUBROUTINE print_progress_bar
442 :
443 : ! **************************************************************************************************
444 : !> \brief Update the KS matrices for each real-space image
445 : !> \param qs_env ...
446 : !> \param ri_data ...
447 : !> \param ks_matrix ...
448 : !> \param ehfx ...
449 : !> \param rho_ao ...
450 : !> \param geometry_did_change ...
451 : !> \param nspins ...
452 : !> \param hf_fraction ...
453 : ! **************************************************************************************************
454 274 : SUBROUTINE hfx_ri_update_ks_kp(qs_env, ri_data, ks_matrix, ehfx, rho_ao, &
455 : geometry_did_change, nspins, hf_fraction)
456 :
457 : TYPE(qs_environment_type), POINTER :: qs_env
458 : TYPE(hfx_ri_type), INTENT(INOUT) :: ri_data
459 : TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: ks_matrix
460 : REAL(KIND=dp), INTENT(OUT) :: ehfx
461 : TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: rho_ao
462 : LOGICAL, INTENT(IN) :: geometry_did_change
463 : INTEGER, INTENT(IN) :: nspins
464 : REAL(KIND=dp), INTENT(IN) :: hf_fraction
465 :
466 : CHARACTER(LEN=*), PARAMETER :: routineN = 'hfx_ri_update_ks_kp'
467 :
468 : INTEGER :: b_img, batch_size, group_size, handle, handle2, i_batch, i_img, i_spin, iatom, &
469 : iblk, igroup, iprint, jatom, mb_img, n_batch_nze, n_nze, natom, ngroups, nimg, nimg_nze
470 : INTEGER(int_8) :: mem, nflop, nze
471 274 : INTEGER, ALLOCATABLE, DIMENSION(:) :: batch_ranges_at, batch_ranges_nze, &
472 274 : idx_to_at_AO
473 274 : INTEGER, ALLOCATABLE, DIMENSION(:, :) :: iapc_pairs
474 274 : INTEGER, ALLOCATABLE, DIMENSION(:, :, :) :: sparsity_pattern
475 : LOGICAL :: estimate_mem, print_progress, use_delta_p
476 : REAL(dp) :: etmp, fac, occ, pfac, pref, t1, t2, t3, &
477 : t4
478 : TYPE(cp_blacs_env_type), POINTER :: blacs_env_sub
479 : TYPE(dbcsr_type) :: ks_desymm, rho_desymm, tmp
480 274 : TYPE(dbcsr_type), ALLOCATABLE, DIMENSION(:) :: mat_2c_pot
481 : TYPE(dbcsr_type), POINTER :: dbcsr_template
482 274 : TYPE(dbt_type), ALLOCATABLE, DIMENSION(:) :: ks_t_split, t_2c_ao_tmp, t_2c_work, &
483 274 : t_3c_int, t_3c_work_2, t_3c_work_3
484 274 : TYPE(dbt_type), ALLOCATABLE, DIMENSION(:, :) :: ks_t, ks_t_sub, t_3c_apc, t_3c_apc_sub
485 : TYPE(mp_para_env_type), POINTER :: para_env, para_env_sub
486 : TYPE(section_vals_type), POINTER :: hfx_section, print_section
487 :
488 274 : NULLIFY (para_env, para_env_sub, blacs_env_sub, hfx_section, dbcsr_template, print_section)
489 :
490 274 : CALL cite_reference(Bussy2024)
491 :
492 274 : CALL timeset(routineN, handle)
493 :
494 274 : CALL get_qs_env(qs_env, para_env=para_env, natom=natom)
495 :
496 274 : IF (nspins == 1) THEN
497 190 : fac = 0.5_dp*hf_fraction
498 : ELSE
499 84 : fac = 1.0_dp*hf_fraction
500 : END IF
501 :
502 274 : hfx_section => section_vals_get_subs_vals(qs_env%input, "DFT%XC%HF%RI")
503 274 : CALL section_vals_val_get(hfx_section, "KP_NGROUPS", i_val=ngroups)
504 274 : CALL section_vals_val_get(hfx_section, "KP_STACK_SIZE", i_val=batch_size)
505 274 : CALL section_vals_val_get(hfx_section, "KP_USE_DELTA_P", l_val=use_delta_p)
506 274 : ri_data%kp_stack_size = batch_size
507 274 : ri_data%kp_ngroups = ngroups
508 :
509 274 : IF (geometry_did_change) THEN
510 88 : CALL hfx_ri_pre_scf_kp(ks_matrix(1, 1)%matrix, ri_data, qs_env)
511 : END IF
512 274 : nimg = ri_data%nimg
513 274 : nimg_nze = ri_data%nimg_nze
514 :
515 : !We need to calculate the KS matrix for each periodic cell with index b: F_mu^0,nu^b
516 : !F_mu^0,nu^b = -0.5 sum_a,c P_sigma^0,lambda^c (mu^0, sigma^a| P^0) V_P^0,Q^b (Q^b| nu^b lambda^a+c)
517 : !with V_P^0,Q^b = (P^0|R^0)^-1 * (R^0|S^b) * (S^b|Q^b)^-1
518 :
519 : !We use a local RI basis set for each atom in the system, which inlcudes RI basis elements for
520 : !each neighboring atom standing within the KIND radius (decay of Gaussian with smallest exponent)
521 :
522 : !We also limit the number of periodic images we consider accorrding to the HFX potentail in the
523 : !RI basis, because if V_P^0,Q^b is zero everywhere, then image b can be ignored (RI basis less diffuse)
524 :
525 : !We manage to calculate each KS matrix doing a double loop on iamges, and a double loop on atoms
526 : !First, we pre-contract and store P_sigma^0,lambda^c (mu^0, sigma^a| P^0) (P^0|R^0)^-1 into T_mu^0,lambda^a+c,P^0
527 : !Then, we loop over b_img, iatom, jatom to get (R^0|S^b)
528 : !Finally, we do an additional loop over a+c images where we do (R^0|S^b) (S^b|Q^b)^-1 (Q^b| nu^b lambda^a+c)
529 : !and the final contraction with T_mu^0,lambda^a+c,P^0
530 :
531 : !Note that the 3-center integrals are pre-contracted with the RI metric, and that the same tensor can be used
532 : !(mu^0, sigma^a| P^0) (P^0|R^0) <===> (S^b|Q^b)^-1 (Q^b| nu^b lambda^a+c) by relabelling the images
533 :
534 : !By default, build the density tensor based on the difference of this SCF P and that of the prev. SCF
535 274 : pfac = -1.0_dp
536 274 : IF (.NOT. use_delta_p) pfac = 0.0_dp
537 274 : CALL get_pmat_images(ri_data%rho_ao_t, rho_ao, pfac, ri_data, qs_env)
538 :
539 274 : n_nze = 0
540 8162 : DO i_img = 1, nimg
541 17616 : DO i_spin = 1, nspins
542 9454 : CALL get_tensor_occupancy(ri_data%rho_ao_t(i_spin, i_img), nze, occ)
543 17342 : IF (nze > 0) THEN
544 7382 : n_nze = n_nze + 1
545 : END IF
546 : END DO
547 : END DO
548 274 : IF (n_nze == nspins) THEN
549 36 : CPWARN("It is highly recommended to restart from a converged GGA K-point calculations.")
550 : END IF
551 :
552 20630 : ALLOCATE (ks_t(nspins, nimg))
553 8162 : DO i_img = 1, nimg
554 17616 : DO i_spin = 1, nspins
555 17342 : CALL dbt_create(ri_data%ks_t(1, 1), ks_t(i_spin, i_img))
556 : END DO
557 : END DO
558 :
559 822 : ALLOCATE (idx_to_at_AO(SIZE(ri_data%bsizes_AO_split)))
560 274 : CALL get_idx_to_atom(idx_to_at_AO, ri_data%bsizes_AO_split, ri_data%bsizes_AO)
561 :
562 : !First we calculate and store T^1_mu^0,lambda^a+c,P = P_mu^0,lambda^c * (mu_0 sigma^a | P^0) (P^0|R^0)^-1
563 : !To avoid doing nimg**2 tiny contractions that do not scale well with a large number of CPUs,
564 : !we instead do a single loop over the a+c image index. For each a+c, we get a list of allowed
565 : !combination of a,c indices. Then we build TAS tensors P_mu^0,lambda^c with all concerned c's
566 : !and (mu^0 sigma^a | P^0)*(P^0|R^0)^-1 with all a's. Then we perform a single contraction with larger tensors,
567 : !were the sum over a,c is automatically taken care of
568 20356 : ALLOCATE (t_3c_apc(nspins, nimg))
569 8162 : DO i_img = 1, nimg
570 17616 : DO i_spin = 1, nspins
571 17342 : CALL dbt_create(ri_data%t_3c_int_ctr_2(1, 1), t_3c_apc(i_spin, i_img))
572 : END DO
573 : END DO
574 274 : CALL contract_pmat_3c(t_3c_apc, ri_data%rho_ao_t, ri_data, qs_env)
575 :
576 274 : IF (MOD(para_env%num_pe, ngroups) /= 0) THEN
577 0 : CPWARN("KP_NGROUPS must be an integer divisor of the total number of MPI ranks. It was set to 1.")
578 0 : ngroups = 1
579 0 : CALL section_vals_val_set(hfx_section, "KP_NGROUPS", i_val=ngroups)
580 : END IF
581 274 : IF ((MOD(ngroups, natom) /= 0) .AND. (MOD(natom, ngroups) /= 0) .AND. geometry_did_change) THEN
582 0 : IF (ngroups > 1) THEN
583 0 : CPWARN("Better load balancing is reached if NGROUPS is a multiple/divisor of the number of atoms")
584 : END IF
585 : END IF
586 274 : group_size = para_env%num_pe/ngroups
587 274 : igroup = para_env%mepos/group_size
588 :
589 274 : ALLOCATE (para_env_sub)
590 274 : CALL para_env_sub%from_split(para_env, igroup)
591 274 : CALL cp_blacs_env_create(blacs_env_sub, para_env_sub)
592 :
593 : ! The sparsity pattern of each iatom, jatom pair, on each b_img, and on which subgroup
594 1370 : ALLOCATE (sparsity_pattern(natom, natom, nimg))
595 274 : CALL get_sparsity_pattern(sparsity_pattern, ri_data, qs_env)
596 274 : CALL get_sub_dist(sparsity_pattern, ngroups, ri_data)
597 :
598 : !Get all the required tensors in the subgroups
599 37012 : ALLOCATE (mat_2c_pot(nimg), ks_t_sub(nspins, nimg), t_2c_ao_tmp(1), ks_t_split(2), t_2c_work(3))
600 : CALL get_subgroup_2c_tensors(mat_2c_pot, t_2c_work, t_2c_ao_tmp, ks_t_split, ks_t_sub, &
601 274 : group_size, ngroups, para_env, para_env_sub, ri_data)
602 :
603 37286 : ALLOCATE (t_3c_int(nimg), t_3c_apc_sub(nspins, nimg), t_3c_work_2(3), t_3c_work_3(3))
604 : CALL get_subgroup_3c_tensors(t_3c_int, t_3c_work_2, t_3c_work_3, t_3c_apc, t_3c_apc_sub, &
605 274 : group_size, ngroups, para_env, para_env_sub, ri_data)
606 :
607 : !We go atom by atom, therefore there is an automatic batching along that direction
608 : !Also, because we stack the 3c tensors nimg times, we naturally do some batching there too
609 822 : ALLOCATE (batch_ranges_at(natom + 1))
610 274 : batch_ranges_at(natom + 1) = SIZE(ri_data%bsizes_AO_split) + 1
611 274 : iatom = 0
612 1240 : DO iblk = 1, SIZE(ri_data%bsizes_AO_split)
613 1240 : IF (idx_to_at_AO(iblk) == iatom + 1) THEN
614 548 : iatom = iatom + 1
615 548 : batch_ranges_at(iatom) = iblk
616 : END IF
617 : END DO
618 :
619 274 : n_batch_nze = nimg_nze/batch_size
620 274 : IF (MODULO(nimg_nze, batch_size) /= 0) n_batch_nze = n_batch_nze + 1
621 822 : ALLOCATE (batch_ranges_nze(n_batch_nze + 1))
622 668 : DO i_batch = 1, n_batch_nze
623 668 : batch_ranges_nze(i_batch) = (i_batch - 1)*batch_size + 1
624 : END DO
625 274 : batch_ranges_nze(n_batch_nze + 1) = nimg_nze + 1
626 :
627 274 : print_section => section_vals_get_subs_vals(qs_env%input, "DFT%XC%HF%RI%PRINT")
628 274 : CALL section_vals_val_get(print_section, "KP_RI_PROGRESS_BAR", l_val=print_progress)
629 274 : CALL section_vals_val_get(print_section, "KP_RI_MEMORY_ESTIMATE", l_val=estimate_mem)
630 :
631 822 : ALLOCATE (iapc_pairs(nimg, 2))
632 274 : IF (estimate_mem .AND. geometry_did_change) THEN
633 : !Populate work tensors to simulate maximum usage
634 0 : CALL get_iapc_pairs(iapc_pairs, 1, ri_data, qs_env)
635 : CALL fill_3c_stack(t_3c_work_3(1), t_3c_int, iapc_pairs(:, 1), 3, ri_data, &
636 : filter_at=1, filter_dim=2, idx_to_at=idx_to_at_AO, &
637 0 : img_bounds=[batch_ranges_nze(1), batch_ranges_nze(2)])
638 : CALL fill_3c_stack(t_3c_work_3(2), t_3c_int, iapc_pairs(:, 1), 3, ri_data, &
639 : filter_at=1, filter_dim=2, idx_to_at=idx_to_at_AO, &
640 0 : img_bounds=[batch_ranges_nze(1), batch_ranges_nze(2)])
641 : CALL fill_3c_stack(t_3c_work_2(1), t_3c_apc_sub(1, :), iapc_pairs(:, 2), 3, &
642 : ri_data, filter_at=1, filter_dim=1, idx_to_at=idx_to_at_AO, &
643 0 : img_bounds=[batch_ranges_nze(1), batch_ranges_nze(2)])
644 : CALL fill_3c_stack(t_3c_work_2(2), t_3c_apc_sub(1, :), iapc_pairs(:, 2), 3, &
645 : ri_data, filter_at=1, filter_dim=1, idx_to_at=idx_to_at_AO, &
646 0 : img_bounds=[batch_ranges_nze(1), batch_ranges_nze(2)])
647 : CALL get_ext_2c_int(t_2c_work(1), mat_2c_pot, 1, 1, 1, ri_data, qs_env, &
648 : blacs_env_ext=blacs_env_sub, para_env_ext=para_env_sub, &
649 0 : dbcsr_template=dbcsr_template)
650 0 : CALL m_memory(mem)
651 0 : CALL para_env%max(mem)
652 0 : CALL dbt_clear(t_3c_work_2(1))
653 0 : CALL dbt_clear(t_3c_work_2(2))
654 0 : CALL dbt_clear(t_3c_work_3(1))
655 0 : CALL dbt_clear(t_3c_work_3(2))
656 0 : CALL dbt_clear(t_2c_work(1))
657 :
658 0 : IF (ri_data%unit_nr > 0) THEN
659 : WRITE (ri_data%unit_nr, FMT="(T3,A,I14)") &
660 0 : "KP-HFX_RI_INFO| Estimated peak memory usage per MPI rank (MiB):", mem/(1024*1024)
661 0 : CALL m_flush(ri_data%unit_nr)
662 : END IF
663 : END IF
664 :
665 274 : CALL dbt_batched_contract_init(t_3c_work_3(1), batch_range_2=batch_ranges_at)
666 274 : CALL dbt_batched_contract_init(t_3c_work_3(2), batch_range_2=batch_ranges_at)
667 274 : CALL dbt_batched_contract_init(t_3c_work_2(1), batch_range_1=batch_ranges_at)
668 274 : CALL dbt_batched_contract_init(t_3c_work_2(2), batch_range_1=batch_ranges_at)
669 :
670 274 : iprint = 1
671 274 : t1 = m_walltime()
672 55490 : ri_data%kp_cost(:, :, :) = 0.0_dp
673 8162 : DO b_img = 1, nimg
674 7888 : IF (print_progress) CALL print_progress_bar(b_img, nimg, iprint, ri_data)
675 7888 : CALL dbt_batched_contract_init(ks_t_split(1))
676 7888 : CALL dbt_batched_contract_init(ks_t_split(2))
677 23664 : DO jatom = 1, natom
678 55216 : DO iatom = 1, natom
679 31552 : IF (.NOT. sparsity_pattern(iatom, jatom, b_img) == igroup) CYCLE
680 5163 : pref = 1.0_dp
681 5163 : IF (iatom == jatom .AND. b_img == 1) pref = 0.5_dp
682 :
683 : !measure the cost of the given i, j, b configuration
684 5163 : t3 = m_walltime()
685 :
686 : !Get the proper HFX potential 2c integrals (R_i^0|S_j^b)
687 5163 : CALL timeset(routineN//"_2c", handle2)
688 : CALL get_ext_2c_int(t_2c_work(1), mat_2c_pot, iatom, jatom, b_img, ri_data, qs_env, &
689 : blacs_env_ext=blacs_env_sub, para_env_ext=para_env_sub, &
690 5163 : dbcsr_template=dbcsr_template)
691 5163 : CALL dbt_copy(t_2c_work(1), t_2c_work(2), move_data=.TRUE.) !move to split blocks
692 5163 : CALL dbt_filter(t_2c_work(2), ri_data%filter_eps)
693 5163 : CALL timestop(handle2)
694 :
695 5163 : CALL dbt_batched_contract_init(t_2c_work(2))
696 5163 : CALL get_iapc_pairs(iapc_pairs, b_img, ri_data, qs_env)
697 5163 : CALL timeset(routineN//"_3c", handle2)
698 :
699 : !Stack the (S^b|Q^b)^-1 * (Q^b| nu^b lambda^a+c) integrals over a+c and multiply by (R_i^0|S_j^b)
700 13932 : DO i_batch = 1, n_batch_nze
701 : CALL fill_3c_stack(t_3c_work_3(3), t_3c_int, iapc_pairs(:, 1), 3, ri_data, &
702 : filter_at=jatom, filter_dim=2, idx_to_at=idx_to_at_AO, &
703 26307 : img_bounds=[batch_ranges_nze(i_batch), batch_ranges_nze(i_batch + 1)])
704 8769 : CALL dbt_copy(t_3c_work_3(3), t_3c_work_3(1), move_data=.TRUE.)
705 :
706 : CALL dbt_contract(1.0_dp, t_2c_work(2), t_3c_work_3(1), &
707 : 0.0_dp, t_3c_work_3(2), map_1=[1], map_2=[2, 3], &
708 : contract_1=[2], notcontract_1=[1], &
709 : contract_2=[1], notcontract_2=[2, 3], &
710 8769 : filter_eps=ri_data%filter_eps, flop=nflop)
711 8769 : ri_data%dbcsr_nflop = ri_data%dbcsr_nflop + nflop
712 8769 : CALL dbt_copy(t_3c_work_3(2), t_3c_work_2(2), order=[2, 1, 3], move_data=.TRUE.)
713 8769 : CALL dbt_copy(t_3c_work_3(3), t_3c_work_3(1))
714 :
715 : !Stack the P_sigma^a,lambda^a+c * (mu^0 sigma^a | P^0)*(P^0|R^0)^-1 integrals over a+c and contract
716 : !to get the final block of the KS matrix
717 24709 : DO i_spin = 1, nspins
718 : CALL fill_3c_stack(t_3c_work_2(3), t_3c_apc_sub(i_spin, :), iapc_pairs(:, 2), 3, &
719 : ri_data, filter_at=iatom, filter_dim=1, idx_to_at=idx_to_at_AO, &
720 32331 : img_bounds=[batch_ranges_nze(i_batch), batch_ranges_nze(i_batch + 1)])
721 10777 : CALL get_tensor_occupancy(t_3c_work_2(3), nze, occ)
722 :
723 10777 : IF (nze == 0) CYCLE
724 10485 : CALL dbt_copy(t_3c_work_2(3), t_3c_work_2(1), move_data=.TRUE.)
725 : CALL dbt_contract(-pref*fac, t_3c_work_2(1), t_3c_work_2(2), &
726 : 1.0_dp, ks_t_split(i_spin), map_1=[1], map_2=[2], &
727 : contract_1=[2, 3], notcontract_1=[1], &
728 : contract_2=[2, 3], notcontract_2=[1], &
729 : filter_eps=ri_data%filter_eps, &
730 10485 : move_data=i_spin == nspins, flop=nflop)
731 30031 : ri_data%dbcsr_nflop = ri_data%dbcsr_nflop + nflop
732 : END DO
733 : END DO !i_batch
734 5163 : CALL timestop(handle2)
735 5163 : CALL dbt_batched_contract_finalize(t_2c_work(2))
736 :
737 5163 : t4 = m_walltime()
738 57654 : ri_data%kp_cost(iatom, jatom, b_img) = t4 - t3
739 : END DO !iatom
740 : END DO !jatom
741 7888 : CALL dbt_batched_contract_finalize(ks_t_split(1))
742 7888 : CALL dbt_batched_contract_finalize(ks_t_split(2))
743 :
744 17616 : DO i_spin = 1, nspins
745 9454 : CALL dbt_copy(ks_t_split(i_spin), t_2c_ao_tmp(1), move_data=.TRUE.)
746 17342 : CALL dbt_copy(t_2c_ao_tmp(1), ks_t_sub(i_spin, b_img), summation=.TRUE.)
747 : END DO
748 : END DO !b_img
749 274 : CALL dbt_batched_contract_finalize(t_3c_work_3(1))
750 274 : CALL dbt_batched_contract_finalize(t_3c_work_3(2))
751 274 : CALL dbt_batched_contract_finalize(t_3c_work_2(1))
752 274 : CALL dbt_batched_contract_finalize(t_3c_work_2(2))
753 274 : CALL para_env%sync()
754 274 : CALL para_env%sum(ri_data%dbcsr_nflop)
755 274 : CALL para_env%sum(ri_data%kp_cost)
756 274 : t2 = m_walltime()
757 274 : ri_data%dbcsr_time = ri_data%dbcsr_time + t2 - t1
758 :
759 : !transfer KS tensor from subgroup to main group
760 274 : CALL gather_ks_matrix(ks_t, ks_t_sub, group_size, sparsity_pattern, para_env, ri_data)
761 :
762 : !Keep the 3c integrals on the subgroups to avoid communication at next SCF step
763 8162 : DO i_img = 1, nimg
764 8162 : CALL dbt_copy(t_3c_int(i_img), ri_data%kp_t_3c_int(i_img), move_data=.TRUE.)
765 : END DO
766 :
767 : !clean-up subgroup tensors
768 274 : CALL dbt_destroy(t_2c_ao_tmp(1))
769 274 : CALL dbt_destroy(ks_t_split(1))
770 274 : CALL dbt_destroy(ks_t_split(2))
771 274 : CALL dbt_destroy(t_2c_work(1))
772 274 : CALL dbt_destroy(t_2c_work(2))
773 274 : CALL dbt_destroy(t_3c_work_2(1))
774 274 : CALL dbt_destroy(t_3c_work_2(2))
775 274 : CALL dbt_destroy(t_3c_work_2(3))
776 274 : CALL dbt_destroy(t_3c_work_3(1))
777 274 : CALL dbt_destroy(t_3c_work_3(2))
778 274 : CALL dbt_destroy(t_3c_work_3(3))
779 8162 : DO i_img = 1, nimg
780 7888 : CALL dbt_destroy(t_3c_int(i_img))
781 7888 : CALL dbcsr_release(mat_2c_pot(i_img))
782 17616 : DO i_spin = 1, nspins
783 9454 : CALL dbt_destroy(t_3c_apc_sub(i_spin, i_img))
784 17342 : CALL dbt_destroy(ks_t_sub(i_spin, i_img))
785 : END DO
786 : END DO
787 274 : IF (ASSOCIATED(dbcsr_template)) THEN
788 274 : CALL dbcsr_release(dbcsr_template)
789 274 : DEALLOCATE (dbcsr_template)
790 : END IF
791 :
792 : !End of subgroup parallelization
793 274 : CALL cp_blacs_env_release(blacs_env_sub)
794 274 : CALL para_env_sub%free()
795 274 : DEALLOCATE (para_env_sub)
796 :
797 : !Currently, rho_ao_t holds the density difference (wrt to pref SCF step).
798 : !ks_t also hold that diff, while only having half the blocks => need to add to prev ks_t and symmetrize
799 : !We need the full thing for the energy, on the next SCF step
800 274 : CALL get_pmat_images(ri_data%rho_ao_t, rho_ao, 0.0_dp, ri_data, qs_env)
801 632 : DO i_spin = 1, nspins
802 10086 : DO b_img = 1, nimg
803 9454 : CALL dbt_copy(ks_t(i_spin, b_img), ri_data%ks_t(i_spin, b_img), summation=.TRUE.)
804 :
805 : !desymmetrize
806 9454 : mb_img = get_opp_index(b_img, qs_env)
807 9812 : IF (mb_img > 0 .AND. mb_img <= nimg) THEN
808 8438 : CALL dbt_copy(ks_t(i_spin, mb_img), ri_data%ks_t(i_spin, b_img), order=[2, 1], summation=.TRUE.)
809 : END IF
810 : END DO
811 : END DO
812 8162 : DO b_img = 1, nimg
813 17616 : DO i_spin = 1, nspins
814 17342 : CALL dbt_destroy(ks_t(i_spin, b_img))
815 : END DO
816 : END DO
817 :
818 : !calculate the energy
819 274 : CALL dbt_create(ri_data%ks_t(1, 1), t_2c_ao_tmp(1))
820 274 : CALL dbcsr_create(tmp, template=ks_matrix(1, 1)%matrix, matrix_type=dbcsr_type_symmetric)
821 274 : CALL dbcsr_create(ks_desymm, template=ks_matrix(1, 1)%matrix, matrix_type=dbcsr_type_no_symmetry)
822 274 : CALL dbcsr_create(rho_desymm, template=ks_matrix(1, 1)%matrix, matrix_type=dbcsr_type_no_symmetry)
823 274 : ehfx = 0.0_dp
824 8162 : DO i_img = 1, nimg
825 17616 : DO i_spin = 1, nspins
826 9454 : CALL dbt_filter(ri_data%ks_t(i_spin, i_img), ri_data%filter_eps)
827 9454 : CALL dbt_copy(ri_data%ks_t(i_spin, i_img), t_2c_ao_tmp(1))
828 9454 : CALL dbt_copy_tensor_to_matrix(t_2c_ao_tmp(1), ks_desymm)
829 9454 : CALL dbt_copy_tensor_to_matrix(t_2c_ao_tmp(1), tmp)
830 9454 : CALL dbcsr_add(ks_matrix(i_spin, i_img)%matrix, tmp, 1.0_dp, 1.0_dp)
831 :
832 9454 : CALL dbt_copy(ri_data%rho_ao_t(i_spin, i_img), t_2c_ao_tmp(1))
833 9454 : CALL dbt_copy_tensor_to_matrix(t_2c_ao_tmp(1), rho_desymm)
834 :
835 9454 : CALL dbcsr_dot(ks_desymm, rho_desymm, etmp)
836 9454 : ehfx = ehfx + 0.5_dp*etmp
837 :
838 17342 : IF (.NOT. use_delta_p) CALL dbt_clear(ri_data%ks_t(i_spin, i_img))
839 : END DO
840 : END DO
841 274 : CALL dbcsr_release(rho_desymm)
842 274 : CALL dbcsr_release(ks_desymm)
843 274 : CALL dbcsr_release(tmp)
844 274 : CALL dbt_destroy(t_2c_ao_tmp(1))
845 :
846 274 : CALL timestop(handle)
847 :
848 50362 : END SUBROUTINE hfx_ri_update_ks_kp
849 :
850 : ! **************************************************************************************************
851 : !> \brief Update the K-points RI-HFX forces
852 : !> \param qs_env ...
853 : !> \param ri_data ...
854 : !> \param nspins ...
855 : !> \param hf_fraction ...
856 : !> \param rho_ao ...
857 : !> \param use_virial ...
858 : !> \note Because this routine uses stored quantities calculated in the energy calculation, they should
859 : !> always be called by pairs, and with the same input densities
860 : ! **************************************************************************************************
861 50 : SUBROUTINE hfx_ri_update_forces_kp(qs_env, ri_data, nspins, hf_fraction, rho_ao, use_virial)
862 :
863 : TYPE(qs_environment_type), POINTER :: qs_env
864 : TYPE(hfx_ri_type), INTENT(INOUT) :: ri_data
865 : INTEGER, INTENT(IN) :: nspins
866 : REAL(KIND=dp), INTENT(IN) :: hf_fraction
867 : TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: rho_ao
868 : LOGICAL, INTENT(IN), OPTIONAL :: use_virial
869 :
870 : CHARACTER(LEN=*), PARAMETER :: routineN = 'hfx_ri_update_forces_kp'
871 :
872 : INTEGER :: b_img, batch_size, group_size, handle, handle2, i_batch, i_img, i_loop, i_spin, &
873 : i_xyz, iatom, iblk, igroup, j_xyz, jatom, k_xyz, n_batch, natom, ngroups, nimg, nimg_nze
874 : INTEGER(int_8) :: nflop, nze
875 50 : INTEGER, ALLOCATABLE, DIMENSION(:) :: atom_of_kind, batch_ranges_at, &
876 50 : batch_ranges_nze, dist1, dist2, &
877 50 : i_images, idx_to_at_AO, idx_to_at_RI, &
878 50 : kind_of
879 50 : INTEGER, ALLOCATABLE, DIMENSION(:, :) :: iapc_pairs
880 50 : INTEGER, ALLOCATABLE, DIMENSION(:, :, :) :: force_pattern, sparsity_pattern
881 : INTEGER, DIMENSION(2, 1) :: bounds_iat, bounds_jat
882 : LOGICAL :: use_virial_prv
883 : REAL(dp) :: fac, occ, pref, t1, t2
884 : REAL(dp), DIMENSION(3, 3) :: work_virial
885 50 : TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set
886 : TYPE(cell_type), POINTER :: cell
887 : TYPE(cp_blacs_env_type), POINTER :: blacs_env_sub
888 50 : TYPE(dbcsr_type), ALLOCATABLE, DIMENSION(:) :: mat_2c_pot
889 50 : TYPE(dbcsr_type), ALLOCATABLE, DIMENSION(:, :) :: mat_der_pot, mat_der_pot_sub
890 : TYPE(dbcsr_type), POINTER :: dbcsr_template
891 850 : TYPE(dbt_type) :: t_2c_R, t_2c_R_split
892 50 : TYPE(dbt_type), ALLOCATABLE, DIMENSION(:) :: t_2c_bint, t_2c_binv, t_2c_der_pot, &
893 100 : t_2c_inv, t_2c_metric, t_2c_work, &
894 50 : t_3c_der_stack, t_3c_work_2, &
895 50 : t_3c_work_3
896 50 : TYPE(dbt_type), ALLOCATABLE, DIMENSION(:, :) :: rho_ao_t, rho_ao_t_sub, t_2c_der_metric, &
897 100 : t_2c_der_metric_sub, t_3c_apc, t_3c_apc_sub, t_3c_der_AO, t_3c_der_AO_sub, t_3c_der_RI, &
898 50 : t_3c_der_RI_sub
899 : TYPE(mp_para_env_type), POINTER :: para_env, para_env_sub
900 50 : TYPE(particle_type), DIMENSION(:), POINTER :: particle_set
901 50 : TYPE(qs_force_type), DIMENSION(:), POINTER :: force
902 : TYPE(section_vals_type), POINTER :: hfx_section
903 : TYPE(virial_type), POINTER :: virial
904 :
905 50 : NULLIFY (para_env, para_env_sub, hfx_section, blacs_env_sub, dbcsr_template, force, atomic_kind_set, &
906 50 : virial, particle_set, cell)
907 :
908 50 : CALL timeset(routineN, handle)
909 :
910 50 : use_virial_prv = .FALSE.
911 50 : IF (PRESENT(use_virial)) use_virial_prv = use_virial
912 :
913 50 : IF (nspins == 1) THEN
914 34 : fac = 0.5_dp*hf_fraction
915 : ELSE
916 16 : fac = 1.0_dp*hf_fraction
917 : END IF
918 :
919 : CALL get_qs_env(qs_env, natom=natom, para_env=para_env, force=force, cell=cell, virial=virial, &
920 50 : atomic_kind_set=atomic_kind_set, particle_set=particle_set)
921 50 : CALL get_atomic_kind_set(atomic_kind_set, kind_of=kind_of, atom_of_kind=atom_of_kind)
922 :
923 150 : ALLOCATE (idx_to_at_AO(SIZE(ri_data%bsizes_AO_split)))
924 50 : CALL get_idx_to_atom(idx_to_at_AO, ri_data%bsizes_AO_split, ri_data%bsizes_AO)
925 :
926 150 : ALLOCATE (idx_to_at_RI(SIZE(ri_data%bsizes_RI_split)))
927 50 : CALL get_idx_to_atom(idx_to_at_RI, ri_data%bsizes_RI_split, ri_data%bsizes_RI)
928 :
929 50 : nimg = ri_data%nimg
930 15298 : ALLOCATE (t_3c_der_RI(nimg, 3), t_3c_der_AO(nimg, 3), mat_der_pot(nimg, 3), t_2c_der_metric(natom, 3))
931 :
932 : !We assume that the integrals are available from the SCF
933 : !pre-calculate the derivs. 3c tensors as (P^0| sigma^a mu^0), with t_3c_der_AO holding deriv wrt mu^0
934 50 : CALL precalc_derivatives(t_3c_der_RI, t_3c_der_AO, mat_der_pot, t_2c_der_metric, ri_data, qs_env)
935 :
936 : !Calculate the density matrix at each image
937 3624 : ALLOCATE (rho_ao_t(nspins, nimg))
938 : CALL create_2c_tensor(rho_ao_t(1, 1), dist1, dist2, ri_data%pgrid_2d, &
939 : ri_data%bsizes_AO_split, ri_data%bsizes_AO_split, &
940 50 : name="(AO | AO)")
941 50 : DEALLOCATE (dist1, dist2)
942 50 : IF (nspins == 2) CALL dbt_create(rho_ao_t(1, 1), rho_ao_t(2, 1))
943 1422 : DO i_img = 2, nimg
944 2958 : DO i_spin = 1, nspins
945 2908 : CALL dbt_create(rho_ao_t(1, 1), rho_ao_t(i_spin, i_img))
946 : END DO
947 : END DO
948 50 : CALL get_pmat_images(rho_ao_t, rho_ao, 0.0_dp, ri_data, qs_env)
949 :
950 : !Contract integrals with the density matrix
951 3624 : ALLOCATE (t_3c_apc(nspins, nimg))
952 1472 : DO i_img = 1, nimg
953 3074 : DO i_spin = 1, nspins
954 3024 : CALL dbt_create(ri_data%t_3c_int_ctr_2(1, 1), t_3c_apc(i_spin, i_img))
955 : END DO
956 : END DO
957 50 : CALL contract_pmat_3c(t_3c_apc, rho_ao_t, ri_data, qs_env)
958 :
959 : !Setup the subgroups
960 50 : hfx_section => section_vals_get_subs_vals(qs_env%input, "DFT%XC%HF%RI")
961 50 : CALL section_vals_val_get(hfx_section, "KP_NGROUPS", i_val=ngroups)
962 50 : group_size = para_env%num_pe/ngroups
963 50 : igroup = para_env%mepos/group_size
964 :
965 50 : ALLOCATE (para_env_sub)
966 50 : CALL para_env_sub%from_split(para_env, igroup)
967 50 : CALL cp_blacs_env_create(blacs_env_sub, para_env_sub)
968 :
969 : !Get the ususal sparsity pattern
970 250 : ALLOCATE (sparsity_pattern(natom, natom, nimg))
971 50 : CALL get_sparsity_pattern(sparsity_pattern, ri_data, qs_env)
972 50 : CALL get_sub_dist(sparsity_pattern, ngroups, ri_data)
973 :
974 : !Get the 2-center quantities in the subgroups (note: main group derivs are deleted wihtin)
975 0 : ALLOCATE (t_2c_inv(natom), mat_2c_pot(nimg), rho_ao_t_sub(nspins, nimg), t_2c_work(5), &
976 0 : t_2c_der_metric_sub(natom, 3), mat_der_pot_sub(nimg, 3), t_2c_bint(natom), &
977 13562 : t_2c_metric(natom), t_2c_binv(natom))
978 : CALL get_subgroup_2c_derivs(t_2c_inv, t_2c_bint, t_2c_metric, mat_2c_pot, t_2c_work, rho_ao_t, &
979 : rho_ao_t_sub, t_2c_der_metric, t_2c_der_metric_sub, mat_der_pot, &
980 50 : mat_der_pot_sub, group_size, ngroups, para_env, para_env_sub, ri_data)
981 50 : CALL dbt_create(t_2c_work(1), t_2c_R) !nRI x nRI
982 50 : CALL dbt_create(t_2c_work(5), t_2c_R_split) !nRI x nRI with split blocks
983 :
984 600 : ALLOCATE (t_2c_der_pot(3))
985 200 : DO i_xyz = 1, 3
986 200 : CALL dbt_create(t_2c_R, t_2c_der_pot(i_xyz))
987 : END DO
988 :
989 : !Get the 3-center quantities in the subgroups. The integrals and t_3c_apc already there
990 0 : ALLOCATE (t_3c_work_2(3), t_3c_work_3(4), t_3c_der_stack(6), t_3c_der_AO_sub(nimg, 3), &
991 15206 : t_3c_der_RI_sub(nimg, 3), t_3c_apc_sub(nspins, nimg))
992 : CALL get_subgroup_3c_derivs(t_3c_work_2, t_3c_work_3, t_3c_der_AO, t_3c_der_AO_sub, &
993 : t_3c_der_RI, t_3c_der_RI_sub, t_3c_apc, t_3c_apc_sub, t_3c_der_stack, &
994 50 : group_size, ngroups, para_env, para_env_sub, ri_data)
995 :
996 : !Set up batched contraction (go atom by atom)
997 150 : ALLOCATE (batch_ranges_at(natom + 1))
998 50 : batch_ranges_at(natom + 1) = SIZE(ri_data%bsizes_AO_split) + 1
999 50 : iatom = 0
1000 244 : DO iblk = 1, SIZE(ri_data%bsizes_AO_split)
1001 244 : IF (idx_to_at_AO(iblk) == iatom + 1) THEN
1002 100 : iatom = iatom + 1
1003 100 : batch_ranges_at(iatom) = iblk
1004 : END IF
1005 : END DO
1006 :
1007 50 : CALL dbt_batched_contract_init(t_3c_work_3(1), batch_range_2=batch_ranges_at)
1008 50 : CALL dbt_batched_contract_init(t_3c_work_3(2), batch_range_2=batch_ranges_at)
1009 50 : CALL dbt_batched_contract_init(t_3c_work_3(3), batch_range_2=batch_ranges_at)
1010 50 : CALL dbt_batched_contract_init(t_3c_work_2(1), batch_range_1=batch_ranges_at)
1011 50 : CALL dbt_batched_contract_init(t_3c_work_2(2), batch_range_1=batch_ranges_at)
1012 :
1013 : !Preparing for the stacking of 3c tensors
1014 50 : nimg_nze = ri_data%nimg_nze
1015 50 : batch_size = ri_data%kp_stack_size
1016 50 : n_batch = nimg_nze/batch_size
1017 50 : IF (MODULO(nimg_nze, batch_size) /= 0) n_batch = n_batch + 1
1018 150 : ALLOCATE (batch_ranges_nze(n_batch + 1))
1019 128 : DO i_batch = 1, n_batch
1020 128 : batch_ranges_nze(i_batch) = (i_batch - 1)*batch_size + 1
1021 : END DO
1022 50 : batch_ranges_nze(n_batch + 1) = nimg_nze + 1
1023 :
1024 : !Applying the external bump to ((P|Q)_D + B*(P|Q)_OD*B)^-1 from left and right
1025 : !And keep the bump on LHS only version as well, with B*M^-1 = (M^-1*B)^T
1026 150 : DO iatom = 1, natom
1027 100 : CALL dbt_create(t_2c_inv(iatom), t_2c_binv(iatom))
1028 100 : CALL dbt_copy(t_2c_inv(iatom), t_2c_binv(iatom))
1029 100 : CALL apply_bump(t_2c_binv(iatom), iatom, ri_data, qs_env, from_left=.TRUE., from_right=.FALSE.)
1030 150 : CALL apply_bump(t_2c_inv(iatom), iatom, ri_data, qs_env, from_left=.TRUE., from_right=.TRUE.)
1031 : END DO
1032 :
1033 50 : t1 = m_walltime()
1034 50 : work_virial = 0.0_dp
1035 250 : ALLOCATE (iapc_pairs(nimg, 2), i_images(nimg))
1036 250 : ALLOCATE (force_pattern(natom, natom, nimg))
1037 10004 : force_pattern(:, :, :) = -1
1038 : !We proceed with 2 loops: one over the sparsity pattern from the SCF, one over the rest
1039 : !We use the SCF cost model for the first loop, while we calculate the cost of the upcoming loop
1040 150 : DO i_loop = 1, 2
1041 2944 : DO b_img = 1, nimg
1042 8632 : DO jatom = 1, natom
1043 19908 : DO iatom = 1, natom
1044 :
1045 11376 : pref = -0.5_dp*fac
1046 11376 : IF (i_loop == 1 .AND. (.NOT. sparsity_pattern(iatom, jatom, b_img) == igroup)) CYCLE
1047 6429 : IF (i_loop == 2 .AND. (.NOT. force_pattern(iatom, jatom, b_img) == igroup)) CYCLE
1048 :
1049 : !Get the proper HFX potential 2c integrals (R_i^0|S_j^b), times (S_j^b|Q_j^b)^-1
1050 1414 : CALL timeset(routineN//"_2c_1", handle2)
1051 : CALL get_ext_2c_int(t_2c_work(1), mat_2c_pot, iatom, jatom, b_img, ri_data, qs_env, &
1052 : blacs_env_ext=blacs_env_sub, para_env_ext=para_env_sub, &
1053 1414 : dbcsr_template=dbcsr_template)
1054 : CALL dbt_contract(1.0_dp, t_2c_work(1), t_2c_inv(jatom), &
1055 : 0.0_dp, t_2c_work(2), map_1=[1], map_2=[2], &
1056 : contract_1=[2], notcontract_1=[1], &
1057 : contract_2=[1], notcontract_2=[2], &
1058 1414 : filter_eps=ri_data%filter_eps, flop=nflop)
1059 1414 : CALL dbt_copy(t_2c_work(2), t_2c_work(5), move_data=.TRUE.) !move to split blocks
1060 1414 : CALL dbt_filter(t_2c_work(5), ri_data%filter_eps)
1061 1414 : CALL timestop(handle2)
1062 :
1063 1414 : CALL timeset(routineN//"_3c", handle2)
1064 7056 : bounds_iat(:, 1) = [SUM(ri_data%bsizes_AO(1:iatom - 1)) + 1, SUM(ri_data%bsizes_AO(1:iatom))]
1065 7020 : bounds_jat(:, 1) = [SUM(ri_data%bsizes_AO(1:jatom - 1)) + 1, SUM(ri_data%bsizes_AO(1:jatom))]
1066 1414 : CALL dbt_clear(t_2c_R_split)
1067 :
1068 3089 : DO i_spin = 1, nspins
1069 3089 : CALL dbt_batched_contract_init(rho_ao_t_sub(i_spin, b_img))
1070 : END DO
1071 :
1072 1414 : CALL get_iapc_pairs(iapc_pairs, b_img, ri_data, qs_env, i_images) !i = a+c-b
1073 4147 : DO i_batch = 1, n_batch
1074 :
1075 : !Stack the 3c derivatives to take the trace later on
1076 10932 : DO i_xyz = 1, 3
1077 8199 : CALL dbt_clear(t_3c_der_stack(i_xyz))
1078 : CALL fill_3c_stack(t_3c_der_stack(i_xyz), t_3c_der_RI_sub(:, i_xyz), &
1079 : iapc_pairs(:, 1), 3, ri_data, filter_at=jatom, &
1080 : filter_dim=2, idx_to_at=idx_to_at_AO, &
1081 24597 : img_bounds=[batch_ranges_nze(i_batch), batch_ranges_nze(i_batch + 1)])
1082 :
1083 8199 : CALL dbt_clear(t_3c_der_stack(3 + i_xyz))
1084 : CALL fill_3c_stack(t_3c_der_stack(3 + i_xyz), t_3c_der_AO_sub(:, i_xyz), &
1085 : iapc_pairs(:, 1), 3, ri_data, filter_at=jatom, &
1086 : filter_dim=2, idx_to_at=idx_to_at_AO, &
1087 27330 : img_bounds=[batch_ranges_nze(i_batch), batch_ranges_nze(i_batch + 1)])
1088 : END DO
1089 :
1090 7241 : DO i_spin = 1, nspins
1091 : !stack the t_3c_apc tensors
1092 3094 : CALL dbt_clear(t_3c_work_2(3))
1093 : CALL fill_3c_stack(t_3c_work_2(3), t_3c_apc_sub(i_spin, :), iapc_pairs(:, 2), 3, &
1094 : ri_data, filter_at=iatom, filter_dim=1, idx_to_at=idx_to_at_AO, &
1095 9282 : img_bounds=[batch_ranges_nze(i_batch), batch_ranges_nze(i_batch + 1)])
1096 3094 : CALL get_tensor_occupancy(t_3c_work_2(3), nze, occ)
1097 3094 : IF (nze == 0) CYCLE
1098 3080 : CALL dbt_copy(t_3c_work_2(3), t_3c_work_2(1), move_data=.TRUE.)
1099 :
1100 : !Contract with the second density matrix: P_mu^0,nu^b * t_3c_apc,
1101 : !where t_3c_apc = P_sigma^a,lambda^a+c (mu^0 P^0 sigma^a) *(P^0|R^0)^-1 (stacked along a+c)
1102 : CALL dbt_contract(1.0_dp, rho_ao_t_sub(i_spin, b_img), t_3c_work_2(1), &
1103 : 0.0_dp, t_3c_work_2(2), map_1=[1], map_2=[2, 3], &
1104 : contract_1=[1], notcontract_1=[2], &
1105 : contract_2=[1], notcontract_2=[2, 3], &
1106 : bounds_1=bounds_iat, bounds_2=bounds_jat, &
1107 3080 : filter_eps=ri_data%filter_eps, flop=nflop)
1108 3080 : ri_data%dbcsr_nflop = ri_data%dbcsr_nflop + nflop
1109 :
1110 3080 : CALL get_tensor_occupancy(t_3c_work_2(2), nze, occ)
1111 3080 : IF (nze == 0) CYCLE
1112 :
1113 : !Contract with V_PQ so that we can take the trace with (Q^b|nu^b lmabda^a+c)^(x)
1114 2654 : CALL dbt_copy(t_3c_work_2(2), t_3c_work_3(1), order=[2, 1, 3], move_data=.TRUE.)
1115 2654 : CALL dbt_batched_contract_init(t_2c_work(5))
1116 : CALL dbt_contract(1.0_dp, t_2c_work(5), t_3c_work_3(1), &
1117 : 0.0_dp, t_3c_work_3(2), map_1=[1], map_2=[2, 3], &
1118 : contract_1=[1], notcontract_1=[2], &
1119 : contract_2=[1], notcontract_2=[2, 3], &
1120 2654 : filter_eps=ri_data%filter_eps, flop=nflop)
1121 2654 : ri_data%dbcsr_nflop = ri_data%dbcsr_nflop + nflop
1122 2654 : CALL dbt_batched_contract_finalize(t_2c_work(5))
1123 :
1124 : !Contract with the 3c derivatives to get the force/virial
1125 2654 : CALL dbt_copy(t_3c_work_3(2), t_3c_work_3(4), move_data=.TRUE.)
1126 2654 : IF (use_virial_prv) THEN
1127 : CALL get_force_from_3c_trace(force, t_3c_work_3(4), t_3c_der_stack(1:3), &
1128 : t_3c_der_stack(4:6), atom_of_kind, kind_of, &
1129 : idx_to_at_RI, idx_to_at_AO, i_images, &
1130 : batch_ranges_nze(i_batch), 2.0_dp*pref, &
1131 460 : ri_data, qs_env, work_virial, cell, particle_set)
1132 : ELSE
1133 : CALL get_force_from_3c_trace(force, t_3c_work_3(4), t_3c_der_stack(1:3), &
1134 : t_3c_der_stack(4:6), atom_of_kind, kind_of, &
1135 : idx_to_at_RI, idx_to_at_AO, i_images, &
1136 : batch_ranges_nze(i_batch), 2.0_dp*pref, &
1137 2194 : ri_data, qs_env)
1138 : END IF
1139 2654 : CALL dbt_clear(t_3c_work_3(4))
1140 :
1141 : !Contract with the 3-center integrals in order to have a matrix R_PQ such that
1142 : !we can take the trace sum_PQ R_PQ (P^0|Q^b)^(x)
1143 2654 : IF (i_loop == 2) CYCLE
1144 :
1145 : !Stack the 3c integrals
1146 : CALL fill_3c_stack(t_3c_work_3(4), ri_data%kp_t_3c_int, iapc_pairs(:, 1), 3, ri_data, &
1147 : filter_at=jatom, filter_dim=2, idx_to_at=idx_to_at_AO, &
1148 4179 : img_bounds=[batch_ranges_nze(i_batch), batch_ranges_nze(i_batch + 1)])
1149 1393 : CALL dbt_copy(t_3c_work_3(4), t_3c_work_3(3), move_data=.TRUE.)
1150 :
1151 1393 : CALL dbt_batched_contract_init(t_2c_R_split)
1152 : CALL dbt_contract(1.0_dp, t_3c_work_3(1), t_3c_work_3(3), &
1153 : 1.0_dp, t_2c_R_split, map_1=[1], map_2=[2], &
1154 : contract_1=[2, 3], notcontract_1=[1], &
1155 : contract_2=[2, 3], notcontract_2=[1], &
1156 1393 : filter_eps=ri_data%filter_eps, flop=nflop)
1157 1393 : ri_data%dbcsr_nflop = ri_data%dbcsr_nflop + nflop
1158 1393 : CALL dbt_batched_contract_finalize(t_2c_R_split)
1159 10300 : CALL dbt_copy(t_3c_work_3(4), t_3c_work_3(1))
1160 : END DO
1161 : END DO
1162 3089 : DO i_spin = 1, nspins
1163 3089 : CALL dbt_batched_contract_finalize(rho_ao_t_sub(i_spin, b_img))
1164 : END DO
1165 1414 : CALL timestop(handle2)
1166 :
1167 1414 : IF (i_loop == 2) CYCLE
1168 741 : pref = 2.0_dp*pref
1169 741 : IF (iatom == jatom .AND. b_img == 1) pref = 0.5_dp*pref
1170 :
1171 741 : CALL timeset(routineN//"_2c_2", handle2)
1172 : !Note that the derivatives are in atomic block format (not split)
1173 741 : CALL dbt_copy(t_2c_R_split, t_2c_R, move_data=.TRUE.)
1174 :
1175 : CALL get_ext_2c_int(t_2c_work(1), mat_2c_pot, iatom, jatom, b_img, ri_data, qs_env, &
1176 : blacs_env_ext=blacs_env_sub, para_env_ext=para_env_sub, &
1177 741 : dbcsr_template=dbcsr_template)
1178 :
1179 : !We have to calculate: S^-1(iat) * R_PQ * S^-1(jat) to trace with HFX pot der
1180 : ! + R_PQ * S^-1(jat) * pot^T to trace with S^(x) (iat)
1181 : ! + pot^T * S^-1(iat) *R_PQ to trace with S^(x) (jat)
1182 :
1183 : !Because 3c tensors are all precontracted with the inverse RI metric,
1184 : !t_2c_R is currently implicitely multiplied by S^-1(iat) from the left
1185 : !and S^-1(jat) from the right, directly in the proper format for the trace
1186 : !with the HFX potential derivative
1187 :
1188 : !Trace with HFX pot deriv, that we need to build first
1189 2964 : DO i_xyz = 1, 3
1190 : CALL get_ext_2c_int(t_2c_der_pot(i_xyz), mat_der_pot_sub(:, i_xyz), iatom, jatom, &
1191 : b_img, ri_data, qs_env, blacs_env_ext=blacs_env_sub, &
1192 2964 : para_env_ext=para_env_sub, dbcsr_template=dbcsr_template)
1193 : END DO
1194 :
1195 741 : IF (use_virial_prv) THEN
1196 : CALL get_2c_der_force(force, t_2c_R, t_2c_der_pot, atom_of_kind, kind_of, &
1197 125 : b_img, pref, ri_data, qs_env, work_virial, cell, particle_set)
1198 : ELSE
1199 : CALL get_2c_der_force(force, t_2c_R, t_2c_der_pot, atom_of_kind, kind_of, &
1200 616 : b_img, pref, ri_data, qs_env)
1201 : END IF
1202 :
1203 2964 : DO i_xyz = 1, 3
1204 2964 : CALL dbt_clear(t_2c_der_pot(i_xyz))
1205 : END DO
1206 :
1207 : !R_PQ * S^-1(jat) * pot^T (=A)
1208 : CALL dbt_contract(1.0_dp, t_2c_metric(iatom), t_2c_R, & !get rid of implicit S^-1(iat)
1209 : 0.0_dp, t_2c_work(2), map_1=[1], map_2=[2], &
1210 : contract_1=[2], notcontract_1=[1], &
1211 : contract_2=[1], notcontract_2=[2], &
1212 741 : filter_eps=ri_data%filter_eps, flop=nflop)
1213 741 : ri_data%dbcsr_nflop = ri_data%dbcsr_nflop + nflop
1214 : CALL dbt_contract(1.0_dp, t_2c_work(2), t_2c_work(1), &
1215 : 0.0_dp, t_2c_work(3), map_1=[1], map_2=[2], &
1216 : contract_1=[2], notcontract_1=[1], &
1217 : contract_2=[2], notcontract_2=[1], &
1218 741 : filter_eps=ri_data%filter_eps, flop=nflop)
1219 741 : ri_data%dbcsr_nflop = ri_data%dbcsr_nflop + nflop
1220 :
1221 : !With the RI bump function, things get more complex. M = (S|P)_D + B*(S|P)_OD*B
1222 : !Calculate M^-1*B*A + A*B*M^-1 to contract with B^x. A is in t_2c_work(3)
1223 : CALL dbt_contract(1.0_dp, t_2c_work(3), t_2c_binv(iatom), &
1224 : 0.0_dp, t_2c_work(2), map_1=[1], map_2=[2], &
1225 : contract_1=[2], notcontract_1=[1], &
1226 : contract_2=[1], notcontract_2=[2], &
1227 741 : filter_eps=ri_data%filter_eps, flop=nflop)
1228 741 : ri_data%dbcsr_nflop = ri_data%dbcsr_nflop + nflop
1229 :
1230 : CALL dbt_contract(1.0_dp, t_2c_binv(iatom), t_2c_work(3), & !use transpose of B*M^-1 = M^-1*B
1231 : 0.0_dp, t_2c_work(4), map_1=[1], map_2=[2], &
1232 : contract_1=[1], notcontract_1=[2], &
1233 : contract_2=[1], notcontract_2=[2], &
1234 741 : filter_eps=ri_data%filter_eps, flop=nflop)
1235 741 : ri_data%dbcsr_nflop = ri_data%dbcsr_nflop + nflop
1236 :
1237 741 : CALL dbt_copy(t_2c_work(2), t_2c_work(4), summation=.TRUE.)
1238 : CALL get_2c_bump_forces(force, t_2c_work(4), iatom, atom_of_kind, kind_of, pref, &
1239 741 : ri_data, qs_env, work_virial)
1240 :
1241 : !Calculate -M^-1*B*A*B*M^-1 to contracte with diagonal RI metric deriv. t_2c_work(2) holds A*B*M^-1
1242 : CALL dbt_contract(1.0_dp, t_2c_binv(iatom), t_2c_work(2), &
1243 : 0.0_dp, t_2c_work(4), map_1=[1], map_2=[2], &
1244 : contract_1=[1], notcontract_1=[2], &
1245 : contract_2=[1], notcontract_2=[2], &
1246 741 : filter_eps=ri_data%filter_eps, flop=nflop)
1247 741 : ri_data%dbcsr_nflop = ri_data%dbcsr_nflop + nflop
1248 :
1249 741 : IF (use_virial_prv) THEN
1250 : CALL get_2c_der_force(force, t_2c_work(4), t_2c_der_metric_sub(iatom, :), atom_of_kind, &
1251 : kind_of, 1, -pref, ri_data, qs_env, work_virial, cell, particle_set, &
1252 125 : diag=.TRUE., offdiag=.FALSE.)
1253 : ELSE
1254 : CALL get_2c_der_force(force, t_2c_work(4), t_2c_der_metric_sub(iatom, :), atom_of_kind, &
1255 616 : kind_of, 1, -pref, ri_data, qs_env, diag=.TRUE., offdiag=.FALSE.)
1256 : END IF
1257 :
1258 : !Calculate -B*M^-1*B*A*B*M^-1*B to contract with off-diagonal RI metric derivs
1259 741 : CALL dbt_copy(t_2c_work(4), t_2c_work(2))
1260 741 : CALL apply_bump(t_2c_work(2), iatom, ri_data, qs_env, from_left=.TRUE., from_right=.TRUE.)
1261 :
1262 741 : IF (use_virial_prv) THEN
1263 : CALL get_2c_der_force(force, t_2c_work(2), t_2c_der_metric_sub(iatom, :), atom_of_kind, &
1264 : kind_of, 1, -pref, ri_data, qs_env, work_virial, cell, particle_set, &
1265 125 : diag=.FALSE., offdiag=.TRUE.)
1266 : ELSE
1267 : CALL get_2c_der_force(force, t_2c_work(2), t_2c_der_metric_sub(iatom, :), atom_of_kind, &
1268 616 : kind_of, 1, -pref, ri_data, qs_env, diag=.FALSE., offdiag=.TRUE.)
1269 : END IF
1270 :
1271 : !Calculate -O*B*M^-1*B*A*B*M^-1 - M^-1*B*A*B*M^-1*B*O, where O is off-diagonal integrals
1272 : !t_2c_work(4) holds M^-1*B*A*B*M^-1, and exploit transpose of B*O (stored in t_2c_bint)
1273 : CALL dbt_contract(1.0_dp, t_2c_work(4), t_2c_bint(iatom), &
1274 : 0.0_dp, t_2c_work(2), map_1=[1], map_2=[2], &
1275 : contract_1=[2], notcontract_1=[1], &
1276 : contract_2=[1], notcontract_2=[2], &
1277 741 : filter_eps=ri_data%filter_eps, flop=nflop)
1278 741 : ri_data%dbcsr_nflop = ri_data%dbcsr_nflop + nflop
1279 :
1280 : CALL dbt_contract(1.0_dp, t_2c_bint(iatom), t_2c_work(4), &
1281 : 1.0_dp, t_2c_work(2), map_1=[1], map_2=[2], &
1282 : contract_1=[1], notcontract_1=[2], &
1283 : contract_2=[1], notcontract_2=[2], &
1284 741 : filter_eps=ri_data%filter_eps, flop=nflop)
1285 741 : ri_data%dbcsr_nflop = ri_data%dbcsr_nflop + nflop
1286 :
1287 : CALL get_2c_bump_forces(force, t_2c_work(2), iatom, atom_of_kind, kind_of, -pref, &
1288 741 : ri_data, qs_env, work_virial)
1289 :
1290 : ! pot^T * S^-1(iat) * R_PQ (=A)
1291 : CALL dbt_contract(1.0_dp, t_2c_work(1), t_2c_R, &
1292 : 0.0_dp, t_2c_work(2), map_1=[1], map_2=[2], &
1293 : contract_1=[1], notcontract_1=[2], &
1294 : contract_2=[1], notcontract_2=[2], &
1295 741 : filter_eps=ri_data%filter_eps, flop=nflop)
1296 741 : ri_data%dbcsr_nflop = ri_data%dbcsr_nflop + nflop
1297 :
1298 : CALL dbt_contract(1.0_dp, t_2c_work(2), t_2c_metric(jatom), & !get rid of implicit S^-1(jat)
1299 : 0.0_dp, t_2c_work(3), map_1=[1], map_2=[2], &
1300 : contract_1=[2], notcontract_1=[1], &
1301 : contract_2=[1], notcontract_2=[2], &
1302 741 : filter_eps=ri_data%filter_eps, flop=nflop)
1303 741 : ri_data%dbcsr_nflop = ri_data%dbcsr_nflop + nflop
1304 :
1305 : !Do the same shenanigans with the S^(x) (jatom)
1306 : !Calculate M^-1*B*A + A*B*M^-1 to contract with B^x. A is in t_2c_work(3)
1307 : CALL dbt_contract(1.0_dp, t_2c_work(3), t_2c_binv(jatom), &
1308 : 0.0_dp, t_2c_work(2), map_1=[1], map_2=[2], &
1309 : contract_1=[2], notcontract_1=[1], &
1310 : contract_2=[1], notcontract_2=[2], &
1311 741 : filter_eps=ri_data%filter_eps, flop=nflop)
1312 741 : ri_data%dbcsr_nflop = ri_data%dbcsr_nflop + nflop
1313 :
1314 : CALL dbt_contract(1.0_dp, t_2c_binv(jatom), t_2c_work(3), & !use transpose of B*M^-1 = M^-1*B
1315 : 0.0_dp, t_2c_work(4), map_1=[1], map_2=[2], &
1316 : contract_1=[1], notcontract_1=[2], &
1317 : contract_2=[1], notcontract_2=[2], &
1318 741 : filter_eps=ri_data%filter_eps, flop=nflop)
1319 741 : ri_data%dbcsr_nflop = ri_data%dbcsr_nflop + nflop
1320 :
1321 741 : CALL dbt_copy(t_2c_work(2), t_2c_work(4), summation=.TRUE.)
1322 : CALL get_2c_bump_forces(force, t_2c_work(4), jatom, atom_of_kind, kind_of, pref, &
1323 741 : ri_data, qs_env, work_virial)
1324 :
1325 : !Calculate -M^-1*B*A*B*M^-1 to contracte with diagonal RI metric deriv. t_2c_work(2) holds A*B*M^-1
1326 : CALL dbt_contract(1.0_dp, t_2c_binv(jatom), t_2c_work(2), &
1327 : 0.0_dp, t_2c_work(4), map_1=[1], map_2=[2], &
1328 : contract_1=[1], notcontract_1=[2], &
1329 : contract_2=[1], notcontract_2=[2], &
1330 741 : filter_eps=ri_data%filter_eps, flop=nflop)
1331 741 : ri_data%dbcsr_nflop = ri_data%dbcsr_nflop + nflop
1332 :
1333 741 : IF (use_virial_prv) THEN
1334 : CALL get_2c_der_force(force, t_2c_work(4), t_2c_der_metric_sub(jatom, :), atom_of_kind, &
1335 : kind_of, 1, -pref, ri_data, qs_env, work_virial, cell, particle_set, &
1336 125 : diag=.TRUE., offdiag=.FALSE.)
1337 : ELSE
1338 : CALL get_2c_der_force(force, t_2c_work(4), t_2c_der_metric_sub(jatom, :), atom_of_kind, &
1339 616 : kind_of, 1, -pref, ri_data, qs_env, diag=.TRUE., offdiag=.FALSE.)
1340 : END IF
1341 :
1342 : !Calculate -B*M^-1*B*A*B*M^-1*B to contract with off-diagonal RI metric derivs
1343 741 : CALL dbt_copy(t_2c_work(4), t_2c_work(2))
1344 741 : CALL apply_bump(t_2c_work(2), jatom, ri_data, qs_env, from_left=.TRUE., from_right=.TRUE.)
1345 :
1346 741 : IF (use_virial_prv) THEN
1347 : CALL get_2c_der_force(force, t_2c_work(2), t_2c_der_metric_sub(jatom, :), atom_of_kind, &
1348 : kind_of, 1, -pref, ri_data, qs_env, work_virial, cell, particle_set, &
1349 125 : diag=.FALSE., offdiag=.TRUE.)
1350 : ELSE
1351 : CALL get_2c_der_force(force, t_2c_work(2), t_2c_der_metric_sub(jatom, :), atom_of_kind, &
1352 616 : kind_of, 1, -pref, ri_data, qs_env, diag=.FALSE., offdiag=.TRUE.)
1353 : END IF
1354 :
1355 : !Calculate -O*B*M^-1*B*A*B*M^-1 - M^-1*B*A*B*M^-1*B*O, where O is off-diagonal integrals
1356 : !t_2c_work(4) holds M^-1*B*A*B*M^-1, and exploit transpose of B*O (stored in t_2c_bint)
1357 : CALL dbt_contract(1.0_dp, t_2c_work(4), t_2c_bint(jatom), &
1358 : 0.0_dp, t_2c_work(2), map_1=[1], map_2=[2], &
1359 : contract_1=[2], notcontract_1=[1], &
1360 : contract_2=[1], notcontract_2=[2], &
1361 741 : filter_eps=ri_data%filter_eps, flop=nflop)
1362 741 : ri_data%dbcsr_nflop = ri_data%dbcsr_nflop + nflop
1363 :
1364 : CALL dbt_contract(1.0_dp, t_2c_bint(jatom), t_2c_work(4), &
1365 : 1.0_dp, t_2c_work(2), map_1=[1], map_2=[2], &
1366 : contract_1=[1], notcontract_1=[2], &
1367 : contract_2=[1], notcontract_2=[2], &
1368 741 : filter_eps=ri_data%filter_eps, flop=nflop)
1369 741 : ri_data%dbcsr_nflop = ri_data%dbcsr_nflop + nflop
1370 :
1371 : CALL get_2c_bump_forces(force, t_2c_work(2), jatom, atom_of_kind, kind_of, -pref, &
1372 741 : ri_data, qs_env, work_virial)
1373 :
1374 19960 : CALL timestop(handle2)
1375 : END DO !iatom
1376 : END DO !jatom
1377 : END DO !b_img
1378 :
1379 150 : IF (i_loop == 1) THEN
1380 50 : CALL update_pattern_to_forces(force_pattern, sparsity_pattern, ngroups, ri_data, qs_env)
1381 : END IF
1382 : END DO !i_loop
1383 :
1384 50 : CALL dbt_batched_contract_finalize(t_3c_work_3(1))
1385 50 : CALL dbt_batched_contract_finalize(t_3c_work_3(2))
1386 50 : CALL dbt_batched_contract_finalize(t_3c_work_3(3))
1387 50 : CALL dbt_batched_contract_finalize(t_3c_work_2(1))
1388 50 : CALL dbt_batched_contract_finalize(t_3c_work_2(2))
1389 :
1390 50 : IF (use_virial_prv) THEN
1391 40 : DO k_xyz = 1, 3
1392 130 : DO j_xyz = 1, 3
1393 390 : DO i_xyz = 1, 3
1394 : virial%pv_fock_4c(i_xyz, j_xyz) = virial%pv_fock_4c(i_xyz, j_xyz) &
1395 360 : + work_virial(i_xyz, k_xyz)*cell%hmat(j_xyz, k_xyz)
1396 : END DO
1397 : END DO
1398 : END DO
1399 : END IF
1400 :
1401 : !End of subgroup parallelization
1402 50 : CALL cp_blacs_env_release(blacs_env_sub)
1403 50 : CALL para_env_sub%free()
1404 50 : DEALLOCATE (para_env_sub)
1405 :
1406 50 : CALL para_env%sync()
1407 50 : t2 = m_walltime()
1408 50 : ri_data%dbcsr_time = ri_data%dbcsr_time + t2 - t1
1409 :
1410 : !clean-up
1411 50 : IF (ASSOCIATED(dbcsr_template)) THEN
1412 50 : CALL dbcsr_release(dbcsr_template)
1413 50 : DEALLOCATE (dbcsr_template)
1414 : END IF
1415 50 : CALL dbt_destroy(t_2c_R)
1416 50 : CALL dbt_destroy(t_2c_R_split)
1417 50 : CALL dbt_destroy(t_2c_work(1))
1418 50 : CALL dbt_destroy(t_2c_work(2))
1419 50 : CALL dbt_destroy(t_2c_work(3))
1420 50 : CALL dbt_destroy(t_2c_work(4))
1421 50 : CALL dbt_destroy(t_2c_work(5))
1422 50 : CALL dbt_destroy(t_3c_work_2(1))
1423 50 : CALL dbt_destroy(t_3c_work_2(2))
1424 50 : CALL dbt_destroy(t_3c_work_2(3))
1425 50 : CALL dbt_destroy(t_3c_work_3(1))
1426 50 : CALL dbt_destroy(t_3c_work_3(2))
1427 50 : CALL dbt_destroy(t_3c_work_3(3))
1428 50 : CALL dbt_destroy(t_3c_work_3(4))
1429 50 : CALL dbt_destroy(t_3c_der_stack(1))
1430 50 : CALL dbt_destroy(t_3c_der_stack(2))
1431 50 : CALL dbt_destroy(t_3c_der_stack(3))
1432 50 : CALL dbt_destroy(t_3c_der_stack(4))
1433 50 : CALL dbt_destroy(t_3c_der_stack(5))
1434 50 : CALL dbt_destroy(t_3c_der_stack(6))
1435 200 : DO i_xyz = 1, 3
1436 200 : CALL dbt_destroy(t_2c_der_pot(i_xyz))
1437 : END DO
1438 150 : DO iatom = 1, natom
1439 100 : CALL dbt_destroy(t_2c_inv(iatom))
1440 100 : CALL dbt_destroy(t_2c_binv(iatom))
1441 100 : CALL dbt_destroy(t_2c_bint(iatom))
1442 100 : CALL dbt_destroy(t_2c_metric(iatom))
1443 450 : DO i_xyz = 1, 3
1444 400 : CALL dbt_destroy(t_2c_der_metric_sub(iatom, i_xyz))
1445 : END DO
1446 : END DO
1447 1472 : DO i_img = 1, nimg
1448 1422 : CALL dbcsr_release(mat_2c_pot(i_img))
1449 3074 : DO i_spin = 1, nspins
1450 1602 : CALL dbt_destroy(rho_ao_t_sub(i_spin, i_img))
1451 3024 : CALL dbt_destroy(t_3c_apc_sub(i_spin, i_img))
1452 : END DO
1453 : END DO
1454 200 : DO i_xyz = 1, 3
1455 4466 : DO i_img = 1, nimg
1456 4266 : CALL dbt_destroy(t_3c_der_RI_sub(i_img, i_xyz))
1457 4266 : CALL dbt_destroy(t_3c_der_AO_sub(i_img, i_xyz))
1458 4416 : CALL dbcsr_release(mat_der_pot_sub(i_img, i_xyz))
1459 : END DO
1460 : END DO
1461 :
1462 50 : CALL timestop(handle)
1463 :
1464 25722 : END SUBROUTINE hfx_ri_update_forces_kp
1465 :
1466 : ! **************************************************************************************************
1467 : !> \brief A routine the applies the RI bump matrix from the left and/or the right, given an input
1468 : !> matrix and the central RI atom. We assume atomic block sizes
1469 : !> \param t_2c_inout ...
1470 : !> \param atom_i ...
1471 : !> \param ri_data ...
1472 : !> \param qs_env ...
1473 : !> \param from_left ...
1474 : !> \param from_right ...
1475 : !> \param debump ...
1476 : ! **************************************************************************************************
1477 2210 : SUBROUTINE apply_bump(t_2c_inout, atom_i, ri_data, qs_env, from_left, from_right, debump)
1478 : TYPE(dbt_type), INTENT(INOUT) :: t_2c_inout
1479 : INTEGER, INTENT(IN) :: atom_i
1480 : TYPE(hfx_ri_type), INTENT(INOUT) :: ri_data
1481 : TYPE(qs_environment_type), POINTER :: qs_env
1482 : LOGICAL, INTENT(IN), OPTIONAL :: from_left, from_right, debump
1483 :
1484 : INTEGER :: i_img, i_RI, iatom, ind(2), j_img, j_RI, &
1485 : jatom, natom, nblks(2), nimg, nkind
1486 2210 : INTEGER, DIMENSION(:, :), POINTER :: index_to_cell
1487 2210 : INTEGER, DIMENSION(:, :, :), POINTER :: cell_to_index
1488 : LOGICAL :: found, my_debump, my_left, my_right
1489 : REAL(dp) :: bval, r0, r1, ri(3), rj(3), rref(3), &
1490 : scoord(3)
1491 2210 : REAL(dp), ALLOCATABLE, DIMENSION(:, :) :: blk
1492 : TYPE(cell_type), POINTER :: cell
1493 : TYPE(dbt_iterator_type) :: iter
1494 : TYPE(kpoint_type), POINTER :: kpoints
1495 2210 : TYPE(particle_type), DIMENSION(:), POINTER :: particle_set
1496 2210 : TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set
1497 :
1498 2210 : NULLIFY (qs_kind_set, particle_set, kpoints, index_to_cell, cell_to_index, cell)
1499 :
1500 : CALL get_qs_env(qs_env, natom=natom, nkind=nkind, qs_kind_set=qs_kind_set, cell=cell, &
1501 2210 : kpoints=kpoints, particle_set=particle_set)
1502 2210 : CALL get_kpoint_info(kpoints, cell_to_index=cell_to_index, index_to_cell=index_to_cell)
1503 :
1504 2210 : my_debump = .FALSE.
1505 2210 : IF (PRESENT(debump)) my_debump = debump
1506 :
1507 2210 : my_left = .FALSE.
1508 2210 : IF (PRESENT(from_left)) my_left = from_left
1509 :
1510 2210 : my_right = .FALSE.
1511 2210 : IF (PRESENT(from_right)) my_right = from_right
1512 2210 : CPASSERT(my_left .OR. my_right)
1513 :
1514 2210 : CALL dbt_get_info(t_2c_inout, nblks_total=nblks)
1515 2210 : CPASSERT(nblks(1) == ri_data%ncell_RI*natom)
1516 2210 : CPASSERT(nblks(2) == ri_data%ncell_RI*natom)
1517 :
1518 2210 : nimg = ri_data%nimg
1519 :
1520 : !Loop over the RI cells and atoms, and apply bump accordingly
1521 2210 : r1 = ri_data%kp_RI_range
1522 2210 : r0 = ri_data%kp_bump_rad
1523 2210 : rref = pbc(particle_set(atom_i)%r, cell)
1524 :
1525 : !$OMP PARALLEL DEFAULT(NONE) SHARED(t_2c_inout,natom,ri_data,cell,particle_set,index_to_cell,my_left, &
1526 : !$OMP my_right,r0,r1,rref,my_debump) &
1527 2210 : !$OMP PRIVATE(iter,ind,blk,found,i_RI,i_img,iatom,j_RI,j_img,jatom,scoord,ri,rj,bval)
1528 : CALL dbt_iterator_start(iter, t_2c_inout)
1529 : DO WHILE (dbt_iterator_blocks_left(iter))
1530 : CALL dbt_iterator_next_block(iter, ind)
1531 : CALL dbt_get_block(t_2c_inout, ind, blk, found)
1532 : IF (.NOT. found) CYCLE
1533 :
1534 : i_RI = (ind(1) - 1)/natom + 1
1535 : i_img = ri_data%RI_cell_to_img(i_RI)
1536 : iatom = ind(1) - (i_RI - 1)*natom
1537 :
1538 : CALL real_to_scaled(scoord, pbc(particle_set(iatom)%r, cell), cell)
1539 : CALL scaled_to_real(ri, scoord(:) + index_to_cell(:, i_img), cell)
1540 :
1541 : j_RI = (ind(2) - 1)/natom + 1
1542 : j_img = ri_data%RI_cell_to_img(j_RI)
1543 : jatom = ind(2) - (j_RI - 1)*natom
1544 :
1545 : CALL real_to_scaled(scoord, pbc(particle_set(jatom)%r, cell), cell)
1546 : CALL scaled_to_real(rj, scoord(:) + index_to_cell(:, j_img), cell)
1547 :
1548 : IF (.NOT. my_debump) THEN
1549 : IF (my_left) blk(:, :) = blk(:, :)*bump(NORM2(ri - rref), r0, r1)
1550 : IF (my_right) blk(:, :) = blk(:, :)*bump(NORM2(rj - rref), r0, r1)
1551 : ELSE
1552 : !Note: by construction, the bump function is never quite zero, as its range is the same
1553 : ! as that of the extended RI basis (but we are safe)
1554 : bval = bump(NORM2(ri - rref), r0, r1)
1555 : IF (my_left .AND. bval > EPSILON(1.0_dp)) blk(:, :) = blk(:, :)/bval
1556 : bval = bump(NORM2(rj - rref), r0, r1)
1557 : IF (my_right .AND. bval > EPSILON(1.0_dp)) blk(:, :) = blk(:, :)/bval
1558 : END IF
1559 :
1560 : CALL dbt_put_block(t_2c_inout, ind, SHAPE(blk), blk)
1561 :
1562 : DEALLOCATE (blk)
1563 : END DO
1564 : CALL dbt_iterator_stop(iter)
1565 : !$OMP END PARALLEL
1566 2210 : CALL dbt_filter(t_2c_inout, ri_data%filter_eps)
1567 :
1568 4420 : END SUBROUTINE apply_bump
1569 :
1570 : ! **************************************************************************************************
1571 : !> \brief A routine that calculates the forces due to the derivative of the bump function
1572 : !> \param force ...
1573 : !> \param t_2c_in ...
1574 : !> \param atom_i ...
1575 : !> \param atom_of_kind ...
1576 : !> \param kind_of ...
1577 : !> \param pref ...
1578 : !> \param ri_data ...
1579 : !> \param qs_env ...
1580 : !> \param work_virial ...
1581 : ! **************************************************************************************************
1582 2964 : SUBROUTINE get_2c_bump_forces(force, t_2c_in, atom_i, atom_of_kind, kind_of, pref, ri_data, &
1583 : qs_env, work_virial)
1584 : TYPE(qs_force_type), DIMENSION(:), POINTER :: force
1585 : TYPE(dbt_type), INTENT(INOUT) :: t_2c_in
1586 : INTEGER, INTENT(IN) :: atom_i
1587 : INTEGER, DIMENSION(:), INTENT(IN) :: atom_of_kind, kind_of
1588 : REAL(dp), INTENT(IN) :: pref
1589 : TYPE(hfx_ri_type), INTENT(INOUT) :: ri_data
1590 : TYPE(qs_environment_type), POINTER :: qs_env
1591 : REAL(dp), DIMENSION(3, 3), INTENT(INOUT) :: work_virial
1592 :
1593 : INTEGER :: i, i_img, i_RI, i_xyz, iat_of_kind, iatom, ikind, ind(2), j_img, j_RI, j_xyz, &
1594 : jat_of_kind, jatom, jkind, natom, nblks(2), nimg, nkind
1595 2964 : INTEGER, DIMENSION(:, :), POINTER :: index_to_cell
1596 2964 : INTEGER, DIMENSION(:, :, :), POINTER :: cell_to_index
1597 : LOGICAL :: found
1598 : REAL(dp) :: new_force, r0, r1, ri(3), rj(3), &
1599 : rref(3), scoord(3), x
1600 2964 : REAL(dp), ALLOCATABLE, DIMENSION(:, :) :: blk
1601 : TYPE(cell_type), POINTER :: cell
1602 : TYPE(dbt_iterator_type) :: iter
1603 : TYPE(kpoint_type), POINTER :: kpoints
1604 2964 : TYPE(particle_type), DIMENSION(:), POINTER :: particle_set
1605 2964 : TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set
1606 :
1607 2964 : NULLIFY (qs_kind_set, particle_set, kpoints, index_to_cell, cell_to_index, cell)
1608 :
1609 : CALL get_qs_env(qs_env, natom=natom, nkind=nkind, qs_kind_set=qs_kind_set, cell=cell, &
1610 2964 : kpoints=kpoints, particle_set=particle_set)
1611 2964 : CALL get_kpoint_info(kpoints, cell_to_index=cell_to_index, index_to_cell=index_to_cell)
1612 :
1613 2964 : CALL dbt_get_info(t_2c_in, nblks_total=nblks)
1614 2964 : CPASSERT(nblks(1) == ri_data%ncell_RI*natom)
1615 2964 : CPASSERT(nblks(2) == ri_data%ncell_RI*natom)
1616 :
1617 2964 : nimg = ri_data%nimg
1618 :
1619 : !Loop over the RI cells and atoms, and apply bump accordingly
1620 2964 : r1 = ri_data%kp_RI_range
1621 2964 : r0 = ri_data%kp_bump_rad
1622 2964 : rref = pbc(particle_set(atom_i)%r, cell)
1623 :
1624 2964 : iat_of_kind = atom_of_kind(atom_i)
1625 2964 : ikind = kind_of(atom_i)
1626 :
1627 : !$OMP PARALLEL DEFAULT(NONE) SHARED(t_2c_in,natom,ri_data,cell,particle_set,index_to_cell,pref, &
1628 : !$OMP force,r0,r1,rref,atom_of_kind,kind_of,iat_of_kind,ikind,work_virial) &
1629 : !$OMP PRIVATE(iter,ind,blk,found,i_RI,i_img,iatom,j_RI,j_img,jatom,scoord,ri,rj,jkind,jat_of_kind, &
1630 2964 : !$OMP new_force,i_xyz,i,x,j_xyz)
1631 : CALL dbt_iterator_start(iter, t_2c_in)
1632 : DO WHILE (dbt_iterator_blocks_left(iter))
1633 : CALL dbt_iterator_next_block(iter, ind)
1634 : IF (ind(1) /= ind(2)) CYCLE !bump matrix is diagonal
1635 :
1636 : CALL dbt_get_block(t_2c_in, ind, blk, found)
1637 : IF (.NOT. found) CYCLE
1638 :
1639 : !bump is a function of x = SQRT((R - Rref)^2). We refer to R as jatom, and Rref as atom_i
1640 : j_RI = (ind(2) - 1)/natom + 1
1641 : j_img = ri_data%RI_cell_to_img(j_RI)
1642 : jatom = ind(2) - (j_RI - 1)*natom
1643 : jat_of_kind = atom_of_kind(jatom)
1644 : jkind = kind_of(jatom)
1645 :
1646 : CALL real_to_scaled(scoord, pbc(particle_set(jatom)%r, cell), cell)
1647 : CALL scaled_to_real(rj, scoord(:) + index_to_cell(:, j_img), cell)
1648 : x = NORM2(rj - rref)
1649 : IF (x < r0 .OR. x > r1) CYCLE
1650 :
1651 : new_force = 0.0_dp
1652 : DO i = 1, SIZE(blk, 1)
1653 : new_force = new_force + blk(i, i)
1654 : END DO
1655 : new_force = pref*new_force*dbump(x, r0, r1)
1656 :
1657 : !x = SQRT((R - Rref)^2), so we multiply by dx/dR and dx/dRref
1658 : DO i_xyz = 1, 3
1659 : !Force acting on second atom
1660 : !$OMP ATOMIC
1661 : force(jkind)%fock_4c(i_xyz, jat_of_kind) = force(jkind)%fock_4c(i_xyz, jat_of_kind) + &
1662 : new_force*(rj(i_xyz) - rref(i_xyz))/x
1663 :
1664 : !virial acting on second atom
1665 : CALL real_to_scaled(scoord, rj, cell)
1666 : DO j_xyz = 1, 3
1667 : !$OMP ATOMIC
1668 : work_virial(i_xyz, j_xyz) = work_virial(i_xyz, j_xyz) &
1669 : + new_force*scoord(j_xyz)*(rj(i_xyz) - rref(i_xyz))/x
1670 : END DO
1671 :
1672 : !Force acting on reference atom, defining the RI basis
1673 : !$OMP ATOMIC
1674 : force(ikind)%fock_4c(i_xyz, iat_of_kind) = force(ikind)%fock_4c(i_xyz, iat_of_kind) - &
1675 : new_force*(rj(i_xyz) - rref(i_xyz))/x
1676 :
1677 : !virial of ref atom
1678 : CALL real_to_scaled(scoord, rref, cell)
1679 : DO j_xyz = 1, 3
1680 : !$OMP ATOMIC
1681 : work_virial(i_xyz, j_xyz) = work_virial(i_xyz, j_xyz) &
1682 : - new_force*scoord(j_xyz)*(rj(i_xyz) - rref(i_xyz))/x
1683 : END DO
1684 : END DO !i_xyz
1685 :
1686 : DEALLOCATE (blk)
1687 : END DO
1688 : CALL dbt_iterator_stop(iter)
1689 : !$OMP END PARALLEL
1690 :
1691 5928 : END SUBROUTINE get_2c_bump_forces
1692 :
1693 : ! **************************************************************************************************
1694 : !> \brief The bumb function as defined by Juerg
1695 : !> \param x ...
1696 : !> \param r0 ...
1697 : !> \param r1 ...
1698 : !> \return ...
1699 : ! **************************************************************************************************
1700 31329 : FUNCTION bump(x, r0, r1) RESULT(b)
1701 : REAL(dp), INTENT(IN) :: x, r0, r1
1702 : REAL(dp) :: b
1703 :
1704 : REAL(dp) :: r
1705 :
1706 : !Head-Gordon
1707 : !b = 1.0_dp/(1.0_dp+EXP((r1-r0)/(r1-x)-(r1-r0)/(x-r0)))
1708 : !Juerg
1709 31329 : r = (x - r0)/(r1 - r0)
1710 31329 : b = -6.0_dp*r**5 + 15.0_dp*r**4 - 10.0_dp*r**3 + 1.0_dp
1711 31329 : IF (x >= r1) b = 0.0_dp
1712 31329 : IF (x <= r0) b = 1.0_dp
1713 :
1714 31329 : END FUNCTION bump
1715 :
1716 : ! **************************************************************************************************
1717 : !> \brief The derivative of the bump function
1718 : !> \param x ...
1719 : !> \param r0 ...
1720 : !> \param r1 ...
1721 : !> \return ...
1722 : ! **************************************************************************************************
1723 610 : FUNCTION dbump(x, r0, r1) RESULT(b)
1724 : REAL(dp), INTENT(IN) :: x, r0, r1
1725 : REAL(dp) :: b
1726 :
1727 : REAL(dp) :: r
1728 :
1729 610 : r = (x - r0)/(r1 - r0)
1730 610 : b = (-30.0_dp*r**4 + 60.0_dp*r**3 - 30.0_dp*r**2)/(r1 - r0)
1731 610 : IF (x >= r1) b = 0.0_dp
1732 610 : IF (x <= r0) b = 0.0_dp
1733 :
1734 610 : END FUNCTION dbump
1735 :
1736 : ! **************************************************************************************************
1737 : !> \brief return the cell index a+c corresponding to given cell index i and b, with i = a+c-b
1738 : !> \param i_index ...
1739 : !> \param b_index ...
1740 : !> \param qs_env ...
1741 : !> \return ...
1742 : ! **************************************************************************************************
1743 652858 : FUNCTION get_apc_index_from_ib(i_index, b_index, qs_env) RESULT(apc_index)
1744 : INTEGER, INTENT(IN) :: i_index, b_index
1745 : TYPE(qs_environment_type), POINTER :: qs_env
1746 : INTEGER :: apc_index
1747 :
1748 : INTEGER, DIMENSION(3) :: cell_apc
1749 652858 : INTEGER, DIMENSION(:, :), POINTER :: index_to_cell
1750 652858 : INTEGER, DIMENSION(:, :, :), POINTER :: cell_to_index
1751 : TYPE(kpoint_type), POINTER :: kpoints
1752 :
1753 652858 : CALL get_qs_env(qs_env, kpoints=kpoints)
1754 652858 : CALL get_kpoint_info(kpoints, cell_to_index=cell_to_index, index_to_cell=index_to_cell)
1755 :
1756 : !i = a+c-b => a+c = i+b
1757 2611432 : cell_apc(:) = index_to_cell(:, i_index) + index_to_cell(:, b_index)
1758 :
1759 4471209 : IF (ANY([cell_apc(1), cell_apc(2), cell_apc(3)] < LBOUND(cell_to_index)) .OR. &
1760 : ANY([cell_apc(1), cell_apc(2), cell_apc(3)] > UBOUND(cell_to_index))) THEN
1761 :
1762 : apc_index = 0
1763 : ELSE
1764 574816 : apc_index = cell_to_index(cell_apc(1), cell_apc(2), cell_apc(3))
1765 : END IF
1766 :
1767 652858 : END FUNCTION get_apc_index_from_ib
1768 :
1769 : ! **************************************************************************************************
1770 : !> \brief return the cell index i corresponding to the summ of cell_a and cell_c
1771 : !> \param a_index ...
1772 : !> \param c_index ...
1773 : !> \param qs_env ...
1774 : !> \return ...
1775 : ! **************************************************************************************************
1776 0 : FUNCTION get_apc_index(a_index, c_index, qs_env) RESULT(i_index)
1777 : INTEGER, INTENT(IN) :: a_index, c_index
1778 : TYPE(qs_environment_type), POINTER :: qs_env
1779 : INTEGER :: i_index
1780 :
1781 : INTEGER, DIMENSION(3) :: cell_i
1782 0 : INTEGER, DIMENSION(:, :), POINTER :: index_to_cell
1783 0 : INTEGER, DIMENSION(:, :, :), POINTER :: cell_to_index
1784 : TYPE(kpoint_type), POINTER :: kpoints
1785 :
1786 0 : CALL get_qs_env(qs_env, kpoints=kpoints)
1787 0 : CALL get_kpoint_info(kpoints, cell_to_index=cell_to_index, index_to_cell=index_to_cell)
1788 :
1789 0 : cell_i(:) = index_to_cell(:, a_index) + index_to_cell(:, c_index)
1790 :
1791 0 : IF (ANY([cell_i(1), cell_i(2), cell_i(3)] < LBOUND(cell_to_index)) .OR. &
1792 : ANY([cell_i(1), cell_i(2), cell_i(3)] > UBOUND(cell_to_index))) THEN
1793 :
1794 : i_index = 0
1795 : ELSE
1796 0 : i_index = cell_to_index(cell_i(1), cell_i(2), cell_i(3))
1797 : END IF
1798 :
1799 0 : END FUNCTION get_apc_index
1800 :
1801 : ! **************************************************************************************************
1802 : !> \brief return the cell index i corresponding to the summ of cell_a + cell_c - cell_b
1803 : !> \param apc_index ...
1804 : !> \param b_index ...
1805 : !> \param qs_env ...
1806 : !> \return ...
1807 : ! **************************************************************************************************
1808 907344 : FUNCTION get_i_index(apc_index, b_index, qs_env) RESULT(i_index)
1809 : INTEGER, INTENT(IN) :: apc_index, b_index
1810 : TYPE(qs_environment_type), POINTER :: qs_env
1811 : INTEGER :: i_index
1812 :
1813 : INTEGER, DIMENSION(3) :: cell_i
1814 907344 : INTEGER, DIMENSION(:, :), POINTER :: index_to_cell
1815 907344 : INTEGER, DIMENSION(:, :, :), POINTER :: cell_to_index
1816 : TYPE(kpoint_type), POINTER :: kpoints
1817 :
1818 907344 : CALL get_qs_env(qs_env, kpoints=kpoints)
1819 907344 : CALL get_kpoint_info(kpoints, cell_to_index=cell_to_index, index_to_cell=index_to_cell)
1820 :
1821 3629376 : cell_i(:) = index_to_cell(:, apc_index) - index_to_cell(:, b_index)
1822 :
1823 6219188 : IF (ANY([cell_i(1), cell_i(2), cell_i(3)] < LBOUND(cell_to_index)) .OR. &
1824 : ANY([cell_i(1), cell_i(2), cell_i(3)] > UBOUND(cell_to_index))) THEN
1825 :
1826 : i_index = 0
1827 : ELSE
1828 796068 : i_index = cell_to_index(cell_i(1), cell_i(2), cell_i(3))
1829 : END IF
1830 :
1831 907344 : END FUNCTION get_i_index
1832 :
1833 : ! **************************************************************************************************
1834 : !> \brief A routine that returns all allowed a,c pairs such that a+c images corresponds to the value
1835 : !> of the apc_index input. Takes into account that image a corresponds to 3c integrals, which
1836 : !> are ordered in their own way
1837 : !> \param ac_pairs ...
1838 : !> \param apc_index ...
1839 : !> \param ri_data ...
1840 : !> \param qs_env ...
1841 : ! **************************************************************************************************
1842 19680 : SUBROUTINE get_ac_pairs(ac_pairs, apc_index, ri_data, qs_env)
1843 : INTEGER, DIMENSION(:, :), INTENT(INOUT) :: ac_pairs
1844 : INTEGER, INTENT(IN) :: apc_index
1845 : TYPE(hfx_ri_type), INTENT(INOUT) :: ri_data
1846 : TYPE(qs_environment_type), POINTER :: qs_env
1847 :
1848 : INTEGER :: a_index, actual_img, c_index, nimg
1849 :
1850 19680 : nimg = SIZE(ac_pairs, 1)
1851 :
1852 1873728 : ac_pairs(:, :) = 0
1853 : !$OMP PARALLEL DO DEFAULT(NONE) SHARED(ac_pairs,nimg,ri_data,qs_env,apc_index) &
1854 19680 : !$OMP PRIVATE(a_index,actual_img,c_index)
1855 : DO a_index = 1, nimg
1856 : actual_img = ri_data%idx_to_img(a_index)
1857 : !c = a+c - a
1858 : c_index = get_i_index(apc_index, actual_img, qs_env)
1859 : ac_pairs(a_index, 1) = a_index
1860 : ac_pairs(a_index, 2) = c_index
1861 : END DO
1862 : !$OMP END PARALLEL DO
1863 :
1864 19680 : END SUBROUTINE get_ac_pairs
1865 :
1866 : ! **************************************************************************************************
1867 : !> \brief A routine that returns all allowed i,a+c pairs such that, for the given value of b, we have
1868 : !> i = a+c-b. Takes into account that image i corrsponds to the 3c ints, which are ordered in
1869 : !> their own way
1870 : !> \param iapc_pairs ...
1871 : !> \param b_index ...
1872 : !> \param ri_data ...
1873 : !> \param qs_env ...
1874 : !> \param actual_i_img ...
1875 : ! **************************************************************************************************
1876 15887 : SUBROUTINE get_iapc_pairs(iapc_pairs, b_index, ri_data, qs_env, actual_i_img)
1877 : INTEGER, DIMENSION(:, :), INTENT(INOUT) :: iapc_pairs
1878 : INTEGER, INTENT(IN) :: b_index
1879 : TYPE(hfx_ri_type), INTENT(INOUT) :: ri_data
1880 : TYPE(qs_environment_type), POINTER :: qs_env
1881 : INTEGER, DIMENSION(:), INTENT(INOUT), OPTIONAL :: actual_i_img
1882 :
1883 : INTEGER :: actual_img, apc_index, i_index, nimg
1884 :
1885 15887 : nimg = SIZE(iapc_pairs, 1)
1886 74475 : IF (PRESENT(actual_i_img)) actual_i_img(:) = 0
1887 :
1888 1353377 : iapc_pairs(:, :) = 0
1889 : !$OMP PARALLEL DO DEFAULT(NONE) SHARED(iapc_pairs,nimg,ri_data,qs_env,b_index,actual_i_img) &
1890 15887 : !$OMP PRIVATE(i_index,actual_img,apc_index)
1891 : DO i_index = 1, nimg
1892 : actual_img = ri_data%idx_to_img(i_index)
1893 : apc_index = get_apc_index_from_ib(actual_img, b_index, qs_env)
1894 : IF (apc_index == 0) CYCLE
1895 : iapc_pairs(i_index, 1) = i_index
1896 : iapc_pairs(i_index, 2) = apc_index
1897 : IF (PRESENT(actual_i_img)) actual_i_img(i_index) = actual_img
1898 : END DO
1899 :
1900 15887 : END SUBROUTINE get_iapc_pairs
1901 :
1902 : ! **************************************************************************************************
1903 : !> \brief A function that, given a cell index a, returun the index corresponding to -a, and zero if
1904 : !> if out of bounds
1905 : !> \param a_index ...
1906 : !> \param qs_env ...
1907 : !> \return ...
1908 : ! **************************************************************************************************
1909 95568 : FUNCTION get_opp_index(a_index, qs_env) RESULT(opp_index)
1910 : INTEGER, INTENT(IN) :: a_index
1911 : TYPE(qs_environment_type), POINTER :: qs_env
1912 : INTEGER :: opp_index
1913 :
1914 : INTEGER, DIMENSION(3) :: opp_cell
1915 95568 : INTEGER, DIMENSION(:, :), POINTER :: index_to_cell
1916 95568 : INTEGER, DIMENSION(:, :, :), POINTER :: cell_to_index
1917 : TYPE(kpoint_type), POINTER :: kpoints
1918 :
1919 95568 : NULLIFY (kpoints, cell_to_index, index_to_cell)
1920 :
1921 95568 : CALL get_qs_env(qs_env, kpoints=kpoints)
1922 95568 : CALL get_kpoint_info(kpoints, cell_to_index=cell_to_index, index_to_cell=index_to_cell)
1923 :
1924 382272 : opp_cell(:) = -index_to_cell(:, a_index)
1925 :
1926 668976 : IF (ANY([opp_cell(1), opp_cell(2), opp_cell(3)] < LBOUND(cell_to_index)) .OR. &
1927 : ANY([opp_cell(1), opp_cell(2), opp_cell(3)] > UBOUND(cell_to_index))) THEN
1928 :
1929 : opp_index = 0
1930 : ELSE
1931 95568 : opp_index = cell_to_index(opp_cell(1), opp_cell(2), opp_cell(3))
1932 : END IF
1933 :
1934 95568 : END FUNCTION get_opp_index
1935 :
1936 : ! **************************************************************************************************
1937 : !> \brief A routine that returns the actual non-symemtric density matrix for each image, by Fourier
1938 : !> transforming the kpoint density matrix
1939 : !> \param rho_ao_t ...
1940 : !> \param rho_ao ...
1941 : !> \param scale_prev_p ...
1942 : !> \param ri_data ...
1943 : !> \param qs_env ...
1944 : ! **************************************************************************************************
1945 598 : SUBROUTINE get_pmat_images(rho_ao_t, rho_ao, scale_prev_p, ri_data, qs_env)
1946 : TYPE(dbt_type), DIMENSION(:, :), INTENT(INOUT) :: rho_ao_t
1947 : TYPE(dbcsr_p_type), DIMENSION(:, :), INTENT(INOUT) :: rho_ao
1948 : REAL(dp), INTENT(IN) :: scale_prev_p
1949 : TYPE(hfx_ri_type), INTENT(INOUT) :: ri_data
1950 : TYPE(qs_environment_type), POINTER :: qs_env
1951 :
1952 : INTEGER :: cell_j(3), i_img, i_spin, iatom, icol, &
1953 : irow, j_img, jatom, mi_img, mj_img, &
1954 : nimg, nspins
1955 598 : INTEGER, DIMENSION(:, :, :), POINTER :: cell_to_index
1956 : LOGICAL :: found
1957 : REAL(dp) :: fac
1958 598 : REAL(dp), DIMENSION(:, :), POINTER :: pblock, pblock_desymm
1959 598 : TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: matrix_ks, rho_desymm
1960 5382 : TYPE(dbt_type) :: tmp
1961 : TYPE(dft_control_type), POINTER :: dft_control
1962 : TYPE(kpoint_type), POINTER :: kpoints
1963 : TYPE(neighbor_list_iterator_p_type), &
1964 598 : DIMENSION(:), POINTER :: nl_iterator
1965 : TYPE(neighbor_list_set_p_type), DIMENSION(:), &
1966 598 : POINTER :: sab_nl, sab_nl_nosym
1967 : TYPE(qs_scf_env_type), POINTER :: scf_env
1968 :
1969 598 : NULLIFY (rho_desymm, kpoints, sab_nl_nosym, scf_env, matrix_ks, dft_control, &
1970 598 : sab_nl, nl_iterator, cell_to_index, pblock, pblock_desymm)
1971 :
1972 598 : CALL get_qs_env(qs_env, kpoints=kpoints, scf_env=scf_env, matrix_ks_kp=matrix_ks, dft_control=dft_control)
1973 598 : CALL get_kpoint_info(kpoints, sab_nl_nosym=sab_nl_nosym, cell_to_index=cell_to_index, sab_nl=sab_nl)
1974 :
1975 598 : IF (dft_control%do_admm) THEN
1976 342 : CALL get_admm_env(qs_env%admm_env, matrix_ks_aux_fit_kp=matrix_ks)
1977 : END IF
1978 :
1979 598 : nspins = SIZE(matrix_ks, 1)
1980 598 : nimg = ri_data%nimg
1981 :
1982 40100 : ALLOCATE (rho_desymm(nspins, nimg))
1983 17796 : DO i_img = 1, nimg
1984 38306 : DO i_spin = 1, nspins
1985 20510 : ALLOCATE (rho_desymm(i_spin, i_img)%matrix)
1986 : CALL dbcsr_create(rho_desymm(i_spin, i_img)%matrix, template=matrix_ks(i_spin, i_img)%matrix, &
1987 20510 : matrix_type=dbcsr_type_no_symmetry)
1988 37708 : CALL cp_dbcsr_alloc_block_from_nbl(rho_desymm(i_spin, i_img)%matrix, sab_nl_nosym)
1989 : END DO
1990 : END DO
1991 598 : CALL dbt_create(rho_desymm(1, 1)%matrix, tmp)
1992 :
1993 : !We transfor the symmtric typed (but not actually symmetric: P_ab^i = P_ba^-i) real-spaced density
1994 : !matrix into proper non-symemtric ones (using the same nl for consistency)
1995 598 : CALL neighbor_list_iterator_create(nl_iterator, sab_nl)
1996 28857 : DO WHILE (neighbor_list_iterate(nl_iterator) == 0)
1997 28259 : CALL get_iterator_info(nl_iterator, iatom=iatom, jatom=jatom, cell=cell_j)
1998 28259 : j_img = cell_to_index(cell_j(1), cell_j(2), cell_j(3))
1999 28259 : IF (j_img > nimg .OR. j_img < 1) CYCLE
2000 :
2001 20879 : fac = 1.0_dp
2002 20879 : IF (iatom == jatom) fac = 0.5_dp
2003 20879 : mj_img = get_opp_index(j_img, qs_env)
2004 : !if no opposite image, then no sum of P^j + P^-j => need full diag
2005 20879 : IF (mj_img == 0) fac = 1.0_dp
2006 :
2007 20879 : irow = iatom
2008 20879 : icol = jatom
2009 20879 : IF (iatom > jatom) THEN
2010 : !because symmetric nl. Value for atom pair i,j is actually stored in j,i if i > j
2011 6933 : irow = jatom
2012 6933 : icol = iatom
2013 : END IF
2014 :
2015 46650 : DO i_spin = 1, nspins
2016 25173 : CALL dbcsr_get_block_p(rho_ao(i_spin, j_img)%matrix, irow, icol, pblock, found)
2017 25173 : IF (.NOT. found) CYCLE
2018 :
2019 : !distribution of symm and non-symm matrix match in that way
2020 25173 : CALL dbcsr_get_block_p(rho_desymm(i_spin, j_img)%matrix, iatom, jatom, pblock_desymm, found)
2021 25173 : IF (.NOT. found) CYCLE
2022 :
2023 103778 : IF (iatom > jatom) THEN
2024 768046 : pblock_desymm(:, :) = fac*TRANSPOSE(pblock(:, :))
2025 : ELSE
2026 1853980 : pblock_desymm(:, :) = fac*pblock(:, :)
2027 : END IF
2028 : END DO
2029 : END DO
2030 598 : CALL neighbor_list_iterator_release(nl_iterator)
2031 :
2032 17796 : DO i_img = 1, nimg
2033 38306 : DO i_spin = 1, nspins
2034 20510 : CALL dbt_scale(rho_ao_t(i_spin, i_img), scale_prev_p)
2035 :
2036 20510 : CALL dbt_copy_matrix_to_tensor(rho_desymm(i_spin, i_img)%matrix, tmp)
2037 20510 : CALL dbt_copy(tmp, rho_ao_t(i_spin, i_img), summation=.TRUE., move_data=.TRUE.)
2038 :
2039 : !symmetrize by addin transpose of opp img
2040 20510 : mi_img = get_opp_index(i_img, qs_env)
2041 20510 : IF (mi_img > 0 .AND. mi_img <= nimg) THEN
2042 18326 : CALL dbt_copy_matrix_to_tensor(rho_desymm(i_spin, mi_img)%matrix, tmp)
2043 18326 : CALL dbt_copy(tmp, rho_ao_t(i_spin, i_img), order=[2, 1], summation=.TRUE., move_data=.TRUE.)
2044 : END IF
2045 37708 : CALL dbt_filter(rho_ao_t(i_spin, i_img), ri_data%filter_eps)
2046 : END DO
2047 : END DO
2048 :
2049 17796 : DO i_img = 1, nimg
2050 38306 : DO i_spin = 1, nspins
2051 20510 : CALL dbcsr_release(rho_desymm(i_spin, i_img)%matrix)
2052 37708 : DEALLOCATE (rho_desymm(i_spin, i_img)%matrix)
2053 : END DO
2054 : END DO
2055 :
2056 598 : CALL dbt_destroy(tmp)
2057 598 : DEALLOCATE (rho_desymm)
2058 :
2059 1196 : END SUBROUTINE get_pmat_images
2060 :
2061 : ! **************************************************************************************************
2062 : !> \brief A routine that, given a cell index b and atom indices ij, returns a 2c tensor with the HFX
2063 : !> potential (P_i^0|Q_j^b), within the extended RI basis
2064 : !> \param t_2c_pot ...
2065 : !> \param mat_orig ...
2066 : !> \param atom_i ...
2067 : !> \param atom_j ...
2068 : !> \param img_b ...
2069 : !> \param ri_data ...
2070 : !> \param qs_env ...
2071 : !> \param do_inverse ...
2072 : !> \param para_env_ext ...
2073 : !> \param blacs_env_ext ...
2074 : !> \param dbcsr_template ...
2075 : !> \param off_diagonal ...
2076 : !> \param skip_inverse ...
2077 : ! **************************************************************************************************
2078 10369 : SUBROUTINE get_ext_2c_int(t_2c_pot, mat_orig, atom_i, atom_j, img_b, ri_data, qs_env, do_inverse, &
2079 : para_env_ext, blacs_env_ext, dbcsr_template, off_diagonal, skip_inverse)
2080 : TYPE(dbt_type), INTENT(INOUT) :: t_2c_pot
2081 : TYPE(dbcsr_type), DIMENSION(:), INTENT(INOUT) :: mat_orig
2082 : INTEGER, INTENT(IN) :: atom_i, atom_j, img_b
2083 : TYPE(hfx_ri_type), INTENT(INOUT) :: ri_data
2084 : TYPE(qs_environment_type), POINTER :: qs_env
2085 : LOGICAL, INTENT(IN), OPTIONAL :: do_inverse
2086 : TYPE(mp_para_env_type), OPTIONAL, POINTER :: para_env_ext
2087 : TYPE(cp_blacs_env_type), OPTIONAL, POINTER :: blacs_env_ext
2088 : TYPE(dbcsr_type), OPTIONAL, POINTER :: dbcsr_template
2089 : LOGICAL, INTENT(IN), OPTIONAL :: off_diagonal, skip_inverse
2090 :
2091 : CHARACTER(LEN=*), PARAMETER :: routineN = 'get_ext_2c_int'
2092 :
2093 : INTEGER :: group, handle, handle2, i_img, i_RI, iatom, iblk, ikind, img_tot, j_img, j_RI, &
2094 : jatom, jblk, jkind, n_dependent, natom, nblks_RI, nimg, nkind
2095 10369 : INTEGER, ALLOCATABLE, DIMENSION(:) :: dist1, dist2
2096 10369 : INTEGER, ALLOCATABLE, DIMENSION(:, :) :: present_atoms_i, present_atoms_j
2097 : INTEGER, DIMENSION(3) :: cell_b, cell_i, cell_j, cell_tot
2098 10369 : INTEGER, DIMENSION(:), POINTER :: col_dist, col_dist_ext, ri_blk_size_ext, &
2099 10369 : row_dist, row_dist_ext
2100 10369 : INTEGER, DIMENSION(:, :), POINTER :: index_to_cell, pgrid
2101 10369 : INTEGER, DIMENSION(:, :, :), POINTER :: cell_to_index
2102 : LOGICAL :: do_inverse_prv, found, my_offd, &
2103 : skip_inverse_prv, use_template
2104 : REAL(dp) :: bfac, dij, r0, r1, threshold
2105 : REAL(dp), DIMENSION(3) :: ri, rij, rj, rref, scoord
2106 10369 : REAL(dp), DIMENSION(:, :), POINTER :: pblock
2107 : TYPE(cell_type), POINTER :: cell
2108 : TYPE(cp_blacs_env_type), POINTER :: blacs_env
2109 : TYPE(dbcsr_distribution_type) :: dbcsr_dist, dbcsr_dist_ext
2110 : TYPE(dbcsr_iterator_type) :: dbcsr_iter
2111 : TYPE(dbcsr_type) :: work, work_tight, work_tight_inv
2112 72583 : TYPE(dbt_type) :: t_2c_tmp
2113 : TYPE(distribution_2d_type), POINTER :: dist_2d
2114 : TYPE(gto_basis_set_p_type), ALLOCATABLE, &
2115 10369 : DIMENSION(:), TARGET :: basis_set_RI
2116 : TYPE(kpoint_type), POINTER :: kpoints
2117 : TYPE(mp_para_env_type), POINTER :: para_env
2118 : TYPE(neighbor_list_iterator_p_type), &
2119 10369 : DIMENSION(:), POINTER :: nl_iterator
2120 : TYPE(neighbor_list_set_p_type), DIMENSION(:), &
2121 10369 : POINTER :: nl_2c
2122 10369 : TYPE(particle_type), DIMENSION(:), POINTER :: particle_set
2123 10369 : TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set
2124 :
2125 10369 : NULLIFY (qs_kind_set, nl_2c, nl_iterator, cell, kpoints, cell_to_index, index_to_cell, dist_2d, &
2126 10369 : para_env, pblock, blacs_env, particle_set, col_dist, row_dist, pgrid, &
2127 10369 : col_dist_ext, row_dist_ext)
2128 :
2129 10369 : CALL timeset(routineN, handle)
2130 :
2131 : !Idea: run over the neighbor list once for i and once for j, and record in which cell the MIC
2132 : ! atoms are. Then loop over the atoms and only take the pairs the we need
2133 :
2134 : CALL get_qs_env(qs_env, natom=natom, nkind=nkind, qs_kind_set=qs_kind_set, cell=cell, &
2135 10369 : kpoints=kpoints, para_env=para_env, blacs_env=blacs_env, particle_set=particle_set)
2136 10369 : CALL get_kpoint_info(kpoints, cell_to_index=cell_to_index, index_to_cell=index_to_cell)
2137 :
2138 10369 : do_inverse_prv = .FALSE.
2139 10369 : IF (PRESENT(do_inverse)) do_inverse_prv = do_inverse
2140 352 : IF (do_inverse_prv) THEN
2141 352 : CPASSERT(atom_i == atom_j)
2142 : END IF
2143 :
2144 10369 : skip_inverse_prv = .FALSE.
2145 10369 : IF (PRESENT(skip_inverse)) skip_inverse_prv = skip_inverse
2146 :
2147 10369 : my_offd = .FALSE.
2148 10369 : IF (PRESENT(off_diagonal)) my_offd = off_diagonal
2149 :
2150 10369 : IF (PRESENT(para_env_ext)) para_env => para_env_ext
2151 10369 : IF (PRESENT(blacs_env_ext)) blacs_env => blacs_env_ext
2152 :
2153 10369 : nimg = SIZE(mat_orig)
2154 :
2155 10369 : CALL timeset(routineN//"_nl_iter", handle2)
2156 :
2157 : !create our own dist_2d in the subgroup
2158 41476 : ALLOCATE (dist1(natom), dist2(natom))
2159 31107 : DO iatom = 1, natom
2160 20738 : dist1(iatom) = MOD(iatom, blacs_env%num_pe(1))
2161 31107 : dist2(iatom) = MOD(iatom, blacs_env%num_pe(2))
2162 : END DO
2163 10369 : CALL distribution_2d_create(dist_2d, dist1, dist2, nkind, particle_set, blacs_env_ext=blacs_env)
2164 :
2165 46173 : ALLOCATE (basis_set_RI(nkind))
2166 10369 : CALL basis_set_list_setup(basis_set_RI, ri_data%ri_basis_type, qs_kind_set)
2167 :
2168 : CALL build_2c_neighbor_lists(nl_2c, basis_set_RI, basis_set_RI, ri_data%ri_metric, &
2169 10369 : "HFX_2c_nl_RI", qs_env, sym_ij=.FALSE., dist_2d=dist_2d)
2170 :
2171 62214 : ALLOCATE (present_atoms_i(natom, nimg), present_atoms_j(natom, nimg))
2172 10369 : present_atoms_i = 0
2173 10369 : present_atoms_j = 0
2174 :
2175 10369 : CALL neighbor_list_iterator_create(nl_iterator, nl_2c)
2176 473197 : DO WHILE (neighbor_list_iterate(nl_iterator) == 0)
2177 : CALL get_iterator_info(nl_iterator, iatom=iatom, jatom=jatom, r=rij, cell=cell_j, &
2178 462828 : ikind=ikind, jkind=jkind)
2179 :
2180 1851312 : dij = NORM2(rij)
2181 :
2182 462828 : j_img = cell_to_index(cell_j(1), cell_j(2), cell_j(3))
2183 462828 : IF (j_img > nimg .OR. j_img < 1) CYCLE
2184 :
2185 460418 : IF (iatom == atom_i .AND. dij <= ri_data%kp_RI_range) present_atoms_i(jatom, j_img) = 1
2186 470787 : IF (iatom == atom_j .AND. dij <= ri_data%kp_RI_range) present_atoms_j(jatom, j_img) = 1
2187 : END DO
2188 10369 : CALL neighbor_list_iterator_release(nl_iterator)
2189 10369 : CALL release_neighbor_list_sets(nl_2c)
2190 10369 : CALL distribution_2d_release(dist_2d)
2191 10369 : CALL timestop(handle2)
2192 :
2193 10369 : CALL para_env%sum(present_atoms_i)
2194 10369 : CALL para_env%sum(present_atoms_j)
2195 :
2196 : !Need to build a work matrix with matching distribution to mat_orig
2197 : !If template is provided, use it. If not, we create it.
2198 10369 : use_template = .FALSE.
2199 10369 : IF (PRESENT(dbcsr_template)) THEN
2200 9541 : IF (ASSOCIATED(dbcsr_template)) use_template = .TRUE.
2201 : END IF
2202 :
2203 : IF (use_template) THEN
2204 9217 : CALL dbcsr_create(work, template=dbcsr_template)
2205 : ELSE
2206 1152 : CALL dbcsr_get_info(mat_orig(1), distribution=dbcsr_dist)
2207 1152 : CALL dbcsr_distribution_get(dbcsr_dist, row_dist=row_dist, col_dist=col_dist, group=group, pgrid=pgrid)
2208 4608 : ALLOCATE (row_dist_ext(ri_data%ncell_RI*natom), col_dist_ext(ri_data%ncell_RI*natom))
2209 2304 : ALLOCATE (ri_blk_size_ext(ri_data%ncell_RI*natom))
2210 8220 : DO i_RI = 1, ri_data%ncell_RI
2211 35340 : row_dist_ext((i_RI - 1)*natom + 1:i_RI*natom) = row_dist(:)
2212 35340 : col_dist_ext((i_RI - 1)*natom + 1:i_RI*natom) = col_dist(:)
2213 22356 : RI_blk_size_ext((i_RI - 1)*natom + 1:i_RI*natom) = ri_data%bsizes_RI(:)
2214 : END DO
2215 :
2216 : CALL dbcsr_distribution_new(dbcsr_dist_ext, group=group, pgrid=pgrid, &
2217 1152 : row_dist=row_dist_ext, col_dist=col_dist_ext)
2218 : CALL dbcsr_create(work, dist=dbcsr_dist_ext, name="RI_ext", matrix_type=dbcsr_type_no_symmetry, &
2219 1152 : row_blk_size=RI_blk_size_ext, col_blk_size=RI_blk_size_ext)
2220 1152 : CALL dbcsr_distribution_release(dbcsr_dist_ext)
2221 1152 : DEALLOCATE (col_dist_ext, row_dist_ext, RI_blk_size_ext)
2222 :
2223 3456 : IF (PRESENT(dbcsr_template)) THEN
2224 324 : ALLOCATE (dbcsr_template)
2225 324 : CALL dbcsr_create(dbcsr_template, template=work)
2226 : END IF
2227 : END IF !use_template
2228 :
2229 41476 : cell_b(:) = index_to_cell(:, img_b)
2230 400665 : DO i_img = 1, nimg
2231 390296 : i_RI = ri_data%img_to_RI_cell(i_img)
2232 390296 : IF (i_RI == 0) CYCLE
2233 262120 : cell_i(:) = index_to_cell(:, i_img)
2234 3038369 : DO j_img = 1, nimg
2235 2962470 : j_RI = ri_data%img_to_RI_cell(j_img)
2236 2962470 : IF (j_RI == 0) CYCLE
2237 2207920 : cell_j(:) = index_to_cell(:, j_img)
2238 2207920 : cell_tot = cell_j - cell_i + cell_b
2239 :
2240 3818385 : IF (ANY([cell_tot(1), cell_tot(2), cell_tot(3)] < LBOUND(cell_to_index)) .OR. &
2241 : ANY([cell_tot(1), cell_tot(2), cell_tot(3)] > UBOUND(cell_to_index))) CYCLE
2242 512599 : img_tot = cell_to_index(cell_tot(1), cell_tot(2), cell_tot(3))
2243 512599 : IF (img_tot > nimg .OR. img_tot < 1) CYCLE
2244 :
2245 352501 : CALL dbcsr_iterator_start(dbcsr_iter, mat_orig(img_tot))
2246 1004091 : DO WHILE (dbcsr_iterator_blocks_left(dbcsr_iter))
2247 651590 : CALL dbcsr_iterator_next_block(dbcsr_iter, row=iatom, column=jatom)
2248 651590 : IF (present_atoms_i(iatom, i_img) == 0) CYCLE
2249 252289 : IF (present_atoms_j(jatom, j_img) == 0) CYCLE
2250 111628 : IF (my_offd .AND. (i_RI - 1)*natom + iatom == (j_RI - 1)*natom + jatom) CYCLE
2251 :
2252 111257 : CALL dbcsr_get_block_p(mat_orig(img_tot), iatom, jatom, pblock, found)
2253 111257 : IF (.NOT. found) CYCLE
2254 :
2255 1004091 : CALL dbcsr_put_block(work, (i_RI - 1)*natom + iatom, (j_RI - 1)*natom + jatom, pblock)
2256 :
2257 : END DO
2258 3665886 : CALL dbcsr_iterator_stop(dbcsr_iter)
2259 :
2260 : END DO !j_img
2261 : END DO !i_img
2262 10369 : CALL dbcsr_finalize(work)
2263 :
2264 10369 : IF (do_inverse_prv) THEN
2265 :
2266 352 : r1 = ri_data%kp_RI_range
2267 352 : r0 = ri_data%kp_bump_rad
2268 :
2269 : !Because there are a lot of empty rows/cols in work, we need to get rid of them for inversion
2270 28600 : nblks_RI = SUM(present_atoms_i)
2271 1760 : ALLOCATE (col_dist_ext(nblks_RI), row_dist_ext(nblks_RI), RI_blk_size_ext(nblks_RI))
2272 352 : iblk = 0
2273 9768 : DO i_img = 1, nimg
2274 9416 : i_RI = ri_data%img_to_RI_cell(i_img)
2275 9416 : IF (i_RI == 0) CYCLE
2276 7000 : DO iatom = 1, natom
2277 4432 : IF (present_atoms_i(iatom, i_img) == 0) CYCLE
2278 1484 : iblk = iblk + 1
2279 1484 : col_dist_ext(iblk) = col_dist(iatom)
2280 1484 : row_dist_ext(iblk) = row_dist(iatom)
2281 13848 : RI_blk_size_ext(iblk) = ri_data%bsizes_RI(iatom)
2282 : END DO
2283 : END DO
2284 :
2285 : CALL dbcsr_distribution_new(dbcsr_dist_ext, group=group, pgrid=pgrid, &
2286 352 : row_dist=row_dist_ext, col_dist=col_dist_ext)
2287 : CALL dbcsr_create(work_tight, dist=dbcsr_dist_ext, name="RI_ext", matrix_type=dbcsr_type_no_symmetry, &
2288 352 : row_blk_size=RI_blk_size_ext, col_blk_size=RI_blk_size_ext)
2289 : CALL dbcsr_create(work_tight_inv, dist=dbcsr_dist_ext, name="RI_ext", matrix_type=dbcsr_type_no_symmetry, &
2290 352 : row_blk_size=RI_blk_size_ext, col_blk_size=RI_blk_size_ext)
2291 352 : CALL dbcsr_distribution_release(dbcsr_dist_ext)
2292 352 : DEALLOCATE (col_dist_ext, row_dist_ext, RI_blk_size_ext)
2293 :
2294 : !We apply a bump function to the RI metric inverse for smooth RI basis extension:
2295 : ! S^-1 = B * ((P|Q)_D + B*(P|Q)_OD*B)^-1 * B, with D block-diagonal blocks and OD off-diagonal
2296 352 : rref = pbc(particle_set(atom_i)%r, cell)
2297 :
2298 352 : iblk = 0
2299 9768 : DO i_img = 1, nimg
2300 9416 : i_RI = ri_data%img_to_RI_cell(i_img)
2301 9416 : IF (i_RI == 0) CYCLE
2302 7000 : DO iatom = 1, natom
2303 4432 : IF (present_atoms_i(iatom, i_img) == 0) CYCLE
2304 1484 : iblk = iblk + 1
2305 :
2306 1484 : CALL real_to_scaled(scoord, pbc(particle_set(iatom)%r, cell), cell)
2307 5936 : CALL scaled_to_real(ri, scoord(:) + index_to_cell(:, i_img), cell)
2308 :
2309 1484 : jblk = 0
2310 58868 : DO j_img = 1, nimg
2311 47968 : j_RI = ri_data%img_to_RI_cell(j_img)
2312 47968 : IF (j_RI == 0) CYCLE
2313 37816 : DO jatom = 1, natom
2314 22256 : IF (present_atoms_j(jatom, j_img) == 0) CYCLE
2315 7236 : jblk = jblk + 1
2316 :
2317 7236 : CALL real_to_scaled(scoord, pbc(particle_set(jatom)%r, cell), cell)
2318 28944 : CALL scaled_to_real(rj, scoord(:) + index_to_cell(:, j_img), cell)
2319 :
2320 7236 : CALL dbcsr_get_block_p(work, (i_RI - 1)*natom + iatom, (j_RI - 1)*natom + jatom, pblock, found)
2321 7236 : IF (.NOT. found) CYCLE
2322 :
2323 3216 : bfac = 1.0_dp
2324 18060 : IF (iblk /= jblk) bfac = bump(NORM2(ri - rref), r0, r1)*bump(NORM2(rj - rref), r0, r1)
2325 6082128 : CALL dbcsr_put_block(work_tight, iblk, jblk, bfac*pblock(:, :))
2326 : END DO
2327 : END DO
2328 : END DO
2329 : END DO
2330 352 : CALL dbcsr_finalize(work_tight)
2331 352 : CALL dbcsr_clear(work)
2332 :
2333 352 : IF (.NOT. skip_inverse_prv) THEN
2334 176 : SELECT CASE (ri_data%t2c_method)
2335 : CASE (hfx_ri_do_2c_iter)
2336 0 : threshold = MAX(ri_data%filter_eps, 1.0e-12_dp)
2337 0 : CALL invert_hotelling(work_tight_inv, work_tight, threshold=threshold, silent=.FALSE.)
2338 : CASE (hfx_ri_do_2c_cholesky)
2339 176 : CALL dbcsr_copy(work_tight_inv, work_tight)
2340 176 : CALL cp_dbcsr_cholesky_decompose(work_tight_inv, para_env=para_env, blacs_env=blacs_env)
2341 : CALL cp_dbcsr_cholesky_invert(work_tight_inv, para_env=para_env, blacs_env=blacs_env, &
2342 176 : uplo_to_full=.TRUE.)
2343 : CASE (hfx_ri_do_2c_diag)
2344 0 : CALL dbcsr_copy(work_tight_inv, work_tight)
2345 : CALL cp_dbcsr_power(work_tight_inv, -1.0_dp, ri_data%eps_eigval, n_dependent, &
2346 176 : para_env, blacs_env, verbose=ri_data%unit_nr_dbcsr > 0)
2347 : END SELECT
2348 : ELSE
2349 176 : CALL dbcsr_copy(work_tight_inv, work_tight)
2350 : END IF
2351 :
2352 : !move back data to standard extended RI pattern
2353 : !Note: we apply the external bump to ((P|Q)_D + B*(P|Q)_OD*B)^-1 later, because this matrix
2354 : ! is required for forces
2355 352 : iblk = 0
2356 9768 : DO i_img = 1, nimg
2357 9416 : i_RI = ri_data%img_to_RI_cell(i_img)
2358 9416 : IF (i_RI == 0) CYCLE
2359 7000 : DO iatom = 1, natom
2360 4432 : IF (present_atoms_i(iatom, i_img) == 0) CYCLE
2361 1484 : iblk = iblk + 1
2362 :
2363 1484 : jblk = 0
2364 58868 : DO j_img = 1, nimg
2365 47968 : j_RI = ri_data%img_to_RI_cell(j_img)
2366 47968 : IF (j_RI == 0) CYCLE
2367 37816 : DO jatom = 1, natom
2368 22256 : IF (present_atoms_j(jatom, j_img) == 0) CYCLE
2369 7236 : jblk = jblk + 1
2370 :
2371 7236 : CALL dbcsr_get_block_p(work_tight_inv, iblk, jblk, pblock, found)
2372 7236 : IF (.NOT. found) CYCLE
2373 :
2374 73641 : CALL dbcsr_put_block(work, (i_RI - 1)*natom + iatom, (j_RI - 1)*natom + jatom, pblock)
2375 : END DO
2376 : END DO
2377 : END DO
2378 : END DO
2379 352 : CALL dbcsr_finalize(work)
2380 :
2381 352 : CALL dbcsr_release(work_tight)
2382 704 : CALL dbcsr_release(work_tight_inv)
2383 : END IF
2384 :
2385 10369 : CALL dbt_create(work, t_2c_tmp)
2386 10369 : CALL dbt_copy_matrix_to_tensor(work, t_2c_tmp)
2387 10369 : CALL dbt_copy(t_2c_tmp, t_2c_pot, move_data=.TRUE.)
2388 10369 : CALL dbt_filter(t_2c_pot, ri_data%filter_eps)
2389 :
2390 10369 : CALL dbt_destroy(t_2c_tmp)
2391 10369 : CALL dbcsr_release(work)
2392 :
2393 10369 : CALL timestop(handle)
2394 :
2395 41476 : END SUBROUTINE get_ext_2c_int
2396 :
2397 : ! **************************************************************************************************
2398 : !> \brief Pre-contract the density matrices with the 3-center integrals:
2399 : !> P_sigma^a,lambda^a+c (mu^0 sigma^a| P^0)
2400 : !> \param t_3c_apc ...
2401 : !> \param rho_ao_t ...
2402 : !> \param ri_data ...
2403 : !> \param qs_env ...
2404 : ! **************************************************************************************************
2405 324 : SUBROUTINE contract_pmat_3c(t_3c_apc, rho_ao_t, ri_data, qs_env)
2406 : TYPE(dbt_type), DIMENSION(:, :), INTENT(INOUT) :: t_3c_apc, rho_ao_t
2407 : TYPE(hfx_ri_type), INTENT(INOUT) :: ri_data
2408 : TYPE(qs_environment_type), POINTER :: qs_env
2409 :
2410 : CHARACTER(len=*), PARAMETER :: routineN = 'contract_pmat_3c'
2411 :
2412 : INTEGER :: apc_img, b_img, batch_size, handle, &
2413 : i_batch, i_img, i_spin, idx, j_batch, &
2414 : n_batch_img, n_batch_nze, nimg, &
2415 : nimg_nze, nspins
2416 : INTEGER(int_8) :: nflop, nze
2417 324 : INTEGER, ALLOCATABLE, DIMENSION(:) :: apc_filter, batch_ranges_img, &
2418 324 : batch_ranges_nze, int_indices
2419 324 : INTEGER, ALLOCATABLE, DIMENSION(:, :) :: ac_pairs, iapc_pairs
2420 : REAL(dp) :: occ, t1, t2
2421 2916 : TYPE(dbt_type) :: t_3c_tmp
2422 324 : TYPE(dbt_type), ALLOCATABLE, DIMENSION(:) :: ints_stack, res_stack, rho_stack
2423 : TYPE(dft_control_type), POINTER :: dft_control
2424 :
2425 324 : CALL timeset(routineN, handle)
2426 :
2427 324 : CALL get_qs_env(qs_env, dft_control=dft_control)
2428 :
2429 324 : nimg = ri_data%nimg
2430 324 : nimg_nze = ri_data%nimg_nze
2431 324 : nspins = dft_control%nspins
2432 :
2433 324 : CALL dbt_create(t_3c_apc(1, 1), t_3c_tmp)
2434 :
2435 324 : batch_size = ri_data%kp_stack_size
2436 :
2437 1620 : ALLOCATE (apc_filter(nimg), iapc_pairs(nimg, 2))
2438 324 : apc_filter = 0
2439 9634 : DO b_img = 1, nimg
2440 9310 : CALL get_iapc_pairs(iapc_pairs, b_img, ri_data, qs_env)
2441 265064 : DO i_img = 1, nimg_nze
2442 255430 : idx = iapc_pairs(i_img, 2)
2443 255430 : IF (idx < 1 .OR. idx > nimg) CYCLE
2444 264740 : apc_filter(idx) = 1
2445 : END DO
2446 : END DO
2447 :
2448 : !batching over all images
2449 324 : n_batch_img = nimg/batch_size
2450 324 : IF (MODULO(nimg, batch_size) /= 0) n_batch_img = n_batch_img + 1
2451 972 : ALLOCATE (batch_ranges_img(n_batch_img + 1))
2452 1000 : DO i_batch = 1, n_batch_img
2453 1000 : batch_ranges_img(i_batch) = (i_batch - 1)*batch_size + 1
2454 : END DO
2455 324 : batch_ranges_img(n_batch_img + 1) = nimg + 1
2456 :
2457 : !batching over images with non-zero 3c integrals
2458 324 : n_batch_nze = nimg_nze/batch_size
2459 324 : IF (MODULO(nimg_nze, batch_size) /= 0) n_batch_nze = n_batch_nze + 1
2460 972 : ALLOCATE (batch_ranges_nze(n_batch_nze + 1))
2461 796 : DO i_batch = 1, n_batch_nze
2462 796 : batch_ranges_nze(i_batch) = (i_batch - 1)*batch_size + 1
2463 : END DO
2464 324 : batch_ranges_nze(n_batch_nze + 1) = nimg_nze + 1
2465 :
2466 : !Create the stack tensors in the approriate distribution
2467 10044 : ALLOCATE (rho_stack(2), ints_stack(2), res_stack(2))
2468 : CALL get_stack_tensors(res_stack, rho_stack, ints_stack, rho_ao_t(1, 1), &
2469 324 : ri_data%t_3c_int_ctr_1(1, 1), batch_size, ri_data, qs_env)
2470 :
2471 1296 : ALLOCATE (ac_pairs(nimg, 2), int_indices(nimg_nze))
2472 6874 : DO i_img = 1, nimg_nze
2473 6874 : int_indices(i_img) = i_img
2474 : END DO
2475 :
2476 324 : t1 = m_walltime()
2477 796 : DO j_batch = 1, n_batch_nze
2478 : !First batch is over the integrals. They are always in the same order, consistent with get_ac_pairs
2479 : CALL fill_3c_stack(ints_stack(1), ri_data%t_3c_int_ctr_1(1, :), int_indices, 3, ri_data, &
2480 1416 : img_bounds=[batch_ranges_nze(j_batch), batch_ranges_nze(j_batch + 1)])
2481 472 : CALL dbt_copy(ints_stack(1), ints_stack(2), move_data=.TRUE.)
2482 :
2483 1402 : DO i_spin = 1, nspins
2484 2568 : DO i_batch = 1, n_batch_img
2485 : !Second batch is over the P matrix. Here we fill the stacked rho tensors col by col
2486 21170 : DO apc_img = batch_ranges_img(i_batch), batch_ranges_img(i_batch + 1) - 1
2487 19680 : IF (apc_filter(apc_img) == 0) CYCLE
2488 19680 : CALL get_ac_pairs(ac_pairs, apc_img, ri_data, qs_env)
2489 : CALL fill_2c_stack(rho_stack(1), rho_ao_t(i_spin, :), ac_pairs(:, 2), 1, ri_data, &
2490 : img_bounds=[batch_ranges_nze(j_batch), batch_ranges_nze(j_batch + 1)], &
2491 60530 : shift=apc_img - batch_ranges_img(i_batch) + 1)
2492 :
2493 : END DO !apc_img
2494 1490 : CALL get_tensor_occupancy(rho_stack(1), nze, occ)
2495 1490 : IF (nze == 0) CYCLE
2496 1466 : CALL dbt_copy(rho_stack(1), rho_stack(2), move_data=.TRUE.)
2497 :
2498 : !The actual contraction
2499 1466 : CALL dbt_batched_contract_init(rho_stack(2))
2500 : CALL dbt_contract(1.0_dp, ints_stack(2), rho_stack(2), &
2501 : 0.0_dp, res_stack(2), map_1=[1, 2], map_2=[3], &
2502 : contract_1=[3], notcontract_1=[1, 2], &
2503 : contract_2=[1], notcontract_2=[2], &
2504 1466 : filter_eps=ri_data%filter_eps, flop=nflop)
2505 1466 : ri_data%dbcsr_nflop = ri_data%dbcsr_nflop + nflop
2506 1466 : CALL dbt_batched_contract_finalize(rho_stack(2))
2507 1466 : CALL dbt_copy(res_stack(2), res_stack(1), move_data=.TRUE.)
2508 :
2509 23006 : DO apc_img = batch_ranges_img(i_batch), batch_ranges_img(i_batch + 1) - 1
2510 : !Destack the resulting tensor and put it in t_3c_apc with correct apc_img
2511 19444 : IF (apc_filter(apc_img) == 0) CYCLE
2512 19444 : CALL unstack_t_3c_apc(t_3c_tmp, res_stack(1), apc_img - batch_ranges_img(i_batch) + 1)
2513 20934 : CALL dbt_copy(t_3c_tmp, t_3c_apc(i_spin, apc_img), summation=.TRUE., move_data=.TRUE.)
2514 : END DO
2515 :
2516 : END DO !i_batch
2517 : END DO !i_spin
2518 : END DO !j_batch
2519 324 : DEALLOCATE (batch_ranges_img)
2520 324 : DEALLOCATE (batch_ranges_nze)
2521 324 : t2 = m_walltime()
2522 324 : ri_data%dbcsr_time = ri_data%dbcsr_time + t2 - t1
2523 :
2524 324 : CALL dbt_destroy(rho_stack(1))
2525 324 : CALL dbt_destroy(rho_stack(2))
2526 324 : CALL dbt_destroy(ints_stack(1))
2527 324 : CALL dbt_destroy(ints_stack(2))
2528 324 : CALL dbt_destroy(res_stack(1))
2529 324 : CALL dbt_destroy(res_stack(2))
2530 324 : CALL dbt_destroy(t_3c_tmp)
2531 :
2532 324 : CALL timestop(handle)
2533 :
2534 3240 : END SUBROUTINE contract_pmat_3c
2535 :
2536 : ! **************************************************************************************************
2537 : !> \brief Pre-contract 3-center integrals with the bumped invrse RI metric, for each atom
2538 : !> \param t_3c_int ...
2539 : !> \param ri_data ...
2540 : !> \param qs_env ...
2541 : ! **************************************************************************************************
2542 88 : SUBROUTINE precontract_3c_ints(t_3c_int, ri_data, qs_env)
2543 : TYPE(dbt_type), DIMENSION(:, :), INTENT(INOUT) :: t_3c_int
2544 : TYPE(hfx_ri_type), INTENT(INOUT) :: ri_data
2545 : TYPE(qs_environment_type), POINTER :: qs_env
2546 :
2547 : CHARACTER(len=*), PARAMETER :: routineN = 'precontract_3c_ints'
2548 :
2549 : INTEGER :: batch_size, handle, i_batch, i_img, &
2550 : i_RI, iatom, is, n_batch, natom, &
2551 : nblks, nblks_3c(3), nimg
2552 : INTEGER(int_8) :: nflop
2553 88 : INTEGER, ALLOCATABLE, DIMENSION(:) :: batch_ranges, bsizes_RI_ext, bsizes_RI_ext_split, &
2554 88 : bsizes_stack, dist1, dist2, dist3, dist_stack3, idx_to_at_AO, int_indices
2555 792 : TYPE(dbt_distribution_type) :: t_dist
2556 18392 : TYPE(dbt_type) :: t_2c_RI_tmp(2), t_3c_tmp(3)
2557 :
2558 88 : CALL timeset(routineN, handle)
2559 :
2560 88 : CALL get_qs_env(qs_env, natom=natom)
2561 :
2562 88 : nimg = ri_data%nimg
2563 264 : ALLOCATE (int_indices(nimg))
2564 2442 : DO i_img = 1, nimg
2565 2442 : int_indices(i_img) = i_img
2566 : END DO
2567 :
2568 264 : ALLOCATE (idx_to_at_AO(SIZE(ri_data%bsizes_AO_split)))
2569 88 : CALL get_idx_to_atom(idx_to_at_AO, ri_data%bsizes_AO_split, ri_data%bsizes_AO)
2570 :
2571 88 : nblks = SIZE(ri_data%bsizes_RI_split)
2572 264 : ALLOCATE (bsizes_RI_ext(ri_data%ncell_RI*natom))
2573 264 : ALLOCATE (bsizes_RI_ext_split(ri_data%ncell_RI*nblks))
2574 642 : DO i_RI = 1, ri_data%ncell_RI
2575 1662 : bsizes_RI_ext((i_RI - 1)*natom + 1:i_RI*natom) = ri_data%bsizes_RI(:)
2576 3264 : bsizes_RI_ext_split((i_RI - 1)*nblks + 1:i_RI*nblks) = ri_data%bsizes_RI_split(:)
2577 : END DO
2578 : CALL create_2c_tensor(t_2c_RI_tmp(1), dist1, dist2, ri_data%pgrid_2d, &
2579 : bsizes_RI_ext, bsizes_RI_ext, &
2580 88 : name="(RI | RI)")
2581 88 : DEALLOCATE (dist1, dist2)
2582 : CALL create_2c_tensor(t_2c_RI_tmp(2), dist1, dist2, ri_data%pgrid_2d, &
2583 : bsizes_RI_ext_split, bsizes_RI_ext_split, &
2584 88 : name="(RI | RI)")
2585 88 : DEALLOCATE (dist1, dist2)
2586 :
2587 : !For more efficiency, we stack multiple images of the 3-center integrals into a single tensor
2588 88 : batch_size = ri_data%kp_stack_size
2589 88 : n_batch = nimg/batch_size
2590 88 : IF (MODULO(nimg, batch_size) /= 0) n_batch = n_batch + 1
2591 264 : ALLOCATE (batch_ranges(n_batch + 1))
2592 268 : DO i_batch = 1, n_batch
2593 268 : batch_ranges(i_batch) = (i_batch - 1)*batch_size + 1
2594 : END DO
2595 88 : batch_ranges(n_batch + 1) = nimg + 1
2596 :
2597 88 : nblks = SIZE(ri_data%bsizes_AO_split)
2598 264 : ALLOCATE (bsizes_stack(batch_size*nblks))
2599 1592 : DO is = 1, batch_size
2600 7320 : bsizes_stack((is - 1)*nblks + 1:is*nblks) = ri_data%bsizes_AO_split(:)
2601 : END DO
2602 :
2603 88 : CALL dbt_get_info(t_3c_int(1, 1), nblks_total=nblks_3c)
2604 792 : ALLOCATE (dist1(nblks_3c(1)), dist2(nblks_3c(2)), dist3(nblks_3c(3)), dist_stack3(batch_size*nblks_3c(3)))
2605 88 : CALL dbt_get_info(t_3c_int(1, 1), proc_dist_1=dist1, proc_dist_2=dist2, proc_dist_3=dist3)
2606 1592 : DO is = 1, batch_size
2607 7320 : dist_stack3((is - 1)*nblks_3c(3) + 1:is*nblks_3c(3)) = dist3(:)
2608 : END DO
2609 :
2610 88 : CALL dbt_distribution_new(t_dist, ri_data%pgrid, dist1, dist2, dist_stack3)
2611 : CALL dbt_create(t_3c_tmp(1), "ints_stack", t_dist, [1], [2, 3], bsizes_RI_ext_split, &
2612 88 : ri_data%bsizes_AO_split, bsizes_stack)
2613 88 : CALL dbt_distribution_destroy(t_dist)
2614 88 : DEALLOCATE (dist1, dist2, dist3, dist_stack3)
2615 :
2616 88 : CALL dbt_create(t_3c_tmp(1), t_3c_tmp(2))
2617 88 : CALL dbt_create(t_3c_int(1, 1), t_3c_tmp(3))
2618 :
2619 264 : DO iatom = 1, natom
2620 176 : CALL dbt_copy(ri_data%t_2c_inv(1, iatom), t_2c_RI_tmp(1))
2621 176 : CALL apply_bump(t_2c_RI_tmp(1), iatom, ri_data, qs_env, from_left=.TRUE., from_right=.TRUE.)
2622 176 : CALL dbt_copy(t_2c_RI_tmp(1), t_2c_RI_tmp(2), move_data=.TRUE.)
2623 :
2624 176 : CALL dbt_batched_contract_init(t_2c_RI_tmp(2))
2625 536 : DO i_batch = 1, n_batch
2626 :
2627 : CALL fill_3c_stack(t_3c_tmp(1), t_3c_int(1, :), int_indices, 3, ri_data, &
2628 : img_bounds=[batch_ranges(i_batch), batch_ranges(i_batch + 1)], &
2629 1080 : filter_at=iatom, filter_dim=2, idx_to_at=idx_to_at_AO)
2630 :
2631 : CALL dbt_contract(1.0_dp, t_2c_RI_tmp(2), t_3c_tmp(1), &
2632 : 0.0_dp, t_3c_tmp(2), map_1=[1], map_2=[2, 3], &
2633 : contract_1=[2], notcontract_1=[1], &
2634 : contract_2=[1], notcontract_2=[2, 3], &
2635 360 : filter_eps=ri_data%filter_eps, flop=nflop)
2636 360 : ri_data%dbcsr_nflop = ri_data%dbcsr_nflop + nflop
2637 :
2638 5068 : DO i_img = batch_ranges(i_batch), batch_ranges(i_batch + 1) - 1
2639 4708 : CALL unstack_t_3c_apc(t_3c_tmp(3), t_3c_tmp(2), i_img - batch_ranges(i_batch) + 1)
2640 : CALL dbt_copy(t_3c_tmp(3), ri_data%t_3c_int_ctr_1(1, i_img), summation=.TRUE., &
2641 5068 : order=[2, 1, 3], move_data=.TRUE.)
2642 : END DO
2643 536 : CALL dbt_clear(t_3c_tmp(1))
2644 : END DO
2645 264 : CALL dbt_batched_contract_finalize(t_2c_RI_tmp(2))
2646 :
2647 : END DO
2648 88 : CALL dbt_destroy(t_2c_RI_tmp(1))
2649 88 : CALL dbt_destroy(t_2c_RI_tmp(2))
2650 88 : CALL dbt_destroy(t_3c_tmp(1))
2651 88 : CALL dbt_destroy(t_3c_tmp(2))
2652 88 : CALL dbt_destroy(t_3c_tmp(3))
2653 :
2654 2442 : DO i_img = 1, nimg
2655 2442 : CALL dbt_destroy(t_3c_int(1, i_img))
2656 : END DO
2657 :
2658 88 : CALL timestop(handle)
2659 :
2660 264 : END SUBROUTINE precontract_3c_ints
2661 :
2662 : ! **************************************************************************************************
2663 : !> \brief Copy the data of a 2D tensor living in the main MPI group to a sub-group, given the proc
2664 : !> mapping from one to the other (e.g. for a proc idx in the subgroup, we get the idx in the main)
2665 : !> \param t2c_sub ...
2666 : !> \param t2c_main ...
2667 : !> \param group_size ...
2668 : !> \param ngroups ...
2669 : !> \param para_env ...
2670 : ! **************************************************************************************************
2671 11138 : SUBROUTINE copy_2c_to_subgroup(t2c_sub, t2c_main, group_size, ngroups, para_env)
2672 : TYPE(dbt_type), INTENT(INOUT) :: t2c_sub, t2c_main
2673 : INTEGER, INTENT(IN) :: group_size, ngroups
2674 : TYPE(mp_para_env_type), POINTER :: para_env
2675 :
2676 : INTEGER :: batch_size, i, i_batch, i_msg, iblk, &
2677 : igroup, iproc, ir, is, jblk, n_batch, &
2678 : nocc, tag
2679 11138 : INTEGER, ALLOCATABLE, DIMENSION(:) :: bsizes1, bsizes2
2680 11138 : INTEGER, ALLOCATABLE, DIMENSION(:, :) :: block_dest, block_source
2681 11138 : INTEGER, ALLOCATABLE, DIMENSION(:, :, :) :: current_dest
2682 : INTEGER, DIMENSION(2) :: ind, nblks
2683 : LOGICAL :: found
2684 11138 : REAL(dp), ALLOCATABLE, DIMENSION(:, :) :: blk
2685 11138 : TYPE(cp_2d_r_p_type), ALLOCATABLE, DIMENSION(:) :: recv_buff, send_buff
2686 : TYPE(dbt_iterator_type) :: iter
2687 11138 : TYPE(mp_request_type), ALLOCATABLE, DIMENSION(:) :: recv_req, send_req
2688 :
2689 : !Stategy: we loop over the main tensor, and send all the data. Then we loop over the sub tensor
2690 : ! and receive it. We do all of it with async MPI communication. The sub tensor needs
2691 : ! to have blocks pre-reserved though
2692 :
2693 11138 : CALL dbt_get_info(t2c_main, nblks_total=nblks)
2694 :
2695 : !Loop over the main tensor, count how many blocks are there, which ones, and on which proc
2696 44552 : ALLOCATE (block_source(nblks(1), nblks(2)))
2697 219202 : block_source = -1
2698 11138 : nocc = 0
2699 11138 : !$OMP PARALLEL DEFAULT(NONE) SHARED(t2c_main,para_env,nocc,block_source) PRIVATE(iter,ind,blk,found)
2700 : CALL dbt_iterator_start(iter, t2c_main)
2701 : DO WHILE (dbt_iterator_blocks_left(iter))
2702 : CALL dbt_iterator_next_block(iter, ind)
2703 : CALL dbt_get_block(t2c_main, ind, blk, found)
2704 : IF (.NOT. found) CYCLE
2705 :
2706 : block_source(ind(1), ind(2)) = para_env%mepos
2707 : !$OMP ATOMIC
2708 : nocc = nocc + 1
2709 : DEALLOCATE (blk)
2710 : END DO
2711 : CALL dbt_iterator_stop(iter)
2712 : !$OMP END PARALLEL
2713 :
2714 11138 : CALL para_env%sum(nocc)
2715 11138 : CALL para_env%sum(block_source)
2716 219202 : block_source = block_source + para_env%num_pe - 1
2717 11138 : IF (nocc == 0) RETURN
2718 :
2719 : !Loop over the sub tensor, get the block destination
2720 10810 : igroup = para_env%mepos/group_size
2721 32430 : ALLOCATE (block_dest(nblks(1), nblks(2)))
2722 216906 : block_dest = -1
2723 40266 : DO jblk = 1, nblks(2)
2724 216906 : DO iblk = 1, nblks(1)
2725 176640 : IF (block_source(iblk, jblk) == -1) CYCLE
2726 :
2727 135642 : CALL dbt_get_stored_coordinates(t2c_sub, [iblk, jblk], iproc)
2728 206096 : block_dest(iblk, jblk) = igroup*group_size + iproc !mapping of iproc in subgroup to main group idx
2729 : END DO
2730 : END DO
2731 :
2732 54050 : ALLOCATE (bsizes1(nblks(1)), bsizes2(nblks(2)))
2733 10810 : CALL dbt_get_info(t2c_main, blk_size_1=bsizes1, blk_size_2=bsizes2)
2734 :
2735 54050 : ALLOCATE (current_dest(nblks(1), nblks(2), 0:ngroups - 1))
2736 32430 : DO igroup = 0, ngroups - 1
2737 : !for a given subgroup, need to make the destination available to everyone in the main group
2738 433812 : current_dest(:, :, igroup) = block_dest(:, :)
2739 32430 : CALL para_env%bcast(current_dest(:, :, igroup), source=igroup*group_size) !bcast from first proc in sub-group
2740 : END DO
2741 :
2742 : !We go by batches, which cannot be larger than the maximum MPI tag value
2743 10810 : batch_size = MIN(para_env%get_tag_ub(), 128000, nocc*ngroups)
2744 10810 : n_batch = (nocc*ngroups)/batch_size
2745 10810 : IF (MODULO(nocc*ngroups, batch_size) /= 0) n_batch = n_batch + 1
2746 :
2747 21620 : DO i_batch = 1, n_batch
2748 : !Loop over groups, blocks and send/receive
2749 224096 : ALLOCATE (send_buff(batch_size), recv_buff(batch_size))
2750 224096 : ALLOCATE (send_req(batch_size), recv_req(batch_size))
2751 : ir = 0
2752 : is = 0
2753 : i_msg = 0
2754 40266 : DO jblk = 1, nblks(2)
2755 216906 : DO iblk = 1, nblks(1)
2756 559376 : DO igroup = 0, ngroups - 1
2757 353280 : IF (block_source(iblk, jblk) == -1) CYCLE
2758 :
2759 90428 : i_msg = i_msg + 1
2760 90428 : IF (i_msg < (i_batch - 1)*batch_size + 1 .OR. i_msg > i_batch*batch_size) CYCLE
2761 :
2762 : !a unique tag per block, within this batch
2763 90428 : tag = i_msg - (i_batch - 1)*batch_size
2764 :
2765 90428 : found = .FALSE.
2766 90428 : IF (para_env%mepos == block_source(iblk, jblk)) THEN
2767 135642 : CALL dbt_get_block(t2c_main, [iblk, jblk], blk, found)
2768 : END IF
2769 :
2770 : !If blocks live on same proc, simply copy. Else MPI send/recv
2771 90428 : IF (block_source(iblk, jblk) == current_dest(iblk, jblk, igroup)) THEN
2772 135642 : IF (found) CALL dbt_put_block(t2c_sub, [iblk, jblk], SHAPE(blk), blk)
2773 : ELSE
2774 45214 : IF (para_env%mepos == block_source(iblk, jblk) .AND. found) THEN
2775 90428 : ALLOCATE (send_buff(tag)%array(bsizes1(iblk), bsizes2(jblk)))
2776 23151133 : send_buff(tag)%array(:, :) = blk(:, :)
2777 22607 : is = is + 1
2778 : CALL para_env%isend(msgin=send_buff(tag)%array, dest=current_dest(iblk, jblk, igroup), &
2779 22607 : request=send_req(is), tag=tag)
2780 : END IF
2781 :
2782 45214 : IF (para_env%mepos == current_dest(iblk, jblk, igroup)) THEN
2783 90428 : ALLOCATE (recv_buff(tag)%array(bsizes1(iblk), bsizes2(jblk)))
2784 22607 : ir = ir + 1
2785 : CALL para_env%irecv(msgout=recv_buff(tag)%array, source=block_source(iblk, jblk), &
2786 22607 : request=recv_req(ir), tag=tag)
2787 : END IF
2788 : END IF
2789 :
2790 267068 : IF (found) DEALLOCATE (blk)
2791 : END DO
2792 : END DO
2793 : END DO
2794 :
2795 10810 : CALL mp_waitall(send_req(1:is))
2796 10810 : CALL mp_waitall(recv_req(1:ir))
2797 : !clean-up
2798 101238 : DO i = 1, batch_size
2799 101238 : IF (ASSOCIATED(send_buff(i)%array)) DEALLOCATE (send_buff(i)%array)
2800 : END DO
2801 :
2802 : !Finally copy the data from the buffer to the sub-tensor
2803 : i_msg = 0
2804 40266 : DO jblk = 1, nblks(2)
2805 216906 : DO iblk = 1, nblks(1)
2806 559376 : DO igroup = 0, ngroups - 1
2807 353280 : IF (block_source(iblk, jblk) == -1) CYCLE
2808 :
2809 90428 : i_msg = i_msg + 1
2810 90428 : IF (i_msg < (i_batch - 1)*batch_size + 1 .OR. i_msg > i_batch*batch_size) CYCLE
2811 :
2812 : !a unique tag per block, within this batch
2813 90428 : tag = i_msg - (i_batch - 1)*batch_size
2814 :
2815 90428 : IF (para_env%mepos == current_dest(iblk, jblk, igroup) .AND. &
2816 176640 : block_source(iblk, jblk) /= current_dest(iblk, jblk, igroup)) THEN
2817 :
2818 90428 : ALLOCATE (blk(bsizes1(iblk), bsizes2(jblk)))
2819 23151133 : blk(:, :) = recv_buff(tag)%array(:, :)
2820 113035 : CALL dbt_put_block(t2c_sub, [iblk, jblk], SHAPE(blk), blk)
2821 22607 : DEALLOCATE (blk)
2822 : END IF
2823 : END DO
2824 : END DO
2825 : END DO
2826 :
2827 : !clean-up
2828 101238 : DO i = 1, batch_size
2829 101238 : IF (ASSOCIATED(recv_buff(i)%array)) DEALLOCATE (recv_buff(i)%array)
2830 : END DO
2831 21620 : DEALLOCATE (send_buff, recv_buff, send_req, recv_req)
2832 : END DO !i_batch
2833 10810 : CALL dbt_finalize(t2c_sub)
2834 :
2835 22276 : END SUBROUTINE copy_2c_to_subgroup
2836 :
2837 : ! **************************************************************************************************
2838 : !> \brief Pre-compute the destination of the block of a 3D tensor in various subgroups
2839 : !> \param subgroup_dest ...
2840 : !> \param t3c_sub ...
2841 : !> \param t3c_main ...
2842 : !> \param group_size ...
2843 : !> \param ngroups ...
2844 : !> \param para_env ...
2845 : ! **************************************************************************************************
2846 648 : SUBROUTINE get_3c_subgroup_dest(subgroup_dest, t3c_sub, t3c_main, group_size, ngroups, para_env)
2847 : INTEGER, ALLOCATABLE, DIMENSION(:, :, :, :), &
2848 : INTENT(INOUT) :: subgroup_dest
2849 : TYPE(dbt_type), INTENT(INOUT) :: t3c_sub, t3c_main
2850 : INTEGER, INTENT(IN) :: group_size, ngroups
2851 : TYPE(mp_para_env_type), POINTER :: para_env
2852 :
2853 : INTEGER :: iblk, igroup, iproc, jblk, kblk
2854 648 : INTEGER, ALLOCATABLE, DIMENSION(:, :, :) :: block_dest
2855 : INTEGER, DIMENSION(3) :: nblks
2856 :
2857 648 : CALL dbt_get_info(t3c_main, nblks_total=nblks)
2858 :
2859 : !Loop over the sub tensor, get the block destination
2860 648 : igroup = para_env%mepos/group_size
2861 3240 : ALLOCATE (block_dest(nblks(1), nblks(2), nblks(3)))
2862 1944 : DO kblk = 1, nblks(3)
2863 10632 : DO jblk = 1, nblks(2)
2864 39552 : DO iblk = 1, nblks(1)
2865 118272 : CALL dbt_get_stored_coordinates(t3c_sub, [iblk, jblk, kblk], iproc)
2866 38256 : block_dest(iblk, jblk, kblk) = igroup*group_size + iproc !mapping of iproc in subgroup to main group idx
2867 : END DO
2868 : END DO
2869 : END DO
2870 :
2871 3888 : ALLOCATE (subgroup_dest(nblks(1), nblks(2), nblks(3), ngroups))
2872 1944 : DO igroup = 0, ngroups - 1
2873 : !for a given subgroup, need to make the destination available to everyone in the main group
2874 80400 : subgroup_dest(:, :, :, igroup + 1) = block_dest(:, :, :)
2875 1944 : CALL para_env%bcast(subgroup_dest(:, :, :, igroup + 1), source=igroup*group_size) !bcast from first proc in subgroup
2876 : END DO
2877 :
2878 648 : END SUBROUTINE get_3c_subgroup_dest
2879 :
2880 : ! **************************************************************************************************
2881 : !> \brief Copy the data of a 3D tensor living in the main MPI group to a sub-group, given the proc
2882 : !> mapping from one to the other (e.g. for a proc idx in the subgroup, we get the idx in the main)
2883 : !> \param t3c_sub ...
2884 : !> \param t3c_main ...
2885 : !> \param ngroups ...
2886 : !> \param para_env ...
2887 : !> \param subgroup_dest ...
2888 : !> \param iatom_to_subgroup ...
2889 : !> \param dim_at ...
2890 : !> \param idx_to_at ...
2891 : ! **************************************************************************************************
2892 17098 : SUBROUTINE copy_3c_to_subgroup(t3c_sub, t3c_main, ngroups, para_env, subgroup_dest, &
2893 17098 : iatom_to_subgroup, dim_at, idx_to_at)
2894 : TYPE(dbt_type), INTENT(INOUT) :: t3c_sub, t3c_main
2895 : INTEGER, INTENT(IN) :: ngroups
2896 : TYPE(mp_para_env_type), POINTER :: para_env
2897 : INTEGER, DIMENSION(:, :, :, :), INTENT(IN) :: subgroup_dest
2898 : TYPE(cp_1d_logical_p_type), DIMENSION(:), &
2899 : INTENT(INOUT), OPTIONAL :: iatom_to_subgroup
2900 : INTEGER, INTENT(IN), OPTIONAL :: dim_at
2901 : INTEGER, DIMENSION(:), OPTIONAL :: idx_to_at
2902 :
2903 : INTEGER :: batch_size, i, i_batch, i_msg, iatom, &
2904 : iblk, igroup, ir, is, isbuff, jblk, &
2905 : kblk, n_batch, nocc, tag
2906 17098 : INTEGER, ALLOCATABLE, DIMENSION(:) :: bsizes1, bsizes2, bsizes3
2907 17098 : INTEGER, ALLOCATABLE, DIMENSION(:, :, :) :: block_source
2908 : INTEGER, DIMENSION(3) :: ind, nblks
2909 : LOGICAL :: filter_at, found
2910 17098 : REAL(dp), ALLOCATABLE, DIMENSION(:, :, :) :: blk
2911 17098 : TYPE(cp_3d_r_p_type), ALLOCATABLE, DIMENSION(:) :: recv_buff, send_buff
2912 : TYPE(dbt_iterator_type) :: iter
2913 17098 : TYPE(mp_request_type), ALLOCATABLE, DIMENSION(:) :: recv_req, send_req
2914 :
2915 : !Stategy: we loop over the main tensor, and send all the data. Then we loop over the sub tensor
2916 : ! and receive it. We do all of it with async MPI communication. The sub tensor needs
2917 : ! to have blocks pre-reserved though
2918 :
2919 17098 : CALL dbt_get_info(t3c_main, nblks_total=nblks)
2920 :
2921 : !in some cases, only copy a fraction of the 3c tensor to a given subgroup (corresponding to some atoms)
2922 17098 : filter_at = .FALSE.
2923 17098 : IF (PRESENT(iatom_to_subgroup) .AND. PRESENT(dim_at) .AND. PRESENT(idx_to_at)) THEN
2924 9992 : filter_at = .TRUE.
2925 9992 : CPASSERT(nblks(dim_at) == SIZE(idx_to_at))
2926 : END IF
2927 :
2928 : !Loop over the main tensor, count how many blocks are there, which ones, and on which proc
2929 85490 : ALLOCATE (block_source(nblks(1), nblks(2), nblks(3)))
2930 1280102 : block_source = -1
2931 17098 : nocc = 0
2932 17098 : !$OMP PARALLEL DEFAULT(NONE) SHARED(t3c_main,para_env,nocc,block_source) PRIVATE(iter,ind,blk,found)
2933 : CALL dbt_iterator_start(iter, t3c_main)
2934 : DO WHILE (dbt_iterator_blocks_left(iter))
2935 : CALL dbt_iterator_next_block(iter, ind)
2936 : CALL dbt_get_block(t3c_main, ind, blk, found)
2937 : IF (.NOT. found) CYCLE
2938 :
2939 : block_source(ind(1), ind(2), ind(3)) = para_env%mepos
2940 : !$OMP ATOMIC
2941 : nocc = nocc + 1
2942 : DEALLOCATE (blk)
2943 : END DO
2944 : CALL dbt_iterator_stop(iter)
2945 : !$OMP END PARALLEL
2946 :
2947 17098 : CALL para_env%sum(nocc)
2948 17098 : CALL para_env%sum(block_source)
2949 1280102 : block_source = block_source + para_env%num_pe - 1
2950 17098 : IF (nocc == 0) RETURN
2951 :
2952 119686 : ALLOCATE (bsizes1(nblks(1)), bsizes2(nblks(2)), bsizes3(nblks(3)))
2953 17098 : CALL dbt_get_info(t3c_main, blk_size_1=bsizes1, blk_size_2=bsizes2, blk_size_3=bsizes3)
2954 :
2955 : !We go by batches, which cannot be larger than the maximum MPI tag value
2956 17098 : batch_size = MIN(para_env%get_tag_ub(), 128000, nocc*ngroups)
2957 17098 : n_batch = (nocc*ngroups)/batch_size
2958 17098 : IF (MODULO(nocc*ngroups, batch_size) /= 0) n_batch = n_batch + 1
2959 :
2960 34196 : DO i_batch = 1, n_batch
2961 : !Loop over groups, blocks and send/receive
2962 846736 : ALLOCATE (send_buff(batch_size), recv_buff(batch_size))
2963 846736 : ALLOCATE (send_req(batch_size), recv_req(batch_size))
2964 : ir = 0
2965 : is = 0
2966 : i_msg = 0
2967 : isbuff = 0
2968 51294 : DO kblk = 1, nblks(3)
2969 334902 : DO jblk = 1, nblks(2)
2970 1263004 : DO iblk = 1, nblks(1)
2971 945200 : IF (block_source(iblk, jblk, kblk) == -1) CYCLE
2972 :
2973 194586 : found = .FALSE.
2974 194586 : IF (para_env%mepos == block_source(iblk, jblk, kblk)) THEN
2975 389172 : CALL dbt_get_block(t3c_main, [iblk, jblk, kblk], blk, found)
2976 97293 : IF (found) THEN
2977 97293 : isbuff = isbuff + 1
2978 486465 : ALLOCATE (send_buff(isbuff)%array(bsizes1(iblk), bsizes2(jblk), bsizes3(kblk)))
2979 : END IF
2980 : END IF
2981 :
2982 583758 : DO igroup = 0, ngroups - 1
2983 :
2984 389172 : i_msg = i_msg + 1
2985 389172 : IF (i_msg < (i_batch - 1)*batch_size + 1 .OR. i_msg > i_batch*batch_size) CYCLE
2986 :
2987 : !a unique tag per block, within this batch
2988 389172 : tag = i_msg - (i_batch - 1)*batch_size
2989 :
2990 389172 : IF (filter_at) THEN
2991 1133584 : ind(:) = [iblk, jblk, kblk]
2992 283396 : iatom = idx_to_at(ind(dim_at))
2993 283396 : IF (.NOT. iatom_to_subgroup(iatom)%array(igroup + 1)) CYCLE
2994 : END IF
2995 :
2996 : !If blocks live on same proc, simply copy. Else MPI send/recv
2997 442060 : IF (block_source(iblk, jblk, kblk) == subgroup_dest(iblk, jblk, kblk, igroup + 1)) THEN
2998 531232 : IF (found) CALL dbt_put_block(t3c_sub, [iblk, jblk, kblk], SHAPE(blk), blk)
2999 : ELSE
3000 114666 : IF (para_env%mepos == block_source(iblk, jblk, kblk) .AND. found) THEN
3001 134557620 : send_buff(isbuff)%array(:, :, :) = blk(:, :, :)
3002 57333 : is = is + 1
3003 : CALL para_env%isend(msgin=send_buff(isbuff)%array, &
3004 : dest=subgroup_dest(iblk, jblk, kblk, igroup + 1), &
3005 57333 : request=send_req(is), tag=tag)
3006 : END IF
3007 :
3008 114666 : IF (para_env%mepos == subgroup_dest(iblk, jblk, kblk, igroup + 1)) THEN
3009 286665 : ALLOCATE (recv_buff(tag)%array(bsizes1(iblk), bsizes2(jblk), bsizes3(kblk)))
3010 57333 : ir = ir + 1
3011 : CALL para_env%irecv(msgout=recv_buff(tag)%array, source=block_source(iblk, jblk, kblk), &
3012 57333 : request=recv_req(ir), tag=tag)
3013 : END IF
3014 : END IF
3015 : END DO !igroup
3016 :
3017 478194 : IF (found) DEALLOCATE (blk)
3018 : END DO
3019 : END DO
3020 : END DO
3021 :
3022 : !Finally copy the data from the buffer to the sub-tensor
3023 : i_msg = 0
3024 : ir = 0
3025 51294 : DO kblk = 1, nblks(3)
3026 334902 : DO jblk = 1, nblks(2)
3027 1263004 : DO iblk = 1, nblks(1)
3028 3119208 : DO igroup = 0, ngroups - 1
3029 1890400 : IF (block_source(iblk, jblk, kblk) == -1) CYCLE
3030 :
3031 389172 : i_msg = i_msg + 1
3032 389172 : IF (i_msg < (i_batch - 1)*batch_size + 1 .OR. i_msg > i_batch*batch_size) CYCLE
3033 :
3034 : !a unique tag per block, within this batch
3035 389172 : tag = i_msg - (i_batch - 1)*batch_size
3036 :
3037 389172 : IF (filter_at) THEN
3038 1133584 : ind(:) = [iblk, jblk, kblk]
3039 283396 : iatom = idx_to_at(ind(dim_at))
3040 283396 : IF (.NOT. iatom_to_subgroup(iatom)%array(igroup + 1)) CYCLE
3041 : END IF
3042 :
3043 247474 : IF (para_env%mepos == subgroup_dest(iblk, jblk, kblk, igroup + 1) .AND. &
3044 945200 : block_source(iblk, jblk, kblk) /= subgroup_dest(iblk, jblk, kblk, igroup + 1)) THEN
3045 :
3046 57333 : ir = ir + 1
3047 57333 : CALL mp_waitall(recv_req(ir:ir))
3048 401331 : CALL dbt_put_block(t3c_sub, [iblk, jblk, kblk], SHAPE(recv_buff(tag)%array), recv_buff(tag)%array)
3049 : END IF
3050 : END DO
3051 : END DO
3052 : END DO
3053 : END DO
3054 :
3055 : !clean-up
3056 17098 : CALL mp_waitall(send_req(1:is))
3057 406270 : DO i = 1, batch_size
3058 389172 : IF (ASSOCIATED(recv_buff(i)%array)) DEALLOCATE (recv_buff(i)%array)
3059 406270 : IF (ASSOCIATED(send_buff(i)%array)) DEALLOCATE (send_buff(i)%array)
3060 : END DO
3061 34196 : DEALLOCATE (send_buff, recv_buff, send_req, recv_req)
3062 : END DO !i_batch
3063 17098 : CALL dbt_finalize(t3c_sub)
3064 :
3065 34196 : END SUBROUTINE copy_3c_to_subgroup
3066 :
3067 : ! **************************************************************************************************
3068 : !> \brief A routine that gather the pieces of the KS matrix accross the subgroup and puts it in the
3069 : !> main group. Each b_img, iatom, jatom tuple is one a single CPU
3070 : !> \param ks_t ...
3071 : !> \param ks_t_sub ...
3072 : !> \param group_size ...
3073 : !> \param sparsity_pattern ...
3074 : !> \param para_env ...
3075 : !> \param ri_data ...
3076 : ! **************************************************************************************************
3077 274 : SUBROUTINE gather_ks_matrix(ks_t, ks_t_sub, group_size, sparsity_pattern, para_env, ri_data)
3078 : TYPE(dbt_type), DIMENSION(:, :), INTENT(INOUT) :: ks_t, ks_t_sub
3079 : INTEGER, INTENT(IN) :: group_size
3080 : INTEGER, DIMENSION(:, :, :), INTENT(IN) :: sparsity_pattern
3081 : TYPE(mp_para_env_type), POINTER :: para_env
3082 : TYPE(hfx_ri_type), INTENT(INOUT) :: ri_data
3083 :
3084 : CHARACTER(len=*), PARAMETER :: routineN = 'gather_ks_matrix'
3085 :
3086 : INTEGER :: b_img, dest, handle, i, i_spin, iatom, &
3087 : igroup, ir, is, jatom, n_mess, natom, &
3088 : nimg, nspins, source, tag
3089 : LOGICAL :: found
3090 274 : REAL(dp), ALLOCATABLE, DIMENSION(:, :) :: blk
3091 274 : TYPE(cp_2d_r_p_type), ALLOCATABLE, DIMENSION(:) :: recv_buff, send_buff
3092 274 : TYPE(mp_request_type), ALLOCATABLE, DIMENSION(:) :: recv_req, send_req
3093 :
3094 274 : CALL timeset(routineN, handle)
3095 :
3096 274 : nimg = SIZE(sparsity_pattern, 3)
3097 274 : natom = SIZE(sparsity_pattern, 2)
3098 274 : nspins = SIZE(ks_t, 1)
3099 :
3100 8162 : DO b_img = 1, nimg
3101 : n_mess = 0
3102 17342 : DO i_spin = 1, nspins
3103 36250 : DO jatom = 1, natom
3104 66178 : DO iatom = 1, natom
3105 56724 : IF (sparsity_pattern(iatom, jatom, b_img) > -1) n_mess = n_mess + 1
3106 : END DO
3107 : END DO
3108 : END DO
3109 :
3110 57572 : ALLOCATE (send_buff(n_mess), recv_buff(n_mess))
3111 65460 : ALLOCATE (send_req(n_mess), recv_req(n_mess))
3112 7888 : ir = 0
3113 7888 : is = 0
3114 7888 : n_mess = 0
3115 7888 : tag = 0
3116 :
3117 17342 : DO i_spin = 1, nspins
3118 36250 : DO jatom = 1, natom
3119 66178 : DO iatom = 1, natom
3120 37816 : IF (sparsity_pattern(iatom, jatom, b_img) < 0) CYCLE
3121 12710 : n_mess = n_mess + 1
3122 12710 : tag = tag + 1
3123 :
3124 : !sending the message
3125 38130 : CALL dbt_get_stored_coordinates(ks_t(i_spin, b_img), [iatom, jatom], dest)
3126 38130 : CALL dbt_get_stored_coordinates(ks_t_sub(i_spin, b_img), [iatom, jatom], source) !source within sub
3127 12710 : igroup = sparsity_pattern(iatom, jatom, b_img)
3128 12710 : source = source + igroup*group_size
3129 12710 : IF (para_env%mepos == source) THEN
3130 19065 : CALL dbt_get_block(ks_t_sub(i_spin, b_img), [iatom, jatom], blk, found)
3131 6355 : IF (source == dest) THEN
3132 4133 : IF (found) CALL dbt_put_block(ks_t(i_spin, b_img), [iatom, jatom], SHAPE(blk), blk)
3133 : ELSE
3134 20872 : ALLOCATE (send_buff(n_mess)%array(ri_data%bsizes_AO(iatom), ri_data%bsizes_AO(jatom)))
3135 328700 : send_buff(n_mess)%array(:, :) = 0.0_dp
3136 5218 : IF (found) THEN
3137 230014 : send_buff(n_mess)%array(:, :) = blk(:, :)
3138 : END IF
3139 5218 : is = is + 1
3140 : CALL para_env%isend(msgin=send_buff(n_mess)%array, dest=dest, &
3141 5218 : request=send_req(is), tag=tag)
3142 : END IF
3143 6355 : DEALLOCATE (blk)
3144 : END IF
3145 :
3146 : !receiving the message
3147 31618 : IF (para_env%mepos == dest .AND. source /= dest) THEN
3148 20872 : ALLOCATE (recv_buff(n_mess)%array(ri_data%bsizes_AO(iatom), ri_data%bsizes_AO(jatom)))
3149 5218 : ir = ir + 1
3150 : CALL para_env%irecv(msgout=recv_buff(n_mess)%array, source=source, &
3151 5218 : request=recv_req(ir), tag=tag)
3152 : END IF
3153 : END DO !iatom
3154 : END DO !jatom
3155 : END DO !ispin
3156 :
3157 7888 : CALL mp_waitall(send_req(1:is))
3158 7888 : CALL mp_waitall(recv_req(1:ir))
3159 :
3160 : !Copy the messages received into the KS matrix
3161 7888 : n_mess = 0
3162 17342 : DO i_spin = 1, nspins
3163 36250 : DO jatom = 1, natom
3164 66178 : DO iatom = 1, natom
3165 37816 : IF (sparsity_pattern(iatom, jatom, b_img) < 0) CYCLE
3166 12710 : n_mess = n_mess + 1
3167 :
3168 38130 : CALL dbt_get_stored_coordinates(ks_t(i_spin, b_img), [iatom, jatom], dest)
3169 31618 : IF (para_env%mepos == dest) THEN
3170 6355 : IF (.NOT. ASSOCIATED(recv_buff(n_mess)%array)) CYCLE
3171 20872 : ALLOCATE (blk(ri_data%bsizes_AO(iatom), ri_data%bsizes_AO(jatom)))
3172 328700 : blk(:, :) = recv_buff(n_mess)%array(:, :)
3173 26090 : CALL dbt_put_block(ks_t(i_spin, b_img), [iatom, jatom], SHAPE(blk), blk)
3174 5218 : DEALLOCATE (blk)
3175 : END IF
3176 : END DO
3177 : END DO
3178 : END DO
3179 :
3180 : !clean-up
3181 20598 : DO i = 1, n_mess
3182 12710 : IF (ASSOCIATED(send_buff(i)%array)) DEALLOCATE (send_buff(i)%array)
3183 20598 : IF (ASSOCIATED(recv_buff(i)%array)) DEALLOCATE (recv_buff(i)%array)
3184 : END DO
3185 8162 : DEALLOCATE (send_buff, recv_buff, send_req, recv_req)
3186 : END DO !b_img
3187 :
3188 274 : CALL timestop(handle)
3189 :
3190 274 : END SUBROUTINE gather_ks_matrix
3191 :
3192 : ! **************************************************************************************************
3193 : !> \brief copy all required 2c tensors from the main MPI group to the subgroups
3194 : !> \param mat_2c_pot ...
3195 : !> \param t_2c_work ...
3196 : !> \param t_2c_ao_tmp ...
3197 : !> \param ks_t_split ...
3198 : !> \param ks_t_sub ...
3199 : !> \param group_size ...
3200 : !> \param ngroups ...
3201 : !> \param para_env ...
3202 : !> \param para_env_sub ...
3203 : !> \param ri_data ...
3204 : ! **************************************************************************************************
3205 274 : SUBROUTINE get_subgroup_2c_tensors(mat_2c_pot, t_2c_work, t_2c_ao_tmp, ks_t_split, ks_t_sub, &
3206 : group_size, ngroups, para_env, para_env_sub, ri_data)
3207 : TYPE(dbcsr_type), DIMENSION(:), INTENT(INOUT) :: mat_2c_pot
3208 : TYPE(dbt_type), DIMENSION(:), INTENT(INOUT) :: t_2c_work, t_2c_ao_tmp, ks_t_split
3209 : TYPE(dbt_type), DIMENSION(:, :), INTENT(INOUT) :: ks_t_sub
3210 : INTEGER, INTENT(IN) :: group_size, ngroups
3211 : TYPE(mp_para_env_type), POINTER :: para_env, para_env_sub
3212 : TYPE(hfx_ri_type), INTENT(INOUT) :: ri_data
3213 :
3214 : CHARACTER(len=*), PARAMETER :: routineN = 'get_subgroup_2c_tensors'
3215 :
3216 : INTEGER :: handle, i, i_img, i_RI, i_spin, iproc, &
3217 : j, natom, nblks, nimg, nspins
3218 : INTEGER(int_8) :: nze
3219 : INTEGER, ALLOCATABLE, DIMENSION(:) :: bsizes_RI_ext, bsizes_RI_ext_split, &
3220 274 : dist1, dist2
3221 : INTEGER, DIMENSION(2) :: pdims_2d
3222 548 : INTEGER, DIMENSION(:), POINTER :: col_dist, RI_blk_size, row_dist
3223 274 : INTEGER, DIMENSION(:, :), POINTER :: dbcsr_pgrid
3224 : REAL(dp) :: occ
3225 : TYPE(dbcsr_distribution_type) :: dbcsr_dist_sub
3226 822 : TYPE(dbt_pgrid_type) :: pgrid_2d
3227 3562 : TYPE(dbt_type) :: work, work_sub
3228 :
3229 274 : CALL timeset(routineN, handle)
3230 :
3231 : !Create the 2d pgrid
3232 274 : pdims_2d = 0
3233 274 : CALL dbt_pgrid_create(para_env_sub, pdims_2d, pgrid_2d)
3234 :
3235 274 : natom = SIZE(ri_data%bsizes_RI)
3236 274 : nblks = SIZE(ri_data%bsizes_RI_split)
3237 822 : ALLOCATE (bsizes_RI_ext(ri_data%ncell_RI*natom))
3238 822 : ALLOCATE (bsizes_RI_ext_split(ri_data%ncell_RI*nblks))
3239 1806 : DO i_RI = 1, ri_data%ncell_RI
3240 4596 : bsizes_RI_ext((i_RI - 1)*natom + 1:i_RI*natom) = ri_data%bsizes_RI(:)
3241 8632 : bsizes_RI_ext_split((i_RI - 1)*nblks + 1:i_RI*nblks) = ri_data%bsizes_RI_split(:)
3242 : END DO
3243 :
3244 : !nRI x nRI 2c tensors
3245 : CALL create_2c_tensor(t_2c_work(1), dist1, dist2, pgrid_2d, &
3246 : bsizes_RI_ext, bsizes_RI_ext, &
3247 274 : name="(RI | RI)")
3248 274 : DEALLOCATE (dist1, dist2)
3249 :
3250 : CALL create_2c_tensor(t_2c_work(2), dist1, dist2, pgrid_2d, &
3251 : bsizes_RI_ext_split, bsizes_RI_ext_split, &
3252 274 : name="(RI | RI)")
3253 274 : DEALLOCATE (dist1, dist2)
3254 :
3255 : !the AO based tensors
3256 : CALL create_2c_tensor(ks_t_split(1), dist1, dist2, pgrid_2d, &
3257 : ri_data%bsizes_AO_split, ri_data%bsizes_AO_split, &
3258 274 : name="(AO | AO)")
3259 274 : DEALLOCATE (dist1, dist2)
3260 274 : CALL dbt_create(ks_t_split(1), ks_t_split(2))
3261 :
3262 : CALL create_2c_tensor(t_2c_ao_tmp(1), dist1, dist2, pgrid_2d, &
3263 : ri_data%bsizes_AO, ri_data%bsizes_AO, &
3264 274 : name="(AO | AO)")
3265 274 : DEALLOCATE (dist1, dist2)
3266 :
3267 274 : nspins = SIZE(ks_t_sub, 1)
3268 274 : nimg = SIZE(ks_t_sub, 2)
3269 8162 : DO i_img = 1, nimg
3270 17616 : DO i_spin = 1, nspins
3271 17342 : CALL dbt_create(t_2c_ao_tmp(1), ks_t_sub(i_spin, i_img))
3272 : END DO
3273 : END DO
3274 :
3275 : !Finally the HFX potential matrices
3276 : !For now, we do a convoluted things where we go to tensors first, then back to matrices.
3277 : CALL create_2c_tensor(work_sub, dist1, dist2, pgrid_2d, &
3278 : ri_data%bsizes_RI, ri_data%bsizes_RI, &
3279 274 : name="(RI | RI)")
3280 274 : CALL dbt_create(ri_data%kp_mat_2c_pot(1, 1), work)
3281 :
3282 1096 : ALLOCATE (dbcsr_pgrid(0:pdims_2d(1) - 1, 0:pdims_2d(2) - 1))
3283 274 : iproc = 0
3284 548 : DO i = 0, pdims_2d(1) - 1
3285 822 : DO j = 0, pdims_2d(2) - 1
3286 274 : dbcsr_pgrid(i, j) = iproc
3287 548 : iproc = iproc + 1
3288 : END DO
3289 : END DO
3290 :
3291 : !We need to have the same exact 2d block dist as the tensors
3292 1096 : ALLOCATE (col_dist(natom), row_dist(natom))
3293 822 : row_dist(:) = dist1(:)
3294 822 : col_dist(:) = dist2(:)
3295 :
3296 548 : ALLOCATE (RI_blk_size(natom))
3297 822 : RI_blk_size(:) = ri_data%bsizes_RI(:)
3298 :
3299 : CALL dbcsr_distribution_new(dbcsr_dist_sub, group=para_env_sub%get_handle(), pgrid=dbcsr_pgrid, &
3300 274 : row_dist=row_dist, col_dist=col_dist)
3301 : CALL dbcsr_create(mat_2c_pot(1), dist=dbcsr_dist_sub, name="sub", matrix_type=dbcsr_type_no_symmetry, &
3302 274 : row_blk_size=RI_blk_size, col_blk_size=RI_blk_size)
3303 :
3304 8162 : DO i_img = 1, nimg
3305 7888 : IF (i_img > 1) CALL dbcsr_create(mat_2c_pot(i_img), template=mat_2c_pot(1))
3306 7888 : CALL dbt_copy_matrix_to_tensor(ri_data%kp_mat_2c_pot(1, i_img), work)
3307 7888 : CALL get_tensor_occupancy(work, nze, occ)
3308 7888 : IF (nze == 0) CYCLE
3309 :
3310 5656 : CALL copy_2c_to_subgroup(work_sub, work, group_size, ngroups, para_env)
3311 5656 : CALL dbt_copy_tensor_to_matrix(work_sub, mat_2c_pot(i_img))
3312 5656 : CALL dbcsr_filter(mat_2c_pot(i_img), ri_data%filter_eps)
3313 13818 : CALL dbt_clear(work_sub)
3314 : END DO
3315 :
3316 274 : CALL dbt_destroy(work)
3317 274 : CALL dbt_destroy(work_sub)
3318 274 : CALL dbt_pgrid_destroy(pgrid_2d)
3319 274 : CALL dbcsr_distribution_release(dbcsr_dist_sub)
3320 274 : DEALLOCATE (col_dist, row_dist, RI_blk_size, dbcsr_pgrid)
3321 274 : CALL timestop(handle)
3322 :
3323 1096 : END SUBROUTINE get_subgroup_2c_tensors
3324 :
3325 : ! **************************************************************************************************
3326 : !> \brief copy all required 3c tensors from the main MPI group to the subgroups
3327 : !> \param t_3c_int ...
3328 : !> \param t_3c_work_2 ...
3329 : !> \param t_3c_work_3 ...
3330 : !> \param t_3c_apc ...
3331 : !> \param t_3c_apc_sub ...
3332 : !> \param group_size ...
3333 : !> \param ngroups ...
3334 : !> \param para_env ...
3335 : !> \param para_env_sub ...
3336 : !> \param ri_data ...
3337 : ! **************************************************************************************************
3338 274 : SUBROUTINE get_subgroup_3c_tensors(t_3c_int, t_3c_work_2, t_3c_work_3, t_3c_apc, t_3c_apc_sub, &
3339 : group_size, ngroups, para_env, para_env_sub, ri_data)
3340 : TYPE(dbt_type), DIMENSION(:), INTENT(INOUT) :: t_3c_int, t_3c_work_2, t_3c_work_3
3341 : TYPE(dbt_type), DIMENSION(:, :), INTENT(INOUT) :: t_3c_apc, t_3c_apc_sub
3342 : INTEGER, INTENT(IN) :: group_size, ngroups
3343 : TYPE(mp_para_env_type), POINTER :: para_env, para_env_sub
3344 : TYPE(hfx_ri_type), INTENT(INOUT) :: ri_data
3345 :
3346 : CHARACTER(len=*), PARAMETER :: routineN = 'get_subgroup_3c_tensors'
3347 :
3348 : INTEGER :: batch_size, bo(2), handle, handle2, &
3349 : i_blk, i_img, i_RI, i_spin, ib, natom, &
3350 : nblks_AO, nblks_RI, nimg, nspins
3351 : INTEGER(int_8) :: nze
3352 274 : INTEGER, ALLOCATABLE, DIMENSION(:) :: bsizes_RI_ext, bsizes_RI_ext_split, &
3353 274 : bsizes_stack, bsizes_tmp, dist1, &
3354 274 : dist2, dist3, dist_stack, idx_to_at
3355 274 : INTEGER, ALLOCATABLE, DIMENSION(:, :, :, :) :: subgroup_dest
3356 : INTEGER, DIMENSION(3) :: pdims
3357 : REAL(dp) :: occ
3358 2466 : TYPE(dbt_distribution_type) :: t_dist
3359 822 : TYPE(dbt_pgrid_type) :: pgrid
3360 6850 : TYPE(dbt_type) :: tmp, work_atom_block, work_atom_block_sub
3361 :
3362 274 : CALL timeset(routineN, handle)
3363 :
3364 274 : nblks_RI = SIZE(ri_data%bsizes_RI_split)
3365 822 : ALLOCATE (bsizes_RI_ext_split(ri_data%ncell_RI*nblks_RI))
3366 1806 : DO i_RI = 1, ri_data%ncell_RI
3367 8632 : bsizes_RI_ext_split((i_RI - 1)*nblks_RI + 1:i_RI*nblks_RI) = ri_data%bsizes_RI_split(:)
3368 : END DO
3369 :
3370 : !Preparing larger block sizes for efficient communication (less, bigger messages)
3371 274 : natom = SIZE(ri_data%bsizes_RI)
3372 274 : nblks_RI = natom
3373 822 : ALLOCATE (bsizes_tmp(nblks_RI))
3374 822 : DO i_blk = 1, nblks_RI
3375 548 : bo = get_limit(natom, nblks_RI, i_blk - 1)
3376 1370 : bsizes_tmp(i_blk) = SUM(ri_data%bsizes_RI(bo(1):bo(2)))
3377 : END DO
3378 822 : ALLOCATE (bsizes_RI_ext(ri_data%ncell_RI*nblks_RI))
3379 1806 : DO i_RI = 1, ri_data%ncell_RI
3380 4870 : bsizes_RI_ext((i_RI - 1)*nblks_RI + 1:i_RI*nblks_RI) = bsizes_tmp(:)
3381 : END DO
3382 :
3383 274 : batch_size = ri_data%kp_stack_size
3384 274 : nblks_AO = SIZE(ri_data%bsizes_AO_split)
3385 822 : ALLOCATE (bsizes_stack(batch_size*nblks_AO))
3386 5586 : DO ib = 1, batch_size
3387 22898 : bsizes_stack((ib - 1)*nblks_AO + 1:ib*nblks_AO) = ri_data%bsizes_AO_split(:)
3388 : END DO
3389 :
3390 : !Create the pgrid for the configuration correspoinding to ri_data%t_3c_int_ctr_3
3391 274 : natom = SIZE(ri_data%bsizes_RI)
3392 274 : pdims = 0
3393 : CALL dbt_pgrid_create(para_env_sub, pdims, pgrid, &
3394 1096 : tensor_dims=[SIZE(bsizes_RI_ext_split), 1, batch_size*SIZE(ri_data%bsizes_AO_split)])
3395 :
3396 : !Create all required 3c tensors in that configuration
3397 : CALL create_3c_tensor(t_3c_int(1), dist1, dist2, dist3, &
3398 : pgrid, bsizes_RI_ext_split, ri_data%bsizes_AO_split, &
3399 274 : ri_data%bsizes_AO_split, [1], [2, 3], name="(RI | AO AO)")
3400 274 : nimg = SIZE(t_3c_int)
3401 7888 : DO i_img = 2, nimg
3402 7888 : CALL dbt_create(t_3c_int(1), t_3c_int(i_img))
3403 : END DO
3404 :
3405 : !The stacked work tensors, in a distribution that matches that of t_3c_int
3406 548 : ALLOCATE (dist_stack(batch_size*nblks_AO))
3407 5586 : DO ib = 1, batch_size
3408 22898 : dist_stack((ib - 1)*nblks_AO + 1:ib*nblks_AO) = dist3(:)
3409 : END DO
3410 :
3411 274 : CALL dbt_distribution_new(t_dist, pgrid, dist1, dist2, dist_stack)
3412 : CALL dbt_create(t_3c_work_3(1), "work_3_stack", t_dist, [1], [2, 3], &
3413 274 : bsizes_RI_ext_split, ri_data%bsizes_AO_split, bsizes_stack)
3414 274 : CALL dbt_create(t_3c_work_3(1), t_3c_work_3(2))
3415 274 : CALL dbt_create(t_3c_work_3(1), t_3c_work_3(3))
3416 274 : CALL dbt_distribution_destroy(t_dist)
3417 274 : DEALLOCATE (dist1, dist2, dist3, dist_stack)
3418 :
3419 : !For more efficient communication, we use intermediate tensors with larger block size
3420 : CALL create_3c_tensor(work_atom_block_sub, dist1, dist2, dist3, &
3421 : pgrid, bsizes_RI_ext, ri_data%bsizes_AO, &
3422 274 : ri_data%bsizes_AO, [1], [2, 3], name="(RI | AO AO)")
3423 274 : DEALLOCATE (dist1, dist2, dist3)
3424 :
3425 : CALL create_3c_tensor(work_atom_block, dist1, dist2, dist3, &
3426 : ri_data%pgrid, bsizes_RI_ext, ri_data%bsizes_AO, &
3427 274 : ri_data%bsizes_AO, [1], [2, 3], name="(RI | AO AO)")
3428 274 : DEALLOCATE (dist1, dist2, dist3)
3429 :
3430 : CALL get_3c_subgroup_dest(subgroup_dest, work_atom_block_sub, work_atom_block, &
3431 274 : group_size, ngroups, para_env)
3432 :
3433 : !Finally copy the integrals into the subgroups (if not there already)
3434 274 : CALL timeset(routineN//"_ints", handle2)
3435 274 : IF (ALLOCATED(ri_data%kp_t_3c_int)) THEN
3436 5720 : DO i_img = 1, nimg
3437 5720 : CALL dbt_copy(ri_data%kp_t_3c_int(i_img), t_3c_int(i_img), move_data=.TRUE.)
3438 : END DO
3439 : ELSE
3440 3322 : ALLOCATE (ri_data%kp_t_3c_int(nimg))
3441 2442 : DO i_img = 1, nimg
3442 2354 : CALL dbt_create(t_3c_int(i_img), ri_data%kp_t_3c_int(i_img))
3443 2354 : CALL get_tensor_occupancy(ri_data%t_3c_int_ctr_1(1, i_img), nze, occ)
3444 2354 : IF (nze == 0) CYCLE
3445 2128 : CALL dbt_copy(ri_data%t_3c_int_ctr_1(1, i_img), work_atom_block, order=[2, 1, 3])
3446 : CALL copy_3c_to_subgroup(work_atom_block_sub, work_atom_block, &
3447 2128 : ngroups, para_env, subgroup_dest)
3448 2128 : CALL dbt_copy(work_atom_block_sub, t_3c_int(i_img), move_data=.TRUE.)
3449 4570 : CALL dbt_filter(t_3c_int(i_img), ri_data%filter_eps)
3450 : END DO
3451 : END IF
3452 274 : CALL timestop(handle2)
3453 274 : CALL dbt_pgrid_destroy(pgrid)
3454 274 : CALL dbt_destroy(work_atom_block)
3455 274 : CALL dbt_destroy(work_atom_block_sub)
3456 274 : DEALLOCATE (subgroup_dest)
3457 :
3458 : !Do the same for the t_3c_ctr_2 configuration
3459 274 : pdims = 0
3460 : CALL dbt_pgrid_create(para_env_sub, pdims, pgrid, &
3461 1096 : tensor_dims=[1, SIZE(bsizes_RI_ext_split), batch_size*SIZE(ri_data%bsizes_AO_split)])
3462 :
3463 : !For more efficient communication, we use intermediate tensors with larger block size
3464 : CALL create_3c_tensor(work_atom_block_sub, dist1, dist2, dist3, &
3465 : pgrid, ri_data%bsizes_AO, bsizes_RI_ext, &
3466 274 : ri_data%bsizes_AO, [1], [2, 3], name="(AO RI | AO)")
3467 274 : DEALLOCATE (dist1, dist2, dist3)
3468 :
3469 : CALL create_3c_tensor(work_atom_block, dist1, dist2, dist3, &
3470 : ri_data%pgrid_1, ri_data%bsizes_AO, bsizes_RI_ext, &
3471 274 : ri_data%bsizes_AO, [1], [2, 3], name="(AO RI | AO)")
3472 274 : DEALLOCATE (dist1, dist2, dist3)
3473 :
3474 : CALL get_3c_subgroup_dest(subgroup_dest, work_atom_block_sub, work_atom_block, &
3475 274 : group_size, ngroups, para_env)
3476 :
3477 : !template for t_3c_apc_sub
3478 : CALL create_3c_tensor(tmp, dist1, dist2, dist3, &
3479 : pgrid, ri_data%bsizes_AO_split, bsizes_RI_ext_split, &
3480 274 : ri_data%bsizes_AO_split, [1], [2, 3], name="(AO RI | AO)")
3481 :
3482 : !create t_3c_work_2 tensors in a distribution that matches the above
3483 548 : ALLOCATE (dist_stack(batch_size*nblks_AO))
3484 5586 : DO ib = 1, batch_size
3485 22898 : dist_stack((ib - 1)*nblks_AO + 1:ib*nblks_AO) = dist3(:)
3486 : END DO
3487 :
3488 274 : CALL dbt_distribution_new(t_dist, pgrid, dist1, dist2, dist_stack)
3489 : CALL dbt_create(t_3c_work_2(1), "work_2_stack", t_dist, [1], [2, 3], &
3490 274 : ri_data%bsizes_AO_split, bsizes_RI_ext_split, bsizes_stack)
3491 274 : CALL dbt_create(t_3c_work_2(1), t_3c_work_2(2))
3492 274 : CALL dbt_create(t_3c_work_2(1), t_3c_work_2(3))
3493 274 : CALL dbt_distribution_destroy(t_dist)
3494 274 : DEALLOCATE (dist1, dist2, dist3, dist_stack)
3495 :
3496 : !Finally copy data from t_3c_apc to the subgroups
3497 822 : ALLOCATE (idx_to_at(SIZE(ri_data%bsizes_AO)))
3498 274 : CALL get_idx_to_atom(idx_to_at, ri_data%bsizes_AO, ri_data%bsizes_AO)
3499 274 : nspins = SIZE(t_3c_apc, 1)
3500 274 : CALL timeset(routineN//"_apc", handle2)
3501 8162 : DO i_img = 1, nimg
3502 17342 : DO i_spin = 1, nspins
3503 9454 : CALL dbt_create(tmp, t_3c_apc_sub(i_spin, i_img))
3504 9454 : CALL get_tensor_occupancy(t_3c_apc(i_spin, i_img), nze, occ)
3505 9454 : IF (nze == 0) CYCLE
3506 8438 : CALL dbt_copy(t_3c_apc(i_spin, i_img), work_atom_block, move_data=.TRUE.)
3507 : CALL copy_3c_to_subgroup(work_atom_block_sub, work_atom_block, ngroups, para_env, &
3508 8438 : subgroup_dest, ri_data%iatom_to_subgroup, 1, idx_to_at)
3509 8438 : CALL dbt_copy(work_atom_block_sub, t_3c_apc_sub(i_spin, i_img), move_data=.TRUE.)
3510 25780 : CALL dbt_filter(t_3c_apc_sub(i_spin, i_img), ri_data%filter_eps)
3511 : END DO
3512 17616 : DO i_spin = 1, nspins
3513 17342 : CALL dbt_destroy(t_3c_apc(i_spin, i_img))
3514 : END DO
3515 : END DO
3516 274 : CALL timestop(handle2)
3517 274 : CALL dbt_pgrid_destroy(pgrid)
3518 274 : CALL dbt_destroy(tmp)
3519 274 : CALL dbt_destroy(work_atom_block)
3520 274 : CALL dbt_destroy(work_atom_block_sub)
3521 :
3522 274 : CALL timestop(handle)
3523 :
3524 1096 : END SUBROUTINE get_subgroup_3c_tensors
3525 :
3526 : ! **************************************************************************************************
3527 : !> \brief copy all required 2c force tensors from the main MPI group to the subgroups
3528 : !> \param t_2c_inv ...
3529 : !> \param t_2c_bint ...
3530 : !> \param t_2c_metric ...
3531 : !> \param mat_2c_pot ...
3532 : !> \param t_2c_work ...
3533 : !> \param rho_ao_t ...
3534 : !> \param rho_ao_t_sub ...
3535 : !> \param t_2c_der_metric ...
3536 : !> \param t_2c_der_metric_sub ...
3537 : !> \param mat_der_pot ...
3538 : !> \param mat_der_pot_sub ...
3539 : !> \param group_size ...
3540 : !> \param ngroups ...
3541 : !> \param para_env ...
3542 : !> \param para_env_sub ...
3543 : !> \param ri_data ...
3544 : !> \note Main MPI group tensors are deleted within this routine, for memory optimization
3545 : ! **************************************************************************************************
3546 100 : SUBROUTINE get_subgroup_2c_derivs(t_2c_inv, t_2c_bint, t_2c_metric, mat_2c_pot, t_2c_work, rho_ao_t, &
3547 50 : rho_ao_t_sub, t_2c_der_metric, t_2c_der_metric_sub, mat_der_pot, &
3548 50 : mat_der_pot_sub, group_size, ngroups, para_env, para_env_sub, ri_data)
3549 : TYPE(dbt_type), DIMENSION(:), INTENT(INOUT) :: t_2c_inv, t_2c_bint, t_2c_metric
3550 : TYPE(dbcsr_type), DIMENSION(:), INTENT(INOUT) :: mat_2c_pot
3551 : TYPE(dbt_type), DIMENSION(:), INTENT(INOUT) :: t_2c_work
3552 : TYPE(dbt_type), DIMENSION(:, :), INTENT(INOUT) :: rho_ao_t, rho_ao_t_sub, t_2c_der_metric, &
3553 : t_2c_der_metric_sub
3554 : TYPE(dbcsr_type), DIMENSION(:, :), INTENT(INOUT) :: mat_der_pot, mat_der_pot_sub
3555 : INTEGER, INTENT(IN) :: group_size, ngroups
3556 : TYPE(mp_para_env_type), POINTER :: para_env, para_env_sub
3557 : TYPE(hfx_ri_type), INTENT(INOUT) :: ri_data
3558 :
3559 : CHARACTER(len=*), PARAMETER :: routineN = 'get_subgroup_2c_derivs'
3560 :
3561 : INTEGER :: handle, i, i_img, i_RI, i_spin, i_xyz, &
3562 : iatom, iproc, j, natom, nblks, nimg, &
3563 : nspins
3564 : INTEGER(int_8) :: nze
3565 : INTEGER, ALLOCATABLE, DIMENSION(:) :: bsizes_RI_ext, bsizes_RI_ext_split, &
3566 50 : dist1, dist2
3567 : INTEGER, DIMENSION(2) :: pdims_2d
3568 100 : INTEGER, DIMENSION(:), POINTER :: col_dist, RI_blk_size, row_dist
3569 50 : INTEGER, DIMENSION(:, :), POINTER :: dbcsr_pgrid
3570 : REAL(dp) :: occ
3571 : TYPE(dbcsr_distribution_type) :: dbcsr_dist_sub
3572 150 : TYPE(dbt_pgrid_type) :: pgrid_2d
3573 650 : TYPE(dbt_type) :: work, work_sub
3574 :
3575 50 : CALL timeset(routineN, handle)
3576 :
3577 : !Note: a fair portion of this routine is copied from the energy version of it
3578 : !Create the 2d pgrid
3579 50 : pdims_2d = 0
3580 50 : CALL dbt_pgrid_create(para_env_sub, pdims_2d, pgrid_2d)
3581 :
3582 50 : natom = SIZE(ri_data%bsizes_RI)
3583 50 : nblks = SIZE(ri_data%bsizes_RI_split)
3584 150 : ALLOCATE (bsizes_RI_ext(ri_data%ncell_RI*natom))
3585 150 : ALLOCATE (bsizes_RI_ext_split(ri_data%ncell_RI*nblks))
3586 366 : DO i_RI = 1, ri_data%ncell_RI
3587 948 : bsizes_RI_ext((i_RI - 1)*natom + 1:i_RI*natom) = ri_data%bsizes_RI(:)
3588 1802 : bsizes_RI_ext_split((i_RI - 1)*nblks + 1:i_RI*nblks) = ri_data%bsizes_RI_split(:)
3589 : END DO
3590 :
3591 : !nRI x nRI 2c tensors
3592 : CALL create_2c_tensor(t_2c_inv(1), dist1, dist2, pgrid_2d, &
3593 : bsizes_RI_ext, bsizes_RI_ext, &
3594 50 : name="(RI | RI)")
3595 50 : DEALLOCATE (dist1, dist2)
3596 :
3597 50 : CALL dbt_create(t_2c_inv(1), t_2c_bint(1))
3598 50 : CALL dbt_create(t_2c_inv(1), t_2c_metric(1))
3599 100 : DO iatom = 2, natom
3600 50 : CALL dbt_create(t_2c_inv(1), t_2c_inv(iatom))
3601 50 : CALL dbt_create(t_2c_inv(1), t_2c_bint(iatom))
3602 100 : CALL dbt_create(t_2c_inv(1), t_2c_metric(iatom))
3603 : END DO
3604 50 : CALL dbt_create(t_2c_inv(1), t_2c_work(1))
3605 50 : CALL dbt_create(t_2c_inv(1), t_2c_work(2))
3606 50 : CALL dbt_create(t_2c_inv(1), t_2c_work(3))
3607 50 : CALL dbt_create(t_2c_inv(1), t_2c_work(4))
3608 :
3609 : CALL create_2c_tensor(t_2c_work(5), dist1, dist2, pgrid_2d, &
3610 : bsizes_RI_ext_split, bsizes_RI_ext_split, &
3611 50 : name="(RI | RI)")
3612 50 : DEALLOCATE (dist1, dist2)
3613 :
3614 : !copy the data from the main group.
3615 150 : DO iatom = 1, natom
3616 100 : CALL copy_2c_to_subgroup(t_2c_inv(iatom), ri_data%t_2c_inv(1, iatom), group_size, ngroups, para_env)
3617 100 : CALL copy_2c_to_subgroup(t_2c_bint(iatom), ri_data%t_2c_int(1, iatom), group_size, ngroups, para_env)
3618 150 : CALL copy_2c_to_subgroup(t_2c_metric(iatom), ri_data%t_2c_pot(1, iatom), group_size, ngroups, para_env)
3619 : END DO
3620 :
3621 : !This includes the derivatives of the RI metric, for which there is one per atom
3622 200 : DO i_xyz = 1, 3
3623 500 : DO iatom = 1, natom
3624 300 : CALL dbt_create(t_2c_inv(1), t_2c_der_metric_sub(iatom, i_xyz))
3625 : CALL copy_2c_to_subgroup(t_2c_der_metric_sub(iatom, i_xyz), t_2c_der_metric(iatom, i_xyz), &
3626 300 : group_size, ngroups, para_env)
3627 450 : CALL dbt_destroy(t_2c_der_metric(iatom, i_xyz))
3628 : END DO
3629 : END DO
3630 :
3631 : !AO x AO 2c tensors
3632 : CALL create_2c_tensor(rho_ao_t_sub(1, 1), dist1, dist2, pgrid_2d, &
3633 : ri_data%bsizes_AO_split, ri_data%bsizes_AO_split, &
3634 50 : name="(AO | AO)")
3635 50 : DEALLOCATE (dist1, dist2)
3636 50 : nspins = SIZE(rho_ao_t, 1)
3637 50 : nimg = SIZE(rho_ao_t, 2)
3638 :
3639 1472 : DO i_img = 1, nimg
3640 3074 : DO i_spin = 1, nspins
3641 1602 : IF (.NOT. (i_img == 1 .AND. i_spin == 1)) THEN
3642 1552 : CALL dbt_create(rho_ao_t_sub(1, 1), rho_ao_t_sub(i_spin, i_img))
3643 : END IF
3644 : CALL copy_2c_to_subgroup(rho_ao_t_sub(i_spin, i_img), rho_ao_t(i_spin, i_img), &
3645 1602 : group_size, ngroups, para_env)
3646 3024 : CALL dbt_destroy(rho_ao_t(i_spin, i_img))
3647 : END DO
3648 : END DO
3649 :
3650 : !The RIxRI matrices, going through tensors
3651 : CALL create_2c_tensor(work_sub, dist1, dist2, pgrid_2d, &
3652 : ri_data%bsizes_RI, ri_data%bsizes_RI, &
3653 50 : name="(RI | RI)")
3654 50 : CALL dbt_create(ri_data%kp_mat_2c_pot(1, 1), work)
3655 :
3656 200 : ALLOCATE (dbcsr_pgrid(0:pdims_2d(1) - 1, 0:pdims_2d(2) - 1))
3657 50 : iproc = 0
3658 100 : DO i = 0, pdims_2d(1) - 1
3659 150 : DO j = 0, pdims_2d(2) - 1
3660 50 : dbcsr_pgrid(i, j) = iproc
3661 100 : iproc = iproc + 1
3662 : END DO
3663 : END DO
3664 :
3665 : !We need to have the same exact 2d block dist as the tensors
3666 200 : ALLOCATE (col_dist(natom), row_dist(natom))
3667 150 : row_dist(:) = dist1(:)
3668 150 : col_dist(:) = dist2(:)
3669 :
3670 100 : ALLOCATE (RI_blk_size(natom))
3671 150 : RI_blk_size(:) = ri_data%bsizes_RI(:)
3672 :
3673 : CALL dbcsr_distribution_new(dbcsr_dist_sub, group=para_env_sub%get_handle(), pgrid=dbcsr_pgrid, &
3674 50 : row_dist=row_dist, col_dist=col_dist)
3675 : CALL dbcsr_create(mat_2c_pot(1), dist=dbcsr_dist_sub, name="sub", matrix_type=dbcsr_type_no_symmetry, &
3676 50 : row_blk_size=RI_blk_size, col_blk_size=RI_blk_size)
3677 :
3678 : !The HFX potential
3679 1472 : DO i_img = 1, nimg
3680 1422 : IF (i_img > 1) CALL dbcsr_create(mat_2c_pot(i_img), template=mat_2c_pot(1))
3681 1422 : CALL dbt_copy_matrix_to_tensor(ri_data%kp_mat_2c_pot(1, i_img), work)
3682 1422 : CALL get_tensor_occupancy(work, nze, occ)
3683 1422 : IF (nze == 0) CYCLE
3684 :
3685 822 : CALL copy_2c_to_subgroup(work_sub, work, group_size, ngroups, para_env)
3686 822 : CALL dbt_copy_tensor_to_matrix(work_sub, mat_2c_pot(i_img))
3687 822 : CALL dbcsr_filter(mat_2c_pot(i_img), ri_data%filter_eps)
3688 2294 : CALL dbt_clear(work_sub)
3689 : END DO
3690 :
3691 : !The derivatives of the HFX potential
3692 200 : DO i_xyz = 1, 3
3693 4466 : DO i_img = 1, nimg
3694 4266 : CALL dbcsr_create(mat_der_pot_sub(i_img, i_xyz), template=mat_2c_pot(1))
3695 4266 : CALL dbt_copy_matrix_to_tensor(mat_der_pot(i_img, i_xyz), work)
3696 4266 : CALL dbcsr_release(mat_der_pot(i_img, i_xyz))
3697 4266 : CALL get_tensor_occupancy(work, nze, occ)
3698 4266 : IF (nze == 0) CYCLE
3699 :
3700 2458 : CALL copy_2c_to_subgroup(work_sub, work, group_size, ngroups, para_env)
3701 2458 : CALL dbt_copy_tensor_to_matrix(work_sub, mat_der_pot_sub(i_img, i_xyz))
3702 2458 : CALL dbcsr_filter(mat_der_pot_sub(i_img, i_xyz), ri_data%filter_eps)
3703 6874 : CALL dbt_clear(work_sub)
3704 : END DO
3705 : END DO
3706 :
3707 50 : CALL dbt_destroy(work)
3708 50 : CALL dbt_destroy(work_sub)
3709 50 : CALL dbt_pgrid_destroy(pgrid_2d)
3710 50 : CALL dbcsr_distribution_release(dbcsr_dist_sub)
3711 50 : DEALLOCATE (col_dist, row_dist, RI_blk_size, dbcsr_pgrid)
3712 :
3713 50 : CALL timestop(handle)
3714 :
3715 200 : END SUBROUTINE get_subgroup_2c_derivs
3716 :
3717 : ! **************************************************************************************************
3718 : !> \brief copy all required 3c derivative tensors from the main MPI group to the subgroups
3719 : !> \param t_3c_work_2 ...
3720 : !> \param t_3c_work_3 ...
3721 : !> \param t_3c_der_AO ...
3722 : !> \param t_3c_der_AO_sub ...
3723 : !> \param t_3c_der_RI ...
3724 : !> \param t_3c_der_RI_sub ...
3725 : !> \param t_3c_apc ...
3726 : !> \param t_3c_apc_sub ...
3727 : !> \param t_3c_der_stack ...
3728 : !> \param group_size ...
3729 : !> \param ngroups ...
3730 : !> \param para_env ...
3731 : !> \param para_env_sub ...
3732 : !> \param ri_data ...
3733 : !> \note the tensor containing the derivatives in the main MPI group are deleted for memory
3734 : ! **************************************************************************************************
3735 50 : SUBROUTINE get_subgroup_3c_derivs(t_3c_work_2, t_3c_work_3, t_3c_der_AO, t_3c_der_AO_sub, &
3736 50 : t_3c_der_RI, t_3c_der_RI_sub, t_3c_apc, t_3c_apc_sub, &
3737 50 : t_3c_der_stack, group_size, ngroups, para_env, para_env_sub, &
3738 : ri_data)
3739 : TYPE(dbt_type), DIMENSION(:), INTENT(INOUT) :: t_3c_work_2, t_3c_work_3
3740 : TYPE(dbt_type), DIMENSION(:, :), INTENT(INOUT) :: t_3c_der_AO, t_3c_der_AO_sub, &
3741 : t_3c_der_RI, t_3c_der_RI_sub, &
3742 : t_3c_apc, t_3c_apc_sub
3743 : TYPE(dbt_type), DIMENSION(:), INTENT(INOUT) :: t_3c_der_stack
3744 : INTEGER, INTENT(IN) :: group_size, ngroups
3745 : TYPE(mp_para_env_type), POINTER :: para_env, para_env_sub
3746 : TYPE(hfx_ri_type), INTENT(INOUT) :: ri_data
3747 :
3748 : CHARACTER(len=*), PARAMETER :: routineN = 'get_subgroup_3c_derivs'
3749 :
3750 : INTEGER :: batch_size, handle, i_img, i_RI, i_spin, &
3751 : i_xyz, ib, nblks_AO, nblks_RI, nimg, &
3752 : nspins, pdims(3)
3753 : INTEGER(int_8) :: nze
3754 50 : INTEGER, ALLOCATABLE, DIMENSION(:) :: bsizes_RI_ext, bsizes_RI_ext_split, &
3755 50 : bsizes_stack, dist1, dist2, dist3, &
3756 50 : dist_stack, idx_to_at
3757 50 : INTEGER, ALLOCATABLE, DIMENSION(:, :, :, :) :: subgroup_dest
3758 : REAL(dp) :: occ
3759 450 : TYPE(dbt_distribution_type) :: t_dist
3760 150 : TYPE(dbt_pgrid_type) :: pgrid
3761 1250 : TYPE(dbt_type) :: tmp, work_atom_block, work_atom_block_sub
3762 :
3763 50 : CALL timeset(routineN, handle)
3764 :
3765 : !We use intermediate tensors with larger block size for more optimized communication
3766 50 : nblks_RI = SIZE(ri_data%bsizes_RI)
3767 150 : ALLOCATE (bsizes_RI_ext(ri_data%ncell_RI*nblks_RI))
3768 366 : DO i_RI = 1, ri_data%ncell_RI
3769 998 : bsizes_RI_ext((i_RI - 1)*nblks_RI + 1:i_RI*nblks_RI) = ri_data%bsizes_RI(:)
3770 : END DO
3771 :
3772 50 : CALL dbt_get_info(ri_data%kp_t_3c_int(1), pdims=pdims)
3773 50 : CALL dbt_pgrid_create(para_env_sub, pdims, pgrid)
3774 :
3775 : CALL create_3c_tensor(work_atom_block_sub, dist1, dist2, dist3, &
3776 : pgrid, bsizes_RI_ext, ri_data%bsizes_AO, &
3777 50 : ri_data%bsizes_AO, [1], [2, 3], name="(RI | AO AO)")
3778 50 : DEALLOCATE (dist1, dist2, dist3)
3779 :
3780 : CALL create_3c_tensor(work_atom_block, dist1, dist2, dist3, &
3781 : ri_data%pgrid_2, bsizes_RI_ext, ri_data%bsizes_AO, &
3782 50 : ri_data%bsizes_AO, [1], [2, 3], name="(RI | AO AO)")
3783 50 : DEALLOCATE (dist1, dist2, dist3)
3784 50 : CALL dbt_pgrid_destroy(pgrid)
3785 :
3786 : CALL get_3c_subgroup_dest(subgroup_dest, work_atom_block_sub, work_atom_block, &
3787 50 : group_size, ngroups, para_env)
3788 :
3789 : !We use the 3c integrals on the subgroup as template for the derivatives
3790 50 : nimg = ri_data%nimg
3791 200 : DO i_xyz = 1, 3
3792 4416 : DO i_img = 1, nimg
3793 4266 : CALL dbt_create(ri_data%kp_t_3c_int(1), t_3c_der_AO_sub(i_img, i_xyz))
3794 4266 : CALL get_tensor_occupancy(t_3c_der_AO(i_img, i_xyz), nze, occ)
3795 4266 : IF (nze == 0) CYCLE
3796 :
3797 2510 : CALL dbt_copy(t_3c_der_AO(i_img, i_xyz), work_atom_block, move_data=.TRUE.)
3798 : CALL copy_3c_to_subgroup(work_atom_block_sub, work_atom_block, &
3799 2510 : ngroups, para_env, subgroup_dest)
3800 2510 : CALL dbt_copy(work_atom_block_sub, t_3c_der_AO_sub(i_img, i_xyz), move_data=.TRUE.)
3801 6926 : CALL dbt_filter(t_3c_der_AO_sub(i_img, i_xyz), ri_data%filter_eps)
3802 : END DO
3803 :
3804 4416 : DO i_img = 1, nimg
3805 4266 : CALL dbt_create(ri_data%kp_t_3c_int(1), t_3c_der_RI_sub(i_img, i_xyz))
3806 4266 : CALL get_tensor_occupancy(t_3c_der_RI(i_img, i_xyz), nze, occ)
3807 4266 : IF (nze == 0) CYCLE
3808 :
3809 2468 : CALL dbt_copy(t_3c_der_RI(i_img, i_xyz), work_atom_block, move_data=.TRUE.)
3810 : CALL copy_3c_to_subgroup(work_atom_block_sub, work_atom_block, &
3811 2468 : ngroups, para_env, subgroup_dest)
3812 2468 : CALL dbt_copy(work_atom_block_sub, t_3c_der_RI_sub(i_img, i_xyz), move_data=.TRUE.)
3813 6884 : CALL dbt_filter(t_3c_der_RI_sub(i_img, i_xyz), ri_data%filter_eps)
3814 : END DO
3815 :
3816 4466 : DO i_img = 1, nimg
3817 4266 : CALL dbt_destroy(t_3c_der_RI(i_img, i_xyz))
3818 4416 : CALL dbt_destroy(t_3c_der_AO(i_img, i_xyz))
3819 : END DO
3820 : END DO
3821 50 : CALL dbt_destroy(work_atom_block_sub)
3822 50 : CALL dbt_destroy(work_atom_block)
3823 50 : DEALLOCATE (subgroup_dest)
3824 :
3825 : !Deal with t_3c_apc
3826 50 : nblks_RI = SIZE(ri_data%bsizes_RI_split)
3827 150 : ALLOCATE (bsizes_RI_ext_split(ri_data%ncell_RI*nblks_RI))
3828 366 : DO i_RI = 1, ri_data%ncell_RI
3829 1802 : bsizes_RI_ext_split((i_RI - 1)*nblks_RI + 1:i_RI*nblks_RI) = ri_data%bsizes_RI_split(:)
3830 : END DO
3831 :
3832 50 : pdims = 0
3833 : CALL dbt_pgrid_create(para_env_sub, pdims, pgrid, &
3834 200 : tensor_dims=[1, SIZE(bsizes_RI_ext_split), batch_size*SIZE(ri_data%bsizes_AO_split)])
3835 :
3836 : CALL create_3c_tensor(work_atom_block_sub, dist1, dist2, dist3, &
3837 : pgrid, ri_data%bsizes_AO, bsizes_RI_ext, &
3838 50 : ri_data%bsizes_AO, [1], [2, 3], name="(AO RI | AO)")
3839 50 : DEALLOCATE (dist1, dist2, dist3)
3840 :
3841 : CALL create_3c_tensor(work_atom_block, dist1, dist2, dist3, &
3842 : ri_data%pgrid_1, ri_data%bsizes_AO, bsizes_RI_ext, &
3843 50 : ri_data%bsizes_AO, [1], [2, 3], name="(AO RI | AO)")
3844 50 : DEALLOCATE (dist1, dist2, dist3)
3845 :
3846 : CALL create_3c_tensor(tmp, dist1, dist2, dist3, &
3847 : pgrid, ri_data%bsizes_AO_split, bsizes_RI_ext_split, &
3848 50 : ri_data%bsizes_AO_split, [1], [2, 3], name="(AO RI | AO)")
3849 50 : DEALLOCATE (dist1, dist2, dist3)
3850 :
3851 : CALL get_3c_subgroup_dest(subgroup_dest, work_atom_block_sub, work_atom_block, &
3852 50 : group_size, ngroups, para_env)
3853 :
3854 150 : ALLOCATE (idx_to_at(SIZE(ri_data%bsizes_AO)))
3855 50 : CALL get_idx_to_atom(idx_to_at, ri_data%bsizes_AO, ri_data%bsizes_AO)
3856 50 : nspins = SIZE(t_3c_apc, 1)
3857 1472 : DO i_img = 1, nimg
3858 3024 : DO i_spin = 1, nspins
3859 1602 : CALL dbt_create(tmp, t_3c_apc_sub(i_spin, i_img))
3860 1602 : CALL get_tensor_occupancy(t_3c_apc(i_spin, i_img), nze, occ)
3861 1602 : IF (nze == 0) CYCLE
3862 1554 : CALL dbt_copy(t_3c_apc(i_spin, i_img), work_atom_block, move_data=.TRUE.)
3863 : CALL copy_3c_to_subgroup(work_atom_block_sub, work_atom_block, ngroups, para_env, &
3864 1554 : subgroup_dest, ri_data%iatom_to_subgroup, 1, idx_to_at)
3865 1554 : CALL dbt_copy(work_atom_block_sub, t_3c_apc_sub(i_spin, i_img), move_data=.TRUE.)
3866 4578 : CALL dbt_filter(t_3c_apc_sub(i_spin, i_img), ri_data%filter_eps)
3867 : END DO
3868 3074 : DO i_spin = 1, nspins
3869 3024 : CALL dbt_destroy(t_3c_apc(i_spin, i_img))
3870 : END DO
3871 : END DO
3872 50 : CALL dbt_destroy(tmp)
3873 50 : CALL dbt_destroy(work_atom_block)
3874 50 : CALL dbt_destroy(work_atom_block_sub)
3875 50 : CALL dbt_pgrid_destroy(pgrid)
3876 :
3877 : !t_3c_work_3 based on structure of 3c integrals/derivs
3878 50 : batch_size = ri_data%kp_stack_size
3879 50 : nblks_AO = SIZE(ri_data%bsizes_AO_split)
3880 150 : ALLOCATE (bsizes_stack(batch_size*nblks_AO))
3881 882 : DO ib = 1, batch_size
3882 4050 : bsizes_stack((ib - 1)*nblks_AO + 1:ib*nblks_AO) = ri_data%bsizes_AO_split(:)
3883 : END DO
3884 :
3885 300 : ALLOCATE (dist1(ri_data%ncell_RI*nblks_RI), dist2(nblks_AO), dist3(nblks_AO))
3886 : CALL dbt_get_info(ri_data%kp_t_3c_int(1), proc_dist_1=dist1, proc_dist_2=dist2, &
3887 50 : proc_dist_3=dist3, pdims=pdims)
3888 :
3889 100 : ALLOCATE (dist_stack(batch_size*nblks_AO))
3890 882 : DO ib = 1, batch_size
3891 4050 : dist_stack((ib - 1)*nblks_AO + 1:ib*nblks_AO) = dist3(:)
3892 : END DO
3893 :
3894 50 : CALL dbt_pgrid_create(para_env_sub, pdims, pgrid)
3895 50 : CALL dbt_distribution_new(t_dist, pgrid, dist1, dist2, dist_stack)
3896 : CALL dbt_create(t_3c_work_3(1), "work_3_stack", t_dist, [1], [2, 3], &
3897 50 : bsizes_RI_ext_split, ri_data%bsizes_AO_split, bsizes_stack)
3898 50 : CALL dbt_create(t_3c_work_3(1), t_3c_work_3(2))
3899 50 : CALL dbt_create(t_3c_work_3(1), t_3c_work_3(3))
3900 50 : CALL dbt_create(t_3c_work_3(1), t_3c_work_3(4))
3901 50 : CALL dbt_distribution_destroy(t_dist)
3902 50 : CALL dbt_pgrid_destroy(pgrid)
3903 50 : DEALLOCATE (dist1, dist2, dist3, dist_stack)
3904 :
3905 : !the derivatives are stacked in the same way
3906 50 : CALL dbt_create(t_3c_work_3(1), t_3c_der_stack(1))
3907 50 : CALL dbt_create(t_3c_work_3(1), t_3c_der_stack(2))
3908 50 : CALL dbt_create(t_3c_work_3(1), t_3c_der_stack(3))
3909 50 : CALL dbt_create(t_3c_work_3(1), t_3c_der_stack(4))
3910 50 : CALL dbt_create(t_3c_work_3(1), t_3c_der_stack(5))
3911 50 : CALL dbt_create(t_3c_work_3(1), t_3c_der_stack(6))
3912 :
3913 : !t_3c_work_2 based on structure of t_3c_apc
3914 250 : ALLOCATE (dist1(nblks_AO), dist2(ri_data%ncell_RI*nblks_RI), dist3(nblks_AO))
3915 : CALL dbt_get_info(t_3c_apc_sub(1, 1), proc_dist_1=dist1, proc_dist_2=dist2, &
3916 50 : proc_dist_3=dist3, pdims=pdims)
3917 :
3918 100 : ALLOCATE (dist_stack(batch_size*nblks_AO))
3919 882 : DO ib = 1, batch_size
3920 4050 : dist_stack((ib - 1)*nblks_AO + 1:ib*nblks_AO) = dist3(:)
3921 : END DO
3922 :
3923 50 : CALL dbt_pgrid_create(para_env_sub, pdims, pgrid)
3924 50 : CALL dbt_distribution_new(t_dist, pgrid, dist1, dist2, dist_stack)
3925 : CALL dbt_create(t_3c_work_2(1), "work_3_stack", t_dist, [1], [2, 3], &
3926 50 : ri_data%bsizes_AO_split, bsizes_RI_ext_split, bsizes_stack)
3927 50 : CALL dbt_create(t_3c_work_2(1), t_3c_work_2(2))
3928 50 : CALL dbt_create(t_3c_work_2(1), t_3c_work_2(3))
3929 50 : CALL dbt_distribution_destroy(t_dist)
3930 50 : CALL dbt_pgrid_destroy(pgrid)
3931 50 : DEALLOCATE (dist1, dist2, dist3, dist_stack)
3932 :
3933 50 : CALL timestop(handle)
3934 :
3935 100 : END SUBROUTINE get_subgroup_3c_derivs
3936 :
3937 : ! **************************************************************************************************
3938 : !> \brief A routine that reorders the t_3c_int tensors such that all items which are fully empty
3939 : !> are bunched together. This way, we can get much more efficient screening based on NZE
3940 : !> \param t_3c_ints ...
3941 : !> \param ri_data ...
3942 : ! **************************************************************************************************
3943 88 : SUBROUTINE reorder_3c_ints(t_3c_ints, ri_data)
3944 : TYPE(dbt_type), DIMENSION(:), INTENT(INOUT) :: t_3c_ints
3945 : TYPE(hfx_ri_type), INTENT(INOUT) :: ri_data
3946 :
3947 : CHARACTER(LEN=*), PARAMETER :: routineN = 'reorder_3c_ints'
3948 :
3949 : INTEGER :: handle, i_img, idx, idx_empty, idx_full, &
3950 : nimg
3951 : INTEGER(int_8) :: nze
3952 : REAL(dp) :: occ
3953 88 : TYPE(dbt_type), ALLOCATABLE, DIMENSION(:) :: t_3c_tmp
3954 :
3955 88 : CALL timeset(routineN, handle)
3956 :
3957 88 : nimg = ri_data%nimg
3958 3322 : ALLOCATE (t_3c_tmp(nimg))
3959 2442 : DO i_img = 1, nimg
3960 2354 : CALL dbt_create(t_3c_ints(i_img), t_3c_tmp(i_img))
3961 2442 : CALL dbt_copy(t_3c_ints(i_img), t_3c_tmp(i_img), move_data=.TRUE.)
3962 : END DO
3963 :
3964 : !Loop over the images, check if ints have NZE == 0, and put them at the start or end of the
3965 : !initial tensor array. Keep the mapping in an array
3966 264 : ALLOCATE (ri_data%idx_to_img(nimg))
3967 88 : idx_full = 0
3968 88 : idx_empty = nimg + 1
3969 :
3970 2442 : DO i_img = 1, nimg
3971 2354 : CALL get_tensor_occupancy(t_3c_tmp(i_img), nze, occ)
3972 2354 : IF (nze == 0) THEN
3973 734 : idx_empty = idx_empty - 1
3974 734 : CALL dbt_copy(t_3c_tmp(i_img), t_3c_ints(idx_empty), move_data=.TRUE.)
3975 734 : ri_data%idx_to_img(idx_empty) = i_img
3976 : ELSE
3977 1620 : idx_full = idx_full + 1
3978 1620 : CALL dbt_copy(t_3c_tmp(i_img), t_3c_ints(idx_full), move_data=.TRUE.)
3979 1620 : ri_data%idx_to_img(idx_full) = i_img
3980 : END IF
3981 4796 : CALL dbt_destroy(t_3c_tmp(i_img))
3982 : END DO
3983 :
3984 : !store the highest image index with non-zero integrals
3985 88 : ri_data%nimg_nze = idx_full
3986 :
3987 176 : ALLOCATE (ri_data%img_to_idx(nimg))
3988 2442 : DO idx = 1, nimg
3989 2442 : ri_data%img_to_idx(ri_data%idx_to_img(idx)) = idx
3990 : END DO
3991 :
3992 88 : CALL timestop(handle)
3993 :
3994 2530 : END SUBROUTINE reorder_3c_ints
3995 :
3996 : ! **************************************************************************************************
3997 : !> \brief A routine that reorders the 3c derivatives, the same way that the integrals are, also to
3998 : !> increase efficiency of screening
3999 : !> \param t_3c_derivs ...
4000 : !> \param ri_data ...
4001 : ! **************************************************************************************************
4002 100 : SUBROUTINE reorder_3c_derivs(t_3c_derivs, ri_data)
4003 : TYPE(dbt_type), DIMENSION(:, :), INTENT(INOUT) :: t_3c_derivs
4004 : TYPE(hfx_ri_type), INTENT(INOUT) :: ri_data
4005 :
4006 : CHARACTER(LEN=*), PARAMETER :: routineN = 'reorder_3c_derivs'
4007 :
4008 : INTEGER :: handle, i_img, i_xyz, idx, nimg
4009 : INTEGER(int_8) :: nze
4010 : REAL(dp) :: occ
4011 100 : TYPE(dbt_type), ALLOCATABLE, DIMENSION(:) :: t_3c_tmp
4012 :
4013 100 : CALL timeset(routineN, handle)
4014 :
4015 100 : nimg = ri_data%nimg
4016 3944 : ALLOCATE (t_3c_tmp(nimg))
4017 2944 : DO i_img = 1, nimg
4018 2944 : CALL dbt_create(t_3c_derivs(1, 1), t_3c_tmp(i_img))
4019 : END DO
4020 :
4021 400 : DO i_xyz = 1, 3
4022 8832 : DO i_img = 1, nimg
4023 8832 : CALL dbt_copy(t_3c_derivs(i_img, i_xyz), t_3c_tmp(i_img), move_data=.TRUE.)
4024 : END DO
4025 8932 : DO i_img = 1, nimg
4026 8532 : idx = ri_data%img_to_idx(i_img)
4027 8532 : CALL dbt_copy(t_3c_tmp(i_img), t_3c_derivs(idx, i_xyz), move_data=.TRUE.)
4028 8532 : CALL get_tensor_occupancy(t_3c_derivs(idx, i_xyz), nze, occ)
4029 8832 : IF (nze > 0) ri_data%nimg_nze = MAX(idx, ri_data%nimg_nze)
4030 : END DO
4031 : END DO
4032 :
4033 2944 : DO i_img = 1, nimg
4034 2944 : CALL dbt_destroy(t_3c_tmp(i_img))
4035 : END DO
4036 :
4037 100 : CALL timestop(handle)
4038 :
4039 3044 : END SUBROUTINE reorder_3c_derivs
4040 :
4041 : ! **************************************************************************************************
4042 : !> \brief Get the sparsity pattern related to the non-symmetric AO basis overlap neighbor list
4043 : !> \param pattern ...
4044 : !> \param ri_data ...
4045 : !> \param qs_env ...
4046 : ! **************************************************************************************************
4047 324 : SUBROUTINE get_sparsity_pattern(pattern, ri_data, qs_env)
4048 : INTEGER, DIMENSION(:, :, :), INTENT(INOUT) :: pattern
4049 : TYPE(hfx_ri_type), INTENT(INOUT) :: ri_data
4050 : TYPE(qs_environment_type), POINTER :: qs_env
4051 :
4052 : INTEGER :: iatom, j_img, jatom, mj_img, natom, nimg
4053 324 : INTEGER, ALLOCATABLE, DIMENSION(:) :: bins
4054 324 : INTEGER, ALLOCATABLE, DIMENSION(:, :, :) :: tmp_pattern
4055 : INTEGER, DIMENSION(3) :: cell_j
4056 324 : INTEGER, DIMENSION(:, :), POINTER :: index_to_cell
4057 324 : INTEGER, DIMENSION(:, :, :), POINTER :: cell_to_index
4058 : TYPE(dft_control_type), POINTER :: dft_control
4059 : TYPE(kpoint_type), POINTER :: kpoints
4060 : TYPE(mp_para_env_type), POINTER :: para_env
4061 : TYPE(neighbor_list_iterator_p_type), &
4062 324 : DIMENSION(:), POINTER :: nl_iterator
4063 : TYPE(neighbor_list_set_p_type), DIMENSION(:), &
4064 324 : POINTER :: nl_2c
4065 :
4066 324 : NULLIFY (nl_2c, nl_iterator, kpoints, cell_to_index, dft_control, index_to_cell, para_env)
4067 :
4068 324 : CALL get_qs_env(qs_env, kpoints=kpoints, dft_control=dft_control, para_env=para_env, natom=natom)
4069 324 : CALL get_kpoint_info(kpoints, cell_to_index=cell_to_index, index_to_cell=index_to_cell, sab_nl=nl_2c)
4070 :
4071 324 : nimg = ri_data%nimg
4072 65494 : pattern(:, :, :) = 0
4073 :
4074 : !We use the symmetric nl for all images that have an opposite cell
4075 324 : CALL neighbor_list_iterator_create(nl_iterator, nl_2c)
4076 15727 : DO WHILE (neighbor_list_iterate(nl_iterator) == 0)
4077 15403 : CALL get_iterator_info(nl_iterator, iatom=iatom, jatom=jatom, cell=cell_j)
4078 :
4079 15403 : j_img = cell_to_index(cell_j(1), cell_j(2), cell_j(3))
4080 15403 : IF (j_img > nimg .OR. j_img < 1) CYCLE
4081 :
4082 11236 : mj_img = get_opp_index(j_img, qs_env)
4083 11236 : IF (mj_img > nimg .OR. mj_img < 1) CYCLE
4084 :
4085 10725 : IF (ri_data%present_images(j_img) == 0) CYCLE
4086 :
4087 15403 : pattern(iatom, jatom, j_img) = 1
4088 : END DO
4089 324 : CALL neighbor_list_iterator_release(nl_iterator)
4090 :
4091 : !If there is no opposite cell present, then we take into account the non-symmetric nl
4092 324 : CALL get_kpoint_info(kpoints, sab_nl_nosym=nl_2c)
4093 :
4094 324 : CALL neighbor_list_iterator_create(nl_iterator, nl_2c)
4095 20738 : DO WHILE (neighbor_list_iterate(nl_iterator) == 0)
4096 20414 : CALL get_iterator_info(nl_iterator, iatom=iatom, jatom=jatom, cell=cell_j)
4097 :
4098 20414 : j_img = cell_to_index(cell_j(1), cell_j(2), cell_j(3))
4099 20414 : IF (j_img > nimg .OR. j_img < 1) CYCLE
4100 :
4101 14511 : mj_img = get_opp_index(j_img, qs_env)
4102 14511 : IF (mj_img <= nimg .AND. mj_img > 0) CYCLE
4103 :
4104 529 : IF (ri_data%present_images(j_img) == 0) CYCLE
4105 :
4106 20414 : pattern(iatom, jatom, j_img) = 1
4107 : END DO
4108 324 : CALL neighbor_list_iterator_release(nl_iterator)
4109 :
4110 130664 : CALL para_env%sum(pattern)
4111 :
4112 : !If the opposite image is considered, then there is no need to compute diagonal twice
4113 9310 : DO j_img = 2, nimg
4114 27282 : DO iatom = 1, natom
4115 26958 : IF (pattern(iatom, iatom, j_img) /= 0) THEN
4116 5748 : mj_img = get_opp_index(j_img, qs_env)
4117 5748 : IF (mj_img > nimg .OR. mj_img < 1) CYCLE
4118 5748 : pattern(iatom, iatom, mj_img) = 0
4119 : END IF
4120 : END DO
4121 : END DO
4122 :
4123 : ! We want to equilibrate the sparsity pattern such that there are same amount of blocks
4124 : ! for each atom i of i,j pairs
4125 972 : ALLOCATE (bins(natom))
4126 324 : bins(:) = 0
4127 :
4128 1620 : ALLOCATE (tmp_pattern(natom, natom, nimg))
4129 324 : tmp_pattern(:, :, :) = 0
4130 9634 : DO j_img = 1, nimg
4131 28254 : DO jatom = 1, natom
4132 65170 : DO iatom = 1, natom
4133 37240 : IF (pattern(iatom, jatom, j_img) == 0) CYCLE
4134 11808 : mj_img = get_opp_index(j_img, qs_env)
4135 :
4136 : !Should we take the i,j,b or th j,i,-b atomic block?
4137 30428 : IF (mj_img > nimg .OR. mj_img < 1) THEN
4138 : !No opposite image, no choice
4139 222 : bins(iatom) = bins(iatom) + 1
4140 222 : tmp_pattern(iatom, jatom, j_img) = 1
4141 : ELSE
4142 :
4143 11586 : IF (bins(iatom) > bins(jatom)) THEN
4144 2460 : bins(jatom) = bins(jatom) + 1
4145 2460 : tmp_pattern(jatom, iatom, mj_img) = 1
4146 : ELSE
4147 9126 : bins(iatom) = bins(iatom) + 1
4148 9126 : tmp_pattern(iatom, jatom, j_img) = 1
4149 : END IF
4150 : END IF
4151 : END DO
4152 : END DO
4153 : END DO
4154 :
4155 : ! -1 => unoccupied, 0 => occupied
4156 65494 : pattern(:, :, :) = tmp_pattern(:, :, :) - 1
4157 :
4158 648 : END SUBROUTINE get_sparsity_pattern
4159 :
4160 : ! **************************************************************************************************
4161 : !> \brief Distribute the iatom, jatom, b_img triplet over the subgroupd to spread the load
4162 : !> the group id for each triplet is passed as the value of sparsity_pattern(i, j, b),
4163 : !> with -1 being an unoccupied block
4164 : !> \param sparsity_pattern ...
4165 : !> \param ngroups ...
4166 : !> \param ri_data ...
4167 : ! **************************************************************************************************
4168 324 : SUBROUTINE get_sub_dist(sparsity_pattern, ngroups, ri_data)
4169 : INTEGER, DIMENSION(:, :, :), INTENT(INOUT) :: sparsity_pattern
4170 : INTEGER, INTENT(IN) :: ngroups
4171 : TYPE(hfx_ri_type), INTENT(INOUT) :: ri_data
4172 :
4173 : INTEGER :: b_img, ctr, iat, iatom, igroup, jatom, &
4174 : natom, nimg, ub
4175 324 : INTEGER, ALLOCATABLE, DIMENSION(:) :: max_at_per_group
4176 : REAL(dp) :: cost
4177 324 : REAL(dp), ALLOCATABLE, DIMENSION(:) :: bins
4178 :
4179 324 : natom = SIZE(sparsity_pattern, 2)
4180 324 : nimg = SIZE(sparsity_pattern, 3)
4181 :
4182 : !To avoid unnecessary data replication accross the subgroups, we want to have a limited number
4183 : !of subgroup with the data of a given iatom. At the minimum, all groups have 1 atom
4184 : !We assume that the cost associated to each iatom is roughly the same
4185 324 : IF (.NOT. ALLOCATED(ri_data%iatom_to_subgroup)) THEN
4186 420 : ALLOCATE (ri_data%iatom_to_subgroup(natom), max_at_per_group(ngroups))
4187 180 : DO iatom = 1, natom
4188 120 : NULLIFY (ri_data%iatom_to_subgroup(iatom)%array)
4189 240 : ALLOCATE (ri_data%iatom_to_subgroup(iatom)%array(ngroups))
4190 420 : ri_data%iatom_to_subgroup(iatom)%array(:) = .FALSE.
4191 : END DO
4192 :
4193 60 : ub = natom/ngroups
4194 60 : IF (ub*ngroups < natom) ub = ub + 1
4195 180 : max_at_per_group(:) = MAX(1, ub)
4196 :
4197 : !We want each atom to be present the same amount of times. Some groups might have more atoms
4198 : !than other to achieve this.
4199 : ctr = 0
4200 180 : DO WHILE (MODULO(SUM(max_at_per_group), natom) /= 0)
4201 0 : igroup = MODULO(ctr, ngroups) + 1
4202 0 : max_at_per_group(igroup) = max_at_per_group(igroup) + 1
4203 60 : ctr = ctr + 1
4204 : END DO
4205 :
4206 : ctr = 0
4207 180 : DO igroup = 1, ngroups
4208 300 : DO iat = 1, max_at_per_group(igroup)
4209 120 : iatom = MODULO(ctr, natom) + 1
4210 120 : ri_data%iatom_to_subgroup(iatom)%array(igroup) = .TRUE.
4211 240 : ctr = ctr + 1
4212 : END DO
4213 : END DO
4214 : END IF
4215 :
4216 972 : ALLOCATE (bins(ngroups))
4217 324 : bins = 0.0_dp
4218 9634 : DO b_img = 1, nimg
4219 28254 : DO jatom = 1, natom
4220 65170 : DO iatom = 1, natom
4221 37240 : IF (sparsity_pattern(iatom, jatom, b_img) == -1) CYCLE
4222 59040 : igroup = MINLOC(bins, 1, MASK=ri_data%iatom_to_subgroup(iatom)%array) - 1
4223 :
4224 : !Use cost information from previous SCF if available
4225 765820 : IF (ANY(ri_data%kp_cost > EPSILON(0.0_dp))) THEN
4226 8936 : cost = ri_data%kp_cost(iatom, jatom, b_img)
4227 : ELSE
4228 2872 : cost = REAL(ri_data%bsizes_AO(iatom)*ri_data%bsizes_AO(jatom), dp)
4229 : END IF
4230 11808 : bins(igroup + 1) = bins(igroup + 1) + cost
4231 55860 : sparsity_pattern(iatom, jatom, b_img) = igroup
4232 : END DO
4233 : END DO
4234 : END DO
4235 :
4236 324 : END SUBROUTINE get_sub_dist
4237 :
4238 : ! **************************************************************************************************
4239 : !> \brief A rouine that updates the sparsity pattern for force calculation, where all i,j,b combinations
4240 : !> are visited.
4241 : !> \param force_pattern ...
4242 : !> \param scf_pattern ...
4243 : !> \param ngroups ...
4244 : !> \param ri_data ...
4245 : !> \param qs_env ...
4246 : ! **************************************************************************************************
4247 50 : SUBROUTINE update_pattern_to_forces(force_pattern, scf_pattern, ngroups, ri_data, qs_env)
4248 : INTEGER, DIMENSION(:, :, :), INTENT(INOUT) :: force_pattern, scf_pattern
4249 : INTEGER, INTENT(IN) :: ngroups
4250 : TYPE(hfx_ri_type), INTENT(INOUT) :: ri_data
4251 : TYPE(qs_environment_type), POINTER :: qs_env
4252 :
4253 : INTEGER :: b_img, iatom, igroup, jatom, mb_img, &
4254 : natom, nimg
4255 50 : REAL(dp), ALLOCATABLE, DIMENSION(:) :: bins
4256 :
4257 50 : natom = SIZE(scf_pattern, 2)
4258 50 : nimg = SIZE(scf_pattern, 3)
4259 :
4260 150 : ALLOCATE (bins(ngroups))
4261 50 : bins = 0.0_dp
4262 :
4263 1472 : DO b_img = 1, nimg
4264 1422 : mb_img = get_opp_index(b_img, qs_env)
4265 4316 : DO jatom = 1, natom
4266 9954 : DO iatom = 1, natom
4267 : !Important: same distribution as KS matrix, because reuse t_3c_apc
4268 28440 : igroup = MINLOC(bins, 1, MASK=ri_data%iatom_to_subgroup(iatom)%array) - 1
4269 :
4270 : !check that block not already treated
4271 5688 : IF (scf_pattern(iatom, jatom, b_img) > -1) CYCLE
4272 :
4273 : !If not, take the cost of block j, i, -b (same energy contribution)
4274 7050 : IF (mb_img > 0 .AND. mb_img <= nimg) THEN
4275 3714 : IF (scf_pattern(jatom, iatom, mb_img) == -1) CYCLE
4276 1346 : bins(igroup + 1) = bins(igroup + 1) + ri_data%kp_cost(jatom, iatom, mb_img)
4277 1346 : force_pattern(iatom, jatom, b_img) = igroup
4278 : END IF
4279 : END DO
4280 : END DO
4281 : END DO
4282 :
4283 50 : END SUBROUTINE update_pattern_to_forces
4284 :
4285 : ! **************************************************************************************************
4286 : !> \brief A routine that determines the extend of the KP RI-HFX periodic images, including for the
4287 : !> extension of the RI basis
4288 : !> \param ri_data ...
4289 : !> \param qs_env ...
4290 : ! **************************************************************************************************
4291 88 : SUBROUTINE get_kp_and_ri_images(ri_data, qs_env)
4292 : TYPE(hfx_ri_type), INTENT(INOUT) :: ri_data
4293 : TYPE(qs_environment_type), POINTER :: qs_env
4294 :
4295 : CHARACTER(LEN=*), PARAMETER :: routineN = 'get_kp_and_ri_images'
4296 :
4297 : CHARACTER(LEN=512) :: warning_msg
4298 : INTEGER :: cell_j(3), cell_k(3), handle, i_img, iatom, ikind, j_img, jatom, jcell, katom, &
4299 : kcell, kp_index_lbounds(3), kp_index_ubounds(3), natom, ngroups, nimg, nkind, pcoord(3), &
4300 : pdims(3)
4301 88 : INTEGER, ALLOCATABLE, DIMENSION(:) :: dist_AO_1, dist_AO_2, dist_RI, &
4302 88 : nRI_per_atom, present_img, RI_cells
4303 88 : INTEGER, DIMENSION(:, :, :), POINTER :: cell_to_index
4304 : REAL(dp) :: bump_fact, dij, dik, image_range, &
4305 : RI_range, rij(3), rik(3)
4306 616 : TYPE(dbt_type) :: t_dummy
4307 : TYPE(dft_control_type), POINTER :: dft_control
4308 : TYPE(distribution_2d_type), POINTER :: dist_2d
4309 : TYPE(distribution_3d_type) :: dist_3d
4310 : TYPE(gto_basis_set_p_type), ALLOCATABLE, &
4311 88 : DIMENSION(:), TARGET :: basis_set_AO, basis_set_RI
4312 : TYPE(kpoint_type), POINTER :: kpoints
4313 88 : TYPE(mp_cart_type) :: mp_comm_t3c
4314 : TYPE(mp_para_env_type), POINTER :: para_env
4315 : TYPE(neighbor_list_3c_iterator_type) :: nl_3c_iter
4316 : TYPE(neighbor_list_3c_type) :: nl_3c
4317 : TYPE(neighbor_list_iterator_p_type), &
4318 88 : DIMENSION(:), POINTER :: nl_iterator
4319 : TYPE(neighbor_list_set_p_type), DIMENSION(:), &
4320 88 : POINTER :: nl_2c
4321 88 : TYPE(particle_type), DIMENSION(:), POINTER :: particle_set
4322 88 : TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set
4323 : TYPE(section_vals_type), POINTER :: hfx_section
4324 :
4325 88 : NULLIFY (qs_kind_set, dist_2d, nl_2c, nl_iterator, dft_control, &
4326 88 : particle_set, kpoints, para_env, cell_to_index, hfx_section)
4327 :
4328 88 : CALL timeset(routineN, handle)
4329 :
4330 : CALL get_qs_env(qs_env, nkind=nkind, qs_kind_set=qs_kind_set, distribution_2d=dist_2d, &
4331 : dft_control=dft_control, particle_set=particle_set, kpoints=kpoints, &
4332 88 : para_env=para_env, natom=natom)
4333 88 : nimg = dft_control%nimages
4334 88 : CALL get_kpoint_info(kpoints, cell_to_index=cell_to_index)
4335 352 : kp_index_lbounds = LBOUND(cell_to_index)
4336 352 : kp_index_ubounds = UBOUND(cell_to_index)
4337 :
4338 88 : hfx_section => section_vals_get_subs_vals(qs_env%input, "DFT%XC%HF%RI")
4339 88 : CALL section_vals_val_get(hfx_section, "KP_NGROUPS", i_val=ngroups)
4340 :
4341 620 : ALLOCATE (basis_set_RI(nkind), basis_set_AO(nkind))
4342 88 : CALL basis_set_list_setup(basis_set_RI, ri_data%ri_basis_type, qs_kind_set)
4343 88 : CALL basis_set_list_setup(basis_set_AO, ri_data%orb_basis_type, qs_kind_set)
4344 :
4345 : !In case of shortrange HFX potential, it is imprtant to be consistent with the rest of the KP
4346 : !code, and use EPS_SCHWARZ to determine the range (rather than eps_filter_2c in normal RI-HFX)
4347 88 : IF (ri_data%hfx_pot%potential_type == do_potential_short) THEN
4348 0 : CALL erfc_cutoff(ri_data%eps_schwarz, ri_data%hfx_pot%omega, ri_data%hfx_pot%cutoff_radius)
4349 : WRITE (warning_msg, '(A)') &
4350 : "The SHORTANGE HFX potential typically extends over many periodic images, "// &
4351 : "possibly slowing down the calculation. Consider using the TRUNCATED "// &
4352 0 : "potential for better computational performance."
4353 0 : CPWARN(warning_msg)
4354 : END IF
4355 :
4356 : !Determine the range for contributing periodic images, and for the RI basis extension
4357 88 : ri_data%kp_RI_range = 0.0_dp
4358 88 : ri_data%kp_image_range = 0.0_dp
4359 222 : DO ikind = 1, nkind
4360 :
4361 134 : CALL init_interaction_radii_orb_basis(basis_set_AO(ikind)%gto_basis_set, ri_data%eps_pgf_orb)
4362 134 : CALL get_gto_basis_set(basis_set_AO(ikind)%gto_basis_set, kind_radius=RI_range)
4363 134 : ri_data%kp_RI_range = MAX(RI_range, ri_data%kp_RI_range)
4364 :
4365 134 : CALL init_interaction_radii_orb_basis(basis_set_AO(ikind)%gto_basis_set, ri_data%eps_pgf_orb)
4366 134 : CALL init_interaction_radii_orb_basis(basis_set_RI(ikind)%gto_basis_set, ri_data%eps_pgf_orb)
4367 134 : CALL get_gto_basis_set(basis_set_RI(ikind)%gto_basis_set, kind_radius=image_range)
4368 :
4369 134 : image_range = 2.0_dp*image_range + cutoff_screen_factor*ri_data%hfx_pot%cutoff_radius
4370 356 : ri_data%kp_image_range = MAX(image_range, ri_data%kp_image_range)
4371 : END DO
4372 :
4373 88 : CALL section_vals_val_get(hfx_section, "KP_RI_BUMP_FACTOR", r_val=bump_fact)
4374 88 : ri_data%kp_bump_rad = bump_fact*ri_data%kp_RI_range
4375 :
4376 : !For the extent of the KP RI-HFX images, we are limited by the RI-HFX potential in
4377 : !(mu^0 sigma^a|P^0) (P^0|Q^b) (Q^b|nu^b lambda^a+c), if there is no contact between
4378 : !any P^0 and Q^b, then image b does not contribute
4379 : CALL build_2c_neighbor_lists(nl_2c, basis_set_RI, basis_set_RI, ri_data%hfx_pot, &
4380 88 : "HFX_2c_nl_RI", qs_env, sym_ij=.FALSE., dist_2d=dist_2d)
4381 :
4382 264 : ALLOCATE (present_img(nimg))
4383 88 : present_img = 0
4384 88 : ri_data%nimg = 0
4385 88 : CALL neighbor_list_iterator_create(nl_iterator, nl_2c)
4386 2078 : DO WHILE (neighbor_list_iterate(nl_iterator) == 0)
4387 1990 : CALL get_iterator_info(nl_iterator, r=rij, cell=cell_j)
4388 :
4389 7960 : dij = NORM2(rij)
4390 :
4391 1990 : j_img = cell_to_index(cell_j(1), cell_j(2), cell_j(3))
4392 1990 : IF (j_img > nimg .OR. j_img < 1) CYCLE
4393 :
4394 1952 : IF (dij > ri_data%kp_image_range) CYCLE
4395 :
4396 1952 : ri_data%nimg = MAX(j_img, ri_data%nimg)
4397 1990 : present_img(j_img) = 1
4398 :
4399 : END DO
4400 88 : CALL neighbor_list_iterator_release(nl_iterator)
4401 88 : CALL release_neighbor_list_sets(nl_2c)
4402 88 : CALL para_env%max(ri_data%nimg)
4403 88 : IF (ri_data%nimg > nimg) THEN
4404 0 : CPABORT("Make sure the smallest exponent of the RI-HFX basis is larger than that of the ORB basis.")
4405 : END IF
4406 :
4407 : !Keep track of which images will not contribute, so that can be ignored before calculation
4408 88 : CALL para_env%sum(present_img)
4409 264 : ALLOCATE (ri_data%present_images(ri_data%nimg))
4410 2442 : ri_data%present_images = 0
4411 2442 : DO i_img = 1, ri_data%nimg
4412 2442 : IF (present_img(i_img) > 0) ri_data%present_images(i_img) = 1
4413 : END DO
4414 :
4415 : CALL create_3c_tensor(t_dummy, dist_AO_1, dist_AO_2, dist_RI, &
4416 : ri_data%pgrid, ri_data%bsizes_AO, ri_data%bsizes_AO, ri_data%bsizes_RI, &
4417 88 : map1=[1, 2], map2=[3], name="(AO AO | RI)")
4418 :
4419 88 : CALL dbt_mp_environ_pgrid(ri_data%pgrid, pdims, pcoord)
4420 88 : CALL mp_comm_t3c%create(ri_data%pgrid%mp_comm_2d, 3, pdims)
4421 : CALL distribution_3d_create(dist_3d, dist_AO_1, dist_AO_2, dist_RI, &
4422 88 : nkind, particle_set, mp_comm_t3c, own_comm=.TRUE.)
4423 88 : DEALLOCATE (dist_RI, dist_AO_1, dist_AO_2)
4424 88 : CALL dbt_destroy(t_dummy)
4425 :
4426 : !For the extension of the RI basis P in (mu^0 sigma^a |P^i), we consider an atom if the distance,
4427 : !between mu^0 and P^i if smaller or equal to the kind radius of mu^0
4428 : CALL build_3c_neighbor_lists(nl_3c, basis_set_AO, basis_set_AO, basis_set_RI, dist_3d, &
4429 : ri_data%ri_metric, "HFX_3c_nl", qs_env, op_pos=2, sym_ij=.FALSE., &
4430 88 : own_dist=.TRUE.)
4431 :
4432 176 : ALLOCATE (RI_cells(nimg))
4433 88 : RI_cells = 0
4434 :
4435 264 : ALLOCATE (nRI_per_atom(natom))
4436 88 : nRI_per_atom = 0
4437 :
4438 88 : CALL neighbor_list_3c_iterator_create(nl_3c_iter, nl_3c)
4439 85714 : DO WHILE (neighbor_list_3c_iterate(nl_3c_iter) == 0)
4440 : CALL get_3c_iterator_info(nl_3c_iter, cell_k=cell_k, rik=rik, cell_j=cell_j, &
4441 85626 : iatom=iatom, jatom=jatom, katom=katom)
4442 342504 : dik = NORM2(rik)
4443 :
4444 599382 : IF (ANY([cell_j(1), cell_j(2), cell_j(3)] < kp_index_lbounds) .OR. &
4445 : ANY([cell_j(1), cell_j(2), cell_j(3)] > kp_index_ubounds)) CYCLE
4446 :
4447 85626 : jcell = cell_to_index(cell_j(1), cell_j(2), cell_j(3))
4448 85626 : IF (jcell > nimg .OR. jcell < 1) CYCLE
4449 :
4450 571310 : IF (ANY([cell_k(1), cell_k(2), cell_k(3)] < kp_index_lbounds) .OR. &
4451 : ANY([cell_k(1), cell_k(2), cell_k(3)] > kp_index_ubounds)) CYCLE
4452 :
4453 77083 : kcell = cell_to_index(cell_k(1), cell_k(2), cell_k(3))
4454 77083 : IF (kcell > nimg .OR. kcell < 1) CYCLE
4455 :
4456 62877 : IF (dik > ri_data%kp_RI_range) CYCLE
4457 7846 : RI_cells(kcell) = 1
4458 :
4459 7934 : IF (jcell == 1 .AND. iatom == jatom) nRI_per_atom(iatom) = nRI_per_atom(iatom) + ri_data%bsizes_RI(katom)
4460 : END DO
4461 88 : CALL neighbor_list_3c_iterator_destroy(nl_3c_iter)
4462 88 : CALL neighbor_list_3c_destroy(nl_3c)
4463 88 : CALL para_env%sum(RI_cells)
4464 88 : CALL para_env%sum(nRI_per_atom)
4465 :
4466 176 : ALLOCATE (ri_data%img_to_RI_cell(nimg))
4467 88 : ri_data%ncell_RI = 0
4468 4428 : ri_data%img_to_RI_cell = 0
4469 4428 : DO i_img = 1, nimg
4470 4428 : IF (RI_cells(i_img) > 0) THEN
4471 554 : ri_data%ncell_RI = ri_data%ncell_RI + 1
4472 554 : ri_data%img_to_RI_cell(i_img) = ri_data%ncell_RI
4473 : END IF
4474 : END DO
4475 :
4476 264 : ALLOCATE (ri_data%RI_cell_to_img(ri_data%ncell_RI))
4477 4428 : DO i_img = 1, nimg
4478 4428 : IF (ri_data%img_to_RI_cell(i_img) > 0) ri_data%RI_cell_to_img(ri_data%img_to_RI_cell(i_img)) = i_img
4479 : END DO
4480 :
4481 : !Print some info
4482 88 : IF (ri_data%unit_nr > 0) THEN
4483 : WRITE (ri_data%unit_nr, FMT="(/T3,A,I29)") &
4484 44 : "KP-HFX_RI_INFO| Number of RI-KP parallel groups:", ngroups
4485 : WRITE (ri_data%unit_nr, FMT="(T3,A,I29)") &
4486 44 : "KP-HFX_RI_INFO| Tensor stack size: ", ri_data%kp_stack_size
4487 : WRITE (ri_data%unit_nr, FMT="(T3,A,F31.3,A)") &
4488 44 : "KP-HFX_RI_INFO| RI basis extension radius:", ri_data%kp_RI_range*angstrom, " Ang"
4489 : WRITE (ri_data%unit_nr, FMT="(T3,A,F12.3,A, F6.3, A)") &
4490 44 : "KP-HFX_RI_INFO| RI basis bump factor and bump radius:", bump_fact, " /", &
4491 88 : ri_data%kp_bump_rad*angstrom, " Ang"
4492 : WRITE (ri_data%unit_nr, FMT="(T3,A,I16,A)") &
4493 44 : "KP-HFX_RI_INFO| The extended RI bases cover up to ", ri_data%ncell_RI, " unit cells"
4494 : WRITE (ri_data%unit_nr, FMT="(T3,A,I18)") &
4495 132 : "KP-HFX_RI_INFO| Average number of sgf in extended RI bases:", SUM(nRI_per_atom)/natom
4496 : WRITE (ri_data%unit_nr, FMT="(T3,A,F13.3,A)") &
4497 44 : "KP-HFX_RI_INFO| Consider all image cells within a radius of ", ri_data%kp_image_range*angstrom, " Ang"
4498 : WRITE (ri_data%unit_nr, FMT="(T3,A,I27/)") &
4499 44 : "KP-HFX_RI_INFO| Number of image cells considered: ", ri_data%nimg
4500 44 : CALL m_flush(ri_data%unit_nr)
4501 : END IF
4502 :
4503 88 : CALL timestop(handle)
4504 :
4505 1056 : END SUBROUTINE get_kp_and_ri_images
4506 :
4507 : ! **************************************************************************************************
4508 : !> \brief A routine that creates tensors structure for rho_ao and 3c_ints in a stacked format for
4509 : !> the efficient contractions of rho_sigma^0,lambda^c * (mu^0 sigam^a | P) => TAS tensors
4510 : !> \param res_stack ...
4511 : !> \param rho_stack ...
4512 : !> \param ints_stack ...
4513 : !> \param rho_template ...
4514 : !> \param ints_template ...
4515 : !> \param stack_size ...
4516 : !> \param ri_data ...
4517 : !> \param qs_env ...
4518 : !> \note The result tensor has the exact same shape and distribution as the integral tensor
4519 : ! **************************************************************************************************
4520 324 : SUBROUTINE get_stack_tensors(res_stack, rho_stack, ints_stack, rho_template, ints_template, &
4521 : stack_size, ri_data, qs_env)
4522 : TYPE(dbt_type), DIMENSION(:), INTENT(INOUT) :: res_stack, rho_stack, ints_stack
4523 : TYPE(dbt_type), INTENT(INOUT) :: rho_template, ints_template
4524 : INTEGER, INTENT(IN) :: stack_size
4525 : TYPE(hfx_ri_type), INTENT(INOUT) :: ri_data
4526 : TYPE(qs_environment_type), POINTER :: qs_env
4527 :
4528 : INTEGER :: is, nblks, nblks_3c(3), pdims_3d(3)
4529 324 : INTEGER, ALLOCATABLE, DIMENSION(:) :: bsizes_RI_ext, bsizes_stack, dist1, &
4530 324 : dist2, dist3, dist_stack1, &
4531 324 : dist_stack2, dist_stack3
4532 2916 : TYPE(dbt_distribution_type) :: t_dist
4533 972 : TYPE(dbt_pgrid_type) :: pgrid
4534 : TYPE(mp_para_env_type), POINTER :: para_env
4535 :
4536 324 : NULLIFY (para_env)
4537 :
4538 324 : CALL get_qs_env(qs_env, para_env=para_env)
4539 :
4540 324 : nblks = SIZE(ri_data%bsizes_AO_split)
4541 972 : ALLOCATE (bsizes_stack(stack_size*nblks))
4542 6468 : DO is = 1, stack_size
4543 26948 : bsizes_stack((is - 1)*nblks + 1:is*nblks) = ri_data%bsizes_AO_split(:)
4544 : END DO
4545 :
4546 1944 : ALLOCATE (dist1(nblks), dist2(nblks), dist_stack1(stack_size*nblks), dist_stack2(stack_size*nblks))
4547 324 : CALL dbt_get_info(rho_template, proc_dist_1=dist1, proc_dist_2=dist2)
4548 6468 : DO is = 1, stack_size
4549 26624 : dist_stack1((is - 1)*nblks + 1:is*nblks) = dist1(:)
4550 26948 : dist_stack2((is - 1)*nblks + 1:is*nblks) = dist2(:)
4551 : END DO
4552 :
4553 : !First 2c tensor matches the distribution of template
4554 : !It is stacked in both directions
4555 324 : CALL dbt_distribution_new(t_dist, ri_data%pgrid_2d, dist_stack1, dist_stack2)
4556 324 : CALL dbt_create(rho_stack(1), "RHO_stack", t_dist, [1], [2], bsizes_stack, bsizes_stack)
4557 324 : CALL dbt_distribution_destroy(t_dist)
4558 324 : DEALLOCATE (dist1, dist2, dist_stack1, dist_stack2)
4559 :
4560 : !Second 2c tensor has optimal distribution on the 2d pgrid
4561 324 : CALL create_2c_tensor(rho_stack(2), dist1, dist2, ri_data%pgrid_2d, bsizes_stack, bsizes_stack, name="RHO_stack")
4562 324 : DEALLOCATE (dist1, dist2)
4563 :
4564 324 : CALL dbt_get_info(ints_template, nblks_total=nblks_3c)
4565 2268 : ALLOCATE (dist1(nblks_3c(1)), dist2(nblks_3c(2)), dist3(nblks_3c(3)))
4566 1296 : ALLOCATE (dist_stack3(stack_size*nblks_3c(3)), bsizes_RI_ext(nblks_3c(2)))
4567 : CALL dbt_get_info(ints_template, proc_dist_1=dist1, proc_dist_2=dist2, &
4568 324 : proc_dist_3=dist3, blk_size_2=bsizes_RI_ext)
4569 6468 : DO is = 1, stack_size
4570 26948 : dist_stack3((is - 1)*nblks_3c(3) + 1:is*nblks_3c(3)) = dist3(:)
4571 : END DO
4572 :
4573 : !First 3c tensor matches the distribution of template
4574 324 : CALL dbt_distribution_new(t_dist, ri_data%pgrid_1, dist1, dist2, dist_stack3)
4575 : CALL dbt_create(ints_stack(1), "ints_stack", t_dist, [1, 2], [3], ri_data%bsizes_AO_split, &
4576 324 : bsizes_RI_ext, bsizes_stack)
4577 324 : CALL dbt_distribution_destroy(t_dist)
4578 324 : DEALLOCATE (dist1, dist2, dist3, dist_stack3)
4579 :
4580 : !Second 3c tensor has optimal pgrid
4581 324 : pdims_3d = 0
4582 1296 : CALL dbt_pgrid_create(para_env, pdims_3d, pgrid, tensor_dims=[nblks_3c(1), nblks_3c(2), stack_size*nblks_3c(3)])
4583 : CALL create_3c_tensor(ints_stack(2), dist1, dist2, dist3, pgrid, ri_data%bsizes_AO_split, &
4584 324 : bsizes_RI_ext, bsizes_stack, [1, 2], [3], name="ints_stack")
4585 324 : DEALLOCATE (dist1, dist2, dist3)
4586 324 : CALL dbt_pgrid_destroy(pgrid)
4587 :
4588 : !The result tensor has the same shape and dist as the integral tensor
4589 324 : CALL dbt_create(ints_stack(1), res_stack(1))
4590 324 : CALL dbt_create(ints_stack(2), res_stack(2))
4591 :
4592 324 : END SUBROUTINE get_stack_tensors
4593 :
4594 : ! **************************************************************************************************
4595 : !> \brief Fill the stack of 3c tensors accrding to the order in the images input
4596 : !> \param t_3c_stack ...
4597 : !> \param t_3c_in ...
4598 : !> \param images ...
4599 : !> \param stack_dim ...
4600 : !> \param ri_data ...
4601 : !> \param filter_at ...
4602 : !> \param filter_dim ...
4603 : !> \param idx_to_at ...
4604 : !> \param img_bounds ...
4605 : ! **************************************************************************************************
4606 41263 : SUBROUTINE fill_3c_stack(t_3c_stack, t_3c_in, images, stack_dim, ri_data, filter_at, filter_dim, &
4607 41263 : idx_to_at, img_bounds)
4608 : TYPE(dbt_type), INTENT(INOUT) :: t_3c_stack
4609 : TYPE(dbt_type), DIMENSION(:), INTENT(INOUT) :: t_3c_in
4610 : INTEGER, DIMENSION(:), INTENT(INOUT) :: images
4611 : INTEGER, INTENT(IN) :: stack_dim
4612 : TYPE(hfx_ri_type), INTENT(INOUT) :: ri_data
4613 : INTEGER, INTENT(IN), OPTIONAL :: filter_at, filter_dim
4614 : INTEGER, DIMENSION(:), INTENT(INOUT), OPTIONAL :: idx_to_at
4615 : INTEGER, INTENT(IN), OPTIONAL :: img_bounds(2)
4616 :
4617 : INTEGER :: dest(3), i_img, idx, ind(3), lb, nblks, &
4618 : nimg, offset, ub
4619 : LOGICAL :: do_filter, found
4620 41263 : REAL(dp), ALLOCATABLE, DIMENSION(:, :, :) :: blk
4621 : TYPE(dbt_iterator_type) :: iter
4622 :
4623 : !We loop over the a images from the ac_pairs, then copy the 3c ints to the correct spot in
4624 : !in the stack tensor (corresponding to pair index). Distributions match by construction
4625 41263 : nimg = ri_data%nimg
4626 41263 : nblks = SIZE(ri_data%bsizes_AO_split)
4627 :
4628 41263 : do_filter = .FALSE.
4629 40791 : IF (PRESENT(filter_at) .AND. PRESENT(filter_dim) .AND. PRESENT(idx_to_at)) do_filter = .TRUE.
4630 :
4631 41263 : lb = 1
4632 41263 : ub = nimg
4633 41263 : offset = 0
4634 41263 : IF (PRESENT(img_bounds)) THEN
4635 41263 : lb = img_bounds(1)
4636 41263 : ub = img_bounds(2) - 1
4637 41263 : offset = lb - 1
4638 : END IF
4639 :
4640 621110 : DO idx = lb, ub
4641 579847 : i_img = images(idx)
4642 579847 : IF (i_img == 0 .OR. i_img > nimg) CYCLE
4643 :
4644 : !$OMP PARALLEL DEFAULT(NONE) &
4645 : !$OMP SHARED(idx,i_img,t_3c_in,t_3c_stack,nblks,stack_dim,filter_at,filter_dim,idx_to_at,do_filter,offset) &
4646 621110 : !$OMP PRIVATE(iter,ind,blk,found,dest)
4647 : CALL dbt_iterator_start(iter, t_3c_in(i_img))
4648 : DO WHILE (dbt_iterator_blocks_left(iter))
4649 : CALL dbt_iterator_next_block(iter, ind)
4650 : CALL dbt_get_block(t_3c_in(i_img), ind, blk, found)
4651 : IF (.NOT. found) CYCLE
4652 :
4653 : IF (do_filter) THEN
4654 : IF (.NOT. idx_to_at(ind(filter_dim)) == filter_at) CYCLE
4655 : END IF
4656 :
4657 : IF (stack_dim == 1) THEN
4658 : dest = [(idx - offset - 1)*nblks + ind(1), ind(2), ind(3)]
4659 : ELSE IF (stack_dim == 2) THEN
4660 : dest = [ind(1), (idx - offset - 1)*nblks + ind(2), ind(3)]
4661 : ELSE
4662 : dest = [ind(1), ind(2), (idx - offset - 1)*nblks + ind(3)]
4663 : END IF
4664 :
4665 : CALL dbt_put_block(t_3c_stack, dest, SHAPE(blk), blk)
4666 : DEALLOCATE (blk)
4667 : END DO
4668 : CALL dbt_iterator_stop(iter)
4669 : !$OMP END PARALLEL
4670 : END DO !i_img
4671 41263 : CALL dbt_finalize(t_3c_stack)
4672 :
4673 82526 : END SUBROUTINE fill_3c_stack
4674 :
4675 : ! **************************************************************************************************
4676 : !> \brief Fill the stack of 2c tensors based on the content of images input
4677 : !> \param t_2c_stack ...
4678 : !> \param t_2c_in ...
4679 : !> \param images ...
4680 : !> \param stack_dim ...
4681 : !> \param ri_data ...
4682 : !> \param img_bounds ...
4683 : !> \param shift ...
4684 : ! **************************************************************************************************
4685 19680 : SUBROUTINE fill_2c_stack(t_2c_stack, t_2c_in, images, stack_dim, ri_data, img_bounds, shift)
4686 : TYPE(dbt_type), INTENT(INOUT) :: t_2c_stack
4687 : TYPE(dbt_type), DIMENSION(:), INTENT(INOUT) :: t_2c_in
4688 : INTEGER, DIMENSION(:), INTENT(INOUT) :: images
4689 : INTEGER, INTENT(IN) :: stack_dim
4690 : TYPE(hfx_ri_type), INTENT(INOUT) :: ri_data
4691 : INTEGER, INTENT(IN), OPTIONAL :: img_bounds(2), shift
4692 :
4693 : INTEGER :: dest(2), i_img, idx, ind(2), lb, &
4694 : my_shift, nblks, nimg, offset, ub
4695 : LOGICAL :: found
4696 19680 : REAL(dp), ALLOCATABLE, DIMENSION(:, :) :: blk
4697 : TYPE(dbt_iterator_type) :: iter
4698 :
4699 : !We loop over the a images from the ac_pairs, then copy the 3c ints to the correct spot in
4700 : !in the stack tensor (corresponding to pair index). Distributions match by construction
4701 19680 : nimg = ri_data%nimg
4702 19680 : nblks = SIZE(ri_data%bsizes_AO_split)
4703 :
4704 19680 : lb = 1
4705 19680 : ub = nimg
4706 19680 : offset = 0
4707 19680 : IF (PRESENT(img_bounds)) THEN
4708 19680 : lb = img_bounds(1)
4709 19680 : ub = img_bounds(2) - 1
4710 19680 : offset = lb - 1
4711 : END IF
4712 :
4713 19680 : my_shift = 1
4714 19680 : IF (PRESENT(shift)) my_shift = shift
4715 :
4716 302352 : DO idx = lb, ub
4717 282672 : i_img = images(idx)
4718 282672 : IF (i_img == 0 .OR. i_img > nimg) CYCLE
4719 :
4720 : !$OMP PARALLEL DEFAULT(NONE) SHARED(idx,i_img,t_2c_in,t_2c_stack,nblks,stack_dim,offset,my_shift) &
4721 302352 : !$OMP PRIVATE(iter,ind,blk,found,dest)
4722 : CALL dbt_iterator_start(iter, t_2c_in(i_img))
4723 : DO WHILE (dbt_iterator_blocks_left(iter))
4724 : CALL dbt_iterator_next_block(iter, ind)
4725 : CALL dbt_get_block(t_2c_in(i_img), ind, blk, found)
4726 : IF (.NOT. found) CYCLE
4727 :
4728 : IF (stack_dim == 1) THEN
4729 : dest = [(idx - offset - 1)*nblks + ind(1), (my_shift - 1)*nblks + ind(2)]
4730 : ELSE
4731 : dest = [(my_shift - 1)*nblks + ind(1), (idx - offset - 1)*nblks + ind(2)]
4732 : END IF
4733 :
4734 : CALL dbt_put_block(t_2c_stack, dest, SHAPE(blk), blk)
4735 : DEALLOCATE (blk)
4736 : END DO
4737 : CALL dbt_iterator_stop(iter)
4738 : !$OMP END PARALLEL
4739 : END DO !idx
4740 19680 : CALL dbt_finalize(t_2c_stack)
4741 :
4742 39360 : END SUBROUTINE fill_2c_stack
4743 :
4744 : ! **************************************************************************************************
4745 : !> \brief Unstacks a stacked 3c tensor containing t_3c_apc
4746 : !> \param t_3c_apc ...
4747 : !> \param t_stacked ...
4748 : !> \param idx ...
4749 : ! **************************************************************************************************
4750 24152 : SUBROUTINE unstack_t_3c_apc(t_3c_apc, t_stacked, idx)
4751 : TYPE(dbt_type), INTENT(INOUT) :: t_3c_apc, t_stacked
4752 : INTEGER, INTENT(IN) :: idx
4753 :
4754 : INTEGER :: current_idx
4755 : INTEGER, DIMENSION(3) :: ind, nblks_3c
4756 : LOGICAL :: found
4757 24152 : REAL(dp), ALLOCATABLE, DIMENSION(:, :, :) :: blk
4758 : TYPE(dbt_iterator_type) :: iter
4759 :
4760 : !Note: t_3c_apc and t_stacked must have the same ditribution
4761 24152 : CALL dbt_get_info(t_3c_apc, nblks_total=nblks_3c)
4762 :
4763 24152 : !$OMP PARALLEL DEFAULT(NONE) SHARED(t_3c_apc,t_stacked,idx,nblks_3c) PRIVATE(iter,ind,blk,found,current_idx)
4764 : CALL dbt_iterator_start(iter, t_stacked)
4765 : DO WHILE (dbt_iterator_blocks_left(iter))
4766 : CALL dbt_iterator_next_block(iter, ind)
4767 :
4768 : !tensor is stacked along the 3rd dimension
4769 : current_idx = (ind(3) - 1)/nblks_3c(3) + 1
4770 : IF (.NOT. idx == current_idx) CYCLE
4771 :
4772 : CALL dbt_get_block(t_stacked, ind, blk, found)
4773 : IF (.NOT. found) CYCLE
4774 :
4775 : CALL dbt_put_block(t_3c_apc, [ind(1), ind(2), ind(3) - (idx - 1)*nblks_3c(3)], SHAPE(blk), blk)
4776 : DEALLOCATE (blk)
4777 : END DO
4778 : CALL dbt_iterator_stop(iter)
4779 : !$OMP END PARALLEL
4780 :
4781 24152 : END SUBROUTINE unstack_t_3c_apc
4782 :
4783 : ! **************************************************************************************************
4784 : !> \brief copies the 3c integrals correspoinding to a single atom mu from the general (P^0| mu^0 sigam^a)
4785 : !> \param t_3c_at ...
4786 : !> \param t_3c_ints ...
4787 : !> \param iatom ...
4788 : !> \param dim_at ...
4789 : !> \param idx_to_at ...
4790 : ! **************************************************************************************************
4791 0 : SUBROUTINE get_atom_3c_ints(t_3c_at, t_3c_ints, iatom, dim_at, idx_to_at)
4792 : TYPE(dbt_type), INTENT(INOUT) :: t_3c_at, t_3c_ints
4793 : INTEGER, INTENT(IN) :: iatom, dim_at
4794 : INTEGER, DIMENSION(:), INTENT(IN) :: idx_to_at
4795 :
4796 : INTEGER, DIMENSION(3) :: ind
4797 : LOGICAL :: found
4798 0 : REAL(dp), ALLOCATABLE, DIMENSION(:, :, :) :: blk
4799 : TYPE(dbt_iterator_type) :: iter
4800 :
4801 0 : !$OMP PARALLEL DEFAULT(NONE) SHARED(t_3c_ints,t_3c_at,iatom,idx_to_at,dim_at) PRIVATE(iter,ind,blk,found)
4802 : CALL dbt_iterator_start(iter, t_3c_ints)
4803 : DO WHILE (dbt_iterator_blocks_left(iter))
4804 : CALL dbt_iterator_next_block(iter, ind)
4805 : IF (.NOT. idx_to_at(ind(dim_at)) == iatom) CYCLE
4806 :
4807 : CALL dbt_get_block(t_3c_ints, ind, blk, found)
4808 : IF (.NOT. found) CYCLE
4809 :
4810 : CALL dbt_put_block(t_3c_at, ind, SHAPE(blk), blk)
4811 : DEALLOCATE (blk)
4812 : END DO
4813 : CALL dbt_iterator_stop(iter)
4814 : !$OMP END PARALLEL
4815 0 : CALL dbt_finalize(t_3c_at)
4816 :
4817 0 : END SUBROUTINE get_atom_3c_ints
4818 :
4819 : ! **************************************************************************************************
4820 : !> \brief Precalculate the 3c and 2c derivatives tensors
4821 : !> \param t_3c_der_RI ...
4822 : !> \param t_3c_der_AO ...
4823 : !> \param mat_der_pot ...
4824 : !> \param t_2c_der_metric ...
4825 : !> \param ri_data ...
4826 : !> \param qs_env ...
4827 : ! **************************************************************************************************
4828 50 : SUBROUTINE precalc_derivatives(t_3c_der_RI, t_3c_der_AO, mat_der_pot, t_2c_der_metric, ri_data, qs_env)
4829 : TYPE(dbt_type), DIMENSION(:, :), INTENT(INOUT) :: t_3c_der_RI, t_3c_der_AO
4830 : TYPE(dbcsr_type), DIMENSION(:, :), INTENT(INOUT) :: mat_der_pot
4831 : TYPE(dbt_type), DIMENSION(:, :), INTENT(INOUT) :: t_2c_der_metric
4832 : TYPE(hfx_ri_type), INTENT(INOUT) :: ri_data
4833 : TYPE(qs_environment_type), POINTER :: qs_env
4834 :
4835 : CHARACTER(LEN=*), PARAMETER :: routineN = 'precalc_derivatives'
4836 :
4837 : INTEGER :: handle, handle2, i_img, i_mem, i_RI, &
4838 : i_xyz, iatom, n_mem, natom, nblks_RI, &
4839 : ncell_RI, nimg, nkind, nthreads
4840 : INTEGER(int_8) :: nze
4841 50 : INTEGER, ALLOCATABLE, DIMENSION(:) :: bsizes_RI_ext, bsizes_RI_ext_split, dist_AO_1, &
4842 100 : dist_AO_2, dist_RI, dist_RI_ext, dummy_end, dummy_start, end_blocks, start_blocks
4843 : INTEGER, DIMENSION(3) :: pcoord, pdims
4844 100 : INTEGER, DIMENSION(:), POINTER :: col_bsize, row_bsize
4845 : REAL(dp) :: occ
4846 : TYPE(dbcsr_distribution_type) :: dbcsr_dist
4847 : TYPE(dbcsr_type) :: dbcsr_template
4848 50 : TYPE(dbcsr_type), ALLOCATABLE, DIMENSION(:, :) :: mat_der_metric
4849 450 : TYPE(dbt_distribution_type) :: t_dist
4850 150 : TYPE(dbt_pgrid_type) :: pgrid
4851 450 : TYPE(dbt_type) :: t_3c_template
4852 50 : TYPE(dbt_type), ALLOCATABLE, DIMENSION(:, :, :) :: t_3c_der_AO_prv, t_3c_der_RI_prv
4853 : TYPE(dft_control_type), POINTER :: dft_control
4854 : TYPE(distribution_2d_type), POINTER :: dist_2d
4855 : TYPE(distribution_3d_type) :: dist_3d
4856 : TYPE(gto_basis_set_p_type), ALLOCATABLE, &
4857 50 : DIMENSION(:), TARGET :: basis_set_AO, basis_set_RI
4858 50 : TYPE(mp_cart_type) :: mp_comm_t3c
4859 : TYPE(mp_para_env_type), POINTER :: para_env
4860 : TYPE(neighbor_list_3c_type) :: nl_3c
4861 : TYPE(neighbor_list_set_p_type), DIMENSION(:), &
4862 50 : POINTER :: nl_2c
4863 50 : TYPE(particle_type), DIMENSION(:), POINTER :: particle_set
4864 50 : TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set
4865 :
4866 50 : NULLIFY (qs_kind_set, dist_2d, nl_2c, particle_set, dft_control, para_env, row_bsize, col_bsize)
4867 :
4868 50 : CALL timeset(routineN, handle)
4869 :
4870 : CALL get_qs_env(qs_env, nkind=nkind, qs_kind_set=qs_kind_set, distribution_2d=dist_2d, natom=natom, &
4871 50 : particle_set=particle_set, dft_control=dft_control, para_env=para_env)
4872 :
4873 50 : nimg = ri_data%nimg
4874 50 : ncell_RI = ri_data%ncell_RI
4875 :
4876 356 : ALLOCATE (basis_set_RI(nkind), basis_set_AO(nkind))
4877 50 : CALL basis_set_list_setup(basis_set_RI, ri_data%ri_basis_type, qs_kind_set)
4878 50 : CALL get_particle_set(particle_set, qs_kind_set, basis=basis_set_RI)
4879 50 : CALL basis_set_list_setup(basis_set_AO, ri_data%orb_basis_type, qs_kind_set)
4880 50 : CALL get_particle_set(particle_set, qs_kind_set, basis=basis_set_AO)
4881 :
4882 : !Dealing with the 3c derivatives
4883 50 : nthreads = 1
4884 50 : !$ nthreads = omp_get_num_threads()
4885 50 : pdims = 0
4886 200 : CALL dbt_pgrid_create(para_env, pdims, pgrid, tensor_dims=[MAX(1, natom/(ri_data%n_mem*nthreads)), natom, natom])
4887 :
4888 : CALL create_3c_tensor(t_3c_template, dist_AO_1, dist_AO_2, dist_RI, pgrid, &
4889 : ri_data%bsizes_AO, ri_data%bsizes_AO, ri_data%bsizes_RI, &
4890 50 : map1=[1, 2], map2=[3], name="tmp")
4891 50 : CALL dbt_destroy(t_3c_template)
4892 :
4893 : !We stack the RI basis images. Keep consistent distribution
4894 50 : nblks_RI = SIZE(ri_data%bsizes_RI_split)
4895 150 : ALLOCATE (dist_RI_ext(natom*ncell_RI))
4896 100 : ALLOCATE (bsizes_RI_ext(natom*ncell_RI))
4897 150 : ALLOCATE (bsizes_RI_ext_split(nblks_RI*ncell_RI))
4898 366 : DO i_RI = 1, ncell_RI
4899 948 : bsizes_RI_ext((i_RI - 1)*natom + 1:i_RI*natom) = ri_data%bsizes_RI(:)
4900 948 : dist_RI_ext((i_RI - 1)*natom + 1:i_RI*natom) = dist_RI(:)
4901 1802 : bsizes_RI_ext_split((i_RI - 1)*nblks_RI + 1:i_RI*nblks_RI) = ri_data%bsizes_RI_split(:)
4902 : END DO
4903 :
4904 50 : CALL dbt_distribution_new(t_dist, pgrid, dist_AO_1, dist_AO_2, dist_RI_ext)
4905 : CALL dbt_create(t_3c_template, "KP_3c_der", t_dist, [1, 2], [3], &
4906 50 : ri_data%bsizes_AO, ri_data%bsizes_AO, bsizes_RI_ext)
4907 50 : CALL dbt_distribution_destroy(t_dist)
4908 :
4909 10132 : ALLOCATE (t_3c_der_RI_prv(nimg, 1, 3), t_3c_der_AO_prv(nimg, 1, 3))
4910 200 : DO i_xyz = 1, 3
4911 4466 : DO i_img = 1, nimg
4912 4266 : CALL dbt_create(t_3c_template, t_3c_der_RI_prv(i_img, 1, i_xyz))
4913 4416 : CALL dbt_create(t_3c_template, t_3c_der_AO_prv(i_img, 1, i_xyz))
4914 : END DO
4915 : END DO
4916 50 : CALL dbt_destroy(t_3c_template)
4917 :
4918 50 : CALL dbt_mp_environ_pgrid(pgrid, pdims, pcoord)
4919 50 : CALL mp_comm_t3c%create(pgrid%mp_comm_2d, 3, pdims)
4920 : CALL distribution_3d_create(dist_3d, dist_AO_1, dist_AO_2, dist_RI, &
4921 50 : nkind, particle_set, mp_comm_t3c, own_comm=.TRUE.)
4922 50 : DEALLOCATE (dist_RI, dist_AO_1, dist_AO_2)
4923 50 : CALL dbt_pgrid_destroy(pgrid)
4924 :
4925 : CALL build_3c_neighbor_lists(nl_3c, basis_set_AO, basis_set_AO, basis_set_RI, dist_3d, ri_data%ri_metric, &
4926 50 : "HFX_3c_nl", qs_env, op_pos=2, sym_jk=.FALSE., own_dist=.TRUE.)
4927 :
4928 50 : n_mem = ri_data%n_mem
4929 : CALL create_tensor_batches(ri_data%bsizes_RI, n_mem, dummy_start, dummy_end, &
4930 50 : start_blocks, end_blocks)
4931 50 : DEALLOCATE (dummy_start, dummy_end)
4932 :
4933 : CALL create_3c_tensor(t_3c_template, dist_RI, dist_AO_1, dist_AO_2, ri_data%pgrid_2, &
4934 : bsizes_RI_ext_split, ri_data%bsizes_AO_split, ri_data%bsizes_AO_split, &
4935 50 : map1=[1], map2=[2, 3], name="der (RI | AO AO)")
4936 200 : DO i_xyz = 1, 3
4937 4466 : DO i_img = 1, nimg
4938 4266 : CALL dbt_create(t_3c_template, t_3c_der_RI(i_img, i_xyz))
4939 4416 : CALL dbt_create(t_3c_template, t_3c_der_AO(i_img, i_xyz))
4940 : END DO
4941 : END DO
4942 :
4943 140 : DO i_mem = 1, n_mem
4944 : CALL build_3c_derivatives(t_3c_der_AO_prv, t_3c_der_RI_prv, ri_data%filter_eps, qs_env, &
4945 : nl_3c, basis_set_AO, basis_set_AO, basis_set_RI, &
4946 : ri_data%ri_metric, der_eps=ri_data%eps_schwarz_forces, op_pos=2, &
4947 : do_kpoints=.TRUE., do_hfx_kpoints=.TRUE., &
4948 : bounds_k=[start_blocks(i_mem), end_blocks(i_mem)], &
4949 270 : RI_range=ri_data%kp_RI_range, img_to_RI_cell=ri_data%img_to_RI_cell)
4950 :
4951 90 : CALL timeset(routineN//"_cpy", handle2)
4952 : !We go from (mu^0 sigma^i | P^j) to (P^i| sigma^j mu^0) and finally to (P^i| mu^0 sigma^j)
4953 2834 : DO i_img = 1, nimg
4954 11066 : DO i_xyz = 1, 3
4955 : !derivative wrt to mu^0
4956 8232 : CALL get_tensor_occupancy(t_3c_der_AO_prv(i_img, 1, i_xyz), nze, occ)
4957 8232 : IF (nze > 0) THEN
4958 : CALL dbt_copy(t_3c_der_AO_prv(i_img, 1, i_xyz), t_3c_template, &
4959 4512 : order=[3, 2, 1], move_data=.TRUE.)
4960 4512 : CALL dbt_filter(t_3c_template, ri_data%filter_eps)
4961 : CALL dbt_copy(t_3c_template, t_3c_der_AO(i_img, i_xyz), &
4962 4512 : order=[1, 3, 2], move_data=.TRUE., summation=.TRUE.)
4963 : END IF
4964 :
4965 : !derivative wrt to P^i
4966 8232 : CALL get_tensor_occupancy(t_3c_der_RI_prv(i_img, 1, i_xyz), nze, occ)
4967 19208 : IF (nze > 0) THEN
4968 : CALL dbt_copy(t_3c_der_RI_prv(i_img, 1, i_xyz), t_3c_template, &
4969 4482 : order=[3, 2, 1], move_data=.TRUE.)
4970 4482 : CALL dbt_filter(t_3c_template, ri_data%filter_eps)
4971 : CALL dbt_copy(t_3c_template, t_3c_der_RI(i_img, i_xyz), &
4972 4482 : order=[1, 3, 2], move_data=.TRUE., summation=.TRUE.)
4973 : END IF
4974 : END DO
4975 : END DO
4976 230 : CALL timestop(handle2)
4977 : END DO
4978 50 : CALL dbt_destroy(t_3c_template)
4979 :
4980 50 : CALL neighbor_list_3c_destroy(nl_3c)
4981 200 : DO i_xyz = 1, 3
4982 4466 : DO i_img = 1, nimg
4983 4266 : CALL dbt_destroy(t_3c_der_RI_prv(i_img, 1, i_xyz))
4984 4416 : CALL dbt_destroy(t_3c_der_AO_prv(i_img, 1, i_xyz))
4985 : END DO
4986 : END DO
4987 8582 : DEALLOCATE (t_3c_der_RI_prv, t_3c_der_AO_prv)
4988 :
4989 : !Reorder 3c derivatives to be consistant with ints
4990 50 : CALL reorder_3c_derivs(t_3c_der_RI, ri_data)
4991 50 : CALL reorder_3c_derivs(t_3c_der_AO, ri_data)
4992 :
4993 50 : CALL timeset(routineN//"_2c", handle2)
4994 : !The 2-center derivatives
4995 50 : CALL cp_dbcsr_dist2d_to_dist(dist_2d, dbcsr_dist)
4996 150 : ALLOCATE (row_bsize(SIZE(ri_data%bsizes_RI)))
4997 100 : ALLOCATE (col_bsize(SIZE(ri_data%bsizes_RI)))
4998 150 : row_bsize(:) = ri_data%bsizes_RI
4999 150 : col_bsize(:) = ri_data%bsizes_RI
5000 :
5001 : CALL dbcsr_create(dbcsr_template, "2c_der", dbcsr_dist, dbcsr_type_no_symmetry, &
5002 50 : row_bsize, col_bsize)
5003 50 : CALL dbcsr_distribution_release(dbcsr_dist)
5004 50 : DEALLOCATE (col_bsize, row_bsize)
5005 :
5006 4566 : ALLOCATE (mat_der_metric(nimg, 3))
5007 200 : DO i_xyz = 1, 3
5008 4466 : DO i_img = 1, nimg
5009 4266 : CALL dbcsr_create(mat_der_pot(i_img, i_xyz), template=dbcsr_template)
5010 4416 : CALL dbcsr_create(mat_der_metric(i_img, i_xyz), template=dbcsr_template)
5011 : END DO
5012 : END DO
5013 50 : CALL dbcsr_release(dbcsr_template)
5014 :
5015 : !HFX potential derivatives
5016 : CALL build_2c_neighbor_lists(nl_2c, basis_set_RI, basis_set_RI, ri_data%hfx_pot, &
5017 50 : "HFX_2c_nl_pot", qs_env, sym_ij=.FALSE., dist_2d=dist_2d)
5018 : CALL build_2c_derivatives(mat_der_pot, ri_data%filter_eps_2c, qs_env, nl_2c, &
5019 50 : basis_set_RI, basis_set_RI, ri_data%hfx_pot, do_kpoints=.TRUE.)
5020 50 : CALL release_neighbor_list_sets(nl_2c)
5021 :
5022 : !RI metric derivatives
5023 : CALL build_2c_neighbor_lists(nl_2c, basis_set_RI, basis_set_RI, ri_data%ri_metric, &
5024 50 : "HFX_2c_nl_pot", qs_env, sym_ij=.FALSE., dist_2d=dist_2d)
5025 : CALL build_2c_derivatives(mat_der_metric, ri_data%filter_eps_2c, qs_env, nl_2c, &
5026 50 : basis_set_RI, basis_set_RI, ri_data%ri_metric, do_kpoints=.TRUE.)
5027 50 : CALL release_neighbor_list_sets(nl_2c)
5028 :
5029 : !Get into extended RI basis and tensor format
5030 200 : DO i_xyz = 1, 3
5031 450 : DO iatom = 1, natom
5032 300 : CALL dbt_create(ri_data%t_2c_inv(1, 1), t_2c_der_metric(iatom, i_xyz))
5033 : CALL get_ext_2c_int(t_2c_der_metric(iatom, i_xyz), mat_der_metric(:, i_xyz), &
5034 450 : iatom, iatom, 1, ri_data, qs_env)
5035 : END DO
5036 4466 : DO i_img = 1, nimg
5037 4416 : CALL dbcsr_release(mat_der_metric(i_img, i_xyz))
5038 : END DO
5039 : END DO
5040 50 : CALL timestop(handle2)
5041 :
5042 50 : CALL timestop(handle)
5043 :
5044 250 : END SUBROUTINE precalc_derivatives
5045 :
5046 : ! **************************************************************************************************
5047 : !> \brief Update the forces due to the derivative of the a 2-center product d/dR (Q|R)
5048 : !> \param force ...
5049 : !> \param t_2c_contr A precontracted tensor containing sum_abcdPS (ab|P)(P|Q)^-1 (R|S)^-1 (S|cd) P_ac P_bd
5050 : !> \param t_2c_der the d/dR (Q|R) tensor, in all 3 cartesian directions
5051 : !> \param atom_of_kind ...
5052 : !> \param kind_of ...
5053 : !> \param img in which periodic image the second center of the tensor is
5054 : !> \param pref ...
5055 : !> \param ri_data ...
5056 : !> \param qs_env ...
5057 : !> \param work_virial ...
5058 : !> \param cell ...
5059 : !> \param particle_set ...
5060 : !> \param diag ...
5061 : !> \param offdiag ...
5062 : !> \note IMPORTANT: t_tc_contr and t_2c_der need to have the same distribution. Atomic block sizes are
5063 : !> assumed
5064 : ! **************************************************************************************************
5065 3705 : SUBROUTINE get_2c_der_force(force, t_2c_contr, t_2c_der, atom_of_kind, kind_of, img, pref, &
5066 : ri_data, qs_env, work_virial, cell, particle_set, diag, offdiag)
5067 :
5068 : TYPE(qs_force_type), DIMENSION(:), POINTER :: force
5069 : TYPE(dbt_type), INTENT(INOUT) :: t_2c_contr
5070 : TYPE(dbt_type), DIMENSION(:), INTENT(INOUT) :: t_2c_der
5071 : INTEGER, DIMENSION(:), INTENT(IN) :: atom_of_kind, kind_of
5072 : INTEGER, INTENT(IN) :: img
5073 : REAL(dp), INTENT(IN) :: pref
5074 : TYPE(hfx_ri_type), INTENT(INOUT) :: ri_data
5075 : TYPE(qs_environment_type), POINTER :: qs_env
5076 : REAL(dp), DIMENSION(3, 3), INTENT(INOUT), OPTIONAL :: work_virial
5077 : TYPE(cell_type), OPTIONAL, POINTER :: cell
5078 : TYPE(particle_type), DIMENSION(:), OPTIONAL, &
5079 : POINTER :: particle_set
5080 : LOGICAL, INTENT(IN), OPTIONAL :: diag, offdiag
5081 :
5082 : CHARACTER(LEN=*), PARAMETER :: routineN = 'get_2c_der_force'
5083 :
5084 : INTEGER :: handle, i_img, i_RI, i_xyz, iat, &
5085 : iat_of_kind, ikind, j_img, j_RI, &
5086 : j_xyz, jat, jat_of_kind, jkind, natom
5087 : INTEGER, DIMENSION(2) :: ind
5088 3705 : INTEGER, DIMENSION(:, :), POINTER :: index_to_cell
5089 : LOGICAL :: found, my_diag, my_offdiag, use_virial
5090 : REAL(dp) :: new_force
5091 3705 : REAL(dp), ALLOCATABLE, DIMENSION(:, :), TARGET :: contr_blk, der_blk
5092 : REAL(dp), DIMENSION(3) :: scoord
5093 : TYPE(dbt_iterator_type) :: iter
5094 : TYPE(kpoint_type), POINTER :: kpoints
5095 :
5096 3705 : NULLIFY (kpoints, index_to_cell)
5097 :
5098 : !Loop over the blocks of d/dR (Q|R), contract with the corresponding block of t_2c_contr and
5099 : !update the relevant force
5100 :
5101 3705 : CALL timeset(routineN, handle)
5102 :
5103 3705 : use_virial = .FALSE.
5104 3705 : IF (PRESENT(work_virial) .AND. PRESENT(cell) .AND. PRESENT(particle_set)) use_virial = .TRUE.
5105 :
5106 3705 : my_diag = .FALSE.
5107 3705 : IF (PRESENT(diag)) my_diag = diag
5108 :
5109 2964 : my_offdiag = .FALSE.
5110 2964 : IF (PRESENT(diag)) my_offdiag = offdiag
5111 :
5112 3705 : CALL get_qs_env(qs_env, kpoints=kpoints, natom=natom)
5113 3705 : CALL get_kpoint_info(kpoints, index_to_cell=index_to_cell)
5114 :
5115 : !$OMP PARALLEL DEFAULT(NONE) &
5116 : !$OMP SHARED(t_2c_der,t_2c_contr,work_virial,force,use_virial,natom,index_to_cell,ri_data,img) &
5117 : !$OMP SHARED(pref,atom_of_kind,kind_of,particle_set,cell,my_diag,my_offdiag) &
5118 : !$OMP PRIVATE(i_xyz,j_xyz,iter,ind,der_blk,contr_blk,found,new_force,i_RI,i_img,j_RI,j_img) &
5119 3705 : !$OMP PRIVATE(iat,jat,iat_of_kind,jat_of_kind,ikind,jkind,scoord)
5120 : DO i_xyz = 1, 3
5121 : CALL dbt_iterator_start(iter, t_2c_der(i_xyz))
5122 : DO WHILE (dbt_iterator_blocks_left(iter))
5123 : CALL dbt_iterator_next_block(iter, ind)
5124 :
5125 : !Only take forecs due to block diagonal or block off-diagonal, depending on arguments
5126 : IF ((my_diag .AND. .NOT. my_offdiag) .OR. (.NOT. my_diag .AND. my_offdiag)) THEN
5127 : IF (my_diag .AND. (ind(1) /= ind(2))) CYCLE
5128 : IF (my_offdiag .AND. (ind(1) == ind(2))) CYCLE
5129 : END IF
5130 :
5131 : CALL dbt_get_block(t_2c_der(i_xyz), ind, der_blk, found)
5132 : CPASSERT(found)
5133 : CALL dbt_get_block(t_2c_contr, ind, contr_blk, found)
5134 :
5135 : IF (found) THEN
5136 :
5137 : !an element of d/dR (Q|R) corresponds to 2 things because of translational invariance
5138 : !(Q'| R) = - (Q| R'), once wrt the center on Q, and once on R
5139 : new_force = pref*SUM(der_blk(:, :)*contr_blk(:, :))
5140 :
5141 : i_RI = (ind(1) - 1)/natom + 1
5142 : i_img = ri_data%RI_cell_to_img(i_RI)
5143 : iat = ind(1) - (i_RI - 1)*natom
5144 : iat_of_kind = atom_of_kind(iat)
5145 : ikind = kind_of(iat)
5146 :
5147 : j_RI = (ind(2) - 1)/natom + 1
5148 : j_img = ri_data%RI_cell_to_img(j_RI)
5149 : jat = ind(2) - (j_RI - 1)*natom
5150 : jat_of_kind = atom_of_kind(jat)
5151 : jkind = kind_of(jat)
5152 :
5153 : !Force on iatom (first center)
5154 : !$OMP ATOMIC
5155 : force(ikind)%fock_4c(i_xyz, iat_of_kind) = force(ikind)%fock_4c(i_xyz, iat_of_kind) &
5156 : + new_force
5157 :
5158 : IF (use_virial) THEN
5159 :
5160 : CALL real_to_scaled(scoord, pbc(particle_set(iat)%r, cell), cell)
5161 : scoord(:) = scoord(:) + REAL(index_to_cell(:, i_img), dp)
5162 :
5163 : DO j_xyz = 1, 3
5164 : !$OMP ATOMIC
5165 : work_virial(i_xyz, j_xyz) = work_virial(i_xyz, j_xyz) + new_force*scoord(j_xyz)
5166 : END DO
5167 : END IF
5168 :
5169 : !Force on jatom (second center)
5170 : !$OMP ATOMIC
5171 : force(jkind)%fock_4c(i_xyz, jat_of_kind) = force(jkind)%fock_4c(i_xyz, jat_of_kind) &
5172 : - new_force
5173 :
5174 : IF (use_virial) THEN
5175 :
5176 : CALL real_to_scaled(scoord, pbc(particle_set(jat)%r, cell), cell)
5177 : scoord(:) = scoord(:) + REAL(index_to_cell(:, j_img) + index_to_cell(:, img), dp)
5178 :
5179 : DO j_xyz = 1, 3
5180 : !$OMP ATOMIC
5181 : work_virial(i_xyz, j_xyz) = work_virial(i_xyz, j_xyz) - new_force*scoord(j_xyz)
5182 : END DO
5183 : END IF
5184 :
5185 : DEALLOCATE (contr_blk)
5186 : END IF
5187 :
5188 : DEALLOCATE (der_blk)
5189 : END DO !iter
5190 : CALL dbt_iterator_stop(iter)
5191 :
5192 : END DO !i_xyz
5193 : !$OMP END PARALLEL
5194 3705 : CALL timestop(handle)
5195 :
5196 7410 : END SUBROUTINE get_2c_der_force
5197 :
5198 : ! **************************************************************************************************
5199 : !> \brief This routines calculates the force contribution from a trace over 3D tensors, i.e.
5200 : !> force = sum_ijk A_ijk B_ijk., the B tensor is (P^0| sigma^0 lambda^img), with P in the
5201 : !> extended RI basis. Note that all tensors are stacked along the 3rd dimension
5202 : !> \param force ...
5203 : !> \param t_3c_contr ...
5204 : !> \param t_3c_der_1 ...
5205 : !> \param t_3c_der_2 ...
5206 : !> \param atom_of_kind ...
5207 : !> \param kind_of ...
5208 : !> \param idx_to_at_RI ...
5209 : !> \param idx_to_at_AO ...
5210 : !> \param i_images ...
5211 : !> \param lb_img ...
5212 : !> \param pref ...
5213 : !> \param ri_data ...
5214 : !> \param qs_env ...
5215 : !> \param work_virial ...
5216 : !> \param cell ...
5217 : !> \param particle_set ...
5218 : ! **************************************************************************************************
5219 2654 : SUBROUTINE get_force_from_3c_trace(force, t_3c_contr, t_3c_der_1, t_3c_der_2, atom_of_kind, kind_of, &
5220 5308 : idx_to_at_RI, idx_to_at_AO, i_images, lb_img, pref, &
5221 : ri_data, qs_env, work_virial, cell, particle_set)
5222 :
5223 : TYPE(qs_force_type), DIMENSION(:), POINTER :: force
5224 : TYPE(dbt_type), INTENT(INOUT) :: t_3c_contr
5225 : TYPE(dbt_type), DIMENSION(3), INTENT(INOUT) :: t_3c_der_1, t_3c_der_2
5226 : INTEGER, DIMENSION(:), INTENT(IN) :: atom_of_kind, kind_of, idx_to_at_RI, &
5227 : idx_to_at_AO, i_images
5228 : INTEGER, INTENT(IN) :: lb_img
5229 : REAL(dp), INTENT(IN) :: pref
5230 : TYPE(hfx_ri_type), INTENT(INOUT) :: ri_data
5231 : TYPE(qs_environment_type), POINTER :: qs_env
5232 : REAL(dp), DIMENSION(3, 3), INTENT(INOUT), OPTIONAL :: work_virial
5233 : TYPE(cell_type), OPTIONAL, POINTER :: cell
5234 : TYPE(particle_type), DIMENSION(:), OPTIONAL, &
5235 : POINTER :: particle_set
5236 :
5237 : CHARACTER(LEN=*), PARAMETER :: routineN = 'get_force_from_3c_trace'
5238 :
5239 : INTEGER :: handle, i_RI, i_xyz, iat, iat_of_kind, idx, ikind, j_xyz, jat, jat_of_kind, &
5240 : jkind, kat, kat_of_kind, kkind, nblks_AO, nblks_RI, RI_img
5241 : INTEGER, DIMENSION(3) :: ind
5242 2654 : INTEGER, DIMENSION(:, :), POINTER :: index_to_cell
5243 : LOGICAL :: found, found_1, found_2, use_virial
5244 : REAL(dp) :: new_force
5245 2654 : REAL(dp), ALLOCATABLE, DIMENSION(:, :, :), TARGET :: contr_blk, der_blk_1, der_blk_2, &
5246 2654 : der_blk_3
5247 : REAL(dp), DIMENSION(3) :: scoord
5248 : TYPE(dbt_iterator_type) :: iter
5249 : TYPE(kpoint_type), POINTER :: kpoints
5250 :
5251 2654 : NULLIFY (kpoints, index_to_cell)
5252 :
5253 2654 : CALL timeset(routineN, handle)
5254 :
5255 2654 : CALL get_qs_env(qs_env, kpoints=kpoints)
5256 2654 : CALL get_kpoint_info(kpoints, index_to_cell=index_to_cell)
5257 :
5258 2654 : nblks_RI = SIZE(ri_data%bsizes_RI_split)
5259 2654 : nblks_AO = SIZE(ri_data%bsizes_AO_split)
5260 :
5261 2654 : use_virial = .FALSE.
5262 2654 : IF (PRESENT(work_virial) .AND. PRESENT(cell) .AND. PRESENT(particle_set)) use_virial = .TRUE.
5263 :
5264 : !$OMP PARALLEL DEFAULT(NONE) &
5265 : !$OMP SHARED(t_3c_der_1, t_3c_der_2,t_3c_contr,work_virial,force,use_virial,index_to_cell,i_images,lb_img) &
5266 : !$OMP SHARED(pref,idx_to_at_AO,atom_of_kind,kind_of,particle_set,cell,idx_to_at_RI,ri_data,nblks_RI,nblks_AO) &
5267 : !$OMP PRIVATE(i_xyz,j_xyz,iter,ind,der_blk_1,contr_blk,found,new_force,iat,iat_of_kind,ikind,scoord) &
5268 2654 : !$OMP PRIVATE(jat,kat,jat_of_kind,kat_of_kind,jkind,kkind,i_RI,RI_img,der_blk_2,der_blk_3,found_1,found_2,idx)
5269 : CALL dbt_iterator_start(iter, t_3c_contr)
5270 : DO WHILE (dbt_iterator_blocks_left(iter))
5271 : CALL dbt_iterator_next_block(iter, ind)
5272 :
5273 : CALL dbt_get_block(t_3c_contr, ind, contr_blk, found)
5274 : IF (found) THEN
5275 :
5276 : DO i_xyz = 1, 3
5277 : CALL dbt_get_block(t_3c_der_1(i_xyz), ind, der_blk_1, found_1)
5278 : IF (.NOT. found_1) THEN
5279 : DEALLOCATE (der_blk_1)
5280 : ALLOCATE (der_blk_1(SIZE(contr_blk, 1), SIZE(contr_blk, 2), SIZE(contr_blk, 3)))
5281 : der_blk_1(:, :, :) = 0.0_dp
5282 : END IF
5283 : CALL dbt_get_block(t_3c_der_2(i_xyz), ind, der_blk_2, found_2)
5284 : IF (.NOT. found_2) THEN
5285 : DEALLOCATE (der_blk_2)
5286 : ALLOCATE (der_blk_2(SIZE(contr_blk, 1), SIZE(contr_blk, 2), SIZE(contr_blk, 3)))
5287 : der_blk_2(:, :, :) = 0.0_dp
5288 : END IF
5289 :
5290 : ALLOCATE (der_blk_3(SIZE(contr_blk, 1), SIZE(contr_blk, 2), SIZE(contr_blk, 3)))
5291 : der_blk_3(:, :, :) = -(der_blk_1(:, :, :) + der_blk_2(:, :, :))
5292 :
5293 : !We assume the tensors are in the format (P^0| sigma^0 mu^a+c-b), with P a member of the
5294 : !extended RI basis set
5295 :
5296 : !Force for the first center (RI extended basis, zero cell)
5297 : new_force = pref*SUM(der_blk_1(:, :, :)*contr_blk(:, :, :))
5298 :
5299 : i_RI = (ind(1) - 1)/nblks_RI + 1
5300 : RI_img = ri_data%RI_cell_to_img(i_RI)
5301 : iat = idx_to_at_RI(ind(1) - (i_RI - 1)*nblks_RI)
5302 : iat_of_kind = atom_of_kind(iat)
5303 : ikind = kind_of(iat)
5304 :
5305 : !$OMP ATOMIC
5306 : force(ikind)%fock_4c(i_xyz, iat_of_kind) = force(ikind)%fock_4c(i_xyz, iat_of_kind) &
5307 : + new_force
5308 :
5309 : IF (use_virial) THEN
5310 :
5311 : CALL real_to_scaled(scoord, pbc(particle_set(iat)%r, cell), cell)
5312 : scoord(:) = scoord(:) + REAL(index_to_cell(:, RI_img), dp)
5313 :
5314 : DO j_xyz = 1, 3
5315 : !$OMP ATOMIC
5316 : work_virial(i_xyz, j_xyz) = work_virial(i_xyz, j_xyz) + new_force*scoord(j_xyz)
5317 : END DO
5318 : END IF
5319 :
5320 : !Force with respect to the second center (AO basis, zero cell)
5321 : new_force = pref*SUM(der_blk_2(:, :, :)*contr_blk(:, :, :))
5322 : jat = idx_to_at_AO(ind(2))
5323 : jat_of_kind = atom_of_kind(jat)
5324 : jkind = kind_of(jat)
5325 :
5326 : !$OMP ATOMIC
5327 : force(jkind)%fock_4c(i_xyz, jat_of_kind) = force(jkind)%fock_4c(i_xyz, jat_of_kind) &
5328 : + new_force
5329 :
5330 : IF (use_virial) THEN
5331 :
5332 : CALL real_to_scaled(scoord, pbc(particle_set(jat)%r, cell), cell)
5333 :
5334 : DO j_xyz = 1, 3
5335 : !$OMP ATOMIC
5336 : work_virial(i_xyz, j_xyz) = work_virial(i_xyz, j_xyz) + new_force*scoord(j_xyz)
5337 : END DO
5338 : END IF
5339 :
5340 : !Force with respect to the third center (AO basis, apc_img - b_img)
5341 : !Note: tensors are stacked along the 3rd direction
5342 : new_force = pref*SUM(der_blk_3(:, :, :)*contr_blk(:, :, :))
5343 : idx = (ind(3) - 1)/nblks_AO + 1
5344 : kat = idx_to_at_AO(ind(3) - (idx - 1)*nblks_AO)
5345 : kat_of_kind = atom_of_kind(kat)
5346 : kkind = kind_of(kat)
5347 :
5348 : !$OMP ATOMIC
5349 : force(kkind)%fock_4c(i_xyz, kat_of_kind) = force(kkind)%fock_4c(i_xyz, kat_of_kind) &
5350 : + new_force
5351 :
5352 : IF (use_virial) THEN
5353 : CALL real_to_scaled(scoord, pbc(particle_set(kat)%r, cell), cell)
5354 : scoord(:) = scoord(:) + REAL(index_to_cell(:, i_images(lb_img - 1 + idx)), dp)
5355 :
5356 : DO j_xyz = 1, 3
5357 : !$OMP ATOMIC
5358 : work_virial(i_xyz, j_xyz) = work_virial(i_xyz, j_xyz) + new_force*scoord(j_xyz)
5359 : END DO
5360 : END IF
5361 :
5362 : DEALLOCATE (der_blk_1, der_blk_2, der_blk_3)
5363 : END DO !i_xyz
5364 : DEALLOCATE (contr_blk)
5365 : END IF !found
5366 : END DO !iter
5367 : CALL dbt_iterator_stop(iter)
5368 : !$OMP END PARALLEL
5369 2654 : CALL timestop(handle)
5370 :
5371 5308 : END SUBROUTINE get_force_from_3c_trace
5372 :
5373 : END MODULE hfx_ri_kp
|
