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