Line data Source code
1 : !--------------------------------------------------------------------------------------------------!
2 : ! CP2K: A general program to perform molecular dynamics simulations !
3 : ! Copyright 2000-2026 CP2K developers group <https://cp2k.org> !
4 : ! !
5 : ! SPDX-License-Identifier: GPL-2.0-or-later !
6 : !--------------------------------------------------------------------------------------------------!
7 :
8 : !--------------------------------------------------------------------------------------------------!
9 : ! IMPORTANT: Update libcp2k.h when you add, remove or change a function in this file. !
10 : !--------------------------------------------------------------------------------------------------!
11 :
12 : ! **************************************************************************************************
13 : !> \brief CP2K C/C++ interface
14 : !> \par History
15 : !> 12.2012 created [Hossein Bani-Hashemian]
16 : !> 04.2016 restructured [Hossein Bani-Hashemian, Ole Schuett]
17 : !> 03.2018 added Active Space functions [Tiziano Mueller]
18 : !> \author Mohammad Hossein Bani-Hashemian
19 : ! **************************************************************************************************
20 : MODULE libcp2k
21 : USE ISO_C_BINDING, ONLY: C_CHAR,&
22 : C_DOUBLE,&
23 : C_FUNPTR,&
24 : C_INT,&
25 : C_LONG,&
26 : C_NULL_CHAR
27 : USE cp2k_info, ONLY: cp2k_version
28 : USE cp2k_runs, ONLY: run_input
29 : USE cp_files, ONLY: close_file,&
30 : open_file
31 : USE cp_fm_types, ONLY: cp_fm_get_element
32 : USE f77_interface, ONLY: &
33 : calc_energy_force, create_force_env, default_para_env, destroy_force_env, &
34 : f_env_add_defaults, f_env_rm_defaults, f_env_type, finalize_cp2k, get_cell, get_energy, &
35 : get_force, get_natom, get_nparticle, get_pos, get_qmmm_cell, get_result_r1, &
36 : get_stress_tensor, init_cp2k, set_cell, set_pos, set_vel
37 : USE force_env_types, ONLY: force_env_get,&
38 : use_qs_force
39 : USE input_cp2k, ONLY: create_cp2k_root_section
40 : USE input_cp2k_read, ONLY: empty_initial_variables
41 : USE input_section_types, ONLY: section_release,&
42 : section_type
43 : USE kinds, ONLY: default_path_length,&
44 : default_string_length,&
45 : dp
46 : USE message_passing, ONLY: mp_comm_type
47 : USE qs_active_space_types, ONLY: eri_type_eri_element_func
48 : USE qs_environment_types, ONLY: qs_environment_type
49 : USE string_utilities, ONLY: strlcpy_c2f
50 : #include "../base/base_uses.f90"
51 :
52 : IMPLICIT NONE
53 :
54 : PRIVATE
55 :
56 : PUBLIC :: cp2k_get_version, cp2k_init, cp2k_init_without_mpi, cp2k_init_without_mpi_comm, &
57 : cp2k_finalize, cp2k_finalize_without_mpi, cp2k_create_force_env, &
58 : cp2k_create_force_env_comm, cp2k_destroy_force_env, cp2k_set_positions, &
59 : cp2k_set_velocities, cp2k_set_cell, cp2k_get_result, cp2k_get_natom, &
60 : cp2k_get_nparticle, cp2k_get_positions, cp2k_get_forces, cp2k_get_stress_tensor, &
61 : cp2k_get_potential_energy, cp2k_get_cell, cp2k_get_qmmm_cell, &
62 : cp2k_get_scf_convergence, &
63 : cp2k_calc_energy_force, cp2k_calc_energy, cp2k_run_input, cp2k_run_input_comm, &
64 : cp2k_transport_set_callback, cp2k_active_space_get_mo_count, &
65 : cp2k_active_space_get_fock_sub, cp2k_active_space_get_eri_nze_count, &
66 : cp2k_active_space_get_eri
67 :
68 : TYPE, EXTENDS(eri_type_eri_element_func) :: eri2array
69 : INTEGER(C_INT), POINTER :: coords(:) => NULL()
70 : REAL(C_DOUBLE), POINTER :: values(:) => NULL()
71 : INTEGER :: idx = 1
72 : CONTAINS
73 : PROCEDURE :: func => eri2array_func
74 : END TYPE eri2array
75 :
76 : CONTAINS
77 :
78 : ! **************************************************************************************************
79 : !> \brief ...
80 : !> \param version_str ...
81 : !> \param str_length ...
82 : ! **************************************************************************************************
83 2 : SUBROUTINE cp2k_get_version(version_str, str_length) BIND(C)
84 : CHARACTER(LEN=1, KIND=C_CHAR), INTENT(OUT) :: version_str(*)
85 : INTEGER(C_INT), VALUE :: str_length
86 :
87 : INTEGER :: i, n
88 :
89 2 : n = LEN_TRIM(cp2k_version)
90 2 : CPASSERT(str_length >= n + 1)
91 : MARK_USED(str_length)
92 :
93 : ! copy string
94 84 : DO i = 1, n
95 84 : version_str(i) = cp2k_version(i:i)
96 : END DO
97 2 : version_str(n + 1) = C_NULL_CHAR
98 2 : END SUBROUTINE cp2k_get_version
99 :
100 : ! **************************************************************************************************
101 : !> \brief ...
102 : ! **************************************************************************************************
103 4 : SUBROUTINE cp2k_init() BIND(C)
104 : INTEGER :: ierr
105 :
106 4 : CALL init_cp2k(.TRUE., ierr)
107 4 : CPASSERT(ierr == 0)
108 4 : END SUBROUTINE cp2k_init
109 :
110 : ! **************************************************************************************************
111 : !> \brief ...
112 : ! **************************************************************************************************
113 0 : SUBROUTINE cp2k_init_without_mpi() BIND(C)
114 : INTEGER :: ierr
115 :
116 0 : CALL init_cp2k(.FALSE., ierr)
117 0 : CPASSERT(ierr == 0)
118 0 : END SUBROUTINE cp2k_init_without_mpi
119 :
120 : ! **************************************************************************************************
121 : !> \brief ...
122 : !> \param mpi_comm ...
123 : ! **************************************************************************************************
124 0 : SUBROUTINE cp2k_init_without_mpi_comm(mpi_comm) BIND(C)
125 : INTEGER(C_INT), VALUE :: mpi_comm
126 :
127 : INTEGER :: ierr
128 : TYPE(mp_comm_type) :: my_mpi_comm
129 :
130 0 : CALL my_mpi_comm%set_handle(INT(mpi_comm))
131 0 : CALL init_cp2k(.FALSE., ierr, my_mpi_comm)
132 0 : CPASSERT(ierr == 0)
133 0 : END SUBROUTINE cp2k_init_without_mpi_comm
134 :
135 : ! **************************************************************************************************
136 : !> \brief ...
137 : ! **************************************************************************************************
138 4 : SUBROUTINE cp2k_finalize() BIND(C)
139 : INTEGER :: ierr
140 :
141 4 : CALL finalize_cp2k(.TRUE., ierr)
142 4 : CPASSERT(ierr == 0)
143 4 : END SUBROUTINE cp2k_finalize
144 :
145 : ! **************************************************************************************************
146 : !> \brief ...
147 : ! **************************************************************************************************
148 0 : SUBROUTINE cp2k_finalize_without_mpi() BIND(C)
149 : INTEGER :: ierr
150 :
151 0 : CALL finalize_cp2k(.FALSE., ierr)
152 0 : CPASSERT(ierr == 0)
153 0 : END SUBROUTINE cp2k_finalize_without_mpi
154 :
155 : ! **************************************************************************************************
156 : !> \brief ...
157 : !> \param new_env_id ...
158 : !> \param input_file_path ...
159 : !> \param output_file_path ...
160 : ! **************************************************************************************************
161 8 : SUBROUTINE cp2k_create_force_env(new_env_id, input_file_path, output_file_path) BIND(C)
162 : INTEGER(C_INT), INTENT(OUT) :: new_env_id
163 : CHARACTER(LEN=1, KIND=C_CHAR), INTENT(IN) :: input_file_path(*), output_file_path(*)
164 :
165 : CHARACTER(LEN=default_path_length) :: ifp, ofp
166 : INTEGER :: ierr, ncopied
167 : TYPE(section_type), POINTER :: input_declaration
168 :
169 4 : ifp = " "; ofp = " "
170 4 : ncopied = strlcpy_c2f(ifp, input_file_path)
171 4 : ncopied = strlcpy_c2f(ofp, output_file_path)
172 :
173 4 : NULLIFY (input_declaration)
174 4 : CALL create_cp2k_root_section(input_declaration)
175 4 : CALL create_force_env(new_env_id, input_declaration, ifp, ofp, ierr=ierr)
176 4 : CALL section_release(input_declaration)
177 4 : CPASSERT(ierr == 0)
178 4 : END SUBROUTINE cp2k_create_force_env
179 :
180 : ! **************************************************************************************************
181 : !> \brief ...
182 : !> \param new_env_id ...
183 : !> \param input_file_path ...
184 : !> \param output_file_path ...
185 : !> \param mpi_comm ...
186 : ! **************************************************************************************************
187 0 : SUBROUTINE cp2k_create_force_env_comm(new_env_id, input_file_path, output_file_path, mpi_comm) BIND(C)
188 : INTEGER(C_INT), INTENT(OUT) :: new_env_id
189 : CHARACTER(LEN=1, KIND=C_CHAR), INTENT(IN) :: input_file_path(*), output_file_path(*)
190 : INTEGER(C_INT), VALUE :: mpi_comm
191 :
192 : CHARACTER(LEN=default_path_length) :: ifp, ofp
193 : INTEGER :: ierr, ncopied
194 : TYPE(mp_comm_type) :: my_mpi_comm
195 : TYPE(section_type), POINTER :: input_declaration
196 :
197 0 : ifp = " "; ofp = " "
198 0 : ncopied = strlcpy_c2f(ifp, input_file_path)
199 0 : ncopied = strlcpy_c2f(ofp, output_file_path)
200 :
201 0 : NULLIFY (input_declaration)
202 0 : CALL create_cp2k_root_section(input_declaration)
203 0 : CALL my_mpi_comm%set_handle(INT(mpi_comm))
204 0 : CALL create_force_env(new_env_id, input_declaration, ifp, ofp, my_mpi_comm, ierr=ierr)
205 0 : CALL section_release(input_declaration)
206 0 : CPASSERT(ierr == 0)
207 0 : END SUBROUTINE cp2k_create_force_env_comm
208 :
209 : ! **************************************************************************************************
210 : !> \brief ...
211 : !> \param env_id ...
212 : ! **************************************************************************************************
213 4 : SUBROUTINE cp2k_destroy_force_env(env_id) BIND(C)
214 : INTEGER(C_INT), VALUE :: env_id
215 :
216 : INTEGER :: ierr
217 :
218 4 : CALL destroy_force_env(env_id, ierr)
219 4 : CPASSERT(ierr == 0)
220 4 : END SUBROUTINE cp2k_destroy_force_env
221 :
222 : ! **************************************************************************************************
223 : !> \brief ...
224 : !> \param env_id ...
225 : !> \param new_pos ...
226 : !> \param n_el ...
227 : ! **************************************************************************************************
228 2 : SUBROUTINE cp2k_set_positions(env_id, new_pos, n_el) BIND(C)
229 : INTEGER(C_INT), VALUE :: env_id, n_el
230 : REAL(C_DOUBLE), DIMENSION(1:n_el), INTENT(IN) :: new_pos
231 :
232 : INTEGER :: ierr
233 :
234 2 : CALL set_pos(env_id, new_pos, n_el, ierr)
235 2 : CPASSERT(ierr == 0)
236 2 : END SUBROUTINE cp2k_set_positions
237 :
238 : ! **************************************************************************************************
239 : !> \brief ...
240 : !> \param env_id ...
241 : !> \param new_vel ...
242 : !> \param n_el ...
243 : ! **************************************************************************************************
244 2 : SUBROUTINE cp2k_set_velocities(env_id, new_vel, n_el) BIND(C)
245 : INTEGER(C_INT), VALUE :: env_id, n_el
246 : REAL(C_DOUBLE), DIMENSION(1:n_el), INTENT(IN) :: new_vel
247 :
248 : INTEGER :: ierr
249 :
250 2 : CALL set_vel(env_id, new_vel, n_el, ierr)
251 2 : CPASSERT(ierr == 0)
252 2 : END SUBROUTINE cp2k_set_velocities
253 :
254 : ! **************************************************************************************************
255 : !> \brief ...
256 : !> \param env_id ...
257 : !> \param new_cell ...
258 : ! **************************************************************************************************
259 2 : SUBROUTINE cp2k_set_cell(env_id, new_cell) BIND(C)
260 : INTEGER(C_INT), VALUE :: env_id
261 : REAL(C_DOUBLE), DIMENSION(3, 3), INTENT(IN) :: new_cell
262 :
263 : INTEGER :: ierr
264 :
265 2 : CALL set_cell(env_id, new_cell, ierr)
266 2 : CPASSERT(ierr == 0)
267 2 : END SUBROUTINE cp2k_set_cell
268 :
269 : ! **************************************************************************************************
270 : !> \brief ...
271 : !> \param env_id ...
272 : !> \param description ...
273 : !> \param RESULT ...
274 : !> \param n_el ...
275 : ! **************************************************************************************************
276 0 : SUBROUTINE cp2k_get_result(env_id, description, RESULT, n_el) BIND(C)
277 : INTEGER(C_INT), VALUE :: env_id
278 : CHARACTER(LEN=1, KIND=C_CHAR), INTENT(IN) :: description(*)
279 : INTEGER(C_INT), VALUE :: n_el
280 : REAL(C_DOUBLE), DIMENSION(1:n_el), INTENT(OUT) :: RESULT
281 :
282 : CHARACTER(LEN=default_string_length) :: desc_low
283 : INTEGER :: ierr, ncopied
284 :
285 0 : desc_low = " "
286 0 : ncopied = strlcpy_c2f(desc_low, description)
287 :
288 0 : CALL get_result_r1(env_id, desc_low, n_el, RESULT, ierr=ierr)
289 0 : CPASSERT(ierr == 0)
290 0 : END SUBROUTINE cp2k_get_result
291 :
292 : ! **************************************************************************************************
293 : !> \brief ...
294 : !> \param env_id ...
295 : !> \param natom ...
296 : ! **************************************************************************************************
297 0 : SUBROUTINE cp2k_get_natom(env_id, natom) BIND(C)
298 : INTEGER(C_INT), VALUE :: env_id
299 : INTEGER(C_INT), INTENT(OUT) :: natom
300 :
301 : INTEGER :: ierr
302 :
303 0 : CALL get_natom(env_id, natom, ierr)
304 0 : CPASSERT(ierr == 0)
305 0 : END SUBROUTINE cp2k_get_natom
306 :
307 : ! **************************************************************************************************
308 : !> \brief ...
309 : !> \param env_id ...
310 : !> \param nparticle ...
311 : ! **************************************************************************************************
312 0 : SUBROUTINE cp2k_get_nparticle(env_id, nparticle) BIND(C)
313 : INTEGER(C_INT), VALUE :: env_id
314 : INTEGER(C_INT), INTENT(OUT) :: nparticle
315 :
316 : INTEGER :: ierr
317 :
318 0 : CALL get_nparticle(env_id, nparticle, ierr)
319 0 : CPASSERT(ierr == 0)
320 0 : END SUBROUTINE cp2k_get_nparticle
321 :
322 : ! **************************************************************************************************
323 : !> \brief ...
324 : !> \param env_id ...
325 : !> \param pos ...
326 : !> \param n_el ...
327 : ! **************************************************************************************************
328 2 : SUBROUTINE cp2k_get_positions(env_id, pos, n_el) BIND(C)
329 : INTEGER(C_INT), VALUE :: env_id, n_el
330 : REAL(C_DOUBLE), DIMENSION(1:n_el), INTENT(OUT) :: pos
331 :
332 : INTEGER :: ierr
333 :
334 2 : CALL get_pos(env_id, pos, n_el, ierr)
335 2 : CPASSERT(ierr == 0)
336 2 : END SUBROUTINE cp2k_get_positions
337 :
338 : ! **************************************************************************************************
339 : !> \brief ...
340 : !> \param env_id ...
341 : !> \param force ...
342 : !> \param n_el ...
343 : ! **************************************************************************************************
344 0 : SUBROUTINE cp2k_get_forces(env_id, force, n_el) BIND(C)
345 : INTEGER(C_INT), VALUE :: env_id, n_el
346 : REAL(C_DOUBLE), DIMENSION(1:n_el), INTENT(OUT) :: force
347 :
348 : INTEGER :: ierr
349 :
350 0 : CALL get_force(env_id, force, n_el, ierr)
351 0 : CPASSERT(ierr == 0)
352 0 : END SUBROUTINE cp2k_get_forces
353 :
354 : ! **************************************************************************************************
355 : !> \brief Get the configurational stress (pressure-positive, atomic units).
356 : !> \param env_id Force environment ID
357 : !> \param stress_tensor Column-major 3x3 tensor
358 : !> \param available 1 if stress was enabled in the input, otherwise 0 (tensor is zero).
359 : ! **************************************************************************************************
360 2 : SUBROUTINE cp2k_get_stress_tensor(env_id, stress_tensor, available) BIND(C)
361 : INTEGER(C_INT), VALUE :: env_id
362 : REAL(C_DOUBLE), DIMENSION(3, 3), INTENT(OUT) :: stress_tensor
363 : INTEGER(C_INT), INTENT(OUT) :: available
364 :
365 : INTEGER :: ierr
366 : LOGICAL :: has_stress
367 :
368 2 : CALL get_stress_tensor(env_id, stress_tensor, ierr, available=has_stress)
369 2 : CPASSERT(ierr == 0)
370 2 : available = MERGE(1, 0, has_stress)
371 2 : END SUBROUTINE cp2k_get_stress_tensor
372 :
373 : ! **************************************************************************************************
374 : !> \brief ...
375 : !> \param env_id ...
376 : !> \param e_pot ...
377 : ! **************************************************************************************************
378 4 : SUBROUTINE cp2k_get_potential_energy(env_id, e_pot) BIND(C)
379 : INTEGER(C_INT), VALUE :: env_id
380 : REAL(C_DOUBLE), INTENT(OUT) :: e_pot
381 :
382 : INTEGER :: ierr
383 :
384 4 : CALL get_energy(env_id, e_pot, ierr)
385 4 : CPASSERT(ierr == 0)
386 4 : END SUBROUTINE cp2k_get_potential_energy
387 :
388 : ! **************************************************************************************************
389 : !> \brief ...
390 : !> \param env_id ...
391 : !> \param cell ...
392 : ! **************************************************************************************************
393 2 : SUBROUTINE cp2k_get_cell(env_id, cell) BIND(C)
394 : INTEGER(C_INT), VALUE :: env_id
395 : REAL(C_DOUBLE), DIMENSION(3, 3), INTENT(OUT) :: cell
396 :
397 : INTEGER :: ierr
398 :
399 2 : CALL get_cell(env_id, cell=cell, ierr=ierr)
400 2 : CPASSERT(ierr == 0)
401 2 : END SUBROUTINE cp2k_get_cell
402 :
403 : ! **************************************************************************************************
404 : !> \brief ...
405 : !> \param env_id ...
406 : !> \param cell ...
407 : ! **************************************************************************************************
408 0 : SUBROUTINE cp2k_get_qmmm_cell(env_id, cell) BIND(C)
409 : INTEGER(C_INT), VALUE :: env_id
410 : REAL(C_DOUBLE), DIMENSION(3, 3), INTENT(OUT) :: cell
411 :
412 : INTEGER :: ierr
413 :
414 0 : CALL get_qmmm_cell(env_id, cell=cell, ierr=ierr)
415 0 : CPASSERT(ierr == 0)
416 0 : END SUBROUTINE cp2k_get_qmmm_cell
417 :
418 : ! **************************************************************************************************
419 : !> \brief ...
420 : !> \param env_id ...
421 : ! **************************************************************************************************
422 4 : SUBROUTINE cp2k_calc_energy_force(env_id) BIND(C)
423 : INTEGER(C_INT), VALUE :: env_id
424 :
425 : INTEGER :: ierr
426 :
427 4 : CALL calc_energy_force(env_id, .TRUE., ierr)
428 4 : CPASSERT(ierr == 0)
429 4 : END SUBROUTINE cp2k_calc_energy_force
430 :
431 : ! **************************************************************************************************
432 : !> \brief ...
433 : !> \param env_id ...
434 : ! **************************************************************************************************
435 4 : SUBROUTINE cp2k_calc_energy(env_id) BIND(C)
436 : INTEGER(C_INT), VALUE :: env_id
437 :
438 : INTEGER :: ierr
439 :
440 4 : CALL calc_energy_force(env_id, .FALSE., ierr)
441 4 : CPASSERT(ierr == 0)
442 4 : END SUBROUTINE cp2k_calc_energy
443 :
444 : ! **************************************************************************************************
445 : !> \brief Get the last Quickstep SCF convergence status, including outer loops
446 : !> \param env_id force environment handle
447 : !> \param status -1: unavailable, 0: not converged, 1: converged
448 : ! **************************************************************************************************
449 30 : SUBROUTINE cp2k_get_scf_convergence(env_id, status) BIND(C)
450 : INTEGER(C_INT), VALUE :: env_id
451 : INTEGER(C_INT), INTENT(OUT) :: status
452 :
453 : INTEGER :: ierr, in_use
454 : TYPE(f_env_type), POINTER :: f_env
455 : TYPE(qs_environment_type), POINTER :: qs_env
456 :
457 10 : CALL f_env_add_defaults(env_id, f_env)
458 10 : status = -1
459 10 : CALL force_env_get(f_env%force_env, in_use=in_use)
460 10 : IF (.NOT. f_env%is_dirty .AND. in_use == use_qs_force) THEN
461 2 : CALL force_env_get(f_env%force_env, qs_env=qs_env)
462 4 : IF (qs_env%scf_convergence_available) status = MERGE(1, 0, qs_env%scf_converged)
463 : END IF
464 10 : CALL f_env_rm_defaults(f_env, ierr)
465 10 : CPASSERT(ierr == 0)
466 10 : END SUBROUTINE cp2k_get_scf_convergence
467 :
468 : ! **************************************************************************************************
469 : !> \brief ...
470 : !> \param input_file_path ...
471 : !> \param output_file_path ...
472 : ! **************************************************************************************************
473 2 : SUBROUTINE cp2k_run_input(input_file_path, output_file_path) BIND(C)
474 : CHARACTER(LEN=1, KIND=C_CHAR), INTENT(IN) :: input_file_path(*), output_file_path(*)
475 :
476 2 : CALL cp2k_run_input_comm(input_file_path, output_file_path, INT(default_para_env%get_handle(), C_INT))
477 2 : END SUBROUTINE cp2k_run_input
478 :
479 : ! **************************************************************************************************
480 : !> \brief ...
481 : !> \param input_file_path ...
482 : !> \param output_file_path ...
483 : !> \param mpi_comm ...
484 : ! **************************************************************************************************
485 4 : SUBROUTINE cp2k_run_input_comm(input_file_path, output_file_path, mpi_comm) BIND(C)
486 : CHARACTER(LEN=1, KIND=C_CHAR), INTENT(IN) :: input_file_path(*), output_file_path(*)
487 : INTEGER(C_INT), VALUE :: mpi_comm
488 :
489 : CHARACTER(LEN=default_path_length) :: ifp, ofp
490 : INTEGER :: ncopied, unit_nr
491 : TYPE(mp_comm_type) :: my_mpi_comm
492 : TYPE(section_type), POINTER :: input_declaration
493 :
494 4 : ifp = " "; ofp = " "
495 4 : ncopied = strlcpy_c2f(ifp, input_file_path)
496 4 : ncopied = strlcpy_c2f(ofp, output_file_path)
497 :
498 4 : NULLIFY (input_declaration)
499 4 : CALL create_cp2k_root_section(input_declaration)
500 4 : CALL my_mpi_comm%set_handle(INT(mpi_comm))
501 4 : IF (my_mpi_comm%is_source() .AND. ofp /= "__STD_OUT__") THEN
502 : CALL open_file(file_name=ofp, &
503 : file_status="UNKNOWN", &
504 : file_action="WRITE", &
505 : file_position="APPEND", &
506 2 : unit_number=unit_nr)
507 : END IF
508 4 : CALL run_input(input_declaration, ifp, ofp, empty_initial_variables, my_mpi_comm)
509 4 : IF (my_mpi_comm%is_source() .AND. ofp /= "__STD_OUT__") CALL close_file(unit_number=unit_nr)
510 4 : CALL section_release(input_declaration)
511 4 : END SUBROUTINE cp2k_run_input_comm
512 :
513 : ! **************************************************************************************************
514 : !> \brief Gets a function pointer pointing to a routine defined in C/C++ and
515 : !> passes it to the transport environment in force environment
516 : !> \param f_env_id the force env id
517 : !> \param func_ptr the function pointer
518 : !> \par History
519 : !> 12.2012 created [Hossein Bani-Hashemian]
520 : !> \author Mohammad Hossein Bani-Hashemian
521 : ! **************************************************************************************************
522 0 : SUBROUTINE cp2k_transport_set_callback(f_env_id, func_ptr) BIND(C)
523 : INTEGER(C_INT), VALUE :: f_env_id
524 : TYPE(C_FUNPTR), VALUE :: func_ptr
525 :
526 : INTEGER :: ierr, in_use
527 : TYPE(f_env_type), POINTER :: f_env
528 :
529 0 : NULLIFY (f_env)
530 0 : CALL f_env_add_defaults(f_env_id, f_env)
531 0 : CALL force_env_get(f_env%force_env, in_use=in_use)
532 0 : IF (in_use == use_qs_force) THEN
533 0 : f_env%force_env%qs_env%transport_env%ext_c_method_ptr = func_ptr
534 : END IF
535 0 : CALL f_env_rm_defaults(f_env, ierr)
536 0 : CPASSERT(ierr == 0)
537 0 : END SUBROUTINE cp2k_transport_set_callback
538 :
539 : ! **************************************************************************************************
540 : !> \brief Get the number of molecular orbitals
541 : !> \param f_env_id the force env id
542 : !> \return The number of elements or -1 if unavailable
543 : !> \author Tiziano Mueller
544 : ! **************************************************************************************************
545 0 : INTEGER(C_INT) FUNCTION cp2k_active_space_get_mo_count(f_env_id) RESULT(nmo) BIND(C)
546 : USE qs_active_space_types, ONLY: active_space_type
547 : USE qs_mo_types, ONLY: get_mo_set
548 : USE qs_environment_types, ONLY: get_qs_env
549 : INTEGER(C_INT), VALUE :: f_env_id
550 :
551 : INTEGER :: ierr
552 : TYPE(active_space_type), POINTER :: active_space_env
553 : TYPE(f_env_type), POINTER :: f_env
554 :
555 0 : nmo = -1
556 0 : NULLIFY (f_env)
557 :
558 0 : CALL f_env_add_defaults(f_env_id, f_env)
559 :
560 : try: BLOCK
561 0 : CALL get_qs_env(f_env%force_env%qs_env, active_space=active_space_env)
562 :
563 0 : IF (.NOT. ASSOCIATED(active_space_env)) THEN
564 : EXIT try
565 : END IF
566 :
567 0 : CALL get_mo_set(active_space_env%mos_active(1), nmo=nmo)
568 : END BLOCK try
569 :
570 0 : CALL f_env_rm_defaults(f_env, ierr)
571 0 : CPASSERT(ierr == 0)
572 0 : END FUNCTION cp2k_active_space_get_mo_count
573 :
574 : ! **************************************************************************************************
575 : !> \brief Get the active space Fock sub-matrix (as a full matrix)
576 : !> \param f_env_id the force env id
577 : !> \param buf C array to write the data to
578 : !> \param buf_len The length of the C array to write the data to (must be at least mo_count^2)
579 : !> \return The number of elements written or -1 if unavailable or buffer too small
580 : !> \author Tiziano Mueller
581 : ! **************************************************************************************************
582 0 : INTEGER(C_LONG) FUNCTION cp2k_active_space_get_fock_sub(f_env_id, buf, buf_len) RESULT(nelem) BIND(C)
583 0 : USE qs_active_space_types, ONLY: active_space_type
584 : USE qs_mo_types, ONLY: get_mo_set
585 : USE qs_environment_types, ONLY: get_qs_env
586 : INTEGER(C_INT), VALUE :: f_env_id
587 : INTEGER(C_LONG), VALUE :: buf_len
588 : REAL(C_DOUBLE), DIMENSION(0:buf_len-1), &
589 : INTENT(OUT) :: buf
590 :
591 : INTEGER :: i, ierr, j, norb
592 : REAL(C_DOUBLE) :: mval
593 : TYPE(active_space_type), POINTER :: active_space_env
594 : TYPE(f_env_type), POINTER :: f_env
595 :
596 0 : nelem = -1
597 0 : NULLIFY (f_env)
598 :
599 0 : CALL f_env_add_defaults(f_env_id, f_env)
600 :
601 : try: BLOCK
602 0 : CALL get_qs_env(f_env%force_env%qs_env, active_space=active_space_env)
603 :
604 0 : IF (.NOT. ASSOCIATED(active_space_env)) THEN
605 : EXIT try
606 : END IF
607 :
608 0 : CALL get_mo_set(active_space_env%mos_active(1), nmo=norb)
609 :
610 0 : IF (buf_len < norb*norb) THEN
611 : EXIT try
612 : END IF
613 :
614 0 : DO i = 0, norb - 1
615 0 : DO j = 0, norb - 1
616 0 : CALL cp_fm_get_element(active_space_env%fock_sub(1), i + 1, j + 1, mval)
617 0 : buf(norb*i + j) = mval
618 0 : buf(norb*j + i) = mval
619 : END DO
620 : END DO
621 :
622 : ! finished successfully, set number of written elements
623 0 : nelem = norb**norb
624 : END BLOCK try
625 :
626 0 : CALL f_env_rm_defaults(f_env, ierr)
627 0 : CPASSERT(ierr == 0)
628 0 : END FUNCTION cp2k_active_space_get_fock_sub
629 :
630 : ! **************************************************************************************************
631 : !> \brief Get the number of non-zero elements of the ERI
632 : !> \param f_env_id the force env id
633 : !> \return The number of elements or -1 if unavailable
634 : !> \author Tiziano Mueller
635 : ! **************************************************************************************************
636 0 : INTEGER(C_LONG) FUNCTION cp2k_active_space_get_eri_nze_count(f_env_id) RESULT(nze_count) BIND(C)
637 0 : USE qs_active_space_types, ONLY: active_space_type
638 : USE qs_environment_types, ONLY: get_qs_env
639 : INTEGER(C_INT), VALUE :: f_env_id
640 :
641 : INTEGER :: ierr
642 : TYPE(active_space_type), POINTER :: active_space_env
643 : TYPE(f_env_type), POINTER :: f_env
644 :
645 0 : nze_count = -1
646 0 : NULLIFY (f_env)
647 :
648 0 : CALL f_env_add_defaults(f_env_id, f_env)
649 :
650 : try: BLOCK
651 0 : CALL get_qs_env(f_env%force_env%qs_env, active_space=active_space_env)
652 :
653 0 : IF (.NOT. ASSOCIATED(active_space_env)) THEN
654 : EXIT try
655 : END IF
656 :
657 0 : nze_count = INT(active_space_env%eri%eri(1)%csr_mat%nze_total, KIND(nze_count))
658 : END BLOCK try
659 :
660 0 : CALL f_env_rm_defaults(f_env, ierr)
661 0 : CPASSERT(ierr == 0)
662 0 : END FUNCTION cp2k_active_space_get_eri_nze_count
663 :
664 : ! **************************************************************************************************
665 : !> \brief Get the electron repulsion integrals (as a sparse tensor)
666 : !> \param f_env_id the force env id
667 : !> \param buf_coords C array to write the indizes (i,j,k,l) to
668 : !> \param buf_coords_len size of the buffer, must be at least 4*nze_count
669 : !> \param buf_values C array to write the values to
670 : !> \param buf_values_len size of the buffer, must be at least nze_count
671 : !> \return The number of elements written or -1 if unavailable or buffer too small
672 : !> \author Tiziano Mueller
673 : ! **************************************************************************************************
674 0 : INTEGER(C_LONG) FUNCTION cp2k_active_space_get_eri(f_env_id, &
675 0 : buf_coords, buf_coords_len, &
676 0 : buf_values, buf_values_len) RESULT(nelem) BIND(C)
677 0 : USE qs_active_space_types, ONLY: active_space_type
678 : USE qs_mo_types, ONLY: get_mo_set
679 : USE qs_environment_types, ONLY: get_qs_env
680 : INTEGER(C_INT), INTENT(IN), VALUE :: f_env_id
681 : INTEGER(C_LONG), INTENT(IN), VALUE :: buf_coords_len
682 : INTEGER(C_INT), INTENT(OUT), TARGET :: buf_coords(1:buf_coords_len)
683 : INTEGER(C_LONG), INTENT(IN), VALUE :: buf_values_len
684 : REAL(C_DOUBLE), INTENT(OUT), TARGET :: buf_values(1:buf_values_len)
685 :
686 : INTEGER :: ierr
687 : TYPE(active_space_type), POINTER :: active_space_env
688 : TYPE(f_env_type), POINTER :: f_env
689 :
690 0 : nelem = -1
691 0 : NULLIFY (f_env)
692 :
693 0 : CALL f_env_add_defaults(f_env_id, f_env)
694 :
695 : try: BLOCK
696 0 : CALL get_qs_env(f_env%force_env%qs_env, active_space=active_space_env)
697 :
698 0 : IF (.NOT. ASSOCIATED(active_space_env)) THEN
699 : EXIT try
700 : END IF
701 :
702 : ASSOCIATE (nze => active_space_env%eri%eri(1)%csr_mat%nze_total)
703 0 : IF (buf_coords_len < 4*nze .OR. buf_values_len < nze) THEN
704 : EXIT try
705 : END IF
706 :
707 0 : CALL active_space_env%eri%eri_foreach(1, active_space_env%active_orbitals, eri2array(buf_coords, buf_values))
708 :
709 0 : nelem = INT(nze, KIND(nelem))
710 : END ASSOCIATE
711 : END BLOCK try
712 :
713 0 : CALL f_env_rm_defaults(f_env, ierr)
714 0 : CPASSERT(ierr == 0)
715 0 : END FUNCTION cp2k_active_space_get_eri
716 :
717 : ! **************************************************************************************************
718 : !> \brief Copy the active space ERI to C buffers
719 : !> \param this Class pointer
720 : !> \param i The i index of the value `val`
721 : !> \param j The j index of the value `val`
722 : !> \param k The k index of the value `val`
723 : !> \param l The l index of the value `val`
724 : !> \param val The value at the given index
725 : !> \return Always true to continue with the loop
726 : !> \author Tiziano Mueller
727 : ! **************************************************************************************************
728 0 : LOGICAL FUNCTION eri2array_func(this, i, j, k, l, val) RESULT(cont)
729 : CLASS(eri2array), INTENT(inout) :: this
730 : INTEGER, INTENT(in) :: i, j, k, l
731 : REAL(KIND=dp), INTENT(in) :: val
732 :
733 0 : this%coords(4*(this%idx - 1) + 1) = i
734 0 : this%coords(4*(this%idx - 1) + 2) = j
735 0 : this%coords(4*(this%idx - 1) + 3) = k
736 0 : this%coords(4*(this%idx - 1) + 4) = l
737 0 : this%values(this%idx) = val
738 :
739 0 : this%idx = this%idx + 1
740 :
741 0 : cont = .TRUE.
742 0 : END FUNCTION eri2array_func
743 :
744 0 : END MODULE libcp2k
|
