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 1183247 : 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 1183247 : 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 1183247 : border_mask = 0
176 1183247 : IF (PRESENT(use_subpatch)) THEN
177 85831 : IF (use_subpatch) THEN
178 74995 : CPASSERT(PRESENT(subpatch_pattern))
179 74995 : border_mask = IAND(63, NOT(subpatch_pattern)) ! invert last 6 bits
180 : END IF
181 : END IF
182 :
183 1183247 : orthorhombic = LOGICAL(rsgrid%desc%orthorhombic, C_BOOL)
184 :
185 1183247 : CPASSERT(LBOUND(pab, 1) == 1)
186 1183247 : 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 1183247 : border_width=border_width)
192 :
193 1183247 : grid(1:, 1:, 1:) => rsgrid%r(:, :, :) ! pointer assignment
194 :
195 : #if __GNUC__ >= 9
196 : CPASSERT(IS_CONTIGUOUS(rsgrid%desc%dh))
197 : CPASSERT(IS_CONTIGUOUS(rsgrid%desc%dh_inv))
198 : CPASSERT(IS_CONTIGUOUS(ra))
199 : CPASSERT(IS_CONTIGUOUS(rab))
200 : CPASSERT(IS_CONTIGUOUS(npts_global))
201 : CPASSERT(IS_CONTIGUOUS(npts_local))
202 : CPASSERT(IS_CONTIGUOUS(shift_local))
203 : CPASSERT(IS_CONTIGUOUS(border_width))
204 1183247 : CPASSERT(IS_CONTIGUOUS(pab))
205 1183247 : CPASSERT(IS_CONTIGUOUS(grid))
206 : #endif
207 :
208 : ! For collocating a single pgf product we use the optimized cpu backend.
209 :
210 : CALL grid_cpu_collocate_pgf_product_c(orthorhombic=orthorhombic, &
211 : border_mask=border_mask, &
212 : func=ga_gb_function, &
213 : la_max=la_max, &
214 : la_min=la_min, &
215 : lb_max=lb_max, &
216 : lb_min=lb_min, &
217 : zeta=zeta, &
218 : zetb=zetb, &
219 : rscale=scale, &
220 : dh=C_LOC(rsgrid%desc%dh(1, 1)), &
221 : dh_inv=C_LOC(rsgrid%desc%dh_inv(1, 1)), &
222 : ra=C_LOC(ra(1)), &
223 : rab=C_LOC(rab(1)), &
224 : npts_global=C_LOC(npts_global(1)), &
225 : npts_local=C_LOC(npts_local(1)), &
226 : shift_local=C_LOC(shift_local(1)), &
227 : border_width=C_LOC(border_width(1)), &
228 : radius=radius, &
229 : o1=o1, &
230 : o2=o2, &
231 : n1=SIZE(pab, 1), &
232 : n2=SIZE(pab, 2), &
233 : pab=C_LOC(pab(1, 1)), &
234 1183247 : grid=C_LOC(grid(1, 1, 1)))
235 :
236 1183247 : END SUBROUTINE collocate_pgf_product
237 :
238 : ! **************************************************************************************************
239 : !> \brief low level function to compute matrix elements of primitive gaussian functions
240 : !> \param la_max ...
241 : !> \param zeta ...
242 : !> \param la_min ...
243 : !> \param lb_max ...
244 : !> \param zetb ...
245 : !> \param lb_min ...
246 : !> \param ra ...
247 : !> \param rab ...
248 : !> \param rsgrid ...
249 : !> \param hab ...
250 : !> \param pab ...
251 : !> \param o1 ...
252 : !> \param o2 ...
253 : !> \param radius ...
254 : !> \param calculate_forces ...
255 : !> \param force_a ...
256 : !> \param force_b ...
257 : !> \param compute_tau ...
258 : !> \param use_virial ...
259 : !> \param my_virial_a ...
260 : !> \param my_virial_b ...
261 : !> \param hdab Derivative with respect to the primitive on the left.
262 : !> \param hadb Derivative with respect to the primitive on the right.
263 : !> \param a_hdab ...
264 : !> \param use_subpatch ...
265 : !> \param subpatch_pattern ...
266 : ! **************************************************************************************************
267 927403 : SUBROUTINE integrate_pgf_product(la_max, zeta, la_min, &
268 : lb_max, zetb, lb_min, &
269 : ra, rab, rsgrid, &
270 : hab, pab, o1, o2, &
271 : radius, &
272 : calculate_forces, force_a, force_b, &
273 : compute_tau, &
274 : use_virial, my_virial_a, &
275 : my_virial_b, hdab, hadb, a_hdab, use_subpatch, subpatch_pattern)
276 :
277 : INTEGER, INTENT(IN) :: la_max
278 : REAL(KIND=dp), INTENT(IN) :: zeta
279 : INTEGER, INTENT(IN) :: la_min, lb_max
280 : REAL(KIND=dp), INTENT(IN) :: zetb
281 : INTEGER, INTENT(IN) :: lb_min
282 : REAL(KIND=dp), DIMENSION(3), INTENT(IN), TARGET :: ra, rab
283 : TYPE(realspace_grid_type), INTENT(IN) :: rsgrid
284 : REAL(KIND=dp), DIMENSION(:, :), POINTER :: hab
285 : REAL(KIND=dp), DIMENSION(:, :), OPTIONAL, POINTER :: pab
286 : INTEGER, INTENT(IN) :: o1, o2
287 : REAL(KIND=dp), INTENT(IN) :: radius
288 : LOGICAL, INTENT(IN) :: calculate_forces
289 : REAL(KIND=dp), DIMENSION(3), INTENT(INOUT), &
290 : OPTIONAL :: force_a, force_b
291 : LOGICAL, INTENT(IN), OPTIONAL :: compute_tau, use_virial
292 : REAL(KIND=dp), DIMENSION(3, 3), OPTIONAL :: my_virial_a, my_virial_b
293 : REAL(KIND=dp), DIMENSION(:, :, :), OPTIONAL, &
294 : POINTER :: hdab, hadb
295 : REAL(KIND=dp), DIMENSION(:, :, :, :), OPTIONAL, &
296 : POINTER :: a_hdab
297 : LOGICAL, OPTIONAL :: use_subpatch
298 : INTEGER, INTENT(IN), OPTIONAL :: subpatch_pattern
299 :
300 : INTEGER :: border_mask
301 : INTEGER, DIMENSION(3), TARGET :: border_width, npts_global, npts_local, &
302 : shift_local
303 : LOGICAL :: my_use_virial
304 : LOGICAL(KIND=C_BOOL) :: my_compute_tau, orthorhombic
305 : REAL(KIND=dp), DIMENSION(3, 2), TARGET :: forces
306 : REAL(KIND=dp), DIMENSION(3, 3, 2), TARGET :: virials
307 927403 : REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: grid
308 : TYPE(C_PTR) :: a_hdab_cptr, forces_cptr, hadb_cptr, &
309 : hdab_cptr, pab_cptr, virials_cptr
310 : INTERFACE
311 : SUBROUTINE grid_cpu_integrate_pgf_product_c(orthorhombic, compute_tau, &
312 : border_mask, &
313 : la_max, la_min, lb_max, lb_min, &
314 : zeta, zetb, dh, dh_inv, ra, rab, &
315 : npts_global, npts_local, shift_local, border_width, &
316 : radius, o1, o2, n1, n2, grid, hab, pab, &
317 : forces, virials, hdab, hadb, a_hdab) &
318 : BIND(C, name="grid_cpu_integrate_pgf_product")
319 : IMPORT :: C_PTR, C_INT, C_DOUBLE, C_BOOL
320 : LOGICAL(KIND=C_BOOL), VALUE :: orthorhombic
321 : LOGICAL(KIND=C_BOOL), VALUE :: compute_tau
322 : INTEGER(KIND=C_INT), VALUE :: border_mask
323 : INTEGER(KIND=C_INT), VALUE :: la_max
324 : INTEGER(KIND=C_INT), VALUE :: la_min
325 : INTEGER(KIND=C_INT), VALUE :: lb_max
326 : INTEGER(KIND=C_INT), VALUE :: lb_min
327 : REAL(KIND=C_DOUBLE), VALUE :: zeta
328 : REAL(KIND=C_DOUBLE), VALUE :: zetb
329 : TYPE(C_PTR), VALUE :: dh
330 : TYPE(C_PTR), VALUE :: dh_inv
331 : TYPE(C_PTR), VALUE :: ra
332 : TYPE(C_PTR), VALUE :: rab
333 : TYPE(C_PTR), VALUE :: npts_global
334 : TYPE(C_PTR), VALUE :: npts_local
335 : TYPE(C_PTR), VALUE :: shift_local
336 : TYPE(C_PTR), VALUE :: border_width
337 : REAL(KIND=C_DOUBLE), VALUE :: radius
338 : INTEGER(KIND=C_INT), VALUE :: o1
339 : INTEGER(KIND=C_INT), VALUE :: o2
340 : INTEGER(KIND=C_INT), VALUE :: n1
341 : INTEGER(KIND=C_INT), VALUE :: n2
342 : TYPE(C_PTR), VALUE :: grid
343 : TYPE(C_PTR), VALUE :: hab
344 : TYPE(C_PTR), VALUE :: pab
345 : TYPE(C_PTR), VALUE :: forces
346 : TYPE(C_PTR), VALUE :: virials
347 : TYPE(C_PTR), VALUE :: hdab
348 : TYPE(C_PTR), VALUE :: hadb
349 : TYPE(C_PTR), VALUE :: a_hdab
350 : END SUBROUTINE grid_cpu_integrate_pgf_product_c
351 : END INTERFACE
352 :
353 927403 : IF (radius == 0.0_dp) THEN
354 0 : RETURN
355 : END IF
356 :
357 927403 : border_mask = 0
358 927403 : IF (PRESENT(use_subpatch)) THEN
359 873172 : IF (use_subpatch) THEN
360 65389 : CPASSERT(PRESENT(subpatch_pattern))
361 65389 : border_mask = IAND(63, NOT(subpatch_pattern)) ! invert last 6 bits
362 : END IF
363 : END IF
364 :
365 : ! When true then 0.5 * (nabla x_a).(v(r) nabla x_b) is computed.
366 927403 : IF (PRESENT(compute_tau)) THEN
367 3612 : my_compute_tau = LOGICAL(compute_tau, C_BOOL)
368 : ELSE
369 : my_compute_tau = .FALSE.
370 : END IF
371 :
372 927403 : IF (PRESENT(use_virial)) THEN
373 414418 : my_use_virial = use_virial
374 : ELSE
375 : my_use_virial = .FALSE.
376 : END IF
377 :
378 927403 : IF (calculate_forces) THEN
379 368357 : CPASSERT(PRESENT(pab))
380 368357 : pab_cptr = C_LOC(pab(1, 1))
381 368357 : forces(:, :) = 0.0_dp
382 368357 : forces_cptr = C_LOC(forces(1, 1))
383 : ELSE
384 : pab_cptr = C_NULL_PTR
385 : forces_cptr = C_NULL_PTR
386 : END IF
387 :
388 927403 : IF (calculate_forces .AND. my_use_virial) THEN
389 81178 : virials(:, :, :) = 0.0_dp
390 81178 : virials_cptr = C_LOC(virials(1, 1, 1))
391 : ELSE
392 : virials_cptr = C_NULL_PTR
393 : END IF
394 :
395 927403 : IF (calculate_forces .AND. PRESENT(hdab)) THEN
396 3404 : hdab_cptr = C_LOC(hdab(1, 1, 1))
397 : ELSE
398 : hdab_cptr = C_NULL_PTR
399 : END IF
400 :
401 927403 : IF (calculate_forces .AND. PRESENT(hadb)) THEN
402 1806 : hadb_cptr = C_LOC(hadb(1, 1, 1))
403 : ELSE
404 : hadb_cptr = C_NULL_PTR
405 : END IF
406 :
407 927403 : IF (calculate_forces .AND. my_use_virial .AND. PRESENT(a_hdab)) THEN
408 82 : a_hdab_cptr = C_LOC(a_hdab(1, 1, 1, 1))
409 : ELSE
410 : a_hdab_cptr = C_NULL_PTR
411 : END IF
412 :
413 927403 : orthorhombic = LOGICAL(rsgrid%desc%orthorhombic, C_BOOL)
414 :
415 : CALL get_rsgrid_properties(rsgrid, npts_global=npts_global, &
416 : npts_local=npts_local, &
417 : shift_local=shift_local, &
418 927403 : border_width=border_width)
419 :
420 927403 : grid(1:, 1:, 1:) => rsgrid%r(:, :, :) ! pointer assignment
421 :
422 : #if __GNUC__ >= 9
423 : CPASSERT(IS_CONTIGUOUS(rsgrid%desc%dh))
424 : CPASSERT(IS_CONTIGUOUS(rsgrid%desc%dh_inv))
425 : CPASSERT(IS_CONTIGUOUS(ra))
426 : CPASSERT(IS_CONTIGUOUS(rab))
427 : CPASSERT(IS_CONTIGUOUS(npts_global))
428 : CPASSERT(IS_CONTIGUOUS(npts_local))
429 : CPASSERT(IS_CONTIGUOUS(shift_local))
430 : CPASSERT(IS_CONTIGUOUS(border_width))
431 927403 : CPASSERT(IS_CONTIGUOUS(grid))
432 927403 : CPASSERT(IS_CONTIGUOUS(hab))
433 : CPASSERT(IS_CONTIGUOUS(forces))
434 : CPASSERT(IS_CONTIGUOUS(virials))
435 927403 : IF (PRESENT(pab)) THEN
436 418053 : CPASSERT(IS_CONTIGUOUS(pab))
437 : END IF
438 927403 : IF (PRESENT(hdab)) THEN
439 39043 : CPASSERT(IS_CONTIGUOUS(hdab))
440 : END IF
441 927403 : IF (PRESENT(a_hdab)) THEN
442 37237 : CPASSERT(IS_CONTIGUOUS(a_hdab))
443 : END IF
444 : #endif
445 :
446 : CALL grid_cpu_integrate_pgf_product_c(orthorhombic=orthorhombic, &
447 : compute_tau=my_compute_tau, &
448 : border_mask=border_mask, &
449 : la_max=la_max, &
450 : la_min=la_min, &
451 : lb_max=lb_max, &
452 : lb_min=lb_min, &
453 : zeta=zeta, &
454 : zetb=zetb, &
455 : dh=C_LOC(rsgrid%desc%dh(1, 1)), &
456 : dh_inv=C_LOC(rsgrid%desc%dh_inv(1, 1)), &
457 : ra=C_LOC(ra(1)), &
458 : rab=C_LOC(rab(1)), &
459 : npts_global=C_LOC(npts_global(1)), &
460 : npts_local=C_LOC(npts_local(1)), &
461 : shift_local=C_LOC(shift_local(1)), &
462 : border_width=C_LOC(border_width(1)), &
463 : radius=radius, &
464 : o1=o1, &
465 : o2=o2, &
466 : n1=SIZE(hab, 1), &
467 : n2=SIZE(hab, 2), &
468 : grid=C_LOC(grid(1, 1, 1)), &
469 : hab=C_LOC(hab(1, 1)), &
470 : pab=pab_cptr, &
471 : forces=forces_cptr, &
472 : virials=virials_cptr, &
473 : hdab=hdab_cptr, &
474 : hadb=hadb_cptr, &
475 927403 : a_hdab=a_hdab_cptr)
476 :
477 927403 : IF (PRESENT(force_a) .AND. C_ASSOCIATED(forces_cptr)) &
478 1457388 : force_a = force_a + forces(:, 1)
479 927403 : IF (PRESENT(force_b) .AND. C_ASSOCIATED(forces_cptr)) &
480 1457388 : force_b = force_b + forces(:, 2)
481 927403 : IF (PRESENT(my_virial_a) .AND. C_ASSOCIATED(virials_cptr)) &
482 1055314 : my_virial_a = my_virial_a + virials(:, :, 1)
483 927403 : IF (PRESENT(my_virial_b) .AND. C_ASSOCIATED(virials_cptr)) &
484 1055314 : my_virial_b = my_virial_b + virials(:, :, 2)
485 :
486 927403 : 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 2173122 : 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 4346244 : CPASSERT(LBOUND(rsgrid%r, 1) == rsgrid%lb_local(1))
506 4346244 : CPASSERT(UBOUND(rsgrid%r, 1) == rsgrid%ub_local(1))
507 4346244 : CPASSERT(LBOUND(rsgrid%r, 2) == rsgrid%lb_local(2))
508 4346244 : CPASSERT(UBOUND(rsgrid%r, 2) == rsgrid%ub_local(2))
509 4346244 : CPASSERT(LBOUND(rsgrid%r, 3) == rsgrid%lb_local(3))
510 4346244 : 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 8692488 : npts_global = rsgrid%desc%ub - rsgrid%desc%lb + 1
518 :
519 : ! Number of local grid points in each direction.
520 8692488 : npts_local = rsgrid%ub_local - rsgrid%lb_local + 1
521 :
522 : ! Number of points the local grid is shifted wrt global grid.
523 8692488 : 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 8692488 : DO i = 1, 3
527 8692488 : IF (rsgrid%desc%perd(i) == 1) THEN
528 : ! Periodic meaning the grid in this direction is entriely present on every processor.
529 6518930 : CPASSERT(npts_local(i) == npts_global(i))
530 6518930 : CPASSERT(shift_local(i) == 0)
531 : ! No need for halo regions.
532 6518930 : 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 2173122 : 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 16827 : SUBROUTINE grid_create_basis_set(nset, nsgf, maxco, maxpgf, &
562 16827 : 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 33654 : 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 16827 : CALL timeset(routineN, handle)
598 :
599 16827 : CPASSERT(SIZE(lmin) == nset)
600 16827 : CPASSERT(SIZE(lmin) == nset)
601 16827 : CPASSERT(SIZE(lmax) == nset)
602 16827 : CPASSERT(SIZE(npgf) == nset)
603 16827 : CPASSERT(SIZE(nsgf_set) == nset)
604 16827 : CPASSERT(SIZE(first_sgf, 2) == nset)
605 16827 : CPASSERT(SIZE(sphi, 1) == maxco .AND. SIZE(sphi, 2) == nsgf)
606 16827 : CPASSERT(SIZE(zet, 1) == maxpgf .AND. SIZE(zet, 2) == nset)
607 16827 : CPASSERT(.NOT. C_ASSOCIATED(basis_set%c_ptr))
608 :
609 : #if __GNUC__ >= 9
610 16827 : CPASSERT(IS_CONTIGUOUS(lmin))
611 16827 : CPASSERT(IS_CONTIGUOUS(lmax))
612 16827 : CPASSERT(IS_CONTIGUOUS(npgf))
613 16827 : CPASSERT(IS_CONTIGUOUS(nsgf_set))
614 : CPASSERT(IS_CONTIGUOUS(my_first_sgf))
615 16827 : CPASSERT(IS_CONTIGUOUS(sphi))
616 16827 : CPASSERT(IS_CONTIGUOUS(zet))
617 : #endif
618 :
619 16827 : lmin_c = C_NULL_PTR
620 16827 : lmax_c = C_NULL_PTR
621 16827 : npgf_c = C_NULL_PTR
622 16827 : nsgf_set_c = C_NULL_PTR
623 16827 : first_sgf_c = C_NULL_PTR
624 16827 : sphi_c = C_NULL_PTR
625 16827 : zet_c = C_NULL_PTR
626 :
627 : ! Basis sets arrays can be empty, need to check before accessing the first element.
628 16827 : IF (nset > 0) THEN
629 16819 : lmin_c = C_LOC(lmin(1))
630 16819 : lmax_c = C_LOC(lmax(1))
631 16819 : npgf_c = C_LOC(npgf(1))
632 16819 : nsgf_set_c = C_LOC(nsgf_set(1))
633 : END IF
634 50481 : IF (SIZE(first_sgf) > 0) THEN
635 55692 : my_first_sgf(:) = first_sgf(1, :) ! make a contiguous copy
636 16819 : first_sgf_c = C_LOC(my_first_sgf(1))
637 : END IF
638 50481 : IF (SIZE(sphi) > 0) THEN
639 16817 : sphi_c = C_LOC(sphi(1, 1))
640 : END IF
641 50481 : IF (SIZE(zet) > 0) THEN
642 16817 : zet_c = C_LOC(zet(1, 1))
643 : END IF
644 :
645 : CALL grid_create_basis_set_c(nset=nset, &
646 : nsgf=nsgf, &
647 : maxco=maxco, &
648 : maxpgf=maxpgf, &
649 : lmin=lmin_c, &
650 : lmax=lmax_c, &
651 : npgf=npgf_c, &
652 : nsgf_set=nsgf_set_c, &
653 : first_sgf=first_sgf_c, &
654 : sphi=sphi_c, &
655 : zet=zet_c, &
656 16827 : basis_set=basis_set%c_ptr)
657 16827 : CPASSERT(C_ASSOCIATED(basis_set%c_ptr))
658 :
659 16827 : CALL timestop(handle)
660 16827 : END SUBROUTINE grid_create_basis_set
661 :
662 : ! **************************************************************************************************
663 : !> \brief Deallocates given basis set.
664 : !> \param basis_set ...
665 : !> \author Ole Schuett
666 : ! **************************************************************************************************
667 16827 : SUBROUTINE grid_free_basis_set(basis_set)
668 : TYPE(grid_basis_set_type), INTENT(INOUT) :: basis_set
669 :
670 : CHARACTER(LEN=*), PARAMETER :: routineN = 'grid_free_basis_set'
671 :
672 : INTEGER :: handle
673 : INTERFACE
674 : SUBROUTINE grid_free_basis_set_c(basis_set) &
675 : BIND(C, name="grid_free_basis_set")
676 : IMPORT :: C_PTR
677 : TYPE(C_PTR), VALUE :: basis_set
678 : END SUBROUTINE grid_free_basis_set_c
679 : END INTERFACE
680 :
681 16827 : CALL timeset(routineN, handle)
682 :
683 16827 : CPASSERT(C_ASSOCIATED(basis_set%c_ptr))
684 :
685 16827 : CALL grid_free_basis_set_c(basis_set%c_ptr)
686 :
687 16827 : basis_set%c_ptr = C_NULL_PTR
688 :
689 16827 : CALL timestop(handle)
690 16827 : END SUBROUTINE grid_free_basis_set
691 :
692 : ! **************************************************************************************************
693 : !> \brief Allocates a task list which can be passed to grid_collocate_task_list.
694 : !> \param ntasks ...
695 : !> \param natoms ...
696 : !> \param nkinds ...
697 : !> \param nblocks ...
698 : !> \param block_offsets ...
699 : !> \param atom_positions ...
700 : !> \param atom_kinds ...
701 : !> \param basis_sets ...
702 : !> \param level_list ...
703 : !> \param iatom_list ...
704 : !> \param jatom_list ...
705 : !> \param iset_list ...
706 : !> \param jset_list ...
707 : !> \param ipgf_list ...
708 : !> \param jpgf_list ...
709 : !> \param border_mask_list ...
710 : !> \param block_num_list ...
711 : !> \param radius_list ...
712 : !> \param rab_list ...
713 : !> \param rs_grids ...
714 : !> \param task_list ...
715 : !> \author Ole Schuett
716 : ! **************************************************************************************************
717 15750 : SUBROUTINE grid_create_task_list(ntasks, natoms, nkinds, nblocks, &
718 15750 : block_offsets, atom_positions, atom_kinds, basis_sets, &
719 15750 : level_list, iatom_list, jatom_list, &
720 15750 : iset_list, jset_list, ipgf_list, jpgf_list, &
721 15750 : border_mask_list, block_num_list, &
722 15750 : radius_list, rab_list, rs_grids, task_list)
723 :
724 : INTEGER, INTENT(IN) :: ntasks, natoms, nkinds, nblocks
725 : INTEGER, DIMENSION(:), INTENT(IN), TARGET :: block_offsets
726 : REAL(KIND=dp), DIMENSION(:, :), INTENT(IN), TARGET :: atom_positions
727 : INTEGER, DIMENSION(:), INTENT(IN), TARGET :: atom_kinds
728 : TYPE(grid_basis_set_type), DIMENSION(:), &
729 : INTENT(IN), TARGET :: basis_sets
730 : INTEGER, DIMENSION(:), INTENT(IN), TARGET :: level_list, iatom_list, jatom_list, &
731 : iset_list, jset_list, ipgf_list, &
732 : jpgf_list, border_mask_list, &
733 : block_num_list
734 : REAL(KIND=dp), DIMENSION(:), INTENT(IN), TARGET :: radius_list
735 : REAL(KIND=dp), DIMENSION(:, :), INTENT(IN), TARGET :: rab_list
736 : TYPE(realspace_grid_type), DIMENSION(:), &
737 : INTENT(IN) :: rs_grids
738 : TYPE(grid_task_list_type), INTENT(INOUT) :: task_list
739 :
740 : CHARACTER(LEN=*), PARAMETER :: routineN = 'grid_create_task_list'
741 :
742 : INTEGER :: handle, ikind, ilevel, nlevels
743 15750 : INTEGER, ALLOCATABLE, DIMENSION(:, :), TARGET :: border_width, npts_global, npts_local, &
744 15750 : shift_local
745 : LOGICAL(KIND=C_BOOL) :: orthorhombic
746 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :), &
747 15750 : TARGET :: dh, dh_inv
748 : TYPE(C_PTR) :: block_num_list_c, block_offsets_c, border_mask_list_c, iatom_list_c, &
749 : ipgf_list_c, iset_list_c, jatom_list_c, jpgf_list_c, jset_list_c, level_list_c, &
750 : rab_list_c, radius_list_c
751 15750 : TYPE(C_PTR), ALLOCATABLE, DIMENSION(:), TARGET :: basis_sets_c
752 : INTERFACE
753 : SUBROUTINE grid_create_task_list_c(orthorhombic, &
754 : ntasks, nlevels, natoms, nkinds, nblocks, &
755 : block_offsets, atom_positions, atom_kinds, basis_sets, &
756 : level_list, iatom_list, jatom_list, &
757 : iset_list, jset_list, ipgf_list, jpgf_list, &
758 : border_mask_list, block_num_list, &
759 : radius_list, rab_list, &
760 : npts_global, npts_local, shift_local, &
761 : border_width, dh, dh_inv, task_list) &
762 : BIND(C, name="grid_create_task_list")
763 : IMPORT :: C_PTR, C_INT, C_BOOL
764 : LOGICAL(KIND=C_BOOL), VALUE :: orthorhombic
765 : INTEGER(KIND=C_INT), VALUE :: ntasks
766 : INTEGER(KIND=C_INT), VALUE :: nlevels
767 : INTEGER(KIND=C_INT), VALUE :: natoms
768 : INTEGER(KIND=C_INT), VALUE :: nkinds
769 : INTEGER(KIND=C_INT), VALUE :: nblocks
770 : TYPE(C_PTR), VALUE :: block_offsets
771 : TYPE(C_PTR), VALUE :: atom_positions
772 : TYPE(C_PTR), VALUE :: atom_kinds
773 : TYPE(C_PTR), VALUE :: basis_sets
774 : TYPE(C_PTR), VALUE :: level_list
775 : TYPE(C_PTR), VALUE :: iatom_list
776 : TYPE(C_PTR), VALUE :: jatom_list
777 : TYPE(C_PTR), VALUE :: iset_list
778 : TYPE(C_PTR), VALUE :: jset_list
779 : TYPE(C_PTR), VALUE :: ipgf_list
780 : TYPE(C_PTR), VALUE :: jpgf_list
781 : TYPE(C_PTR), VALUE :: border_mask_list
782 : TYPE(C_PTR), VALUE :: block_num_list
783 : TYPE(C_PTR), VALUE :: radius_list
784 : TYPE(C_PTR), VALUE :: rab_list
785 : TYPE(C_PTR), VALUE :: npts_global
786 : TYPE(C_PTR), VALUE :: npts_local
787 : TYPE(C_PTR), VALUE :: shift_local
788 : TYPE(C_PTR), VALUE :: border_width
789 : TYPE(C_PTR), VALUE :: dh
790 : TYPE(C_PTR), VALUE :: dh_inv
791 : TYPE(C_PTR) :: task_list
792 : END SUBROUTINE grid_create_task_list_c
793 : END INTERFACE
794 :
795 15750 : CALL timeset(routineN, handle)
796 :
797 15750 : CPASSERT(SIZE(block_offsets) == nblocks)
798 15750 : CPASSERT(SIZE(atom_positions, 1) == 3 .AND. SIZE(atom_positions, 2) == natoms)
799 15750 : CPASSERT(SIZE(atom_kinds) == natoms)
800 15750 : CPASSERT(SIZE(basis_sets) == nkinds)
801 15750 : CPASSERT(SIZE(level_list) == ntasks)
802 15750 : CPASSERT(SIZE(iatom_list) == ntasks)
803 15750 : CPASSERT(SIZE(jatom_list) == ntasks)
804 15750 : CPASSERT(SIZE(iset_list) == ntasks)
805 15750 : CPASSERT(SIZE(jset_list) == ntasks)
806 15750 : CPASSERT(SIZE(ipgf_list) == ntasks)
807 15750 : CPASSERT(SIZE(jpgf_list) == ntasks)
808 15750 : CPASSERT(SIZE(border_mask_list) == ntasks)
809 15750 : CPASSERT(SIZE(block_num_list) == ntasks)
810 15750 : CPASSERT(SIZE(radius_list) == ntasks)
811 15750 : CPASSERT(SIZE(rab_list, 1) == 3 .AND. SIZE(rab_list, 2) == ntasks)
812 :
813 47250 : ALLOCATE (basis_sets_c(nkinds))
814 43879 : DO ikind = 1, nkinds
815 43879 : basis_sets_c(ikind) = basis_sets(ikind)%c_ptr
816 : END DO
817 :
818 15750 : nlevels = SIZE(rs_grids)
819 15750 : CPASSERT(nlevels > 0)
820 15750 : orthorhombic = LOGICAL(rs_grids(1)%desc%orthorhombic, C_BOOL)
821 :
822 63000 : ALLOCATE (npts_global(3, nlevels), npts_local(3, nlevels))
823 47250 : ALLOCATE (shift_local(3, nlevels), border_width(3, nlevels))
824 63000 : ALLOCATE (dh(3, 3, nlevels), dh_inv(3, 3, nlevels))
825 78222 : DO ilevel = 1, nlevels
826 15750 : ASSOCIATE (rsgrid => rs_grids(ilevel))
827 : CALL get_rsgrid_properties(rsgrid=rsgrid, &
828 : npts_global=npts_global(:, ilevel), &
829 : npts_local=npts_local(:, ilevel), &
830 : shift_local=shift_local(:, ilevel), &
831 62472 : border_width=border_width(:, ilevel))
832 62472 : CPASSERT(rsgrid%desc%orthorhombic .EQV. orthorhombic) ! should be the same for all levels
833 812136 : dh(:, :, ilevel) = rsgrid%desc%dh(:, :)
834 874608 : dh_inv(:, :, ilevel) = rsgrid%desc%dh_inv(:, :)
835 : END ASSOCIATE
836 : END DO
837 :
838 : #if __GNUC__ >= 9
839 15750 : CPASSERT(IS_CONTIGUOUS(block_offsets))
840 15750 : CPASSERT(IS_CONTIGUOUS(atom_positions))
841 15750 : CPASSERT(IS_CONTIGUOUS(atom_kinds))
842 15750 : CPASSERT(IS_CONTIGUOUS(basis_sets))
843 15750 : CPASSERT(IS_CONTIGUOUS(level_list))
844 15750 : CPASSERT(IS_CONTIGUOUS(iatom_list))
845 15750 : CPASSERT(IS_CONTIGUOUS(jatom_list))
846 15750 : CPASSERT(IS_CONTIGUOUS(iset_list))
847 15750 : CPASSERT(IS_CONTIGUOUS(jset_list))
848 15750 : CPASSERT(IS_CONTIGUOUS(ipgf_list))
849 15750 : CPASSERT(IS_CONTIGUOUS(jpgf_list))
850 15750 : CPASSERT(IS_CONTIGUOUS(border_mask_list))
851 15750 : CPASSERT(IS_CONTIGUOUS(block_num_list))
852 15750 : CPASSERT(IS_CONTIGUOUS(radius_list))
853 15750 : CPASSERT(IS_CONTIGUOUS(rab_list))
854 : CPASSERT(IS_CONTIGUOUS(npts_global))
855 : CPASSERT(IS_CONTIGUOUS(npts_local))
856 : CPASSERT(IS_CONTIGUOUS(shift_local))
857 : CPASSERT(IS_CONTIGUOUS(border_width))
858 : CPASSERT(IS_CONTIGUOUS(dh))
859 : CPASSERT(IS_CONTIGUOUS(dh_inv))
860 : #endif
861 :
862 15750 : IF (ntasks > 0) THEN
863 : block_offsets_c = C_LOC(block_offsets(1))
864 : level_list_c = C_LOC(level_list(1))
865 : iatom_list_c = C_LOC(iatom_list(1))
866 : jatom_list_c = C_LOC(jatom_list(1))
867 : iset_list_c = C_LOC(iset_list(1))
868 : jset_list_c = C_LOC(jset_list(1))
869 : ipgf_list_c = C_LOC(ipgf_list(1))
870 : jpgf_list_c = C_LOC(jpgf_list(1))
871 : border_mask_list_c = C_LOC(border_mask_list(1))
872 : block_num_list_c = C_LOC(block_num_list(1))
873 : radius_list_c = C_LOC(radius_list(1))
874 : rab_list_c = C_LOC(rab_list(1, 1))
875 : ELSE
876 : ! Without tasks the lists are empty and there is no first element to call C_LOC on.
877 244 : block_offsets_c = C_NULL_PTR
878 244 : level_list_c = C_NULL_PTR
879 244 : iatom_list_c = C_NULL_PTR
880 244 : jatom_list_c = C_NULL_PTR
881 244 : iset_list_c = C_NULL_PTR
882 244 : jset_list_c = C_NULL_PTR
883 244 : ipgf_list_c = C_NULL_PTR
884 244 : jpgf_list_c = C_NULL_PTR
885 244 : border_mask_list_c = C_NULL_PTR
886 244 : block_num_list_c = C_NULL_PTR
887 244 : radius_list_c = C_NULL_PTR
888 244 : rab_list_c = C_NULL_PTR
889 : END IF
890 :
891 : !If task_list%c_ptr is already allocated, then its memory will be reused or freed.
892 : CALL grid_create_task_list_c(orthorhombic=orthorhombic, &
893 : ntasks=ntasks, &
894 : nlevels=nlevels, &
895 : natoms=natoms, &
896 : nkinds=nkinds, &
897 : nblocks=nblocks, &
898 : block_offsets=block_offsets_c, &
899 : atom_positions=C_LOC(atom_positions(1, 1)), &
900 : atom_kinds=C_LOC(atom_kinds(1)), &
901 : basis_sets=C_LOC(basis_sets_c(1)), &
902 : level_list=level_list_c, &
903 : iatom_list=iatom_list_c, &
904 : jatom_list=jatom_list_c, &
905 : iset_list=iset_list_c, &
906 : jset_list=jset_list_c, &
907 : ipgf_list=ipgf_list_c, &
908 : jpgf_list=jpgf_list_c, &
909 : border_mask_list=border_mask_list_c, &
910 : block_num_list=block_num_list_c, &
911 : radius_list=radius_list_c, &
912 : rab_list=rab_list_c, &
913 : npts_global=C_LOC(npts_global(1, 1)), &
914 : npts_local=C_LOC(npts_local(1, 1)), &
915 : shift_local=C_LOC(shift_local(1, 1)), &
916 : border_width=C_LOC(border_width(1, 1)), &
917 : dh=C_LOC(dh(1, 1, 1)), &
918 : dh_inv=C_LOC(dh_inv(1, 1, 1)), &
919 15750 : task_list=task_list%c_ptr)
920 :
921 15750 : CPASSERT(C_ASSOCIATED(task_list%c_ptr))
922 :
923 15750 : CALL timestop(handle)
924 31500 : END SUBROUTINE grid_create_task_list
925 :
926 : ! **************************************************************************************************
927 : !> \brief Deallocates given task list, basis_sets have to be freed separately.
928 : !> \param task_list ...
929 : !> \author Ole Schuett
930 : ! **************************************************************************************************
931 9532 : SUBROUTINE grid_free_task_list(task_list)
932 : TYPE(grid_task_list_type), INTENT(INOUT) :: task_list
933 :
934 : CHARACTER(LEN=*), PARAMETER :: routineN = 'grid_free_task_list'
935 :
936 : INTEGER :: handle
937 : INTERFACE
938 : SUBROUTINE grid_free_task_list_c(task_list) &
939 : BIND(C, name="grid_free_task_list")
940 : IMPORT :: C_PTR
941 : TYPE(C_PTR), VALUE :: task_list
942 : END SUBROUTINE grid_free_task_list_c
943 : END INTERFACE
944 :
945 9532 : CALL timeset(routineN, handle)
946 :
947 9532 : IF (C_ASSOCIATED(task_list%c_ptr)) THEN
948 9532 : CALL grid_free_task_list_c(task_list%c_ptr)
949 : END IF
950 :
951 9532 : task_list%c_ptr = C_NULL_PTR
952 :
953 9532 : CALL timestop(handle)
954 9532 : END SUBROUTINE grid_free_task_list
955 :
956 : ! **************************************************************************************************
957 : !> \brief Collocate all tasks of in given list onto given grids.
958 : !> \param task_list ...
959 : !> \param ga_gb_function ...
960 : !> \param pab_blocks ...
961 : !> \param rs_grids ...
962 : !> \author Ole Schuett
963 : ! **************************************************************************************************
964 230834 : SUBROUTINE grid_collocate_task_list(task_list, ga_gb_function, pab_blocks, rs_grids)
965 : TYPE(grid_task_list_type), INTENT(IN) :: task_list
966 : INTEGER, INTENT(IN) :: ga_gb_function
967 : TYPE(offload_buffer_type), INTENT(IN) :: pab_blocks
968 : TYPE(realspace_grid_type), DIMENSION(:), &
969 : INTENT(IN) :: rs_grids
970 :
971 : CHARACTER(LEN=*), PARAMETER :: routineN = 'grid_collocate_task_list'
972 :
973 : INTEGER :: handle, ilevel, nlevels
974 230834 : INTEGER, ALLOCATABLE, DIMENSION(:, :), TARGET :: npts_local
975 230834 : TYPE(C_PTR), ALLOCATABLE, DIMENSION(:), TARGET :: grids_c
976 : INTERFACE
977 : SUBROUTINE grid_collocate_task_list_c(task_list, func, nlevels, &
978 : npts_local, pab_blocks, grids) &
979 : BIND(C, name="grid_collocate_task_list")
980 : IMPORT :: C_PTR, C_INT, C_BOOL
981 : TYPE(C_PTR), VALUE :: task_list
982 : INTEGER(KIND=C_INT), VALUE :: func
983 : INTEGER(KIND=C_INT), VALUE :: nlevels
984 : TYPE(C_PTR), VALUE :: npts_local
985 : TYPE(C_PTR), VALUE :: pab_blocks
986 : TYPE(C_PTR), VALUE :: grids
987 : END SUBROUTINE grid_collocate_task_list_c
988 : END INTERFACE
989 :
990 230834 : CALL timeset(routineN, handle)
991 :
992 230834 : nlevels = SIZE(rs_grids)
993 230834 : CPASSERT(nlevels > 0)
994 :
995 692502 : ALLOCATE (grids_c(nlevels))
996 692502 : ALLOCATE (npts_local(3, nlevels))
997 1145488 : DO ilevel = 1, nlevels
998 230834 : ASSOCIATE (rsgrid => rs_grids(ilevel))
999 3658616 : npts_local(:, ilevel) = rsgrid%ub_local - rsgrid%lb_local + 1
1000 1829308 : grids_c(ilevel) = rsgrid%buffer%c_ptr
1001 : END ASSOCIATE
1002 : END DO
1003 :
1004 : #if __GNUC__ >= 9
1005 : CPASSERT(IS_CONTIGUOUS(npts_local))
1006 : CPASSERT(IS_CONTIGUOUS(grids_c))
1007 : #endif
1008 :
1009 230834 : CPASSERT(C_ASSOCIATED(task_list%c_ptr))
1010 230834 : CPASSERT(C_ASSOCIATED(pab_blocks%c_ptr))
1011 :
1012 : CALL grid_collocate_task_list_c(task_list=task_list%c_ptr, &
1013 : func=ga_gb_function, &
1014 : nlevels=nlevels, &
1015 : npts_local=C_LOC(npts_local(1, 1)), &
1016 : pab_blocks=pab_blocks%c_ptr, &
1017 230834 : grids=C_LOC(grids_c(1)))
1018 :
1019 230834 : CALL timestop(handle)
1020 461668 : END SUBROUTINE grid_collocate_task_list
1021 :
1022 : ! **************************************************************************************************
1023 : !> \brief Integrate all tasks of in given list from given grids.
1024 : !> \param task_list ...
1025 : !> \param compute_tau ...
1026 : !> \param calculate_forces ...
1027 : !> \param calculate_virial ...
1028 : !> \param pab_blocks ...
1029 : !> \param rs_grids ...
1030 : !> \param hab_blocks ...
1031 : !> \param forces ...
1032 : !> \param virial ...
1033 : !> \author Ole Schuett
1034 : ! **************************************************************************************************
1035 210614 : SUBROUTINE grid_integrate_task_list(task_list, compute_tau, calculate_forces, calculate_virial, &
1036 210614 : pab_blocks, rs_grids, hab_blocks, forces, virial)
1037 : TYPE(grid_task_list_type), INTENT(IN) :: task_list
1038 : LOGICAL, INTENT(IN) :: compute_tau, calculate_forces, &
1039 : calculate_virial
1040 : TYPE(offload_buffer_type), INTENT(IN) :: pab_blocks
1041 : TYPE(realspace_grid_type), DIMENSION(:), &
1042 : INTENT(IN) :: rs_grids
1043 : TYPE(offload_buffer_type), INTENT(INOUT) :: hab_blocks
1044 : REAL(KIND=dp), DIMENSION(:, :), INTENT(INOUT), &
1045 : TARGET :: forces
1046 : REAL(KIND=dp), DIMENSION(3, 3), INTENT(INOUT), &
1047 : TARGET :: virial
1048 :
1049 : CHARACTER(LEN=*), PARAMETER :: routineN = 'grid_integrate_task_list'
1050 :
1051 : INTEGER :: handle, ilevel, nlevels
1052 210614 : INTEGER, ALLOCATABLE, DIMENSION(:, :), TARGET :: npts_local
1053 : TYPE(C_PTR) :: forces_c, virial_c
1054 210614 : TYPE(C_PTR), ALLOCATABLE, DIMENSION(:), TARGET :: grids_c
1055 : INTERFACE
1056 : SUBROUTINE grid_integrate_task_list_c(task_list, compute_tau, natoms, &
1057 : nlevels, npts_local, &
1058 : pab_blocks, grids, hab_blocks, forces, virial) &
1059 : BIND(C, name="grid_integrate_task_list")
1060 : IMPORT :: C_PTR, C_INT, C_BOOL
1061 : TYPE(C_PTR), VALUE :: task_list
1062 : LOGICAL(KIND=C_BOOL), VALUE :: compute_tau
1063 : INTEGER(KIND=C_INT), VALUE :: natoms
1064 : INTEGER(KIND=C_INT), VALUE :: nlevels
1065 : TYPE(C_PTR), VALUE :: npts_local
1066 : TYPE(C_PTR), VALUE :: pab_blocks
1067 : TYPE(C_PTR), VALUE :: grids
1068 : TYPE(C_PTR), VALUE :: hab_blocks
1069 : TYPE(C_PTR), VALUE :: forces
1070 : TYPE(C_PTR), VALUE :: virial
1071 : END SUBROUTINE grid_integrate_task_list_c
1072 : END INTERFACE
1073 :
1074 210614 : CALL timeset(routineN, handle)
1075 :
1076 210614 : nlevels = SIZE(rs_grids)
1077 210614 : CPASSERT(nlevels > 0)
1078 :
1079 631842 : ALLOCATE (grids_c(nlevels))
1080 631842 : ALLOCATE (npts_local(3, nlevels))
1081 1045264 : DO ilevel = 1, nlevels
1082 210614 : ASSOCIATE (rsgrid => rs_grids(ilevel))
1083 3338600 : npts_local(:, ilevel) = rsgrid%ub_local - rsgrid%lb_local + 1
1084 1669300 : grids_c(ilevel) = rsgrid%buffer%c_ptr
1085 : END ASSOCIATE
1086 : END DO
1087 :
1088 210614 : IF (calculate_forces) THEN
1089 : forces_c = C_LOC(forces(1, 1))
1090 : ELSE
1091 185915 : forces_c = C_NULL_PTR
1092 : END IF
1093 :
1094 210614 : IF (calculate_virial) THEN
1095 3707 : virial_c = C_LOC(virial(1, 1))
1096 : ELSE
1097 : virial_c = C_NULL_PTR
1098 : END IF
1099 :
1100 : #if __GNUC__ >= 9
1101 : CPASSERT(IS_CONTIGUOUS(npts_local))
1102 : CPASSERT(IS_CONTIGUOUS(grids_c))
1103 210614 : CPASSERT(IS_CONTIGUOUS(forces))
1104 : CPASSERT(IS_CONTIGUOUS(virial))
1105 : #endif
1106 :
1107 210614 : CPASSERT(SIZE(forces, 1) == 3)
1108 210614 : CPASSERT(C_ASSOCIATED(task_list%c_ptr))
1109 210614 : CPASSERT(C_ASSOCIATED(hab_blocks%c_ptr))
1110 210614 : CPASSERT(C_ASSOCIATED(pab_blocks%c_ptr) .OR. .NOT. calculate_forces)
1111 210614 : CPASSERT(C_ASSOCIATED(pab_blocks%c_ptr) .OR. .NOT. calculate_virial)
1112 :
1113 : CALL grid_integrate_task_list_c(task_list=task_list%c_ptr, &
1114 : compute_tau=LOGICAL(compute_tau, C_BOOL), &
1115 : natoms=SIZE(forces, 2), &
1116 : nlevels=nlevels, &
1117 : npts_local=C_LOC(npts_local(1, 1)), &
1118 : pab_blocks=pab_blocks%c_ptr, &
1119 : grids=C_LOC(grids_c(1)), &
1120 : hab_blocks=hab_blocks%c_ptr, &
1121 : forces=forces_c, &
1122 210614 : virial=virial_c)
1123 :
1124 210614 : CALL timestop(handle)
1125 421228 : END SUBROUTINE grid_integrate_task_list
1126 :
1127 : ! **************************************************************************************************
1128 : !> \brief Initialize grid library
1129 : !> \author Ole Schuett
1130 : ! **************************************************************************************************
1131 10112 : SUBROUTINE grid_library_init()
1132 : INTERFACE
1133 : SUBROUTINE grid_library_init_c() BIND(C, name="grid_library_init")
1134 : END SUBROUTINE grid_library_init_c
1135 : END INTERFACE
1136 :
1137 10112 : CALL grid_library_init_c()
1138 :
1139 10112 : END SUBROUTINE grid_library_init
1140 :
1141 : ! **************************************************************************************************
1142 : !> \brief Finalize grid library
1143 : !> \author Ole Schuett
1144 : ! **************************************************************************************************
1145 10112 : SUBROUTINE grid_library_finalize()
1146 : INTERFACE
1147 : SUBROUTINE grid_library_finalize_c() BIND(C, name="grid_library_finalize")
1148 : END SUBROUTINE grid_library_finalize_c
1149 : END INTERFACE
1150 :
1151 10112 : CALL grid_library_finalize_c()
1152 :
1153 10112 : END SUBROUTINE grid_library_finalize
1154 :
1155 : ! **************************************************************************************************
1156 : !> \brief Configures the grid library
1157 : !> \param backend : backend to be used for collocate/integrate, possible values are REF, CPU, GPU
1158 : !> \param validate : if set to true, compare the results of all backend to the reference backend
1159 : !> \param apply_cutoff : apply a spherical cutoff before collocating or integrating. Only relevant for CPU backend
1160 : !> \author Ole Schuett
1161 : ! **************************************************************************************************
1162 10230 : SUBROUTINE grid_library_set_config(backend, validate, apply_cutoff)
1163 : INTEGER, INTENT(IN) :: backend
1164 : LOGICAL, INTENT(IN) :: validate, apply_cutoff
1165 :
1166 : INTERFACE
1167 : SUBROUTINE grid_library_set_config_c(backend, validate, apply_cutoff) &
1168 : BIND(C, name="grid_library_set_config")
1169 : IMPORT :: C_INT, C_BOOL
1170 : INTEGER(KIND=C_INT), VALUE :: backend
1171 : LOGICAL(KIND=C_BOOL), VALUE :: validate
1172 : LOGICAL(KIND=C_BOOL), VALUE :: apply_cutoff
1173 : END SUBROUTINE grid_library_set_config_c
1174 : END INTERFACE
1175 :
1176 : CALL grid_library_set_config_c(backend=backend, &
1177 : validate=LOGICAL(validate, C_BOOL), &
1178 10230 : apply_cutoff=LOGICAL(apply_cutoff, C_BOOL))
1179 :
1180 10230 : END SUBROUTINE grid_library_set_config
1181 :
1182 : ! **************************************************************************************************
1183 : !> \brief Print grid library statistics
1184 : !> \param mpi_comm ...
1185 : !> \param output_unit ...
1186 : !> \author Ole Schuett
1187 : ! **************************************************************************************************
1188 10230 : SUBROUTINE grid_library_print_stats(mpi_comm, output_unit)
1189 : TYPE(mp_comm_type) :: mpi_comm
1190 : INTEGER, INTENT(IN) :: output_unit
1191 :
1192 : INTERFACE
1193 : SUBROUTINE grid_library_print_stats_c(mpi_comm, print_func, output_unit) &
1194 : BIND(C, name="grid_library_print_stats")
1195 : IMPORT :: C_FUNPTR, C_INT
1196 : INTEGER(KIND=C_INT), VALUE :: mpi_comm
1197 : TYPE(C_FUNPTR), VALUE :: print_func
1198 : INTEGER(KIND=C_INT), VALUE :: output_unit
1199 : END SUBROUTINE grid_library_print_stats_c
1200 : END INTERFACE
1201 :
1202 : ! Since Fortran units and mpi groups can't be used from C, we pass function pointers instead.
1203 : CALL grid_library_print_stats_c(mpi_comm=mpi_comm%get_handle(), &
1204 : print_func=C_FUNLOC(print_func), &
1205 10230 : output_unit=output_unit)
1206 :
1207 10230 : END SUBROUTINE grid_library_print_stats
1208 :
1209 : ! **************************************************************************************************
1210 : !> \brief Callback to write to a Fortran output unit (called by C-side).
1211 : !> \param msg to be printed.
1212 : !> \param msglen number of characters excluding the terminating character.
1213 : !> \param output_unit used for output.
1214 : !> \author Ole Schuett and Hans Pabst
1215 : ! **************************************************************************************************
1216 101382 : SUBROUTINE print_func(msg, msglen, output_unit) BIND(C, name="grid_api_print_func")
1217 : CHARACTER(KIND=C_CHAR), INTENT(IN) :: msg(*)
1218 : INTEGER(KIND=C_INT), INTENT(IN), VALUE :: msglen, output_unit
1219 :
1220 101382 : IF (output_unit <= 0) RETURN ! Omit to print the message.
1221 50691 : WRITE (output_unit, FMT="(100A)", ADVANCE="NO") msg(1:msglen)
1222 : END SUBROUTINE print_func
1223 0 : END MODULE grid_api
|
