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 : #ifdef __GAUXC
9 : #include "gauxc/gauxc_config.f"
10 : #endif
11 :
12 : #define GAUXC_RETURN_IF_ERROR(status) IF (status%status%code /= 0) RETURN
13 :
14 : MODULE xc_gauxc_interface
15 :
16 : USE iso_fortran_env, ONLY: &
17 : error_unit
18 : #if defined (__HAS_IEEE_EXCEPTIONS)
19 : USE ieee_exceptions, ONLY: &
20 : ieee_all, &
21 : ieee_get_halting_mode, &
22 : ieee_set_halting_mode
23 : #endif
24 : USE iso_c_binding, ONLY: &
25 : c_associated, &
26 : c_bool, &
27 : c_char, &
28 : c_double, &
29 : c_f_pointer, &
30 : c_int, &
31 : c_int32_t, &
32 : c_int64_t, &
33 : c_null_char, &
34 : c_null_ptr, &
35 : c_ptr, &
36 : c_size_t
37 : USE particle_types, ONLY: &
38 : particle_type
39 : USE qs_kind_types, ONLY: &
40 : get_qs_kind, &
41 : qs_kind_type
42 : USE cp_dbcsr_api, ONLY: &
43 : dbcsr_p_type
44 : USE cp_log_handling, ONLY: &
45 : cp_logger_get_default_io_unit
46 :
47 : #ifdef __GAUXC
48 :
49 : USE kinds, ONLY: &
50 : default_path_length, &
51 : default_string_length, &
52 : dp
53 : USE physcon, ONLY: &
54 : bohr
55 : USE atomic_kind_types, ONLY: &
56 : atomic_kind_type, &
57 : get_atomic_kind, &
58 : get_atomic_kind_set
59 : USE qs_integral_utils, ONLY: &
60 : basis_set_list_setup
61 : USE basis_set_types, ONLY: &
62 : gto_basis_set_p_type, &
63 : gto_basis_set_type, &
64 : write_gto_basis_set
65 : USE periodic_table, ONLY: &
66 : get_ptable_info
67 : USE gauxc_status, ONLY: &
68 : gauxc_status_message, &
69 : gauxc_status_type
70 : USE gauxc_enums, ONLY: &
71 : gauxc_atomicgridsizedefault, &
72 : gauxc_executionspace, &
73 : gauxc_pruningscheme, &
74 : gauxc_radialquad
75 : USE gauxc_runtime_environment, ONLY: &
76 : gauxc_runtime_environment_delete, &
77 : gauxc_runtime_environment_new, &
78 : gauxc_runtime_environment_type
79 : #ifdef GAUXC_HAS_DEVICE
80 : USE gauxc_runtime_environment, ONLY: &
81 : gauxc_device_runtime_environment_new
82 : #endif
83 : USE gauxc_molecule, ONLY: &
84 : gauxc_delete, &
85 : gauxc_molecule_new_from_atoms, &
86 : gauxc_molecule_type
87 : USE gauxc_atom, ONLY: &
88 : gauxc_atom_type
89 : USE gauxc_basisset, ONLY: &
90 : gauxc_basisset_new, &
91 : gauxc_basisset_new_from_shells, &
92 : gauxc_basisset_type, &
93 : gauxc_delete
94 : USE gauxc_shell, ONLY: &
95 : gauxc_shell_type
96 : USE gauxc_molgrid, ONLY: &
97 : gauxc_delete, &
98 : gauxc_molgrid_new_default, &
99 : gauxc_molgrid_type
100 : USE gauxc_load_balancer, ONLY: &
101 : gauxc_delete, &
102 : gauxc_load_balancer_factory_get_instance, &
103 : gauxc_load_balancer_factory_new, &
104 : gauxc_load_balancer_factory_type, &
105 : gauxc_load_balancer_type
106 : USE gauxc_molecular_weights, ONLY: &
107 : gauxc_delete, &
108 : gauxc_get_instance, &
109 : gauxc_molecular_weights_factory_new, &
110 : gauxc_molecular_weights_factory_type, &
111 : gauxc_molecular_weights_modify_weights, &
112 : gauxc_molecular_weights_settings, &
113 : gauxc_molecular_weights_type
114 : USE gauxc_xc_functional, ONLY: &
115 : gauxc_delete, &
116 : gauxc_functional_from_string, &
117 : gauxc_functional_type
118 : USE gauxc_integrator, ONLY: &
119 : gauxc_delete, &
120 : gauxc_integrator_eval_exc_grad_rks, &
121 : gauxc_integrator_eval_exc_grad_uks, &
122 : gauxc_integrator_eval_exc_vxc_rks, &
123 : gauxc_integrator_eval_exc_vxc_uks, &
124 : gauxc_integrator_new, &
125 : gauxc_integrator_type
126 : #ifdef GAUXC_HAS_ONEDFT
127 : USE gauxc_integrator, ONLY: &
128 : gauxc_integrator_eval_exc_grad_onedft_uks, &
129 : gauxc_integrator_eval_exc_vxc_onedft_uks
130 : USE OMP_LIB, ONLY: &
131 : omp_get_max_threads, &
132 : omp_set_num_threads
133 : #endif
134 : #ifdef GAUXC_HAS_HDF5
135 : USE gauxc_external_hdf5_write, ONLY: &
136 : gauxc_write_hdf5_record
137 : #endif
138 : USE string_utilities, ONLY: &
139 : uppercase
140 : #endif
141 :
142 : #include "../base/base_uses.f90"
143 :
144 : IMPLICIT NONE
145 : PRIVATE
146 :
147 : #ifndef __GAUXC
148 :
149 : ! The module still exists as an empty shell when compiling without GauXC.
150 :
151 : TYPE cp_gauxc_molecule_type
152 : END TYPE cp_gauxc_molecule_type
153 :
154 : TYPE cp_gauxc_basisset_type
155 : INTEGER :: max_l = -1
156 : END TYPE cp_gauxc_basisset_type
157 :
158 : TYPE cp_gauxc_grid_type
159 : END TYPE cp_gauxc_grid_type
160 :
161 : TYPE cp_gauxc_integrator_type
162 : END TYPE cp_gauxc_integrator_type
163 :
164 : TYPE cp_gauxc_status_type
165 : END TYPE cp_gauxc_status_type
166 :
167 : #else
168 :
169 : ! TODO can we make the single fields private somehow?
170 :
171 : TYPE cp_gauxc_molecule_type
172 : TYPE(gauxc_molecule_type) :: molecule
173 : END TYPE cp_gauxc_molecule_type
174 :
175 : TYPE cp_gauxc_basisset_type
176 : TYPE(gauxc_basisset_type) :: basis
177 : INTEGER :: max_l = -1
178 : END TYPE cp_gauxc_basisset_type
179 :
180 : TYPE cp_gauxc_grid_type
181 : TYPE(gauxc_molgrid_type) :: grid
182 : TYPE(gauxc_load_balancer_type) :: lb
183 : TYPE(gauxc_load_balancer_factory_type) :: lbf
184 : TYPE(gauxc_molecular_weights_type) :: mw
185 : TYPE(gauxc_molecular_weights_factory_type) :: mwf
186 : TYPE(gauxc_runtime_environment_type) :: rt
187 : LOGICAL :: owns_rt = .FALSE.
188 : END TYPE cp_gauxc_grid_type
189 :
190 : TYPE cp_gauxc_integrator_type
191 : TYPE(gauxc_functional_type) :: func
192 : TYPE(gauxc_integrator_type) :: integrator
193 : END TYPE cp_gauxc_integrator_type
194 :
195 : TYPE cp_gauxc_status_type
196 : TYPE(gauxc_status_type) :: status
197 : END TYPE cp_gauxc_status_type
198 :
199 : TYPE(gauxc_runtime_environment_type) :: rt
200 : INTEGER :: rt_mpi_comm = -1
201 : LOGICAL :: rt_has_mpi_comm = .FALSE.
202 :
203 : #endif
204 :
205 : TYPE cp_gauxc_xc_type
206 : REAL(c_double) :: exc = 0.0_c_double
207 : REAL(c_double), DIMENSION(:, :), ALLOCATABLE :: vxc_scalar, vxc_zeta
208 : END TYPE cp_gauxc_xc_type
209 :
210 : TYPE cp_gauxc_xc_gradient_type
211 : REAL(c_double), ALLOCATABLE, DIMENSION(:) :: exc_grad
212 : END TYPE cp_gauxc_xc_gradient_type
213 :
214 : CHARACTER(len=*), PARAMETER :: no_gauxc_message = "Compile CP2K with GauXC to use this functionality!"
215 :
216 : PUBLIC :: &
217 : cp_gauxc_basisset_type, &
218 : cp_gauxc_grid_type, &
219 : cp_gauxc_integrator_type, &
220 : cp_gauxc_molecule_type, &
221 : cp_gauxc_status_type, &
222 : cp_gauxc_xc_gradient_type, &
223 : cp_gauxc_xc_type, &
224 : gauxc_check_status, &
225 : gauxc_compute_xc_gradient, &
226 : gauxc_compute_xc, &
227 : gauxc_create_basisset, &
228 : gauxc_create_grid, &
229 : gauxc_create_integrator, &
230 : gauxc_create_molecule, &
231 : gauxc_destroy_basisset, &
232 : gauxc_destroy_grid, &
233 : gauxc_destroy_integrator, &
234 : gauxc_destroy_molecule, &
235 : gauxc_finalize, &
236 : gauxc_init, &
237 : gauxc_write_basisset_hdf5, &
238 : gauxc_write_molecule_hdf5
239 : CONTAINS
240 :
241 : ! **************************************************************************************************
242 : !> \brief ...
243 : !> \param status ...
244 : ! **************************************************************************************************
245 0 : SUBROUTINE print_gauxc_status_message(status)
246 : ! IMPORT :: c_ptr
247 : TYPE(cp_gauxc_status_type) :: status
248 :
249 : #ifdef __GAUXC
250 0 : CHARACTER(kind=c_char), POINTER :: s(:)
251 : CHARACTER(len=32) :: stderr_env
252 : INTEGER :: i, ierr, iw
253 : LOGICAL :: print_to_stderr
254 : INTEGER, PARAMETER :: status_message_length = 4096
255 :
256 0 : iw = cp_logger_get_default_io_unit()
257 0 : ierr = error_unit
258 0 : CALL GET_ENVIRONMENT_VARIABLE("CP2K_GAUXC_STATUS_STDERR", stderr_env)
259 0 : CALL uppercase(stderr_env)
260 0 : SELECT CASE (TRIM(stderr_env))
261 : CASE ("", "0", "FALSE", "F", "OFF", "NO")
262 0 : print_to_stderr = .FALSE.
263 : CASE ("1", "TRUE", "T", "ON", "YES")
264 0 : print_to_stderr = .TRUE.
265 : CASE DEFAULT
266 0 : print_to_stderr = .TRUE.
267 : END SELECT
268 0 : IF (iw > 0) THEN
269 0 : WRITE (UNIT=iw, FMT='(a,1x,i0)') "GauXC returned with status code", status%status%code
270 0 : IF (c_associated(status%status%message)) THEN
271 0 : WRITE (UNIT=iw, FMT='(a)', ADVANCE='no') "GauXC status message: ["
272 :
273 0 : CALL c_f_pointer(status%status%message, s, [status_message_length])
274 0 : DO i = 1, SIZE(s)
275 0 : IF (s(i) == c_null_char) EXIT
276 0 : WRITE (UNIT=iw, FMT='(A)', ADVANCE='no') s(i)
277 : END DO
278 :
279 0 : WRITE (UNIT=iw, FMT='(a)') "]"
280 : ELSE
281 0 : WRITE (UNIT=iw, FMT='(a)') "GauXC status message: [null]"
282 : END IF
283 : END IF
284 0 : IF (print_to_stderr) THEN
285 0 : WRITE (UNIT=ierr, FMT='(a,1x,i0)') "GauXC returned with status code", status%status%code
286 0 : IF (c_associated(status%status%message)) THEN
287 0 : WRITE (UNIT=ierr, FMT='(a)', ADVANCE='no') "GauXC status message: ["
288 :
289 0 : CALL c_f_pointer(status%status%message, s, [status_message_length])
290 0 : DO i = 1, SIZE(s)
291 0 : IF (s(i) == c_null_char) EXIT
292 0 : WRITE (UNIT=ierr, FMT='(A)', ADVANCE='no') s(i)
293 : END DO
294 :
295 0 : WRITE (UNIT=ierr, FMT='(a)') "]"
296 : ELSE
297 0 : WRITE (UNIT=ierr, FMT='(a)') "GauXC status message: [null]"
298 : END IF
299 : END IF
300 : #else
301 : MARK_USED(status)
302 : #endif
303 0 : END SUBROUTINE print_gauxc_status_message
304 :
305 : ! **************************************************************************************************
306 : !> \brief ...
307 : !> \param mpi_comm ...
308 : !> \param status ...
309 : ! **************************************************************************************************
310 10624 : SUBROUTINE gauxc_init(mpi_comm, status)
311 : INTEGER, INTENT(IN), OPTIONAL :: mpi_comm
312 : TYPE(cp_gauxc_status_type), INTENT(OUT) :: status
313 :
314 : #ifdef __GAUXC
315 : #if defined(GAUXC_HAS_MPI) && defined(__parallel)
316 10624 : IF (PRESENT(mpi_comm)) THEN
317 10624 : rt = gauxc_runtime_environment_new(status%status, mpi_comm)
318 10624 : rt_mpi_comm = mpi_comm
319 10624 : rt_has_mpi_comm = .TRUE.
320 : ELSE
321 0 : rt = gauxc_runtime_environment_new(status%status)
322 0 : rt_mpi_comm = -1
323 0 : rt_has_mpi_comm = .FALSE.
324 : END IF
325 : #else
326 : MARK_USED(mpi_comm)
327 : rt = gauxc_runtime_environment_new(status%status)
328 : rt_mpi_comm = -1
329 : rt_has_mpi_comm = .FALSE.
330 : #endif
331 10624 : GAUXC_RETURN_IF_ERROR(status)
332 : #else
333 : MARK_USED(mpi_comm)
334 : MARK_USED(status)
335 : #endif
336 : END SUBROUTINE gauxc_init
337 :
338 : ! **************************************************************************************************
339 : !> \brief ...
340 : !> \param status ...
341 : ! **************************************************************************************************
342 10624 : SUBROUTINE gauxc_finalize(status)
343 : TYPE(cp_gauxc_status_type), INTENT(OUT) :: status
344 :
345 : #ifdef __GAUXC
346 10624 : CALL gauxc_runtime_environment_delete(status%status, rt)
347 10624 : GAUXC_RETURN_IF_ERROR(status)
348 10624 : rt_mpi_comm = -1
349 10624 : rt_has_mpi_comm = .FALSE.
350 : #else
351 : MARK_USED(status)
352 : #endif
353 : END SUBROUTINE gauxc_finalize
354 :
355 : ! **************************************************************************************************
356 : !> \brief ...
357 : !> \param particle_set ...
358 : !> \param status ...
359 : !> \return ...
360 : ! **************************************************************************************************
361 132 : FUNCTION gauxc_create_molecule(particle_set, status) RESULT(res)
362 : TYPE(particle_type), DIMENSION(:), INTENT(IN) :: particle_set
363 : TYPE(cp_gauxc_status_type), INTENT(OUT) :: status
364 : TYPE(cp_gauxc_molecule_type) :: res
365 :
366 : #ifdef __GAUXC
367 : CHARACTER(LEN=2) :: element_symbol
368 : INTEGER :: atomic_number, i, natoms
369 : TYPE(atomic_kind_type), POINTER :: atomic_kind
370 66 : TYPE(gauxc_atom_type), ALLOCATABLE, DIMENSION(:) :: atoms
371 :
372 66 : natoms = SIZE(particle_set)
373 198 : ALLOCATE (atoms(natoms))
374 :
375 230 : DO i = 1, natoms
376 164 : atomic_kind => particle_set(i)%atomic_kind
377 164 : CALL get_atomic_kind(atomic_kind, element_symbol=element_symbol)
378 164 : CALL get_ptable_info(element_symbol, number=atomic_number)
379 164 : atoms(i)%atomic_number = INT(atomic_number, c_int64_t)
380 164 : atoms(i)%x = REAL(particle_set(i)%r(1), c_double)
381 164 : atoms(i)%y = REAL(particle_set(i)%r(2), c_double)
382 230 : atoms(i)%z = REAL(particle_set(i)%r(3), c_double)
383 : END DO
384 :
385 66 : res%molecule = gauxc_molecule_new_from_atoms(status%status, atoms, INT(natoms, c_size_t))
386 66 : GAUXC_RETURN_IF_ERROR(status)
387 :
388 66 : DEALLOCATE (atoms)
389 : #else
390 : MARK_USED(particle_set)
391 : MARK_USED(res)
392 : MARK_USED(status)
393 : CPABORT(no_gauxc_message)
394 : #endif
395 132 : END FUNCTION gauxc_create_molecule
396 :
397 : ! **************************************************************************************************
398 : !> \brief ...
399 : !> \param qs_kind_set ...
400 : !> \param particle_set ...
401 : !> \param status ...
402 : !> \return ...
403 : ! **************************************************************************************************
404 132 : FUNCTION gauxc_create_basisset(qs_kind_set, particle_set, status) RESULT(res)
405 : TYPE(qs_kind_type), DIMENSION(:), INTENT(IN), &
406 : POINTER :: qs_kind_set
407 : TYPE(particle_type), DIMENSION(:), INTENT(IN) :: particle_set
408 : TYPE(cp_gauxc_status_type), INTENT(OUT) :: status
409 : TYPE(cp_gauxc_basisset_type) :: res
410 :
411 : #ifdef __GAUXC
412 : INTEGER :: iatom, ikind, iprim, iset, ishell, lval, &
413 : nkind, npgf, nset, nshell, &
414 : nshell_total, shell_index, natoms
415 : REAL(c_double), DIMENSION(3) :: shell_origin
416 : TYPE(atomic_kind_type), POINTER :: atomic_kind
417 66 : TYPE(gauxc_shell_type), ALLOCATABLE, DIMENSION(:) :: shells
418 : TYPE(gto_basis_set_p_type), DIMENSION(:), POINTER :: basis_set_list
419 : TYPE(gto_basis_set_type), POINTER :: gto_basis
420 :
421 66 : nkind = SIZE(qs_kind_set)
422 66 : natoms = SIZE(particle_set)
423 :
424 296 : ALLOCATE (basis_set_list(nkind))
425 66 : CALL basis_set_list_setup(basis_set_list, "ORB", qs_kind_set)
426 :
427 66 : nshell_total = 0
428 230 : DO iatom = 1, natoms
429 164 : atomic_kind => particle_set(iatom)%atomic_kind
430 164 : CALL get_atomic_kind(atomic_kind, kind_number=ikind)
431 164 : gto_basis => basis_set_list(ikind)%gto_basis_set
432 164 : CPASSERT(ASSOCIATED(gto_basis))
433 : ! CALL write_gto_basis_set(gto_basis, 6, "–––––GAUXC-CREATE-BASISSET–––––")
434 674 : nshell_total = nshell_total + SUM(gto_basis%nshell)
435 : END DO
436 :
437 714 : ALLOCATE (shells(nshell_total))
438 :
439 230 : shell_index = 0
440 230 : res%max_l = -1
441 230 : DO iatom = 1, natoms ! for each atom
442 164 : atomic_kind => particle_set(iatom)%atomic_kind
443 164 : CALL get_atomic_kind(atomic_kind, kind_number=ikind)
444 164 : gto_basis => basis_set_list(ikind)%gto_basis_set
445 164 : CPASSERT(ASSOCIATED(gto_basis))
446 :
447 164 : shell_origin(1) = REAL(particle_set(iatom)%r(1), c_double)
448 164 : shell_origin(2) = REAL(particle_set(iatom)%r(2), c_double)
449 164 : shell_origin(3) = REAL(particle_set(iatom)%r(3), c_double)
450 :
451 164 : nset = gto_basis%nset
452 164 : CPASSERT(nset == SIZE(gto_basis%nshell))
453 674 : DO iset = 1, nset ! for each shell group
454 280 : nshell = gto_basis%nshell(iset)
455 280 : npgf = gto_basis%npgf(iset) ! corresponds with nprim of gauxc
456 :
457 960 : DO ishell = 1, gto_basis%nshell(iset) ! for each shell within the shell group
458 516 : shell_index = shell_index + 1 ! global shell index, flattened over atoms and groups
459 516 : lval = gto_basis%l(ishell, iset)
460 516 : res%max_l = MAX(res%max_l, lval)
461 516 : shells(shell_index)%l = INT(lval, c_int32_t)
462 : ! FIXME hardcoded true param
463 : ! pure=1: spherical Gaussians; pure=0: cartesian Gaussians
464 516 : shells(shell_index)%pure = .TRUE._c_bool
465 516 : shells(shell_index)%nprim = INT(npgf, c_int32_t)
466 2064 : shells(shell_index)%origin = shell_origin
467 :
468 2576 : DO iprim = 1, npgf
469 : shells(shell_index)%exponents(iprim) = &
470 1780 : REAL(gto_basis%zet(iprim, iset), c_double)
471 : shells(shell_index)%coefficients(iprim) = &
472 : REAL(gto_basis%norm_cgf(gto_basis%first_cgf(ishell, iset))* &
473 2296 : gto_basis%gcc(iprim, ishell, iset), c_double)
474 : END DO
475 : END DO
476 : END DO
477 : END DO
478 :
479 : res%basis = gauxc_basisset_new_from_shells( &
480 : status%status, &
481 : shells, &
482 66 : normalize=.FALSE.)
483 66 : GAUXC_RETURN_IF_ERROR(status)
484 :
485 66 : DEALLOCATE (shells)
486 66 : DEALLOCATE (basis_set_list)
487 :
488 : #else
489 : MARK_USED(particle_set)
490 : MARK_USED(qs_kind_set)
491 : MARK_USED(res)
492 : MARK_USED(status)
493 : CPABORT(no_gauxc_message)
494 : #endif
495 132 : END FUNCTION gauxc_create_basisset
496 :
497 : ! **************************************************************************************************
498 : !> \brief ...
499 : !> \param molecule ...
500 : !> \param basis ...
501 : !> \param grid_type ...
502 : !> \param radial_quadrature ...
503 : !> \param pruning_scheme ...
504 : !> \param lb_exec_space ...
505 : !> \param batch_size ...
506 : !> \param device_runtime_fill_fraction ...
507 : !> \param status ...
508 : !> \param mpi_comm optional communicator for a grid-local GauXC runtime
509 : !> \param force_new_runtime force creation of a grid-local GauXC runtime
510 : !> \return ...
511 : ! **************************************************************************************************
512 66 : FUNCTION gauxc_create_grid( &
513 : molecule, &
514 : basis, &
515 : grid_type, &
516 : radial_quadrature, &
517 : pruning_scheme, &
518 : lb_exec_space, &
519 : batch_size, &
520 : device_runtime_fill_fraction, &
521 : status, &
522 : mpi_comm, &
523 66 : force_new_runtime) RESULT(res)
524 :
525 : TYPE(cp_gauxc_molecule_type), INTENT(IN) :: molecule
526 : TYPE(cp_gauxc_basisset_type), INTENT(in) :: basis
527 : CHARACTER(len=*) :: grid_type, lb_exec_space, &
528 : pruning_scheme, radial_quadrature
529 : INTEGER :: batch_size
530 : REAL(c_double), INTENT(IN) :: device_runtime_fill_fraction
531 : TYPE(cp_gauxc_status_type), INTENT(OUT) :: status
532 : INTEGER, INTENT(IN), OPTIONAL :: mpi_comm
533 : LOGICAL, INTENT(IN), OPTIONAL :: force_new_runtime
534 : TYPE(cp_gauxc_grid_type) :: res
535 :
536 : #ifdef __GAUXC
537 : INTEGER(c_int) :: grid_type_local, int_exec_space_local, &
538 : lb_exec_space_local, &
539 : pruning_scheme_local, radial_quad_local
540 : LOGICAL :: force_new_runtime_local, use_device_runtime
541 :
542 66 : grid_type_local = read_atomic_grid_size(grid_type)
543 66 : radial_quad_local = read_radial_quad(radial_quadrature)
544 66 : pruning_scheme_local = read_pruning_scheme(pruning_scheme)
545 66 : lb_exec_space_local = read_execution_space(lb_exec_space)
546 66 : int_exec_space_local = read_execution_space("host")
547 66 : use_device_runtime = (lb_exec_space_local == gauxc_executionspace%device)
548 66 : force_new_runtime_local = .FALSE.
549 50 : IF (PRESENT(force_new_runtime)) force_new_runtime_local = force_new_runtime
550 66 : res%owns_rt = .FALSE.
551 :
552 66 : IF (use_device_runtime) THEN
553 : #ifdef GAUXC_HAS_DEVICE
554 : #if defined(GAUXC_HAS_MPI) && defined(__parallel)
555 : IF (PRESENT(mpi_comm)) THEN
556 : res%rt = gauxc_device_runtime_environment_new( &
557 : status%status, mpi_comm, device_runtime_fill_fraction)
558 : ELSE
559 : res%rt = gauxc_device_runtime_environment_new( &
560 : status%status, device_runtime_fill_fraction)
561 : END IF
562 : #else
563 : MARK_USED(mpi_comm)
564 : res%rt = gauxc_device_runtime_environment_new( &
565 : status%status, device_runtime_fill_fraction)
566 : #endif
567 : GAUXC_RETURN_IF_ERROR(status)
568 : res%owns_rt = .TRUE.
569 : #else
570 : MARK_USED(device_runtime_fill_fraction)
571 0 : CPABORT("GauXC was built without device runtime support")
572 : #endif
573 : ELSE
574 : #if defined(GAUXC_HAS_MPI) && defined(__parallel)
575 66 : IF (PRESENT(mpi_comm)) THEN
576 : ! Reuse the global runtime when the requested communicator matches
577 : ! the communicator used during gauxc_init.
578 66 : IF (force_new_runtime_local .OR. .NOT. rt_has_mpi_comm .OR. &
579 : mpi_comm /= rt_mpi_comm) THEN
580 54 : res%rt = gauxc_runtime_environment_new(status%status, mpi_comm)
581 54 : GAUXC_RETURN_IF_ERROR(status)
582 : res%owns_rt = .TRUE.
583 : END IF
584 : END IF
585 : #else
586 : MARK_USED(mpi_comm)
587 : MARK_USED(force_new_runtime)
588 : #endif
589 : END IF
590 :
591 : res%grid = gauxc_molgrid_new_default( &
592 : status%status, &
593 : molecule%molecule, &
594 : pruning_scheme_local, &
595 : INT(batch_size, c_int64_t), &
596 : radial_quad_local, &
597 66 : grid_type_local)
598 66 : GAUXC_RETURN_IF_ERROR(status)
599 :
600 : res%lbf = gauxc_load_balancer_factory_new( &
601 : status%status, &
602 66 : lb_exec_space_local)
603 66 : GAUXC_RETURN_IF_ERROR(status)
604 :
605 66 : IF (res%owns_rt) THEN
606 : res%lb = gauxc_load_balancer_factory_get_instance( &
607 : status%status, &
608 : res%lbf, &
609 : res%rt, &
610 : molecule%molecule, &
611 : res%grid, &
612 54 : basis%basis)
613 : ELSE
614 : res%lb = gauxc_load_balancer_factory_get_instance( &
615 : status%status, &
616 : res%lbf, &
617 : rt, &
618 : molecule%molecule, &
619 : res%grid, &
620 12 : basis%basis)
621 : END IF
622 66 : GAUXC_RETURN_IF_ERROR(status)
623 :
624 : res%mwf = gauxc_molecular_weights_factory_new( &
625 : status%status, &
626 66 : int_exec_space_local)
627 66 : GAUXC_RETURN_IF_ERROR(status)
628 :
629 : res%mw = gauxc_get_instance( &
630 : status%status, &
631 66 : res%mwf)
632 66 : GAUXC_RETURN_IF_ERROR(status)
633 :
634 : CALL gauxc_molecular_weights_modify_weights( &
635 : status%status, &
636 : res%mw, &
637 66 : res%lb)
638 66 : GAUXC_RETURN_IF_ERROR(status)
639 :
640 : #else
641 : MARK_USED(basis)
642 : MARK_USED(batch_size)
643 : MARK_USED(device_runtime_fill_fraction)
644 : MARK_USED(grid_type)
645 : MARK_USED(lb_exec_space)
646 : MARK_USED(mpi_comm)
647 : MARK_USED(force_new_runtime)
648 : MARK_USED(molecule)
649 : MARK_USED(pruning_scheme)
650 : MARK_USED(radial_quadrature)
651 : MARK_USED(res)
652 : MARK_USED(status)
653 : CPABORT(no_gauxc_message)
654 : #endif
655 132 : END FUNCTION gauxc_create_grid
656 :
657 : ! **************************************************************************************************
658 : !> \brief ...
659 : !> \param xc_functional_name ...
660 : !> \param grid ...
661 : !> \param int_exec_space ...
662 : !> \param lwd_kernel ...
663 : !> \param nspins ...
664 : !> \param status ...
665 : !> \return ...
666 : ! **************************************************************************************************
667 66 : FUNCTION gauxc_create_integrator( &
668 : xc_functional_name, &
669 : grid, &
670 : int_exec_space, &
671 : lwd_kernel, &
672 : nspins, &
673 66 : status) RESULT(res)
674 :
675 : CHARACTER(len=*), INTENT(IN) :: xc_functional_name, int_exec_space, &
676 : lwd_kernel
677 : TYPE(cp_gauxc_grid_type), INTENT(IN) :: grid
678 : INTEGER, INTENT(IN) :: nspins
679 : TYPE(cp_gauxc_status_type), INTENT(OUT) :: status
680 : TYPE(cp_gauxc_integrator_type) :: res
681 :
682 : #ifdef __GAUXC
683 : INTEGER(c_int) :: int_exec_space_local
684 : LOGICAL(c_bool) :: polarized
685 :
686 66 : polarized = (nspins == 2)
687 : res%func = gauxc_functional_from_string( &
688 : status%status, &
689 : xc_functional_name, &
690 132 : polarized)
691 66 : GAUXC_RETURN_IF_ERROR(status)
692 :
693 66 : int_exec_space_local = read_execution_space(int_exec_space)
694 : res%integrator = gauxc_integrator_new( &
695 : status%status, &
696 : res%func, &
697 : grid%lb, &
698 : int_exec_space_local, &
699 66 : local_work_kernel_name=TRIM(lwd_kernel))
700 66 : GAUXC_RETURN_IF_ERROR(status)
701 :
702 : #else
703 : MARK_USED(grid)
704 : MARK_USED(int_exec_space)
705 : MARK_USED(lwd_kernel)
706 : MARK_USED(nspins)
707 : MARK_USED(res)
708 : MARK_USED(status)
709 : MARK_USED(xc_functional_name)
710 : CPABORT(no_gauxc_message)
711 : #endif
712 132 : END FUNCTION gauxc_create_integrator
713 :
714 : ! **************************************************************************************************
715 : !> \brief ...
716 : !> \param integrator ...
717 : !> \param density_scalar ...
718 : !> \param density_zeta ...
719 : !> \param nspins ...
720 : !> \param status ...
721 : !> \param model ...
722 : !> \return ...
723 : ! **************************************************************************************************
724 980 : FUNCTION gauxc_compute_xc( &
725 : integrator, &
726 980 : density_scalar, &
727 490 : density_zeta, &
728 : nspins, &
729 : status, &
730 490 : model) RESULT(res)
731 :
732 : TYPE(cp_gauxc_integrator_type), INTENT(IN) :: integrator
733 : REAL(c_double), DIMENSION(:, :), INTENT(IN) :: density_scalar
734 : REAL(c_double), DIMENSION(:, :), INTENT(IN), &
735 : OPTIONAL :: density_zeta
736 : INTEGER, INTENT(IN) :: nspins
737 : TYPE(cp_gauxc_status_type), INTENT(OUT) :: status
738 : CHARACTER(len=*), INTENT(IN), OPTIONAL :: model
739 : TYPE(cp_gauxc_xc_type) :: res
740 :
741 : #ifdef __GAUXC
742 : CHARACTER(len=default_path_length) :: model_key
743 : LOGICAL :: use_gauxc_model
744 490 : REAL(c_double), ALLOCATABLE, DIMENSION(:, :) :: density_scalar_rks
745 : #ifdef GAUXC_HAS_ONEDFT
746 490 : REAL(c_double), ALLOCATABLE, DIMENSION(:, :) :: density_zeta_zero
747 : #if defined (__HAS_IEEE_EXCEPTIONS)
748 : LOGICAL, DIMENSION(5) :: ieee_halt
749 : #endif
750 : INTEGER :: omp_max_threads_restore
751 : #endif
752 :
753 490 : use_gauxc_model = .FALSE.
754 490 : IF (PRESENT(model)) THEN
755 490 : model_key = ADJUSTL(model)
756 490 : CALL uppercase(model_key)
757 490 : use_gauxc_model = (TRIM(model_key) /= "" .AND. TRIM(model_key) /= "NONE")
758 : END IF
759 :
760 490 : IF (.NOT. ALLOCATED(res%vxc_scalar)) THEN
761 1960 : ALLOCATE (res%vxc_scalar, mold=density_scalar)
762 : ELSE
763 0 : CPASSERT(ALL(SHAPE(res%vxc_scalar) == SHAPE(density_scalar)))
764 : END IF
765 144990 : res%vxc_scalar = 0._dp
766 :
767 490 : IF (use_gauxc_model) THEN
768 : #ifndef GAUXC_HAS_ONEDFT
769 : CPABORT("GauXC lacks Skala support")
770 : #else
771 : ! Skala may change the OpenMP team size for later parallel regions.
772 : ! Restore max threads only; omp_get_num_threads() is 1 here.
773 28 : omp_max_threads_restore = omp_get_max_threads()
774 : #if defined (__HAS_IEEE_EXCEPTIONS)
775 : CALL ieee_get_halting_mode(IEEE_ALL, ieee_halt)
776 : CALL ieee_set_halting_mode(IEEE_ALL, .FALSE.)
777 : #endif
778 28 : IF (.NOT. ALLOCATED(res%vxc_zeta)) THEN
779 112 : ALLOCATE (res%vxc_zeta, mold=density_scalar)
780 : ELSE
781 0 : CPASSERT(ALL(SHAPE(res%vxc_zeta) == SHAPE(density_scalar)))
782 : END IF
783 2828 : res%vxc_zeta = 0._dp
784 :
785 28 : IF (nspins == 1) THEN
786 80 : ALLOCATE (density_zeta_zero, mold=density_scalar)
787 20 : density_zeta_zero = 0._dp
788 : CALL gauxc_integrator_eval_exc_vxc_onedft_uks( &
789 : status%status, &
790 : integrator%integrator, &
791 : density_scalar, &
792 : density_zeta_zero, &
793 : TRIM(model), &
794 : res%exc, &
795 : res%vxc_scalar, &
796 2300 : res%vxc_zeta)
797 20 : DEALLOCATE (density_zeta_zero)
798 : ELSE
799 8 : CPASSERT(PRESENT(density_zeta))
800 : CALL gauxc_integrator_eval_exc_vxc_onedft_uks( &
801 : status%status, &
802 : integrator%integrator, &
803 : density_scalar, &
804 : density_zeta, &
805 : TRIM(model), &
806 : res%exc, &
807 : res%vxc_scalar, &
808 1048 : res%vxc_zeta)
809 : END IF
810 : #if defined (__HAS_IEEE_EXCEPTIONS)
811 : CALL ieee_set_halting_mode(IEEE_ALL, ieee_halt)
812 : #endif
813 28 : CALL omp_set_num_threads(omp_max_threads_restore)
814 28 : GAUXC_RETURN_IF_ERROR(status)
815 28 : RETURN
816 : #endif
817 : END IF
818 :
819 462 : IF (nspins == 1) THEN
820 : ! xmat factor 2 is applied by both CP2K and GauXC
821 : ! "unapply" it here to even things back out.
822 : ! This is NOT necessary in the Skala branch.
823 1792 : ALLOCATE (density_scalar_rks, mold=density_scalar)
824 137360 : density_scalar_rks(:, :) = 0.5_dp*density_scalar
825 : CALL gauxc_integrator_eval_exc_vxc_rks( &
826 : status%status, &
827 : integrator%integrator, &
828 : density_scalar_rks, &
829 : res%exc, &
830 448 : res%vxc_scalar)
831 448 : DEALLOCATE (density_scalar_rks)
832 : ELSE
833 14 : CPASSERT(PRESENT(density_zeta))
834 :
835 14 : IF (.NOT. ALLOCATED(res%vxc_zeta)) THEN
836 56 : ALLOCATE (res%vxc_zeta, mold=density_zeta)
837 : ELSE
838 0 : CPASSERT(ALL(SHAPE(res%vxc_zeta) == SHAPE(density_scalar)))
839 : END IF
840 4802 : res%vxc_zeta = 0._dp
841 :
842 : CALL gauxc_integrator_eval_exc_vxc_uks( &
843 : status%status, &
844 : integrator%integrator, &
845 : density_scalar, &
846 : density_zeta, &
847 : res%exc, &
848 : res%vxc_scalar, &
849 9590 : res%vxc_zeta)
850 : END IF
851 462 : GAUXC_RETURN_IF_ERROR(status)
852 :
853 : #else
854 : MARK_USED(integrator)
855 : MARK_USED(density_scalar)
856 : MARK_USED(density_zeta)
857 : MARK_USED(nspins)
858 : MARK_USED(status)
859 : MARK_USED(model)
860 : CPABORT(no_gauxc_message)
861 : #endif
862 980 : END FUNCTION gauxc_compute_xc
863 :
864 : ! **************************************************************************************************
865 : !> \brief ...
866 : !> \param integrator ...
867 : !> \param density_scalar ...
868 : !> \param density_zeta ...
869 : !> \param nspins ...
870 : !> \param natom ...
871 : !> \param status ...
872 : !> \param model ...
873 : !> \return ...
874 : ! **************************************************************************************************
875 8 : FUNCTION gauxc_compute_xc_gradient( &
876 : integrator, &
877 8 : density_scalar, &
878 4 : density_zeta, &
879 : nspins, &
880 : natom, &
881 : status, &
882 4 : model) RESULT(res)
883 :
884 : TYPE(cp_gauxc_integrator_type), INTENT(IN) :: integrator
885 : REAL(c_double), DIMENSION(:, :), INTENT(IN) :: density_scalar
886 : REAL(c_double), DIMENSION(:, :), INTENT(IN), &
887 : OPTIONAL :: density_zeta
888 : INTEGER, INTENT(IN) :: nspins, natom
889 : TYPE(cp_gauxc_status_type), INTENT(OUT) :: status
890 : CHARACTER(len=*), INTENT(IN), OPTIONAL :: model
891 : TYPE(cp_gauxc_xc_gradient_type) :: res
892 :
893 : #ifdef __GAUXC
894 : CHARACTER(len=default_path_length) :: model_key
895 : LOGICAL :: use_gauxc_model
896 4 : REAL(c_double), ALLOCATABLE, DIMENSION(:, :) :: density_scalar_rks
897 : #ifdef GAUXC_HAS_ONEDFT
898 4 : REAL(c_double), ALLOCATABLE, DIMENSION(:, :) :: density_zeta_zero
899 : #if defined (__HAS_IEEE_EXCEPTIONS)
900 : LOGICAL, DIMENSION(5) :: ieee_halt
901 : #endif
902 : INTEGER :: omp_max_threads_restore
903 : #endif
904 :
905 12 : ALLOCATE (res%exc_grad(3*natom))
906 40 : res%exc_grad = 0._dp
907 :
908 4 : use_gauxc_model = .FALSE.
909 4 : IF (PRESENT(model)) THEN
910 4 : model_key = ADJUSTL(model)
911 4 : CALL uppercase(model_key)
912 4 : use_gauxc_model = (TRIM(model_key) /= "" .AND. TRIM(model_key) /= "NONE")
913 : END IF
914 :
915 : IF (use_gauxc_model) THEN
916 : #ifndef GAUXC_HAS_ONEDFT
917 : CPABORT("GauXC lacks Skala support")
918 : #else
919 : ! Skala may change the OpenMP team size for later parallel regions.
920 : ! Restore max threads only; omp_get_num_threads() is 1 here.
921 0 : omp_max_threads_restore = omp_get_max_threads()
922 : #if defined (__HAS_IEEE_EXCEPTIONS)
923 : CALL ieee_get_halting_mode(IEEE_ALL, ieee_halt)
924 : CALL ieee_set_halting_mode(IEEE_ALL, .FALSE.)
925 : #endif
926 0 : IF (nspins == 1) THEN
927 0 : ALLOCATE (density_zeta_zero, mold=density_scalar)
928 0 : density_zeta_zero = 0._dp
929 : CALL gauxc_integrator_eval_exc_grad_onedft_uks( &
930 : status%status, &
931 : integrator%integrator, &
932 : density_scalar, &
933 : density_zeta_zero, &
934 : TRIM(model), &
935 0 : res%exc_grad)
936 0 : DEALLOCATE (density_zeta_zero)
937 : ELSE
938 0 : CPASSERT(PRESENT(density_zeta))
939 : CALL gauxc_integrator_eval_exc_grad_onedft_uks( &
940 : status%status, &
941 : integrator%integrator, &
942 : density_scalar, &
943 : density_zeta, &
944 : TRIM(model), &
945 0 : res%exc_grad)
946 : END IF
947 : #if defined (__HAS_IEEE_EXCEPTIONS)
948 : CALL ieee_set_halting_mode(IEEE_ALL, ieee_halt)
949 : #endif
950 0 : CALL omp_set_num_threads(omp_max_threads_restore)
951 0 : GAUXC_RETURN_IF_ERROR(status)
952 0 : RETURN
953 : #endif
954 : END IF
955 :
956 4 : IF (nspins == 1) THEN
957 16 : ALLOCATE (density_scalar_rks, mold=density_scalar)
958 1848 : density_scalar_rks(:, :) = 0.5_dp*density_scalar
959 : CALL gauxc_integrator_eval_exc_grad_rks( &
960 : status%status, &
961 : integrator%integrator, &
962 : density_scalar_rks, &
963 4 : res%exc_grad)
964 4 : DEALLOCATE (density_scalar_rks)
965 : ELSE
966 0 : CPASSERT(PRESENT(density_zeta))
967 : CALL gauxc_integrator_eval_exc_grad_uks( &
968 : status%status, &
969 : integrator%integrator, &
970 : density_scalar, &
971 : density_zeta, &
972 0 : res%exc_grad)
973 : END IF
974 4 : GAUXC_RETURN_IF_ERROR(status)
975 :
976 : #else
977 : MARK_USED(density_scalar)
978 : MARK_USED(density_zeta)
979 : MARK_USED(res)
980 : MARK_USED(integrator)
981 : MARK_USED(model)
982 : MARK_USED(natom)
983 : MARK_USED(nspins)
984 : MARK_USED(status)
985 : CPABORT(no_gauxc_message)
986 : #endif
987 8 : END FUNCTION gauxc_compute_xc_gradient
988 :
989 : ! **************************************************************************************************
990 : !> \brief ...
991 : !> \param molecule ...
992 : !> \param status ...
993 : ! **************************************************************************************************
994 66 : SUBROUTINE gauxc_destroy_molecule(molecule, status)
995 : TYPE(cp_gauxc_molecule_type), INTENT(INOUT) :: molecule
996 : TYPE(cp_gauxc_status_type), INTENT(OUT) :: status
997 :
998 : #ifdef __GAUXC
999 66 : CALL gauxc_delete(status%status, molecule%molecule)
1000 66 : GAUXC_RETURN_IF_ERROR(status)
1001 : #else
1002 : MARK_USED(molecule)
1003 : MARK_USED(status)
1004 : CPABORT(no_gauxc_message)
1005 : #endif
1006 : END SUBROUTINE gauxc_destroy_molecule
1007 :
1008 : ! **************************************************************************************************
1009 : !> \brief ...
1010 : !> \param basis ...
1011 : !> \param status ...
1012 : ! **************************************************************************************************
1013 66 : SUBROUTINE gauxc_destroy_basisset(basis, status)
1014 : TYPE(cp_gauxc_basisset_type), INTENT(INOUT) :: basis
1015 : TYPE(cp_gauxc_status_type), INTENT(OUT) :: status
1016 :
1017 : #ifdef __GAUXC
1018 66 : CALL gauxc_delete(status%status, basis%basis)
1019 66 : GAUXC_RETURN_IF_ERROR(status)
1020 : #else
1021 : MARK_USED(basis)
1022 : MARK_USED(status)
1023 : CPABORT(no_gauxc_message)
1024 : #endif
1025 : END SUBROUTINE gauxc_destroy_basisset
1026 :
1027 : ! **************************************************************************************************
1028 : !> \brief ...
1029 : !> \param grid_result ...
1030 : !> \param status ...
1031 : ! **************************************************************************************************
1032 66 : SUBROUTINE gauxc_destroy_grid(grid_result, status)
1033 : TYPE(cp_gauxc_grid_type), INTENT(INOUT) :: grid_result
1034 : TYPE(cp_gauxc_status_type), INTENT(OUT) :: status
1035 :
1036 : #ifdef __GAUXC
1037 66 : CALL gauxc_delete(status%status, grid_result%mw)
1038 66 : GAUXC_RETURN_IF_ERROR(status)
1039 66 : CALL gauxc_delete(status%status, grid_result%mwf)
1040 66 : GAUXC_RETURN_IF_ERROR(status)
1041 66 : CALL gauxc_delete(status%status, grid_result%lb)
1042 66 : GAUXC_RETURN_IF_ERROR(status)
1043 66 : CALL gauxc_delete(status%status, grid_result%lbf)
1044 66 : GAUXC_RETURN_IF_ERROR(status)
1045 66 : CALL gauxc_delete(status%status, grid_result%grid)
1046 66 : GAUXC_RETURN_IF_ERROR(status)
1047 66 : IF (grid_result%owns_rt) THEN
1048 54 : CALL gauxc_runtime_environment_delete(status%status, grid_result%rt)
1049 54 : GAUXC_RETURN_IF_ERROR(status)
1050 54 : grid_result%owns_rt = .FALSE.
1051 : END IF
1052 : #else
1053 : MARK_USED(grid_result)
1054 : MARK_USED(status)
1055 : CPABORT(no_gauxc_message)
1056 : #endif
1057 : END SUBROUTINE gauxc_destroy_grid
1058 :
1059 : ! **************************************************************************************************
1060 : !> \brief ...
1061 : !> \param integrator_result ...
1062 : !> \param status ...
1063 : ! **************************************************************************************************
1064 66 : SUBROUTINE gauxc_destroy_integrator(integrator_result, status)
1065 : TYPE(cp_gauxc_integrator_type), INTENT(INOUT) :: integrator_result
1066 : TYPE(cp_gauxc_status_type), INTENT(OUT) :: status
1067 :
1068 : #ifdef __GAUXC
1069 66 : CALL gauxc_delete(status%status, integrator_result%integrator)
1070 66 : GAUXC_RETURN_IF_ERROR(status)
1071 66 : CALL gauxc_delete(status%status, integrator_result%func)
1072 66 : GAUXC_RETURN_IF_ERROR(status)
1073 : #else
1074 : MARK_USED(integrator_result)
1075 : MARK_USED(status)
1076 : CPABORT(no_gauxc_message)
1077 : #endif
1078 : END SUBROUTINE gauxc_destroy_integrator
1079 :
1080 : ! **************************************************************************************************
1081 : !> \brief Checks gauxc status and prints error message before aborting
1082 : !> \param status the gauxc status to check
1083 : ! **************************************************************************************************
1084 22056 : SUBROUTINE gauxc_check_status(status)
1085 : TYPE(cp_gauxc_status_type), INTENT(IN) :: status
1086 :
1087 : #ifdef __GAUXC
1088 22056 : IF (status%status%code /= 0) THEN
1089 0 : CALL print_gauxc_status_message(status)
1090 0 : CPABORT("GauXC returned with non-zero status code")
1091 : END IF
1092 : #else
1093 : MARK_USED(status)
1094 : #endif
1095 22056 : END SUBROUTINE gauxc_check_status
1096 :
1097 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1098 : ! From here on, it's private helpers !
1099 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1100 :
1101 : #ifdef __GAUXC
1102 :
1103 : ! **************************************************************************************************
1104 : !> \brief ...
1105 : !> \param spec ...
1106 : !> \return ...
1107 : ! **************************************************************************************************
1108 198 : PURE FUNCTION read_execution_space(spec) RESULT(val)
1109 : CHARACTER(len=*), INTENT(IN) :: spec
1110 : INTEGER(c_int) :: val
1111 :
1112 198 : CHARACTER(len=LEN(spec)) :: spec_upper
1113 :
1114 198 : spec_upper = spec
1115 198 : CALL uppercase(spec_upper)
1116 :
1117 : SELECT CASE (spec_upper)
1118 : CASE ("HOST")
1119 0 : val = gauxc_executionspace%host
1120 : CASE ("DEVICE")
1121 0 : val = gauxc_executionspace%device
1122 : CASE DEFAULT
1123 198 : val = gauxc_executionspace%host
1124 : END SELECT
1125 198 : END FUNCTION read_execution_space
1126 :
1127 : ! **************************************************************************************************
1128 : !> \brief ...
1129 : !> \param spec ...
1130 : !> \return ...
1131 : ! **************************************************************************************************
1132 66 : PURE FUNCTION read_atomic_grid_size(spec) RESULT(val)
1133 : CHARACTER(len=*), INTENT(IN) :: spec
1134 : INTEGER(c_int) :: val
1135 :
1136 66 : CHARACTER(len=LEN(spec)) :: spec_upper
1137 :
1138 66 : spec_upper = spec
1139 66 : CALL uppercase(spec_upper)
1140 :
1141 : SELECT CASE (spec_upper)
1142 : CASE ("FINE")
1143 0 : val = gauxc_atomicgridsizedefault%finegrid
1144 : CASE ("ULTRAFINE")
1145 0 : val = gauxc_atomicgridsizedefault%ultrafinegrid
1146 : CASE ("SUPERFINE")
1147 0 : val = gauxc_atomicgridsizedefault%superfinegrid
1148 : CASE ("GM3")
1149 0 : val = gauxc_atomicgridsizedefault%gm3
1150 : CASE ("GM5")
1151 0 : val = gauxc_atomicgridsizedefault%gm5
1152 : CASE DEFAULT
1153 66 : val = gauxc_atomicgridsizedefault%finegrid
1154 : END SELECT
1155 66 : END FUNCTION read_atomic_grid_size
1156 :
1157 : ! **************************************************************************************************
1158 : !> \brief ...
1159 : !> \param spec ...
1160 : !> \return ...
1161 : ! **************************************************************************************************
1162 66 : PURE FUNCTION read_radial_quad(spec) RESULT(val)
1163 : CHARACTER(len=*), INTENT(IN) :: spec
1164 : INTEGER(c_int) :: val
1165 :
1166 66 : CHARACTER(len=LEN(spec)) :: spec_upper
1167 :
1168 66 : spec_upper = spec
1169 66 : CALL uppercase(spec_upper)
1170 :
1171 : SELECT CASE (spec_upper)
1172 : CASE ("BECKE")
1173 66 : val = gauxc_radialquad%becke
1174 : CASE ("MURAKNOWLES")
1175 66 : val = gauxc_radialquad%mura_knowles
1176 : CASE ("TREUTLERAHLRICHS")
1177 0 : val = gauxc_radialquad%treutler_ahlrichs
1178 : CASE ("MURRAYHANDYLAMING")
1179 0 : val = gauxc_radialquad%murray_handy_laming
1180 : CASE DEFAULT
1181 66 : val = gauxc_radialquad%mura_knowles
1182 : END SELECT
1183 66 : END FUNCTION read_radial_quad
1184 :
1185 : ! **************************************************************************************************
1186 : !> \brief ...
1187 : !> \param spec ...
1188 : !> \return ...
1189 : ! **************************************************************************************************
1190 66 : PURE FUNCTION read_pruning_scheme(spec) RESULT(val)
1191 : CHARACTER(len=*), INTENT(IN) :: spec
1192 : INTEGER(c_int) :: val
1193 :
1194 66 : CHARACTER(len=LEN(spec)) :: spec_upper
1195 :
1196 66 : spec_upper = spec
1197 66 : CALL uppercase(spec_upper)
1198 :
1199 : SELECT CASE (spec_upper)
1200 : CASE ("UNPRUNED")
1201 66 : val = gauxc_pruningscheme%unpruned
1202 : CASE ("ROBUST")
1203 66 : val = gauxc_pruningscheme%robust
1204 : CASE ("TREUTLER")
1205 0 : val = gauxc_pruningscheme%treutler
1206 : CASE DEFAULT
1207 66 : val = gauxc_pruningscheme%robust
1208 : END SELECT
1209 66 : END FUNCTION read_pruning_scheme
1210 :
1211 : #endif
1212 :
1213 : ! **************************************************************************************************
1214 : !> \brief Write molecule data to HDF5 file for debugging
1215 : !> \param molecule ...
1216 : !> \param output_path ...
1217 : !> \param filename ...
1218 : !> \param dataset ...
1219 : !> \param status ...
1220 : ! **************************************************************************************************
1221 0 : SUBROUTINE gauxc_write_molecule_hdf5(molecule, output_path, filename, dataset, status)
1222 : TYPE(cp_gauxc_molecule_type), INTENT(IN) :: molecule
1223 : CHARACTER(len=*), INTENT(IN) :: output_path, filename, dataset
1224 : TYPE(cp_gauxc_status_type), INTENT(INOUT) :: status
1225 :
1226 : #if defined(__GAUXC) && defined(GAUXC_HAS_HDF5)
1227 : CHARACTER(len=default_path_length) :: full_path
1228 :
1229 : full_path = TRIM(output_path)//"/"//TRIM(filename)
1230 : CALL gauxc_write_hdf5_record(status%status, molecule%molecule, full_path, dataset)
1231 : #else
1232 : MARK_USED(molecule)
1233 : MARK_USED(output_path)
1234 : MARK_USED(filename)
1235 : MARK_USED(dataset)
1236 : MARK_USED(status)
1237 0 : CPABORT("GauXC HDF5 output requires GauXC to be built with HDF5 support.")
1238 : #endif
1239 0 : END SUBROUTINE gauxc_write_molecule_hdf5
1240 :
1241 : ! **************************************************************************************************
1242 : !> \brief Write basis set data to HDF5 file for debugging
1243 : !> \param basis ...
1244 : !> \param output_path ...
1245 : !> \param filename ...
1246 : !> \param dataset ...
1247 : !> \param status ...
1248 : ! **************************************************************************************************
1249 0 : SUBROUTINE gauxc_write_basisset_hdf5(basis, output_path, filename, dataset, status)
1250 : TYPE(cp_gauxc_basisset_type), INTENT(IN) :: basis
1251 : CHARACTER(len=*), INTENT(IN) :: output_path, filename, dataset
1252 : TYPE(cp_gauxc_status_type), INTENT(INOUT) :: status
1253 :
1254 : #if defined(__GAUXC) && defined(GAUXC_HAS_HDF5)
1255 : CHARACTER(len=default_path_length) :: full_path
1256 :
1257 : full_path = TRIM(output_path)//"/"//TRIM(filename)
1258 : CALL gauxc_write_hdf5_record(status%status, basis%basis, full_path, dataset)
1259 : #else
1260 : MARK_USED(basis)
1261 : MARK_USED(output_path)
1262 : MARK_USED(filename)
1263 : MARK_USED(dataset)
1264 : MARK_USED(status)
1265 0 : CPABORT("GauXC HDF5 output requires GauXC to be built with HDF5 support.")
1266 : #endif
1267 0 : END SUBROUTINE gauxc_write_basisset_hdf5
1268 :
1269 0 : END MODULE xc_gauxc_interface
|
