Line data Source code
1 : !--------------------------------------------------------------------------------------------------!
2 : ! CP2K: A general program to perform molecular dynamics simulations !
3 : ! Copyright 2000-2025 CP2K developers group <https://cp2k.org> !
4 : ! !
5 : ! SPDX-License-Identifier: BSD-3-Clause !
6 : !--------------------------------------------------------------------------------------------------!
7 :
8 : ! **************************************************************************************************
9 : !> \brief Fortran API for the grid package, which is written in C.
10 : !> \author Ole Schuett
11 : ! **************************************************************************************************
12 : MODULE grid_api
13 : USE ISO_C_BINDING, ONLY: &
14 : C_ASSOCIATED, C_BOOL, C_CHAR, C_DOUBLE, C_FUNLOC, C_FUNPTR, C_INT, C_LOC, C_NULL_PTR, C_PTR
15 : USE kinds, ONLY: dp
16 : USE message_passing, ONLY: mp_comm_type
17 : USE offload_api, ONLY: offload_buffer_type
18 : USE realspace_grid_types, ONLY: realspace_grid_type
19 : #include "../base/base_uses.f90"
20 :
21 : IMPLICIT NONE
22 :
23 : PRIVATE
24 :
25 : CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'grid_api'
26 :
27 : INTEGER, PARAMETER, PUBLIC :: GRID_FUNC_AB = 100
28 : INTEGER, PARAMETER, PUBLIC :: GRID_FUNC_DADB = 200
29 : INTEGER, PARAMETER, PUBLIC :: GRID_FUNC_ADBmDAB_X = 301
30 : INTEGER, PARAMETER, PUBLIC :: GRID_FUNC_ADBmDAB_Y = 302
31 : INTEGER, PARAMETER, PUBLIC :: GRID_FUNC_ADBmDAB_Z = 303
32 : INTEGER, PARAMETER, PUBLIC :: GRID_FUNC_ARDBmDARB_XX = 411
33 : INTEGER, PARAMETER, PUBLIC :: GRID_FUNC_ARDBmDARB_XY = 412
34 : INTEGER, PARAMETER, PUBLIC :: GRID_FUNC_ARDBmDARB_XZ = 413
35 : INTEGER, PARAMETER, PUBLIC :: GRID_FUNC_ARDBmDARB_YX = 421
36 : INTEGER, PARAMETER, PUBLIC :: GRID_FUNC_ARDBmDARB_YY = 422
37 : INTEGER, PARAMETER, PUBLIC :: GRID_FUNC_ARDBmDARB_YZ = 423
38 : INTEGER, PARAMETER, PUBLIC :: GRID_FUNC_ARDBmDARB_ZX = 431
39 : INTEGER, PARAMETER, PUBLIC :: GRID_FUNC_ARDBmDARB_ZY = 432
40 : INTEGER, PARAMETER, PUBLIC :: GRID_FUNC_ARDBmDARB_ZZ = 433
41 : INTEGER, PARAMETER, PUBLIC :: GRID_FUNC_DABpADB_X = 501
42 : INTEGER, PARAMETER, PUBLIC :: GRID_FUNC_DABpADB_Y = 502
43 : INTEGER, PARAMETER, PUBLIC :: GRID_FUNC_DABpADB_Z = 503
44 : INTEGER, PARAMETER, PUBLIC :: GRID_FUNC_DX = 601
45 : INTEGER, PARAMETER, PUBLIC :: GRID_FUNC_DY = 602
46 : INTEGER, PARAMETER, PUBLIC :: GRID_FUNC_DZ = 603
47 : INTEGER, PARAMETER, PUBLIC :: GRID_FUNC_DXDY = 701
48 : INTEGER, PARAMETER, PUBLIC :: GRID_FUNC_DYDZ = 702
49 : INTEGER, PARAMETER, PUBLIC :: GRID_FUNC_DZDX = 703
50 : INTEGER, PARAMETER, PUBLIC :: GRID_FUNC_DXDX = 801
51 : INTEGER, PARAMETER, PUBLIC :: GRID_FUNC_DYDY = 802
52 : INTEGER, PARAMETER, PUBLIC :: GRID_FUNC_DZDZ = 803
53 : INTEGER, PARAMETER, PUBLIC :: GRID_FUNC_DAB_X = 901
54 : INTEGER, PARAMETER, PUBLIC :: GRID_FUNC_DAB_Y = 902
55 : INTEGER, PARAMETER, PUBLIC :: GRID_FUNC_DAB_Z = 903
56 : INTEGER, PARAMETER, PUBLIC :: GRID_FUNC_ADB_X = 904
57 : INTEGER, PARAMETER, PUBLIC :: GRID_FUNC_ADB_Y = 905
58 : INTEGER, PARAMETER, PUBLIC :: GRID_FUNC_ADB_Z = 906
59 :
60 : INTEGER, PARAMETER, PUBLIC :: GRID_FUNC_CORE_X = 1001
61 : INTEGER, PARAMETER, PUBLIC :: GRID_FUNC_CORE_Y = 1002
62 : INTEGER, PARAMETER, PUBLIC :: GRID_FUNC_CORE_Z = 1003
63 :
64 : INTEGER, PARAMETER, PUBLIC :: GRID_BACKEND_AUTO = 10
65 : INTEGER, PARAMETER, PUBLIC :: GRID_BACKEND_REF = 11
66 : INTEGER, PARAMETER, PUBLIC :: GRID_BACKEND_CPU = 12
67 : INTEGER, PARAMETER, PUBLIC :: GRID_BACKEND_DGEMM = 13
68 : INTEGER, PARAMETER, PUBLIC :: GRID_BACKEND_GPU = 14
69 : INTEGER, PARAMETER, PUBLIC :: GRID_BACKEND_HIP = 15
70 :
71 : PUBLIC :: grid_library_init, grid_library_finalize
72 : PUBLIC :: grid_library_set_config, grid_library_print_stats
73 : PUBLIC :: collocate_pgf_product, integrate_pgf_product
74 : PUBLIC :: grid_basis_set_type, grid_create_basis_set, grid_free_basis_set
75 : PUBLIC :: grid_task_list_type, grid_create_task_list, grid_free_task_list
76 : PUBLIC :: grid_collocate_task_list, grid_integrate_task_list
77 :
78 : TYPE grid_basis_set_type
79 : PRIVATE
80 : TYPE(C_PTR) :: c_ptr = C_NULL_PTR
81 : END TYPE grid_basis_set_type
82 :
83 : TYPE grid_task_list_type
84 : PRIVATE
85 : TYPE(C_PTR) :: c_ptr = C_NULL_PTR
86 : END TYPE grid_task_list_type
87 :
88 : CONTAINS
89 :
90 : ! **************************************************************************************************
91 : !> \brief low level collocation of primitive gaussian functions
92 : !> \param la_max ...
93 : !> \param zeta ...
94 : !> \param la_min ...
95 : !> \param lb_max ...
96 : !> \param zetb ...
97 : !> \param lb_min ...
98 : !> \param ra ...
99 : !> \param rab ...
100 : !> \param scale ...
101 : !> \param pab ...
102 : !> \param o1 ...
103 : !> \param o2 ...
104 : !> \param rsgrid ...
105 : !> \param ga_gb_function ...
106 : !> \param radius ...
107 : !> \param use_subpatch ...
108 : !> \param subpatch_pattern ...
109 : !> \author Ole Schuett
110 : ! **************************************************************************************************
111 1156685 : SUBROUTINE collocate_pgf_product(la_max, zeta, la_min, &
112 : lb_max, zetb, lb_min, &
113 : ra, rab, scale, pab, o1, o2, &
114 : rsgrid, &
115 : ga_gb_function, radius, &
116 : use_subpatch, subpatch_pattern)
117 :
118 : INTEGER, INTENT(IN) :: la_max
119 : REAL(KIND=dp), INTENT(IN) :: zeta
120 : INTEGER, INTENT(IN) :: la_min, lb_max
121 : REAL(KIND=dp), INTENT(IN) :: zetb
122 : INTEGER, INTENT(IN) :: lb_min
123 : REAL(KIND=dp), DIMENSION(3), INTENT(IN), TARGET :: ra, rab
124 : REAL(KIND=dp), INTENT(IN) :: scale
125 : REAL(KIND=dp), DIMENSION(:, :), POINTER :: pab
126 : INTEGER, INTENT(IN) :: o1, o2
127 : TYPE(realspace_grid_type) :: rsgrid
128 : INTEGER, INTENT(IN) :: ga_gb_function
129 : REAL(KIND=dp), INTENT(IN) :: radius
130 : LOGICAL, OPTIONAL :: use_subpatch
131 : INTEGER, INTENT(IN), OPTIONAL :: subpatch_pattern
132 :
133 : INTEGER :: border_mask
134 : INTEGER, DIMENSION(3), TARGET :: border_width, npts_global, npts_local, &
135 : shift_local
136 : LOGICAL(KIND=C_BOOL) :: orthorhombic
137 1156685 : REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: grid
138 : INTERFACE
139 : SUBROUTINE grid_cpu_collocate_pgf_product_c(orthorhombic, &
140 : border_mask, func, &
141 : la_max, la_min, lb_max, lb_min, &
142 : zeta, zetb, rscale, dh, dh_inv, ra, rab, &
143 : npts_global, npts_local, shift_local, border_width, &
144 : radius, o1, o2, n1, n2, pab, &
145 : grid) &
146 : BIND(C, name="grid_cpu_collocate_pgf_product")
147 : IMPORT :: C_PTR, C_INT, C_DOUBLE, C_BOOL
148 : LOGICAL(KIND=C_BOOL), VALUE :: orthorhombic
149 : INTEGER(KIND=C_INT), VALUE :: border_mask
150 : INTEGER(KIND=C_INT), VALUE :: func
151 : INTEGER(KIND=C_INT), VALUE :: la_max
152 : INTEGER(KIND=C_INT), VALUE :: la_min
153 : INTEGER(KIND=C_INT), VALUE :: lb_max
154 : INTEGER(KIND=C_INT), VALUE :: lb_min
155 : REAL(KIND=C_DOUBLE), VALUE :: zeta
156 : REAL(KIND=C_DOUBLE), VALUE :: zetb
157 : REAL(KIND=C_DOUBLE), VALUE :: rscale
158 : TYPE(C_PTR), VALUE :: dh
159 : TYPE(C_PTR), VALUE :: dh_inv
160 : TYPE(C_PTR), VALUE :: ra
161 : TYPE(C_PTR), VALUE :: rab
162 : TYPE(C_PTR), VALUE :: npts_global
163 : TYPE(C_PTR), VALUE :: npts_local
164 : TYPE(C_PTR), VALUE :: shift_local
165 : TYPE(C_PTR), VALUE :: border_width
166 : REAL(KIND=C_DOUBLE), VALUE :: radius
167 : INTEGER(KIND=C_INT), VALUE :: o1
168 : INTEGER(KIND=C_INT), VALUE :: o2
169 : INTEGER(KIND=C_INT), VALUE :: n1
170 : INTEGER(KIND=C_INT), VALUE :: n2
171 : TYPE(C_PTR), VALUE :: pab
172 : TYPE(C_PTR), VALUE :: grid
173 : END SUBROUTINE grid_cpu_collocate_pgf_product_c
174 : END INTERFACE
175 :
176 1156685 : border_mask = 0
177 1156685 : IF (PRESENT(use_subpatch)) THEN
178 69589 : IF (use_subpatch) THEN
179 58753 : CPASSERT(PRESENT(subpatch_pattern))
180 58753 : border_mask = IAND(63, NOT(subpatch_pattern)) ! invert last 6 bits
181 : END IF
182 : END IF
183 :
184 1156685 : orthorhombic = LOGICAL(rsgrid%desc%orthorhombic, C_BOOL)
185 :
186 1156685 : CPASSERT(LBOUND(pab, 1) == 1)
187 1156685 : CPASSERT(LBOUND(pab, 2) == 1)
188 :
189 : CALL get_rsgrid_properties(rsgrid, npts_global=npts_global, &
190 : npts_local=npts_local, &
191 : shift_local=shift_local, &
192 1156685 : border_width=border_width)
193 :
194 1156685 : grid(1:, 1:, 1:) => rsgrid%r(:, :, :) ! pointer assignment
195 :
196 : #if __GNUC__ >= 9
197 : CPASSERT(IS_CONTIGUOUS(rsgrid%desc%dh))
198 : CPASSERT(IS_CONTIGUOUS(rsgrid%desc%dh_inv))
199 : CPASSERT(IS_CONTIGUOUS(ra))
200 : CPASSERT(IS_CONTIGUOUS(rab))
201 : CPASSERT(IS_CONTIGUOUS(npts_global))
202 : CPASSERT(IS_CONTIGUOUS(npts_local))
203 : CPASSERT(IS_CONTIGUOUS(shift_local))
204 : CPASSERT(IS_CONTIGUOUS(border_width))
205 1156685 : CPASSERT(IS_CONTIGUOUS(pab))
206 1156685 : CPASSERT(IS_CONTIGUOUS(grid))
207 : #endif
208 :
209 : ! For collocating a single pgf product we use the optimized cpu backend.
210 :
211 : CALL grid_cpu_collocate_pgf_product_c(orthorhombic=orthorhombic, &
212 : border_mask=border_mask, &
213 : func=ga_gb_function, &
214 : la_max=la_max, &
215 : la_min=la_min, &
216 : lb_max=lb_max, &
217 : lb_min=lb_min, &
218 : zeta=zeta, &
219 : zetb=zetb, &
220 : rscale=scale, &
221 : dh=C_LOC(rsgrid%desc%dh(1, 1)), &
222 : dh_inv=C_LOC(rsgrid%desc%dh_inv(1, 1)), &
223 : ra=C_LOC(ra(1)), &
224 : rab=C_LOC(rab(1)), &
225 : npts_global=C_LOC(npts_global(1)), &
226 : npts_local=C_LOC(npts_local(1)), &
227 : shift_local=C_LOC(shift_local(1)), &
228 : border_width=C_LOC(border_width(1)), &
229 : radius=radius, &
230 : o1=o1, &
231 : o2=o2, &
232 : n1=SIZE(pab, 1), &
233 : n2=SIZE(pab, 2), &
234 : pab=C_LOC(pab(1, 1)), &
235 1156685 : grid=C_LOC(grid(1, 1, 1)))
236 :
237 1156685 : END SUBROUTINE collocate_pgf_product
238 :
239 : ! **************************************************************************************************
240 : !> \brief low level function to compute matrix elements of primitive gaussian functions
241 : !> \param la_max ...
242 : !> \param zeta ...
243 : !> \param la_min ...
244 : !> \param lb_max ...
245 : !> \param zetb ...
246 : !> \param lb_min ...
247 : !> \param ra ...
248 : !> \param rab ...
249 : !> \param rsgrid ...
250 : !> \param hab ...
251 : !> \param pab ...
252 : !> \param o1 ...
253 : !> \param o2 ...
254 : !> \param radius ...
255 : !> \param calculate_forces ...
256 : !> \param force_a ...
257 : !> \param force_b ...
258 : !> \param compute_tau ...
259 : !> \param use_virial ...
260 : !> \param my_virial_a ...
261 : !> \param my_virial_b ...
262 : !> \param hdab Derivative with respect to the primitive on the left.
263 : !> \param hadb Derivative with respect to the primitive on the right.
264 : !> \param a_hdab ...
265 : !> \param use_subpatch ...
266 : !> \param subpatch_pattern ...
267 : ! **************************************************************************************************
268 905518 : SUBROUTINE integrate_pgf_product(la_max, zeta, la_min, &
269 : lb_max, zetb, lb_min, &
270 : ra, rab, rsgrid, &
271 : hab, pab, o1, o2, &
272 : radius, &
273 : calculate_forces, force_a, force_b, &
274 : compute_tau, &
275 : use_virial, my_virial_a, &
276 : my_virial_b, hdab, hadb, a_hdab, use_subpatch, subpatch_pattern)
277 :
278 : INTEGER, INTENT(IN) :: la_max
279 : REAL(KIND=dp), INTENT(IN) :: zeta
280 : INTEGER, INTENT(IN) :: la_min, lb_max
281 : REAL(KIND=dp), INTENT(IN) :: zetb
282 : INTEGER, INTENT(IN) :: lb_min
283 : REAL(KIND=dp), DIMENSION(3), INTENT(IN), TARGET :: ra, rab
284 : TYPE(realspace_grid_type), INTENT(IN) :: rsgrid
285 : REAL(KIND=dp), DIMENSION(:, :), POINTER :: hab
286 : REAL(KIND=dp), DIMENSION(:, :), OPTIONAL, POINTER :: pab
287 : INTEGER, INTENT(IN) :: o1, o2
288 : REAL(KIND=dp), INTENT(IN) :: radius
289 : LOGICAL, INTENT(IN) :: calculate_forces
290 : REAL(KIND=dp), DIMENSION(3), INTENT(INOUT), &
291 : OPTIONAL :: force_a, force_b
292 : LOGICAL, INTENT(IN), OPTIONAL :: compute_tau, use_virial
293 : REAL(KIND=dp), DIMENSION(3, 3), OPTIONAL :: my_virial_a, my_virial_b
294 : REAL(KIND=dp), DIMENSION(:, :, :), OPTIONAL, &
295 : POINTER :: hdab, hadb
296 : REAL(KIND=dp), DIMENSION(:, :, :, :), OPTIONAL, &
297 : POINTER :: a_hdab
298 : LOGICAL, OPTIONAL :: use_subpatch
299 : INTEGER, INTENT(IN), OPTIONAL :: subpatch_pattern
300 :
301 : INTEGER :: border_mask
302 : INTEGER, DIMENSION(3), TARGET :: border_width, npts_global, npts_local, &
303 : shift_local
304 : LOGICAL :: my_use_virial
305 : LOGICAL(KIND=C_BOOL) :: my_compute_tau, orthorhombic
306 : REAL(KIND=dp), DIMENSION(3, 2), TARGET :: forces
307 : REAL(KIND=dp), DIMENSION(3, 3, 2), TARGET :: virials
308 905518 : REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: grid
309 : TYPE(C_PTR) :: a_hdab_cptr, forces_cptr, hadb_cptr, &
310 : hdab_cptr, pab_cptr, virials_cptr
311 : INTERFACE
312 : SUBROUTINE grid_cpu_integrate_pgf_product_c(orthorhombic, compute_tau, &
313 : border_mask, &
314 : la_max, la_min, lb_max, lb_min, &
315 : zeta, zetb, dh, dh_inv, ra, rab, &
316 : npts_global, npts_local, shift_local, border_width, &
317 : radius, o1, o2, n1, n2, grid, hab, pab, &
318 : forces, virials, hdab, hadb, a_hdab) &
319 : BIND(C, name="grid_cpu_integrate_pgf_product")
320 : IMPORT :: C_PTR, C_INT, C_DOUBLE, C_BOOL
321 : LOGICAL(KIND=C_BOOL), VALUE :: orthorhombic
322 : LOGICAL(KIND=C_BOOL), VALUE :: compute_tau
323 : INTEGER(KIND=C_INT), VALUE :: border_mask
324 : INTEGER(KIND=C_INT), VALUE :: la_max
325 : INTEGER(KIND=C_INT), VALUE :: la_min
326 : INTEGER(KIND=C_INT), VALUE :: lb_max
327 : INTEGER(KIND=C_INT), VALUE :: lb_min
328 : REAL(KIND=C_DOUBLE), VALUE :: zeta
329 : REAL(KIND=C_DOUBLE), VALUE :: zetb
330 : TYPE(C_PTR), VALUE :: dh
331 : TYPE(C_PTR), VALUE :: dh_inv
332 : TYPE(C_PTR), VALUE :: ra
333 : TYPE(C_PTR), VALUE :: rab
334 : TYPE(C_PTR), VALUE :: npts_global
335 : TYPE(C_PTR), VALUE :: npts_local
336 : TYPE(C_PTR), VALUE :: shift_local
337 : TYPE(C_PTR), VALUE :: border_width
338 : REAL(KIND=C_DOUBLE), VALUE :: radius
339 : INTEGER(KIND=C_INT), VALUE :: o1
340 : INTEGER(KIND=C_INT), VALUE :: o2
341 : INTEGER(KIND=C_INT), VALUE :: n1
342 : INTEGER(KIND=C_INT), VALUE :: n2
343 : TYPE(C_PTR), VALUE :: grid
344 : TYPE(C_PTR), VALUE :: hab
345 : TYPE(C_PTR), VALUE :: pab
346 : TYPE(C_PTR), VALUE :: forces
347 : TYPE(C_PTR), VALUE :: virials
348 : TYPE(C_PTR), VALUE :: hdab
349 : TYPE(C_PTR), VALUE :: hadb
350 : TYPE(C_PTR), VALUE :: a_hdab
351 : END SUBROUTINE grid_cpu_integrate_pgf_product_c
352 : END INTERFACE
353 :
354 905518 : IF (radius == 0.0_dp) THEN
355 0 : RETURN
356 : END IF
357 :
358 905518 : border_mask = 0
359 905518 : IF (PRESENT(use_subpatch)) THEN
360 859932 : IF (use_subpatch) THEN
361 52149 : CPASSERT(PRESENT(subpatch_pattern))
362 52149 : border_mask = IAND(63, NOT(subpatch_pattern)) ! invert last 6 bits
363 : END IF
364 : END IF
365 :
366 : ! When true then 0.5 * (nabla x_a).(v(r) nabla x_b) is computed.
367 905518 : IF (PRESENT(compute_tau)) THEN
368 3612 : my_compute_tau = LOGICAL(compute_tau, C_BOOL)
369 : ELSE
370 : my_compute_tau = .FALSE.
371 : END IF
372 :
373 905518 : IF (PRESENT(use_virial)) THEN
374 400224 : my_use_virial = use_virial
375 : ELSE
376 : my_use_virial = .FALSE.
377 : END IF
378 :
379 905518 : IF (calculate_forces) THEN
380 365632 : CPASSERT(PRESENT(pab))
381 365632 : pab_cptr = C_LOC(pab(1, 1))
382 365632 : forces(:, :) = 0.0_dp
383 365632 : forces_cptr = C_LOC(forces(1, 1))
384 : ELSE
385 : pab_cptr = C_NULL_PTR
386 : forces_cptr = C_NULL_PTR
387 : END IF
388 :
389 905518 : IF (calculate_forces .AND. my_use_virial) THEN
390 80120 : virials(:, :, :) = 0.0_dp
391 80120 : virials_cptr = C_LOC(virials(1, 1, 1))
392 : ELSE
393 : virials_cptr = C_NULL_PTR
394 : END IF
395 :
396 905518 : IF (calculate_forces .AND. PRESENT(hdab)) THEN
397 2803 : hdab_cptr = C_LOC(hdab(1, 1, 1))
398 : ELSE
399 : hdab_cptr = C_NULL_PTR
400 : END IF
401 :
402 905518 : IF (calculate_forces .AND. PRESENT(hadb)) THEN
403 1806 : hadb_cptr = C_LOC(hadb(1, 1, 1))
404 : ELSE
405 : hadb_cptr = C_NULL_PTR
406 : END IF
407 :
408 905518 : IF (calculate_forces .AND. my_use_virial .AND. PRESENT(a_hdab)) THEN
409 36 : a_hdab_cptr = C_LOC(a_hdab(1, 1, 1, 1))
410 : ELSE
411 : a_hdab_cptr = C_NULL_PTR
412 : END IF
413 :
414 905518 : orthorhombic = LOGICAL(rsgrid%desc%orthorhombic, C_BOOL)
415 :
416 : CALL get_rsgrid_properties(rsgrid, npts_global=npts_global, &
417 : npts_local=npts_local, &
418 : shift_local=shift_local, &
419 905518 : border_width=border_width)
420 :
421 905518 : grid(1:, 1:, 1:) => rsgrid%r(:, :, :) ! pointer assignment
422 :
423 : #if __GNUC__ >= 9
424 : CPASSERT(IS_CONTIGUOUS(rsgrid%desc%dh))
425 : CPASSERT(IS_CONTIGUOUS(rsgrid%desc%dh_inv))
426 : CPASSERT(IS_CONTIGUOUS(ra))
427 : CPASSERT(IS_CONTIGUOUS(rab))
428 : CPASSERT(IS_CONTIGUOUS(npts_global))
429 : CPASSERT(IS_CONTIGUOUS(npts_local))
430 : CPASSERT(IS_CONTIGUOUS(shift_local))
431 : CPASSERT(IS_CONTIGUOUS(border_width))
432 905518 : CPASSERT(IS_CONTIGUOUS(grid))
433 905518 : CPASSERT(IS_CONTIGUOUS(hab))
434 : CPASSERT(IS_CONTIGUOUS(forces))
435 : CPASSERT(IS_CONTIGUOUS(virials))
436 905518 : IF (PRESENT(pab)) THEN
437 403859 : CPASSERT(IS_CONTIGUOUS(pab))
438 : END IF
439 905518 : IF (PRESENT(hdab)) THEN
440 27694 : CPASSERT(IS_CONTIGUOUS(hdab))
441 : END IF
442 905518 : IF (PRESENT(a_hdab)) THEN
443 25888 : CPASSERT(IS_CONTIGUOUS(a_hdab))
444 : END IF
445 : #endif
446 :
447 : CALL grid_cpu_integrate_pgf_product_c(orthorhombic=orthorhombic, &
448 : compute_tau=my_compute_tau, &
449 : border_mask=border_mask, &
450 : la_max=la_max, &
451 : la_min=la_min, &
452 : lb_max=lb_max, &
453 : lb_min=lb_min, &
454 : zeta=zeta, &
455 : zetb=zetb, &
456 : dh=C_LOC(rsgrid%desc%dh(1, 1)), &
457 : dh_inv=C_LOC(rsgrid%desc%dh_inv(1, 1)), &
458 : ra=C_LOC(ra(1)), &
459 : rab=C_LOC(rab(1)), &
460 : npts_global=C_LOC(npts_global(1)), &
461 : npts_local=C_LOC(npts_local(1)), &
462 : shift_local=C_LOC(shift_local(1)), &
463 : border_width=C_LOC(border_width(1)), &
464 : radius=radius, &
465 : o1=o1, &
466 : o2=o2, &
467 : n1=SIZE(hab, 1), &
468 : n2=SIZE(hab, 2), &
469 : grid=C_LOC(grid(1, 1, 1)), &
470 : hab=C_LOC(hab(1, 1)), &
471 : pab=pab_cptr, &
472 : forces=forces_cptr, &
473 : virials=virials_cptr, &
474 : hdab=hdab_cptr, &
475 : hadb=hadb_cptr, &
476 905518 : a_hdab=a_hdab_cptr)
477 :
478 905518 : IF (PRESENT(force_a) .AND. C_ASSOCIATED(forces_cptr)) &
479 1448892 : force_a = force_a + forces(:, 1)
480 905518 : IF (PRESENT(force_b) .AND. C_ASSOCIATED(forces_cptr)) &
481 1448892 : force_b = force_b + forces(:, 2)
482 905518 : IF (PRESENT(my_virial_a) .AND. C_ASSOCIATED(virials_cptr)) &
483 1041560 : my_virial_a = my_virial_a + virials(:, :, 1)
484 905518 : IF (PRESENT(my_virial_b) .AND. C_ASSOCIATED(virials_cptr)) &
485 1041560 : my_virial_b = my_virial_b + virials(:, :, 2)
486 :
487 905518 : END SUBROUTINE integrate_pgf_product
488 :
489 : ! **************************************************************************************************
490 : !> \brief Helper routines for getting rsgrid properties and asserting underlying assumptions.
491 : !> \param rsgrid ...
492 : !> \param npts_global ...
493 : !> \param npts_local ...
494 : !> \param shift_local ...
495 : !> \param border_width ...
496 : !> \author Ole Schuett
497 : ! **************************************************************************************************
498 2118183 : SUBROUTINE get_rsgrid_properties(rsgrid, npts_global, npts_local, shift_local, border_width)
499 : TYPE(realspace_grid_type), INTENT(IN) :: rsgrid
500 : INTEGER, DIMENSION(:) :: npts_global, npts_local, shift_local, &
501 : border_width
502 :
503 : INTEGER :: i
504 :
505 : ! See rs_grid_create() in ./src/pw/realspace_grid_types.F.
506 4236366 : CPASSERT(LBOUND(rsgrid%r, 1) == rsgrid%lb_local(1))
507 4236366 : CPASSERT(UBOUND(rsgrid%r, 1) == rsgrid%ub_local(1))
508 4236366 : CPASSERT(LBOUND(rsgrid%r, 2) == rsgrid%lb_local(2))
509 4236366 : CPASSERT(UBOUND(rsgrid%r, 2) == rsgrid%ub_local(2))
510 4236366 : CPASSERT(LBOUND(rsgrid%r, 3) == rsgrid%lb_local(3))
511 4236366 : CPASSERT(UBOUND(rsgrid%r, 3) == rsgrid%ub_local(3))
512 :
513 : ! While the rsgrid code assumes that the grid starts at rsgrid%lb,
514 : ! the collocate code assumes that the grid starts at (1,1,1) in Fortran, or (0,0,0) in C.
515 : ! So, a point rp(:) gets the following grid coordinates MODULO(rp(:)/dr(:),npts_global(:))
516 :
517 : ! Number of global grid points in each direction.
518 8472732 : npts_global = rsgrid%desc%ub - rsgrid%desc%lb + 1
519 :
520 : ! Number of local grid points in each direction.
521 8472732 : npts_local = rsgrid%ub_local - rsgrid%lb_local + 1
522 :
523 : ! Number of points the local grid is shifted wrt global grid.
524 8472732 : shift_local = rsgrid%lb_local - rsgrid%desc%lb
525 :
526 : ! Convert rsgrid%desc%border and rsgrid%desc%perd into the more convenient border_width array.
527 8472732 : DO i = 1, 3
528 8472732 : IF (rsgrid%desc%perd(i) == 1) THEN
529 : ! Periodic meaning the grid in this direction is entriely present on every processor.
530 6354113 : CPASSERT(npts_local(i) == npts_global(i))
531 6354113 : CPASSERT(shift_local(i) == 0)
532 : ! No need for halo regions.
533 6354113 : border_width(i) = 0
534 : ELSE
535 : ! Not periodic meaning the grid in this direction is distributed among processors.
536 436 : CPASSERT(npts_local(i) <= npts_global(i))
537 : ! Check bounds of grid section that is owned by this processor.
538 436 : CPASSERT(rsgrid%lb_real(i) == rsgrid%lb_local(i) + rsgrid%desc%border)
539 436 : CPASSERT(rsgrid%ub_real(i) == rsgrid%ub_local(i) - rsgrid%desc%border)
540 : ! We have halo regions.
541 436 : border_width(i) = rsgrid%desc%border
542 : END IF
543 : END DO
544 2118183 : END SUBROUTINE get_rsgrid_properties
545 :
546 : ! **************************************************************************************************
547 : !> \brief Allocates a basis set which can be passed to grid_create_task_list.
548 : !> \param nset ...
549 : !> \param nsgf ...
550 : !> \param maxco ...
551 : !> \param maxpgf ...
552 : !> \param lmin ...
553 : !> \param lmax ...
554 : !> \param npgf ...
555 : !> \param nsgf_set ...
556 : !> \param first_sgf ...
557 : !> \param sphi ...
558 : !> \param zet ...
559 : !> \param basis_set ...
560 : !> \author Ole Schuett
561 : ! **************************************************************************************************
562 14977 : SUBROUTINE grid_create_basis_set(nset, nsgf, maxco, maxpgf, &
563 14977 : lmin, lmax, npgf, nsgf_set, first_sgf, sphi, zet, &
564 : basis_set)
565 : INTEGER, INTENT(IN) :: nset, nsgf, maxco, maxpgf
566 : INTEGER, DIMENSION(:), INTENT(IN), TARGET :: lmin, lmax, npgf, nsgf_set
567 : INTEGER, DIMENSION(:, :), INTENT(IN) :: first_sgf
568 : REAL(KIND=dp), DIMENSION(:, :), INTENT(IN), TARGET :: sphi, zet
569 : TYPE(grid_basis_set_type), INTENT(INOUT) :: basis_set
570 :
571 : CHARACTER(LEN=*), PARAMETER :: routineN = 'grid_create_basis_set'
572 :
573 : INTEGER :: handle
574 29954 : INTEGER, DIMENSION(nset), TARGET :: my_first_sgf
575 : TYPE(C_PTR) :: first_sgf_c, lmax_c, lmin_c, npgf_c, &
576 : nsgf_set_c, sphi_c, zet_c
577 : INTERFACE
578 : SUBROUTINE grid_create_basis_set_c(nset, nsgf, maxco, maxpgf, &
579 : lmin, lmax, npgf, nsgf_set, first_sgf, sphi, zet, &
580 : basis_set) &
581 : BIND(C, name="grid_create_basis_set")
582 : IMPORT :: C_PTR, C_INT
583 : INTEGER(KIND=C_INT), VALUE :: nset
584 : INTEGER(KIND=C_INT), VALUE :: nsgf
585 : INTEGER(KIND=C_INT), VALUE :: maxco
586 : INTEGER(KIND=C_INT), VALUE :: maxpgf
587 : TYPE(C_PTR), VALUE :: lmin
588 : TYPE(C_PTR), VALUE :: lmax
589 : TYPE(C_PTR), VALUE :: npgf
590 : TYPE(C_PTR), VALUE :: nsgf_set
591 : TYPE(C_PTR), VALUE :: first_sgf
592 : TYPE(C_PTR), VALUE :: sphi
593 : TYPE(C_PTR), VALUE :: zet
594 : TYPE(C_PTR) :: basis_set
595 : END SUBROUTINE grid_create_basis_set_c
596 : END INTERFACE
597 :
598 14977 : CALL timeset(routineN, handle)
599 :
600 14977 : CPASSERT(SIZE(lmin) == nset)
601 14977 : CPASSERT(SIZE(lmin) == nset)
602 14977 : CPASSERT(SIZE(lmax) == nset)
603 14977 : CPASSERT(SIZE(npgf) == nset)
604 14977 : CPASSERT(SIZE(nsgf_set) == nset)
605 14977 : CPASSERT(SIZE(first_sgf, 2) == nset)
606 14977 : CPASSERT(SIZE(sphi, 1) == maxco .AND. SIZE(sphi, 2) == nsgf)
607 14977 : CPASSERT(SIZE(zet, 1) == maxpgf .AND. SIZE(zet, 2) == nset)
608 14977 : CPASSERT(.NOT. C_ASSOCIATED(basis_set%c_ptr))
609 :
610 : #if __GNUC__ >= 9
611 14977 : CPASSERT(IS_CONTIGUOUS(lmin))
612 14977 : CPASSERT(IS_CONTIGUOUS(lmax))
613 14977 : CPASSERT(IS_CONTIGUOUS(npgf))
614 14977 : CPASSERT(IS_CONTIGUOUS(nsgf_set))
615 : CPASSERT(IS_CONTIGUOUS(my_first_sgf))
616 14977 : CPASSERT(IS_CONTIGUOUS(sphi))
617 14977 : CPASSERT(IS_CONTIGUOUS(zet))
618 : #endif
619 :
620 14977 : lmin_c = C_NULL_PTR
621 14977 : lmax_c = C_NULL_PTR
622 14977 : npgf_c = C_NULL_PTR
623 14977 : nsgf_set_c = C_NULL_PTR
624 14977 : first_sgf_c = C_NULL_PTR
625 14977 : sphi_c = C_NULL_PTR
626 14977 : zet_c = C_NULL_PTR
627 :
628 : ! Basis sets arrays can be empty, need to check before accessing the first element.
629 14977 : IF (nset > 0) THEN
630 14969 : lmin_c = C_LOC(lmin(1))
631 14969 : lmax_c = C_LOC(lmax(1))
632 14969 : npgf_c = C_LOC(npgf(1))
633 14969 : nsgf_set_c = C_LOC(nsgf_set(1))
634 : END IF
635 44931 : IF (SIZE(first_sgf) > 0) THEN
636 49648 : my_first_sgf(:) = first_sgf(1, :) ! make a contiguous copy
637 14969 : first_sgf_c = C_LOC(my_first_sgf(1))
638 : END IF
639 44931 : IF (SIZE(sphi) > 0) THEN
640 14967 : sphi_c = C_LOC(sphi(1, 1))
641 : END IF
642 44931 : IF (SIZE(zet) > 0) THEN
643 14967 : zet_c = C_LOC(zet(1, 1))
644 : END IF
645 :
646 : CALL grid_create_basis_set_c(nset=nset, &
647 : nsgf=nsgf, &
648 : maxco=maxco, &
649 : maxpgf=maxpgf, &
650 : lmin=lmin_c, &
651 : lmax=lmax_c, &
652 : npgf=npgf_c, &
653 : nsgf_set=nsgf_set_c, &
654 : first_sgf=first_sgf_c, &
655 : sphi=sphi_c, &
656 : zet=zet_c, &
657 14977 : basis_set=basis_set%c_ptr)
658 14977 : CPASSERT(C_ASSOCIATED(basis_set%c_ptr))
659 :
660 14977 : CALL timestop(handle)
661 14977 : END SUBROUTINE grid_create_basis_set
662 :
663 : ! **************************************************************************************************
664 : !> \brief Deallocates given basis set.
665 : !> \param basis_set ...
666 : !> \author Ole Schuett
667 : ! **************************************************************************************************
668 14977 : SUBROUTINE grid_free_basis_set(basis_set)
669 : TYPE(grid_basis_set_type), INTENT(INOUT) :: basis_set
670 :
671 : CHARACTER(LEN=*), PARAMETER :: routineN = 'grid_free_basis_set'
672 :
673 : INTEGER :: handle
674 : INTERFACE
675 : SUBROUTINE grid_free_basis_set_c(basis_set) &
676 : BIND(C, name="grid_free_basis_set")
677 : IMPORT :: C_PTR
678 : TYPE(C_PTR), VALUE :: basis_set
679 : END SUBROUTINE grid_free_basis_set_c
680 : END INTERFACE
681 :
682 14977 : CALL timeset(routineN, handle)
683 :
684 14977 : CPASSERT(C_ASSOCIATED(basis_set%c_ptr))
685 :
686 14977 : CALL grid_free_basis_set_c(basis_set%c_ptr)
687 :
688 14977 : basis_set%c_ptr = C_NULL_PTR
689 :
690 14977 : CALL timestop(handle)
691 14977 : END SUBROUTINE grid_free_basis_set
692 :
693 : ! **************************************************************************************************
694 : !> \brief Allocates a task list which can be passed to grid_collocate_task_list.
695 : !> \param ntasks ...
696 : !> \param natoms ...
697 : !> \param nkinds ...
698 : !> \param nblocks ...
699 : !> \param block_offsets ...
700 : !> \param atom_positions ...
701 : !> \param atom_kinds ...
702 : !> \param basis_sets ...
703 : !> \param level_list ...
704 : !> \param iatom_list ...
705 : !> \param jatom_list ...
706 : !> \param iset_list ...
707 : !> \param jset_list ...
708 : !> \param ipgf_list ...
709 : !> \param jpgf_list ...
710 : !> \param border_mask_list ...
711 : !> \param block_num_list ...
712 : !> \param radius_list ...
713 : !> \param rab_list ...
714 : !> \param rs_grids ...
715 : !> \param task_list ...
716 : !> \author Ole Schuett
717 : ! **************************************************************************************************
718 14110 : SUBROUTINE grid_create_task_list(ntasks, natoms, nkinds, nblocks, &
719 14110 : block_offsets, atom_positions, atom_kinds, basis_sets, &
720 14110 : level_list, iatom_list, jatom_list, &
721 14110 : iset_list, jset_list, ipgf_list, jpgf_list, &
722 14110 : border_mask_list, block_num_list, &
723 14110 : radius_list, rab_list, rs_grids, task_list)
724 :
725 : INTEGER, INTENT(IN) :: ntasks, natoms, nkinds, nblocks
726 : INTEGER, DIMENSION(:), INTENT(IN), TARGET :: block_offsets
727 : REAL(KIND=dp), DIMENSION(:, :), INTENT(IN), TARGET :: atom_positions
728 : INTEGER, DIMENSION(:), INTENT(IN), TARGET :: atom_kinds
729 : TYPE(grid_basis_set_type), DIMENSION(:), &
730 : INTENT(IN), TARGET :: basis_sets
731 : INTEGER, DIMENSION(:), INTENT(IN), TARGET :: level_list, iatom_list, jatom_list, &
732 : iset_list, jset_list, ipgf_list, &
733 : jpgf_list, border_mask_list, &
734 : block_num_list
735 : REAL(KIND=dp), DIMENSION(:), INTENT(IN), TARGET :: radius_list
736 : REAL(KIND=dp), DIMENSION(:, :), INTENT(IN), TARGET :: rab_list
737 : TYPE(realspace_grid_type), DIMENSION(:), &
738 : INTENT(IN) :: rs_grids
739 : TYPE(grid_task_list_type), INTENT(INOUT) :: task_list
740 :
741 : CHARACTER(LEN=*), PARAMETER :: routineN = 'grid_create_task_list'
742 :
743 : INTEGER :: handle, ikind, ilevel, nlevels
744 14110 : INTEGER, ALLOCATABLE, DIMENSION(:, :), TARGET :: border_width, npts_global, npts_local, &
745 14110 : shift_local
746 : LOGICAL(KIND=C_BOOL) :: orthorhombic
747 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :), &
748 14110 : TARGET :: dh, dh_inv
749 : TYPE(C_PTR) :: block_num_list_c, block_offsets_c, border_mask_list_c, iatom_list_c, &
750 : ipgf_list_c, iset_list_c, jatom_list_c, jpgf_list_c, jset_list_c, level_list_c, &
751 : rab_list_c, radius_list_c
752 14110 : TYPE(C_PTR), ALLOCATABLE, DIMENSION(:), TARGET :: basis_sets_c
753 : INTERFACE
754 : SUBROUTINE grid_create_task_list_c(orthorhombic, &
755 : ntasks, nlevels, natoms, nkinds, nblocks, &
756 : block_offsets, atom_positions, atom_kinds, basis_sets, &
757 : level_list, iatom_list, jatom_list, &
758 : iset_list, jset_list, ipgf_list, jpgf_list, &
759 : border_mask_list, block_num_list, &
760 : radius_list, rab_list, &
761 : npts_global, npts_local, shift_local, &
762 : border_width, dh, dh_inv, task_list) &
763 : BIND(C, name="grid_create_task_list")
764 : IMPORT :: C_PTR, C_INT, C_BOOL
765 : LOGICAL(KIND=C_BOOL), VALUE :: orthorhombic
766 : INTEGER(KIND=C_INT), VALUE :: ntasks
767 : INTEGER(KIND=C_INT), VALUE :: nlevels
768 : INTEGER(KIND=C_INT), VALUE :: natoms
769 : INTEGER(KIND=C_INT), VALUE :: nkinds
770 : INTEGER(KIND=C_INT), VALUE :: nblocks
771 : TYPE(C_PTR), VALUE :: block_offsets
772 : TYPE(C_PTR), VALUE :: atom_positions
773 : TYPE(C_PTR), VALUE :: atom_kinds
774 : TYPE(C_PTR), VALUE :: basis_sets
775 : TYPE(C_PTR), VALUE :: level_list
776 : TYPE(C_PTR), VALUE :: iatom_list
777 : TYPE(C_PTR), VALUE :: jatom_list
778 : TYPE(C_PTR), VALUE :: iset_list
779 : TYPE(C_PTR), VALUE :: jset_list
780 : TYPE(C_PTR), VALUE :: ipgf_list
781 : TYPE(C_PTR), VALUE :: jpgf_list
782 : TYPE(C_PTR), VALUE :: border_mask_list
783 : TYPE(C_PTR), VALUE :: block_num_list
784 : TYPE(C_PTR), VALUE :: radius_list
785 : TYPE(C_PTR), VALUE :: rab_list
786 : TYPE(C_PTR), VALUE :: npts_global
787 : TYPE(C_PTR), VALUE :: npts_local
788 : TYPE(C_PTR), VALUE :: shift_local
789 : TYPE(C_PTR), VALUE :: border_width
790 : TYPE(C_PTR), VALUE :: dh
791 : TYPE(C_PTR), VALUE :: dh_inv
792 : TYPE(C_PTR) :: task_list
793 : END SUBROUTINE grid_create_task_list_c
794 : END INTERFACE
795 :
796 14110 : CALL timeset(routineN, handle)
797 :
798 14110 : CPASSERT(SIZE(block_offsets) == nblocks)
799 14110 : CPASSERT(SIZE(atom_positions, 1) == 3 .AND. SIZE(atom_positions, 2) == natoms)
800 14110 : CPASSERT(SIZE(atom_kinds) == natoms)
801 14110 : CPASSERT(SIZE(basis_sets) == nkinds)
802 14110 : CPASSERT(SIZE(level_list) == ntasks)
803 14110 : CPASSERT(SIZE(iatom_list) == ntasks)
804 14110 : CPASSERT(SIZE(jatom_list) == ntasks)
805 14110 : CPASSERT(SIZE(iset_list) == ntasks)
806 14110 : CPASSERT(SIZE(jset_list) == ntasks)
807 14110 : CPASSERT(SIZE(ipgf_list) == ntasks)
808 14110 : CPASSERT(SIZE(jpgf_list) == ntasks)
809 14110 : CPASSERT(SIZE(border_mask_list) == ntasks)
810 14110 : CPASSERT(SIZE(block_num_list) == ntasks)
811 14110 : CPASSERT(SIZE(radius_list) == ntasks)
812 14110 : CPASSERT(SIZE(rab_list, 1) == 3 .AND. SIZE(rab_list, 2) == ntasks)
813 :
814 42330 : ALLOCATE (basis_sets_c(nkinds))
815 39275 : DO ikind = 1, nkinds
816 39275 : basis_sets_c(ikind) = basis_sets(ikind)%c_ptr
817 : END DO
818 :
819 14110 : nlevels = SIZE(rs_grids)
820 14110 : CPASSERT(nlevels > 0)
821 14110 : orthorhombic = LOGICAL(rs_grids(1)%desc%orthorhombic, C_BOOL)
822 :
823 56440 : ALLOCATE (npts_global(3, nlevels), npts_local(3, nlevels))
824 42330 : ALLOCATE (shift_local(3, nlevels), border_width(3, nlevels))
825 56440 : ALLOCATE (dh(3, 3, nlevels), dh_inv(3, 3, nlevels))
826 70090 : DO ilevel = 1, nlevels
827 14110 : ASSOCIATE (rsgrid => rs_grids(ilevel))
828 : CALL get_rsgrid_properties(rsgrid=rsgrid, &
829 : npts_global=npts_global(:, ilevel), &
830 : npts_local=npts_local(:, ilevel), &
831 : shift_local=shift_local(:, ilevel), &
832 55980 : border_width=border_width(:, ilevel))
833 55980 : CPASSERT(rsgrid%desc%orthorhombic .EQV. orthorhombic) ! should be the same for all levels
834 727740 : dh(:, :, ilevel) = rsgrid%desc%dh(:, :)
835 783720 : dh_inv(:, :, ilevel) = rsgrid%desc%dh_inv(:, :)
836 : END ASSOCIATE
837 : END DO
838 :
839 : #if __GNUC__ >= 9
840 14110 : CPASSERT(IS_CONTIGUOUS(block_offsets))
841 14110 : CPASSERT(IS_CONTIGUOUS(atom_positions))
842 14110 : CPASSERT(IS_CONTIGUOUS(atom_kinds))
843 14110 : CPASSERT(IS_CONTIGUOUS(basis_sets))
844 14110 : CPASSERT(IS_CONTIGUOUS(level_list))
845 14110 : CPASSERT(IS_CONTIGUOUS(iatom_list))
846 14110 : CPASSERT(IS_CONTIGUOUS(jatom_list))
847 14110 : CPASSERT(IS_CONTIGUOUS(iset_list))
848 14110 : CPASSERT(IS_CONTIGUOUS(jset_list))
849 14110 : CPASSERT(IS_CONTIGUOUS(ipgf_list))
850 14110 : CPASSERT(IS_CONTIGUOUS(jpgf_list))
851 14110 : CPASSERT(IS_CONTIGUOUS(border_mask_list))
852 14110 : CPASSERT(IS_CONTIGUOUS(block_num_list))
853 14110 : CPASSERT(IS_CONTIGUOUS(radius_list))
854 14110 : CPASSERT(IS_CONTIGUOUS(rab_list))
855 : CPASSERT(IS_CONTIGUOUS(npts_global))
856 : CPASSERT(IS_CONTIGUOUS(npts_local))
857 : CPASSERT(IS_CONTIGUOUS(shift_local))
858 : CPASSERT(IS_CONTIGUOUS(border_width))
859 : CPASSERT(IS_CONTIGUOUS(dh))
860 : CPASSERT(IS_CONTIGUOUS(dh_inv))
861 : #endif
862 :
863 14110 : IF (ntasks > 0) THEN
864 : block_offsets_c = C_LOC(block_offsets(1))
865 : level_list_c = C_LOC(level_list(1))
866 : iatom_list_c = C_LOC(iatom_list(1))
867 : jatom_list_c = C_LOC(jatom_list(1))
868 : iset_list_c = C_LOC(iset_list(1))
869 : jset_list_c = C_LOC(jset_list(1))
870 : ipgf_list_c = C_LOC(ipgf_list(1))
871 : jpgf_list_c = C_LOC(jpgf_list(1))
872 : border_mask_list_c = C_LOC(border_mask_list(1))
873 : block_num_list_c = C_LOC(block_num_list(1))
874 : radius_list_c = C_LOC(radius_list(1))
875 : rab_list_c = C_LOC(rab_list(1, 1))
876 : ELSE
877 : ! Without tasks the lists are empty and there is no first element to call C_LOC on.
878 232 : block_offsets_c = C_NULL_PTR
879 232 : level_list_c = C_NULL_PTR
880 232 : iatom_list_c = C_NULL_PTR
881 232 : jatom_list_c = C_NULL_PTR
882 232 : iset_list_c = C_NULL_PTR
883 232 : jset_list_c = C_NULL_PTR
884 232 : ipgf_list_c = C_NULL_PTR
885 232 : jpgf_list_c = C_NULL_PTR
886 232 : border_mask_list_c = C_NULL_PTR
887 232 : block_num_list_c = C_NULL_PTR
888 232 : radius_list_c = C_NULL_PTR
889 232 : rab_list_c = C_NULL_PTR
890 : END IF
891 :
892 : !If task_list%c_ptr is already allocated, then its memory will be reused or freed.
893 : CALL grid_create_task_list_c(orthorhombic=orthorhombic, &
894 : ntasks=ntasks, &
895 : nlevels=nlevels, &
896 : natoms=natoms, &
897 : nkinds=nkinds, &
898 : nblocks=nblocks, &
899 : block_offsets=block_offsets_c, &
900 : atom_positions=C_LOC(atom_positions(1, 1)), &
901 : atom_kinds=C_LOC(atom_kinds(1)), &
902 : basis_sets=C_LOC(basis_sets_c(1)), &
903 : level_list=level_list_c, &
904 : iatom_list=iatom_list_c, &
905 : jatom_list=jatom_list_c, &
906 : iset_list=iset_list_c, &
907 : jset_list=jset_list_c, &
908 : ipgf_list=ipgf_list_c, &
909 : jpgf_list=jpgf_list_c, &
910 : border_mask_list=border_mask_list_c, &
911 : block_num_list=block_num_list_c, &
912 : radius_list=radius_list_c, &
913 : rab_list=rab_list_c, &
914 : npts_global=C_LOC(npts_global(1, 1)), &
915 : npts_local=C_LOC(npts_local(1, 1)), &
916 : shift_local=C_LOC(shift_local(1, 1)), &
917 : border_width=C_LOC(border_width(1, 1)), &
918 : dh=C_LOC(dh(1, 1, 1)), &
919 : dh_inv=C_LOC(dh_inv(1, 1, 1)), &
920 14110 : task_list=task_list%c_ptr)
921 :
922 14110 : CPASSERT(C_ASSOCIATED(task_list%c_ptr))
923 :
924 14110 : CALL timestop(handle)
925 28220 : END SUBROUTINE grid_create_task_list
926 :
927 : ! **************************************************************************************************
928 : !> \brief Deallocates given task list, basis_sets have to be freed separately.
929 : !> \param task_list ...
930 : !> \author Ole Schuett
931 : ! **************************************************************************************************
932 8432 : SUBROUTINE grid_free_task_list(task_list)
933 : TYPE(grid_task_list_type), INTENT(INOUT) :: task_list
934 :
935 : CHARACTER(LEN=*), PARAMETER :: routineN = 'grid_free_task_list'
936 :
937 : INTEGER :: handle
938 : INTERFACE
939 : SUBROUTINE grid_free_task_list_c(task_list) &
940 : BIND(C, name="grid_free_task_list")
941 : IMPORT :: C_PTR
942 : TYPE(C_PTR), VALUE :: task_list
943 : END SUBROUTINE grid_free_task_list_c
944 : END INTERFACE
945 :
946 8432 : CALL timeset(routineN, handle)
947 :
948 8432 : IF (C_ASSOCIATED(task_list%c_ptr)) THEN
949 8432 : CALL grid_free_task_list_c(task_list%c_ptr)
950 : END IF
951 :
952 8432 : task_list%c_ptr = C_NULL_PTR
953 :
954 8432 : CALL timestop(handle)
955 8432 : END SUBROUTINE grid_free_task_list
956 :
957 : ! **************************************************************************************************
958 : !> \brief Collocate all tasks of in given list onto given grids.
959 : !> \param task_list ...
960 : !> \param ga_gb_function ...
961 : !> \param pab_blocks ...
962 : !> \param rs_grids ...
963 : !> \author Ole Schuett
964 : ! **************************************************************************************************
965 208186 : SUBROUTINE grid_collocate_task_list(task_list, ga_gb_function, pab_blocks, rs_grids)
966 : TYPE(grid_task_list_type), INTENT(IN) :: task_list
967 : INTEGER, INTENT(IN) :: ga_gb_function
968 : TYPE(offload_buffer_type), INTENT(IN) :: pab_blocks
969 : TYPE(realspace_grid_type), DIMENSION(:), &
970 : INTENT(IN) :: rs_grids
971 :
972 : CHARACTER(LEN=*), PARAMETER :: routineN = 'grid_collocate_task_list'
973 :
974 : INTEGER :: handle, ilevel, nlevels
975 208186 : INTEGER, ALLOCATABLE, DIMENSION(:, :), TARGET :: npts_local
976 208186 : TYPE(C_PTR), ALLOCATABLE, DIMENSION(:), TARGET :: grids_c
977 : INTERFACE
978 : SUBROUTINE grid_collocate_task_list_c(task_list, func, nlevels, &
979 : npts_local, pab_blocks, grids) &
980 : BIND(C, name="grid_collocate_task_list")
981 : IMPORT :: C_PTR, C_INT, C_BOOL
982 : TYPE(C_PTR), VALUE :: task_list
983 : INTEGER(KIND=C_INT), VALUE :: func
984 : INTEGER(KIND=C_INT), VALUE :: nlevels
985 : TYPE(C_PTR), VALUE :: npts_local
986 : TYPE(C_PTR), VALUE :: pab_blocks
987 : TYPE(C_PTR), VALUE :: grids
988 : END SUBROUTINE grid_collocate_task_list_c
989 : END INTERFACE
990 :
991 208186 : CALL timeset(routineN, handle)
992 :
993 208186 : nlevels = SIZE(rs_grids)
994 208186 : CPASSERT(nlevels > 0)
995 :
996 624558 : ALLOCATE (grids_c(nlevels))
997 624558 : ALLOCATE (npts_local(3, nlevels))
998 1032580 : DO ilevel = 1, nlevels
999 208186 : ASSOCIATE (rsgrid => rs_grids(ilevel))
1000 3297576 : npts_local(:, ilevel) = rsgrid%ub_local - rsgrid%lb_local + 1
1001 1648788 : grids_c(ilevel) = rsgrid%buffer%c_ptr
1002 : END ASSOCIATE
1003 : END DO
1004 :
1005 : #if __GNUC__ >= 9
1006 : CPASSERT(IS_CONTIGUOUS(npts_local))
1007 : CPASSERT(IS_CONTIGUOUS(grids_c))
1008 : #endif
1009 :
1010 208186 : CPASSERT(C_ASSOCIATED(task_list%c_ptr))
1011 208186 : CPASSERT(C_ASSOCIATED(pab_blocks%c_ptr))
1012 :
1013 : CALL grid_collocate_task_list_c(task_list=task_list%c_ptr, &
1014 : func=ga_gb_function, &
1015 : nlevels=nlevels, &
1016 : npts_local=C_LOC(npts_local(1, 1)), &
1017 : pab_blocks=pab_blocks%c_ptr, &
1018 208186 : grids=C_LOC(grids_c(1)))
1019 :
1020 208186 : CALL timestop(handle)
1021 416372 : END SUBROUTINE grid_collocate_task_list
1022 :
1023 : ! **************************************************************************************************
1024 : !> \brief Integrate all tasks of in given list from given grids.
1025 : !> \param task_list ...
1026 : !> \param compute_tau ...
1027 : !> \param calculate_forces ...
1028 : !> \param calculate_virial ...
1029 : !> \param pab_blocks ...
1030 : !> \param rs_grids ...
1031 : !> \param hab_blocks ...
1032 : !> \param forces ...
1033 : !> \param virial ...
1034 : !> \author Ole Schuett
1035 : ! **************************************************************************************************
1036 190818 : SUBROUTINE grid_integrate_task_list(task_list, compute_tau, calculate_forces, calculate_virial, &
1037 190818 : pab_blocks, rs_grids, hab_blocks, forces, virial)
1038 : TYPE(grid_task_list_type), INTENT(IN) :: task_list
1039 : LOGICAL, INTENT(IN) :: compute_tau, calculate_forces, &
1040 : calculate_virial
1041 : TYPE(offload_buffer_type), INTENT(IN) :: pab_blocks
1042 : TYPE(realspace_grid_type), DIMENSION(:), &
1043 : INTENT(IN) :: rs_grids
1044 : TYPE(offload_buffer_type), INTENT(INOUT) :: hab_blocks
1045 : REAL(KIND=dp), DIMENSION(:, :), INTENT(INOUT), &
1046 : TARGET :: forces
1047 : REAL(KIND=dp), DIMENSION(3, 3), INTENT(INOUT), &
1048 : TARGET :: virial
1049 :
1050 : CHARACTER(LEN=*), PARAMETER :: routineN = 'grid_integrate_task_list'
1051 :
1052 : INTEGER :: handle, ilevel, nlevels
1053 190818 : INTEGER, ALLOCATABLE, DIMENSION(:, :), TARGET :: npts_local
1054 : TYPE(C_PTR) :: forces_c, virial_c
1055 190818 : TYPE(C_PTR), ALLOCATABLE, DIMENSION(:), TARGET :: grids_c
1056 : INTERFACE
1057 : SUBROUTINE grid_integrate_task_list_c(task_list, compute_tau, natoms, &
1058 : nlevels, npts_local, &
1059 : pab_blocks, grids, hab_blocks, forces, virial) &
1060 : BIND(C, name="grid_integrate_task_list")
1061 : IMPORT :: C_PTR, C_INT, C_BOOL
1062 : TYPE(C_PTR), VALUE :: task_list
1063 : LOGICAL(KIND=C_BOOL), VALUE :: compute_tau
1064 : INTEGER(KIND=C_INT), VALUE :: natoms
1065 : INTEGER(KIND=C_INT), VALUE :: nlevels
1066 : TYPE(C_PTR), VALUE :: npts_local
1067 : TYPE(C_PTR), VALUE :: pab_blocks
1068 : TYPE(C_PTR), VALUE :: grids
1069 : TYPE(C_PTR), VALUE :: hab_blocks
1070 : TYPE(C_PTR), VALUE :: forces
1071 : TYPE(C_PTR), VALUE :: virial
1072 : END SUBROUTINE grid_integrate_task_list_c
1073 : END INTERFACE
1074 :
1075 190818 : CALL timeset(routineN, handle)
1076 :
1077 190818 : nlevels = SIZE(rs_grids)
1078 190818 : CPASSERT(nlevels > 0)
1079 :
1080 572454 : ALLOCATE (grids_c(nlevels))
1081 572454 : ALLOCATE (npts_local(3, nlevels))
1082 946006 : DO ilevel = 1, nlevels
1083 190818 : ASSOCIATE (rsgrid => rs_grids(ilevel))
1084 3020752 : npts_local(:, ilevel) = rsgrid%ub_local - rsgrid%lb_local + 1
1085 1510376 : grids_c(ilevel) = rsgrid%buffer%c_ptr
1086 : END ASSOCIATE
1087 : END DO
1088 :
1089 190818 : IF (calculate_forces) THEN
1090 : forces_c = C_LOC(forces(1, 1))
1091 : ELSE
1092 167261 : forces_c = C_NULL_PTR
1093 : END IF
1094 :
1095 190818 : IF (calculate_virial) THEN
1096 3609 : virial_c = C_LOC(virial(1, 1))
1097 : ELSE
1098 : virial_c = C_NULL_PTR
1099 : END IF
1100 :
1101 : #if __GNUC__ >= 9
1102 : CPASSERT(IS_CONTIGUOUS(npts_local))
1103 : CPASSERT(IS_CONTIGUOUS(grids_c))
1104 190818 : CPASSERT(IS_CONTIGUOUS(forces))
1105 : CPASSERT(IS_CONTIGUOUS(virial))
1106 : #endif
1107 :
1108 190818 : CPASSERT(SIZE(forces, 1) == 3)
1109 190818 : CPASSERT(C_ASSOCIATED(task_list%c_ptr))
1110 190818 : CPASSERT(C_ASSOCIATED(hab_blocks%c_ptr))
1111 190818 : CPASSERT(C_ASSOCIATED(pab_blocks%c_ptr) .OR. .NOT. calculate_forces)
1112 190818 : CPASSERT(C_ASSOCIATED(pab_blocks%c_ptr) .OR. .NOT. calculate_virial)
1113 :
1114 : CALL grid_integrate_task_list_c(task_list=task_list%c_ptr, &
1115 : compute_tau=LOGICAL(compute_tau, C_BOOL), &
1116 : natoms=SIZE(forces, 2), &
1117 : nlevels=nlevels, &
1118 : npts_local=C_LOC(npts_local(1, 1)), &
1119 : pab_blocks=pab_blocks%c_ptr, &
1120 : grids=C_LOC(grids_c(1)), &
1121 : hab_blocks=hab_blocks%c_ptr, &
1122 : forces=forces_c, &
1123 190818 : virial=virial_c)
1124 :
1125 190818 : CALL timestop(handle)
1126 381636 : END SUBROUTINE grid_integrate_task_list
1127 :
1128 : ! **************************************************************************************************
1129 : !> \brief Initialize grid library
1130 : !> \author Ole Schuett
1131 : ! **************************************************************************************************
1132 9284 : SUBROUTINE grid_library_init()
1133 : INTERFACE
1134 : SUBROUTINE grid_library_init_c() BIND(C, name="grid_library_init")
1135 : END SUBROUTINE grid_library_init_c
1136 : END INTERFACE
1137 :
1138 9284 : CALL grid_library_init_c()
1139 :
1140 9284 : END SUBROUTINE grid_library_init
1141 :
1142 : ! **************************************************************************************************
1143 : !> \brief Finalize grid library
1144 : !> \author Ole Schuett
1145 : ! **************************************************************************************************
1146 9284 : SUBROUTINE grid_library_finalize()
1147 : INTERFACE
1148 : SUBROUTINE grid_library_finalize_c() BIND(C, name="grid_library_finalize")
1149 : END SUBROUTINE grid_library_finalize_c
1150 : END INTERFACE
1151 :
1152 9284 : CALL grid_library_finalize_c()
1153 :
1154 9284 : END SUBROUTINE grid_library_finalize
1155 :
1156 : ! **************************************************************************************************
1157 : !> \brief Configures the grid library
1158 : !> \param backend : backend to be used for collocate/integrate, possible values are REF, CPU, GPU
1159 : !> \param validate : if set to true, compare the results of all backend to the reference backend
1160 : !> \param apply_cutoff : apply a spherical cutoff before collocating or integrating. Only relevant for CPU backend
1161 : !> \author Ole Schuett
1162 : ! **************************************************************************************************
1163 9402 : SUBROUTINE grid_library_set_config(backend, validate, apply_cutoff)
1164 : INTEGER, INTENT(IN) :: backend
1165 : LOGICAL, INTENT(IN) :: validate, apply_cutoff
1166 :
1167 : INTERFACE
1168 : SUBROUTINE grid_library_set_config_c(backend, validate, apply_cutoff) &
1169 : BIND(C, name="grid_library_set_config")
1170 : IMPORT :: C_INT, C_BOOL
1171 : INTEGER(KIND=C_INT), VALUE :: backend
1172 : LOGICAL(KIND=C_BOOL), VALUE :: validate
1173 : LOGICAL(KIND=C_BOOL), VALUE :: apply_cutoff
1174 : END SUBROUTINE grid_library_set_config_c
1175 : END INTERFACE
1176 :
1177 : CALL grid_library_set_config_c(backend=backend, &
1178 : validate=LOGICAL(validate, C_BOOL), &
1179 9402 : apply_cutoff=LOGICAL(apply_cutoff, C_BOOL))
1180 :
1181 9402 : END SUBROUTINE grid_library_set_config
1182 :
1183 : ! **************************************************************************************************
1184 : !> \brief Print grid library statistics
1185 : !> \param mpi_comm ...
1186 : !> \param output_unit ...
1187 : !> \author Ole Schuett
1188 : ! **************************************************************************************************
1189 9402 : SUBROUTINE grid_library_print_stats(mpi_comm, output_unit)
1190 : TYPE(mp_comm_type) :: mpi_comm
1191 : INTEGER, INTENT(IN) :: output_unit
1192 :
1193 : INTERFACE
1194 : SUBROUTINE grid_library_print_stats_c(mpi_comm, print_func, output_unit) &
1195 : BIND(C, name="grid_library_print_stats")
1196 : IMPORT :: C_FUNPTR, C_INT
1197 : INTEGER(KIND=C_INT), VALUE :: mpi_comm
1198 : TYPE(C_FUNPTR), VALUE :: print_func
1199 : INTEGER(KIND=C_INT), VALUE :: output_unit
1200 : END SUBROUTINE grid_library_print_stats_c
1201 : END INTERFACE
1202 :
1203 : ! Since Fortran units and mpi groups can't be used from C, we pass function pointers instead.
1204 : CALL grid_library_print_stats_c(mpi_comm=mpi_comm%get_handle(), &
1205 : print_func=C_FUNLOC(print_func), &
1206 9402 : output_unit=output_unit)
1207 :
1208 9402 : END SUBROUTINE grid_library_print_stats
1209 :
1210 : ! **************************************************************************************************
1211 : !> \brief Callback to write to a Fortran output unit (called by C-side).
1212 : !> \param msg to be printed.
1213 : !> \param msglen number of characters excluding the terminating character.
1214 : !> \param output_unit used for output.
1215 : !> \author Ole Schuett and Hans Pabst
1216 : ! **************************************************************************************************
1217 90676 : SUBROUTINE print_func(msg, msglen, output_unit) BIND(C, name="grid_api_print_func")
1218 : CHARACTER(KIND=C_CHAR), INTENT(IN) :: msg(*)
1219 : INTEGER(KIND=C_INT), INTENT(IN), VALUE :: msglen, output_unit
1220 :
1221 90676 : IF (output_unit <= 0) RETURN ! Omit to print the message.
1222 45338 : WRITE (output_unit, FMT="(100A)", ADVANCE="NO") msg(1:msglen)
1223 : END SUBROUTINE print_func
1224 0 : END MODULE grid_api
|
