(git:b195825)
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 ! **************************************************************************************************
14 MODULE 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 
71 CONTAINS
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 
5202 END MODULE ewalds_multipole
pbc
subroutine pbc(r, r_pbc, s, s_pbc, a, b, c, alpha, beta, gamma, debug, info, pbc0, h, hinv)
...
Definition: dumpdcd.F:1203
fac
static GRID_HOST_DEVICE double fac(const int i)
Factorial function, e.g. fac(5) = 5! = 120.
Definition: grid_common.h:48
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
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
dg_types::dg_type
Definition: dg_types.F:23