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 1186369 : 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 1186369 : 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 1186369 : border_mask = 0
176 1186369 : IF (PRESENT(use_subpatch)) THEN
177 88375 : IF (use_subpatch) THEN
178 77539 : CPASSERT(PRESENT(subpatch_pattern))
179 77539 : border_mask = IAND(63, NOT(subpatch_pattern)) ! invert last 6 bits
180 : END IF
181 : END IF
182 :
183 1186369 : orthorhombic = LOGICAL(rsgrid%desc%orthorhombic, C_BOOL)
184 :
185 1186369 : CPASSERT(LBOUND(pab, 1) == 1)
186 1186369 : 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 1186369 : border_width=border_width)
192 :
193 1186369 : 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 1186369 : CPASSERT(IS_CONTIGUOUS(pab))
205 1186369 : 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 1186369 : grid=C_LOC(grid(1, 1, 1)))
235 :
236 1186369 : 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 929526 : 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 929526 : 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 929526 : IF (radius == 0.0_dp) THEN
354 0 : RETURN
355 : END IF
356 :
357 929526 : border_mask = 0
358 929526 : IF (PRESENT(use_subpatch)) THEN
359 874717 : IF (use_subpatch) THEN
360 66934 : CPASSERT(PRESENT(subpatch_pattern))
361 66934 : 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 929526 : 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 929526 : IF (PRESENT(use_virial)) THEN
373 415963 : my_use_virial = use_virial
374 : ELSE
375 : my_use_virial = .FALSE.
376 : END IF
377 :
378 929526 : IF (calculate_forces) THEN
379 368549 : CPASSERT(PRESENT(pab))
380 368549 : pab_cptr = C_LOC(pab(1, 1))
381 368549 : forces(:, :) = 0.0_dp
382 368549 : 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 929526 : IF (calculate_forces .AND. my_use_virial) THEN
389 81300 : virials(:, :, :) = 0.0_dp
390 81300 : virials_cptr = C_LOC(virials(1, 1, 1))
391 : ELSE
392 : virials_cptr = C_NULL_PTR
393 : END IF
394 :
395 929526 : IF (calculate_forces .AND. PRESENT(hdab)) THEN
396 3446 : hdab_cptr = C_LOC(hdab(1, 1, 1))
397 : ELSE
398 : hdab_cptr = C_NULL_PTR
399 : END IF
400 :
401 929526 : 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 929526 : IF (calculate_forces .AND. my_use_virial .AND. PRESENT(a_hdab)) THEN
408 115 : 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 929526 : 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 929526 : border_width=border_width)
419 :
420 929526 : 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 929526 : CPASSERT(IS_CONTIGUOUS(grid))
432 929526 : CPASSERT(IS_CONTIGUOUS(hab))
433 : CPASSERT(IS_CONTIGUOUS(forces))
434 : CPASSERT(IS_CONTIGUOUS(virials))
435 929526 : IF (PRESENT(pab)) THEN
436 419598 : CPASSERT(IS_CONTIGUOUS(pab))
437 : END IF
438 929526 : IF (PRESENT(hdab)) THEN
439 39968 : CPASSERT(IS_CONTIGUOUS(hdab))
440 : END IF
441 929526 : IF (PRESENT(a_hdab)) THEN
442 38162 : 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 929526 : a_hdab=a_hdab_cptr)
476 :
477 929526 : IF (PRESENT(force_a) .AND. C_ASSOCIATED(forces_cptr)) THEN
478 1457988 : force_a = force_a + forces(:, 1)
479 : END IF
480 929526 : IF (PRESENT(force_b) .AND. C_ASSOCIATED(forces_cptr)) THEN
481 1457988 : force_b = force_b + forces(:, 2)
482 : END IF
483 929526 : IF (PRESENT(my_virial_a) .AND. C_ASSOCIATED(virials_cptr)) THEN
484 1056900 : my_virial_a = my_virial_a + virials(:, :, 1)
485 : END IF
486 929526 : IF (PRESENT(my_virial_b) .AND. C_ASSOCIATED(virials_cptr)) THEN
487 1056900 : my_virial_b = my_virial_b + virials(:, :, 2)
488 : END IF
489 :
490 929526 : END SUBROUTINE integrate_pgf_product
491 :
492 : ! **************************************************************************************************
493 : !> \brief Helper routines for getting rsgrid properties and asserting underlying assumptions.
494 : !> \param rsgrid ...
495 : !> \param npts_global ...
496 : !> \param npts_local ...
497 : !> \param shift_local ...
498 : !> \param border_width ...
499 : !> \author Ole Schuett
500 : ! **************************************************************************************************
501 2180669 : SUBROUTINE get_rsgrid_properties(rsgrid, npts_global, npts_local, shift_local, border_width)
502 : TYPE(realspace_grid_type), INTENT(IN) :: rsgrid
503 : INTEGER, DIMENSION(:) :: npts_global, npts_local, shift_local, &
504 : border_width
505 :
506 : INTEGER :: i
507 :
508 : ! See rs_grid_create() in ./src/pw/realspace_grid_types.F.
509 4361338 : CPASSERT(LBOUND(rsgrid%r, 1) == rsgrid%lb_local(1))
510 4361338 : CPASSERT(UBOUND(rsgrid%r, 1) == rsgrid%ub_local(1))
511 4361338 : CPASSERT(LBOUND(rsgrid%r, 2) == rsgrid%lb_local(2))
512 4361338 : CPASSERT(UBOUND(rsgrid%r, 2) == rsgrid%ub_local(2))
513 4361338 : CPASSERT(LBOUND(rsgrid%r, 3) == rsgrid%lb_local(3))
514 4361338 : CPASSERT(UBOUND(rsgrid%r, 3) == rsgrid%ub_local(3))
515 :
516 : ! While the rsgrid code assumes that the grid starts at rsgrid%lb,
517 : ! the collocate code assumes that the grid starts at (1,1,1) in Fortran, or (0,0,0) in C.
518 : ! So, a point rp(:) gets the following grid coordinates MODULO(rp(:)/dr(:),npts_global(:))
519 :
520 : ! Number of global grid points in each direction.
521 8722676 : npts_global = rsgrid%desc%ub - rsgrid%desc%lb + 1
522 :
523 : ! Number of local grid points in each direction.
524 8722676 : npts_local = rsgrid%ub_local - rsgrid%lb_local + 1
525 :
526 : ! Number of points the local grid is shifted wrt global grid.
527 8722676 : shift_local = rsgrid%lb_local - rsgrid%desc%lb
528 :
529 : ! Convert rsgrid%desc%border and rsgrid%desc%perd into the more convenient border_width array.
530 8722676 : DO i = 1, 3
531 8722676 : IF (rsgrid%desc%perd(i) == 1) THEN
532 : ! Periodic meaning the grid in this direction is entriely present on every processor.
533 6541571 : CPASSERT(npts_local(i) == npts_global(i))
534 6541571 : CPASSERT(shift_local(i) == 0)
535 : ! No need for halo regions.
536 6541571 : border_width(i) = 0
537 : ELSE
538 : ! Not periodic meaning the grid in this direction is distributed among processors.
539 436 : CPASSERT(npts_local(i) <= npts_global(i))
540 : ! Check bounds of grid section that is owned by this processor.
541 436 : CPASSERT(rsgrid%lb_real(i) == rsgrid%lb_local(i) + rsgrid%desc%border)
542 436 : CPASSERT(rsgrid%ub_real(i) == rsgrid%ub_local(i) - rsgrid%desc%border)
543 : ! We have halo regions.
544 436 : border_width(i) = rsgrid%desc%border
545 : END IF
546 : END DO
547 2180669 : END SUBROUTINE get_rsgrid_properties
548 :
549 : ! **************************************************************************************************
550 : !> \brief Allocates a basis set which can be passed to grid_create_task_list.
551 : !> \param nset ...
552 : !> \param nsgf ...
553 : !> \param maxco ...
554 : !> \param maxpgf ...
555 : !> \param lmin ...
556 : !> \param lmax ...
557 : !> \param npgf ...
558 : !> \param nsgf_set ...
559 : !> \param first_sgf ...
560 : !> \param sphi ...
561 : !> \param zet ...
562 : !> \param basis_set ...
563 : !> \author Ole Schuett
564 : ! **************************************************************************************************
565 17357 : SUBROUTINE grid_create_basis_set(nset, nsgf, maxco, maxpgf, &
566 17357 : lmin, lmax, npgf, nsgf_set, first_sgf, sphi, zet, &
567 : basis_set)
568 : INTEGER, INTENT(IN) :: nset, nsgf, maxco, maxpgf
569 : INTEGER, DIMENSION(:), INTENT(IN), TARGET :: lmin, lmax, npgf, nsgf_set
570 : INTEGER, DIMENSION(:, :), INTENT(IN) :: first_sgf
571 : REAL(KIND=dp), DIMENSION(:, :), INTENT(IN), TARGET :: sphi, zet
572 : TYPE(grid_basis_set_type), INTENT(INOUT) :: basis_set
573 :
574 : CHARACTER(LEN=*), PARAMETER :: routineN = 'grid_create_basis_set'
575 :
576 : INTEGER :: handle
577 34714 : INTEGER, DIMENSION(nset), TARGET :: my_first_sgf
578 : TYPE(C_PTR) :: first_sgf_c, lmax_c, lmin_c, npgf_c, &
579 : nsgf_set_c, sphi_c, zet_c
580 : INTERFACE
581 : SUBROUTINE grid_create_basis_set_c(nset, nsgf, maxco, maxpgf, &
582 : lmin, lmax, npgf, nsgf_set, first_sgf, sphi, zet, &
583 : basis_set) &
584 : BIND(C, name="grid_create_basis_set")
585 : IMPORT :: C_PTR, C_INT
586 : INTEGER(KIND=C_INT), VALUE :: nset
587 : INTEGER(KIND=C_INT), VALUE :: nsgf
588 : INTEGER(KIND=C_INT), VALUE :: maxco
589 : INTEGER(KIND=C_INT), VALUE :: maxpgf
590 : TYPE(C_PTR), VALUE :: lmin
591 : TYPE(C_PTR), VALUE :: lmax
592 : TYPE(C_PTR), VALUE :: npgf
593 : TYPE(C_PTR), VALUE :: nsgf_set
594 : TYPE(C_PTR), VALUE :: first_sgf
595 : TYPE(C_PTR), VALUE :: sphi
596 : TYPE(C_PTR), VALUE :: zet
597 : TYPE(C_PTR) :: basis_set
598 : END SUBROUTINE grid_create_basis_set_c
599 : END INTERFACE
600 :
601 17357 : CALL timeset(routineN, handle)
602 :
603 17357 : CPASSERT(SIZE(lmin) == nset)
604 17357 : CPASSERT(SIZE(lmin) == nset)
605 17357 : CPASSERT(SIZE(lmax) == nset)
606 17357 : CPASSERT(SIZE(npgf) == nset)
607 17357 : CPASSERT(SIZE(nsgf_set) == nset)
608 17357 : CPASSERT(SIZE(first_sgf, 2) == nset)
609 17357 : CPASSERT(SIZE(sphi, 1) == maxco .AND. SIZE(sphi, 2) == nsgf)
610 17357 : CPASSERT(SIZE(zet, 1) == maxpgf .AND. SIZE(zet, 2) == nset)
611 17357 : CPASSERT(.NOT. C_ASSOCIATED(basis_set%c_ptr))
612 :
613 : #if __GNUC__ >= 9
614 17357 : CPASSERT(IS_CONTIGUOUS(lmin))
615 17357 : CPASSERT(IS_CONTIGUOUS(lmax))
616 17357 : CPASSERT(IS_CONTIGUOUS(npgf))
617 17357 : CPASSERT(IS_CONTIGUOUS(nsgf_set))
618 : CPASSERT(IS_CONTIGUOUS(my_first_sgf))
619 17357 : CPASSERT(IS_CONTIGUOUS(sphi))
620 17357 : CPASSERT(IS_CONTIGUOUS(zet))
621 : #endif
622 :
623 17357 : lmin_c = C_NULL_PTR
624 17357 : lmax_c = C_NULL_PTR
625 17357 : npgf_c = C_NULL_PTR
626 17357 : nsgf_set_c = C_NULL_PTR
627 17357 : first_sgf_c = C_NULL_PTR
628 17357 : sphi_c = C_NULL_PTR
629 17357 : zet_c = C_NULL_PTR
630 :
631 : ! Basis sets arrays can be empty, need to check before accessing the first element.
632 17357 : IF (nset > 0) THEN
633 17349 : lmin_c = C_LOC(lmin(1))
634 17349 : lmax_c = C_LOC(lmax(1))
635 17349 : npgf_c = C_LOC(npgf(1))
636 17349 : nsgf_set_c = C_LOC(nsgf_set(1))
637 : END IF
638 52071 : IF (SIZE(first_sgf) > 0) THEN
639 57010 : my_first_sgf(:) = first_sgf(1, :) ! make a contiguous copy
640 17349 : first_sgf_c = C_LOC(my_first_sgf(1))
641 : END IF
642 52071 : IF (SIZE(sphi) > 0) THEN
643 17347 : sphi_c = C_LOC(sphi(1, 1))
644 : END IF
645 52071 : IF (SIZE(zet) > 0) THEN
646 17347 : zet_c = C_LOC(zet(1, 1))
647 : END IF
648 :
649 : CALL grid_create_basis_set_c(nset=nset, &
650 : nsgf=nsgf, &
651 : maxco=maxco, &
652 : maxpgf=maxpgf, &
653 : lmin=lmin_c, &
654 : lmax=lmax_c, &
655 : npgf=npgf_c, &
656 : nsgf_set=nsgf_set_c, &
657 : first_sgf=first_sgf_c, &
658 : sphi=sphi_c, &
659 : zet=zet_c, &
660 17357 : basis_set=basis_set%c_ptr)
661 17357 : CPASSERT(C_ASSOCIATED(basis_set%c_ptr))
662 :
663 17357 : CALL timestop(handle)
664 17357 : END SUBROUTINE grid_create_basis_set
665 :
666 : ! **************************************************************************************************
667 : !> \brief Deallocates given basis set.
668 : !> \param basis_set ...
669 : !> \author Ole Schuett
670 : ! **************************************************************************************************
671 17357 : SUBROUTINE grid_free_basis_set(basis_set)
672 : TYPE(grid_basis_set_type), INTENT(INOUT) :: basis_set
673 :
674 : CHARACTER(LEN=*), PARAMETER :: routineN = 'grid_free_basis_set'
675 :
676 : INTEGER :: handle
677 : INTERFACE
678 : SUBROUTINE grid_free_basis_set_c(basis_set) &
679 : BIND(C, name="grid_free_basis_set")
680 : IMPORT :: C_PTR
681 : TYPE(C_PTR), VALUE :: basis_set
682 : END SUBROUTINE grid_free_basis_set_c
683 : END INTERFACE
684 :
685 17357 : CALL timeset(routineN, handle)
686 :
687 17357 : CPASSERT(C_ASSOCIATED(basis_set%c_ptr))
688 :
689 17357 : CALL grid_free_basis_set_c(basis_set%c_ptr)
690 :
691 17357 : basis_set%c_ptr = C_NULL_PTR
692 :
693 17357 : CALL timestop(handle)
694 17357 : END SUBROUTINE grid_free_basis_set
695 :
696 : ! **************************************************************************************************
697 : !> \brief Allocates a task list which can be passed to grid_collocate_task_list.
698 : !> \param ntasks ...
699 : !> \param natoms ...
700 : !> \param nkinds ...
701 : !> \param nblocks ...
702 : !> \param block_offsets ...
703 : !> \param atom_positions ...
704 : !> \param atom_kinds ...
705 : !> \param basis_sets ...
706 : !> \param level_list ...
707 : !> \param iatom_list ...
708 : !> \param jatom_list ...
709 : !> \param iset_list ...
710 : !> \param jset_list ...
711 : !> \param ipgf_list ...
712 : !> \param jpgf_list ...
713 : !> \param border_mask_list ...
714 : !> \param block_num_list ...
715 : !> \param radius_list ...
716 : !> \param rab_list ...
717 : !> \param rs_grids ...
718 : !> \param task_list ...
719 : !> \author Ole Schuett
720 : ! **************************************************************************************************
721 16338 : SUBROUTINE grid_create_task_list(ntasks, natoms, nkinds, nblocks, &
722 16338 : block_offsets, atom_positions, atom_kinds, basis_sets, &
723 16338 : level_list, iatom_list, jatom_list, &
724 16338 : iset_list, jset_list, ipgf_list, jpgf_list, &
725 16338 : border_mask_list, block_num_list, &
726 16338 : radius_list, rab_list, rs_grids, task_list)
727 :
728 : INTEGER, INTENT(IN) :: ntasks, natoms, nkinds, nblocks
729 : INTEGER, DIMENSION(:), INTENT(IN), TARGET :: block_offsets
730 : REAL(KIND=dp), DIMENSION(:, :), INTENT(IN), TARGET :: atom_positions
731 : INTEGER, DIMENSION(:), INTENT(IN), TARGET :: atom_kinds
732 : TYPE(grid_basis_set_type), DIMENSION(:), &
733 : INTENT(IN), TARGET :: basis_sets
734 : INTEGER, DIMENSION(:), INTENT(IN), TARGET :: level_list, iatom_list, jatom_list, &
735 : iset_list, jset_list, ipgf_list, &
736 : jpgf_list, border_mask_list, &
737 : block_num_list
738 : REAL(KIND=dp), DIMENSION(:), INTENT(IN), TARGET :: radius_list
739 : REAL(KIND=dp), DIMENSION(:, :), INTENT(IN), TARGET :: rab_list
740 : TYPE(realspace_grid_type), DIMENSION(:), &
741 : INTENT(IN) :: rs_grids
742 : TYPE(grid_task_list_type), INTENT(INOUT) :: task_list
743 :
744 : CHARACTER(LEN=*), PARAMETER :: routineN = 'grid_create_task_list'
745 :
746 : INTEGER :: handle, ikind, ilevel, nlevels
747 16338 : INTEGER, ALLOCATABLE, DIMENSION(:, :), TARGET :: border_width, npts_global, npts_local, &
748 16338 : shift_local
749 : LOGICAL(KIND=C_BOOL) :: orthorhombic
750 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :), &
751 16338 : TARGET :: dh, dh_inv
752 : TYPE(C_PTR) :: block_num_list_c, block_offsets_c, border_mask_list_c, iatom_list_c, &
753 : ipgf_list_c, iset_list_c, jatom_list_c, jpgf_list_c, jset_list_c, level_list_c, &
754 : rab_list_c, radius_list_c
755 16338 : TYPE(C_PTR), ALLOCATABLE, DIMENSION(:), TARGET :: basis_sets_c
756 : INTERFACE
757 : SUBROUTINE grid_create_task_list_c(orthorhombic, &
758 : ntasks, nlevels, natoms, nkinds, nblocks, &
759 : block_offsets, atom_positions, atom_kinds, basis_sets, &
760 : level_list, iatom_list, jatom_list, &
761 : iset_list, jset_list, ipgf_list, jpgf_list, &
762 : border_mask_list, block_num_list, &
763 : radius_list, rab_list, &
764 : npts_global, npts_local, shift_local, &
765 : border_width, dh, dh_inv, task_list) &
766 : BIND(C, name="grid_create_task_list")
767 : IMPORT :: C_PTR, C_INT, C_BOOL
768 : LOGICAL(KIND=C_BOOL), VALUE :: orthorhombic
769 : INTEGER(KIND=C_INT), VALUE :: ntasks
770 : INTEGER(KIND=C_INT), VALUE :: nlevels
771 : INTEGER(KIND=C_INT), VALUE :: natoms
772 : INTEGER(KIND=C_INT), VALUE :: nkinds
773 : INTEGER(KIND=C_INT), VALUE :: nblocks
774 : TYPE(C_PTR), VALUE :: block_offsets
775 : TYPE(C_PTR), VALUE :: atom_positions
776 : TYPE(C_PTR), VALUE :: atom_kinds
777 : TYPE(C_PTR), VALUE :: basis_sets
778 : TYPE(C_PTR), VALUE :: level_list
779 : TYPE(C_PTR), VALUE :: iatom_list
780 : TYPE(C_PTR), VALUE :: jatom_list
781 : TYPE(C_PTR), VALUE :: iset_list
782 : TYPE(C_PTR), VALUE :: jset_list
783 : TYPE(C_PTR), VALUE :: ipgf_list
784 : TYPE(C_PTR), VALUE :: jpgf_list
785 : TYPE(C_PTR), VALUE :: border_mask_list
786 : TYPE(C_PTR), VALUE :: block_num_list
787 : TYPE(C_PTR), VALUE :: radius_list
788 : TYPE(C_PTR), VALUE :: rab_list
789 : TYPE(C_PTR), VALUE :: npts_global
790 : TYPE(C_PTR), VALUE :: npts_local
791 : TYPE(C_PTR), VALUE :: shift_local
792 : TYPE(C_PTR), VALUE :: border_width
793 : TYPE(C_PTR), VALUE :: dh
794 : TYPE(C_PTR), VALUE :: dh_inv
795 : TYPE(C_PTR) :: task_list
796 : END SUBROUTINE grid_create_task_list_c
797 : END INTERFACE
798 :
799 16338 : CALL timeset(routineN, handle)
800 :
801 16338 : CPASSERT(SIZE(block_offsets) == nblocks)
802 16338 : CPASSERT(SIZE(atom_positions, 1) == 3 .AND. SIZE(atom_positions, 2) == natoms)
803 16338 : CPASSERT(SIZE(atom_kinds) == natoms)
804 16338 : CPASSERT(SIZE(basis_sets) == nkinds)
805 16338 : CPASSERT(SIZE(level_list) == ntasks)
806 16338 : CPASSERT(SIZE(iatom_list) == ntasks)
807 16338 : CPASSERT(SIZE(jatom_list) == ntasks)
808 16338 : CPASSERT(SIZE(iset_list) == ntasks)
809 16338 : CPASSERT(SIZE(jset_list) == ntasks)
810 16338 : CPASSERT(SIZE(ipgf_list) == ntasks)
811 16338 : CPASSERT(SIZE(jpgf_list) == ntasks)
812 16338 : CPASSERT(SIZE(border_mask_list) == ntasks)
813 16338 : CPASSERT(SIZE(block_num_list) == ntasks)
814 16338 : CPASSERT(SIZE(radius_list) == ntasks)
815 16338 : CPASSERT(SIZE(rab_list, 1) == 3 .AND. SIZE(rab_list, 2) == ntasks)
816 :
817 49014 : ALLOCATE (basis_sets_c(nkinds))
818 45293 : DO ikind = 1, nkinds
819 45293 : basis_sets_c(ikind) = basis_sets(ikind)%c_ptr
820 : END DO
821 :
822 16338 : nlevels = SIZE(rs_grids)
823 16338 : CPASSERT(nlevels > 0)
824 16338 : orthorhombic = LOGICAL(rs_grids(1)%desc%orthorhombic, C_BOOL)
825 :
826 65352 : ALLOCATE (npts_global(3, nlevels), npts_local(3, nlevels))
827 49014 : ALLOCATE (shift_local(3, nlevels), border_width(3, nlevels))
828 65352 : ALLOCATE (dh(3, 3, nlevels), dh_inv(3, 3, nlevels))
829 81112 : DO ilevel = 1, nlevels
830 16338 : ASSOCIATE (rsgrid => rs_grids(ilevel))
831 : CALL get_rsgrid_properties(rsgrid=rsgrid, &
832 : npts_global=npts_global(:, ilevel), &
833 : npts_local=npts_local(:, ilevel), &
834 : shift_local=shift_local(:, ilevel), &
835 64774 : border_width=border_width(:, ilevel))
836 64774 : CPASSERT(rsgrid%desc%orthorhombic .EQV. orthorhombic) ! should be the same for all levels
837 842062 : dh(:, :, ilevel) = rsgrid%desc%dh(:, :)
838 906836 : dh_inv(:, :, ilevel) = rsgrid%desc%dh_inv(:, :)
839 : END ASSOCIATE
840 : END DO
841 :
842 : #if __GNUC__ >= 9
843 16338 : CPASSERT(IS_CONTIGUOUS(block_offsets))
844 16338 : CPASSERT(IS_CONTIGUOUS(atom_positions))
845 16338 : CPASSERT(IS_CONTIGUOUS(atom_kinds))
846 16338 : CPASSERT(IS_CONTIGUOUS(basis_sets))
847 16338 : CPASSERT(IS_CONTIGUOUS(level_list))
848 16338 : CPASSERT(IS_CONTIGUOUS(iatom_list))
849 16338 : CPASSERT(IS_CONTIGUOUS(jatom_list))
850 16338 : CPASSERT(IS_CONTIGUOUS(iset_list))
851 16338 : CPASSERT(IS_CONTIGUOUS(jset_list))
852 16338 : CPASSERT(IS_CONTIGUOUS(ipgf_list))
853 16338 : CPASSERT(IS_CONTIGUOUS(jpgf_list))
854 16338 : CPASSERT(IS_CONTIGUOUS(border_mask_list))
855 16338 : CPASSERT(IS_CONTIGUOUS(block_num_list))
856 16338 : CPASSERT(IS_CONTIGUOUS(radius_list))
857 16338 : CPASSERT(IS_CONTIGUOUS(rab_list))
858 : CPASSERT(IS_CONTIGUOUS(npts_global))
859 : CPASSERT(IS_CONTIGUOUS(npts_local))
860 : CPASSERT(IS_CONTIGUOUS(shift_local))
861 : CPASSERT(IS_CONTIGUOUS(border_width))
862 : CPASSERT(IS_CONTIGUOUS(dh))
863 : CPASSERT(IS_CONTIGUOUS(dh_inv))
864 : #endif
865 :
866 16338 : IF (ntasks > 0) THEN
867 : block_offsets_c = C_LOC(block_offsets(1))
868 : level_list_c = C_LOC(level_list(1))
869 : iatom_list_c = C_LOC(iatom_list(1))
870 : jatom_list_c = C_LOC(jatom_list(1))
871 : iset_list_c = C_LOC(iset_list(1))
872 : jset_list_c = C_LOC(jset_list(1))
873 : ipgf_list_c = C_LOC(ipgf_list(1))
874 : jpgf_list_c = C_LOC(jpgf_list(1))
875 : border_mask_list_c = C_LOC(border_mask_list(1))
876 : block_num_list_c = C_LOC(block_num_list(1))
877 : radius_list_c = C_LOC(radius_list(1))
878 : rab_list_c = C_LOC(rab_list(1, 1))
879 : ELSE
880 : ! Without tasks the lists are empty and there is no first element to call C_LOC on.
881 245 : block_offsets_c = C_NULL_PTR
882 245 : level_list_c = C_NULL_PTR
883 245 : iatom_list_c = C_NULL_PTR
884 245 : jatom_list_c = C_NULL_PTR
885 245 : iset_list_c = C_NULL_PTR
886 245 : jset_list_c = C_NULL_PTR
887 245 : ipgf_list_c = C_NULL_PTR
888 245 : jpgf_list_c = C_NULL_PTR
889 245 : border_mask_list_c = C_NULL_PTR
890 245 : block_num_list_c = C_NULL_PTR
891 245 : radius_list_c = C_NULL_PTR
892 245 : rab_list_c = C_NULL_PTR
893 : END IF
894 :
895 : !If task_list%c_ptr is already allocated, then its memory will be reused or freed.
896 : CALL grid_create_task_list_c(orthorhombic=orthorhombic, &
897 : ntasks=ntasks, &
898 : nlevels=nlevels, &
899 : natoms=natoms, &
900 : nkinds=nkinds, &
901 : nblocks=nblocks, &
902 : block_offsets=block_offsets_c, &
903 : atom_positions=C_LOC(atom_positions(1, 1)), &
904 : atom_kinds=C_LOC(atom_kinds(1)), &
905 : basis_sets=C_LOC(basis_sets_c(1)), &
906 : level_list=level_list_c, &
907 : iatom_list=iatom_list_c, &
908 : jatom_list=jatom_list_c, &
909 : iset_list=iset_list_c, &
910 : jset_list=jset_list_c, &
911 : ipgf_list=ipgf_list_c, &
912 : jpgf_list=jpgf_list_c, &
913 : border_mask_list=border_mask_list_c, &
914 : block_num_list=block_num_list_c, &
915 : radius_list=radius_list_c, &
916 : rab_list=rab_list_c, &
917 : npts_global=C_LOC(npts_global(1, 1)), &
918 : npts_local=C_LOC(npts_local(1, 1)), &
919 : shift_local=C_LOC(shift_local(1, 1)), &
920 : border_width=C_LOC(border_width(1, 1)), &
921 : dh=C_LOC(dh(1, 1, 1)), &
922 : dh_inv=C_LOC(dh_inv(1, 1, 1)), &
923 16338 : task_list=task_list%c_ptr)
924 :
925 16338 : CPASSERT(C_ASSOCIATED(task_list%c_ptr))
926 :
927 16338 : CALL timestop(handle)
928 32676 : END SUBROUTINE grid_create_task_list
929 :
930 : ! **************************************************************************************************
931 : !> \brief Deallocates given task list, basis_sets have to be freed separately.
932 : !> \param task_list ...
933 : !> \author Ole Schuett
934 : ! **************************************************************************************************
935 9866 : SUBROUTINE grid_free_task_list(task_list)
936 : TYPE(grid_task_list_type), INTENT(INOUT) :: task_list
937 :
938 : CHARACTER(LEN=*), PARAMETER :: routineN = 'grid_free_task_list'
939 :
940 : INTEGER :: handle
941 : INTERFACE
942 : SUBROUTINE grid_free_task_list_c(task_list) &
943 : BIND(C, name="grid_free_task_list")
944 : IMPORT :: C_PTR
945 : TYPE(C_PTR), VALUE :: task_list
946 : END SUBROUTINE grid_free_task_list_c
947 : END INTERFACE
948 :
949 9866 : CALL timeset(routineN, handle)
950 :
951 9866 : IF (C_ASSOCIATED(task_list%c_ptr)) THEN
952 9866 : CALL grid_free_task_list_c(task_list%c_ptr)
953 : END IF
954 :
955 9866 : task_list%c_ptr = C_NULL_PTR
956 :
957 9866 : CALL timestop(handle)
958 9866 : END SUBROUTINE grid_free_task_list
959 :
960 : ! **************************************************************************************************
961 : !> \brief Collocate all tasks of in given list onto given grids.
962 : !> \param task_list ...
963 : !> \param ga_gb_function ...
964 : !> \param pab_blocks ...
965 : !> \param rs_grids ...
966 : !> \author Ole Schuett
967 : ! **************************************************************************************************
968 238534 : SUBROUTINE grid_collocate_task_list(task_list, ga_gb_function, pab_blocks, rs_grids)
969 : TYPE(grid_task_list_type), INTENT(IN) :: task_list
970 : INTEGER, INTENT(IN) :: ga_gb_function
971 : TYPE(offload_buffer_type), INTENT(IN) :: pab_blocks
972 : TYPE(realspace_grid_type), DIMENSION(:), &
973 : INTENT(IN) :: rs_grids
974 :
975 : CHARACTER(LEN=*), PARAMETER :: routineN = 'grid_collocate_task_list'
976 :
977 : INTEGER :: handle, ilevel, nlevels
978 238534 : INTEGER, ALLOCATABLE, DIMENSION(:, :), TARGET :: npts_local
979 238534 : TYPE(C_PTR), ALLOCATABLE, DIMENSION(:), TARGET :: grids_c
980 : INTERFACE
981 : SUBROUTINE grid_collocate_task_list_c(task_list, func, nlevels, &
982 : npts_local, pab_blocks, grids) &
983 : BIND(C, name="grid_collocate_task_list")
984 : IMPORT :: C_PTR, C_INT, C_BOOL
985 : TYPE(C_PTR), VALUE :: task_list
986 : INTEGER(KIND=C_INT), VALUE :: func
987 : INTEGER(KIND=C_INT), VALUE :: nlevels
988 : TYPE(C_PTR), VALUE :: npts_local
989 : TYPE(C_PTR), VALUE :: pab_blocks
990 : TYPE(C_PTR), VALUE :: grids
991 : END SUBROUTINE grid_collocate_task_list_c
992 : END INTERFACE
993 :
994 238534 : CALL timeset(routineN, handle)
995 :
996 238534 : nlevels = SIZE(rs_grids)
997 238534 : CPASSERT(nlevels > 0)
998 :
999 715602 : ALLOCATE (grids_c(nlevels))
1000 715602 : ALLOCATE (npts_local(3, nlevels))
1001 1181808 : DO ilevel = 1, nlevels
1002 238534 : ASSOCIATE (rsgrid => rs_grids(ilevel))
1003 3773096 : npts_local(:, ilevel) = rsgrid%ub_local - rsgrid%lb_local + 1
1004 1886548 : grids_c(ilevel) = rsgrid%buffer%c_ptr
1005 : END ASSOCIATE
1006 : END DO
1007 :
1008 : #if __GNUC__ >= 9
1009 : CPASSERT(IS_CONTIGUOUS(npts_local))
1010 : CPASSERT(IS_CONTIGUOUS(grids_c))
1011 : #endif
1012 :
1013 238534 : CPASSERT(C_ASSOCIATED(task_list%c_ptr))
1014 238534 : CPASSERT(C_ASSOCIATED(pab_blocks%c_ptr))
1015 :
1016 : CALL grid_collocate_task_list_c(task_list=task_list%c_ptr, &
1017 : func=ga_gb_function, &
1018 : nlevels=nlevels, &
1019 : npts_local=C_LOC(npts_local(1, 1)), &
1020 : pab_blocks=pab_blocks%c_ptr, &
1021 238534 : grids=C_LOC(grids_c(1)))
1022 :
1023 238534 : CALL timestop(handle)
1024 477068 : END SUBROUTINE grid_collocate_task_list
1025 :
1026 : ! **************************************************************************************************
1027 : !> \brief Integrate all tasks of in given list from given grids.
1028 : !> \param task_list ...
1029 : !> \param compute_tau ...
1030 : !> \param calculate_forces ...
1031 : !> \param calculate_virial ...
1032 : !> \param pab_blocks ...
1033 : !> \param rs_grids ...
1034 : !> \param hab_blocks ...
1035 : !> \param forces ...
1036 : !> \param virial ...
1037 : !> \author Ole Schuett
1038 : ! **************************************************************************************************
1039 217430 : SUBROUTINE grid_integrate_task_list(task_list, compute_tau, calculate_forces, calculate_virial, &
1040 217430 : pab_blocks, rs_grids, hab_blocks, forces, virial)
1041 : TYPE(grid_task_list_type), INTENT(IN) :: task_list
1042 : LOGICAL, INTENT(IN) :: compute_tau, calculate_forces, &
1043 : calculate_virial
1044 : TYPE(offload_buffer_type), INTENT(IN) :: pab_blocks
1045 : TYPE(realspace_grid_type), DIMENSION(:), &
1046 : INTENT(IN) :: rs_grids
1047 : TYPE(offload_buffer_type), INTENT(INOUT) :: hab_blocks
1048 : REAL(KIND=dp), DIMENSION(:, :), INTENT(INOUT), &
1049 : TARGET :: forces
1050 : REAL(KIND=dp), DIMENSION(3, 3), INTENT(INOUT), &
1051 : TARGET :: virial
1052 :
1053 : CHARACTER(LEN=*), PARAMETER :: routineN = 'grid_integrate_task_list'
1054 :
1055 : INTEGER :: handle, ilevel, nlevels
1056 217430 : INTEGER, ALLOCATABLE, DIMENSION(:, :), TARGET :: npts_local
1057 : TYPE(C_PTR) :: forces_c, virial_c
1058 217430 : TYPE(C_PTR), ALLOCATABLE, DIMENSION(:), TARGET :: grids_c
1059 : INTERFACE
1060 : SUBROUTINE grid_integrate_task_list_c(task_list, compute_tau, natoms, &
1061 : nlevels, npts_local, &
1062 : pab_blocks, grids, hab_blocks, forces, virial) &
1063 : BIND(C, name="grid_integrate_task_list")
1064 : IMPORT :: C_PTR, C_INT, C_BOOL
1065 : TYPE(C_PTR), VALUE :: task_list
1066 : LOGICAL(KIND=C_BOOL), VALUE :: compute_tau
1067 : INTEGER(KIND=C_INT), VALUE :: natoms
1068 : INTEGER(KIND=C_INT), VALUE :: nlevels
1069 : TYPE(C_PTR), VALUE :: npts_local
1070 : TYPE(C_PTR), VALUE :: pab_blocks
1071 : TYPE(C_PTR), VALUE :: grids
1072 : TYPE(C_PTR), VALUE :: hab_blocks
1073 : TYPE(C_PTR), VALUE :: forces
1074 : TYPE(C_PTR), VALUE :: virial
1075 : END SUBROUTINE grid_integrate_task_list_c
1076 : END INTERFACE
1077 :
1078 217430 : CALL timeset(routineN, handle)
1079 :
1080 217430 : nlevels = SIZE(rs_grids)
1081 217430 : CPASSERT(nlevels > 0)
1082 :
1083 652290 : ALLOCATE (grids_c(nlevels))
1084 652290 : ALLOCATE (npts_local(3, nlevels))
1085 1078372 : DO ilevel = 1, nlevels
1086 217430 : ASSOCIATE (rsgrid => rs_grids(ilevel))
1087 3443768 : npts_local(:, ilevel) = rsgrid%ub_local - rsgrid%lb_local + 1
1088 1721884 : grids_c(ilevel) = rsgrid%buffer%c_ptr
1089 : END ASSOCIATE
1090 : END DO
1091 :
1092 217430 : IF (calculate_forces) THEN
1093 : forces_c = C_LOC(forces(1, 1))
1094 : ELSE
1095 192517 : forces_c = C_NULL_PTR
1096 : END IF
1097 :
1098 217430 : IF (calculate_virial) THEN
1099 3861 : virial_c = C_LOC(virial(1, 1))
1100 : ELSE
1101 : virial_c = C_NULL_PTR
1102 : END IF
1103 :
1104 : #if __GNUC__ >= 9
1105 : CPASSERT(IS_CONTIGUOUS(npts_local))
1106 : CPASSERT(IS_CONTIGUOUS(grids_c))
1107 217430 : CPASSERT(IS_CONTIGUOUS(forces))
1108 : CPASSERT(IS_CONTIGUOUS(virial))
1109 : #endif
1110 :
1111 217430 : CPASSERT(SIZE(forces, 1) == 3)
1112 217430 : CPASSERT(C_ASSOCIATED(task_list%c_ptr))
1113 217430 : CPASSERT(C_ASSOCIATED(hab_blocks%c_ptr))
1114 217430 : CPASSERT(C_ASSOCIATED(pab_blocks%c_ptr) .OR. .NOT. calculate_forces)
1115 217430 : CPASSERT(C_ASSOCIATED(pab_blocks%c_ptr) .OR. .NOT. calculate_virial)
1116 :
1117 : CALL grid_integrate_task_list_c(task_list=task_list%c_ptr, &
1118 : compute_tau=LOGICAL(compute_tau, C_BOOL), &
1119 : natoms=SIZE(forces, 2), &
1120 : nlevels=nlevels, &
1121 : npts_local=C_LOC(npts_local(1, 1)), &
1122 : pab_blocks=pab_blocks%c_ptr, &
1123 : grids=C_LOC(grids_c(1)), &
1124 : hab_blocks=hab_blocks%c_ptr, &
1125 : forces=forces_c, &
1126 217430 : virial=virial_c)
1127 :
1128 217430 : CALL timestop(handle)
1129 434860 : END SUBROUTINE grid_integrate_task_list
1130 :
1131 : ! **************************************************************************************************
1132 : !> \brief Initialize grid library
1133 : !> \author Ole Schuett
1134 : ! **************************************************************************************************
1135 10486 : SUBROUTINE grid_library_init()
1136 : INTERFACE
1137 : SUBROUTINE grid_library_init_c() BIND(C, name="grid_library_init")
1138 : END SUBROUTINE grid_library_init_c
1139 : END INTERFACE
1140 :
1141 10486 : CALL grid_library_init_c()
1142 :
1143 10486 : END SUBROUTINE grid_library_init
1144 :
1145 : ! **************************************************************************************************
1146 : !> \brief Finalize grid library
1147 : !> \author Ole Schuett
1148 : ! **************************************************************************************************
1149 10486 : SUBROUTINE grid_library_finalize()
1150 : INTERFACE
1151 : SUBROUTINE grid_library_finalize_c() BIND(C, name="grid_library_finalize")
1152 : END SUBROUTINE grid_library_finalize_c
1153 : END INTERFACE
1154 :
1155 10486 : CALL grid_library_finalize_c()
1156 :
1157 10486 : END SUBROUTINE grid_library_finalize
1158 :
1159 : ! **************************************************************************************************
1160 : !> \brief Configures the grid library
1161 : !> \param backend : backend to be used for collocate/integrate, possible values are REF, CPU, GPU
1162 : !> \param validate : if set to true, compare the results of all backend to the reference backend
1163 : !> \param apply_cutoff : apply a spherical cutoff before collocating or integrating. Only relevant for CPU backend
1164 : !> \author Ole Schuett
1165 : ! **************************************************************************************************
1166 10604 : SUBROUTINE grid_library_set_config(backend, validate, apply_cutoff)
1167 : INTEGER, INTENT(IN) :: backend
1168 : LOGICAL, INTENT(IN) :: validate, apply_cutoff
1169 :
1170 : INTERFACE
1171 : SUBROUTINE grid_library_set_config_c(backend, validate, apply_cutoff) &
1172 : BIND(C, name="grid_library_set_config")
1173 : IMPORT :: C_INT, C_BOOL
1174 : INTEGER(KIND=C_INT), VALUE :: backend
1175 : LOGICAL(KIND=C_BOOL), VALUE :: validate
1176 : LOGICAL(KIND=C_BOOL), VALUE :: apply_cutoff
1177 : END SUBROUTINE grid_library_set_config_c
1178 : END INTERFACE
1179 :
1180 : CALL grid_library_set_config_c(backend=backend, &
1181 : validate=LOGICAL(validate, C_BOOL), &
1182 10604 : apply_cutoff=LOGICAL(apply_cutoff, C_BOOL))
1183 :
1184 10604 : END SUBROUTINE grid_library_set_config
1185 :
1186 : ! **************************************************************************************************
1187 : !> \brief Print grid library statistics
1188 : !> \param mpi_comm ...
1189 : !> \param output_unit ...
1190 : !> \author Ole Schuett
1191 : ! **************************************************************************************************
1192 10604 : SUBROUTINE grid_library_print_stats(mpi_comm, output_unit)
1193 : TYPE(mp_comm_type) :: mpi_comm
1194 : INTEGER, INTENT(IN) :: output_unit
1195 :
1196 : INTERFACE
1197 : SUBROUTINE grid_library_print_stats_c(mpi_comm, print_func, output_unit) &
1198 : BIND(C, name="grid_library_print_stats")
1199 : IMPORT :: C_FUNPTR, C_INT
1200 : INTEGER(KIND=C_INT), VALUE :: mpi_comm
1201 : TYPE(C_FUNPTR), VALUE :: print_func
1202 : INTEGER(KIND=C_INT), VALUE :: output_unit
1203 : END SUBROUTINE grid_library_print_stats_c
1204 : END INTERFACE
1205 :
1206 : ! Since Fortran units and mpi groups can't be used from C, we pass function pointers instead.
1207 : CALL grid_library_print_stats_c(mpi_comm=mpi_comm%get_handle(), &
1208 : print_func=C_FUNLOC(print_func), &
1209 10604 : output_unit=output_unit)
1210 :
1211 10604 : END SUBROUTINE grid_library_print_stats
1212 :
1213 : ! **************************************************************************************************
1214 : !> \brief Callback to write to a Fortran output unit (called by C-side).
1215 : !> \param msg to be printed.
1216 : !> \param msglen number of characters excluding the terminating character.
1217 : !> \param output_unit used for output.
1218 : !> \author Ole Schuett and Hans Pabst
1219 : ! **************************************************************************************************
1220 106900 : SUBROUTINE print_func(msg, msglen, output_unit) BIND(C, name="grid_api_print_func")
1221 : CHARACTER(KIND=C_CHAR), INTENT(IN) :: msg(*)
1222 : INTEGER(KIND=C_INT), INTENT(IN), VALUE :: msglen, output_unit
1223 :
1224 106900 : IF (output_unit <= 0) RETURN ! Omit to print the message.
1225 53450 : WRITE (output_unit, FMT="(100A)", ADVANCE="NO") msg(1:msglen)
1226 : END SUBROUTINE print_func
1227 0 : END MODULE grid_api
|
