Line data Source code
1 : !--------------------------------------------------------------------------------------------------!
2 : ! CP2K: A general program to perform molecular dynamics simulations !
3 : ! Copyright 2000-2024 CP2K developers group <https://cp2k.org> !
4 : ! !
5 : ! SPDX-License-Identifier: GPL-2.0-or-later !
6 : !--------------------------------------------------------------------------------------------------!
7 :
8 : ! **************************************************************************************************
9 : !> \brief types that represent a subsys, i.e. a part of the system
10 : !> \par History
11 : !> 07.2003 created [fawzi]
12 : !> 09.2007 cleaned [tlaino] - University of Zurich
13 : !> 22.11.2010 pack/unpack particle routines added (MK)
14 : !> \author Fawzi Mohamed
15 : ! **************************************************************************************************
16 : MODULE cp_subsys_types
17 : USE atomic_kind_list_types, ONLY: atomic_kind_list_release,&
18 : atomic_kind_list_retain,&
19 : atomic_kind_list_type
20 : USE atomic_kind_types, ONLY: atomic_kind_type
21 : USE atprop_types, ONLY: atprop_release,&
22 : atprop_type
23 : USE cell_types, ONLY: cell_release,&
24 : cell_retain,&
25 : cell_type,&
26 : real_to_scaled,&
27 : scaled_to_real
28 : USE colvar_types, ONLY: colvar_p_release,&
29 : colvar_p_type
30 : USE cp_result_types, ONLY: cp_result_release,&
31 : cp_result_retain,&
32 : cp_result_type
33 : USE distribution_1d_types, ONLY: distribution_1d_release,&
34 : distribution_1d_retain,&
35 : distribution_1d_type
36 : USE kinds, ONLY: dp
37 : USE message_passing, ONLY: mp_para_env_release,&
38 : mp_para_env_type
39 : USE molecule_kind_list_types, ONLY: molecule_kind_list_release,&
40 : molecule_kind_list_retain,&
41 : molecule_kind_list_type
42 : USE molecule_kind_types, ONLY: molecule_kind_type
43 : USE molecule_list_types, ONLY: molecule_list_release,&
44 : molecule_list_retain,&
45 : molecule_list_type
46 : USE molecule_types, ONLY: deallocate_global_constraint,&
47 : global_constraint_type,&
48 : molecule_type
49 : USE multipole_types, ONLY: multipole_type,&
50 : release_multipole_type
51 : USE particle_list_types, ONLY: particle_list_release,&
52 : particle_list_retain,&
53 : particle_list_type
54 : USE particle_types, ONLY: particle_type
55 : USE virial_types, ONLY: virial_type
56 : #include "../base/base_uses.f90"
57 :
58 : IMPLICIT NONE
59 : PRIVATE
60 :
61 : CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'cp_subsys_types'
62 : LOGICAL, PRIVATE, PARAMETER :: debug_this_module = .FALSE.
63 :
64 : PUBLIC :: cp_subsys_type, &
65 : cp_subsys_p_type
66 :
67 : PUBLIC :: cp_subsys_retain, &
68 : cp_subsys_release, &
69 : cp_subsys_get, &
70 : cp_subsys_set, &
71 : pack_subsys_particles, &
72 : unpack_subsys_particles
73 :
74 : ! **************************************************************************************************
75 : !> \brief represents a system: atoms, molecules, their pos,vel,...
76 : !> \param atomic_kinds list with all the kinds in the actual subsys
77 : !> \param particles list with the particles of the actual subsys
78 : !> \param local_particles the particles that are local to the actual processor
79 : !> \param molecule_kinds list with the molecule kinds
80 : !> \param local_molecules the molecule structures of the actual subsys
81 : !> that are local to this processor
82 : !> \param para_env the parallel environment of the actual subsys
83 : !> \param shell_particles list with the shells of the actual subsys if shell-model is used
84 : !> \param core_particles list with the shells of the actual subsys if shell-model is used
85 : !> \par History
86 : !> 07.2003 created [fawzi]
87 : !> \author Fawzi Mohamed
88 : ! **************************************************************************************************
89 : TYPE cp_subsys_type
90 : INTEGER :: ref_count = 1
91 : REAL(KIND=dp), DIMENSION(3, 2) :: seed = -1
92 : TYPE(atomic_kind_list_type), POINTER :: atomic_kinds => Null()
93 : TYPE(particle_list_type), POINTER :: particles => Null()
94 : TYPE(particle_list_type), POINTER :: shell_particles => Null()
95 : TYPE(particle_list_type), POINTER :: core_particles => Null()
96 : TYPE(distribution_1d_type), POINTER :: local_particles => Null()
97 : TYPE(mp_para_env_type), POINTER :: para_env => Null()
98 : ! molecules kinds
99 : TYPE(molecule_list_type), POINTER :: molecules => Null()
100 : TYPE(molecule_kind_list_type), POINTER :: molecule_kinds => Null()
101 : TYPE(distribution_1d_type), POINTER :: local_molecules => Null()
102 : ! Definitions of the collective variables
103 : TYPE(colvar_p_type), DIMENSION(:), POINTER :: colvar_p => Null()
104 : ! Intermolecular constraints
105 : TYPE(global_constraint_type), POINTER :: gci => Null()
106 : ! Multipoles
107 : TYPE(multipole_type), POINTER :: multipoles => Null()
108 : TYPE(atprop_type), POINTER :: atprop => Null()
109 : TYPE(virial_type), POINTER :: virial => Null()
110 : TYPE(cp_result_type), POINTER :: results => Null()
111 : TYPE(cell_type), POINTER :: cell => Null()
112 : END TYPE cp_subsys_type
113 :
114 : ! **************************************************************************************************
115 : !> \brief represent a pointer to a subsys, to be able to create arrays
116 : !> of pointers
117 : !> \param subsys the pointer to the subsys
118 : !> \par History
119 : !> 07.2003 created [fawzi]
120 : !> \author Fawzi Mohamed
121 : ! **************************************************************************************************
122 : TYPE cp_subsys_p_type
123 : TYPE(cp_subsys_type), POINTER :: subsys => NULL()
124 : END TYPE cp_subsys_p_type
125 :
126 : CONTAINS
127 :
128 : ! **************************************************************************************************
129 : !> \brief retains a subsys (see doc/ReferenceCounting.html)
130 : !> \param subsys the subsys to retain
131 : !> \par History
132 : !> 07.2003 created [fawzi]
133 : !> \author Fawzi Mohamed
134 : ! **************************************************************************************************
135 6702 : SUBROUTINE cp_subsys_retain(subsys)
136 : TYPE(cp_subsys_type), INTENT(INOUT) :: subsys
137 :
138 6702 : CPASSERT(subsys%ref_count > 0)
139 6702 : subsys%ref_count = subsys%ref_count + 1
140 6702 : END SUBROUTINE cp_subsys_retain
141 :
142 : ! **************************************************************************************************
143 : !> \brief releases a subsys (see doc/ReferenceCounting.html)
144 : !> \param subsys the subsys to release
145 : !> \par History
146 : !> 07.2003 created [fawzi]
147 : !> \author Fawzi Mohamed
148 : ! **************************************************************************************************
149 22913 : SUBROUTINE cp_subsys_release(subsys)
150 : TYPE(cp_subsys_type), POINTER :: subsys
151 :
152 22913 : IF (ASSOCIATED(subsys)) THEN
153 16211 : CPASSERT(subsys%ref_count > 0)
154 16211 : subsys%ref_count = subsys%ref_count - 1
155 16211 : IF (subsys%ref_count == 0) THEN
156 9509 : CALL atomic_kind_list_release(subsys%atomic_kinds)
157 9509 : CALL particle_list_release(subsys%particles)
158 9509 : CALL particle_list_release(subsys%shell_particles)
159 9509 : CALL particle_list_release(subsys%core_particles)
160 9509 : CALL distribution_1d_release(subsys%local_particles)
161 9509 : CALL molecule_kind_list_release(subsys%molecule_kinds)
162 9509 : CALL molecule_list_release(subsys%molecules)
163 9509 : CALL distribution_1d_release(subsys%local_molecules)
164 9509 : CALL mp_para_env_release(subsys%para_env)
165 9509 : IF (ASSOCIATED(subsys%multipoles)) THEN
166 138 : CALL release_multipole_type(subsys%multipoles)
167 138 : DEALLOCATE (subsys%multipoles)
168 : END IF
169 9509 : CALL colvar_p_release(subsys%colvar_p)
170 9509 : CALL deallocate_global_constraint(subsys%gci)
171 9509 : CALL atprop_release(subsys%atprop)
172 9509 : IF (ASSOCIATED(subsys%virial)) DEALLOCATE (subsys%virial)
173 9509 : CALL cp_result_release(subsys%results)
174 9509 : CALL cell_release(subsys%cell)
175 9509 : DEALLOCATE (subsys)
176 : END IF
177 16211 : NULLIFY (subsys)
178 : END IF
179 22913 : END SUBROUTINE cp_subsys_release
180 :
181 : ! **************************************************************************************************
182 : !> \brief sets various propreties of the subsys
183 : !> \param subsys the subsys you want to modify
184 : !> \param atomic_kinds ...
185 : !> \param particles ...
186 : !> \param local_particles ...
187 : !> \param molecules ...
188 : !> \param molecule_kinds ...
189 : !> \param local_molecules ...
190 : !> \param para_env ...
191 : !> \param colvar_p ...
192 : !> \param shell_particles ...
193 : !> \param core_particles ...
194 : !> \param gci ...
195 : !> \param multipoles ...
196 : !> \param results ...
197 : !> \param cell ...
198 : !> \par History
199 : !> 08.2003 created [fawzi]
200 : !> \author Fawzi Mohamed
201 : ! **************************************************************************************************
202 77212 : SUBROUTINE cp_subsys_set(subsys, atomic_kinds, particles, local_particles, &
203 : molecules, molecule_kinds, local_molecules, para_env, &
204 : colvar_p, shell_particles, core_particles, gci, multipoles, results, cell)
205 : TYPE(cp_subsys_type), INTENT(INOUT) :: subsys
206 : TYPE(atomic_kind_list_type), OPTIONAL, POINTER :: atomic_kinds
207 : TYPE(particle_list_type), OPTIONAL, POINTER :: particles
208 : TYPE(distribution_1d_type), OPTIONAL, POINTER :: local_particles
209 : TYPE(molecule_list_type), OPTIONAL, POINTER :: molecules
210 : TYPE(molecule_kind_list_type), OPTIONAL, POINTER :: molecule_kinds
211 : TYPE(distribution_1d_type), OPTIONAL, POINTER :: local_molecules
212 : TYPE(mp_para_env_type), OPTIONAL, POINTER :: para_env
213 : TYPE(colvar_p_type), DIMENSION(:), OPTIONAL, &
214 : POINTER :: colvar_p
215 : TYPE(particle_list_type), OPTIONAL, POINTER :: shell_particles, core_particles
216 : TYPE(global_constraint_type), OPTIONAL, POINTER :: gci
217 : TYPE(multipole_type), OPTIONAL, POINTER :: multipoles
218 : TYPE(cp_result_type), OPTIONAL, POINTER :: results
219 : TYPE(cell_type), OPTIONAL, POINTER :: cell
220 :
221 77212 : CPASSERT(subsys%ref_count > 0)
222 77212 : IF (PRESENT(multipoles)) THEN
223 2639 : IF (ASSOCIATED(subsys%multipoles)) THEN
224 0 : IF (.NOT. ASSOCIATED(subsys%multipoles, multipoles)) THEN
225 0 : CALL release_multipole_type(subsys%multipoles)
226 0 : DEALLOCATE (subsys%multipoles)
227 : END IF
228 : END IF
229 2639 : subsys%multipoles => multipoles
230 : END IF
231 77212 : IF (PRESENT(atomic_kinds)) THEN
232 9509 : CALL atomic_kind_list_retain(atomic_kinds)
233 9509 : CALL atomic_kind_list_release(subsys%atomic_kinds)
234 9509 : subsys%atomic_kinds => atomic_kinds
235 : END IF
236 77212 : IF (PRESENT(particles)) THEN
237 11509 : CALL particle_list_retain(particles)
238 11509 : CALL particle_list_release(subsys%particles)
239 11509 : subsys%particles => particles
240 : END IF
241 77212 : IF (PRESENT(local_particles)) THEN
242 9511 : CALL distribution_1d_retain(local_particles)
243 9511 : CALL distribution_1d_release(subsys%local_particles)
244 9511 : subsys%local_particles => local_particles
245 : END IF
246 77212 : IF (PRESENT(local_molecules)) THEN
247 9511 : CALL distribution_1d_retain(local_molecules)
248 9511 : CALL distribution_1d_release(subsys%local_molecules)
249 9511 : subsys%local_molecules => local_molecules
250 : END IF
251 77212 : IF (PRESENT(molecule_kinds)) THEN
252 9509 : CALL molecule_kind_list_retain(molecule_kinds)
253 9509 : CALL molecule_kind_list_release(subsys%molecule_kinds)
254 9509 : subsys%molecule_kinds => molecule_kinds
255 : END IF
256 77212 : IF (PRESENT(molecules)) THEN
257 9509 : CALL molecule_list_retain(molecules)
258 9509 : CALL molecule_list_release(subsys%molecules)
259 9509 : subsys%molecules => molecules
260 : END IF
261 77212 : IF (PRESENT(para_env)) THEN
262 0 : CALL para_env%retain()
263 0 : CALL mp_para_env_release(subsys%para_env)
264 0 : subsys%para_env => para_env
265 : END IF
266 77212 : IF (PRESENT(colvar_p)) THEN
267 0 : CPASSERT(.NOT. ASSOCIATED(subsys%colvar_p))
268 0 : subsys%colvar_p => colvar_p
269 : END IF
270 77212 : IF (PRESENT(shell_particles)) THEN
271 2639 : IF (ASSOCIATED(shell_particles)) THEN
272 258 : CALL particle_list_retain(shell_particles)
273 258 : CALL particle_list_release(subsys%shell_particles)
274 258 : subsys%shell_particles => shell_particles
275 : END IF
276 : END IF
277 77212 : IF (PRESENT(core_particles)) THEN
278 2639 : IF (ASSOCIATED(core_particles)) THEN
279 258 : CALL particle_list_retain(core_particles)
280 258 : CALL particle_list_release(subsys%core_particles)
281 258 : subsys%core_particles => core_particles
282 : END IF
283 : END IF
284 77212 : IF (PRESENT(gci)) THEN
285 0 : CPASSERT(.NOT. ASSOCIATED(subsys%gci))
286 0 : subsys%gci => gci
287 : END IF
288 77212 : IF (PRESENT(results)) THEN
289 5206 : IF (ASSOCIATED(results)) THEN
290 5206 : CALL cp_result_retain(results)
291 5206 : CALL cp_result_release(subsys%results)
292 5206 : subsys%results => results
293 : END IF
294 : END IF
295 77212 : IF (PRESENT(cell)) THEN
296 27065 : IF (ASSOCIATED(cell)) THEN
297 27065 : CALL cell_retain(cell)
298 27065 : CALL cell_release(subsys%cell)
299 27065 : subsys%cell => cell
300 : END IF
301 : END IF
302 77212 : END SUBROUTINE cp_subsys_set
303 :
304 : ! **************************************************************************************************
305 : !> \brief returns information about various attributes of the given subsys
306 : !> \param subsys the subsys you want info about
307 : !> \param ref_count ...
308 : !> \param atomic_kinds ...
309 : !> \param atomic_kind_set ...
310 : !> \param particles ...
311 : !> \param particle_set ...
312 : !> \param local_particles ...
313 : !> \param molecules ...
314 : !> \param molecule_set ...
315 : !> \param molecule_kinds ...
316 : !> \param molecule_kind_set ...
317 : !> \param local_molecules ...
318 : !> \param para_env ...
319 : !> \param colvar_p ...
320 : !> \param shell_particles ...
321 : !> \param core_particles ...
322 : !> \param gci ...
323 : !> \param multipoles ...
324 : !> \param natom ...
325 : !> \param nparticle ...
326 : !> \param ncore ...
327 : !> \param nshell ...
328 : !> \param nkind ...
329 : !> \param atprop ...
330 : !> \param virial ...
331 : !> \param results ...
332 : !> \param cell ...
333 : !> \par History
334 : !> 08.2003 created [fawzi]
335 : !> 22.11.2010 (MK)
336 : !> \author Fawzi Mohamed
337 : ! **************************************************************************************************
338 13571106 : SUBROUTINE cp_subsys_get(subsys, ref_count, atomic_kinds, atomic_kind_set, &
339 : particles, particle_set, &
340 : local_particles, molecules, molecule_set, molecule_kinds, &
341 : molecule_kind_set, local_molecules, para_env, colvar_p, &
342 : shell_particles, core_particles, gci, multipoles, &
343 : natom, nparticle, ncore, nshell, nkind, atprop, virial, &
344 : results, cell)
345 : TYPE(cp_subsys_type), INTENT(IN) :: subsys
346 : INTEGER, INTENT(out), OPTIONAL :: ref_count
347 : TYPE(atomic_kind_list_type), OPTIONAL, POINTER :: atomic_kinds
348 : TYPE(atomic_kind_type), DIMENSION(:), OPTIONAL, &
349 : POINTER :: atomic_kind_set
350 : TYPE(particle_list_type), OPTIONAL, POINTER :: particles
351 : TYPE(particle_type), DIMENSION(:), OPTIONAL, &
352 : POINTER :: particle_set
353 : TYPE(distribution_1d_type), OPTIONAL, POINTER :: local_particles
354 : TYPE(molecule_list_type), OPTIONAL, POINTER :: molecules
355 : TYPE(molecule_type), DIMENSION(:), OPTIONAL, &
356 : POINTER :: molecule_set
357 : TYPE(molecule_kind_list_type), OPTIONAL, POINTER :: molecule_kinds
358 : TYPE(molecule_kind_type), DIMENSION(:), OPTIONAL, &
359 : POINTER :: molecule_kind_set
360 : TYPE(distribution_1d_type), OPTIONAL, POINTER :: local_molecules
361 : TYPE(mp_para_env_type), OPTIONAL, POINTER :: para_env
362 : TYPE(colvar_p_type), DIMENSION(:), OPTIONAL, &
363 : POINTER :: colvar_p
364 : TYPE(particle_list_type), OPTIONAL, POINTER :: shell_particles, core_particles
365 : TYPE(global_constraint_type), OPTIONAL, POINTER :: gci
366 : TYPE(multipole_type), OPTIONAL, POINTER :: multipoles
367 : INTEGER, INTENT(out), OPTIONAL :: natom, nparticle, ncore, nshell, nkind
368 : TYPE(atprop_type), OPTIONAL, POINTER :: atprop
369 : TYPE(virial_type), OPTIONAL, POINTER :: virial
370 : TYPE(cp_result_type), OPTIONAL, POINTER :: results
371 : TYPE(cell_type), OPTIONAL, POINTER :: cell
372 :
373 : INTEGER :: n_atom, n_core, n_shell
374 :
375 13571106 : n_atom = 0
376 13571106 : n_core = 0
377 13571106 : n_shell = 0
378 :
379 13571106 : CPASSERT(subsys%ref_count > 0)
380 :
381 13571106 : IF (PRESENT(ref_count)) ref_count = subsys%ref_count
382 13571106 : IF (PRESENT(atomic_kinds)) atomic_kinds => subsys%atomic_kinds
383 13571106 : IF (PRESENT(atomic_kind_set)) atomic_kind_set => subsys%atomic_kinds%els
384 13571106 : IF (PRESENT(particles)) particles => subsys%particles
385 13571106 : IF (PRESENT(particle_set)) particle_set => subsys%particles%els
386 13571106 : IF (PRESENT(local_particles)) local_particles => subsys%local_particles
387 13571106 : IF (PRESENT(molecules)) molecules => subsys%molecules
388 13571106 : IF (PRESENT(molecule_set)) molecule_set => subsys%molecules%els
389 13571106 : IF (PRESENT(molecule_kinds)) molecule_kinds => subsys%molecule_kinds
390 13571106 : IF (PRESENT(molecule_kind_set)) molecule_kind_set => subsys%molecule_kinds%els
391 13571106 : IF (PRESENT(local_molecules)) local_molecules => subsys%local_molecules
392 13571106 : IF (PRESENT(para_env)) para_env => subsys%para_env
393 13571106 : IF (PRESENT(colvar_p)) colvar_p => subsys%colvar_p
394 13571106 : IF (PRESENT(shell_particles)) shell_particles => subsys%shell_particles
395 13571106 : IF (PRESENT(core_particles)) core_particles => subsys%core_particles
396 13571106 : IF (PRESENT(gci)) gci => subsys%gci
397 13571106 : IF (PRESENT(multipoles)) multipoles => subsys%multipoles
398 13571106 : IF (PRESENT(virial)) virial => subsys%virial
399 13571106 : IF (PRESENT(atprop)) atprop => subsys%atprop
400 13571106 : IF (PRESENT(results)) results => subsys%results
401 13571106 : IF (PRESENT(cell)) cell => subsys%cell
402 13571106 : IF (PRESENT(nkind)) nkind = SIZE(subsys%atomic_kinds%els)
403 :
404 13571106 : IF (PRESENT(natom) .OR. PRESENT(nparticle) .OR. PRESENT(nshell)) THEN
405 : ! An atomic particle set should be present in each subsystem at the moment
406 736516 : CPASSERT(ASSOCIATED(subsys%particles))
407 736516 : n_atom = subsys%particles%n_els
408 : ! Check if we have other kinds of particles in this subsystem
409 736516 : IF (ASSOCIATED(subsys%shell_particles)) THEN
410 42038 : n_shell = subsys%shell_particles%n_els
411 42038 : CPASSERT(ASSOCIATED(subsys%core_particles))
412 42038 : n_core = subsys%core_particles%n_els
413 : ! The same number of shell and core particles is assumed
414 42038 : CPASSERT(n_core == n_shell)
415 694478 : ELSE IF (ASSOCIATED(subsys%core_particles)) THEN
416 : ! This case should not occur at the moment
417 0 : CPASSERT(ASSOCIATED(subsys%shell_particles))
418 : ELSE
419 : n_core = 0
420 : n_shell = 0
421 : END IF
422 736516 : IF (PRESENT(natom)) natom = n_atom
423 736516 : IF (PRESENT(nparticle)) nparticle = n_atom + n_shell
424 736516 : IF (PRESENT(ncore)) ncore = n_core
425 736516 : IF (PRESENT(nshell)) nshell = n_shell
426 : END IF
427 :
428 13571106 : END SUBROUTINE cp_subsys_get
429 :
430 : ! **************************************************************************************************
431 : !> \brief Pack components of a subsystem particle sets into a single vector
432 : !> \param subsys ...
433 : !> \param f ...
434 : !> \param r ...
435 : !> \param s ...
436 : !> \param v ...
437 : !> \param fscale ...
438 : !> \param cell ...
439 : !> \date 19.11.10
440 : !> \author Matthias Krack (MK)
441 : !> \version 1.0
442 : !> \note It is assumed that f, r, s, or v are properly allocated already
443 : ! **************************************************************************************************
444 29621 : SUBROUTINE pack_subsys_particles(subsys, f, r, s, v, fscale, cell)
445 :
446 : TYPE(cp_subsys_type), INTENT(IN) :: subsys
447 : REAL(KIND=dp), DIMENSION(:), INTENT(OUT), OPTIONAL :: f, r, s, v
448 : REAL(KIND=dp), INTENT(IN), OPTIONAL :: fscale
449 : TYPE(cell_type), OPTIONAL, POINTER :: cell
450 :
451 : INTEGER :: i, iatom, j, k, natom, nparticle, nsize, &
452 : shell_index
453 : REAL(KIND=dp), DIMENSION(3) :: rs
454 : TYPE(particle_list_type), POINTER :: core_particles, particles, &
455 : shell_particles
456 :
457 29621 : IF (PRESENT(s)) THEN
458 0 : CPASSERT(PRESENT(cell))
459 0 : CPASSERT(ASSOCIATED(cell))
460 : END IF
461 :
462 29621 : NULLIFY (core_particles)
463 29621 : NULLIFY (particles)
464 29621 : NULLIFY (shell_particles)
465 :
466 : CALL cp_subsys_get(subsys, &
467 : core_particles=core_particles, &
468 : natom=natom, &
469 : nparticle=nparticle, &
470 : particles=particles, &
471 29621 : shell_particles=shell_particles)
472 :
473 29621 : nsize = 3*nparticle
474 :
475 : ! Pack forces
476 :
477 29621 : IF (PRESENT(f)) THEN
478 23188 : CPASSERT((SIZE(f) >= nsize))
479 23188 : j = 0
480 1139901 : DO iatom = 1, natom
481 1116713 : shell_index = particles%els(iatom)%shell_index
482 1139901 : IF (shell_index == 0) THEN
483 3273588 : DO i = 1, 3
484 2455191 : j = j + 1
485 3273588 : f(j) = particles%els(iatom)%f(i)
486 : END DO
487 : ELSE
488 1193264 : DO i = 1, 3
489 894948 : j = j + 1
490 1193264 : f(j) = core_particles%els(shell_index)%f(i)
491 : END DO
492 298316 : k = 3*(natom + shell_index - 1)
493 1193264 : DO i = 1, 3
494 1193264 : f(k + i) = shell_particles%els(shell_index)%f(i)
495 : END DO
496 : END IF
497 : END DO
498 2667331 : IF (PRESENT(fscale)) f(1:nsize) = fscale*f(1:nsize)
499 : END IF
500 :
501 : ! Pack coordinates
502 :
503 29621 : IF (PRESENT(r)) THEN
504 6433 : CPASSERT((SIZE(r) >= nsize))
505 6433 : j = 0
506 176217 : DO iatom = 1, natom
507 169784 : shell_index = particles%els(iatom)%shell_index
508 176217 : IF (shell_index == 0) THEN
509 616352 : DO i = 1, 3
510 462264 : j = j + 1
511 616352 : r(j) = particles%els(iatom)%r(i)
512 : END DO
513 : ELSE
514 62784 : DO i = 1, 3
515 47088 : j = j + 1
516 62784 : r(j) = core_particles%els(shell_index)%r(i)
517 : END DO
518 15696 : k = 3*(natom + shell_index - 1)
519 62784 : DO i = 1, 3
520 62784 : r(k + i) = shell_particles%els(shell_index)%r(i)
521 : END DO
522 : END IF
523 : END DO
524 : END IF
525 :
526 : ! Pack as scaled coordinates
527 :
528 29621 : IF (PRESENT(s)) THEN
529 0 : CPASSERT((SIZE(s) >= nsize))
530 0 : j = 0
531 0 : DO iatom = 1, natom
532 0 : shell_index = particles%els(iatom)%shell_index
533 0 : IF (shell_index == 0) THEN
534 0 : CALL real_to_scaled(rs, particles%els(iatom)%r, cell)
535 0 : DO i = 1, 3
536 0 : j = j + 1
537 0 : s(j) = rs(i)
538 : END DO
539 : ELSE
540 0 : CALL real_to_scaled(rs, core_particles%els(shell_index)%r, cell)
541 0 : DO i = 1, 3
542 0 : j = j + 1
543 0 : s(j) = rs(i)
544 : END DO
545 0 : CALL real_to_scaled(rs, shell_particles%els(shell_index)%r, cell)
546 0 : k = 3*(natom + shell_index - 1)
547 0 : DO i = 1, 3
548 0 : s(k + i) = rs(i)
549 : END DO
550 : END IF
551 : END DO
552 : END IF
553 :
554 : ! Pack velocities
555 :
556 29621 : IF (PRESENT(v)) THEN
557 0 : CPASSERT((SIZE(v) >= nsize))
558 0 : j = 0
559 0 : DO iatom = 1, natom
560 0 : shell_index = particles%els(iatom)%shell_index
561 0 : IF (shell_index == 0) THEN
562 0 : DO i = 1, 3
563 0 : j = j + 1
564 0 : v(j) = particles%els(iatom)%v(i)
565 : END DO
566 : ELSE
567 0 : DO i = 1, 3
568 0 : j = j + 1
569 0 : v(j) = core_particles%els(shell_index)%v(i)
570 : END DO
571 0 : k = 3*(natom + shell_index - 1)
572 0 : DO i = 1, 3
573 0 : v(k + i) = shell_particles%els(shell_index)%v(i)
574 : END DO
575 : END IF
576 : END DO
577 : END IF
578 :
579 29621 : END SUBROUTINE pack_subsys_particles
580 :
581 : ! **************************************************************************************************
582 : !> \brief Unpack components of a subsystem particle sets into a single vector
583 : !> \param subsys ...
584 : !> \param f ...
585 : !> \param r ...
586 : !> \param s ...
587 : !> \param v ...
588 : !> \param fscale ...
589 : !> \param cell ...
590 : !> \date 19.11.10
591 : !> \author Matthias Krack (MK)
592 : !> \version 1.0
593 : ! **************************************************************************************************
594 42219 : SUBROUTINE unpack_subsys_particles(subsys, f, r, s, v, fscale, cell)
595 :
596 : TYPE(cp_subsys_type), INTENT(IN) :: subsys
597 : REAL(KIND=dp), DIMENSION(:), INTENT(IN), OPTIONAL :: f, r, s, v
598 : REAL(KIND=dp), INTENT(IN), OPTIONAL :: fscale
599 : TYPE(cell_type), OPTIONAL, POINTER :: cell
600 :
601 : INTEGER :: i, iatom, j, k, natom, nparticle, nsize, &
602 : shell_index
603 : REAL(KIND=dp) :: fc, fs, mass, my_fscale
604 : REAL(KIND=dp), DIMENSION(3) :: rs
605 : TYPE(particle_list_type), POINTER :: core_particles, particles, &
606 : shell_particles
607 :
608 42219 : NULLIFY (core_particles)
609 42219 : NULLIFY (particles)
610 42219 : NULLIFY (shell_particles)
611 :
612 : CALL cp_subsys_get(subsys, &
613 : core_particles=core_particles, &
614 : natom=natom, &
615 : nparticle=nparticle, &
616 : particles=particles, &
617 42219 : shell_particles=shell_particles)
618 :
619 42219 : nsize = 3*nparticle
620 :
621 : ! Unpack forces
622 :
623 42219 : IF (PRESENT(f)) THEN
624 0 : CPASSERT((SIZE(f) >= nsize))
625 0 : IF (PRESENT(fscale)) THEN
626 0 : my_fscale = fscale
627 : ELSE
628 : my_fscale = 1.0_dp
629 : END IF
630 0 : j = 0
631 0 : DO iatom = 1, natom
632 0 : shell_index = particles%els(iatom)%shell_index
633 0 : IF (shell_index == 0) THEN
634 0 : DO i = 1, 3
635 0 : j = j + 1
636 0 : particles%els(iatom)%f(i) = my_fscale*f(j)
637 : END DO
638 : ELSE
639 0 : DO i = 1, 3
640 0 : j = j + 1
641 0 : core_particles%els(shell_index)%f(i) = my_fscale*f(j)
642 : END DO
643 0 : k = 3*(natom + shell_index - 1)
644 0 : DO i = 1, 3
645 0 : shell_particles%els(shell_index)%f(i) = my_fscale*f(k + i)
646 : END DO
647 : END IF
648 : END DO
649 : END IF
650 :
651 : ! Unpack coordinates
652 :
653 42219 : IF (PRESENT(r)) THEN
654 42075 : CPASSERT((SIZE(r) >= nsize))
655 42075 : j = 0
656 1656334 : DO iatom = 1, natom
657 1614259 : shell_index = particles%els(iatom)%shell_index
658 1656334 : IF (shell_index == 0) THEN
659 5403868 : DO i = 1, 3
660 4052901 : j = j + 1
661 5403868 : particles%els(iatom)%r(i) = r(j)
662 : END DO
663 : ELSE
664 1053168 : DO i = 1, 3
665 789876 : j = j + 1
666 1053168 : core_particles%els(shell_index)%r(i) = r(j)
667 : END DO
668 263292 : k = 3*(natom + shell_index - 1)
669 1053168 : DO i = 1, 3
670 1053168 : shell_particles%els(shell_index)%r(i) = r(k + i)
671 : END DO
672 : ! Update atomic position due to core and shell motion
673 263292 : mass = particles%els(iatom)%atomic_kind%mass
674 263292 : fc = core_particles%els(shell_index)%atomic_kind%shell%mass_core/mass
675 263292 : fs = shell_particles%els(shell_index)%atomic_kind%shell%mass_shell/mass
676 : particles%els(iatom)%r(1:3) = fc*core_particles%els(shell_index)%r(1:3) + &
677 2106336 : fs*shell_particles%els(shell_index)%r(1:3)
678 : END IF
679 : END DO
680 : END IF
681 :
682 : ! Unpack scaled coordinates
683 :
684 42219 : IF (PRESENT(s)) THEN
685 0 : CPASSERT((SIZE(s) >= nsize))
686 0 : CPASSERT(PRESENT(cell))
687 0 : CPASSERT(ASSOCIATED(cell))
688 0 : j = 0
689 0 : DO iatom = 1, natom
690 0 : shell_index = particles%els(iatom)%shell_index
691 0 : IF (shell_index == 0) THEN
692 0 : DO i = 1, 3
693 0 : j = j + 1
694 0 : rs(i) = s(j)
695 : END DO
696 0 : CALL scaled_to_real(particles%els(iatom)%r, rs, cell)
697 : ELSE
698 0 : DO i = 1, 3
699 0 : j = j + 1
700 0 : rs(i) = s(j)
701 : END DO
702 0 : CALL scaled_to_real(core_particles%els(shell_index)%r, rs, cell)
703 0 : k = 3*(natom + shell_index - 1)
704 0 : DO i = 1, 3
705 0 : rs(i) = s(k + i)
706 : END DO
707 0 : CALL scaled_to_real(shell_particles%els(shell_index)%r, rs, cell)
708 : ! Update atomic position due to core and shell motion
709 0 : mass = particles%els(iatom)%atomic_kind%mass
710 0 : fc = core_particles%els(shell_index)%atomic_kind%shell%mass_core/mass
711 0 : fs = shell_particles%els(shell_index)%atomic_kind%shell%mass_shell/mass
712 : particles%els(iatom)%r(1:3) = fc*core_particles%els(shell_index)%r(1:3) + &
713 0 : fs*shell_particles%els(shell_index)%r(1:3)
714 : END IF
715 : END DO
716 : END IF
717 :
718 : ! Unpack velocities
719 :
720 42219 : IF (PRESENT(v)) THEN
721 144 : CPASSERT((SIZE(v) >= nsize))
722 144 : j = 0
723 25110 : DO iatom = 1, natom
724 24966 : shell_index = particles%els(iatom)%shell_index
725 25110 : IF (shell_index == 0) THEN
726 98344 : DO i = 1, 3
727 73758 : j = j + 1
728 98344 : particles%els(iatom)%v(i) = v(j)
729 : END DO
730 : ELSE
731 1520 : DO i = 1, 3
732 1140 : j = j + 1
733 1520 : core_particles%els(shell_index)%v(i) = v(j)
734 : END DO
735 380 : k = 3*(natom + shell_index - 1)
736 1520 : DO i = 1, 3
737 1520 : shell_particles%els(shell_index)%v(i) = v(k + i)
738 : END DO
739 : ! Update atomic velocity due to core and shell motion
740 380 : mass = particles%els(iatom)%atomic_kind%mass
741 380 : fc = core_particles%els(shell_index)%atomic_kind%shell%mass_core/mass
742 380 : fs = shell_particles%els(shell_index)%atomic_kind%shell%mass_shell/mass
743 : particles%els(iatom)%v(1:3) = fc*core_particles%els(shell_index)%v(1:3) + &
744 3040 : fs*shell_particles%els(shell_index)%v(1:3)
745 : END IF
746 : END DO
747 : END IF
748 :
749 42219 : END SUBROUTINE unpack_subsys_particles
750 :
751 0 : END MODULE cp_subsys_types
|
