(git:c51e757)
Loading...
Searching...
No Matches
hfx_ri_kp.F
Go to the documentation of this file.
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
13MODULE 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'
124CONTAINS
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 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 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 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 CALL get_qs_env(qs_env, dft_control=dft_control, natom=natom, para_env=para_env, nkind=nkind)
152 nimg = ri_data%nimg
153
154 !Along the RI direction we have basis elements spread accross ncell_RI images.
155 nblks_ri = SIZE(ri_data%bsizes_RI_split)
156 ALLOCATE (bsizes_ri_ext(nblks_ri*ri_data%ncell_RI))
157 DO i_ri = 1, ri_data%ncell_RI
158 bsizes_ri_ext((i_ri - 1)*nblks_ri + 1:i_ri*nblks_ri) = ri_data%bsizes_RI_split(:)
159 END DO
160
161 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 ri_data%bsizes_AO_split, [1, 2], [3], name="(AO RI | AO)")
165
166 DO i_img = 2, nimg
167 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 DEALLOCATE (dist1, dist2, dist3)
170
171 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 ri_data%bsizes_AO_split, [1], [2, 3], name="(AO RI | AO)")
175 DEALLOCATE (dist1, dist2, dist3)
176
177 !We use full block sizes for the 2c quantities
178 DEALLOCATE (bsizes_ri_ext)
179 nblks_ri = SIZE(ri_data%bsizes_RI)
180 ALLOCATE (bsizes_ri_ext(nblks_ri*ri_data%ncell_RI))
181 DO i_ri = 1, ri_data%ncell_RI
182 bsizes_ri_ext((i_ri - 1)*nblks_ri + 1:i_ri*nblks_ri) = ri_data%bsizes_RI(:)
183 END DO
184
185 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 name="(RI | RI)")
189 DEALLOCATE (dist1, dist2)
190 CALL dbt_create(ri_data%t_2c_inv(1, 1), ri_data%t_2c_int(1, 1))
191 CALL dbt_create(ri_data%t_2c_inv(1, 1), ri_data%t_2c_pot(1, 1))
192 DO iatom = 2, natom
193 CALL dbt_create(ri_data%t_2c_inv(1, 1), ri_data%t_2c_inv(1, iatom))
194 CALL dbt_create(ri_data%t_2c_inv(1, 1), ri_data%t_2c_int(1, iatom))
195 CALL dbt_create(ri_data%t_2c_inv(1, 1), ri_data%t_2c_pot(1, iatom))
196 END DO
197
198 ALLOCATE (ri_data%kp_cost(natom, natom, nimg))
199 ri_data%kp_cost = 0.0_dp
200
201 !We store the density and KS matrix in tensor format
202 nspins = dft_control%nspins
203 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 name="(AO | AO)")
207 DEALLOCATE (dist1, dist2)
208
209 CALL dbt_create(dbcsr_template, ri_data%ks_t(1, 1))
210
211 IF (nspins == 2) THEN
212 CALL dbt_create(ri_data%rho_ao_t(1, 1), ri_data%rho_ao_t(2, 1))
213 CALL dbt_create(ri_data%ks_t(1, 1), ri_data%ks_t(2, 1))
214 END IF
215 DO i_img = 2, nimg
216 DO i_spin = 1, nspins
217 CALL dbt_create(ri_data%rho_ao_t(1, 1), ri_data%rho_ao_t(i_spin, i_img))
218 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 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 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 TYPE(dbcsr_type), ALLOCATABLE, DIMENSION(:) :: t_2c_op_pot, t_2c_op_RI
239 TYPE(dbt_type), ALLOCATABLE, DIMENSION(:, :) :: t_3c_int
240 TYPE(dft_control_type), POINTER :: dft_control
241
242 NULLIFY (dft_control)
243
244 CALL timeset(routinen, handle)
245
246 CALL get_qs_env(qs_env, dft_control=dft_control, natom=natom, nkind=nkind)
247
248 CALL cleanup_kp(ri_data)
249
250 !We do all the checks on what we allow in this initial implementation
251 IF (ri_data%flavor /= ri_pmat) cpabort("K-points RI-HFX only with RHO flavor")
252 IF (ri_data%same_op) ri_data%same_op = .false. !force the full calculation with RI metric
253 IF (abs(ri_data%eps_pgf_orb - dft_control%qs_control%eps_pgf_orb) > 1.0e-16_dp) THEN
254 cpabort("RI%EPS_PGF_ORB and QS%EPS_PGF_ORB must be identical for RI-HFX k-points")
255 END IF
256
257 CALL get_kp_and_ri_images(ri_data, qs_env)
258 nimg = ri_data%nimg
259
260 !Calculate the integrals
261 ALLOCATE (t_2c_op_pot(nimg), t_2c_op_ri(nimg))
262 ALLOCATE (t_3c_int(1, nimg))
263 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 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 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 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 qs_env, off_diagonal=.true.)
277 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 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 from_right=.true., debump=.true.)
284
285 END DO
286
287 DO i_img = 1, nimg
288 CALL dbcsr_release(t_2c_op_ri(i_img))
289 END DO
290
291 ALLOCATE (ri_data%kp_mat_2c_pot(1, nimg))
292 DO i_img = 1, nimg
293 CALL dbcsr_create(ri_data%kp_mat_2c_pot(1, i_img), template=t_2c_op_pot(i_img))
294 CALL dbcsr_copy(ri_data%kp_mat_2c_pot(1, i_img), t_2c_op_pot(i_img))
295 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 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 CALL precontract_3c_ints(t_3c_int, ri_data, qs_env)
304
305 CALL timestop(handle)
306
307 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 SUBROUTINE cleanup_kp(ri_data)
314 TYPE(hfx_ri_type), INTENT(INOUT) :: ri_data
315
316 INTEGER :: i, j
317
318 IF (ALLOCATED(ri_data%kp_cost)) DEALLOCATE (ri_data%kp_cost)
319 IF (ALLOCATED(ri_data%idx_to_img)) DEALLOCATE (ri_data%idx_to_img)
320 IF (ALLOCATED(ri_data%img_to_idx)) DEALLOCATE (ri_data%img_to_idx)
321 IF (ALLOCATED(ri_data%present_images)) DEALLOCATE (ri_data%present_images)
322 IF (ALLOCATED(ri_data%img_to_RI_cell)) DEALLOCATE (ri_data%img_to_RI_cell)
323 IF (ALLOCATED(ri_data%RI_cell_to_img)) DEALLOCATE (ri_data%RI_cell_to_img)
324
325 IF (ALLOCATED(ri_data%kp_mat_2c_pot)) THEN
326 DO j = 1, SIZE(ri_data%kp_mat_2c_pot, 2)
327 DO i = 1, SIZE(ri_data%kp_mat_2c_pot, 1)
328 CALL dbcsr_release(ri_data%kp_mat_2c_pot(i, j))
329 END DO
330 END DO
331 DEALLOCATE (ri_data%kp_mat_2c_pot)
332 END IF
333
334 IF (ALLOCATED(ri_data%kp_t_3c_int)) THEN
335 DO i = 1, SIZE(ri_data%kp_t_3c_int)
336 CALL dbt_destroy(ri_data%kp_t_3c_int(i))
337 END DO
338 DEALLOCATE (ri_data%kp_t_3c_int)
339 END IF
340
341 IF (ALLOCATED(ri_data%t_2c_inv)) THEN
342 DO j = 1, SIZE(ri_data%t_2c_inv, 2)
343 DO i = 1, SIZE(ri_data%t_2c_inv, 1)
344 CALL dbt_destroy(ri_data%t_2c_inv(i, j))
345 END DO
346 END DO
347 DEALLOCATE (ri_data%t_2c_inv)
348 END IF
349
350 IF (ALLOCATED(ri_data%t_2c_int)) THEN
351 DO j = 1, SIZE(ri_data%t_2c_int, 2)
352 DO i = 1, SIZE(ri_data%t_2c_int, 1)
353 CALL dbt_destroy(ri_data%t_2c_int(i, j))
354 END DO
355 END DO
356 DEALLOCATE (ri_data%t_2c_int)
357 END IF
358
359 IF (ALLOCATED(ri_data%t_2c_pot)) THEN
360 DO j = 1, SIZE(ri_data%t_2c_pot, 2)
361 DO i = 1, SIZE(ri_data%t_2c_pot, 1)
362 CALL dbt_destroy(ri_data%t_2c_pot(i, j))
363 END DO
364 END DO
365 DEALLOCATE (ri_data%t_2c_pot)
366 END IF
367
368 IF (ALLOCATED(ri_data%t_3c_int_ctr_1)) THEN
369 DO j = 1, SIZE(ri_data%t_3c_int_ctr_1, 2)
370 DO i = 1, SIZE(ri_data%t_3c_int_ctr_1, 1)
371 CALL dbt_destroy(ri_data%t_3c_int_ctr_1(i, j))
372 END DO
373 END DO
374 DEALLOCATE (ri_data%t_3c_int_ctr_1)
375 END IF
376
377 IF (ALLOCATED(ri_data%t_3c_int_ctr_2)) THEN
378 DO j = 1, SIZE(ri_data%t_3c_int_ctr_2, 2)
379 DO i = 1, SIZE(ri_data%t_3c_int_ctr_2, 1)
380 CALL dbt_destroy(ri_data%t_3c_int_ctr_2(i, j))
381 END DO
382 END DO
383 DEALLOCATE (ri_data%t_3c_int_ctr_2)
384 END IF
385
386 IF (ALLOCATED(ri_data%rho_ao_t)) THEN
387 DO j = 1, SIZE(ri_data%rho_ao_t, 2)
388 DO i = 1, SIZE(ri_data%rho_ao_t, 1)
389 CALL dbt_destroy(ri_data%rho_ao_t(i, j))
390 END DO
391 END DO
392 DEALLOCATE (ri_data%rho_ao_t)
393 END IF
394
395 IF (ALLOCATED(ri_data%ks_t)) THEN
396 DO j = 1, SIZE(ri_data%ks_t, 2)
397 DO i = 1, SIZE(ri_data%ks_t, 1)
398 CALL dbt_destroy(ri_data%ks_t(i, j))
399 END DO
400 END DO
401 DEALLOCATE (ri_data%ks_t)
402 END IF
403
404 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 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 IF (ri_data%unit_nr > 0) THEN
422 IF (b_img == 1) THEN
423 WRITE (ri_data%unit_nr, '(/T6,A)', advance="no") '[-'
424 CALL m_flush(ri_data%unit_nr)
425 END IF
426 IF (b_img > iprint*nimg/71) THEN
427 rep = max(1, 71/nimg)
428 bar = repeat("-", rep)
429 WRITE (ri_data%unit_nr, '(A)', advance="no") trim(bar)
430 CALL m_flush(ri_data%unit_nr)
431 iprint = iprint + 1
432 END IF
433 IF (b_img == nimg) THEN
434 rep = max(0, 1 + 71 - iprint*rep)
435 bar = repeat("-", rep)
436 WRITE (ri_data%unit_nr, '(A,A)') trim(bar), '-]'
437 CALL m_flush(ri_data%unit_nr)
438 END IF
439 END IF
440
441 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 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 INTEGER, ALLOCATABLE, DIMENSION(:) :: batch_ranges_at, batch_ranges_nze, &
472 idx_to_at_ao
473 INTEGER, ALLOCATABLE, DIMENSION(:, :) :: iapc_pairs
474 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 TYPE(dbcsr_type), ALLOCATABLE, DIMENSION(:) :: mat_2c_pot
481 TYPE(dbcsr_type), POINTER :: dbcsr_template
482 TYPE(dbt_type), ALLOCATABLE, DIMENSION(:) :: ks_t_split, t_2c_ao_tmp, t_2c_work, &
483 t_3c_int, t_3c_work_2, t_3c_work_3
484 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 NULLIFY (para_env, para_env_sub, blacs_env_sub, hfx_section, dbcsr_template, print_section)
489
490 CALL cite_reference(bussy2024)
491
492 CALL timeset(routinen, handle)
493
494 CALL get_qs_env(qs_env, para_env=para_env, natom=natom)
495
496 IF (nspins == 1) THEN
497 fac = 0.5_dp*hf_fraction
498 ELSE
499 fac = 1.0_dp*hf_fraction
500 END IF
501
502 hfx_section => section_vals_get_subs_vals(qs_env%input, "DFT%XC%HF%RI")
503 CALL section_vals_val_get(hfx_section, "KP_NGROUPS", i_val=ngroups)
504 CALL section_vals_val_get(hfx_section, "KP_STACK_SIZE", i_val=batch_size)
505 CALL section_vals_val_get(hfx_section, "KP_USE_DELTA_P", l_val=use_delta_p)
506 ri_data%kp_stack_size = batch_size
507 ri_data%kp_ngroups = ngroups
508
509 IF (geometry_did_change) THEN
510 CALL hfx_ri_pre_scf_kp(ks_matrix(1, 1)%matrix, ri_data, qs_env)
511 END IF
512 nimg = ri_data%nimg
513 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 pfac = -1.0_dp
536 IF (.NOT. use_delta_p) pfac = 0.0_dp
537 CALL get_pmat_images(ri_data%rho_ao_t, rho_ao, pfac, ri_data, qs_env)
538
539 n_nze = 0
540 DO i_img = 1, nimg
541 DO i_spin = 1, nspins
542 CALL get_tensor_occupancy(ri_data%rho_ao_t(i_spin, i_img), nze, occ)
543 IF (nze > 0) THEN
544 n_nze = n_nze + 1
545 END IF
546 END DO
547 END DO
548 IF (n_nze == nspins) THEN
549 cpwarn("It is highly recommended to restart from a converged GGA K-point calculations.")
550 END IF
551
552 ALLOCATE (ks_t(nspins, nimg))
553 DO i_img = 1, nimg
554 DO i_spin = 1, nspins
555 CALL dbt_create(ri_data%ks_t(1, 1), ks_t(i_spin, i_img))
556 END DO
557 END DO
558
559 ALLOCATE (idx_to_at_ao(SIZE(ri_data%bsizes_AO_split)))
560 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 ALLOCATE (t_3c_apc(nspins, nimg))
569 DO i_img = 1, nimg
570 DO i_spin = 1, nspins
571 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 CALL contract_pmat_3c(t_3c_apc, ri_data%rho_ao_t, ri_data, qs_env)
575
576 IF (mod(para_env%num_pe, ngroups) /= 0) THEN
577 cpwarn("KP_NGROUPS must be an integer divisor of the total number of MPI ranks. It was set to 1.")
578 ngroups = 1
579 CALL section_vals_val_set(hfx_section, "KP_NGROUPS", i_val=ngroups)
580 END IF
581 IF ((mod(ngroups, natom) /= 0) .AND. (mod(natom, ngroups) /= 0) .AND. geometry_did_change) THEN
582 IF (ngroups > 1) THEN
583 cpwarn("Better load balancing is reached if NGROUPS is a multiple/divisor of the number of atoms")
584 END IF
585 END IF
586 group_size = para_env%num_pe/ngroups
587 igroup = para_env%mepos/group_size
588
589 ALLOCATE (para_env_sub)
590 CALL para_env_sub%from_split(para_env, igroup)
591 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 ALLOCATE (sparsity_pattern(natom, natom, nimg))
595 CALL get_sparsity_pattern(sparsity_pattern, ri_data, qs_env)
596 CALL get_sub_dist(sparsity_pattern, ngroups, ri_data)
597
598 !Get all the required tensors in the subgroups
599 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 group_size, ngroups, para_env, para_env_sub, ri_data)
602
603 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 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 ALLOCATE (batch_ranges_at(natom + 1))
610 batch_ranges_at(natom + 1) = SIZE(ri_data%bsizes_AO_split) + 1
611 iatom = 0
612 DO iblk = 1, SIZE(ri_data%bsizes_AO_split)
613 IF (idx_to_at_ao(iblk) == iatom + 1) THEN
614 iatom = iatom + 1
615 batch_ranges_at(iatom) = iblk
616 END IF
617 END DO
618
619 n_batch_nze = nimg_nze/batch_size
620 IF (modulo(nimg_nze, batch_size) /= 0) n_batch_nze = n_batch_nze + 1
621 ALLOCATE (batch_ranges_nze(n_batch_nze + 1))
622 DO i_batch = 1, n_batch_nze
623 batch_ranges_nze(i_batch) = (i_batch - 1)*batch_size + 1
624 END DO
625 batch_ranges_nze(n_batch_nze + 1) = nimg_nze + 1
626
627 print_section => section_vals_get_subs_vals(qs_env%input, "DFT%XC%HF%RI%PRINT")
628 CALL section_vals_val_get(print_section, "KP_RI_PROGRESS_BAR", l_val=print_progress)
629 CALL section_vals_val_get(print_section, "KP_RI_MEMORY_ESTIMATE", l_val=estimate_mem)
630
631 ALLOCATE (iapc_pairs(nimg, 2))
632 IF (estimate_mem .AND. geometry_did_change) THEN
633 !Populate work tensors to simulate maximum usage
634 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 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 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 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 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 dbcsr_template=dbcsr_template)
650 CALL m_memory(mem)
651 CALL para_env%max(mem)
652 CALL dbt_clear(t_3c_work_2(1))
653 CALL dbt_clear(t_3c_work_2(2))
654 CALL dbt_clear(t_3c_work_3(1))
655 CALL dbt_clear(t_3c_work_3(2))
656 CALL dbt_clear(t_2c_work(1))
657
658 IF (ri_data%unit_nr > 0) THEN
659 WRITE (ri_data%unit_nr, fmt="(T3,A,I14)") &
660 "KP-HFX_RI_INFO| Estimated peak memory usage per MPI rank (MiB):", mem/(1024*1024)
661 CALL m_flush(ri_data%unit_nr)
662 END IF
663 END IF
664
665 CALL dbt_batched_contract_init(t_3c_work_3(1), batch_range_2=batch_ranges_at)
666 CALL dbt_batched_contract_init(t_3c_work_3(2), batch_range_2=batch_ranges_at)
667 CALL dbt_batched_contract_init(t_3c_work_2(1), batch_range_1=batch_ranges_at)
668 CALL dbt_batched_contract_init(t_3c_work_2(2), batch_range_1=batch_ranges_at)
669
670 iprint = 1
671 t1 = m_walltime()
672 ri_data%kp_cost(:, :, :) = 0.0_dp
673 DO b_img = 1, nimg
674 IF (print_progress) CALL print_progress_bar(b_img, nimg, iprint, ri_data)
675 CALL dbt_batched_contract_init(ks_t_split(1))
676 CALL dbt_batched_contract_init(ks_t_split(2))
677 DO jatom = 1, natom
678 DO iatom = 1, natom
679 IF (.NOT. sparsity_pattern(iatom, jatom, b_img) == igroup) cycle
680 pref = 1.0_dp
681 IF (iatom == jatom .AND. b_img == 1) pref = 0.5_dp
682
683 !measure the cost of the given i, j, b configuration
684 t3 = m_walltime()
685
686 !Get the proper HFX potential 2c integrals (R_i^0|S_j^b)
687 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 dbcsr_template=dbcsr_template)
691 CALL dbt_copy(t_2c_work(1), t_2c_work(2), move_data=.true.) !move to split blocks
692 CALL dbt_filter(t_2c_work(2), ri_data%filter_eps)
693 CALL timestop(handle2)
694
695 CALL dbt_batched_contract_init(t_2c_work(2))
696 CALL get_iapc_pairs(iapc_pairs, b_img, ri_data, qs_env)
697 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 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 img_bounds=[batch_ranges_nze(i_batch), batch_ranges_nze(i_batch + 1)])
704 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 filter_eps=ri_data%filter_eps, flop=nflop)
711 ri_data%dbcsr_nflop = ri_data%dbcsr_nflop + nflop
712 CALL dbt_copy(t_3c_work_3(2), t_3c_work_2(2), order=[2, 1, 3], move_data=.true.)
713 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 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 img_bounds=[batch_ranges_nze(i_batch), batch_ranges_nze(i_batch + 1)])
721 CALL get_tensor_occupancy(t_3c_work_2(3), nze, occ)
722
723 IF (nze == 0) cycle
724 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 move_data=i_spin == nspins, flop=nflop)
731 ri_data%dbcsr_nflop = ri_data%dbcsr_nflop + nflop
732 END DO
733 END DO !i_batch
734 CALL timestop(handle2)
735 CALL dbt_batched_contract_finalize(t_2c_work(2))
736
737 t4 = m_walltime()
738 ri_data%kp_cost(iatom, jatom, b_img) = t4 - t3
739 END DO !iatom
740 END DO !jatom
741 CALL dbt_batched_contract_finalize(ks_t_split(1))
742 CALL dbt_batched_contract_finalize(ks_t_split(2))
743
744 DO i_spin = 1, nspins
745 CALL dbt_copy(ks_t_split(i_spin), t_2c_ao_tmp(1), move_data=.true.)
746 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 CALL dbt_batched_contract_finalize(t_3c_work_3(1))
750 CALL dbt_batched_contract_finalize(t_3c_work_3(2))
751 CALL dbt_batched_contract_finalize(t_3c_work_2(1))
752 CALL dbt_batched_contract_finalize(t_3c_work_2(2))
753 CALL para_env%sync()
754 CALL para_env%sum(ri_data%dbcsr_nflop)
755 CALL para_env%sum(ri_data%kp_cost)
756 t2 = m_walltime()
757 ri_data%dbcsr_time = ri_data%dbcsr_time + t2 - t1
758
759 !transfer KS tensor from subgroup to main group
760 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 DO i_img = 1, nimg
764 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 CALL dbt_destroy(t_2c_ao_tmp(1))
769 CALL dbt_destroy(ks_t_split(1))
770 CALL dbt_destroy(ks_t_split(2))
771 CALL dbt_destroy(t_2c_work(1))
772 CALL dbt_destroy(t_2c_work(2))
773 CALL dbt_destroy(t_3c_work_2(1))
774 CALL dbt_destroy(t_3c_work_2(2))
775 CALL dbt_destroy(t_3c_work_2(3))
776 CALL dbt_destroy(t_3c_work_3(1))
777 CALL dbt_destroy(t_3c_work_3(2))
778 CALL dbt_destroy(t_3c_work_3(3))
779 DO i_img = 1, nimg
780 CALL dbt_destroy(t_3c_int(i_img))
781 CALL dbcsr_release(mat_2c_pot(i_img))
782 DO i_spin = 1, nspins
783 CALL dbt_destroy(t_3c_apc_sub(i_spin, i_img))
784 CALL dbt_destroy(ks_t_sub(i_spin, i_img))
785 END DO
786 END DO
787 IF (ASSOCIATED(dbcsr_template)) THEN
788 CALL dbcsr_release(dbcsr_template)
789 DEALLOCATE (dbcsr_template)
790 END IF
791
792 !End of subgroup parallelization
793 CALL cp_blacs_env_release(blacs_env_sub)
794 CALL para_env_sub%free()
795 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 CALL get_pmat_images(ri_data%rho_ao_t, rho_ao, 0.0_dp, ri_data, qs_env)
801 DO i_spin = 1, nspins
802 DO b_img = 1, nimg
803 CALL dbt_copy(ks_t(i_spin, b_img), ri_data%ks_t(i_spin, b_img), summation=.true.)
804
805 !desymmetrize
806 mb_img = get_opp_index(b_img, qs_env)
807 IF (mb_img > 0 .AND. mb_img <= nimg) THEN
808 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 DO b_img = 1, nimg
813 DO i_spin = 1, nspins
814 CALL dbt_destroy(ks_t(i_spin, b_img))
815 END DO
816 END DO
817
818 !calculate the energy
819 CALL dbt_create(ri_data%ks_t(1, 1), t_2c_ao_tmp(1))
820 CALL dbcsr_create(tmp, template=ks_matrix(1, 1)%matrix, matrix_type=dbcsr_type_symmetric)
821 CALL dbcsr_create(ks_desymm, template=ks_matrix(1, 1)%matrix, matrix_type=dbcsr_type_no_symmetry)
822 CALL dbcsr_create(rho_desymm, template=ks_matrix(1, 1)%matrix, matrix_type=dbcsr_type_no_symmetry)
823 ehfx = 0.0_dp
824 DO i_img = 1, nimg
825 DO i_spin = 1, nspins
826 CALL dbt_filter(ri_data%ks_t(i_spin, i_img), ri_data%filter_eps)
827 CALL dbt_copy(ri_data%ks_t(i_spin, i_img), t_2c_ao_tmp(1))
828 CALL dbt_copy_tensor_to_matrix(t_2c_ao_tmp(1), ks_desymm)
829 CALL dbt_copy_tensor_to_matrix(t_2c_ao_tmp(1), tmp)
830 CALL dbcsr_add(ks_matrix(i_spin, i_img)%matrix, tmp, 1.0_dp, 1.0_dp)
831
832 CALL dbt_copy(ri_data%rho_ao_t(i_spin, i_img), t_2c_ao_tmp(1))
833 CALL dbt_copy_tensor_to_matrix(t_2c_ao_tmp(1), rho_desymm)
834
835 CALL dbcsr_dot(ks_desymm, rho_desymm, etmp)
836 ehfx = ehfx + 0.5_dp*etmp
837
838 IF (.NOT. use_delta_p) CALL dbt_clear(ri_data%ks_t(i_spin, i_img))
839 END DO
840 END DO
841 CALL dbcsr_release(rho_desymm)
842 CALL dbcsr_release(ks_desymm)
843 CALL dbcsr_release(tmp)
844 CALL dbt_destroy(t_2c_ao_tmp(1))
845
846 CALL timestop(handle)
847
848 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 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 INTEGER, ALLOCATABLE, DIMENSION(:) :: atom_of_kind, batch_ranges_at, &
876 batch_ranges_nze, dist1, dist2, &
877 i_images, idx_to_at_ao, idx_to_at_ri, &
878 kind_of
879 INTEGER, ALLOCATABLE, DIMENSION(:, :) :: iapc_pairs
880 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 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 TYPE(dbcsr_type), ALLOCATABLE, DIMENSION(:) :: mat_2c_pot
889 TYPE(dbcsr_type), ALLOCATABLE, DIMENSION(:, :) :: mat_der_pot, mat_der_pot_sub
890 TYPE(dbcsr_type), POINTER :: dbcsr_template
891 TYPE(dbt_type) :: t_2c_r, t_2c_r_split
892 TYPE(dbt_type), ALLOCATABLE, DIMENSION(:) :: t_2c_bint, t_2c_binv, t_2c_der_pot, &
893 t_2c_inv, t_2c_metric, t_2c_work, &
894 t_3c_der_stack, t_3c_work_2, &
895 t_3c_work_3
896 TYPE(dbt_type), ALLOCATABLE, DIMENSION(:, :) :: rho_ao_t, rho_ao_t_sub, t_2c_der_metric, &
897 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 t_3c_der_ri_sub
899 TYPE(mp_para_env_type), POINTER :: para_env, para_env_sub
900 TYPE(particle_type), DIMENSION(:), POINTER :: particle_set
901 TYPE(qs_force_type), DIMENSION(:), POINTER :: force
902 TYPE(section_vals_type), POINTER :: hfx_section
903 TYPE(virial_type), POINTER :: virial
904
905 NULLIFY (para_env, para_env_sub, hfx_section, blacs_env_sub, dbcsr_template, force, atomic_kind_set, &
906 virial, particle_set, cell)
907
908 CALL timeset(routinen, handle)
909
910 use_virial_prv = .false.
911 IF (PRESENT(use_virial)) use_virial_prv = use_virial
912
913 IF (nspins == 1) THEN
914 fac = 0.5_dp*hf_fraction
915 ELSE
916 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 atomic_kind_set=atomic_kind_set, particle_set=particle_set)
921 CALL get_atomic_kind_set(atomic_kind_set, kind_of=kind_of, atom_of_kind=atom_of_kind)
922
923 ALLOCATE (idx_to_at_ao(SIZE(ri_data%bsizes_AO_split)))
924 CALL get_idx_to_atom(idx_to_at_ao, ri_data%bsizes_AO_split, ri_data%bsizes_AO)
925
926 ALLOCATE (idx_to_at_ri(SIZE(ri_data%bsizes_RI_split)))
927 CALL get_idx_to_atom(idx_to_at_ri, ri_data%bsizes_RI_split, ri_data%bsizes_RI)
928
929 nimg = ri_data%nimg
930 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 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 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 name="(AO | AO)")
941 DEALLOCATE (dist1, dist2)
942 IF (nspins == 2) CALL dbt_create(rho_ao_t(1, 1), rho_ao_t(2, 1))
943 DO i_img = 2, nimg
944 DO i_spin = 1, nspins
945 CALL dbt_create(rho_ao_t(1, 1), rho_ao_t(i_spin, i_img))
946 END DO
947 END DO
948 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 ALLOCATE (t_3c_apc(nspins, nimg))
952 DO i_img = 1, nimg
953 DO i_spin = 1, nspins
954 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 CALL contract_pmat_3c(t_3c_apc, rho_ao_t, ri_data, qs_env)
958
959 !Setup the subgroups
960 hfx_section => section_vals_get_subs_vals(qs_env%input, "DFT%XC%HF%RI")
961 CALL section_vals_val_get(hfx_section, "KP_NGROUPS", i_val=ngroups)
962 group_size = para_env%num_pe/ngroups
963 igroup = para_env%mepos/group_size
964
965 ALLOCATE (para_env_sub)
966 CALL para_env_sub%from_split(para_env, igroup)
967 CALL cp_blacs_env_create(blacs_env_sub, para_env_sub)
968
969 !Get the ususal sparsity pattern
970 ALLOCATE (sparsity_pattern(natom, natom, nimg))
971 CALL get_sparsity_pattern(sparsity_pattern, ri_data, qs_env)
972 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 ALLOCATE (t_2c_inv(natom), mat_2c_pot(nimg), rho_ao_t_sub(nspins, nimg), t_2c_work(5), &
976 t_2c_der_metric_sub(natom, 3), mat_der_pot_sub(nimg, 3), t_2c_bint(natom), &
977 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 mat_der_pot_sub, group_size, ngroups, para_env, para_env_sub, ri_data)
981 CALL dbt_create(t_2c_work(1), t_2c_r) !nRI x nRI
982 CALL dbt_create(t_2c_work(5), t_2c_r_split) !nRI x nRI with split blocks
983
984 ALLOCATE (t_2c_der_pot(3))
985 DO i_xyz = 1, 3
986 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 ALLOCATE (t_3c_work_2(3), t_3c_work_3(4), t_3c_der_stack(6), t_3c_der_ao_sub(nimg, 3), &
991 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 group_size, ngroups, para_env, para_env_sub, ri_data)
995
996 !Set up batched contraction (go atom by atom)
997 ALLOCATE (batch_ranges_at(natom + 1))
998 batch_ranges_at(natom + 1) = SIZE(ri_data%bsizes_AO_split) + 1
999 iatom = 0
1000 DO iblk = 1, SIZE(ri_data%bsizes_AO_split)
1001 IF (idx_to_at_ao(iblk) == iatom + 1) THEN
1002 iatom = iatom + 1
1003 batch_ranges_at(iatom) = iblk
1004 END IF
1005 END DO
1006
1007 CALL dbt_batched_contract_init(t_3c_work_3(1), batch_range_2=batch_ranges_at)
1008 CALL dbt_batched_contract_init(t_3c_work_3(2), batch_range_2=batch_ranges_at)
1009 CALL dbt_batched_contract_init(t_3c_work_3(3), batch_range_2=batch_ranges_at)
1010 CALL dbt_batched_contract_init(t_3c_work_2(1), batch_range_1=batch_ranges_at)
1011 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 nimg_nze = ri_data%nimg_nze
1015 batch_size = ri_data%kp_stack_size
1016 n_batch = nimg_nze/batch_size
1017 IF (modulo(nimg_nze, batch_size) /= 0) n_batch = n_batch + 1
1018 ALLOCATE (batch_ranges_nze(n_batch + 1))
1019 DO i_batch = 1, n_batch
1020 batch_ranges_nze(i_batch) = (i_batch - 1)*batch_size + 1
1021 END DO
1022 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 DO iatom = 1, natom
1027 CALL dbt_create(t_2c_inv(iatom), t_2c_binv(iatom))
1028 CALL dbt_copy(t_2c_inv(iatom), t_2c_binv(iatom))
1029 CALL apply_bump(t_2c_binv(iatom), iatom, ri_data, qs_env, from_left=.true., from_right=.false.)
1030 CALL apply_bump(t_2c_inv(iatom), iatom, ri_data, qs_env, from_left=.true., from_right=.true.)
1031 END DO
1032
1033 t1 = m_walltime()
1034 work_virial = 0.0_dp
1035 ALLOCATE (iapc_pairs(nimg, 2), i_images(nimg))
1036 ALLOCATE (force_pattern(natom, natom, nimg))
1037 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 DO i_loop = 1, 2
1041 DO b_img = 1, nimg
1042 DO jatom = 1, natom
1043 DO iatom = 1, natom
1044
1045 pref = -0.5_dp*fac
1046 IF (i_loop == 1 .AND. (.NOT. sparsity_pattern(iatom, jatom, b_img) == igroup)) cycle
1047 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 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 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 filter_eps=ri_data%filter_eps, flop=nflop)
1059 CALL dbt_copy(t_2c_work(2), t_2c_work(5), move_data=.true.) !move to split blocks
1060 CALL dbt_filter(t_2c_work(5), ri_data%filter_eps)
1061 CALL timestop(handle2)
1062
1063 CALL timeset(routinen//"_3c", handle2)
1064 bounds_iat(:, 1) = [sum(ri_data%bsizes_AO(1:iatom - 1)) + 1, sum(ri_data%bsizes_AO(1:iatom))]
1065 bounds_jat(:, 1) = [sum(ri_data%bsizes_AO(1:jatom - 1)) + 1, sum(ri_data%bsizes_AO(1:jatom))]
1066 CALL dbt_clear(t_2c_r_split)
1067
1068 DO i_spin = 1, nspins
1069 CALL dbt_batched_contract_init(rho_ao_t_sub(i_spin, b_img))
1070 END DO
1071
1072 CALL get_iapc_pairs(iapc_pairs, b_img, ri_data, qs_env, i_images) !i = a+c-b
1073 DO i_batch = 1, n_batch
1074
1075 !Stack the 3c derivatives to take the trace later on
1076 DO i_xyz = 1, 3
1077 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 img_bounds=[batch_ranges_nze(i_batch), batch_ranges_nze(i_batch + 1)])
1082
1083 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 img_bounds=[batch_ranges_nze(i_batch), batch_ranges_nze(i_batch + 1)])
1088 END DO
1089
1090 DO i_spin = 1, nspins
1091 !stack the t_3c_apc tensors
1092 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 img_bounds=[batch_ranges_nze(i_batch), batch_ranges_nze(i_batch + 1)])
1096 CALL get_tensor_occupancy(t_3c_work_2(3), nze, occ)
1097 IF (nze == 0) cycle
1098 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 filter_eps=ri_data%filter_eps, flop=nflop)
1108 ri_data%dbcsr_nflop = ri_data%dbcsr_nflop + nflop
1109
1110 CALL get_tensor_occupancy(t_3c_work_2(2), nze, occ)
1111 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 CALL dbt_copy(t_3c_work_2(2), t_3c_work_3(1), order=[2, 1, 3], move_data=.true.)
1115 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 filter_eps=ri_data%filter_eps, flop=nflop)
1121 ri_data%dbcsr_nflop = ri_data%dbcsr_nflop + nflop
1122 CALL dbt_batched_contract_finalize(t_2c_work(5))
1123
1124 !Contract with the 3c derivatives to get the force/virial
1125 CALL dbt_copy(t_3c_work_3(2), t_3c_work_3(4), move_data=.true.)
1126 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 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 ri_data, qs_env)
1138 END IF
1139 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 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 img_bounds=[batch_ranges_nze(i_batch), batch_ranges_nze(i_batch + 1)])
1149 CALL dbt_copy(t_3c_work_3(4), t_3c_work_3(3), move_data=.true.)
1150
1151 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 filter_eps=ri_data%filter_eps, flop=nflop)
1157 ri_data%dbcsr_nflop = ri_data%dbcsr_nflop + nflop
1158 CALL dbt_batched_contract_finalize(t_2c_r_split)
1159 CALL dbt_copy(t_3c_work_3(4), t_3c_work_3(1))
1160 END DO
1161 END DO
1162 DO i_spin = 1, nspins
1163 CALL dbt_batched_contract_finalize(rho_ao_t_sub(i_spin, b_img))
1164 END DO
1165 CALL timestop(handle2)
1166
1167 IF (i_loop == 2) cycle
1168 pref = 2.0_dp*pref
1169 IF (iatom == jatom .AND. b_img == 1) pref = 0.5_dp*pref
1170
1171 CALL timeset(routinen//"_2c_2", handle2)
1172 !Note that the derivatives are in atomic block format (not split)
1173 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 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 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 para_env_ext=para_env_sub, dbcsr_template=dbcsr_template)
1193 END DO
1194
1195 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 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 b_img, pref, ri_data, qs_env)
1201 END IF
1202
1203 DO i_xyz = 1, 3
1204 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 filter_eps=ri_data%filter_eps, flop=nflop)
1213 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 filter_eps=ri_data%filter_eps, flop=nflop)
1219 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 filter_eps=ri_data%filter_eps, flop=nflop)
1228 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 filter_eps=ri_data%filter_eps, flop=nflop)
1235 ri_data%dbcsr_nflop = ri_data%dbcsr_nflop + nflop
1236
1237 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 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 filter_eps=ri_data%filter_eps, flop=nflop)
1247 ri_data%dbcsr_nflop = ri_data%dbcsr_nflop + nflop
1248
1249 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 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 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 CALL dbt_copy(t_2c_work(4), t_2c_work(2))
1260 CALL apply_bump(t_2c_work(2), iatom, ri_data, qs_env, from_left=.true., from_right=.true.)
1261
1262 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 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 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 filter_eps=ri_data%filter_eps, flop=nflop)
1278 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 filter_eps=ri_data%filter_eps, flop=nflop)
1285 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 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 filter_eps=ri_data%filter_eps, flop=nflop)
1296 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 filter_eps=ri_data%filter_eps, flop=nflop)
1303 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 filter_eps=ri_data%filter_eps, flop=nflop)
1312 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 filter_eps=ri_data%filter_eps, flop=nflop)
1319 ri_data%dbcsr_nflop = ri_data%dbcsr_nflop + nflop
1320
1321 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 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 filter_eps=ri_data%filter_eps, flop=nflop)
1331 ri_data%dbcsr_nflop = ri_data%dbcsr_nflop + nflop
1332
1333 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 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 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 CALL dbt_copy(t_2c_work(4), t_2c_work(2))
1344 CALL apply_bump(t_2c_work(2), jatom, ri_data, qs_env, from_left=.true., from_right=.true.)
1345
1346 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 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 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 filter_eps=ri_data%filter_eps, flop=nflop)
1362 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 filter_eps=ri_data%filter_eps, flop=nflop)
1369 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 ri_data, qs_env, work_virial)
1373
1374 CALL timestop(handle2)
1375 END DO !iatom
1376 END DO !jatom
1377 END DO !b_img
1378
1379 IF (i_loop == 1) THEN
1380 CALL update_pattern_to_forces(force_pattern, sparsity_pattern, ngroups, ri_data, qs_env)
1381 END IF
1382 END DO !i_loop
1383
1384 CALL dbt_batched_contract_finalize(t_3c_work_3(1))
1385 CALL dbt_batched_contract_finalize(t_3c_work_3(2))
1386 CALL dbt_batched_contract_finalize(t_3c_work_3(3))
1387 CALL dbt_batched_contract_finalize(t_3c_work_2(1))
1388 CALL dbt_batched_contract_finalize(t_3c_work_2(2))
1389
1390 IF (use_virial_prv) THEN
1391 DO k_xyz = 1, 3
1392 DO j_xyz = 1, 3
1393 DO i_xyz = 1, 3
1394 virial%pv_fock_4c(i_xyz, j_xyz) = virial%pv_fock_4c(i_xyz, j_xyz) &
1395 + 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 CALL cp_blacs_env_release(blacs_env_sub)
1403 CALL para_env_sub%free()
1404 DEALLOCATE (para_env_sub)
1405
1406 CALL para_env%sync()
1407 t2 = m_walltime()
1408 ri_data%dbcsr_time = ri_data%dbcsr_time + t2 - t1
1409
1410 !clean-up
1411 IF (ASSOCIATED(dbcsr_template)) THEN
1412 CALL dbcsr_release(dbcsr_template)
1413 DEALLOCATE (dbcsr_template)
1414 END IF
1415 CALL dbt_destroy(t_2c_r)
1416 CALL dbt_destroy(t_2c_r_split)
1417 CALL dbt_destroy(t_2c_work(1))
1418 CALL dbt_destroy(t_2c_work(2))
1419 CALL dbt_destroy(t_2c_work(3))
1420 CALL dbt_destroy(t_2c_work(4))
1421 CALL dbt_destroy(t_2c_work(5))
1422 CALL dbt_destroy(t_3c_work_2(1))
1423 CALL dbt_destroy(t_3c_work_2(2))
1424 CALL dbt_destroy(t_3c_work_2(3))
1425 CALL dbt_destroy(t_3c_work_3(1))
1426 CALL dbt_destroy(t_3c_work_3(2))
1427 CALL dbt_destroy(t_3c_work_3(3))
1428 CALL dbt_destroy(t_3c_work_3(4))
1429 CALL dbt_destroy(t_3c_der_stack(1))
1430 CALL dbt_destroy(t_3c_der_stack(2))
1431 CALL dbt_destroy(t_3c_der_stack(3))
1432 CALL dbt_destroy(t_3c_der_stack(4))
1433 CALL dbt_destroy(t_3c_der_stack(5))
1434 CALL dbt_destroy(t_3c_der_stack(6))
1435 DO i_xyz = 1, 3
1436 CALL dbt_destroy(t_2c_der_pot(i_xyz))
1437 END DO
1438 DO iatom = 1, natom
1439 CALL dbt_destroy(t_2c_inv(iatom))
1440 CALL dbt_destroy(t_2c_binv(iatom))
1441 CALL dbt_destroy(t_2c_bint(iatom))
1442 CALL dbt_destroy(t_2c_metric(iatom))
1443 DO i_xyz = 1, 3
1444 CALL dbt_destroy(t_2c_der_metric_sub(iatom, i_xyz))
1445 END DO
1446 END DO
1447 DO i_img = 1, nimg
1448 CALL dbcsr_release(mat_2c_pot(i_img))
1449 DO i_spin = 1, nspins
1450 CALL dbt_destroy(rho_ao_t_sub(i_spin, i_img))
1451 CALL dbt_destroy(t_3c_apc_sub(i_spin, i_img))
1452 END DO
1453 END DO
1454 DO i_xyz = 1, 3
1455 DO i_img = 1, nimg
1456 CALL dbt_destroy(t_3c_der_ri_sub(i_img, i_xyz))
1457 CALL dbt_destroy(t_3c_der_ao_sub(i_img, i_xyz))
1458 CALL dbcsr_release(mat_der_pot_sub(i_img, i_xyz))
1459 END DO
1460 END DO
1461
1462 CALL timestop(handle)
1463
1464 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 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 INTEGER, DIMENSION(:, :), POINTER :: index_to_cell
1487 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 REAL(dp), ALLOCATABLE, DIMENSION(:, :) :: blk
1492 TYPE(cell_type), POINTER :: cell
1493 TYPE(dbt_iterator_type) :: iter
1494 TYPE(kpoint_type), POINTER :: kpoints
1495 TYPE(particle_type), DIMENSION(:), POINTER :: particle_set
1496 TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set
1497
1498 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 kpoints=kpoints, particle_set=particle_set)
1502 CALL get_kpoint_info(kpoints, cell_to_index=cell_to_index, index_to_cell=index_to_cell)
1503
1504 my_debump = .false.
1505 IF (PRESENT(debump)) my_debump = debump
1506
1507 my_left = .false.
1508 IF (PRESENT(from_left)) my_left = from_left
1509
1510 my_right = .false.
1511 IF (PRESENT(from_right)) my_right = from_right
1512 cpassert(my_left .OR. my_right)
1513
1514 CALL dbt_get_info(t_2c_inout, nblks_total=nblks)
1515 cpassert(nblks(1) == ri_data%ncell_RI*natom)
1516 cpassert(nblks(2) == ri_data%ncell_RI*natom)
1517
1518 nimg = ri_data%nimg
1519
1520 !Loop over the RI cells and atoms, and apply bump accordingly
1521 r1 = ri_data%kp_RI_range
1522 r0 = ri_data%kp_bump_rad
1523 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!$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 CALL dbt_filter(t_2c_inout, ri_data%filter_eps)
1567
1568 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 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 INTEGER, DIMENSION(:, :), POINTER :: index_to_cell
1596 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 REAL(dp), ALLOCATABLE, DIMENSION(:, :) :: blk
1601 TYPE(cell_type), POINTER :: cell
1602 TYPE(dbt_iterator_type) :: iter
1603 TYPE(kpoint_type), POINTER :: kpoints
1604 TYPE(particle_type), DIMENSION(:), POINTER :: particle_set
1605 TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set
1606
1607 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 kpoints=kpoints, particle_set=particle_set)
1611 CALL get_kpoint_info(kpoints, cell_to_index=cell_to_index, index_to_cell=index_to_cell)
1612
1613 CALL dbt_get_info(t_2c_in, nblks_total=nblks)
1614 cpassert(nblks(1) == ri_data%ncell_RI*natom)
1615 cpassert(nblks(2) == ri_data%ncell_RI*natom)
1616
1617 nimg = ri_data%nimg
1618
1619 !Loop over the RI cells and atoms, and apply bump accordingly
1620 r1 = ri_data%kp_RI_range
1621 r0 = ri_data%kp_bump_rad
1622 rref = pbc(particle_set(atom_i)%r, cell)
1623
1624 iat_of_kind = atom_of_kind(atom_i)
1625 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!$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 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 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 r = (x - r0)/(r1 - r0)
1710 b = -6.0_dp*r**5 + 15.0_dp*r**4 - 10.0_dp*r**3 + 1.0_dp
1711 IF (x >= r1) b = 0.0_dp
1712 IF (x <= r0) b = 1.0_dp
1713
1714 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 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 r = (x - r0)/(r1 - r0)
1730 b = (-30.0_dp*r**4 + 60.0_dp*r**3 - 30.0_dp*r**2)/(r1 - r0)
1731 IF (x >= r1) b = 0.0_dp
1732 IF (x <= r0) b = 0.0_dp
1733
1734 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 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 INTEGER, DIMENSION(:, :), POINTER :: index_to_cell
1750 INTEGER, DIMENSION(:, :, :), POINTER :: cell_to_index
1751 TYPE(kpoint_type), POINTER :: kpoints
1752
1753 CALL get_qs_env(qs_env, kpoints=kpoints)
1754 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 cell_apc(:) = index_to_cell(:, i_index) + index_to_cell(:, b_index)
1758
1759 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 apc_index = cell_to_index(cell_apc(1), cell_apc(2), cell_apc(3))
1765 END IF
1766
1767 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 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 INTEGER, DIMENSION(:, :), POINTER :: index_to_cell
1783 INTEGER, DIMENSION(:, :, :), POINTER :: cell_to_index
1784 TYPE(kpoint_type), POINTER :: kpoints
1785
1786 CALL get_qs_env(qs_env, kpoints=kpoints)
1787 CALL get_kpoint_info(kpoints, cell_to_index=cell_to_index, index_to_cell=index_to_cell)
1788
1789 cell_i(:) = index_to_cell(:, a_index) + index_to_cell(:, c_index)
1790
1791 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 i_index = cell_to_index(cell_i(1), cell_i(2), cell_i(3))
1797 END IF
1798
1799 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 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 INTEGER, DIMENSION(:, :), POINTER :: index_to_cell
1815 INTEGER, DIMENSION(:, :, :), POINTER :: cell_to_index
1816 TYPE(kpoint_type), POINTER :: kpoints
1817
1818 CALL get_qs_env(qs_env, kpoints=kpoints)
1819 CALL get_kpoint_info(kpoints, cell_to_index=cell_to_index, index_to_cell=index_to_cell)
1820
1821 cell_i(:) = index_to_cell(:, apc_index) - index_to_cell(:, b_index)
1822
1823 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 i_index = cell_to_index(cell_i(1), cell_i(2), cell_i(3))
1829 END IF
1830
1831 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 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 nimg = SIZE(ac_pairs, 1)
1851
1852 ac_pairs(:, :) = 0
1853!$OMP PARALLEL DO DEFAULT(NONE) SHARED(ac_pairs,nimg,ri_data,qs_env,apc_index) &
1854!$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 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 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 nimg = SIZE(iapc_pairs, 1)
1886 IF (PRESENT(actual_i_img)) actual_i_img(:) = 0
1887
1888 iapc_pairs(:, :) = 0
1889!$OMP PARALLEL DO DEFAULT(NONE) SHARED(iapc_pairs,nimg,ri_data,qs_env,b_index,actual_i_img) &
1890!$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 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 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 INTEGER, DIMENSION(:, :), POINTER :: index_to_cell
1916 INTEGER, DIMENSION(:, :, :), POINTER :: cell_to_index
1917 TYPE(kpoint_type), POINTER :: kpoints
1918
1919 NULLIFY (kpoints, cell_to_index, index_to_cell)
1920
1921 CALL get_qs_env(qs_env, kpoints=kpoints)
1922 CALL get_kpoint_info(kpoints, cell_to_index=cell_to_index, index_to_cell=index_to_cell)
1923
1924 opp_cell(:) = -index_to_cell(:, a_index)
1925
1926 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 opp_index = cell_to_index(opp_cell(1), opp_cell(2), opp_cell(3))
1932 END IF
1933
1934 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 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 INTEGER, DIMENSION(:, :, :), POINTER :: cell_to_index
1956 LOGICAL :: found
1957 REAL(dp) :: fac
1958 REAL(dp), DIMENSION(:, :), POINTER :: pblock, pblock_desymm
1959 TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: matrix_ks, rho_desymm
1960 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 DIMENSION(:), POINTER :: nl_iterator
1965 TYPE(neighbor_list_set_p_type), DIMENSION(:), &
1966 POINTER :: sab_nl, sab_nl_nosym
1967 TYPE(qs_scf_env_type), POINTER :: scf_env
1968
1969 NULLIFY (rho_desymm, kpoints, sab_nl_nosym, scf_env, matrix_ks, dft_control, &
1970 sab_nl, nl_iterator, cell_to_index, pblock, pblock_desymm)
1971
1972 CALL get_qs_env(qs_env, kpoints=kpoints, scf_env=scf_env, matrix_ks_kp=matrix_ks, dft_control=dft_control)
1973 CALL get_kpoint_info(kpoints, sab_nl_nosym=sab_nl_nosym, cell_to_index=cell_to_index, sab_nl=sab_nl)
1974
1975 IF (dft_control%do_admm) THEN
1976 CALL get_admm_env(qs_env%admm_env, matrix_ks_aux_fit_kp=matrix_ks)
1977 END IF
1978
1979 nspins = SIZE(matrix_ks, 1)
1980 nimg = ri_data%nimg
1981
1982 ALLOCATE (rho_desymm(nspins, nimg))
1983 DO i_img = 1, nimg
1984 DO i_spin = 1, nspins
1985 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 matrix_type=dbcsr_type_no_symmetry)
1988 CALL cp_dbcsr_alloc_block_from_nbl(rho_desymm(i_spin, i_img)%matrix, sab_nl_nosym)
1989 END DO
1990 END DO
1991 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 CALL neighbor_list_iterator_create(nl_iterator, sab_nl)
1996 DO WHILE (neighbor_list_iterate(nl_iterator) == 0)
1997 CALL get_iterator_info(nl_iterator, iatom=iatom, jatom=jatom, cell=cell_j)
1998 j_img = cell_to_index(cell_j(1), cell_j(2), cell_j(3))
1999 IF (j_img > nimg .OR. j_img < 1) cycle
2000
2001 fac = 1.0_dp
2002 IF (iatom == jatom) fac = 0.5_dp
2003 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 IF (mj_img == 0) fac = 1.0_dp
2006
2007 irow = iatom
2008 icol = jatom
2009 IF (iatom > jatom) THEN
2010 !because symmetric nl. Value for atom pair i,j is actually stored in j,i if i > j
2011 irow = jatom
2012 icol = iatom
2013 END IF
2014
2015 DO i_spin = 1, nspins
2016 CALL dbcsr_get_block_p(rho_ao(i_spin, j_img)%matrix, irow, icol, pblock, found)
2017 IF (.NOT. found) cycle
2018
2019 !distribution of symm and non-symm matrix match in that way
2020 CALL dbcsr_get_block_p(rho_desymm(i_spin, j_img)%matrix, iatom, jatom, pblock_desymm, found)
2021 IF (.NOT. found) cycle
2022
2023 IF (iatom > jatom) THEN
2024 pblock_desymm(:, :) = fac*transpose(pblock(:, :))
2025 ELSE
2026 pblock_desymm(:, :) = fac*pblock(:, :)
2027 END IF
2028 END DO
2029 END DO
2030 CALL neighbor_list_iterator_release(nl_iterator)
2031
2032 DO i_img = 1, nimg
2033 DO i_spin = 1, nspins
2034 CALL dbt_scale(rho_ao_t(i_spin, i_img), scale_prev_p)
2035
2036 CALL dbt_copy_matrix_to_tensor(rho_desymm(i_spin, i_img)%matrix, tmp)
2037 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 mi_img = get_opp_index(i_img, qs_env)
2041 IF (mi_img > 0 .AND. mi_img <= nimg) THEN
2042 CALL dbt_copy_matrix_to_tensor(rho_desymm(i_spin, mi_img)%matrix, tmp)
2043 CALL dbt_copy(tmp, rho_ao_t(i_spin, i_img), order=[2, 1], summation=.true., move_data=.true.)
2044 END IF
2045 CALL dbt_filter(rho_ao_t(i_spin, i_img), ri_data%filter_eps)
2046 END DO
2047 END DO
2048
2049 DO i_img = 1, nimg
2050 DO i_spin = 1, nspins
2051 CALL dbcsr_release(rho_desymm(i_spin, i_img)%matrix)
2052 DEALLOCATE (rho_desymm(i_spin, i_img)%matrix)
2053 END DO
2054 END DO
2055
2056 CALL dbt_destroy(tmp)
2057 DEALLOCATE (rho_desymm)
2058
2059 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 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 INTEGER, ALLOCATABLE, DIMENSION(:) :: dist1, dist2
2096 INTEGER, ALLOCATABLE, DIMENSION(:, :) :: present_atoms_i, present_atoms_j
2097 INTEGER, DIMENSION(3) :: cell_b, cell_i, cell_j, cell_tot
2098 INTEGER, DIMENSION(:), POINTER :: col_dist, col_dist_ext, ri_blk_size_ext, &
2099 row_dist, row_dist_ext
2100 INTEGER, DIMENSION(:, :), POINTER :: index_to_cell, pgrid
2101 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 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 TYPE(dbt_type) :: t_2c_tmp
2113 TYPE(distribution_2d_type), POINTER :: dist_2d
2114 TYPE(gto_basis_set_p_type), ALLOCATABLE, &
2115 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 DIMENSION(:), POINTER :: nl_iterator
2120 TYPE(neighbor_list_set_p_type), DIMENSION(:), &
2121 POINTER :: nl_2c
2122 TYPE(particle_type), DIMENSION(:), POINTER :: particle_set
2123 TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set
2124
2125 NULLIFY (qs_kind_set, nl_2c, nl_iterator, cell, kpoints, cell_to_index, index_to_cell, dist_2d, &
2126 para_env, pblock, blacs_env, particle_set, col_dist, row_dist, pgrid, &
2127 col_dist_ext, row_dist_ext)
2128
2129 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 kpoints=kpoints, para_env=para_env, blacs_env=blacs_env, particle_set=particle_set)
2136 CALL get_kpoint_info(kpoints, cell_to_index=cell_to_index, index_to_cell=index_to_cell)
2137
2138 do_inverse_prv = .false.
2139 IF (PRESENT(do_inverse)) do_inverse_prv = do_inverse
2140 IF (do_inverse_prv) THEN
2141 cpassert(atom_i == atom_j)
2142 END IF
2143
2144 skip_inverse_prv = .false.
2145 IF (PRESENT(skip_inverse)) skip_inverse_prv = skip_inverse
2146
2147 my_offd = .false.
2148 IF (PRESENT(off_diagonal)) my_offd = off_diagonal
2149
2150 IF (PRESENT(para_env_ext)) para_env => para_env_ext
2151 IF (PRESENT(blacs_env_ext)) blacs_env => blacs_env_ext
2152
2153 nimg = SIZE(mat_orig)
2154
2155 CALL timeset(routinen//"_nl_iter", handle2)
2156
2157 !create our own dist_2d in the subgroup
2158 ALLOCATE (dist1(natom), dist2(natom))
2159 DO iatom = 1, natom
2160 dist1(iatom) = mod(iatom, blacs_env%num_pe(1))
2161 dist2(iatom) = mod(iatom, blacs_env%num_pe(2))
2162 END DO
2163 CALL distribution_2d_create(dist_2d, dist1, dist2, nkind, particle_set, blacs_env_ext=blacs_env)
2164
2165 ALLOCATE (basis_set_ri(nkind))
2166 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 "HFX_2c_nl_RI", qs_env, sym_ij=.false., dist_2d=dist_2d)
2170
2171 ALLOCATE (present_atoms_i(natom, nimg), present_atoms_j(natom, nimg))
2172 present_atoms_i = 0
2173 present_atoms_j = 0
2174
2175 CALL neighbor_list_iterator_create(nl_iterator, nl_2c)
2176 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 ikind=ikind, jkind=jkind)
2179
2180 dij = norm2(rij)
2181
2182 j_img = cell_to_index(cell_j(1), cell_j(2), cell_j(3))
2183 IF (j_img > nimg .OR. j_img < 1) cycle
2184
2185 IF (iatom == atom_i .AND. dij <= ri_data%kp_RI_range) present_atoms_i(jatom, j_img) = 1
2186 IF (iatom == atom_j .AND. dij <= ri_data%kp_RI_range) present_atoms_j(jatom, j_img) = 1
2187 END DO
2188 CALL neighbor_list_iterator_release(nl_iterator)
2189 CALL release_neighbor_list_sets(nl_2c)
2190 CALL distribution_2d_release(dist_2d)
2191 CALL timestop(handle2)
2192
2193 CALL para_env%sum(present_atoms_i)
2194 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 use_template = .false.
2199 IF (PRESENT(dbcsr_template)) THEN
2200 IF (ASSOCIATED(dbcsr_template)) use_template = .true.
2201 END IF
2202
2203 IF (use_template) THEN
2204 CALL dbcsr_create(work, template=dbcsr_template)
2205 ELSE
2206 CALL dbcsr_get_info(mat_orig(1), distribution=dbcsr_dist)
2207 CALL dbcsr_distribution_get(dbcsr_dist, row_dist=row_dist, col_dist=col_dist, group=group, pgrid=pgrid)
2208 ALLOCATE (row_dist_ext(ri_data%ncell_RI*natom), col_dist_ext(ri_data%ncell_RI*natom))
2209 ALLOCATE (ri_blk_size_ext(ri_data%ncell_RI*natom))
2210 DO i_ri = 1, ri_data%ncell_RI
2211 row_dist_ext((i_ri - 1)*natom + 1:i_ri*natom) = row_dist(:)
2212 col_dist_ext((i_ri - 1)*natom + 1:i_ri*natom) = col_dist(:)
2213 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 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 row_blk_size=ri_blk_size_ext, col_blk_size=ri_blk_size_ext)
2220 CALL dbcsr_distribution_release(dbcsr_dist_ext)
2221 DEALLOCATE (col_dist_ext, row_dist_ext, ri_blk_size_ext)
2222
2223 IF (PRESENT(dbcsr_template)) THEN
2224 ALLOCATE (dbcsr_template)
2225 CALL dbcsr_create(dbcsr_template, template=work)
2226 END IF
2227 END IF !use_template
2228
2229 cell_b(:) = index_to_cell(:, img_b)
2230 DO i_img = 1, nimg
2231 i_ri = ri_data%img_to_RI_cell(i_img)
2232 IF (i_ri == 0) cycle
2233 cell_i(:) = index_to_cell(:, i_img)
2234 DO j_img = 1, nimg
2235 j_ri = ri_data%img_to_RI_cell(j_img)
2236 IF (j_ri == 0) cycle
2237 cell_j(:) = index_to_cell(:, j_img)
2238 cell_tot = cell_j - cell_i + cell_b
2239
2240 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 img_tot = cell_to_index(cell_tot(1), cell_tot(2), cell_tot(3))
2243 IF (img_tot > nimg .OR. img_tot < 1) cycle
2244
2245 CALL dbcsr_iterator_start(dbcsr_iter, mat_orig(img_tot))
2246 DO WHILE (dbcsr_iterator_blocks_left(dbcsr_iter))
2247 CALL dbcsr_iterator_next_block(dbcsr_iter, row=iatom, column=jatom)
2248 IF (present_atoms_i(iatom, i_img) == 0) cycle
2249 IF (present_atoms_j(jatom, j_img) == 0) cycle
2250 IF (my_offd .AND. (i_ri - 1)*natom + iatom == (j_ri - 1)*natom + jatom) cycle
2251
2252 CALL dbcsr_get_block_p(mat_orig(img_tot), iatom, jatom, pblock, found)
2253 IF (.NOT. found) cycle
2254
2255 CALL dbcsr_put_block(work, (i_ri - 1)*natom + iatom, (j_ri - 1)*natom + jatom, pblock)
2256
2257 END DO
2258 CALL dbcsr_iterator_stop(dbcsr_iter)
2259
2260 END DO !j_img
2261 END DO !i_img
2262 CALL dbcsr_finalize(work)
2263
2264 IF (do_inverse_prv) THEN
2265
2266 r1 = ri_data%kp_RI_range
2267 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 nblks_ri = sum(present_atoms_i)
2271 ALLOCATE (col_dist_ext(nblks_ri), row_dist_ext(nblks_ri), ri_blk_size_ext(nblks_ri))
2272 iblk = 0
2273 DO i_img = 1, nimg
2274 i_ri = ri_data%img_to_RI_cell(i_img)
2275 IF (i_ri == 0) cycle
2276 DO iatom = 1, natom
2277 IF (present_atoms_i(iatom, i_img) == 0) cycle
2278 iblk = iblk + 1
2279 col_dist_ext(iblk) = col_dist(iatom)
2280 row_dist_ext(iblk) = row_dist(iatom)
2281 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 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 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 row_blk_size=ri_blk_size_ext, col_blk_size=ri_blk_size_ext)
2291 CALL dbcsr_distribution_release(dbcsr_dist_ext)
2292 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 rref = pbc(particle_set(atom_i)%r, cell)
2297
2298 iblk = 0
2299 DO i_img = 1, nimg
2300 i_ri = ri_data%img_to_RI_cell(i_img)
2301 IF (i_ri == 0) cycle
2302 DO iatom = 1, natom
2303 IF (present_atoms_i(iatom, i_img) == 0) cycle
2304 iblk = iblk + 1
2305
2306 CALL real_to_scaled(scoord, pbc(particle_set(iatom)%r, cell), cell)
2307 CALL scaled_to_real(ri, scoord(:) + index_to_cell(:, i_img), cell)
2308
2309 jblk = 0
2310 DO j_img = 1, nimg
2311 j_ri = ri_data%img_to_RI_cell(j_img)
2312 IF (j_ri == 0) cycle
2313 DO jatom = 1, natom
2314 IF (present_atoms_j(jatom, j_img) == 0) cycle
2315 jblk = jblk + 1
2316
2317 CALL real_to_scaled(scoord, pbc(particle_set(jatom)%r, cell), cell)
2318 CALL scaled_to_real(rj, scoord(:) + index_to_cell(:, j_img), cell)
2319
2320 CALL dbcsr_get_block_p(work, (i_ri - 1)*natom + iatom, (j_ri - 1)*natom + jatom, pblock, found)
2321 IF (.NOT. found) cycle
2322
2323 bfac = 1.0_dp
2324 IF (iblk /= jblk) bfac = bump(norm2(ri - rref), r0, r1)*bump(norm2(rj - rref), r0, r1)
2325 CALL dbcsr_put_block(work_tight, iblk, jblk, bfac*pblock(:, :))
2326 END DO
2327 END DO
2328 END DO
2329 END DO
2330 CALL dbcsr_finalize(work_tight)
2331 CALL dbcsr_clear(work)
2332
2333 IF (.NOT. skip_inverse_prv) THEN
2334 SELECT CASE (ri_data%t2c_method)
2335 CASE (hfx_ri_do_2c_iter)
2336 threshold = max(ri_data%filter_eps, 1.0e-12_dp)
2337 CALL invert_hotelling(work_tight_inv, work_tight, threshold=threshold, silent=.false.)
2338 CASE (hfx_ri_do_2c_cholesky)
2339 CALL dbcsr_copy(work_tight_inv, work_tight)
2340 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 uplo_to_full=.true.)
2343 CASE (hfx_ri_do_2c_diag)
2344 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 para_env, blacs_env, verbose=ri_data%unit_nr_dbcsr > 0)
2347 END SELECT
2348 ELSE
2349 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 iblk = 0
2356 DO i_img = 1, nimg
2357 i_ri = ri_data%img_to_RI_cell(i_img)
2358 IF (i_ri == 0) cycle
2359 DO iatom = 1, natom
2360 IF (present_atoms_i(iatom, i_img) == 0) cycle
2361 iblk = iblk + 1
2362
2363 jblk = 0
2364 DO j_img = 1, nimg
2365 j_ri = ri_data%img_to_RI_cell(j_img)
2366 IF (j_ri == 0) cycle
2367 DO jatom = 1, natom
2368 IF (present_atoms_j(jatom, j_img) == 0) cycle
2369 jblk = jblk + 1
2370
2371 CALL dbcsr_get_block_p(work_tight_inv, iblk, jblk, pblock, found)
2372 IF (.NOT. found) cycle
2373
2374 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 CALL dbcsr_finalize(work)
2380
2381 CALL dbcsr_release(work_tight)
2382 CALL dbcsr_release(work_tight_inv)
2383 END IF
2384
2385 CALL dbt_create(work, t_2c_tmp)
2386 CALL dbt_copy_matrix_to_tensor(work, t_2c_tmp)
2387 CALL dbt_copy(t_2c_tmp, t_2c_pot, move_data=.true.)
2388 CALL dbt_filter(t_2c_pot, ri_data%filter_eps)
2389
2390 CALL dbt_destroy(t_2c_tmp)
2391 CALL dbcsr_release(work)
2392
2393 CALL timestop(handle)
2394
2395 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 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 INTEGER, ALLOCATABLE, DIMENSION(:) :: apc_filter, batch_ranges_img, &
2418 batch_ranges_nze, int_indices
2419 INTEGER, ALLOCATABLE, DIMENSION(:, :) :: ac_pairs, iapc_pairs
2420 REAL(dp) :: occ, t1, t2
2421 TYPE(dbt_type) :: t_3c_tmp
2422 TYPE(dbt_type), ALLOCATABLE, DIMENSION(:) :: ints_stack, res_stack, rho_stack
2423 TYPE(dft_control_type), POINTER :: dft_control
2424
2425 CALL timeset(routinen, handle)
2426
2427 CALL get_qs_env(qs_env, dft_control=dft_control)
2428
2429 nimg = ri_data%nimg
2430 nimg_nze = ri_data%nimg_nze
2431 nspins = dft_control%nspins
2432
2433 CALL dbt_create(t_3c_apc(1, 1), t_3c_tmp)
2434
2435 batch_size = ri_data%kp_stack_size
2436
2437 ALLOCATE (apc_filter(nimg), iapc_pairs(nimg, 2))
2438 apc_filter = 0
2439 DO b_img = 1, nimg
2440 CALL get_iapc_pairs(iapc_pairs, b_img, ri_data, qs_env)
2441 DO i_img = 1, nimg_nze
2442 idx = iapc_pairs(i_img, 2)
2443 IF (idx < 1 .OR. idx > nimg) cycle
2444 apc_filter(idx) = 1
2445 END DO
2446 END DO
2447
2448 !batching over all images
2449 n_batch_img = nimg/batch_size
2450 IF (modulo(nimg, batch_size) /= 0) n_batch_img = n_batch_img + 1
2451 ALLOCATE (batch_ranges_img(n_batch_img + 1))
2452 DO i_batch = 1, n_batch_img
2453 batch_ranges_img(i_batch) = (i_batch - 1)*batch_size + 1
2454 END DO
2455 batch_ranges_img(n_batch_img + 1) = nimg + 1
2456
2457 !batching over images with non-zero 3c integrals
2458 n_batch_nze = nimg_nze/batch_size
2459 IF (modulo(nimg_nze, batch_size) /= 0) n_batch_nze = n_batch_nze + 1
2460 ALLOCATE (batch_ranges_nze(n_batch_nze + 1))
2461 DO i_batch = 1, n_batch_nze
2462 batch_ranges_nze(i_batch) = (i_batch - 1)*batch_size + 1
2463 END DO
2464 batch_ranges_nze(n_batch_nze + 1) = nimg_nze + 1
2465
2466 !Create the stack tensors in the approriate distribution
2467 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 ri_data%t_3c_int_ctr_1(1, 1), batch_size, ri_data, qs_env)
2470
2471 ALLOCATE (ac_pairs(nimg, 2), int_indices(nimg_nze))
2472 DO i_img = 1, nimg_nze
2473 int_indices(i_img) = i_img
2474 END DO
2475
2476 t1 = m_walltime()
2477 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 img_bounds=[batch_ranges_nze(j_batch), batch_ranges_nze(j_batch + 1)])
2481 CALL dbt_copy(ints_stack(1), ints_stack(2), move_data=.true.)
2482
2483 DO i_spin = 1, nspins
2484 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 DO apc_img = batch_ranges_img(i_batch), batch_ranges_img(i_batch + 1) - 1
2487 IF (apc_filter(apc_img) == 0) cycle
2488 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 shift=apc_img - batch_ranges_img(i_batch) + 1)
2492
2493 END DO !apc_img
2494 CALL get_tensor_occupancy(rho_stack(1), nze, occ)
2495 IF (nze == 0) cycle
2496 CALL dbt_copy(rho_stack(1), rho_stack(2), move_data=.true.)
2497
2498 !The actual contraction
2499 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 filter_eps=ri_data%filter_eps, flop=nflop)
2505 ri_data%dbcsr_nflop = ri_data%dbcsr_nflop + nflop
2506 CALL dbt_batched_contract_finalize(rho_stack(2))
2507 CALL dbt_copy(res_stack(2), res_stack(1), move_data=.true.)
2508
2509 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 IF (apc_filter(apc_img) == 0) cycle
2512 CALL unstack_t_3c_apc(t_3c_tmp, res_stack(1), apc_img - batch_ranges_img(i_batch) + 1)
2513 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 DEALLOCATE (batch_ranges_img)
2520 DEALLOCATE (batch_ranges_nze)
2521 t2 = m_walltime()
2522 ri_data%dbcsr_time = ri_data%dbcsr_time + t2 - t1
2523
2524 CALL dbt_destroy(rho_stack(1))
2525 CALL dbt_destroy(rho_stack(2))
2526 CALL dbt_destroy(ints_stack(1))
2527 CALL dbt_destroy(ints_stack(2))
2528 CALL dbt_destroy(res_stack(1))
2529 CALL dbt_destroy(res_stack(2))
2530 CALL dbt_destroy(t_3c_tmp)
2531
2532 CALL timestop(handle)
2533
2534 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 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 INTEGER, ALLOCATABLE, DIMENSION(:) :: batch_ranges, bsizes_ri_ext, bsizes_ri_ext_split, &
2554 bsizes_stack, dist1, dist2, dist3, dist_stack3, idx_to_at_ao, int_indices
2555 TYPE(dbt_distribution_type) :: t_dist
2556 TYPE(dbt_type) :: t_2c_ri_tmp(2), t_3c_tmp(3)
2557
2558 CALL timeset(routinen, handle)
2559
2560 CALL get_qs_env(qs_env, natom=natom)
2561
2562 nimg = ri_data%nimg
2563 ALLOCATE (int_indices(nimg))
2564 DO i_img = 1, nimg
2565 int_indices(i_img) = i_img
2566 END DO
2567
2568 ALLOCATE (idx_to_at_ao(SIZE(ri_data%bsizes_AO_split)))
2569 CALL get_idx_to_atom(idx_to_at_ao, ri_data%bsizes_AO_split, ri_data%bsizes_AO)
2570
2571 nblks = SIZE(ri_data%bsizes_RI_split)
2572 ALLOCATE (bsizes_ri_ext(ri_data%ncell_RI*natom))
2573 ALLOCATE (bsizes_ri_ext_split(ri_data%ncell_RI*nblks))
2574 DO i_ri = 1, ri_data%ncell_RI
2575 bsizes_ri_ext((i_ri - 1)*natom + 1:i_ri*natom) = ri_data%bsizes_RI(:)
2576 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 name="(RI | RI)")
2581 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 name="(RI | RI)")
2585 DEALLOCATE (dist1, dist2)
2586
2587 !For more efficiency, we stack multiple images of the 3-center integrals into a single tensor
2588 batch_size = ri_data%kp_stack_size
2589 n_batch = nimg/batch_size
2590 IF (modulo(nimg, batch_size) /= 0) n_batch = n_batch + 1
2591 ALLOCATE (batch_ranges(n_batch + 1))
2592 DO i_batch = 1, n_batch
2593 batch_ranges(i_batch) = (i_batch - 1)*batch_size + 1
2594 END DO
2595 batch_ranges(n_batch + 1) = nimg + 1
2596
2597 nblks = SIZE(ri_data%bsizes_AO_split)
2598 ALLOCATE (bsizes_stack(batch_size*nblks))
2599 DO is = 1, batch_size
2600 bsizes_stack((is - 1)*nblks + 1:is*nblks) = ri_data%bsizes_AO_split(:)
2601 END DO
2602
2603 CALL dbt_get_info(t_3c_int(1, 1), nblks_total=nblks_3c)
2604 ALLOCATE (dist1(nblks_3c(1)), dist2(nblks_3c(2)), dist3(nblks_3c(3)), dist_stack3(batch_size*nblks_3c(3)))
2605 CALL dbt_get_info(t_3c_int(1, 1), proc_dist_1=dist1, proc_dist_2=dist2, proc_dist_3=dist3)
2606 DO is = 1, batch_size
2607 dist_stack3((is - 1)*nblks_3c(3) + 1:is*nblks_3c(3)) = dist3(:)
2608 END DO
2609
2610 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 ri_data%bsizes_AO_split, bsizes_stack)
2613 CALL dbt_distribution_destroy(t_dist)
2614 DEALLOCATE (dist1, dist2, dist3, dist_stack3)
2615
2616 CALL dbt_create(t_3c_tmp(1), t_3c_tmp(2))
2617 CALL dbt_create(t_3c_int(1, 1), t_3c_tmp(3))
2618
2619 DO iatom = 1, natom
2620 CALL dbt_copy(ri_data%t_2c_inv(1, iatom), t_2c_ri_tmp(1))
2621 CALL apply_bump(t_2c_ri_tmp(1), iatom, ri_data, qs_env, from_left=.true., from_right=.true.)
2622 CALL dbt_copy(t_2c_ri_tmp(1), t_2c_ri_tmp(2), move_data=.true.)
2623
2624 CALL dbt_batched_contract_init(t_2c_ri_tmp(2))
2625 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 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 filter_eps=ri_data%filter_eps, flop=nflop)
2636 ri_data%dbcsr_nflop = ri_data%dbcsr_nflop + nflop
2637
2638 DO i_img = batch_ranges(i_batch), batch_ranges(i_batch + 1) - 1
2639 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 order=[2, 1, 3], move_data=.true.)
2642 END DO
2643 CALL dbt_clear(t_3c_tmp(1))
2644 END DO
2645 CALL dbt_batched_contract_finalize(t_2c_ri_tmp(2))
2646
2647 END DO
2648 CALL dbt_destroy(t_2c_ri_tmp(1))
2649 CALL dbt_destroy(t_2c_ri_tmp(2))
2650 CALL dbt_destroy(t_3c_tmp(1))
2651 CALL dbt_destroy(t_3c_tmp(2))
2652 CALL dbt_destroy(t_3c_tmp(3))
2653
2654 DO i_img = 1, nimg
2655 CALL dbt_destroy(t_3c_int(1, i_img))
2656 END DO
2657
2658 CALL timestop(handle)
2659
2660 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 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 INTEGER, ALLOCATABLE, DIMENSION(:) :: bsizes1, bsizes2
2680 INTEGER, ALLOCATABLE, DIMENSION(:, :) :: block_dest, block_source
2681 INTEGER, ALLOCATABLE, DIMENSION(:, :, :) :: current_dest
2682 INTEGER, DIMENSION(2) :: ind, nblks
2683 LOGICAL :: found
2684 REAL(dp), ALLOCATABLE, DIMENSION(:, :) :: blk
2685 TYPE(cp_2d_r_p_type), ALLOCATABLE, DIMENSION(:) :: recv_buff, send_buff
2686 TYPE(dbt_iterator_type) :: iter
2687 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 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 ALLOCATE (block_source(nblks(1), nblks(2)))
2697 block_source = -1
2698 nocc = 0
2699!$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 CALL para_env%sum(nocc)
2715 CALL para_env%sum(block_source)
2716 block_source = block_source + para_env%num_pe - 1
2717 IF (nocc == 0) RETURN
2718
2719 !Loop over the sub tensor, get the block destination
2720 igroup = para_env%mepos/group_size
2721 ALLOCATE (block_dest(nblks(1), nblks(2)))
2722 block_dest = -1
2723 DO jblk = 1, nblks(2)
2724 DO iblk = 1, nblks(1)
2725 IF (block_source(iblk, jblk) == -1) cycle
2726
2727 CALL dbt_get_stored_coordinates(t2c_sub, [iblk, jblk], iproc)
2728 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 ALLOCATE (bsizes1(nblks(1)), bsizes2(nblks(2)))
2733 CALL dbt_get_info(t2c_main, blk_size_1=bsizes1, blk_size_2=bsizes2)
2734
2735 ALLOCATE (current_dest(nblks(1), nblks(2), 0:ngroups - 1))
2736 DO igroup = 0, ngroups - 1
2737 !for a given subgroup, need to make the destination available to everyone in the main group
2738 current_dest(:, :, igroup) = block_dest(:, :)
2739 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 batch_size = min(para_env%get_tag_ub(), 128000, nocc*ngroups)
2744 n_batch = (nocc*ngroups)/batch_size
2745 IF (modulo(nocc*ngroups, batch_size) /= 0) n_batch = n_batch + 1
2746
2747 DO i_batch = 1, n_batch
2748 !Loop over groups, blocks and send/receive
2749 ALLOCATE (send_buff(batch_size), recv_buff(batch_size))
2750 ALLOCATE (send_req(batch_size), recv_req(batch_size))
2751 ir = 0
2752 is = 0
2753 i_msg = 0
2754 DO jblk = 1, nblks(2)
2755 DO iblk = 1, nblks(1)
2756 DO igroup = 0, ngroups - 1
2757 IF (block_source(iblk, jblk) == -1) cycle
2758
2759 i_msg = i_msg + 1
2760 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 tag = i_msg - (i_batch - 1)*batch_size
2764
2765 found = .false.
2766 IF (para_env%mepos == block_source(iblk, jblk)) THEN
2767 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 IF (block_source(iblk, jblk) == current_dest(iblk, jblk, igroup)) THEN
2772 IF (found) CALL dbt_put_block(t2c_sub, [iblk, jblk], shape(blk), blk)
2773 ELSE
2774 IF (para_env%mepos == block_source(iblk, jblk) .AND. found) THEN
2775 ALLOCATE (send_buff(tag)%array(bsizes1(iblk), bsizes2(jblk)))
2776 send_buff(tag)%array(:, :) = blk(:, :)
2777 is = is + 1
2778 CALL para_env%isend(msgin=send_buff(tag)%array, dest=current_dest(iblk, jblk, igroup), &
2779 request=send_req(is), tag=tag)
2780 END IF
2781
2782 IF (para_env%mepos == current_dest(iblk, jblk, igroup)) THEN
2783 ALLOCATE (recv_buff(tag)%array(bsizes1(iblk), bsizes2(jblk)))
2784 ir = ir + 1
2785 CALL para_env%irecv(msgout=recv_buff(tag)%array, source=block_source(iblk, jblk), &
2786 request=recv_req(ir), tag=tag)
2787 END IF
2788 END IF
2789
2790 IF (found) DEALLOCATE (blk)
2791 END DO
2792 END DO
2793 END DO
2794
2795 CALL mp_waitall(send_req(1:is))
2796 CALL mp_waitall(recv_req(1:ir))
2797 !clean-up
2798 DO i = 1, batch_size
2799 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 DO jblk = 1, nblks(2)
2805 DO iblk = 1, nblks(1)
2806 DO igroup = 0, ngroups - 1
2807 IF (block_source(iblk, jblk) == -1) cycle
2808
2809 i_msg = i_msg + 1
2810 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 tag = i_msg - (i_batch - 1)*batch_size
2814
2815 IF (para_env%mepos == current_dest(iblk, jblk, igroup) .AND. &
2816 block_source(iblk, jblk) /= current_dest(iblk, jblk, igroup)) THEN
2817
2818 ALLOCATE (blk(bsizes1(iblk), bsizes2(jblk)))
2819 blk(:, :) = recv_buff(tag)%array(:, :)
2820 CALL dbt_put_block(t2c_sub, [iblk, jblk], shape(blk), blk)
2821 DEALLOCATE (blk)
2822 END IF
2823 END DO
2824 END DO
2825 END DO
2826
2827 !clean-up
2828 DO i = 1, batch_size
2829 IF (ASSOCIATED(recv_buff(i)%array)) DEALLOCATE (recv_buff(i)%array)
2830 END DO
2831 DEALLOCATE (send_buff, recv_buff, send_req, recv_req)
2832 END DO !i_batch
2833 CALL dbt_finalize(t2c_sub)
2834
2835 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 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 INTEGER, ALLOCATABLE, DIMENSION(:, :, :) :: block_dest
2855 INTEGER, DIMENSION(3) :: nblks
2856
2857 CALL dbt_get_info(t3c_main, nblks_total=nblks)
2858
2859 !Loop over the sub tensor, get the block destination
2860 igroup = para_env%mepos/group_size
2861 ALLOCATE (block_dest(nblks(1), nblks(2), nblks(3)))
2862 DO kblk = 1, nblks(3)
2863 DO jblk = 1, nblks(2)
2864 DO iblk = 1, nblks(1)
2865 CALL dbt_get_stored_coordinates(t3c_sub, [iblk, jblk, kblk], iproc)
2866 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 ALLOCATE (subgroup_dest(nblks(1), nblks(2), nblks(3), ngroups))
2872 DO igroup = 0, ngroups - 1
2873 !for a given subgroup, need to make the destination available to everyone in the main group
2874 subgroup_dest(:, :, :, igroup + 1) = block_dest(:, :, :)
2875 CALL para_env%bcast(subgroup_dest(:, :, :, igroup + 1), source=igroup*group_size) !bcast from first proc in subgroup
2876 END DO
2877
2878 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 SUBROUTINE copy_3c_to_subgroup(t3c_sub, t3c_main, ngroups, para_env, subgroup_dest, &
2893 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 INTEGER, ALLOCATABLE, DIMENSION(:) :: bsizes1, bsizes2, bsizes3
2907 INTEGER, ALLOCATABLE, DIMENSION(:, :, :) :: block_source
2908 INTEGER, DIMENSION(3) :: ind, nblks
2909 LOGICAL :: filter_at, found
2910 REAL(dp), ALLOCATABLE, DIMENSION(:, :, :) :: blk
2911 TYPE(cp_3d_r_p_type), ALLOCATABLE, DIMENSION(:) :: recv_buff, send_buff
2912 TYPE(dbt_iterator_type) :: iter
2913 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 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 filter_at = .false.
2923 IF (PRESENT(iatom_to_subgroup) .AND. PRESENT(dim_at) .AND. PRESENT(idx_to_at)) THEN
2924 filter_at = .true.
2925 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 ALLOCATE (block_source(nblks(1), nblks(2), nblks(3)))
2930 block_source = -1
2931 nocc = 0
2932!$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 CALL para_env%sum(nocc)
2948 CALL para_env%sum(block_source)
2949 block_source = block_source + para_env%num_pe - 1
2950 IF (nocc == 0) RETURN
2951
2952 ALLOCATE (bsizes1(nblks(1)), bsizes2(nblks(2)), bsizes3(nblks(3)))
2953 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 batch_size = min(para_env%get_tag_ub(), 128000, nocc*ngroups)
2957 n_batch = (nocc*ngroups)/batch_size
2958 IF (modulo(nocc*ngroups, batch_size) /= 0) n_batch = n_batch + 1
2959
2960 DO i_batch = 1, n_batch
2961 !Loop over groups, blocks and send/receive
2962 ALLOCATE (send_buff(batch_size), recv_buff(batch_size))
2963 ALLOCATE (send_req(batch_size), recv_req(batch_size))
2964 ir = 0
2965 is = 0
2966 i_msg = 0
2967 isbuff = 0
2968 DO kblk = 1, nblks(3)
2969 DO jblk = 1, nblks(2)
2970 DO iblk = 1, nblks(1)
2971 IF (block_source(iblk, jblk, kblk) == -1) cycle
2972
2973 found = .false.
2974 IF (para_env%mepos == block_source(iblk, jblk, kblk)) THEN
2975 CALL dbt_get_block(t3c_main, [iblk, jblk, kblk], blk, found)
2976 IF (found) THEN
2977 isbuff = isbuff + 1
2978 ALLOCATE (send_buff(isbuff)%array(bsizes1(iblk), bsizes2(jblk), bsizes3(kblk)))
2979 END IF
2980 END IF
2981
2982 DO igroup = 0, ngroups - 1
2983
2984 i_msg = i_msg + 1
2985 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 tag = i_msg - (i_batch - 1)*batch_size
2989
2990 IF (filter_at) THEN
2991 ind(:) = [iblk, jblk, kblk]
2992 iatom = idx_to_at(ind(dim_at))
2993 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 IF (block_source(iblk, jblk, kblk) == subgroup_dest(iblk, jblk, kblk, igroup + 1)) THEN
2998 IF (found) CALL dbt_put_block(t3c_sub, [iblk, jblk, kblk], shape(blk), blk)
2999 ELSE
3000 IF (para_env%mepos == block_source(iblk, jblk, kblk) .AND. found) THEN
3001 send_buff(isbuff)%array(:, :, :) = blk(:, :, :)
3002 is = is + 1
3003 CALL para_env%isend(msgin=send_buff(isbuff)%array, &
3004 dest=subgroup_dest(iblk, jblk, kblk, igroup + 1), &
3005 request=send_req(is), tag=tag)
3006 END IF
3007
3008 IF (para_env%mepos == subgroup_dest(iblk, jblk, kblk, igroup + 1)) THEN
3009 ALLOCATE (recv_buff(tag)%array(bsizes1(iblk), bsizes2(jblk), bsizes3(kblk)))
3010 ir = ir + 1
3011 CALL para_env%irecv(msgout=recv_buff(tag)%array, source=block_source(iblk, jblk, kblk), &
3012 request=recv_req(ir), tag=tag)
3013 END IF
3014 END IF
3015 END DO !igroup
3016
3017 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 DO kblk = 1, nblks(3)
3026 DO jblk = 1, nblks(2)
3027 DO iblk = 1, nblks(1)
3028 DO igroup = 0, ngroups - 1
3029 IF (block_source(iblk, jblk, kblk) == -1) cycle
3030
3031 i_msg = i_msg + 1
3032 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 tag = i_msg - (i_batch - 1)*batch_size
3036
3037 IF (filter_at) THEN
3038 ind(:) = [iblk, jblk, kblk]
3039 iatom = idx_to_at(ind(dim_at))
3040 IF (.NOT. iatom_to_subgroup(iatom)%array(igroup + 1)) cycle
3041 END IF
3042
3043 IF (para_env%mepos == subgroup_dest(iblk, jblk, kblk, igroup + 1) .AND. &
3044 block_source(iblk, jblk, kblk) /= subgroup_dest(iblk, jblk, kblk, igroup + 1)) THEN
3045
3046 ir = ir + 1
3047 CALL mp_waitall(recv_req(ir:ir))
3048 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 CALL mp_waitall(send_req(1:is))
3057 DO i = 1, batch_size
3058 IF (ASSOCIATED(recv_buff(i)%array)) DEALLOCATE (recv_buff(i)%array)
3059 IF (ASSOCIATED(send_buff(i)%array)) DEALLOCATE (send_buff(i)%array)
3060 END DO
3061 DEALLOCATE (send_buff, recv_buff, send_req, recv_req)
3062 END DO !i_batch
3063 CALL dbt_finalize(t3c_sub)
3064
3065 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 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 REAL(dp), ALLOCATABLE, DIMENSION(:, :) :: blk
3091 TYPE(cp_2d_r_p_type), ALLOCATABLE, DIMENSION(:) :: recv_buff, send_buff
3092 TYPE(mp_request_type), ALLOCATABLE, DIMENSION(:) :: recv_req, send_req
3093
3094 CALL timeset(routinen, handle)
3095
3096 nimg = SIZE(sparsity_pattern, 3)
3097 natom = SIZE(sparsity_pattern, 2)
3098 nspins = SIZE(ks_t, 1)
3099
3100 DO b_img = 1, nimg
3101 n_mess = 0
3102 DO i_spin = 1, nspins
3103 DO jatom = 1, natom
3104 DO iatom = 1, natom
3105 IF (sparsity_pattern(iatom, jatom, b_img) > -1) n_mess = n_mess + 1
3106 END DO
3107 END DO
3108 END DO
3109
3110 ALLOCATE (send_buff(n_mess), recv_buff(n_mess))
3111 ALLOCATE (send_req(n_mess), recv_req(n_mess))
3112 ir = 0
3113 is = 0
3114 n_mess = 0
3115 tag = 0
3116
3117 DO i_spin = 1, nspins
3118 DO jatom = 1, natom
3119 DO iatom = 1, natom
3120 IF (sparsity_pattern(iatom, jatom, b_img) < 0) cycle
3121 n_mess = n_mess + 1
3122 tag = tag + 1
3123
3124 !sending the message
3125 CALL dbt_get_stored_coordinates(ks_t(i_spin, b_img), [iatom, jatom], dest)
3126 CALL dbt_get_stored_coordinates(ks_t_sub(i_spin, b_img), [iatom, jatom], source) !source within sub
3127 igroup = sparsity_pattern(iatom, jatom, b_img)
3128 source = source + igroup*group_size
3129 IF (para_env%mepos == source) THEN
3130 CALL dbt_get_block(ks_t_sub(i_spin, b_img), [iatom, jatom], blk, found)
3131 IF (source == dest) THEN
3132 IF (found) CALL dbt_put_block(ks_t(i_spin, b_img), [iatom, jatom], shape(blk), blk)
3133 ELSE
3134 ALLOCATE (send_buff(n_mess)%array(ri_data%bsizes_AO(iatom), ri_data%bsizes_AO(jatom)))
3135 send_buff(n_mess)%array(:, :) = 0.0_dp
3136 IF (found) THEN
3137 send_buff(n_mess)%array(:, :) = blk(:, :)
3138 END IF
3139 is = is + 1
3140 CALL para_env%isend(msgin=send_buff(n_mess)%array, dest=dest, &
3141 request=send_req(is), tag=tag)
3142 END IF
3143 DEALLOCATE (blk)
3144 END IF
3145
3146 !receiving the message
3147 IF (para_env%mepos == dest .AND. source /= dest) THEN
3148 ALLOCATE (recv_buff(n_mess)%array(ri_data%bsizes_AO(iatom), ri_data%bsizes_AO(jatom)))
3149 ir = ir + 1
3150 CALL para_env%irecv(msgout=recv_buff(n_mess)%array, source=source, &
3151 request=recv_req(ir), tag=tag)
3152 END IF
3153 END DO !iatom
3154 END DO !jatom
3155 END DO !ispin
3156
3157 CALL mp_waitall(send_req(1:is))
3158 CALL mp_waitall(recv_req(1:ir))
3159
3160 !Copy the messages received into the KS matrix
3161 n_mess = 0
3162 DO i_spin = 1, nspins
3163 DO jatom = 1, natom
3164 DO iatom = 1, natom
3165 IF (sparsity_pattern(iatom, jatom, b_img) < 0) cycle
3166 n_mess = n_mess + 1
3167
3168 CALL dbt_get_stored_coordinates(ks_t(i_spin, b_img), [iatom, jatom], dest)
3169 IF (para_env%mepos == dest) THEN
3170 IF (.NOT. ASSOCIATED(recv_buff(n_mess)%array)) cycle
3171 ALLOCATE (blk(ri_data%bsizes_AO(iatom), ri_data%bsizes_AO(jatom)))
3172 blk(:, :) = recv_buff(n_mess)%array(:, :)
3173 CALL dbt_put_block(ks_t(i_spin, b_img), [iatom, jatom], shape(blk), blk)
3174 DEALLOCATE (blk)
3175 END IF
3176 END DO
3177 END DO
3178 END DO
3179
3180 !clean-up
3181 DO i = 1, n_mess
3182 IF (ASSOCIATED(send_buff(i)%array)) DEALLOCATE (send_buff(i)%array)
3183 IF (ASSOCIATED(recv_buff(i)%array)) DEALLOCATE (recv_buff(i)%array)
3184 END DO
3185 DEALLOCATE (send_buff, recv_buff, send_req, recv_req)
3186 END DO !b_img
3187
3188 CALL timestop(handle)
3189
3190 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 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 dist1, dist2
3221 INTEGER, DIMENSION(2) :: pdims_2d
3222 INTEGER, DIMENSION(:), POINTER :: col_dist, ri_blk_size, row_dist
3223 INTEGER, DIMENSION(:, :), POINTER :: dbcsr_pgrid
3224 REAL(dp) :: occ
3225 TYPE(dbcsr_distribution_type) :: dbcsr_dist_sub
3226 TYPE(dbt_pgrid_type) :: pgrid_2d
3227 TYPE(dbt_type) :: work, work_sub
3228
3229 CALL timeset(routinen, handle)
3230
3231 !Create the 2d pgrid
3232 pdims_2d = 0
3233 CALL dbt_pgrid_create(para_env_sub, pdims_2d, pgrid_2d)
3234
3235 natom = SIZE(ri_data%bsizes_RI)
3236 nblks = SIZE(ri_data%bsizes_RI_split)
3237 ALLOCATE (bsizes_ri_ext(ri_data%ncell_RI*natom))
3238 ALLOCATE (bsizes_ri_ext_split(ri_data%ncell_RI*nblks))
3239 DO i_ri = 1, ri_data%ncell_RI
3240 bsizes_ri_ext((i_ri - 1)*natom + 1:i_ri*natom) = ri_data%bsizes_RI(:)
3241 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 name="(RI | RI)")
3248 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 name="(RI | RI)")
3253 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 name="(AO | AO)")
3259 DEALLOCATE (dist1, dist2)
3260 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 name="(AO | AO)")
3265 DEALLOCATE (dist1, dist2)
3266
3267 nspins = SIZE(ks_t_sub, 1)
3268 nimg = SIZE(ks_t_sub, 2)
3269 DO i_img = 1, nimg
3270 DO i_spin = 1, nspins
3271 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 name="(RI | RI)")
3280 CALL dbt_create(ri_data%kp_mat_2c_pot(1, 1), work)
3281
3282 ALLOCATE (dbcsr_pgrid(0:pdims_2d(1) - 1, 0:pdims_2d(2) - 1))
3283 iproc = 0
3284 DO i = 0, pdims_2d(1) - 1
3285 DO j = 0, pdims_2d(2) - 1
3286 dbcsr_pgrid(i, j) = iproc
3287 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 ALLOCATE (col_dist(natom), row_dist(natom))
3293 row_dist(:) = dist1(:)
3294 col_dist(:) = dist2(:)
3295
3296 ALLOCATE (ri_blk_size(natom))
3297 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 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 row_blk_size=ri_blk_size, col_blk_size=ri_blk_size)
3303
3304 DO i_img = 1, nimg
3305 IF (i_img > 1) CALL dbcsr_create(mat_2c_pot(i_img), template=mat_2c_pot(1))
3306 CALL dbt_copy_matrix_to_tensor(ri_data%kp_mat_2c_pot(1, i_img), work)
3307 CALL get_tensor_occupancy(work, nze, occ)
3308 IF (nze == 0) cycle
3309
3310 CALL copy_2c_to_subgroup(work_sub, work, group_size, ngroups, para_env)
3311 CALL dbt_copy_tensor_to_matrix(work_sub, mat_2c_pot(i_img))
3312 CALL dbcsr_filter(mat_2c_pot(i_img), ri_data%filter_eps)
3313 CALL dbt_clear(work_sub)
3314 END DO
3315
3316 CALL dbt_destroy(work)
3317 CALL dbt_destroy(work_sub)
3318 CALL dbt_pgrid_destroy(pgrid_2d)
3319 CALL dbcsr_distribution_release(dbcsr_dist_sub)
3320 DEALLOCATE (col_dist, row_dist, ri_blk_size, dbcsr_pgrid)
3321 CALL timestop(handle)
3322
3323 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 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 INTEGER, ALLOCATABLE, DIMENSION(:) :: bsizes_ri_ext, bsizes_ri_ext_split, &
3353 bsizes_stack, bsizes_tmp, dist1, &
3354 dist2, dist3, dist_stack, idx_to_at
3355 INTEGER, ALLOCATABLE, DIMENSION(:, :, :, :) :: subgroup_dest
3356 INTEGER, DIMENSION(3) :: pdims
3357 REAL(dp) :: occ
3358 TYPE(dbt_distribution_type) :: t_dist
3359 TYPE(dbt_pgrid_type) :: pgrid
3360 TYPE(dbt_type) :: tmp, work_atom_block, work_atom_block_sub
3361
3362 CALL timeset(routinen, handle)
3363
3364 nblks_ri = SIZE(ri_data%bsizes_RI_split)
3365 ALLOCATE (bsizes_ri_ext_split(ri_data%ncell_RI*nblks_ri))
3366 DO i_ri = 1, ri_data%ncell_RI
3367 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 natom = SIZE(ri_data%bsizes_RI)
3372 nblks_ri = natom
3373 ALLOCATE (bsizes_tmp(nblks_ri))
3374 DO i_blk = 1, nblks_ri
3375 bo = get_limit(natom, nblks_ri, i_blk - 1)
3376 bsizes_tmp(i_blk) = sum(ri_data%bsizes_RI(bo(1):bo(2)))
3377 END DO
3378 ALLOCATE (bsizes_ri_ext(ri_data%ncell_RI*nblks_ri))
3379 DO i_ri = 1, ri_data%ncell_RI
3380 bsizes_ri_ext((i_ri - 1)*nblks_ri + 1:i_ri*nblks_ri) = bsizes_tmp(:)
3381 END DO
3382
3383 batch_size = ri_data%kp_stack_size
3384 nblks_ao = SIZE(ri_data%bsizes_AO_split)
3385 ALLOCATE (bsizes_stack(batch_size*nblks_ao))
3386 DO ib = 1, batch_size
3387 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 natom = SIZE(ri_data%bsizes_RI)
3392 pdims = 0
3393 CALL dbt_pgrid_create(para_env_sub, pdims, pgrid, &
3394 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 ri_data%bsizes_AO_split, [1], [2, 3], name="(RI | AO AO)")
3400 nimg = SIZE(t_3c_int)
3401 DO i_img = 2, nimg
3402 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 ALLOCATE (dist_stack(batch_size*nblks_ao))
3407 DO ib = 1, batch_size
3408 dist_stack((ib - 1)*nblks_ao + 1:ib*nblks_ao) = dist3(:)
3409 END DO
3410
3411 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 bsizes_ri_ext_split, ri_data%bsizes_AO_split, bsizes_stack)
3414 CALL dbt_create(t_3c_work_3(1), t_3c_work_3(2))
3415 CALL dbt_create(t_3c_work_3(1), t_3c_work_3(3))
3416 CALL dbt_distribution_destroy(t_dist)
3417 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 ri_data%bsizes_AO, [1], [2, 3], name="(RI | AO AO)")
3423 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 ri_data%bsizes_AO, [1], [2, 3], name="(RI | AO AO)")
3428 DEALLOCATE (dist1, dist2, dist3)
3429
3430 CALL get_3c_subgroup_dest(subgroup_dest, work_atom_block_sub, work_atom_block, &
3431 group_size, ngroups, para_env)
3432
3433 !Finally copy the integrals into the subgroups (if not there already)
3434 CALL timeset(routinen//"_ints", handle2)
3435 IF (ALLOCATED(ri_data%kp_t_3c_int)) THEN
3436 DO i_img = 1, nimg
3437 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 ALLOCATE (ri_data%kp_t_3c_int(nimg))
3441 DO i_img = 1, nimg
3442 CALL dbt_create(t_3c_int(i_img), ri_data%kp_t_3c_int(i_img))
3443 CALL get_tensor_occupancy(ri_data%t_3c_int_ctr_1(1, i_img), nze, occ)
3444 IF (nze == 0) cycle
3445 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 ngroups, para_env, subgroup_dest)
3448 CALL dbt_copy(work_atom_block_sub, t_3c_int(i_img), move_data=.true.)
3449 CALL dbt_filter(t_3c_int(i_img), ri_data%filter_eps)
3450 END DO
3451 END IF
3452 CALL timestop(handle2)
3453 CALL dbt_pgrid_destroy(pgrid)
3454 CALL dbt_destroy(work_atom_block)
3455 CALL dbt_destroy(work_atom_block_sub)
3456 DEALLOCATE (subgroup_dest)
3457
3458 !Do the same for the t_3c_ctr_2 configuration
3459 pdims = 0
3460 CALL dbt_pgrid_create(para_env_sub, pdims, pgrid, &
3461 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 ri_data%bsizes_AO, [1], [2, 3], name="(AO RI | AO)")
3467 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 ri_data%bsizes_AO, [1], [2, 3], name="(AO RI | AO)")
3472 DEALLOCATE (dist1, dist2, dist3)
3473
3474 CALL get_3c_subgroup_dest(subgroup_dest, work_atom_block_sub, work_atom_block, &
3475 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 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 ALLOCATE (dist_stack(batch_size*nblks_ao))
3484 DO ib = 1, batch_size
3485 dist_stack((ib - 1)*nblks_ao + 1:ib*nblks_ao) = dist3(:)
3486 END DO
3487
3488 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 ri_data%bsizes_AO_split, bsizes_ri_ext_split, bsizes_stack)
3491 CALL dbt_create(t_3c_work_2(1), t_3c_work_2(2))
3492 CALL dbt_create(t_3c_work_2(1), t_3c_work_2(3))
3493 CALL dbt_distribution_destroy(t_dist)
3494 DEALLOCATE (dist1, dist2, dist3, dist_stack)
3495
3496 !Finally copy data from t_3c_apc to the subgroups
3497 ALLOCATE (idx_to_at(SIZE(ri_data%bsizes_AO)))
3498 CALL get_idx_to_atom(idx_to_at, ri_data%bsizes_AO, ri_data%bsizes_AO)
3499 nspins = SIZE(t_3c_apc, 1)
3500 CALL timeset(routinen//"_apc", handle2)
3501 DO i_img = 1, nimg
3502 DO i_spin = 1, nspins
3503 CALL dbt_create(tmp, t_3c_apc_sub(i_spin, i_img))
3504 CALL get_tensor_occupancy(t_3c_apc(i_spin, i_img), nze, occ)
3505 IF (nze == 0) cycle
3506 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 subgroup_dest, ri_data%iatom_to_subgroup, 1, idx_to_at)
3509 CALL dbt_copy(work_atom_block_sub, t_3c_apc_sub(i_spin, i_img), move_data=.true.)
3510 CALL dbt_filter(t_3c_apc_sub(i_spin, i_img), ri_data%filter_eps)
3511 END DO
3512 DO i_spin = 1, nspins
3513 CALL dbt_destroy(t_3c_apc(i_spin, i_img))
3514 END DO
3515 END DO
3516 CALL timestop(handle2)
3517 CALL dbt_pgrid_destroy(pgrid)
3518 CALL dbt_destroy(tmp)
3519 CALL dbt_destroy(work_atom_block)
3520 CALL dbt_destroy(work_atom_block_sub)
3521
3522 CALL timestop(handle)
3523
3524 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 SUBROUTINE get_subgroup_2c_derivs(t_2c_inv, t_2c_bint, t_2c_metric, mat_2c_pot, t_2c_work, rho_ao_t, &
3547 rho_ao_t_sub, t_2c_der_metric, t_2c_der_metric_sub, mat_der_pot, &
3548 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 dist1, dist2
3567 INTEGER, DIMENSION(2) :: pdims_2d
3568 INTEGER, DIMENSION(:), POINTER :: col_dist, ri_blk_size, row_dist
3569 INTEGER, DIMENSION(:, :), POINTER :: dbcsr_pgrid
3570 REAL(dp) :: occ
3571 TYPE(dbcsr_distribution_type) :: dbcsr_dist_sub
3572 TYPE(dbt_pgrid_type) :: pgrid_2d
3573 TYPE(dbt_type) :: work, work_sub
3574
3575 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 pdims_2d = 0
3580 CALL dbt_pgrid_create(para_env_sub, pdims_2d, pgrid_2d)
3581
3582 natom = SIZE(ri_data%bsizes_RI)
3583 nblks = SIZE(ri_data%bsizes_RI_split)
3584 ALLOCATE (bsizes_ri_ext(ri_data%ncell_RI*natom))
3585 ALLOCATE (bsizes_ri_ext_split(ri_data%ncell_RI*nblks))
3586 DO i_ri = 1, ri_data%ncell_RI
3587 bsizes_ri_ext((i_ri - 1)*natom + 1:i_ri*natom) = ri_data%bsizes_RI(:)
3588 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 name="(RI | RI)")
3595 DEALLOCATE (dist1, dist2)
3596
3597 CALL dbt_create(t_2c_inv(1), t_2c_bint(1))
3598 CALL dbt_create(t_2c_inv(1), t_2c_metric(1))
3599 DO iatom = 2, natom
3600 CALL dbt_create(t_2c_inv(1), t_2c_inv(iatom))
3601 CALL dbt_create(t_2c_inv(1), t_2c_bint(iatom))
3602 CALL dbt_create(t_2c_inv(1), t_2c_metric(iatom))
3603 END DO
3604 CALL dbt_create(t_2c_inv(1), t_2c_work(1))
3605 CALL dbt_create(t_2c_inv(1), t_2c_work(2))
3606 CALL dbt_create(t_2c_inv(1), t_2c_work(3))
3607 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 name="(RI | RI)")
3612 DEALLOCATE (dist1, dist2)
3613
3614 !copy the data from the main group.
3615 DO iatom = 1, natom
3616 CALL copy_2c_to_subgroup(t_2c_inv(iatom), ri_data%t_2c_inv(1, iatom), group_size, ngroups, para_env)
3617 CALL copy_2c_to_subgroup(t_2c_bint(iatom), ri_data%t_2c_int(1, iatom), group_size, ngroups, para_env)
3618 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 DO i_xyz = 1, 3
3623 DO iatom = 1, natom
3624 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 group_size, ngroups, para_env)
3627 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 name="(AO | AO)")
3635 DEALLOCATE (dist1, dist2)
3636 nspins = SIZE(rho_ao_t, 1)
3637 nimg = SIZE(rho_ao_t, 2)
3638
3639 DO i_img = 1, nimg
3640 DO i_spin = 1, nspins
3641 IF (.NOT. (i_img == 1 .AND. i_spin == 1)) THEN
3642 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 group_size, ngroups, para_env)
3646 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 name="(RI | RI)")
3654 CALL dbt_create(ri_data%kp_mat_2c_pot(1, 1), work)
3655
3656 ALLOCATE (dbcsr_pgrid(0:pdims_2d(1) - 1, 0:pdims_2d(2) - 1))
3657 iproc = 0
3658 DO i = 0, pdims_2d(1) - 1
3659 DO j = 0, pdims_2d(2) - 1
3660 dbcsr_pgrid(i, j) = iproc
3661 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 ALLOCATE (col_dist(natom), row_dist(natom))
3667 row_dist(:) = dist1(:)
3668 col_dist(:) = dist2(:)
3669
3670 ALLOCATE (ri_blk_size(natom))
3671 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 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 row_blk_size=ri_blk_size, col_blk_size=ri_blk_size)
3677
3678 !The HFX potential
3679 DO i_img = 1, nimg
3680 IF (i_img > 1) CALL dbcsr_create(mat_2c_pot(i_img), template=mat_2c_pot(1))
3681 CALL dbt_copy_matrix_to_tensor(ri_data%kp_mat_2c_pot(1, i_img), work)
3682 CALL get_tensor_occupancy(work, nze, occ)
3683 IF (nze == 0) cycle
3684
3685 CALL copy_2c_to_subgroup(work_sub, work, group_size, ngroups, para_env)
3686 CALL dbt_copy_tensor_to_matrix(work_sub, mat_2c_pot(i_img))
3687 CALL dbcsr_filter(mat_2c_pot(i_img), ri_data%filter_eps)
3688 CALL dbt_clear(work_sub)
3689 END DO
3690
3691 !The derivatives of the HFX potential
3692 DO i_xyz = 1, 3
3693 DO i_img = 1, nimg
3694 CALL dbcsr_create(mat_der_pot_sub(i_img, i_xyz), template=mat_2c_pot(1))
3695 CALL dbt_copy_matrix_to_tensor(mat_der_pot(i_img, i_xyz), work)
3696 CALL dbcsr_release(mat_der_pot(i_img, i_xyz))
3697 CALL get_tensor_occupancy(work, nze, occ)
3698 IF (nze == 0) cycle
3699
3700 CALL copy_2c_to_subgroup(work_sub, work, group_size, ngroups, para_env)
3701 CALL dbt_copy_tensor_to_matrix(work_sub, mat_der_pot_sub(i_img, i_xyz))
3702 CALL dbcsr_filter(mat_der_pot_sub(i_img, i_xyz), ri_data%filter_eps)
3703 CALL dbt_clear(work_sub)
3704 END DO
3705 END DO
3706
3707 CALL dbt_destroy(work)
3708 CALL dbt_destroy(work_sub)
3709 CALL dbt_pgrid_destroy(pgrid_2d)
3710 CALL dbcsr_distribution_release(dbcsr_dist_sub)
3711 DEALLOCATE (col_dist, row_dist, ri_blk_size, dbcsr_pgrid)
3712
3713 CALL timestop(handle)
3714
3715 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 SUBROUTINE get_subgroup_3c_derivs(t_3c_work_2, t_3c_work_3, t_3c_der_AO, t_3c_der_AO_sub, &
3736 t_3c_der_RI, t_3c_der_RI_sub, t_3c_apc, t_3c_apc_sub, &
3737 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 INTEGER, ALLOCATABLE, DIMENSION(:) :: bsizes_ri_ext, bsizes_ri_ext_split, &
3755 bsizes_stack, dist1, dist2, dist3, &
3756 dist_stack, idx_to_at
3757 INTEGER, ALLOCATABLE, DIMENSION(:, :, :, :) :: subgroup_dest
3758 REAL(dp) :: occ
3759 TYPE(dbt_distribution_type) :: t_dist
3760 TYPE(dbt_pgrid_type) :: pgrid
3761 TYPE(dbt_type) :: tmp, work_atom_block, work_atom_block_sub
3762
3763 CALL timeset(routinen, handle)
3764
3765 !We use intermediate tensors with larger block size for more optimized communication
3766 nblks_ri = SIZE(ri_data%bsizes_RI)
3767 ALLOCATE (bsizes_ri_ext(ri_data%ncell_RI*nblks_ri))
3768 DO i_ri = 1, ri_data%ncell_RI
3769 bsizes_ri_ext((i_ri - 1)*nblks_ri + 1:i_ri*nblks_ri) = ri_data%bsizes_RI(:)
3770 END DO
3771
3772 CALL dbt_get_info(ri_data%kp_t_3c_int(1), pdims=pdims)
3773 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 ri_data%bsizes_AO, [1], [2, 3], name="(RI | AO AO)")
3778 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 ri_data%bsizes_AO, [1], [2, 3], name="(RI | AO AO)")
3783 DEALLOCATE (dist1, dist2, dist3)
3784 CALL dbt_pgrid_destroy(pgrid)
3785
3786 CALL get_3c_subgroup_dest(subgroup_dest, work_atom_block_sub, work_atom_block, &
3787 group_size, ngroups, para_env)
3788
3789 !We use the 3c integrals on the subgroup as template for the derivatives
3790 nimg = ri_data%nimg
3791 DO i_xyz = 1, 3
3792 DO i_img = 1, nimg
3793 CALL dbt_create(ri_data%kp_t_3c_int(1), t_3c_der_ao_sub(i_img, i_xyz))
3794 CALL get_tensor_occupancy(t_3c_der_ao(i_img, i_xyz), nze, occ)
3795 IF (nze == 0) cycle
3796
3797 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 ngroups, para_env, subgroup_dest)
3800 CALL dbt_copy(work_atom_block_sub, t_3c_der_ao_sub(i_img, i_xyz), move_data=.true.)
3801 CALL dbt_filter(t_3c_der_ao_sub(i_img, i_xyz), ri_data%filter_eps)
3802 END DO
3803
3804 DO i_img = 1, nimg
3805 CALL dbt_create(ri_data%kp_t_3c_int(1), t_3c_der_ri_sub(i_img, i_xyz))
3806 CALL get_tensor_occupancy(t_3c_der_ri(i_img, i_xyz), nze, occ)
3807 IF (nze == 0) cycle
3808
3809 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 ngroups, para_env, subgroup_dest)
3812 CALL dbt_copy(work_atom_block_sub, t_3c_der_ri_sub(i_img, i_xyz), move_data=.true.)
3813 CALL dbt_filter(t_3c_der_ri_sub(i_img, i_xyz), ri_data%filter_eps)
3814 END DO
3815
3816 DO i_img = 1, nimg
3817 CALL dbt_destroy(t_3c_der_ri(i_img, i_xyz))
3818 CALL dbt_destroy(t_3c_der_ao(i_img, i_xyz))
3819 END DO
3820 END DO
3821 CALL dbt_destroy(work_atom_block_sub)
3822 CALL dbt_destroy(work_atom_block)
3823 DEALLOCATE (subgroup_dest)
3824
3825 !Deal with t_3c_apc
3826 nblks_ri = SIZE(ri_data%bsizes_RI_split)
3827 ALLOCATE (bsizes_ri_ext_split(ri_data%ncell_RI*nblks_ri))
3828 DO i_ri = 1, ri_data%ncell_RI
3829 bsizes_ri_ext_split((i_ri - 1)*nblks_ri + 1:i_ri*nblks_ri) = ri_data%bsizes_RI_split(:)
3830 END DO
3831
3832 pdims = 0
3833 CALL dbt_pgrid_create(para_env_sub, pdims, pgrid, &
3834 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 ri_data%bsizes_AO, [1], [2, 3], name="(AO RI | AO)")
3839 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 ri_data%bsizes_AO, [1], [2, 3], name="(AO RI | AO)")
3844 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 ri_data%bsizes_AO_split, [1], [2, 3], name="(AO RI | AO)")
3849 DEALLOCATE (dist1, dist2, dist3)
3850
3851 CALL get_3c_subgroup_dest(subgroup_dest, work_atom_block_sub, work_atom_block, &
3852 group_size, ngroups, para_env)
3853
3854 ALLOCATE (idx_to_at(SIZE(ri_data%bsizes_AO)))
3855 CALL get_idx_to_atom(idx_to_at, ri_data%bsizes_AO, ri_data%bsizes_AO)
3856 nspins = SIZE(t_3c_apc, 1)
3857 DO i_img = 1, nimg
3858 DO i_spin = 1, nspins
3859 CALL dbt_create(tmp, t_3c_apc_sub(i_spin, i_img))
3860 CALL get_tensor_occupancy(t_3c_apc(i_spin, i_img), nze, occ)
3861 IF (nze == 0) cycle
3862 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 subgroup_dest, ri_data%iatom_to_subgroup, 1, idx_to_at)
3865 CALL dbt_copy(work_atom_block_sub, t_3c_apc_sub(i_spin, i_img), move_data=.true.)
3866 CALL dbt_filter(t_3c_apc_sub(i_spin, i_img), ri_data%filter_eps)
3867 END DO
3868 DO i_spin = 1, nspins
3869 CALL dbt_destroy(t_3c_apc(i_spin, i_img))
3870 END DO
3871 END DO
3872 CALL dbt_destroy(tmp)
3873 CALL dbt_destroy(work_atom_block)
3874 CALL dbt_destroy(work_atom_block_sub)
3875 CALL dbt_pgrid_destroy(pgrid)
3876
3877 !t_3c_work_3 based on structure of 3c integrals/derivs
3878 batch_size = ri_data%kp_stack_size
3879 nblks_ao = SIZE(ri_data%bsizes_AO_split)
3880 ALLOCATE (bsizes_stack(batch_size*nblks_ao))
3881 DO ib = 1, batch_size
3882 bsizes_stack((ib - 1)*nblks_ao + 1:ib*nblks_ao) = ri_data%bsizes_AO_split(:)
3883 END DO
3884
3885 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 proc_dist_3=dist3, pdims=pdims)
3888
3889 ALLOCATE (dist_stack(batch_size*nblks_ao))
3890 DO ib = 1, batch_size
3891 dist_stack((ib - 1)*nblks_ao + 1:ib*nblks_ao) = dist3(:)
3892 END DO
3893
3894 CALL dbt_pgrid_create(para_env_sub, pdims, pgrid)
3895 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 bsizes_ri_ext_split, ri_data%bsizes_AO_split, bsizes_stack)
3898 CALL dbt_create(t_3c_work_3(1), t_3c_work_3(2))
3899 CALL dbt_create(t_3c_work_3(1), t_3c_work_3(3))
3900 CALL dbt_create(t_3c_work_3(1), t_3c_work_3(4))
3901 CALL dbt_distribution_destroy(t_dist)
3902 CALL dbt_pgrid_destroy(pgrid)
3903 DEALLOCATE (dist1, dist2, dist3, dist_stack)
3904
3905 !the derivatives are stacked in the same way
3906 CALL dbt_create(t_3c_work_3(1), t_3c_der_stack(1))
3907 CALL dbt_create(t_3c_work_3(1), t_3c_der_stack(2))
3908 CALL dbt_create(t_3c_work_3(1), t_3c_der_stack(3))
3909 CALL dbt_create(t_3c_work_3(1), t_3c_der_stack(4))
3910 CALL dbt_create(t_3c_work_3(1), t_3c_der_stack(5))
3911 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 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 proc_dist_3=dist3, pdims=pdims)
3917
3918 ALLOCATE (dist_stack(batch_size*nblks_ao))
3919 DO ib = 1, batch_size
3920 dist_stack((ib - 1)*nblks_ao + 1:ib*nblks_ao) = dist3(:)
3921 END DO
3922
3923 CALL dbt_pgrid_create(para_env_sub, pdims, pgrid)
3924 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 ri_data%bsizes_AO_split, bsizes_ri_ext_split, bsizes_stack)
3927 CALL dbt_create(t_3c_work_2(1), t_3c_work_2(2))
3928 CALL dbt_create(t_3c_work_2(1), t_3c_work_2(3))
3929 CALL dbt_distribution_destroy(t_dist)
3930 CALL dbt_pgrid_destroy(pgrid)
3931 DEALLOCATE (dist1, dist2, dist3, dist_stack)
3932
3933 CALL timestop(handle)
3934
3935 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 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 TYPE(dbt_type), ALLOCATABLE, DIMENSION(:) :: t_3c_tmp
3954
3955 CALL timeset(routinen, handle)
3956
3957 nimg = ri_data%nimg
3958 ALLOCATE (t_3c_tmp(nimg))
3959 DO i_img = 1, nimg
3960 CALL dbt_create(t_3c_ints(i_img), t_3c_tmp(i_img))
3961 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 ALLOCATE (ri_data%idx_to_img(nimg))
3967 idx_full = 0
3968 idx_empty = nimg + 1
3969
3970 DO i_img = 1, nimg
3971 CALL get_tensor_occupancy(t_3c_tmp(i_img), nze, occ)
3972 IF (nze == 0) THEN
3973 idx_empty = idx_empty - 1
3974 CALL dbt_copy(t_3c_tmp(i_img), t_3c_ints(idx_empty), move_data=.true.)
3975 ri_data%idx_to_img(idx_empty) = i_img
3976 ELSE
3977 idx_full = idx_full + 1
3978 CALL dbt_copy(t_3c_tmp(i_img), t_3c_ints(idx_full), move_data=.true.)
3979 ri_data%idx_to_img(idx_full) = i_img
3980 END IF
3981 CALL dbt_destroy(t_3c_tmp(i_img))
3982 END DO
3983
3984 !store the highest image index with non-zero integrals
3985 ri_data%nimg_nze = idx_full
3986
3987 ALLOCATE (ri_data%img_to_idx(nimg))
3988 DO idx = 1, nimg
3989 ri_data%img_to_idx(ri_data%idx_to_img(idx)) = idx
3990 END DO
3991
3992 CALL timestop(handle)
3993
3994 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 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 TYPE(dbt_type), ALLOCATABLE, DIMENSION(:) :: t_3c_tmp
4012
4013 CALL timeset(routinen, handle)
4014
4015 nimg = ri_data%nimg
4016 ALLOCATE (t_3c_tmp(nimg))
4017 DO i_img = 1, nimg
4018 CALL dbt_create(t_3c_derivs(1, 1), t_3c_tmp(i_img))
4019 END DO
4020
4021 DO i_xyz = 1, 3
4022 DO i_img = 1, nimg
4023 CALL dbt_copy(t_3c_derivs(i_img, i_xyz), t_3c_tmp(i_img), move_data=.true.)
4024 END DO
4025 DO i_img = 1, nimg
4026 idx = ri_data%img_to_idx(i_img)
4027 CALL dbt_copy(t_3c_tmp(i_img), t_3c_derivs(idx, i_xyz), move_data=.true.)
4028 CALL get_tensor_occupancy(t_3c_derivs(idx, i_xyz), nze, occ)
4029 IF (nze > 0) ri_data%nimg_nze = max(idx, ri_data%nimg_nze)
4030 END DO
4031 END DO
4032
4033 DO i_img = 1, nimg
4034 CALL dbt_destroy(t_3c_tmp(i_img))
4035 END DO
4036
4037 CALL timestop(handle)
4038
4039 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 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 INTEGER, ALLOCATABLE, DIMENSION(:) :: bins
4054 INTEGER, ALLOCATABLE, DIMENSION(:, :, :) :: tmp_pattern
4055 INTEGER, DIMENSION(3) :: cell_j
4056 INTEGER, DIMENSION(:, :), POINTER :: index_to_cell
4057 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 DIMENSION(:), POINTER :: nl_iterator
4063 TYPE(neighbor_list_set_p_type), DIMENSION(:), &
4064 POINTER :: nl_2c
4065
4066 NULLIFY (nl_2c, nl_iterator, kpoints, cell_to_index, dft_control, index_to_cell, para_env)
4067
4068 CALL get_qs_env(qs_env, kpoints=kpoints, dft_control=dft_control, para_env=para_env, natom=natom)
4069 CALL get_kpoint_info(kpoints, cell_to_index=cell_to_index, index_to_cell=index_to_cell, sab_nl=nl_2c)
4070
4071 nimg = ri_data%nimg
4072 pattern(:, :, :) = 0
4073
4074 !We use the symmetric nl for all images that have an opposite cell
4075 CALL neighbor_list_iterator_create(nl_iterator, nl_2c)
4076 DO WHILE (neighbor_list_iterate(nl_iterator) == 0)
4077 CALL get_iterator_info(nl_iterator, iatom=iatom, jatom=jatom, cell=cell_j)
4078
4079 j_img = cell_to_index(cell_j(1), cell_j(2), cell_j(3))
4080 IF (j_img > nimg .OR. j_img < 1) cycle
4081
4082 mj_img = get_opp_index(j_img, qs_env)
4083 IF (mj_img > nimg .OR. mj_img < 1) cycle
4084
4085 IF (ri_data%present_images(j_img) == 0) cycle
4086
4087 pattern(iatom, jatom, j_img) = 1
4088 END DO
4089 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 CALL get_kpoint_info(kpoints, sab_nl_nosym=nl_2c)
4093
4094 CALL neighbor_list_iterator_create(nl_iterator, nl_2c)
4095 DO WHILE (neighbor_list_iterate(nl_iterator) == 0)
4096 CALL get_iterator_info(nl_iterator, iatom=iatom, jatom=jatom, cell=cell_j)
4097
4098 j_img = cell_to_index(cell_j(1), cell_j(2), cell_j(3))
4099 IF (j_img > nimg .OR. j_img < 1) cycle
4100
4101 mj_img = get_opp_index(j_img, qs_env)
4102 IF (mj_img <= nimg .AND. mj_img > 0) cycle
4103
4104 IF (ri_data%present_images(j_img) == 0) cycle
4105
4106 pattern(iatom, jatom, j_img) = 1
4107 END DO
4108 CALL neighbor_list_iterator_release(nl_iterator)
4109
4110 CALL para_env%sum(pattern)
4111
4112 !If the opposite image is considered, then there is no need to compute diagonal twice
4113 DO j_img = 2, nimg
4114 DO iatom = 1, natom
4115 IF (pattern(iatom, iatom, j_img) /= 0) THEN
4116 mj_img = get_opp_index(j_img, qs_env)
4117 IF (mj_img > nimg .OR. mj_img < 1) cycle
4118 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 ALLOCATE (bins(natom))
4126 bins(:) = 0
4127
4128 ALLOCATE (tmp_pattern(natom, natom, nimg))
4129 tmp_pattern(:, :, :) = 0
4130 DO j_img = 1, nimg
4131 DO jatom = 1, natom
4132 DO iatom = 1, natom
4133 IF (pattern(iatom, jatom, j_img) == 0) cycle
4134 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 IF (mj_img > nimg .OR. mj_img < 1) THEN
4138 !No opposite image, no choice
4139 bins(iatom) = bins(iatom) + 1
4140 tmp_pattern(iatom, jatom, j_img) = 1
4141 ELSE
4142
4143 IF (bins(iatom) > bins(jatom)) THEN
4144 bins(jatom) = bins(jatom) + 1
4145 tmp_pattern(jatom, iatom, mj_img) = 1
4146 ELSE
4147 bins(iatom) = bins(iatom) + 1
4148 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 pattern(:, :, :) = tmp_pattern(:, :, :) - 1
4157
4158 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 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 INTEGER, ALLOCATABLE, DIMENSION(:) :: max_at_per_group
4176 REAL(dp) :: cost
4177 REAL(dp), ALLOCATABLE, DIMENSION(:) :: bins
4178
4179 natom = SIZE(sparsity_pattern, 2)
4180 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 IF (.NOT. ALLOCATED(ri_data%iatom_to_subgroup)) THEN
4186 ALLOCATE (ri_data%iatom_to_subgroup(natom), max_at_per_group(ngroups))
4187 DO iatom = 1, natom
4188 NULLIFY (ri_data%iatom_to_subgroup(iatom)%array)
4189 ALLOCATE (ri_data%iatom_to_subgroup(iatom)%array(ngroups))
4190 ri_data%iatom_to_subgroup(iatom)%array(:) = .false.
4191 END DO
4192
4193 ub = natom/ngroups
4194 IF (ub*ngroups < natom) ub = ub + 1
4195 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 DO WHILE (modulo(sum(max_at_per_group), natom) /= 0)
4201 igroup = modulo(ctr, ngroups) + 1
4202 max_at_per_group(igroup) = max_at_per_group(igroup) + 1
4203 ctr = ctr + 1
4204 END DO
4205
4206 ctr = 0
4207 DO igroup = 1, ngroups
4208 DO iat = 1, max_at_per_group(igroup)
4209 iatom = modulo(ctr, natom) + 1
4210 ri_data%iatom_to_subgroup(iatom)%array(igroup) = .true.
4211 ctr = ctr + 1
4212 END DO
4213 END DO
4214 END IF
4215
4216 ALLOCATE (bins(ngroups))
4217 bins = 0.0_dp
4218 DO b_img = 1, nimg
4219 DO jatom = 1, natom
4220 DO iatom = 1, natom
4221 IF (sparsity_pattern(iatom, jatom, b_img) == -1) cycle
4222 igroup = minloc(bins, 1, mask=ri_data%iatom_to_subgroup(iatom)%array) - 1
4223
4224 !Use cost information from previous SCF if available
4225 IF (any(ri_data%kp_cost > epsilon(0.0_dp))) THEN
4226 cost = ri_data%kp_cost(iatom, jatom, b_img)
4227 ELSE
4228 cost = real(ri_data%bsizes_AO(iatom)*ri_data%bsizes_AO(jatom), dp)
4229 END IF
4230 bins(igroup + 1) = bins(igroup + 1) + cost
4231 sparsity_pattern(iatom, jatom, b_img) = igroup
4232 END DO
4233 END DO
4234 END DO
4235
4236 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 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 REAL(dp), ALLOCATABLE, DIMENSION(:) :: bins
4256
4257 natom = SIZE(scf_pattern, 2)
4258 nimg = SIZE(scf_pattern, 3)
4259
4260 ALLOCATE (bins(ngroups))
4261 bins = 0.0_dp
4262
4263 DO b_img = 1, nimg
4264 mb_img = get_opp_index(b_img, qs_env)
4265 DO jatom = 1, natom
4266 DO iatom = 1, natom
4267 !Important: same distribution as KS matrix, because reuse t_3c_apc
4268 igroup = minloc(bins, 1, mask=ri_data%iatom_to_subgroup(iatom)%array) - 1
4269
4270 !check that block not already treated
4271 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 IF (mb_img > 0 .AND. mb_img <= nimg) THEN
4275 IF (scf_pattern(jatom, iatom, mb_img) == -1) cycle
4276 bins(igroup + 1) = bins(igroup + 1) + ri_data%kp_cost(jatom, iatom, mb_img)
4277 force_pattern(iatom, jatom, b_img) = igroup
4278 END IF
4279 END DO
4280 END DO
4281 END DO
4282
4283 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 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 INTEGER, ALLOCATABLE, DIMENSION(:) :: dist_ao_1, dist_ao_2, dist_ri, &
4302 nri_per_atom, present_img, ri_cells
4303 INTEGER, DIMENSION(:, :, :), POINTER :: cell_to_index
4304 REAL(dp) :: bump_fact, dij, dik, image_range, &
4305 ri_range, rij(3), rik(3)
4306 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 DIMENSION(:), TARGET :: basis_set_ao, basis_set_ri
4312 TYPE(kpoint_type), POINTER :: kpoints
4313 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 DIMENSION(:), POINTER :: nl_iterator
4319 TYPE(neighbor_list_set_p_type), DIMENSION(:), &
4320 POINTER :: nl_2c
4321 TYPE(particle_type), DIMENSION(:), POINTER :: particle_set
4322 TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set
4323 TYPE(section_vals_type), POINTER :: hfx_section
4324
4325 NULLIFY (qs_kind_set, dist_2d, nl_2c, nl_iterator, dft_control, &
4326 particle_set, kpoints, para_env, cell_to_index, hfx_section)
4327
4328 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 para_env=para_env, natom=natom)
4333 nimg = dft_control%nimages
4334 CALL get_kpoint_info(kpoints, cell_to_index=cell_to_index)
4335 kp_index_lbounds = lbound(cell_to_index)
4336 kp_index_ubounds = ubound(cell_to_index)
4337
4338 hfx_section => section_vals_get_subs_vals(qs_env%input, "DFT%XC%HF%RI")
4339 CALL section_vals_val_get(hfx_section, "KP_NGROUPS", i_val=ngroups)
4340
4341 ALLOCATE (basis_set_ri(nkind), basis_set_ao(nkind))
4342 CALL basis_set_list_setup(basis_set_ri, ri_data%ri_basis_type, qs_kind_set)
4343 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 IF (ri_data%hfx_pot%potential_type == do_potential_short) THEN
4348 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 "potential for better computational performance."
4353 cpwarn(warning_msg)
4354 END IF
4355
4356 !Determine the range for contributing periodic images, and for the RI basis extension
4357 ri_data%kp_RI_range = 0.0_dp
4358 ri_data%kp_image_range = 0.0_dp
4359 DO ikind = 1, nkind
4360
4361 CALL init_interaction_radii_orb_basis(basis_set_ao(ikind)%gto_basis_set, ri_data%eps_pgf_orb)
4362 CALL get_gto_basis_set(basis_set_ao(ikind)%gto_basis_set, kind_radius=ri_range)
4363 ri_data%kp_RI_range = max(ri_range, ri_data%kp_RI_range)
4364
4365 CALL init_interaction_radii_orb_basis(basis_set_ao(ikind)%gto_basis_set, ri_data%eps_pgf_orb)
4366 CALL init_interaction_radii_orb_basis(basis_set_ri(ikind)%gto_basis_set, ri_data%eps_pgf_orb)
4367 CALL get_gto_basis_set(basis_set_ri(ikind)%gto_basis_set, kind_radius=image_range)
4368
4369 image_range = 2.0_dp*image_range + cutoff_screen_factor*ri_data%hfx_pot%cutoff_radius
4370 ri_data%kp_image_range = max(image_range, ri_data%kp_image_range)
4371 END DO
4372
4373 CALL section_vals_val_get(hfx_section, "KP_RI_BUMP_FACTOR", r_val=bump_fact)
4374 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 "HFX_2c_nl_RI", qs_env, sym_ij=.false., dist_2d=dist_2d)
4381
4382 ALLOCATE (present_img(nimg))
4383 present_img = 0
4384 ri_data%nimg = 0
4385 CALL neighbor_list_iterator_create(nl_iterator, nl_2c)
4386 DO WHILE (neighbor_list_iterate(nl_iterator) == 0)
4387 CALL get_iterator_info(nl_iterator, r=rij, cell=cell_j)
4388
4389 dij = norm2(rij)
4390
4391 j_img = cell_to_index(cell_j(1), cell_j(2), cell_j(3))
4392 IF (j_img > nimg .OR. j_img < 1) cycle
4393
4394 IF (dij > ri_data%kp_image_range) cycle
4395
4396 ri_data%nimg = max(j_img, ri_data%nimg)
4397 present_img(j_img) = 1
4398
4399 END DO
4400 CALL neighbor_list_iterator_release(nl_iterator)
4401 CALL release_neighbor_list_sets(nl_2c)
4402 CALL para_env%max(ri_data%nimg)
4403 IF (ri_data%nimg > nimg) THEN
4404 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 CALL para_env%sum(present_img)
4409 ALLOCATE (ri_data%present_images(ri_data%nimg))
4410 ri_data%present_images = 0
4411 DO i_img = 1, ri_data%nimg
4412 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 map1=[1, 2], map2=[3], name="(AO AO | RI)")
4418
4419 CALL dbt_mp_environ_pgrid(ri_data%pgrid, pdims, pcoord)
4420 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 nkind, particle_set, mp_comm_t3c, own_comm=.true.)
4423 DEALLOCATE (dist_ri, dist_ao_1, dist_ao_2)
4424 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 own_dist=.true.)
4431
4432 ALLOCATE (ri_cells(nimg))
4433 ri_cells = 0
4434
4435 ALLOCATE (nri_per_atom(natom))
4436 nri_per_atom = 0
4437
4438 CALL neighbor_list_3c_iterator_create(nl_3c_iter, nl_3c)
4439 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 iatom=iatom, jatom=jatom, katom=katom)
4442 dik = norm2(rik)
4443
4444 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 jcell = cell_to_index(cell_j(1), cell_j(2), cell_j(3))
4448 IF (jcell > nimg .OR. jcell < 1) cycle
4449
4450 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 kcell = cell_to_index(cell_k(1), cell_k(2), cell_k(3))
4454 IF (kcell > nimg .OR. kcell < 1) cycle
4455
4456 IF (dik > ri_data%kp_RI_range) cycle
4457 ri_cells(kcell) = 1
4458
4459 IF (jcell == 1 .AND. iatom == jatom) nri_per_atom(iatom) = nri_per_atom(iatom) + ri_data%bsizes_RI(katom)
4460 END DO
4461 CALL neighbor_list_3c_iterator_destroy(nl_3c_iter)
4462 CALL neighbor_list_3c_destroy(nl_3c)
4463 CALL para_env%sum(ri_cells)
4464 CALL para_env%sum(nri_per_atom)
4465
4466 ALLOCATE (ri_data%img_to_RI_cell(nimg))
4467 ri_data%ncell_RI = 0
4468 ri_data%img_to_RI_cell = 0
4469 DO i_img = 1, nimg
4470 IF (ri_cells(i_img) > 0) THEN
4471 ri_data%ncell_RI = ri_data%ncell_RI + 1
4472 ri_data%img_to_RI_cell(i_img) = ri_data%ncell_RI
4473 END IF
4474 END DO
4475
4476 ALLOCATE (ri_data%RI_cell_to_img(ri_data%ncell_RI))
4477 DO i_img = 1, nimg
4478 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 IF (ri_data%unit_nr > 0) THEN
4483 WRITE (ri_data%unit_nr, fmt="(/T3,A,I29)") &
4484 "KP-HFX_RI_INFO| Number of RI-KP parallel groups:", ngroups
4485 WRITE (ri_data%unit_nr, fmt="(T3,A,I29)") &
4486 "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 "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 "KP-HFX_RI_INFO| RI basis bump factor and bump radius:", bump_fact, " /", &
4491 ri_data%kp_bump_rad*angstrom, " Ang"
4492 WRITE (ri_data%unit_nr, fmt="(T3,A,I16,A)") &
4493 "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 "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 "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 "KP-HFX_RI_INFO| Number of image cells considered: ", ri_data%nimg
4500 CALL m_flush(ri_data%unit_nr)
4501 END IF
4502
4503 CALL timestop(handle)
4504
4505 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 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 INTEGER, ALLOCATABLE, DIMENSION(:) :: bsizes_ri_ext, bsizes_stack, dist1, &
4530 dist2, dist3, dist_stack1, &
4531 dist_stack2, dist_stack3
4532 TYPE(dbt_distribution_type) :: t_dist
4533 TYPE(dbt_pgrid_type) :: pgrid
4534 TYPE(mp_para_env_type), POINTER :: para_env
4535
4536 NULLIFY (para_env)
4537
4538 CALL get_qs_env(qs_env, para_env=para_env)
4539
4540 nblks = SIZE(ri_data%bsizes_AO_split)
4541 ALLOCATE (bsizes_stack(stack_size*nblks))
4542 DO is = 1, stack_size
4543 bsizes_stack((is - 1)*nblks + 1:is*nblks) = ri_data%bsizes_AO_split(:)
4544 END DO
4545
4546 ALLOCATE (dist1(nblks), dist2(nblks), dist_stack1(stack_size*nblks), dist_stack2(stack_size*nblks))
4547 CALL dbt_get_info(rho_template, proc_dist_1=dist1, proc_dist_2=dist2)
4548 DO is = 1, stack_size
4549 dist_stack1((is - 1)*nblks + 1:is*nblks) = dist1(:)
4550 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 CALL dbt_distribution_new(t_dist, ri_data%pgrid_2d, dist_stack1, dist_stack2)
4556 CALL dbt_create(rho_stack(1), "RHO_stack", t_dist, [1], [2], bsizes_stack, bsizes_stack)
4557 CALL dbt_distribution_destroy(t_dist)
4558 DEALLOCATE (dist1, dist2, dist_stack1, dist_stack2)
4559
4560 !Second 2c tensor has optimal distribution on the 2d pgrid
4561 CALL create_2c_tensor(rho_stack(2), dist1, dist2, ri_data%pgrid_2d, bsizes_stack, bsizes_stack, name="RHO_stack")
4562 DEALLOCATE (dist1, dist2)
4563
4564 CALL dbt_get_info(ints_template, nblks_total=nblks_3c)
4565 ALLOCATE (dist1(nblks_3c(1)), dist2(nblks_3c(2)), dist3(nblks_3c(3)))
4566 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 proc_dist_3=dist3, blk_size_2=bsizes_ri_ext)
4569 DO is = 1, stack_size
4570 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 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 bsizes_ri_ext, bsizes_stack)
4577 CALL dbt_distribution_destroy(t_dist)
4578 DEALLOCATE (dist1, dist2, dist3, dist_stack3)
4579
4580 !Second 3c tensor has optimal pgrid
4581 pdims_3d = 0
4582 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 bsizes_ri_ext, bsizes_stack, [1, 2], [3], name="ints_stack")
4585 DEALLOCATE (dist1, dist2, dist3)
4586 CALL dbt_pgrid_destroy(pgrid)
4587
4588 !The result tensor has the same shape and dist as the integral tensor
4589 CALL dbt_create(ints_stack(1), res_stack(1))
4590 CALL dbt_create(ints_stack(2), res_stack(2))
4591
4592 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 SUBROUTINE fill_3c_stack(t_3c_stack, t_3c_in, images, stack_dim, ri_data, filter_at, filter_dim, &
4607 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 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 nimg = ri_data%nimg
4626 nblks = SIZE(ri_data%bsizes_AO_split)
4627
4628 do_filter = .false.
4629 IF (PRESENT(filter_at) .AND. PRESENT(filter_dim) .AND. PRESENT(idx_to_at)) do_filter = .true.
4630
4631 lb = 1
4632 ub = nimg
4633 offset = 0
4634 IF (PRESENT(img_bounds)) THEN
4635 lb = img_bounds(1)
4636 ub = img_bounds(2) - 1
4637 offset = lb - 1
4638 END IF
4639
4640 DO idx = lb, ub
4641 i_img = images(idx)
4642 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!$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 CALL dbt_finalize(t_3c_stack)
4672
4673 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 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 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 nimg = ri_data%nimg
4702 nblks = SIZE(ri_data%bsizes_AO_split)
4703
4704 lb = 1
4705 ub = nimg
4706 offset = 0
4707 IF (PRESENT(img_bounds)) THEN
4708 lb = img_bounds(1)
4709 ub = img_bounds(2) - 1
4710 offset = lb - 1
4711 END IF
4712
4713 my_shift = 1
4714 IF (PRESENT(shift)) my_shift = shift
4715
4716 DO idx = lb, ub
4717 i_img = images(idx)
4718 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!$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 CALL dbt_finalize(t_2c_stack)
4741
4742 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 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 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 CALL dbt_get_info(t_3c_apc, nblks_total=nblks_3c)
4762
4763!$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 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 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 REAL(dp), ALLOCATABLE, DIMENSION(:, :, :) :: blk
4799 TYPE(dbt_iterator_type) :: iter
4800
4801!$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 CALL dbt_finalize(t_3c_at)
4816
4817 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 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 INTEGER, ALLOCATABLE, DIMENSION(:) :: bsizes_ri_ext, bsizes_ri_ext_split, dist_ao_1, &
4842 dist_ao_2, dist_ri, dist_ri_ext, dummy_end, dummy_start, end_blocks, start_blocks
4843 INTEGER, DIMENSION(3) :: pcoord, pdims
4844 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 TYPE(dbcsr_type), ALLOCATABLE, DIMENSION(:, :) :: mat_der_metric
4849 TYPE(dbt_distribution_type) :: t_dist
4850 TYPE(dbt_pgrid_type) :: pgrid
4851 TYPE(dbt_type) :: t_3c_template
4852 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 DIMENSION(:), TARGET :: basis_set_ao, basis_set_ri
4858 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 POINTER :: nl_2c
4863 TYPE(particle_type), DIMENSION(:), POINTER :: particle_set
4864 TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set
4865
4866 NULLIFY (qs_kind_set, dist_2d, nl_2c, particle_set, dft_control, para_env, row_bsize, col_bsize)
4867
4868 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 particle_set=particle_set, dft_control=dft_control, para_env=para_env)
4872
4873 nimg = ri_data%nimg
4874 ncell_ri = ri_data%ncell_RI
4875
4876 ALLOCATE (basis_set_ri(nkind), basis_set_ao(nkind))
4877 CALL basis_set_list_setup(basis_set_ri, ri_data%ri_basis_type, qs_kind_set)
4878 CALL get_particle_set(particle_set, qs_kind_set, basis=basis_set_ri)
4879 CALL basis_set_list_setup(basis_set_ao, ri_data%orb_basis_type, qs_kind_set)
4880 CALL get_particle_set(particle_set, qs_kind_set, basis=basis_set_ao)
4881
4882 !Dealing with the 3c derivatives
4883 nthreads = 1
4884!$ nthreads = omp_get_num_threads()
4885 pdims = 0
4886 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 map1=[1, 2], map2=[3], name="tmp")
4891 CALL dbt_destroy(t_3c_template)
4892
4893 !We stack the RI basis images. Keep consistent distribution
4894 nblks_ri = SIZE(ri_data%bsizes_RI_split)
4895 ALLOCATE (dist_ri_ext(natom*ncell_ri))
4896 ALLOCATE (bsizes_ri_ext(natom*ncell_ri))
4897 ALLOCATE (bsizes_ri_ext_split(nblks_ri*ncell_ri))
4898 DO i_ri = 1, ncell_ri
4899 bsizes_ri_ext((i_ri - 1)*natom + 1:i_ri*natom) = ri_data%bsizes_RI(:)
4900 dist_ri_ext((i_ri - 1)*natom + 1:i_ri*natom) = dist_ri(:)
4901 bsizes_ri_ext_split((i_ri - 1)*nblks_ri + 1:i_ri*nblks_ri) = ri_data%bsizes_RI_split(:)
4902 END DO
4903
4904 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 ri_data%bsizes_AO, ri_data%bsizes_AO, bsizes_ri_ext)
4907 CALL dbt_distribution_destroy(t_dist)
4908
4909 ALLOCATE (t_3c_der_ri_prv(nimg, 1, 3), t_3c_der_ao_prv(nimg, 1, 3))
4910 DO i_xyz = 1, 3
4911 DO i_img = 1, nimg
4912 CALL dbt_create(t_3c_template, t_3c_der_ri_prv(i_img, 1, i_xyz))
4913 CALL dbt_create(t_3c_template, t_3c_der_ao_prv(i_img, 1, i_xyz))
4914 END DO
4915 END DO
4916 CALL dbt_destroy(t_3c_template)
4917
4918 CALL dbt_mp_environ_pgrid(pgrid, pdims, pcoord)
4919 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 nkind, particle_set, mp_comm_t3c, own_comm=.true.)
4922 DEALLOCATE (dist_ri, dist_ao_1, dist_ao_2)
4923 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 "HFX_3c_nl", qs_env, op_pos=2, sym_jk=.false., own_dist=.true.)
4927
4928 n_mem = ri_data%n_mem
4929 CALL create_tensor_batches(ri_data%bsizes_RI, n_mem, dummy_start, dummy_end, &
4930 start_blocks, end_blocks)
4931 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 map1=[1], map2=[2, 3], name="der (RI | AO AO)")
4936 DO i_xyz = 1, 3
4937 DO i_img = 1, nimg
4938 CALL dbt_create(t_3c_template, t_3c_der_ri(i_img, i_xyz))
4939 CALL dbt_create(t_3c_template, t_3c_der_ao(i_img, i_xyz))
4940 END DO
4941 END DO
4942
4943 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 ri_range=ri_data%kp_RI_range, img_to_ri_cell=ri_data%img_to_RI_cell)
4950
4951 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 DO i_img = 1, nimg
4954 DO i_xyz = 1, 3
4955 !derivative wrt to mu^0
4956 CALL get_tensor_occupancy(t_3c_der_ao_prv(i_img, 1, i_xyz), nze, occ)
4957 IF (nze > 0) THEN
4958 CALL dbt_copy(t_3c_der_ao_prv(i_img, 1, i_xyz), t_3c_template, &
4959 order=[3, 2, 1], move_data=.true.)
4960 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 order=[1, 3, 2], move_data=.true., summation=.true.)
4963 END IF
4964
4965 !derivative wrt to P^i
4966 CALL get_tensor_occupancy(t_3c_der_ri_prv(i_img, 1, i_xyz), nze, occ)
4967 IF (nze > 0) THEN
4968 CALL dbt_copy(t_3c_der_ri_prv(i_img, 1, i_xyz), t_3c_template, &
4969 order=[3, 2, 1], move_data=.true.)
4970 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 order=[1, 3, 2], move_data=.true., summation=.true.)
4973 END IF
4974 END DO
4975 END DO
4976 CALL timestop(handle2)
4977 END DO
4978 CALL dbt_destroy(t_3c_template)
4979
4980 CALL neighbor_list_3c_destroy(nl_3c)
4981 DO i_xyz = 1, 3
4982 DO i_img = 1, nimg
4983 CALL dbt_destroy(t_3c_der_ri_prv(i_img, 1, i_xyz))
4984 CALL dbt_destroy(t_3c_der_ao_prv(i_img, 1, i_xyz))
4985 END DO
4986 END DO
4987 DEALLOCATE (t_3c_der_ri_prv, t_3c_der_ao_prv)
4988
4989 !Reorder 3c derivatives to be consistant with ints
4990 CALL reorder_3c_derivs(t_3c_der_ri, ri_data)
4991 CALL reorder_3c_derivs(t_3c_der_ao, ri_data)
4992
4993 CALL timeset(routinen//"_2c", handle2)
4994 !The 2-center derivatives
4995 CALL cp_dbcsr_dist2d_to_dist(dist_2d, dbcsr_dist)
4996 ALLOCATE (row_bsize(SIZE(ri_data%bsizes_RI)))
4997 ALLOCATE (col_bsize(SIZE(ri_data%bsizes_RI)))
4998 row_bsize(:) = ri_data%bsizes_RI
4999 col_bsize(:) = ri_data%bsizes_RI
5000
5001 CALL dbcsr_create(dbcsr_template, "2c_der", dbcsr_dist, dbcsr_type_no_symmetry, &
5002 row_bsize, col_bsize)
5003 CALL dbcsr_distribution_release(dbcsr_dist)
5004 DEALLOCATE (col_bsize, row_bsize)
5005
5006 ALLOCATE (mat_der_metric(nimg, 3))
5007 DO i_xyz = 1, 3
5008 DO i_img = 1, nimg
5009 CALL dbcsr_create(mat_der_pot(i_img, i_xyz), template=dbcsr_template)
5010 CALL dbcsr_create(mat_der_metric(i_img, i_xyz), template=dbcsr_template)
5011 END DO
5012 END DO
5013 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 "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 basis_set_ri, basis_set_ri, ri_data%hfx_pot, do_kpoints=.true.)
5020 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 "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 basis_set_ri, basis_set_ri, ri_data%ri_metric, do_kpoints=.true.)
5027 CALL release_neighbor_list_sets(nl_2c)
5028
5029 !Get into extended RI basis and tensor format
5030 DO i_xyz = 1, 3
5031 DO iatom = 1, natom
5032 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 iatom, iatom, 1, ri_data, qs_env)
5035 END DO
5036 DO i_img = 1, nimg
5037 CALL dbcsr_release(mat_der_metric(i_img, i_xyz))
5038 END DO
5039 END DO
5040 CALL timestop(handle2)
5041
5042 CALL timestop(handle)
5043
5044 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 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 INTEGER, DIMENSION(:, :), POINTER :: index_to_cell
5089 LOGICAL :: found, my_diag, my_offdiag, use_virial
5090 REAL(dp) :: new_force
5091 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 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 CALL timeset(routinen, handle)
5102
5103 use_virial = .false.
5104 IF (PRESENT(work_virial) .AND. PRESENT(cell) .AND. PRESENT(particle_set)) use_virial = .true.
5105
5106 my_diag = .false.
5107 IF (PRESENT(diag)) my_diag = diag
5108
5109 my_offdiag = .false.
5110 IF (PRESENT(diag)) my_offdiag = offdiag
5111
5112 CALL get_qs_env(qs_env, kpoints=kpoints, natom=natom)
5113 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!$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 CALL timestop(handle)
5195
5196 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 SUBROUTINE get_force_from_3c_trace(force, t_3c_contr, t_3c_der_1, t_3c_der_2, atom_of_kind, kind_of, &
5220 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 INTEGER, DIMENSION(:, :), POINTER :: index_to_cell
5243 LOGICAL :: found, found_1, found_2, use_virial
5244 REAL(dp) :: new_force
5245 REAL(dp), ALLOCATABLE, DIMENSION(:, :, :), TARGET :: contr_blk, der_blk_1, der_blk_2, &
5246 der_blk_3
5247 REAL(dp), DIMENSION(3) :: scoord
5248 TYPE(dbt_iterator_type) :: iter
5249 TYPE(kpoint_type), POINTER :: kpoints
5250
5251 NULLIFY (kpoints, index_to_cell)
5252
5253 CALL timeset(routinen, handle)
5254
5255 CALL get_qs_env(qs_env, kpoints=kpoints)
5256 CALL get_kpoint_info(kpoints, index_to_cell=index_to_cell)
5257
5258 nblks_ri = SIZE(ri_data%bsizes_RI_split)
5259 nblks_ao = SIZE(ri_data%bsizes_AO_split)
5260
5261 use_virial = .false.
5262 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!$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 CALL timestop(handle)
5370
5371 END SUBROUTINE get_force_from_3c_trace
5372
5373END MODULE hfx_ri_kp
modulo
static GRID_HOST_DEVICE int modulo(int a, int m)
Equivalent of Fortran's MODULO, which always return a positive number. https://gcc....
Definition grid_common.h:125
fac
static GRID_HOST_DEVICE double fac(const int i)
Factorial function, e.g. fac(5) = 5! = 120.
Definition grid_common.h:56
idx
static GRID_HOST_DEVICE int idx(const orbital a)
Return coset index of given orbital angular momentum.
Definition grid_common.h:161
cell_types::pbc
Definition cell_types.F:104
cp_dbcsr_api::dbcsr_create
Definition cp_dbcsr_api.F:194
message_passing::mp_waitall
Definition message_passing.F:853
admm_types
Types and set/get functions for auxiliary density matrix methods.
Definition admm_types.F:15
admm_types::get_admm_env
subroutine, public get_admm_env(admm_env, mo_derivs_aux_fit, mos_aux_fit, sab_aux_fit, sab_aux_fit_asymm, sab_aux_fit_vs_orb, matrix_s_aux_fit, matrix_s_aux_fit_kp, matrix_s_aux_fit_vs_orb, matrix_s_aux_fit_vs_orb_kp, task_list_aux_fit, matrix_ks_aux_fit, matrix_ks_aux_fit_kp, matrix_ks_aux_fit_im, matrix_ks_aux_fit_dft, matrix_ks_aux_fit_hfx, matrix_ks_aux_fit_dft_kp, matrix_ks_aux_fit_hfx_kp, rho_aux_fit, rho_aux_fit_buffer, admm_dm)
Get routine for the ADMM env.
Definition admm_types.F:599
atomic_kind_types
Define the atomic kind types and their sub types.
Definition atomic_kind_types.F:23
atomic_kind_types::get_atomic_kind_set
subroutine, public get_atomic_kind_set(atomic_kind_set, atom_of_kind, kind_of, natom_of_kind, maxatom, natom, nshell, fist_potential_present, shell_present, shell_adiabatic, shell_check_distance, damping_present)
Get attributes of an atomic kind set.
Definition atomic_kind_types.F:223
basis_set_types
Definition basis_set_types.F:15
basis_set_types::get_gto_basis_set
subroutine, public get_gto_basis_set(gto_basis_set, name, aliases, norm_type, kind_radius, ncgf, nset, nsgf, cgf_symbol, sgf_symbol, norm_cgf, set_radius, lmax, lmin, lx, ly, lz, m, ncgf_set, npgf, nsgf_set, nshell, cphi, pgf_radius, sphi, scon, zet, first_cgf, first_sgf, l, last_cgf, last_sgf, n, gcc, maxco, maxl, maxpgf, maxsgf_set, maxshell, maxso, nco_sum, npgf_sum, nshell_sum, maxder, short_kind_radius, npgf_seg_sum, ccon)
...
Definition basis_set_types.F:643
bibliography
collects all references to literature in CP2K as new algorithms / method are included from literature...
Definition bibliography.F:21
bibliography::bussy2024
integer, save, public bussy2024
Definition bibliography.F:36
cell_types
Handles all functions related to the CELL.
Definition cell_types.F:15
cell_types::scaled_to_real
subroutine, public scaled_to_real(r, s, cell)
Transform scaled cell coordinates real coordinates. r=h*s.
Definition cell_types.F:625
cell_types::real_to_scaled
subroutine, public real_to_scaled(s, r, cell)
Transform real to scaled cell coordinates. s=h_inv*r.
Definition cell_types.F:595
cp_array_utils
various utilities that regard array of different kinds: output, allocation,... maybe it is not a good...
Definition cp_array_utils.F:18
cp_blacs_env
methods related to the blacs parallel environment
Definition cp_blacs_env.F:15
cp_blacs_env::cp_blacs_env_release
subroutine, public cp_blacs_env_release(blacs_env)
releases the given blacs_env
Definition cp_blacs_env.F:274
cp_blacs_env::cp_blacs_env_create
subroutine, public cp_blacs_env_create(blacs_env, para_env, blacs_grid_layout, blacs_repeatable, row_major, grid_2d)
allocates and initializes a type that represent a blacs context
Definition cp_blacs_env.F:123
cp_control_types
Defines control structures, which contain the parameters and the settings for the DFT-based calculati...
Definition cp_control_types.F:12
cp_dbcsr_api
Definition cp_dbcsr_api.F:8
cp_dbcsr_api::dbcsr_distribution_release
subroutine, public dbcsr_distribution_release(dist)
...
Definition cp_dbcsr_api.F:643
cp_dbcsr_api::dbcsr_distribution_new
subroutine, public dbcsr_distribution_new(dist, template, group, pgrid, row_dist, col_dist, reuse_arrays)
...
Definition cp_dbcsr_api.F:616
cp_dbcsr_api::dbcsr_iterator_blocks_left
logical function, public dbcsr_iterator_blocks_left(iterator)
...
Definition cp_dbcsr_api.F:944
cp_dbcsr_api::dbcsr_iterator_stop
subroutine, public dbcsr_iterator_stop(iterator)
...
Definition cp_dbcsr_api.F:1050
cp_dbcsr_api::dbcsr_copy
subroutine, public dbcsr_copy(matrix_b, matrix_a, name, keep_sparsity, keep_imaginary)
...
Definition cp_dbcsr_api.F:371
cp_dbcsr_api::dbcsr_get_block_p
subroutine, public dbcsr_get_block_p(matrix, row, col, block, found, row_size, col_size)
...
Definition cp_dbcsr_api.F:693
cp_dbcsr_api::dbcsr_get_info
subroutine, public dbcsr_get_info(matrix, nblkrows_total, nblkcols_total, nfullrows_total, nfullcols_total, nblkrows_local, nblkcols_local, nfullrows_local, nfullcols_local, my_prow, my_pcol, local_rows, local_cols, proc_row_dist, proc_col_dist, row_blk_size, col_blk_size, row_blk_offset, col_blk_offset, distribution, name, matrix_type, group)
...
Definition cp_dbcsr_api.F:808
cp_dbcsr_api::dbcsr_iterator_next_block
subroutine, public dbcsr_iterator_next_block(iterator, row, column, block, block_number_argument_has_been_removed, row_size, col_size, row_offset, col_offset, transposed)
...
Definition cp_dbcsr_api.F:971
cp_dbcsr_api::dbcsr_filter
subroutine, public dbcsr_filter(matrix, eps)
...
Definition cp_dbcsr_api.F:658
cp_dbcsr_api::dbcsr_finalize
subroutine, public dbcsr_finalize(matrix)
...
Definition cp_dbcsr_api.F:673
cp_dbcsr_api::dbcsr_iterator_start
subroutine, public dbcsr_iterator_start(iterator, matrix, shared, dynamic, dynamic_byrows)
...
Definition cp_dbcsr_api.F:1012
cp_dbcsr_api::dbcsr_release
subroutine, public dbcsr_release(matrix)
...
Definition cp_dbcsr_api.F:1142
cp_dbcsr_api::dbcsr_clear
subroutine, public dbcsr_clear(matrix)
...
Definition cp_dbcsr_api.F:305
cp_dbcsr_api::dbcsr_put_block
subroutine, public dbcsr_put_block(matrix, row, col, block, summation)
...
Definition cp_dbcsr_api.F:1125
cp_dbcsr_api::dbcsr_add
subroutine, public dbcsr_add(matrix_a, matrix_b, alpha_scalar, beta_scalar)
...
Definition cp_dbcsr_api.F:254
cp_dbcsr_api::dbcsr_distribution_get
subroutine, public dbcsr_distribution_get(dist, row_dist, col_dist, nrows, ncols, has_threads, group, mynode, numnodes, nprows, npcols, myprow, mypcol, pgrid, subgroups_defined, prow_group, pcol_group)
...
Definition cp_dbcsr_api.F:572
cp_dbcsr_cholesky
Interface to (sca)lapack for the Cholesky based procedures.
Definition cp_dbcsr_cholesky.F:17
cp_dbcsr_cholesky::cp_dbcsr_cholesky_decompose
subroutine, public cp_dbcsr_cholesky_decompose(matrix, n, para_env, blacs_env)
used to replace a symmetric positive def. matrix M with its cholesky decomposition U: M = U^T * U,...
Definition cp_dbcsr_cholesky.F:61
cp_dbcsr_cholesky::cp_dbcsr_cholesky_invert
subroutine, public cp_dbcsr_cholesky_invert(matrix, n, para_env, blacs_env, uplo_to_full)
used to replace the cholesky decomposition by the inverse
Definition cp_dbcsr_cholesky.F:114
cp_dbcsr_contrib
Definition cp_dbcsr_contrib.F:8
cp_dbcsr_contrib::dbcsr_dot
subroutine, public dbcsr_dot(matrix_a, matrix_b, trace)
Computes the dot product of two matrices, also known as the trace of their matrix product.
Definition cp_dbcsr_contrib.F:367
cp_dbcsr_cp2k_link
Routines that link DBCSR and CP2K concepts together.
Definition cp_dbcsr_cp2k_link.F:14
cp_dbcsr_cp2k_link::cp_dbcsr_alloc_block_from_nbl
subroutine, public cp_dbcsr_alloc_block_from_nbl(matrix, sab_orb, desymmetrize)
allocate the blocks of a dbcsr based on the neighbor list
Definition cp_dbcsr_cp2k_link.F:445
cp_dbcsr_diag
Interface to (sca)lapack for the Cholesky based procedures.
Definition cp_dbcsr_diag.F:17
cp_dbcsr_diag::cp_dbcsr_power
subroutine, public cp_dbcsr_power(matrix, exponent, threshold, n_dependent, para_env, blacs_env, verbose, eigenvectors, eigenvalues)
...
Definition cp_dbcsr_diag.F:279
cp_dbcsr_operations
DBCSR operations in CP2K.
Definition cp_dbcsr_operations.F:18
cp_dbcsr_operations::cp_dbcsr_dist2d_to_dist
subroutine, public cp_dbcsr_dist2d_to_dist(dist2d, dist)
Creates a DBCSR distribution from a distribution_2d.
Definition cp_dbcsr_operations.F:415
dbt_api
This is the start of a dbt_api, all publically needed functions are exported here....
Definition dbt_api.F:17
distribution_2d_types
stores a mapping of 2D info (e.g. matrix) on a 2D processor distribution (i.e. blacs grid) where cpus...
Definition distribution_2d_types.F:15
distribution_2d_types::distribution_2d_create
subroutine, public distribution_2d_create(distribution_2d, blacs_env, local_rows_ptr, n_local_rows, local_cols_ptr, row_distribution_ptr, col_distribution_ptr, n_local_cols, n_row_distribution, n_col_distribution)
initializes the distribution_2d
Definition distribution_2d_types.F:102
distribution_2d_types::distribution_2d_release
subroutine, public distribution_2d_release(distribution_2d)
...
Definition distribution_2d_types.F:238
hfx_ri_kp
RI-methods for HFX and K-points. \auhtor Augustin Bussy (01.2023)
Definition hfx_ri_kp.F:13
hfx_ri_kp::hfx_ri_update_forces_kp
subroutine, public hfx_ri_update_forces_kp(qs_env, ri_data, nspins, hf_fraction, rho_ao, use_virial)
Update the K-points RI-HFX forces.
Definition hfx_ri_kp.F:862
hfx_ri_kp::hfx_ri_update_ks_kp
subroutine, public hfx_ri_update_ks_kp(qs_env, ri_data, ks_matrix, ehfx, rho_ao, geometry_did_change, nspins, hf_fraction)
Update the KS matrices for each real-space image.
Definition hfx_ri_kp.F:456
hfx_ri
RI-methods for HFX.
Definition hfx_ri.F:12
hfx_ri::get_force_from_3c_trace
subroutine, public get_force_from_3c_trace(force, t_3c_contr, t_3c_der, atom_of_kind, kind_of, idx_to_at, pref, do_mp2, deriv_dim)
This routines calculates the force contribution from a trace over 3D tensors, i.e....
Definition hfx_ri.F:3368
hfx_ri::get_idx_to_atom
subroutine, public get_idx_to_atom(idx_to_at, bsizes_split, bsizes_orig)
a small utility function that returns the atom corresponding to a block of a split tensor
Definition hfx_ri.F:4239
hfx_ri::hfx_ri_pre_scf_calc_tensors
subroutine, public hfx_ri_pre_scf_calc_tensors(qs_env, ri_data, t_2c_int_ri, t_2c_int_pot, t_3c_int, do_kpoints)
Calculate 2-center and 3-center integrals.
Definition hfx_ri.F:449
hfx_ri::get_2c_der_force
subroutine, public get_2c_der_force(force, t_2c_contr, t_2c_der, atom_of_kind, kind_of, idx_to_at, pref, do_mp2, do_ovlp)
Update the forces due to the derivative of the a 2-center product d/dR (Q|R)
Definition hfx_ri.F:3454
hfx_types
Types and set/get functions for HFX.
Definition hfx_types.F:16
input_constants
collects all constants needed in input so that they can be used without circular dependencies
Definition input_constants.F:18
input_constants::hfx_ri_do_2c_cholesky
integer, parameter, public hfx_ri_do_2c_cholesky
Definition input_constants.F:864
input_constants::hfx_ri_do_2c_diag
integer, parameter, public hfx_ri_do_2c_diag
Definition input_constants.F:864
input_constants::hfx_ri_do_2c_iter
integer, parameter, public hfx_ri_do_2c_iter
Definition input_constants.F:864
input_constants::do_potential_short
integer, parameter, public do_potential_short
Definition input_constants.F:838
input_cp2k_hfx
function that builds the hartree fock exchange section of the input
Definition input_cp2k_hfx.F:14
input_cp2k_hfx::ri_pmat
integer, parameter, public ri_pmat
Definition input_cp2k_hfx.F:47
input_section_types
objects that represent the structure of input sections and the data contained in an input section
Definition input_section_types.F:15
input_section_types::section_vals_val_set
subroutine, public section_vals_val_set(section_vals, keyword_name, i_rep_section, i_rep_val, val, l_val, i_val, r_val, c_val, l_vals_ptr, i_vals_ptr, r_vals_ptr, c_vals_ptr)
sets the requested value
Definition input_section_types.F:1233
input_section_types::section_vals_get_subs_vals
recursive type(section_vals_type) function, pointer, public section_vals_get_subs_vals(section_vals, subsection_name, i_rep_section, can_return_null)
returns the values of the requested subsection
Definition input_section_types.F:735
input_section_types::section_vals_val_get
subroutine, public section_vals_val_get(section_vals, keyword_name, i_rep_section, i_rep_val, n_rep_val, val, l_val, i_val, r_val, c_val, l_vals, i_vals, r_vals, c_vals, explicit)
returns the requested value
Definition input_section_types.F:1052
iterate_matrix
Routines useful for iterative matrix calculations.
Definition iterate_matrix.F:13
iterate_matrix::invert_hotelling
subroutine, public invert_hotelling(matrix_inverse, matrix, threshold, use_inv_as_guess, norm_convergence, filter_eps, accelerator_order, max_iter_lanczos, eps_lanczos, silent)
invert a symmetric positive definite matrix by Hotelling's method explicit symmetrization makes this ...
Definition iterate_matrix.F:473
kinds
Defines the basic variable types.
Definition kinds.F:23
kinds::int_8
integer, parameter, public int_8
Definition kinds.F:54
kinds::dp
integer, parameter, public dp
Definition kinds.F:34
kinds::default_string_length
integer, parameter, public default_string_length
Definition kinds.F:57
kpoint_types
Types and basic routines needed for a kpoint calculation.
Definition kpoint_types.F:15
kpoint_types::get_kpoint_info
subroutine, public get_kpoint_info(kpoint, kp_scheme, nkp_grid, kp_shift, symmetry, verbose, full_grid, use_real_wfn, eps_geo, parallel_group_size, kp_range, nkp, xkp, wkp, para_env, blacs_env_all, para_env_kp, para_env_inter_kp, blacs_env, kp_env, kp_aux_env, mpools, iogrp, nkp_groups, kp_dist, cell_to_index, index_to_cell, sab_nl, sab_nl_nosym, inversion_symmetry_only, symmetry_backend, symmetry_reduction_method, gamma_centered)
Retrieve information from a kpoint environment.
Definition kpoint_types.F:529
libint_2c_3c
2- and 3-center electron repulsion integral routines based on libint2 Currently available operators: ...
Definition libint_2c_3c.F:14
libint_2c_3c::cutoff_screen_factor
real(kind=dp), parameter, public cutoff_screen_factor
Definition libint_2c_3c.F:49
machine
Machine interface based on Fortran 2003 and POSIX.
Definition machine.F:17
machine::m_memory
subroutine, public m_memory(mem)
Returns the total amount of memory [bytes] in use, if known, zero otherwise.
Definition machine.F:440
machine::m_flush
subroutine, public m_flush(lunit)
flushes units if the &GLOBAL flag is set accordingly
Definition machine.F:124
machine::m_walltime
real(kind=dp) function, public m_walltime()
returns time from a real-time clock, protected against rolling early/easily
Definition machine.F:141
mathlib
Collection of simple mathematical functions and subroutines.
Definition mathlib.F:15
mathlib::diag
subroutine, public diag(n, a, d, v)
Diagonalize matrix a. The eigenvalues are returned in vector d and the eigenvectors are returned in m...
Definition mathlib.F:1633
mathlib::erfc_cutoff
subroutine, public erfc_cutoff(eps, omg, r_cutoff)
compute a truncation radius for the shortrange operator
Definition mathlib.F:1823
message_passing
Interface to the message passing library MPI.
Definition message_passing.F:23
particle_methods
Define methods related to particle_type.
Definition particle_methods.F:14
particle_methods::get_particle_set
subroutine, public get_particle_set(particle_set, qs_kind_set, first_sgf, last_sgf, nsgf, nmao, basis, ncgf)
Get the components of a particle set.
Definition particle_methods.F:121
particle_types
Define the data structure for the particle information.
Definition particle_types.F:19
physcon
Definition of physical constants:
Definition physcon.F:68
physcon::angstrom
real(kind=dp), parameter, public angstrom
Definition physcon.F:144
qs_environment_types
Definition qs_environment_types.F:14
qs_environment_types::get_qs_env
subroutine, public get_qs_env(qs_env, atomic_kind_set, qs_kind_set, cell, super_cell, cell_ref, use_ref_cell, kpoints, dft_control, mos, sab_orb, sab_all, qmmm, qmmm_periodic, mimic, sac_ae, sac_ppl, sac_lri, sap_ppnl, sab_vdw, sab_scp, sap_oce, sab_lrc, sab_se, sab_xtbe, sab_tbe, sab_core, sab_xb, sab_xtb_pp, sab_xtb_nonbond, sab_almo, sab_kp, sab_kp_nosym, sab_cneo, particle_set, energy, force, matrix_h, matrix_h_im, matrix_ks, matrix_ks_im, matrix_vxc, run_rtp, rtp, matrix_h_kp, matrix_h_im_kp, matrix_ks_kp, matrix_ks_im_kp, matrix_vxc_kp, kinetic_kp, matrix_s_kp, matrix_w_kp, matrix_s_ri_aux_kp, matrix_s, matrix_s_ri_aux, matrix_w, matrix_p_mp2, matrix_p_mp2_admm, matrix_vhxc, rho, rho_xc, pw_env, ewald_env, ewald_pw, active_space, mpools, input, para_env, blacs_env, scf_control, rel_control, kinetic, qs_charges, vppl, xcint_weights, rho_core, rho_nlcc, rho_nlcc_g, ks_env, ks_qmmm_env, wf_history, scf_env, local_particles, local_molecules, distribution_2d, dbcsr_dist, molecule_kind_set, molecule_set, subsys, cp_subsys, oce, local_rho_set, rho_atom_set, task_list, task_list_soft, rho0_atom_set, rho0_mpole, rhoz_set, rhoz_cneo_set, ecoul_1c, rho0_s_rs, rho0_s_gs, rhoz_cneo_s_rs, rhoz_cneo_s_gs, do_kpoints, has_unit_metric, requires_mo_derivs, mo_derivs, mo_loc_history, nkind, natom, nelectron_total, nelectron_spin, efield, neighbor_list_id, linres_control, xas_env, virial, cp_ddapc_env, cp_ddapc_ewald, outer_scf_history, outer_scf_ihistory, x_data, et_coupling, dftb_potential, results, se_taper, se_store_int_env, se_nddo_mpole, se_nonbond_env, admm_env, lri_env, lri_density, exstate_env, ec_env, harris_env, dispersion_env, gcp_env, vee, rho_external, external_vxc, mask, mp2_env, bs_env, kg_env, wanniercentres, atprop, ls_scf_env, do_transport, transport_env, v_hartree_rspace, s_mstruct_changed, rho_changed, potential_changed, forces_up_to_date, mscfg_env, almo_scf_env, gradient_history, variable_history, embed_pot, spin_embed_pot, polar_env, mos_last_converged, eeq, rhs, do_rixs, tb_tblite)
Get the QUICKSTEP environment.
Definition qs_environment_types.F:534
qs_force_types
Definition qs_force_types.F:13
qs_integral_utils
Some utility functions for the calculation of integrals.
Definition qs_integral_utils.F:14
qs_integral_utils::basis_set_list_setup
subroutine, public basis_set_list_setup(basis_set_list, basis_type, qs_kind_set)
Set up an easy accessible list of the basis sets for all kinds.
Definition qs_integral_utils.F:149
qs_interactions
Calculate the interaction radii for the operator matrix calculation.
Definition qs_interactions.F:17
qs_interactions::init_interaction_radii_orb_basis
subroutine, public init_interaction_radii_orb_basis(orb_basis_set, eps_pgf_orb, eps_pgf_short)
...
Definition qs_interactions.F:439
qs_kind_types
Define the quickstep kind type and their sub types.
Definition qs_kind_types.F:23
qs_neighbor_list_types
Define the neighbor list data types and the corresponding functionality.
Definition qs_neighbor_list_types.F:17
qs_neighbor_list_types::release_neighbor_list_sets
subroutine, public release_neighbor_list_sets(nlists)
releases an array of neighbor_list_sets
Definition qs_neighbor_list_types.F:1096
qs_neighbor_list_types::neighbor_list_iterator_create
subroutine, public neighbor_list_iterator_create(iterator_set, nl, search, nthread)
Neighbor list iterator functions.
Definition qs_neighbor_list_types.F:165
qs_neighbor_list_types::neighbor_list_iterator_release
subroutine, public neighbor_list_iterator_release(iterator_set)
...
Definition qs_neighbor_list_types.F:251
qs_neighbor_list_types::neighbor_list_iterate
integer function, public neighbor_list_iterate(iterator_set, mepos)
...
Definition qs_neighbor_list_types.F:351
qs_neighbor_list_types::get_iterator_info
subroutine, public get_iterator_info(iterator_set, mepos, ikind, jkind, nkind, ilist, nlist, inode, nnode, iatom, jatom, r, cell)
...
Definition qs_neighbor_list_types.F:550
qs_scf_types
module that contains the definitions of the scf types
Definition qs_scf_types.F:14
qs_tensors_types
Utility methods to build 3-center integral tensors of various types.
Definition qs_tensors_types.F:12
qs_tensors_types::distribution_3d_create
subroutine, public distribution_3d_create(dist_3d, dist1, dist2, dist3, nkind, particle_set, mp_comm_3d, own_comm)
Create a 3d distribution.
Definition qs_tensors_types.F:91
qs_tensors_types::create_2c_tensor
subroutine, public create_2c_tensor(t2c, dist_1, dist_2, pgrid, sizes_1, sizes_2, order, name)
...
Definition qs_tensors_types.F:382
qs_tensors_types::create_tensor_batches
subroutine, public create_tensor_batches(sizes, nbatches, starts_array, ends_array, starts_array_block, ends_array_block)
...
Definition qs_tensors_types.F:522
qs_tensors_types::create_3c_tensor
subroutine, public create_3c_tensor(t3c, dist_1, dist_2, dist_3, pgrid, sizes_1, sizes_2, sizes_3, map1, map2, name)
...
Definition qs_tensors_types.F:335
qs_tensors
Utility methods to build 3-center integral tensors of various types.
Definition qs_tensors.F:11
qs_tensors::build_3c_derivatives
subroutine, public build_3c_derivatives(t3c_der_i, t3c_der_k, filter_eps, qs_env, nl_3c, basis_i, basis_j, basis_k, potential_parameter, der_eps, op_pos, do_kpoints, do_hfx_kpoints, bounds_i, bounds_j, bounds_k, ri_range, img_to_ri_cell)
Build 3-center derivative tensors.
Definition qs_tensors.F:926
qs_tensors::build_2c_neighbor_lists
subroutine, public build_2c_neighbor_lists(ij_list, basis_i, basis_j, potential_parameter, name, qs_env, sym_ij, molecular, dist_2d, pot_to_rad)
Build 2-center neighborlists adapted to different operators This mainly wraps build_neighbor_lists fo...
Definition qs_tensors.F:144
qs_tensors::neighbor_list_3c_iterate
recursive integer function, public neighbor_list_3c_iterate(iterator)
Iterate 3c-nl iterator.
Definition qs_tensors.F:465
qs_tensors::neighbor_list_3c_iterator_destroy
subroutine, public neighbor_list_3c_iterator_destroy(iterator)
Destroy 3c-nl iterator.
Definition qs_tensors.F:443
qs_tensors::neighbor_list_3c_destroy
subroutine, public neighbor_list_3c_destroy(ijk_list)
Destroy 3c neighborlist.
Definition qs_tensors.F:381
qs_tensors::build_2c_derivatives
subroutine, public build_2c_derivatives(t2c_der, filter_eps, qs_env, nl_2c, basis_i, basis_j, potential_parameter, do_kpoints)
Calculates the derivatives of 2-center integrals, wrt to the first center.
Definition qs_tensors.F:2735
qs_tensors::get_tensor_occupancy
subroutine, public get_tensor_occupancy(tensor, nze, occ)
...
Definition qs_tensors.F:3624
qs_tensors::build_3c_neighbor_lists
subroutine, public build_3c_neighbor_lists(ijk_list, basis_i, basis_j, basis_k, dist_3d, potential_parameter, name, qs_env, sym_ij, sym_jk, sym_ik, molecular, op_pos, own_dist)
Build a 3-center neighbor list.
Definition qs_tensors.F:280
qs_tensors::neighbor_list_3c_iterator_create
subroutine, public neighbor_list_3c_iterator_create(iterator, ijk_nl)
Create a 3-center neighborlist iterator.
Definition qs_tensors.F:398
qs_tensors::get_3c_iterator_info
subroutine, public get_3c_iterator_info(iterator, ikind, jkind, kkind, nkind, iatom, jatom, katom, rij, rjk, rik, cell_j, cell_k)
Get info of current iteration.
Definition qs_tensors.F:562
util
All kind of helpful little routines.
Definition util.F:14
util::get_limit
pure integer function, dimension(2), public get_limit(m, n, me)
divide m entries into n parts, return size of part me
Definition util.F:333
virial_types
Definition virial_types.F:13
atomic_kind_types::atomic_kind_type
Provides all information about an atomic kind.
Definition atomic_kind_types.F:45
basis_set_types::gto_basis_set_p_type
Definition basis_set_types.F:94
cell_types::cell_type
Type defining parameters related to the simulation cell.
Definition cell_types.F:60
cp_array_utils::cp_1d_logical_p_type
represent a pointer to a 1d array
Definition cp_array_utils.F:282
cp_array_utils::cp_2d_r_p_type
represent a pointer to a 2d array
Definition cp_array_utils.F:109
cp_array_utils::cp_3d_r_p_type
represent a pointer to a 3d array
Definition cp_array_utils.F:119
cp_blacs_env::cp_blacs_env_type
represent a blacs multidimensional parallel environment (for the mpi corrispective see cp_paratypes/m...
Definition cp_blacs_env.F:53
cp_control_types::dft_control_type
Definition cp_control_types.F:757
cp_dbcsr_api::dbcsr_distribution_type
Definition cp_dbcsr_api.F:182
cp_dbcsr_api::dbcsr_iterator_type
Definition cp_dbcsr_api.F:188
cp_dbcsr_api::dbcsr_p_type
Definition cp_dbcsr_api.F:172
cp_dbcsr_api::dbcsr_type
Definition cp_dbcsr_api.F:176
distribution_2d_types::distribution_2d_type
distributes pairs on a 2d grid of processors
Definition distribution_2d_types.F:62
hfx_types::hfx_ri_type
Definition hfx_types.F:376
input_section_types::section_vals_type
stores the values of a section
Definition input_section_types.F:127
kpoint_types::kpoint_type
Contains information about kpoints.
Definition kpoint_types.F:175
message_passing::mp_cart_type
Definition message_passing.F:723
message_passing::mp_para_env_type
stores all the informations relevant to an mpi environment
Definition message_passing.F:746
message_passing::mp_request_type
Definition message_passing.F:606
particle_types::particle_type
Definition particle_types.F:35
qs_environment_types::qs_environment_type
Definition qs_environment_types.F:222
qs_force_types::qs_force_type
Definition qs_force_types.F:28
qs_kind_types::qs_kind_type
Provides all information about a quickstep kind.
Definition qs_kind_types.F:185
qs_neighbor_list_types::neighbor_list_iterator_p_type
Definition qs_neighbor_list_types.F:117
qs_neighbor_list_types::neighbor_list_set_p_type
Definition qs_neighbor_list_types.F:67
qs_scf_types::qs_scf_env_type
Definition qs_scf_types.F:97
qs_tensors_types::distribution_3d_type
Definition qs_tensors_types.F:57
qs_tensors_types::neighbor_list_3c_iterator_type
Definition qs_tensors_types.F:70
qs_tensors_types::neighbor_list_3c_type
Definition qs_tensors_types.F:63
virial_types::virial_type
Definition virial_types.F:26