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: GPL-2.0-or-later !
6 : !--------------------------------------------------------------------------------------------------!
7 :
8 : ! **************************************************************************************************
9 : !> \brief Includes all necessary routines, functions and parameters from
10 : !> libxc. Provides CP2K routines/functions where the LibXC calling list
11 : !> is version dependent (>=4.0.3). The naming convention for such
12 : !> routines/functions is xc_f03_XXX --> 'xc_libxc_wrap_XXX'. All version
13 : !> independent routines/functions are just bypassed to higher level
14 : !> module file 'xc_libxc'.
15 : !>
16 : !> \par History
17 : !> 08.2015 created [A. Gloess (agloess)]
18 : !> 01.2018 refactoring [A. Gloess (agloess)]
19 : !> 10.2018/04.2019 added hyb_mgga [S. Simko, included by F. Stein]
20 : !> \author A. Gloess (agloess)
21 : ! **************************************************************************************************
22 : #:include 'xc_gamma.fypp'
23 :
24 : #! Every staging buffer of a worker, so that the component count and the
25 : #! release cannot fall out of step with the allocation.
26 : #:set worker_1d = ["exc", "nd", "nda", "ndb"]
27 : #:set worker_2d = ["rho", "sigma", "lapl", "tau", "vrho", "vsigma", "vlapl", "vtau", &
28 : & "v2rho2", "v2rhosigma", "v2sigma2", "v2rholapl", "v2rhotau", &
29 : & "v2sigmalapl", "v2sigmatau", "v2lapl2", "v2lapltau", "v2tau2", &
30 : & "v3rho3", "v3rho2sigma", "v3rhosigma2", "v3sigma3"] + v3_new
31 :
32 : MODULE xc_libxc_wrap
33 : #if defined (__LIBXC)
34 : #include <xc_version.h>
35 : ! check for LibXC version - updated for LibXC 7.x
36 : #if (XC_MAJOR_VERSION < 7)
37 : #error "This version of CP2K requires libxc version 7.x or above for full functionality. Some features may not be available with older versions."
38 : #else
39 : USE kinds, ONLY: dp
40 : USE input_constants, ONLY: do_libxc_cpu, do_libxc_gpu
41 : USE xc_f03_lib_m, ONLY: xc_f03_func_end, &
42 : xc_f03_func_init, &
43 : xc_f03_functional_get_name, &
44 : xc_f03_func_set_ext_params, &
45 : xc_f03_func_set_dens_threshold, &
46 : xc_f03_func_set_tau_threshold, &
47 : xc_f03_version_string, &
48 : xc_f03_reference, &
49 : xc_f03_reference_doi, &
50 : xc_f03_functional_get_number, &
51 : xc_f03_available_functional_numbers, &
52 : xc_f03_available_functional_names, &
53 : xc_f03_maximum_name_length, &
54 : xc_f03_number_of_functionals, &
55 : !
56 : xc_f03_gga_exc, &
57 : xc_f03_gga_exc_vxc, &
58 : xc_f03_gga_exc_vxc_fxc, &
59 : xc_f03_gga_exc_vxc_fxc_kxc, &
60 : xc_f03_mgga_exc_vxc_fxc_kxc, &
61 : xc_f03_mgga_vxc_fxc_kxc, &
62 : xc_f03_gga_fxc, &
63 : xc_f03_gga_vxc, &
64 : xc_f03_gga_vxc_fxc, &
65 : xc_f03_gga_vxc_fxc_kxc, &
66 : !
67 : xc_f03_func_get_info, &
68 : xc_f03_func_info_get_family, &
69 : xc_f03_func_info_get_kind, &
70 : xc_f03_func_info_get_name, &
71 : xc_f03_func_info_get_references, &
72 : xc_f03_func_info_get_flags, &
73 : xc_f03_func_info_get_n_ext_params, &
74 : xc_f03_func_info_get_ext_params_name, &
75 : xc_f03_func_info_get_ext_params_default_value, &
76 : xc_f03_func_info_get_ext_params_description, &
77 : !
78 : xc_f03_func_reference_get_ref, &
79 : xc_f03_func_reference_get_doi, &
80 : !
81 : xc_f03_lda_exc_vxc_fxc_kxc, &
82 : xc_f03_lda_exc, &
83 : xc_f03_lda_exc_vxc, &
84 : xc_f03_lda_exc_vxc_fxc, &
85 : xc_f03_lda_fxc, &
86 : xc_f03_lda_kxc, &
87 : xc_f03_lda_vxc, &
88 : xc_f03_lda_vxc_fxc, &
89 : xc_f03_lda_vxc_fxc_kxc, &
90 : !
91 : xc_f03_mgga_exc_vxc_fxc, &
92 : xc_f03_mgga_exc, &
93 : xc_f03_mgga_exc_vxc, &
94 : xc_f03_mgga_fxc, &
95 : xc_f03_mgga_vxc, &
96 : xc_f03_mgga_vxc_fxc, &
97 : !
98 : xc_f03_func_t, &
99 : xc_f03_func_info_t, &
100 : xc_f03_func_reference_t, &
101 : !
102 : XC_FAMILY_LDA, &
103 : XC_FAMILY_GGA, &
104 : XC_FAMILY_MGGA, &
105 : XC_FAMILY_HYB_LDA, &
106 : XC_FAMILY_HYB_GGA, &
107 : XC_FAMILY_HYB_MGGA, &
108 : !
109 : XC_UNPOLARIZED, &
110 : XC_POLARIZED, &
111 : !
112 : XC_EXCHANGE, &
113 : XC_CORRELATION, &
114 : XC_EXCHANGE_CORRELATION, &
115 : XC_KINETIC, &
116 : !
117 : XC_FLAGS_NEEDS_LAPLACIAN, &
118 : XC_FLAGS_HAVE_EXC, &
119 : XC_FLAGS_DEVELOPMENT, &
120 : XC_FLAGS_ON_HOST, &
121 : XC_FLAGS_ON_DEVICE, &
122 : xc_f03_func_info_set_default_flags
123 :
124 : #include "../base/base_uses.f90"
125 : USE ISO_C_BINDING, ONLY: C_PTR, C_NULL_PTR, C_SIZE_T, C_ASSOCIATED, C_LOC
126 : #endif
127 : #if defined(__OFFLOAD) && !defined(__NO_OFFLOAD_LIBXC)
128 : USE offload_api, ONLY: offload_buffer_type
129 : #endif
130 : IMPLICIT NONE
131 : PRIVATE
132 : #if defined (__LIBXC)
133 :
134 : CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'xc_libxc_wrap'
135 :
136 : CHARACTER(LEN=*), PARAMETER, PUBLIC :: libxc_version = XC_VERSION
137 :
138 : PUBLIC :: xc_f03_func_t, xc_f03_func_info_t
139 : PUBLIC :: xc_f03_func_init, xc_f03_func_end, xc_f03_func_set_ext_params
140 : PUBLIC :: xc_f03_functional_get_name, xc_f03_available_functional_numbers, xc_f03_maximum_name_length, &
141 : xc_f03_number_of_functionals, xc_f03_available_functional_names
142 : PUBLIC :: xc_f03_func_get_info, xc_f03_func_info_get_family, xc_f03_func_info_get_kind, &
143 : xc_f03_func_info_get_name, xc_f03_func_info_get_ext_params_name, &
144 : xc_f03_func_info_get_ext_params_description, xc_f03_func_info_get_ext_params_default_value, &
145 : xc_f03_func_info_get_n_ext_params
146 : PUBLIC :: xc_f03_gga_exc, xc_f03_gga_exc_vxc, xc_f03_gga_exc_vxc_fxc, xc_f03_gga_fxc, &
147 : xc_f03_gga_vxc, xc_f03_gga_vxc_fxc, &
148 : xc_f03_gga_exc_vxc_fxc_kxc, xc_f03_gga_vxc_fxc_kxc
149 : PUBLIC :: xc_f03_mgga_exc_vxc_fxc_kxc, xc_f03_mgga_vxc_fxc_kxc, &
150 : xc_f03_mgga_exc, xc_f03_mgga_exc_vxc, xc_f03_mgga_exc_vxc_fxc, &
151 : xc_f03_mgga_fxc, xc_f03_mgga_vxc, xc_f03_mgga_vxc_fxc
152 :
153 : PUBLIC :: XC_FAMILY_LDA, XC_FAMILY_GGA, XC_FAMILY_MGGA, &
154 : XC_FAMILY_HYB_LDA, XC_FAMILY_HYB_GGA, XC_FAMILY_HYB_MGGA
155 :
156 : PUBLIC :: XC_UNPOLARIZED, XC_POLARIZED
157 :
158 : PUBLIC :: XC_EXCHANGE, XC_CORRELATION, XC_EXCHANGE_CORRELATION, XC_KINETIC
159 : PUBLIC :: XC_FLAGS_ON_HOST, XC_FLAGS_ON_DEVICE
160 :
161 : ! Create aliases for backward compatibility with the LibXC 6.x interface,
162 : ! which referenced xc_f03_lda / xc_f03_mgga as all-in-one evaluation entries.
163 : PUBLIC :: xc_f03_lda, xc_f03_mgga
164 : PUBLIC :: xc_f03_lda_exc, xc_f03_lda_exc_vxc, xc_f03_lda_exc_vxc_fxc, &
165 : xc_f03_lda_fxc, xc_f03_lda_kxc, xc_f03_lda_vxc
166 :
167 : ! Runtime backend selection. Whether a device backend can ever be selected is
168 : ! a compile-time property (__OFFLOAD and !__NO_OFFLOAD_LIBXC), but the flag
169 : ! itself is always compiled so that callers keep a single runtime branch; on
170 : ! CPU-only builds it can never become the GPU.
171 : #if defined(__OFFLOAD) && !defined(__NO_OFFLOAD_LIBXC)
172 : LOGICAL, PARAMETER, PRIVATE :: libxc_have_device = .TRUE.
173 : #else
174 : LOGICAL, PARAMETER, PRIVATE :: libxc_have_device = .FALSE.
175 : #endif
176 : INTEGER, SAVE, PRIVATE :: libxc_backend = MERGE(do_libxc_gpu, do_libxc_cpu, libxc_have_device)
177 :
178 : ! Debug switch: test the freshly evaluated block for NaNs. Kept here because
179 : ! the per-block evaluation now runs inside this module.
180 : LOGICAL, PARAMETER, PRIVATE :: libxc_check_nan = .FALSE.
181 :
182 : #if defined(__OFFLOAD) && !defined(__NO_OFFLOAD_LIBXC)
183 : ! Device buffer type for GPU memory management. It wraps an offload buffer so
184 : ! that the host-side pinned staging memory and the device allocation share a
185 : ! lifetime and are released exactly once, together.
186 : TYPE, PRIVATE :: libxc_device_buffer_type
187 : TYPE(offload_buffer_type) :: buffer
188 : INTEGER(KIND=C_SIZE_T) :: size = 0
189 : END TYPE libxc_device_buffer_type
190 : #endif
191 :
192 : ! wrappers for routines
193 : PUBLIC :: xc_libxc_wrap_info_refs, &
194 : xc_libxc_wrap_version, &
195 : xc_libxc_wrap_library_reference, &
196 : xc_libxc_wrap_info_needs_laplace, &
197 : xc_libxc_wrap_info_no_exc, &
198 : xc_libxc_wrap_set_thresholds, &
199 : xc_libxc_wrap_functional_get_number, &
200 : xc_libxc_wrap_is_under_development, &
201 : xc_libxc_get_reference_length, &
202 : xc_libxc_check_functional, &
203 : xc_libxc_wrap_init_safe, &
204 : libxc_set_backend, &
205 : libxc_func_init_wrapper, &
206 : libxc_gga_exc_vxc_wrapper, libxc_gga_exc_wrapper, &
207 : libxc_lda_exc_vxc_wrapper, libxc_lda_exc_wrapper, &
208 : libxc_mgga_exc_vxc_wrapper, libxc_mgga_exc_wrapper, &
209 : libxc_mgga_vxc_wrapper
210 : PUBLIC :: libxc_is_gpu
211 :
212 : ! Worker type: one LibXC functional object plus the host staging buffers used
213 : ! to hand it a block of grid points, together with the device buffers mirroring
214 : ! them on the GPU backend. It lives in the wrapper because it owns the device
215 : ! buffers; CPU-only builds compile an empty device section but the same type.
216 : ! One worker is kept per OpenMP thread, so neither the functional object nor
217 : ! the buffers are rebuilt between batches.
218 : INTEGER, PARAMETER, PRIVATE :: libxc_max_dev_buffers = 64
219 :
220 : TYPE, PUBLIC :: libxc_worker_type
221 : TYPE(xc_f03_func_t) :: func = xc_f03_func_t()
222 : TYPE(xc_f03_func_info_t) :: info = xc_f03_func_info_t()
223 : LOGICAL :: is_init = .FALSE.
224 : ! number of points the staging buffers below were allocated for
225 : INTEGER :: nb = 0
226 : ! staging buffers, dimensioned (component, point)
227 : REAL(KIND=dp), DIMENSION(:, :), ALLOCATABLE :: rho, sigma, lapl, tau
228 : ! the floored gradient norms the spin-polarized chain rule is written in
229 : REAL(KIND=dp), DIMENSION(:), ALLOCATABLE :: nd, nda, ndb
230 : REAL(KIND=dp), DIMENSION(:), ALLOCATABLE :: exc
231 : REAL(KIND=dp), DIMENSION(:, :), ALLOCATABLE :: vrho, vsigma, vlapl, vtau
232 : REAL(KIND=dp), DIMENSION(:, :), ALLOCATABLE :: v2rho2, v2rhosigma, v2sigma2, &
233 : v2rholapl, v2rhotau, v2sigmalapl, &
234 : v2sigmatau, v2lapl2, v2lapltau, v2tau2
235 : REAL(KIND=dp), DIMENSION(:, :), ALLOCATABLE :: v3rho3, v3rho2sigma, &
236 : v3rhosigma2, v3sigma3
237 : #:for arr in v3_new
238 : REAL(KIND=dp), DIMENSION(:, :), ALLOCATABLE :: ${arr}$
239 : #:endfor
240 : #if defined(__OFFLOAD) && !defined(__NO_OFFLOAD_LIBXC)
241 : ! GPU device buffers for the active backend, indexed by the caller with the
242 : ! libxc_dev_* slot constants defined in this module.
243 : TYPE(libxc_device_buffer_type), DIMENSION(libxc_max_dev_buffers) :: dev
244 : #endif
245 : END TYPE libxc_worker_type
246 :
247 : ! Slot integers naming the device buffers, used only by the host/device copy
248 : ! routines above; the generated third-derivative arrays continue after the
249 : ! hand-written ones.
250 : INTEGER, PARAMETER, PRIVATE :: libxc_dev_rho = 1, libxc_dev_sigma = 2, &
251 : libxc_dev_lapl = 3, libxc_dev_tau = 4, &
252 : libxc_dev_exc = 5, libxc_dev_vrho = 6, &
253 : libxc_dev_vsigma = 7, libxc_dev_vlapl = 8, &
254 : libxc_dev_vtau = 9, libxc_dev_v2rho2 = 10, &
255 : libxc_dev_v2rhosigma = 11, libxc_dev_v2sigma2 = 12, &
256 : libxc_dev_v2rholapl = 13, libxc_dev_v2rhotau = 14, &
257 : libxc_dev_v2sigmalapl = 15, libxc_dev_v2sigmatau = 16, &
258 : libxc_dev_v2lapl2 = 17, libxc_dev_v2lapltau = 18, &
259 : libxc_dev_v2tau2 = 19, libxc_dev_v3rho3 = 20, &
260 : libxc_dev_v3rho2sigma = 21, libxc_dev_v3rhosigma2 = 22, &
261 : libxc_dev_v3sigma3 = 23
262 : INTEGER, PARAMETER, PRIVATE :: libxc_dev_first_new3 = 24
263 : #:for i, arr in enumerate(v3_new)
264 : INTEGER, PARAMETER, PRIVATE :: libxc_dev_${arr}$ = libxc_dev_first_new3 + ${i}$
265 : #:endfor
266 :
267 : PUBLIC :: libxc_worker_alloc, libxc_worker_free_buffers, &
268 : libxc_worker_resize_cuda, libxc_worker_eval, libxc_family_flags
269 :
270 : ! Alias definitions for backward compatibility
271 : PROCEDURE(xc_f03_lda_exc_vxc_fxc_kxc), POINTER :: xc_f03_lda => xc_f03_lda_exc_vxc_fxc_kxc
272 : PROCEDURE(xc_f03_mgga_exc_vxc_fxc), POINTER :: xc_f03_mgga => xc_f03_mgga_exc_vxc_fxc
273 :
274 : CONTAINS
275 :
276 : ! Backend selection: the runtime libxc_backend switch, fed by
277 : ! &XC/LIBXC_GPU_BACKEND (see libxc_set_backend). Whether a device backend can
278 : ! ever be selected is a compile-time property (__OFFLOAD and
279 : ! !defined(__NO_OFFLOAD_LIBXC)).
280 : ! **************************************************************************************************
281 : !> \brief Runtime switch for the LibXC backend, fed by &XC/LIBXC_GPU_BACKEND.
282 : !> \param backend one of do_libxc_cpu / do_libxc_gpu
283 : !> \note Whether a device backend can ever be selected is a compile-time property
284 : !> (__OFFLOAD and !defined(__NO_OFFLOAD_LIBXC)). A DEVICE request on a build
285 : !> without a device path is an error.
286 : ! **************************************************************************************************
287 166849 : SUBROUTINE libxc_set_backend(backend)
288 : #if defined(__OFFLOAD) && !defined(__NO_OFFLOAD_LIBXC)
289 : USE offload_api, ONLY: offload_get_device_count
290 : #endif
291 : INTEGER, INTENT(IN) :: backend
292 :
293 : #if defined(__OFFLOAD) && !defined(__NO_OFFLOAD_LIBXC)
294 : ! Honor the request only when an accelerator is usable at runtime;
295 : ! a DEVICE request without one is an error.
296 : SELECT CASE (backend)
297 : CASE (do_libxc_gpu)
298 : IF (offload_get_device_count() > 0) THEN
299 : libxc_backend = do_libxc_gpu
300 : ELSE
301 : CALL cp__b(__SHORT_FILE__, __LINE__, &
302 : "&XC/LIBXC_GPU_BACKEND requests DEVICE, "// &
303 : "but no usable device/GPU was found at runtime.")
304 : END IF
305 : CASE default
306 : libxc_backend = do_libxc_cpu
307 : END SELECT
308 : #else
309 : ! Without a device path a DEVICE request is an error, HOST runs.
310 166849 : IF (backend == do_libxc_gpu) THEN
311 : CALL cp__b(__SHORT_FILE__, __LINE__, &
312 : "LibXC was compiled without a device/GPU backend, "// &
313 0 : "but &XC/LIBXC_GPU_BACKEND requests DEVICE.")
314 : END IF
315 166849 : libxc_backend = do_libxc_cpu
316 : #endif
317 166849 : END SUBROUTINE libxc_set_backend
318 :
319 : ! **************************************************************************************************
320 : !> \brief Set the default LibXC functional flags to host.
321 : ! **************************************************************************************************
322 291 : SUBROUTINE xc_libxc_wrap_init_safe()
323 : CHARACTER(LEN=*), PARAMETER :: routineN = 'xc_libxc_wrap_init_safe'
324 :
325 : INTEGER :: handle
326 :
327 291 : CALL timeset(routineN, handle)
328 :
329 : ! Set default flags
330 291 : CALL xc_f03_func_info_set_default_flags(XC_FLAGS_ON_HOST)
331 :
332 291 : CALL timestop(handle)
333 291 : END SUBROUTINE xc_libxc_wrap_init_safe
334 :
335 : ! **************************************************************************************************
336 : !> \brief Provides the reference(s) for this functional.
337 : !> \param xc_info func_info object of the functional
338 : !> \return upper bound for the length of the reference string
339 : !> \author F. Stein
340 : ! **************************************************************************************************
341 121 : FUNCTION xc_libxc_get_reference_length(xc_info) RESULT(length)
342 :
343 : TYPE(xc_f03_func_info_t), INTENT(IN) :: xc_info
344 : INTEGER :: length
345 :
346 : CHARACTER(LEN=*), PARAMETER :: routineN = 'xc_libxc_get_reference_length'
347 : INTEGER, PARAMETER :: maxlen = 67
348 :
349 : CHARACTER(LEN=1024) :: doi_string, ref_string
350 : CHARACTER(LEN=128) :: descr_string
351 : INTEGER :: handle, i, i_ref, i_ref_old, n_params
352 : TYPE(xc_f03_func_reference_t) :: xc_ref
353 :
354 121 : CALL timeset(routineN, handle)
355 :
356 : ! We are counting the number of necessary lines by carrying out a dry run of xc_libxc_wrap_info_refs
357 121 : i_ref = 0
358 121 : i_ref_old = -1
359 121 : length = 0
360 242 : DO WHILE (i_ref >= 0 .AND. i_ref /= i_ref_old)
361 : ! information about functional references
362 121 : xc_ref = xc_f03_func_info_get_references(xc_info, i_ref)
363 121 : ref_string = xc_f03_func_reference_get_ref(xc_ref)
364 121 : doi_string = xc_f03_func_reference_get_doi(xc_ref)
365 121 : length = length + LEN_TRIM(ref_string) + LEN_TRIM(doi_string) + 11
366 121 : IF (MOD(length, maxlen) /= 0) length = length + maxlen - MOD(length, maxlen)
367 : ! information about (optional) external parameters
368 121 : n_params = xc_f03_func_info_get_n_ext_params(xc_info)
369 121 : IF (n_params > 0) THEN
370 94 : length = length + maxlen
371 : END IF
372 667 : DO i = 1, n_params
373 546 : descr_string = xc_f03_func_info_get_ext_params_description(xc_info, i - 1)
374 546 : length = length + LEN_TRIM(descr_string) + 3
375 667 : IF (MOD(length, maxlen) /= 0) length = length + maxlen - MOD(length, maxlen)
376 : END DO
377 121 : i_ref_old = i_ref
378 : END DO
379 : ! two additional lines for spin polarization, scaling factor and buffer
380 121 : length = length + 2*maxlen
381 :
382 121 : CALL timestop(handle)
383 :
384 121 : END FUNCTION xc_libxc_get_reference_length
385 :
386 : ! **************************************************************************************************
387 : !> \brief Provides the reference(s) for this functional.
388 : !> \param xc_info ...
389 : !> \param polarized ...
390 : !> \param sc ...
391 : !> \param reference ...
392 : !>
393 : !> \author A. Gloess (agloess)
394 : ! **************************************************************************************************
395 121 : SUBROUTINE xc_libxc_wrap_info_refs(xc_info, polarized, sc, reference)
396 : TYPE(xc_f03_func_info_t), INTENT(IN) :: xc_info
397 : INTEGER, INTENT(IN) :: polarized
398 : REAL(KIND=dp), INTENT(IN) :: sc
399 : CHARACTER(LEN=*), INTENT(OUT) :: reference
400 :
401 : CHARACTER(LEN=*), PARAMETER :: routineN = 'xc_libxc_wrap_info_refs'
402 : INTEGER, PARAMETER :: maxlen = 67
403 :
404 : CHARACTER(LEN=1028) :: doi_string, ref_string
405 : CHARACTER(LEN=128) :: descr_string
406 : CHARACTER(LEN=2067) :: tmp_string
407 : INTEGER :: empty, first, handle, i, i_ref, &
408 : i_ref_old, idx, last, n_params
409 : TYPE(xc_f03_func_reference_t) :: xc_ref
410 :
411 : ! conservative estimate of the necessary length: 2*1028+11=2067
412 :
413 121 : CALL timeset(routineN, handle)
414 :
415 121 : i_ref = 0
416 121 : i_ref_old = -1
417 121 : idx = 1
418 121 : first = 1
419 242 : DO WHILE (i_ref >= 0 .AND. i_ref /= i_ref_old)
420 : ! information about functional references
421 121 : xc_ref = xc_f03_func_info_get_references(xc_info, i_ref)
422 121 : ref_string = xc_f03_func_reference_get_ref(xc_ref)
423 121 : doi_string = xc_f03_func_reference_get_doi(xc_ref)
424 121 : WRITE (tmp_string, '(a1,i1,a2,a,a7,a)') '[', idx, '] ', &
425 242 : TRIM(ref_string), ', doi: ', TRIM(doi_string)
426 121 : last = first + LEN_TRIM(tmp_string) - 1
427 121 : reference(first:last) = TRIM(tmp_string)
428 121 : first = last + 1
429 121 : empty = last + (maxlen - 1) - MOD(last - 1, maxlen)
430 : ! fill up line with 'spaces'
431 121 : IF (empty /= last) THEN
432 121 : reference(first:empty) = ' '
433 121 : first = empty + 1
434 : END IF
435 : ! information about (optional) external parameters
436 121 : n_params = xc_f03_func_info_get_n_ext_params(xc_info)
437 121 : IF (n_params > 0) THEN
438 94 : reference(first:first + maxlen - 1) = 'Optional external parameters:'//REPEAT(' ', maxlen - 28)
439 94 : first = first + maxlen
440 : END IF
441 667 : DO i = 1, n_params
442 546 : descr_string = xc_f03_func_info_get_ext_params_description(xc_info, i - 1)
443 546 : last = first + LEN_TRIM(descr_string) - 1 + 3
444 546 : reference(first:last) = ' * '//TRIM(descr_string)
445 546 : first = last + 1
446 546 : empty = last + (maxlen - 1) - MOD(last - 1, maxlen)
447 : ! fill up line with 'spaces'
448 :
449 667 : IF (empty /= last) THEN
450 546 : reference(first:empty) = ' '
451 546 : first = empty + 1
452 : END IF
453 : END DO
454 121 : idx = idx + 1
455 121 : i_ref_old = i_ref
456 : END DO
457 185 : SELECT CASE (polarized)
458 : CASE (XC_UNPOLARIZED)
459 64 : WRITE (tmp_string, "('{scale=',f5.3,', spin-unpolarized}')") sc
460 : CASE (XC_POLARIZED)
461 57 : WRITE (tmp_string, "('{scale=',f5.3,', spin-polarized}')") sc
462 : CASE default
463 121 : CPABORT("Unsupported value for variable 'polarized'.")
464 : END SELECT
465 121 : last = first + LEN_TRIM(tmp_string) - 1
466 121 : reference(first:last) = TRIM(tmp_string)
467 121 : first = last + 1
468 : ! fill with 'spaces'
469 121 : reference(first:LEN(reference)) = ' '
470 :
471 121 : IF (last > LEN(reference)) &
472 0 : CPABORT("Faulty reference length.")
473 :
474 121 : CALL timestop(handle)
475 :
476 121 : END SUBROUTINE xc_libxc_wrap_info_refs
477 :
478 : ! **************************************************************************************************
479 : !> \brief Provides the version of the LibXC library CP2K is running against.
480 : !> \param version version string reported by the library at run time
481 : !> \param compiled_version version of the headers CP2K was compiled against
482 : !> \author A. Gloess (agloess)
483 : !> \note The run-time and compile-time versions differ whenever CP2K is executed
484 : !> against a shared LibXC other than the one it was built with. Reporting
485 : !> the run-time version is what actually describes the numbers produced.
486 : !>
487 : ! **************************************************************************************************
488 76 : SUBROUTINE xc_libxc_wrap_version(version, compiled_version)
489 : CHARACTER(LEN=*), INTENT(OUT) :: version
490 : CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: compiled_version
491 :
492 : CHARACTER(LEN=*), PARAMETER :: routineN = 'xc_libxc_wrap_version'
493 :
494 : INTEGER :: handle
495 :
496 76 : CALL timeset(routineN, handle)
497 :
498 76 : CALL xc_f03_version_string(version)
499 76 : IF (PRESENT(compiled_version)) compiled_version = TRIM(libxc_version)
500 :
501 76 : CALL timestop(handle)
502 :
503 76 : END SUBROUTINE xc_libxc_wrap_version
504 :
505 : ! **************************************************************************************************
506 : !> \brief Provides the citation LibXC asks to be given for the library itself.
507 : !> \param reference bibliographic reference
508 : !> \param doi digital object identifier of that reference
509 : !> \author S. Lehtola
510 : !> \note Taken from the library at run time rather than hard-coded, so that the
511 : !> citation stays correct when LibXC updates its own self-citation.
512 : !>
513 : ! **************************************************************************************************
514 76 : SUBROUTINE xc_libxc_wrap_library_reference(reference, doi)
515 : CHARACTER(LEN=*), INTENT(OUT) :: reference, doi
516 :
517 : CHARACTER(LEN=*), PARAMETER :: routineN = 'xc_libxc_wrap_library_reference'
518 :
519 : INTEGER :: handle
520 :
521 76 : CALL timeset(routineN, handle)
522 :
523 76 : CALL xc_f03_reference(reference)
524 76 : CALL xc_f03_reference_doi(doi)
525 :
526 76 : CALL timestop(handle)
527 :
528 76 : END SUBROUTINE xc_libxc_wrap_library_reference
529 :
530 : ! **************************************************************************************************
531 : !> \brief Applies the CP2K screening cutoffs to a LibXC functional object.
532 : !> \param xc_func LibXC functional object
533 : !> \param xc_info info object belonging to xc_func
534 : !> \param epsilon_rho density cutoff (XC%DENSITY_CUTOFF)
535 : !> \param epsilon_tau kinetic energy density cutoff (XC%TAU_CUTOFF)
536 : !> \author S. Lehtola
537 : !> \note LibXC screens every point against the density threshold internally, which
538 : !> is what allows CP2K to hand it whole blocks of points instead of filtering
539 : !> point by point. The sigma threshold is deliberately left at LibXC's own
540 : !> default: CP2K has no cutoff of its own on the gradient here, and raising
541 : !> it in step with the density cutoff would floor sigma for points with a
542 : !> small gradient that used to be evaluated as given.
543 : !>
544 : ! **************************************************************************************************
545 580 : SUBROUTINE xc_libxc_wrap_set_thresholds(xc_func, xc_info, epsilon_rho, epsilon_tau)
546 : TYPE(xc_f03_func_t), INTENT(INOUT) :: xc_func
547 : TYPE(xc_f03_func_info_t), INTENT(IN) :: xc_info
548 : REAL(KIND=dp), INTENT(IN) :: epsilon_rho, epsilon_tau
549 :
550 : CHARACTER(LEN=*), PARAMETER :: routineN = 'xc_libxc_wrap_set_thresholds'
551 :
552 : INTEGER :: handle
553 :
554 580 : CALL timeset(routineN, handle)
555 :
556 580 : CALL xc_f03_func_set_dens_threshold(xc_func, epsilon_rho)
557 :
558 178 : SELECT CASE (xc_f03_func_info_get_family(xc_info))
559 : CASE (XC_FAMILY_MGGA, XC_FAMILY_HYB_MGGA)
560 580 : CALL xc_f03_func_set_tau_threshold(xc_func, epsilon_tau)
561 : END SELECT
562 :
563 580 : CALL timestop(handle)
564 :
565 580 : END SUBROUTINE xc_libxc_wrap_set_thresholds
566 :
567 : ! **************************************************************************************************
568 : !> \brief Checks existence of functional in LibXC
569 : !> \param func_string ...
570 : !> \return ...
571 : !> \author F. Stein
572 : !> \note Remove prefix to keep compatibility, functionals can be specified (in
573 : !> LIBXC section) as:
574 : !> GGA_X_... or XC_GGA_X_...
575 : !> Starting from version 2.2.0 both name conventions are allowed, before
576 : !> the 'XC_' prefix was necessary.
577 : !>
578 : ! **************************************************************************************************
579 4276 : LOGICAL FUNCTION xc_libxc_check_functional(func_string) RESULT(exists)
580 : CHARACTER(LEN=*), INTENT(IN) :: func_string
581 :
582 : CHARACTER(LEN=*), PARAMETER :: routineN = 'xc_libxc_check_functional'
583 :
584 : INTEGER :: func_id, handle
585 :
586 4276 : CALL timeset(routineN, handle)
587 :
588 4276 : IF (func_string(1:3) == "XC_") THEN
589 0 : func_id = xc_f03_functional_get_number(func_string(4:LEN_TRIM(func_string)))
590 : ELSE
591 4276 : func_id = xc_f03_functional_get_number(func_string(1:LEN_TRIM(func_string)))
592 : END IF
593 :
594 4276 : exists = .TRUE.
595 4276 : IF (func_id == -1) exists = .FALSE.
596 :
597 4276 : CALL timestop(handle)
598 :
599 4276 : END FUNCTION xc_libxc_check_functional
600 :
601 : ! **************************************************************************************************
602 : !> \brief Provides the functional ID.
603 : !> \param func_string ...
604 : !> \return ...
605 : !> \author A. Gloess (agloess)
606 : !> \note Remove prefix to keep compatibility, functionals can be specified (in
607 : !> LIBXC section) as:
608 : !> GGA_X_... or XC_GGA_X_...
609 : !> Starting from version 2.2.0 both name conventions are allowed, before
610 : !> the 'XC_' prefix was necessary.
611 : !>
612 : ! **************************************************************************************************
613 47226 : INTEGER FUNCTION xc_libxc_wrap_functional_get_number(func_string) RESULT(func_id)
614 : CHARACTER(LEN=*), INTENT(IN) :: func_string
615 :
616 : CHARACTER(LEN=*), PARAMETER :: routineN = 'xc_libxc_wrap_functional_get_number'
617 :
618 : INTEGER :: handle
619 :
620 47226 : CALL timeset(routineN, handle)
621 :
622 47226 : IF (func_string(1:3) == "XC_") THEN
623 0 : func_id = xc_f03_functional_get_number(func_string(4:LEN_TRIM(func_string)))
624 : ELSE
625 47226 : func_id = xc_f03_functional_get_number(func_string(1:LEN_TRIM(func_string)))
626 : END IF
627 47226 : IF (func_id == -1) THEN
628 0 : CPABORT(TRIM(func_string)//": wrong functional name")
629 : END IF
630 :
631 47226 : CALL timestop(handle)
632 :
633 47226 : END FUNCTION xc_libxc_wrap_functional_get_number
634 :
635 : ! **************************************************************************************************
636 : !> \brief Wrapper to test wether functional is considered under development in Libxc
637 : !> \param xc_info ...
638 : !>
639 : !> \return ...
640 : !> \author F. Stein (fstein93)
641 : ! **************************************************************************************************
642 0 : LOGICAL FUNCTION xc_libxc_wrap_is_under_development(xc_info)
643 : TYPE(xc_f03_func_info_t) :: xc_info
644 :
645 0 : IF (IAND(xc_f03_func_info_get_flags(xc_info), XC_FLAGS_DEVELOPMENT) == XC_FLAGS_DEVELOPMENT) THEN
646 : xc_libxc_wrap_is_under_development = .TRUE.
647 : ELSE
648 0 : xc_libxc_wrap_is_under_development = .FALSE.
649 : END IF
650 :
651 0 : END FUNCTION xc_libxc_wrap_is_under_development
652 :
653 : ! **************************************************************************************************
654 : !> \brief Wrapper for functionals that need the Laplacian, all others can use
655 : !> a dummy array.
656 : !> \param xc_info info object of an already initialized functional
657 : !>
658 : !> \return ...
659 : !> \author A. Gloess (agloess)
660 : !> \note Reads the flag off an info object the caller already holds. Creating a
661 : !> throw-away functional object just to look at one flag used to cost an
662 : !> extra xc_f03_func_init/xc_f03_func_end pair per evaluated batch.
663 : ! **************************************************************************************************
664 6026 : LOGICAL FUNCTION xc_libxc_wrap_info_needs_laplace(xc_info)
665 : ! Only some MGGA functionals needs the laplacian
666 : TYPE(xc_f03_func_info_t), INTENT(IN) :: xc_info
667 :
668 6026 : IF (IAND(xc_f03_func_info_get_flags(xc_info), XC_FLAGS_NEEDS_LAPLACIAN) == XC_FLAGS_NEEDS_LAPLACIAN) THEN
669 : xc_libxc_wrap_info_needs_laplace = .TRUE.
670 : ELSE
671 4728 : xc_libxc_wrap_info_needs_laplace = .FALSE.
672 : END IF
673 :
674 6026 : END FUNCTION xc_libxc_wrap_info_needs_laplace
675 :
676 : ! **************************************************************************************************
677 : !> \brief Whether the functional does not provide the energy density.
678 : !> \param xc_info info object of an already initialized functional
679 : !>
680 : !> \return .TRUE. when LibXC cannot supply Exc for this functional
681 : !> \author S. Lehtola
682 : ! **************************************************************************************************
683 580 : LOGICAL FUNCTION xc_libxc_wrap_info_no_exc(xc_info)
684 : TYPE(xc_f03_func_info_t), INTENT(IN) :: xc_info
685 :
686 580 : IF (IAND(xc_f03_func_info_get_flags(xc_info), XC_FLAGS_HAVE_EXC) == XC_FLAGS_HAVE_EXC) THEN
687 : xc_libxc_wrap_info_no_exc = .FALSE.
688 : ELSE
689 0 : xc_libxc_wrap_info_no_exc = .TRUE.
690 : END IF
691 :
692 580 : END FUNCTION xc_libxc_wrap_info_no_exc
693 :
694 : ! **************************************************************************************************
695 : !> \brief Initialize a LibXC functional honoring the runtime backend.
696 : !> \param func the functional object to initialize
697 : !> \param functional LibXC functional number
698 : !> \param nspin XC_UNPOLARIZED or XC_POLARIZED (defaults to XC_UNPOLARIZED)
699 : !> \param force_host initialize on the host even when the runtime backend is the
700 : !> device (used for query/metadata functional objects)
701 : !> \note The functional's default flags are set to XC_FLAGS_ON_DEVICE when the
702 : !> device backend is active (and the initialization is not forced to the
703 : !> host), so that later evaluation calls run on the device.
704 : ! **************************************************************************************************
705 10363188 : SUBROUTINE libxc_func_init_wrapper(func, functional, nspin, force_host)
706 : TYPE(xc_f03_func_t), INTENT(OUT) :: func
707 : INTEGER, INTENT(IN) :: functional
708 : INTEGER, INTENT(IN), OPTIONAL :: nspin
709 : LOGICAL, INTENT(IN), OPTIONAL :: force_host
710 :
711 : LOGICAL :: my_force_host
712 :
713 10363188 : my_force_host = .FALSE.
714 10363188 : IF (PRESENT(force_host)) my_force_host = force_host
715 :
716 : ! Query/metadata initialization always runs on the host (force_host).
717 10363188 : IF (libxc_backend == do_libxc_gpu .AND. .NOT. my_force_host) THEN
718 0 : CALL xc_f03_func_info_set_default_flags(XC_FLAGS_ON_DEVICE)
719 0 : IF (PRESENT(nspin)) THEN
720 0 : CALL xc_f03_func_init(func, functional, nspin)
721 : ELSE
722 0 : CALL xc_f03_func_init(func, functional, XC_UNPOLARIZED)
723 : END IF
724 : ELSE
725 10363188 : CALL xc_f03_func_info_set_default_flags(XC_FLAGS_ON_HOST)
726 10363188 : IF (PRESENT(nspin)) THEN
727 10363188 : CALL xc_f03_func_init(func, functional, nspin)
728 : ELSE
729 0 : CALL xc_f03_func_init(func, functional, XC_UNPOLARIZED)
730 : END IF
731 : END IF
732 10363188 : END SUBROUTINE libxc_func_init_wrapper
733 :
734 : #endif
735 :
736 : ! **************************************************************************************************
737 : !> \brief Whether the runtime LibXC backend is the GPU.
738 : !> \return ...
739 : !> \note Always available under __LIBXC: CPU-only/__NO_OFFLOAD_LIBXC builds
740 : !> compile the flag but can never select the device backend at runtime.
741 : ! **************************************************************************************************
742 2742512 : FUNCTION libxc_is_gpu() RESULT(is_gpu)
743 : LOGICAL :: is_gpu
744 :
745 2742512 : is_gpu = (libxc_backend == do_libxc_gpu)
746 2742512 : END FUNCTION libxc_is_gpu
747 :
748 : ! **************************************************************************************************
749 : !> \brief Allocates the staging buffers of a single worker, sizing the block so
750 : !> that they stay within the cache budget.
751 : !> \param worker the worker
752 : !> \param family LibXC functional family
753 : !> \param nspin XC_UNPOLARIZED or XC_POLARIZED
754 : !> \param grad_deriv highest derivative order the buffers must hold
755 : !> \author S. Lehtola
756 : ! **************************************************************************************************
757 740 : SUBROUTINE libxc_worker_alloc(worker, family, nspin, grad_deriv)
758 : TYPE(libxc_worker_type), INTENT(INOUT) :: worker
759 : INTEGER, INTENT(IN) :: family, nspin, grad_deriv
760 :
761 : INTEGER, PARAMETER :: libxc_block_bytes = 256*1024
762 : INTEGER, PARAMETER :: libxc_block_min = 64
763 : INTEGER, PARAMETER :: libxc_block_max = 512
764 :
765 : INTEGER :: nb, ncomp
766 :
767 : ! How many doubles a point occupies spans a factor of twenty over the
768 : ! families, spin cases and derivative orders, so a block length fixed in
769 : ! points would size the buffers anywhere between 49 KiB and 950 KiB. Derive
770 : ! it from the footprint instead: build a one-point worker, ask it how wide
771 : ! a point is, and cut the real block to the byte budget. Taking the count
772 : ! from the buffers themselves is what stops it drifting away from the
773 : ! allocation it is meant to describe.
774 31080 : BLOCK
775 740 : TYPE(libxc_worker_type) :: probe
776 : ! The probe only counts host components, so skip the device buffers:
777 : ! they would otherwise be allocated and leaked for a worker that is
778 : ! discarded immediately.
779 : CALL libxc_worker_alloc_buffers(probe, family, nspin, grad_deriv, 1, &
780 740 : alloc_device=.FALSE.)
781 740 : ncomp = libxc_worker_ncomp(probe)
782 31080 : CALL libxc_worker_free_buffers(probe)
783 : END BLOCK
784 : nb = MIN(libxc_block_max, &
785 740 : MAX(libxc_block_min, libxc_block_bytes/(ncomp*(STORAGE_SIZE(0.0_dp)/8))))
786 :
787 740 : CALL libxc_worker_alloc_buffers(worker, family, nspin, grad_deriv, nb)
788 :
789 740 : END SUBROUTINE libxc_worker_alloc
790 :
791 : ! **************************************************************************************************
792 : !> \brief Number of buffer components a single grid point occupies in a worker.
793 : !> \param worker the worker
794 : !> \return components per point, summed over the buffers it actually carries
795 : !> \author S. Lehtola
796 : ! **************************************************************************************************
797 740 : FUNCTION libxc_worker_ncomp(worker) RESULT(ncomp)
798 : TYPE(libxc_worker_type), INTENT(IN) :: worker
799 : INTEGER :: ncomp
800 :
801 740 : ncomp = 0
802 : #:for arr in worker_1d
803 740 : IF (ALLOCATED(worker%${arr}$)) ncomp = ncomp + 1
804 : #:endfor
805 : #:for arr in worker_2d
806 740 : IF (ALLOCATED(worker%${arr}$)) ncomp = ncomp + SIZE(worker%${arr}$, 1)
807 : #:endfor
808 :
809 740 : END FUNCTION libxc_worker_ncomp
810 :
811 : ! **************************************************************************************************
812 : !> \brief Allocates the staging buffers of a single worker for a given block length.
813 : !> \param worker the worker
814 : !> \param family LibXC functional family
815 : !> \param nspin XC_UNPOLARIZED or XC_POLARIZED
816 : !> \param grad_deriv highest derivative order the buffers must hold
817 : !> \param nb number of grid points per block
818 : !> \param alloc_device whether to allocate the matching GPU device buffers
819 : !> \author S. Lehtola
820 : !> \note The buffers follow LibXC's own layout, i.e. the leading dimension is the
821 : !> number of components of the quantity and the points run along the second
822 : !> dimension. They are allocated once per worker and reused for every batch.
823 : !> Only the orders this evaluation asks for are allocated: the third
824 : !> derivatives alone are 130 components per point for a spin-polarized
825 : !> meta-GGA, which a ground-state calculation would never fill.
826 : ! **************************************************************************************************
827 1480 : SUBROUTINE libxc_worker_alloc_buffers(worker, family, nspin, grad_deriv, nb, alloc_device)
828 : TYPE(libxc_worker_type), INTENT(INOUT) :: worker
829 : INTEGER, INTENT(IN) :: family, nspin, grad_deriv, nb
830 : LOGICAL, INTENT(IN), OPTIONAL :: alloc_device
831 :
832 : INTEGER :: nl, np, ns
833 : LOGICAL :: pol, want_device
834 :
835 1480 : pol = (nspin == XC_POLARIZED)
836 1480 : want_device = .TRUE.
837 1480 : IF (PRESENT(alloc_device)) want_device = alloc_device
838 1480 : CALL libxc_worker_dims(nspin, np, ns, nl)
839 :
840 1480 : worker%nb = nb
841 :
842 : ! The energy density and the first derivatives are always staged: LibXC
843 : ! writes them whatever higher order was asked for.
844 5920 : ALLOCATE (worker%rho(np, nb))
845 4440 : ALLOCATE (worker%exc(nb))
846 4440 : ALLOCATE (worker%vrho(np, nb))
847 3088 : IF (grad_deriv >= 2) ALLOCATE (worker%v2rho2(ns, nb))
848 1720 : IF (grad_deriv >= 3) ALLOCATE (worker%v3rho3(nl, nb))
849 :
850 2560 : SELECT CASE (family)
851 : CASE (XC_FAMILY_GGA, XC_FAMILY_HYB_GGA, XC_FAMILY_MGGA, XC_FAMILY_HYB_MGGA)
852 4320 : ALLOCATE (worker%sigma(ns, nb))
853 3240 : ALLOCATE (worker%vsigma(ns, nb))
854 1080 : IF (pol) THEN
855 1232 : ALLOCATE (worker%nd(nb), worker%nda(nb), worker%ndb(nb))
856 : END IF
857 1080 : IF (grad_deriv >= 2) THEN
858 1784 : ALLOCATE (worker%v2rhosigma(MERGE(6, 1, pol), nb))
859 1176 : ALLOCATE (worker%v2sigma2(MERGE(6, 1, pol), nb))
860 : END IF
861 2560 : IF (grad_deriv >= 3) THEN
862 268 : ALLOCATE (worker%v3rho2sigma(MERGE(9, 1, pol), nb))
863 268 : ALLOCATE (worker%v3rhosigma2(MERGE(12, 1, pol), nb))
864 268 : ALLOCATE (worker%v3sigma3(MERGE(10, 1, pol), nb))
865 : END IF
866 : END SELECT
867 :
868 528 : SELECT CASE (family)
869 : CASE (XC_FAMILY_MGGA, XC_FAMILY_HYB_MGGA)
870 1584 : ALLOCATE (worker%lapl(np, nb))
871 1584 : ALLOCATE (worker%tau(np, nb))
872 1584 : ALLOCATE (worker%vlapl(np, nb))
873 1584 : ALLOCATE (worker%vtau(np, nb))
874 528 : IF (grad_deriv >= 2) THEN
875 880 : ALLOCATE (worker%v2rholapl(nl, nb))
876 660 : ALLOCATE (worker%v2rhotau(nl, nb))
877 1016 : ALLOCATE (worker%v2sigmalapl(MERGE(6, 1, pol), nb))
878 660 : ALLOCATE (worker%v2sigmatau(MERGE(6, 1, pol), nb))
879 880 : ALLOCATE (worker%v2lapl2(ns, nb))
880 660 : ALLOCATE (worker%v2lapltau(nl, nb))
881 660 : ALLOCATE (worker%v2tau2(ns, nb))
882 : END IF
883 528 : IF (grad_deriv >= 3) THEN
884 : #:for arr in v3_new
885 1580 : ALLOCATE (worker%${arr}$ (MERGE(${mgga_ncomp[arr]}$, 1, pol), nb))
886 : #:endfor
887 : END IF
888 : ! LibXC leaves vlapl untouched for functionals that do not use the
889 : ! Laplacian, and CP2K then ignores it; zero it once so it never holds
890 : ! uninitialized memory.
891 308782 : worker%vlapl = 0.0_dp
892 : END SELECT
893 :
894 : ! Allocate GPU device buffers when the GPU backend is active. They follow
895 : ! the host staging buffers, so the same derivative-order guards apply.
896 1480 : IF (want_device .AND. libxc_is_gpu()) THEN
897 : CALL libxc_worker_device_alloc(worker, family, pol, nl, np, ns, nb)
898 : END IF
899 :
900 1480 : END SUBROUTINE libxc_worker_alloc_buffers
901 :
902 : ! **************************************************************************************************
903 : !> \brief Releases the staging buffers of a worker, keeping its functional object.
904 : !> \param worker the worker
905 : !> \author S. Lehtola
906 : !> \note Frees the host buffers and the matching device buffers, but leaves the
907 : !> LibXC functional object untouched so that it can be reused.
908 : ! **************************************************************************************************
909 1480 : SUBROUTINE libxc_worker_free_buffers(worker)
910 : TYPE(libxc_worker_type), INTENT(INOUT) :: worker
911 :
912 : #:for arr in worker_1d + worker_2d
913 1480 : IF (ALLOCATED(worker%${arr}$)) DEALLOCATE (worker%${arr}$)
914 : #:endfor
915 1480 : worker%nb = 0
916 :
917 : ! Freeing a buffer that was never allocated is a no-op, so this is done
918 : ! unconditionally rather than gating on the currently active backend.
919 : CALL libxc_worker_device_free(worker)
920 :
921 1480 : END SUBROUTINE libxc_worker_free_buffers
922 :
923 : ! **************************************************************************************************
924 : !> \brief Activates the rank's chosen device on the calling thread.
925 : !> \note Needed because CUDA's current device is thread-local; a no-op without
926 : !> a device, so xc_libxc can call it unconditionally.
927 : ! **************************************************************************************************
928 0 : SUBROUTINE libxc_activate_device()
929 : #if defined(__OFFLOAD) && !defined(__NO_OFFLOAD_LIBXC)
930 : USE offload_api, ONLY: offload_activate_chosen_device
931 :
932 : CALL offload_activate_chosen_device()
933 : #endif
934 0 : END SUBROUTINE libxc_activate_device
935 :
936 : ! **************************************************************************************************
937 : !> \brief Waits for all outstanding device-to-host copies to complete.
938 : ! **************************************************************************************************
939 0 : SUBROUTINE libxc_sync_device()
940 : #if defined(__OFFLOAD) && !defined(__NO_OFFLOAD_LIBXC)
941 : USE offload_api, ONLY: offload_device_synchronize
942 :
943 : CALL offload_device_synchronize()
944 : #endif
945 0 : END SUBROUTINE libxc_sync_device
946 :
947 : ! **************************************************************************************************
948 : !> \brief Copies host staging data into a worker's device buffer.
949 : !> \param worker the worker
950 : !> \param slot device buffer to copy into (one of libxc_dev_*)
951 : !> \param host host array to copy from
952 : !> \param n number of elements
953 : ! **************************************************************************************************
954 0 : SUBROUTINE libxc_worker_h2d(worker, slot, host, n)
955 : TYPE(libxc_worker_type), INTENT(INOUT) :: worker
956 : INTEGER, INTENT(IN) :: slot
957 : REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: host
958 : INTEGER, INTENT(IN) :: n
959 : #if defined(__OFFLOAD) && !defined(__NO_OFFLOAD_LIBXC)
960 : CALL libxc_host_to_device(worker%dev(slot), host, n)
961 : #else
962 : MARK_USED(worker)
963 : MARK_USED(slot)
964 : IF (.FALSE.) THEN; DO; IF (ABS(host(1)) > ABS(host(1))) EXIT; END DO; END IF
965 : MARK_USED(n)
966 0 : CPABORT("libxc_worker_h2d: device backend not compiled in.")
967 : #endif
968 0 : END SUBROUTINE libxc_worker_h2d
969 :
970 : ! **************************************************************************************************
971 : !> \brief Issues an async device-to-host copy of one of a worker's buffers.
972 : ! **************************************************************************************************
973 0 : SUBROUTINE libxc_worker_d2h_issue(worker, slot, n)
974 : TYPE(libxc_worker_type), INTENT(INOUT) :: worker
975 : INTEGER, INTENT(IN) :: slot
976 : INTEGER, INTENT(IN) :: n
977 : #if defined(__OFFLOAD) && !defined(__NO_OFFLOAD_LIBXC)
978 : CALL libxc_d2h_issue(worker%dev(slot), n)
979 : #else
980 : MARK_USED(worker)
981 : MARK_USED(slot)
982 : MARK_USED(n)
983 0 : CPABORT("libxc_worker_d2h_issue: device backend not compiled in.")
984 : #endif
985 0 : END SUBROUTINE libxc_worker_d2h_issue
986 :
987 : ! **************************************************************************************************
988 : !> \brief Reads one of a worker's device buffers back into host memory.
989 : ! **************************************************************************************************
990 0 : SUBROUTINE libxc_worker_d2h_read(worker, slot, host, n)
991 : TYPE(libxc_worker_type), INTENT(IN) :: worker
992 : INTEGER, INTENT(IN) :: slot
993 : REAL(KIND=dp), DIMENSION(*), INTENT(OUT) :: host
994 : INTEGER, INTENT(IN) :: n
995 : #if defined(__OFFLOAD) && !defined(__NO_OFFLOAD_LIBXC)
996 : CALL libxc_d2h_read(host, worker%dev(slot), n)
997 : #else
998 : MARK_USED(worker)
999 : MARK_USED(slot)
1000 : IF (.FALSE.) THEN; DO; IF (ABS(host(1)) > ABS(host(1))) EXIT; END DO; END IF
1001 : MARK_USED(n)
1002 0 : CPABORT("libxc_worker_d2h_read: device backend not compiled in.")
1003 : #endif
1004 0 : END SUBROUTINE libxc_worker_d2h_read
1005 :
1006 : #if defined(__OFFLOAD) && !defined(__NO_OFFLOAD_LIBXC)
1007 : ! **************************************************************************************************
1008 : !> \brief Allocates (or, with grow_only, grows) one device buffer.
1009 : !> \param buffer the device buffer
1010 : !> \param n required element count
1011 : !> \param grow_only when true, leave the buffer alone if it is already large enough
1012 : ! **************************************************************************************************
1013 : SUBROUTINE libxc_dev_alloc_maybe(buffer, n, grow_only)
1014 : TYPE(libxc_device_buffer_type), INTENT(INOUT) :: buffer
1015 : INTEGER, INTENT(IN) :: n
1016 : LOGICAL, INTENT(IN) :: grow_only
1017 :
1018 : IF (grow_only .AND. INT(buffer%size) >= n) RETURN
1019 : CALL libxc_device_buffer_alloc(buffer, n)
1020 : END SUBROUTINE libxc_dev_alloc_maybe
1021 :
1022 : ! **************************************************************************************************
1023 : !> \brief Allocates the device buffers of a worker, sizing them for n points.
1024 : !> \param worker the worker
1025 : !> \param family LibXC functional family
1026 : !> \param pol whether the functional is spin-polarized
1027 : !> \param nl, np, ns leading dimensions from libxc_worker_dims
1028 : !> \param n number of grid points the buffers must hold
1029 : !> \param grow_only when true, only grow buffers that are too small (used on the
1030 : !> GPU path, where the buffers are regrown to the whole grid)
1031 : !> \note Only the buffers whose host counterpart is allocated are touched, so the
1032 : !> derivative-order and family guards of libxc_worker_alloc_buffers hold.
1033 : ! **************************************************************************************************
1034 : SUBROUTINE libxc_worker_device_alloc(worker, family, pol, nl, np, ns, n, grow_only)
1035 : TYPE(libxc_worker_type), INTENT(INOUT) :: worker
1036 : INTEGER, INTENT(IN) :: family, nl, np, ns, n
1037 : LOGICAL, INTENT(IN) :: pol
1038 : LOGICAL, INTENT(IN), OPTIONAL :: grow_only
1039 :
1040 : INTEGER :: base, i
1041 : LOGICAL :: g
1042 :
1043 : g = .FALSE.
1044 : IF (PRESENT(grow_only)) g = grow_only
1045 :
1046 : CALL libxc_dev_alloc_maybe(worker%dev(libxc_dev_rho), np*n, g)
1047 : CALL libxc_dev_alloc_maybe(worker%dev(libxc_dev_exc), n, g)
1048 : CALL libxc_dev_alloc_maybe(worker%dev(libxc_dev_vrho), np*n, g)
1049 : IF (ALLOCATED(worker%v2rho2)) CALL libxc_dev_alloc_maybe(worker%dev(libxc_dev_v2rho2), ns*n, g)
1050 : IF (ALLOCATED(worker%v3rho3)) CALL libxc_dev_alloc_maybe(worker%dev(libxc_dev_v3rho3), nl*n, g)
1051 :
1052 : SELECT CASE (family)
1053 : CASE (XC_FAMILY_GGA, XC_FAMILY_HYB_GGA, XC_FAMILY_MGGA, XC_FAMILY_HYB_MGGA)
1054 : CALL libxc_dev_alloc_maybe(worker%dev(libxc_dev_sigma), ns*n, g)
1055 : CALL libxc_dev_alloc_maybe(worker%dev(libxc_dev_vsigma), ns*n, g)
1056 : IF (ALLOCATED(worker%v2rhosigma)) &
1057 : CALL libxc_dev_alloc_maybe(worker%dev(libxc_dev_v2rhosigma), MERGE(6, 1, pol)*n, g)
1058 : IF (ALLOCATED(worker%v2sigma2)) &
1059 : CALL libxc_dev_alloc_maybe(worker%dev(libxc_dev_v2sigma2), MERGE(6, 1, pol)*n, g)
1060 : IF (ALLOCATED(worker%v3rho2sigma)) &
1061 : CALL libxc_dev_alloc_maybe(worker%dev(libxc_dev_v3rho2sigma), MERGE(9, 1, pol)*n, g)
1062 : IF (ALLOCATED(worker%v3rhosigma2)) &
1063 : CALL libxc_dev_alloc_maybe(worker%dev(libxc_dev_v3rhosigma2), MERGE(12, 1, pol)*n, g)
1064 : IF (ALLOCATED(worker%v3sigma3)) &
1065 : CALL libxc_dev_alloc_maybe(worker%dev(libxc_dev_v3sigma3), MERGE(10, 1, pol)*n, g)
1066 : END SELECT
1067 :
1068 : SELECT CASE (family)
1069 : CASE (XC_FAMILY_MGGA, XC_FAMILY_HYB_MGGA)
1070 : CALL libxc_dev_alloc_maybe(worker%dev(libxc_dev_lapl), np*n, g)
1071 : CALL libxc_dev_alloc_maybe(worker%dev(libxc_dev_tau), np*n, g)
1072 : CALL libxc_dev_alloc_maybe(worker%dev(libxc_dev_vlapl), np*n, g)
1073 : CALL libxc_dev_alloc_maybe(worker%dev(libxc_dev_vtau), np*n, g)
1074 : IF (ALLOCATED(worker%v2rholapl)) &
1075 : CALL libxc_dev_alloc_maybe(worker%dev(libxc_dev_v2rholapl), nl*n, g)
1076 : IF (ALLOCATED(worker%v2rhotau)) &
1077 : CALL libxc_dev_alloc_maybe(worker%dev(libxc_dev_v2rhotau), nl*n, g)
1078 : IF (ALLOCATED(worker%v2sigmalapl)) &
1079 : CALL libxc_dev_alloc_maybe(worker%dev(libxc_dev_v2sigmalapl), MERGE(6, 1, pol)*n, g)
1080 : IF (ALLOCATED(worker%v2sigmatau)) &
1081 : CALL libxc_dev_alloc_maybe(worker%dev(libxc_dev_v2sigmatau), MERGE(6, 1, pol)*n, g)
1082 : IF (ALLOCATED(worker%v2lapl2)) &
1083 : CALL libxc_dev_alloc_maybe(worker%dev(libxc_dev_v2lapl2), ns*n, g)
1084 : IF (ALLOCATED(worker%v2lapltau)) &
1085 : CALL libxc_dev_alloc_maybe(worker%dev(libxc_dev_v2lapltau), nl*n, g)
1086 : IF (ALLOCATED(worker%v2tau2)) &
1087 : CALL libxc_dev_alloc_maybe(worker%dev(libxc_dev_v2tau2), ns*n, g)
1088 : base = libxc_dev_first_new3
1089 : #:for idx, arr in enumerate(v3_new)
1090 : IF (ALLOCATED(worker%${arr}$)) THEN
1091 : i = base + ${idx}$
1092 : CALL libxc_dev_alloc_maybe(worker%dev(i), MERGE(${mgga_ncomp[arr]}$, 1, pol)*n, g)
1093 : END IF
1094 : #:endfor
1095 : END SELECT
1096 :
1097 : END SUBROUTINE libxc_worker_device_alloc
1098 :
1099 : ! **************************************************************************************************
1100 : !> \brief Frees every device buffer of a worker.
1101 : ! **************************************************************************************************
1102 : SUBROUTINE libxc_worker_device_free(worker)
1103 : TYPE(libxc_worker_type), INTENT(INOUT) :: worker
1104 :
1105 : INTEGER :: i
1106 :
1107 : DO i = 1, libxc_max_dev_buffers
1108 : CALL libxc_device_buffer_free(worker%dev(i))
1109 : END DO
1110 :
1111 : END SUBROUTINE libxc_worker_device_free
1112 :
1113 : ! **************************************************************************************************
1114 : !> \brief Runs the device evaluation matching the functional family and the
1115 : !> requested derivative order on a worker's device buffers.
1116 : !> \param worker the worker owning the device buffers
1117 : !> \param family LibXC functional family
1118 : !> \param grad_deriv derivative order requested (0..3)
1119 : !> \param no_exc functional does not provide the energy density
1120 : !> \param np number of grid points in this block
1121 : !> \note This is the only copy of the device dispatch; xc_libxc only has to
1122 : !> stage its host buffers and then read the results back.
1123 : ! **************************************************************************************************
1124 : SUBROUTINE libxc_worker_eval_device(worker, family, grad_deriv, no_exc, np)
1125 : TYPE(libxc_worker_type), INTENT(INOUT) :: worker
1126 : INTEGER, INTENT(IN) :: family, grad_deriv
1127 : LOGICAL, INTENT(IN) :: no_exc
1128 : INTEGER(KIND=C_SIZE_T), INTENT(IN) :: np
1129 :
1130 : LOGICAL :: is_gga, is_mgga
1131 :
1132 : CALL libxc_family_flags(family, is_gga, is_mgga, "libxc_worker_eval_device")
1133 :
1134 : IF (is_mgga) THEN
1135 : SELECT CASE (grad_deriv)
1136 : CASE (0)
1137 : CALL libxc_mgga_exc_device(worker%func, worker%dev(libxc_dev_rho), worker%dev(libxc_dev_sigma), &
1138 : worker%dev(libxc_dev_lapl), worker%dev(libxc_dev_tau), &
1139 : worker%dev(libxc_dev_exc), np)
1140 : CASE (1)
1141 : IF (no_exc) THEN
1142 : CALL libxc_mgga_vxc_device(worker%func, worker%dev(libxc_dev_rho), worker%dev(libxc_dev_sigma), &
1143 : worker%dev(libxc_dev_lapl), worker%dev(libxc_dev_tau), &
1144 : worker%dev(libxc_dev_vrho), worker%dev(libxc_dev_vsigma), &
1145 : worker%dev(libxc_dev_vlapl), worker%dev(libxc_dev_vtau), np)
1146 : worker%exc = 0.0_dp
1147 : ELSE
1148 : CALL libxc_mgga_exc_vxc_device(worker%func, worker%dev(libxc_dev_rho), worker%dev(libxc_dev_sigma), &
1149 : worker%dev(libxc_dev_lapl), worker%dev(libxc_dev_tau), &
1150 : worker%dev(libxc_dev_exc), worker%dev(libxc_dev_vrho), &
1151 : worker%dev(libxc_dev_vsigma), worker%dev(libxc_dev_vlapl), &
1152 : worker%dev(libxc_dev_vtau), np)
1153 : END IF
1154 : CASE (2)
1155 : IF (no_exc) THEN
1156 : CALL libxc_mgga_vxc_fxc_device(worker%func, worker%dev(libxc_dev_rho), worker%dev(libxc_dev_sigma), &
1157 : worker%dev(libxc_dev_lapl), worker%dev(libxc_dev_tau), &
1158 : worker%dev(libxc_dev_vrho), worker%dev(libxc_dev_vsigma), &
1159 : worker%dev(libxc_dev_vlapl), worker%dev(libxc_dev_vtau), &
1160 : worker%dev(libxc_dev_v2rho2), worker%dev(libxc_dev_v2rhosigma), &
1161 : worker%dev(libxc_dev_v2rholapl), worker%dev(libxc_dev_v2rhotau), &
1162 : worker%dev(libxc_dev_v2sigma2), worker%dev(libxc_dev_v2sigmalapl), &
1163 : worker%dev(libxc_dev_v2sigmatau), worker%dev(libxc_dev_v2lapl2), &
1164 : worker%dev(libxc_dev_v2lapltau), worker%dev(libxc_dev_v2tau2), np)
1165 : worker%exc = 0.0_dp
1166 : ELSE
1167 : CALL libxc_mgga_exc_vxc_fxc_device(worker%func, worker%dev(libxc_dev_rho), worker%dev(libxc_dev_sigma), &
1168 : worker%dev(libxc_dev_lapl), worker%dev(libxc_dev_tau), &
1169 : worker%dev(libxc_dev_exc), worker%dev(libxc_dev_vrho), &
1170 : worker%dev(libxc_dev_vsigma), worker%dev(libxc_dev_vlapl), &
1171 : worker%dev(libxc_dev_vtau), worker%dev(libxc_dev_v2rho2), &
1172 : worker%dev(libxc_dev_v2rhosigma), worker%dev(libxc_dev_v2rholapl), &
1173 : worker%dev(libxc_dev_v2rhotau), worker%dev(libxc_dev_v2sigma2), &
1174 : worker%dev(libxc_dev_v2sigmalapl), worker%dev(libxc_dev_v2sigmatau), &
1175 : worker%dev(libxc_dev_v2lapl2), worker%dev(libxc_dev_v2lapltau), &
1176 : worker%dev(libxc_dev_v2tau2), np)
1177 : END IF
1178 : CASE (3)
1179 : IF (no_exc) THEN
1180 : CALL libxc_mgga_vxc_fxc_kxc_device(worker%func, worker%dev(libxc_dev_rho), worker%dev(libxc_dev_sigma), &
1181 : worker%dev(libxc_dev_lapl), worker%dev(libxc_dev_tau), &
1182 : worker%dev(libxc_dev_vrho), worker%dev(libxc_dev_vsigma), &
1183 : worker%dev(libxc_dev_vlapl), worker%dev(libxc_dev_vtau), &
1184 : worker%dev(libxc_dev_v2rho2), worker%dev(libxc_dev_v2rhosigma), &
1185 : worker%dev(libxc_dev_v2rholapl), worker%dev(libxc_dev_v2rhotau), &
1186 : worker%dev(libxc_dev_v2sigma2), worker%dev(libxc_dev_v2sigmalapl), &
1187 : worker%dev(libxc_dev_v2sigmatau), worker%dev(libxc_dev_v2lapl2), &
1188 : worker%dev(libxc_dev_v2lapltau), worker%dev(libxc_dev_v2tau2), &
1189 : worker%dev(libxc_dev_v3rho3), worker%dev(libxc_dev_v3rho2sigma), &
1190 : worker%dev(libxc_dev_v3rho2lapl), worker%dev(libxc_dev_v3rho2tau), &
1191 : worker%dev(libxc_dev_v3rhosigma2), worker%dev(libxc_dev_v3rhosigmalapl), &
1192 : worker%dev(libxc_dev_v3rhosigmatau), worker%dev(libxc_dev_v3rholapl2), &
1193 : worker%dev(libxc_dev_v3rholapltau), worker%dev(libxc_dev_v3rhotau2), &
1194 : worker%dev(libxc_dev_v3sigma3), worker%dev(libxc_dev_v3sigma2lapl), &
1195 : worker%dev(libxc_dev_v3sigma2tau), worker%dev(libxc_dev_v3sigmalapl2), &
1196 : worker%dev(libxc_dev_v3sigmalapltau), worker%dev(libxc_dev_v3sigmatau2), &
1197 : worker%dev(libxc_dev_v3lapl3), worker%dev(libxc_dev_v3lapl2tau), &
1198 : worker%dev(libxc_dev_v3lapltau2), worker%dev(libxc_dev_v3tau3), np)
1199 : worker%exc = 0.0_dp
1200 : ELSE
1201 : CALL libxc_mgga_exc_vxc_fxc_kxc_device(worker%func, worker%dev(libxc_dev_rho), &
1202 : worker%dev(libxc_dev_sigma), worker%dev(libxc_dev_lapl), &
1203 : worker%dev(libxc_dev_tau), worker%dev(libxc_dev_exc), &
1204 : worker%dev(libxc_dev_vrho), worker%dev(libxc_dev_vsigma), &
1205 : worker%dev(libxc_dev_vlapl), worker%dev(libxc_dev_vtau), &
1206 : worker%dev(libxc_dev_v2rho2), worker%dev(libxc_dev_v2rhosigma), &
1207 : worker%dev(libxc_dev_v2rholapl), worker%dev(libxc_dev_v2rhotau), &
1208 : worker%dev(libxc_dev_v2sigma2), worker%dev(libxc_dev_v2sigmalapl), &
1209 : worker%dev(libxc_dev_v2sigmatau), worker%dev(libxc_dev_v2lapl2), &
1210 : worker%dev(libxc_dev_v2lapltau), worker%dev(libxc_dev_v2tau2), &
1211 : worker%dev(libxc_dev_v3rho3), worker%dev(libxc_dev_v3rho2sigma), &
1212 : worker%dev(libxc_dev_v3rho2lapl), worker%dev(libxc_dev_v3rho2tau), &
1213 : worker%dev(libxc_dev_v3rhosigma2), worker%dev(libxc_dev_v3rhosigmalapl), &
1214 : worker%dev(libxc_dev_v3rhosigmatau), worker%dev(libxc_dev_v3rholapl2), &
1215 : worker%dev(libxc_dev_v3rholapltau), worker%dev(libxc_dev_v3rhotau2), &
1216 : worker%dev(libxc_dev_v3sigma3), worker%dev(libxc_dev_v3sigma2lapl), &
1217 : worker%dev(libxc_dev_v3sigma2tau), worker%dev(libxc_dev_v3sigmalapl2), &
1218 : worker%dev(libxc_dev_v3sigmalapltau), worker%dev(libxc_dev_v3sigmatau2), &
1219 : worker%dev(libxc_dev_v3lapl3), worker%dev(libxc_dev_v3lapl2tau), &
1220 : worker%dev(libxc_dev_v3lapltau2), worker%dev(libxc_dev_v3tau3), np)
1221 : END IF
1222 : END SELECT
1223 : ELSE IF (is_gga) THEN
1224 : SELECT CASE (grad_deriv)
1225 : CASE (0)
1226 : CALL libxc_gga_exc_device(worker%func, worker%dev(libxc_dev_rho), worker%dev(libxc_dev_sigma), &
1227 : worker%dev(libxc_dev_exc), np)
1228 : CASE (1)
1229 : IF (no_exc) THEN
1230 : CALL libxc_gga_vxc_device(worker%func, worker%dev(libxc_dev_rho), worker%dev(libxc_dev_sigma), &
1231 : worker%dev(libxc_dev_vrho), worker%dev(libxc_dev_vsigma), np)
1232 : worker%exc = 0.0_dp
1233 : ELSE
1234 : CALL libxc_gga_exc_vxc_device(worker%func, worker%dev(libxc_dev_rho), worker%dev(libxc_dev_sigma), &
1235 : worker%dev(libxc_dev_exc), worker%dev(libxc_dev_vrho), &
1236 : worker%dev(libxc_dev_vsigma), np)
1237 : END IF
1238 : CASE (2)
1239 : IF (no_exc) THEN
1240 : CALL libxc_gga_vxc_fxc_device(worker%func, worker%dev(libxc_dev_rho), worker%dev(libxc_dev_sigma), &
1241 : worker%dev(libxc_dev_vrho), worker%dev(libxc_dev_vsigma), &
1242 : worker%dev(libxc_dev_v2rho2), worker%dev(libxc_dev_v2rhosigma), &
1243 : worker%dev(libxc_dev_v2sigma2), np)
1244 : worker%exc = 0.0_dp
1245 : ELSE
1246 : CALL libxc_gga_exc_vxc_fxc_device(worker%func, worker%dev(libxc_dev_rho), worker%dev(libxc_dev_sigma), &
1247 : worker%dev(libxc_dev_exc), worker%dev(libxc_dev_vrho), &
1248 : worker%dev(libxc_dev_vsigma), worker%dev(libxc_dev_v2rho2), &
1249 : worker%dev(libxc_dev_v2rhosigma), worker%dev(libxc_dev_v2sigma2), np)
1250 : END IF
1251 : CASE (3)
1252 : IF (no_exc) THEN
1253 : CALL libxc_gga_vxc_fxc_kxc_device(worker%func, worker%dev(libxc_dev_rho), worker%dev(libxc_dev_sigma), &
1254 : worker%dev(libxc_dev_vrho), worker%dev(libxc_dev_vsigma), &
1255 : worker%dev(libxc_dev_v2rho2), worker%dev(libxc_dev_v2rhosigma), &
1256 : worker%dev(libxc_dev_v2sigma2), worker%dev(libxc_dev_v3rho3), &
1257 : worker%dev(libxc_dev_v3rho2sigma), worker%dev(libxc_dev_v3rhosigma2), &
1258 : worker%dev(libxc_dev_v3sigma3), np)
1259 : worker%exc = 0.0_dp
1260 : ELSE
1261 : CALL libxc_gga_exc_vxc_fxc_kxc_device(worker%func, worker%dev(libxc_dev_rho), &
1262 : worker%dev(libxc_dev_sigma), worker%dev(libxc_dev_exc), &
1263 : worker%dev(libxc_dev_vrho), worker%dev(libxc_dev_vsigma), &
1264 : worker%dev(libxc_dev_v2rho2), worker%dev(libxc_dev_v2rhosigma), &
1265 : worker%dev(libxc_dev_v2sigma2), worker%dev(libxc_dev_v3rho3), &
1266 : worker%dev(libxc_dev_v3rho2sigma), worker%dev(libxc_dev_v3rhosigma2), &
1267 : worker%dev(libxc_dev_v3sigma3), np)
1268 : END IF
1269 : END SELECT
1270 : ELSE
1271 : SELECT CASE (grad_deriv)
1272 : CASE (0)
1273 : CALL libxc_lda_exc_device(worker%func, worker%dev(libxc_dev_rho), worker%dev(libxc_dev_exc), np)
1274 : CASE (1)
1275 : CALL libxc_lda_exc_vxc_device(worker%func, worker%dev(libxc_dev_rho), worker%dev(libxc_dev_exc), &
1276 : worker%dev(libxc_dev_vrho), np)
1277 : CASE (2)
1278 : CALL libxc_lda_exc_vxc_fxc_device(worker%func, worker%dev(libxc_dev_rho), worker%dev(libxc_dev_exc), &
1279 : worker%dev(libxc_dev_vrho), worker%dev(libxc_dev_v2rho2), np)
1280 : CASE (3)
1281 : CALL libxc_lda_exc_vxc_fxc_kxc_device(worker%func, worker%dev(libxc_dev_rho), worker%dev(libxc_dev_exc), &
1282 : worker%dev(libxc_dev_vrho), worker%dev(libxc_dev_v2rho2), &
1283 : worker%dev(libxc_dev_v3rho3), np)
1284 : END SELECT
1285 : END IF
1286 :
1287 : END SUBROUTINE libxc_worker_eval_device
1288 :
1289 : ! **************************************************************************************************
1290 : !> \brief Grows a worker's staging and device buffers to hold at least npoints
1291 : !> grid points.
1292 : !> \param worker the worker
1293 : !> \param family LibXC functional family
1294 : !> \param nspin XC_UNPOLARIZED or XC_POLARIZED
1295 : !> \param npoints number of grid points the buffers must hold
1296 : !> \author S. Lehtola
1297 : !> \note Only used on the GPU path, where the whole grid is handed to LibXC in
1298 : !> a single call (no block cap), so the staging and device buffers have
1299 : !> to hold the entire grid. They grow to the largest point count seen and
1300 : !> are reused (never shrunk) for the run. Only the arrays the worker
1301 : !> actually carries are touched, mirroring libxc_worker_alloc_buffers.
1302 : ! **************************************************************************************************
1303 : SUBROUTINE libxc_worker_resize_cuda(worker, family, nspin, npoints)
1304 : TYPE(libxc_worker_type), INTENT(INOUT) :: worker
1305 : INTEGER, INTENT(IN) :: family, nspin, npoints
1306 :
1307 : INTEGER :: nl, np, ns
1308 : LOGICAL :: pol
1309 :
1310 : pol = (nspin == XC_POLARIZED)
1311 : CALL libxc_worker_dims(nspin, np, ns, nl)
1312 :
1313 : ! grow the host staging buffers that are actually allocated
1314 : IF (ALLOCATED(worker%rho)) THEN
1315 : IF (SIZE(worker%rho, 2) < npoints) THEN
1316 : DEALLOCATE (worker%rho)
1317 : ALLOCATE (worker%rho(np, npoints))
1318 : END IF
1319 : END IF
1320 : IF (ALLOCATED(worker%exc)) THEN
1321 : IF (SIZE(worker%exc) < npoints) THEN
1322 : DEALLOCATE (worker%exc)
1323 : ALLOCATE (worker%exc(npoints))
1324 : END IF
1325 : END IF
1326 : IF (ALLOCATED(worker%vrho)) THEN
1327 : IF (SIZE(worker%vrho, 2) < npoints) THEN
1328 : DEALLOCATE (worker%vrho)
1329 : ALLOCATE (worker%vrho(np, npoints))
1330 : END IF
1331 : END IF
1332 : IF (ALLOCATED(worker%v2rho2)) THEN
1333 : IF (SIZE(worker%v2rho2, 2) < npoints) THEN
1334 : DEALLOCATE (worker%v2rho2)
1335 : ALLOCATE (worker%v2rho2(ns, npoints))
1336 : END IF
1337 : END IF
1338 : IF (ALLOCATED(worker%v3rho3)) THEN
1339 : IF (SIZE(worker%v3rho3, 2) < npoints) THEN
1340 : DEALLOCATE (worker%v3rho3)
1341 : ALLOCATE (worker%v3rho3(nl, npoints))
1342 : END IF
1343 : END IF
1344 :
1345 : SELECT CASE (family)
1346 : CASE (XC_FAMILY_GGA, XC_FAMILY_HYB_GGA, XC_FAMILY_MGGA, XC_FAMILY_HYB_MGGA)
1347 : IF (ALLOCATED(worker%sigma)) THEN
1348 : IF (SIZE(worker%sigma, 2) < npoints) THEN
1349 : DEALLOCATE (worker%sigma)
1350 : ALLOCATE (worker%sigma(ns, npoints))
1351 : END IF
1352 : END IF
1353 : IF (ALLOCATED(worker%vsigma)) THEN
1354 : IF (SIZE(worker%vsigma, 2) < npoints) THEN
1355 : DEALLOCATE (worker%vsigma)
1356 : ALLOCATE (worker%vsigma(ns, npoints))
1357 : END IF
1358 : END IF
1359 : IF (pol) THEN
1360 : IF (ALLOCATED(worker%nd) .AND. SIZE(worker%nd) < npoints) THEN
1361 : DEALLOCATE (worker%nd, worker%nda, worker%ndb)
1362 : ALLOCATE (worker%nd(npoints), worker%nda(npoints), worker%ndb(npoints))
1363 : END IF
1364 : END IF
1365 : IF (ALLOCATED(worker%v2rhosigma)) THEN
1366 : IF (SIZE(worker%v2rhosigma, 2) < npoints) THEN
1367 : DEALLOCATE (worker%v2rhosigma)
1368 : ALLOCATE (worker%v2rhosigma(MERGE(6, 1, pol), npoints))
1369 : END IF
1370 : END IF
1371 : IF (ALLOCATED(worker%v2sigma2)) THEN
1372 : IF (SIZE(worker%v2sigma2, 2) < npoints) THEN
1373 : DEALLOCATE (worker%v2sigma2)
1374 : ALLOCATE (worker%v2sigma2(MERGE(6, 1, pol), npoints))
1375 : END IF
1376 : END IF
1377 : #:for arr, dim in [("v3rho2sigma", "MERGE(9, 1, pol)"), &
1378 : ("v3rhosigma2", "MERGE(12, 1, pol)"), &
1379 : ("v3sigma3", "MERGE(10, 1, pol)")]
1380 : IF (ALLOCATED(worker%${arr}$)) THEN
1381 : IF (SIZE(worker%${arr}$, 2) < npoints) THEN
1382 : DEALLOCATE (worker%${arr}$)
1383 : ALLOCATE (worker%${arr}$ (${dim}$, npoints))
1384 : END IF
1385 : END IF
1386 : #:endfor
1387 : END SELECT
1388 :
1389 : SELECT CASE (family)
1390 : CASE (XC_FAMILY_MGGA, XC_FAMILY_HYB_MGGA)
1391 : #:for arr, dim in [("lapl", "np"), ("tau", "np"), ("vlapl", "np"), ("vtau", "np")]
1392 : IF (ALLOCATED(worker%${arr}$)) THEN
1393 : IF (SIZE(worker%${arr}$, 2) < npoints) THEN
1394 : DEALLOCATE (worker%${arr}$)
1395 : ALLOCATE (worker%${arr}$ (${dim}$, npoints))
1396 : END IF
1397 : END IF
1398 : #:endfor
1399 : ! LibXC leaves vlapl untouched for functionals that do not use the
1400 : ! Laplacian; re-zero a freshly grown buffer as in the initial alloc.
1401 : IF (ALLOCATED(worker%vlapl)) worker%vlapl = 0.0_dp
1402 : #:for arr, dim in [("v2rholapl", "nl"), ("v2rhotau", "nl"), &
1403 : ("v2sigmalapl", "MERGE(6, 1, pol)"), &
1404 : ("v2sigmatau", "MERGE(6, 1, pol)"), &
1405 : ("v2lapl2", "ns"), ("v2lapltau", "nl"), ("v2tau2", "ns")]
1406 : IF (ALLOCATED(worker%${arr}$)) THEN
1407 : IF (SIZE(worker%${arr}$, 2) < npoints) THEN
1408 : DEALLOCATE (worker%${arr}$)
1409 : ALLOCATE (worker%${arr}$ (${dim}$, npoints))
1410 : END IF
1411 : END IF
1412 : #:endfor
1413 : #:for arr in v3_new
1414 : IF (ALLOCATED(worker%${arr}$)) THEN
1415 : IF (SIZE(worker%${arr}$, 2) < npoints) THEN
1416 : DEALLOCATE (worker%${arr}$)
1417 : ALLOCATE (worker%${arr}$ (MERGE(${mgga_ncomp[arr]}$, 1, pol), npoints))
1418 : END IF
1419 : END IF
1420 : #:endfor
1421 : END SELECT
1422 :
1423 : ! grow only the CUDA device buffers that are already large enough to be
1424 : ! reused; the grow-only guards keep the derivative-order and family
1425 : ! logic of libxc_worker_alloc_buffers intact.
1426 : CALL libxc_worker_device_alloc(worker, family, pol, nl, np, ns, npoints, grow_only=.TRUE.)
1427 :
1428 : END SUBROUTINE libxc_worker_resize_cuda
1429 :
1430 : ! **************************************************************************************************
1431 : !> \brief Allocate a device buffer for LibXC.
1432 : !> \param buffer ...
1433 : !> \param n ...
1434 : ! **************************************************************************************************
1435 : SUBROUTINE libxc_device_buffer_alloc(buffer, n)
1436 : USE ISO_C_BINDING, ONLY: C_INT64_T
1437 : USE offload_api, ONLY: offload_create_buffer
1438 : TYPE(libxc_device_buffer_type), INTENT(INOUT) :: buffer
1439 : INTEGER, INTENT(IN) :: n
1440 :
1441 : ! Release any previous allocation first: the GPU path regrows the device
1442 : ! buffers to the whole grid (libxc_worker_resize_cuda), and
1443 : ! offload_create_buffer does not free the old device pointer on its own.
1444 : ! Freeing a buffer that was never allocated is a no-op.
1445 : CALL libxc_device_buffer_free(buffer)
1446 :
1447 : buffer%size = INT(n, KIND=C_INT64_T)
1448 : CALL offload_create_buffer(n, buffer%buffer)
1449 : END SUBROUTINE libxc_device_buffer_alloc
1450 :
1451 : ! **************************************************************************************************
1452 : !> \brief Free a LibXC device buffer.
1453 : !> \param buffer ...
1454 : ! **************************************************************************************************
1455 : SUBROUTINE libxc_device_buffer_free(buffer)
1456 : USE offload_api, ONLY: offload_free_buffer
1457 : TYPE(libxc_device_buffer_type), INTENT(INOUT) :: buffer
1458 :
1459 : CALL offload_free_buffer(buffer%buffer)
1460 : buffer%size = 0
1461 : END SUBROUTINE libxc_device_buffer_free
1462 :
1463 : ! **************************************************************************************************
1464 : !> \brief Copy host data into a LibXC device buffer.
1465 : !> \param buffer ...
1466 : !> \param host ...
1467 : !> \param n ...
1468 : ! **************************************************************************************************
1469 : SUBROUTINE libxc_host_to_device(buffer, host, n)
1470 : USE ISO_C_BINDING, ONLY: C_PTR, C_F_POINTER
1471 : USE offload_api, ONLY: offload_buffer_h2d, offload_get_buffer_host_pointer
1472 : TYPE(libxc_device_buffer_type), INTENT(INOUT) :: buffer
1473 : REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: host
1474 : INTEGER, INTENT(IN) :: n
1475 :
1476 : REAL(KIND=dp), DIMENSION(:), POINTER :: host_p
1477 : TYPE(C_PTR) :: hptr
1478 :
1479 : hptr = offload_get_buffer_host_pointer(buffer%buffer)
1480 : CALL C_F_POINTER(hptr, host_p, [n])
1481 : host_p(1:n) = host(1:n)
1482 : CALL offload_buffer_h2d(buffer%buffer, n)
1483 : END SUBROUTINE libxc_host_to_device
1484 : ! **************************************************************************************************
1485 : !> \brief Issue a device-to-host copy of a LibXC buffer.
1486 : !> \param buffer ...
1487 : !> \param n ...
1488 : ! **************************************************************************************************
1489 : SUBROUTINE libxc_d2h_issue(buffer, n)
1490 : USE offload_api, ONLY: offload_buffer_d2h
1491 : TYPE(libxc_device_buffer_type), INTENT(INOUT) :: buffer
1492 : INTEGER, INTENT(IN) :: n
1493 :
1494 : CALL offload_buffer_d2h(buffer%buffer, n)
1495 : END SUBROUTINE libxc_d2h_issue
1496 : ! **************************************************************************************************
1497 : !> \brief Read the host side of a LibXC device buffer after a copy.
1498 : !> \param host ...
1499 : !> \param buffer ...
1500 : !> \param n ...
1501 : ! **************************************************************************************************
1502 : SUBROUTINE libxc_d2h_read(host, buffer, n)
1503 : USE ISO_C_BINDING, ONLY: C_PTR, C_F_POINTER
1504 : USE offload_api, ONLY: offload_get_buffer_host_pointer
1505 : REAL(KIND=dp), DIMENSION(*), INTENT(OUT) :: host
1506 : TYPE(libxc_device_buffer_type), INTENT(IN) :: buffer
1507 : INTEGER, INTENT(IN) :: n
1508 :
1509 : REAL(KIND=dp), DIMENSION(:), POINTER :: host_p
1510 : TYPE(C_PTR) :: hptr
1511 :
1512 : hptr = offload_get_buffer_host_pointer(buffer%buffer)
1513 : CALL C_F_POINTER(hptr, host_p, [n])
1514 : host(1:n) = host_p(1:n)
1515 : END SUBROUTINE libxc_d2h_read
1516 :
1517 : ! **************************************************************************************************
1518 : !> \brief Return a Fortran pointer to a device buffer's underlying GPU memory.
1519 : !> \param buffer ...
1520 : !> \param n ...
1521 : !> \param fptr ...
1522 : ! **************************************************************************************************
1523 : SUBROUTINE libxc_device_buffer_get_ptr(buffer, n, fptr)
1524 : USE ISO_C_BINDING, ONLY: C_F_POINTER, C_PTR
1525 : USE offload_api, ONLY: offload_get_buffer_device_pointer
1526 : TYPE(libxc_device_buffer_type), INTENT(IN) :: buffer
1527 : INTEGER, INTENT(IN) :: n
1528 : REAL(KIND=dp), DIMENSION(:), INTENT(OUT), POINTER :: fptr
1529 :
1530 : TYPE(C_PTR) :: dptr
1531 :
1532 : dptr = offload_get_buffer_device_pointer(buffer%buffer)
1533 : CALL C_F_POINTER(dptr, fptr, [n])
1534 : END SUBROUTINE libxc_device_buffer_get_ptr
1535 :
1536 : ! **************************************************************************************************
1537 : !> \brief LDA exc and vxc on device buffers.
1538 : !> \param func ...
1539 : !> \param rho_d ...
1540 : !> \param exc_d ...
1541 : !> \param vrho_d ...
1542 : !> \param np ...
1543 : ! **************************************************************************************************
1544 : SUBROUTINE libxc_lda_exc_vxc_device(func, rho_d, exc_d, vrho_d, np)
1545 : USE ISO_C_BINDING, ONLY: C_SIZE_T
1546 : TYPE(xc_f03_func_t), INTENT(IN) :: func
1547 : TYPE(libxc_device_buffer_type), INTENT(IN) :: rho_d
1548 : TYPE(libxc_device_buffer_type), INTENT(INOUT) :: exc_d, vrho_d
1549 : INTEGER(KIND=C_SIZE_T), INTENT(IN) :: np
1550 :
1551 : REAL(KIND=dp), DIMENSION(:), POINTER :: exc_p, rho_p, vrho_p
1552 :
1553 : CALL libxc_device_buffer_get_ptr(rho_d, INT(rho_d%size), rho_p)
1554 : CALL libxc_device_buffer_get_ptr(exc_d, INT(exc_d%size), exc_p)
1555 : CALL libxc_device_buffer_get_ptr(vrho_d, INT(vrho_d%size), vrho_p)
1556 :
1557 : CALL xc_f03_lda_exc_vxc(func, np, rho_p, exc_p, vrho_p)
1558 : END SUBROUTINE libxc_lda_exc_vxc_device
1559 :
1560 : ! **************************************************************************************************
1561 : !> \brief LDA exc on device buffers.
1562 : !> \param func ...
1563 : !> \param rho_d ...
1564 : !> \param exc_d ...
1565 : !> \param np ...
1566 : ! **************************************************************************************************
1567 : SUBROUTINE libxc_lda_exc_device(func, rho_d, exc_d, np)
1568 : USE ISO_C_BINDING, ONLY: C_SIZE_T
1569 : TYPE(xc_f03_func_t), INTENT(IN) :: func
1570 : TYPE(libxc_device_buffer_type), INTENT(IN) :: rho_d
1571 : TYPE(libxc_device_buffer_type), INTENT(INOUT) :: exc_d
1572 : INTEGER(KIND=C_SIZE_T), INTENT(IN) :: np
1573 :
1574 : REAL(KIND=dp), DIMENSION(:), POINTER :: exc_p, rho_p
1575 :
1576 : CALL libxc_device_buffer_get_ptr(rho_d, INT(rho_d%size), rho_p)
1577 : CALL libxc_device_buffer_get_ptr(exc_d, INT(exc_d%size), exc_p)
1578 :
1579 : CALL xc_f03_lda_exc(func, np, rho_p, exc_p)
1580 : END SUBROUTINE libxc_lda_exc_device
1581 :
1582 : ! **************************************************************************************************
1583 : !> \brief LDA exc, vxc and fxc on device buffers.
1584 : !> \param func ...
1585 : !> \param rho_d ...
1586 : !> \param exc_d ...
1587 : !> \param vrho_d ...
1588 : !> \param v2rho2_d ...
1589 : !> \param np ...
1590 : ! **************************************************************************************************
1591 : SUBROUTINE libxc_lda_exc_vxc_fxc_device(func, rho_d, exc_d, vrho_d, v2rho2_d, np)
1592 : USE ISO_C_BINDING, ONLY: C_SIZE_T
1593 : TYPE(xc_f03_func_t), INTENT(IN) :: func
1594 : TYPE(libxc_device_buffer_type), INTENT(IN) :: rho_d
1595 : TYPE(libxc_device_buffer_type), INTENT(INOUT) :: exc_d, vrho_d, v2rho2_d
1596 : INTEGER(KIND=C_SIZE_T), INTENT(IN) :: np
1597 :
1598 : REAL(KIND=dp), DIMENSION(:), POINTER :: exc_p, rho_p, v2rho2_p, vrho_p
1599 :
1600 : CALL libxc_device_buffer_get_ptr(rho_d, INT(rho_d%size), rho_p)
1601 : CALL libxc_device_buffer_get_ptr(exc_d, INT(exc_d%size), exc_p)
1602 : CALL libxc_device_buffer_get_ptr(vrho_d, INT(vrho_d%size), vrho_p)
1603 : CALL libxc_device_buffer_get_ptr(v2rho2_d, INT(v2rho2_d%size), v2rho2_p)
1604 :
1605 : CALL xc_f03_lda_exc_vxc_fxc(func, np, rho_p, exc_p, vrho_p, v2rho2_p)
1606 : END SUBROUTINE libxc_lda_exc_vxc_fxc_device
1607 :
1608 : ! **************************************************************************************************
1609 : !> \brief LDA exc, vxc, fxc and kxc on device buffers.
1610 : !> \param func ...
1611 : !> \param rho_d ...
1612 : !> \param exc_d ...
1613 : !> \param vrho_d ...
1614 : !> \param v2rho2_d ...
1615 : !> \param v3rho3_d ...
1616 : !> \param np ...
1617 : ! **************************************************************************************************
1618 : SUBROUTINE libxc_lda_exc_vxc_fxc_kxc_device(func, rho_d, exc_d, vrho_d, v2rho2_d, v3rho3_d, np)
1619 : USE ISO_C_BINDING, ONLY: C_SIZE_T
1620 : TYPE(xc_f03_func_t), INTENT(IN) :: func
1621 : TYPE(libxc_device_buffer_type), INTENT(IN) :: rho_d
1622 : TYPE(libxc_device_buffer_type), INTENT(INOUT) :: exc_d, vrho_d, v2rho2_d, v3rho3_d
1623 : INTEGER(KIND=C_SIZE_T), INTENT(IN) :: np
1624 :
1625 : REAL(KIND=dp), DIMENSION(:), POINTER :: exc_p, rho_p, v2rho2_p, v3rho3_p, vrho_p
1626 :
1627 : CALL libxc_device_buffer_get_ptr(rho_d, INT(rho_d%size), rho_p)
1628 : CALL libxc_device_buffer_get_ptr(exc_d, INT(exc_d%size), exc_p)
1629 : CALL libxc_device_buffer_get_ptr(vrho_d, INT(vrho_d%size), vrho_p)
1630 : CALL libxc_device_buffer_get_ptr(v2rho2_d, INT(v2rho2_d%size), v2rho2_p)
1631 : CALL libxc_device_buffer_get_ptr(v3rho3_d, INT(v3rho3_d%size), v3rho3_p)
1632 :
1633 : CALL xc_f03_lda_exc_vxc_fxc_kxc(func, np, rho_p, exc_p, vrho_p, v2rho2_p, v3rho3_p)
1634 : END SUBROUTINE libxc_lda_exc_vxc_fxc_kxc_device
1635 :
1636 : ! **************************************************************************************************
1637 : !> \brief GGA exc on device buffers.
1638 : !> \param func ...
1639 : !> \param rho_d ...
1640 : !> \param sigma_d ...
1641 : !> \param exc_d ...
1642 : !> \param np ...
1643 : ! **************************************************************************************************
1644 : SUBROUTINE libxc_gga_exc_device(func, rho_d, sigma_d, exc_d, np)
1645 : USE ISO_C_BINDING, ONLY: C_SIZE_T
1646 : TYPE(xc_f03_func_t), INTENT(IN) :: func
1647 : TYPE(libxc_device_buffer_type), INTENT(IN) :: rho_d, sigma_d
1648 : TYPE(libxc_device_buffer_type), INTENT(INOUT) :: exc_d
1649 : INTEGER(KIND=C_SIZE_T), INTENT(IN) :: np
1650 :
1651 : REAL(KIND=dp), DIMENSION(:), POINTER :: exc_p, rho_p, sigma_p
1652 :
1653 : CALL libxc_device_buffer_get_ptr(rho_d, INT(rho_d%size), rho_p)
1654 : CALL libxc_device_buffer_get_ptr(sigma_d, INT(sigma_d%size), sigma_p)
1655 : CALL libxc_device_buffer_get_ptr(exc_d, INT(exc_d%size), exc_p)
1656 :
1657 : CALL xc_f03_gga_exc(func, np, rho_p, sigma_p, exc_p)
1658 : END SUBROUTINE libxc_gga_exc_device
1659 :
1660 : ! **************************************************************************************************
1661 : !> \brief GGA exc and vxc on device buffers.
1662 : !> \param func ...
1663 : !> \param rho_d ...
1664 : !> \param sigma_d ...
1665 : !> \param exc_d ...
1666 : !> \param vrho_d ...
1667 : !> \param vsigma_d ...
1668 : !> \param np ...
1669 : ! **************************************************************************************************
1670 : SUBROUTINE libxc_gga_exc_vxc_device(func, rho_d, sigma_d, exc_d, vrho_d, vsigma_d, np)
1671 : USE ISO_C_BINDING, ONLY: C_SIZE_T
1672 : TYPE(xc_f03_func_t), INTENT(IN) :: func
1673 : TYPE(libxc_device_buffer_type), INTENT(IN) :: rho_d, sigma_d
1674 : TYPE(libxc_device_buffer_type), INTENT(INOUT) :: exc_d, vrho_d, vsigma_d
1675 : INTEGER(KIND=C_SIZE_T), INTENT(IN) :: np
1676 :
1677 : REAL(KIND=dp), DIMENSION(:), POINTER :: exc_p, rho_p, sigma_p, vrho_p, vsigma_p
1678 :
1679 : CALL libxc_device_buffer_get_ptr(rho_d, INT(rho_d%size), rho_p)
1680 : CALL libxc_device_buffer_get_ptr(sigma_d, INT(sigma_d%size), sigma_p)
1681 : CALL libxc_device_buffer_get_ptr(exc_d, INT(exc_d%size), exc_p)
1682 : CALL libxc_device_buffer_get_ptr(vrho_d, INT(vrho_d%size), vrho_p)
1683 : CALL libxc_device_buffer_get_ptr(vsigma_d, INT(vsigma_d%size), vsigma_p)
1684 :
1685 : CALL xc_f03_gga_exc_vxc(func, np, rho_p, sigma_p, exc_p, vrho_p, vsigma_p)
1686 : END SUBROUTINE libxc_gga_exc_vxc_device
1687 :
1688 : ! **************************************************************************************************
1689 : !> \brief GGA exc, vxc and fxc on device buffers.
1690 : !> \param func ...
1691 : !> \param rho_d ...
1692 : !> \param sigma_d ...
1693 : !> \param exc_d ...
1694 : !> \param vrho_d ...
1695 : !> \param vsigma_d ...
1696 : !> \param v2rho2_d ...
1697 : !> \param v2rhosigma_d ...
1698 : !> \param v2sigma2_d ...
1699 : !> \param np ...
1700 : ! **************************************************************************************************
1701 : SUBROUTINE libxc_gga_exc_vxc_fxc_device(func, rho_d, sigma_d, exc_d, vrho_d, vsigma_d, &
1702 : v2rho2_d, v2rhosigma_d, v2sigma2_d, np)
1703 : USE ISO_C_BINDING, ONLY: C_SIZE_T
1704 : TYPE(xc_f03_func_t), INTENT(IN) :: func
1705 : TYPE(libxc_device_buffer_type), INTENT(IN) :: rho_d, sigma_d
1706 : TYPE(libxc_device_buffer_type), INTENT(INOUT) :: exc_d, vrho_d, vsigma_d, v2rho2_d, &
1707 : v2rhosigma_d, v2sigma2_d
1708 : INTEGER(KIND=C_SIZE_T), INTENT(IN) :: np
1709 :
1710 : REAL(KIND=dp), DIMENSION(:), POINTER :: exc_p, rho_p, sigma_p, v2rho2_p, &
1711 : v2rhosigma_p, v2sigma2_p, vrho_p, &
1712 : vsigma_p
1713 :
1714 : CALL libxc_device_buffer_get_ptr(rho_d, INT(rho_d%size), rho_p)
1715 : CALL libxc_device_buffer_get_ptr(sigma_d, INT(sigma_d%size), sigma_p)
1716 : CALL libxc_device_buffer_get_ptr(exc_d, INT(exc_d%size), exc_p)
1717 : CALL libxc_device_buffer_get_ptr(vrho_d, INT(vrho_d%size), vrho_p)
1718 : CALL libxc_device_buffer_get_ptr(vsigma_d, INT(vsigma_d%size), vsigma_p)
1719 : CALL libxc_device_buffer_get_ptr(v2rho2_d, INT(v2rho2_d%size), v2rho2_p)
1720 : CALL libxc_device_buffer_get_ptr(v2rhosigma_d, INT(v2rhosigma_d%size), v2rhosigma_p)
1721 : CALL libxc_device_buffer_get_ptr(v2sigma2_d, INT(v2sigma2_d%size), v2sigma2_p)
1722 :
1723 : CALL xc_f03_gga_exc_vxc_fxc(func, np, rho_p, sigma_p, exc_p, vrho_p, vsigma_p, &
1724 : v2rho2_p, v2rhosigma_p, v2sigma2_p)
1725 : END SUBROUTINE libxc_gga_exc_vxc_fxc_device
1726 :
1727 : ! **************************************************************************************************
1728 : !> \brief GGA vxc and fxc on device buffers.
1729 : !> \param func ...
1730 : !> \param rho_d ...
1731 : !> \param sigma_d ...
1732 : !> \param vrho_d ...
1733 : !> \param vsigma_d ...
1734 : !> \param v2rho2_d ...
1735 : !> \param v2rhosigma_d ...
1736 : !> \param v2sigma2_d ...
1737 : !> \param np ...
1738 : ! **************************************************************************************************
1739 : SUBROUTINE libxc_gga_vxc_fxc_device(func, rho_d, sigma_d, vrho_d, vsigma_d, &
1740 : v2rho2_d, v2rhosigma_d, v2sigma2_d, np)
1741 : USE ISO_C_BINDING, ONLY: C_SIZE_T
1742 : TYPE(xc_f03_func_t), INTENT(IN) :: func
1743 : TYPE(libxc_device_buffer_type), INTENT(IN) :: rho_d, sigma_d
1744 : TYPE(libxc_device_buffer_type), INTENT(INOUT) :: vrho_d, vsigma_d, v2rho2_d, &
1745 : v2rhosigma_d, v2sigma2_d
1746 : INTEGER(KIND=C_SIZE_T), INTENT(IN) :: np
1747 :
1748 : REAL(KIND=dp), DIMENSION(:), POINTER :: rho_p, sigma_p, v2rho2_p, v2rhosigma_p, &
1749 : v2sigma2_p, vrho_p, vsigma_p
1750 :
1751 : CALL libxc_device_buffer_get_ptr(rho_d, INT(rho_d%size), rho_p)
1752 : CALL libxc_device_buffer_get_ptr(sigma_d, INT(sigma_d%size), sigma_p)
1753 : CALL libxc_device_buffer_get_ptr(vrho_d, INT(vrho_d%size), vrho_p)
1754 : CALL libxc_device_buffer_get_ptr(vsigma_d, INT(vsigma_d%size), vsigma_p)
1755 : CALL libxc_device_buffer_get_ptr(v2rho2_d, INT(v2rho2_d%size), v2rho2_p)
1756 : CALL libxc_device_buffer_get_ptr(v2rhosigma_d, INT(v2rhosigma_d%size), v2rhosigma_p)
1757 : CALL libxc_device_buffer_get_ptr(v2sigma2_d, INT(v2sigma2_d%size), v2sigma2_p)
1758 :
1759 : CALL xc_f03_gga_vxc_fxc(func, np, rho_p, sigma_p, vrho_p, vsigma_p, &
1760 : v2rho2_p, v2rhosigma_p, v2sigma2_p)
1761 : END SUBROUTINE libxc_gga_vxc_fxc_device
1762 :
1763 : ! **************************************************************************************************
1764 : !> \brief GGA exc, vxc, fxc and kxc on device buffers.
1765 : !> \param func ...
1766 : !> \param rho_d ...
1767 : !> \param sigma_d ...
1768 : !> \param exc_d ...
1769 : !> \param vrho_d ...
1770 : !> \param vsigma_d ...
1771 : !> \param v2rho2_d ...
1772 : !> \param v2rhosigma_d ...
1773 : !> \param v2sigma2_d ...
1774 : !> \param v3rho3_d ...
1775 : !> \param v3rho2sigma_d ...
1776 : !> \param v3rhosigma2_d ...
1777 : !> \param v3sigma3_d ...
1778 : !> \param np ...
1779 : ! **************************************************************************************************
1780 : SUBROUTINE libxc_gga_exc_vxc_fxc_kxc_device(func, rho_d, sigma_d, exc_d, vrho_d, vsigma_d, &
1781 : v2rho2_d, v2rhosigma_d, v2sigma2_d, &
1782 : v3rho3_d, v3rho2sigma_d, v3rhosigma2_d, v3sigma3_d, np)
1783 : USE ISO_C_BINDING, ONLY: C_SIZE_T
1784 : TYPE(xc_f03_func_t), INTENT(IN) :: func
1785 : TYPE(libxc_device_buffer_type), INTENT(IN) :: rho_d, sigma_d
1786 : TYPE(libxc_device_buffer_type), INTENT(INOUT) :: exc_d, vrho_d, vsigma_d, v2rho2_d, &
1787 : v2rhosigma_d, v2sigma2_d, v3rho3_d, &
1788 : v3rho2sigma_d, v3rhosigma2_d, &
1789 : v3sigma3_d
1790 : INTEGER(KIND=C_SIZE_T), INTENT(IN) :: np
1791 :
1792 : REAL(KIND=dp), DIMENSION(:), POINTER :: exc_p, rho_p, sigma_p, v2rho2_p, v2rhosigma_p, &
1793 : v2sigma2_p, v3rho2sigma_p, v3rho3_p, v3rhosigma2_p, v3sigma3_p, vrho_p, vsigma_p
1794 :
1795 : CALL libxc_device_buffer_get_ptr(rho_d, INT(rho_d%size), rho_p)
1796 : CALL libxc_device_buffer_get_ptr(sigma_d, INT(sigma_d%size), sigma_p)
1797 : CALL libxc_device_buffer_get_ptr(exc_d, INT(exc_d%size), exc_p)
1798 : CALL libxc_device_buffer_get_ptr(vrho_d, INT(vrho_d%size), vrho_p)
1799 : CALL libxc_device_buffer_get_ptr(vsigma_d, INT(vsigma_d%size), vsigma_p)
1800 : CALL libxc_device_buffer_get_ptr(v2rho2_d, INT(v2rho2_d%size), v2rho2_p)
1801 : CALL libxc_device_buffer_get_ptr(v2rhosigma_d, INT(v2rhosigma_d%size), v2rhosigma_p)
1802 : CALL libxc_device_buffer_get_ptr(v2sigma2_d, INT(v2sigma2_d%size), v2sigma2_p)
1803 : CALL libxc_device_buffer_get_ptr(v3rho3_d, INT(v3rho3_d%size), v3rho3_p)
1804 : CALL libxc_device_buffer_get_ptr(v3rho2sigma_d, INT(v3rho2sigma_d%size), v3rho2sigma_p)
1805 : CALL libxc_device_buffer_get_ptr(v3rhosigma2_d, INT(v3rhosigma2_d%size), v3rhosigma2_p)
1806 : CALL libxc_device_buffer_get_ptr(v3sigma3_d, INT(v3sigma3_d%size), v3sigma3_p)
1807 :
1808 : CALL xc_f03_gga_exc_vxc_fxc_kxc(func, np, rho_p, sigma_p, exc_p, vrho_p, vsigma_p, &
1809 : v2rho2_p, v2rhosigma_p, v2sigma2_p, v3rho3_p, &
1810 : v3rho2sigma_p, v3rhosigma2_p, v3sigma3_p)
1811 : END SUBROUTINE libxc_gga_exc_vxc_fxc_kxc_device
1812 :
1813 : ! **************************************************************************************************
1814 : !> \brief GGA vxc, fxc and kxc on device buffers.
1815 : !> \param func ...
1816 : !> \param rho_d ...
1817 : !> \param sigma_d ...
1818 : !> \param vrho_d ...
1819 : !> \param vsigma_d ...
1820 : !> \param v2rho2_d ...
1821 : !> \param v2rhosigma_d ...
1822 : !> \param v2sigma2_d ...
1823 : !> \param v3rho3_d ...
1824 : !> \param v3rho2sigma_d ...
1825 : !> \param v3rhosigma2_d ...
1826 : !> \param v3sigma3_d ...
1827 : !> \param np ...
1828 : ! **************************************************************************************************
1829 : SUBROUTINE libxc_gga_vxc_fxc_kxc_device(func, rho_d, sigma_d, vrho_d, vsigma_d, &
1830 : v2rho2_d, v2rhosigma_d, v2sigma2_d, &
1831 : v3rho3_d, v3rho2sigma_d, v3rhosigma2_d, v3sigma3_d, np)
1832 : USE ISO_C_BINDING, ONLY: C_SIZE_T
1833 : TYPE(xc_f03_func_t), INTENT(IN) :: func
1834 : TYPE(libxc_device_buffer_type), INTENT(IN) :: rho_d, sigma_d
1835 : TYPE(libxc_device_buffer_type), INTENT(INOUT) :: vrho_d, vsigma_d, v2rho2_d, &
1836 : v2rhosigma_d, v2sigma2_d, v3rho3_d, &
1837 : v3rho2sigma_d, v3rhosigma2_d, &
1838 : v3sigma3_d
1839 : INTEGER(KIND=C_SIZE_T), INTENT(IN) :: np
1840 :
1841 : REAL(KIND=dp), DIMENSION(:), POINTER :: rho_p, sigma_p, v2rho2_p, v2rhosigma_p, v2sigma2_p, &
1842 : v3rho2sigma_p, v3rho3_p, v3rhosigma2_p, v3sigma3_p, vrho_p, vsigma_p
1843 :
1844 : CALL libxc_device_buffer_get_ptr(rho_d, INT(rho_d%size), rho_p)
1845 : CALL libxc_device_buffer_get_ptr(sigma_d, INT(sigma_d%size), sigma_p)
1846 : CALL libxc_device_buffer_get_ptr(vrho_d, INT(vrho_d%size), vrho_p)
1847 : CALL libxc_device_buffer_get_ptr(vsigma_d, INT(vsigma_d%size), vsigma_p)
1848 : CALL libxc_device_buffer_get_ptr(v2rho2_d, INT(v2rho2_d%size), v2rho2_p)
1849 : CALL libxc_device_buffer_get_ptr(v2rhosigma_d, INT(v2rhosigma_d%size), v2rhosigma_p)
1850 : CALL libxc_device_buffer_get_ptr(v2sigma2_d, INT(v2sigma2_d%size), v2sigma2_p)
1851 : CALL libxc_device_buffer_get_ptr(v3rho3_d, INT(v3rho3_d%size), v3rho3_p)
1852 : CALL libxc_device_buffer_get_ptr(v3rho2sigma_d, INT(v3rho2sigma_d%size), v3rho2sigma_p)
1853 : CALL libxc_device_buffer_get_ptr(v3rhosigma2_d, INT(v3rhosigma2_d%size), v3rhosigma2_p)
1854 : CALL libxc_device_buffer_get_ptr(v3sigma3_d, INT(v3sigma3_d%size), v3sigma3_p)
1855 :
1856 : CALL xc_f03_gga_vxc_fxc_kxc(func, np, rho_p, sigma_p, vrho_p, vsigma_p, &
1857 : v2rho2_p, v2rhosigma_p, v2sigma2_p, v3rho3_p, &
1858 : v3rho2sigma_p, v3rhosigma2_p, v3sigma3_p)
1859 : END SUBROUTINE libxc_gga_vxc_fxc_kxc_device
1860 :
1861 : ! **************************************************************************************************
1862 : !> \brief GGA vxc on device buffers.
1863 : !> \param func ...
1864 : !> \param rho_d ...
1865 : !> \param sigma_d ...
1866 : !> \param vrho_d ...
1867 : !> \param vsigma_d ...
1868 : !> \param np ...
1869 : ! **************************************************************************************************
1870 : SUBROUTINE libxc_gga_vxc_device(func, rho_d, sigma_d, vrho_d, vsigma_d, np)
1871 : USE ISO_C_BINDING, ONLY: C_SIZE_T
1872 : TYPE(xc_f03_func_t), INTENT(IN) :: func
1873 : TYPE(libxc_device_buffer_type), INTENT(IN) :: rho_d, sigma_d
1874 : TYPE(libxc_device_buffer_type), INTENT(INOUT) :: vrho_d, vsigma_d
1875 : INTEGER(KIND=C_SIZE_T), INTENT(IN) :: np
1876 :
1877 : REAL(KIND=dp), DIMENSION(:), POINTER :: rho_p, sigma_p, vrho_p, vsigma_p
1878 :
1879 : CALL libxc_device_buffer_get_ptr(rho_d, INT(rho_d%size), rho_p)
1880 : CALL libxc_device_buffer_get_ptr(sigma_d, INT(sigma_d%size), sigma_p)
1881 : CALL libxc_device_buffer_get_ptr(vrho_d, INT(vrho_d%size), vrho_p)
1882 : CALL libxc_device_buffer_get_ptr(vsigma_d, INT(vsigma_d%size), vsigma_p)
1883 :
1884 : CALL xc_f03_gga_vxc(func, np, rho_p, sigma_p, vrho_p, vsigma_p)
1885 : END SUBROUTINE libxc_gga_vxc_device
1886 :
1887 : ! **************************************************************************************************
1888 : !> \brief MGGA exc on device buffers.
1889 : !> \param func ...
1890 : !> \param rho_d ...
1891 : !> \param sigma_d ...
1892 : !> \param lapl_d ...
1893 : !> \param tau_d ...
1894 : !> \param exc_d ...
1895 : !> \param np ...
1896 : ! **************************************************************************************************
1897 : SUBROUTINE libxc_mgga_exc_device(func, rho_d, sigma_d, lapl_d, tau_d, exc_d, np)
1898 : USE ISO_C_BINDING, ONLY: C_SIZE_T
1899 : TYPE(xc_f03_func_t), INTENT(IN) :: func
1900 : TYPE(libxc_device_buffer_type), INTENT(IN) :: rho_d, sigma_d, lapl_d, tau_d
1901 : TYPE(libxc_device_buffer_type), INTENT(INOUT) :: exc_d
1902 : INTEGER(KIND=C_SIZE_T), INTENT(IN) :: np
1903 :
1904 : REAL(KIND=dp), DIMENSION(:), POINTER :: exc_p, lapl_p, rho_p, sigma_p, tau_p
1905 :
1906 : CALL libxc_device_buffer_get_ptr(rho_d, INT(rho_d%size), rho_p)
1907 : CALL libxc_device_buffer_get_ptr(sigma_d, INT(sigma_d%size), sigma_p)
1908 : CALL libxc_device_buffer_get_ptr(lapl_d, INT(lapl_d%size), lapl_p)
1909 : CALL libxc_device_buffer_get_ptr(tau_d, INT(tau_d%size), tau_p)
1910 : CALL libxc_device_buffer_get_ptr(exc_d, INT(exc_d%size), exc_p)
1911 :
1912 : CALL xc_f03_mgga_exc(func, np, rho_p, sigma_p, lapl_p, tau_p, exc_p)
1913 : END SUBROUTINE libxc_mgga_exc_device
1914 :
1915 : ! **************************************************************************************************
1916 : !> \brief MGGA exc and vxc on device buffers.
1917 : !> \param func ...
1918 : !> \param rho_d ...
1919 : !> \param sigma_d ...
1920 : !> \param lapl_d ...
1921 : !> \param tau_d ...
1922 : !> \param exc_d ...
1923 : !> \param vrho_d ...
1924 : !> \param vsigma_d ...
1925 : !> \param vlapl_d ...
1926 : !> \param vtau_d ...
1927 : !> \param np ...
1928 : ! **************************************************************************************************
1929 : SUBROUTINE libxc_mgga_exc_vxc_device(func, rho_d, sigma_d, lapl_d, tau_d, exc_d, vrho_d, vsigma_d, vlapl_d, vtau_d, np)
1930 : USE ISO_C_BINDING, ONLY: C_SIZE_T
1931 : TYPE(xc_f03_func_t), INTENT(IN) :: func
1932 : TYPE(libxc_device_buffer_type), INTENT(IN) :: rho_d, sigma_d, lapl_d, tau_d
1933 : TYPE(libxc_device_buffer_type), INTENT(INOUT) :: exc_d, vrho_d, vsigma_d, vlapl_d, vtau_d
1934 : INTEGER(KIND=C_SIZE_T), INTENT(IN) :: np
1935 :
1936 : REAL(KIND=dp), DIMENSION(:), POINTER :: exc_p, lapl_p, rho_p, sigma_p, tau_p, &
1937 : vlapl_p, vrho_p, vsigma_p, vtau_p
1938 :
1939 : CALL libxc_device_buffer_get_ptr(rho_d, INT(rho_d%size), rho_p)
1940 : CALL libxc_device_buffer_get_ptr(sigma_d, INT(sigma_d%size), sigma_p)
1941 : CALL libxc_device_buffer_get_ptr(lapl_d, INT(lapl_d%size), lapl_p)
1942 : CALL libxc_device_buffer_get_ptr(tau_d, INT(tau_d%size), tau_p)
1943 : CALL libxc_device_buffer_get_ptr(exc_d, INT(exc_d%size), exc_p)
1944 : CALL libxc_device_buffer_get_ptr(vrho_d, INT(vrho_d%size), vrho_p)
1945 : CALL libxc_device_buffer_get_ptr(vsigma_d, INT(vsigma_d%size), vsigma_p)
1946 : CALL libxc_device_buffer_get_ptr(vlapl_d, INT(vlapl_d%size), vlapl_p)
1947 : CALL libxc_device_buffer_get_ptr(vtau_d, INT(vtau_d%size), vtau_p)
1948 :
1949 : CALL xc_f03_mgga_exc_vxc(func, np, rho_p, sigma_p, lapl_p, tau_p, &
1950 : exc_p, vrho_p, vsigma_p, vlapl_p, vtau_p)
1951 : END SUBROUTINE libxc_mgga_exc_vxc_device
1952 :
1953 : ! **************************************************************************************************
1954 : !> \brief MGGA exc, vxc and fxc on device buffers.
1955 : !> \param func ...
1956 : !> \param rho_d ...
1957 : !> \param sigma_d ...
1958 : !> \param lapl_d ...
1959 : !> \param tau_d ...
1960 : !> \param exc_d ...
1961 : !> \param vrho_d ...
1962 : !> \param vsigma_d ...
1963 : !> \param vlapl_d ...
1964 : !> \param vtau_d ...
1965 : !> \param v2rho2_d ...
1966 : !> \param v2rhosigma_d ...
1967 : !> \param v2rholapl_d ...
1968 : !> \param v2rhotau_d ...
1969 : !> \param v2sigma2_d ...
1970 : !> \param v2sigmalapl_d ...
1971 : !> \param v2sigmatau_d ...
1972 : !> \param v2lapl2_d ...
1973 : !> \param v2lapltau_d ...
1974 : !> \param v2tau2_d ...
1975 : !> \param np ...
1976 : ! **************************************************************************************************
1977 : SUBROUTINE libxc_mgga_exc_vxc_fxc_device(func, rho_d, sigma_d, lapl_d, tau_d, exc_d, &
1978 : vrho_d, vsigma_d, vlapl_d, vtau_d, v2rho2_d, &
1979 : v2rhosigma_d, v2rholapl_d, v2rhotau_d, v2sigma2_d, &
1980 : v2sigmalapl_d, v2sigmatau_d, v2lapl2_d, v2lapltau_d, &
1981 : v2tau2_d, np)
1982 : USE ISO_C_BINDING, ONLY: C_SIZE_T
1983 : TYPE(xc_f03_func_t), INTENT(IN) :: func
1984 : TYPE(libxc_device_buffer_type), INTENT(IN) :: rho_d, sigma_d, lapl_d, tau_d
1985 : TYPE(libxc_device_buffer_type), INTENT(INOUT) :: exc_d, vrho_d, vsigma_d, vlapl_d, vtau_d, &
1986 : v2rho2_d, v2rhosigma_d, v2rholapl_d, v2rhotau_d, v2sigma2_d, v2sigmalapl_d, v2sigmatau_d, &
1987 : v2lapl2_d, v2lapltau_d, v2tau2_d
1988 : INTEGER(KIND=C_SIZE_T), INTENT(IN) :: np
1989 :
1990 : REAL(KIND=dp), DIMENSION(:), POINTER :: exc_p, lapl_p, rho_p, sigma_p, tau_p, v2lapl2_p, &
1991 : v2lapltau_p, v2rho2_p, v2rholapl_p, v2rhosigma_p, v2rhotau_p, v2sigma2_p, v2sigmalapl_p, &
1992 : v2sigmatau_p, v2tau2_p, vlapl_p, vrho_p, vsigma_p, vtau_p
1993 :
1994 : CALL libxc_device_buffer_get_ptr(rho_d, INT(rho_d%size), rho_p)
1995 : CALL libxc_device_buffer_get_ptr(sigma_d, INT(sigma_d%size), sigma_p)
1996 : CALL libxc_device_buffer_get_ptr(lapl_d, INT(lapl_d%size), lapl_p)
1997 : CALL libxc_device_buffer_get_ptr(tau_d, INT(tau_d%size), tau_p)
1998 : CALL libxc_device_buffer_get_ptr(exc_d, INT(exc_d%size), exc_p)
1999 : CALL libxc_device_buffer_get_ptr(vrho_d, INT(vrho_d%size), vrho_p)
2000 : CALL libxc_device_buffer_get_ptr(vsigma_d, INT(vsigma_d%size), vsigma_p)
2001 : CALL libxc_device_buffer_get_ptr(vlapl_d, INT(vlapl_d%size), vlapl_p)
2002 : CALL libxc_device_buffer_get_ptr(vtau_d, INT(vtau_d%size), vtau_p)
2003 : CALL libxc_device_buffer_get_ptr(v2rho2_d, INT(v2rho2_d%size), v2rho2_p)
2004 : CALL libxc_device_buffer_get_ptr(v2rhosigma_d, INT(v2rhosigma_d%size), v2rhosigma_p)
2005 : CALL libxc_device_buffer_get_ptr(v2rholapl_d, INT(v2rholapl_d%size), v2rholapl_p)
2006 : CALL libxc_device_buffer_get_ptr(v2rhotau_d, INT(v2rhotau_d%size), v2rhotau_p)
2007 : CALL libxc_device_buffer_get_ptr(v2sigma2_d, INT(v2sigma2_d%size), v2sigma2_p)
2008 : CALL libxc_device_buffer_get_ptr(v2sigmalapl_d, INT(v2sigmalapl_d%size), v2sigmalapl_p)
2009 : CALL libxc_device_buffer_get_ptr(v2sigmatau_d, INT(v2sigmatau_d%size), v2sigmatau_p)
2010 : CALL libxc_device_buffer_get_ptr(v2lapl2_d, INT(v2lapl2_d%size), v2lapl2_p)
2011 : CALL libxc_device_buffer_get_ptr(v2lapltau_d, INT(v2lapltau_d%size), v2lapltau_p)
2012 : CALL libxc_device_buffer_get_ptr(v2tau2_d, INT(v2tau2_d%size), v2tau2_p)
2013 :
2014 : CALL xc_f03_mgga_exc_vxc_fxc(func, np, rho_p, sigma_p, lapl_p, tau_p, &
2015 : exc_p, vrho_p, vsigma_p, vlapl_p, vtau_p, &
2016 : v2rho2_p, v2rhosigma_p, v2rholapl_p, &
2017 : v2rhotau_p, v2sigma2_p, v2sigmalapl_p, &
2018 : v2sigmatau_p, v2lapl2_p, v2lapltau_p, v2tau2_p)
2019 : END SUBROUTINE libxc_mgga_exc_vxc_fxc_device
2020 :
2021 : ! **************************************************************************************************
2022 : !> \brief MGGA vxc and fxc on device buffers.
2023 : !> \param func ...
2024 : !> \param rho_d ...
2025 : !> \param sigma_d ...
2026 : !> \param lapl_d ...
2027 : !> \param tau_d ...
2028 : !> \param vrho_d ...
2029 : !> \param vsigma_d ...
2030 : !> \param vlapl_d ...
2031 : !> \param vtau_d ...
2032 : !> \param v2rho2_d ...
2033 : !> \param v2rhosigma_d ...
2034 : !> \param v2rholapl_d ...
2035 : !> \param v2rhotau_d ...
2036 : !> \param v2sigma2_d ...
2037 : !> \param v2sigmalapl_d ...
2038 : !> \param v2sigmatau_d ...
2039 : !> \param v2lapl2_d ...
2040 : !> \param v2lapltau_d ...
2041 : !> \param v2tau2_d ...
2042 : !> \param np ...
2043 : ! **************************************************************************************************
2044 : SUBROUTINE libxc_mgga_vxc_fxc_device(func, rho_d, sigma_d, lapl_d, tau_d, vrho_d, &
2045 : vsigma_d, vlapl_d, vtau_d, v2rho2_d, &
2046 : v2rhosigma_d, v2rholapl_d, v2rhotau_d, v2sigma2_d, &
2047 : v2sigmalapl_d, v2sigmatau_d, v2lapl2_d, v2lapltau_d, &
2048 : v2tau2_d, np)
2049 : USE ISO_C_BINDING, ONLY: C_SIZE_T
2050 : TYPE(xc_f03_func_t), INTENT(IN) :: func
2051 : TYPE(libxc_device_buffer_type), INTENT(IN) :: rho_d, sigma_d, lapl_d, tau_d
2052 : TYPE(libxc_device_buffer_type), INTENT(INOUT) :: vrho_d, vsigma_d, vlapl_d, vtau_d, &
2053 : v2rho2_d, v2rhosigma_d, v2rholapl_d, v2rhotau_d, v2sigma2_d, v2sigmalapl_d, v2sigmatau_d, &
2054 : v2lapl2_d, v2lapltau_d, v2tau2_d
2055 : INTEGER(KIND=C_SIZE_T), INTENT(IN) :: np
2056 :
2057 : REAL(KIND=dp), DIMENSION(:), POINTER :: lapl_p, rho_p, sigma_p, tau_p, v2lapl2_p, &
2058 : v2lapltau_p, v2rho2_p, v2rholapl_p, v2rhosigma_p, v2rhotau_p, v2sigma2_p, v2sigmalapl_p, &
2059 : v2sigmatau_p, v2tau2_p, vlapl_p, vrho_p, vsigma_p, vtau_p
2060 :
2061 : CALL libxc_device_buffer_get_ptr(rho_d, INT(rho_d%size), rho_p)
2062 : CALL libxc_device_buffer_get_ptr(sigma_d, INT(sigma_d%size), sigma_p)
2063 : CALL libxc_device_buffer_get_ptr(lapl_d, INT(lapl_d%size), lapl_p)
2064 : CALL libxc_device_buffer_get_ptr(tau_d, INT(tau_d%size), tau_p)
2065 : CALL libxc_device_buffer_get_ptr(vrho_d, INT(vrho_d%size), vrho_p)
2066 : CALL libxc_device_buffer_get_ptr(vsigma_d, INT(vsigma_d%size), vsigma_p)
2067 : CALL libxc_device_buffer_get_ptr(vlapl_d, INT(vlapl_d%size), vlapl_p)
2068 : CALL libxc_device_buffer_get_ptr(vtau_d, INT(vtau_d%size), vtau_p)
2069 : CALL libxc_device_buffer_get_ptr(v2rho2_d, INT(v2rho2_d%size), v2rho2_p)
2070 : CALL libxc_device_buffer_get_ptr(v2rhosigma_d, INT(v2rhosigma_d%size), v2rhosigma_p)
2071 : CALL libxc_device_buffer_get_ptr(v2rholapl_d, INT(v2rholapl_d%size), v2rholapl_p)
2072 : CALL libxc_device_buffer_get_ptr(v2rhotau_d, INT(v2rhotau_d%size), v2rhotau_p)
2073 : CALL libxc_device_buffer_get_ptr(v2sigma2_d, INT(v2sigma2_d%size), v2sigma2_p)
2074 : CALL libxc_device_buffer_get_ptr(v2sigmalapl_d, INT(v2sigmalapl_d%size), v2sigmalapl_p)
2075 : CALL libxc_device_buffer_get_ptr(v2sigmatau_d, INT(v2sigmatau_d%size), v2sigmatau_p)
2076 : CALL libxc_device_buffer_get_ptr(v2lapl2_d, INT(v2lapl2_d%size), v2lapl2_p)
2077 : CALL libxc_device_buffer_get_ptr(v2lapltau_d, INT(v2lapltau_d%size), v2lapltau_p)
2078 : CALL libxc_device_buffer_get_ptr(v2tau2_d, INT(v2tau2_d%size), v2tau2_p)
2079 :
2080 : CALL xc_f03_mgga_vxc_fxc(func, np, rho_p, sigma_p, lapl_p, tau_p, &
2081 : vrho_p, vsigma_p, vlapl_p, vtau_p, &
2082 : v2rho2_p, v2rhosigma_p, v2rholapl_p, &
2083 : v2rhotau_p, v2sigma2_p, v2sigmalapl_p, &
2084 : v2sigmatau_p, v2lapl2_p, v2lapltau_p, v2tau2_p)
2085 : END SUBROUTINE libxc_mgga_vxc_fxc_device
2086 :
2087 : ! **************************************************************************************************
2088 : !> \brief MGGA exc, vxc, fxc and kxc on device buffers.
2089 : !> \param func ...
2090 : !> \param rho_d ...
2091 : !> \param sigma_d ...
2092 : !> \param lapl_d ...
2093 : !> \param tau_d ...
2094 : !> \param exc_d ...
2095 : !> \param vrho_d ...
2096 : !> \param vsigma_d ...
2097 : !> \param vlapl_d ...
2098 : !> \param vtau_d ...
2099 : !> \param v2rho2_d ...
2100 : !> \param v2rhosigma_d ...
2101 : !> \param v2rholapl_d ...
2102 : !> \param v2rhotau_d ...
2103 : !> \param v2sigma2_d ...
2104 : !> \param v2sigmalapl_d ...
2105 : !> \param v2sigmatau_d ...
2106 : !> \param v2lapl2_d ...
2107 : !> \param v2lapltau_d ...
2108 : !> \param v2tau2_d ...
2109 : !> \param v3rho3_d ...
2110 : !> \param v3rho2sigma_d ...
2111 : !> \param v3rho2lapl_d ...
2112 : !> \param v3rho2tau_d ...
2113 : !> \param v3rhosigma2_d ...
2114 : !> \param v3rhosigmalapl_d ...
2115 : !> \param v3rhosigmatau_d ...
2116 : !> \param v3rholapl2_d ...
2117 : !> \param v3rholapltau_d ...
2118 : !> \param v3rhotau2_d ...
2119 : !> \param v3sigma3_d ...
2120 : !> \param v3sigma2lapl_d ...
2121 : !> \param v3sigma2tau_d ...
2122 : !> \param v3sigmalapl2_d ...
2123 : !> \param v3sigmalapltau_d ...
2124 : !> \param v3sigmatau2_d ...
2125 : !> \param v3lapl3_d ...
2126 : !> \param v3lapl2tau_d ...
2127 : !> \param v3lapltau2_d ...
2128 : !> \param v3tau3_d ...
2129 : !> \param np ...
2130 : ! **************************************************************************************************
2131 : SUBROUTINE libxc_mgga_exc_vxc_fxc_kxc_device(func, rho_d, sigma_d, lapl_d, tau_d, exc_d, &
2132 : vrho_d, vsigma_d, vlapl_d, vtau_d, v2rho2_d, &
2133 : v2rhosigma_d, v2rholapl_d, v2rhotau_d, v2sigma2_d, &
2134 : v2sigmalapl_d, v2sigmatau_d, v2lapl2_d, v2lapltau_d, &
2135 : v2tau2_d, v3rho3_d, v3rho2sigma_d, v3rho2lapl_d, &
2136 : v3rho2tau_d, v3rhosigma2_d, v3rhosigmalapl_d, &
2137 : v3rhosigmatau_d, v3rholapl2_d, v3rholapltau_d, &
2138 : v3rhotau2_d, v3sigma3_d, v3sigma2lapl_d, v3sigma2tau_d, &
2139 : v3sigmalapl2_d, v3sigmalapltau_d, v3sigmatau2_d, &
2140 : v3lapl3_d, v3lapl2tau_d, v3lapltau2_d, v3tau3_d, np)
2141 : USE ISO_C_BINDING, ONLY: C_SIZE_T
2142 : TYPE(xc_f03_func_t), INTENT(IN) :: func
2143 : TYPE(libxc_device_buffer_type), INTENT(IN) :: rho_d, sigma_d, lapl_d, tau_d
2144 : TYPE(libxc_device_buffer_type), INTENT(INOUT) :: exc_d, vrho_d, vsigma_d, vlapl_d, vtau_d, &
2145 : v2rho2_d, v2rhosigma_d, v2rholapl_d, v2rhotau_d, v2sigma2_d, v2sigmalapl_d, v2sigmatau_d, &
2146 : v2lapl2_d, v2lapltau_d, v2tau2_d, v3rho3_d, v3rho2sigma_d, v3rho2lapl_d, v3rho2tau_d, &
2147 : v3rhosigma2_d, v3rhosigmalapl_d, v3rhosigmatau_d, v3rholapl2_d, v3rholapltau_d, &
2148 : v3rhotau2_d, v3sigma3_d, v3sigma2lapl_d, v3sigma2tau_d, v3sigmalapl2_d, v3sigmalapltau_d, &
2149 : v3sigmatau2_d, v3lapl3_d, v3lapl2tau_d, v3lapltau2_d, v3tau3_d
2150 : INTEGER(KIND=C_SIZE_T), INTENT(IN) :: np
2151 :
2152 : REAL(KIND=dp), DIMENSION(:), POINTER :: exc_p, lapl_p, rho_p, sigma_p, tau_p, v2lapl2_p, &
2153 : v2lapltau_p, v2rho2_p, v2rholapl_p, v2rhosigma_p, v2rhotau_p, v2sigma2_p, v2sigmalapl_p, &
2154 : v2sigmatau_p, v2tau2_p, v3lapl2tau_p, v3lapl3_p, v3lapltau2_p, v3rho2lapl_p, &
2155 : v3rho2sigma_p, v3rho2tau_p, v3rho3_p, v3rholapl2_p, v3rholapltau_p, v3rhosigma2_p, &
2156 : v3rhosigmalapl_p, v3rhosigmatau_p, v3rhotau2_p, v3sigma2lapl_p, v3sigma2tau_p, &
2157 : v3sigma3_p, v3sigmalapl2_p, v3sigmalapltau_p, v3sigmatau2_p, v3tau3_p, vlapl_p, vrho_p, &
2158 : vsigma_p, vtau_p
2159 :
2160 : CALL libxc_device_buffer_get_ptr(rho_d, INT(rho_d%size), rho_p)
2161 : CALL libxc_device_buffer_get_ptr(sigma_d, INT(sigma_d%size), sigma_p)
2162 : CALL libxc_device_buffer_get_ptr(lapl_d, INT(lapl_d%size), lapl_p)
2163 : CALL libxc_device_buffer_get_ptr(tau_d, INT(tau_d%size), tau_p)
2164 : CALL libxc_device_buffer_get_ptr(exc_d, INT(exc_d%size), exc_p)
2165 : CALL libxc_device_buffer_get_ptr(vrho_d, INT(vrho_d%size), vrho_p)
2166 : CALL libxc_device_buffer_get_ptr(vsigma_d, INT(vsigma_d%size), vsigma_p)
2167 : CALL libxc_device_buffer_get_ptr(vlapl_d, INT(vlapl_d%size), vlapl_p)
2168 : CALL libxc_device_buffer_get_ptr(vtau_d, INT(vtau_d%size), vtau_p)
2169 : CALL libxc_device_buffer_get_ptr(v2rho2_d, INT(v2rho2_d%size), v2rho2_p)
2170 : CALL libxc_device_buffer_get_ptr(v2rhosigma_d, INT(v2rhosigma_d%size), v2rhosigma_p)
2171 : CALL libxc_device_buffer_get_ptr(v2rholapl_d, INT(v2rholapl_d%size), v2rholapl_p)
2172 : CALL libxc_device_buffer_get_ptr(v2rhotau_d, INT(v2rhotau_d%size), v2rhotau_p)
2173 : CALL libxc_device_buffer_get_ptr(v2sigma2_d, INT(v2sigma2_d%size), v2sigma2_p)
2174 : CALL libxc_device_buffer_get_ptr(v2sigmalapl_d, INT(v2sigmalapl_d%size), v2sigmalapl_p)
2175 : CALL libxc_device_buffer_get_ptr(v2sigmatau_d, INT(v2sigmatau_d%size), v2sigmatau_p)
2176 : CALL libxc_device_buffer_get_ptr(v2lapl2_d, INT(v2lapl2_d%size), v2lapl2_p)
2177 : CALL libxc_device_buffer_get_ptr(v2lapltau_d, INT(v2lapltau_d%size), v2lapltau_p)
2178 : CALL libxc_device_buffer_get_ptr(v2tau2_d, INT(v2tau2_d%size), v2tau2_p)
2179 : CALL libxc_device_buffer_get_ptr(v3rho3_d, INT(v3rho3_d%size), v3rho3_p)
2180 : CALL libxc_device_buffer_get_ptr(v3rho2sigma_d, INT(v3rho2sigma_d%size), v3rho2sigma_p)
2181 : CALL libxc_device_buffer_get_ptr(v3rho2lapl_d, INT(v3rho2lapl_d%size), v3rho2lapl_p)
2182 : CALL libxc_device_buffer_get_ptr(v3rho2tau_d, INT(v3rho2tau_d%size), v3rho2tau_p)
2183 : CALL libxc_device_buffer_get_ptr(v3rhosigma2_d, INT(v3rhosigma2_d%size), v3rhosigma2_p)
2184 : CALL libxc_device_buffer_get_ptr(v3rhosigmalapl_d, INT(v3rhosigmalapl_d%size), v3rhosigmalapl_p)
2185 : CALL libxc_device_buffer_get_ptr(v3rhosigmatau_d, INT(v3rhosigmatau_d%size), v3rhosigmatau_p)
2186 : CALL libxc_device_buffer_get_ptr(v3rholapl2_d, INT(v3rholapl2_d%size), v3rholapl2_p)
2187 : CALL libxc_device_buffer_get_ptr(v3rholapltau_d, INT(v3rholapltau_d%size), v3rholapltau_p)
2188 : CALL libxc_device_buffer_get_ptr(v3rhotau2_d, INT(v3rhotau2_d%size), v3rhotau2_p)
2189 : CALL libxc_device_buffer_get_ptr(v3sigma3_d, INT(v3sigma3_d%size), v3sigma3_p)
2190 : CALL libxc_device_buffer_get_ptr(v3sigma2lapl_d, INT(v3sigma2lapl_d%size), v3sigma2lapl_p)
2191 : CALL libxc_device_buffer_get_ptr(v3sigma2tau_d, INT(v3sigma2tau_d%size), v3sigma2tau_p)
2192 : CALL libxc_device_buffer_get_ptr(v3sigmalapl2_d, INT(v3sigmalapl2_d%size), v3sigmalapl2_p)
2193 : CALL libxc_device_buffer_get_ptr(v3sigmalapltau_d, INT(v3sigmalapltau_d%size), v3sigmalapltau_p)
2194 : CALL libxc_device_buffer_get_ptr(v3sigmatau2_d, INT(v3sigmatau2_d%size), v3sigmatau2_p)
2195 : CALL libxc_device_buffer_get_ptr(v3lapl3_d, INT(v3lapl3_d%size), v3lapl3_p)
2196 : CALL libxc_device_buffer_get_ptr(v3lapl2tau_d, INT(v3lapl2tau_d%size), v3lapl2tau_p)
2197 : CALL libxc_device_buffer_get_ptr(v3lapltau2_d, INT(v3lapltau2_d%size), v3lapltau2_p)
2198 : CALL libxc_device_buffer_get_ptr(v3tau3_d, INT(v3tau3_d%size), v3tau3_p)
2199 :
2200 : CALL xc_f03_mgga_exc_vxc_fxc_kxc(func, np, rho_p, sigma_p, lapl_p, tau_p, &
2201 : exc_p, vrho_p, vsigma_p, vlapl_p, vtau_p, &
2202 : v2rho2_p, v2rhosigma_p, v2rholapl_p, &
2203 : v2rhotau_p, v2sigma2_p, v2sigmalapl_p, &
2204 : v2sigmatau_p, v2lapl2_p, v2lapltau_p, v2tau2_p, &
2205 : v3rho3_p, v3rho2sigma_p, v3rho2lapl_p, v3rho2tau_p, &
2206 : v3rhosigma2_p, v3rhosigmalapl_p, v3rhosigmatau_p, &
2207 : v3rholapl2_p, v3rholapltau_p, v3rhotau2_p, &
2208 : v3sigma3_p, v3sigma2lapl_p, v3sigma2tau_p, &
2209 : v3sigmalapl2_p, v3sigmalapltau_p, v3sigmatau2_p, &
2210 : v3lapl3_p, v3lapl2tau_p, v3lapltau2_p, v3tau3_p)
2211 : END SUBROUTINE libxc_mgga_exc_vxc_fxc_kxc_device
2212 :
2213 : ! **************************************************************************************************
2214 : !> \brief MGGA vxc, fxc and kxc on device buffers.
2215 : !> \param func ...
2216 : !> \param rho_d ...
2217 : !> \param sigma_d ...
2218 : !> \param lapl_d ...
2219 : !> \param tau_d ...
2220 : !> \param vrho_d ...
2221 : !> \param vsigma_d ...
2222 : !> \param vlapl_d ...
2223 : !> \param vtau_d ...
2224 : !> \param v2rho2_d ...
2225 : !> \param v2rhosigma_d ...
2226 : !> \param v2rholapl_d ...
2227 : !> \param v2rhotau_d ...
2228 : !> \param v2sigma2_d ...
2229 : !> \param v2sigmalapl_d ...
2230 : !> \param v2sigmatau_d ...
2231 : !> \param v2lapl2_d ...
2232 : !> \param v2lapltau_d ...
2233 : !> \param v2tau2_d ...
2234 : !> \param v3rho3_d ...
2235 : !> \param v3rho2sigma_d ...
2236 : !> \param v3rho2lapl_d ...
2237 : !> \param v3rho2tau_d ...
2238 : !> \param v3rhosigma2_d ...
2239 : !> \param v3rhosigmalapl_d ...
2240 : !> \param v3rhosigmatau_d ...
2241 : !> \param v3rholapl2_d ...
2242 : !> \param v3rholapltau_d ...
2243 : !> \param v3rhotau2_d ...
2244 : !> \param v3sigma3_d ...
2245 : !> \param v3sigma2lapl_d ...
2246 : !> \param v3sigma2tau_d ...
2247 : !> \param v3sigmalapl2_d ...
2248 : !> \param v3sigmalapltau_d ...
2249 : !> \param v3sigmatau2_d ...
2250 : !> \param v3lapl3_d ...
2251 : !> \param v3lapl2tau_d ...
2252 : !> \param v3lapltau2_d ...
2253 : !> \param v3tau3_d ...
2254 : !> \param np ...
2255 : ! **************************************************************************************************
2256 : SUBROUTINE libxc_mgga_vxc_fxc_kxc_device(func, rho_d, sigma_d, lapl_d, tau_d, vrho_d, &
2257 : vsigma_d, vlapl_d, vtau_d, v2rho2_d, &
2258 : v2rhosigma_d, v2rholapl_d, v2rhotau_d, v2sigma2_d, &
2259 : v2sigmalapl_d, v2sigmatau_d, v2lapl2_d, v2lapltau_d, &
2260 : v2tau2_d, v3rho3_d, v3rho2sigma_d, v3rho2lapl_d, &
2261 : v3rho2tau_d, v3rhosigma2_d, v3rhosigmalapl_d, &
2262 : v3rhosigmatau_d, v3rholapl2_d, v3rholapltau_d, &
2263 : v3rhotau2_d, v3sigma3_d, v3sigma2lapl_d, v3sigma2tau_d, &
2264 : v3sigmalapl2_d, v3sigmalapltau_d, v3sigmatau2_d, &
2265 : v3lapl3_d, v3lapl2tau_d, v3lapltau2_d, v3tau3_d, np)
2266 : USE ISO_C_BINDING, ONLY: C_SIZE_T
2267 : TYPE(xc_f03_func_t), INTENT(IN) :: func
2268 : TYPE(libxc_device_buffer_type), INTENT(IN) :: rho_d, sigma_d, lapl_d, tau_d
2269 : TYPE(libxc_device_buffer_type), INTENT(INOUT) :: vrho_d, vsigma_d, vlapl_d, vtau_d, &
2270 : v2rho2_d, v2rhosigma_d, v2rholapl_d, v2rhotau_d, v2sigma2_d, v2sigmalapl_d, v2sigmatau_d, &
2271 : v2lapl2_d, v2lapltau_d, v2tau2_d, v3rho3_d, v3rho2sigma_d, v3rho2lapl_d, v3rho2tau_d, &
2272 : v3rhosigma2_d, v3rhosigmalapl_d, v3rhosigmatau_d, v3rholapl2_d, v3rholapltau_d, &
2273 : v3rhotau2_d, v3sigma3_d, v3sigma2lapl_d, v3sigma2tau_d, v3sigmalapl2_d, v3sigmalapltau_d, &
2274 : v3sigmatau2_d, v3lapl3_d, v3lapl2tau_d, v3lapltau2_d, v3tau3_d
2275 : INTEGER(KIND=C_SIZE_T), INTENT(IN) :: np
2276 :
2277 : REAL(KIND=dp), DIMENSION(:), POINTER :: lapl_p, rho_p, sigma_p, tau_p, v2lapl2_p, &
2278 : v2lapltau_p, v2rho2_p, v2rholapl_p, v2rhosigma_p, v2rhotau_p, v2sigma2_p, v2sigmalapl_p, &
2279 : v2sigmatau_p, v2tau2_p, v3lapl2tau_p, v3lapl3_p, v3lapltau2_p, v3rho2lapl_p, &
2280 : v3rho2sigma_p, v3rho2tau_p, v3rho3_p, v3rholapl2_p, v3rholapltau_p, v3rhosigma2_p, &
2281 : v3rhosigmalapl_p, v3rhosigmatau_p, v3rhotau2_p, v3sigma2lapl_p, v3sigma2tau_p, &
2282 : v3sigma3_p, v3sigmalapl2_p, v3sigmalapltau_p, v3sigmatau2_p, v3tau3_p, vlapl_p, vrho_p, &
2283 : vsigma_p, vtau_p
2284 :
2285 : CALL libxc_device_buffer_get_ptr(rho_d, INT(rho_d%size), rho_p)
2286 : CALL libxc_device_buffer_get_ptr(sigma_d, INT(sigma_d%size), sigma_p)
2287 : CALL libxc_device_buffer_get_ptr(lapl_d, INT(lapl_d%size), lapl_p)
2288 : CALL libxc_device_buffer_get_ptr(tau_d, INT(tau_d%size), tau_p)
2289 : CALL libxc_device_buffer_get_ptr(vrho_d, INT(vrho_d%size), vrho_p)
2290 : CALL libxc_device_buffer_get_ptr(vsigma_d, INT(vsigma_d%size), vsigma_p)
2291 : CALL libxc_device_buffer_get_ptr(vlapl_d, INT(vlapl_d%size), vlapl_p)
2292 : CALL libxc_device_buffer_get_ptr(vtau_d, INT(vtau_d%size), vtau_p)
2293 : CALL libxc_device_buffer_get_ptr(v2rho2_d, INT(v2rho2_d%size), v2rho2_p)
2294 : CALL libxc_device_buffer_get_ptr(v2rhosigma_d, INT(v2rhosigma_d%size), v2rhosigma_p)
2295 : CALL libxc_device_buffer_get_ptr(v2rholapl_d, INT(v2rholapl_d%size), v2rholapl_p)
2296 : CALL libxc_device_buffer_get_ptr(v2rhotau_d, INT(v2rhotau_d%size), v2rhotau_p)
2297 : CALL libxc_device_buffer_get_ptr(v2sigma2_d, INT(v2sigma2_d%size), v2sigma2_p)
2298 : CALL libxc_device_buffer_get_ptr(v2sigmalapl_d, INT(v2sigmalapl_d%size), v2sigmalapl_p)
2299 : CALL libxc_device_buffer_get_ptr(v2sigmatau_d, INT(v2sigmatau_d%size), v2sigmatau_p)
2300 : CALL libxc_device_buffer_get_ptr(v2lapl2_d, INT(v2lapl2_d%size), v2lapl2_p)
2301 : CALL libxc_device_buffer_get_ptr(v2lapltau_d, INT(v2lapltau_d%size), v2lapltau_p)
2302 : CALL libxc_device_buffer_get_ptr(v2tau2_d, INT(v2tau2_d%size), v2tau2_p)
2303 : CALL libxc_device_buffer_get_ptr(v3rho3_d, INT(v3rho3_d%size), v3rho3_p)
2304 : CALL libxc_device_buffer_get_ptr(v3rho2sigma_d, INT(v3rho2sigma_d%size), v3rho2sigma_p)
2305 : CALL libxc_device_buffer_get_ptr(v3rho2lapl_d, INT(v3rho2lapl_d%size), v3rho2lapl_p)
2306 : CALL libxc_device_buffer_get_ptr(v3rho2tau_d, INT(v3rho2tau_d%size), v3rho2tau_p)
2307 : CALL libxc_device_buffer_get_ptr(v3rhosigma2_d, INT(v3rhosigma2_d%size), v3rhosigma2_p)
2308 : CALL libxc_device_buffer_get_ptr(v3rhosigmalapl_d, INT(v3rhosigmalapl_d%size), v3rhosigmalapl_p)
2309 : CALL libxc_device_buffer_get_ptr(v3rhosigmatau_d, INT(v3rhosigmatau_d%size), v3rhosigmatau_p)
2310 : CALL libxc_device_buffer_get_ptr(v3rholapl2_d, INT(v3rholapl2_d%size), v3rholapl2_p)
2311 : CALL libxc_device_buffer_get_ptr(v3rholapltau_d, INT(v3rholapltau_d%size), v3rholapltau_p)
2312 : CALL libxc_device_buffer_get_ptr(v3rhotau2_d, INT(v3rhotau2_d%size), v3rhotau2_p)
2313 : CALL libxc_device_buffer_get_ptr(v3sigma3_d, INT(v3sigma3_d%size), v3sigma3_p)
2314 : CALL libxc_device_buffer_get_ptr(v3sigma2lapl_d, INT(v3sigma2lapl_d%size), v3sigma2lapl_p)
2315 : CALL libxc_device_buffer_get_ptr(v3sigma2tau_d, INT(v3sigma2tau_d%size), v3sigma2tau_p)
2316 : CALL libxc_device_buffer_get_ptr(v3sigmalapl2_d, INT(v3sigmalapl2_d%size), v3sigmalapl2_p)
2317 : CALL libxc_device_buffer_get_ptr(v3sigmalapltau_d, INT(v3sigmalapltau_d%size), v3sigmalapltau_p)
2318 : CALL libxc_device_buffer_get_ptr(v3sigmatau2_d, INT(v3sigmatau2_d%size), v3sigmatau2_p)
2319 : CALL libxc_device_buffer_get_ptr(v3lapl3_d, INT(v3lapl3_d%size), v3lapl3_p)
2320 : CALL libxc_device_buffer_get_ptr(v3lapl2tau_d, INT(v3lapl2tau_d%size), v3lapl2tau_p)
2321 : CALL libxc_device_buffer_get_ptr(v3lapltau2_d, INT(v3lapltau2_d%size), v3lapltau2_p)
2322 : CALL libxc_device_buffer_get_ptr(v3tau3_d, INT(v3tau3_d%size), v3tau3_p)
2323 :
2324 : CALL xc_f03_mgga_vxc_fxc_kxc(func, np, rho_p, sigma_p, lapl_p, tau_p, &
2325 : vrho_p, vsigma_p, vlapl_p, vtau_p, &
2326 : v2rho2_p, v2rhosigma_p, v2rholapl_p, &
2327 : v2rhotau_p, v2sigma2_p, v2sigmalapl_p, &
2328 : v2sigmatau_p, v2lapl2_p, v2lapltau_p, v2tau2_p, &
2329 : v3rho3_p, v3rho2sigma_p, v3rho2lapl_p, v3rho2tau_p, &
2330 : v3rhosigma2_p, v3rhosigmalapl_p, v3rhosigmatau_p, &
2331 : v3rholapl2_p, v3rholapltau_p, v3rhotau2_p, &
2332 : v3sigma3_p, v3sigma2lapl_p, v3sigma2tau_p, &
2333 : v3sigmalapl2_p, v3sigmalapltau_p, v3sigmatau2_p, &
2334 : v3lapl3_p, v3lapl2tau_p, v3lapltau2_p, v3tau3_p)
2335 : END SUBROUTINE libxc_mgga_vxc_fxc_kxc_device
2336 :
2337 : ! **************************************************************************************************
2338 : !> \brief MGGA vxc on device buffers.
2339 : !> \param func ...
2340 : !> \param rho_d ...
2341 : !> \param sigma_d ...
2342 : !> \param lapl_d ...
2343 : !> \param tau_d ...
2344 : !> \param vrho_d ...
2345 : !> \param vsigma_d ...
2346 : !> \param vlapl_d ...
2347 : !> \param vtau_d ...
2348 : !> \param np ...
2349 : ! **************************************************************************************************
2350 : SUBROUTINE libxc_mgga_vxc_device(func, rho_d, sigma_d, lapl_d, tau_d, vrho_d, vsigma_d, vlapl_d, vtau_d, np)
2351 : USE ISO_C_BINDING, ONLY: C_SIZE_T
2352 : TYPE(xc_f03_func_t), INTENT(IN) :: func
2353 : TYPE(libxc_device_buffer_type), INTENT(IN) :: rho_d, sigma_d, lapl_d, tau_d
2354 : TYPE(libxc_device_buffer_type), INTENT(INOUT) :: vrho_d, vsigma_d, vlapl_d, vtau_d
2355 : INTEGER(KIND=C_SIZE_T), INTENT(IN) :: np
2356 :
2357 : REAL(KIND=dp), DIMENSION(:), POINTER :: lapl_p, rho_p, sigma_p, tau_p, vlapl_p, &
2358 : vrho_p, vsigma_p, vtau_p
2359 :
2360 : CALL libxc_device_buffer_get_ptr(rho_d, INT(rho_d%size), rho_p)
2361 : CALL libxc_device_buffer_get_ptr(sigma_d, INT(sigma_d%size), sigma_p)
2362 : CALL libxc_device_buffer_get_ptr(lapl_d, INT(lapl_d%size), lapl_p)
2363 : CALL libxc_device_buffer_get_ptr(tau_d, INT(tau_d%size), tau_p)
2364 : CALL libxc_device_buffer_get_ptr(vrho_d, INT(vrho_d%size), vrho_p)
2365 : CALL libxc_device_buffer_get_ptr(vsigma_d, INT(vsigma_d%size), vsigma_p)
2366 : CALL libxc_device_buffer_get_ptr(vlapl_d, INT(vlapl_d%size), vlapl_p)
2367 : CALL libxc_device_buffer_get_ptr(vtau_d, INT(vtau_d%size), vtau_p)
2368 :
2369 : CALL xc_f03_mgga_vxc(func, np, rho_p, sigma_p, lapl_p, tau_p, vrho_p, vsigma_p, vlapl_p, vtau_p)
2370 : END SUBROUTINE libxc_mgga_vxc_device
2371 :
2372 : #else
2373 : ! **************************************************************************************************
2374 : !> \brief CPU-only build: a worker never carries device buffers. The device
2375 : !> entry points libxc_worker_eval calls are compiled as no-ops/aborts so
2376 : !> that no __OFFLOAD guards are needed above; the runtime backend
2377 : !> selection prevents them from ever being reached.
2378 : ! **************************************************************************************************
2379 : SUBROUTINE libxc_worker_device_alloc(worker, family, pol, nl, np, ns, n, grow_only)
2380 : TYPE(libxc_worker_type), INTENT(INOUT) :: worker
2381 : INTEGER, INTENT(IN) :: family, nl, np, ns, n
2382 : LOGICAL, INTENT(IN) :: pol
2383 : LOGICAL, INTENT(IN), OPTIONAL :: grow_only
2384 :
2385 : MARK_USED(worker)
2386 : MARK_USED(family)
2387 : MARK_USED(pol)
2388 : MARK_USED(nl)
2389 : MARK_USED(np)
2390 : MARK_USED(ns)
2391 : MARK_USED(n)
2392 : MARK_USED(grow_only)
2393 : END SUBROUTINE libxc_worker_device_alloc
2394 :
2395 : SUBROUTINE libxc_worker_device_free(worker)
2396 : TYPE(libxc_worker_type), INTENT(INOUT) :: worker
2397 :
2398 : MARK_USED(worker)
2399 : END SUBROUTINE libxc_worker_device_free
2400 :
2401 : ! **************************************************************************************************
2402 : !> \brief CPU-only build: the whole dispatch is a single abort. The runtime
2403 : !> backend selection can never route here.
2404 : ! **************************************************************************************************
2405 : SUBROUTINE libxc_worker_eval_device(worker, family, grad_deriv, no_exc, np)
2406 : USE ISO_C_BINDING, ONLY: C_SIZE_T
2407 : TYPE(libxc_worker_type), INTENT(INOUT) :: worker
2408 : INTEGER, INTENT(IN) :: family, grad_deriv
2409 : LOGICAL, INTENT(IN) :: no_exc
2410 : INTEGER(KIND=C_SIZE_T), INTENT(IN) :: np
2411 :
2412 : MARK_USED(worker)
2413 : MARK_USED(family)
2414 : MARK_USED(grad_deriv)
2415 : MARK_USED(no_exc)
2416 : MARK_USED(np)
2417 : CPABORT("libxc_worker_eval_device: device backend not compiled in.")
2418 : END SUBROUTINE libxc_worker_eval_device
2419 :
2420 : ! **************************************************************************************************
2421 : !> \brief CPU-only build: growing the device buffers is a no-op.
2422 : ! **************************************************************************************************
2423 : SUBROUTINE libxc_worker_resize_cuda(worker, family, nspin, npoints)
2424 : TYPE(libxc_worker_type), INTENT(INOUT) :: worker
2425 : INTEGER, INTENT(IN) :: family, nspin, npoints
2426 :
2427 : MARK_USED(worker)
2428 : MARK_USED(family)
2429 : MARK_USED(nspin)
2430 : MARK_USED(npoints)
2431 : END SUBROUTINE libxc_worker_resize_cuda
2432 : #endif
2433 : ! **************************************************************************************************
2434 : !> \brief Natural family classification: whether a family carries the gradient
2435 : !> (GGA) and the kinetic-energy density/Laplacian (MGGA) variables.
2436 : !> \param family LibXC functional family
2437 : !> \param is_gga the family has sigma/gradient components
2438 : !> \param is_mgga the family has tau/laplacian components
2439 : !> \param where optional routine name used in the abort message
2440 : ! **************************************************************************************************
2441 : SUBROUTINE libxc_family_flags(family, is_gga, is_mgga, where)
2442 : INTEGER, INTENT(IN) :: family
2443 : LOGICAL, INTENT(OUT) :: is_gga, is_mgga
2444 : CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: where
2445 :
2446 : SELECT CASE (family)
2447 : CASE (XC_FAMILY_LDA, XC_FAMILY_HYB_LDA)
2448 : is_gga = .FALSE.
2449 : is_mgga = .FALSE.
2450 : CASE (XC_FAMILY_GGA, XC_FAMILY_HYB_GGA)
2451 : is_gga = .TRUE.
2452 : is_mgga = .FALSE.
2453 : CASE (XC_FAMILY_MGGA, XC_FAMILY_HYB_MGGA)
2454 : is_gga = .TRUE.
2455 : is_mgga = .TRUE.
2456 : CASE default
2457 : is_gga = .FALSE.
2458 : is_mgga = .FALSE.
2459 : IF (PRESENT(where)) THEN
2460 : CPABORT(TRIM(where)//": this XC_FAMILY is currently not supported.")
2461 : ELSE
2462 : CPABORT("libxc_family_flags: unsupported XC_FAMILY.")
2463 : END IF
2464 : END SELECT
2465 : END SUBROUTINE libxc_family_flags
2466 :
2467 : ! **************************************************************************************************
2468 : !> \brief Leading dimension (number of components per point) of the worker
2469 : !> buffers for a spin polarization, cf. the LibXC manual.
2470 : !> \param nspin XC_UNPOLARIZED or XC_POLARIZED
2471 : !> \param np number of rho-like components (rho, vrho, lapl, tau, vlapl, vtau)
2472 : !> \param ns number of sigma-like components (sigma, vsigma, v2rho2, ...)
2473 : !> \param nl number of rho-lapl/tau-like components (v2rholapl, v3rho3, ...)
2474 : ! **************************************************************************************************
2475 : SUBROUTINE libxc_worker_dims(nspin, np, ns, nl)
2476 : INTEGER, INTENT(IN) :: nspin
2477 : INTEGER, INTENT(OUT) :: np, ns, nl
2478 :
2479 : IF (nspin == XC_POLARIZED) THEN
2480 : np = 2
2481 : ns = 3
2482 : nl = 4
2483 : ELSE
2484 : np = 1
2485 : ns = 1
2486 : nl = 1
2487 : END IF
2488 : END SUBROUTINE libxc_worker_dims
2489 :
2490 : ! **************************************************************************************************
2491 : !> \brief Aborts when a freshly evaluated block contains a NaN, if checking is on.
2492 : !> \param worker the worker
2493 : !> \param npoints number of points in this block
2494 : !> \param grad_deriv derivative order requested
2495 : !> \param no_exc functional does not provide the energy density
2496 : !> \param family LibXC functional family
2497 : ! **************************************************************************************************
2498 : SUBROUTINE libxc_worker_check_nan(worker, npoints, grad_deriv, no_exc, family)
2499 : TYPE(libxc_worker_type), INTENT(IN) :: worker
2500 : INTEGER, INTENT(IN) :: npoints, grad_deriv
2501 : LOGICAL, INTENT(IN) :: no_exc
2502 : INTEGER, INTENT(IN) :: family
2503 :
2504 : CHARACTER(len=256) :: message
2505 : LOGICAL :: exc_has_nan, vrho_has_nan
2506 :
2507 : IF (.NOT. libxc_check_nan) RETURN
2508 : exc_has_nan = ANY(worker%exc(1:npoints) /= worker%exc(1:npoints))
2509 : vrho_has_nan = .FALSE.
2510 : IF (grad_deriv >= 1) THEN
2511 : vrho_has_nan = ANY(worker%vrho(:, 1:npoints) /= worker%vrho(:, 1:npoints))
2512 : END IF
2513 : IF (exc_has_nan .OR. vrho_has_nan) THEN
2514 : WRITE (message, '(A,I0,A,I0,A,L1,A,I0,A,L1,A,L1)') &
2515 : "NaN after device_to_host: family=", family, " grad_deriv=", grad_deriv, &
2516 : " no_exc=", no_exc, " nb=", npoints, &
2517 : " exc has NaN=", exc_has_nan, " vrho has NaN=", vrho_has_nan
2518 : CPABORT(TRIM(message))
2519 : END IF
2520 : END SUBROUTINE libxc_worker_check_nan
2521 :
2522 : ! **************************************************************************************************
2523 : !> \brief Evaluates one block of points for a worker, on the device when the GPU
2524 : !> backend is active and on the host otherwise.
2525 : !> \param worker the worker holding the functional and the staging buffers
2526 : !> \param family LibXC functional family
2527 : !> \param nspin XC_UNPOLARIZED or XC_POLARIZED
2528 : !> \param grad_deriv derivative order requested
2529 : !> \param no_exc functional does not provide the energy density
2530 : !> \param npoints number of points in this block; on the GPU path the whole grid
2531 : !> is one block, so this is also the full grid size
2532 : !> \note The staged inputs (worker%rho/sigma/lapl/tau) must already be filled by
2533 : !> the caller; the outputs (worker%exc/vrho/...) are filled on return.
2534 : ! **************************************************************************************************
2535 : SUBROUTINE libxc_worker_eval(worker, family, nspin, grad_deriv, no_exc, npoints)
2536 : TYPE(libxc_worker_type), INTENT(INOUT) :: worker
2537 : INTEGER, INTENT(IN) :: family, nspin, grad_deriv, npoints
2538 : LOGICAL, INTENT(IN) :: no_exc
2539 :
2540 : INTEGER :: nl, ns, np
2541 : INTEGER(KIND=C_SIZE_T) :: npts
2542 : LOGICAL :: is_gga, is_mgga, pol
2543 :
2544 : CALL libxc_family_flags(family, is_gga, is_mgga)
2545 : CALL libxc_worker_dims(nspin, np, ns, nl)
2546 : pol = (nspin == XC_POLARIZED)
2547 : npts = INT(npoints, KIND=C_SIZE_T)
2548 :
2549 : ! CUDA's current device is thread-local; make sure every thread that runs
2550 : ! this block uses the rank's selected device. No-op without a device.
2551 : CALL libxc_activate_device()
2552 :
2553 : IF (libxc_is_gpu()) THEN
2554 : ! Copy the staged block to the worker's device buffers.
2555 : CALL libxc_worker_h2d(worker, libxc_dev_rho, worker%rho(1, 1), INT(np*npts))
2556 : IF (is_gga) THEN
2557 : CALL libxc_worker_h2d(worker, libxc_dev_sigma, worker%sigma(1, 1), INT(ns*npts))
2558 : END IF
2559 : IF (is_mgga) THEN
2560 : CALL libxc_worker_h2d(worker, libxc_dev_lapl, worker%lapl(1, 1), INT(np*npts))
2561 : CALL libxc_worker_h2d(worker, libxc_dev_tau, worker%tau(1, 1), INT(np*npts))
2562 : END IF
2563 :
2564 : ! One device call for the whole block; worker%exc is zeroed there if the
2565 : ! functional does not provide it.
2566 : CALL libxc_worker_eval_device(worker, family, grad_deriv, no_exc, npts)
2567 :
2568 : ! Issue all D2H copies first (async), then a single synchronize() covers
2569 : ! all of them, then read every result.
2570 : IF (.NOT. no_exc) THEN
2571 : CALL libxc_worker_d2h_issue(worker, libxc_dev_exc, npoints)
2572 : END IF
2573 : IF (grad_deriv >= 1) THEN
2574 : CALL libxc_worker_d2h_issue(worker, libxc_dev_vrho, np*npoints)
2575 : IF (is_gga) THEN
2576 : CALL libxc_worker_d2h_issue(worker, libxc_dev_vsigma, ns*npoints)
2577 : END IF
2578 : IF (is_mgga) THEN
2579 : CALL libxc_worker_d2h_issue(worker, libxc_dev_vlapl, np*npoints)
2580 : CALL libxc_worker_d2h_issue(worker, libxc_dev_vtau, np*npoints)
2581 : END IF
2582 : END IF
2583 : IF (grad_deriv >= 2) THEN
2584 : CALL libxc_worker_d2h_issue(worker, libxc_dev_v2rho2, ns*npoints)
2585 : IF (is_gga) THEN
2586 : CALL libxc_worker_d2h_issue(worker, libxc_dev_v2rhosigma, MERGE(6, 1, pol)*npoints)
2587 : CALL libxc_worker_d2h_issue(worker, libxc_dev_v2sigma2, MERGE(6, 1, pol)*npoints)
2588 : END IF
2589 : IF (is_mgga) THEN
2590 : CALL libxc_worker_d2h_issue(worker, libxc_dev_v2rholapl, nl*npoints)
2591 : CALL libxc_worker_d2h_issue(worker, libxc_dev_v2rhotau, nl*npoints)
2592 : CALL libxc_worker_d2h_issue(worker, libxc_dev_v2sigmalapl, MERGE(6, 1, pol)*npoints)
2593 : CALL libxc_worker_d2h_issue(worker, libxc_dev_v2sigmatau, MERGE(6, 1, pol)*npoints)
2594 : CALL libxc_worker_d2h_issue(worker, libxc_dev_v2lapl2, ns*npoints)
2595 : CALL libxc_worker_d2h_issue(worker, libxc_dev_v2lapltau, nl*npoints)
2596 : CALL libxc_worker_d2h_issue(worker, libxc_dev_v2tau2, ns*npoints)
2597 : END IF
2598 : END IF
2599 : IF (grad_deriv >= 3) THEN
2600 : CALL libxc_worker_d2h_issue(worker, libxc_dev_v3rho3, nl*npoints)
2601 : IF (is_gga) THEN
2602 : CALL libxc_worker_d2h_issue(worker, libxc_dev_v3rho2sigma, MERGE(9, 1, pol)*npoints)
2603 : CALL libxc_worker_d2h_issue(worker, libxc_dev_v3rhosigma2, MERGE(12, 1, pol)*npoints)
2604 : CALL libxc_worker_d2h_issue(worker, libxc_dev_v3sigma3, MERGE(10, 1, pol)*npoints)
2605 : END IF
2606 : #:for arr in v3_new
2607 0 : IF (is_mgga) THEN
2608 0 : CALL libxc_worker_d2h_issue(worker, libxc_dev_${arr}$, MERGE(${mgga_ncomp[arr]}$, 1, pol)*npoints)
2609 : END IF
2610 : #:endfor
2611 : END IF
2612 :
2613 : CALL libxc_sync_device()
2614 :
2615 0 : IF (.NOT. no_exc) THEN
2616 0 : CALL libxc_worker_d2h_read(worker, libxc_dev_exc, worker%exc(1:npoints), npoints)
2617 : END IF
2618 0 : IF (grad_deriv >= 1) THEN
2619 0 : CALL libxc_worker_d2h_read(worker, libxc_dev_vrho, worker%vrho(1, 1), np*npoints)
2620 0 : IF (is_gga) THEN
2621 0 : CALL libxc_worker_d2h_read(worker, libxc_dev_vsigma, worker%vsigma(1, 1), ns*npoints)
2622 : END IF
2623 0 : IF (is_mgga) THEN
2624 0 : CALL libxc_worker_d2h_read(worker, libxc_dev_vlapl, worker%vlapl(1, 1), np*npoints)
2625 0 : CALL libxc_worker_d2h_read(worker, libxc_dev_vtau, worker%vtau(1, 1), np*npoints)
2626 : END IF
2627 : END IF
2628 0 : IF (grad_deriv >= 2) THEN
2629 0 : CALL libxc_worker_d2h_read(worker, libxc_dev_v2rho2, worker%v2rho2(1, 1), ns*npoints)
2630 0 : IF (is_gga) THEN
2631 0 : CALL libxc_worker_d2h_read(worker, libxc_dev_v2rhosigma, worker%v2rhosigma(1, 1), MERGE(6, 1, pol)*npoints)
2632 0 : CALL libxc_worker_d2h_read(worker, libxc_dev_v2sigma2, worker%v2sigma2(1, 1), MERGE(6, 1, pol)*npoints)
2633 : END IF
2634 0 : IF (is_mgga) THEN
2635 0 : CALL libxc_worker_d2h_read(worker, libxc_dev_v2rholapl, worker%v2rholapl(1, 1), nl*npoints)
2636 0 : CALL libxc_worker_d2h_read(worker, libxc_dev_v2rhotau, worker%v2rhotau(1, 1), nl*npoints)
2637 : CALL libxc_worker_d2h_read(worker, libxc_dev_v2sigmalapl, worker%v2sigmalapl(1, 1), &
2638 0 : MERGE(6, 1, pol)*npoints)
2639 : CALL libxc_worker_d2h_read(worker, libxc_dev_v2sigmatau, worker%v2sigmatau(1, 1), &
2640 0 : MERGE(6, 1, pol)*npoints)
2641 0 : CALL libxc_worker_d2h_read(worker, libxc_dev_v2lapl2, worker%v2lapl2(1, 1), ns*npoints)
2642 0 : CALL libxc_worker_d2h_read(worker, libxc_dev_v2lapltau, worker%v2lapltau(1, 1), nl*npoints)
2643 0 : CALL libxc_worker_d2h_read(worker, libxc_dev_v2tau2, worker%v2tau2(1, 1), ns*npoints)
2644 : END IF
2645 0 : END IF
2646 0 : IF (grad_deriv >= 3) THEN
2647 0 : CALL libxc_worker_d2h_read(worker, libxc_dev_v3rho3, worker%v3rho3(1, 1), nl*npoints)
2648 0 : IF (is_gga) THEN
2649 : CALL libxc_worker_d2h_read(worker, libxc_dev_v3rho2sigma, worker%v3rho2sigma(1, 1), &
2650 0 : MERGE(9, 1, pol)*npoints)
2651 0 : CALL libxc_worker_d2h_read(worker, libxc_dev_v3rhosigma2, worker%v3rhosigma2(1, 1), &
2652 0 : MERGE(12, 1, pol)*npoints)
2653 : CALL libxc_worker_d2h_read(worker, libxc_dev_v3sigma3, worker%v3sigma3(1, 1), &
2654 0 : MERGE(10, 1, pol)*npoints)
2655 : END IF
2656 : #:for arr in v3_new
2657 0 : IF (is_mgga) THEN
2658 : CALL libxc_worker_d2h_read(worker, libxc_dev_${arr}$, worker%${arr}$ (1, 1), &
2659 0 : MERGE(${mgga_ncomp[arr]}$, 1, pol)*npoints)
2660 : END IF
2661 : #:endfor
2662 : END IF
2663 : ELSE
2664 : ! Host evaluation. The staging buffers already hold the block; these
2665 : ! wrappers write the requested derivatives in place.
2666 1357294 : IF (is_mgga) THEN
2667 277526 : SELECT CASE (grad_deriv)
2668 : CASE (0)
2669 0 : CALL libxc_mgga_exc_wrapper(worker%func, npts, worker%rho(1, 1), worker%sigma(1, 1), &
2670 8310 : worker%lapl(1, 1), worker%tau(1, 1), worker%exc(1))
2671 : CASE (1)
2672 240670 : IF (no_exc) THEN
2673 : CALL libxc_mgga_vxc_wrapper(worker%func, npts, worker%rho(1, 1), worker%sigma(1, 1), &
2674 : worker%lapl(1, 1), worker%tau(1, 1), worker%vrho(1, 1), &
2675 0 : worker%vsigma(1, 1), worker%vlapl(1, 1), worker%vtau(1, 1))
2676 0 : worker%exc(1:npoints) = 0.0_dp
2677 : ELSE
2678 : CALL libxc_mgga_exc_vxc_wrapper(worker%func, npts, worker%rho(1, 1), worker%sigma(1, 1), &
2679 : worker%lapl(1, 1), worker%tau(1, 1), worker%exc(1), &
2680 : worker%vrho(1, 1), worker%vsigma(1, 1), &
2681 240670 : worker%vlapl(1, 1), worker%vtau(1, 1))
2682 : END IF
2683 0 : CASE (2)
2684 18014 : IF (no_exc) THEN
2685 : CALL xc_f03_mgga_vxc_fxc(worker%func, npts, worker%rho(1, 1), worker%sigma(1, 1), &
2686 : worker%lapl(1, 1), worker%tau(1, 1), worker%vrho(1, 1), &
2687 : worker%vsigma(1, 1), worker%vlapl(1, 1), worker%vtau(1, 1), &
2688 : worker%v2rho2(1, 1), worker%v2rhosigma(1, 1), worker%v2rholapl(1, 1), &
2689 : worker%v2rhotau(1, 1), worker%v2sigma2(1, 1), worker%v2sigmalapl(1, 1), &
2690 : worker%v2sigmatau(1, 1), worker%v2lapl2(1, 1), worker%v2lapltau(1, 1), &
2691 0 : worker%v2tau2(1, 1))
2692 0 : worker%exc(1:npoints) = 0.0_dp
2693 1384478 : ELSE
2694 : CALL xc_f03_mgga(worker%func, npts, worker%rho(1, 1), worker%sigma(1, 1), &
2695 : worker%lapl(1, 1), worker%tau(1, 1), worker%exc(1), &
2696 : worker%vrho(1, 1), worker%vsigma(1, 1), worker%vlapl(1, 1), worker%vtau(1, 1), &
2697 : worker%v2rho2(1, 1), worker%v2rhosigma(1, 1), worker%v2rholapl(1, 1), &
2698 1972978 : worker%v2rhotau(1, 1), worker%v2sigma2(1, 1), worker%v2sigmalapl(1, 1), &
2699 : worker%v2sigmatau(1, 1), worker%v2lapl2(1, 1), worker%v2lapltau(1, 1), &
2700 18014 : worker%v2tau2(1, 1))
2701 588500 : END IF
2702 : CASE (3)
2703 269216 : IF (no_exc) THEN
2704 519672 : CALL xc_f03_mgga_vxc_fxc_kxc(worker%func, npts, worker%rho(1, 1), worker%sigma(1, 1), &
2705 : worker%lapl(1, 1), worker%tau(1, 1), worker%vrho(1, 1), &
2706 276306 : worker%vsigma(1, 1), worker%vlapl(1, 1), worker%vtau(1, 1), &
2707 276306 : worker%v2rho2(1, 1), worker%v2rhosigma(1, 1), worker%v2rholapl(1, 1), &
2708 : worker%v2rhotau(1, 1), worker%v2sigma2(1, 1), worker%v2sigmalapl(1, 1), &
2709 0 : worker%v2sigmatau(1, 1), worker%v2lapl2(1, 1), worker%v2lapltau(1, 1), &
2710 0 : worker%v2tau2(1, 1), worker%v3rho3(1, 1), worker%v3rho2sigma(1, 1), &
2711 1384478 : worker%v3rho2lapl(1, 1), worker%v3rho2tau(1, 1), &
2712 0 : worker%v3rhosigma2(1, 1), worker%v3rhosigmalapl(1, 1), &
2713 : worker%v3rhosigmatau(1, 1), worker%v3rholapl2(1, 1), &
2714 0 : worker%v3rholapltau(1, 1), worker%v3rhotau2(1, 1), &
2715 : worker%v3sigma3(1, 1), worker%v3sigma2lapl(1, 1), &
2716 : worker%v3sigma2tau(1, 1), worker%v3sigmalapl2(1, 1), &
2717 1384478 : worker%v3sigmalapltau(1, 1), worker%v3sigmatau2(1, 1), &
2718 : worker%v3lapl3(1, 1), worker%v3lapl2tau(1, 1), &
2719 0 : worker%v3lapltau2(1, 1), worker%v3tau3(1, 1))
2720 0 : worker%exc(1:npoints) = 0.0_dp
2721 : ELSE
2722 : CALL xc_f03_mgga_exc_vxc_fxc_kxc(worker%func, npts, worker%rho(1, 1), worker%sigma(1, 1), &
2723 : worker%lapl(1, 1), worker%tau(1, 1), worker%exc(1), &
2724 : worker%vrho(1, 1), worker%vsigma(1, 1), worker%vlapl(1, 1), &
2725 : worker%vtau(1, 1), worker%v2rho2(1, 1), worker%v2rhosigma(1, 1), &
2726 : worker%v2rholapl(1, 1), worker%v2rhotau(1, 1), &
2727 1358774 : worker%v2sigma2(1, 1), worker%v2sigmalapl(1, 1), &
2728 : worker%v2sigmatau(1, 1), worker%v2lapl2(1, 1), &
2729 : worker%v2lapltau(1, 1), worker%v2tau2(1, 1), &
2730 : worker%v3rho3(1, 1), worker%v3rho2sigma(1, 1), &
2731 1358774 : worker%v3rho2lapl(1, 1), worker%v3rho2tau(1, 1), &
2732 205680 : worker%v3rhosigma2(1, 1), worker%v3rhosigmalapl(1, 1), &
2733 205680 : worker%v3rhosigmatau(1, 1), worker%v3rholapl2(1, 1), &
2734 205680 : worker%v3rholapltau(1, 1), worker%v3rhotau2(1, 1), &
2735 : worker%v3sigma3(1, 1), worker%v3sigma2lapl(1, 1), &
2736 1153094 : worker%v3sigma2tau(1, 1), worker%v3sigmalapl2(1, 1), &
2737 1153094 : worker%v3sigmalapltau(1, 1), worker%v3sigmatau2(1, 1), &
2738 1153094 : worker%v3lapl3(1, 1), worker%v3lapl2tau(1, 1), &
2739 2222 : worker%v3lapltau2(1, 1), worker%v3tau3(1, 1))
2740 1358774 : END IF
2741 : END SELECT
2742 1088078 : ELSE IF (is_gga) THEN
2743 523858 : SELECT CASE (grad_deriv)
2744 : CASE (0)
2745 12474 : CALL libxc_gga_exc_wrapper(worker%func, npts, worker%rho(1, 1), worker%sigma(1, 1), worker%exc(1))
2746 : CASE (1)
2747 483410 : IF (no_exc) THEN
2748 : CALL xc_f03_gga_vxc(worker%func, npts, worker%rho(1, 1), worker%sigma(1, 1), &
2749 0 : worker%vrho(1, 1), worker%vsigma(1, 1))
2750 0 : worker%exc(1:npoints) = 0.0_dp
2751 : ELSE
2752 : CALL libxc_gga_exc_vxc_wrapper(worker%func, npts, worker%rho(1, 1), worker%sigma(1, 1), &
2753 483410 : worker%exc(1), worker%vrho(1, 1), worker%vsigma(1, 1))
2754 : END IF
2755 : CASE (2)
2756 14056 : IF (no_exc) THEN
2757 : CALL xc_f03_gga_vxc_fxc(worker%func, npts, worker%rho(1, 1), worker%sigma(1, 1), &
2758 : worker%vrho(1, 1), worker%vsigma(1, 1), &
2759 0 : worker%v2rho2(1, 1), worker%v2rhosigma(1, 1), worker%v2sigma2(1, 1))
2760 0 : worker%exc(1:npoints) = 0.0_dp
2761 : ELSE
2762 : CALL xc_f03_gga_exc_vxc_fxc(worker%func, npts, worker%rho(1, 1), worker%sigma(1, 1), &
2763 : worker%exc(1), worker%vrho(1, 1), worker%vsigma(1, 1), &
2764 14056 : worker%v2rho2(1, 1), worker%v2rhosigma(1, 1), worker%v2sigma2(1, 1))
2765 : END IF
2766 : CASE (3)
2767 511384 : IF (no_exc) THEN
2768 : CALL xc_f03_gga_vxc_fxc_kxc(worker%func, npts, worker%rho(1, 1), worker%sigma(1, 1), &
2769 : worker%vrho(1, 1), worker%vsigma(1, 1), &
2770 : worker%v2rho2(1, 1), worker%v2rhosigma(1, 1), worker%v2sigma2(1, 1), &
2771 : worker%v3rho3(1, 1), worker%v3rho2sigma(1, 1), &
2772 0 : worker%v3rhosigma2(1, 1), worker%v3sigma3(1, 1))
2773 0 : worker%exc(1:npoints) = 0.0_dp
2774 : ELSE
2775 : CALL xc_f03_gga_exc_vxc_fxc_kxc(worker%func, npts, worker%rho(1, 1), worker%sigma(1, 1), &
2776 : worker%exc(1), worker%vrho(1, 1), worker%vsigma(1, 1), &
2777 : worker%v2rho2(1, 1), worker%v2rhosigma(1, 1), worker%v2sigma2(1, 1), &
2778 : worker%v3rho3(1, 1), worker%v3rho2sigma(1, 1), &
2779 1444 : worker%v3rhosigma2(1, 1), worker%v3sigma3(1, 1))
2780 : END IF
2781 : END SELECT
2782 : ELSE
2783 589236 : SELECT CASE (grad_deriv)
2784 : CASE (0)
2785 12542 : CALL libxc_lda_exc_wrapper(worker%func, npts, worker%rho(1, 1), worker%exc(1))
2786 : CASE (1)
2787 535102 : CALL libxc_lda_exc_vxc_wrapper(worker%func, npts, worker%rho(1, 1), worker%exc(1), worker%vrho(1, 1))
2788 : CASE (2)
2789 : CALL xc_f03_lda_exc_vxc_fxc(worker%func, npts, worker%rho(1, 1), &
2790 27606 : worker%exc(1), worker%vrho(1, 1), worker%v2rho2(1, 1))
2791 : CASE (3)
2792 : CALL xc_f03_lda(worker%func, npts, worker%rho(1, 1), &
2793 576694 : worker%exc(1), worker%vrho(1, 1), worker%v2rho2(1, 1), worker%v3rho3(1, 1))
2794 : END SELECT
2795 : END IF
2796 1357294 : END IF
2797 1357294 :
2798 1357294 : CALL libxc_worker_check_nan(worker, npoints, grad_deriv, no_exc, family)
2799 1357294 :
2800 1357294 : END SUBROUTINE libxc_worker_eval
2801 :
2802 : ! **************************************************************************************************
2803 : !> \brief GGA exc and vxc on host arrays.
2804 : !> \param func ...
2805 1357294 : !> \param np ...
2806 : !> \param rho ...
2807 0 : !> \param sigma ...
2808 0 : !> \param exc ...
2809 0 : !> \param vrho ...
2810 : !> \param vsigma ...
2811 0 : ! **************************************************************************************************
2812 0 : SUBROUTINE libxc_gga_exc_vxc_wrapper(func, np, rho, sigma, exc, vrho, vsigma)
2813 0 : USE ISO_C_BINDING, ONLY: C_SIZE_T
2814 : TYPE(xc_f03_func_t), INTENT(IN) :: func
2815 : INTEGER(KIND=C_SIZE_T), INTENT(IN) :: np
2816 : REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rho, sigma
2817 : REAL(KIND=dp), DIMENSION(*), INTENT(OUT) :: exc, vrho, vsigma
2818 0 :
2819 483410 : CALL xc_f03_gga_exc_vxc(func, np, rho, sigma, exc, vrho, vsigma)
2820 483410 : END SUBROUTINE libxc_gga_exc_vxc_wrapper
2821 :
2822 0 : ! **************************************************************************************************
2823 0 : !> \brief GGA exc on host arrays.
2824 : !> \param func ...
2825 0 : !> \param np ...
2826 0 : !> \param rho ...
2827 0 : !> \param sigma ...
2828 0 : !> \param exc ...
2829 : ! **************************************************************************************************
2830 0 : SUBROUTINE libxc_gga_exc_wrapper(func, np, rho, sigma, exc)
2831 0 : USE ISO_C_BINDING, ONLY: C_SIZE_T
2832 0 : TYPE(xc_f03_func_t), INTENT(IN) :: func
2833 : INTEGER(KIND=C_SIZE_T), INTENT(IN) :: np
2834 : REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rho, sigma
2835 0 : REAL(KIND=dp), DIMENSION(*), INTENT(OUT) :: exc
2836 0 :
2837 12474 : CALL xc_f03_gga_exc(func, np, rho, sigma, exc)
2838 0 : END SUBROUTINE libxc_gga_exc_wrapper
2839 0 :
2840 : ! **************************************************************************************************
2841 0 : !> \brief LDA exc and vxc on host arrays.
2842 0 : !> \param func ...
2843 0 : !> \param np ...
2844 0 : !> \param rho ...
2845 0 : !> \param exc ...
2846 0 : !> \param vrho ...
2847 0 : ! **************************************************************************************************
2848 0 : SUBROUTINE libxc_lda_exc_vxc_wrapper(func, np, rho, exc, vrho)
2849 : USE ISO_C_BINDING, ONLY: C_SIZE_T
2850 : TYPE(xc_f03_func_t), INTENT(IN) :: func
2851 0 : INTEGER(KIND=C_SIZE_T), INTENT(IN) :: np
2852 0 : REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rho
2853 0 : REAL(KIND=dp), DIMENSION(*), INTENT(OUT) :: exc, vrho
2854 0 :
2855 535102 : CALL xc_f03_lda_exc_vxc(func, np, rho, exc, vrho)
2856 0 : END SUBROUTINE libxc_lda_exc_vxc_wrapper
2857 :
2858 : ! **************************************************************************************************
2859 : !> \brief LDA exc on host arrays.
2860 : !> \param func ...
2861 : !> \param np ...
2862 : !> \param rho ...
2863 : !> \param exc ...
2864 : ! **************************************************************************************************
2865 12542 : SUBROUTINE libxc_lda_exc_wrapper(func, np, rho, exc)
2866 : USE ISO_C_BINDING, ONLY: C_SIZE_T
2867 : TYPE(xc_f03_func_t), INTENT(IN) :: func
2868 : INTEGER(KIND=C_SIZE_T), INTENT(IN) :: np
2869 : REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rho
2870 : REAL(KIND=dp), DIMENSION(*), INTENT(OUT) :: exc
2871 :
2872 12542 : CALL xc_f03_lda_exc(func, np, rho, exc)
2873 12542 : END SUBROUTINE libxc_lda_exc_wrapper
2874 :
2875 : ! **************************************************************************************************
2876 : !> \brief MGGA exc and vxc on host arrays.
2877 : !> \param func ...
2878 : !> \param np ...
2879 : !> \param rho ...
2880 : !> \param sigma ...
2881 : !> \param lapl ...
2882 : !> \param tau ...
2883 : !> \param exc ...
2884 : !> \param vrho ...
2885 : !> \param vsigma ...
2886 : !> \param vlapl ...
2887 : !> \param vtau ...
2888 : ! **************************************************************************************************
2889 240670 : SUBROUTINE libxc_mgga_exc_vxc_wrapper(func, np, rho, sigma, lapl, tau, exc, vrho, vsigma, vlapl, vtau)
2890 : USE ISO_C_BINDING, ONLY: C_SIZE_T
2891 : TYPE(xc_f03_func_t), INTENT(IN) :: func
2892 : INTEGER(KIND=C_SIZE_T), INTENT(IN) :: np
2893 : REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rho, sigma, lapl, tau
2894 : REAL(KIND=dp), DIMENSION(*), INTENT(OUT) :: exc, vrho, vsigma, vlapl, vtau
2895 :
2896 240670 : CALL xc_f03_mgga_exc_vxc(func, np, rho, sigma, lapl, tau, exc, vrho, vsigma, vlapl, vtau)
2897 240670 : END SUBROUTINE libxc_mgga_exc_vxc_wrapper
2898 :
2899 : ! **************************************************************************************************
2900 : !> \brief MGGA exc on host arrays.
2901 : !> \param func ...
2902 : !> \param np ...
2903 : !> \param rho ...
2904 : !> \param sigma ...
2905 : !> \param lapl ...
2906 : !> \param tau ...
2907 : !> \param exc ...
2908 : ! **************************************************************************************************
2909 8310 : SUBROUTINE libxc_mgga_exc_wrapper(func, np, rho, sigma, lapl, tau, exc)
2910 : USE ISO_C_BINDING, ONLY: C_SIZE_T
2911 : TYPE(xc_f03_func_t), INTENT(IN) :: func
2912 : INTEGER(KIND=C_SIZE_T), INTENT(IN) :: np
2913 : REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rho, sigma, lapl, tau
2914 : REAL(KIND=dp), DIMENSION(*), INTENT(OUT) :: exc
2915 :
2916 8310 : CALL xc_f03_mgga_exc(func, np, rho, sigma, lapl, tau, exc)
2917 8310 : END SUBROUTINE libxc_mgga_exc_wrapper
2918 :
2919 : ! **************************************************************************************************
2920 : !> \brief MGGA vxc on host arrays.
2921 : !> \param func ...
2922 : !> \param np ...
2923 : !> \param rho ...
2924 : !> \param sigma ...
2925 : !> \param lapl ...
2926 : !> \param tau ...
2927 : !> \param vrho ...
2928 : !> \param vsigma ...
2929 : !> \param vlapl ...
2930 : !> \param vtau ...
2931 : ! **************************************************************************************************
2932 0 : SUBROUTINE libxc_mgga_vxc_wrapper(func, np, rho, sigma, lapl, tau, vrho, vsigma, vlapl, vtau)
2933 : USE ISO_C_BINDING, ONLY: C_SIZE_T
2934 : TYPE(xc_f03_func_t), INTENT(IN) :: func
2935 : INTEGER(KIND=C_SIZE_T), INTENT(IN) :: np
2936 : REAL(KIND=dp), DIMENSION(*), INTENT(IN) :: rho, sigma, lapl, tau
2937 : REAL(KIND=dp), DIMENSION(*), INTENT(OUT) :: vrho, vsigma, vlapl, vtau
2938 :
2939 0 : CALL xc_f03_mgga_vxc(func, np, rho, sigma, lapl, tau, vrho, vsigma, vlapl, vtau)
2940 0 : END SUBROUTINE libxc_mgga_vxc_wrapper
2941 :
2942 : #endif
2943 :
2944 0 : END MODULE xc_libxc_wrap
|
