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 10324 : 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 10324 : IF (PRESENT(mpi_comm)) THEN
317 10324 : rt = gauxc_runtime_environment_new(status%status, mpi_comm)
318 10324 : rt_mpi_comm = mpi_comm
319 10324 : 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 10324 : 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 10324 : SUBROUTINE gauxc_finalize(status)
343 : TYPE(cp_gauxc_status_type), INTENT(OUT) :: status
344 :
345 : #ifdef __GAUXC
346 10324 : CALL gauxc_runtime_environment_delete(status%status, rt)
347 10324 : GAUXC_RETURN_IF_ERROR(status)
348 10324 : rt_mpi_comm = -1
349 10324 : 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 756 : 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 378 : TYPE(gauxc_atom_type), ALLOCATABLE, DIMENSION(:) :: atoms
371 :
372 378 : natoms = SIZE(particle_set)
373 1134 : ALLOCATE (atoms(natoms))
374 :
375 1350 : DO i = 1, natoms
376 972 : atomic_kind => particle_set(i)%atomic_kind
377 972 : CALL get_atomic_kind(atomic_kind, element_symbol=element_symbol)
378 972 : CALL get_ptable_info(element_symbol, number=atomic_number)
379 972 : atoms(i)%atomic_number = INT(atomic_number, c_int64_t)
380 972 : atoms(i)%x = REAL(particle_set(i)%r(1), c_double)
381 972 : atoms(i)%y = REAL(particle_set(i)%r(2), c_double)
382 1350 : atoms(i)%z = REAL(particle_set(i)%r(3), c_double)
383 : END DO
384 :
385 378 : res%molecule = gauxc_molecule_new_from_atoms(status%status, atoms, INT(natoms, c_size_t))
386 378 : GAUXC_RETURN_IF_ERROR(status)
387 :
388 378 : 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 756 : 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 756 : 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 378 : 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 378 : nkind = SIZE(qs_kind_set)
422 378 : natoms = SIZE(particle_set)
423 :
424 1630 : ALLOCATE (basis_set_list(nkind))
425 378 : CALL basis_set_list_setup(basis_set_list, "ORB", qs_kind_set)
426 :
427 378 : nshell_total = 0
428 1350 : DO iatom = 1, natoms
429 972 : atomic_kind => particle_set(iatom)%atomic_kind
430 972 : CALL get_atomic_kind(atomic_kind, kind_number=ikind)
431 972 : gto_basis => basis_set_list(ikind)%gto_basis_set
432 972 : CPASSERT(ASSOCIATED(gto_basis))
433 : ! CALL write_gto_basis_set(gto_basis, 6, "–––––GAUXC-CREATE-BASISSET–––––")
434 4208 : nshell_total = nshell_total + SUM(gto_basis%nshell)
435 : END DO
436 :
437 4260 : ALLOCATE (shells(nshell_total))
438 :
439 1350 : shell_index = 0
440 1350 : res%max_l = -1
441 1350 : DO iatom = 1, natoms ! for each atom
442 972 : atomic_kind => particle_set(iatom)%atomic_kind
443 972 : CALL get_atomic_kind(atomic_kind, kind_number=ikind)
444 972 : gto_basis => basis_set_list(ikind)%gto_basis_set
445 972 : CPASSERT(ASSOCIATED(gto_basis))
446 :
447 972 : shell_origin(1) = REAL(particle_set(iatom)%r(1), c_double)
448 972 : shell_origin(2) = REAL(particle_set(iatom)%r(2), c_double)
449 972 : shell_origin(3) = REAL(particle_set(iatom)%r(3), c_double)
450 :
451 972 : nset = gto_basis%nset
452 972 : CPASSERT(nset == SIZE(gto_basis%nshell))
453 4208 : DO iset = 1, nset ! for each shell group
454 1886 : nshell = gto_basis%nshell(iset)
455 1886 : npgf = gto_basis%npgf(iset) ! corresponds with nprim of gauxc
456 :
457 5984 : DO ishell = 1, gto_basis%nshell(iset) ! for each shell within the shell group
458 3126 : shell_index = shell_index + 1 ! global shell index, flattened over atoms and groups
459 3126 : lval = gto_basis%l(ishell, iset)
460 3126 : res%max_l = MAX(res%max_l, lval)
461 3126 : shells(shell_index)%l = INT(lval, c_int32_t)
462 : ! FIXME hardcoded true param
463 : ! pure=1: spherical Gaussians; pure=0: cartesian Gaussians
464 3126 : shells(shell_index)%pure = .TRUE._c_bool
465 3126 : shells(shell_index)%nprim = INT(npgf, c_int32_t)
466 12504 : shells(shell_index)%origin = shell_origin
467 :
468 15134 : DO iprim = 1, npgf
469 : shells(shell_index)%exponents(iprim) = &
470 10122 : 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 13248 : 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 378 : normalize=.FALSE.)
483 378 : GAUXC_RETURN_IF_ERROR(status)
484 :
485 378 : DEALLOCATE (shells)
486 378 : 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 756 : 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 : !> \return ...
510 : ! **************************************************************************************************
511 382 : FUNCTION gauxc_create_grid( &
512 : molecule, &
513 : basis, &
514 : grid_type, &
515 : radial_quadrature, &
516 : pruning_scheme, &
517 : lb_exec_space, &
518 : batch_size, &
519 : device_runtime_fill_fraction, &
520 : status, &
521 382 : mpi_comm) RESULT(res)
522 :
523 : TYPE(cp_gauxc_molecule_type), INTENT(IN) :: molecule
524 : TYPE(cp_gauxc_basisset_type), INTENT(in) :: basis
525 : CHARACTER(len=*) :: grid_type, lb_exec_space, &
526 : pruning_scheme, radial_quadrature
527 : INTEGER :: batch_size
528 : REAL(c_double), INTENT(IN) :: device_runtime_fill_fraction
529 : TYPE(cp_gauxc_status_type), INTENT(OUT) :: status
530 : INTEGER, INTENT(IN), OPTIONAL :: mpi_comm
531 : TYPE(cp_gauxc_grid_type) :: res
532 :
533 : #ifdef __GAUXC
534 : INTEGER(c_int) :: grid_type_local, int_exec_space_local, &
535 : lb_exec_space_local, &
536 : pruning_scheme_local, radial_quad_local
537 : LOGICAL :: use_device_runtime
538 :
539 382 : grid_type_local = read_atomic_grid_size(grid_type)
540 382 : radial_quad_local = read_radial_quad(radial_quadrature)
541 382 : pruning_scheme_local = read_pruning_scheme(pruning_scheme)
542 382 : lb_exec_space_local = read_execution_space(lb_exec_space)
543 382 : int_exec_space_local = read_execution_space("host")
544 382 : use_device_runtime = (lb_exec_space_local == gauxc_executionspace%device)
545 382 : res%owns_rt = .FALSE.
546 :
547 382 : IF (use_device_runtime) THEN
548 : #ifdef GAUXC_HAS_DEVICE
549 : #if defined(GAUXC_HAS_MPI) && defined(__parallel)
550 : IF (PRESENT(mpi_comm)) THEN
551 : res%rt = gauxc_device_runtime_environment_new( &
552 : status%status, mpi_comm, device_runtime_fill_fraction)
553 : ELSE
554 : res%rt = gauxc_device_runtime_environment_new( &
555 : status%status, device_runtime_fill_fraction)
556 : END IF
557 : #else
558 : MARK_USED(mpi_comm)
559 : res%rt = gauxc_device_runtime_environment_new( &
560 : status%status, device_runtime_fill_fraction)
561 : #endif
562 : GAUXC_RETURN_IF_ERROR(status)
563 : res%owns_rt = .TRUE.
564 : #else
565 : MARK_USED(device_runtime_fill_fraction)
566 0 : CPABORT("GauXC was built without device runtime support")
567 : #endif
568 : ELSE
569 : #if defined(GAUXC_HAS_MPI) && defined(__parallel)
570 382 : IF (PRESENT(mpi_comm)) THEN
571 : ! Reuse the global runtime when the requested communicator matches
572 : ! the communicator used during gauxc_init.
573 382 : IF (.NOT. rt_has_mpi_comm .OR. mpi_comm /= rt_mpi_comm) THEN
574 92 : res%rt = gauxc_runtime_environment_new(status%status, mpi_comm)
575 92 : GAUXC_RETURN_IF_ERROR(status)
576 : res%owns_rt = .TRUE.
577 : END IF
578 : END IF
579 : #else
580 : MARK_USED(mpi_comm)
581 : #endif
582 : END IF
583 :
584 : res%grid = gauxc_molgrid_new_default( &
585 : status%status, &
586 : molecule%molecule, &
587 : pruning_scheme_local, &
588 : INT(batch_size, c_int64_t), &
589 : radial_quad_local, &
590 382 : grid_type_local)
591 382 : GAUXC_RETURN_IF_ERROR(status)
592 :
593 : res%lbf = gauxc_load_balancer_factory_new( &
594 : status%status, &
595 382 : lb_exec_space_local)
596 382 : GAUXC_RETURN_IF_ERROR(status)
597 :
598 382 : IF (res%owns_rt) THEN
599 : res%lb = gauxc_load_balancer_factory_get_instance( &
600 : status%status, &
601 : res%lbf, &
602 : res%rt, &
603 : molecule%molecule, &
604 : res%grid, &
605 92 : basis%basis)
606 : ELSE
607 : res%lb = gauxc_load_balancer_factory_get_instance( &
608 : status%status, &
609 : res%lbf, &
610 : rt, &
611 : molecule%molecule, &
612 : res%grid, &
613 290 : basis%basis)
614 : END IF
615 382 : GAUXC_RETURN_IF_ERROR(status)
616 :
617 : res%mwf = gauxc_molecular_weights_factory_new( &
618 : status%status, &
619 382 : int_exec_space_local)
620 382 : GAUXC_RETURN_IF_ERROR(status)
621 :
622 : res%mw = gauxc_get_instance( &
623 : status%status, &
624 382 : res%mwf)
625 382 : GAUXC_RETURN_IF_ERROR(status)
626 :
627 : CALL gauxc_molecular_weights_modify_weights( &
628 : status%status, &
629 : res%mw, &
630 382 : res%lb)
631 382 : GAUXC_RETURN_IF_ERROR(status)
632 :
633 : #else
634 : MARK_USED(basis)
635 : MARK_USED(batch_size)
636 : MARK_USED(device_runtime_fill_fraction)
637 : MARK_USED(grid_type)
638 : MARK_USED(lb_exec_space)
639 : MARK_USED(mpi_comm)
640 : MARK_USED(molecule)
641 : MARK_USED(pruning_scheme)
642 : MARK_USED(radial_quadrature)
643 : MARK_USED(res)
644 : MARK_USED(status)
645 : CPABORT(no_gauxc_message)
646 : #endif
647 764 : END FUNCTION gauxc_create_grid
648 :
649 : ! **************************************************************************************************
650 : !> \brief ...
651 : !> \param xc_functional_name ...
652 : !> \param grid ...
653 : !> \param int_exec_space ...
654 : !> \param lwd_kernel ...
655 : !> \param nspins ...
656 : !> \param status ...
657 : !> \return ...
658 : ! **************************************************************************************************
659 382 : FUNCTION gauxc_create_integrator( &
660 : xc_functional_name, &
661 : grid, &
662 : int_exec_space, &
663 : lwd_kernel, &
664 : nspins, &
665 382 : status) RESULT(res)
666 :
667 : CHARACTER(len=*), INTENT(IN) :: xc_functional_name, int_exec_space, &
668 : lwd_kernel
669 : TYPE(cp_gauxc_grid_type), INTENT(IN) :: grid
670 : INTEGER, INTENT(IN) :: nspins
671 : TYPE(cp_gauxc_status_type), INTENT(OUT) :: status
672 : TYPE(cp_gauxc_integrator_type) :: res
673 :
674 : #ifdef __GAUXC
675 : INTEGER(c_int) :: int_exec_space_local
676 : LOGICAL(c_bool) :: polarized
677 :
678 382 : polarized = (nspins == 2)
679 : res%func = gauxc_functional_from_string( &
680 : status%status, &
681 : xc_functional_name, &
682 764 : polarized)
683 382 : GAUXC_RETURN_IF_ERROR(status)
684 :
685 382 : int_exec_space_local = read_execution_space(int_exec_space)
686 : res%integrator = gauxc_integrator_new( &
687 : status%status, &
688 : res%func, &
689 : grid%lb, &
690 : int_exec_space_local, &
691 382 : local_work_kernel_name=TRIM(lwd_kernel))
692 382 : GAUXC_RETURN_IF_ERROR(status)
693 :
694 : #else
695 : MARK_USED(grid)
696 : MARK_USED(int_exec_space)
697 : MARK_USED(lwd_kernel)
698 : MARK_USED(nspins)
699 : MARK_USED(res)
700 : MARK_USED(status)
701 : MARK_USED(xc_functional_name)
702 : CPABORT(no_gauxc_message)
703 : #endif
704 764 : END FUNCTION gauxc_create_integrator
705 :
706 : ! **************************************************************************************************
707 : !> \brief ...
708 : !> \param integrator ...
709 : !> \param density_scalar ...
710 : !> \param density_zeta ...
711 : !> \param nspins ...
712 : !> \param status ...
713 : !> \param model ...
714 : !> \return ...
715 : ! **************************************************************************************************
716 756 : FUNCTION gauxc_compute_xc( &
717 : integrator, &
718 756 : density_scalar, &
719 378 : density_zeta, &
720 : nspins, &
721 : status, &
722 378 : model) RESULT(res)
723 :
724 : TYPE(cp_gauxc_integrator_type), INTENT(IN) :: integrator
725 : ! Must be inout since we need to modify the matrix for some code paths
726 : REAL(c_double), DIMENSION(:, :) :: density_scalar
727 : REAL(c_double), DIMENSION(:, :), INTENT(IN), &
728 : OPTIONAL :: density_zeta
729 : INTEGER, INTENT(IN) :: nspins
730 : TYPE(cp_gauxc_status_type), INTENT(OUT) :: status
731 : CHARACTER(len=*), INTENT(IN), OPTIONAL :: model
732 : TYPE(cp_gauxc_xc_type) :: res
733 :
734 : #ifdef __GAUXC
735 : CHARACTER(len=default_path_length) :: model_key
736 : LOGICAL :: use_onedft
737 : #ifdef GAUXC_HAS_ONEDFT
738 378 : REAL(c_double), ALLOCATABLE, DIMENSION(:, :) :: density_zeta_zero
739 : #if defined (__HAS_IEEE_EXCEPTIONS)
740 : LOGICAL, DIMENSION(5) :: ieee_halt
741 : #endif
742 : INTEGER :: omp_max_threads_restore
743 : #endif
744 :
745 378 : use_onedft = .FALSE.
746 378 : IF (PRESENT(model)) THEN
747 378 : model_key = ADJUSTL(model)
748 378 : CALL uppercase(model_key)
749 378 : use_onedft = (TRIM(model_key) /= "" .AND. TRIM(model_key) /= "NONE")
750 : END IF
751 :
752 378 : IF (.NOT. ALLOCATED(res%vxc_scalar)) THEN
753 1512 : ALLOCATE (res%vxc_scalar, mold=density_scalar)
754 : ELSE
755 0 : CPASSERT(ALL(SHAPE(res%vxc_scalar) == SHAPE(density_scalar)))
756 : END IF
757 118518 : res%vxc_scalar = 0._dp
758 :
759 378 : IF (use_onedft) THEN
760 : #ifndef GAUXC_HAS_ONEDFT
761 : CPABORT("GauXC lacks OneDFT support")
762 : #else
763 : ! OneDFT may change the OpenMP team size for later parallel regions.
764 : ! Restore max threads only; omp_get_num_threads() is 1 here.
765 354 : omp_max_threads_restore = omp_get_max_threads()
766 : #if defined (__HAS_IEEE_EXCEPTIONS)
767 : CALL ieee_get_halting_mode(IEEE_ALL, ieee_halt)
768 : CALL ieee_set_halting_mode(IEEE_ALL, .FALSE.)
769 : #endif
770 354 : IF (.NOT. ALLOCATED(res%vxc_zeta)) THEN
771 1416 : ALLOCATE (res%vxc_zeta, mold=density_scalar)
772 : ELSE
773 0 : CPASSERT(ALL(SHAPE(res%vxc_zeta) == SHAPE(density_scalar)))
774 : END IF
775 112462 : res%vxc_zeta = 0._dp
776 :
777 354 : IF (nspins == 1) THEN
778 1328 : ALLOCATE (density_zeta_zero, mold=density_scalar)
779 332 : density_zeta_zero = 0._dp
780 : CALL gauxc_integrator_eval_exc_vxc_onedft_uks( &
781 : status%status, &
782 : integrator%integrator, &
783 : density_scalar, &
784 : density_zeta_zero, &
785 : TRIM(model), &
786 : res%exc, &
787 : res%vxc_scalar, &
788 107132 : res%vxc_zeta)
789 332 : DEALLOCATE (density_zeta_zero)
790 : ELSE
791 22 : CPASSERT(PRESENT(density_zeta))
792 : CALL gauxc_integrator_eval_exc_vxc_onedft_uks( &
793 : status%status, &
794 : integrator%integrator, &
795 : density_scalar, &
796 : density_zeta, &
797 : TRIM(model), &
798 : res%exc, &
799 : res%vxc_scalar, &
800 10638 : res%vxc_zeta)
801 : END IF
802 : #if defined (__HAS_IEEE_EXCEPTIONS)
803 : CALL ieee_set_halting_mode(IEEE_ALL, ieee_halt)
804 : #endif
805 354 : CALL omp_set_num_threads(omp_max_threads_restore)
806 354 : GAUXC_RETURN_IF_ERROR(status)
807 354 : RETURN
808 : #endif
809 : END IF
810 :
811 24 : IF (nspins == 1) THEN
812 : ! xmat factor 2 is applied by both CP2K and GauXC
813 : ! "unapply" it here to even things back out
814 : ! This is NOT necessary in the OneDFT branch
815 6056 : density_scalar = 0.5_dp*density_scalar
816 : CALL gauxc_integrator_eval_exc_vxc_rks( &
817 : status%status, &
818 : integrator%integrator, &
819 : density_scalar, &
820 : res%exc, &
821 6056 : res%vxc_scalar)
822 : ELSE
823 0 : CPASSERT(PRESENT(density_zeta))
824 :
825 0 : IF (.NOT. ALLOCATED(res%vxc_zeta)) THEN
826 0 : ALLOCATE (res%vxc_zeta, mold=density_zeta)
827 : ELSE
828 0 : CPASSERT(ALL(SHAPE(res%vxc_zeta) == SHAPE(density_scalar)))
829 : END IF
830 0 : res%vxc_zeta = 0._dp
831 :
832 : CALL gauxc_integrator_eval_exc_vxc_uks( &
833 : status%status, &
834 : integrator%integrator, &
835 : density_scalar, &
836 : density_zeta, &
837 : res%exc, &
838 : res%vxc_scalar, &
839 0 : res%vxc_zeta)
840 : END IF
841 24 : GAUXC_RETURN_IF_ERROR(status)
842 :
843 : #else
844 : MARK_USED(integrator)
845 : MARK_USED(density_scalar)
846 : MARK_USED(density_zeta)
847 : MARK_USED(nspins)
848 : MARK_USED(status)
849 : MARK_USED(model)
850 : CPABORT(no_gauxc_message)
851 : #endif
852 756 : END FUNCTION gauxc_compute_xc
853 :
854 : ! **************************************************************************************************
855 : !> \brief ...
856 : !> \param integrator ...
857 : !> \param density_scalar ...
858 : !> \param density_zeta ...
859 : !> \param nspins ...
860 : !> \param natom ...
861 : !> \param status ...
862 : !> \param model ...
863 : !> \return ...
864 : ! **************************************************************************************************
865 8 : FUNCTION gauxc_compute_xc_gradient( &
866 : integrator, &
867 8 : density_scalar, &
868 4 : density_zeta, &
869 : nspins, &
870 : natom, &
871 : status, &
872 4 : model) RESULT(res)
873 :
874 : TYPE(cp_gauxc_integrator_type), INTENT(IN) :: integrator
875 : REAL(c_double), DIMENSION(:, :), INTENT(IN) :: density_scalar
876 : REAL(c_double), DIMENSION(:, :), INTENT(IN), &
877 : OPTIONAL :: density_zeta
878 : INTEGER, INTENT(IN) :: nspins, natom
879 : TYPE(cp_gauxc_status_type), INTENT(OUT) :: status
880 : CHARACTER(len=*), INTENT(IN), OPTIONAL :: model
881 : TYPE(cp_gauxc_xc_gradient_type) :: res
882 :
883 : #ifdef __GAUXC
884 : CHARACTER(len=default_path_length) :: model_key
885 : LOGICAL :: use_onedft
886 : #ifdef GAUXC_HAS_ONEDFT
887 4 : REAL(c_double), ALLOCATABLE, DIMENSION(:, :) :: density_zeta_zero
888 : #if defined (__HAS_IEEE_EXCEPTIONS)
889 : LOGICAL, DIMENSION(5) :: ieee_halt
890 : #endif
891 : INTEGER :: omp_max_threads_restore
892 : #endif
893 :
894 12 : ALLOCATE (res%exc_grad(3*natom))
895 40 : res%exc_grad = 0._dp
896 :
897 4 : use_onedft = .FALSE.
898 4 : IF (PRESENT(model)) THEN
899 4 : model_key = ADJUSTL(model)
900 4 : CALL uppercase(model_key)
901 4 : use_onedft = (TRIM(model_key) /= "" .AND. TRIM(model_key) /= "NONE")
902 : END IF
903 :
904 : IF (use_onedft) THEN
905 : #ifndef GAUXC_HAS_ONEDFT
906 : CPABORT("GauXC lacks OneDFT support")
907 : #else
908 : ! OneDFT may change the OpenMP team size for later parallel regions.
909 : ! Restore max threads only; omp_get_num_threads() is 1 here.
910 4 : omp_max_threads_restore = omp_get_max_threads()
911 : #if defined (__HAS_IEEE_EXCEPTIONS)
912 : CALL ieee_get_halting_mode(IEEE_ALL, ieee_halt)
913 : CALL ieee_set_halting_mode(IEEE_ALL, .FALSE.)
914 : #endif
915 4 : IF (nspins == 1) THEN
916 16 : ALLOCATE (density_zeta_zero, mold=density_scalar)
917 4 : density_zeta_zero = 0._dp
918 : CALL gauxc_integrator_eval_exc_grad_onedft_uks( &
919 : status%status, &
920 : integrator%integrator, &
921 : density_scalar, &
922 : density_zeta_zero, &
923 : TRIM(model), &
924 1848 : res%exc_grad)
925 4 : DEALLOCATE (density_zeta_zero)
926 : ELSE
927 0 : CPASSERT(PRESENT(density_zeta))
928 : CALL gauxc_integrator_eval_exc_grad_onedft_uks( &
929 : status%status, &
930 : integrator%integrator, &
931 : density_scalar, &
932 : density_zeta, &
933 : TRIM(model), &
934 0 : res%exc_grad)
935 : END IF
936 : #if defined (__HAS_IEEE_EXCEPTIONS)
937 : CALL ieee_set_halting_mode(IEEE_ALL, ieee_halt)
938 : #endif
939 4 : CALL omp_set_num_threads(omp_max_threads_restore)
940 4 : GAUXC_RETURN_IF_ERROR(status)
941 4 : RETURN
942 : #endif
943 : END IF
944 :
945 0 : IF (nspins == 1) THEN
946 : CALL gauxc_integrator_eval_exc_grad_rks( &
947 : status%status, &
948 : integrator%integrator, &
949 : density_scalar, &
950 0 : res%exc_grad)
951 : ELSE
952 0 : CPASSERT(PRESENT(density_zeta))
953 : CALL gauxc_integrator_eval_exc_grad_uks( &
954 : status%status, &
955 : integrator%integrator, &
956 : density_scalar, &
957 : density_zeta, &
958 0 : res%exc_grad)
959 : END IF
960 0 : GAUXC_RETURN_IF_ERROR(status)
961 :
962 : #else
963 : MARK_USED(density_scalar)
964 : MARK_USED(density_zeta)
965 : MARK_USED(res)
966 : MARK_USED(integrator)
967 : MARK_USED(model)
968 : MARK_USED(natom)
969 : MARK_USED(nspins)
970 : MARK_USED(status)
971 : CPABORT(no_gauxc_message)
972 : #endif
973 8 : END FUNCTION gauxc_compute_xc_gradient
974 :
975 : ! **************************************************************************************************
976 : !> \brief ...
977 : !> \param molecule ...
978 : !> \param status ...
979 : ! **************************************************************************************************
980 378 : SUBROUTINE gauxc_destroy_molecule(molecule, status)
981 : TYPE(cp_gauxc_molecule_type), INTENT(INOUT) :: molecule
982 : TYPE(cp_gauxc_status_type), INTENT(OUT) :: status
983 :
984 : #ifdef __GAUXC
985 378 : CALL gauxc_delete(status%status, molecule%molecule)
986 378 : GAUXC_RETURN_IF_ERROR(status)
987 : #else
988 : MARK_USED(molecule)
989 : MARK_USED(status)
990 : CPABORT(no_gauxc_message)
991 : #endif
992 : END SUBROUTINE gauxc_destroy_molecule
993 :
994 : ! **************************************************************************************************
995 : !> \brief ...
996 : !> \param basis ...
997 : !> \param status ...
998 : ! **************************************************************************************************
999 378 : SUBROUTINE gauxc_destroy_basisset(basis, status)
1000 : TYPE(cp_gauxc_basisset_type), INTENT(INOUT) :: basis
1001 : TYPE(cp_gauxc_status_type), INTENT(OUT) :: status
1002 :
1003 : #ifdef __GAUXC
1004 378 : CALL gauxc_delete(status%status, basis%basis)
1005 378 : GAUXC_RETURN_IF_ERROR(status)
1006 : #else
1007 : MARK_USED(basis)
1008 : MARK_USED(status)
1009 : CPABORT(no_gauxc_message)
1010 : #endif
1011 : END SUBROUTINE gauxc_destroy_basisset
1012 :
1013 : ! **************************************************************************************************
1014 : !> \brief ...
1015 : !> \param grid_result ...
1016 : !> \param status ...
1017 : ! **************************************************************************************************
1018 382 : SUBROUTINE gauxc_destroy_grid(grid_result, status)
1019 : TYPE(cp_gauxc_grid_type), INTENT(INOUT) :: grid_result
1020 : TYPE(cp_gauxc_status_type), INTENT(OUT) :: status
1021 :
1022 : #ifdef __GAUXC
1023 382 : CALL gauxc_delete(status%status, grid_result%mw)
1024 382 : GAUXC_RETURN_IF_ERROR(status)
1025 382 : CALL gauxc_delete(status%status, grid_result%mwf)
1026 382 : GAUXC_RETURN_IF_ERROR(status)
1027 382 : CALL gauxc_delete(status%status, grid_result%lb)
1028 382 : GAUXC_RETURN_IF_ERROR(status)
1029 382 : CALL gauxc_delete(status%status, grid_result%lbf)
1030 382 : GAUXC_RETURN_IF_ERROR(status)
1031 382 : CALL gauxc_delete(status%status, grid_result%grid)
1032 382 : GAUXC_RETURN_IF_ERROR(status)
1033 382 : IF (grid_result%owns_rt) THEN
1034 92 : CALL gauxc_runtime_environment_delete(status%status, grid_result%rt)
1035 92 : GAUXC_RETURN_IF_ERROR(status)
1036 92 : grid_result%owns_rt = .FALSE.
1037 : END IF
1038 : #else
1039 : MARK_USED(grid_result)
1040 : MARK_USED(status)
1041 : CPABORT(no_gauxc_message)
1042 : #endif
1043 : END SUBROUTINE gauxc_destroy_grid
1044 :
1045 : ! **************************************************************************************************
1046 : !> \brief ...
1047 : !> \param integrator_result ...
1048 : !> \param status ...
1049 : ! **************************************************************************************************
1050 382 : SUBROUTINE gauxc_destroy_integrator(integrator_result, status)
1051 : TYPE(cp_gauxc_integrator_type), INTENT(INOUT) :: integrator_result
1052 : TYPE(cp_gauxc_status_type), INTENT(OUT) :: status
1053 :
1054 : #ifdef __GAUXC
1055 382 : CALL gauxc_delete(status%status, integrator_result%integrator)
1056 382 : GAUXC_RETURN_IF_ERROR(status)
1057 382 : CALL gauxc_delete(status%status, integrator_result%func)
1058 382 : GAUXC_RETURN_IF_ERROR(status)
1059 : #else
1060 : MARK_USED(integrator_result)
1061 : MARK_USED(status)
1062 : CPABORT(no_gauxc_message)
1063 : #endif
1064 : END SUBROUTINE gauxc_destroy_integrator
1065 :
1066 : ! **************************************************************************************************
1067 : !> \brief Checks gauxc status and prints error message before aborting
1068 : !> \param status the gauxc status to check
1069 : ! **************************************************************************************************
1070 24070 : SUBROUTINE gauxc_check_status(status)
1071 : TYPE(cp_gauxc_status_type), INTENT(IN) :: status
1072 :
1073 : #ifdef __GAUXC
1074 24070 : IF (status%status%code /= 0) THEN
1075 0 : CALL print_gauxc_status_message(status)
1076 0 : CPABORT("GauXC returned with non-zero status code")
1077 : END IF
1078 : #else
1079 : MARK_USED(status)
1080 : #endif
1081 24070 : END SUBROUTINE gauxc_check_status
1082 :
1083 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1084 : ! From here on, it's private helpers !
1085 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1086 :
1087 : #ifdef __GAUXC
1088 :
1089 : ! **************************************************************************************************
1090 : !> \brief ...
1091 : !> \param spec ...
1092 : !> \return ...
1093 : ! **************************************************************************************************
1094 1146 : PURE FUNCTION read_execution_space(spec) RESULT(val)
1095 : CHARACTER(len=*), INTENT(IN) :: spec
1096 : INTEGER(c_int) :: val
1097 :
1098 1146 : CHARACTER(len=LEN(spec)) :: spec_upper
1099 :
1100 1146 : spec_upper = spec
1101 1146 : CALL uppercase(spec_upper)
1102 :
1103 : SELECT CASE (spec_upper)
1104 : CASE ("HOST")
1105 0 : val = gauxc_executionspace%host
1106 : CASE ("DEVICE")
1107 0 : val = gauxc_executionspace%device
1108 : CASE DEFAULT
1109 1146 : val = gauxc_executionspace%host
1110 : END SELECT
1111 1146 : END FUNCTION read_execution_space
1112 :
1113 : ! **************************************************************************************************
1114 : !> \brief ...
1115 : !> \param spec ...
1116 : !> \return ...
1117 : ! **************************************************************************************************
1118 382 : PURE FUNCTION read_atomic_grid_size(spec) RESULT(val)
1119 : CHARACTER(len=*), INTENT(IN) :: spec
1120 : INTEGER(c_int) :: val
1121 :
1122 382 : CHARACTER(len=LEN(spec)) :: spec_upper
1123 :
1124 382 : spec_upper = spec
1125 382 : CALL uppercase(spec_upper)
1126 :
1127 : SELECT CASE (spec_upper)
1128 : CASE ("FINE")
1129 0 : val = gauxc_atomicgridsizedefault%finegrid
1130 : CASE ("ULTRAFINE")
1131 0 : val = gauxc_atomicgridsizedefault%ultrafinegrid
1132 : CASE ("SUPERFINE")
1133 36 : val = gauxc_atomicgridsizedefault%superfinegrid
1134 : CASE ("GM3")
1135 0 : val = gauxc_atomicgridsizedefault%gm3
1136 : CASE ("GM5")
1137 0 : val = gauxc_atomicgridsizedefault%gm5
1138 : CASE DEFAULT
1139 382 : val = gauxc_atomicgridsizedefault%finegrid
1140 : END SELECT
1141 382 : END FUNCTION read_atomic_grid_size
1142 :
1143 : ! **************************************************************************************************
1144 : !> \brief ...
1145 : !> \param spec ...
1146 : !> \return ...
1147 : ! **************************************************************************************************
1148 382 : PURE FUNCTION read_radial_quad(spec) RESULT(val)
1149 : CHARACTER(len=*), INTENT(IN) :: spec
1150 : INTEGER(c_int) :: val
1151 :
1152 382 : CHARACTER(len=LEN(spec)) :: spec_upper
1153 :
1154 382 : spec_upper = spec
1155 382 : CALL uppercase(spec_upper)
1156 :
1157 : SELECT CASE (spec_upper)
1158 : CASE ("BECKE")
1159 382 : val = gauxc_radialquad%becke
1160 : CASE ("MURAKNOWLES")
1161 382 : val = gauxc_radialquad%mura_knowles
1162 : CASE ("TREUTLERAHLRICHS")
1163 0 : val = gauxc_radialquad%treutler_ahlrichs
1164 : CASE ("MURRAYHANDYLAMING")
1165 0 : val = gauxc_radialquad%murray_handy_laming
1166 : CASE DEFAULT
1167 382 : val = gauxc_radialquad%mura_knowles
1168 : END SELECT
1169 382 : END FUNCTION read_radial_quad
1170 :
1171 : ! **************************************************************************************************
1172 : !> \brief ...
1173 : !> \param spec ...
1174 : !> \return ...
1175 : ! **************************************************************************************************
1176 382 : PURE FUNCTION read_pruning_scheme(spec) RESULT(val)
1177 : CHARACTER(len=*), INTENT(IN) :: spec
1178 : INTEGER(c_int) :: val
1179 :
1180 382 : CHARACTER(len=LEN(spec)) :: spec_upper
1181 :
1182 382 : spec_upper = spec
1183 382 : CALL uppercase(spec_upper)
1184 :
1185 : SELECT CASE (spec_upper)
1186 : CASE ("UNPRUNED")
1187 346 : val = gauxc_pruningscheme%unpruned
1188 : CASE ("ROBUST")
1189 346 : val = gauxc_pruningscheme%robust
1190 : CASE ("TREUTLER")
1191 0 : val = gauxc_pruningscheme%treutler
1192 : CASE DEFAULT
1193 382 : val = gauxc_pruningscheme%robust
1194 : END SELECT
1195 382 : END FUNCTION read_pruning_scheme
1196 :
1197 : #endif
1198 :
1199 : ! **************************************************************************************************
1200 : !> \brief Write molecule data to HDF5 file for debugging
1201 : !> \param molecule ...
1202 : !> \param output_path ...
1203 : !> \param filename ...
1204 : !> \param dataset ...
1205 : !> \param status ...
1206 : ! **************************************************************************************************
1207 0 : SUBROUTINE gauxc_write_molecule_hdf5(molecule, output_path, filename, dataset, status)
1208 : TYPE(cp_gauxc_molecule_type), INTENT(IN) :: molecule
1209 : CHARACTER(len=*), INTENT(IN) :: output_path, filename, dataset
1210 : TYPE(cp_gauxc_status_type), INTENT(INOUT) :: status
1211 :
1212 : #if defined(__GAUXC) && defined(GAUXC_HAS_HDF5)
1213 : CHARACTER(len=default_path_length) :: full_path
1214 :
1215 : full_path = TRIM(output_path)//"/"//TRIM(filename)
1216 : CALL gauxc_write_hdf5_record(status%status, molecule%molecule, full_path, dataset)
1217 : #else
1218 : MARK_USED(molecule)
1219 : MARK_USED(output_path)
1220 : MARK_USED(filename)
1221 : MARK_USED(dataset)
1222 : MARK_USED(status)
1223 0 : CPABORT("GauXC HDF5 output requires GauXC to be built with HDF5 support.")
1224 : #endif
1225 0 : END SUBROUTINE gauxc_write_molecule_hdf5
1226 :
1227 : ! **************************************************************************************************
1228 : !> \brief Write basis set data to HDF5 file for debugging
1229 : !> \param basis ...
1230 : !> \param output_path ...
1231 : !> \param filename ...
1232 : !> \param dataset ...
1233 : !> \param status ...
1234 : ! **************************************************************************************************
1235 0 : SUBROUTINE gauxc_write_basisset_hdf5(basis, output_path, filename, dataset, status)
1236 : TYPE(cp_gauxc_basisset_type), INTENT(IN) :: basis
1237 : CHARACTER(len=*), INTENT(IN) :: output_path, filename, dataset
1238 : TYPE(cp_gauxc_status_type), INTENT(INOUT) :: status
1239 :
1240 : #if defined(__GAUXC) && defined(GAUXC_HAS_HDF5)
1241 : CHARACTER(len=default_path_length) :: full_path
1242 :
1243 : full_path = TRIM(output_path)//"/"//TRIM(filename)
1244 : CALL gauxc_write_hdf5_record(status%status, basis%basis, full_path, dataset)
1245 : #else
1246 : MARK_USED(basis)
1247 : MARK_USED(output_path)
1248 : MARK_USED(filename)
1249 : MARK_USED(dataset)
1250 : MARK_USED(status)
1251 0 : CPABORT("GauXC HDF5 output requires GauXC to be built with HDF5 support.")
1252 : #endif
1253 0 : END SUBROUTINE gauxc_write_basisset_hdf5
1254 :
1255 0 : END MODULE xc_gauxc_interface
|
