(git:374b731)
Loading...
Searching...
No Matches
ewalds_multipole.F
Go to the documentation of this file.
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 Treats the electrostatic for multipoles (up to quadrupoles)
10!> \author Teodoro Laino [tlaino] - 12.2007 - University of Zurich
11!> inclusion of optional electric field damping for the polarizable atoms
12!> Rodolphe Vuilleumier and Mathieu Salanne - 12.2009
13! **************************************************************************************************
14MODULE ewalds_multipole
15 USE atomic_kind_types, ONLY: atomic_kind_type
16 USE bibliography, ONLY: aguado2003, &
17 laino2008, &
18 cite_reference
19 USE cell_types, ONLY: cell_type, &
20 pbc
21 USE cp_log_handling, ONLY: cp_get_default_logger, &
22 cp_logger_type
23 USE damping_dipole_types, ONLY: damping_type, &
24 no_damping, &
25 tang_toennies
26 USE dg_rho0_types, ONLY: dg_rho0_type
27 USE dg_types, ONLY: dg_get, &
28 dg_type
29 USE distribution_1d_types, ONLY: distribution_1d_type
30 USE ewald_environment_types, ONLY: ewald_env_get, &
31 ewald_environment_type
32 USE ewald_pw_types, ONLY: ewald_pw_get, &
33 ewald_pw_type
34 USE fist_neighbor_list_control, ONLY: list_control
35 USE fist_neighbor_list_types, ONLY: fist_neighbor_type, &
36 neighbor_kind_pairs_type
37 USE fist_nonbond_env_types, ONLY: fist_nonbond_env_get, &
38 fist_nonbond_env_type, &
39 pos_type
40 USE input_section_types, ONLY: section_vals_type
41 USE kinds, ONLY: dp
42 USE mathconstants, ONLY: fourpi, &
43 oorootpi, &
44 pi, &
45 sqrthalf
46 USE message_passing, ONLY: mp_comm_type
47 USE parallel_rng_types, ONLY: uniform, &
48 rng_stream_type
49 USE particle_types, ONLY: particle_type
50 USE pw_grid_types, ONLY: pw_grid_type
51 USE pw_pool_types, ONLY: pw_pool_type
52 USE structure_factor_types, ONLY: structure_factor_type
53 USE structure_factors, ONLY: structure_factor_allocate, &
54 structure_factor_deallocate, &
55 structure_factor_evaluate
56#include "./base/base_uses.f90"
57
58
59 IMPLICIT NONE
60 PRIVATE
61
62 LOGICAL, PRIVATE, PARAMETER :: debug_this_module = .false.
63 LOGICAL, PRIVATE, PARAMETER :: debug_r_space = .false.
64 LOGICAL, PRIVATE, PARAMETER :: debug_g_space = .false.
65 LOGICAL, PRIVATE, PARAMETER :: debug_e_field = .false.
66 LOGICAL, PRIVATE, PARAMETER :: debug_e_field_en = .false.
67 CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'ewalds_multipole'
68
69 PUBLIC :: ewald_multipole_evaluate
70
71CONTAINS
72
73! **************************************************************************************************
74!> \brief Computes the potential and the force for a lattice sum of multipoles (up to quadrupole)
75!> \param ewald_env ...
76!> \param ewald_pw ...
77!> \param nonbond_env ...
78!> \param cell ...
79!> \param particle_set ...
80!> \param local_particles ...
81!> \param energy_local ...
82!> \param energy_glob ...
83!> \param e_neut ...
84!> \param e_self ...
85!> \param task ...
86!> \param do_correction_bonded ...
87!> \param do_forces ...
88!> \param do_stress ...
89!> \param do_efield ...
90!> \param radii ...
91!> \param charges ...
92!> \param dipoles ...
93!> \param quadrupoles ...
94!> \param forces_local ...
95!> \param forces_glob ...
96!> \param pv_local ...
97!> \param pv_glob ...
98!> \param efield0 ...
99!> \param efield1 ...
100!> \param efield2 ...
101!> \param iw ...
102!> \param do_debug ...
103!> \param atomic_kind_set ...
104!> \param mm_section ...
105!> \par Note
106!> atomic_kind_set and mm_section are between the arguments only
107!> for debug purpose (therefore optional) and can be avoided when this
108!> function is called in other part of the program
109!> \par Note
110!> When a gaussian multipole is used instead of point multipole, i.e.
111!> when radii(i)>0, the electrostatic fields (efield0, efield1, efield2)
112!> become derivatives of the electrostatic potential energy towards
113!> these gaussian multipoles.
114!> \author Teodoro Laino [tlaino] - 12.2007 - University of Zurich
115! **************************************************************************************************
116 RECURSIVE SUBROUTINE ewald_multipole_evaluate(ewald_env, ewald_pw, nonbond_env, &
117 cell, particle_set, local_particles, energy_local, energy_glob, e_neut, e_self, &
118 task, do_correction_bonded, do_forces, do_stress, &
119 do_efield, radii, charges, dipoles, &
120 quadrupoles, forces_local, forces_glob, pv_local, pv_glob, efield0, efield1, &
121 efield2, iw, do_debug, atomic_kind_set, mm_section)
122 TYPE(ewald_environment_type), POINTER :: ewald_env
123 TYPE(ewald_pw_type), POINTER :: ewald_pw
124 TYPE(fist_nonbond_env_type), POINTER :: nonbond_env
125 TYPE(cell_type), POINTER :: cell
126 TYPE(particle_type), POINTER :: particle_set(:)
127 TYPE(distribution_1d_type), POINTER :: local_particles
128 REAL(kind=dp), INTENT(INOUT) :: energy_local, energy_glob
129 REAL(kind=dp), INTENT(OUT) :: e_neut, e_self
130 LOGICAL, DIMENSION(3), INTENT(IN) :: task
131 LOGICAL, INTENT(IN) :: do_correction_bonded, do_forces, &
132 do_stress, do_efield
133 REAL(kind=dp), DIMENSION(:), OPTIONAL, POINTER :: radii, charges
134 REAL(kind=dp), DIMENSION(:, :), OPTIONAL, POINTER :: dipoles
135 REAL(kind=dp), DIMENSION(:, :, :), OPTIONAL, &
136 POINTER :: quadrupoles
137 REAL(kind=dp), DIMENSION(:, :), INTENT(INOUT), &
138 OPTIONAL :: forces_local, forces_glob, pv_local, &
139 pv_glob
140 REAL(kind=dp), DIMENSION(:), INTENT(OUT), OPTIONAL :: efield0
141 REAL(kind=dp), DIMENSION(:, :), INTENT(OUT), &
142 OPTIONAL :: efield1, efield2
143 INTEGER, INTENT(IN) :: iw
144 LOGICAL, INTENT(IN) :: do_debug
145 TYPE(atomic_kind_type), DIMENSION(:), OPTIONAL, &
146 POINTER :: atomic_kind_set
147 TYPE(section_vals_type), OPTIONAL, POINTER :: mm_section
148
149 CHARACTER(len=*), PARAMETER :: routinen = 'ewald_multipole_evaluate'
150
151 INTEGER :: handle, i, j, size1, size2
152 LOGICAL :: check_debug, check_efield, check_forces, &
153 do_task(3)
154 LOGICAL, DIMENSION(3, 3) :: my_task
155 REAL(kind=dp) :: e_bonded, e_bonded_t, e_rspace, &
156 e_rspace_t, energy_glob_t
157 REAL(kind=dp), DIMENSION(:), POINTER :: efield0_lr, efield0_sr
158 REAL(kind=dp), DIMENSION(:, :), POINTER :: efield1_lr, efield1_sr, efield2_lr, &
159 efield2_sr
160 TYPE(mp_comm_type) :: group
161
162 CALL cite_reference(aguado2003)
163 CALL cite_reference(laino2008)
164 CALL timeset(routinen, handle)
165 cpassert(ASSOCIATED(nonbond_env))
166 check_debug = (debug_this_module .OR. debug_r_space .OR. debug_g_space .OR. debug_e_field .OR. debug_e_field_en) &
167 .EQV. debug_this_module
168 cpassert(check_debug)
169 check_forces = do_forces .EQV. (PRESENT(forces_local) .AND. PRESENT(forces_glob))
170 cpassert(check_forces)
171 check_efield = do_efield .EQV. (PRESENT(efield0) .OR. PRESENT(efield1) .OR. PRESENT(efield2))
172 cpassert(check_efield)
173 ! Debugging this module
174 IF (debug_this_module .AND. do_debug) THEN
175 ! Debug specifically real space part
176 IF (debug_r_space) THEN
177 CALL debug_ewald_multipoles(ewald_env, ewald_pw, nonbond_env, cell, &
178 particle_set, local_particles, iw, debug_r_space)
179 cpabort("Debug Multipole Requested: Real Part!")
180 END IF
181 ! Debug electric fields and gradients as pure derivatives
182 IF (debug_e_field) THEN
183 cpassert(PRESENT(atomic_kind_set))
184 cpassert(PRESENT(mm_section))
185 CALL debug_ewald_multipoles_fields(ewald_env, ewald_pw, nonbond_env, &
186 cell, particle_set, local_particles, radii, charges, dipoles, &
187 quadrupoles, task, iw, atomic_kind_set, mm_section)
188 cpabort("Debug Multipole Requested: POT+EFIELDS+GRAD!")
189 END IF
190 ! Debug the potential, electric fields and electric fields gradient in oder
191 ! to retrieve the correct energy
192 IF (debug_e_field_en) THEN
193 CALL debug_ewald_multipoles_fields2(ewald_env, ewald_pw, nonbond_env, &
194 cell, particle_set, local_particles, radii, charges, dipoles, &
195 quadrupoles, task, iw)
196 cpabort("Debug Multipole Requested: POT+EFIELDS+GRAD to give the correct energy!!")
197 END IF
198 END IF
199
200 ! Setup the tasks (needed to skip useless parts in the real-space term)
201 do_task = task
202 DO i = 1, 3
203 IF (do_task(i)) THEN
204 SELECT CASE (i)
205 CASE (1)
206 do_task(1) = any(charges /= 0.0_dp)
207 CASE (2)
208 do_task(2) = any(dipoles /= 0.0_dp)
209 CASE (3)
210 do_task(3) = any(quadrupoles /= 0.0_dp)
211 END SELECT
212 END IF
213 END DO
214 DO i = 1, 3
215 DO j = i, 3
216 my_task(j, i) = do_task(i) .AND. do_task(j)
217 my_task(i, j) = my_task(j, i)
218 END DO
219 END DO
220
221 ! Allocate arrays for the evaluation of the potential, fields and electrostatic field gradients
222 NULLIFY (efield0_sr, efield0_lr, efield1_sr, efield1_lr, efield2_sr, efield2_lr)
223 IF (do_efield) THEN
224 IF (PRESENT(efield0)) THEN
225 size1 = SIZE(efield0)
226 ALLOCATE (efield0_sr(size1))
227 ALLOCATE (efield0_lr(size1))
228 efield0_sr = 0.0_dp
229 efield0_lr = 0.0_dp
230 END IF
231 IF (PRESENT(efield1)) THEN
232 size1 = SIZE(efield1, 1)
233 size2 = SIZE(efield1, 2)
234 ALLOCATE (efield1_sr(size1, size2))
235 ALLOCATE (efield1_lr(size1, size2))
236 efield1_sr = 0.0_dp
237 efield1_lr = 0.0_dp
238 END IF
239 IF (PRESENT(efield2)) THEN
240 size1 = SIZE(efield2, 1)
241 size2 = SIZE(efield2, 2)
242 ALLOCATE (efield2_sr(size1, size2))
243 ALLOCATE (efield2_lr(size1, size2))
244 efield2_sr = 0.0_dp
245 efield2_lr = 0.0_dp
246 END IF
247 END IF
248
249 e_rspace = 0.0_dp
250 e_bonded = 0.0_dp
251 IF ((.NOT. debug_g_space) .AND. (nonbond_env%do_nonbonded)) THEN
252 ! Compute the Real Space (Short-Range) part of the Ewald sum.
253 ! This contribution is only added when the nonbonded flag in the input
254 ! is set, because these contributions depend. the neighborlists.
255 CALL ewald_multipole_sr(nonbond_env, ewald_env, atomic_kind_set, &
256 particle_set, cell, e_rspace, my_task, &
257 do_forces, do_efield, do_stress, radii, charges, dipoles, quadrupoles, &
258 forces_glob, pv_glob, efield0_sr, efield1_sr, efield2_sr)
259 energy_glob = energy_glob + e_rspace
260
261 IF (do_correction_bonded) THEN
262 ! The corrections for bonded interactions are stored in the Real Space
263 ! (Short-Range) part of the fields array.
264 CALL ewald_multipole_bonded(nonbond_env, particle_set, ewald_env, &
265 cell, e_bonded, my_task, do_forces, do_efield, do_stress, &
266 charges, dipoles, quadrupoles, forces_glob, pv_glob, &
267 efield0_sr, efield1_sr, efield2_sr)
268 energy_glob = energy_glob + e_bonded
269 END IF
270 END IF
271
272 e_neut = 0.0_dp
273 e_self = 0.0_dp
274 energy_local = 0.0_dp
275 IF (.NOT. debug_r_space) THEN
276 ! Compute the Reciprocal Space (Long-Range) part of the Ewald sum
277 CALL ewald_multipole_lr(ewald_env, ewald_pw, cell, particle_set, &
278 local_particles, energy_local, my_task, do_forces, do_efield, do_stress, &
279 charges, dipoles, quadrupoles, forces_local, pv_local, efield0_lr, efield1_lr, &
280 efield2_lr)
281
282 ! Self-Interactions corrections
283 CALL ewald_multipole_self(ewald_env, cell, local_particles, e_self, &
284 e_neut, my_task, do_efield, radii, charges, dipoles, quadrupoles, &
285 efield0_lr, efield1_lr, efield2_lr)
286 END IF
287
288 ! Sumup energy contributions for possible IO
289 CALL ewald_env_get(ewald_env, group=group)
290 energy_glob_t = energy_glob
291 e_rspace_t = e_rspace
292 e_bonded_t = e_bonded
293 CALL group%sum(energy_glob_t)
294 CALL group%sum(e_rspace_t)
295 CALL group%sum(e_bonded_t)
296 ! Print some info about energetics
297 CALL ewald_multipole_print(iw, energy_local, e_rspace_t, e_bonded_t, e_self, e_neut)
298
299 ! Gather the components of the potential, fields and electrostatic field gradients
300 IF (do_efield) THEN
301 IF (PRESENT(efield0)) THEN
302 efield0 = efield0_sr + efield0_lr
303 CALL group%sum(efield0)
304 DEALLOCATE (efield0_sr)
305 DEALLOCATE (efield0_lr)
306 END IF
307 IF (PRESENT(efield1)) THEN
308 efield1 = efield1_sr + efield1_lr
309 CALL group%sum(efield1)
310 DEALLOCATE (efield1_sr)
311 DEALLOCATE (efield1_lr)
312 END IF
313 IF (PRESENT(efield2)) THEN
314 efield2 = efield2_sr + efield2_lr
315 CALL group%sum(efield2)
316 DEALLOCATE (efield2_sr)
317 DEALLOCATE (efield2_lr)
318 END IF
319 END IF
320 CALL timestop(handle)
321 END SUBROUTINE ewald_multipole_evaluate
322
323! **************************************************************************************************
324!> \brief computes the potential and the force for a lattice sum of multipoles
325!> up to quadrupole - Short Range (Real Space) Term
326!> \param nonbond_env ...
327!> \param ewald_env ...
328!> \param atomic_kind_set ...
329!> \param particle_set ...
330!> \param cell ...
331!> \param energy ...
332!> \param task ...
333!> \param do_forces ...
334!> \param do_efield ...
335!> \param do_stress ...
336!> \param radii ...
337!> \param charges ...
338!> \param dipoles ...
339!> \param quadrupoles ...
340!> \param forces ...
341!> \param pv ...
342!> \param efield0 ...
343!> \param efield1 ...
344!> \param efield2 ...
345!> \author Teodoro Laino [tlaino] - 12.2007 - University of Zurich
346! **************************************************************************************************
347 SUBROUTINE ewald_multipole_sr(nonbond_env, ewald_env, atomic_kind_set, &
348 particle_set, cell, energy, task, &
349 do_forces, do_efield, do_stress, radii, charges, dipoles, quadrupoles, &
350 forces, pv, efield0, efield1, efield2)
351 TYPE(fist_nonbond_env_type), POINTER :: nonbond_env
352 TYPE(ewald_environment_type), POINTER :: ewald_env
353 TYPE(atomic_kind_type), DIMENSION(:), OPTIONAL, &
354 POINTER :: atomic_kind_set
355 TYPE(particle_type), POINTER :: particle_set(:)
356 TYPE(cell_type), POINTER :: cell
357 REAL(kind=dp), INTENT(INOUT) :: energy
358 LOGICAL, DIMENSION(3, 3), INTENT(IN) :: task
359 LOGICAL, INTENT(IN) :: do_forces, do_efield, do_stress
360 REAL(kind=dp), DIMENSION(:), OPTIONAL, POINTER :: radii, charges
361 REAL(kind=dp), DIMENSION(:, :), OPTIONAL, POINTER :: dipoles
362 REAL(kind=dp), DIMENSION(:, :, :), OPTIONAL, &
363 POINTER :: quadrupoles
364 REAL(kind=dp), DIMENSION(:, :), INTENT(INOUT), &
365 OPTIONAL :: forces, pv
366 REAL(kind=dp), DIMENSION(:), POINTER :: efield0
367 REAL(kind=dp), DIMENSION(:, :), POINTER :: efield1, efield2
368
369 CHARACTER(len=*), PARAMETER :: routinen = 'ewald_multipole_SR'
370
371 INTEGER :: a, atom_a, atom_b, b, c, d, e, handle, i, iend, igrp, ikind, ilist, ipair, &
372 istart, itype_ij, itype_ji, jkind, k, kind_a, kind_b, kk, nkdamp_ij, nkdamp_ji, nkinds, &
373 npairs
374 INTEGER, DIMENSION(:, :), POINTER :: list
375 LOGICAL :: do_efield0, do_efield1, do_efield2, &
376 force_eval
377 REAL(kind=dp) :: alpha, beta, ch_i, ch_j, dampa_ij, dampa_ji, dampaexpi, dampaexpj, &
378 dampfac_ij, dampfac_ji, dampfuncdiffi, dampfuncdiffj, dampfunci, dampfuncj, dampsumfi, &
379 dampsumfj, ef0_i, ef0_j, eloc, fac, fac_ij, factorial, ir, irab2, ptens11, ptens12, &
380 ptens13, ptens21, ptens22, ptens23, ptens31, ptens32, ptens33, r, rab2, rab2_max, radius, &
381 rcut, tij, tmp, tmp1, tmp11, tmp12, tmp13, tmp2, tmp21, tmp22, tmp23, tmp31, tmp32, &
382 tmp33, tmp_ij, tmp_ji, xf
383 REAL(kind=dp), DIMENSION(0:5) :: f
384 REAL(kind=dp), DIMENSION(3) :: cell_v, cvi, damptij_a, damptji_a, dp_i, &
385 dp_j, ef1_i, ef1_j, fr, rab, tij_a
386 REAL(kind=dp), DIMENSION(3, 3) :: damptij_ab, damptji_ab, ef2_i, ef2_j, &
387 qp_i, qp_j, tij_ab
388 REAL(kind=dp), DIMENSION(3, 3, 3) :: tij_abc
389 REAL(kind=dp), DIMENSION(3, 3, 3, 3) :: tij_abcd
390 REAL(kind=dp), DIMENSION(3, 3, 3, 3, 3) :: tij_abcde
391 TYPE(damping_type) :: damping_ij, damping_ji
392 TYPE(fist_neighbor_type), POINTER :: nonbonded
393 TYPE(neighbor_kind_pairs_type), POINTER :: neighbor_kind_pair
394 TYPE(pos_type), DIMENSION(:), POINTER :: r_last_update, r_last_update_pbc
395
396 CALL timeset(routinen, handle)
397 NULLIFY (nonbonded, r_last_update, r_last_update_pbc)
398 do_efield0 = do_efield .AND. ASSOCIATED(efield0)
399 do_efield1 = do_efield .AND. ASSOCIATED(efield1)
400 do_efield2 = do_efield .AND. ASSOCIATED(efield2)
401 IF (do_stress) THEN
402 ptens11 = 0.0_dp; ptens12 = 0.0_dp; ptens13 = 0.0_dp
403 ptens21 = 0.0_dp; ptens22 = 0.0_dp; ptens23 = 0.0_dp
404 ptens31 = 0.0_dp; ptens32 = 0.0_dp; ptens33 = 0.0_dp
405 END IF
406 ! Get nonbond_env info
407 CALL fist_nonbond_env_get(nonbond_env, nonbonded=nonbonded, natom_types=nkinds, &
408 r_last_update=r_last_update, r_last_update_pbc=r_last_update_pbc)
409 CALL ewald_env_get(ewald_env, alpha=alpha, rcut=rcut)
410 rab2_max = rcut**2
411 IF (debug_r_space) THEN
412 rab2_max = huge(0.0_dp)
413 END IF
414 ! Starting the force loop
415 lists: DO ilist = 1, nonbonded%nlists
416 neighbor_kind_pair => nonbonded%neighbor_kind_pairs(ilist)
417 npairs = neighbor_kind_pair%npairs
418 IF (npairs == 0) cycle
419 list => neighbor_kind_pair%list
420 cvi = neighbor_kind_pair%cell_vector
421 cell_v = matmul(cell%hmat, cvi)
422 kind_group_loop: DO igrp = 1, neighbor_kind_pair%ngrp_kind
423 istart = neighbor_kind_pair%grp_kind_start(igrp)
424 iend = neighbor_kind_pair%grp_kind_end(igrp)
425 ikind = neighbor_kind_pair%ij_kind(1, igrp)
426 jkind = neighbor_kind_pair%ij_kind(2, igrp)
427
428 itype_ij = no_damping
429 nkdamp_ij = 1
430 dampa_ij = 1.0_dp
431 dampfac_ij = 0.0_dp
432
433 itype_ji = no_damping
434 nkdamp_ji = 1
435 dampa_ji = 1.0_dp
436 dampfac_ji = 0.0_dp
437 IF (PRESENT(atomic_kind_set)) THEN
438 IF (ASSOCIATED(atomic_kind_set(jkind)%damping)) THEN
439 damping_ij = atomic_kind_set(jkind)%damping%damp(ikind)
440 itype_ij = damping_ij%itype
441 nkdamp_ij = damping_ij%order
442 dampa_ij = damping_ij%bij
443 dampfac_ij = damping_ij%cij
444 END IF
445
446 IF (ASSOCIATED(atomic_kind_set(ikind)%damping)) THEN
447 damping_ji = atomic_kind_set(ikind)%damping%damp(jkind)
448 itype_ji = damping_ji%itype
449 nkdamp_ji = damping_ji%order
450 dampa_ji = damping_ji%bij
451 dampfac_ji = damping_ji%cij
452 END IF
453 END IF
454
455 pairs: DO ipair = istart, iend
456 IF (ipair <= neighbor_kind_pair%nscale) THEN
457 ! scale the electrostatic interaction if needed
458 ! (most often scaled to zero)
459 fac_ij = neighbor_kind_pair%ei_scale(ipair)
460 IF (fac_ij <= 0) cycle
461 ELSE
462 fac_ij = 1.0_dp
463 END IF
464 atom_a = list(1, ipair)
465 atom_b = list(2, ipair)
466 kind_a = particle_set(atom_a)%atomic_kind%kind_number
467 kind_b = particle_set(atom_b)%atomic_kind%kind_number
468 IF (atom_a == atom_b) fac_ij = 0.5_dp
469 rab = r_last_update_pbc(atom_b)%r - r_last_update_pbc(atom_a)%r
470 rab = rab + cell_v
471 rab2 = rab(1)**2 + rab(2)**2 + rab(3)**2
472 IF (rab2 <= rab2_max) THEN
473 IF (PRESENT(radii)) THEN
474 radius = sqrt(radii(atom_a)*radii(atom_a) + radii(atom_b)*radii(atom_b))
475 ELSE
476 radius = 0.0_dp
477 END IF
478 IF (radius > 0.0_dp) THEN
479 beta = sqrthalf/radius
480 ! Compute the Short Range constribution according the task
481 IF (debug_this_module) THEN
482 f = huge(0.0_dp)
483 tij = huge(0.0_dp)
484 tij_a = huge(0.0_dp)
485 tij_ab = huge(0.0_dp)
486 tij_abc = huge(0.0_dp)
487 tij_abcd = huge(0.0_dp)
488 tij_abcde = huge(0.0_dp)
489 END IF
490 r = sqrt(rab2)
491 irab2 = 1.0_dp/rab2
492 ir = 1.0_dp/r
493
494 ! Compute the radial function
495 ! code for gaussian multipole with screening
496 IF (debug_this_module .AND. debug_r_space .AND. (.NOT. debug_g_space)) THEN
497 f(0) = ir
498 tmp1 = 0.0_dp
499 tmp2 = 0.0_dp
500 ELSE
501 f(0) = erf(beta*r)*ir - erf(alpha*r)*ir
502 tmp1 = exp(-alpha**2*rab2)*oorootpi
503 tmp2 = exp(-beta**2*rab2)*oorootpi
504 END IF
505 fac = 1.0_dp
506 DO i = 1, 5
507 fac = fac*real(2*i - 1, kind=dp)
508 f(i) = irab2*(f(i - 1) + tmp1*((2.0_dp*alpha**2)**i)/(fac*alpha) - tmp2*((2.0_dp*beta**2)**i)/(fac*beta))
509 END DO
510
511
512 ! Compute the Tensor components
513 force_eval = do_stress
514 IF (task(1, 1)) THEN
515 tij = f(0)*fac_ij
516 force_eval = do_forces .OR. do_efield1
517 END IF
518 IF (task(2, 2)) force_eval = force_eval .OR. do_efield0
519 IF (task(1, 2) .OR. force_eval) THEN
520 force_eval = do_stress
521 tij_a = -rab*f(1)*fac_ij
522 IF (task(1, 2)) force_eval = force_eval .OR. do_forces
523 END IF
524 IF (task(1, 1)) force_eval = force_eval .OR. do_efield2
525 IF (task(3, 3)) force_eval = force_eval .OR. do_efield0
526 IF (task(2, 2) .OR. task(3, 1) .OR. force_eval) THEN
527 force_eval = do_stress
528 DO b = 1, 3
529 DO a = 1, 3
530 tmp = rab(a)*rab(b)*fac_ij
531 tij_ab(a, b) = 3.0_dp*tmp*f(2)
532 IF (a == b) tij_ab(a, b) = tij_ab(a, b) - f(1)*fac_ij
533 END DO
534 END DO
535 IF (task(2, 2) .OR. task(3, 1)) force_eval = force_eval .OR. do_forces
536 END IF
537 IF (task(2, 2)) force_eval = force_eval .OR. do_efield2
538 IF (task(3, 3)) force_eval = force_eval .OR. do_efield1
539 IF (task(3, 2) .OR. force_eval) THEN
540 force_eval = do_stress
541 DO c = 1, 3
542 DO b = 1, 3
543 DO a = 1, 3
544 tmp = rab(a)*rab(b)*rab(c)*fac_ij
545 tij_abc(a, b, c) = -15.0_dp*tmp*f(3)
546 tmp = 3.0_dp*f(2)*fac_ij
547 IF (a == b) tij_abc(a, b, c) = tij_abc(a, b, c) + tmp*rab(c)
548 IF (a == c) tij_abc(a, b, c) = tij_abc(a, b, c) + tmp*rab(b)
549 IF (b == c) tij_abc(a, b, c) = tij_abc(a, b, c) + tmp*rab(a)
550 END DO
551 END DO
552 END DO
553 IF (task(3, 2)) force_eval = force_eval .OR. do_forces
554 END IF
555 IF (task(3, 3) .OR. force_eval) THEN
556 force_eval = do_stress
557 DO d = 1, 3
558 DO c = 1, 3
559 DO b = 1, 3
560 DO a = 1, 3
561 tmp = rab(a)*rab(b)*rab(c)*rab(d)*fac_ij
562 tij_abcd(a, b, c, d) = 105.0_dp*tmp*f(4)
563 tmp1 = 15.0_dp*f(3)*fac_ij
564 tmp2 = 3.0_dp*f(2)*fac_ij
565 IF (a == b) THEN
566 tij_abcd(a, b, c, d) = tij_abcd(a, b, c, d) - tmp1*rab(c)*rab(d)
567 IF (c == d) tij_abcd(a, b, c, d) = tij_abcd(a, b, c, d) + tmp2
568 END IF
569 IF (a == c) THEN
570 tij_abcd(a, b, c, d) = tij_abcd(a, b, c, d) - tmp1*rab(b)*rab(d)
571 IF (b == d) tij_abcd(a, b, c, d) = tij_abcd(a, b, c, d) + tmp2
572 END IF
573 IF (a == d) tij_abcd(a, b, c, d) = tij_abcd(a, b, c, d) - tmp1*rab(b)*rab(c)
574 IF (b == c) THEN
575 tij_abcd(a, b, c, d) = tij_abcd(a, b, c, d) - tmp1*rab(a)*rab(d)
576 IF (a == d) tij_abcd(a, b, c, d) = tij_abcd(a, b, c, d) + tmp2
577 END IF
578 IF (b == d) tij_abcd(a, b, c, d) = tij_abcd(a, b, c, d) - tmp1*rab(a)*rab(c)
579 IF (c == d) tij_abcd(a, b, c, d) = tij_abcd(a, b, c, d) - tmp1*rab(a)*rab(b)
580 END DO
581 END DO
582 END DO
583 END DO
584 IF (task(3, 3)) force_eval = force_eval .OR. do_forces
585 END IF
586 IF (force_eval) THEN
587 force_eval = do_stress
588 DO e = 1, 3
589 DO d = 1, 3
590 DO c = 1, 3
591 DO b = 1, 3
592 DO a = 1, 3
593 tmp = rab(a)*rab(b)*rab(c)*rab(d)*rab(e)*fac_ij
594 tij_abcde(a, b, c, d, e) = -945.0_dp*tmp*f(5)
595 tmp1 = 105.0_dp*f(4)*fac_ij
596 tmp2 = 15.0_dp*f(3)*fac_ij
597 IF (a == b) THEN
598 tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) + tmp1*rab(c)*rab(d)*rab(e)
599 IF (c == d) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) - tmp2*rab(e)
600 IF (c == e) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) - tmp2*rab(d)
601 IF (d == e) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) - tmp2*rab(c)
602 END IF
603 IF (a == c) THEN
604 tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) + tmp1*rab(b)*rab(d)*rab(e)
605 IF (b == d) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) - tmp2*rab(e)
606 IF (b == e) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) - tmp2*rab(d)
607 IF (d == e) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) - tmp2*rab(b)
608 END IF
609 IF (a == d) THEN
610 tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) + tmp1*rab(b)*rab(c)*rab(e)
611 IF (b == c) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) - tmp2*rab(e)
612 IF (b == e) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) - tmp2*rab(c)
613 IF (c == e) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) - tmp2*rab(b)
614 END IF
615 IF (a == e) THEN
616 tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) + tmp1*rab(b)*rab(c)*rab(d)
617 IF (b == c) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) - tmp2*rab(d)
618 IF (b == d) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) - tmp2*rab(c)
619 IF (c == d) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) - tmp2*rab(b)
620 END IF
621 IF (b == c) THEN
622 tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) + tmp1*rab(a)*rab(d)*rab(e)
623 IF (d == e) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) - tmp2*rab(a)
624 END IF
625 IF (b == d) THEN
626 tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) + tmp1*rab(a)*rab(c)*rab(e)
627 IF (c == e) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) - tmp2*rab(a)
628 END IF
629 IF (b == e) THEN
630 tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) + tmp1*rab(a)*rab(c)*rab(d)
631 IF (c == d) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) - tmp2*rab(a)
632 END IF
633 IF (c == d) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) + tmp1*rab(a)*rab(b)*rab(e)
634 IF (c == e) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) + tmp1*rab(a)*rab(b)*rab(d)
635 IF (d == e) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) + tmp1*rab(a)*rab(b)*rab(c)
636 END DO
637 END DO
638 END DO
639 END DO
640 END DO
641 END IF
642 eloc = 0.0_dp
643 fr = 0.0_dp
644 ef0_i = 0.0_dp
645 ef0_j = 0.0_dp
646 ef1_j = 0.0_dp
647 ef1_i = 0.0_dp
648 ef2_j = 0.0_dp
649 ef2_i = 0.0_dp
650
651
652 ! Initialize the charge, dipole and quadrupole for atom A and B
653 IF (debug_this_module) THEN
654 ch_j = huge(0.0_dp)
655 ch_i = huge(0.0_dp)
656 dp_j = huge(0.0_dp)
657 dp_i = huge(0.0_dp)
658 qp_j = huge(0.0_dp)
659 qp_i = huge(0.0_dp)
660 END IF
661 IF (any(task(1, :))) THEN
662 ch_j = charges(atom_a)
663 ch_i = charges(atom_b)
664 END IF
665 IF (any(task(2, :))) THEN
666 dp_j = dipoles(:, atom_a)
667 dp_i = dipoles(:, atom_b)
668 END IF
669 IF (any(task(3, :))) THEN
670 qp_j = quadrupoles(:, :, atom_a)
671 qp_i = quadrupoles(:, :, atom_b)
672 END IF
673 IF (task(1, 1)) THEN
674 ! Charge - Charge
675 eloc = eloc + ch_i*tij*ch_j
676 ! Forces on particle i (locally b)
677 IF (do_forces .OR. do_stress) THEN
678 fr(1) = fr(1) - ch_j*tij_a(1)*ch_i
679 fr(2) = fr(2) - ch_j*tij_a(2)*ch_i
680 fr(3) = fr(3) - ch_j*tij_a(3)*ch_i
681 END IF
682 ! Electric fields
683 IF (do_efield) THEN
684 ! Potential
685 IF (do_efield0) THEN
686 ef0_i = ef0_i + tij*ch_j
687
688 ef0_j = ef0_j + tij*ch_i
689 END IF
690 ! Electric field
691 IF (do_efield1) THEN
692 ef1_i(1) = ef1_i(1) - tij_a(1)*ch_j
693 ef1_i(2) = ef1_i(2) - tij_a(2)*ch_j
694 ef1_i(3) = ef1_i(3) - tij_a(3)*ch_j
695
696 ef1_j(1) = ef1_j(1) + tij_a(1)*ch_i
697 ef1_j(2) = ef1_j(2) + tij_a(2)*ch_i
698 ef1_j(3) = ef1_j(3) + tij_a(3)*ch_i
699
700
701 END IF
702 ! Electric field gradient
703 IF (do_efield2) THEN
704 ef2_i(1, 1) = ef2_i(1, 1) - tij_ab(1, 1)*ch_j
705 ef2_i(2, 1) = ef2_i(2, 1) - tij_ab(2, 1)*ch_j
706 ef2_i(3, 1) = ef2_i(3, 1) - tij_ab(3, 1)*ch_j
707 ef2_i(1, 2) = ef2_i(1, 2) - tij_ab(1, 2)*ch_j
708 ef2_i(2, 2) = ef2_i(2, 2) - tij_ab(2, 2)*ch_j
709 ef2_i(3, 2) = ef2_i(3, 2) - tij_ab(3, 2)*ch_j
710 ef2_i(1, 3) = ef2_i(1, 3) - tij_ab(1, 3)*ch_j
711 ef2_i(2, 3) = ef2_i(2, 3) - tij_ab(2, 3)*ch_j
712 ef2_i(3, 3) = ef2_i(3, 3) - tij_ab(3, 3)*ch_j
713
714 ef2_j(1, 1) = ef2_j(1, 1) - tij_ab(1, 1)*ch_i
715 ef2_j(2, 1) = ef2_j(2, 1) - tij_ab(2, 1)*ch_i
716 ef2_j(3, 1) = ef2_j(3, 1) - tij_ab(3, 1)*ch_i
717 ef2_j(1, 2) = ef2_j(1, 2) - tij_ab(1, 2)*ch_i
718 ef2_j(2, 2) = ef2_j(2, 2) - tij_ab(2, 2)*ch_i
719 ef2_j(3, 2) = ef2_j(3, 2) - tij_ab(3, 2)*ch_i
720 ef2_j(1, 3) = ef2_j(1, 3) - tij_ab(1, 3)*ch_i
721 ef2_j(2, 3) = ef2_j(2, 3) - tij_ab(2, 3)*ch_i
722 ef2_j(3, 3) = ef2_j(3, 3) - tij_ab(3, 3)*ch_i
723 END IF
724 END IF
725 END IF
726 IF (task(2, 2)) THEN
727 ! Dipole - Dipole
728 tmp = -(dp_i(1)*(tij_ab(1, 1)*dp_j(1) + &
729 tij_ab(2, 1)*dp_j(2) + &
730 tij_ab(3, 1)*dp_j(3)) + &
731 dp_i(2)*(tij_ab(1, 2)*dp_j(1) + &
732 tij_ab(2, 2)*dp_j(2) + &
733 tij_ab(3, 2)*dp_j(3)) + &
734 dp_i(3)*(tij_ab(1, 3)*dp_j(1) + &
735 tij_ab(2, 3)*dp_j(2) + &
736 tij_ab(3, 3)*dp_j(3)))
737 eloc = eloc + tmp
738 ! Forces on particle i (locally b)
739 IF (do_forces .OR. do_stress) THEN
740 DO k = 1, 3
741 fr(k) = fr(k) + dp_i(1)*(tij_abc(1, 1, k)*dp_j(1) + &
742 tij_abc(2, 1, k)*dp_j(2) + &
743 tij_abc(3, 1, k)*dp_j(3)) &
744 + dp_i(2)*(tij_abc(1, 2, k)*dp_j(1) + &
745 tij_abc(2, 2, k)*dp_j(2) + &
746 tij_abc(3, 2, k)*dp_j(3)) &
747 + dp_i(3)*(tij_abc(1, 3, k)*dp_j(1) + &
748 tij_abc(2, 3, k)*dp_j(2) + &
749 tij_abc(3, 3, k)*dp_j(3))
750 END DO
751 END IF
752 ! Electric fields
753 IF (do_efield) THEN
754 ! Potential
755 IF (do_efield0) THEN
756 ef0_i = ef0_i - (tij_a(1)*dp_j(1) + &
757 tij_a(2)*dp_j(2) + &
758 tij_a(3)*dp_j(3))
759
760 ef0_j = ef0_j + (tij_a(1)*dp_i(1) + &
761 tij_a(2)*dp_i(2) + &
762 tij_a(3)*dp_i(3))
763 END IF
764 ! Electric field
765 IF (do_efield1) THEN
766 ef1_i(1) = ef1_i(1) + (tij_ab(1, 1)*dp_j(1) + &
767 tij_ab(2, 1)*dp_j(2) + &
768 tij_ab(3, 1)*dp_j(3))
769 ef1_i(2) = ef1_i(2) + (tij_ab(1, 2)*dp_j(1) + &
770 tij_ab(2, 2)*dp_j(2) + &
771 tij_ab(3, 2)*dp_j(3))
772 ef1_i(3) = ef1_i(3) + (tij_ab(1, 3)*dp_j(1) + &
773 tij_ab(2, 3)*dp_j(2) + &
774 tij_ab(3, 3)*dp_j(3))
775
776 ef1_j(1) = ef1_j(1) + (tij_ab(1, 1)*dp_i(1) + &
777 tij_ab(2, 1)*dp_i(2) + &
778 tij_ab(3, 1)*dp_i(3))
779 ef1_j(2) = ef1_j(2) + (tij_ab(1, 2)*dp_i(1) + &
780 tij_ab(2, 2)*dp_i(2) + &
781 tij_ab(3, 2)*dp_i(3))
782 ef1_j(3) = ef1_j(3) + (tij_ab(1, 3)*dp_i(1) + &
783 tij_ab(2, 3)*dp_i(2) + &
784 tij_ab(3, 3)*dp_i(3))
785 END IF
786 ! Electric field gradient
787 IF (do_efield2) THEN
788 ef2_i(1, 1) = ef2_i(1, 1) + (tij_abc(1, 1, 1)*dp_j(1) + &
789 tij_abc(2, 1, 1)*dp_j(2) + &
790 tij_abc(3, 1, 1)*dp_j(3))
791 ef2_i(1, 2) = ef2_i(1, 2) + (tij_abc(1, 1, 2)*dp_j(1) + &
792 tij_abc(2, 1, 2)*dp_j(2) + &
793 tij_abc(3, 1, 2)*dp_j(3))
794 ef2_i(1, 3) = ef2_i(1, 3) + (tij_abc(1, 1, 3)*dp_j(1) + &
795 tij_abc(2, 1, 3)*dp_j(2) + &
796 tij_abc(3, 1, 3)*dp_j(3))
797 ef2_i(2, 1) = ef2_i(2, 1) + (tij_abc(1, 2, 1)*dp_j(1) + &
798 tij_abc(2, 2, 1)*dp_j(2) + &
799 tij_abc(3, 2, 1)*dp_j(3))
800 ef2_i(2, 2) = ef2_i(2, 2) + (tij_abc(1, 2, 2)*dp_j(1) + &
801 tij_abc(2, 2, 2)*dp_j(2) + &
802 tij_abc(3, 2, 2)*dp_j(3))
803 ef2_i(2, 3) = ef2_i(2, 3) + (tij_abc(1, 2, 3)*dp_j(1) + &
804 tij_abc(2, 2, 3)*dp_j(2) + &
805 tij_abc(3, 2, 3)*dp_j(3))
806 ef2_i(3, 1) = ef2_i(3, 1) + (tij_abc(1, 3, 1)*dp_j(1) + &
807 tij_abc(2, 3, 1)*dp_j(2) + &
808 tij_abc(3, 3, 1)*dp_j(3))
809 ef2_i(3, 2) = ef2_i(3, 2) + (tij_abc(1, 3, 2)*dp_j(1) + &
810 tij_abc(2, 3, 2)*dp_j(2) + &
811 tij_abc(3, 3, 2)*dp_j(3))
812 ef2_i(3, 3) = ef2_i(3, 3) + (tij_abc(1, 3, 3)*dp_j(1) + &
813 tij_abc(2, 3, 3)*dp_j(2) + &
814 tij_abc(3, 3, 3)*dp_j(3))
815
816 ef2_j(1, 1) = ef2_j(1, 1) - (tij_abc(1, 1, 1)*dp_i(1) + &
817 tij_abc(2, 1, 1)*dp_i(2) + &
818 tij_abc(3, 1, 1)*dp_i(3))
819 ef2_j(1, 2) = ef2_j(1, 2) - (tij_abc(1, 1, 2)*dp_i(1) + &
820 tij_abc(2, 1, 2)*dp_i(2) + &
821 tij_abc(3, 1, 2)*dp_i(3))
822 ef2_j(1, 3) = ef2_j(1, 3) - (tij_abc(1, 1, 3)*dp_i(1) + &
823 tij_abc(2, 1, 3)*dp_i(2) + &
824 tij_abc(3, 1, 3)*dp_i(3))
825 ef2_j(2, 1) = ef2_j(2, 1) - (tij_abc(1, 2, 1)*dp_i(1) + &
826 tij_abc(2, 2, 1)*dp_i(2) + &
827 tij_abc(3, 2, 1)*dp_i(3))
828 ef2_j(2, 2) = ef2_j(2, 2) - (tij_abc(1, 2, 2)*dp_i(1) + &
829 tij_abc(2, 2, 2)*dp_i(2) + &
830 tij_abc(3, 2, 2)*dp_i(3))
831 ef2_j(2, 3) = ef2_j(2, 3) - (tij_abc(1, 2, 3)*dp_i(1) + &
832 tij_abc(2, 2, 3)*dp_i(2) + &
833 tij_abc(3, 2, 3)*dp_i(3))
834 ef2_j(3, 1) = ef2_j(3, 1) - (tij_abc(1, 3, 1)*dp_i(1) + &
835 tij_abc(2, 3, 1)*dp_i(2) + &
836 tij_abc(3, 3, 1)*dp_i(3))
837 ef2_j(3, 2) = ef2_j(3, 2) - (tij_abc(1, 3, 2)*dp_i(1) + &
838 tij_abc(2, 3, 2)*dp_i(2) + &
839 tij_abc(3, 3, 2)*dp_i(3))
840 ef2_j(3, 3) = ef2_j(3, 3) - (tij_abc(1, 3, 3)*dp_i(1) + &
841 tij_abc(2, 3, 3)*dp_i(2) + &
842 tij_abc(3, 3, 3)*dp_i(3))
843 END IF
844 END IF
845 END IF
846 IF (task(2, 1)) THEN
847 ! Dipole - Charge
848 tmp = ch_j*(tij_a(1)*dp_i(1) + &
849 tij_a(2)*dp_i(2) + &
850 tij_a(3)*dp_i(3)) &
851 - ch_i*(tij_a(1)*dp_j(1) + &
852 tij_a(2)*dp_j(2) + &
853 tij_a(3)*dp_j(3))
854 eloc = eloc + tmp
855 ! Forces on particle i (locally b)
856 IF (do_forces .OR. do_stress) THEN
857 DO k = 1, 3
858 fr(k) = fr(k) - ch_j*(tij_ab(1, k)*dp_i(1) + &
859 tij_ab(2, k)*dp_i(2) + &
860 tij_ab(3, k)*dp_i(3)) &
861 + ch_i*(tij_ab(1, k)*dp_j(1) + &
862 tij_ab(2, k)*dp_j(2) + &
863 tij_ab(3, k)*dp_j(3))
864 END DO
865 END IF
866 END IF
867 IF (task(3, 3)) THEN
868 ! Quadrupole - Quadrupole
869 fac = 1.0_dp/9.0_dp
870 tmp11 = qp_i(1, 1)*(tij_abcd(1, 1, 1, 1)*qp_j(1, 1) + &
871 tij_abcd(2, 1, 1, 1)*qp_j(2, 1) + &
872 tij_abcd(3, 1, 1, 1)*qp_j(3, 1) + &
873 tij_abcd(1, 2, 1, 1)*qp_j(1, 2) + &
874 tij_abcd(2, 2, 1, 1)*qp_j(2, 2) + &
875 tij_abcd(3, 2, 1, 1)*qp_j(3, 2) + &
876 tij_abcd(1, 3, 1, 1)*qp_j(1, 3) + &
877 tij_abcd(2, 3, 1, 1)*qp_j(2, 3) + &
878 tij_abcd(3, 3, 1, 1)*qp_j(3, 3))
879 tmp21 = qp_i(2, 1)*(tij_abcd(1, 1, 1, 2)*qp_j(1, 1) + &
880 tij_abcd(2, 1, 1, 2)*qp_j(2, 1) + &
881 tij_abcd(3, 1, 1, 2)*qp_j(3, 1) + &
882 tij_abcd(1, 2, 1, 2)*qp_j(1, 2) + &
883 tij_abcd(2, 2, 1, 2)*qp_j(2, 2) + &
884 tij_abcd(3, 2, 1, 2)*qp_j(3, 2) + &
885 tij_abcd(1, 3, 1, 2)*qp_j(1, 3) + &
886 tij_abcd(2, 3, 1, 2)*qp_j(2, 3) + &
887 tij_abcd(3, 3, 1, 2)*qp_j(3, 3))
888 tmp31 = qp_i(3, 1)*(tij_abcd(1, 1, 1, 3)*qp_j(1, 1) + &
889 tij_abcd(2, 1, 1, 3)*qp_j(2, 1) + &
890 tij_abcd(3, 1, 1, 3)*qp_j(3, 1) + &
891 tij_abcd(1, 2, 1, 3)*qp_j(1, 2) + &
892 tij_abcd(2, 2, 1, 3)*qp_j(2, 2) + &
893 tij_abcd(3, 2, 1, 3)*qp_j(3, 2) + &
894 tij_abcd(1, 3, 1, 3)*qp_j(1, 3) + &
895 tij_abcd(2, 3, 1, 3)*qp_j(2, 3) + &
896 tij_abcd(3, 3, 1, 3)*qp_j(3, 3))
897 tmp22 = qp_i(2, 2)*(tij_abcd(1, 1, 2, 2)*qp_j(1, 1) + &
898 tij_abcd(2, 1, 2, 2)*qp_j(2, 1) + &
899 tij_abcd(3, 1, 2, 2)*qp_j(3, 1) + &
900 tij_abcd(1, 2, 2, 2)*qp_j(1, 2) + &
901 tij_abcd(2, 2, 2, 2)*qp_j(2, 2) + &
902 tij_abcd(3, 2, 2, 2)*qp_j(3, 2) + &
903 tij_abcd(1, 3, 2, 2)*qp_j(1, 3) + &
904 tij_abcd(2, 3, 2, 2)*qp_j(2, 3) + &
905 tij_abcd(3, 3, 2, 2)*qp_j(3, 3))
906 tmp32 = qp_i(3, 2)*(tij_abcd(1, 1, 2, 3)*qp_j(1, 1) + &
907 tij_abcd(2, 1, 2, 3)*qp_j(2, 1) + &
908 tij_abcd(3, 1, 2, 3)*qp_j(3, 1) + &
909 tij_abcd(1, 2, 2, 3)*qp_j(1, 2) + &
910 tij_abcd(2, 2, 2, 3)*qp_j(2, 2) + &
911 tij_abcd(3, 2, 2, 3)*qp_j(3, 2) + &
912 tij_abcd(1, 3, 2, 3)*qp_j(1, 3) + &
913 tij_abcd(2, 3, 2, 3)*qp_j(2, 3) + &
914 tij_abcd(3, 3, 2, 3)*qp_j(3, 3))
915 tmp33 = qp_i(3, 3)*(tij_abcd(1, 1, 3, 3)*qp_j(1, 1) + &
916 tij_abcd(2, 1, 3, 3)*qp_j(2, 1) + &
917 tij_abcd(3, 1, 3, 3)*qp_j(3, 1) + &
918 tij_abcd(1, 2, 3, 3)*qp_j(1, 2) + &
919 tij_abcd(2, 2, 3, 3)*qp_j(2, 2) + &
920 tij_abcd(3, 2, 3, 3)*qp_j(3, 2) + &
921 tij_abcd(1, 3, 3, 3)*qp_j(1, 3) + &
922 tij_abcd(2, 3, 3, 3)*qp_j(2, 3) + &
923 tij_abcd(3, 3, 3, 3)*qp_j(3, 3))
924 tmp12 = tmp21
925 tmp13 = tmp31
926 tmp23 = tmp32
927 tmp = tmp11 + tmp12 + tmp13 + &
928 tmp21 + tmp22 + tmp23 + &
929 tmp31 + tmp32 + tmp33
930
931 eloc = eloc + fac*tmp
932 ! Forces on particle i (locally b)
933 IF (do_forces .OR. do_stress) THEN
934 DO k = 1, 3
935 tmp11 = qp_i(1, 1)*(tij_abcde(1, 1, 1, 1, k)*qp_j(1, 1) + &
936 tij_abcde(2, 1, 1, 1, k)*qp_j(2, 1) + &
937 tij_abcde(3, 1, 1, 1, k)*qp_j(3, 1) + &
938 tij_abcde(1, 2, 1, 1, k)*qp_j(1, 2) + &
939 tij_abcde(2, 2, 1, 1, k)*qp_j(2, 2) + &
940 tij_abcde(3, 2, 1, 1, k)*qp_j(3, 2) + &
941 tij_abcde(1, 3, 1, 1, k)*qp_j(1, 3) + &
942 tij_abcde(2, 3, 1, 1, k)*qp_j(2, 3) + &
943 tij_abcde(3, 3, 1, 1, k)*qp_j(3, 3))
944 tmp21 = qp_i(2, 1)*(tij_abcde(1, 1, 2, 1, k)*qp_j(1, 1) + &
945 tij_abcde(2, 1, 2, 1, k)*qp_j(2, 1) + &
946 tij_abcde(3, 1, 2, 1, k)*qp_j(3, 1) + &
947 tij_abcde(1, 2, 2, 1, k)*qp_j(1, 2) + &
948 tij_abcde(2, 2, 2, 1, k)*qp_j(2, 2) + &
949 tij_abcde(3, 2, 2, 1, k)*qp_j(3, 2) + &
950 tij_abcde(1, 3, 2, 1, k)*qp_j(1, 3) + &
951 tij_abcde(2, 3, 2, 1, k)*qp_j(2, 3) + &
952 tij_abcde(3, 3, 2, 1, k)*qp_j(3, 3))
953 tmp31 = qp_i(3, 1)*(tij_abcde(1, 1, 3, 1, k)*qp_j(1, 1) + &
954 tij_abcde(2, 1, 3, 1, k)*qp_j(2, 1) + &
955 tij_abcde(3, 1, 3, 1, k)*qp_j(3, 1) + &
956 tij_abcde(1, 2, 3, 1, k)*qp_j(1, 2) + &
957 tij_abcde(2, 2, 3, 1, k)*qp_j(2, 2) + &
958 tij_abcde(3, 2, 3, 1, k)*qp_j(3, 2) + &
959 tij_abcde(1, 3, 3, 1, k)*qp_j(1, 3) + &
960 tij_abcde(2, 3, 3, 1, k)*qp_j(2, 3) + &
961 tij_abcde(3, 3, 3, 1, k)*qp_j(3, 3))
962 tmp22 = qp_i(2, 2)*(tij_abcde(1, 1, 2, 2, k)*qp_j(1, 1) + &
963 tij_abcde(2, 1, 2, 2, k)*qp_j(2, 1) + &
964 tij_abcde(3, 1, 2, 2, k)*qp_j(3, 1) + &
965 tij_abcde(1, 2, 2, 2, k)*qp_j(1, 2) + &
966 tij_abcde(2, 2, 2, 2, k)*qp_j(2, 2) + &
967 tij_abcde(3, 2, 2, 2, k)*qp_j(3, 2) + &
968 tij_abcde(1, 3, 2, 2, k)*qp_j(1, 3) + &
969 tij_abcde(2, 3, 2, 2, k)*qp_j(2, 3) + &
970 tij_abcde(3, 3, 2, 2, k)*qp_j(3, 3))
971 tmp32 = qp_i(3, 2)*(tij_abcde(1, 1, 3, 2, k)*qp_j(1, 1) + &
972 tij_abcde(2, 1, 3, 2, k)*qp_j(2, 1) + &
973 tij_abcde(3, 1, 3, 2, k)*qp_j(3, 1) + &
974 tij_abcde(1, 2, 3, 2, k)*qp_j(1, 2) + &
975 tij_abcde(2, 2, 3, 2, k)*qp_j(2, 2) + &
976 tij_abcde(3, 2, 3, 2, k)*qp_j(3, 2) + &
977 tij_abcde(1, 3, 3, 2, k)*qp_j(1, 3) + &
978 tij_abcde(2, 3, 3, 2, k)*qp_j(2, 3) + &
979 tij_abcde(3, 3, 3, 2, k)*qp_j(3, 3))
980 tmp33 = qp_i(3, 3)*(tij_abcde(1, 1, 3, 3, k)*qp_j(1, 1) + &
981 tij_abcde(2, 1, 3, 3, k)*qp_j(2, 1) + &
982 tij_abcde(3, 1, 3, 3, k)*qp_j(3, 1) + &
983 tij_abcde(1, 2, 3, 3, k)*qp_j(1, 2) + &
984 tij_abcde(2, 2, 3, 3, k)*qp_j(2, 2) + &
985 tij_abcde(3, 2, 3, 3, k)*qp_j(3, 2) + &
986 tij_abcde(1, 3, 3, 3, k)*qp_j(1, 3) + &
987 tij_abcde(2, 3, 3, 3, k)*qp_j(2, 3) + &
988 tij_abcde(3, 3, 3, 3, k)*qp_j(3, 3))
989 tmp12 = tmp21
990 tmp13 = tmp31
991 tmp23 = tmp32
992 fr(k) = fr(k) - fac*(tmp11 + tmp12 + tmp13 + &
993 tmp21 + tmp22 + tmp23 + &
994 tmp31 + tmp32 + tmp33)
995 END DO
996 END IF
997 ! Electric field
998 IF (do_efield) THEN
999 fac = 1.0_dp/3.0_dp
1000 ! Potential
1001 IF (do_efield0) THEN
1002 ef0_i = ef0_i + fac*(tij_ab(1, 1)*qp_j(1, 1) + &
1003 tij_ab(2, 1)*qp_j(2, 1) + &
1004 tij_ab(3, 1)*qp_j(3, 1) + &
1005 tij_ab(1, 2)*qp_j(1, 2) + &
1006 tij_ab(2, 2)*qp_j(2, 2) + &
1007 tij_ab(3, 2)*qp_j(3, 2) + &
1008 tij_ab(1, 3)*qp_j(1, 3) + &
1009 tij_ab(2, 3)*qp_j(2, 3) + &
1010 tij_ab(3, 3)*qp_j(3, 3))
1011
1012 ef0_j = ef0_j + fac*(tij_ab(1, 1)*qp_i(1, 1) + &
1013 tij_ab(2, 1)*qp_i(2, 1) + &
1014 tij_ab(3, 1)*qp_i(3, 1) + &
1015 tij_ab(1, 2)*qp_i(1, 2) + &
1016 tij_ab(2, 2)*qp_i(2, 2) + &
1017 tij_ab(3, 2)*qp_i(3, 2) + &
1018 tij_ab(1, 3)*qp_i(1, 3) + &
1019 tij_ab(2, 3)*qp_i(2, 3) + &
1020 tij_ab(3, 3)*qp_i(3, 3))
1021 END IF
1022 ! Electric field
1023 IF (do_efield1) THEN
1024 ef1_i(1) = ef1_i(1) - fac*(tij_abc(1, 1, 1)*qp_j(1, 1) + &
1025 tij_abc(2, 1, 1)*qp_j(2, 1) + &
1026 tij_abc(3, 1, 1)*qp_j(3, 1) + &
1027 tij_abc(1, 2, 1)*qp_j(1, 2) + &
1028 tij_abc(2, 2, 1)*qp_j(2, 2) + &
1029 tij_abc(3, 2, 1)*qp_j(3, 2) + &
1030 tij_abc(1, 3, 1)*qp_j(1, 3) + &
1031 tij_abc(2, 3, 1)*qp_j(2, 3) + &
1032 tij_abc(3, 3, 1)*qp_j(3, 3))
1033 ef1_i(2) = ef1_i(2) - fac*(tij_abc(1, 1, 2)*qp_j(1, 1) + &
1034 tij_abc(2, 1, 2)*qp_j(2, 1) + &
1035 tij_abc(3, 1, 2)*qp_j(3, 1) + &
1036 tij_abc(1, 2, 2)*qp_j(1, 2) + &
1037 tij_abc(2, 2, 2)*qp_j(2, 2) + &
1038 tij_abc(3, 2, 2)*qp_j(3, 2) + &
1039 tij_abc(1, 3, 2)*qp_j(1, 3) + &
1040 tij_abc(2, 3, 2)*qp_j(2, 3) + &
1041 tij_abc(3, 3, 2)*qp_j(3, 3))
1042 ef1_i(3) = ef1_i(3) - fac*(tij_abc(1, 1, 3)*qp_j(1, 1) + &
1043 tij_abc(2, 1, 3)*qp_j(2, 1) + &
1044 tij_abc(3, 1, 3)*qp_j(3, 1) + &
1045 tij_abc(1, 2, 3)*qp_j(1, 2) + &
1046 tij_abc(2, 2, 3)*qp_j(2, 2) + &
1047 tij_abc(3, 2, 3)*qp_j(3, 2) + &
1048 tij_abc(1, 3, 3)*qp_j(1, 3) + &
1049 tij_abc(2, 3, 3)*qp_j(2, 3) + &
1050 tij_abc(3, 3, 3)*qp_j(3, 3))
1051
1052 ef1_j(1) = ef1_j(1) + fac*(tij_abc(1, 1, 1)*qp_i(1, 1) + &
1053 tij_abc(2, 1, 1)*qp_i(2, 1) + &
1054 tij_abc(3, 1, 1)*qp_i(3, 1) + &
1055 tij_abc(1, 2, 1)*qp_i(1, 2) + &
1056 tij_abc(2, 2, 1)*qp_i(2, 2) + &
1057 tij_abc(3, 2, 1)*qp_i(3, 2) + &
1058 tij_abc(1, 3, 1)*qp_i(1, 3) + &
1059 tij_abc(2, 3, 1)*qp_i(2, 3) + &
1060 tij_abc(3, 3, 1)*qp_i(3, 3))
1061 ef1_j(2) = ef1_j(2) + fac*(tij_abc(1, 1, 2)*qp_i(1, 1) + &
1062 tij_abc(2, 1, 2)*qp_i(2, 1) + &
1063 tij_abc(3, 1, 2)*qp_i(3, 1) + &
1064 tij_abc(1, 2, 2)*qp_i(1, 2) + &
1065 tij_abc(2, 2, 2)*qp_i(2, 2) + &
1066 tij_abc(3, 2, 2)*qp_i(3, 2) + &
1067 tij_abc(1, 3, 2)*qp_i(1, 3) + &
1068 tij_abc(2, 3, 2)*qp_i(2, 3) + &
1069 tij_abc(3, 3, 2)*qp_i(3, 3))
1070 ef1_j(3) = ef1_j(3) + fac*(tij_abc(1, 1, 3)*qp_i(1, 1) + &
1071 tij_abc(2, 1, 3)*qp_i(2, 1) + &
1072 tij_abc(3, 1, 3)*qp_i(3, 1) + &
1073 tij_abc(1, 2, 3)*qp_i(1, 2) + &
1074 tij_abc(2, 2, 3)*qp_i(2, 2) + &
1075 tij_abc(3, 2, 3)*qp_i(3, 2) + &
1076 tij_abc(1, 3, 3)*qp_i(1, 3) + &
1077 tij_abc(2, 3, 3)*qp_i(2, 3) + &
1078 tij_abc(3, 3, 3)*qp_i(3, 3))
1079 END IF
1080 ! Electric field gradient
1081 IF (do_efield2) THEN
1082 tmp11 = fac*(tij_abcd(1, 1, 1, 1)*qp_j(1, 1) + &
1083 tij_abcd(2, 1, 1, 1)*qp_j(2, 1) + &
1084 tij_abcd(3, 1, 1, 1)*qp_j(3, 1) + &
1085 tij_abcd(1, 2, 1, 1)*qp_j(1, 2) + &
1086 tij_abcd(2, 2, 1, 1)*qp_j(2, 2) + &
1087 tij_abcd(3, 2, 1, 1)*qp_j(3, 2) + &
1088 tij_abcd(1, 3, 1, 1)*qp_j(1, 3) + &
1089 tij_abcd(2, 3, 1, 1)*qp_j(2, 3) + &
1090 tij_abcd(3, 3, 1, 1)*qp_j(3, 3))
1091 tmp12 = fac*(tij_abcd(1, 1, 1, 2)*qp_j(1, 1) + &
1092 tij_abcd(2, 1, 1, 2)*qp_j(2, 1) + &
1093 tij_abcd(3, 1, 1, 2)*qp_j(3, 1) + &
1094 tij_abcd(1, 2, 1, 2)*qp_j(1, 2) + &
1095 tij_abcd(2, 2, 1, 2)*qp_j(2, 2) + &
1096 tij_abcd(3, 2, 1, 2)*qp_j(3, 2) + &
1097 tij_abcd(1, 3, 1, 2)*qp_j(1, 3) + &
1098 tij_abcd(2, 3, 1, 2)*qp_j(2, 3) + &
1099 tij_abcd(3, 3, 1, 2)*qp_j(3, 3))
1100 tmp13 = fac*(tij_abcd(1, 1, 1, 3)*qp_j(1, 1) + &
1101 tij_abcd(2, 1, 1, 3)*qp_j(2, 1) + &
1102 tij_abcd(3, 1, 1, 3)*qp_j(3, 1) + &
1103 tij_abcd(1, 2, 1, 3)*qp_j(1, 2) + &
1104 tij_abcd(2, 2, 1, 3)*qp_j(2, 2) + &
1105 tij_abcd(3, 2, 1, 3)*qp_j(3, 2) + &
1106 tij_abcd(1, 3, 1, 3)*qp_j(1, 3) + &
1107 tij_abcd(2, 3, 1, 3)*qp_j(2, 3) + &
1108 tij_abcd(3, 3, 1, 3)*qp_j(3, 3))
1109 tmp22 = fac*(tij_abcd(1, 1, 2, 2)*qp_j(1, 1) + &
1110 tij_abcd(2, 1, 2, 2)*qp_j(2, 1) + &
1111 tij_abcd(3, 1, 2, 2)*qp_j(3, 1) + &
1112 tij_abcd(1, 2, 2, 2)*qp_j(1, 2) + &
1113 tij_abcd(2, 2, 2, 2)*qp_j(2, 2) + &
1114 tij_abcd(3, 2, 2, 2)*qp_j(3, 2) + &
1115 tij_abcd(1, 3, 2, 2)*qp_j(1, 3) + &
1116 tij_abcd(2, 3, 2, 2)*qp_j(2, 3) + &
1117 tij_abcd(3, 3, 2, 2)*qp_j(3, 3))
1118 tmp23 = fac*(tij_abcd(1, 1, 2, 3)*qp_j(1, 1) + &
1119 tij_abcd(2, 1, 2, 3)*qp_j(2, 1) + &
1120 tij_abcd(3, 1, 2, 3)*qp_j(3, 1) + &
1121 tij_abcd(1, 2, 2, 3)*qp_j(1, 2) + &
1122 tij_abcd(2, 2, 2, 3)*qp_j(2, 2) + &
1123 tij_abcd(3, 2, 2, 3)*qp_j(3, 2) + &
1124 tij_abcd(1, 3, 2, 3)*qp_j(1, 3) + &
1125 tij_abcd(2, 3, 2, 3)*qp_j(2, 3) + &
1126 tij_abcd(3, 3, 2, 3)*qp_j(3, 3))
1127 tmp33 = fac*(tij_abcd(1, 1, 3, 3)*qp_j(1, 1) + &
1128 tij_abcd(2, 1, 3, 3)*qp_j(2, 1) + &
1129 tij_abcd(3, 1, 3, 3)*qp_j(3, 1) + &
1130 tij_abcd(1, 2, 3, 3)*qp_j(1, 2) + &
1131 tij_abcd(2, 2, 3, 3)*qp_j(2, 2) + &
1132 tij_abcd(3, 2, 3, 3)*qp_j(3, 2) + &
1133 tij_abcd(1, 3, 3, 3)*qp_j(1, 3) + &
1134 tij_abcd(2, 3, 3, 3)*qp_j(2, 3) + &
1135 tij_abcd(3, 3, 3, 3)*qp_j(3, 3))
1136
1137 ef2_i(1, 1) = ef2_i(1, 1) - tmp11
1138 ef2_i(1, 2) = ef2_i(1, 2) - tmp12
1139 ef2_i(1, 3) = ef2_i(1, 3) - tmp13
1140 ef2_i(2, 1) = ef2_i(2, 1) - tmp12
1141 ef2_i(2, 2) = ef2_i(2, 2) - tmp22
1142 ef2_i(2, 3) = ef2_i(2, 3) - tmp23
1143 ef2_i(3, 1) = ef2_i(3, 1) - tmp13
1144 ef2_i(3, 2) = ef2_i(3, 2) - tmp23
1145 ef2_i(3, 3) = ef2_i(3, 3) - tmp33
1146
1147 tmp11 = fac*(tij_abcd(1, 1, 1, 1)*qp_i(1, 1) + &
1148 tij_abcd(2, 1, 1, 1)*qp_i(2, 1) + &
1149 tij_abcd(3, 1, 1, 1)*qp_i(3, 1) + &
1150 tij_abcd(1, 2, 1, 1)*qp_i(1, 2) + &
1151 tij_abcd(2, 2, 1, 1)*qp_i(2, 2) + &
1152 tij_abcd(3, 2, 1, 1)*qp_i(3, 2) + &
1153 tij_abcd(1, 3, 1, 1)*qp_i(1, 3) + &
1154 tij_abcd(2, 3, 1, 1)*qp_i(2, 3) + &
1155 tij_abcd(3, 3, 1, 1)*qp_i(3, 3))
1156 tmp12 = fac*(tij_abcd(1, 1, 1, 2)*qp_i(1, 1) + &
1157 tij_abcd(2, 1, 1, 2)*qp_i(2, 1) + &
1158 tij_abcd(3, 1, 1, 2)*qp_i(3, 1) + &
1159 tij_abcd(1, 2, 1, 2)*qp_i(1, 2) + &
1160 tij_abcd(2, 2, 1, 2)*qp_i(2, 2) + &
1161 tij_abcd(3, 2, 1, 2)*qp_i(3, 2) + &
1162 tij_abcd(1, 3, 1, 2)*qp_i(1, 3) + &
1163 tij_abcd(2, 3, 1, 2)*qp_i(2, 3) + &
1164 tij_abcd(3, 3, 1, 2)*qp_i(3, 3))
1165 tmp13 = fac*(tij_abcd(1, 1, 1, 3)*qp_i(1, 1) + &
1166 tij_abcd(2, 1, 1, 3)*qp_i(2, 1) + &
1167 tij_abcd(3, 1, 1, 3)*qp_i(3, 1) + &
1168 tij_abcd(1, 2, 1, 3)*qp_i(1, 2) + &
1169 tij_abcd(2, 2, 1, 3)*qp_i(2, 2) + &
1170 tij_abcd(3, 2, 1, 3)*qp_i(3, 2) + &
1171 tij_abcd(1, 3, 1, 3)*qp_i(1, 3) + &
1172 tij_abcd(2, 3, 1, 3)*qp_i(2, 3) + &
1173 tij_abcd(3, 3, 1, 3)*qp_i(3, 3))
1174 tmp22 = fac*(tij_abcd(1, 1, 2, 2)*qp_i(1, 1) + &
1175 tij_abcd(2, 1, 2, 2)*qp_i(2, 1) + &
1176 tij_abcd(3, 1, 2, 2)*qp_i(3, 1) + &
1177 tij_abcd(1, 2, 2, 2)*qp_i(1, 2) + &
1178 tij_abcd(2, 2, 2, 2)*qp_i(2, 2) + &
1179 tij_abcd(3, 2, 2, 2)*qp_i(3, 2) + &
1180 tij_abcd(1, 3, 2, 2)*qp_i(1, 3) + &
1181 tij_abcd(2, 3, 2, 2)*qp_i(2, 3) + &
1182 tij_abcd(3, 3, 2, 2)*qp_i(3, 3))
1183 tmp23 = fac*(tij_abcd(1, 1, 2, 3)*qp_i(1, 1) + &
1184 tij_abcd(2, 1, 2, 3)*qp_i(2, 1) + &
1185 tij_abcd(3, 1, 2, 3)*qp_i(3, 1) + &
1186 tij_abcd(1, 2, 2, 3)*qp_i(1, 2) + &
1187 tij_abcd(2, 2, 2, 3)*qp_i(2, 2) + &
1188 tij_abcd(3, 2, 2, 3)*qp_i(3, 2) + &
1189 tij_abcd(1, 3, 2, 3)*qp_i(1, 3) + &
1190 tij_abcd(2, 3, 2, 3)*qp_i(2, 3) + &
1191 tij_abcd(3, 3, 2, 3)*qp_i(3, 3))
1192 tmp33 = fac*(tij_abcd(1, 1, 3, 3)*qp_i(1, 1) + &
1193 tij_abcd(2, 1, 3, 3)*qp_i(2, 1) + &
1194 tij_abcd(3, 1, 3, 3)*qp_i(3, 1) + &
1195 tij_abcd(1, 2, 3, 3)*qp_i(1, 2) + &
1196 tij_abcd(2, 2, 3, 3)*qp_i(2, 2) + &
1197 tij_abcd(3, 2, 3, 3)*qp_i(3, 2) + &
1198 tij_abcd(1, 3, 3, 3)*qp_i(1, 3) + &
1199 tij_abcd(2, 3, 3, 3)*qp_i(2, 3) + &
1200 tij_abcd(3, 3, 3, 3)*qp_i(3, 3))
1201
1202 ef2_j(1, 1) = ef2_j(1, 1) - tmp11
1203 ef2_j(1, 2) = ef2_j(1, 2) - tmp12
1204 ef2_j(1, 3) = ef2_j(1, 3) - tmp13
1205 ef2_j(2, 1) = ef2_j(2, 1) - tmp12
1206 ef2_j(2, 2) = ef2_j(2, 2) - tmp22
1207 ef2_j(2, 3) = ef2_j(2, 3) - tmp23
1208 ef2_j(3, 1) = ef2_j(3, 1) - tmp13
1209 ef2_j(3, 2) = ef2_j(3, 2) - tmp23
1210 ef2_j(3, 3) = ef2_j(3, 3) - tmp33
1211 END IF
1212 END IF
1213 END IF
1214 IF (task(3, 2)) THEN
1215 ! Quadrupole - Dipole
1216 fac = 1.0_dp/3.0_dp
1217 ! Dipole i (locally B) - Quadrupole j (locally A)
1218 tmp_ij = dp_i(1)*(tij_abc(1, 1, 1)*qp_j(1, 1) + &
1219 tij_abc(2, 1, 1)*qp_j(2, 1) + &
1220 tij_abc(3, 1, 1)*qp_j(3, 1) + &
1221 tij_abc(1, 2, 1)*qp_j(1, 2) + &
1222 tij_abc(2, 2, 1)*qp_j(2, 2) + &
1223 tij_abc(3, 2, 1)*qp_j(3, 2) + &
1224 tij_abc(1, 3, 1)*qp_j(1, 3) + &
1225 tij_abc(2, 3, 1)*qp_j(2, 3) + &
1226 tij_abc(3, 3, 1)*qp_j(3, 3)) + &
1227 dp_i(2)*(tij_abc(1, 1, 2)*qp_j(1, 1) + &
1228 tij_abc(2, 1, 2)*qp_j(2, 1) + &
1229 tij_abc(3, 1, 2)*qp_j(3, 1) + &
1230 tij_abc(1, 2, 2)*qp_j(1, 2) + &
1231 tij_abc(2, 2, 2)*qp_j(2, 2) + &
1232 tij_abc(3, 2, 2)*qp_j(3, 2) + &
1233 tij_abc(1, 3, 2)*qp_j(1, 3) + &
1234 tij_abc(2, 3, 2)*qp_j(2, 3) + &
1235 tij_abc(3, 3, 2)*qp_j(3, 3)) + &
1236 dp_i(3)*(tij_abc(1, 1, 3)*qp_j(1, 1) + &
1237 tij_abc(2, 1, 3)*qp_j(2, 1) + &
1238 tij_abc(3, 1, 3)*qp_j(3, 1) + &
1239 tij_abc(1, 2, 3)*qp_j(1, 2) + &
1240 tij_abc(2, 2, 3)*qp_j(2, 2) + &
1241 tij_abc(3, 2, 3)*qp_j(3, 2) + &
1242 tij_abc(1, 3, 3)*qp_j(1, 3) + &
1243 tij_abc(2, 3, 3)*qp_j(2, 3) + &
1244 tij_abc(3, 3, 3)*qp_j(3, 3))
1245
1246 ! Dipole j (locally A) - Quadrupole i (locally B)
1247 tmp_ji = dp_j(1)*(tij_abc(1, 1, 1)*qp_i(1, 1) + &
1248 tij_abc(2, 1, 1)*qp_i(2, 1) + &
1249 tij_abc(3, 1, 1)*qp_i(3, 1) + &
1250 tij_abc(1, 2, 1)*qp_i(1, 2) + &
1251 tij_abc(2, 2, 1)*qp_i(2, 2) + &
1252 tij_abc(3, 2, 1)*qp_i(3, 2) + &
1253 tij_abc(1, 3, 1)*qp_i(1, 3) + &
1254 tij_abc(2, 3, 1)*qp_i(2, 3) + &
1255 tij_abc(3, 3, 1)*qp_i(3, 3)) + &
1256 dp_j(2)*(tij_abc(1, 1, 2)*qp_i(1, 1) + &
1257 tij_abc(2, 1, 2)*qp_i(2, 1) + &
1258 tij_abc(3, 1, 2)*qp_i(3, 1) + &
1259 tij_abc(1, 2, 2)*qp_i(1, 2) + &
1260 tij_abc(2, 2, 2)*qp_i(2, 2) + &
1261 tij_abc(3, 2, 2)*qp_i(3, 2) + &
1262 tij_abc(1, 3, 2)*qp_i(1, 3) + &
1263 tij_abc(2, 3, 2)*qp_i(2, 3) + &
1264 tij_abc(3, 3, 2)*qp_i(3, 3)) + &
1265 dp_j(3)*(tij_abc(1, 1, 3)*qp_i(1, 1) + &
1266 tij_abc(2, 1, 3)*qp_i(2, 1) + &
1267 tij_abc(3, 1, 3)*qp_i(3, 1) + &
1268 tij_abc(1, 2, 3)*qp_i(1, 2) + &
1269 tij_abc(2, 2, 3)*qp_i(2, 2) + &
1270 tij_abc(3, 2, 3)*qp_i(3, 2) + &
1271 tij_abc(1, 3, 3)*qp_i(1, 3) + &
1272 tij_abc(2, 3, 3)*qp_i(2, 3) + &
1273 tij_abc(3, 3, 3)*qp_i(3, 3))
1274
1275 tmp = fac*(tmp_ij - tmp_ji)
1276 eloc = eloc + tmp
1277 IF (do_forces .OR. do_stress) THEN
1278 DO k = 1, 3
1279 ! Dipole i (locally B) - Quadrupole j (locally A)
1280 tmp_ij = dp_i(1)*(tij_abcd(1, 1, 1, k)*qp_j(1, 1) + &
1281 tij_abcd(2, 1, 1, k)*qp_j(2, 1) + &
1282 tij_abcd(3, 1, 1, k)*qp_j(3, 1) + &
1283 tij_abcd(1, 2, 1, k)*qp_j(1, 2) + &
1284 tij_abcd(2, 2, 1, k)*qp_j(2, 2) + &
1285 tij_abcd(3, 2, 1, k)*qp_j(3, 2) + &
1286 tij_abcd(1, 3, 1, k)*qp_j(1, 3) + &
1287 tij_abcd(2, 3, 1, k)*qp_j(2, 3) + &
1288 tij_abcd(3, 3, 1, k)*qp_j(3, 3)) + &
1289 dp_i(2)*(tij_abcd(1, 1, 2, k)*qp_j(1, 1) + &
1290 tij_abcd(2, 1, 2, k)*qp_j(2, 1) + &
1291 tij_abcd(3, 1, 2, k)*qp_j(3, 1) + &
1292 tij_abcd(1, 2, 2, k)*qp_j(1, 2) + &
1293 tij_abcd(2, 2, 2, k)*qp_j(2, 2) + &
1294 tij_abcd(3, 2, 2, k)*qp_j(3, 2) + &
1295 tij_abcd(1, 3, 2, k)*qp_j(1, 3) + &
1296 tij_abcd(2, 3, 2, k)*qp_j(2, 3) + &
1297 tij_abcd(3, 3, 2, k)*qp_j(3, 3)) + &
1298 dp_i(3)*(tij_abcd(1, 1, 3, k)*qp_j(1, 1) + &
1299 tij_abcd(2, 1, 3, k)*qp_j(2, 1) + &
1300 tij_abcd(3, 1, 3, k)*qp_j(3, 1) + &
1301 tij_abcd(1, 2, 3, k)*qp_j(1, 2) + &
1302 tij_abcd(2, 2, 3, k)*qp_j(2, 2) + &
1303 tij_abcd(3, 2, 3, k)*qp_j(3, 2) + &
1304 tij_abcd(1, 3, 3, k)*qp_j(1, 3) + &
1305 tij_abcd(2, 3, 3, k)*qp_j(2, 3) + &
1306 tij_abcd(3, 3, 3, k)*qp_j(3, 3))
1307
1308 ! Dipole j (locally A) - Quadrupole i (locally B)
1309 tmp_ji = dp_j(1)*(tij_abcd(1, 1, 1, k)*qp_i(1, 1) + &
1310 tij_abcd(2, 1, 1, k)*qp_i(2, 1) + &
1311 tij_abcd(3, 1, 1, k)*qp_i(3, 1) + &
1312 tij_abcd(1, 2, 1, k)*qp_i(1, 2) + &
1313 tij_abcd(2, 2, 1, k)*qp_i(2, 2) + &
1314 tij_abcd(3, 2, 1, k)*qp_i(3, 2) + &
1315 tij_abcd(1, 3, 1, k)*qp_i(1, 3) + &
1316 tij_abcd(2, 3, 1, k)*qp_i(2, 3) + &
1317 tij_abcd(3, 3, 1, k)*qp_i(3, 3)) + &
1318 dp_j(2)*(tij_abcd(1, 1, 2, k)*qp_i(1, 1) + &
1319 tij_abcd(2, 1, 2, k)*qp_i(2, 1) + &
1320 tij_abcd(3, 1, 2, k)*qp_i(3, 1) + &
1321 tij_abcd(1, 2, 2, k)*qp_i(1, 2) + &
1322 tij_abcd(2, 2, 2, k)*qp_i(2, 2) + &
1323 tij_abcd(3, 2, 2, k)*qp_i(3, 2) + &
1324 tij_abcd(1, 3, 2, k)*qp_i(1, 3) + &
1325 tij_abcd(2, 3, 2, k)*qp_i(2, 3) + &
1326 tij_abcd(3, 3, 2, k)*qp_i(3, 3)) + &
1327 dp_j(3)*(tij_abcd(1, 1, 3, k)*qp_i(1, 1) + &
1328 tij_abcd(2, 1, 3, k)*qp_i(2, 1) + &
1329 tij_abcd(3, 1, 3, k)*qp_i(3, 1) + &
1330 tij_abcd(1, 2, 3, k)*qp_i(1, 2) + &
1331 tij_abcd(2, 2, 3, k)*qp_i(2, 2) + &
1332 tij_abcd(3, 2, 3, k)*qp_i(3, 2) + &
1333 tij_abcd(1, 3, 3, k)*qp_i(1, 3) + &
1334 tij_abcd(2, 3, 3, k)*qp_i(2, 3) + &
1335 tij_abcd(3, 3, 3, k)*qp_i(3, 3))
1336
1337 fr(k) = fr(k) - fac*(tmp_ij - tmp_ji)
1338 END DO
1339 END IF
1340 END IF
1341 IF (task(3, 1)) THEN
1342 ! Quadrupole - Charge
1343 fac = 1.0_dp/3.0_dp
1344
1345 ! Quadrupole j (locally A) - Charge j (locally B)
1346 tmp_ij = ch_i*(tij_ab(1, 1)*qp_j(1, 1) + &
1347 tij_ab(2, 1)*qp_j(2, 1) + &
1348 tij_ab(3, 1)*qp_j(3, 1) + &
1349 tij_ab(1, 2)*qp_j(1, 2) + &
1350 tij_ab(2, 2)*qp_j(2, 2) + &
1351 tij_ab(3, 2)*qp_j(3, 2) + &
1352 tij_ab(1, 3)*qp_j(1, 3) + &
1353 tij_ab(2, 3)*qp_j(2, 3) + &
1354 tij_ab(3, 3)*qp_j(3, 3))
1355
1356 ! Quadrupole i (locally B) - Charge j (locally A)
1357 tmp_ji = ch_j*(tij_ab(1, 1)*qp_i(1, 1) + &
1358 tij_ab(2, 1)*qp_i(2, 1) + &
1359 tij_ab(3, 1)*qp_i(3, 1) + &
1360 tij_ab(1, 2)*qp_i(1, 2) + &
1361 tij_ab(2, 2)*qp_i(2, 2) + &
1362 tij_ab(3, 2)*qp_i(3, 2) + &
1363 tij_ab(1, 3)*qp_i(1, 3) + &
1364 tij_ab(2, 3)*qp_i(2, 3) + &
1365 tij_ab(3, 3)*qp_i(3, 3))
1366
1367 eloc = eloc + fac*(tmp_ij + tmp_ji)
1368 IF (do_forces .OR. do_stress) THEN
1369 DO k = 1, 3
1370 ! Quadrupole j (locally A) - Charge i (locally B)
1371 tmp_ij = ch_i*(tij_abc(1, 1, k)*qp_j(1, 1) + &
1372 tij_abc(2, 1, k)*qp_j(2, 1) + &
1373 tij_abc(3, 1, k)*qp_j(3, 1) + &
1374 tij_abc(1, 2, k)*qp_j(1, 2) + &
1375 tij_abc(2, 2, k)*qp_j(2, 2) + &
1376 tij_abc(3, 2, k)*qp_j(3, 2) + &
1377 tij_abc(1, 3, k)*qp_j(1, 3) + &
1378 tij_abc(2, 3, k)*qp_j(2, 3) + &
1379 tij_abc(3, 3, k)*qp_j(3, 3))
1380
1381 ! Quadrupole i (locally B) - Charge j (locally A)
1382 tmp_ji = ch_j*(tij_abc(1, 1, k)*qp_i(1, 1) + &
1383 tij_abc(2, 1, k)*qp_i(2, 1) + &
1384 tij_abc(3, 1, k)*qp_i(3, 1) + &
1385 tij_abc(1, 2, k)*qp_i(1, 2) + &
1386 tij_abc(2, 2, k)*qp_i(2, 2) + &
1387 tij_abc(3, 2, k)*qp_i(3, 2) + &
1388 tij_abc(1, 3, k)*qp_i(1, 3) + &
1389 tij_abc(2, 3, k)*qp_i(2, 3) + &
1390 tij_abc(3, 3, k)*qp_i(3, 3))
1391
1392 fr(k) = fr(k) - fac*(tmp_ij + tmp_ji)
1393 END DO
1394 END IF
1395 END IF
1396 energy = energy + eloc
1397 IF (do_forces) THEN
1398 forces(1, atom_a) = forces(1, atom_a) - fr(1)
1399 forces(2, atom_a) = forces(2, atom_a) - fr(2)
1400 forces(3, atom_a) = forces(3, atom_a) - fr(3)
1401 forces(1, atom_b) = forces(1, atom_b) + fr(1)
1402 forces(2, atom_b) = forces(2, atom_b) + fr(2)
1403 forces(3, atom_b) = forces(3, atom_b) + fr(3)
1404 END IF
1405 ! Electric fields
1406 IF (do_efield) THEN
1407 ! Potential
1408 IF (do_efield0) THEN
1409 efield0(atom_a) = efield0(atom_a) + ef0_j
1410
1411 efield0(atom_b) = efield0(atom_b) + ef0_i
1412 END IF
1413 ! Electric field
1414 IF (do_efield1) THEN
1415 efield1(1, atom_a) = efield1(1, atom_a) + ef1_j(1)
1416 efield1(2, atom_a) = efield1(2, atom_a) + ef1_j(2)
1417 efield1(3, atom_a) = efield1(3, atom_a) + ef1_j(3)
1418
1419 efield1(1, atom_b) = efield1(1, atom_b) + ef1_i(1)
1420 efield1(2, atom_b) = efield1(2, atom_b) + ef1_i(2)
1421 efield1(3, atom_b) = efield1(3, atom_b) + ef1_i(3)
1422 END IF
1423 ! Electric field gradient
1424 IF (do_efield2) THEN
1425 efield2(1, atom_a) = efield2(1, atom_a) + ef2_j(1, 1)
1426 efield2(2, atom_a) = efield2(2, atom_a) + ef2_j(1, 2)
1427 efield2(3, atom_a) = efield2(3, atom_a) + ef2_j(1, 3)
1428 efield2(4, atom_a) = efield2(4, atom_a) + ef2_j(2, 1)
1429 efield2(5, atom_a) = efield2(5, atom_a) + ef2_j(2, 2)
1430 efield2(6, atom_a) = efield2(6, atom_a) + ef2_j(2, 3)
1431 efield2(7, atom_a) = efield2(7, atom_a) + ef2_j(3, 1)
1432 efield2(8, atom_a) = efield2(8, atom_a) + ef2_j(3, 2)
1433 efield2(9, atom_a) = efield2(9, atom_a) + ef2_j(3, 3)
1434
1435 efield2(1, atom_b) = efield2(1, atom_b) + ef2_i(1, 1)
1436 efield2(2, atom_b) = efield2(2, atom_b) + ef2_i(1, 2)
1437 efield2(3, atom_b) = efield2(3, atom_b) + ef2_i(1, 3)
1438 efield2(4, atom_b) = efield2(4, atom_b) + ef2_i(2, 1)
1439 efield2(5, atom_b) = efield2(5, atom_b) + ef2_i(2, 2)
1440 efield2(6, atom_b) = efield2(6, atom_b) + ef2_i(2, 3)
1441 efield2(7, atom_b) = efield2(7, atom_b) + ef2_i(3, 1)
1442 efield2(8, atom_b) = efield2(8, atom_b) + ef2_i(3, 2)
1443 efield2(9, atom_b) = efield2(9, atom_b) + ef2_i(3, 3)
1444 END IF
1445 END IF
1446 IF (do_stress) THEN
1447 ptens11 = ptens11 + rab(1)*fr(1)
1448 ptens21 = ptens21 + rab(2)*fr(1)
1449 ptens31 = ptens31 + rab(3)*fr(1)
1450 ptens12 = ptens12 + rab(1)*fr(2)
1451 ptens22 = ptens22 + rab(2)*fr(2)
1452 ptens32 = ptens32 + rab(3)*fr(2)
1453 ptens13 = ptens13 + rab(1)*fr(3)
1454 ptens23 = ptens23 + rab(2)*fr(3)
1455 ptens33 = ptens33 + rab(3)*fr(3)
1456 END IF
1457
1458 ELSE
1459 ! Compute the Short Range constribution according the task
1460 IF (debug_this_module) THEN
1461 f = huge(0.0_dp)
1462 tij = huge(0.0_dp)
1463 tij_a = huge(0.0_dp)
1464 tij_ab = huge(0.0_dp)
1465 tij_abc = huge(0.0_dp)
1466 tij_abcd = huge(0.0_dp)
1467 tij_abcde = huge(0.0_dp)
1468 END IF
1469 r = sqrt(rab2)
1470 irab2 = 1.0_dp/rab2
1471 ir = 1.0_dp/r
1472
1473 ! Compute the radial function
1474 ! code for point multipole with screening
1475 IF (debug_this_module .AND. debug_r_space .AND. (.NOT. debug_g_space)) THEN
1476 f(0) = ir
1477 tmp = 0.0_dp
1478 ELSE
1479 f(0) = erfc(alpha*r)*ir
1480 tmp = exp(-alpha**2*rab2)*oorootpi
1481 END IF
1482 fac = 1.0_dp
1483 DO i = 1, 5
1484 fac = fac*real(2*i - 1, kind=dp)
1485 f(i) = irab2*(f(i - 1) + tmp*((2.0_dp*alpha**2)**i)/(fac*alpha))
1486 END DO
1487
1488
1489 ! Compute the Tensor components
1490 force_eval = do_stress
1491 IF (task(1, 1)) THEN
1492 tij = f(0)*fac_ij
1493 force_eval = do_forces .OR. do_efield1
1494 END IF
1495 IF (task(2, 2)) force_eval = force_eval .OR. do_efield0
1496 IF (task(1, 2) .OR. force_eval) THEN
1497 force_eval = do_stress
1498 tij_a = -rab*f(1)*fac_ij
1499 IF (task(1, 2)) force_eval = force_eval .OR. do_forces
1500 END IF
1501 IF (task(1, 1)) force_eval = force_eval .OR. do_efield2
1502 IF (task(3, 3)) force_eval = force_eval .OR. do_efield0
1503 IF (task(2, 2) .OR. task(3, 1) .OR. force_eval) THEN
1504 force_eval = do_stress
1505 DO b = 1, 3
1506 DO a = 1, 3
1507 tmp = rab(a)*rab(b)*fac_ij
1508 tij_ab(a, b) = 3.0_dp*tmp*f(2)
1509 IF (a == b) tij_ab(a, b) = tij_ab(a, b) - f(1)*fac_ij
1510 END DO
1511 END DO
1512 IF (task(2, 2) .OR. task(3, 1)) force_eval = force_eval .OR. do_forces
1513 END IF
1514 IF (task(2, 2)) force_eval = force_eval .OR. do_efield2
1515 IF (task(3, 3)) force_eval = force_eval .OR. do_efield1
1516 IF (task(3, 2) .OR. force_eval) THEN
1517 force_eval = do_stress
1518 DO c = 1, 3
1519 DO b = 1, 3
1520 DO a = 1, 3
1521 tmp = rab(a)*rab(b)*rab(c)*fac_ij
1522 tij_abc(a, b, c) = -15.0_dp*tmp*f(3)
1523 tmp = 3.0_dp*f(2)*fac_ij
1524 IF (a == b) tij_abc(a, b, c) = tij_abc(a, b, c) + tmp*rab(c)
1525 IF (a == c) tij_abc(a, b, c) = tij_abc(a, b, c) + tmp*rab(b)
1526 IF (b == c) tij_abc(a, b, c) = tij_abc(a, b, c) + tmp*rab(a)
1527 END DO
1528 END DO
1529 END DO
1530 IF (task(3, 2)) force_eval = force_eval .OR. do_forces
1531 END IF
1532 IF (task(3, 3) .OR. force_eval) THEN
1533 force_eval = do_stress
1534 DO d = 1, 3
1535 DO c = 1, 3
1536 DO b = 1, 3
1537 DO a = 1, 3
1538 tmp = rab(a)*rab(b)*rab(c)*rab(d)*fac_ij
1539 tij_abcd(a, b, c, d) = 105.0_dp*tmp*f(4)
1540 tmp1 = 15.0_dp*f(3)*fac_ij
1541 tmp2 = 3.0_dp*f(2)*fac_ij
1542 IF (a == b) THEN
1543 tij_abcd(a, b, c, d) = tij_abcd(a, b, c, d) - tmp1*rab(c)*rab(d)
1544 IF (c == d) tij_abcd(a, b, c, d) = tij_abcd(a, b, c, d) + tmp2
1545 END IF
1546 IF (a == c) THEN
1547 tij_abcd(a, b, c, d) = tij_abcd(a, b, c, d) - tmp1*rab(b)*rab(d)
1548 IF (b == d) tij_abcd(a, b, c, d) = tij_abcd(a, b, c, d) + tmp2
1549 END IF
1550 IF (a == d) tij_abcd(a, b, c, d) = tij_abcd(a, b, c, d) - tmp1*rab(b)*rab(c)
1551 IF (b == c) THEN
1552 tij_abcd(a, b, c, d) = tij_abcd(a, b, c, d) - tmp1*rab(a)*rab(d)
1553 IF (a == d) tij_abcd(a, b, c, d) = tij_abcd(a, b, c, d) + tmp2
1554 END IF
1555 IF (b == d) tij_abcd(a, b, c, d) = tij_abcd(a, b, c, d) - tmp1*rab(a)*rab(c)
1556 IF (c == d) tij_abcd(a, b, c, d) = tij_abcd(a, b, c, d) - tmp1*rab(a)*rab(b)
1557 END DO
1558 END DO
1559 END DO
1560 END DO
1561 IF (task(3, 3)) force_eval = force_eval .OR. do_forces
1562 END IF
1563 IF (force_eval) THEN
1564 force_eval = do_stress
1565 DO e = 1, 3
1566 DO d = 1, 3
1567 DO c = 1, 3
1568 DO b = 1, 3
1569 DO a = 1, 3
1570 tmp = rab(a)*rab(b)*rab(c)*rab(d)*rab(e)*fac_ij
1571 tij_abcde(a, b, c, d, e) = -945.0_dp*tmp*f(5)
1572 tmp1 = 105.0_dp*f(4)*fac_ij
1573 tmp2 = 15.0_dp*f(3)*fac_ij
1574 IF (a == b) THEN
1575 tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) + tmp1*rab(c)*rab(d)*rab(e)
1576 IF (c == d) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) - tmp2*rab(e)
1577 IF (c == e) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) - tmp2*rab(d)
1578 IF (d == e) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) - tmp2*rab(c)
1579 END IF
1580 IF (a == c) THEN
1581 tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) + tmp1*rab(b)*rab(d)*rab(e)
1582 IF (b == d) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) - tmp2*rab(e)
1583 IF (b == e) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) - tmp2*rab(d)
1584 IF (d == e) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) - tmp2*rab(b)
1585 END IF
1586 IF (a == d) THEN
1587 tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) + tmp1*rab(b)*rab(c)*rab(e)
1588 IF (b == c) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) - tmp2*rab(e)
1589 IF (b == e) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) - tmp2*rab(c)
1590 IF (c == e) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) - tmp2*rab(b)
1591 END IF
1592 IF (a == e) THEN
1593 tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) + tmp1*rab(b)*rab(c)*rab(d)
1594 IF (b == c) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) - tmp2*rab(d)
1595 IF (b == d) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) - tmp2*rab(c)
1596 IF (c == d) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) - tmp2*rab(b)
1597 END IF
1598 IF (b == c) THEN
1599 tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) + tmp1*rab(a)*rab(d)*rab(e)
1600 IF (d == e) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) - tmp2*rab(a)
1601 END IF
1602 IF (b == d) THEN
1603 tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) + tmp1*rab(a)*rab(c)*rab(e)
1604 IF (c == e) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) - tmp2*rab(a)
1605 END IF
1606 IF (b == e) THEN
1607 tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) + tmp1*rab(a)*rab(c)*rab(d)
1608 IF (c == d) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) - tmp2*rab(a)
1609 END IF
1610 IF (c == d) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) + tmp1*rab(a)*rab(b)*rab(e)
1611 IF (c == e) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) + tmp1*rab(a)*rab(b)*rab(d)
1612 IF (d == e) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) + tmp1*rab(a)*rab(b)*rab(c)
1613 END DO
1614 END DO
1615 END DO
1616 END DO
1617 END DO
1618 END IF
1619 eloc = 0.0_dp
1620 fr = 0.0_dp
1621 ef0_i = 0.0_dp
1622 ef0_j = 0.0_dp
1623 ef1_j = 0.0_dp
1624 ef1_i = 0.0_dp
1625 ef2_j = 0.0_dp
1626 ef2_i = 0.0_dp
1627
1628
1629 ! Initialize the damping function.
1630 IF (kind_a == ikind) THEN
1631 ! for atom i
1632 SELECT CASE (itype_ij)
1633 CASE (tang_toennies)
1634 dampsumfi = 1.0_dp
1635 xf = 1.0_dp
1636 factorial = 1.0_dp
1637 DO kk = 1, nkdamp_ij
1638 xf = xf*dampa_ij*r
1639 factorial = factorial*real(kk, kind=dp)
1640 dampsumfi = dampsumfi + (xf/factorial)
1641 END DO
1642 dampaexpi = dexp(-dampa_ij*r)
1643 dampfunci = dampsumfi*dampaexpi*dampfac_ij
1644 dampfuncdiffi = -dampa_ij*dampaexpi* &
1645 dampfac_ij*(((dampa_ij*r)**nkdamp_ij)/ &
1646 factorial)
1647 CASE DEFAULT
1648 dampfunci = 0.0_dp
1649 dampfuncdiffi = 0.0_dp
1650 END SELECT
1651
1652 ! for atom j
1653 SELECT CASE (itype_ji)
1654 CASE (tang_toennies)
1655 dampsumfj = 1.0_dp
1656 xf = 1.0_dp
1657 factorial = 1.0_dp
1658 DO kk = 1, nkdamp_ji
1659 xf = xf*dampa_ji*r
1660 factorial = factorial*real(kk, kind=dp)
1661 dampsumfj = dampsumfj + (xf/factorial)
1662 END DO
1663 dampaexpj = dexp(-dampa_ji*r)
1664 dampfuncj = dampsumfj*dampaexpj*dampfac_ji
1665 dampfuncdiffj = -dampa_ji*dampaexpj* &
1666 dampfac_ji*(((dampa_ji*r)**nkdamp_ji)/ &
1667 factorial)
1668 CASE DEFAULT
1669 dampfuncj = 0.0_dp
1670 dampfuncdiffj = 0.0_dp
1671 END SELECT
1672 ELSE
1673 SELECT CASE (itype_ij)
1674 CASE (tang_toennies)
1675 dampsumfj = 1.0_dp
1676 xf = 1.0_dp
1677 factorial = 1.0_dp
1678 DO kk = 1, nkdamp_ij
1679 xf = xf*dampa_ij*r
1680 factorial = factorial*real(kk, kind=dp)
1681 dampsumfj = dampsumfj + (xf/factorial)
1682 END DO
1683 dampaexpj = dexp(-dampa_ij*r)
1684 dampfuncj = dampsumfj*dampaexpj*dampfac_ij
1685 dampfuncdiffj = -dampa_ij*dampaexpj* &
1686 dampfac_ij*(((dampa_ij*r)**nkdamp_ij)/ &
1687 factorial)
1688 CASE DEFAULT
1689 dampfuncj = 0.0_dp
1690 dampfuncdiffj = 0.0_dp
1691 END SELECT
1692
1693 !for j
1694 SELECT CASE (itype_ji)
1695 CASE (tang_toennies)
1696 dampsumfi = 1.0_dp
1697 xf = 1.0_dp
1698 factorial = 1.0_dp
1699 DO kk = 1, nkdamp_ji
1700 xf = xf*dampa_ji*r
1701 factorial = factorial*real(kk, kind=dp)
1702 dampsumfi = dampsumfi + (xf/factorial)
1703 END DO
1704 dampaexpi = dexp(-dampa_ji*r)
1705 dampfunci = dampsumfi*dampaexpi*dampfac_ji
1706 dampfuncdiffi = -dampa_ji*dampaexpi* &
1707 dampfac_ji*(((dampa_ji*r)**nkdamp_ji)/ &
1708 factorial)
1709 CASE DEFAULT
1710 dampfunci = 0.0_dp
1711 dampfuncdiffi = 0.0_dp
1712 END SELECT
1713 END IF
1714
1715 damptij_a = -rab*dampfunci*fac_ij*irab2*ir
1716 damptji_a = -rab*dampfuncj*fac_ij*irab2*ir
1717 DO b = 1, 3
1718 DO a = 1, 3
1719 tmp = rab(a)*rab(b)*fac_ij
1720 damptij_ab(a, b) = tmp*(-dampfuncdiffi*irab2*irab2 + 3.0_dp*dampfunci*irab2*irab2*ir)
1721 damptji_ab(a, b) = tmp*(-dampfuncdiffj*irab2*irab2 + 3.0_dp*dampfuncj*irab2*irab2*ir)
1722 IF (a == b) damptij_ab(a, b) = damptij_ab(a, b) - dampfunci*fac_ij*irab2*ir
1723 IF (a == b) damptji_ab(a, b) = damptji_ab(a, b) - dampfuncj*fac_ij*irab2*ir
1724 END DO
1725 END DO
1726
1727
1728 ! Initialize the charge, dipole and quadrupole for atom A and B
1729 IF (debug_this_module) THEN
1730 ch_j = huge(0.0_dp)
1731 ch_i = huge(0.0_dp)
1732 dp_j = huge(0.0_dp)
1733 dp_i = huge(0.0_dp)
1734 qp_j = huge(0.0_dp)
1735 qp_i = huge(0.0_dp)
1736 END IF
1737 IF (any(task(1, :))) THEN
1738 ch_j = charges(atom_a)
1739 ch_i = charges(atom_b)
1740 END IF
1741 IF (any(task(2, :))) THEN
1742 dp_j = dipoles(:, atom_a)
1743 dp_i = dipoles(:, atom_b)
1744 END IF
1745 IF (any(task(3, :))) THEN
1746 qp_j = quadrupoles(:, :, atom_a)
1747 qp_i = quadrupoles(:, :, atom_b)
1748 END IF
1749 IF (task(1, 1)) THEN
1750 ! Charge - Charge
1751 eloc = eloc + ch_i*tij*ch_j
1752 ! Forces on particle i (locally b)
1753 IF (do_forces .OR. do_stress) THEN
1754 fr(1) = fr(1) - ch_j*tij_a(1)*ch_i
1755 fr(2) = fr(2) - ch_j*tij_a(2)*ch_i
1756 fr(3) = fr(3) - ch_j*tij_a(3)*ch_i
1757 END IF
1758 ! Electric fields
1759 IF (do_efield) THEN
1760 ! Potential
1761 IF (do_efield0) THEN
1762 ef0_i = ef0_i + tij*ch_j
1763
1764 ef0_j = ef0_j + tij*ch_i
1765 END IF
1766 ! Electric field
1767 IF (do_efield1) THEN
1768 ef1_i(1) = ef1_i(1) - tij_a(1)*ch_j
1769 ef1_i(2) = ef1_i(2) - tij_a(2)*ch_j
1770 ef1_i(3) = ef1_i(3) - tij_a(3)*ch_j
1771
1772 ef1_j(1) = ef1_j(1) + tij_a(1)*ch_i
1773 ef1_j(2) = ef1_j(2) + tij_a(2)*ch_i
1774 ef1_j(3) = ef1_j(3) + tij_a(3)*ch_i
1775
1776 ef1_i(1) = ef1_i(1) + damptij_a(1)*ch_j
1777 ef1_i(2) = ef1_i(2) + damptij_a(2)*ch_j
1778 ef1_i(3) = ef1_i(3) + damptij_a(3)*ch_j
1779
1780 ef1_j(1) = ef1_j(1) - damptji_a(1)*ch_i
1781 ef1_j(2) = ef1_j(2) - damptji_a(2)*ch_i
1782 ef1_j(3) = ef1_j(3) - damptji_a(3)*ch_i
1783
1784 END IF
1785 ! Electric field gradient
1786 IF (do_efield2) THEN
1787 ef2_i(1, 1) = ef2_i(1, 1) - tij_ab(1, 1)*ch_j
1788 ef2_i(2, 1) = ef2_i(2, 1) - tij_ab(2, 1)*ch_j
1789 ef2_i(3, 1) = ef2_i(3, 1) - tij_ab(3, 1)*ch_j
1790 ef2_i(1, 2) = ef2_i(1, 2) - tij_ab(1, 2)*ch_j
1791 ef2_i(2, 2) = ef2_i(2, 2) - tij_ab(2, 2)*ch_j
1792 ef2_i(3, 2) = ef2_i(3, 2) - tij_ab(3, 2)*ch_j
1793 ef2_i(1, 3) = ef2_i(1, 3) - tij_ab(1, 3)*ch_j
1794 ef2_i(2, 3) = ef2_i(2, 3) - tij_ab(2, 3)*ch_j
1795 ef2_i(3, 3) = ef2_i(3, 3) - tij_ab(3, 3)*ch_j
1796
1797 ef2_j(1, 1) = ef2_j(1, 1) - tij_ab(1, 1)*ch_i
1798 ef2_j(2, 1) = ef2_j(2, 1) - tij_ab(2, 1)*ch_i
1799 ef2_j(3, 1) = ef2_j(3, 1) - tij_ab(3, 1)*ch_i
1800 ef2_j(1, 2) = ef2_j(1, 2) - tij_ab(1, 2)*ch_i
1801 ef2_j(2, 2) = ef2_j(2, 2) - tij_ab(2, 2)*ch_i
1802 ef2_j(3, 2) = ef2_j(3, 2) - tij_ab(3, 2)*ch_i
1803 ef2_j(1, 3) = ef2_j(1, 3) - tij_ab(1, 3)*ch_i
1804 ef2_j(2, 3) = ef2_j(2, 3) - tij_ab(2, 3)*ch_i
1805 ef2_j(3, 3) = ef2_j(3, 3) - tij_ab(3, 3)*ch_i
1806 END IF
1807 END IF
1808 END IF
1809 IF (task(2, 2)) THEN
1810 ! Dipole - Dipole
1811 tmp = -(dp_i(1)*(tij_ab(1, 1)*dp_j(1) + &
1812 tij_ab(2, 1)*dp_j(2) + &
1813 tij_ab(3, 1)*dp_j(3)) + &
1814 dp_i(2)*(tij_ab(1, 2)*dp_j(1) + &
1815 tij_ab(2, 2)*dp_j(2) + &
1816 tij_ab(3, 2)*dp_j(3)) + &
1817 dp_i(3)*(tij_ab(1, 3)*dp_j(1) + &
1818 tij_ab(2, 3)*dp_j(2) + &
1819 tij_ab(3, 3)*dp_j(3)))
1820 eloc = eloc + tmp
1821 ! Forces on particle i (locally b)
1822 IF (do_forces .OR. do_stress) THEN
1823 DO k = 1, 3
1824 fr(k) = fr(k) + dp_i(1)*(tij_abc(1, 1, k)*dp_j(1) + &
1825 tij_abc(2, 1, k)*dp_j(2) + &
1826 tij_abc(3, 1, k)*dp_j(3)) &
1827 + dp_i(2)*(tij_abc(1, 2, k)*dp_j(1) + &
1828 tij_abc(2, 2, k)*dp_j(2) + &
1829 tij_abc(3, 2, k)*dp_j(3)) &
1830 + dp_i(3)*(tij_abc(1, 3, k)*dp_j(1) + &
1831 tij_abc(2, 3, k)*dp_j(2) + &
1832 tij_abc(3, 3, k)*dp_j(3))
1833 END DO
1834 END IF
1835 ! Electric fields
1836 IF (do_efield) THEN
1837 ! Potential
1838 IF (do_efield0) THEN
1839 ef0_i = ef0_i - (tij_a(1)*dp_j(1) + &
1840 tij_a(2)*dp_j(2) + &
1841 tij_a(3)*dp_j(3))
1842
1843 ef0_j = ef0_j + (tij_a(1)*dp_i(1) + &
1844 tij_a(2)*dp_i(2) + &
1845 tij_a(3)*dp_i(3))
1846 END IF
1847 ! Electric field
1848 IF (do_efield1) THEN
1849 ef1_i(1) = ef1_i(1) + (tij_ab(1, 1)*dp_j(1) + &
1850 tij_ab(2, 1)*dp_j(2) + &
1851 tij_ab(3, 1)*dp_j(3))
1852 ef1_i(2) = ef1_i(2) + (tij_ab(1, 2)*dp_j(1) + &
1853 tij_ab(2, 2)*dp_j(2) + &
1854 tij_ab(3, 2)*dp_j(3))
1855 ef1_i(3) = ef1_i(3) + (tij_ab(1, 3)*dp_j(1) + &
1856 tij_ab(2, 3)*dp_j(2) + &
1857 tij_ab(3, 3)*dp_j(3))
1858
1859 ef1_j(1) = ef1_j(1) + (tij_ab(1, 1)*dp_i(1) + &
1860 tij_ab(2, 1)*dp_i(2) + &
1861 tij_ab(3, 1)*dp_i(3))
1862 ef1_j(2) = ef1_j(2) + (tij_ab(1, 2)*dp_i(1) + &
1863 tij_ab(2, 2)*dp_i(2) + &
1864 tij_ab(3, 2)*dp_i(3))
1865 ef1_j(3) = ef1_j(3) + (tij_ab(1, 3)*dp_i(1) + &
1866 tij_ab(2, 3)*dp_i(2) + &
1867 tij_ab(3, 3)*dp_i(3))
1868 END IF
1869 ! Electric field gradient
1870 IF (do_efield2) THEN
1871 ef2_i(1, 1) = ef2_i(1, 1) + (tij_abc(1, 1, 1)*dp_j(1) + &
1872 tij_abc(2, 1, 1)*dp_j(2) + &
1873 tij_abc(3, 1, 1)*dp_j(3))
1874 ef2_i(1, 2) = ef2_i(1, 2) + (tij_abc(1, 1, 2)*dp_j(1) + &
1875 tij_abc(2, 1, 2)*dp_j(2) + &
1876 tij_abc(3, 1, 2)*dp_j(3))
1877 ef2_i(1, 3) = ef2_i(1, 3) + (tij_abc(1, 1, 3)*dp_j(1) + &
1878 tij_abc(2, 1, 3)*dp_j(2) + &
1879 tij_abc(3, 1, 3)*dp_j(3))
1880 ef2_i(2, 1) = ef2_i(2, 1) + (tij_abc(1, 2, 1)*dp_j(1) + &
1881 tij_abc(2, 2, 1)*dp_j(2) + &
1882 tij_abc(3, 2, 1)*dp_j(3))
1883 ef2_i(2, 2) = ef2_i(2, 2) + (tij_abc(1, 2, 2)*dp_j(1) + &
1884 tij_abc(2, 2, 2)*dp_j(2) + &
1885 tij_abc(3, 2, 2)*dp_j(3))
1886 ef2_i(2, 3) = ef2_i(2, 3) + (tij_abc(1, 2, 3)*dp_j(1) + &
1887 tij_abc(2, 2, 3)*dp_j(2) + &
1888 tij_abc(3, 2, 3)*dp_j(3))
1889 ef2_i(3, 1) = ef2_i(3, 1) + (tij_abc(1, 3, 1)*dp_j(1) + &
1890 tij_abc(2, 3, 1)*dp_j(2) + &
1891 tij_abc(3, 3, 1)*dp_j(3))
1892 ef2_i(3, 2) = ef2_i(3, 2) + (tij_abc(1, 3, 2)*dp_j(1) + &
1893 tij_abc(2, 3, 2)*dp_j(2) + &
1894 tij_abc(3, 3, 2)*dp_j(3))
1895 ef2_i(3, 3) = ef2_i(3, 3) + (tij_abc(1, 3, 3)*dp_j(1) + &
1896 tij_abc(2, 3, 3)*dp_j(2) + &
1897 tij_abc(3, 3, 3)*dp_j(3))
1898
1899 ef2_j(1, 1) = ef2_j(1, 1) - (tij_abc(1, 1, 1)*dp_i(1) + &
1900 tij_abc(2, 1, 1)*dp_i(2) + &
1901 tij_abc(3, 1, 1)*dp_i(3))
1902 ef2_j(1, 2) = ef2_j(1, 2) - (tij_abc(1, 1, 2)*dp_i(1) + &
1903 tij_abc(2, 1, 2)*dp_i(2) + &
1904 tij_abc(3, 1, 2)*dp_i(3))
1905 ef2_j(1, 3) = ef2_j(1, 3) - (tij_abc(1, 1, 3)*dp_i(1) + &
1906 tij_abc(2, 1, 3)*dp_i(2) + &
1907 tij_abc(3, 1, 3)*dp_i(3))
1908 ef2_j(2, 1) = ef2_j(2, 1) - (tij_abc(1, 2, 1)*dp_i(1) + &
1909 tij_abc(2, 2, 1)*dp_i(2) + &
1910 tij_abc(3, 2, 1)*dp_i(3))
1911 ef2_j(2, 2) = ef2_j(2, 2) - (tij_abc(1, 2, 2)*dp_i(1) + &
1912 tij_abc(2, 2, 2)*dp_i(2) + &
1913 tij_abc(3, 2, 2)*dp_i(3))
1914 ef2_j(2, 3) = ef2_j(2, 3) - (tij_abc(1, 2, 3)*dp_i(1) + &
1915 tij_abc(2, 2, 3)*dp_i(2) + &
1916 tij_abc(3, 2, 3)*dp_i(3))
1917 ef2_j(3, 1) = ef2_j(3, 1) - (tij_abc(1, 3, 1)*dp_i(1) + &
1918 tij_abc(2, 3, 1)*dp_i(2) + &
1919 tij_abc(3, 3, 1)*dp_i(3))
1920 ef2_j(3, 2) = ef2_j(3, 2) - (tij_abc(1, 3, 2)*dp_i(1) + &
1921 tij_abc(2, 3, 2)*dp_i(2) + &
1922 tij_abc(3, 3, 2)*dp_i(3))
1923 ef2_j(3, 3) = ef2_j(3, 3) - (tij_abc(1, 3, 3)*dp_i(1) + &
1924 tij_abc(2, 3, 3)*dp_i(2) + &
1925 tij_abc(3, 3, 3)*dp_i(3))
1926 END IF
1927 END IF
1928 END IF
1929 IF (task(2, 1)) THEN
1930 ! Dipole - Charge
1931 tmp = ch_j*(tij_a(1)*dp_i(1) + &
1932 tij_a(2)*dp_i(2) + &
1933 tij_a(3)*dp_i(3)) &
1934 - ch_i*(tij_a(1)*dp_j(1) + &
1935 tij_a(2)*dp_j(2) + &
1936 tij_a(3)*dp_j(3))
1937 tmp = tmp - ch_j*(damptij_a(1)*dp_i(1) + &
1938 damptij_a(2)*dp_i(2) + &
1939 damptij_a(3)*dp_i(3)) &
1940 + ch_i*(damptji_a(1)*dp_j(1) + &
1941 damptji_a(2)*dp_j(2) + &
1942 damptji_a(3)*dp_j(3))
1943 eloc = eloc + tmp
1944 ! Forces on particle i (locally b)
1945 IF (do_forces .OR. do_stress) THEN
1946 DO k = 1, 3
1947 fr(k) = fr(k) - ch_j*(tij_ab(1, k)*dp_i(1) + &
1948 tij_ab(2, k)*dp_i(2) + &
1949 tij_ab(3, k)*dp_i(3)) &
1950 + ch_i*(tij_ab(1, k)*dp_j(1) + &
1951 tij_ab(2, k)*dp_j(2) + &
1952 tij_ab(3, k)*dp_j(3))
1953 fr(k) = fr(k) + ch_j*(damptij_ab(1, k)*dp_i(1) + &
1954 damptij_ab(2, k)*dp_i(2) + &
1955 damptij_ab(3, k)*dp_i(3)) &
1956 - ch_i*(damptji_ab(1, k)*dp_j(1) + &
1957 damptji_ab(2, k)*dp_j(2) + &
1958 damptji_ab(3, k)*dp_j(3))
1959 END DO
1960 END IF
1961 END IF
1962 IF (task(3, 3)) THEN
1963 ! Quadrupole - Quadrupole
1964 fac = 1.0_dp/9.0_dp
1965 tmp11 = qp_i(1, 1)*(tij_abcd(1, 1, 1, 1)*qp_j(1, 1) + &
1966 tij_abcd(2, 1, 1, 1)*qp_j(2, 1) + &
1967 tij_abcd(3, 1, 1, 1)*qp_j(3, 1) + &
1968 tij_abcd(1, 2, 1, 1)*qp_j(1, 2) + &
1969 tij_abcd(2, 2, 1, 1)*qp_j(2, 2) + &
1970 tij_abcd(3, 2, 1, 1)*qp_j(3, 2) + &
1971 tij_abcd(1, 3, 1, 1)*qp_j(1, 3) + &
1972 tij_abcd(2, 3, 1, 1)*qp_j(2, 3) + &
1973 tij_abcd(3, 3, 1, 1)*qp_j(3, 3))
1974 tmp21 = qp_i(2, 1)*(tij_abcd(1, 1, 1, 2)*qp_j(1, 1) + &
1975 tij_abcd(2, 1, 1, 2)*qp_j(2, 1) + &
1976 tij_abcd(3, 1, 1, 2)*qp_j(3, 1) + &
1977 tij_abcd(1, 2, 1, 2)*qp_j(1, 2) + &
1978 tij_abcd(2, 2, 1, 2)*qp_j(2, 2) + &
1979 tij_abcd(3, 2, 1, 2)*qp_j(3, 2) + &
1980 tij_abcd(1, 3, 1, 2)*qp_j(1, 3) + &
1981 tij_abcd(2, 3, 1, 2)*qp_j(2, 3) + &
1982 tij_abcd(3, 3, 1, 2)*qp_j(3, 3))
1983 tmp31 = qp_i(3, 1)*(tij_abcd(1, 1, 1, 3)*qp_j(1, 1) + &
1984 tij_abcd(2, 1, 1, 3)*qp_j(2, 1) + &
1985 tij_abcd(3, 1, 1, 3)*qp_j(3, 1) + &
1986 tij_abcd(1, 2, 1, 3)*qp_j(1, 2) + &
1987 tij_abcd(2, 2, 1, 3)*qp_j(2, 2) + &
1988 tij_abcd(3, 2, 1, 3)*qp_j(3, 2) + &
1989 tij_abcd(1, 3, 1, 3)*qp_j(1, 3) + &
1990 tij_abcd(2, 3, 1, 3)*qp_j(2, 3) + &
1991 tij_abcd(3, 3, 1, 3)*qp_j(3, 3))
1992 tmp22 = qp_i(2, 2)*(tij_abcd(1, 1, 2, 2)*qp_j(1, 1) + &
1993 tij_abcd(2, 1, 2, 2)*qp_j(2, 1) + &
1994 tij_abcd(3, 1, 2, 2)*qp_j(3, 1) + &
1995 tij_abcd(1, 2, 2, 2)*qp_j(1, 2) + &
1996 tij_abcd(2, 2, 2, 2)*qp_j(2, 2) + &
1997 tij_abcd(3, 2, 2, 2)*qp_j(3, 2) + &
1998 tij_abcd(1, 3, 2, 2)*qp_j(1, 3) + &
1999 tij_abcd(2, 3, 2, 2)*qp_j(2, 3) + &
2000 tij_abcd(3, 3, 2, 2)*qp_j(3, 3))
2001 tmp32 = qp_i(3, 2)*(tij_abcd(1, 1, 2, 3)*qp_j(1, 1) + &
2002 tij_abcd(2, 1, 2, 3)*qp_j(2, 1) + &
2003 tij_abcd(3, 1, 2, 3)*qp_j(3, 1) + &
2004 tij_abcd(1, 2, 2, 3)*qp_j(1, 2) + &
2005 tij_abcd(2, 2, 2, 3)*qp_j(2, 2) + &
2006 tij_abcd(3, 2, 2, 3)*qp_j(3, 2) + &
2007 tij_abcd(1, 3, 2, 3)*qp_j(1, 3) + &
2008 tij_abcd(2, 3, 2, 3)*qp_j(2, 3) + &
2009 tij_abcd(3, 3, 2, 3)*qp_j(3, 3))
2010 tmp33 = qp_i(3, 3)*(tij_abcd(1, 1, 3, 3)*qp_j(1, 1) + &
2011 tij_abcd(2, 1, 3, 3)*qp_j(2, 1) + &
2012 tij_abcd(3, 1, 3, 3)*qp_j(3, 1) + &
2013 tij_abcd(1, 2, 3, 3)*qp_j(1, 2) + &
2014 tij_abcd(2, 2, 3, 3)*qp_j(2, 2) + &
2015 tij_abcd(3, 2, 3, 3)*qp_j(3, 2) + &
2016 tij_abcd(1, 3, 3, 3)*qp_j(1, 3) + &
2017 tij_abcd(2, 3, 3, 3)*qp_j(2, 3) + &
2018 tij_abcd(3, 3, 3, 3)*qp_j(3, 3))
2019 tmp12 = tmp21
2020 tmp13 = tmp31
2021 tmp23 = tmp32
2022 tmp = tmp11 + tmp12 + tmp13 + &
2023 tmp21 + tmp22 + tmp23 + &
2024 tmp31 + tmp32 + tmp33
2025
2026 eloc = eloc + fac*tmp
2027 ! Forces on particle i (locally b)
2028 IF (do_forces .OR. do_stress) THEN
2029 DO k = 1, 3
2030 tmp11 = qp_i(1, 1)*(tij_abcde(1, 1, 1, 1, k)*qp_j(1, 1) + &
2031 tij_abcde(2, 1, 1, 1, k)*qp_j(2, 1) + &
2032 tij_abcde(3, 1, 1, 1, k)*qp_j(3, 1) + &
2033 tij_abcde(1, 2, 1, 1, k)*qp_j(1, 2) + &
2034 tij_abcde(2, 2, 1, 1, k)*qp_j(2, 2) + &
2035 tij_abcde(3, 2, 1, 1, k)*qp_j(3, 2) + &
2036 tij_abcde(1, 3, 1, 1, k)*qp_j(1, 3) + &
2037 tij_abcde(2, 3, 1, 1, k)*qp_j(2, 3) + &
2038 tij_abcde(3, 3, 1, 1, k)*qp_j(3, 3))
2039 tmp21 = qp_i(2, 1)*(tij_abcde(1, 1, 2, 1, k)*qp_j(1, 1) + &
2040 tij_abcde(2, 1, 2, 1, k)*qp_j(2, 1) + &
2041 tij_abcde(3, 1, 2, 1, k)*qp_j(3, 1) + &
2042 tij_abcde(1, 2, 2, 1, k)*qp_j(1, 2) + &
2043 tij_abcde(2, 2, 2, 1, k)*qp_j(2, 2) + &
2044 tij_abcde(3, 2, 2, 1, k)*qp_j(3, 2) + &
2045 tij_abcde(1, 3, 2, 1, k)*qp_j(1, 3) + &
2046 tij_abcde(2, 3, 2, 1, k)*qp_j(2, 3) + &
2047 tij_abcde(3, 3, 2, 1, k)*qp_j(3, 3))
2048 tmp31 = qp_i(3, 1)*(tij_abcde(1, 1, 3, 1, k)*qp_j(1, 1) + &
2049 tij_abcde(2, 1, 3, 1, k)*qp_j(2, 1) + &
2050 tij_abcde(3, 1, 3, 1, k)*qp_j(3, 1) + &
2051 tij_abcde(1, 2, 3, 1, k)*qp_j(1, 2) + &
2052 tij_abcde(2, 2, 3, 1, k)*qp_j(2, 2) + &
2053 tij_abcde(3, 2, 3, 1, k)*qp_j(3, 2) + &
2054 tij_abcde(1, 3, 3, 1, k)*qp_j(1, 3) + &
2055 tij_abcde(2, 3, 3, 1, k)*qp_j(2, 3) + &
2056 tij_abcde(3, 3, 3, 1, k)*qp_j(3, 3))
2057 tmp22 = qp_i(2, 2)*(tij_abcde(1, 1, 2, 2, k)*qp_j(1, 1) + &
2058 tij_abcde(2, 1, 2, 2, k)*qp_j(2, 1) + &
2059 tij_abcde(3, 1, 2, 2, k)*qp_j(3, 1) + &
2060 tij_abcde(1, 2, 2, 2, k)*qp_j(1, 2) + &
2061 tij_abcde(2, 2, 2, 2, k)*qp_j(2, 2) + &
2062 tij_abcde(3, 2, 2, 2, k)*qp_j(3, 2) + &
2063 tij_abcde(1, 3, 2, 2, k)*qp_j(1, 3) + &
2064 tij_abcde(2, 3, 2, 2, k)*qp_j(2, 3) + &
2065 tij_abcde(3, 3, 2, 2, k)*qp_j(3, 3))
2066 tmp32 = qp_i(3, 2)*(tij_abcde(1, 1, 3, 2, k)*qp_j(1, 1) + &
2067 tij_abcde(2, 1, 3, 2, k)*qp_j(2, 1) + &
2068 tij_abcde(3, 1, 3, 2, k)*qp_j(3, 1) + &
2069 tij_abcde(1, 2, 3, 2, k)*qp_j(1, 2) + &
2070 tij_abcde(2, 2, 3, 2, k)*qp_j(2, 2) + &
2071 tij_abcde(3, 2, 3, 2, k)*qp_j(3, 2) + &
2072 tij_abcde(1, 3, 3, 2, k)*qp_j(1, 3) + &
2073 tij_abcde(2, 3, 3, 2, k)*qp_j(2, 3) + &
2074 tij_abcde(3, 3, 3, 2, k)*qp_j(3, 3))
2075 tmp33 = qp_i(3, 3)*(tij_abcde(1, 1, 3, 3, k)*qp_j(1, 1) + &
2076 tij_abcde(2, 1, 3, 3, k)*qp_j(2, 1) + &
2077 tij_abcde(3, 1, 3, 3, k)*qp_j(3, 1) + &
2078 tij_abcde(1, 2, 3, 3, k)*qp_j(1, 2) + &
2079 tij_abcde(2, 2, 3, 3, k)*qp_j(2, 2) + &
2080 tij_abcde(3, 2, 3, 3, k)*qp_j(3, 2) + &
2081 tij_abcde(1, 3, 3, 3, k)*qp_j(1, 3) + &
2082 tij_abcde(2, 3, 3, 3, k)*qp_j(2, 3) + &
2083 tij_abcde(3, 3, 3, 3, k)*qp_j(3, 3))
2084 tmp12 = tmp21
2085 tmp13 = tmp31
2086 tmp23 = tmp32
2087 fr(k) = fr(k) - fac*(tmp11 + tmp12 + tmp13 + &
2088 tmp21 + tmp22 + tmp23 + &
2089 tmp31 + tmp32 + tmp33)
2090 END DO
2091 END IF
2092 ! Electric field
2093 IF (do_efield) THEN
2094 fac = 1.0_dp/3.0_dp
2095 ! Potential
2096 IF (do_efield0) THEN
2097 ef0_i = ef0_i + fac*(tij_ab(1, 1)*qp_j(1, 1) + &
2098 tij_ab(2, 1)*qp_j(2, 1) + &
2099 tij_ab(3, 1)*qp_j(3, 1) + &
2100 tij_ab(1, 2)*qp_j(1, 2) + &
2101 tij_ab(2, 2)*qp_j(2, 2) + &
2102 tij_ab(3, 2)*qp_j(3, 2) + &
2103 tij_ab(1, 3)*qp_j(1, 3) + &
2104 tij_ab(2, 3)*qp_j(2, 3) + &
2105 tij_ab(3, 3)*qp_j(3, 3))
2106
2107 ef0_j = ef0_j + fac*(tij_ab(1, 1)*qp_i(1, 1) + &
2108 tij_ab(2, 1)*qp_i(2, 1) + &
2109 tij_ab(3, 1)*qp_i(3, 1) + &
2110 tij_ab(1, 2)*qp_i(1, 2) + &
2111 tij_ab(2, 2)*qp_i(2, 2) + &
2112 tij_ab(3, 2)*qp_i(3, 2) + &
2113 tij_ab(1, 3)*qp_i(1, 3) + &
2114 tij_ab(2, 3)*qp_i(2, 3) + &
2115 tij_ab(3, 3)*qp_i(3, 3))
2116 END IF
2117 ! Electric field
2118 IF (do_efield1) THEN
2119 ef1_i(1) = ef1_i(1) - fac*(tij_abc(1, 1, 1)*qp_j(1, 1) + &
2120 tij_abc(2, 1, 1)*qp_j(2, 1) + &
2121 tij_abc(3, 1, 1)*qp_j(3, 1) + &
2122 tij_abc(1, 2, 1)*qp_j(1, 2) + &
2123 tij_abc(2, 2, 1)*qp_j(2, 2) + &
2124 tij_abc(3, 2, 1)*qp_j(3, 2) + &
2125 tij_abc(1, 3, 1)*qp_j(1, 3) + &
2126 tij_abc(2, 3, 1)*qp_j(2, 3) + &
2127 tij_abc(3, 3, 1)*qp_j(3, 3))
2128 ef1_i(2) = ef1_i(2) - fac*(tij_abc(1, 1, 2)*qp_j(1, 1) + &
2129 tij_abc(2, 1, 2)*qp_j(2, 1) + &
2130 tij_abc(3, 1, 2)*qp_j(3, 1) + &
2131 tij_abc(1, 2, 2)*qp_j(1, 2) + &
2132 tij_abc(2, 2, 2)*qp_j(2, 2) + &
2133 tij_abc(3, 2, 2)*qp_j(3, 2) + &
2134 tij_abc(1, 3, 2)*qp_j(1, 3) + &
2135 tij_abc(2, 3, 2)*qp_j(2, 3) + &
2136 tij_abc(3, 3, 2)*qp_j(3, 3))
2137 ef1_i(3) = ef1_i(3) - fac*(tij_abc(1, 1, 3)*qp_j(1, 1) + &
2138 tij_abc(2, 1, 3)*qp_j(2, 1) + &
2139 tij_abc(3, 1, 3)*qp_j(3, 1) + &
2140 tij_abc(1, 2, 3)*qp_j(1, 2) + &
2141 tij_abc(2, 2, 3)*qp_j(2, 2) + &
2142 tij_abc(3, 2, 3)*qp_j(3, 2) + &
2143 tij_abc(1, 3, 3)*qp_j(1, 3) + &
2144 tij_abc(2, 3, 3)*qp_j(2, 3) + &
2145 tij_abc(3, 3, 3)*qp_j(3, 3))
2146
2147 ef1_j(1) = ef1_j(1) + fac*(tij_abc(1, 1, 1)*qp_i(1, 1) + &
2148 tij_abc(2, 1, 1)*qp_i(2, 1) + &
2149 tij_abc(3, 1, 1)*qp_i(3, 1) + &
2150 tij_abc(1, 2, 1)*qp_i(1, 2) + &
2151 tij_abc(2, 2, 1)*qp_i(2, 2) + &
2152 tij_abc(3, 2, 1)*qp_i(3, 2) + &
2153 tij_abc(1, 3, 1)*qp_i(1, 3) + &
2154 tij_abc(2, 3, 1)*qp_i(2, 3) + &
2155 tij_abc(3, 3, 1)*qp_i(3, 3))
2156 ef1_j(2) = ef1_j(2) + fac*(tij_abc(1, 1, 2)*qp_i(1, 1) + &
2157 tij_abc(2, 1, 2)*qp_i(2, 1) + &
2158 tij_abc(3, 1, 2)*qp_i(3, 1) + &
2159 tij_abc(1, 2, 2)*qp_i(1, 2) + &
2160 tij_abc(2, 2, 2)*qp_i(2, 2) + &
2161 tij_abc(3, 2, 2)*qp_i(3, 2) + &
2162 tij_abc(1, 3, 2)*qp_i(1, 3) + &
2163 tij_abc(2, 3, 2)*qp_i(2, 3) + &
2164 tij_abc(3, 3, 2)*qp_i(3, 3))
2165 ef1_j(3) = ef1_j(3) + fac*(tij_abc(1, 1, 3)*qp_i(1, 1) + &
2166 tij_abc(2, 1, 3)*qp_i(2, 1) + &
2167 tij_abc(3, 1, 3)*qp_i(3, 1) + &
2168 tij_abc(1, 2, 3)*qp_i(1, 2) + &
2169 tij_abc(2, 2, 3)*qp_i(2, 2) + &
2170 tij_abc(3, 2, 3)*qp_i(3, 2) + &
2171 tij_abc(1, 3, 3)*qp_i(1, 3) + &
2172 tij_abc(2, 3, 3)*qp_i(2, 3) + &
2173 tij_abc(3, 3, 3)*qp_i(3, 3))
2174 END IF
2175 ! Electric field gradient
2176 IF (do_efield2) THEN
2177 tmp11 = fac*(tij_abcd(1, 1, 1, 1)*qp_j(1, 1) + &
2178 tij_abcd(2, 1, 1, 1)*qp_j(2, 1) + &
2179 tij_abcd(3, 1, 1, 1)*qp_j(3, 1) + &
2180 tij_abcd(1, 2, 1, 1)*qp_j(1, 2) + &
2181 tij_abcd(2, 2, 1, 1)*qp_j(2, 2) + &
2182 tij_abcd(3, 2, 1, 1)*qp_j(3, 2) + &
2183 tij_abcd(1, 3, 1, 1)*qp_j(1, 3) + &
2184 tij_abcd(2, 3, 1, 1)*qp_j(2, 3) + &
2185 tij_abcd(3, 3, 1, 1)*qp_j(3, 3))
2186 tmp12 = fac*(tij_abcd(1, 1, 1, 2)*qp_j(1, 1) + &
2187 tij_abcd(2, 1, 1, 2)*qp_j(2, 1) + &
2188 tij_abcd(3, 1, 1, 2)*qp_j(3, 1) + &
2189 tij_abcd(1, 2, 1, 2)*qp_j(1, 2) + &
2190 tij_abcd(2, 2, 1, 2)*qp_j(2, 2) + &
2191 tij_abcd(3, 2, 1, 2)*qp_j(3, 2) + &
2192 tij_abcd(1, 3, 1, 2)*qp_j(1, 3) + &
2193 tij_abcd(2, 3, 1, 2)*qp_j(2, 3) + &
2194 tij_abcd(3, 3, 1, 2)*qp_j(3, 3))
2195 tmp13 = fac*(tij_abcd(1, 1, 1, 3)*qp_j(1, 1) + &
2196 tij_abcd(2, 1, 1, 3)*qp_j(2, 1) + &
2197 tij_abcd(3, 1, 1, 3)*qp_j(3, 1) + &
2198 tij_abcd(1, 2, 1, 3)*qp_j(1, 2) + &
2199 tij_abcd(2, 2, 1, 3)*qp_j(2, 2) + &
2200 tij_abcd(3, 2, 1, 3)*qp_j(3, 2) + &
2201 tij_abcd(1, 3, 1, 3)*qp_j(1, 3) + &
2202 tij_abcd(2, 3, 1, 3)*qp_j(2, 3) + &
2203 tij_abcd(3, 3, 1, 3)*qp_j(3, 3))
2204 tmp22 = fac*(tij_abcd(1, 1, 2, 2)*qp_j(1, 1) + &
2205 tij_abcd(2, 1, 2, 2)*qp_j(2, 1) + &
2206 tij_abcd(3, 1, 2, 2)*qp_j(3, 1) + &
2207 tij_abcd(1, 2, 2, 2)*qp_j(1, 2) + &
2208 tij_abcd(2, 2, 2, 2)*qp_j(2, 2) + &
2209 tij_abcd(3, 2, 2, 2)*qp_j(3, 2) + &
2210 tij_abcd(1, 3, 2, 2)*qp_j(1, 3) + &
2211 tij_abcd(2, 3, 2, 2)*qp_j(2, 3) + &
2212 tij_abcd(3, 3, 2, 2)*qp_j(3, 3))
2213 tmp23 = fac*(tij_abcd(1, 1, 2, 3)*qp_j(1, 1) + &
2214 tij_abcd(2, 1, 2, 3)*qp_j(2, 1) + &
2215 tij_abcd(3, 1, 2, 3)*qp_j(3, 1) + &
2216 tij_abcd(1, 2, 2, 3)*qp_j(1, 2) + &
2217 tij_abcd(2, 2, 2, 3)*qp_j(2, 2) + &
2218 tij_abcd(3, 2, 2, 3)*qp_j(3, 2) + &
2219 tij_abcd(1, 3, 2, 3)*qp_j(1, 3) + &
2220 tij_abcd(2, 3, 2, 3)*qp_j(2, 3) + &
2221 tij_abcd(3, 3, 2, 3)*qp_j(3, 3))
2222 tmp33 = fac*(tij_abcd(1, 1, 3, 3)*qp_j(1, 1) + &
2223 tij_abcd(2, 1, 3, 3)*qp_j(2, 1) + &
2224 tij_abcd(3, 1, 3, 3)*qp_j(3, 1) + &
2225 tij_abcd(1, 2, 3, 3)*qp_j(1, 2) + &
2226 tij_abcd(2, 2, 3, 3)*qp_j(2, 2) + &
2227 tij_abcd(3, 2, 3, 3)*qp_j(3, 2) + &
2228 tij_abcd(1, 3, 3, 3)*qp_j(1, 3) + &
2229 tij_abcd(2, 3, 3, 3)*qp_j(2, 3) + &
2230 tij_abcd(3, 3, 3, 3)*qp_j(3, 3))
2231
2232 ef2_i(1, 1) = ef2_i(1, 1) - tmp11
2233 ef2_i(1, 2) = ef2_i(1, 2) - tmp12
2234 ef2_i(1, 3) = ef2_i(1, 3) - tmp13
2235 ef2_i(2, 1) = ef2_i(2, 1) - tmp12
2236 ef2_i(2, 2) = ef2_i(2, 2) - tmp22
2237 ef2_i(2, 3) = ef2_i(2, 3) - tmp23
2238 ef2_i(3, 1) = ef2_i(3, 1) - tmp13
2239 ef2_i(3, 2) = ef2_i(3, 2) - tmp23
2240 ef2_i(3, 3) = ef2_i(3, 3) - tmp33
2241
2242 tmp11 = fac*(tij_abcd(1, 1, 1, 1)*qp_i(1, 1) + &
2243 tij_abcd(2, 1, 1, 1)*qp_i(2, 1) + &
2244 tij_abcd(3, 1, 1, 1)*qp_i(3, 1) + &
2245 tij_abcd(1, 2, 1, 1)*qp_i(1, 2) + &
2246 tij_abcd(2, 2, 1, 1)*qp_i(2, 2) + &
2247 tij_abcd(3, 2, 1, 1)*qp_i(3, 2) + &
2248 tij_abcd(1, 3, 1, 1)*qp_i(1, 3) + &
2249 tij_abcd(2, 3, 1, 1)*qp_i(2, 3) + &
2250 tij_abcd(3, 3, 1, 1)*qp_i(3, 3))
2251 tmp12 = fac*(tij_abcd(1, 1, 1, 2)*qp_i(1, 1) + &
2252 tij_abcd(2, 1, 1, 2)*qp_i(2, 1) + &
2253 tij_abcd(3, 1, 1, 2)*qp_i(3, 1) + &
2254 tij_abcd(1, 2, 1, 2)*qp_i(1, 2) + &
2255 tij_abcd(2, 2, 1, 2)*qp_i(2, 2) + &
2256 tij_abcd(3, 2, 1, 2)*qp_i(3, 2) + &
2257 tij_abcd(1, 3, 1, 2)*qp_i(1, 3) + &
2258 tij_abcd(2, 3, 1, 2)*qp_i(2, 3) + &
2259 tij_abcd(3, 3, 1, 2)*qp_i(3, 3))
2260 tmp13 = fac*(tij_abcd(1, 1, 1, 3)*qp_i(1, 1) + &
2261 tij_abcd(2, 1, 1, 3)*qp_i(2, 1) + &
2262 tij_abcd(3, 1, 1, 3)*qp_i(3, 1) + &
2263 tij_abcd(1, 2, 1, 3)*qp_i(1, 2) + &
2264 tij_abcd(2, 2, 1, 3)*qp_i(2, 2) + &
2265 tij_abcd(3, 2, 1, 3)*qp_i(3, 2) + &
2266 tij_abcd(1, 3, 1, 3)*qp_i(1, 3) + &
2267 tij_abcd(2, 3, 1, 3)*qp_i(2, 3) + &
2268 tij_abcd(3, 3, 1, 3)*qp_i(3, 3))
2269 tmp22 = fac*(tij_abcd(1, 1, 2, 2)*qp_i(1, 1) + &
2270 tij_abcd(2, 1, 2, 2)*qp_i(2, 1) + &
2271 tij_abcd(3, 1, 2, 2)*qp_i(3, 1) + &
2272 tij_abcd(1, 2, 2, 2)*qp_i(1, 2) + &
2273 tij_abcd(2, 2, 2, 2)*qp_i(2, 2) + &
2274 tij_abcd(3, 2, 2, 2)*qp_i(3, 2) + &
2275 tij_abcd(1, 3, 2, 2)*qp_i(1, 3) + &
2276 tij_abcd(2, 3, 2, 2)*qp_i(2, 3) + &
2277 tij_abcd(3, 3, 2, 2)*qp_i(3, 3))
2278 tmp23 = fac*(tij_abcd(1, 1, 2, 3)*qp_i(1, 1) + &
2279 tij_abcd(2, 1, 2, 3)*qp_i(2, 1) + &
2280 tij_abcd(3, 1, 2, 3)*qp_i(3, 1) + &
2281 tij_abcd(1, 2, 2, 3)*qp_i(1, 2) + &
2282 tij_abcd(2, 2, 2, 3)*qp_i(2, 2) + &
2283 tij_abcd(3, 2, 2, 3)*qp_i(3, 2) + &
2284 tij_abcd(1, 3, 2, 3)*qp_i(1, 3) + &
2285 tij_abcd(2, 3, 2, 3)*qp_i(2, 3) + &
2286 tij_abcd(3, 3, 2, 3)*qp_i(3, 3))
2287 tmp33 = fac*(tij_abcd(1, 1, 3, 3)*qp_i(1, 1) + &
2288 tij_abcd(2, 1, 3, 3)*qp_i(2, 1) + &
2289 tij_abcd(3, 1, 3, 3)*qp_i(3, 1) + &
2290 tij_abcd(1, 2, 3, 3)*qp_i(1, 2) + &
2291 tij_abcd(2, 2, 3, 3)*qp_i(2, 2) + &
2292 tij_abcd(3, 2, 3, 3)*qp_i(3, 2) + &
2293 tij_abcd(1, 3, 3, 3)*qp_i(1, 3) + &
2294 tij_abcd(2, 3, 3, 3)*qp_i(2, 3) + &
2295 tij_abcd(3, 3, 3, 3)*qp_i(3, 3))
2296
2297 ef2_j(1, 1) = ef2_j(1, 1) - tmp11
2298 ef2_j(1, 2) = ef2_j(1, 2) - tmp12
2299 ef2_j(1, 3) = ef2_j(1, 3) - tmp13
2300 ef2_j(2, 1) = ef2_j(2, 1) - tmp12
2301 ef2_j(2, 2) = ef2_j(2, 2) - tmp22
2302 ef2_j(2, 3) = ef2_j(2, 3) - tmp23
2303 ef2_j(3, 1) = ef2_j(3, 1) - tmp13
2304 ef2_j(3, 2) = ef2_j(3, 2) - tmp23
2305 ef2_j(3, 3) = ef2_j(3, 3) - tmp33
2306 END IF
2307 END IF
2308 END IF
2309 IF (task(3, 2)) THEN
2310 ! Quadrupole - Dipole
2311 fac = 1.0_dp/3.0_dp
2312 ! Dipole i (locally B) - Quadrupole j (locally A)
2313 tmp_ij = dp_i(1)*(tij_abc(1, 1, 1)*qp_j(1, 1) + &
2314 tij_abc(2, 1, 1)*qp_j(2, 1) + &
2315 tij_abc(3, 1, 1)*qp_j(3, 1) + &
2316 tij_abc(1, 2, 1)*qp_j(1, 2) + &
2317 tij_abc(2, 2, 1)*qp_j(2, 2) + &
2318 tij_abc(3, 2, 1)*qp_j(3, 2) + &
2319 tij_abc(1, 3, 1)*qp_j(1, 3) + &
2320 tij_abc(2, 3, 1)*qp_j(2, 3) + &
2321 tij_abc(3, 3, 1)*qp_j(3, 3)) + &
2322 dp_i(2)*(tij_abc(1, 1, 2)*qp_j(1, 1) + &
2323 tij_abc(2, 1, 2)*qp_j(2, 1) + &
2324 tij_abc(3, 1, 2)*qp_j(3, 1) + &
2325 tij_abc(1, 2, 2)*qp_j(1, 2) + &
2326 tij_abc(2, 2, 2)*qp_j(2, 2) + &
2327 tij_abc(3, 2, 2)*qp_j(3, 2) + &
2328 tij_abc(1, 3, 2)*qp_j(1, 3) + &
2329 tij_abc(2, 3, 2)*qp_j(2, 3) + &
2330 tij_abc(3, 3, 2)*qp_j(3, 3)) + &
2331 dp_i(3)*(tij_abc(1, 1, 3)*qp_j(1, 1) + &
2332 tij_abc(2, 1, 3)*qp_j(2, 1) + &
2333 tij_abc(3, 1, 3)*qp_j(3, 1) + &
2334 tij_abc(1, 2, 3)*qp_j(1, 2) + &
2335 tij_abc(2, 2, 3)*qp_j(2, 2) + &
2336 tij_abc(3, 2, 3)*qp_j(3, 2) + &
2337 tij_abc(1, 3, 3)*qp_j(1, 3) + &
2338 tij_abc(2, 3, 3)*qp_j(2, 3) + &
2339 tij_abc(3, 3, 3)*qp_j(3, 3))
2340
2341 ! Dipole j (locally A) - Quadrupole i (locally B)
2342 tmp_ji = dp_j(1)*(tij_abc(1, 1, 1)*qp_i(1, 1) + &
2343 tij_abc(2, 1, 1)*qp_i(2, 1) + &
2344 tij_abc(3, 1, 1)*qp_i(3, 1) + &
2345 tij_abc(1, 2, 1)*qp_i(1, 2) + &
2346 tij_abc(2, 2, 1)*qp_i(2, 2) + &
2347 tij_abc(3, 2, 1)*qp_i(3, 2) + &
2348 tij_abc(1, 3, 1)*qp_i(1, 3) + &
2349 tij_abc(2, 3, 1)*qp_i(2, 3) + &
2350 tij_abc(3, 3, 1)*qp_i(3, 3)) + &
2351 dp_j(2)*(tij_abc(1, 1, 2)*qp_i(1, 1) + &
2352 tij_abc(2, 1, 2)*qp_i(2, 1) + &
2353 tij_abc(3, 1, 2)*qp_i(3, 1) + &
2354 tij_abc(1, 2, 2)*qp_i(1, 2) + &
2355 tij_abc(2, 2, 2)*qp_i(2, 2) + &
2356 tij_abc(3, 2, 2)*qp_i(3, 2) + &
2357 tij_abc(1, 3, 2)*qp_i(1, 3) + &
2358 tij_abc(2, 3, 2)*qp_i(2, 3) + &
2359 tij_abc(3, 3, 2)*qp_i(3, 3)) + &
2360 dp_j(3)*(tij_abc(1, 1, 3)*qp_i(1, 1) + &
2361 tij_abc(2, 1, 3)*qp_i(2, 1) + &
2362 tij_abc(3, 1, 3)*qp_i(3, 1) + &
2363 tij_abc(1, 2, 3)*qp_i(1, 2) + &
2364 tij_abc(2, 2, 3)*qp_i(2, 2) + &
2365 tij_abc(3, 2, 3)*qp_i(3, 2) + &
2366 tij_abc(1, 3, 3)*qp_i(1, 3) + &
2367 tij_abc(2, 3, 3)*qp_i(2, 3) + &
2368 tij_abc(3, 3, 3)*qp_i(3, 3))
2369
2370 tmp = fac*(tmp_ij - tmp_ji)
2371 eloc = eloc + tmp
2372 IF (do_forces .OR. do_stress) THEN
2373 DO k = 1, 3
2374 ! Dipole i (locally B) - Quadrupole j (locally A)
2375 tmp_ij = dp_i(1)*(tij_abcd(1, 1, 1, k)*qp_j(1, 1) + &
2376 tij_abcd(2, 1, 1, k)*qp_j(2, 1) + &
2377 tij_abcd(3, 1, 1, k)*qp_j(3, 1) + &
2378 tij_abcd(1, 2, 1, k)*qp_j(1, 2) + &
2379 tij_abcd(2, 2, 1, k)*qp_j(2, 2) + &
2380 tij_abcd(3, 2, 1, k)*qp_j(3, 2) + &
2381 tij_abcd(1, 3, 1, k)*qp_j(1, 3) + &
2382 tij_abcd(2, 3, 1, k)*qp_j(2, 3) + &
2383 tij_abcd(3, 3, 1, k)*qp_j(3, 3)) + &
2384 dp_i(2)*(tij_abcd(1, 1, 2, k)*qp_j(1, 1) + &
2385 tij_abcd(2, 1, 2, k)*qp_j(2, 1) + &
2386 tij_abcd(3, 1, 2, k)*qp_j(3, 1) + &
2387 tij_abcd(1, 2, 2, k)*qp_j(1, 2) + &
2388 tij_abcd(2, 2, 2, k)*qp_j(2, 2) + &
2389 tij_abcd(3, 2, 2, k)*qp_j(3, 2) + &
2390 tij_abcd(1, 3, 2, k)*qp_j(1, 3) + &
2391 tij_abcd(2, 3, 2, k)*qp_j(2, 3) + &
2392 tij_abcd(3, 3, 2, k)*qp_j(3, 3)) + &
2393 dp_i(3)*(tij_abcd(1, 1, 3, k)*qp_j(1, 1) + &
2394 tij_abcd(2, 1, 3, k)*qp_j(2, 1) + &
2395 tij_abcd(3, 1, 3, k)*qp_j(3, 1) + &
2396 tij_abcd(1, 2, 3, k)*qp_j(1, 2) + &
2397 tij_abcd(2, 2, 3, k)*qp_j(2, 2) + &
2398 tij_abcd(3, 2, 3, k)*qp_j(3, 2) + &
2399 tij_abcd(1, 3, 3, k)*qp_j(1, 3) + &
2400 tij_abcd(2, 3, 3, k)*qp_j(2, 3) + &
2401 tij_abcd(3, 3, 3, k)*qp_j(3, 3))
2402
2403 ! Dipole j (locally A) - Quadrupole i (locally B)
2404 tmp_ji = dp_j(1)*(tij_abcd(1, 1, 1, k)*qp_i(1, 1) + &
2405 tij_abcd(2, 1, 1, k)*qp_i(2, 1) + &
2406 tij_abcd(3, 1, 1, k)*qp_i(3, 1) + &
2407 tij_abcd(1, 2, 1, k)*qp_i(1, 2) + &
2408 tij_abcd(2, 2, 1, k)*qp_i(2, 2) + &
2409 tij_abcd(3, 2, 1, k)*qp_i(3, 2) + &
2410 tij_abcd(1, 3, 1, k)*qp_i(1, 3) + &
2411 tij_abcd(2, 3, 1, k)*qp_i(2, 3) + &
2412 tij_abcd(3, 3, 1, k)*qp_i(3, 3)) + &
2413 dp_j(2)*(tij_abcd(1, 1, 2, k)*qp_i(1, 1) + &
2414 tij_abcd(2, 1, 2, k)*qp_i(2, 1) + &
2415 tij_abcd(3, 1, 2, k)*qp_i(3, 1) + &
2416 tij_abcd(1, 2, 2, k)*qp_i(1, 2) + &
2417 tij_abcd(2, 2, 2, k)*qp_i(2, 2) + &
2418 tij_abcd(3, 2, 2, k)*qp_i(3, 2) + &
2419 tij_abcd(1, 3, 2, k)*qp_i(1, 3) + &
2420 tij_abcd(2, 3, 2, k)*qp_i(2, 3) + &
2421 tij_abcd(3, 3, 2, k)*qp_i(3, 3)) + &
2422 dp_j(3)*(tij_abcd(1, 1, 3, k)*qp_i(1, 1) + &
2423 tij_abcd(2, 1, 3, k)*qp_i(2, 1) + &
2424 tij_abcd(3, 1, 3, k)*qp_i(3, 1) + &
2425 tij_abcd(1, 2, 3, k)*qp_i(1, 2) + &
2426 tij_abcd(2, 2, 3, k)*qp_i(2, 2) + &
2427 tij_abcd(3, 2, 3, k)*qp_i(3, 2) + &
2428 tij_abcd(1, 3, 3, k)*qp_i(1, 3) + &
2429 tij_abcd(2, 3, 3, k)*qp_i(2, 3) + &
2430 tij_abcd(3, 3, 3, k)*qp_i(3, 3))
2431
2432 fr(k) = fr(k) - fac*(tmp_ij - tmp_ji)
2433 END DO
2434 END IF
2435 END IF
2436 IF (task(3, 1)) THEN
2437 ! Quadrupole - Charge
2438 fac = 1.0_dp/3.0_dp
2439
2440 ! Quadrupole j (locally A) - Charge j (locally B)
2441 tmp_ij = ch_i*(tij_ab(1, 1)*qp_j(1, 1) + &
2442 tij_ab(2, 1)*qp_j(2, 1) + &
2443 tij_ab(3, 1)*qp_j(3, 1) + &
2444 tij_ab(1, 2)*qp_j(1, 2) + &
2445 tij_ab(2, 2)*qp_j(2, 2) + &
2446 tij_ab(3, 2)*qp_j(3, 2) + &
2447 tij_ab(1, 3)*qp_j(1, 3) + &
2448 tij_ab(2, 3)*qp_j(2, 3) + &
2449 tij_ab(3, 3)*qp_j(3, 3))
2450
2451 ! Quadrupole i (locally B) - Charge j (locally A)
2452 tmp_ji = ch_j*(tij_ab(1, 1)*qp_i(1, 1) + &
2453 tij_ab(2, 1)*qp_i(2, 1) + &
2454 tij_ab(3, 1)*qp_i(3, 1) + &
2455 tij_ab(1, 2)*qp_i(1, 2) + &
2456 tij_ab(2, 2)*qp_i(2, 2) + &
2457 tij_ab(3, 2)*qp_i(3, 2) + &
2458 tij_ab(1, 3)*qp_i(1, 3) + &
2459 tij_ab(2, 3)*qp_i(2, 3) + &
2460 tij_ab(3, 3)*qp_i(3, 3))
2461
2462 eloc = eloc + fac*(tmp_ij + tmp_ji)
2463 IF (do_forces .OR. do_stress) THEN
2464 DO k = 1, 3
2465 ! Quadrupole j (locally A) - Charge i (locally B)
2466 tmp_ij = ch_i*(tij_abc(1, 1, k)*qp_j(1, 1) + &
2467 tij_abc(2, 1, k)*qp_j(2, 1) + &
2468 tij_abc(3, 1, k)*qp_j(3, 1) + &
2469 tij_abc(1, 2, k)*qp_j(1, 2) + &
2470 tij_abc(2, 2, k)*qp_j(2, 2) + &
2471 tij_abc(3, 2, k)*qp_j(3, 2) + &
2472 tij_abc(1, 3, k)*qp_j(1, 3) + &
2473 tij_abc(2, 3, k)*qp_j(2, 3) + &
2474 tij_abc(3, 3, k)*qp_j(3, 3))
2475
2476 ! Quadrupole i (locally B) - Charge j (locally A)
2477 tmp_ji = ch_j*(tij_abc(1, 1, k)*qp_i(1, 1) + &
2478 tij_abc(2, 1, k)*qp_i(2, 1) + &
2479 tij_abc(3, 1, k)*qp_i(3, 1) + &
2480 tij_abc(1, 2, k)*qp_i(1, 2) + &
2481 tij_abc(2, 2, k)*qp_i(2, 2) + &
2482 tij_abc(3, 2, k)*qp_i(3, 2) + &
2483 tij_abc(1, 3, k)*qp_i(1, 3) + &
2484 tij_abc(2, 3, k)*qp_i(2, 3) + &
2485 tij_abc(3, 3, k)*qp_i(3, 3))
2486
2487 fr(k) = fr(k) - fac*(tmp_ij + tmp_ji)
2488 END DO
2489 END IF
2490 END IF
2491 energy = energy + eloc
2492 IF (do_forces) THEN
2493 forces(1, atom_a) = forces(1, atom_a) - fr(1)
2494 forces(2, atom_a) = forces(2, atom_a) - fr(2)
2495 forces(3, atom_a) = forces(3, atom_a) - fr(3)
2496 forces(1, atom_b) = forces(1, atom_b) + fr(1)
2497 forces(2, atom_b) = forces(2, atom_b) + fr(2)
2498 forces(3, atom_b) = forces(3, atom_b) + fr(3)
2499 END IF
2500 ! Electric fields
2501 IF (do_efield) THEN
2502 ! Potential
2503 IF (do_efield0) THEN
2504 efield0(atom_a) = efield0(atom_a) + ef0_j
2505
2506 efield0(atom_b) = efield0(atom_b) + ef0_i
2507 END IF
2508 ! Electric field
2509 IF (do_efield1) THEN
2510 efield1(1, atom_a) = efield1(1, atom_a) + ef1_j(1)
2511 efield1(2, atom_a) = efield1(2, atom_a) + ef1_j(2)
2512 efield1(3, atom_a) = efield1(3, atom_a) + ef1_j(3)
2513
2514 efield1(1, atom_b) = efield1(1, atom_b) + ef1_i(1)
2515 efield1(2, atom_b) = efield1(2, atom_b) + ef1_i(2)
2516 efield1(3, atom_b) = efield1(3, atom_b) + ef1_i(3)
2517 END IF
2518 ! Electric field gradient
2519 IF (do_efield2) THEN
2520 efield2(1, atom_a) = efield2(1, atom_a) + ef2_j(1, 1)
2521 efield2(2, atom_a) = efield2(2, atom_a) + ef2_j(1, 2)
2522 efield2(3, atom_a) = efield2(3, atom_a) + ef2_j(1, 3)
2523 efield2(4, atom_a) = efield2(4, atom_a) + ef2_j(2, 1)
2524 efield2(5, atom_a) = efield2(5, atom_a) + ef2_j(2, 2)
2525 efield2(6, atom_a) = efield2(6, atom_a) + ef2_j(2, 3)
2526 efield2(7, atom_a) = efield2(7, atom_a) + ef2_j(3, 1)
2527 efield2(8, atom_a) = efield2(8, atom_a) + ef2_j(3, 2)
2528 efield2(9, atom_a) = efield2(9, atom_a) + ef2_j(3, 3)
2529
2530 efield2(1, atom_b) = efield2(1, atom_b) + ef2_i(1, 1)
2531 efield2(2, atom_b) = efield2(2, atom_b) + ef2_i(1, 2)
2532 efield2(3, atom_b) = efield2(3, atom_b) + ef2_i(1, 3)
2533 efield2(4, atom_b) = efield2(4, atom_b) + ef2_i(2, 1)
2534 efield2(5, atom_b) = efield2(5, atom_b) + ef2_i(2, 2)
2535 efield2(6, atom_b) = efield2(6, atom_b) + ef2_i(2, 3)
2536 efield2(7, atom_b) = efield2(7, atom_b) + ef2_i(3, 1)
2537 efield2(8, atom_b) = efield2(8, atom_b) + ef2_i(3, 2)
2538 efield2(9, atom_b) = efield2(9, atom_b) + ef2_i(3, 3)
2539 END IF
2540 END IF
2541 IF (do_stress) THEN
2542 ptens11 = ptens11 + rab(1)*fr(1)
2543 ptens21 = ptens21 + rab(2)*fr(1)
2544 ptens31 = ptens31 + rab(3)*fr(1)
2545 ptens12 = ptens12 + rab(1)*fr(2)
2546 ptens22 = ptens22 + rab(2)*fr(2)
2547 ptens32 = ptens32 + rab(3)*fr(2)
2548 ptens13 = ptens13 + rab(1)*fr(3)
2549 ptens23 = ptens23 + rab(2)*fr(3)
2550 ptens33 = ptens33 + rab(3)*fr(3)
2551 END IF
2552
2553 END IF
2554 END IF
2555 END DO pairs
2556 END DO kind_group_loop
2557 END DO lists
2558 IF (do_stress) THEN
2559 pv(1, 1) = pv(1, 1) + ptens11
2560 pv(1, 2) = pv(1, 2) + (ptens12 + ptens21)*0.5_dp
2561 pv(1, 3) = pv(1, 3) + (ptens13 + ptens31)*0.5_dp
2562 pv(2, 1) = pv(1, 2)
2563 pv(2, 2) = pv(2, 2) + ptens22
2564 pv(2, 3) = pv(2, 3) + (ptens23 + ptens32)*0.5_dp
2565 pv(3, 1) = pv(1, 3)
2566 pv(3, 2) = pv(2, 3)
2567 pv(3, 3) = pv(3, 3) + ptens33
2568 END IF
2569
2570 CALL timestop(handle)
2571 END SUBROUTINE ewald_multipole_sr
2572
2573! **************************************************************************************************
2574!> \brief computes the bonded correction for the potential and the force for a
2575!> lattice sum of multipoles up to quadrupole
2576!> \param nonbond_env ...
2577!> \param particle_set ...
2578!> \param ewald_env ...
2579!> \param cell ...
2580!> \param energy ...
2581!> \param task ...
2582!> \param do_forces ...
2583!> \param do_efield ...
2584!> \param do_stress ...
2585!> \param charges ...
2586!> \param dipoles ...
2587!> \param quadrupoles ...
2588!> \param forces ...
2589!> \param pv ...
2590!> \param efield0 ...
2591!> \param efield1 ...
2592!> \param efield2 ...
2593!> \author Teodoro Laino [tlaino] - 05.2009
2594! **************************************************************************************************
2595 SUBROUTINE ewald_multipole_bonded(nonbond_env, particle_set, ewald_env, &
2596 cell, energy, task, do_forces, do_efield, do_stress, charges, &
2597 dipoles, quadrupoles, forces, pv, efield0, efield1, efield2)
2598
2599 TYPE(fist_nonbond_env_type), POINTER :: nonbond_env
2600 TYPE(particle_type), POINTER :: particle_set(:)
2601 TYPE(ewald_environment_type), POINTER :: ewald_env
2602 TYPE(cell_type), POINTER :: cell
2603 REAL(kind=dp), INTENT(INOUT) :: energy
2604 LOGICAL, DIMENSION(3, 3), INTENT(IN) :: task
2605 LOGICAL, INTENT(IN) :: do_forces, do_efield, do_stress
2606 REAL(kind=dp), DIMENSION(:), OPTIONAL, POINTER :: charges
2607 REAL(kind=dp), DIMENSION(:, :), OPTIONAL, POINTER :: dipoles
2608 REAL(kind=dp), DIMENSION(:, :, :), OPTIONAL, &
2609 POINTER :: quadrupoles
2610 REAL(kind=dp), DIMENSION(:, :), INTENT(INOUT), &
2611 OPTIONAL :: forces, pv
2612 REAL(kind=dp), DIMENSION(:), POINTER :: efield0
2613 REAL(kind=dp), DIMENSION(:, :), POINTER :: efield1, efield2
2614
2615 CHARACTER(len=*), PARAMETER :: routinen = 'ewald_multipole_bonded'
2616
2617 INTEGER :: a, atom_a, atom_b, b, c, d, e, handle, &
2618 i, iend, igrp, ilist, ipair, istart, &
2619 k, nscale
2620 INTEGER, DIMENSION(:, :), POINTER :: list
2621 LOGICAL :: do_efield0, do_efield1, do_efield2, &
2622 force_eval
2623 REAL(kind=dp) :: alpha, ch_i, ch_j, ef0_i, ef0_j, eloc, fac, fac_ij, ir, irab2, ptens11, &
2624 ptens12, ptens13, ptens21, ptens22, ptens23, ptens31, ptens32, ptens33, r, rab2, tij, &
2625 tmp, tmp1, tmp11, tmp12, tmp13, tmp2, tmp21, tmp22, tmp23, tmp31, tmp32, tmp33, tmp_ij, &
2626 tmp_ji
2627 REAL(kind=dp), DIMENSION(0:5) :: f
2628 REAL(kind=dp), DIMENSION(3) :: dp_i, dp_j, ef1_i, ef1_j, fr, rab, tij_a
2629 REAL(kind=dp), DIMENSION(3, 3) :: ef2_i, ef2_j, qp_i, qp_j, tij_ab
2630 REAL(kind=dp), DIMENSION(3, 3, 3) :: tij_abc
2631 REAL(kind=dp), DIMENSION(3, 3, 3, 3) :: tij_abcd
2632 REAL(kind=dp), DIMENSION(3, 3, 3, 3, 3) :: tij_abcde
2633 TYPE(fist_neighbor_type), POINTER :: nonbonded
2634 TYPE(neighbor_kind_pairs_type), POINTER :: neighbor_kind_pair
2635
2636 CALL timeset(routinen, handle)
2637 do_efield0 = do_efield .AND. ASSOCIATED(efield0)
2638 do_efield1 = do_efield .AND. ASSOCIATED(efield1)
2639 do_efield2 = do_efield .AND. ASSOCIATED(efield2)
2640 IF (do_stress) THEN
2641 ptens11 = 0.0_dp; ptens12 = 0.0_dp; ptens13 = 0.0_dp
2642 ptens21 = 0.0_dp; ptens22 = 0.0_dp; ptens23 = 0.0_dp
2643 ptens31 = 0.0_dp; ptens32 = 0.0_dp; ptens33 = 0.0_dp
2644 END IF
2645 CALL ewald_env_get(ewald_env, alpha=alpha)
2646 CALL fist_nonbond_env_get(nonbond_env, nonbonded=nonbonded)
2647
2648 ! Starting the force loop
2649 lists: DO ilist = 1, nonbonded%nlists
2650 neighbor_kind_pair => nonbonded%neighbor_kind_pairs(ilist)
2651 nscale = neighbor_kind_pair%nscale
2652 IF (nscale == 0) cycle
2653 list => neighbor_kind_pair%list
2654 kind_group_loop: DO igrp = 1, neighbor_kind_pair%ngrp_kind
2655 istart = neighbor_kind_pair%grp_kind_start(igrp)
2656 IF (istart > nscale) cycle
2657 iend = min(neighbor_kind_pair%grp_kind_end(igrp), nscale)
2658 pairs: DO ipair = istart, iend
2659 ! only use pairs that are (partially) excluded for electrostatics
2660 fac_ij = -1.0_dp + neighbor_kind_pair%ei_scale(ipair)
2661 IF (fac_ij >= 0) cycle
2662
2663 atom_a = list(1, ipair)
2664 atom_b = list(2, ipair)
2665
2666 rab = particle_set(atom_b)%r - particle_set(atom_a)%r
2667 rab = pbc(rab, cell)
2668 rab2 = rab(1)**2 + rab(2)**2 + rab(3)**2
2669 ! Compute the Short Range constribution according the task
2670 IF (debug_this_module) THEN
2671 f = huge(0.0_dp)
2672 tij = huge(0.0_dp)
2673 tij_a = huge(0.0_dp)
2674 tij_ab = huge(0.0_dp)
2675 tij_abc = huge(0.0_dp)
2676 tij_abcd = huge(0.0_dp)
2677 tij_abcde = huge(0.0_dp)
2678 END IF
2679 r = sqrt(rab2)
2680 irab2 = 1.0_dp/rab2
2681 ir = 1.0_dp/r
2682
2683 ! Compute the radial function
2684 IF (debug_this_module .AND. debug_r_space .AND. (.NOT. debug_g_space)) THEN
2685 f(0) = ir
2686 tmp = 0.0_dp
2687 ELSE
2688 f(0) = erf(alpha*r)*ir
2689 tmp = exp(-alpha**2*rab2)*oorootpi
2690 END IF
2691 fac = 1.0_dp
2692 DO i = 1, 5
2693 fac = fac*real(2*i - 1, kind=dp)
2694 f(i) = irab2*(f(i - 1) - tmp*((2.0_dp*alpha**2)**i)/(fac*alpha))
2695 END DO
2696
2697
2698 ! Compute the Tensor components
2699 force_eval = do_stress
2700 IF (task(1, 1)) THEN
2701 tij = f(0)*fac_ij
2702 force_eval = do_forces .OR. do_efield1
2703 END IF
2704 IF (task(2, 2)) force_eval = force_eval .OR. do_efield0
2705 IF (task(1, 2) .OR. force_eval) THEN
2706 force_eval = do_stress
2707 tij_a = -rab*f(1)*fac_ij
2708 IF (task(1, 2)) force_eval = force_eval .OR. do_forces
2709 END IF
2710 IF (task(1, 1)) force_eval = force_eval .OR. do_efield2
2711 IF (task(3, 3)) force_eval = force_eval .OR. do_efield0
2712 IF (task(2, 2) .OR. task(3, 1) .OR. force_eval) THEN
2713 force_eval = do_stress
2714 DO b = 1, 3
2715 DO a = 1, 3
2716 tmp = rab(a)*rab(b)*fac_ij
2717 tij_ab(a, b) = 3.0_dp*tmp*f(2)
2718 IF (a == b) tij_ab(a, b) = tij_ab(a, b) - f(1)*fac_ij
2719 END DO
2720 END DO
2721 IF (task(2, 2) .OR. task(3, 1)) force_eval = force_eval .OR. do_forces
2722 END IF
2723 IF (task(2, 2)) force_eval = force_eval .OR. do_efield2
2724 IF (task(3, 3)) force_eval = force_eval .OR. do_efield1
2725 IF (task(3, 2) .OR. force_eval) THEN
2726 force_eval = do_stress
2727 DO c = 1, 3
2728 DO b = 1, 3
2729 DO a = 1, 3
2730 tmp = rab(a)*rab(b)*rab(c)*fac_ij
2731 tij_abc(a, b, c) = -15.0_dp*tmp*f(3)
2732 tmp = 3.0_dp*f(2)*fac_ij
2733 IF (a == b) tij_abc(a, b, c) = tij_abc(a, b, c) + tmp*rab(c)
2734 IF (a == c) tij_abc(a, b, c) = tij_abc(a, b, c) + tmp*rab(b)
2735 IF (b == c) tij_abc(a, b, c) = tij_abc(a, b, c) + tmp*rab(a)
2736 END DO
2737 END DO
2738 END DO
2739 IF (task(3, 2)) force_eval = force_eval .OR. do_forces
2740 END IF
2741 IF (task(3, 3) .OR. force_eval) THEN
2742 force_eval = do_stress
2743 DO d = 1, 3
2744 DO c = 1, 3
2745 DO b = 1, 3
2746 DO a = 1, 3
2747 tmp = rab(a)*rab(b)*rab(c)*rab(d)*fac_ij
2748 tij_abcd(a, b, c, d) = 105.0_dp*tmp*f(4)
2749 tmp1 = 15.0_dp*f(3)*fac_ij
2750 tmp2 = 3.0_dp*f(2)*fac_ij
2751 IF (a == b) THEN
2752 tij_abcd(a, b, c, d) = tij_abcd(a, b, c, d) - tmp1*rab(c)*rab(d)
2753 IF (c == d) tij_abcd(a, b, c, d) = tij_abcd(a, b, c, d) + tmp2
2754 END IF
2755 IF (a == c) THEN
2756 tij_abcd(a, b, c, d) = tij_abcd(a, b, c, d) - tmp1*rab(b)*rab(d)
2757 IF (b == d) tij_abcd(a, b, c, d) = tij_abcd(a, b, c, d) + tmp2
2758 END IF
2759 IF (a == d) tij_abcd(a, b, c, d) = tij_abcd(a, b, c, d) - tmp1*rab(b)*rab(c)
2760 IF (b == c) THEN
2761 tij_abcd(a, b, c, d) = tij_abcd(a, b, c, d) - tmp1*rab(a)*rab(d)
2762 IF (a == d) tij_abcd(a, b, c, d) = tij_abcd(a, b, c, d) + tmp2
2763 END IF
2764 IF (b == d) tij_abcd(a, b, c, d) = tij_abcd(a, b, c, d) - tmp1*rab(a)*rab(c)
2765 IF (c == d) tij_abcd(a, b, c, d) = tij_abcd(a, b, c, d) - tmp1*rab(a)*rab(b)
2766 END DO
2767 END DO
2768 END DO
2769 END DO
2770 IF (task(3, 3)) force_eval = force_eval .OR. do_forces
2771 END IF
2772 IF (force_eval) THEN
2773 force_eval = do_stress
2774 DO e = 1, 3
2775 DO d = 1, 3
2776 DO c = 1, 3
2777 DO b = 1, 3
2778 DO a = 1, 3
2779 tmp = rab(a)*rab(b)*rab(c)*rab(d)*rab(e)*fac_ij
2780 tij_abcde(a, b, c, d, e) = -945.0_dp*tmp*f(5)
2781 tmp1 = 105.0_dp*f(4)*fac_ij
2782 tmp2 = 15.0_dp*f(3)*fac_ij
2783 IF (a == b) THEN
2784 tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) + tmp1*rab(c)*rab(d)*rab(e)
2785 IF (c == d) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) - tmp2*rab(e)
2786 IF (c == e) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) - tmp2*rab(d)
2787 IF (d == e) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) - tmp2*rab(c)
2788 END IF
2789 IF (a == c) THEN
2790 tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) + tmp1*rab(b)*rab(d)*rab(e)
2791 IF (b == d) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) - tmp2*rab(e)
2792 IF (b == e) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) - tmp2*rab(d)
2793 IF (d == e) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) - tmp2*rab(b)
2794 END IF
2795 IF (a == d) THEN
2796 tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) + tmp1*rab(b)*rab(c)*rab(e)
2797 IF (b == c) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) - tmp2*rab(e)
2798 IF (b == e) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) - tmp2*rab(c)
2799 IF (c == e) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) - tmp2*rab(b)
2800 END IF
2801 IF (a == e) THEN
2802 tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) + tmp1*rab(b)*rab(c)*rab(d)
2803 IF (b == c) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) - tmp2*rab(d)
2804 IF (b == d) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) - tmp2*rab(c)
2805 IF (c == d) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) - tmp2*rab(b)
2806 END IF
2807 IF (b == c) THEN
2808 tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) + tmp1*rab(a)*rab(d)*rab(e)
2809 IF (d == e) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) - tmp2*rab(a)
2810 END IF
2811 IF (b == d) THEN
2812 tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) + tmp1*rab(a)*rab(c)*rab(e)
2813 IF (c == e) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) - tmp2*rab(a)
2814 END IF
2815 IF (b == e) THEN
2816 tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) + tmp1*rab(a)*rab(c)*rab(d)
2817 IF (c == d) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) - tmp2*rab(a)
2818 END IF
2819 IF (c == d) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) + tmp1*rab(a)*rab(b)*rab(e)
2820 IF (c == e) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) + tmp1*rab(a)*rab(b)*rab(d)
2821 IF (d == e) tij_abcde(a, b, c, d, e) = tij_abcde(a, b, c, d, e) + tmp1*rab(a)*rab(b)*rab(c)
2822 END DO
2823 END DO
2824 END DO
2825 END DO
2826 END DO
2827 END IF
2828 eloc = 0.0_dp
2829 fr = 0.0_dp
2830 ef0_i = 0.0_dp
2831 ef0_j = 0.0_dp
2832 ef1_j = 0.0_dp
2833 ef1_i = 0.0_dp
2834 ef2_j = 0.0_dp
2835 ef2_i = 0.0_dp
2836
2837
2838 ! Initialize the charge, dipole and quadrupole for atom A and B
2839 IF (debug_this_module) THEN
2840 ch_j = huge(0.0_dp)
2841 ch_i = huge(0.0_dp)
2842 dp_j = huge(0.0_dp)
2843 dp_i = huge(0.0_dp)
2844 qp_j = huge(0.0_dp)
2845 qp_i = huge(0.0_dp)
2846 END IF
2847 IF (any(task(1, :))) THEN
2848 ch_j = charges(atom_a)
2849 ch_i = charges(atom_b)
2850 END IF
2851 IF (any(task(2, :))) THEN
2852 dp_j = dipoles(:, atom_a)
2853 dp_i = dipoles(:, atom_b)
2854 END IF
2855 IF (any(task(3, :))) THEN
2856 qp_j = quadrupoles(:, :, atom_a)
2857 qp_i = quadrupoles(:, :, atom_b)
2858 END IF
2859 IF (task(1, 1)) THEN
2860 ! Charge - Charge
2861 eloc = eloc + ch_i*tij*ch_j
2862 ! Forces on particle i (locally b)
2863 IF (do_forces .OR. do_stress) THEN
2864 fr(1) = fr(1) - ch_j*tij_a(1)*ch_i
2865 fr(2) = fr(2) - ch_j*tij_a(2)*ch_i
2866 fr(3) = fr(3) - ch_j*tij_a(3)*ch_i
2867 END IF
2868 ! Electric fields
2869 IF (do_efield) THEN
2870 ! Potential
2871 IF (do_efield0) THEN
2872 ef0_i = ef0_i + tij*ch_j
2873
2874 ef0_j = ef0_j + tij*ch_i
2875 END IF
2876 ! Electric field
2877 IF (do_efield1) THEN
2878 ef1_i(1) = ef1_i(1) - tij_a(1)*ch_j
2879 ef1_i(2) = ef1_i(2) - tij_a(2)*ch_j
2880 ef1_i(3) = ef1_i(3) - tij_a(3)*ch_j
2881
2882 ef1_j(1) = ef1_j(1) + tij_a(1)*ch_i
2883 ef1_j(2) = ef1_j(2) + tij_a(2)*ch_i
2884 ef1_j(3) = ef1_j(3) + tij_a(3)*ch_i
2885
2886
2887 END IF
2888 ! Electric field gradient
2889 IF (do_efield2) THEN
2890 ef2_i(1, 1) = ef2_i(1, 1) - tij_ab(1, 1)*ch_j
2891 ef2_i(2, 1) = ef2_i(2, 1) - tij_ab(2, 1)*ch_j
2892 ef2_i(3, 1) = ef2_i(3, 1) - tij_ab(3, 1)*ch_j
2893 ef2_i(1, 2) = ef2_i(1, 2) - tij_ab(1, 2)*ch_j
2894 ef2_i(2, 2) = ef2_i(2, 2) - tij_ab(2, 2)*ch_j
2895 ef2_i(3, 2) = ef2_i(3, 2) - tij_ab(3, 2)*ch_j
2896 ef2_i(1, 3) = ef2_i(1, 3) - tij_ab(1, 3)*ch_j
2897 ef2_i(2, 3) = ef2_i(2, 3) - tij_ab(2, 3)*ch_j
2898 ef2_i(3, 3) = ef2_i(3, 3) - tij_ab(3, 3)*ch_j
2899
2900 ef2_j(1, 1) = ef2_j(1, 1) - tij_ab(1, 1)*ch_i
2901 ef2_j(2, 1) = ef2_j(2, 1) - tij_ab(2, 1)*ch_i
2902 ef2_j(3, 1) = ef2_j(3, 1) - tij_ab(3, 1)*ch_i
2903 ef2_j(1, 2) = ef2_j(1, 2) - tij_ab(1, 2)*ch_i
2904 ef2_j(2, 2) = ef2_j(2, 2) - tij_ab(2, 2)*ch_i
2905 ef2_j(3, 2) = ef2_j(3, 2) - tij_ab(3, 2)*ch_i
2906 ef2_j(1, 3) = ef2_j(1, 3) - tij_ab(1, 3)*ch_i
2907 ef2_j(2, 3) = ef2_j(2, 3) - tij_ab(2, 3)*ch_i
2908 ef2_j(3, 3) = ef2_j(3, 3) - tij_ab(3, 3)*ch_i
2909 END IF
2910 END IF
2911 END IF
2912 IF (task(2, 2)) THEN
2913 ! Dipole - Dipole
2914 tmp = -(dp_i(1)*(tij_ab(1, 1)*dp_j(1) + &
2915 tij_ab(2, 1)*dp_j(2) + &
2916 tij_ab(3, 1)*dp_j(3)) + &
2917 dp_i(2)*(tij_ab(1, 2)*dp_j(1) + &
2918 tij_ab(2, 2)*dp_j(2) + &
2919 tij_ab(3, 2)*dp_j(3)) + &
2920 dp_i(3)*(tij_ab(1, 3)*dp_j(1) + &
2921 tij_ab(2, 3)*dp_j(2) + &
2922 tij_ab(3, 3)*dp_j(3)))
2923 eloc = eloc + tmp
2924 ! Forces on particle i (locally b)
2925 IF (do_forces .OR. do_stress) THEN
2926 DO k = 1, 3
2927 fr(k) = fr(k) + dp_i(1)*(tij_abc(1, 1, k)*dp_j(1) + &
2928 tij_abc(2, 1, k)*dp_j(2) + &
2929 tij_abc(3, 1, k)*dp_j(3)) &
2930 + dp_i(2)*(tij_abc(1, 2, k)*dp_j(1) + &
2931 tij_abc(2, 2, k)*dp_j(2) + &
2932 tij_abc(3, 2, k)*dp_j(3)) &
2933 + dp_i(3)*(tij_abc(1, 3, k)*dp_j(1) + &
2934 tij_abc(2, 3, k)*dp_j(2) + &
2935 tij_abc(3, 3, k)*dp_j(3))
2936 END DO
2937 END IF
2938 ! Electric fields
2939 IF (do_efield) THEN
2940 ! Potential
2941 IF (do_efield0) THEN
2942 ef0_i = ef0_i - (tij_a(1)*dp_j(1) + &
2943 tij_a(2)*dp_j(2) + &
2944 tij_a(3)*dp_j(3))
2945
2946 ef0_j = ef0_j + (tij_a(1)*dp_i(1) + &
2947 tij_a(2)*dp_i(2) + &
2948 tij_a(3)*dp_i(3))
2949 END IF
2950 ! Electric field
2951 IF (do_efield1) THEN
2952 ef1_i(1) = ef1_i(1) + (tij_ab(1, 1)*dp_j(1) + &
2953 tij_ab(2, 1)*dp_j(2) + &
2954 tij_ab(3, 1)*dp_j(3))
2955 ef1_i(2) = ef1_i(2) + (tij_ab(1, 2)*dp_j(1) + &
2956 tij_ab(2, 2)*dp_j(2) + &
2957 tij_ab(3, 2)*dp_j(3))
2958 ef1_i(3) = ef1_i(3) + (tij_ab(1, 3)*dp_j(1) + &
2959 tij_ab(2, 3)*dp_j(2) + &
2960 tij_ab(3, 3)*dp_j(3))
2961
2962 ef1_j(1) = ef1_j(1) + (tij_ab(1, 1)*dp_i(1) + &
2963 tij_ab(2, 1)*dp_i(2) + &
2964 tij_ab(3, 1)*dp_i(3))
2965 ef1_j(2) = ef1_j(2) + (tij_ab(1, 2)*dp_i(1) + &
2966 tij_ab(2, 2)*dp_i(2) + &
2967 tij_ab(3, 2)*dp_i(3))
2968 ef1_j(3) = ef1_j(3) + (tij_ab(1, 3)*dp_i(1) + &
2969 tij_ab(2, 3)*dp_i(2) + &
2970 tij_ab(3, 3)*dp_i(3))
2971 END IF
2972 ! Electric field gradient
2973 IF (do_efield2) THEN
2974 ef2_i(1, 1) = ef2_i(1, 1) + (tij_abc(1, 1, 1)*dp_j(1) + &
2975 tij_abc(2, 1, 1)*dp_j(2) + &
2976 tij_abc(3, 1, 1)*dp_j(3))
2977 ef2_i(1, 2) = ef2_i(1, 2) + (tij_abc(1, 1, 2)*dp_j(1) + &
2978 tij_abc(2, 1, 2)*dp_j(2) + &
2979 tij_abc(3, 1, 2)*dp_j(3))
2980 ef2_i(1, 3) = ef2_i(1, 3) + (tij_abc(1, 1, 3)*dp_j(1) + &
2981 tij_abc(2, 1, 3)*dp_j(2) + &
2982 tij_abc(3, 1, 3)*dp_j(3))
2983 ef2_i(2, 1) = ef2_i(2, 1) + (tij_abc(1, 2, 1)*dp_j(1) + &
2984 tij_abc(2, 2, 1)*dp_j(2) + &
2985 tij_abc(3, 2, 1)*dp_j(3))
2986 ef2_i(2, 2) = ef2_i(2, 2) + (tij_abc(1, 2, 2)*dp_j(1) + &
2987 tij_abc(2, 2, 2)*dp_j(2) + &
2988 tij_abc(3, 2, 2)*dp_j(3))
2989 ef2_i(2, 3) = ef2_i(2, 3) + (tij_abc(1, 2, 3)*dp_j(1) + &
2990 tij_abc(2, 2, 3)*dp_j(2) + &
2991 tij_abc(3, 2, 3)*dp_j(3))
2992 ef2_i(3, 1) = ef2_i(3, 1) + (tij_abc(1, 3, 1)*dp_j(1) + &
2993 tij_abc(2, 3, 1)*dp_j(2) + &
2994 tij_abc(3, 3, 1)*dp_j(3))
2995 ef2_i(3, 2) = ef2_i(3, 2) + (tij_abc(1, 3, 2)*dp_j(1) + &
2996 tij_abc(2, 3, 2)*dp_j(2) + &
2997 tij_abc(3, 3, 2)*dp_j(3))
2998 ef2_i(3, 3) = ef2_i(3, 3) + (tij_abc(1, 3, 3)*dp_j(1) + &
2999 tij_abc(2, 3, 3)*dp_j(2) + &
3000 tij_abc(3, 3, 3)*dp_j(3))
3001
3002 ef2_j(1, 1) = ef2_j(1, 1) - (tij_abc(1, 1, 1)*dp_i(1) + &
3003 tij_abc(2, 1, 1)*dp_i(2) + &
3004 tij_abc(3, 1, 1)*dp_i(3))
3005 ef2_j(1, 2) = ef2_j(1, 2) - (tij_abc(1, 1, 2)*dp_i(1) + &
3006 tij_abc(2, 1, 2)*dp_i(2) + &
3007 tij_abc(3, 1, 2)*dp_i(3))
3008 ef2_j(1, 3) = ef2_j(1, 3) - (tij_abc(1, 1, 3)*dp_i(1) + &
3009 tij_abc(2, 1, 3)*dp_i(2) + &
3010 tij_abc(3, 1, 3)*dp_i(3))
3011 ef2_j(2, 1) = ef2_j(2, 1) - (tij_abc(1, 2, 1)*dp_i(1) + &
3012 tij_abc(2, 2, 1)*dp_i(2) + &
3013 tij_abc(3, 2, 1)*dp_i(3))
3014 ef2_j(2, 2) = ef2_j(2, 2) - (tij_abc(1, 2, 2)*dp_i(1) + &
3015 tij_abc(2, 2, 2)*dp_i(2) + &
3016 tij_abc(3, 2, 2)*dp_i(3))
3017 ef2_j(2, 3) = ef2_j(2, 3) - (tij_abc(1, 2, 3)*dp_i(1) + &
3018 tij_abc(2, 2, 3)*dp_i(2) + &
3019 tij_abc(3, 2, 3)*dp_i(3))
3020 ef2_j(3, 1) = ef2_j(3, 1) - (tij_abc(1, 3, 1)*dp_i(1) + &
3021 tij_abc(2, 3, 1)*dp_i(2) + &
3022 tij_abc(3, 3, 1)*dp_i(3))
3023 ef2_j(3, 2) = ef2_j(3, 2) - (tij_abc(1, 3, 2)*dp_i(1) + &
3024 tij_abc(2, 3, 2)*dp_i(2) + &
3025 tij_abc(3, 3, 2)*dp_i(3))
3026 ef2_j(3, 3) = ef2_j(3, 3) - (tij_abc(1, 3, 3)*dp_i(1) + &
3027 tij_abc(2, 3, 3)*dp_i(2) + &
3028 tij_abc(3, 3, 3)*dp_i(3))
3029 END IF
3030 END IF
3031 END IF
3032 IF (task(2, 1)) THEN
3033 ! Dipole - Charge
3034 tmp = ch_j*(tij_a(1)*dp_i(1) + &
3035 tij_a(2)*dp_i(2) + &
3036 tij_a(3)*dp_i(3)) &
3037 - ch_i*(tij_a(1)*dp_j(1) + &
3038 tij_a(2)*dp_j(2) + &
3039 tij_a(3)*dp_j(3))
3040 eloc = eloc + tmp
3041 ! Forces on particle i (locally b)
3042 IF (do_forces .OR. do_stress) THEN
3043 DO k = 1, 3
3044 fr(k) = fr(k) - ch_j*(tij_ab(1, k)*dp_i(1) + &
3045 tij_ab(2, k)*dp_i(2) + &
3046 tij_ab(3, k)*dp_i(3)) &
3047 + ch_i*(tij_ab(1, k)*dp_j(1) + &
3048 tij_ab(2, k)*dp_j(2) + &
3049 tij_ab(3, k)*dp_j(3))
3050 END DO
3051 END IF
3052 END IF
3053 IF (task(3, 3)) THEN
3054 ! Quadrupole - Quadrupole
3055 fac = 1.0_dp/9.0_dp
3056 tmp11 = qp_i(1, 1)*(tij_abcd(1, 1, 1, 1)*qp_j(1, 1) + &
3057 tij_abcd(2, 1, 1, 1)*qp_j(2, 1) + &
3058 tij_abcd(3, 1, 1, 1)*qp_j(3, 1) + &
3059 tij_abcd(1, 2, 1, 1)*qp_j(1, 2) + &
3060 tij_abcd(2, 2, 1, 1)*qp_j(2, 2) + &
3061 tij_abcd(3, 2, 1, 1)*qp_j(3, 2) + &
3062 tij_abcd(1, 3, 1, 1)*qp_j(1, 3) + &
3063 tij_abcd(2, 3, 1, 1)*qp_j(2, 3) + &
3064 tij_abcd(3, 3, 1, 1)*qp_j(3, 3))
3065 tmp21 = qp_i(2, 1)*(tij_abcd(1, 1, 1, 2)*qp_j(1, 1) + &
3066 tij_abcd(2, 1, 1, 2)*qp_j(2, 1) + &
3067 tij_abcd(3, 1, 1, 2)*qp_j(3, 1) + &
3068 tij_abcd(1, 2, 1, 2)*qp_j(1, 2) + &
3069 tij_abcd(2, 2, 1, 2)*qp_j(2, 2) + &
3070 tij_abcd(3, 2, 1, 2)*qp_j(3, 2) + &
3071 tij_abcd(1, 3, 1, 2)*qp_j(1, 3) + &
3072 tij_abcd(2, 3, 1, 2)*qp_j(2, 3) + &
3073 tij_abcd(3, 3, 1, 2)*qp_j(3, 3))
3074 tmp31 = qp_i(3, 1)*(tij_abcd(1, 1, 1, 3)*qp_j(1, 1) + &
3075 tij_abcd(2, 1, 1, 3)*qp_j(2, 1) + &
3076 tij_abcd(3, 1, 1, 3)*qp_j(3, 1) + &
3077 tij_abcd(1, 2, 1, 3)*qp_j(1, 2) + &
3078 tij_abcd(2, 2, 1, 3)*qp_j(2, 2) + &
3079 tij_abcd(3, 2, 1, 3)*qp_j(3, 2) + &
3080 tij_abcd(1, 3, 1, 3)*qp_j(1, 3) + &
3081 tij_abcd(2, 3, 1, 3)*qp_j(2, 3) + &
3082 tij_abcd(3, 3, 1, 3)*qp_j(3, 3))
3083 tmp22 = qp_i(2, 2)*(tij_abcd(1, 1, 2, 2)*qp_j(1, 1) + &
3084 tij_abcd(2, 1, 2, 2)*qp_j(2, 1) + &
3085 tij_abcd(3, 1, 2, 2)*qp_j(3, 1) + &
3086 tij_abcd(1, 2, 2, 2)*qp_j(1, 2) + &
3087 tij_abcd(2, 2, 2, 2)*qp_j(2, 2) + &
3088 tij_abcd(3, 2, 2, 2)*qp_j(3, 2) + &
3089 tij_abcd(1, 3, 2, 2)*qp_j(1, 3) + &
3090 tij_abcd(2, 3, 2, 2)*qp_j(2, 3) + &
3091 tij_abcd(3, 3, 2, 2)*qp_j(3, 3))
3092 tmp32 = qp_i(3, 2)*(tij_abcd(1, 1, 2, 3)*qp_j(1, 1) + &
3093 tij_abcd(2, 1, 2, 3)*qp_j(2, 1) + &
3094 tij_abcd(3, 1, 2, 3)*qp_j(3, 1) + &
3095 tij_abcd(1, 2, 2, 3)*qp_j(1, 2) + &
3096 tij_abcd(2, 2, 2, 3)*qp_j(2, 2) + &
3097 tij_abcd(3, 2, 2, 3)*qp_j(3, 2) + &
3098 tij_abcd(1, 3, 2, 3)*qp_j(1, 3) + &
3099 tij_abcd(2, 3, 2, 3)*qp_j(2, 3) + &
3100 tij_abcd(3, 3, 2, 3)*qp_j(3, 3))
3101 tmp33 = qp_i(3, 3)*(tij_abcd(1, 1, 3, 3)*qp_j(1, 1) + &
3102 tij_abcd(2, 1, 3, 3)*qp_j(2, 1) + &
3103 tij_abcd(3, 1, 3, 3)*qp_j(3, 1) + &
3104 tij_abcd(1, 2, 3, 3)*qp_j(1, 2) + &
3105 tij_abcd(2, 2, 3, 3)*qp_j(2, 2) + &
3106 tij_abcd(3, 2, 3, 3)*qp_j(3, 2) + &
3107 tij_abcd(1, 3, 3, 3)*qp_j(1, 3) + &
3108 tij_abcd(2, 3, 3, 3)*qp_j(2, 3) + &
3109 tij_abcd(3, 3, 3, 3)*qp_j(3, 3))
3110 tmp12 = tmp21
3111 tmp13 = tmp31
3112 tmp23 = tmp32
3113 tmp = tmp11 + tmp12 + tmp13 + &
3114 tmp21 + tmp22 + tmp23 + &
3115 tmp31 + tmp32 + tmp33
3116
3117 eloc = eloc + fac*tmp
3118 ! Forces on particle i (locally b)
3119 IF (do_forces .OR. do_stress) THEN
3120 DO k = 1, 3
3121 tmp11 = qp_i(1, 1)*(tij_abcde(1, 1, 1, 1, k)*qp_j(1, 1) + &
3122 tij_abcde(2, 1, 1, 1, k)*qp_j(2, 1) + &
3123 tij_abcde(3, 1, 1, 1, k)*qp_j(3, 1) + &
3124 tij_abcde(1, 2, 1, 1, k)*qp_j(1, 2) + &
3125 tij_abcde(2, 2, 1, 1, k)*qp_j(2, 2) + &
3126 tij_abcde(3, 2, 1, 1, k)*qp_j(3, 2) + &
3127 tij_abcde(1, 3, 1, 1, k)*qp_j(1, 3) + &
3128 tij_abcde(2, 3, 1, 1, k)*qp_j(2, 3) + &
3129 tij_abcde(3, 3, 1, 1, k)*qp_j(3, 3))
3130 tmp21 = qp_i(2, 1)*(tij_abcde(1, 1, 2, 1, k)*qp_j(1, 1) + &
3131 tij_abcde(2, 1, 2, 1, k)*qp_j(2, 1) + &
3132 tij_abcde(3, 1, 2, 1, k)*qp_j(3, 1) + &
3133 tij_abcde(1, 2, 2, 1, k)*qp_j(1, 2) + &
3134 tij_abcde(2, 2, 2, 1, k)*qp_j(2, 2) + &
3135 tij_abcde(3, 2, 2, 1, k)*qp_j(3, 2) + &
3136 tij_abcde(1, 3, 2, 1, k)*qp_j(1, 3) + &
3137 tij_abcde(2, 3, 2, 1, k)*qp_j(2, 3) + &
3138 tij_abcde(3, 3, 2, 1, k)*qp_j(3, 3))
3139 tmp31 = qp_i(3, 1)*(tij_abcde(1, 1, 3, 1, k)*qp_j(1, 1) + &
3140 tij_abcde(2, 1, 3, 1, k)*qp_j(2, 1) + &
3141 tij_abcde(3, 1, 3, 1, k)*qp_j(3, 1) + &
3142 tij_abcde(1, 2, 3, 1, k)*qp_j(1, 2) + &
3143 tij_abcde(2, 2, 3, 1, k)*qp_j(2, 2) + &
3144 tij_abcde(3, 2, 3, 1, k)*qp_j(3, 2) + &
3145 tij_abcde(1, 3, 3, 1, k)*qp_j(1, 3) + &
3146 tij_abcde(2, 3, 3, 1, k)*qp_j(2, 3) + &
3147 tij_abcde(3, 3, 3, 1, k)*qp_j(3, 3))
3148 tmp22 = qp_i(2, 2)*(tij_abcde(1, 1, 2, 2, k)*qp_j(1, 1) + &
3149 tij_abcde(2, 1, 2, 2, k)*qp_j(2, 1) + &
3150 tij_abcde(3, 1, 2, 2, k)*qp_j(3, 1) + &
3151 tij_abcde(1, 2, 2, 2, k)*qp_j(1, 2) + &
3152 tij_abcde(2, 2, 2, 2, k)*qp_j(2, 2) + &
3153 tij_abcde(3, 2, 2, 2, k)*qp_j(3, 2) + &
3154 tij_abcde(1, 3, 2, 2, k)*qp_j(1, 3) + &
3155 tij_abcde(2, 3, 2, 2, k)*qp_j(2, 3) + &
3156 tij_abcde(3, 3, 2, 2, k)*qp_j(3, 3))
3157 tmp32 = qp_i(3, 2)*(tij_abcde(1, 1, 3, 2, k)*qp_j(1, 1) + &
3158 tij_abcde(2, 1, 3, 2, k)*qp_j(2, 1) + &
3159 tij_abcde(3, 1, 3, 2, k)*qp_j(3, 1) + &
3160 tij_abcde(1, 2, 3, 2, k)*qp_j(1, 2) + &
3161 tij_abcde(2, 2, 3, 2, k)*qp_j(2, 2) + &
3162 tij_abcde(3, 2, 3, 2, k)*qp_j(3, 2) + &
3163 tij_abcde(1, 3, 3, 2, k)*qp_j(1, 3) + &
3164 tij_abcde(2, 3, 3, 2, k)*qp_j(2, 3) + &
3165 tij_abcde(3, 3, 3, 2, k)*qp_j(3, 3))
3166 tmp33 = qp_i(3, 3)*(tij_abcde(1, 1, 3, 3, k)*qp_j(1, 1) + &
3167 tij_abcde(2, 1, 3, 3, k)*qp_j(2, 1) + &
3168 tij_abcde(3, 1, 3, 3, k)*qp_j(3, 1) + &
3169 tij_abcde(1, 2, 3, 3, k)*qp_j(1, 2) + &
3170 tij_abcde(2, 2, 3, 3, k)*qp_j(2, 2) + &
3171 tij_abcde(3, 2, 3, 3, k)*qp_j(3, 2) + &
3172 tij_abcde(1, 3, 3, 3, k)*qp_j(1, 3) + &
3173 tij_abcde(2, 3, 3, 3, k)*qp_j(2, 3) + &
3174 tij_abcde(3, 3, 3, 3, k)*qp_j(3, 3))
3175 tmp12 = tmp21
3176 tmp13 = tmp31
3177 tmp23 = tmp32
3178 fr(k) = fr(k) - fac*(tmp11 + tmp12 + tmp13 + &
3179 tmp21 + tmp22 + tmp23 + &
3180 tmp31 + tmp32 + tmp33)
3181 END DO
3182 END IF
3183 ! Electric field
3184 IF (do_efield) THEN
3185 fac = 1.0_dp/3.0_dp
3186 ! Potential
3187 IF (do_efield0) THEN
3188 ef0_i = ef0_i + fac*(tij_ab(1, 1)*qp_j(1, 1) + &
3189 tij_ab(2, 1)*qp_j(2, 1) + &
3190 tij_ab(3, 1)*qp_j(3, 1) + &
3191 tij_ab(1, 2)*qp_j(1, 2) + &
3192 tij_ab(2, 2)*qp_j(2, 2) + &
3193 tij_ab(3, 2)*qp_j(3, 2) + &
3194 tij_ab(1, 3)*qp_j(1, 3) + &
3195 tij_ab(2, 3)*qp_j(2, 3) + &
3196 tij_ab(3, 3)*qp_j(3, 3))
3197
3198 ef0_j = ef0_j + fac*(tij_ab(1, 1)*qp_i(1, 1) + &
3199 tij_ab(2, 1)*qp_i(2, 1) + &
3200 tij_ab(3, 1)*qp_i(3, 1) + &
3201 tij_ab(1, 2)*qp_i(1, 2) + &
3202 tij_ab(2, 2)*qp_i(2, 2) + &
3203 tij_ab(3, 2)*qp_i(3, 2) + &
3204 tij_ab(1, 3)*qp_i(1, 3) + &
3205 tij_ab(2, 3)*qp_i(2, 3) + &
3206 tij_ab(3, 3)*qp_i(3, 3))
3207 END IF
3208 ! Electric field
3209 IF (do_efield1) THEN
3210 ef1_i(1) = ef1_i(1) - fac*(tij_abc(1, 1, 1)*qp_j(1, 1) + &
3211 tij_abc(2, 1, 1)*qp_j(2, 1) + &
3212 tij_abc(3, 1, 1)*qp_j(3, 1) + &
3213 tij_abc(1, 2, 1)*qp_j(1, 2) + &
3214 tij_abc(2, 2, 1)*qp_j(2, 2) + &
3215 tij_abc(3, 2, 1)*qp_j(3, 2) + &
3216 tij_abc(1, 3, 1)*qp_j(1, 3) + &
3217 tij_abc(2, 3, 1)*qp_j(2, 3) + &
3218 tij_abc(3, 3, 1)*qp_j(3, 3))
3219 ef1_i(2) = ef1_i(2) - fac*(tij_abc(1, 1, 2)*qp_j(1, 1) + &
3220 tij_abc(2, 1, 2)*qp_j(2, 1) + &
3221 tij_abc(3, 1, 2)*qp_j(3, 1) + &
3222 tij_abc(1, 2, 2)*qp_j(1, 2) + &
3223 tij_abc(2, 2, 2)*qp_j(2, 2) + &
3224 tij_abc(3, 2, 2)*qp_j(3, 2) + &
3225 tij_abc(1, 3, 2)*qp_j(1, 3) + &
3226 tij_abc(2, 3, 2)*qp_j(2, 3) + &
3227 tij_abc(3, 3, 2)*qp_j(3, 3))
3228 ef1_i(3) = ef1_i(3) - fac*(tij_abc(1, 1, 3)*qp_j(1, 1) + &
3229 tij_abc(2, 1, 3)*qp_j(2, 1) + &
3230 tij_abc(3, 1, 3)*qp_j(3, 1) + &
3231 tij_abc(1, 2, 3)*qp_j(1, 2) + &
3232 tij_abc(2, 2, 3)*qp_j(2, 2) + &
3233 tij_abc(3, 2, 3)*qp_j(3, 2) + &
3234 tij_abc(1, 3, 3)*qp_j(1, 3) + &
3235 tij_abc(2, 3, 3)*qp_j(2, 3) + &
3236 tij_abc(3, 3, 3)*qp_j(3, 3))
3237
3238 ef1_j(1) = ef1_j(1) + fac*(tij_abc(1, 1, 1)*qp_i(1, 1) + &
3239 tij_abc(2, 1, 1)*qp_i(2, 1) + &
3240 tij_abc(3, 1, 1)*qp_i(3, 1) + &
3241 tij_abc(1, 2, 1)*qp_i(1, 2) + &
3242 tij_abc(2, 2, 1)*qp_i(2, 2) + &
3243 tij_abc(3, 2, 1)*qp_i(3, 2) + &
3244 tij_abc(1, 3, 1)*qp_i(1, 3) + &
3245 tij_abc(2, 3, 1)*qp_i(2, 3) + &
3246 tij_abc(3, 3, 1)*qp_i(3, 3))
3247 ef1_j(2) = ef1_j(2) + fac*(tij_abc(1, 1, 2)*qp_i(1, 1) + &
3248 tij_abc(2, 1, 2)*qp_i(2, 1) + &
3249 tij_abc(3, 1, 2)*qp_i(3, 1) + &
3250 tij_abc(1, 2, 2)*qp_i(1, 2) + &
3251 tij_abc(2, 2, 2)*qp_i(2, 2) + &
3252 tij_abc(3, 2, 2)*qp_i(3, 2) + &
3253 tij_abc(1, 3, 2)*qp_i(1, 3) + &
3254 tij_abc(2, 3, 2)*qp_i(2, 3) + &
3255 tij_abc(3, 3, 2)*qp_i(3, 3))
3256 ef1_j(3) = ef1_j(3) + fac*(tij_abc(1, 1, 3)*qp_i(1, 1) + &
3257 tij_abc(2, 1, 3)*qp_i(2, 1) + &
3258 tij_abc(3, 1, 3)*qp_i(3, 1) + &
3259 tij_abc(1, 2, 3)*qp_i(1, 2) + &
3260 tij_abc(2, 2, 3)*qp_i(2, 2) + &
3261 tij_abc(3, 2, 3)*qp_i(3, 2) + &
3262 tij_abc(1, 3, 3)*qp_i(1, 3) + &
3263 tij_abc(2, 3, 3)*qp_i(2, 3) + &
3264 tij_abc(3, 3, 3)*qp_i(3, 3))
3265 END IF
3266 ! Electric field gradient
3267 IF (do_efield2) THEN
3268 tmp11 = fac*(tij_abcd(1, 1, 1, 1)*qp_j(1, 1) + &
3269 tij_abcd(2, 1, 1, 1)*qp_j(2, 1) + &
3270 tij_abcd(3, 1, 1, 1)*qp_j(3, 1) + &
3271 tij_abcd(1, 2, 1, 1)*qp_j(1, 2) + &
3272 tij_abcd(2, 2, 1, 1)*qp_j(2, 2) + &
3273 tij_abcd(3, 2, 1, 1)*qp_j(3, 2) + &
3274 tij_abcd(1, 3, 1, 1)*qp_j(1, 3) + &
3275 tij_abcd(2, 3, 1, 1)*qp_j(2, 3) + &
3276 tij_abcd(3, 3, 1, 1)*qp_j(3, 3))
3277 tmp12 = fac*(tij_abcd(1, 1, 1, 2)*qp_j(1, 1) + &
3278 tij_abcd(2, 1, 1, 2)*qp_j(2, 1) + &
3279 tij_abcd(3, 1, 1, 2)*qp_j(3, 1) + &
3280 tij_abcd(1, 2, 1, 2)*qp_j(1, 2) + &
3281 tij_abcd(2, 2, 1, 2)*qp_j(2, 2) + &
3282 tij_abcd(3, 2, 1, 2)*qp_j(3, 2) + &
3283 tij_abcd(1, 3, 1, 2)*qp_j(1, 3) + &
3284 tij_abcd(2, 3, 1, 2)*qp_j(2, 3) + &
3285 tij_abcd(3, 3, 1, 2)*qp_j(3, 3))
3286 tmp13 = fac*(tij_abcd(1, 1, 1, 3)*qp_j(1, 1) + &
3287 tij_abcd(2, 1, 1, 3)*qp_j(2, 1) + &
3288 tij_abcd(3, 1, 1, 3)*qp_j(3, 1) + &
3289 tij_abcd(1, 2, 1, 3)*qp_j(1, 2) + &
3290 tij_abcd(2, 2, 1, 3)*qp_j(2, 2) + &
3291 tij_abcd(3, 2, 1, 3)*qp_j(3, 2) + &
3292 tij_abcd(1, 3, 1, 3)*qp_j(1, 3) + &
3293 tij_abcd(2, 3, 1, 3)*qp_j(2, 3) + &
3294 tij_abcd(3, 3, 1, 3)*qp_j(3, 3))
3295 tmp22 = fac*(tij_abcd(1, 1, 2, 2)*qp_j(1, 1) + &
3296 tij_abcd(2, 1, 2, 2)*qp_j(2, 1) + &
3297 tij_abcd(3, 1, 2, 2)*qp_j(3, 1) + &
3298 tij_abcd(1, 2, 2, 2)*qp_j(1, 2) + &
3299 tij_abcd(2, 2, 2, 2)*qp_j(2, 2) + &
3300 tij_abcd(3, 2, 2, 2)*qp_j(3, 2) + &
3301 tij_abcd(1, 3, 2, 2)*qp_j(1, 3) + &
3302 tij_abcd(2, 3, 2, 2)*qp_j(2, 3) + &
3303 tij_abcd(3, 3, 2, 2)*qp_j(3, 3))
3304 tmp23 = fac*(tij_abcd(1, 1, 2, 3)*qp_j(1, 1) + &
3305 tij_abcd(2, 1, 2, 3)*qp_j(2, 1) + &
3306 tij_abcd(3, 1, 2, 3)*qp_j(3, 1) + &
3307 tij_abcd(1, 2, 2, 3)*qp_j(1, 2) + &
3308 tij_abcd(2, 2, 2, 3)*qp_j(2, 2) + &
3309 tij_abcd(3, 2, 2, 3)*qp_j(3, 2) + &
3310 tij_abcd(1, 3, 2, 3)*qp_j(1, 3) + &
3311 tij_abcd(2, 3, 2, 3)*qp_j(2, 3) + &
3312 tij_abcd(3, 3, 2, 3)*qp_j(3, 3))
3313 tmp33 = fac*(tij_abcd(1, 1, 3, 3)*qp_j(1, 1) + &
3314 tij_abcd(2, 1, 3, 3)*qp_j(2, 1) + &
3315 tij_abcd(3, 1, 3, 3)*qp_j(3, 1) + &
3316 tij_abcd(1, 2, 3, 3)*qp_j(1, 2) + &
3317 tij_abcd(2, 2, 3, 3)*qp_j(2, 2) + &
3318 tij_abcd(3, 2, 3, 3)*qp_j(3, 2) + &
3319 tij_abcd(1, 3, 3, 3)*qp_j(1, 3) + &
3320 tij_abcd(2, 3, 3, 3)*qp_j(2, 3) + &
3321 tij_abcd(3, 3, 3, 3)*qp_j(3, 3))
3322
3323 ef2_i(1, 1) = ef2_i(1, 1) - tmp11
3324 ef2_i(1, 2) = ef2_i(1, 2) - tmp12
3325 ef2_i(1, 3) = ef2_i(1, 3) - tmp13
3326 ef2_i(2, 1) = ef2_i(2, 1) - tmp12
3327 ef2_i(2, 2) = ef2_i(2, 2) - tmp22
3328 ef2_i(2, 3) = ef2_i(2, 3) - tmp23
3329 ef2_i(3, 1) = ef2_i(3, 1) - tmp13
3330 ef2_i(3, 2) = ef2_i(3, 2) - tmp23
3331 ef2_i(3, 3) = ef2_i(3, 3) - tmp33
3332
3333 tmp11 = fac*(tij_abcd(1, 1, 1, 1)*qp_i(1, 1) + &
3334 tij_abcd(2, 1, 1, 1)*qp_i(2, 1) + &
3335 tij_abcd(3, 1, 1, 1)*qp_i(3, 1) + &
3336 tij_abcd(1, 2, 1, 1)*qp_i(1, 2) + &
3337 tij_abcd(2, 2, 1, 1)*qp_i(2, 2) + &
3338 tij_abcd(3, 2, 1, 1)*qp_i(3, 2) + &
3339 tij_abcd(1, 3, 1, 1)*qp_i(1, 3) + &
3340 tij_abcd(2, 3, 1, 1)*qp_i(2, 3) + &
3341 tij_abcd(3, 3, 1, 1)*qp_i(3, 3))
3342 tmp12 = fac*(tij_abcd(1, 1, 1, 2)*qp_i(1, 1) + &
3343 tij_abcd(2, 1, 1, 2)*qp_i(2, 1) + &
3344 tij_abcd(3, 1, 1, 2)*qp_i(3, 1) + &
3345 tij_abcd(1, 2, 1, 2)*qp_i(1, 2) + &
3346 tij_abcd(2, 2, 1, 2)*qp_i(2, 2) + &
3347 tij_abcd(3, 2, 1, 2)*qp_i(3, 2) + &
3348 tij_abcd(1, 3, 1, 2)*qp_i(1, 3) + &
3349 tij_abcd(2, 3, 1, 2)*qp_i(2, 3) + &
3350 tij_abcd(3, 3, 1, 2)*qp_i(3, 3))
3351 tmp13 = fac*(tij_abcd(1, 1, 1, 3)*qp_i(1, 1) + &
3352 tij_abcd(2, 1, 1, 3)*qp_i(2, 1) + &
3353 tij_abcd(3, 1, 1, 3)*qp_i(3, 1) + &
3354 tij_abcd(1, 2, 1, 3)*qp_i(1, 2) + &
3355 tij_abcd(2, 2, 1, 3)*qp_i(2, 2) + &
3356 tij_abcd(3, 2, 1, 3)*qp_i(3, 2) + &
3357 tij_abcd(1, 3, 1, 3)*qp_i(1, 3) + &
3358 tij_abcd(2, 3, 1, 3)*qp_i(2, 3) + &
3359 tij_abcd(3, 3, 1, 3)*qp_i(3, 3))
3360 tmp22 = fac*(tij_abcd(1, 1, 2, 2)*qp_i(1, 1) + &
3361 tij_abcd(2, 1, 2, 2)*qp_i(2, 1) + &
3362 tij_abcd(3, 1, 2, 2)*qp_i(3, 1) + &
3363 tij_abcd(1, 2, 2, 2)*qp_i(1, 2) + &
3364 tij_abcd(2, 2, 2, 2)*qp_i(2, 2) + &
3365 tij_abcd(3, 2, 2, 2)*qp_i(3, 2) + &
3366 tij_abcd(1, 3, 2, 2)*qp_i(1, 3) + &
3367 tij_abcd(2, 3, 2, 2)*qp_i(2, 3) + &
3368 tij_abcd(3, 3, 2, 2)*qp_i(3, 3))
3369 tmp23 = fac*(tij_abcd(1, 1, 2, 3)*qp_i(1, 1) + &
3370 tij_abcd(2, 1, 2, 3)*qp_i(2, 1) + &
3371 tij_abcd(3, 1, 2, 3)*qp_i(3, 1) + &
3372 tij_abcd(1, 2, 2, 3)*qp_i(1, 2) + &
3373 tij_abcd(2, 2, 2, 3)*qp_i(2, 2) + &
3374 tij_abcd(3, 2, 2, 3)*qp_i(3, 2) + &
3375 tij_abcd(1, 3, 2, 3)*qp_i(1, 3) + &
3376 tij_abcd(2, 3, 2, 3)*qp_i(2, 3) + &
3377 tij_abcd(3, 3, 2, 3)*qp_i(3, 3))
3378 tmp33 = fac*(tij_abcd(1, 1, 3, 3)*qp_i(1, 1) + &
3379 tij_abcd(2, 1, 3, 3)*qp_i(2, 1) + &
3380 tij_abcd(3, 1, 3, 3)*qp_i(3, 1) + &
3381 tij_abcd(1, 2, 3, 3)*qp_i(1, 2) + &
3382 tij_abcd(2, 2, 3, 3)*qp_i(2, 2) + &
3383 tij_abcd(3, 2, 3, 3)*qp_i(3, 2) + &
3384 tij_abcd(1, 3, 3, 3)*qp_i(1, 3) + &
3385 tij_abcd(2, 3, 3, 3)*qp_i(2, 3) + &
3386 tij_abcd(3, 3, 3, 3)*qp_i(3, 3))
3387
3388 ef2_j(1, 1) = ef2_j(1, 1) - tmp11
3389 ef2_j(1, 2) = ef2_j(1, 2) - tmp12
3390 ef2_j(1, 3) = ef2_j(1, 3) - tmp13
3391 ef2_j(2, 1) = ef2_j(2, 1) - tmp12
3392 ef2_j(2, 2) = ef2_j(2, 2) - tmp22
3393 ef2_j(2, 3) = ef2_j(2, 3) - tmp23
3394 ef2_j(3, 1) = ef2_j(3, 1) - tmp13
3395 ef2_j(3, 2) = ef2_j(3, 2) - tmp23
3396 ef2_j(3, 3) = ef2_j(3, 3) - tmp33
3397 END IF
3398 END IF
3399 END IF
3400 IF (task(3, 2)) THEN
3401 ! Quadrupole - Dipole
3402 fac = 1.0_dp/3.0_dp
3403 ! Dipole i (locally B) - Quadrupole j (locally A)
3404 tmp_ij = dp_i(1)*(tij_abc(1, 1, 1)*qp_j(1, 1) + &
3405 tij_abc(2, 1, 1)*qp_j(2, 1) + &
3406 tij_abc(3, 1, 1)*qp_j(3, 1) + &
3407 tij_abc(1, 2, 1)*qp_j(1, 2) + &
3408 tij_abc(2, 2, 1)*qp_j(2, 2) + &
3409 tij_abc(3, 2, 1)*qp_j(3, 2) + &
3410 tij_abc(1, 3, 1)*qp_j(1, 3) + &
3411 tij_abc(2, 3, 1)*qp_j(2, 3) + &
3412 tij_abc(3, 3, 1)*qp_j(3, 3)) + &
3413 dp_i(2)*(tij_abc(1, 1, 2)*qp_j(1, 1) + &
3414 tij_abc(2, 1, 2)*qp_j(2, 1) + &
3415 tij_abc(3, 1, 2)*qp_j(3, 1) + &
3416 tij_abc(1, 2, 2)*qp_j(1, 2) + &
3417 tij_abc(2, 2, 2)*qp_j(2, 2) + &
3418 tij_abc(3, 2, 2)*qp_j(3, 2) + &
3419 tij_abc(1, 3, 2)*qp_j(1, 3) + &
3420 tij_abc(2, 3, 2)*qp_j(2, 3) + &
3421 tij_abc(3, 3, 2)*qp_j(3, 3)) + &
3422 dp_i(3)*(tij_abc(1, 1, 3)*qp_j(1, 1) + &
3423 tij_abc(2, 1, 3)*qp_j(2, 1) + &
3424 tij_abc(3, 1, 3)*qp_j(3, 1) + &
3425 tij_abc(1, 2, 3)*qp_j(1, 2) + &
3426 tij_abc(2, 2, 3)*qp_j(2, 2) + &
3427 tij_abc(3, 2, 3)*qp_j(3, 2) + &
3428 tij_abc(1, 3, 3)*qp_j(1, 3) + &
3429 tij_abc(2, 3, 3)*qp_j(2, 3) + &
3430 tij_abc(3, 3, 3)*qp_j(3, 3))
3431
3432 ! Dipole j (locally A) - Quadrupole i (locally B)
3433 tmp_ji = dp_j(1)*(tij_abc(1, 1, 1)*qp_i(1, 1) + &
3434 tij_abc(2, 1, 1)*qp_i(2, 1) + &
3435 tij_abc(3, 1, 1)*qp_i(3, 1) + &
3436 tij_abc(1, 2, 1)*qp_i(1, 2) + &
3437 tij_abc(2, 2, 1)*qp_i(2, 2) + &
3438 tij_abc(3, 2, 1)*qp_i(3, 2) + &
3439 tij_abc(1, 3, 1)*qp_i(1, 3) + &
3440 tij_abc(2, 3, 1)*qp_i(2, 3) + &
3441 tij_abc(3, 3, 1)*qp_i(3, 3)) + &
3442 dp_j(2)*(tij_abc(1, 1, 2)*qp_i(1, 1) + &
3443 tij_abc(2, 1, 2)*qp_i(2, 1) + &
3444 tij_abc(3, 1, 2)*qp_i(3, 1) + &
3445 tij_abc(1, 2, 2)*qp_i(1, 2) + &
3446 tij_abc(2, 2, 2)*qp_i(2, 2) + &
3447 tij_abc(3, 2, 2)*qp_i(3, 2) + &
3448 tij_abc(1, 3, 2)*qp_i(1, 3) + &
3449 tij_abc(2, 3, 2)*qp_i(2, 3) + &
3450 tij_abc(3, 3, 2)*qp_i(3, 3)) + &
3451 dp_j(3)*(tij_abc(1, 1, 3)*qp_i(1, 1) + &
3452 tij_abc(2, 1, 3)*qp_i(2, 1) + &
3453 tij_abc(3, 1, 3)*qp_i(3, 1) + &
3454 tij_abc(1, 2, 3)*qp_i(1, 2) + &
3455 tij_abc(2, 2, 3)*qp_i(2, 2) + &
3456 tij_abc(3, 2, 3)*qp_i(3, 2) + &
3457 tij_abc(1, 3, 3)*qp_i(1, 3) + &
3458 tij_abc(2, 3, 3)*qp_i(2, 3) + &
3459 tij_abc(3, 3, 3)*qp_i(3, 3))
3460
3461 tmp = fac*(tmp_ij - tmp_ji)
3462 eloc = eloc + tmp
3463 IF (do_forces .OR. do_stress) THEN
3464 DO k = 1, 3
3465 ! Dipole i (locally B) - Quadrupole j (locally A)
3466 tmp_ij = dp_i(1)*(tij_abcd(1, 1, 1, k)*qp_j(1, 1) + &
3467 tij_abcd(2, 1, 1, k)*qp_j(2, 1) + &
3468 tij_abcd(3, 1, 1, k)*qp_j(3, 1) + &
3469 tij_abcd(1, 2, 1, k)*qp_j(1, 2) + &
3470 tij_abcd(2, 2, 1, k)*qp_j(2, 2) + &
3471 tij_abcd(3, 2, 1, k)*qp_j(3, 2) + &
3472 tij_abcd(1, 3, 1, k)*qp_j(1, 3) + &
3473 tij_abcd(2, 3, 1, k)*qp_j(2, 3) + &
3474 tij_abcd(3, 3, 1, k)*qp_j(3, 3)) + &
3475 dp_i(2)*(tij_abcd(1, 1, 2, k)*qp_j(1, 1) + &
3476 tij_abcd(2, 1, 2, k)*qp_j(2, 1) + &
3477 tij_abcd(3, 1, 2, k)*qp_j(3, 1) + &
3478 tij_abcd(1, 2, 2, k)*qp_j(1, 2) + &
3479 tij_abcd(2, 2, 2, k)*qp_j(2, 2) + &
3480 tij_abcd(3, 2, 2, k)*qp_j(3, 2) + &
3481 tij_abcd(1, 3, 2, k)*qp_j(1, 3) + &
3482 tij_abcd(2, 3, 2, k)*qp_j(2, 3) + &
3483 tij_abcd(3, 3, 2, k)*qp_j(3, 3)) + &
3484 dp_i(3)*(tij_abcd(1, 1, 3, k)*qp_j(1, 1) + &
3485 tij_abcd(2, 1, 3, k)*qp_j(2, 1) + &
3486 tij_abcd(3, 1, 3, k)*qp_j(3, 1) + &
3487 tij_abcd(1, 2, 3, k)*qp_j(1, 2) + &
3488 tij_abcd(2, 2, 3, k)*qp_j(2, 2) + &
3489 tij_abcd(3, 2, 3, k)*qp_j(3, 2) + &
3490 tij_abcd(1, 3, 3, k)*qp_j(1, 3) + &
3491 tij_abcd(2, 3, 3, k)*qp_j(2, 3) + &
3492 tij_abcd(3, 3, 3, k)*qp_j(3, 3))
3493
3494 ! Dipole j (locally A) - Quadrupole i (locally B)
3495 tmp_ji = dp_j(1)*(tij_abcd(1, 1, 1, k)*qp_i(1, 1) + &
3496 tij_abcd(2, 1, 1, k)*qp_i(2, 1) + &
3497 tij_abcd(3, 1, 1, k)*qp_i(3, 1) + &
3498 tij_abcd(1, 2, 1, k)*qp_i(1, 2) + &
3499 tij_abcd(2, 2, 1, k)*qp_i(2, 2) + &
3500 tij_abcd(3, 2, 1, k)*qp_i(3, 2) + &
3501 tij_abcd(1, 3, 1, k)*qp_i(1, 3) + &
3502 tij_abcd(2, 3, 1, k)*qp_i(2, 3) + &
3503 tij_abcd(3, 3, 1, k)*qp_i(3, 3)) + &
3504 dp_j(2)*(tij_abcd(1, 1, 2, k)*qp_i(1, 1) + &
3505 tij_abcd(2, 1, 2, k)*qp_i(2, 1) + &
3506 tij_abcd(3, 1, 2, k)*qp_i(3, 1) + &
3507 tij_abcd(1, 2, 2, k)*qp_i(1, 2) + &
3508 tij_abcd(2, 2, 2, k)*qp_i(2, 2) + &
3509 tij_abcd(3, 2, 2, k)*qp_i(3, 2) + &
3510 tij_abcd(1, 3, 2, k)*qp_i(1, 3) + &
3511 tij_abcd(2, 3, 2, k)*qp_i(2, 3) + &
3512 tij_abcd(3, 3, 2, k)*qp_i(3, 3)) + &
3513 dp_j(3)*(tij_abcd(1, 1, 3, k)*qp_i(1, 1) + &
3514 tij_abcd(2, 1, 3, k)*qp_i(2, 1) + &
3515 tij_abcd(3, 1, 3, k)*qp_i(3, 1) + &
3516 tij_abcd(1, 2, 3, k)*qp_i(1, 2) + &
3517 tij_abcd(2, 2, 3, k)*qp_i(2, 2) + &
3518 tij_abcd(3, 2, 3, k)*qp_i(3, 2) + &
3519 tij_abcd(1, 3, 3, k)*qp_i(1, 3) + &
3520 tij_abcd(2, 3, 3, k)*qp_i(2, 3) + &
3521 tij_abcd(3, 3, 3, k)*qp_i(3, 3))
3522
3523 fr(k) = fr(k) - fac*(tmp_ij - tmp_ji)
3524 END DO
3525 END IF
3526 END IF
3527 IF (task(3, 1)) THEN
3528 ! Quadrupole - Charge
3529 fac = 1.0_dp/3.0_dp
3530
3531 ! Quadrupole j (locally A) - Charge j (locally B)
3532 tmp_ij = ch_i*(tij_ab(1, 1)*qp_j(1, 1) + &
3533 tij_ab(2, 1)*qp_j(2, 1) + &
3534 tij_ab(3, 1)*qp_j(3, 1) + &
3535 tij_ab(1, 2)*qp_j(1, 2) + &
3536 tij_ab(2, 2)*qp_j(2, 2) + &
3537 tij_ab(3, 2)*qp_j(3, 2) + &
3538 tij_ab(1, 3)*qp_j(1, 3) + &
3539 tij_ab(2, 3)*qp_j(2, 3) + &
3540 tij_ab(3, 3)*qp_j(3, 3))
3541
3542 ! Quadrupole i (locally B) - Charge j (locally A)
3543 tmp_ji = ch_j*(tij_ab(1, 1)*qp_i(1, 1) + &
3544 tij_ab(2, 1)*qp_i(2, 1) + &
3545 tij_ab(3, 1)*qp_i(3, 1) + &
3546 tij_ab(1, 2)*qp_i(1, 2) + &
3547 tij_ab(2, 2)*qp_i(2, 2) + &
3548 tij_ab(3, 2)*qp_i(3, 2) + &
3549 tij_ab(1, 3)*qp_i(1, 3) + &
3550 tij_ab(2, 3)*qp_i(2, 3) + &
3551 tij_ab(3, 3)*qp_i(3, 3))
3552
3553 eloc = eloc + fac*(tmp_ij + tmp_ji)
3554 IF (do_forces .OR. do_stress) THEN
3555 DO k = 1, 3
3556 ! Quadrupole j (locally A) - Charge i (locally B)
3557 tmp_ij = ch_i*(tij_abc(1, 1, k)*qp_j(1, 1) + &
3558 tij_abc(2, 1, k)*qp_j(2, 1) + &
3559 tij_abc(3, 1, k)*qp_j(3, 1) + &
3560 tij_abc(1, 2, k)*qp_j(1, 2) + &
3561 tij_abc(2, 2, k)*qp_j(2, 2) + &
3562 tij_abc(3, 2, k)*qp_j(3, 2) + &
3563 tij_abc(1, 3, k)*qp_j(1, 3) + &
3564 tij_abc(2, 3, k)*qp_j(2, 3) + &
3565 tij_abc(3, 3, k)*qp_j(3, 3))
3566
3567 ! Quadrupole i (locally B) - Charge j (locally A)
3568 tmp_ji = ch_j*(tij_abc(1, 1, k)*qp_i(1, 1) + &
3569 tij_abc(2, 1, k)*qp_i(2, 1) + &
3570 tij_abc(3, 1, k)*qp_i(3, 1) + &
3571 tij_abc(1, 2, k)*qp_i(1, 2) + &
3572 tij_abc(2, 2, k)*qp_i(2, 2) + &
3573 tij_abc(3, 2, k)*qp_i(3, 2) + &
3574 tij_abc(1, 3, k)*qp_i(1, 3) + &
3575 tij_abc(2, 3, k)*qp_i(2, 3) + &
3576 tij_abc(3, 3, k)*qp_i(3, 3))
3577
3578 fr(k) = fr(k) - fac*(tmp_ij + tmp_ji)
3579 END DO
3580 END IF
3581 END IF
3582 energy = energy + eloc
3583 IF (do_forces) THEN
3584 forces(1, atom_a) = forces(1, atom_a) - fr(1)
3585 forces(2, atom_a) = forces(2, atom_a) - fr(2)
3586 forces(3, atom_a) = forces(3, atom_a) - fr(3)
3587 forces(1, atom_b) = forces(1, atom_b) + fr(1)
3588 forces(2, atom_b) = forces(2, atom_b) + fr(2)
3589 forces(3, atom_b) = forces(3, atom_b) + fr(3)
3590 END IF
3591 ! Electric fields
3592 IF (do_efield) THEN
3593 ! Potential
3594 IF (do_efield0) THEN
3595 efield0(atom_a) = efield0(atom_a) + ef0_j
3596
3597 efield0(atom_b) = efield0(atom_b) + ef0_i
3598 END IF
3599 ! Electric field
3600 IF (do_efield1) THEN
3601 efield1(1, atom_a) = efield1(1, atom_a) + ef1_j(1)
3602 efield1(2, atom_a) = efield1(2, atom_a) + ef1_j(2)
3603 efield1(3, atom_a) = efield1(3, atom_a) + ef1_j(3)
3604
3605 efield1(1, atom_b) = efield1(1, atom_b) + ef1_i(1)
3606 efield1(2, atom_b) = efield1(2, atom_b) + ef1_i(2)
3607 efield1(3, atom_b) = efield1(3, atom_b) + ef1_i(3)
3608 END IF
3609 ! Electric field gradient
3610 IF (do_efield2) THEN
3611 efield2(1, atom_a) = efield2(1, atom_a) + ef2_j(1, 1)
3612 efield2(2, atom_a) = efield2(2, atom_a) + ef2_j(1, 2)
3613 efield2(3, atom_a) = efield2(3, atom_a) + ef2_j(1, 3)
3614 efield2(4, atom_a) = efield2(4, atom_a) + ef2_j(2, 1)
3615 efield2(5, atom_a) = efield2(5, atom_a) + ef2_j(2, 2)
3616 efield2(6, atom_a) = efield2(6, atom_a) + ef2_j(2, 3)
3617 efield2(7, atom_a) = efield2(7, atom_a) + ef2_j(3, 1)
3618 efield2(8, atom_a) = efield2(8, atom_a) + ef2_j(3, 2)
3619 efield2(9, atom_a) = efield2(9, atom_a) + ef2_j(3, 3)
3620
3621 efield2(1, atom_b) = efield2(1, atom_b) + ef2_i(1, 1)
3622 efield2(2, atom_b) = efield2(2, atom_b) + ef2_i(1, 2)
3623 efield2(3, atom_b) = efield2(3, atom_b) + ef2_i(1, 3)
3624 efield2(4, atom_b) = efield2(4, atom_b) + ef2_i(2, 1)
3625 efield2(5, atom_b) = efield2(5, atom_b) + ef2_i(2, 2)
3626 efield2(6, atom_b) = efield2(6, atom_b) + ef2_i(2, 3)
3627 efield2(7, atom_b) = efield2(7, atom_b) + ef2_i(3, 1)
3628 efield2(8, atom_b) = efield2(8, atom_b) + ef2_i(3, 2)
3629 efield2(9, atom_b) = efield2(9, atom_b) + ef2_i(3, 3)
3630 END IF
3631 END IF
3632 IF (do_stress) THEN
3633 ptens11 = ptens11 + rab(1)*fr(1)
3634 ptens21 = ptens21 + rab(2)*fr(1)
3635 ptens31 = ptens31 + rab(3)*fr(1)
3636 ptens12 = ptens12 + rab(1)*fr(2)
3637 ptens22 = ptens22 + rab(2)*fr(2)
3638 ptens32 = ptens32 + rab(3)*fr(2)
3639 ptens13 = ptens13 + rab(1)*fr(3)
3640 ptens23 = ptens23 + rab(2)*fr(3)
3641 ptens33 = ptens33 + rab(3)*fr(3)
3642 END IF
3643
3644 END DO pairs
3645 END DO kind_group_loop
3646 END DO lists
3647 IF (do_stress) THEN
3648 pv(1, 1) = pv(1, 1) + ptens11
3649 pv(1, 2) = pv(1, 2) + (ptens12 + ptens21)*0.5_dp
3650 pv(1, 3) = pv(1, 3) + (ptens13 + ptens31)*0.5_dp
3651 pv(2, 1) = pv(1, 2)
3652 pv(2, 2) = pv(2, 2) + ptens22
3653 pv(2, 3) = pv(2, 3) + (ptens23 + ptens32)*0.5_dp
3654 pv(3, 1) = pv(1, 3)
3655 pv(3, 2) = pv(2, 3)
3656 pv(3, 3) = pv(3, 3) + ptens33
3657 END IF
3658
3659 CALL timestop(handle)
3660 END SUBROUTINE ewald_multipole_bonded
3661
3662! **************************************************************************************************
3663!> \brief computes the potential and the force for a lattice sum of multipoles
3664!> up to quadrupole - Long Range (Reciprocal Space) Term
3665!> \param ewald_env ...
3666!> \param ewald_pw ...
3667!> \param cell ...
3668!> \param particle_set ...
3669!> \param local_particles ...
3670!> \param energy ...
3671!> \param task ...
3672!> \param do_forces ...
3673!> \param do_efield ...
3674!> \param do_stress ...
3675!> \param charges ...
3676!> \param dipoles ...
3677!> \param quadrupoles ...
3678!> \param forces ...
3679!> \param pv ...
3680!> \param efield0 ...
3681!> \param efield1 ...
3682!> \param efield2 ...
3683!> \author Teodoro Laino [tlaino] - 12.2007 - University of Zurich
3684! **************************************************************************************************
3685 SUBROUTINE ewald_multipole_lr(ewald_env, ewald_pw, cell, particle_set, &
3686 local_particles, energy, task, do_forces, do_efield, do_stress, &
3687 charges, dipoles, quadrupoles, forces, pv, efield0, efield1, efield2)
3688 TYPE(ewald_environment_type), POINTER :: ewald_env
3689 TYPE(ewald_pw_type), POINTER :: ewald_pw
3690 TYPE(cell_type), POINTER :: cell
3691 TYPE(particle_type), POINTER :: particle_set(:)
3692 TYPE(distribution_1d_type), POINTER :: local_particles
3693 REAL(kind=dp), INTENT(INOUT) :: energy
3694 LOGICAL, DIMENSION(3, 3), INTENT(IN) :: task
3695 LOGICAL, INTENT(IN) :: do_forces, do_efield, do_stress
3696 REAL(kind=dp), DIMENSION(:), OPTIONAL, POINTER :: charges
3697 REAL(kind=dp), DIMENSION(:, :), OPTIONAL, POINTER :: dipoles
3698 REAL(kind=dp), DIMENSION(:, :, :), OPTIONAL, &
3699 POINTER :: quadrupoles
3700 REAL(kind=dp), DIMENSION(:, :), INTENT(INOUT), &
3701 OPTIONAL :: forces, pv
3702 REAL(kind=dp), DIMENSION(:), POINTER :: efield0
3703 REAL(kind=dp), DIMENSION(:, :), POINTER :: efield1, efield2
3704
3705 CHARACTER(len=*), PARAMETER :: routinen = 'ewald_multipole_LR'
3706
3707 COMPLEX(KIND=dp) :: atm_factor, atm_factor_st(3), cnjg_fac, &
3708 fac, summe_tmp
3709 COMPLEX(KIND=dp), ALLOCATABLE, DIMENSION(:) :: summe_ef
3710 COMPLEX(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: summe_st
3711 INTEGER :: gpt, handle, iparticle, iparticle_kind, iparticle_local, lp, mp, nnodes, &
3712 node, np, nparticle_kind, nparticle_local
3713 INTEGER, DIMENSION(:, :), POINTER :: bds
3714 LOGICAL :: do_efield0, do_efield1, do_efield2
3715 REAL(kind=dp) :: alpha, denom, dipole_t(3), f0, factor, &
3716 four_alpha_sq, gauss, pref, q_t, tmp, &
3717 trq_t
3718 REAL(kind=dp), DIMENSION(3) :: tmp_v, vec
3719 REAL(kind=dp), DIMENSION(3, 3) :: pv_tmp
3720 REAL(kind=dp), DIMENSION(:, :, :), POINTER :: rho0
3721 TYPE(dg_rho0_type), POINTER :: dg_rho0
3722 TYPE(dg_type), POINTER :: dg
3723 TYPE(pw_grid_type), POINTER :: pw_grid
3724 TYPE(pw_pool_type), POINTER :: pw_pool
3725 TYPE(structure_factor_type) :: exp_igr
3726 TYPE(mp_comm_type) :: group
3727
3728 CALL timeset(routinen, handle)
3729 do_efield0 = do_efield .AND. ASSOCIATED(efield0)
3730 do_efield1 = do_efield .AND. ASSOCIATED(efield1)
3731 do_efield2 = do_efield .AND. ASSOCIATED(efield2)
3732
3733 ! Gathering data from the ewald environment
3734 CALL ewald_env_get(ewald_env, alpha=alpha, group=group)
3735 CALL ewald_pw_get(ewald_pw, pw_big_pool=pw_pool, dg=dg)
3736 CALL dg_get(dg, dg_rho0=dg_rho0)
3737 rho0 => dg_rho0%density%array
3738 pw_grid => pw_pool%pw_grid
3739 bds => pw_grid%bounds
3740
3741 ! Allocation of working arrays
3742 nparticle_kind = SIZE(local_particles%n_el)
3743 nnodes = 0
3744 DO iparticle_kind = 1, nparticle_kind
3745 nnodes = nnodes + local_particles%n_el(iparticle_kind)
3746 END DO
3747 CALL structure_factor_allocate(pw_grid%bounds, nnodes, exp_igr)
3748
3749 ALLOCATE (summe_ef(1:pw_grid%ngpts_cut))
3750 summe_ef = cmplx(0.0_dp, 0.0_dp, kind=dp)
3751 ! Stress Tensor
3752 IF (do_stress) THEN
3753 pv_tmp = 0.0_dp
3754 ALLOCATE (summe_st(3, 1:pw_grid%ngpts_cut))
3755 summe_st = cmplx(0.0_dp, 0.0_dp, kind=dp)
3756 END IF
3757
3758 ! Defining four_alpha_sq
3759 four_alpha_sq = 4.0_dp*alpha**2
3760 dipole_t = 0.0_dp
3761 q_t = 0.0_dp
3762 trq_t = 0.0_dp
3763 ! Zero node count
3764 node = 0
3765 DO iparticle_kind = 1, nparticle_kind
3766 nparticle_local = local_particles%n_el(iparticle_kind)
3767 DO iparticle_local = 1, nparticle_local
3768 node = node + 1
3769 iparticle = local_particles%list(iparticle_kind)%array(iparticle_local)
3770 vec = matmul(cell%h_inv, particle_set(iparticle)%r)
3771 CALL structure_factor_evaluate(vec, exp_igr%lb, &
3772 exp_igr%ex(:, node), exp_igr%ey(:, node), exp_igr%ez(:, node))
3773
3774 ! Computing the total charge, dipole and quadrupole trace (if any)
3775 IF (any(task(1, :))) THEN
3776 q_t = q_t + charges(iparticle)
3777 END IF
3778 IF (any(task(2, :))) THEN
3779 dipole_t = dipole_t + dipoles(:, iparticle)
3780 END IF
3781 IF (any(task(3, :))) THEN
3782 trq_t = trq_t + quadrupoles(1, 1, iparticle) + &
3783 quadrupoles(2, 2, iparticle) + &
3784 quadrupoles(3, 3, iparticle)
3785 END IF
3786 END DO
3787 END DO
3788
3789 ! Looping over the positive g-vectors
3790 DO gpt = 1, pw_grid%ngpts_cut_local
3791 lp = pw_grid%mapl%pos(pw_grid%g_hat(1, gpt))
3792 mp = pw_grid%mapm%pos(pw_grid%g_hat(2, gpt))
3793 np = pw_grid%mapn%pos(pw_grid%g_hat(3, gpt))
3794
3795 lp = lp + bds(1, 1)
3796 mp = mp + bds(1, 2)
3797 np = np + bds(1, 3)
3798
3799 ! Initializing sum to be used in the energy and force
3800 node = 0
3801 DO iparticle_kind = 1, nparticle_kind
3802 nparticle_local = local_particles%n_el(iparticle_kind)
3803 DO iparticle_local = 1, nparticle_local
3804 node = node + 1
3805 iparticle = local_particles%list(iparticle_kind)%array(iparticle_local)
3806 ! Density for energy and forces
3807 CALL get_atom_factor(atm_factor, pw_grid, gpt, iparticle, task, charges, &
3808 dipoles, quadrupoles)
3809 summe_tmp = exp_igr%ex(lp, node)*exp_igr%ey(mp, node)*exp_igr%ez(np, node)
3810 summe_ef(gpt) = summe_ef(gpt) + atm_factor*summe_tmp
3811
3812 ! Precompute pseudo-density for stress tensor calculation
3813 IF (do_stress) THEN
3814 CALL get_atom_factor_stress(atm_factor_st, pw_grid, gpt, iparticle, task, &
3815 dipoles, quadrupoles)
3816 summe_st(1:3, gpt) = summe_st(1:3, gpt) + atm_factor_st(1:3)*summe_tmp
3817 END IF
3818 END DO
3819 END DO
3820 END DO
3821 CALL group%sum(q_t)
3822 CALL group%sum(dipole_t)
3823 CALL group%sum(trq_t)
3824 CALL group%sum(summe_ef)
3825 IF (do_stress) CALL group%sum(summe_st)
3826
3827 ! Looping over the positive g-vectors
3828 DO gpt = 1, pw_grid%ngpts_cut_local
3829 ! computing the potential energy
3830 lp = pw_grid%mapl%pos(pw_grid%g_hat(1, gpt))
3831 mp = pw_grid%mapm%pos(pw_grid%g_hat(2, gpt))
3832 np = pw_grid%mapn%pos(pw_grid%g_hat(3, gpt))
3833
3834 lp = lp + bds(1, 1)
3835 mp = mp + bds(1, 2)
3836 np = np + bds(1, 3)
3837
3838 IF (pw_grid%gsq(gpt) == 0.0_dp) THEN
3839 ! G=0 vector for dipole-dipole and charge-quadrupole
3840 energy = energy + (1.0_dp/6.0_dp)*dot_product(dipole_t, dipole_t) &
3841 - (1.0_dp/9.0_dp)*q_t*trq_t
3842 ! Stress tensor
3843 IF (do_stress) THEN
3844 pv_tmp(1, 1) = pv_tmp(1, 1) + (1.0_dp/6.0_dp)*dot_product(dipole_t, dipole_t)
3845 pv_tmp(2, 2) = pv_tmp(2, 2) + (1.0_dp/6.0_dp)*dot_product(dipole_t, dipole_t)
3846 pv_tmp(3, 3) = pv_tmp(3, 3) + (1.0_dp/6.0_dp)*dot_product(dipole_t, dipole_t)
3847 END IF
3848 ! Corrections for G=0 to potential, field and field gradient
3849 IF (do_efield .AND. (debug_e_field_en .OR. (.NOT. debug_this_module))) THEN
3850 ! This term is important and may give problems if one is debugging
3851 ! VS finite differences since it comes from a residual integral in
3852 ! the complex plane (cannot be reproduced with finite differences)
3853 node = 0
3854 DO iparticle_kind = 1, nparticle_kind
3855 nparticle_local = local_particles%n_el(iparticle_kind)
3856 DO iparticle_local = 1, nparticle_local
3857 node = node + 1
3858 iparticle = local_particles%list(iparticle_kind)%array(iparticle_local)
3859
3860 ! Potential
3861 IF (do_efield0) THEN
3862 efield0(iparticle) = efield0(iparticle)
3863 END IF
3864 ! Electrostatic field
3865 IF (do_efield1) THEN
3866 efield1(1:3, iparticle) = efield1(1:3, iparticle) - (1.0_dp/6.0_dp)*dipole_t(1:3)
3867 END IF
3868 ! Electrostatic field gradients
3869 IF (do_efield2) THEN
3870 efield2(1, iparticle) = efield2(1, iparticle) - (1.0_dp/(18.0_dp))*q_t
3871 efield2(5, iparticle) = efield2(5, iparticle) - (1.0_dp/(18.0_dp))*q_t
3872 efield2(9, iparticle) = efield2(9, iparticle) - (1.0_dp/(18.0_dp))*q_t
3873 END IF
3874 END DO
3875 END DO
3876 END IF
3877 cycle
3878 END IF
3879 gauss = (rho0(lp, mp, np)*pw_grid%vol)**2/pw_grid%gsq(gpt)
3880 factor = gauss*real(summe_ef(gpt)*conjg(summe_ef(gpt)), kind=dp)
3881 energy = energy + factor
3882
3883 IF (do_forces .OR. do_efield) THEN
3884 node = 0
3885 DO iparticle_kind = 1, nparticle_kind
3886 nparticle_local = local_particles%n_el(iparticle_kind)
3887 DO iparticle_local = 1, nparticle_local
3888 node = node + 1
3889 iparticle = local_particles%list(iparticle_kind)%array(iparticle_local)
3890 fac = exp_igr%ex(lp, node)*exp_igr%ey(mp, node)*exp_igr%ez(np, node)
3891 cnjg_fac = conjg(fac)
3892
3893 ! Forces
3894 IF (do_forces) THEN
3895 CALL get_atom_factor(atm_factor, pw_grid, gpt, iparticle, task, charges, &
3896 dipoles, quadrupoles)
3897
3898 tmp = gauss*aimag(summe_ef(gpt)*(cnjg_fac*conjg(atm_factor)))
3899 forces(1, node) = forces(1, node) + tmp*pw_grid%g(1, gpt)
3900 forces(2, node) = forces(2, node) + tmp*pw_grid%g(2, gpt)
3901 forces(3, node) = forces(3, node) + tmp*pw_grid%g(3, gpt)
3902 END IF
3903
3904 ! Electric field
3905 IF (do_efield) THEN
3906 ! Potential
3907 IF (do_efield0) THEN
3908 efield0(iparticle) = efield0(iparticle) + gauss*real(fac*conjg(summe_ef(gpt)), kind=dp)
3909 END IF
3910 ! Electric field
3911 IF (do_efield1) THEN
3912 tmp = aimag(fac*conjg(summe_ef(gpt)))*gauss
3913 efield1(1, iparticle) = efield1(1, iparticle) - tmp*pw_grid%g(1, gpt)
3914 efield1(2, iparticle) = efield1(2, iparticle) - tmp*pw_grid%g(2, gpt)
3915 efield1(3, iparticle) = efield1(3, iparticle) - tmp*pw_grid%g(3, gpt)
3916 END IF
3917 ! Electric field gradient
3918 IF (do_efield2) THEN
3919 tmp_v(1) = real(fac*conjg(summe_ef(gpt)), kind=dp)*pw_grid%g(1, gpt)*gauss
3920 tmp_v(2) = real(fac*conjg(summe_ef(gpt)), kind=dp)*pw_grid%g(2, gpt)*gauss
3921 tmp_v(3) = real(fac*conjg(summe_ef(gpt)), kind=dp)*pw_grid%g(3, gpt)*gauss
3922
3923 efield2(1, iparticle) = efield2(1, iparticle) + tmp_v(1)*pw_grid%g(1, gpt)
3924 efield2(2, iparticle) = efield2(2, iparticle) + tmp_v(1)*pw_grid%g(2, gpt)
3925 efield2(3, iparticle) = efield2(3, iparticle) + tmp_v(1)*pw_grid%g(3, gpt)
3926 efield2(4, iparticle) = efield2(4, iparticle) + tmp_v(2)*pw_grid%g(1, gpt)
3927 efield2(5, iparticle) = efield2(5, iparticle) + tmp_v(2)*pw_grid%g(2, gpt)
3928 efield2(6, iparticle) = efield2(6, iparticle) + tmp_v(2)*pw_grid%g(3, gpt)
3929 efield2(7, iparticle) = efield2(7, iparticle) + tmp_v(3)*pw_grid%g(1, gpt)
3930 efield2(8, iparticle) = efield2(8, iparticle) + tmp_v(3)*pw_grid%g(2, gpt)
3931 efield2(9, iparticle) = efield2(9, iparticle) + tmp_v(3)*pw_grid%g(3, gpt)
3932 END IF
3933 END IF
3934 END DO
3935 END DO
3936 END IF
3937
3938 ! Compute the virial P*V
3939 IF (do_stress) THEN
3940 ! The Stress Tensor can be decomposed in two main components.
3941 ! The first one is just a normal ewald component for reciprocal space
3942 denom = 1.0_dp/four_alpha_sq + 1.0_dp/pw_grid%gsq(gpt)
3943 pv_tmp(1, 1) = pv_tmp(1, 1) + factor*(1.0_dp - 2.0_dp*pw_grid%g(1, gpt)*pw_grid%g(1, gpt)*denom)
3944 pv_tmp(1, 2) = pv_tmp(1, 2) - factor*(2.0_dp*pw_grid%g(1, gpt)*pw_grid%g(2, gpt)*denom)
3945 pv_tmp(1, 3) = pv_tmp(1, 3) - factor*(2.0_dp*pw_grid%g(1, gpt)*pw_grid%g(3, gpt)*denom)
3946 pv_tmp(2, 1) = pv_tmp(2, 1) - factor*(2.0_dp*pw_grid%g(2, gpt)*pw_grid%g(1, gpt)*denom)
3947 pv_tmp(2, 2) = pv_tmp(2, 2) + factor*(1.0_dp - 2.0_dp*pw_grid%g(2, gpt)*pw_grid%g(2, gpt)*denom)
3948 pv_tmp(2, 3) = pv_tmp(2, 3) - factor*(2.0_dp*pw_grid%g(2, gpt)*pw_grid%g(3, gpt)*denom)
3949 pv_tmp(3, 1) = pv_tmp(3, 1) - factor*(2.0_dp*pw_grid%g(3, gpt)*pw_grid%g(1, gpt)*denom)
3950 pv_tmp(3, 2) = pv_tmp(3, 2) - factor*(2.0_dp*pw_grid%g(3, gpt)*pw_grid%g(2, gpt)*denom)
3951 pv_tmp(3, 3) = pv_tmp(3, 3) + factor*(1.0_dp - 2.0_dp*pw_grid%g(3, gpt)*pw_grid%g(3, gpt)*denom)
3952 ! The second one can be written in the following way
3953 f0 = 2.0_dp*gauss
3954 pv_tmp(1, 1) = pv_tmp(1, 1) + f0*pw_grid%g(1, gpt)*real(summe_st(1, gpt)*conjg(summe_ef(gpt)), kind=dp)
3955 pv_tmp(1, 2) = pv_tmp(1, 2) + f0*pw_grid%g(1, gpt)*real(summe_st(2, gpt)*conjg(summe_ef(gpt)), kind=dp)
3956 pv_tmp(1, 3) = pv_tmp(1, 3) + f0*pw_grid%g(1, gpt)*real(summe_st(3, gpt)*conjg(summe_ef(gpt)), kind=dp)
3957 pv_tmp(2, 1) = pv_tmp(2, 1) + f0*pw_grid%g(2, gpt)*real(summe_st(1, gpt)*conjg(summe_ef(gpt)), kind=dp)
3958 pv_tmp(2, 2) = pv_tmp(2, 2) + f0*pw_grid%g(2, gpt)*real(summe_st(2, gpt)*conjg(summe_ef(gpt)), kind=dp)
3959 pv_tmp(2, 3) = pv_tmp(2, 3) + f0*pw_grid%g(2, gpt)*real(summe_st(3, gpt)*conjg(summe_ef(gpt)), kind=dp)
3960 pv_tmp(3, 1) = pv_tmp(3, 1) + f0*pw_grid%g(3, gpt)*real(summe_st(1, gpt)*conjg(summe_ef(gpt)), kind=dp)
3961 pv_tmp(3, 2) = pv_tmp(3, 2) + f0*pw_grid%g(3, gpt)*real(summe_st(2, gpt)*conjg(summe_ef(gpt)), kind=dp)
3962 pv_tmp(3, 3) = pv_tmp(3, 3) + f0*pw_grid%g(3, gpt)*real(summe_st(3, gpt)*conjg(summe_ef(gpt)), kind=dp)
3963 END IF
3964 END DO
3965 pref = fourpi/pw_grid%vol
3966 energy = energy*pref
3967
3968 CALL structure_factor_deallocate(exp_igr)
3969 DEALLOCATE (summe_ef)
3970 IF (do_stress) THEN
3971 pv_tmp = pv_tmp*pref
3972 ! Symmetrize the tensor
3973 pv(1, 1) = pv(1, 1) + pv_tmp(1, 1)
3974 pv(1, 2) = pv(1, 2) + (pv_tmp(1, 2) + pv_tmp(2, 1))*0.5_dp
3975 pv(1, 3) = pv(1, 3) + (pv_tmp(1, 3) + pv_tmp(3, 1))*0.5_dp
3976 pv(2, 1) = pv(1, 2)
3977 pv(2, 2) = pv(2, 2) + pv_tmp(2, 2)
3978 pv(2, 3) = pv(2, 3) + (pv_tmp(2, 3) + pv_tmp(3, 2))*0.5_dp
3979 pv(3, 1) = pv(1, 3)
3980 pv(3, 2) = pv(2, 3)
3981 pv(3, 3) = pv(3, 3) + pv_tmp(3, 3)
3982 DEALLOCATE (summe_st)
3983 END IF
3984 IF (do_forces) THEN
3985 forces = 2.0_dp*forces*pref
3986 END IF
3987 IF (do_efield0) THEN
3988 efield0 = 2.0_dp*efield0*pref
3989 END IF
3990 IF (do_efield1) THEN
3991 efield1 = 2.0_dp*efield1*pref
3992 END IF
3993 IF (do_efield2) THEN
3994 efield2 = 2.0_dp*efield2*pref
3995 END IF
3996 CALL timestop(handle)
3997
3998 END SUBROUTINE ewald_multipole_lr
3999
4000! **************************************************************************************************
4001!> \brief Computes the atom factor including charge, dipole and quadrupole
4002!> \param atm_factor ...
4003!> \param pw_grid ...
4004!> \param gpt ...
4005!> \param iparticle ...
4006!> \param task ...
4007!> \param charges ...
4008!> \param dipoles ...
4009!> \param quadrupoles ...
4010!> \par History
4011!> none
4012!> \author Teodoro Laino [tlaino] - 12.2007 - University of Zurich
4013! **************************************************************************************************
4014 SUBROUTINE get_atom_factor(atm_factor, pw_grid, gpt, iparticle, task, charges, &
4015 dipoles, quadrupoles)
4016 COMPLEX(KIND=dp), INTENT(OUT) :: atm_factor
4017 TYPE(pw_grid_type), POINTER :: pw_grid
4018 INTEGER, INTENT(IN) :: gpt
4019 INTEGER :: iparticle
4020 LOGICAL, DIMENSION(3, 3), INTENT(IN) :: task
4021 REAL(kind=dp), DIMENSION(:), OPTIONAL, POINTER :: charges
4022 REAL(kind=dp), DIMENSION(:, :), OPTIONAL, POINTER :: dipoles
4023 REAL(kind=dp), DIMENSION(:, :, :), OPTIONAL, &
4024 POINTER :: quadrupoles
4025
4026 COMPLEX(KIND=dp) :: tmp
4027 INTEGER :: i, j
4028
4029 atm_factor = cmplx(0.0_dp, 0.0_dp, kind=dp)
4030 IF (task(1, 1)) THEN
4031 ! Charge
4032 atm_factor = atm_factor + charges(iparticle)
4033 END IF
4034 IF (task(2, 2)) THEN
4035 ! Dipole
4036 tmp = cmplx(0.0_dp, 0.0_dp, kind=dp)
4037 DO i = 1, 3
4038 tmp = tmp + dipoles(i, iparticle)*pw_grid%g(i, gpt)
4039 END DO
4040 atm_factor = atm_factor + tmp*cmplx(0.0_dp, -1.0_dp, kind=dp)
4041 END IF
4042 IF (task(3, 3)) THEN
4043 ! Quadrupole
4044 tmp = cmplx(0.0_dp, 0.0_dp, kind=dp)
4045 DO i = 1, 3
4046 DO j = 1, 3
4047 tmp = tmp + quadrupoles(j, i, iparticle)*pw_grid%g(j, gpt)*pw_grid%g(i, gpt)
4048 END DO
4049 END DO
4050 atm_factor = atm_factor - 1.0_dp/3.0_dp*tmp
4051 END IF
4052
4053 END SUBROUTINE get_atom_factor
4054
4055! **************************************************************************************************
4056!> \brief Computes the atom factor including charge, dipole and quadrupole
4057!> \param atm_factor ...
4058!> \param pw_grid ...
4059!> \param gpt ...
4060!> \param iparticle ...
4061!> \param task ...
4062!> \param dipoles ...
4063!> \param quadrupoles ...
4064!> \par History
4065!> none
4066!> \author Teodoro Laino [tlaino] - 12.2007 - University of Zurich
4067! **************************************************************************************************
4068 SUBROUTINE get_atom_factor_stress(atm_factor, pw_grid, gpt, iparticle, task, &
4069 dipoles, quadrupoles)
4070 COMPLEX(KIND=dp), INTENT(OUT) :: atm_factor(3)
4071 TYPE(pw_grid_type), POINTER :: pw_grid
4072 INTEGER, INTENT(IN) :: gpt
4073 INTEGER :: iparticle
4074 LOGICAL, DIMENSION(3, 3), INTENT(IN) :: task
4075 REAL(kind=dp), DIMENSION(:, :), OPTIONAL, POINTER :: dipoles
4076 REAL(kind=dp), DIMENSION(:, :, :), OPTIONAL, &
4077 POINTER :: quadrupoles
4078
4079 INTEGER :: i
4080
4081 atm_factor = cmplx(0.0_dp, 0.0_dp, kind=dp)
4082 IF (any(task(2, :))) THEN
4083 ! Dipole
4084 atm_factor = dipoles(:, iparticle)*cmplx(0.0_dp, -1.0_dp, kind=dp)
4085 END IF
4086 IF (any(task(3, :))) THEN
4087 ! Quadrupole
4088 DO i = 1, 3
4089 atm_factor(1) = atm_factor(1) - 1.0_dp/3.0_dp* &
4090 (quadrupoles(1, i, iparticle)*pw_grid%g(i, gpt) + &
4091 quadrupoles(i, 1, iparticle)*pw_grid%g(i, gpt))
4092 atm_factor(2) = atm_factor(2) - 1.0_dp/3.0_dp* &
4093 (quadrupoles(2, i, iparticle)*pw_grid%g(i, gpt) + &
4094 quadrupoles(i, 2, iparticle)*pw_grid%g(i, gpt))
4095 atm_factor(3) = atm_factor(3) - 1.0_dp/3.0_dp* &
4096 (quadrupoles(3, i, iparticle)*pw_grid%g(i, gpt) + &
4097 quadrupoles(i, 3, iparticle)*pw_grid%g(i, gpt))
4098 END DO
4099 END IF
4100
4101 END SUBROUTINE get_atom_factor_stress
4102
4103! **************************************************************************************************
4104!> \brief Computes the self interaction from g-space and the neutralizing background
4105!> when using multipoles
4106!> \param ewald_env ...
4107!> \param cell ...
4108!> \param local_particles ...
4109!> \param e_self ...
4110!> \param e_neut ...
4111!> \param task ...
4112!> \param do_efield ...
4113!> \param radii ...
4114!> \param charges ...
4115!> \param dipoles ...
4116!> \param quadrupoles ...
4117!> \param efield0 ...
4118!> \param efield1 ...
4119!> \param efield2 ...
4120!> \author Teodoro Laino [tlaino] - University of Zurich - 12.2007
4121! **************************************************************************************************
4122 SUBROUTINE ewald_multipole_self(ewald_env, cell, local_particles, e_self, &
4123 e_neut, task, do_efield, radii, charges, dipoles, quadrupoles, efield0, &
4124 efield1, efield2)
4125 TYPE(ewald_environment_type), POINTER :: ewald_env
4126 TYPE(cell_type), POINTER :: cell
4127 TYPE(distribution_1d_type), POINTER :: local_particles
4128 REAL(kind=dp), INTENT(OUT) :: e_self, e_neut
4129 LOGICAL, DIMENSION(3, 3), INTENT(IN) :: task
4130 LOGICAL, INTENT(IN) :: do_efield
4131 REAL(kind=dp), DIMENSION(:), OPTIONAL, POINTER :: radii, charges
4132 REAL(kind=dp), DIMENSION(:, :), OPTIONAL, POINTER :: dipoles
4133 REAL(kind=dp), DIMENSION(:, :, :), OPTIONAL, &
4134 POINTER :: quadrupoles
4135 REAL(kind=dp), DIMENSION(:), POINTER :: efield0
4136 REAL(kind=dp), DIMENSION(:, :), POINTER :: efield1, efield2
4137
4138 REAL(kind=dp), PARAMETER :: f23 = 2.0_dp/3.0_dp, &
4139 f415 = 4.0_dp/15.0_dp
4140
4141 INTEGER :: ewald_type, i, iparticle, &
4142 iparticle_kind, iparticle_local, j, &
4143 nparticle_local
4144 LOGICAL :: do_efield0, do_efield1, do_efield2, &
4145 lradii
4146 REAL(kind=dp) :: alpha, ch_qu_self, ch_qu_self_tmp, &
4147 dipole_self, fac1, fac2, fac3, fac4, &
4148 q, q_neutg, q_self, q_sum, qu_qu_self, &
4149 radius
4150 TYPE(mp_comm_type) :: group
4151
4152 CALL ewald_env_get(ewald_env, ewald_type=ewald_type, alpha=alpha, &
4153 group=group)
4154
4155 do_efield0 = do_efield .AND. ASSOCIATED(efield0)
4156 do_efield1 = do_efield .AND. ASSOCIATED(efield1)
4157 do_efield2 = do_efield .AND. ASSOCIATED(efield2)
4158 q_self = 0.0_dp
4159 q_sum = 0.0_dp
4160 dipole_self = 0.0_dp
4161 ch_qu_self = 0.0_dp
4162 qu_qu_self = 0.0_dp
4163 fac1 = 2.0_dp*alpha*oorootpi
4164 fac2 = 6.0_dp*(f23**2)*(alpha**3)*oorootpi
4165 fac3 = (2.0_dp*oorootpi)*f23*alpha**3
4166 fac4 = (4.0_dp*oorootpi)*f415*alpha**5
4167 lradii = PRESENT(radii)
4168 radius = 0.0_dp
4169 q_neutg = 0.0_dp
4170 DO iparticle_kind = 1, SIZE(local_particles%n_el)
4171 nparticle_local = local_particles%n_el(iparticle_kind)
4172 DO iparticle_local = 1, nparticle_local
4173 iparticle = local_particles%list(iparticle_kind)%array(iparticle_local)
4174 IF (any(task(1, :))) THEN
4175 ! Charge - Charge
4176 q = charges(iparticle)
4177 IF (lradii) radius = radii(iparticle)
4178 IF (radius > 0) THEN
4179 q_neutg = q_neutg + 2.0_dp*q*radius**2
4180 END IF
4181 q_self = q_self + q*q
4182 q_sum = q_sum + q
4183 ! Potential
4184 IF (do_efield0) THEN
4185 efield0(iparticle) = efield0(iparticle) - q*fac1
4186 END IF
4187
4188 IF (task(1, 3)) THEN
4189 ! Charge - Quadrupole
4190 ch_qu_self_tmp = 0.0_dp
4191 DO i = 1, 3
4192 ch_qu_self_tmp = ch_qu_self_tmp + quadrupoles(i, i, iparticle)*q
4193 END DO
4194 ch_qu_self = ch_qu_self + ch_qu_self_tmp
4195 ! Electric Field Gradient
4196 IF (do_efield2) THEN
4197 efield2(1, iparticle) = efield2(1, iparticle) + fac2*q
4198 efield2(5, iparticle) = efield2(5, iparticle) + fac2*q
4199 efield2(9, iparticle) = efield2(9, iparticle) + fac2*q
4200 END IF
4201 END IF
4202 END IF
4203 IF (any(task(2, :))) THEN
4204 ! Dipole - Dipole
4205 DO i = 1, 3
4206 dipole_self = dipole_self + dipoles(i, iparticle)**2
4207 END DO
4208 ! Electric Field
4209 IF (do_efield1) THEN
4210 efield1(1, iparticle) = efield1(1, iparticle) + fac3*dipoles(1, iparticle)
4211 efield1(2, iparticle) = efield1(2, iparticle) + fac3*dipoles(2, iparticle)
4212 efield1(3, iparticle) = efield1(3, iparticle) + fac3*dipoles(3, iparticle)
4213 END IF
4214 END IF
4215 IF (any(task(3, :))) THEN
4216 ! Quadrupole - Quadrupole
4217 DO i = 1, 3
4218 DO j = 1, 3
4219 qu_qu_self = qu_qu_self + quadrupoles(j, i, iparticle)**2
4220 END DO
4221 END DO
4222 ! Electric Field Gradient
4223 IF (do_efield2) THEN
4224 efield2(1, iparticle) = efield2(1, iparticle) + fac4*quadrupoles(1, 1, iparticle)
4225 efield2(2, iparticle) = efield2(2, iparticle) + fac4*quadrupoles(2, 1, iparticle)
4226 efield2(3, iparticle) = efield2(3, iparticle) + fac4*quadrupoles(3, 1, iparticle)
4227 efield2(4, iparticle) = efield2(4, iparticle) + fac4*quadrupoles(1, 2, iparticle)
4228 efield2(5, iparticle) = efield2(5, iparticle) + fac4*quadrupoles(2, 2, iparticle)
4229 efield2(6, iparticle) = efield2(6, iparticle) + fac4*quadrupoles(3, 2, iparticle)
4230 efield2(7, iparticle) = efield2(7, iparticle) + fac4*quadrupoles(1, 3, iparticle)
4231 efield2(8, iparticle) = efield2(8, iparticle) + fac4*quadrupoles(2, 3, iparticle)
4232 efield2(9, iparticle) = efield2(9, iparticle) + fac4*quadrupoles(3, 3, iparticle)
4233 END IF
4234 END IF
4235 END DO
4236 END DO
4237
4238 CALL group%sum(q_neutg)
4239 CALL group%sum(q_self)
4240 CALL group%sum(q_sum)
4241 CALL group%sum(dipole_self)
4242 CALL group%sum(ch_qu_self)
4243 CALL group%sum(qu_qu_self)
4244
4245 e_self = -(q_self + f23*(dipole_self - f23*ch_qu_self + f415*qu_qu_self*alpha**2)*alpha**2)*alpha*oorootpi
4246 fac1 = pi/(2.0_dp*cell%deth)
4247 e_neut = -q_sum*fac1*(q_sum/alpha**2 - q_neutg)
4248
4249 ! Correcting Potential for the neutralizing background charge
4250 DO iparticle_kind = 1, SIZE(local_particles%n_el)
4251 nparticle_local = local_particles%n_el(iparticle_kind)
4252 DO iparticle_local = 1, nparticle_local
4253 iparticle = local_particles%list(iparticle_kind)%array(iparticle_local)
4254 IF (any(task(1, :))) THEN
4255 ! Potential energy
4256 IF (do_efield0) THEN
4257 efield0(iparticle) = efield0(iparticle) - q_sum*2.0_dp*fac1/alpha**2
4258 IF (lradii) radius = radii(iparticle)
4259 IF (radius > 0) THEN
4260 q = charges(iparticle)
4261 efield0(iparticle) = efield0(iparticle) + fac1*radius**2*(q_sum + q)
4262 END IF
4263 END IF
4264 END IF
4265 END DO
4266 END DO
4267
4268 END SUBROUTINE ewald_multipole_self
4269
4270! **************************************************************************************************
4271!> \brief ...
4272!> \param iw ...
4273!> \param e_gspace ...
4274!> \param e_rspace ...
4275!> \param e_bonded ...
4276!> \param e_self ...
4277!> \param e_neut ...
4278!> \author Teodoro Laino [tlaino] - University of Zurich - 12.2007
4279! **************************************************************************************************
4280 SUBROUTINE ewald_multipole_print(iw, e_gspace, e_rspace, e_bonded, e_self, e_neut)
4281
4282 INTEGER, INTENT(IN) :: iw
4283 REAL(kind=dp), INTENT(IN) :: e_gspace, e_rspace, e_bonded, e_self, &
4284 e_neut
4285
4286 IF (iw > 0) THEN
4287 WRITE (iw, '( A, A )') ' *********************************', &
4288 '**********************************************'
4289 WRITE (iw, '( A, A, T35, A, T56, E25.15 )') ' INITIAL GSPACE ENERGY', &
4290 '[hartree]', '= ', e_gspace
4291 WRITE (iw, '( A, A, T35, A, T56, E25.15 )') ' INITIAL RSPACE ENERGY', &
4292 '[hartree]', '= ', e_rspace
4293 WRITE (iw, '( A, A, T35, A, T56, E25.15 )') ' BONDED CORRECTION', &
4294 '[hartree]', '= ', e_bonded
4295 WRITE (iw, '( A, A, T35, A, T56, E25.15 )') ' SELF ENERGY CORRECTION', &
4296 '[hartree]', '= ', e_self
4297 WRITE (iw, '( A, A, T35, A, T56, E25.15 )') ' NEUTRALIZ. BCKGR. ENERGY', &
4298 '[hartree]', '= ', e_neut
4299 WRITE (iw, '( A, A, T35, A, T56, E25.15 )') ' TOTAL ELECTROSTATIC EN.', &
4300 '[hartree]', '= ', e_rspace + e_bonded + e_gspace + e_self + e_neut
4301 WRITE (iw, '( A, A )') ' *********************************', &
4302 '**********************************************'
4303 END IF
4304 END SUBROUTINE ewald_multipole_print
4305
4306! **************************************************************************************************
4307!> \brief Debug routines for multipoles
4308!> \param ewald_env ...
4309!> \param ewald_pw ...
4310!> \param nonbond_env ...
4311!> \param cell ...
4312!> \param particle_set ...
4313!> \param local_particles ...
4314!> \param iw ...
4315!> \param debug_r_space ...
4316!> \date 05.2008
4317!> \author Teodoro Laino [tlaino] - University of Zurich - 05.2008
4318! **************************************************************************************************
4319 SUBROUTINE debug_ewald_multipoles(ewald_env, ewald_pw, nonbond_env, cell, &
4320 particle_set, local_particles, iw, debug_r_space)
4321 TYPE charge_mono_type
4322 REAL(kind=dp), DIMENSION(:), &
4323 POINTER :: charge
4324 REAL(kind=dp), DIMENSION(:, :), &
4325 POINTER :: pos
4326 END TYPE charge_mono_type
4327 TYPE multi_charge_type
4328 TYPE(charge_mono_type), DIMENSION(:), &
4329 POINTER :: charge_typ
4330 END TYPE multi_charge_type
4331 TYPE(ewald_environment_type), POINTER :: ewald_env
4332 TYPE(ewald_pw_type), POINTER :: ewald_pw
4333 TYPE(fist_nonbond_env_type), POINTER :: nonbond_env
4334 TYPE(cell_type), POINTER :: cell
4335 TYPE(particle_type), DIMENSION(:), &
4336 POINTER :: particle_set
4337 TYPE(distribution_1d_type), POINTER :: local_particles
4338 INTEGER, INTENT(IN) :: iw
4339 LOGICAL, INTENT(IN) :: debug_r_space
4340
4341 INTEGER :: nparticles
4342 LOGICAL, DIMENSION(3) :: task
4343 REAL(kind=dp) :: e_neut, e_self, g_energy, &
4344 r_energy, debug_energy
4345 REAL(kind=dp), POINTER, DIMENSION(:) :: charges
4346 REAL(kind=dp), POINTER, &
4347 DIMENSION(:, :) :: dipoles, g_forces, g_pv, &
4348 r_forces, r_pv, e_field1, &
4349 e_field2
4350 REAL(kind=dp), POINTER, &
4351 DIMENSION(:, :, :) :: quadrupoles
4352 TYPE(rng_stream_type) :: random_stream
4353 TYPE(multi_charge_type), DIMENSION(:), &
4354 POINTER :: multipoles
4355
4356 NULLIFY (multipoles, charges, dipoles, g_forces, g_pv, &
4357 r_forces, r_pv, e_field1, e_field2)
4358 random_stream = rng_stream_type(name="DEBUG_EWALD_MULTIPOLE", &
4359 distribution_type=uniform)
4360 ! check: charge - charge
4361 task = .false.
4362 nparticles = SIZE(particle_set)
4363
4364 ! Allocate charges, dipoles, quadrupoles
4365 ALLOCATE (charges(nparticles))
4366 ALLOCATE (dipoles(3, nparticles))
4367 ALLOCATE (quadrupoles(3, 3, nparticles))
4368
4369 ! Allocate arrays for forces
4370 ALLOCATE (r_forces(3, nparticles))
4371 ALLOCATE (g_forces(3, nparticles))
4372 ALLOCATE (e_field1(3, nparticles))
4373 ALLOCATE (e_field2(3, nparticles))
4374 ALLOCATE (g_pv(3, 3))
4375 ALLOCATE (r_pv(3, 3))
4376
4377 ! Debug CHARGES-CHARGES
4378 task(1) = .true.
4379 charges = 0.0_dp
4380 dipoles = 0.0_dp
4381 quadrupoles = 0.0_dp
4382 r_forces = 0.0_dp
4383 g_forces = 0.0_dp
4384 e_field1 = 0.0_dp
4385 e_field2 = 0.0_dp
4386 g_pv = 0.0_dp
4387 r_pv = 0.0_dp
4388 g_energy = 0.0_dp
4389 r_energy = 0.0_dp
4390 e_neut = 0.0_dp
4391 e_self = 0.0_dp
4392
4393 CALL create_multi_type(multipoles, nparticles, 1, nparticles/2, "CHARGE", echarge=-1.0_dp, &
4394 random_stream=random_stream, charges=charges)
4395 CALL create_multi_type(multipoles, nparticles, nparticles/2 + 1, nparticles, "CHARGE", echarge=1.0_dp, &
4396 random_stream=random_stream, charges=charges)
4397 CALL debug_ewald_multipole_low(particle_set, cell, nonbond_env, multipoles, debug_energy, &
4398 debug_r_space)
4399
4400 WRITE (iw, *) "DEBUG ENERGY (CHARGE-CHARGE): ", debug_energy
4401 CALL ewald_multipole_evaluate(ewald_env, ewald_pw, nonbond_env, cell, &
4402 particle_set, local_particles, g_energy, r_energy, e_neut, e_self, &
4403 task, do_correction_bonded=.false., do_forces=.true., do_stress=.true., do_efield=.false., &
4404 charges=charges, dipoles=dipoles, quadrupoles=quadrupoles, forces_local=g_forces, &
4405 forces_glob=r_forces, pv_local=g_pv, pv_glob=r_pv, iw=iw, do_debug=.false.)
4406 CALL release_multi_type(multipoles)
4407
4408 ! Debug CHARGES-DIPOLES
4409 task(1) = .true.
4410 task(2) = .true.
4411 charges = 0.0_dp
4412 dipoles = 0.0_dp
4413 quadrupoles = 0.0_dp
4414 r_forces = 0.0_dp
4415 g_forces = 0.0_dp
4416 e_field1 = 0.0_dp
4417 e_field2 = 0.0_dp
4418 g_pv = 0.0_dp
4419 r_pv = 0.0_dp
4420 g_energy = 0.0_dp
4421 r_energy = 0.0_dp
4422 e_neut = 0.0_dp
4423 e_self = 0.0_dp
4424
4425 CALL create_multi_type(multipoles, nparticles, 1, nparticles/2, "CHARGE", echarge=-1.0_dp, &
4426 random_stream=random_stream, charges=charges)
4427 CALL create_multi_type(multipoles, nparticles, nparticles/2 + 1, nparticles, "DIPOLE", echarge=0.5_dp, &
4428 random_stream=random_stream, dipoles=dipoles)
4429 WRITE (iw, '("CHARGES",F15.9)') charges
4430 WRITE (iw, '("DIPOLES",3F15.9)') dipoles
4431 CALL debug_ewald_multipole_low(particle_set, cell, nonbond_env, multipoles, debug_energy, &
4432 debug_r_space)
4433
4434 WRITE (iw, *) "DEBUG ENERGY (CHARGE-DIPOLE): ", debug_energy
4435 CALL ewald_multipole_evaluate(ewald_env, ewald_pw, nonbond_env, cell, &
4436 particle_set, local_particles, g_energy, r_energy, e_neut, e_self, &
4437 task, do_correction_bonded=.false., do_forces=.true., do_stress=.true., do_efield=.false., &
4438 charges=charges, dipoles=dipoles, quadrupoles=quadrupoles, forces_local=g_forces, &
4439 forces_glob=r_forces, pv_local=g_pv, pv_glob=r_pv, iw=iw, do_debug=.false.)
4440 CALL release_multi_type(multipoles)
4441
4442 ! Debug DIPOLES-DIPOLES
4443 task(2) = .true.
4444 charges = 0.0_dp
4445 dipoles = 0.0_dp
4446 quadrupoles = 0.0_dp
4447 r_forces = 0.0_dp
4448 g_forces = 0.0_dp
4449 e_field1 = 0.0_dp
4450 e_field2 = 0.0_dp
4451 g_pv = 0.0_dp
4452 r_pv = 0.0_dp
4453 g_energy = 0.0_dp
4454 r_energy = 0.0_dp
4455 e_neut = 0.0_dp
4456 e_self = 0.0_dp
4457
4458 CALL create_multi_type(multipoles, nparticles, 1, nparticles/2, "DIPOLE", echarge=10000.0_dp, &
4459 random_stream=random_stream, dipoles=dipoles)
4460 CALL create_multi_type(multipoles, nparticles, nparticles/2 + 1, nparticles, "DIPOLE", echarge=20000._dp, &
4461 random_stream=random_stream, dipoles=dipoles)
4462 WRITE (iw, '("DIPOLES",3F15.9)') dipoles
4463 CALL debug_ewald_multipole_low(particle_set, cell, nonbond_env, multipoles, debug_energy, &
4464 debug_r_space)
4465
4466 WRITE (iw, *) "DEBUG ENERGY (DIPOLE-DIPOLE): ", debug_energy
4467 CALL ewald_multipole_evaluate(ewald_env, ewald_pw, nonbond_env, cell, &
4468 particle_set, local_particles, g_energy, r_energy, e_neut, e_self, &
4469 task, do_correction_bonded=.false., do_forces=.true., do_stress=.true., do_efield=.false., &
4470 charges=charges, dipoles=dipoles, quadrupoles=quadrupoles, forces_local=g_forces, &
4471 forces_glob=r_forces, pv_local=g_pv, pv_glob=r_pv, iw=iw, do_debug=.false.)
4472 CALL release_multi_type(multipoles)
4473
4474 ! Debug CHARGES-QUADRUPOLES
4475 task(1) = .true.
4476 task(3) = .true.
4477 charges = 0.0_dp
4478 dipoles = 0.0_dp
4479 quadrupoles = 0.0_dp
4480 r_forces = 0.0_dp
4481 g_forces = 0.0_dp
4482 e_field1 = 0.0_dp
4483 e_field2 = 0.0_dp
4484 g_pv = 0.0_dp
4485 r_pv = 0.0_dp
4486 g_energy = 0.0_dp
4487 r_energy = 0.0_dp
4488 e_neut = 0.0_dp
4489 e_self = 0.0_dp
4490
4491 CALL create_multi_type(multipoles, nparticles, 1, nparticles/2, "CHARGE", echarge=-1.0_dp, &
4492 random_stream=random_stream, charges=charges)
4493 CALL create_multi_type(multipoles, nparticles, nparticles/2 + 1, nparticles, "QUADRUPOLE", echarge=10.0_dp, &
4494 random_stream=random_stream, quadrupoles=quadrupoles)
4495 WRITE (iw, '("CHARGES",F15.9)') charges
4496 WRITE (iw, '("QUADRUPOLES",9F15.9)') quadrupoles
4497 CALL debug_ewald_multipole_low(particle_set, cell, nonbond_env, multipoles, debug_energy, &
4498 debug_r_space)
4499
4500 WRITE (iw, *) "DEBUG ENERGY (CHARGE-QUADRUPOLE): ", debug_energy
4501 CALL ewald_multipole_evaluate(ewald_env, ewald_pw, nonbond_env, cell, &
4502 particle_set, local_particles, g_energy, r_energy, e_neut, e_self, &
4503 task, do_correction_bonded=.false., do_forces=.true., do_stress=.true., do_efield=.false., &
4504 charges=charges, dipoles=dipoles, quadrupoles=quadrupoles, forces_local=g_forces, &
4505 forces_glob=r_forces, pv_local=g_pv, pv_glob=r_pv, iw=iw, do_debug=.false.)
4506 CALL release_multi_type(multipoles)
4507
4508 ! Debug DIPOLES-QUADRUPOLES
4509 task(2) = .true.
4510 task(3) = .true.
4511 charges = 0.0_dp
4512 dipoles = 0.0_dp
4513 quadrupoles = 0.0_dp
4514 r_forces = 0.0_dp
4515 g_forces = 0.0_dp
4516 e_field1 = 0.0_dp
4517 e_field2 = 0.0_dp
4518 g_pv = 0.0_dp
4519 r_pv = 0.0_dp
4520 g_energy = 0.0_dp
4521 r_energy = 0.0_dp
4522 e_neut = 0.0_dp
4523 e_self = 0.0_dp
4524
4525 CALL create_multi_type(multipoles, nparticles, 1, nparticles/2, "DIPOLE", echarge=10000.0_dp, &
4526 random_stream=random_stream, dipoles=dipoles)
4527 CALL create_multi_type(multipoles, nparticles, nparticles/2 + 1, nparticles, "QUADRUPOLE", echarge=10000.0_dp, &
4528 random_stream=random_stream, quadrupoles=quadrupoles)
4529 WRITE (iw, '("DIPOLES",3F15.9)') dipoles
4530 WRITE (iw, '("QUADRUPOLES",9F15.9)') quadrupoles
4531 CALL debug_ewald_multipole_low(particle_set, cell, nonbond_env, multipoles, debug_energy, &
4532 debug_r_space)
4533
4534 WRITE (iw, *) "DEBUG ENERGY (DIPOLE-QUADRUPOLE): ", debug_energy
4535 CALL ewald_multipole_evaluate(ewald_env, ewald_pw, nonbond_env, cell, &
4536 particle_set, local_particles, g_energy, r_energy, e_neut, e_self, &
4537 task, do_correction_bonded=.false., do_forces=.true., do_stress=.true., do_efield=.false., &
4538 charges=charges, dipoles=dipoles, quadrupoles=quadrupoles, forces_local=g_forces, &
4539 forces_glob=r_forces, pv_local=g_pv, pv_glob=r_pv, iw=iw, do_debug=.false.)
4540 CALL release_multi_type(multipoles)
4541
4542 ! Debug QUADRUPOLES-QUADRUPOLES
4543 task(3) = .true.
4544 charges = 0.0_dp
4545 dipoles = 0.0_dp
4546 quadrupoles = 0.0_dp
4547 r_forces = 0.0_dp
4548 g_forces = 0.0_dp
4549 e_field1 = 0.0_dp
4550 e_field2 = 0.0_dp
4551 g_pv = 0.0_dp
4552 r_pv = 0.0_dp
4553 g_energy = 0.0_dp
4554 r_energy = 0.0_dp
4555 e_neut = 0.0_dp
4556 e_self = 0.0_dp
4557
4558 CALL create_multi_type(multipoles, nparticles, 1, nparticles/2, "QUADRUPOLE", echarge=-20000.0_dp, &
4559 random_stream=random_stream, quadrupoles=quadrupoles)
4560 CALL create_multi_type(multipoles, nparticles, nparticles/2 + 1, nparticles, "QUADRUPOLE", echarge=10000.0_dp, &
4561 random_stream=random_stream, quadrupoles=quadrupoles)
4562 WRITE (iw, '("QUADRUPOLES",9F15.9)') quadrupoles
4563 CALL debug_ewald_multipole_low(particle_set, cell, nonbond_env, multipoles, debug_energy, &
4564 debug_r_space)
4565
4566 WRITE (iw, *) "DEBUG ENERGY (QUADRUPOLE-QUADRUPOLE): ", debug_energy
4567 CALL ewald_multipole_evaluate(ewald_env, ewald_pw, nonbond_env, cell, &
4568 particle_set, local_particles, g_energy, r_energy, e_neut, e_self, &
4569 task, do_correction_bonded=.false., do_forces=.true., do_stress=.true., do_efield=.false., &
4570 charges=charges, dipoles=dipoles, quadrupoles=quadrupoles, forces_local=g_forces, &
4571 forces_glob=r_forces, pv_local=g_pv, pv_glob=r_pv, iw=iw, do_debug=.false.)
4572 CALL release_multi_type(multipoles)
4573
4574 DEALLOCATE (charges)
4575 DEALLOCATE (dipoles)
4576 DEALLOCATE (quadrupoles)
4577 DEALLOCATE (r_forces)
4578 DEALLOCATE (g_forces)
4579 DEALLOCATE (e_field1)
4580 DEALLOCATE (e_field2)
4581 DEALLOCATE (g_pv)
4582 DEALLOCATE (r_pv)
4583
4584 CONTAINS
4585! **************************************************************************************************
4586!> \brief Debug routines for multipoles - low level - charge interactions
4587!> \param particle_set ...
4588!> \param cell ...
4589!> \param nonbond_env ...
4590!> \param multipoles ...
4591!> \param energy ...
4592!> \param debug_r_space ...
4593!> \date 05.2008
4594!> \author Teodoro Laino [tlaino] - University of Zurich - 05.2008
4595! **************************************************************************************************
4596 SUBROUTINE debug_ewald_multipole_low(particle_set, cell, nonbond_env, multipoles, &
4597 energy, debug_r_space)
4598 TYPE(particle_type), DIMENSION(:), POINTER :: particle_set
4599 TYPE(cell_type), POINTER :: cell
4600 TYPE(fist_nonbond_env_type), POINTER :: nonbond_env
4601 TYPE(multi_charge_type), DIMENSION(:), POINTER :: multipoles
4602 REAL(kind=dp), INTENT(OUT) :: energy
4603 LOGICAL, INTENT(IN) :: debug_r_space
4604
4605 INTEGER :: atom_a, atom_b, icell, iend, igrp, &
4606 ikind, ilist, ipair, istart, jcell, &
4607 jkind, k, k1, kcell, l, l1, ncells, &
4608 nkinds, npairs
4609 INTEGER, DIMENSION(:, :), POINTER :: list
4610 REAL(kind=dp) :: fac_ij, q, r, rab2, rab2_max
4611 REAL(kind=dp), DIMENSION(3) :: cell_v, cvi, rab, rab0, rm
4612 TYPE(fist_neighbor_type), POINTER :: nonbonded
4613 TYPE(neighbor_kind_pairs_type), POINTER :: neighbor_kind_pair
4614 TYPE(pos_type), DIMENSION(:), POINTER :: r_last_update, r_last_update_pbc
4615
4616 energy = 0.0_dp
4617 CALL fist_nonbond_env_get(nonbond_env, nonbonded=nonbonded, natom_types=nkinds, &
4618 r_last_update=r_last_update, r_last_update_pbc=r_last_update_pbc)
4619 rab2_max = huge(0.0_dp)
4620 IF (debug_r_space) THEN
4621 ! This debugs the real space part of the multipole Ewald summation scheme
4622 ! Starting the force loop
4623 lists: DO ilist = 1, nonbonded%nlists
4624 neighbor_kind_pair => nonbonded%neighbor_kind_pairs(ilist)
4625 npairs = neighbor_kind_pair%npairs
4626 IF (npairs == 0) cycle
4627 list => neighbor_kind_pair%list
4628 cvi = neighbor_kind_pair%cell_vector
4629 cell_v = matmul(cell%hmat, cvi)
4630 kind_group_loop: DO igrp = 1, neighbor_kind_pair%ngrp_kind
4631 istart = neighbor_kind_pair%grp_kind_start(igrp)
4632 iend = neighbor_kind_pair%grp_kind_end(igrp)
4633 ikind = neighbor_kind_pair%ij_kind(1, igrp)
4634 jkind = neighbor_kind_pair%ij_kind(2, igrp)
4635 pairs: DO ipair = istart, iend
4636 fac_ij = 1.0_dp
4637 atom_a = list(1, ipair)
4638 atom_b = list(2, ipair)
4639 IF (atom_a == atom_b) fac_ij = 0.5_dp
4640 rab = r_last_update_pbc(atom_b)%r - r_last_update_pbc(atom_a)%r
4641 rab = rab + cell_v
4642 rab2 = rab(1)**2 + rab(2)**2 + rab(3)**2
4643 IF (rab2 <= rab2_max) THEN
4644
4645 DO k = 1, SIZE(multipoles(atom_a)%charge_typ)
4646 DO k1 = 1, SIZE(multipoles(atom_a)%charge_typ(k)%charge)
4647
4648 DO l = 1, SIZE(multipoles(atom_b)%charge_typ)
4649 DO l1 = 1, SIZE(multipoles(atom_b)%charge_typ(l)%charge)
4650
4651 rm = rab + multipoles(atom_b)%charge_typ(l)%pos(:, l1) - multipoles(atom_a)%charge_typ(k)%pos(:, k1)
4652 r = sqrt(dot_product(rm, rm))
4653 q = multipoles(atom_b)%charge_typ(l)%charge(l1)*multipoles(atom_a)%charge_typ(k)%charge(k1)
4654 energy = energy + q/r*fac_ij
4655 END DO
4656 END DO
4657
4658 END DO
4659 END DO
4660
4661 END IF
4662 END DO pairs
4663 END DO kind_group_loop
4664 END DO lists
4665 ELSE
4666 ncells = 6
4667 !Debugs the sum of real + space terms.. (Charge-Charge and Charge-Dipole should be anyway wrong but
4668 !all the other terms should be correct)
4669 DO atom_a = 1, SIZE(particle_set)
4670 DO atom_b = atom_a, SIZE(particle_set)
4671 fac_ij = 1.0_dp
4672 IF (atom_a == atom_b) fac_ij = 0.5_dp
4673 rab0 = r_last_update_pbc(atom_b)%r - r_last_update_pbc(atom_a)%r
4674 ! Loop over cells
4675 DO icell = -ncells, ncells
4676 DO jcell = -ncells, ncells
4677 DO kcell = -ncells, ncells
4678 cell_v = matmul(cell%hmat, real((/icell, jcell, kcell/), kind=dp))
4679 IF (all(cell_v == 0.0_dp) .AND. (atom_a == atom_b)) cycle
4680 rab = rab0 + cell_v
4681 rab2 = rab(1)**2 + rab(2)**2 + rab(3)**2
4682 IF (rab2 <= rab2_max) THEN
4683
4684 DO k = 1, SIZE(multipoles(atom_a)%charge_typ)
4685 DO k1 = 1, SIZE(multipoles(atom_a)%charge_typ(k)%charge)
4686
4687 DO l = 1, SIZE(multipoles(atom_b)%charge_typ)
4688 DO l1 = 1, SIZE(multipoles(atom_b)%charge_typ(l)%charge)
4689
4690 rm = rab + multipoles(atom_b)%charge_typ(l)%pos(:, l1) - multipoles(atom_a)%charge_typ(k)%pos(:, k1)
4691 r = sqrt(dot_product(rm, rm))
4692 q = multipoles(atom_b)%charge_typ(l)%charge(l1)*multipoles(atom_a)%charge_typ(k)%charge(k1)
4693 energy = energy + q/r*fac_ij
4694 END DO
4695 END DO
4696
4697 END DO
4698 END DO
4699
4700 END IF
4701 END DO
4702 END DO
4703 END DO
4704 END DO
4705 END DO
4706 END IF
4707 END SUBROUTINE debug_ewald_multipole_low
4708
4709! **************************************************************************************************
4710!> \brief create multi_type for multipoles
4711!> \param multipoles ...
4712!> \param idim ...
4713!> \param istart ...
4714!> \param iend ...
4715!> \param label ...
4716!> \param echarge ...
4717!> \param random_stream ...
4718!> \param charges ...
4719!> \param dipoles ...
4720!> \param quadrupoles ...
4721!> \date 05.2008
4722!> \author Teodoro Laino [tlaino] - University of Zurich - 05.2008
4723! **************************************************************************************************
4724 SUBROUTINE create_multi_type(multipoles, idim, istart, iend, label, echarge, &
4725 random_stream, charges, dipoles, quadrupoles)
4726 TYPE(multi_charge_type), DIMENSION(:), POINTER :: multipoles
4727 INTEGER, INTENT(IN) :: idim, istart, iend
4728 CHARACTER(LEN=*), INTENT(IN) :: label
4729 REAL(kind=dp), INTENT(IN) :: echarge
4730 TYPE(rng_stream_type), INTENT(INOUT) :: random_stream
4731 REAL(kind=dp), DIMENSION(:), OPTIONAL, POINTER :: charges
4732 REAL(kind=dp), DIMENSION(:, :), OPTIONAL, POINTER :: dipoles
4733 REAL(kind=dp), DIMENSION(:, :, :), OPTIONAL, &
4734 POINTER :: quadrupoles
4735
4736 INTEGER :: i, isize, k, l, m
4737 REAL(kind=dp) :: dx, r2, rvec(3), rvec1(3), rvec2(3)
4738
4739 IF (ASSOCIATED(multipoles)) THEN
4740 cpassert(SIZE(multipoles) == idim)
4741 ELSE
4742 ALLOCATE (multipoles(idim))
4743 DO i = 1, idim
4744 NULLIFY (multipoles(i)%charge_typ)
4745 END DO
4746 END IF
4747 DO i = istart, iend
4748 IF (ASSOCIATED(multipoles(i)%charge_typ)) THEN
4749 ! make a copy of the array and enlarge the array type by 1
4750 isize = SIZE(multipoles(i)%charge_typ) + 1
4751 ELSE
4752 isize = 1
4753 END IF
4754 CALL reallocate_charge_type(multipoles(i)%charge_typ, 1, isize)
4755 SELECT CASE (label)
4756 CASE ("CHARGE")
4757 cpassert(PRESENT(charges))
4758 cpassert(ASSOCIATED(charges))
4759 ALLOCATE (multipoles(i)%charge_typ(isize)%charge(1))
4760 ALLOCATE (multipoles(i)%charge_typ(isize)%pos(3, 1))
4761
4762 multipoles(i)%charge_typ(isize)%charge(1) = echarge
4763 multipoles(i)%charge_typ(isize)%pos(1:3, 1) = 0.0_dp
4764 charges(i) = charges(i) + echarge
4765 CASE ("DIPOLE")
4766 dx = 1.0e-4_dp
4767 cpassert(PRESENT(dipoles))
4768 cpassert(ASSOCIATED(dipoles))
4769 ALLOCATE (multipoles(i)%charge_typ(isize)%charge(2))
4770 ALLOCATE (multipoles(i)%charge_typ(isize)%pos(3, 2))
4771 CALL random_stream%fill(rvec)
4772 rvec = rvec/(2.0_dp*sqrt(dot_product(rvec, rvec)))*dx
4773 multipoles(i)%charge_typ(isize)%charge(1) = echarge
4774 multipoles(i)%charge_typ(isize)%pos(1:3, 1) = rvec
4775 multipoles(i)%charge_typ(isize)%charge(2) = -echarge
4776 multipoles(i)%charge_typ(isize)%pos(1:3, 2) = -rvec
4777
4778 dipoles(:, i) = dipoles(:, i) + 2.0_dp*echarge*rvec
4779 CASE ("QUADRUPOLE")
4780 dx = 1.0e-2_dp
4781 cpassert(PRESENT(quadrupoles))
4782 cpassert(ASSOCIATED(quadrupoles))
4783 ALLOCATE (multipoles(i)%charge_typ(isize)%charge(4))
4784 ALLOCATE (multipoles(i)%charge_typ(isize)%pos(3, 4))
4785 CALL random_stream%fill(rvec1)
4786 CALL random_stream%fill(rvec2)
4787 rvec1 = rvec1/sqrt(dot_product(rvec1, rvec1))
4788 rvec2 = rvec2 - dot_product(rvec2, rvec1)*rvec1
4789 rvec2 = rvec2/sqrt(dot_product(rvec2, rvec2))
4790 !
4791 rvec1 = rvec1/2.0_dp*dx
4792 rvec2 = rvec2/2.0_dp*dx
4793 ! + (4) ^ - (1)
4794 ! |rvec2
4795 ! |
4796 ! 0------> rvec1
4797 !
4798 !
4799 ! - (3) + (2)
4800 multipoles(i)%charge_typ(isize)%charge(1) = -echarge
4801 multipoles(i)%charge_typ(isize)%pos(1:3, 1) = rvec1 + rvec2
4802 multipoles(i)%charge_typ(isize)%charge(2) = echarge
4803 multipoles(i)%charge_typ(isize)%pos(1:3, 2) = rvec1 - rvec2
4804 multipoles(i)%charge_typ(isize)%charge(3) = -echarge
4805 multipoles(i)%charge_typ(isize)%pos(1:3, 3) = -rvec1 - rvec2
4806 multipoles(i)%charge_typ(isize)%charge(4) = echarge
4807 multipoles(i)%charge_typ(isize)%pos(1:3, 4) = -rvec1 + rvec2
4808
4809 DO k = 1, 4
4810 r2 = dot_product(multipoles(i)%charge_typ(isize)%pos(:, k), multipoles(i)%charge_typ(isize)%pos(:, k))
4811 DO l = 1, 3
4812 DO m = 1, 3
4813 quadrupoles(m, l, i) = quadrupoles(m, l, i) + 3.0_dp*0.5_dp*multipoles(i)%charge_typ(isize)%charge(k)* &
4814 multipoles(i)%charge_typ(isize)%pos(l, k)* &
4815 multipoles(i)%charge_typ(isize)%pos(m, k)
4816 IF (m == l) quadrupoles(m, l, i) = quadrupoles(m, l, i) - 0.5_dp*multipoles(i)%charge_typ(isize)%charge(k)*r2
4817 END DO
4818 END DO
4819 END DO
4820
4821 END SELECT
4822 END DO
4823 END SUBROUTINE create_multi_type
4824
4825! **************************************************************************************************
4826!> \brief release multi_type for multipoles
4827!> \param multipoles ...
4828!> \date 05.2008
4829!> \author Teodoro Laino [tlaino] - University of Zurich - 05.2008
4830! **************************************************************************************************
4831 SUBROUTINE release_multi_type(multipoles)
4832 TYPE(multi_charge_type), DIMENSION(:), POINTER :: multipoles
4833
4834 INTEGER :: i, j
4835
4836 IF (ASSOCIATED(multipoles)) THEN
4837 DO i = 1, SIZE(multipoles)
4838 DO j = 1, SIZE(multipoles(i)%charge_typ)
4839 DEALLOCATE (multipoles(i)%charge_typ(j)%charge)
4840 DEALLOCATE (multipoles(i)%charge_typ(j)%pos)
4841 END DO
4842 DEALLOCATE (multipoles(i)%charge_typ)
4843 END DO
4844 END IF
4845 END SUBROUTINE release_multi_type
4846
4847! **************************************************************************************************
4848!> \brief reallocates multi_type for multipoles
4849!> \param charge_typ ...
4850!> \param istart ...
4851!> \param iend ...
4852!> \date 05.2008
4853!> \author Teodoro Laino [tlaino] - University of Zurich - 05.2008
4854! **************************************************************************************************
4855 SUBROUTINE reallocate_charge_type(charge_typ, istart, iend)
4856 TYPE(charge_mono_type), DIMENSION(:), POINTER :: charge_typ
4857 INTEGER, INTENT(IN) :: istart, iend
4858
4859 INTEGER :: i, isize, j, jsize, jsize1, jsize2
4860 TYPE(charge_mono_type), DIMENSION(:), POINTER :: charge_typ_bk
4861
4862 IF (ASSOCIATED(charge_typ)) THEN
4863 isize = SIZE(charge_typ)
4864 ALLOCATE (charge_typ_bk(1:isize))
4865 DO j = 1, isize
4866 jsize = SIZE(charge_typ(j)%charge)
4867 ALLOCATE (charge_typ_bk(j)%charge(jsize))
4868 jsize1 = SIZE(charge_typ(j)%pos, 1)
4869 jsize2 = SIZE(charge_typ(j)%pos, 2)
4870 ALLOCATE (charge_typ_bk(j)%pos(jsize1, jsize2))
4871 charge_typ_bk(j)%pos = charge_typ(j)%pos
4872 charge_typ_bk(j)%charge = charge_typ(j)%charge
4873 END DO
4874 DO j = 1, SIZE(charge_typ)
4875 DEALLOCATE (charge_typ(j)%charge)
4876 DEALLOCATE (charge_typ(j)%pos)
4877 END DO
4878 DEALLOCATE (charge_typ)
4879 ! Reallocate
4880 ALLOCATE (charge_typ_bk(istart:iend))
4881 DO i = istart, isize
4882 jsize = SIZE(charge_typ_bk(j)%charge)
4883 ALLOCATE (charge_typ(j)%charge(jsize))
4884 jsize1 = SIZE(charge_typ_bk(j)%pos, 1)
4885 jsize2 = SIZE(charge_typ_bk(j)%pos, 2)
4886 ALLOCATE (charge_typ(j)%pos(jsize1, jsize2))
4887 charge_typ(j)%pos = charge_typ_bk(j)%pos
4888 charge_typ(j)%charge = charge_typ_bk(j)%charge
4889 END DO
4890 DO j = 1, SIZE(charge_typ_bk)
4891 DEALLOCATE (charge_typ_bk(j)%charge)
4892 DEALLOCATE (charge_typ_bk(j)%pos)
4893 END DO
4894 DEALLOCATE (charge_typ_bk)
4895 ELSE
4896 ALLOCATE (charge_typ(istart:iend))
4897 END IF
4898
4899 END SUBROUTINE reallocate_charge_type
4900
4901 END SUBROUTINE debug_ewald_multipoles
4902
4903! **************************************************************************************************
4904!> \brief Routine to debug potential, field and electric field gradients
4905!> \param ewald_env ...
4906!> \param ewald_pw ...
4907!> \param nonbond_env ...
4908!> \param cell ...
4909!> \param particle_set ...
4910!> \param local_particles ...
4911!> \param radii ...
4912!> \param charges ...
4913!> \param dipoles ...
4914!> \param quadrupoles ...
4915!> \param task ...
4916!> \param iw ...
4917!> \param atomic_kind_set ...
4918!> \param mm_section ...
4919!> \date 05.2008
4920!> \author Teodoro Laino [tlaino] - University of Zurich - 05.2008
4921! **************************************************************************************************
4922 SUBROUTINE debug_ewald_multipoles_fields(ewald_env, ewald_pw, nonbond_env, cell, &
4923 particle_set, local_particles, radii, charges, dipoles, quadrupoles, task, iw, &
4924 atomic_kind_set, mm_section)
4925 TYPE(ewald_environment_type), POINTER :: ewald_env
4926 TYPE(ewald_pw_type), POINTER :: ewald_pw
4927 TYPE(fist_nonbond_env_type), POINTER :: nonbond_env
4928 TYPE(cell_type), POINTER :: cell
4929 TYPE(particle_type), POINTER :: particle_set(:)
4930 TYPE(distribution_1d_type), POINTER :: local_particles
4931 REAL(kind=dp), DIMENSION(:), OPTIONAL, POINTER :: radii, charges
4932 REAL(kind=dp), DIMENSION(:, :), OPTIONAL, POINTER :: dipoles
4933 REAL(kind=dp), DIMENSION(:, :, :), OPTIONAL, &
4934 POINTER :: quadrupoles
4935 LOGICAL, DIMENSION(3), INTENT(IN) :: task
4936 INTEGER, INTENT(IN) :: iw
4937 TYPE(atomic_kind_type), POINTER :: atomic_kind_set(:)
4938 TYPE(section_vals_type), POINTER :: mm_section
4939
4940 INTEGER :: i, iparticle_kind, j, k, &
4941 nparticle_local, nparticles
4942 REAL(kind=dp) :: coord(3), dq, e_neut, e_self, efield1n(3), efield2n(3, 3), ene(2), &
4943 energy_glob, energy_local, enev(3, 2), o_tot_ene, pot, pv_glob(3, 3), pv_local(3, 3), &
4944 tot_ene
4945 REAL(kind=dp), ALLOCATABLE, DIMENSION(:, :) :: efield1, efield2, forces_glob, &
4946 forces_local
4947 REAL(kind=dp), DIMENSION(:), POINTER :: efield0, lcharges
4948 TYPE(cp_logger_type), POINTER :: logger
4949 TYPE(particle_type), DIMENSION(:), POINTER :: core_particle_set, shell_particle_set
4950
4951 NULLIFY (lcharges, shell_particle_set, core_particle_set)
4952 NULLIFY (logger)
4953 logger => cp_get_default_logger()
4954
4955 nparticles = SIZE(particle_set)
4956 nparticle_local = 0
4957 DO iparticle_kind = 1, SIZE(local_particles%n_el)
4958 nparticle_local = nparticle_local + local_particles%n_el(iparticle_kind)
4959 END DO
4960 ALLOCATE (lcharges(nparticles))
4961 ALLOCATE (forces_glob(3, nparticles))
4962 ALLOCATE (forces_local(3, nparticle_local))
4963 ALLOCATE (efield0(nparticles))
4964 ALLOCATE (efield1(3, nparticles))
4965 ALLOCATE (efield2(9, nparticles))
4966 forces_glob = 0.0_dp
4967 forces_local = 0.0_dp
4968 efield0 = 0.0_dp
4969 efield1 = 0.0_dp
4970 efield2 = 0.0_dp
4971 pv_local = 0.0_dp
4972 pv_glob = 0.0_dp
4973 energy_glob = 0.0_dp
4974 energy_local = 0.0_dp
4975 e_neut = 0.0_dp
4976 e_self = 0.0_dp
4977 CALL ewald_multipole_evaluate(ewald_env, ewald_pw, nonbond_env, cell, particle_set, &
4978 local_particles, energy_local, energy_glob, e_neut, e_self, task, .false., .true., .true., &
4979 .true., radii, charges, dipoles, quadrupoles, forces_local, forces_glob, pv_local, pv_glob, &
4980 efield0, efield1, efield2, iw, do_debug=.false.)
4981 o_tot_ene = energy_local + energy_glob + e_neut + e_self
4982 WRITE (iw, *) "TOTAL ENERGY :: ========>", o_tot_ene
4983 ! Debug Potential
4984 dq = 0.001_dp
4985 tot_ene = 0.0_dp
4986 DO i = 1, nparticles
4987 DO k = 1, 2
4988 lcharges = charges
4989 lcharges(i) = charges(i) + (-1.0_dp)**k*dq
4990 forces_glob = 0.0_dp
4991 forces_local = 0.0_dp
4992 pv_local = 0.0_dp
4993 pv_glob = 0.0_dp
4994 energy_glob = 0.0_dp
4995 energy_local = 0.0_dp
4996 e_neut = 0.0_dp
4997 e_self = 0.0_dp
4998 CALL ewald_multipole_evaluate(ewald_env, ewald_pw, nonbond_env, cell, particle_set, &
4999 local_particles, energy_local, energy_glob, e_neut, e_self, &
5000 task, .false., .false., .false., .false., radii, &
5001 lcharges, dipoles, quadrupoles, iw=iw, do_debug=.false.)
5002 ene(k) = energy_local + energy_glob + e_neut + e_self
5003 END DO
5004 pot = (ene(2) - ene(1))/(2.0_dp*dq)
5005 WRITE (iw, '(A,I8,3(A,F15.9))') "POTENTIAL FOR ATOM: ", i, " NUMERICAL: ", pot, " ANALYTICAL: ", efield0(i), &
5006 " ERROR: ", pot - efield0(i)
5007 tot_ene = tot_ene + 0.5_dp*efield0(i)*charges(i)
5008 END DO
5009 WRITE (iw, *) "ENERGIES: ", o_tot_ene, tot_ene, o_tot_ene - tot_ene
5010 WRITE (iw, '(/,/,/)')
5011 ! Debug Field
5012 dq = 0.001_dp
5013 DO i = 1, nparticles
5014 coord = particle_set(i)%r
5015 DO j = 1, 3
5016 DO k = 1, 2
5017 particle_set(i)%r(j) = coord(j) + (-1.0_dp)**k*dq
5018
5019 ! Rebuild neighbor lists
5020 CALL list_control(atomic_kind_set, particle_set, local_particles, &
5021 cell, nonbond_env, logger%para_env, mm_section, &
5022 shell_particle_set, core_particle_set)
5023
5024 forces_glob = 0.0_dp
5025 forces_local = 0.0_dp
5026 pv_local = 0.0_dp
5027 pv_glob = 0.0_dp
5028 energy_glob = 0.0_dp
5029 energy_local = 0.0_dp
5030 e_neut = 0.0_dp
5031 e_self = 0.0_dp
5032 efield0 = 0.0_dp
5033 CALL ewald_multipole_evaluate(ewald_env, ewald_pw, nonbond_env, cell, particle_set, &
5034 local_particles, energy_local, energy_glob, e_neut, e_self, &
5035 task, .false., .true., .true., .true., radii, &
5036 charges, dipoles, quadrupoles, forces_local, forces_glob, &
5037 pv_local, pv_glob, efield0, iw=iw, do_debug=.false.)
5038 ene(k) = efield0(i)
5039 particle_set(i)%r(j) = coord(j)
5040 END DO
5041 efield1n(j) = -(ene(2) - ene(1))/(2.0_dp*dq)
5042 END DO
5043 WRITE (iw, '(/,A,I8)') "FIELD FOR ATOM: ", i
5044 WRITE (iw, '(A,3F15.9)') " NUMERICAL: ", efield1n, " ANALYTICAL: ", efield1(:, i), &
5045 " ERROR: ", efield1n - efield1(:, i)
5046 IF (task(2)) THEN
5047 tot_ene = tot_ene - 0.5_dp*dot_product(efield1(:, i), dipoles(:, i))
5048 END IF
5049 END DO
5050 WRITE (iw, *) "ENERGIES: ", o_tot_ene, tot_ene, o_tot_ene - tot_ene
5051
5052 ! Debug Field Gradient
5053 dq = 0.0001_dp
5054 DO i = 1, nparticles
5055 coord = particle_set(i)%r
5056 DO j = 1, 3
5057 DO k = 1, 2
5058 particle_set(i)%r(j) = coord(j) + (-1.0_dp)**k*dq
5059
5060 ! Rebuild neighbor lists
5061 CALL list_control(atomic_kind_set, particle_set, local_particles, &
5062 cell, nonbond_env, logger%para_env, mm_section, &
5063 shell_particle_set, core_particle_set)
5064
5065 forces_glob = 0.0_dp
5066 forces_local = 0.0_dp
5067 pv_local = 0.0_dp
5068 pv_glob = 0.0_dp
5069 energy_glob = 0.0_dp
5070 energy_local = 0.0_dp
5071 e_neut = 0.0_dp
5072 e_self = 0.0_dp
5073 efield1 = 0.0_dp
5074 CALL ewald_multipole_evaluate(ewald_env, ewald_pw, nonbond_env, cell, particle_set, &
5075 local_particles, energy_local, energy_glob, e_neut, e_self, &
5076 task, .false., .true., .true., .true., radii, &
5077 charges, dipoles, quadrupoles, forces_local, forces_glob, &
5078 pv_local, pv_glob, efield1=efield1, iw=iw, do_debug=.false.)
5079 enev(:, k) = efield1(:, i)
5080 particle_set(i)%r(j) = coord(j)
5081 END DO
5082 efield2n(:, j) = (enev(:, 2) - enev(:, 1))/(2.0_dp*dq)
5083 END DO
5084 WRITE (iw, '(/,A,I8)') "FIELD GRADIENT FOR ATOM: ", i
5085 WRITE (iw, '(A,9F15.9)') " NUMERICAL: ", efield2n, &
5086 " ANALYTICAL: ", efield2(:, i), &
5087 " ERROR: ", reshape(efield2n, (/9/)) - efield2(:, i)
5088 END DO
5089 END SUBROUTINE debug_ewald_multipoles_fields
5090
5091! **************************************************************************************************
5092!> \brief Routine to debug potential, field and electric field gradients
5093!> \param ewald_env ...
5094!> \param ewald_pw ...
5095!> \param nonbond_env ...
5096!> \param cell ...
5097!> \param particle_set ...
5098!> \param local_particles ...
5099!> \param radii ...
5100!> \param charges ...
5101!> \param dipoles ...
5102!> \param quadrupoles ...
5103!> \param task ...
5104!> \param iw ...
5105!> \date 05.2008
5106!> \author Teodoro Laino [tlaino] - University of Zurich - 05.2008
5107! **************************************************************************************************
5108 SUBROUTINE debug_ewald_multipoles_fields2(ewald_env, ewald_pw, nonbond_env, cell, &
5109 particle_set, local_particles, radii, charges, dipoles, quadrupoles, task, iw)
5110 TYPE(ewald_environment_type), POINTER :: ewald_env
5111 TYPE(ewald_pw_type), POINTER :: ewald_pw
5112 TYPE(fist_nonbond_env_type), POINTER :: nonbond_env
5113 TYPE(cell_type), POINTER :: cell
5114 TYPE(particle_type), POINTER :: particle_set(:)
5115 TYPE(distribution_1d_type), POINTER :: local_particles
5116 REAL(kind=dp), DIMENSION(:), OPTIONAL, POINTER :: radii, charges
5117 REAL(kind=dp), DIMENSION(:, :), OPTIONAL, POINTER :: dipoles
5118 REAL(kind=dp), DIMENSION(:, :, :), OPTIONAL, &
5119 POINTER :: quadrupoles
5120 LOGICAL, DIMENSION(3), INTENT(IN) :: task
5121 INTEGER, INTENT(IN) :: iw
5122
5123 INTEGER :: i, ind, iparticle_kind, j, k, &
5124 nparticle_local, nparticles
5125 REAL(kind=dp) :: e_neut, e_self, energy_glob, &
5126 energy_local, o_tot_ene, prod, &
5127 pv_glob(3, 3), pv_local(3, 3), tot_ene
5128 REAL(kind=dp), ALLOCATABLE, DIMENSION(:, :) :: efield1, efield2, forces_glob, &
5129 forces_local
5130 REAL(kind=dp), DIMENSION(:), POINTER :: efield0
5131 TYPE(cp_logger_type), POINTER :: logger
5132
5133 NULLIFY (logger)
5134 logger => cp_get_default_logger()
5135
5136 nparticles = SIZE(particle_set)
5137 nparticle_local = 0
5138 DO iparticle_kind = 1, SIZE(local_particles%n_el)
5139 nparticle_local = nparticle_local + local_particles%n_el(iparticle_kind)
5140 END DO
5141 ALLOCATE (forces_glob(3, nparticles))
5142 ALLOCATE (forces_local(3, nparticle_local))
5143 ALLOCATE (efield0(nparticles))
5144 ALLOCATE (efield1(3, nparticles))
5145 ALLOCATE (efield2(9, nparticles))
5146 forces_glob = 0.0_dp
5147 forces_local = 0.0_dp
5148 efield0 = 0.0_dp
5149 efield1 = 0.0_dp
5150 efield2 = 0.0_dp
5151 pv_local = 0.0_dp
5152 pv_glob = 0.0_dp
5153 energy_glob = 0.0_dp
5154 energy_local = 0.0_dp
5155 e_neut = 0.0_dp
5156 e_self = 0.0_dp
5157 CALL ewald_multipole_evaluate(ewald_env, ewald_pw, nonbond_env, cell, particle_set, &
5158 local_particles, energy_local, energy_glob, e_neut, e_self, task, .false., .true., .true., &
5159 .true., radii, charges, dipoles, quadrupoles, forces_local, forces_glob, pv_local, pv_glob, &
5160 efield0, efield1, efield2, iw, do_debug=.false.)
5161 o_tot_ene = energy_local + energy_glob + e_neut + e_self
5162 WRITE (iw, *) "TOTAL ENERGY :: ========>", o_tot_ene
5163
5164 ! Debug Potential
5165 tot_ene = 0.0_dp
5166 IF (task(1)) THEN
5167 DO i = 1, nparticles
5168 tot_ene = tot_ene + 0.5_dp*efield0(i)*charges(i)
5169 END DO
5170 WRITE (iw, *) "ENERGIES: ", o_tot_ene, tot_ene, o_tot_ene - tot_ene
5171 WRITE (iw, '(/,/,/)')
5172 END IF
5173
5174 ! Debug Field
5175 IF (task(2)) THEN
5176 DO i = 1, nparticles
5177 tot_ene = tot_ene - 0.5_dp*dot_product(efield1(:, i), dipoles(:, i))
5178 END DO
5179 WRITE (iw, *) "ENERGIES: ", o_tot_ene, tot_ene, o_tot_ene - tot_ene
5180 WRITE (iw, '(/,/,/)')
5181 END IF
5182
5183 ! Debug Field Gradient
5184 IF (task(3)) THEN
5185 DO i = 1, nparticles
5186 ind = 0
5187 prod = 0.0_dp
5188 DO j = 1, 3
5189 DO k = 1, 3
5190 ind = ind + 1
5191 prod = prod + efield2(ind, i)*quadrupoles(j, k, i)
5192 END DO
5193 END DO
5194 tot_ene = tot_ene - 0.5_dp*(1.0_dp/3.0_dp)*prod
5195 END DO
5196 WRITE (iw, *) "ENERGIES: ", o_tot_ene, tot_ene, o_tot_ene - tot_ene
5197 WRITE (iw, '(/,/,/)')
5198 END IF
5199
5200 END SUBROUTINE debug_ewald_multipoles_fields2
5201
5202END MODULE ewalds_multipole
cell_types::pbc
Definition cell_types.F:92
atomic_kind_types
Define the atomic kind types and their sub types.
Definition atomic_kind_types.F:23
bibliography
collects all references to literature in CP2K as new algorithms / method are included from literature...
Definition bibliography.F:28
bibliography::aguado2003
integer, save, public aguado2003
Definition bibliography.F:43
bibliography::laino2008
integer, save, public laino2008
Definition bibliography.F:43
cell_types
Handles all functions related to the CELL.
Definition cell_types.F:15
cp_log_handling
various routines to log and control the output. The idea is that decisions about where to log should ...
Definition cp_log_handling.F:41
cp_log_handling::cp_get_default_logger
type(cp_logger_type) function, pointer, public cp_get_default_logger()
returns the default logger
Definition cp_log_handling.F:234
damping_dipole_types
Definition damping_dipole_types.F:11
damping_dipole_types::tang_toennies
integer, parameter, public tang_toennies
Definition damping_dipole_types.F:27
damping_dipole_types::no_damping
integer, parameter, public no_damping
Definition damping_dipole_types.F:27
dg_rho0_types
Definition dg_rho0_types.F:12
dg_types
Definition dg_types.F:12
dg_types::dg_get
subroutine, public dg_get(dg, dg_rho0)
Get the dg_type.
Definition dg_types.F:44
distribution_1d_types
stores a lists of integer that are local to a processor. The idea is that these integers represent ob...
Definition distribution_1d_types.F:24
ewald_environment_types
Definition ewald_environment_types.F:14
ewald_environment_types::ewald_env_get
subroutine, public ewald_env_get(ewald_env, ewald_type, alpha, eps_pol, epsilon, gmax, ns_max, o_spline, group, para_env, poisson_section, precs, rcut, do_multipoles, max_multipole, do_ipol, max_ipol_iter, interaction_cutoffs, cell_hmat)
Purpose: Get the EWALD environment.
Definition ewald_environment_types.F:123
ewald_pw_types
pw_types
Definition ewald_pw_types.F:12
ewald_pw_types::ewald_pw_get
subroutine, public ewald_pw_get(ewald_pw, pw_big_pool, pw_small_pool, rs_desc, poisson_env, dg)
get the ewald_pw environment to the correct program.
Definition ewald_pw_types.F:325
ewalds_multipole
Treats the electrostatic for multipoles (up to quadrupoles)
Definition ewalds_multipole.F:14
ewalds_multipole::ewald_multipole_evaluate
recursive subroutine, public ewald_multipole_evaluate(ewald_env, ewald_pw, nonbond_env, cell, particle_set, local_particles, energy_local, energy_glob, e_neut, e_self, task, do_correction_bonded, do_forces, do_stress, do_efield, radii, charges, dipoles, quadrupoles, forces_local, forces_glob, pv_local, pv_glob, efield0, efield1, efield2, iw, do_debug, atomic_kind_set, mm_section)
Computes the potential and the force for a lattice sum of multipoles (up to quadrupole)
Definition ewalds_multipole.F:122
fist_neighbor_list_control
Definition fist_neighbor_list_control.F:15
fist_neighbor_list_control::list_control
subroutine, public list_control(atomic_kind_set, particle_set, local_particles, cell, fist_nonbond_env, para_env, mm_section, shell_particle_set, core_particle_set, force_update, exclusions)
...
Definition fist_neighbor_list_control.F:86
fist_neighbor_list_types
Define the neighbor list data types and the corresponding functionality.
Definition fist_neighbor_list_types.F:11
fist_nonbond_env_types
Definition fist_nonbond_env_types.F:13
fist_nonbond_env_types::fist_nonbond_env_get
subroutine, public fist_nonbond_env_get(fist_nonbond_env, potparm14, potparm, nonbonded, rlist_cut, rlist_lowsq, aup, lup, ei_scale14, vdw_scale14, shift_cutoff, do_electrostatics, r_last_update, r_last_update_pbc, rshell_last_update_pbc, rcore_last_update_pbc, cell_last_update, num_update, last_update, counter, natom_types, long_range_correction, ij_kind_full_fac, eam_data, quip_data, nequip_data, allegro_data, deepmd_data, charges)
sets a fist_nonbond_env
Definition fist_nonbond_env_types.F:157
input_section_types
objects that represent the structure of input sections and the data contained in an input section
Definition input_section_types.F:15
kinds
Defines the basic variable types.
Definition kinds.F:23
kinds::dp
integer, parameter, public dp
Definition kinds.F:34
list
An array-based list which grows on demand. When the internal array is full, a new array of twice the ...
Definition list.F:24
mathconstants
Definition of mathematical constants and functions.
Definition mathconstants.F:16
mathconstants::oorootpi
real(kind=dp), parameter, public oorootpi
Definition mathconstants.F:115
mathconstants::pi
real(kind=dp), parameter, public pi
Definition mathconstants.F:110
mathconstants::sqrthalf
real(kind=dp), parameter, public sqrthalf
Definition mathconstants.F:127
mathconstants::fourpi
real(kind=dp), parameter, public fourpi
Definition mathconstants.F:113
mathconstants::fac
real(kind=dp), dimension(0:maxfac), parameter, public fac
Definition mathconstants.F:37
message_passing
Interface to the message passing library MPI.
Definition message_passing.F:23
parallel_rng_types
Parallel (pseudo)random number generator (RNG) for multiple streams and substreams of random numbers.
Definition parallel_rng_types.F:51
parallel_rng_types::uniform
integer, parameter, public uniform
Definition parallel_rng_types.F:73
particle_types
Define the data structure for the particle information.
Definition particle_types.F:19
pw_grid_types
Definition pw_grid_types.F:13
pw_pool_types
Manages a pool of grids (to be used for example as tmp objects), but can also be used to instantiate ...
Definition pw_pool_types.F:24
structure_factor_types
Definition structure_factor_types.F:12
structure_factors
Definition structure_factors.F:12
structure_factors::structure_factor_deallocate
subroutine, public structure_factor_deallocate(exp_igr)
...
Definition structure_factors.F:50
structure_factors::structure_factor_allocate
subroutine, public structure_factor_allocate(bds, nparts, exp_igr, allocate_centre, allocate_shell_e, allocate_shell_centre, nshell)
...
Definition structure_factors.F:91
structure_factors::structure_factor_evaluate
subroutine, public structure_factor_evaluate(delta, lb, ex, ey, ez)
...
Definition structure_factors.F:151
atomic_kind_types::atomic_kind_type
Provides all information about an atomic kind.
Definition atomic_kind_types.F:45
cell_types::cell_type
Type defining parameters related to the simulation cell.
Definition cell_types.F:55
cp_log_handling::cp_logger_type
type of a logger, at the moment it contains just a print level starting at which level it should be l...
Definition cp_log_handling.F:140
damping_dipole_types::damping_type
Definition damping_dipole_types.F:39
dg_rho0_types::dg_rho0_type
Type for Gaussian Densities type = type of gaussian (PME) grid = grid number gcc = Gaussian contracti...
Definition dg_rho0_types.F:39
dg_types::dg_type
Definition dg_types.F:23
distribution_1d_types::distribution_1d_type
structure to store local (to a processor) ordered lists of integers.
Definition distribution_1d_types.F:62
ewald_environment_types::ewald_environment_type
to build arrays of pointers
Definition ewald_environment_types.F:55
ewald_pw_types::ewald_pw_type
Definition ewald_pw_types.F:64
fist_neighbor_list_types::fist_neighbor_type
Definition fist_neighbor_list_types.F:48
fist_neighbor_list_types::neighbor_kind_pairs_type
Definition fist_neighbor_list_types.F:26
fist_nonbond_env_types::fist_nonbond_env_type
Definition fist_nonbond_env_types.F:81
fist_nonbond_env_types::pos_type
Definition fist_nonbond_env_types.F:44
input_section_types::section_vals_type
stores the values of a section
Definition input_section_types.F:126
message_passing::mp_comm_type
Definition message_passing.F:189
parallel_rng_types::rng_stream_type
Definition parallel_rng_types.F:157
particle_types::particle_type
Definition particle_types.F:35
pw_grid_types::pw_grid_type
Definition pw_grid_types.F:62
pw_pool_types::pw_pool_type
Manages a pool of grids (to be used for example as tmp objects), but can also be used to instantiate ...
Definition pw_pool_types.F:83
structure_factor_types::structure_factor_type
Definition structure_factor_types.F:23