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 10486 : 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 10486 : IF (PRESENT(mpi_comm)) THEN
317 10486 : rt = gauxc_runtime_environment_new(status%status, mpi_comm)
318 10486 : rt_mpi_comm = mpi_comm
319 10486 : 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 10486 : 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 10486 : SUBROUTINE gauxc_finalize(status)
343 : TYPE(cp_gauxc_status_type), INTENT(OUT) :: status
344 :
345 : #ifdef __GAUXC
346 10486 : CALL gauxc_runtime_environment_delete(status%status, rt)
347 10486 : GAUXC_RETURN_IF_ERROR(status)
348 10486 : rt_mpi_comm = -1
349 10486 : 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 88 : 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 44 : TYPE(gauxc_atom_type), ALLOCATABLE, DIMENSION(:) :: atoms
371 :
372 44 : natoms = SIZE(particle_set)
373 132 : ALLOCATE (atoms(natoms))
374 :
375 164 : DO i = 1, natoms
376 120 : atomic_kind => particle_set(i)%atomic_kind
377 120 : CALL get_atomic_kind(atomic_kind, element_symbol=element_symbol)
378 120 : CALL get_ptable_info(element_symbol, number=atomic_number)
379 120 : atoms(i)%atomic_number = INT(atomic_number, c_int64_t)
380 120 : atoms(i)%x = REAL(particle_set(i)%r(1), c_double)
381 120 : atoms(i)%y = REAL(particle_set(i)%r(2), c_double)
382 164 : atoms(i)%z = REAL(particle_set(i)%r(3), c_double)
383 : END DO
384 :
385 44 : res%molecule = gauxc_molecule_new_from_atoms(status%status, atoms, INT(natoms, c_size_t))
386 44 : GAUXC_RETURN_IF_ERROR(status)
387 :
388 44 : 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 88 : 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 88 : 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 44 : 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 44 : nkind = SIZE(qs_kind_set)
422 44 : natoms = SIZE(particle_set)
423 :
424 190 : ALLOCATE (basis_set_list(nkind))
425 44 : CALL basis_set_list_setup(basis_set_list, "ORB", qs_kind_set)
426 :
427 44 : nshell_total = 0
428 164 : DO iatom = 1, natoms
429 120 : atomic_kind => particle_set(iatom)%atomic_kind
430 120 : CALL get_atomic_kind(atomic_kind, kind_number=ikind)
431 120 : gto_basis => basis_set_list(ikind)%gto_basis_set
432 120 : CPASSERT(ASSOCIATED(gto_basis))
433 : ! CALL write_gto_basis_set(gto_basis, 6, "–––––GAUXC-CREATE-BASISSET–––––")
434 494 : nshell_total = nshell_total + SUM(gto_basis%nshell)
435 : END DO
436 :
437 498 : ALLOCATE (shells(nshell_total))
438 :
439 164 : shell_index = 0
440 164 : res%max_l = -1
441 164 : DO iatom = 1, natoms ! for each atom
442 120 : atomic_kind => particle_set(iatom)%atomic_kind
443 120 : CALL get_atomic_kind(atomic_kind, kind_number=ikind)
444 120 : gto_basis => basis_set_list(ikind)%gto_basis_set
445 120 : CPASSERT(ASSOCIATED(gto_basis))
446 :
447 120 : shell_origin(1) = REAL(particle_set(iatom)%r(1), c_double)
448 120 : shell_origin(2) = REAL(particle_set(iatom)%r(2), c_double)
449 120 : shell_origin(3) = REAL(particle_set(iatom)%r(3), c_double)
450 :
451 120 : nset = gto_basis%nset
452 120 : CPASSERT(nset == SIZE(gto_basis%nshell))
453 494 : DO iset = 1, nset ! for each shell group
454 210 : nshell = gto_basis%nshell(iset)
455 210 : npgf = gto_basis%npgf(iset) ! corresponds with nprim of gauxc
456 :
457 696 : DO ishell = 1, gto_basis%nshell(iset) ! for each shell within the shell group
458 366 : shell_index = shell_index + 1 ! global shell index, flattened over atoms and groups
459 366 : lval = gto_basis%l(ishell, iset)
460 366 : res%max_l = MAX(res%max_l, lval)
461 366 : shells(shell_index)%l = INT(lval, c_int32_t)
462 : ! FIXME hardcoded true param
463 : ! pure=1: spherical Gaussians; pure=0: cartesian Gaussians
464 366 : shells(shell_index)%pure = .TRUE._c_bool
465 366 : shells(shell_index)%nprim = INT(npgf, c_int32_t)
466 1464 : shells(shell_index)%origin = shell_origin
467 :
468 1834 : DO iprim = 1, npgf
469 : shells(shell_index)%exponents(iprim) = &
470 1258 : 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 1624 : 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 44 : normalize=.FALSE.)
483 44 : GAUXC_RETURN_IF_ERROR(status)
484 :
485 44 : DEALLOCATE (shells)
486 44 : 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 88 : 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 44 : 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 44 : 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 44 : grid_type_local = read_atomic_grid_size(grid_type)
543 44 : radial_quad_local = read_radial_quad(radial_quadrature)
544 44 : pruning_scheme_local = read_pruning_scheme(pruning_scheme)
545 44 : lb_exec_space_local = read_execution_space(lb_exec_space)
546 44 : int_exec_space_local = read_execution_space("host")
547 44 : use_device_runtime = (lb_exec_space_local == gauxc_executionspace%device)
548 44 : force_new_runtime_local = .FALSE.
549 30 : IF (PRESENT(force_new_runtime)) force_new_runtime_local = force_new_runtime
550 44 : res%owns_rt = .FALSE.
551 :
552 44 : 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 44 : IF (PRESENT(mpi_comm)) THEN
576 : ! Reuse the global runtime when the requested communicator matches
577 : ! the communicator used during gauxc_init.
578 44 : IF (force_new_runtime_local .OR. .NOT. rt_has_mpi_comm .OR. &
579 : mpi_comm /= rt_mpi_comm) THEN
580 34 : res%rt = gauxc_runtime_environment_new(status%status, mpi_comm)
581 34 : 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 44 : grid_type_local)
598 44 : GAUXC_RETURN_IF_ERROR(status)
599 :
600 : res%lbf = gauxc_load_balancer_factory_new( &
601 : status%status, &
602 44 : lb_exec_space_local)
603 44 : GAUXC_RETURN_IF_ERROR(status)
604 :
605 44 : 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 34 : 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 10 : basis%basis)
621 : END IF
622 44 : GAUXC_RETURN_IF_ERROR(status)
623 :
624 : res%mwf = gauxc_molecular_weights_factory_new( &
625 : status%status, &
626 44 : int_exec_space_local)
627 44 : GAUXC_RETURN_IF_ERROR(status)
628 :
629 : res%mw = gauxc_get_instance( &
630 : status%status, &
631 44 : res%mwf)
632 44 : GAUXC_RETURN_IF_ERROR(status)
633 :
634 : CALL gauxc_molecular_weights_modify_weights( &
635 : status%status, &
636 : res%mw, &
637 44 : res%lb)
638 44 : 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 88 : 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 44 : FUNCTION gauxc_create_integrator( &
668 : xc_functional_name, &
669 : grid, &
670 : int_exec_space, &
671 : lwd_kernel, &
672 : nspins, &
673 44 : 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 44 : polarized = (nspins == 2)
687 : res%func = gauxc_functional_from_string( &
688 : status%status, &
689 : xc_functional_name, &
690 88 : polarized)
691 44 : GAUXC_RETURN_IF_ERROR(status)
692 :
693 44 : 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 44 : local_work_kernel_name=TRIM(lwd_kernel))
700 44 : 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 88 : 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 756 : FUNCTION gauxc_compute_xc( &
725 : integrator, &
726 756 : density_scalar, &
727 378 : density_zeta, &
728 : nspins, &
729 : status, &
730 378 : model) RESULT(res)
731 :
732 : TYPE(cp_gauxc_integrator_type), INTENT(IN) :: integrator
733 : ! Must be inout since we need to modify the matrix for some code paths
734 : REAL(c_double), DIMENSION(:, :) :: density_scalar
735 : REAL(c_double), DIMENSION(:, :), INTENT(IN), &
736 : OPTIONAL :: density_zeta
737 : INTEGER, INTENT(IN) :: nspins
738 : TYPE(cp_gauxc_status_type), INTENT(OUT) :: status
739 : CHARACTER(len=*), INTENT(IN), OPTIONAL :: model
740 : TYPE(cp_gauxc_xc_type) :: res
741 :
742 : #ifdef __GAUXC
743 : CHARACTER(len=default_path_length) :: model_key
744 : LOGICAL :: use_gauxc_model
745 : #ifdef GAUXC_HAS_ONEDFT
746 378 : 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 378 : use_gauxc_model = .FALSE.
754 378 : IF (PRESENT(model)) THEN
755 378 : model_key = ADJUSTL(model)
756 378 : CALL uppercase(model_key)
757 378 : use_gauxc_model = (TRIM(model_key) /= "" .AND. TRIM(model_key) /= "NONE")
758 : END IF
759 :
760 378 : IF (.NOT. ALLOCATED(res%vxc_scalar)) THEN
761 1512 : ALLOCATE (res%vxc_scalar, mold=density_scalar)
762 : ELSE
763 0 : CPASSERT(ALL(SHAPE(res%vxc_scalar) == SHAPE(density_scalar)))
764 : END IF
765 118518 : res%vxc_scalar = 0._dp
766 :
767 378 : 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 26 : 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 26 : IF (.NOT. ALLOCATED(res%vxc_zeta)) THEN
779 104 : ALLOCATE (res%vxc_zeta, mold=density_scalar)
780 : ELSE
781 0 : CPASSERT(ALL(SHAPE(res%vxc_zeta) == SHAPE(density_scalar)))
782 : END IF
783 2606 : res%vxc_zeta = 0._dp
784 :
785 26 : IF (nspins == 1) THEN
786 72 : ALLOCATE (density_zeta_zero, mold=density_scalar)
787 18 : 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 2078 : res%vxc_zeta)
797 18 : 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 26 : CALL omp_set_num_threads(omp_max_threads_restore)
814 26 : GAUXC_RETURN_IF_ERROR(status)
815 26 : RETURN
816 : #endif
817 : END IF
818 :
819 352 : 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 111110 : density_scalar = 0.5_dp*density_scalar
824 : CALL gauxc_integrator_eval_exc_vxc_rks( &
825 : status%status, &
826 : integrator%integrator, &
827 : density_scalar, &
828 : res%exc, &
829 111110 : res%vxc_scalar)
830 : ELSE
831 14 : CPASSERT(PRESENT(density_zeta))
832 :
833 14 : IF (.NOT. ALLOCATED(res%vxc_zeta)) THEN
834 56 : ALLOCATE (res%vxc_zeta, mold=density_zeta)
835 : ELSE
836 0 : CPASSERT(ALL(SHAPE(res%vxc_zeta) == SHAPE(density_scalar)))
837 : END IF
838 4802 : res%vxc_zeta = 0._dp
839 :
840 : CALL gauxc_integrator_eval_exc_vxc_uks( &
841 : status%status, &
842 : integrator%integrator, &
843 : density_scalar, &
844 : density_zeta, &
845 : res%exc, &
846 : res%vxc_scalar, &
847 9590 : res%vxc_zeta)
848 : END IF
849 352 : GAUXC_RETURN_IF_ERROR(status)
850 :
851 : #else
852 : MARK_USED(integrator)
853 : MARK_USED(density_scalar)
854 : MARK_USED(density_zeta)
855 : MARK_USED(nspins)
856 : MARK_USED(status)
857 : MARK_USED(model)
858 : CPABORT(no_gauxc_message)
859 : #endif
860 756 : END FUNCTION gauxc_compute_xc
861 :
862 : ! **************************************************************************************************
863 : !> \brief ...
864 : !> \param integrator ...
865 : !> \param density_scalar ...
866 : !> \param density_zeta ...
867 : !> \param nspins ...
868 : !> \param natom ...
869 : !> \param status ...
870 : !> \param model ...
871 : !> \return ...
872 : ! **************************************************************************************************
873 8 : FUNCTION gauxc_compute_xc_gradient( &
874 : integrator, &
875 8 : density_scalar, &
876 4 : density_zeta, &
877 : nspins, &
878 : natom, &
879 : status, &
880 4 : model) RESULT(res)
881 :
882 : TYPE(cp_gauxc_integrator_type), INTENT(IN) :: integrator
883 : REAL(c_double), DIMENSION(:, :), INTENT(IN) :: density_scalar
884 : REAL(c_double), DIMENSION(:, :), INTENT(IN), &
885 : OPTIONAL :: density_zeta
886 : INTEGER, INTENT(IN) :: nspins, natom
887 : TYPE(cp_gauxc_status_type), INTENT(OUT) :: status
888 : CHARACTER(len=*), INTENT(IN), OPTIONAL :: model
889 : TYPE(cp_gauxc_xc_gradient_type) :: res
890 :
891 : #ifdef __GAUXC
892 : CHARACTER(len=default_path_length) :: model_key
893 : LOGICAL :: use_gauxc_model
894 : #ifdef GAUXC_HAS_ONEDFT
895 4 : REAL(c_double), ALLOCATABLE, DIMENSION(:, :) :: density_zeta_zero
896 : #if defined (__HAS_IEEE_EXCEPTIONS)
897 : LOGICAL, DIMENSION(5) :: ieee_halt
898 : #endif
899 : INTEGER :: omp_max_threads_restore
900 : #endif
901 :
902 12 : ALLOCATE (res%exc_grad(3*natom))
903 40 : res%exc_grad = 0._dp
904 :
905 4 : use_gauxc_model = .FALSE.
906 4 : IF (PRESENT(model)) THEN
907 4 : model_key = ADJUSTL(model)
908 4 : CALL uppercase(model_key)
909 4 : use_gauxc_model = (TRIM(model_key) /= "" .AND. TRIM(model_key) /= "NONE")
910 : END IF
911 :
912 : IF (use_gauxc_model) THEN
913 : #ifndef GAUXC_HAS_ONEDFT
914 : CPABORT("GauXC lacks Skala support")
915 : #else
916 : ! Skala may change the OpenMP team size for later parallel regions.
917 : ! Restore max threads only; omp_get_num_threads() is 1 here.
918 0 : omp_max_threads_restore = omp_get_max_threads()
919 : #if defined (__HAS_IEEE_EXCEPTIONS)
920 : CALL ieee_get_halting_mode(IEEE_ALL, ieee_halt)
921 : CALL ieee_set_halting_mode(IEEE_ALL, .FALSE.)
922 : #endif
923 0 : IF (nspins == 1) THEN
924 0 : ALLOCATE (density_zeta_zero, mold=density_scalar)
925 0 : density_zeta_zero = 0._dp
926 : CALL gauxc_integrator_eval_exc_grad_onedft_uks( &
927 : status%status, &
928 : integrator%integrator, &
929 : density_scalar, &
930 : density_zeta_zero, &
931 : TRIM(model), &
932 0 : res%exc_grad)
933 0 : DEALLOCATE (density_zeta_zero)
934 : ELSE
935 0 : CPASSERT(PRESENT(density_zeta))
936 : CALL gauxc_integrator_eval_exc_grad_onedft_uks( &
937 : status%status, &
938 : integrator%integrator, &
939 : density_scalar, &
940 : density_zeta, &
941 : TRIM(model), &
942 0 : res%exc_grad)
943 : END IF
944 : #if defined (__HAS_IEEE_EXCEPTIONS)
945 : CALL ieee_set_halting_mode(IEEE_ALL, ieee_halt)
946 : #endif
947 0 : CALL omp_set_num_threads(omp_max_threads_restore)
948 0 : GAUXC_RETURN_IF_ERROR(status)
949 0 : RETURN
950 : #endif
951 : END IF
952 :
953 4 : IF (nspins == 1) THEN
954 : CALL gauxc_integrator_eval_exc_grad_rks( &
955 : status%status, &
956 : integrator%integrator, &
957 : density_scalar, &
958 1848 : res%exc_grad)
959 : ELSE
960 0 : CPASSERT(PRESENT(density_zeta))
961 : CALL gauxc_integrator_eval_exc_grad_uks( &
962 : status%status, &
963 : integrator%integrator, &
964 : density_scalar, &
965 : density_zeta, &
966 0 : res%exc_grad)
967 : END IF
968 4 : GAUXC_RETURN_IF_ERROR(status)
969 :
970 : #else
971 : MARK_USED(density_scalar)
972 : MARK_USED(density_zeta)
973 : MARK_USED(res)
974 : MARK_USED(integrator)
975 : MARK_USED(model)
976 : MARK_USED(natom)
977 : MARK_USED(nspins)
978 : MARK_USED(status)
979 : CPABORT(no_gauxc_message)
980 : #endif
981 8 : END FUNCTION gauxc_compute_xc_gradient
982 :
983 : ! **************************************************************************************************
984 : !> \brief ...
985 : !> \param molecule ...
986 : !> \param status ...
987 : ! **************************************************************************************************
988 44 : SUBROUTINE gauxc_destroy_molecule(molecule, status)
989 : TYPE(cp_gauxc_molecule_type), INTENT(INOUT) :: molecule
990 : TYPE(cp_gauxc_status_type), INTENT(OUT) :: status
991 :
992 : #ifdef __GAUXC
993 44 : CALL gauxc_delete(status%status, molecule%molecule)
994 44 : GAUXC_RETURN_IF_ERROR(status)
995 : #else
996 : MARK_USED(molecule)
997 : MARK_USED(status)
998 : CPABORT(no_gauxc_message)
999 : #endif
1000 : END SUBROUTINE gauxc_destroy_molecule
1001 :
1002 : ! **************************************************************************************************
1003 : !> \brief ...
1004 : !> \param basis ...
1005 : !> \param status ...
1006 : ! **************************************************************************************************
1007 44 : SUBROUTINE gauxc_destroy_basisset(basis, status)
1008 : TYPE(cp_gauxc_basisset_type), INTENT(INOUT) :: basis
1009 : TYPE(cp_gauxc_status_type), INTENT(OUT) :: status
1010 :
1011 : #ifdef __GAUXC
1012 44 : CALL gauxc_delete(status%status, basis%basis)
1013 44 : GAUXC_RETURN_IF_ERROR(status)
1014 : #else
1015 : MARK_USED(basis)
1016 : MARK_USED(status)
1017 : CPABORT(no_gauxc_message)
1018 : #endif
1019 : END SUBROUTINE gauxc_destroy_basisset
1020 :
1021 : ! **************************************************************************************************
1022 : !> \brief ...
1023 : !> \param grid_result ...
1024 : !> \param status ...
1025 : ! **************************************************************************************************
1026 44 : SUBROUTINE gauxc_destroy_grid(grid_result, status)
1027 : TYPE(cp_gauxc_grid_type), INTENT(INOUT) :: grid_result
1028 : TYPE(cp_gauxc_status_type), INTENT(OUT) :: status
1029 :
1030 : #ifdef __GAUXC
1031 44 : CALL gauxc_delete(status%status, grid_result%mw)
1032 44 : GAUXC_RETURN_IF_ERROR(status)
1033 44 : CALL gauxc_delete(status%status, grid_result%mwf)
1034 44 : GAUXC_RETURN_IF_ERROR(status)
1035 44 : CALL gauxc_delete(status%status, grid_result%lb)
1036 44 : GAUXC_RETURN_IF_ERROR(status)
1037 44 : CALL gauxc_delete(status%status, grid_result%lbf)
1038 44 : GAUXC_RETURN_IF_ERROR(status)
1039 44 : CALL gauxc_delete(status%status, grid_result%grid)
1040 44 : GAUXC_RETURN_IF_ERROR(status)
1041 44 : IF (grid_result%owns_rt) THEN
1042 34 : CALL gauxc_runtime_environment_delete(status%status, grid_result%rt)
1043 34 : GAUXC_RETURN_IF_ERROR(status)
1044 34 : grid_result%owns_rt = .FALSE.
1045 : END IF
1046 : #else
1047 : MARK_USED(grid_result)
1048 : MARK_USED(status)
1049 : CPABORT(no_gauxc_message)
1050 : #endif
1051 : END SUBROUTINE gauxc_destroy_grid
1052 :
1053 : ! **************************************************************************************************
1054 : !> \brief ...
1055 : !> \param integrator_result ...
1056 : !> \param status ...
1057 : ! **************************************************************************************************
1058 44 : SUBROUTINE gauxc_destroy_integrator(integrator_result, status)
1059 : TYPE(cp_gauxc_integrator_type), INTENT(INOUT) :: integrator_result
1060 : TYPE(cp_gauxc_status_type), INTENT(OUT) :: status
1061 :
1062 : #ifdef __GAUXC
1063 44 : CALL gauxc_delete(status%status, integrator_result%integrator)
1064 44 : GAUXC_RETURN_IF_ERROR(status)
1065 44 : CALL gauxc_delete(status%status, integrator_result%func)
1066 44 : GAUXC_RETURN_IF_ERROR(status)
1067 : #else
1068 : MARK_USED(integrator_result)
1069 : MARK_USED(status)
1070 : CPABORT(no_gauxc_message)
1071 : #endif
1072 : END SUBROUTINE gauxc_destroy_integrator
1073 :
1074 : ! **************************************************************************************************
1075 : !> \brief Checks gauxc status and prints error message before aborting
1076 : !> \param status the gauxc status to check
1077 : ! **************************************************************************************************
1078 21530 : SUBROUTINE gauxc_check_status(status)
1079 : TYPE(cp_gauxc_status_type), INTENT(IN) :: status
1080 :
1081 : #ifdef __GAUXC
1082 21530 : IF (status%status%code /= 0) THEN
1083 0 : CALL print_gauxc_status_message(status)
1084 0 : CPABORT("GauXC returned with non-zero status code")
1085 : END IF
1086 : #else
1087 : MARK_USED(status)
1088 : #endif
1089 21530 : END SUBROUTINE gauxc_check_status
1090 :
1091 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1092 : ! From here on, it's private helpers !
1093 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1094 :
1095 : #ifdef __GAUXC
1096 :
1097 : ! **************************************************************************************************
1098 : !> \brief ...
1099 : !> \param spec ...
1100 : !> \return ...
1101 : ! **************************************************************************************************
1102 132 : PURE FUNCTION read_execution_space(spec) RESULT(val)
1103 : CHARACTER(len=*), INTENT(IN) :: spec
1104 : INTEGER(c_int) :: val
1105 :
1106 132 : CHARACTER(len=LEN(spec)) :: spec_upper
1107 :
1108 132 : spec_upper = spec
1109 132 : CALL uppercase(spec_upper)
1110 :
1111 : SELECT CASE (spec_upper)
1112 : CASE ("HOST")
1113 0 : val = gauxc_executionspace%host
1114 : CASE ("DEVICE")
1115 0 : val = gauxc_executionspace%device
1116 : CASE DEFAULT
1117 132 : val = gauxc_executionspace%host
1118 : END SELECT
1119 132 : END FUNCTION read_execution_space
1120 :
1121 : ! **************************************************************************************************
1122 : !> \brief ...
1123 : !> \param spec ...
1124 : !> \return ...
1125 : ! **************************************************************************************************
1126 44 : PURE FUNCTION read_atomic_grid_size(spec) RESULT(val)
1127 : CHARACTER(len=*), INTENT(IN) :: spec
1128 : INTEGER(c_int) :: val
1129 :
1130 44 : CHARACTER(len=LEN(spec)) :: spec_upper
1131 :
1132 44 : spec_upper = spec
1133 44 : CALL uppercase(spec_upper)
1134 :
1135 : SELECT CASE (spec_upper)
1136 : CASE ("FINE")
1137 0 : val = gauxc_atomicgridsizedefault%finegrid
1138 : CASE ("ULTRAFINE")
1139 0 : val = gauxc_atomicgridsizedefault%ultrafinegrid
1140 : CASE ("SUPERFINE")
1141 0 : val = gauxc_atomicgridsizedefault%superfinegrid
1142 : CASE ("GM3")
1143 0 : val = gauxc_atomicgridsizedefault%gm3
1144 : CASE ("GM5")
1145 0 : val = gauxc_atomicgridsizedefault%gm5
1146 : CASE DEFAULT
1147 44 : val = gauxc_atomicgridsizedefault%finegrid
1148 : END SELECT
1149 44 : END FUNCTION read_atomic_grid_size
1150 :
1151 : ! **************************************************************************************************
1152 : !> \brief ...
1153 : !> \param spec ...
1154 : !> \return ...
1155 : ! **************************************************************************************************
1156 44 : PURE FUNCTION read_radial_quad(spec) RESULT(val)
1157 : CHARACTER(len=*), INTENT(IN) :: spec
1158 : INTEGER(c_int) :: val
1159 :
1160 44 : CHARACTER(len=LEN(spec)) :: spec_upper
1161 :
1162 44 : spec_upper = spec
1163 44 : CALL uppercase(spec_upper)
1164 :
1165 : SELECT CASE (spec_upper)
1166 : CASE ("BECKE")
1167 44 : val = gauxc_radialquad%becke
1168 : CASE ("MURAKNOWLES")
1169 44 : val = gauxc_radialquad%mura_knowles
1170 : CASE ("TREUTLERAHLRICHS")
1171 0 : val = gauxc_radialquad%treutler_ahlrichs
1172 : CASE ("MURRAYHANDYLAMING")
1173 0 : val = gauxc_radialquad%murray_handy_laming
1174 : CASE DEFAULT
1175 44 : val = gauxc_radialquad%mura_knowles
1176 : END SELECT
1177 44 : END FUNCTION read_radial_quad
1178 :
1179 : ! **************************************************************************************************
1180 : !> \brief ...
1181 : !> \param spec ...
1182 : !> \return ...
1183 : ! **************************************************************************************************
1184 44 : PURE FUNCTION read_pruning_scheme(spec) RESULT(val)
1185 : CHARACTER(len=*), INTENT(IN) :: spec
1186 : INTEGER(c_int) :: val
1187 :
1188 44 : CHARACTER(len=LEN(spec)) :: spec_upper
1189 :
1190 44 : spec_upper = spec
1191 44 : CALL uppercase(spec_upper)
1192 :
1193 : SELECT CASE (spec_upper)
1194 : CASE ("UNPRUNED")
1195 44 : val = gauxc_pruningscheme%unpruned
1196 : CASE ("ROBUST")
1197 44 : val = gauxc_pruningscheme%robust
1198 : CASE ("TREUTLER")
1199 0 : val = gauxc_pruningscheme%treutler
1200 : CASE DEFAULT
1201 44 : val = gauxc_pruningscheme%robust
1202 : END SELECT
1203 44 : END FUNCTION read_pruning_scheme
1204 :
1205 : #endif
1206 :
1207 : ! **************************************************************************************************
1208 : !> \brief Write molecule data to HDF5 file for debugging
1209 : !> \param molecule ...
1210 : !> \param output_path ...
1211 : !> \param filename ...
1212 : !> \param dataset ...
1213 : !> \param status ...
1214 : ! **************************************************************************************************
1215 0 : SUBROUTINE gauxc_write_molecule_hdf5(molecule, output_path, filename, dataset, status)
1216 : TYPE(cp_gauxc_molecule_type), INTENT(IN) :: molecule
1217 : CHARACTER(len=*), INTENT(IN) :: output_path, filename, dataset
1218 : TYPE(cp_gauxc_status_type), INTENT(INOUT) :: status
1219 :
1220 : #if defined(__GAUXC) && defined(GAUXC_HAS_HDF5)
1221 : CHARACTER(len=default_path_length) :: full_path
1222 :
1223 : full_path = TRIM(output_path)//"/"//TRIM(filename)
1224 : CALL gauxc_write_hdf5_record(status%status, molecule%molecule, full_path, dataset)
1225 : #else
1226 : MARK_USED(molecule)
1227 : MARK_USED(output_path)
1228 : MARK_USED(filename)
1229 : MARK_USED(dataset)
1230 : MARK_USED(status)
1231 0 : CPABORT("GauXC HDF5 output requires GauXC to be built with HDF5 support.")
1232 : #endif
1233 0 : END SUBROUTINE gauxc_write_molecule_hdf5
1234 :
1235 : ! **************************************************************************************************
1236 : !> \brief Write basis set data to HDF5 file for debugging
1237 : !> \param basis ...
1238 : !> \param output_path ...
1239 : !> \param filename ...
1240 : !> \param dataset ...
1241 : !> \param status ...
1242 : ! **************************************************************************************************
1243 0 : SUBROUTINE gauxc_write_basisset_hdf5(basis, output_path, filename, dataset, status)
1244 : TYPE(cp_gauxc_basisset_type), INTENT(IN) :: basis
1245 : CHARACTER(len=*), INTENT(IN) :: output_path, filename, dataset
1246 : TYPE(cp_gauxc_status_type), INTENT(INOUT) :: status
1247 :
1248 : #if defined(__GAUXC) && defined(GAUXC_HAS_HDF5)
1249 : CHARACTER(len=default_path_length) :: full_path
1250 :
1251 : full_path = TRIM(output_path)//"/"//TRIM(filename)
1252 : CALL gauxc_write_hdf5_record(status%status, basis%basis, full_path, dataset)
1253 : #else
1254 : MARK_USED(basis)
1255 : MARK_USED(output_path)
1256 : MARK_USED(filename)
1257 : MARK_USED(dataset)
1258 : MARK_USED(status)
1259 0 : CPABORT("GauXC HDF5 output requires GauXC to be built with HDF5 support.")
1260 : #endif
1261 0 : END SUBROUTINE gauxc_write_basisset_hdf5
1262 :
1263 0 : END MODULE xc_gauxc_interface
|
