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