90 SUBROUTINE build_core_ppnl(matrix_h, matrix_p, force, virial, calculate_forces, use_virial, nder, &
91 qs_kind_set, atomic_kind_set, particle_set, sab_orb, sap_ppnl, eps_ppnl, &
92 nimages, cell_to_index, basis_type, deltaR, matrix_l, atcore)
94 TYPE(
dbcsr_p_type),
DIMENSION(:, :),
POINTER :: matrix_h, matrix_p
97 LOGICAL,
INTENT(IN) :: calculate_forces
100 TYPE(
qs_kind_type),
DIMENSION(:),
POINTER :: qs_kind_set
104 POINTER :: sab_orb, sap_ppnl
105 REAL(kind=
dp),
INTENT(IN) :: eps_ppnl
106 INTEGER,
INTENT(IN) :: nimages
107 INTEGER,
DIMENSION(:, :, :),
OPTIONAL,
POINTER :: cell_to_index
108 CHARACTER(LEN=*),
INTENT(IN) :: basis_type
109 REAL(kind=
dp),
DIMENSION(:, :),
INTENT(IN), &
113 REAL(kind=
dp),
DIMENSION(:),
INTENT(INOUT), &
116 CHARACTER(LEN=*),
PARAMETER :: routinen =
'build_core_ppnl'
118 INTEGER :: atom_a, first_col, handle, i, i_dim, iab, iac, iatom, ib, ibc, icol, ikind, &
119 ilist, img, irow, iset, j, jatom, jb, jkind, jneighbor, kac, katom, kbc, kkind, l, &
120 lc_max, lc_min, ldai, ldsab, lppnl, maxco, maxder, maxl, maxlgto, maxlppnl, maxppnl, &
121 maxsgf, na, natom, nb, ncoa, ncoc, nkind, nlist, nneighbor, nnl, np, nppnl, nprjc, nseta, &
122 nsgfa, prjc, sgfa, slot
123 INTEGER,
ALLOCATABLE,
DIMENSION(:) :: atom_of_kind, kind_of
124 INTEGER,
DIMENSION(3) :: cell_b, cell_c
125 INTEGER,
DIMENSION(:),
POINTER :: la_max, la_min, npgfa, nprj_ppnl, &
127 INTEGER,
DIMENSION(:, :),
POINTER :: first_sgfa
128 LOGICAL :: do_dr, do_gth, do_kp, do_soc, do_upf, &
129 doat, found, ppnl_present
130 REAL(kind=
dp) :: atk, dac, f0, ppnl_radius
131 REAL(kind=
dp),
ALLOCATABLE :: upf_int(:, :, :)
132 REAL(kind=
dp),
ALLOCATABLE,
DIMENSION(:) :: radp
133 REAL(kind=
dp),
ALLOCATABLE,
DIMENSION(:, :) :: sab, work
134 REAL(kind=
dp),
ALLOCATABLE,
DIMENSION(:, :, :) :: ai_work, lab, work_l
135 REAL(kind=
dp),
DIMENSION(1) :: rprjc, zetc
136 REAL(kind=
dp),
DIMENSION(3) :: fa, fb, rab, rac, rbc
137 REAL(kind=
dp),
DIMENSION(3, 3) :: pv_thread
143 TYPE(
alist_type),
POINTER :: alist_ac, alist_bc
144 REAL(kind=
dp),
DIMENSION(SIZE(particle_set)) :: at_thread
145 REAL(kind=
dp),
DIMENSION(:, :, :),
POINTER :: achint, acint, alkint, bchint, bcint, &
147 REAL(kind=
dp),
DIMENSION(:, :),
POINTER :: cprj, h_block, l_block_x, l_block_y, &
148 l_block_z, p_block, r_2block, &
149 r_3block, rpgfa, sphi_a, vprj_ppnl, &
151 REAL(kind=
dp),
DIMENSION(:),
POINTER :: a_nl, alpha_ppnl, hprj, set_radius_a
152 REAL(kind=
dp),
DIMENSION(3, SIZE(particle_set)) :: force_thread
167 IF (
PRESENT(deltar)) do_dr = .true.
169 IF (
PRESENT(atcore)) doat = .true.
170 IF ((calculate_forces .OR. doat) .AND. do_dr)
THEN
171 cpabort(
"core_ppl: incompatible options")
174 IF (calculate_forces)
THEN
175 CALL timeset(routinen//
"_forces", handle)
177 CALL timeset(routinen, handle)
180 do_soc =
PRESENT(matrix_l)
182 ppnl_present =
ASSOCIATED(sap_ppnl)
184 IF (ppnl_present)
THEN
186 nkind =
SIZE(atomic_kind_set)
187 natom =
SIZE(particle_set)
189 do_kp = (nimages > 1)
192 IF (
PRESENT(cell_to_index))
THEN
193 cpassert(
ASSOCIATED(cell_to_index))
195 cpabort(
"Missing cell_to_index for k-point calculation")
199 IF (calculate_forces .OR. doat)
THEN
200 IF (
SIZE(matrix_p, 1) == 2)
THEN
202 CALL dbcsr_add(matrix_p(1, img)%matrix, matrix_p(2, img)%matrix, &
203 alpha_scalar=1.0_dp, beta_scalar=1.0_dp)
204 CALL dbcsr_add(matrix_p(2, img)%matrix, matrix_p(1, img)%matrix, &
205 alpha_scalar=-2.0_dp, beta_scalar=1.0_dp)
218 basis_type=basis_type)
220 maxl = max(maxlgto, maxlppnl)
223 ldsab = max(maxco,
ncoset(maxlppnl), maxsgf, maxppnl)
224 ldai =
ncoset(maxl + nder + 1)
227 ALLOCATE (sap_int(nkind*nkind))
228 DO i = 1, nkind*nkind
229 NULLIFY (sap_int(i)%alist, sap_int(i)%asort, sap_int(i)%aindex)
230 sap_int(i)%nalist = 0
234 ALLOCATE (basis_set(nkind), gpotential(nkind), spotential(nkind))
236 CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis_set, basis_type=basis_type)
237 IF (
ASSOCIATED(orb_basis_set))
THEN
238 basis_set(ikind)%gto_basis_set => orb_basis_set
240 NULLIFY (basis_set(ikind)%gto_basis_set)
242 CALL get_qs_kind(qs_kind_set(ikind), gth_potential=gth_potential, sgp_potential=sgp_potential)
243 NULLIFY (gpotential(ikind)%gth_potential)
244 NULLIFY (spotential(ikind)%sgp_potential)
245 IF (
ASSOCIATED(gth_potential))
THEN
246 gpotential(ikind)%gth_potential => gth_potential
247 IF (do_soc .AND. (.NOT. gth_potential%soc))
THEN
248 cpabort(
"Spin-orbit coupling selected, but GTH potential without SOC parameters provided")
250 ELSE IF (
ASSOCIATED(sgp_potential))
THEN
251 spotential(ikind)%sgp_potential => sgp_potential
252 IF (
ALLOCATED(sgp_potential%upf_data))
THEN
253 IF (sgp_potential%upf_data%number_of_proj > 0)
THEN
254 IF (sgp_potential%upf_projectors%degree < maxlgto + nder)
THEN
255 CALL upf_projector_init(sgp_potential%upf_data, maxlgto + nder, sgp_potential%upf_projectors)
259 IF (do_soc .AND.
ALLOCATED(sgp_potential%upf_data))
THEN
260 cpabort(
"Spin-orbit UPF projectors are not supported")
266 DO slot = 1, sap_ppnl(1)%nl_size
268 ikind = sap_ppnl(1)%nlist_task(slot)%ikind
269 kkind = sap_ppnl(1)%nlist_task(slot)%jkind
270 iatom = sap_ppnl(1)%nlist_task(slot)%iatom
271 katom = sap_ppnl(1)%nlist_task(slot)%jatom
272 nlist = sap_ppnl(1)%nlist_task(slot)%nlist
273 ilist = sap_ppnl(1)%nlist_task(slot)%ilist
274 nneighbor = sap_ppnl(1)%nlist_task(slot)%nnode
276 iac = ikind + nkind*(kkind - 1)
277 IF (.NOT.
ASSOCIATED(basis_set(ikind)%gto_basis_set)) cycle
278 IF (.NOT.
ASSOCIATED(gpotential(kkind)%gth_potential) .AND. &
279 .NOT.
ASSOCIATED(spotential(kkind)%sgp_potential)) cycle
280 IF (.NOT.
ASSOCIATED(sap_int(iac)%alist))
THEN
281 sap_int(iac)%a_kind = ikind
282 sap_int(iac)%p_kind = kkind
283 sap_int(iac)%nalist = nlist
284 ALLOCATE (sap_int(iac)%alist(nlist))
286 NULLIFY (sap_int(iac)%alist(i)%clist)
287 sap_int(iac)%alist(i)%aatom = 0
288 sap_int(iac)%alist(i)%nclist = 0
291 IF (.NOT.
ASSOCIATED(sap_int(iac)%alist(ilist)%clist))
THEN
292 sap_int(iac)%alist(ilist)%aatom = iatom
293 sap_int(iac)%alist(ilist)%nclist = nneighbor
294 ALLOCATE (sap_int(iac)%alist(ilist)%clist(nneighbor))
296 sap_int(iac)%alist(ilist)%clist(i)%catom = 0
315 ALLOCATE (sab(ldsab, ldsab*maxder), work(ldsab, ldsab*maxder))
317 ALLOCATE (ai_work(ldai, ldai,
ncoset(nder + 1)))
320 ALLOCATE (lab(ldsab, ldsab, 3), work_l(ldsab, ldsab, 3))
325 DO slot = 1, sap_ppnl(1)%nl_size
327 ikind = sap_ppnl(1)%nlist_task(slot)%ikind
328 kkind = sap_ppnl(1)%nlist_task(slot)%jkind
329 iatom = sap_ppnl(1)%nlist_task(slot)%iatom
330 katom = sap_ppnl(1)%nlist_task(slot)%jatom
331 nlist = sap_ppnl(1)%nlist_task(slot)%nlist
332 ilist = sap_ppnl(1)%nlist_task(slot)%ilist
333 nneighbor = sap_ppnl(1)%nlist_task(slot)%nnode
334 jneighbor = sap_ppnl(1)%nlist_task(slot)%inode
335 cell_c(:) = sap_ppnl(1)%nlist_task(slot)%cell(:)
336 rac(1:3) = sap_ppnl(1)%nlist_task(slot)%r(1:3)
338 iac = ikind + nkind*(kkind - 1)
339 IF (.NOT.
ASSOCIATED(basis_set(ikind)%gto_basis_set)) cycle
341 first_sgfa => basis_set(ikind)%gto_basis_set%first_sgf
342 la_max => basis_set(ikind)%gto_basis_set%lmax
343 la_min => basis_set(ikind)%gto_basis_set%lmin
344 npgfa => basis_set(ikind)%gto_basis_set%npgf
345 nseta = basis_set(ikind)%gto_basis_set%nset
346 nsgfa = basis_set(ikind)%gto_basis_set%nsgf
347 nsgf_seta => basis_set(ikind)%gto_basis_set%nsgf_set
348 rpgfa => basis_set(ikind)%gto_basis_set%pgf_radius
349 set_radius_a => basis_set(ikind)%gto_basis_set%set_radius
350 sphi_a => basis_set(ikind)%gto_basis_set%sphi
351 zeta => basis_set(ikind)%gto_basis_set%zet
354 IF (
ASSOCIATED(gpotential(kkind)%gth_potential))
THEN
357 alpha_ppnl => gpotential(kkind)%gth_potential%alpha_ppnl
358 cprj => gpotential(kkind)%gth_potential%cprj
359 lppnl = gpotential(kkind)%gth_potential%lppnl
360 nppnl = gpotential(kkind)%gth_potential%nppnl
361 nprj_ppnl => gpotential(kkind)%gth_potential%nprj_ppnl
362 ppnl_radius = gpotential(kkind)%gth_potential%ppnl_radius
363 vprj_ppnl => gpotential(kkind)%gth_potential%vprj_ppnl
364 wprj_ppnl => gpotential(kkind)%gth_potential%wprj_ppnl
365 ELSE IF (
ASSOCIATED(spotential(kkind)%sgp_potential))
THEN
368 nprjc = spotential(kkind)%sgp_potential%nppnl
369 IF (nprjc == 0) cycle
370 do_upf =
ALLOCATED(spotential(kkind)%sgp_potential%upf_data)
372 upf => spotential(kkind)%sgp_potential%upf_projectors
375 nnl = spotential(kkind)%sgp_potential%n_nonlocal
376 lppnl = spotential(kkind)%sgp_potential%lmax
377 a_nl => spotential(kkind)%sgp_potential%a_nonlocal
378 ppnl_radius = spotential(kkind)%sgp_potential%ppnl_radius
380 radp(:) = ppnl_radius
381 cprj => spotential(kkind)%sgp_potential%cprj_ppnl
382 hprj => spotential(kkind)%sgp_potential%vprj_ppnl
383 nppnl =
SIZE(cprj, 2)
389 dac = sqrt(sum(rac*rac))
390 clist => sap_int(iac)%alist(ilist)%clist(jneighbor)
394 ALLOCATE (clist%acint(nsgfa, nppnl, maxder), &
395 clist%achint(nsgfa, nppnl, maxder), &
396 clist%alint(nsgfa, nppnl, 3), &
397 clist%alkint(nsgfa, nppnl, 3))
399 clist%achint = 0.0_dp
401 clist%alkint = 0.0_dp
404 NULLIFY (clist%sgf_list)
406 ncoa = npgfa(iset)*
ncoset(la_max(iset))
407 sgfa = first_sgfa(1, iset)
414 IF (do_soc) work_l = 0.0_dp
416 nprjc = nprj_ppnl(l)*
nco(l)
417 IF (nprjc == 0) cycle
418 rprjc(1) = ppnl_radius
419 IF (set_radius_a(iset) + rprjc(1) < dac) cycle
420 lc_max = l + 2*(nprj_ppnl(l) - 1)
422 zetc(1) = alpha_ppnl(l)
426 CALL overlap(la_max(iset), la_min(iset), npgfa(iset), rpgfa(:, iset), zeta(:, iset), &
427 lc_max, lc_min, 1, rprjc, zetc, rac, dac, sab, nder, .true., ai_work, ldai)
433 first_col = (i - 1)*ldsab
436 work(1:na, first_col + prjc:first_col + prjc + nb - 1) = &
437 matmul(sab(1:na, first_col + 1:first_col + np), cprj(1:np, prjc:prjc + nb - 1))
443 CALL angmom(la_max(iset), npgfa(iset), zeta(:, iset), rpgfa(:, iset), la_min(iset), &
444 lc_max, 1, zetc, rprjc, -rac, [0._dp, 0._dp, 0._dp], lab)
446 work_l(1:na, prjc:prjc + nb - 1, i_dim) = &
447 matmul(lab(1:na, 1:np, i_dim), cprj(1:np, prjc:prjc + nb - 1))
458 first_col = (i - 1)*ldsab + 1
462 clist%acint(sgfa:sgfa + na - 1, 1:nb, i) = &
463 matmul(transpose(sphi_a(1:np, sgfa:sgfa + na - 1)), work(1:np, first_col:first_col + nb - 1))
467 clist%achint(sgfa:sgfa + na - 1, 1:nb, i) = &
468 matmul(clist%acint(sgfa:sgfa + na - 1, 1:nb, i), vprj_ppnl(1:nb, 1:nb))
472 clist%alint(sgfa:sgfa + na - 1, 1:nb, i_dim) = &
473 matmul(transpose(sphi_a(1:np, sgfa:sgfa + na - 1)), work_l(1:np, 1:nb, i_dim))
474 clist%alkint(sgfa:sgfa + na - 1, 1:nb, i_dim) = &
475 matmul(clist%alint(sgfa:sgfa + na - 1, 1:nb, i_dim), wprj_ppnl(1:nb, 1:nb))
478 ELSE IF (do_upf)
THEN
482 ALLOCATE (upf_int(np, nb, maxder))
486 clist%acint(sgfa:sgfa + na - 1, 1:nb, i) = &
487 matmul(transpose(sphi_a(1:np, sgfa:sgfa + na - 1)), upf_int(:, :, i))
488 clist%achint(sgfa:sgfa + na - 1, 1:nb, i) = &
489 matmul(clist%acint(sgfa:sgfa + na - 1, 1:nb, i), upf%d)
495 CALL overlap(la_max(iset), la_min(iset), npgfa(iset), rpgfa(:, iset), zeta(:, iset), &
496 lppnl, 0, nnl, radp, a_nl, rac, dac, sab, nder, .true., ai_work, ldai)
501 first_col = (i - 1)*ldsab + 1
505 work(1:np, 1:nb) = matmul(sab(1:np, first_col:first_col + nprjc - 1), cprj(1:nprjc, 1:nb))
509 clist%acint(sgfa:sgfa + na - 1, 1:nb, i) = &
510 matmul(transpose(sphi_a(1:np, sgfa:sgfa + na - 1)), work(1:np, 1:nb))
512 ncoc = sgfa + nsgf_seta(iset) - 1
514 clist%achint(sgfa:ncoc, j, i) = clist%acint(sgfa:ncoc, j, i)*hprj(j)
519 clist%maxac = maxval(abs(clist%acint(:, :, 1)))
520 clist%maxach = maxval(abs(clist%achint(:, :, 1)))
521 IF (.NOT. do_gth .AND. .NOT. do_upf)
DEALLOCATE (radp)
524 DEALLOCATE (sab, ai_work, work)
525 IF (do_soc)
DEALLOCATE (lab, work_l)
533 force_thread = 0.0_dp
564 DO slot = 1, sab_orb(1)%nl_size
566 ikind = sab_orb(1)%nlist_task(slot)%ikind
567 jkind = sab_orb(1)%nlist_task(slot)%jkind
568 iatom = sab_orb(1)%nlist_task(slot)%iatom
569 jatom = sab_orb(1)%nlist_task(slot)%jatom
570 cell_b(:) = sab_orb(1)%nlist_task(slot)%cell(:)
571 rab(1:3) = sab_orb(1)%nlist_task(slot)%r(1:3)
573 IF (.NOT.
ASSOCIATED(basis_set(ikind)%gto_basis_set)) cycle
574 IF (.NOT.
ASSOCIATED(basis_set(jkind)%gto_basis_set)) cycle
576 iab = ikind + nkind*(jkind - 1)
579 IF (iatom == jatom)
THEN
586 img = cell_to_index(cell_b(1), cell_b(2), cell_b(3))
592 IF (iatom <= jatom)
THEN
602 NULLIFY (l_block_x, l_block_y, l_block_z)
609 NULLIFY (r_2block, r_3block)
614 IF (calculate_forces .OR. doat)
THEN
620 IF (
ASSOCIATED(h_block))
THEN
625 iac = ikind + nkind*(kkind - 1)
626 ibc = jkind + nkind*(kkind - 1)
627 IF (.NOT.
ASSOCIATED(sap_int(iac)%alist)) cycle
628 IF (.NOT.
ASSOCIATED(sap_int(ibc)%alist)) cycle
629 CALL get_alist(sap_int(iac), alist_ac, iatom)
630 CALL get_alist(sap_int(ibc), alist_bc, jatom)
631 IF (.NOT.
ASSOCIATED(alist_ac)) cycle
632 IF (.NOT.
ASSOCIATED(alist_bc)) cycle
633 DO kac = 1, alist_ac%nclist
634 DO kbc = 1, alist_bc%nclist
635 IF (alist_ac%clist(kac)%catom /= alist_bc%clist(kbc)%catom) cycle
636 IF (all(cell_b + alist_bc%clist(kbc)%cell - alist_ac%clist(kac)%cell == 0))
THEN
637 IF (alist_ac%clist(kac)%maxac*alist_bc%clist(kbc)%maxach < eps_ppnl) cycle
638 acint => alist_ac%clist(kac)%acint
639 bcint => alist_bc%clist(kbc)%acint
640 achint => alist_ac%clist(kac)%achint
641 bchint => alist_bc%clist(kbc)%achint
643 alkint => alist_ac%clist(kac)%alkint
644 blkint => alist_bc%clist(kbc)%alkint
650 IF (.NOT. do_dr)
THEN
651 IF (iatom <= jatom)
THEN
652 h_block(1:na, 1:nb) = h_block(1:na, 1:nb) + &
653 matmul(achint(1:na, 1:np, 1), transpose(bcint(1:nb, 1:np, 1)))
655 h_block(1:nb, 1:na) = h_block(1:nb, 1:na) + &
656 matmul(bchint(1:nb, 1:np, 1), transpose(acint(1:na, 1:np, 1)))
660 IF (iatom <= jatom)
THEN
661 l_block_x(1:na, 1:nb) = l_block_x(1:na, 1:nb) + &
662 matmul(alkint(1:na, 1:np, 1), transpose(bcint(1:nb, 1:np, 1)))
663 l_block_y(1:na, 1:nb) = l_block_y(1:na, 1:nb) + &
664 matmul(alkint(1:na, 1:np, 2), transpose(bcint(1:nb, 1:np, 1)))
665 l_block_z(1:na, 1:nb) = l_block_z(1:na, 1:nb) + &
666 matmul(alkint(1:na, 1:np, 3), transpose(bcint(1:nb, 1:np, 1)))
669 l_block_x(1:nb, 1:na) = l_block_x(1:nb, 1:na) + &
670 matmul(blkint(1:nb, 1:np, 1), transpose(acint(1:na, 1:np, 1)))
671 l_block_y(1:nb, 1:na) = l_block_y(1:nb, 1:na) + &
672 matmul(blkint(1:nb, 1:np, 2), transpose(acint(1:na, 1:np, 1)))
673 l_block_z(1:nb, 1:na) = l_block_z(1:nb, 1:na) + &
674 matmul(blkint(1:nb, 1:np, 3), transpose(acint(1:na, 1:np, 1)))
678 IF (calculate_forces)
THEN
679 IF (
ASSOCIATED(p_block))
THEN
680 katom = alist_ac%clist(kac)%catom
683 IF (iatom <= jatom)
THEN
684 fa(i) = sum(p_block(1:na, 1:nb)* &
685 matmul(acint(1:na, 1:np, j), transpose(bchint(1:nb, 1:np, 1))))
686 fb(i) = sum(p_block(1:na, 1:nb)* &
687 matmul(achint(1:na, 1:np, 1), transpose(bcint(1:nb, 1:np, j))))
689 fa(i) = sum(p_block(1:nb, 1:na)* &
690 matmul(bchint(1:nb, 1:np, 1), transpose(acint(1:na, 1:np, j))))
691 fb(i) = sum(p_block(1:nb, 1:na)* &
692 matmul(bcint(1:nb, 1:np, j), transpose(achint(1:na, 1:np, 1))))
694 force_thread(i, iatom) = force_thread(i, iatom) + f0*fa(i)
695 force_thread(i, katom) = force_thread(i, katom) - f0*fa(i)
696 force_thread(i, jatom) = force_thread(i, jatom) + f0*fb(i)
697 force_thread(i, katom) = force_thread(i, katom) - f0*fb(i)
701 rac = alist_ac%clist(kac)%rac
702 rbc = alist_bc%clist(kbc)%rac
711 katom = alist_ac%clist(kac)%catom
712 IF (iatom <= jatom)
THEN
713 h_block(1:na, 1:nb) = h_block(1:na, 1:nb) + &
714 (deltar(i, iatom) - deltar(i, katom))* &
715 matmul(acint(1:na, 1:np, j), transpose(bchint(1:nb, 1:np, 1)))
717 h_block(1:na, 1:nb) = h_block(1:na, 1:nb) + &
718 (deltar(i, jatom) - deltar(i, katom))* &
719 matmul(achint(1:na, 1:np, 1), transpose(bcint(1:nb, 1:np, j)))
721 h_block(1:nb, 1:na) = h_block(1:nb, 1:na) + &
722 (deltar(i, iatom) - deltar(i, katom))* &
723 matmul(bchint(1:nb, 1:np, 1), transpose(acint(1:na, 1:np, j)))
724 h_block(1:nb, 1:na) = h_block(1:nb, 1:na) + &
725 (deltar(i, jatom) - deltar(i, katom))* &
726 matmul(bcint(1:nb, 1:np, j), transpose(achint(1:na, 1:np, 1)))
730 katom = alist_ac%clist(kac)%catom
731 IF (iatom <= jatom)
THEN
732 r_2block(1:na, 1:nb) = r_2block(1:na, 1:nb) + &
733 (deltar(i, iatom) - deltar(i, katom))* &
734 matmul(acint(1:na, 1:np, j), transpose(bchint(1:nb, 1:np, 1)))
736 r_2block(1:na, 1:nb) = r_2block(1:na, 1:nb) + &
737 (deltar(i, jatom) - deltar(i, katom))* &
738 matmul(achint(1:na, 1:np, 1), transpose(bcint(1:nb, 1:np, j)))
740 r_2block(1:nb, 1:na) = r_2block(1:nb, 1:na) + &
741 (deltar(i, iatom) - deltar(i, katom))* &
742 matmul(bchint(1:nb, 1:np, 1), transpose(acint(1:na, 1:np, j)))
743 r_2block(1:nb, 1:na) = r_2block(1:nb, 1:na) + &
744 (deltar(i, jatom) - deltar(i, katom))* &
745 matmul(bcint(1:nb, 1:np, j), transpose(achint(1:na, 1:np, 1)))
749 katom = alist_ac%clist(kac)%catom
750 IF (iatom <= jatom)
THEN
751 r_3block(1:na, 1:nb) = r_3block(1:na, 1:nb) + &
752 (deltar(i, iatom) - deltar(i, katom))* &
753 matmul(acint(1:na, 1:np, j), transpose(bchint(1:nb, 1:np, 1)))
755 r_3block(1:na, 1:nb) = r_3block(1:na, 1:nb) + &
756 (deltar(i, jatom) - deltar(i, katom))* &
757 matmul(achint(1:na, 1:np, 1), transpose(bcint(1:nb, 1:np, j)))
759 r_3block(1:nb, 1:na) = r_3block(1:nb, 1:na) + &
760 (deltar(i, iatom) - deltar(i, katom))* &
761 matmul(bchint(1:nb, 1:np, 1), transpose(acint(1:na, 1:np, j)))
762 r_3block(1:nb, 1:na) = r_3block(1:nb, 1:na) + &
763 (deltar(i, jatom) - deltar(i, katom))* &
764 matmul(bcint(1:nb, 1:np, j), transpose(achint(1:na, 1:np, 1)))
769 IF (
ASSOCIATED(p_block))
THEN
770 katom = alist_ac%clist(kac)%catom
771 IF (iatom <= jatom)
THEN
772 atk = sum(p_block(1:na, 1:nb)* &
773 matmul(achint(1:na, 1:np, 1), transpose(bcint(1:nb, 1:np, 1))))
775 atk = sum(p_block(1:nb, 1:na)* &
776 matmul(bchint(1:nb, 1:np, 1), transpose(acint(1:na, 1:np, 1))))
778 at_thread(katom) = at_thread(katom) + f0*atk
803 DEALLOCATE (basis_set, gpotential, spotential)
804 IF (calculate_forces)
THEN
808 atom_a = atom_of_kind(iatom)
809 ikind = kind_of(iatom)
810 force(ikind)%gth_ppnl(:, atom_a) = force(ikind)%gth_ppnl(:, atom_a) + force_thread(:, iatom)
813 DEALLOCATE (atom_of_kind, kind_of)
816 IF (calculate_forces .AND. use_virial)
THEN
817 virial%pv_ppnl = virial%pv_ppnl + pv_thread
818 virial%pv_virial = virial%pv_virial + pv_thread
822 atcore(1:natom) = atcore(1:natom) + at_thread
825 IF (calculate_forces .OR. doat)
THEN
828 IF (
SIZE(matrix_p, 1) == 2)
THEN
830 CALL dbcsr_add(matrix_p(1, img)%matrix, matrix_p(2, img)%matrix, &
831 alpha_scalar=0.5_dp, beta_scalar=0.5_dp)
832 CALL dbcsr_add(matrix_p(2, img)%matrix, matrix_p(1, img)%matrix, &
833 alpha_scalar=-1.0_dp, beta_scalar=1.0_dp)
840 CALL timestop(handle)