Branch data Line data Source code
1 : : !!****m* ABINIT/m_dynmat
2 : : !! NAME
3 : : !! m_dynmat
4 : : !!
5 : : !! FUNCTION
6 : : !! This module provides low-level tools to operate on the dynamical matrix
7 : : !!
8 : : !! COPYRIGHT
9 : : !! Copyright (C) 2014-2026 ABINIT group (XG, JCC, MJV, NH, RC, MVeithen, MM, MG, MT, DCA)
10 : : !! This file is distributed under the terms of the
11 : : !! GNU General Public License, see ~abinit/COPYING
12 : : !! or http://www.gnu.org/copyleft/gpl.txt .
13 : : !!
14 : : !! TODO
15 : : !! Use more explicative names for the procedures!
16 : : !!
17 : : !! SOURCE
18 : :
19 : : #if defined HAVE_CONFIG_H
20 : : #include "config.h"
21 : : #endif
22 : :
23 : : #include "abi_common.h"
24 : :
25 : : module m_dynmat
26 : :
27 : : use, intrinsic :: iso_c_binding
28 : : use defs_basis
29 : : use m_abicore
30 : : use m_errors
31 : : use m_linalg_interfaces
32 : : use m_xmpi
33 : :
34 : : use m_fstrings, only : itoa, sjoin
35 : : use m_numeric_tools, only : wrap2_pmhalf, mkherm
36 : : use m_matrix, only : mati3inv, matr3inv
37 : : use m_symtk, only : littlegroup_q
38 : : use m_cgtools, only : fxphas_seq
39 : : use m_crystal, only : crystal_t
40 : : use m_ewald, only : ewald9, ewald9_2D
41 : : use m_time, only : timab
42 : : use m_ifc_supercell, only : ifc_supercell_type
43 : :
44 : : implicit none
45 : :
46 : : private
47 : :
48 : : public :: asria_calc ! Calculate the correction for the Acoustic sum rule on
49 : : ! the InterAtomic Forces or on the dynamical matrix directly
50 : : public :: asria_corr ! Imposition of the Acoustic sum rule on the InterAtomic Forces
51 : : ! or on the dynamical matrix directly from the previously calculated d2asr
52 : : public :: asrprs ! Imposition of the Acoustic sum rule on the InterAtomic Forces Plus Rotational Symmetry
53 : : public :: cart29 ! Transform a second-derivative matrix from reduced coordinates to cartesian coordinates, and also
54 : : ! 1) add the ionic part of the effective charges,
55 : : ! 2) normalize the electronic dielectric tensor, and add the vacuum polarisation
56 : : public :: cart39 ! Transform a vector from reduced coordinates to cartesian coordinates,
57 : : ! taking into account the perturbation from which it was derived,
58 : : ! and also check the existence of the new values.
59 : : public :: d2cart_to_red ! Transform a second-derivative matrix
60 : : ! from cartesian to reduced coordinate.
61 : : public :: chkph3 ! Check the completeness of the dynamical matrix
62 : : public :: chneu9 ! Imposition of the charge neutrality sum rule on the Effective charges
63 : : public :: d2sym3 ! Build (nearly) all the other matrix elements that can be build using symmetries.
64 : : public :: q0dy3_apply ! Takes care of the inclusion of the ewald q=0 term in the dynamical matrix
65 : : public :: q0dy3_calc ! Calculate the q=0 correction term to the dynamical matrix
66 : : ! TODO: 3 routines to symmetrize. Clarify different use cases
67 : : public :: symdyma ! Symmetrize the dynamical matrices
68 : : public :: dfpt_sygra ! Symmetrize derivatives of energy with respect to coordinates,
69 : : public :: dfpt_sydy ! Symmetrize dynamical matrix (eventually diagonal wrt to the atoms)
70 : : public :: wings3 ! Suppress the wings of the cartesian 2DTE for which the diagonal element is not known
71 : : public :: asrif9 ! Imposes the Acoustic Sum Rule to Interatomic Forces
72 : : public :: get_bigbox_and_weights ! Compute
73 : : public :: bigbx9 ! Generates a Big Box of R points for the Fourier Transforms the dynamical matrix
74 : : public :: make_bigbox ! Helper functions that faciliates the generation of a Big Box containing
75 : : public :: canat9 ! From reduced to canonical coordinates
76 : : public :: canct9 ! Convert from canonical coordinates to cartesian coordinates
77 : : public :: chkrp9 ! Check if the rprim used for the definition of the unit cell (in the
78 : : ! inputs) are consistent with the rprim used in the routine generating the Big Box
79 : : public :: dist9 ! Compute the distance between atoms in the big box
80 : : public :: ftifc_q2r ! Fourier transform of the dynamical matrices to obtain interatomic forces (real space).
81 : : public :: ftifc_r2q ! Fourier transform of the interatomic forces to obtain dynamical matrices (reciprocal space).
82 : : public :: dynmat_dq ! Compute the derivative D(q)/dq via Fourier transform of the interatomic forces
83 : : public :: ifclo9 ! Convert from cartesian coordinates to local coordinates
84 : : public :: wght9 ! Generates a weight to each R points of the Big Box and for each pair of atoms
85 : : public :: d3sym ! Given a set of calculated elements of the 3DTE matrix,
86 : : ! build (nearly) all the other matrix elements that can be build using symmetries.
87 : : public :: sytens ! Determines the set of irreductible elements of the nonlinear optical susceptibility
88 : : ! and Raman tensors
89 : : public :: axial9 ! Generates the local coordinates system from the knowledge of the first vector (longitudinal) and
90 : : ! the ifc matrix in cartesian coordinates
91 : : public :: dymfz9 ! Multiply the dynamical matrix by a phase shift to account for normalized canonical coordinates.
92 : : public :: ifc_atom_phase ! Phase factor e^{i 2pi k.dtau} associated with an atom-position difference dtau (dymfz9's building block).
93 : : public :: nanal9 ! Subtract/Add the non-analytical part from one dynamical matrix with number iqpt.
94 : : public :: gtdyn9 ! Generates a dynamical matrix from interatomic force constants and
95 : : ! long-range electrostatic interactions.
96 : : public :: dfpt_phfrq ! Diagonalize IFC(q), return phonon frequencies and eigenvectors.
97 : : ! If q is Gamma, the non-analytical behaviour can be included.
98 : : public :: pheigvec_normalize ! Normalize input eigenvectors in cartesian coordinates.
99 : : public :: phdispl_from_eigvec ! Phonon displacements from eigenvectors
100 : : public :: phangmom_from_eigvec ! compute phonon angular momentum for one q-point from eigenvectors
101 : : public :: dfpt_prtph ! Print phonon frequencies
102 : : public :: massmult_and_breaksym ! Multiply IFC(q) by atomic masses.
103 : : public :: massmult_and_breaksym_cplx ! Version for complex array
104 : :
105 : : ! TODO: Change name,
106 : : public :: ftgam
107 : : public :: ftgam_init
108 : :
109 : : public :: msria_calc ! Calculate the correction for the Acoustic sum rule
110 : : ! + rotational invariance on the IFCs in reciprocal space
111 : : public :: msria_apply ! Apply the correction for the Acoustic sum rule + rotational invariance
112 : : ! If IFCs derivatives calculated both from LW driver and Fourier, correct the interpolation
113 : :
114 : : ! *************************************************************************
115 : :
116 : : contains
117 : : !!***
118 : :
119 : : !!****f* m_dynmat/asria_calc
120 : : !! NAME
121 : : !! asria_calc
122 : : !!
123 : : !! FUNCTION
124 : : !! Calculate the correction for the Acoustic sum rule on the InterAtomic Forces
125 : : !! or on the dynamical matrix directly
126 : : !!
127 : : !! INPUTS
128 : : !! asr=(0 => no ASR, 1 or 2=> the diagonal element is modified to give the ASR,
129 : : !! 5 => impose hermitian solution using lapack call)
130 : : !! d2cart=matrix of second derivatives of total energy, in cartesian coordinates
131 : : !! mpert =maximum number of ipert
132 : : !! natom=number of atom
133 : : !!
134 : : !! OUTPUT
135 : : !! d2asr=matrix used to store the correction needed to fulfill
136 : : !! the acoustic sum rule.
137 : : !!
138 : : !! SOURCE
139 : :
140 : 286 : subroutine asria_calc(asr,d2asr,d2cart,mpert,natom)
141 : :
142 : : !Arguments -------------------------------
143 : : !scalars
144 : : integer,intent(in) :: asr,mpert,natom
145 : : !arrays
146 : : real(dp),intent(in) :: d2cart(2,3,mpert,3,mpert)
147 : : real(dp),intent(out) :: d2asr(2,3,natom,3,natom)
148 : :
149 : : !Local variables-------------------------------
150 : : !scalars
151 : : integer :: idir1,idir2,ii,ipert1,ipert2
152 : : integer :: constrank, imatelem, iconst, nconst, nd2_packed, info
153 : : !character(len=500) :: msg
154 : : !arrays
155 : 286 : integer, allocatable :: packingindex(:,:,:,:)
156 : 286 : real(dp), allocatable :: constraints(:,:,:)
157 : 286 : real(dp), allocatable :: d2cart_packed(:,:)
158 : 286 : real(dp), allocatable :: singvals(:)
159 : 286 : real(dp), allocatable :: constr_rhs(:,:)
160 : 286 : real(dp), allocatable :: work(:,:),rwork(:)
161 : : ! *********************************************************************
162 : :
163 [ + + + + : 127546 : d2asr = zero
+ + + + +
+ ]
164 : :
165 [ + - ]: 286 : if (asr==0) return
166 : :
167 : : !call wrtout(std_out,' asria_calc: calculation of the correction to the ASR for the interatomic forces.')
168 [ + + ]: 1156 : do ipert1=1,natom
169 [ + + ]: 3766 : do idir1=1,3
170 [ + + ]: 11310 : do idir2=1,3
171 : :
172 : : ! Compute d2asr
173 [ + + ]: 47574 : do ipert2=1,natom
174 : : d2asr(:,idir1,ipert1,idir2,ipert1)=&
175 : : & d2asr(:,idir1,ipert1,idir2,ipert1)+&
176 [ + + ]: 119232 : & d2cart(:,idir1,ipert1,idir2,ipert2)
177 : : end do
178 : : end do
179 : : end do
180 : : end do
181 : :
182 : : !holistic method: overwrite d2asr with hermitian solution
183 [ - + ]: 286 : if (asr == 5) then
184 : 0 : nconst = 9*natom
185 : 0 : nd2_packed = 3*natom*(3*natom+1)/2
186 [ # # # # : 0 : ABI_MALLOC(constraints,(2,nconst, nd2_packed))
# # # # #
# # # # #
# # ]
187 [ # # # # : 0 : ABI_MALLOC(d2cart_packed,(2,nd2_packed))
# # # # #
# # # ]
188 [ # # # # : 0 : ABI_MALLOC(constr_rhs,(2,nd2_packed))
# # # # ]
189 [ # # # # : 0 : ABI_MALLOC(singvals,(nconst))
# # # # #
# # # ]
190 [ # # # # : 0 : ABI_MALLOC(work,(2,3*nd2_packed))
# # # # #
# # # #
# ]
191 [ # # # # : 0 : ABI_MALLOC(rwork,(5*nd2_packed))
# # # # #
# # # #
# ]
192 [ # # # # : 0 : ABI_MALLOC(packingindex,(3,natom,3,natom))
# # # # #
# # # # #
# # # # ]
193 : 0 : ii=1
194 [ # # # # : 0 : packingindex=-1
# # # # ]
195 [ # # ]: 0 : do ipert2=1,natom
196 [ # # ]: 0 : do idir2=1,3
197 [ # # ]: 0 : do ipert1=1,ipert2-1
198 [ # # ]: 0 : do idir1=1,3
199 : 0 : packingindex(idir1,ipert1,idir2,ipert2) = ii
200 : 0 : ii = ii+1
201 : : end do
202 : : end do
203 [ # # ]: 0 : do idir1=1,idir2
204 : 0 : packingindex(idir1,ipert2,idir2,ipert2) = ii
205 : 0 : ii = ii+1
206 : : end do
207 : : end do
208 : : end do
209 : : ! setup constraint matrix
210 [ # # # # : 0 : constraints = zero
# # ]
211 [ # # ]: 0 : do ipert1=1,natom
212 [ # # ]: 0 : do idir1=1,3
213 [ # # ]: 0 : do idir2=1,3
214 : 0 : iconst = idir2+3*(idir1-1 + 3*(ipert1-1))
215 : : ! set all atom forces, this component
216 [ # # ]: 0 : do ipert2=1,natom
217 : 0 : imatelem = packingindex(idir1,ipert1,idir2,ipert2)
218 [ # # ]: 0 : if (imatelem == -1) then
219 : 0 : imatelem = packingindex(idir2,ipert2,idir1,ipert1)
220 : : end if
221 : 0 : constraints(1,iconst,imatelem) = one
222 : : end do
223 : : end do
224 : : end do
225 : : end do
226 : :
227 [ # # # # ]: 0 : d2cart_packed = -999.0d0
228 [ # # ]: 0 : do ipert2=1,natom
229 [ # # ]: 0 : do idir2=1,3
230 [ # # ]: 0 : do ipert1=1,natom
231 [ # # ]: 0 : do idir1=1,3
232 : 0 : imatelem = packingindex(idir1,ipert1,idir2,ipert2)
233 [ # # ]: 0 : if (imatelem == -1) cycle
234 [ # # ]: 0 : d2cart_packed(:,imatelem) = d2cart(:,idir1,ipert1,idir2,ipert2)
235 : : end do
236 : : end do
237 : : end do
238 : : end do
239 [ # # # # ]: 0 : constr_rhs = zero
240 [ # # # # : 0 : constr_rhs(1,1:nconst) = matmul(constraints(1,:,:),d2cart_packed(1,:))
# # ]
241 [ # # # # : 0 : constr_rhs(2,1:nconst) = matmul(constraints(1,:,:),d2cart_packed(2,:))
# # ]
242 : :
243 : : ! lwork = 3*nd2_packed
244 : : call zgelss (nconst,nd2_packed,1,constraints,nconst,constr_rhs,nd2_packed,&
245 : 0 : & singvals,-one,constrank,work,3*nd2_packed,rwork,info)
246 [ # # ]: 0 : ABI_CHECK(info == 0, sjoin('zgelss returned:', itoa(info)))
247 : :
248 : : ! unpack
249 [ # # ]: 0 : do ipert2=1,natom
250 [ # # ]: 0 : do idir2=1,3
251 [ # # ]: 0 : do ipert1=1,natom
252 [ # # ]: 0 : do idir1=1,3
253 : 0 : imatelem = packingindex(idir1,ipert1,idir2,ipert2)
254 [ # # ]: 0 : if (imatelem == -1) then
255 : 0 : imatelem = packingindex(idir2,ipert2,idir1,ipert1)
256 : : ! NOTE: should complex conjugate the correction below.
257 : : end if
258 [ # # ]: 0 : d2asr(:,idir1,ipert1,idir2,ipert2) = constr_rhs(:,imatelem)
259 : : end do
260 : : end do
261 : : end do
262 : : end do
263 : :
264 [ # # ]: 0 : ABI_FREE(constraints)
265 [ # # ]: 0 : ABI_FREE(d2cart_packed)
266 [ # # ]: 0 : ABI_FREE(singvals)
267 [ # # ]: 0 : ABI_FREE(constr_rhs)
268 [ # # ]: 0 : ABI_FREE(work)
269 [ # # ]: 0 : ABI_FREE(rwork)
270 [ # # ]: 0 : ABI_FREE(packingindex)
271 : : end if
272 : :
273 : : end subroutine asria_calc
274 : : !!***
275 : :
276 : : !----------------------------------------------------------------------
277 : :
278 : : !!****f* m_dynmat/asria_corr
279 : : !! NAME
280 : : !! asria_corr
281 : : !!
282 : : !! FUNCTION
283 : : !! Imposition of the Acoustic sum rule on the InterAtomic Forces
284 : : !! or on the dynamical matrix directly from the previously calculated d2asr
285 : : !!
286 : : !! INPUTS
287 : : !! asr=(0 => no ASR, 1 or 2=> the diagonal element is modified to give the ASR,
288 : : !! 5 => impose hermitian solution using lapack call)
289 : : !! d2asr=matrix used to store the correction needed to fulfill
290 : : !! the acoustic sum rule.
291 : : !! mpert =maximum number of ipert
292 : : !! natom=number of atom
293 : : !!
294 : : !! OUTPUT
295 : : !! Input/Output:
296 : : !! d2cart=matrix of second derivatives of total energy, in cartesian coordinates
297 : : !!
298 : : !! SOURCE
299 : :
300 : 255 : subroutine asria_corr(asr,d2asr,d2cart,mpert,natom)
301 : :
302 : : !Arguments -------------------------------
303 : : !scalars
304 : : integer,intent(in) :: asr,mpert,natom
305 : : !arrays
306 : : real(dp),intent(in) :: d2asr(2,3,natom,3,natom)
307 : : real(dp),intent(inout) :: d2cart(2,3,mpert,3,mpert)
308 : :
309 : : !Local variables-------------------------------
310 : : !scalars
311 : : integer :: idir1,idir2,ipert1,ipert2
312 : : ! *********************************************************************
313 : :
314 [ + - ]: 255 : if (asr==0) return
315 : : !call wrtout(std_out,' asria_corr: imposition of the ASR for the interatomic forces.')
316 : :
317 : : ! Remove d2asr
318 [ + + ]: 961 : do ipert2=1,natom
319 [ + + ]: 3079 : do idir2=1,3
320 [ + + ]: 11518 : do ipert1=1,natom
321 [ + + ]: 36894 : do idir1=1,3
322 [ + + ]: 86940 : d2cart(:,idir1,ipert1,idir2,ipert2)= d2cart(:,idir1,ipert1,idir2,ipert2) - d2asr(:,idir1,ipert1,idir2,ipert2)
323 : : end do
324 : : end do
325 : : end do
326 : : end do
327 : :
328 : : end subroutine asria_corr
329 : : !!***
330 : :
331 : : !----------------------------------------------------------------------
332 : :
333 : : !!****f* m_dynmat/asrprs
334 : : !! NAME
335 : : !! asrprs
336 : : !!
337 : : !! FUNCTION
338 : : !! Imposition of the Acoustic sum rule on the InterAtomic Forces Plus Rotational Symmetry
339 : : !!
340 : : !! INPUTS
341 : : !! asr=(3 => 1D systems, all elements are modified to give ASR and
342 : : !! rotational symmetry)
343 : : !! (4 => 0D systems, all elements are modified to give ASR and
344 : : !! rotational symmetry)
345 : : !! asrflg=(1 => the correction to enforce asr is computed from
346 : : !! d2cart, but NOT applied;
347 : : !! 2 => one uses the previously determined correction)
348 : : !! minvers=previously calculated inverted coefficient matrix
349 : : !! mpert =maximum number of ipert
350 : : !! natom=number of atom
351 : : !! rotinv=(1,2,3 => for linear systems along x,y,z
352 : : !! 4 => non-linear molecule
353 : : !! xcart=cartesian coordinates of the ions
354 : : !!
355 : : !! OUTPUT
356 : : !! (see side effects)
357 : : !!
358 : : !! SIDE EFFECTS
359 : : !! Input/Output:
360 : : !! d2cart=matrix of second derivatives of total energy, in cartesian coordinates
361 : : !! minvers=inverse of the supermatrix for future application of the corrections
362 : : !!
363 : : !! SOURCE
364 : :
365 : 24 : subroutine asrprs(asr,asrflag,rotinv,uinvers,vtinvers,singular,d2cart,mpert,natom,xcart)
366 : :
367 : : !Arguments ------------------------------------
368 : : !scalars
369 : : integer,intent(in) :: asr,asrflag,mpert,natom,rotinv
370 : : !arrays
371 : : real(dp),intent(in) :: xcart(3,natom)
372 : : real(dp),intent(inout) :: d2cart(2,3,mpert,3,mpert)
373 : : real(dp),intent(inout) :: singular(1:3*natom*(3*natom-1)/2)
374 : : real(dp),intent(inout) :: uinvers(1:3*natom*(3*natom-1)/2,1:3*natom*(3*natom-1)/2)
375 : : real(dp),intent(inout) :: vtinvers(1:3*natom*(3*natom-1)/2,1:3*natom*(3*natom-1)/2)
376 : :
377 : : !Local variables-------------------------------
378 : : !scalars
379 : : integer :: column,idir1,idir2,ii,info,ipert1,ipert2,jj,n3,row,superdim
380 : : real(dp) :: rcond,test
381 : : ! real(dp) :: tau ! tau is present but commented out in this routine
382 : : character(len=500) :: msg
383 : : !arrays
384 : 48 : integer :: check(3,natom,3)
385 : 48 : real(dp) :: tmp(natom,3,3),weightf(1:natom,1:natom)
386 : 24 : real(dp),allocatable :: d2cartold(:,:,:,:,:),d2vecc(:),d2veccnew(:),d2vecr(:)
387 : 24 : real(dp),allocatable :: d2vecrnew(:),superm(:,:),umatrix(:,:),vtmatrix(:)
388 : 24 : real(dp),allocatable :: work(:)
389 : : ! *********************************************************************
390 : :
391 [ - + ]: 24 : if(asr/=3 .and. asr/=4)then
392 : : write(msg,'(3a,i0)')&
393 : 0 : 'The argument asr should be 3 or 4,',ch10, 'however, asr = ',asr
394 : 0 : ABI_BUG(msg)
395 : : end if
396 : :
397 [ + - ]: 24 : if (asr==3.or.asr==4)then
398 : 24 : write(msg, '(a,a)' ) ch10, &
399 : 48 : 'asrprs: imposition of the ASR for the interatomic forces and rotational invariance'
400 : 24 : call wrtout(std_out,msg)
401 : : end if
402 : :
403 : 24 : write(msg,'(a,i0)')' asrflag is ', asrflag
404 [ + + ]: 72 : call wrtout([std_out, ab_out], msg)
405 : :
406 : : !variables for the dimensions of the matrices
407 : :
408 : : !n1=3*natom*(3*natom-1)/2
409 : : !n2=9*natom
410 : 24 : n3=3*natom
411 : :
412 : 24 : superdim=9*natom*(natom-1)/2+n3
413 : :
414 [ - + + - : 72 : ABI_MALLOC(d2vecr,(1:superdim))
+ - + - -
+ - + ]
415 [ - + + - : 48 : ABI_MALLOC(d2vecc,(1:superdim))
- + - + ]
416 [ + + ]: 384 : d2vecr=0d0
417 [ + + ]: 384 : d2vecc=0d0
418 : :
419 : : !should be changed set to delta function for debugging
420 [ + + + + ]: 168 : weightf=1d0
421 : : !tau=1d-10
422 [ + + ]: 72 : do ii=1, natom
423 : : ! do jj=1, ii-1
424 : : ! weightf(ii,jj)= &
425 : : ! & ((xcart(1,ii)-xcart(1,jj))**2+(xcart(2,ii)-xcart(2,jj))**2+(xcart(3,ii)-xcart(3,jj))**2)**tau
426 : : ! enddo
427 : 72 : weightf(ii,ii)=0d0
428 : : end do
429 : :
430 [ - + + - : 120 : ABI_MALLOC(d2cartold,(2,3,mpert,3,mpert))
+ - - + +
- + - + -
- + - + ]
431 : :
432 [ - + + + : 163488 : d2cartold=d2cart
+ + + + +
+ + + ]
433 : :
434 : : !setup vector with uncorrected derivatives
435 : :
436 [ + + ]: 72 : do ipert1=1, natom
437 [ + + ]: 96 : do ipert2=1, ipert1-1
438 [ + + ]: 144 : do idir1=1,3
439 [ + + ]: 312 : do idir2=1,3
440 : 216 : row=n3+9*(ipert1-1)*(ipert1-2)/2+9*(ipert2-1)+3*(idir1-1)+idir2
441 [ + + ]: 216 : if(abs(d2cart(1,idir1,ipert1,idir2,ipert2))<1d-6)then
442 : 110 : d2cart(1,idir1,ipert1,idir2,ipert2)=0d0
443 : : else
444 : 106 : d2vecr(row)=4*weightf(ipert1,ipert2)*d2cart(1,idir1,ipert1,idir2,ipert2)
445 : : end if
446 [ + + ]: 288 : if(abs(d2cart(2,idir1,ipert1,idir2,ipert2))<1d-6) then
447 : 126 : d2cart(2,idir1,ipert1,idir2,ipert2)=0d0
448 : : else
449 : 90 : d2vecc(row)=4*weightf(ipert1,ipert2)*d2cart(2,idir1,ipert1,idir2,ipert2)
450 : : end if
451 : : end do
452 : : end do
453 : : end do
454 : : end do
455 : :
456 [ + + ]: 24 : if(asrflag==1) then !calculate the pseudo-inverse of the supermatrix
457 [ - + + - : 8 : ABI_MALLOC(superm,(1:superdim,1:superdim))
- + + - +
- + - - +
- + ]
458 : :
459 [ + + + + ]: 482 : superm=0d0
460 : :
461 : : ! Setting up the supermatrix containing G, A, D
462 : :
463 [ + + ]: 6 : do ipert1=1, natom
464 [ + + ]: 16 : do idir1=1, 3
465 : : ! Setting up G
466 : 12 : idir2=mod(idir1,3)+1
467 : 12 : row=3*(ipert1-1)+idir1
468 [ + + ]: 18 : do ipert2=1, ipert1-1
469 : 6 : column=9*(ipert1-1)*(ipert1-2)/2+9*(ipert2-1)+3*(rotinv-1)+idir1
470 : 6 : superm(column,row)=xcart(idir2,ipert2)-xcart(idir2,ipert1)
471 : 6 : column=9*(ipert1-1)*(ipert1-2)/2+9*(ipert2-1)+3*(rotinv-1)+idir2
472 : 18 : superm(column,row)=xcart(idir1,ipert1)-xcart(idir1,ipert2)
473 : : end do
474 [ + + ]: 22 : do ipert2=ipert1+1, natom
475 : 6 : column=9*(ipert2-1)*(ipert2-2)/2+9*(ipert1-1)+3*(idir1-1)+rotinv
476 : 6 : superm(column,row)=xcart(idir2,ipert2)-xcart(idir2,ipert1)
477 : 6 : column=9*(ipert2-1)*(ipert2-2)/2+9*(ipert1-1)+3*(idir2-1)+rotinv
478 : 18 : superm(column,row)=xcart(idir1,ipert1)-xcart(idir1,ipert2)
479 : : end do
480 : : end do
481 [ + + ]: 18 : do idir1=1, 3
482 : : ! Setting up D
483 : 12 : idir2=mod(idir1,3)+1
484 : 12 : ii=mod(idir1+1,3)+1
485 [ + + ]: 18 : do ipert2=1, ipert1-1
486 : 6 : row=n3+9*(ipert1-1)*(ipert1-2)/2+9*(ipert2-1)+3*(rotinv-1)+idir1
487 : 6 : column=9*natom*(natom-1)/2+3*(ipert1-1)+idir1
488 : 6 : superm(column,row)=superm(column,row)+xcart(idir2,ipert2)-xcart(idir2,ipert1)
489 : 6 : column=9*natom*(natom-1)/2+3*(ipert1-1)+ii
490 : 6 : superm(column,row)=superm(column,row)+xcart(ii,ipert1)-xcart(ii,ipert2)
491 : 6 : row=n3+9*(ipert1-1)*(ipert1-2)/2+9*(ipert2-1)+3*(idir1-1)+rotinv
492 : 6 : column=9*natom*(natom-1)/2+3*(ipert2-1)+idir1
493 : 6 : superm(column,row)=superm(column,row)+xcart(idir2,ipert1)-xcart(idir2,ipert2)
494 : 6 : column=9*natom*(natom-1)/2+3*(ipert2-1)+ii
495 : 18 : superm(column,row)=superm(column,row)+xcart(ii,ipert2)-xcart(ii,ipert1)
496 : : end do
497 : : ! Setting up A
498 [ + + ]: 52 : do idir2=1, 3
499 [ + + ]: 66 : do ipert2=1, ipert1-1
500 : 18 : column=9*(ipert1-1)*(ipert1-2)/2+9*(ipert2-1)+3*(idir1-1)+idir2
501 : 18 : row=n3+column
502 : 54 : superm(column,row)=4*weightf(ipert1,ipert2)
503 : : end do
504 : : end do
505 : : end do
506 : : end do
507 : :
508 : : ! calculate the pseudo-inverse of the supermatrix
509 : :
510 [ - + + - : 6 : ABI_MALLOC(work,(1:6*superdim))
+ - + - -
+ - + ]
511 [ - + + - : 4 : ABI_MALLOC(vtmatrix,(1:superdim))
- + - + ]
512 [ - + + - : 6 : ABI_MALLOC(umatrix,(1:superdim,1:superdim))
- + + - -
+ - + ]
513 : :
514 : : ! singular value decomposition of superm
515 : :
516 : : call dgesvd('A','O',superdim,superdim,superm,superdim,singular,umatrix,superdim, &
517 : 2 : vtmatrix, 1, work,6*superdim,info)
518 [ - + ]: 2 : ABI_CHECK(info == 0, sjoin('dgesvd returned:', itoa(info)))
519 : :
520 [ - + ]: 2 : ABI_FREE(vtmatrix)
521 [ - + ]: 2 : ABI_FREE(work)
522 : :
523 : 2 : write(msg, '(a,es16.8,es16.8)' )' Largest and smallest values from svd', singular(1), singular(superdim)
524 [ + + ]: 6 : call wrtout([std_out, ab_out], msg)
525 : :
526 : : ! Invert U and V**T, orthogonal matrices
527 : :
528 [ + + + + ]: 482 : uinvers = transpose(umatrix)
529 [ + + + + ]: 482 : vtinvers = transpose(superm)
530 : :
531 [ - + ]: 2 : ABI_FREE(umatrix)
532 [ - + ]: 2 : ABI_FREE(superm)
533 : :
534 : 2 : write(msg,'(a,a)')' asrprs: done with asrflag 1', ch10
535 : 2 : call wrtout(std_out,msg)
536 : :
537 : : end if !asrflag=1
538 : :
539 [ + + ]: 24 : if(asrflag==2) then
540 : :
541 [ - + + - : 66 : ABI_MALLOC(d2vecrnew,(1:superdim))
+ - + - -
+ - + ]
542 [ - + + - : 44 : ABI_MALLOC(d2veccnew,(1:superdim))
- + - + ]
543 : :
544 : : ! Calculate V**T**-1 Sigma**-1 U**-1 *rhs
545 : :
546 [ + - - + : 5632 : d2vecrnew = matmul(uinvers, d2vecr)
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- + + + +
+ + ]
547 [ + - - + : 5632 : d2veccnew = matmul(uinvers, d2vecc)
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- + + + +
+ + ]
548 : :
549 : 22 : rcond=1d-10*singular(1)
550 [ + + ]: 352 : do ii=1, superdim
551 [ + + ]: 352 : if(singular(ii)>rcond) then
552 : 286 : d2vecrnew(ii)=d2vecrnew(ii)/singular(ii)
553 : 286 : d2veccnew(ii)=d2veccnew(ii)/singular(ii)
554 : : else
555 : 44 : d2vecrnew(ii)=0d0
556 : 44 : d2veccnew(ii)=0d0
557 : : end if
558 : : end do
559 : :
560 [ + + ]: 352 : do ii=1, superdim
561 : 330 : d2vecr(ii)=0d0
562 : 330 : d2vecc(ii)=0d0
563 [ + + ]: 5302 : do jj=1, superdim
564 : 4950 : d2vecr(ii)=d2vecr(ii)+vtinvers(ii,jj)*d2vecrnew(jj)
565 : 5280 : d2vecc(ii)=d2vecc(ii)+vtinvers(ii,jj)*d2veccnew(jj)
566 : : end do
567 : : end do
568 : :
569 : : ! Store vector back into the matrix of 2nd order derivates
570 : :
571 [ + + ]: 66 : do ipert1=1, natom
572 [ + + ]: 88 : do ipert2=1, ipert1-1
573 [ + + ]: 132 : do idir1=1,3
574 [ + + ]: 286 : do idir2=1,3
575 : 198 : row=9*(ipert1-1)*(ipert1-2)/2+9*(ipert2-1)+3*(idir1-1)+idir2
576 : 198 : d2cart(1,idir1,ipert1,idir2,ipert2)=d2vecr(row)
577 : 198 : d2cart(2,idir1,ipert1,idir2,ipert2)=d2vecc(row)
578 : 198 : d2cart(1,idir2,ipert2,idir1,ipert1)=d2vecr(row)
579 : 264 : d2cart(2,idir2,ipert2,idir1,ipert1)=d2vecc(row)
580 : : end do
581 : : end do
582 : : end do
583 : : end do
584 : :
585 [ - + ]: 22 : ABI_FREE(d2vecrnew)
586 [ - + ]: 22 : ABI_FREE(d2veccnew)
587 : :
588 [ + + + + : 616 : check=0
+ + ]
589 : :
590 [ + + ]: 66 : do ipert1=1, natom
591 [ + + ]: 198 : do idir1=1, 3
592 [ + + ]: 572 : do idir2=1, 3
593 : 396 : d2cart(1,idir1,ipert1,idir2,ipert1)=0d0
594 : 396 : d2cart(2,idir1,ipert1,idir2,ipert1)=0d0
595 : 396 : tmp(ipert1,idir1,idir2)=0d0
596 [ + + ]: 1320 : do ipert2=1, natom
597 [ + + ]: 1188 : if(ipert2/=ipert1) then
598 : : tmp(ipert1,idir1,idir2)=tmp(ipert1,idir1,idir2) &
599 : : & -d2cart(1,idir1,ipert1,idir2,ipert2) &
600 : 396 : & -d2cart(1,idir2,ipert2,idir1,ipert1)
601 : : end if
602 : : end do
603 : : end do
604 : : end do
605 : : end do
606 : :
607 [ + + ]: 66 : do ipert1=1, natom
608 [ + + ]: 198 : do idir1=1, 3
609 [ + + ]: 572 : do idir2=1, 3
610 : 396 : d2cart(1,idir1,ipert1,idir2,ipert1)=tmp(ipert1,idir1,idir2)/2
611 : 528 : d2cart(1,idir2,ipert1,idir1,ipert1)=d2cart(1,idir1,ipert1,idir2,ipert1)
612 : : end do
613 : : end do
614 : : end do
615 : :
616 : 22 : write(std_out,*) 'this should all be zero'
617 : :
618 [ + + ]: 66 : do ipert1=1, natom
619 [ + + ]: 198 : do idir1=1, 3
620 [ + + ]: 572 : do idir2=1, 3
621 : 396 : test=0d0
622 [ + + ]: 1188 : do ipert2=1, natom
623 : 1188 : test=test+d2cart(1,idir1,ipert1,idir2,ipert2)+d2cart(1,idir2,ipert2,idir1,ipert1)
624 : : end do
625 : 396 : write(std_out,'(i3,i3,i3,es11.3)') idir1,ipert1,idir2,test
626 : :
627 : 396 : write(msg, '(i3,i3,i3,es11.3)' ) idir1,ipert1,idir2,test
628 : 528 : call wrtout(ab_out,msg)
629 : : end do
630 : : end do
631 : : end do
632 : :
633 : 22 : write(std_out,*) 'these as well'
634 [ + + ]: 66 : do ipert2=1, natom
635 [ + + ]: 198 : do idir1=1, 3
636 [ + + ]: 572 : do idir2=1, 3
637 : 396 : test=0d0
638 [ + + ]: 1188 : do ipert1=1, natom
639 : 1188 : test=test+d2cart(1,idir1,ipert1,idir2,ipert2)
640 : : end do
641 : 528 : write(std_out,'(i3,i3,i3,i3,es11.3)') idir1,ipert1,idir2,ipert2,test
642 : : end do
643 : : end do
644 : : end do
645 : :
646 : 22 : write(msg,'(a,a)')' asrprs: done with asrflag 2', ch10
647 : 22 : call wrtout(std_out,msg)
648 : :
649 : : end if !ends asrflag=2
650 : :
651 [ - + ]: 24 : ABI_FREE(d2vecr)
652 [ - + ]: 24 : ABI_FREE(d2vecc)
653 [ - + ]: 24 : ABI_FREE(d2cartold)
654 : :
655 : 24 : end subroutine asrprs
656 : : !!***
657 : :
658 : : !----------------------------------------------------------------------
659 : :
660 : : !!****f* m_dynmat/cart29
661 : : !! NAME
662 : : !! cart29
663 : : !!
664 : : !!
665 : : !! FUNCTION
666 : : !! Transform a second-derivative matrix from reduced
667 : : !! coordinates to cartesian coordinates, and also
668 : : !! 1) add the ionic part of the effective charges,
669 : : !! 2) normalize the electronic dielectric tensor, and
670 : : !! add the vacuum polarisation
671 : : !!
672 : : !! INPUTS
673 : : !! blkflg(3,mpert,3,mpert,nblok)=
674 : : !! ( 1 if the element of the dynamical matrix has been calculated ;
675 : : !! 0 otherwise )
676 : : !! blkval(2,3,mpert,3,mpert,nblok)=DDB values
677 : : !! gprimd(3,3)=basis vector in the reciprocal space
678 : : !! iblok=number of the blok that will be transformed
679 : : !! mpert =maximum number of ipert
680 : : !! natom=number of atom
681 : : !! nblok=number of blocks (dimension of blkflg and blkval)
682 : : !! ntypat=number of atom types
683 : : !! rprimd(3,3)=basis vector in the real space
684 : : !! typat(natom)=integer label of each type of atom (1,2,...)
685 : : !! ucvol=unit cell volume
686 : : !! zion(ntypat)=charge corresponding to the atom type
687 : : !!
688 : : !! OUTPUT
689 : : !! carflg(3,mpert,3,mpert)= ( 1 if the element of the cartesian
690 : : !! 2DTE matrix has been calculated correctly ; 0 otherwise )
691 : : !! d2cart(2,3,mpert,3,mpert)=
692 : : !! dynamical matrix, effective charges, dielectric tensor,....
693 : : !! all in cartesian coordinates
694 : : !!
695 : : !! SOURCE
696 : :
697 : 2315 : subroutine cart29(blkflg,blkval,carflg,d2cart,&
698 : 2315 : & gprimd,iblok,mpert,natom,nblok,ntypat,rprimd,typat,ucvol,zion)
699 : :
700 : : !Arguments -------------------------------
701 : : !scalars
702 : : integer,intent(in) :: iblok,mpert,natom,nblok,ntypat
703 : : real(dp),intent(in) :: ucvol
704 : : !arrays
705 : : integer,intent(in) :: blkflg(3,mpert,3,mpert,nblok),typat(natom)
706 : : integer,intent(out) :: carflg(3,mpert,3,mpert)
707 : : real(dp),intent(in) :: blkval(2,3,mpert,3,mpert,nblok),gprimd(3,3),rprimd(3,3)
708 : : real(dp),intent(in) :: zion(ntypat)
709 : : real(dp),intent(out) :: d2cart(2,3,mpert,3,mpert)
710 : :
711 : : !Local variables -------------------------
712 : : !scalars
713 : : integer :: idir1,idir2,ii,ipert1,ipert2
714 : : !arrays
715 : : integer :: flg1(3),flg2(3)
716 : 4630 : integer :: mflg(3,mpert,3,mpert)
717 : : real(dp) :: vec1(3),vec2(3)
718 : : ! *********************************************************************
719 : :
720 : : !First, copy the data blok in place.
721 [ + + + + : 21429833 : d2cart(:,:,:,:,:)=blkval(:,:,:,:,:,iblok)
+ + + + +
+ ]
722 : :
723 : : !Cartesian coordinates transformation (in two steps)
724 : : !First step
725 [ + + ]: 40862 : do ipert1=1,mpert
726 [ + + ]: 749973 : do ipert2=1,mpert
727 [ + + ]: 2165880 : do ii=1,2
728 [ + + ]: 6381999 : do idir1=1,3
729 [ + + ]: 17018664 : do idir2=1,3
730 : 12763998 : vec1(idir2)=d2cart(ii,idir1,ipert1,idir2,ipert2)
731 : : ! Note here blkflg
732 : 17018664 : flg1(idir2)=blkflg(idir1,ipert1,idir2,ipert2,iblok)
733 : : end do
734 : 4254666 : call cart39(flg1,flg2,gprimd,ipert2,natom,rprimd,vec1,vec2)
735 [ + + ]: 18436886 : do idir2=1,3
736 : 12763998 : d2cart(ii,idir1,ipert1,idir2,ipert2)=vec2(idir2)
737 : : ! And here carflg
738 : 17018664 : carflg(idir1,ipert1,idir2,ipert2)=flg2(idir2)
739 : : end do
740 : : end do
741 : : end do
742 : : end do
743 : : end do
744 : :
745 : : !Second step
746 [ + + ]: 40862 : do ipert1=1,mpert
747 [ + + ]: 749973 : do ipert2=1,mpert
748 [ + + ]: 2165880 : do ii=1,2
749 [ + + ]: 6381999 : do idir2=1,3
750 [ + + ]: 17018664 : do idir1=1,3
751 : 12763998 : vec1(idir1)=d2cart(ii,idir1,ipert1,idir2,ipert2)
752 : : ! Note here carflg
753 : 17018664 : flg1(idir1)=carflg(idir1,ipert1,idir2,ipert2)
754 : : end do
755 : 4254666 : call cart39(flg1,flg2,gprimd,ipert1,natom,rprimd,vec1,vec2)
756 [ + + ]: 18436886 : do idir1=1,3
757 : 12763998 : d2cart(ii,idir1,ipert1,idir2,ipert2)=vec2(idir1)
758 : : ! And here carflg again
759 : 17018664 : carflg(idir1,ipert1,idir2,ipert2)=flg2(idir1)
760 : : end do
761 : : end do
762 : : end do
763 : : end do
764 : : end do
765 : :
766 : : !For the dielectric tensor, takes into account the volume
767 : : !of the unit cell, and add the unit matrix (polarization of the vacuum)
768 [ + + ]: 9260 : do idir1=1,3
769 [ + + ]: 30095 : do idir2=1,3
770 [ + + ]: 69450 : do ii=1,2
771 : : d2cart(ii,idir1,natom+2,idir2,natom+2)=&
772 : 62505 : & -four_pi/ucvol*d2cart(ii,idir1,natom+2,idir2,natom+2)
773 : : end do
774 : : end do
775 : : end do
776 : :
777 [ + + ]: 9260 : do idir1=1,3
778 : : d2cart(1,idir1,natom+2,idir1,natom+2)=&
779 : 9260 : & 1.0_dp+d2cart(1,idir1,natom+2,idir1,natom+2)
780 : : end do
781 : :
782 : : !Add the ionic charges to delta z to get the effective charges
783 [ + + ]: 10172 : do ipert1=1,natom
784 [ + + ]: 33743 : do idir1=1,3
785 : : d2cart(1,idir1,ipert1,idir1,natom+2)=&
786 : 31428 : & zion(typat(ipert1))+d2cart(1,idir1,ipert1,idir1,natom+2)
787 : : end do
788 : : end do
789 [ + + ]: 10172 : do ipert2=1,natom
790 [ + + ]: 33743 : do idir2=1,3
791 : : d2cart(1,idir2,natom+2,idir2,ipert2)=&
792 : 31428 : & zion(typat(ipert2))+d2cart(1,idir2,natom+2,idir2,ipert2)
793 : : end do
794 : : end do
795 : :
796 : : !For the piezoelectric tensor, takes into account the volume of the unit cell
797 [ + + ]: 6945 : do ipert2=natom+3,natom+4
798 [ + + ]: 20835 : do idir1=1,3
799 [ + + ]: 60190 : do idir2=1,3
800 [ + + ]: 138900 : do ii=1,2
801 : : d2cart(ii,idir1,natom+2,idir2,ipert2)=&
802 : 83340 : & (1.0_dp/ucvol)*d2cart(ii,idir1,natom+2,idir2,ipert2)
803 : : d2cart(ii,idir2,ipert2,idir1,natom+2)=&
804 : 125010 : & (1.0_dp/ucvol)*d2cart(ii,idir2,ipert2,idir1,natom+2)
805 : : end do
806 : : end do
807 : : end do
808 : : end do
809 : :
810 : : !MRoyo: For magnetic Zeeman perturbations, apply a negative sign to get induced magnetic moments.
811 : : !Macroscopic Zeeman
812 [ + + + + : 8665835 : mflg= 0
+ + + + ]
813 : 2315 : ipert1=natom+5
814 [ + + ]: 9260 : do idir1=1,3
815 [ + + ]: 74501 : do ipert2= 1, natom+6 !exclude local Zeemans, to be done below
816 [ + + ]: 267909 : do idir2=1,3
817 [ + + ]: 195723 : if (mflg(idir1,ipert1,idir2,ipert2)==0) then
818 [ + + ]: 566334 : do ii=1,2
819 : : d2cart(ii,idir1,ipert1,idir2,ipert2)=&
820 : 377556 : & -one*d2cart(ii,idir1,ipert1,idir2,ipert2)
821 : 566334 : mflg(idir1,ipert1,idir2,ipert2)=1
822 : : end do
823 : : end if
824 [ + + ]: 260964 : if (mflg(idir2,ipert2,idir1,ipert1)==0) then
825 [ + + ]: 545499 : do ii=1,2
826 : : d2cart(ii,idir2,ipert2,idir1,ipert1)=&
827 : 363666 : & -one*d2cart(ii,idir2,ipert2,idir1,ipert1)
828 : 545499 : mflg(idir2,ipert2,idir1,ipert1)=1
829 : : end do
830 : : end if
831 : : end do
832 : : end do
833 : : end do
834 : :
835 : : !Local Zeemans
836 [ + + ]: 2315 : if (mpert>natom+MPERT_MAX) then
837 [ + + ]: 8854 : do ipert1= natom+12,2*natom+11
838 [ + + ]: 29785 : do idir1=1,3
839 [ + + ]: 466319 : do ipert2= 1, mpert
840 [ + + ]: 1774575 : do idir2=1,3
841 [ + + ]: 1315233 : if (mflg(idir1,ipert1,idir2,ipert2)==0) then
842 [ + + ]: 3508713 : do ii=1,2
843 : : d2cart(ii,idir1,ipert1,idir2,ipert2)=&
844 : 2339142 : & -one*d2cart(ii,idir1,ipert1,idir2,ipert2)
845 : 3508713 : mflg(idir1,ipert1,idir2,ipert2)=1
846 : : end do
847 : : end if
848 [ + + ]: 1753644 : if (mflg(idir2,ipert2,idir1,ipert1)==0) then
849 [ + + ]: 3445920 : do ii=1,2
850 : : d2cart(ii,idir2,ipert2,idir1,ipert1)=&
851 : 2297280 : & -one*d2cart(ii,idir2,ipert2,idir1,ipert1)
852 : 3445920 : mflg(idir2,ipert2,idir1,ipert1)=1
853 : : end do
854 : : end if
855 : : end do
856 : : end do
857 : : end do
858 : : end do
859 : : end if
860 : :
861 : : !For magnetoelectric and magnetic susceptibility apply a 1/ucvol factor
862 : 2315 : ipert1= natom + 2
863 : 2315 : ipert2= natom + 5
864 [ + + ]: 9260 : do idir1= 1, 3
865 [ + + ]: 30095 : do idir2= 1, 3
866 [ + + ]: 69450 : do ii=1,2
867 : : d2cart(ii,idir1,ipert1,idir2,ipert2)=&
868 : 41670 : & d2cart(ii,idir1,ipert1,idir2,ipert2)/ucvol
869 : : d2cart(ii,idir2,ipert2,idir1,ipert1)=&
870 : 41670 : & d2cart(ii,idir2,ipert2,idir1,ipert1)/ucvol
871 : : d2cart(ii,idir1,ipert2,idir2,ipert2)=&
872 : 62505 : & d2cart(ii,idir1,ipert2,idir2,ipert2)/ucvol
873 : : end do
874 : : end do
875 : : end do
876 : :
877 : 2315 : end subroutine cart29
878 : : !!***
879 : :
880 : : !----------------------------------------------------------------------
881 : :
882 : : !!****f* m_dynmat/cart39
883 : : !! NAME
884 : : !! cart39
885 : : !!
886 : : !!
887 : : !! FUNCTION
888 : : !! Transform a vector from reduced coordinates to cartesian coordinates,
889 : : !! taking into account the perturbation from which it was derived,
890 : : !! and also check the existence of the new values.
891 : : !!
892 : : !! INPUTS
893 : : !! flg1(3)=tell if information of each component of vec1 is valid
894 : : !! gprimd(3,3)=basis vector in the reciprocal space
895 : : !! ipert=number of the perturbation
896 : : !! natom=number of atom
897 : : !! rprimd(3,3)=basis vector in the real space
898 : : !! vec1(3)=input vector, in reduced coordinates
899 : : !!
900 : : !! OUTPUT
901 : : !! flg2(3)=tell if information of each component of vec2 is valid
902 : : !! vec2(3)=output vector, in cartesian coordinates
903 : : !!
904 : : !! SOURCE
905 : :
906 : 18234876 : subroutine cart39(flg1,flg2,gprimd,ipert,natom,rprimd,vec1,vec2)
907 : :
908 : : !Arguments -------------------------------
909 : : !scalars
910 : : integer,intent(in) :: ipert,natom
911 : : !arrays
912 : : integer,intent(in) :: flg1(3)
913 : : integer,intent(out) :: flg2(3)
914 : : real(dp),intent(in) :: gprimd(3,3),rprimd(3,3),vec1(3)
915 : : real(dp),intent(out) :: vec2(3)
916 : :
917 : : !Local variables -------------------------
918 : : !scalars
919 : : integer :: idir,ii
920 : : ! *********************************************************************
921 : :
922 : : !Treat phonon-type perturbation
923 [ + - + + ]: 18234876 : if(ipert>=1.and.ipert<=natom)then
924 : :
925 [ + + ]: 17947560 : do idir=1,3
926 : 13460670 : vec2(idir)=zero
927 : 13460670 : flg2(idir)=1
928 [ + + ]: 53842680 : do ii=1,3
929 [ + + ]: 53842680 : if(abs(gprimd(idir,ii))>1.0d-10)then
930 [ + + ]: 19988040 : if(flg1(ii)==1)then
931 : 5585401 : vec2(idir)=vec2(idir)+gprimd(idir,ii)*vec1(ii)
932 : : else
933 : 14402639 : flg2(idir)=0
934 : : end if
935 : : end if
936 : : end do
937 [ + + ]: 17947560 : if(flg2(idir)==0)vec2(idir)=zero
938 : : end do
939 : :
940 : : ! Treat electric field and qvec perturbations
941 [ + + + + ]: 13747986 : else if(ipert==natom+2.or.ipert==natom+8) then
942 : : ! OCL SCALAR
943 [ + + ]: 7786224 : do idir=1,3
944 : 5839668 : vec2(idir)=zero
945 : 5839668 : flg2(idir)=1
946 : : ! OCL SCALAR
947 [ + + ]: 23358672 : do ii=1,3
948 [ + + ]: 23358672 : if(abs(rprimd(idir,ii))>1.0d-10)then
949 [ + + ]: 8569860 : if(flg1(ii)==1)then
950 : 1366773 : vec2(idir)=vec2(idir)+rprimd(idir,ii)*vec1(ii)/two_pi
951 : : else
952 : 7203087 : flg2(idir)=0
953 : : end if
954 : : end if
955 : : end do
956 [ + + ]: 7786224 : if(flg2(idir)==0)vec2(idir)=zero
957 : : end do
958 : :
959 : : ! Treat other perturbations
960 : : else
961 [ + + ]: 47205720 : do idir=1,3
962 : 35404290 : vec2(idir)=vec1(idir)
963 : 47205720 : flg2(idir)=flg1(idir)
964 : : end do
965 : : end if
966 : :
967 : 18234876 : end subroutine cart39
968 : : !!***
969 : :
970 : : !----------------------------------------------------------------------
971 : :
972 : : !!****f* m_dynmat/d2cart_to_red
973 : : !! NAME
974 : : !! d2cart_to_red
975 : : !!
976 : : !!
977 : : !! FUNCTION
978 : : !! Transform a second-derivative matrix from cartesian
979 : : !! coordinates to reduced coordinate. Also,
980 : : !! 1) remove the ionic part of the effective charges,
981 : : !! 2) remove the vacuum polarisation from the dielectric tensor
982 : : !! and scale it with the unit cell volume
983 : : !! In short, does the inverse operation of cart29.
984 : : !!
985 : : !! INPUTS
986 : : !! d2cart(2,3,mpert,3,mpert)=
987 : : !! second-derivative matrix in cartesian coordinates
988 : : !! gprimd(3,3)=basis vector in the reciprocal space
989 : : !! rprimd(3,3)=basis vector in the real space
990 : : !! mpert =maximum number of ipert
991 : : !! natom=number of atom
992 : : !!
993 : : !! OUTPUT
994 : : !! d2red(2,3,mpert,3,mpert)=
995 : : !! second-derivative matrix in reduced coordinates
996 : : !!
997 : : !! SOURCE
998 : :
999 : 2223 : subroutine d2cart_to_red(d2cart, d2red, gprimd, rprimd, mpert, natom, &
1000 : 2223 : & ntypat,typat,ucvol,zion)
1001 : :
1002 : : !Arguments -------------------------------
1003 : : !scalars
1004 : : integer,intent(in) :: mpert,natom,ntypat
1005 : : real(dp),intent(in) :: ucvol
1006 : : !arrays
1007 : : integer,intent(in) :: typat(natom)
1008 : : real(dp),intent(in) :: d2cart(2,3,mpert,3,mpert)
1009 : : real(dp),intent(out) :: d2red(2,3,mpert,3,mpert)
1010 : : real(dp),intent(in) :: gprimd(3,3),rprimd(3,3)
1011 : : real(dp),intent(in) :: zion(ntypat)
1012 : :
1013 : : !Local variables -------------------------
1014 : : !scalars
1015 : : integer :: idir1,idir2,ii,ipert1,ipert2
1016 : : real(dp) :: fac
1017 : : !arrays
1018 : : integer :: flg1(3),flg2(3)
1019 : : real(dp) :: vec1(3),vec2(3)
1020 : : real(dp) :: gprimdt(3,3),rprimdt(3,3)
1021 : : ! *********************************************************************
1022 : :
1023 [ + + ]: 8892 : flg1 = one
1024 [ + + ]: 8892 : flg2 = one
1025 : :
1026 [ + + + + : 4996765 : d2red = d2cart
+ + + + +
+ ]
1027 : :
1028 : : !Remove the ionic charges to z to get the change in effective charges
1029 [ + + ]: 7322 : do ipert1=1,natom
1030 [ + + ]: 22619 : do idir1=1,3
1031 : : d2red(1,idir1,ipert1,idir1,natom+2)=&
1032 : 20396 : & d2red(1,idir1,ipert1,idir1,natom+2) - zion(typat(ipert1))
1033 : : end do
1034 : : end do
1035 [ + + ]: 7322 : do ipert2=1,natom
1036 [ + + ]: 22619 : do idir2=1,3
1037 : : d2red(1,idir2,natom+2,idir2,ipert2)=&
1038 : 20396 : & d2red(1,idir2,natom+2,idir2,ipert2) - zion(typat(ipert2))
1039 : : end do
1040 : : end do
1041 : :
1042 : : ! Remove the vacuum polarizability from the dielectric tensor
1043 [ + + ]: 8892 : do idir1=1,3
1044 : : d2red(1,idir1,natom+2,idir1,natom+2)=&
1045 : 8892 : & d2red(1,idir1,natom+2,idir1,natom+2) - 1.0_dp
1046 : : end do
1047 : :
1048 : : ! Scale the dielectric tensor with the volue of the unit cell
1049 [ + + ]: 8892 : do idir1=1,3
1050 [ + + ]: 28899 : do idir2=1,3
1051 [ + + ]: 66690 : do ii=1,2
1052 : : d2red(ii,idir1,natom+2,idir2,natom+2)=&
1053 : 60021 : & - (ucvol / four_pi) * d2red(ii,idir1,natom+2,idir2,natom+2)
1054 : : end do
1055 : : end do
1056 : : end do
1057 : :
1058 : : !For the piezoelectric tensor, takes into account the volume of the unit cell
1059 [ + + ]: 6669 : do ipert2=natom+3,natom+4
1060 [ + + ]: 20007 : do idir1=1,3
1061 [ + + ]: 57798 : do idir2=1,3
1062 [ + + ]: 133380 : do ii=1,2
1063 : : d2red(ii,idir1,natom+2,idir2,ipert2)=&
1064 : 80028 : & (ucvol)*d2red(ii,idir1,natom+2,idir2,ipert2)
1065 : : d2red(ii,idir2,ipert2,idir1,natom+2)=&
1066 : 120042 : & (ucvol)*d2red(ii,idir2,ipert2,idir1,natom+2)
1067 : : end do
1068 : : end do
1069 : : end do
1070 : : end do
1071 : :
1072 : : ! Reduced coordinates transformation (in two steps)
1073 : : ! Note that rprimd and gprimd are swapped, compared to what cart39 expects
1074 : : ! A factor of (2pi) ** 2 is added to transform the electric field perturbations
1075 : :
1076 [ + + + + ]: 28899 : rprimdt = transpose(rprimd)
1077 [ + + + + ]: 28899 : gprimdt = transpose(gprimd)
1078 : :
1079 : : !First step
1080 [ + + ]: 20716 : do ipert1=1,mpert
1081 [ + + ]: 18493 : fac = one; if (ipert1==natom+2) fac = two_pi ** 2
1082 : :
1083 [ + + ]: 184735 : do ipert2=1,mpert
1084 [ + + ]: 510550 : do ii=1,2
1085 [ + + ]: 1476171 : do idir1=1,3
1086 [ + + ]: 3936456 : do idir2=1,3
1087 : 3936456 : vec1(idir2)=d2red(ii,idir1,ipert1,idir2,ipert2)
1088 : : end do
1089 : : ! Transform vector from cartesian to reduced coordinates
1090 : 984114 : call cart39(flg1,flg2,rprimdt,ipert1,natom,gprimdt,vec1,vec2)
1091 [ + + ]: 4264494 : do idir2=1,3
1092 : 3936456 : d2red(ii,idir1,ipert1,idir2,ipert2)=vec2(idir2) * fac
1093 : : end do
1094 : : end do
1095 : : end do
1096 : : end do
1097 : : end do
1098 : :
1099 : : !Second step
1100 [ + + ]: 20716 : do ipert1=1,mpert
1101 [ + + ]: 184735 : do ipert2=1,mpert
1102 [ + + ]: 164019 : fac = one; if (ipert2==natom+2) fac = two_pi ** 2
1103 : :
1104 [ + + ]: 510550 : do ii=1,2
1105 [ + + ]: 1476171 : do idir2=1,3
1106 [ + + ]: 3936456 : do idir1=1,3
1107 : 3936456 : vec1(idir1)=d2red(ii,idir1,ipert1,idir2,ipert2)
1108 : : end do
1109 : : ! Transform vector from cartesian to reduced coordinates
1110 : 984114 : call cart39(flg1,flg2,rprimdt,ipert2,natom,gprimdt,vec1,vec2)
1111 [ + + ]: 4264494 : do idir1=1,3
1112 : 3936456 : d2red(ii,idir1,ipert1,idir2,ipert2)=vec2(idir1) * fac
1113 : : end do
1114 : : end do
1115 : : end do
1116 : : end do
1117 : : end do
1118 : :
1119 : :
1120 : 2223 : end subroutine d2cart_to_red
1121 : : !!***
1122 : :
1123 : : !----------------------------------------------------------------------
1124 : :
1125 : : !!****f* m_dynmat/chkph3
1126 : : !! NAME
1127 : : !! chkph3
1128 : : !!
1129 : : !! FUNCTION
1130 : : !! Check the completeness of the dynamical matrix and eventually send a warning
1131 : : !!
1132 : : !! INPUTS
1133 : : !! carflg(3,mpert,3,mpert)= ( 1 if the element of the cartesian
1134 : : !! 2DTE matrix has been calculated correctly ; 0 otherwise )
1135 : : !! idir = direction of the eventual electric field
1136 : : !! mpert =maximum number of ipert
1137 : : !! natom=number of atoms in unit cell
1138 : : !!
1139 : : !! OUTPUT
1140 : : !! eventually send a warning message
1141 : : !!
1142 : : !! SOURCE
1143 : :
1144 : 601 : subroutine chkph3(carflg,idir,mpert,natom)
1145 : :
1146 : : !Arguments -------------------------------
1147 : : !scalars
1148 : : integer,intent(in) :: idir,mpert,natom
1149 : : !arrays
1150 : : integer,intent(in) :: carflg(3,mpert,3,mpert)
1151 : :
1152 : : !Local variables -------------------------
1153 : : !scalars
1154 : : integer :: idir1,idir2,ipert1,ipert2,send
1155 : : character(len=500) :: msg
1156 : : ! *********************************************************************
1157 : :
1158 : 601 : send=0
1159 : :
1160 : : !Check the elements of the analytical part of the dynamical matrix
1161 [ + + ]: 1852 : do ipert2=1,natom
1162 [ + + ]: 5605 : do idir2=1,3
1163 [ + + ]: 14967 : do ipert1=1,natom
1164 [ + + ]: 43605 : do idir1=1,3
1165 [ + + ]: 39852 : if(carflg(idir1,ipert1,idir2,ipert2)==0)then
1166 : 8501 : send=1
1167 : : end if
1168 : : end do
1169 : : end do
1170 : : end do
1171 : : end do
1172 : :
1173 : : !If some electric field is present
1174 [ + + ]: 601 : if(idir/=0)then
1175 : :
1176 : : ! Check the dielectric constant
1177 [ - + ]: 219 : if(carflg(idir,natom+2,idir,natom+2)==0)then
1178 : 0 : send=1
1179 : : end if
1180 : :
1181 : : ! Check the effective charges
1182 [ + + ]: 707 : do ipert1=1,natom
1183 [ + + ]: 2171 : do idir1=1,3
1184 [ + + ]: 1952 : if(carflg(idir1,ipert1,idir,natom+2)==0)then
1185 : 39 : send=1
1186 : : end if
1187 : : end do
1188 : : end do
1189 : :
1190 : : end if
1191 : :
1192 : : ! If needed, send the message
1193 [ + + ]: 601 : if(send==1)then
1194 : : write(msg, '(a,a,a,a)' )&
1195 : 75 : & ' chkph3 : WARNING -',ch10,&
1196 : 150 : & ' Dynamical matrix incomplete, phonon frequencies may be wrong, see the log file for more explanations.'
1197 : 75 : call wrtout(ab_out,msg)
1198 : : write(msg, '(11a)' )&
1199 : 75 : & ' chkph3 : WARNING -',ch10,&
1200 : 75 : & ' Dynamical matrix incomplete, phonon frequencies may be wrong.',ch10,&
1201 : 75 : & ' Likely due to a list of perturbations, as defined by rfatpol and rfdir, that does not include',ch10,&
1202 : 75 : & ' all displacements of all atoms and (if non-metallic material) electric field type perturbation.',ch10,&
1203 : 75 : & ' Then, the dynamical matrix includes zeroes when the matrix element is not computed.',ch10,&
1204 : 150 : & ' This is allowed for testing purposes. But the phonon frequencies may be wrong.'
1205 : 75 : call wrtout(std_out,msg)
1206 : : write(msg, '(9a)' )&
1207 : 75 : & ' If there are symmetries, perhaps these matrix elements are zero by symmetry anyhow, and phonon frequencies might be right.',ch10,&
1208 : 75 : & ' Please check the input variables rfatpol and rfdir, to determine whether abinit is doing what you intend it to do.',ch10,&
1209 : 75 : & ' Note that ANADDB is able to detect whether the symmetries allow one to reconstruct the full dynamical matrix from',ch10,&
1210 : 75 : & ' an incomplete one. In this case, passing to ANADDB the delivered _DDB file might confirm (or not) that',ch10,&
1211 : 150 : & ' phonon frequencies are right.'
1212 : 75 : call wrtout(std_out,msg)
1213 : : end if
1214 : :
1215 : 601 : end subroutine chkph3
1216 : : !!***
1217 : :
1218 : : !----------------------------------------------------------------------
1219 : :
1220 : : !!****f* m_dynmat/chneu9
1221 : : !! NAME
1222 : : !! chneu9
1223 : : !!
1224 : : !! FUNCTION
1225 : : !! Imposition of the charge neutrality sum rule on the Effective charges
1226 : : !! and suppress the imaginary part of the dynamical matrix
1227 : : !!
1228 : : !! INPUTS
1229 : : !! chneut=(0 => no ASR, 1 => equal repartition, 2 => weighted repartition )
1230 : : !! mpert =maximum number of ipert
1231 : : !! natom=number of atom
1232 : : !! ntypat=number of types of atoms in unit cell
1233 : : !! selectz=selection of some parts of the effective charge tensor attached to one atom.
1234 : : !! (0=> no selection, 1=> trace only, 2=> symmetric part only)
1235 : : !! typat(natom)=type of the atom
1236 : : !! zion(ntypat)=atomic charge for every type of atom
1237 : : !!
1238 : : !! SIDE EFFECTS
1239 : : !! Input/Output
1240 : : !! d2cart=matrix of second derivatives of total energy, in cartesian
1241 : : !! coordinates
1242 : : !!
1243 : : !! SOURCE
1244 : :
1245 : 194 : subroutine chneu9(chneut,d2cart,mpert,natom,ntypat,selectz,typat,zion)
1246 : :
1247 : : !Arguments -------------------------------
1248 : : !scalars
1249 : : integer,intent(in) :: chneut,mpert,natom,ntypat,selectz
1250 : : !arrays
1251 : : integer,intent(in) :: typat(natom)
1252 : : real(dp),intent(in) :: zion(ntypat)
1253 : : real(dp),intent(inout) :: d2cart(2,3,mpert,3,mpert)
1254 : :
1255 : : !Local variables -------------------------
1256 : : !scalars
1257 : : integer :: idir1,idir2,ii,ipert1,ipert2
1258 : : character(len=500) :: msg
1259 : : !arrays
1260 : : real(dp) :: sumwght(2)
1261 : 194 : real(dp),allocatable :: wghtat(:)
1262 : : ! *********************************************************************
1263 : :
1264 [ - + + - : 582 : ABI_MALLOC(wghtat,(natom))
+ - + - -
+ - + ]
1265 : :
1266 : : !In case of acoustic sum rule imposition, compute the weights on each atom.
1267 [ + + ]: 194 : if (chneut==1)then
1268 : :
1269 : : ! The weight is the same for all atom
1270 [ + + ]: 659 : do ipert1=1,natom
1271 : 659 : wghtat(ipert1)=1./natom
1272 : : end do
1273 : :
1274 [ + + ]: 22 : else if (chneut==2) then
1275 : :
1276 : : ! The weight is proportional to the diagonal electronic screening charge of the atom
1277 : 11 : sumwght(1)=zero
1278 [ + + ]: 66 : do ipert1=1,natom
1279 : 55 : wghtat(ipert1)=zero
1280 [ + + ]: 220 : do idir1=1,3
1281 : : wghtat(ipert1)=wghtat(ipert1)+&
1282 : : & d2cart(1,idir1,ipert1,idir1,natom+2)+&
1283 : 220 : & d2cart(1,idir1,natom+2,idir1,ipert1)-2*zion(typat(ipert1))
1284 : : end do
1285 : 66 : sumwght(1)=sumwght(1)+wghtat(ipert1)
1286 : : end do
1287 : :
1288 : : ! Normalize the weights to unity
1289 [ + + ]: 66 : wghtat(1:natom) = wghtat(1:natom) / sumwght(1)
1290 : : end if
1291 : :
1292 : : !Calculation of the violation of the charge neutrality
1293 : : !and imposition of the charge neutrality condition
1294 [ + + ]: 194 : if (chneut/=0)then
1295 : : write(msg, '(a,a,a,a,a,a,a)' )&
1296 : 183 : ' The violation of the charge neutrality conditions',ch10,&
1297 : 183 : ' by the effective charges is as follows :',ch10,&
1298 : 183 : ' atom electric field',ch10,&
1299 : 366 : ' displacement direction '
1300 : 183 : call wrtout(ab_out,msg)
1301 [ + + ]: 732 : do idir1=1,3
1302 [ + + ]: 2379 : do idir2=1,3
1303 [ + + ]: 4941 : do ii=1,2
1304 : 3294 : sumwght(ii)=zero
1305 [ + + ]: 13050 : do ipert1=1,natom
1306 : 13050 : sumwght(ii)=sumwght(ii)+d2cart(ii,idir1,ipert1,idir2,natom+2)
1307 : : end do
1308 [ + + ]: 14697 : do ipert1=1,natom
1309 : : d2cart(ii,idir1,ipert1,idir2,natom+2)=&
1310 : 13050 : d2cart(ii,idir1,ipert1,idir2,natom+2)-sumwght(ii)*wghtat(ipert1)
1311 : : end do
1312 : : end do
1313 : 1647 : write(msg, '(i8,i16,2f16.6)' ) idir1,idir2,sumwght(1),sumwght(2)
1314 : 2196 : call wrtout(ab_out,msg)
1315 : : end do
1316 : : end do
1317 : 183 : write(msg, '(a)' )' '
1318 : 183 : call wrtout(ab_out,msg)
1319 : :
1320 : : ! The same for the symmetrical part
1321 [ + + ]: 732 : do idir1=1,3
1322 [ + + ]: 2379 : do idir2=1,3
1323 [ + + ]: 5490 : do ii=1,2
1324 : 3294 : sumwght(ii)=zero
1325 [ + + ]: 13050 : do ipert2=1,natom
1326 : 13050 : sumwght(ii)=sumwght(ii)+d2cart(ii,idir1,natom+2,idir2,ipert2)
1327 : : end do
1328 [ + + ]: 14697 : do ipert2=1,natom
1329 : : d2cart(ii,idir1,natom+2,idir2,ipert2)=&
1330 : 13050 : d2cart(ii,idir1,natom+2,idir2,ipert2)-sumwght(ii)*wghtat(ipert2)
1331 : : end do
1332 : : end do
1333 : : end do
1334 : : end do
1335 : : end if
1336 : :
1337 : : !Selection of the trace of the effective charge tensor attached to each atom
1338 [ - + ]: 194 : if(selectz==1)then
1339 [ # # ]: 0 : do ipert1=1,natom
1340 [ # # ]: 0 : do ii=1,2
1341 : 0 : sumwght(ii)=zero
1342 [ # # ]: 0 : do idir1=1,3
1343 : 0 : sumwght(ii)=sumwght(ii)+d2cart(ii,idir1,ipert1,idir1,natom+2)
1344 : : end do
1345 [ # # ]: 0 : do idir1=1,3
1346 [ # # ]: 0 : do idir2=1,3
1347 : 0 : d2cart(ii,idir1,ipert1,idir2,natom+2)=zero
1348 : : end do
1349 : : end do
1350 [ # # ]: 0 : do idir1=1,3
1351 : 0 : d2cart(ii,idir1,ipert1,idir1,natom+2)=sumwght(ii)/3.0_dp
1352 : : end do
1353 : : end do
1354 : : end do
1355 : : ! Do the same for the symmetrical part of d2cart
1356 [ # # ]: 0 : do ipert2=1,natom
1357 [ # # ]: 0 : do ii=1,2
1358 : 0 : sumwght(ii)=zero
1359 [ # # ]: 0 : do idir1=1,3
1360 : 0 : sumwght(ii)=sumwght(ii)+d2cart(ii,idir1,natom+2,idir1,ipert2)
1361 : : end do
1362 [ # # ]: 0 : do idir1=1,3
1363 [ # # ]: 0 : do idir2=1,3
1364 : 0 : d2cart(ii,idir1,natom+2,idir2,ipert2)=zero
1365 : : end do
1366 : : end do
1367 [ # # ]: 0 : do idir1=1,3
1368 : 0 : d2cart(ii,idir1,natom+2,idir1,ipert2)=sumwght(ii)/3.0_dp
1369 : : end do
1370 : : end do
1371 : : end do
1372 : : end if
1373 : :
1374 : : !Selection of the symmetric part of the effective charge tensor attached to each atom
1375 [ - + ]: 194 : if(selectz==2)then
1376 [ # # ]: 0 : do ipert1=1,natom
1377 [ # # ]: 0 : do ii=1,2
1378 [ # # ]: 0 : do idir1=1,3
1379 [ # # ]: 0 : do idir2=1,3
1380 : : sumwght(ii)=(d2cart(ii,idir1,ipert1,idir2,natom+2)&
1381 : 0 : & +d2cart(ii,idir2,ipert1,idir1,natom+2))/2.0_dp
1382 : 0 : d2cart(ii,idir1,ipert1,idir2,natom+2)=sumwght(ii)
1383 : 0 : d2cart(ii,idir2,ipert1,idir1,natom+2)=sumwght(ii)
1384 : : end do
1385 : : end do
1386 : : end do
1387 : : end do
1388 : : ! Do the same for the symmetrical part of d2cart
1389 [ # # ]: 0 : do ipert1=1,natom
1390 [ # # ]: 0 : do ii=1,2
1391 [ # # ]: 0 : do idir1=1,3
1392 [ # # ]: 0 : do idir2=1,3
1393 : : sumwght(ii)=(d2cart(ii,idir1,ipert1,idir2,natom+2)&
1394 : 0 : & +d2cart(ii,idir2,ipert1,idir1,natom+2))/2.0_dp
1395 : 0 : d2cart(ii,idir1,ipert1,idir2,natom+2)=sumwght(ii)
1396 : 0 : d2cart(ii,idir2,ipert1,idir1,natom+2)=sumwght(ii)
1397 : : end do
1398 : : end do
1399 : : end do
1400 : : end do
1401 : : end if
1402 : :
1403 : : !Write the effective charge tensor
1404 : : write(msg, '(a,a,a,a,a,a,a)' )&
1405 : 194 : ' Effective charge tensors after ',ch10,&
1406 : 194 : ' imposition of the charge neutrality (if requested by user),',ch10,&
1407 : 194 : ' and eventual restriction to some part :',ch10,&
1408 : 388 : ' atom displacement '
1409 : 194 : call wrtout(ab_out,msg)
1410 : :
1411 [ + + ]: 770 : do ipert1=1,natom
1412 [ + + ]: 2498 : do idir1=1,3
1413 [ + - + + ]: 6912 : write(msg, '(2i10,3es16.6)' )ipert1,idir1,(d2cart(1,idir1,ipert1,idir2,natom+2),idir2=1,3)
1414 : 2304 : call wrtout(ab_out,msg)
1415 : : end do
1416 : : end do
1417 : :
1418 : : !Zero the imaginary part of the dynamical matrix
1419 : 194 : write(msg, '(a)' )' Now, the imaginary part of the dynamical matrix is zeroed '
1420 : 194 : call wrtout(ab_out,msg)
1421 : 194 : call wrtout(std_out,msg)
1422 : :
1423 [ + + + + : 32474 : d2cart(2, 1:3, 1:natom, 1:3, 1:natom) = zero
+ + + + ]
1424 : :
1425 [ - + ]: 194 : ABI_FREE(wghtat)
1426 : :
1427 : 194 : end subroutine chneu9
1428 : : !!***
1429 : :
1430 : : !----------------------------------------------------------------------
1431 : :
1432 : : !!****f* m_dynmat/d2sym3
1433 : : !! NAME
1434 : : !! d2sym3
1435 : : !!
1436 : : !! FUNCTION
1437 : : !! Given a set of calculated elements of the 2DTE matrix d2,
1438 : : !! build (nearly) all the other matrix elements that can be build using symmetries.
1439 : : !!
1440 : : !! 1. Perform first some completion by symmetrisation (exchange)
1441 : : !! over the two defining perturbations
1442 : : !! 2. For each element, uses every symmetry, and build the element, in case
1443 : : !! EITHER all the needed elements are available,
1444 : : !! OR the only missing is itself
1445 : : !! OR the perturbation is the electric field, in a diamond
1446 : : !! symmetry (the last case was coded rather dirty)
1447 : : !!
1448 : : !! INPUTS
1449 : : !! indsym(4,nsym,natom)=indirect indexing array : for each
1450 : : !! isym,iatom, fourth element is label of atom into which iatom is sent by
1451 : : !! INVERSE of symmetry operation isym; first three elements are the primitive
1452 : : !! translations which must be subtracted after the transformation to get back
1453 : : !! to the original unit cell.
1454 : : !! mpert =maximum number of ipert
1455 : : !! natom= number of atoms
1456 : : !! nsym=number of space group symmetries
1457 : : !! qpt(3)=wavevector of the perturbation
1458 : : !! symq(4,2,nsym)= (integer) three first numbers define the G vector ;
1459 : : !! fourth number is zero if the q-vector is not preserved,
1460 : : !! is 1 otherwise
1461 : : !! second index is one without time-reversal symmetry,
1462 : : !! two with time-reversal symmetry
1463 : : !! symrec(3,3,nsym)=3x3 matrices of the group symmetries (reciprocal space)
1464 : : !! symrel(3,3,nsym)=3x3 matrices of the group symmetries (real space)
1465 : : !! timrev=1 if the time-reversal symmetry preserves the wavevector,
1466 : : !! modulo a reciprocal lattice vector, timrev=0 otherwise
1467 : : !! zero_by_symm= if 1, set blkflg to 1 for the elements that must be zero by symmetry, and zero them.
1468 : : !! This has the indirect effect of being able to resymmetrize the whole matrix, thus
1469 : : !! enforcing better the symmetry for the 2DTE.
1470 : : !!
1471 : : !! SIDE EFFECTS
1472 : : !! Input/Output
1473 : : !! d2(2,3,mpert,3,mpert)= matrix of the 2DTE
1474 : : !! blkflg(3,mpert,3,mpert)= ( 1 if the element of the dynamical
1475 : : !! matrix has been calculated ; 0 otherwise)
1476 : : !!
1477 : : !! NOTES
1478 : : !! The complete search would be to have the possibility
1479 : : !! of a set of missing elements. See notes of July 2, 1994,
1480 : : !! in the blue notebook 'computer codes'
1481 : : !! The partial solution adopted here takes into
1482 : : !! account some mirror symmetries
1483 : : !! as well as the tetrahedral symmetry of the diamond lattice
1484 : : !! On 010331, replaced the loops up to mpert by loops up to
1485 : : !! natom+2, because of a crash bug under Windows. However,
1486 : : !! the problem lies likely in the use of the indsym array.
1487 : : !!
1488 : : !! SOURCE
1489 : :
1490 : 174682 : subroutine d2sym3(blkflg,d2,indsym,mpert,natom,nsym,qpt,symq,symrec,symrel,timrev,zero_by_symm,eta)
1491 : :
1492 : : !Arguments -------------------------------
1493 : : !scalars
1494 : : integer,intent(in) :: mpert,natom,nsym,timrev,zero_by_symm
1495 : : !arrays
1496 : : integer,intent(in) :: indsym(4,nsym,natom),symq(4,2,nsym)
1497 : : integer,intent(in),target :: symrec(3,3,nsym),symrel(3,3,nsym)
1498 : : integer,intent(inout) :: blkflg(3,mpert,3,mpert)
1499 : : real(dp),intent(in) :: qpt(3)
1500 : : real(dp),intent(inout) :: d2(2,3,mpert,3,mpert)
1501 : : real(dp),optional,intent(in) :: eta
1502 : :
1503 : : !Local variables -------------------------
1504 : : !scalars
1505 : : logical, parameter :: do_final_sym=.true.
1506 : : logical :: qzero
1507 : : integer :: exch12,found,idir1,idir2,idisy1,idisy2,ipert1,ipert2
1508 : : integer :: ipesy1,ipesy2,isgn,isym,ithree,itirev,nblkflg_is_one,noccur,nsym_used,quit,quit1
1509 : : real(dp) :: arg1,arg2,im,norm,eta_,re,sumi,sumr,xi,xr
1510 : : !arrays
1511 : 174682 : integer,pointer :: sym1_(:,:,:),sym2_(:,:,:)
1512 : 174682 : real(dp),allocatable :: d2tmp1(:,:,:),d2tmp2(:,:,:),d2work(:,:,:,:,:)
1513 : : ! *********************************************************************
1514 : :
1515 : 174682 : qzero=(qpt(1)**2+qpt(2)**2+qpt(3)**2<tol16)
1516 : :
1517 : : !Here look after exchange of 1 and 2 axis,
1518 : : !for electric field in diamond symmetry
1519 : 174682 : exch12=0
1520 : 174682 : if (qzero) then
1521 [ + + ]: 1467356 : do isym=1,nsym
1522 : 1466947 : exch12=1
1523 [ + + ]: 1466947 : if(symrel(1,1,isym)/=0)exch12=0
1524 [ + + ]: 1466947 : if(symrel(1,2,isym)/=1)exch12=0
1525 [ + + ]: 1466947 : if(symrel(1,3,isym)/=0)exch12=0
1526 [ + + ]: 1466947 : if(symrel(2,1,isym)/=1)exch12=0
1527 [ + + ]: 1466947 : if(symrel(2,2,isym)/=0)exch12=0
1528 [ + + ]: 1466947 : if(symrel(2,3,isym)/=0)exch12=0
1529 [ + + ]: 1466947 : if(symrel(3,1,isym)/=0)exch12=0
1530 [ + + ]: 1466947 : if(symrel(3,2,isym)/=0)exch12=0
1531 [ + + ]: 1466947 : if(symrel(3,3,isym)/=1)exch12=0
1532 : : ! if(exch12==1) write(std_out,*)' d2sym3 : found exchange 1 2 =',isym
1533 [ + + ]: 390083 : if(exch12==1)exit
1534 : : end do
1535 : : end if
1536 : :
1537 [ + + ]: 174682 : eta_=zero; if(present(eta)) eta_=eta
1538 : :
1539 : : !Consider two cases : either time-reversal symmetry
1540 : : !conserves the wavevector, or not
1541 [ + + - + ]: 174682 : if(timrev==0.and.abs(eta_)<tol8)then
1542 : :
1543 [ + + ]: 530536 : do ipert1=1,mpert !See notes
1544 : : ! do ipert1=1,min(natom+2,mpert)
1545 [ + + ]: 1763503 : do idir1=1,3
1546 : :
1547 : : ! Since the matrix is hermitian, the diagonal elements are real
1548 : 1232967 : d2(2,idir1,ipert1,idir1,ipert1)=zero
1549 : :
1550 [ + + ]: 7223125 : do ipert2=1,mpert !See notes
1551 : : ! do ipert2=1,min(natom+2,mpert)
1552 [ + + ]: 23549643 : do idir2=1,3
1553 : :
1554 : : ! FIXME use is_type functions
1555 : : ! If an element exists
1556 [ + + ]: 22316676 : if(blkflg(idir1,ipert1,idir2,ipert2)==1)then
1557 : :
1558 : : ! Either complete the symmetric missing element
1559 [ + + ]: 2028269 : if(blkflg(idir2,ipert2,idir1,ipert1)==0)then
1560 : :
1561 : 1207 : d2(1,idir2,ipert2,idir1,ipert1)= d2(1,idir1,ipert1,idir2,ipert2)
1562 : 1207 : d2(2,idir2,ipert2,idir1,ipert1)=-d2(2,idir1,ipert1,idir2,ipert2)
1563 : :
1564 : 1207 : blkflg(idir2,ipert2,idir1,ipert1)=1
1565 : :
1566 : : ! Or symmetrize (the matrix is hermitian) in case both exists
1567 : : ! (Note : this opportunity has been disabled for more
1568 : : ! obvious search for bugs in the code )
1569 : : ! else
1570 : : ! sumr=d2(1,idir2,ipert2,idir1,ipert1)+d2(1,idir1,ipert1,idir2,ipert2)
1571 : : ! sumi=d2(1,idir2,ipert2,idir1,ipert1)-d2(1,idir1,ipert1,idir2,ipert2)
1572 : : ! d2(1,idir2,ipert2,idir1,ipert1)=half*sumr
1573 : : ! d2(1,idir1,ipert1,idir2,ipert2)=half*sumr
1574 : : ! d2(2,idir2,ipert2,idir1,ipert1)=half*sumi
1575 : : ! d2(2,idir1,ipert1,idir2,ipert2)=-half*sumi
1576 : : end if
1577 : : end if
1578 : :
1579 : : end do
1580 : : end do
1581 : :
1582 : : end do
1583 : : end do
1584 : :
1585 : : ! Here, case with time-reversal symmetry
1586 : : else
1587 : :
1588 [ + + ]: 233391 : do ipert1=1,mpert !See notes
1589 : : ! do ipert1=1,min(natom+2,mpert)
1590 [ + + ]: 768159 : do idir1=1,3
1591 [ + + ]: 2623184 : do ipert2=1,mpert !See notes
1592 : : ! do ipert2=1,min(natom+2,mpert)
1593 [ + + ]: 8175408 : do idir2=1,3
1594 : 5730480 : d2(2,idir1,ipert1,idir2,ipert2)=zero
1595 : :
1596 : : ! If an element exists
1597 [ + + ]: 7640640 : if(blkflg(idir1,ipert1,idir2,ipert2)==1)then
1598 : :
1599 : : ! Either complete the symmetric missing element
1600 [ + + ]: 777582 : if(blkflg(idir2,ipert2,idir1,ipert1)==0)then
1601 : :
1602 : 7372 : d2(1,idir2,ipert2,idir1,ipert1)=d2(1,idir1,ipert1,idir2,ipert2)
1603 : 7372 : blkflg(idir2,ipert2,idir1,ipert1)=1
1604 : :
1605 : : ! Or symmetrize (the matrix is hermitian) in case both exists
1606 : : ! (Note : this opportunity has been disabled for more
1607 : : ! obvious search for bugs in the code )
1608 : : ! else
1609 : : ! sumr=d2(1,idir2,ipert2,idir1,ipert1)+d2(1,idir1,ipert1,idir2,ipert2)
1610 : : ! d2(1,idir2,ipert2,idir1,ipert1)=half*sumr
1611 : : ! d2(1,idir1,ipert1,idir2,ipert2)=half*sumr
1612 : : end if
1613 : :
1614 : : end if
1615 : : end do
1616 : : end do
1617 : : end do
1618 : : end do
1619 : : end if
1620 : :
1621 : : !Big Big Loop : symmetrize three times, because
1622 : : !of some cases in which one element is not yet available
1623 : : !at the first pass, and even at the second one !
1624 [ + + ]: 698728 : do ithree=1,3
1625 : :
1626 : : ! Big loop on all elements
1627 [ + + ]: 2466463 : do ipert1=1,mpert !See notes
1628 : : ! do ipert1=1,min(natom+2,mpert)
1629 : :
1630 : : ! Select the symmetries according to pertubation 1
1631 [ + + ]: 1767735 : if (ipert1<=natom)then
1632 : 642897 : sym1_ => symrec
1633 : : else
1634 : 1124838 : sym1_ => symrel
1635 : : end if
1636 : :
1637 [ + + ]: 7594986 : do idir1=1,3
1638 [ + + ]: 29538927 : do ipert2=1,mpert !See notes
1639 : : ! do ipert2=1,min(natom+2,mpert)
1640 : :
1641 : : ! Select the symmetries according to pertubation 2
1642 [ + + ]: 22467987 : if (ipert2<=natom)then
1643 : 7575489 : sym2_ => symrec
1644 : : else
1645 : 14892498 : sym2_ => symrel
1646 : : end if
1647 : :
1648 [ + + ]: 95175153 : do idir2=1,3
1649 : :
1650 : : ! Will get element (idir1,ipert1,idir2,ipert2)
1651 : : ! so this element should not yet be present ...
1652 [ + + ]: 89871948 : if(blkflg(idir1,ipert1,idir2,ipert2)/=1)then
1653 : :
1654 : 57508094 : d2(1,idir1,ipert1,idir2,ipert2)=zero
1655 : 57508094 : d2(2,idir1,ipert1,idir2,ipert2)=zero
1656 : :
1657 : : ! Loop on all symmetries, including time-reversal
1658 : 57508094 : quit1=0
1659 [ + + ]: 2174508361 : do isym=1,nsym
1660 [ + + ]: 6351736674 : do itirev=1,2
1661 : 4234736407 : isgn=3-2*itirev
1662 : :
1663 [ + + ]: 6351736674 : if(symq(4,itirev,isym)/=0)then
1664 : 1817820617 : found=1
1665 : :
1666 : : ! Here select the symmetric of ipert1
1667 [ + + ]: 1817820617 : if(ipert1<=natom)then
1668 : 415311059 : ipesy1=indsym(4,isym,ipert1)
1669 [ + + + + ]: 1402509558 : else if(ipert1==(natom+2).and.qzero)then
1670 : : ipesy1=ipert1
1671 : : else
1672 : 1122607581 : found=0
1673 : : end if
1674 : :
1675 : : ! Here select the symmetric of ipert2
1676 [ + + ]: 1817820617 : if(ipert2<=natom)then
1677 : 417907445 : ipesy2=indsym(4,isym,ipert2)
1678 [ + + + + ]: 1399913172 : else if(ipert2==(natom+2).and.qzero)then
1679 : : ipesy2=ipert2
1680 : : else
1681 : : found=0
1682 : : end if
1683 : :
1684 : : ! Now that a symmetric perturbation has been obtained,
1685 : : ! including the expression of the symmetry matrix, see
1686 : : ! if the symmetric values are available
1687 [ + + ]: 695213036 : if( found==1 ) then
1688 : :
1689 : : sumr=zero
1690 : : sumi=zero
1691 : : noccur=0
1692 : : nblkflg_is_one=0
1693 : : quit=0
1694 [ + + ]: 505121346 : do idisy1=1,3
1695 [ + + ]: 1465486933 : do idisy2=1,3
1696 [ + + + + ]: 1465486933 : if(sym1_(idir1,idisy1,isym)/=0 .and. sym2_(idir2,idisy2,isym)/=0 )then
1697 [ + + ]: 273775434 : if(blkflg(idisy1,ipesy1,idisy2,ipesy2)==1)then
1698 : 40998557 : nblkflg_is_one=nblkflg_is_one+1
1699 : : sumr=sumr+sym1_(idir1,idisy1,isym)*sym2_(idir2,idisy2,isym)*&
1700 : 40998557 : & d2(1,idisy1,ipesy1,idisy2,ipesy2)
1701 : : sumi=sumi+sym1_(idir1,idisy1,isym)*sym2_(idir2,idisy2,isym)*&
1702 : 40998557 : & d2(2,idisy1,ipesy1,idisy2,ipesy2)
1703 : :
1704 : : ! Here, in case the symmetric of the element
1705 : : ! is the element, or the symmetric with
1706 : : ! respect to permutation of perturbations
1707 : : ! (some more conditions on the time-reversal
1708 : : ! symmetry must be fulfilled although)
1709 : : else if( idisy1==idir1 .and. ipesy1==ipert1&
1710 : : & .and. idisy2==idir2 .and. ipesy2==ipert2&
1711 [ + + + + : 232776877 : & .and.(isgn==1 .or. timrev==1 &
+ + + + +
+ ]
1712 : : & .or. (idir1==idir2 .and. ipert1==ipert2)))&
1713 : : & then
1714 : 58712890 : noccur=noccur+sym1_(idir1,idisy1,isym)*sym2_(idir2,idisy2,isym)
1715 : : else if( idisy1==idir2 .and. ipesy1==ipert2&
1716 : : & .and. idisy2==idir1 .and. ipesy2==ipert1&
1717 [ + + + + : 174063987 : & .and.(isgn==-1 .or. timrev==1&
+ + + + -
+ ]
1718 : : & .or. (idir1==idir2 .and. ipert1==ipert2)))&
1719 : : & then
1720 : 12296011 : noccur=noccur+sym1_(idir1,idisy1,isym)*sym2_(idir2,idisy2,isym)
1721 : :
1722 : : ! Here, electric field case
1723 : : else if( exch12==1 .and. &
1724 : : & ipert1==natom+2 .and. ipert2==natom+2&
1725 [ + + + + : 161767976 : & .and.(( idisy1+idir1 ==3 &
+ + + + +
+ + + + +
+ + + + +
+ + + ]
1726 : : & .and. idisy2==3 .and. idir2==3)&
1727 : : & .or. ( idisy1+idir2 ==3&
1728 : : & .and. idisy2==3 .and. idir1==3)&
1729 : : & .or. ( idisy2+idir2 ==3&
1730 : : & .and. idisy1==3 .and. idir1==3)&
1731 : : & .or. ( idisy2+idir1 ==3&
1732 : : & .and. idisy1==3 .and. idir2==3)))&
1733 : : & then
1734 : 15375464 : noccur=noccur+sym1_(idir1,idisy1,isym)*sym2_(idir2,idisy2,isym)
1735 : :
1736 : : else
1737 : : ! Not found
1738 : : found=0
1739 : : quit=1
1740 : : exit
1741 : : end if
1742 : :
1743 : : end if
1744 : : end do
1745 [ + + ]: 505121346 : if(quit==1)exit
1746 : : end do
1747 : : end if
1748 : :
1749 : : ! In case zero_by_symm==0, the computed matrix element must be associated to at least one really computed matrix element
1750 [ + + ]: 1817820617 : if(zero_by_symm==0 .and. nblkflg_is_one==0)then
1751 : : found=0
1752 : : endif
1753 : :
1754 : : ! Now, if still found and associated to at least one really computed matrix element, put the correct value into array d2
1755 [ + + ]: 1817786153 : if(found==1)then
1756 : :
1757 : : ! In case of phonons, need to take into account the
1758 : : ! time-reversal symmetry, and the shift back to the unit cell
1759 : : !
1760 : : ! XG990712 : I am not sure this must be kept for electric field ...
1761 : : ! 1) Consider time-reversal symmetry
1762 : 59422310 : sumi=isgn*sumi
1763 : :
1764 [ + + + + ]: 59422310 : if(ipert1<=natom .and. ipert2<=natom)then
1765 : : ! 2) Shift the atoms back to the unit cell.
1766 : : arg1=two_pi*( qpt(1)*indsym(1,isym,ipert1)&
1767 : : & +qpt(2)*indsym(2,isym,ipert1)&
1768 : 199758 : & +qpt(3)*indsym(3,isym,ipert1) )
1769 : : arg2=two_pi*( qpt(1)*indsym(1,isym,ipert2)&
1770 : : & +qpt(2)*indsym(2,isym,ipert2)&
1771 : 199758 : & +qpt(3)*indsym(3,isym,ipert2) )
1772 : 199758 : re=cos(arg1)*cos(arg2)+sin(arg1)*sin(arg2)
1773 : : ! XG010117 Must use isgn
1774 : 199758 : im=isgn*(cos(arg2)*sin(arg1)-cos(arg1)*sin(arg2))
1775 : : else
1776 : : re=one
1777 : : im=zero
1778 : : end if
1779 : :
1780 : : ! Final check, could still fail if the
1781 : : ! element was its own symmetric
1782 [ + + - + ]: 59422310 : if (abs(1.0_dp-re*noccur)< 1.0d-6.and.abs(im*noccur) <1.0d-6) then
1783 : : found=0
1784 : : end if
1785 : :
1786 : : end if
1787 : :
1788 : : if(found==1)then
1789 : :
1790 [ + + ]: 735390 : if(noccur==0)then
1791 : 600529 : d2(1,idir1,ipert1,idir2,ipert2)=re*sumr-im*sumi
1792 : 600529 : d2(2,idir1,ipert1,idir2,ipert2)=re*sumi+im*sumr
1793 : : else
1794 : : ! See page July 2, 1994 in computer codes notebook
1795 : 134861 : xr=re*sumr-im*sumi
1796 : 134861 : xi=re*sumi+im*sumr
1797 : 134861 : norm=one+noccur**2-two*re*noccur
1798 : 134861 : xr=xr/norm
1799 : 134861 : xi=xi/norm
1800 : : d2(1,idir1,ipert1,idir2,ipert2)=&
1801 : 134861 : & (one-re*noccur)*xr-im*noccur*xi
1802 : : d2(2,idir1,ipert1,idir2,ipert2)=&
1803 : 134861 : & (one-re*noccur)*xi+im*noccur*xr
1804 : : end if
1805 : :
1806 : : ! The element has been constructed !
1807 : 735390 : blkflg(idir1,ipert1,idir2,ipert2)=1
1808 : :
1809 : : quit1=1
1810 : : exit ! Exit loop on symmetry operations
1811 : : end if
1812 : :
1813 : : ! End loop on all symmetries + time-reversal
1814 : : end if
1815 : : end do
1816 : 56772704 : if(quit1==1)exit
1817 : : end do
1818 : :
1819 : : end if
1820 : : end do ! End big loop on all elements
1821 : : end do
1822 : : end do
1823 : : end do
1824 : :
1825 : : end do ! End Big Big Loop
1826 : :
1827 : : !MT oct. 20, 2014:
1828 : : !Once the matrix has been built, it does not necessarily fulfill the correct symmetries.
1829 : : !It has just been filled up from rows or columns that only fulfill symmetries preserving
1830 : : !one particular perturbation.
1831 : : !An additional symmetrization might solve this (do not consider TR-symmetry)
1832 : : if (do_final_sym) then
1833 [ - + ]: 174682 : ABI_MALLOC(d2tmp1,(2,3,3))
1834 [ - + ]: 174682 : ABI_MALLOC(d2tmp2,(2,3,3))
1835 [ - + + - : 873410 : ABI_MALLOC(d2work,(2,3,mpert,3,mpert))
+ - - + +
- + - + -
- + - + ]
1836 [ + + + + : 77424952 : d2work(:,:,:,:,:)=d2(:,:,:,:,:)
+ + + + +
+ ]
1837 [ + + ]: 763927 : do ipert1=1,mpert
1838 : : !do ipert1=1,min(natom+2,mpert)
1839 [ + + + + : 589245 : if ((ipert1==natom+1.or.ipert1==natom+10.or.ipert1==natom+11).or.(ipert1==natom+2.and.(.not.qzero))) cycle
+ + + + +
+ ]
1840 [ + + ]: 291628 : if (ipert1<=natom)then
1841 : 214299 : sym1_ => symrec
1842 : : else
1843 : 77329 : sym1_ => symrel
1844 : : end if
1845 [ + + ]: 1894154 : do ipert2=1,mpert
1846 : : !do ipert2=1,min(natom+2,mpert)
1847 : : ! if (any(blkflg(:,ipert1,:,ipert2)==0)) cycle
1848 [ + + + + : 1427844 : if ((ipert2==natom+1.or.ipert2==natom+10.or.ipert2==natom+11).or.(ipert2==natom+2.and.(.not.qzero))) cycle
+ + + + +
+ ]
1849 [ + + ]: 913608 : if (ipert2<=natom)then
1850 : 464406 : sym2_ => symrec
1851 : : else
1852 : 449202 : sym2_ => symrel
1853 : : end if
1854 : 913608 : nsym_used=0
1855 [ + + + + : 28321848 : d2tmp2(:,:,:)=zero
+ + ]
1856 [ + + ]: 30619939 : do isym=1,nsym
1857 [ + + ]: 30619939 : if (symq(4,1,isym)==1) then
1858 [ + + ]: 16085572 : ipesy1=ipert1;if (ipert1<=natom) ipesy1=indsym(4,isym,ipert1)
1859 [ + + ]: 16085572 : ipesy2=ipert2;if (ipert2<=natom) ipesy2=indsym(4,isym,ipert2)
1860 : : ! The condition on next line is too severe, since some elements of sym1_ or sym2_ might be zero,
1861 : : ! which means not all blkflg(:,ipesy1,:,ipesy2) would need to be 1 to symmetrize the matrix.
1862 : : ! However, coding something more refined is really more difficult.
1863 : : ! This condition then has the side effect that more symmetries can be applied when zero_by_symm==1,
1864 : : ! since blkflg can be set to 1 when the symmetries guarantee the matrix element to be zero.
1865 [ + + + + : 82408363 : if (all(blkflg(:,ipesy1,:,ipesy2)==1)) then
+ + + + ]
1866 : 5523960 : nsym_used=nsym_used+1
1867 : 5523960 : re=one;im=zero
1868 [ + + + + : 5523960 : if (ipert1<=natom.and.ipert2<=natom.and.(.not.qzero)) then
+ + ]
1869 : : arg1=two_pi*(qpt(1)*(indsym(1,isym,ipert1)-indsym(1,isym,ipert2)) &
1870 : : & +qpt(2)*(indsym(2,isym,ipert1)-indsym(2,isym,ipert2)) &
1871 : 2626726 : & +qpt(3)*(indsym(3,isym,ipert1)-indsym(3,isym,ipert2)))
1872 : 2626726 : re=cos(arg1);im=sin(arg1)
1873 : : end if
1874 [ + + + + : 171242760 : d2tmp1(:,:,:)=zero
+ + ]
1875 [ + + ]: 22095840 : do idir2=1,3 !kappa
1876 [ + + ]: 71811480 : do idir1=1,3 !mu
1877 [ + + ]: 215434440 : do idisy1=1,3 !nu
1878 : : d2tmp1(:,idir1,idir2)=d2tmp1(:,idir1,idir2) &
1879 [ + + ]: 497156400 : & +sym1_(idir1,idisy1,isym)*d2(:,idisy1,ipesy1,idir2,ipesy2)
1880 : : end do
1881 : : end do
1882 : : end do
1883 [ + + ]: 22095840 : do idir2=1,3 !mu
1884 [ + + ]: 71811480 : do idir1=1,3 !kappa
1885 [ + + ]: 215434440 : do idisy2=1,3 !nu
1886 : : d2tmp2(1,idir1,idir2)=d2tmp2(1,idir1,idir2) &
1887 : 149146920 : & +sym2_(idir2,idisy2,isym)*(d2tmp1(1,idir1,idisy2)*re-d2tmp1(2,idir1,idisy2)*im)
1888 : : d2tmp2(2,idir1,idir2)=d2tmp2(2,idir1,idir2) &
1889 : 198862560 : & +sym2_(idir2,idisy2,isym)*(d2tmp1(1,idir1,idisy2)*im+d2tmp1(2,idir1,idisy2)*re)
1890 : : end do
1891 : : end do
1892 : : end do
1893 : : end if
1894 : : end if
1895 : : end do ! isym
1896 [ + + + + : 10897233 : if (nsym_used>0) d2work(:,1:3,ipert1,1:3,ipert2)=d2tmp2(:,1:3,1:3)/dble(nsym_used)
+ + + + ]
1897 : : end do !ipert2
1898 : : end do !ipert1
1899 [ + - + + : 10400248 : if (mpert>=natom) d2(:,1:3,1:natom,1:3,1:natom)=d2work(:,1:3,1:natom,1:3,1:natom)
+ + + + +
+ + + ]
1900 [ + + ]: 174682 : if (mpert>=natom+2) then
1901 [ + + + + : 6801530 : d2(:,1:3,natom+2,1:3,1:natom)=d2work(:,1:3,natom+2,1:3,1:natom)
+ + + + ]
1902 [ + + + + : 7111082 : d2(:,1:3,1:natom,1:3,natom+2)=d2work(:,1:3,1:natom,1:3,natom+2)
+ + + + ]
1903 [ + + + + : 5407733 : d2(:,1:3,natom+2,1:3,natom+2)=d2work(:,1:3,natom+2,1:3,natom+2)
+ + ]
1904 : : end if
1905 [ - + ]: 174682 : ABI_FREE(d2tmp1)
1906 [ - + ]: 174682 : ABI_FREE(d2tmp2)
1907 [ - + ]: 174682 : ABI_FREE(d2work)
1908 : : end if
1909 : :
1910 [ + + ]: 174682 : end subroutine d2sym3
1911 : : !!***
1912 : :
1913 : : !----------------------------------------------------------------------
1914 : :
1915 : : !!****f* m_dynmat/q0dy3_apply
1916 : : !! NAME
1917 : : !! q0dy3_apply
1918 : : !!
1919 : : !! FUNCTION
1920 : : !! Takes care of the inclusion of the ewald q=0 term in the dynamical
1921 : : !! matrix - corrects the dyew matrix provided as input
1922 : : !! See Eq.(71) in Gonze&Lee PRB 55, 10355 (1997) [[cite:Gonze1997a]],
1923 : : !! get the left hand side.
1924 : : !!
1925 : : !! INPUTS
1926 : : !! dyewq0(3,3,natom) = part needed to correct the dynamical matrix for atom self-interaction.
1927 : : !! natom= number of atom in the unit cell
1928 : : !!
1929 : : !! SIDE EFFECTS
1930 : : !! dyew(2,3,natom,3,natom)= dynamical matrix corrected on output
1931 : : !!
1932 : : !! NOTES
1933 : : !! Should be used just after each call to dfpt_ewald, for both
1934 : : !! q==0 and the real wavelength.
1935 : : !!
1936 : : !! The q0dy3_apply should be used in conjunction with the subroutine dfpt_ewald (or ewald9):
1937 : : !! First, the call of dfpt_ewald with q==0 should be done,
1938 : : !! then the call to q0dy3_calc will produce
1939 : : !! the dyewq0 matrix from the (q=0) dyew matrix
1940 : : !! Second, the call of dfpt_ewald with the real q (either =0 or diff 0)
1941 : : !! should be done, then the call to q0dy3_apply
1942 : : !! will produce the correct dynamical matrix dyew starting from
1943 : : !! the previously calculated dyewq0 and the bare(non-corrected)
1944 : : !! dyew matrix
1945 : : !!
1946 : : !! SOURCE
1947 : :
1948 : 176672 : subroutine q0dy3_apply(natom,dyewq0,dyew)
1949 : :
1950 : : !Arguments -------------------------------
1951 : : !scalars
1952 : : integer,intent(in) :: natom
1953 : : !arrays
1954 : : real(dp),intent(in) :: dyewq0(3,3,natom)
1955 : : real(dp),intent(inout) :: dyew(2,3,natom,3,natom)
1956 : :
1957 : : !Local variables -------------------------
1958 : : !scalars
1959 : : integer :: ia,mu,nu
1960 : : ! *********************************************************************
1961 : :
1962 [ + + ]: 706688 : do mu=1,3
1963 [ + + ]: 2296736 : do nu=1,3
1964 [ + + ]: 5657631 : do ia=1,natom
1965 : 5127615 : dyew(1,mu,ia,nu,ia)=dyew(1,mu,ia,nu,ia)-dyewq0(mu,nu,ia)
1966 : : end do
1967 : : end do
1968 : : end do
1969 : :
1970 : 176672 : end subroutine q0dy3_apply
1971 : : !!***
1972 : :
1973 : : !----------------------------------------------------------------------
1974 : :
1975 : : !!****f* m_dynmat/q0dy3_calc
1976 : : !! NAME
1977 : : !! q0dy3_calc
1978 : : !!
1979 : : !! FUNCTION
1980 : : !! Calculate the q=0 correction term to the dynamical matrix
1981 : : !! See Eq.(71) in Gonze&Lee PRB 55, 10355 (1997) [[cite:Gonze1997a]], the sum over \kappa"
1982 : : !!
1983 : : !! INPUTS
1984 : : !! dyew(2,3,natom,3,natom)= dynamical matrix
1985 : : !! input, non-corrected, for q=0 if option=1 or 2
1986 : : !! natom= number of atom in the unit cell
1987 : : !! option= either 1 or 2:
1988 : : !! 1: use dyew to calculate dyewq0 symmetrical form
1989 : : !! 2: use dyew to calculate dyewq0 symmetrical form
1990 : : !!
1991 : : !! OUTPUT
1992 : : !! dyewq0(3,3,natom) = part needed to correct
1993 : : !! the dynamical matrix for atom self-interaction.
1994 : : !!
1995 : : !! NOTES
1996 : : !! Should be used just after each call to dfpt_ewald, for both
1997 : : !! q==0 and the real wavelength.
1998 : : !!
1999 : : !! If option=1 or 2, q0dy3_calc uses an Ewald dynamical matrix at q=0,
2000 : : !! called dyew, to produce a contracted form called dyewq0 :
2001 : : !! either:
2002 : : !! in an unsymmetrical form (if option=1), or
2003 : : !! in a symmetrical form (if option=2).
2004 : : !!
2005 : : !! The q0dy3_calc should be used in conjunction with the subroutine dfpt_ewald (or ewald9).
2006 : : !! First, the call of dfpt_ewald with q==0 should be done ,
2007 : : !! then the call to q0dy3_calc will produce
2008 : : !! the dyewq0 matrix from the (q=0) dyew matrix
2009 : : !! Second, the call of dfpt_ewald with the real q (either =0 or diff 0)
2010 : : !! should be done, then the call to q0dy3_apply
2011 : : !! will produce the correct dynamical matrix dyew starting from
2012 : : !! the previously calculated dyewq0 and the bare(non-corrected)
2013 : : !! dyew matrix
2014 : : !!
2015 : : !! SOURCE
2016 : :
2017 : 608 : subroutine q0dy3_calc(natom,dyewq0,dyew,option)
2018 : :
2019 : : !Arguments -------------------------------
2020 : : !scalars
2021 : : integer,intent(in) :: natom,option
2022 : : !arrays
2023 : : real(dp),intent(in) :: dyew(2,3,natom,3,natom)
2024 : : real(dp),intent(out) :: dyewq0(3,3,natom)
2025 : :
2026 : : !Local variables -------------------------
2027 : : !scalars
2028 : : integer :: ia,ib,mu,nu
2029 : : character(len=500) :: msg
2030 : : ! *********************************************************************
2031 : :
2032 [ + - ]: 608 : if(option==1.or.option==2.or.option==6)then
2033 [ + + ]: 2432 : do mu=1,3
2034 [ + + ]: 7904 : do nu=1,3
2035 [ + + ]: 19419 : do ia=1,natom
2036 : 12123 : dyewq0(mu,nu,ia)=zero
2037 [ + + ]: 56160 : do ib=1,natom
2038 : 50688 : dyewq0(mu,nu,ia)=dyewq0(mu,nu,ia)+dyew(1,mu,ia,nu,ib)
2039 : : end do
2040 : : end do
2041 : : end do
2042 : : end do
2043 : : else
2044 : : write (msg, '(3a)')&
2045 : 0 : & 'option should be 1 or 2 or 6.',ch10,&
2046 : 0 : & 'action: correct calling routine'
2047 : 0 : ABI_BUG(msg)
2048 : : end if
2049 : :
2050 [ + + ]: 608 : if(option==2)then
2051 [ + + ]: 141 : do ia=1,natom
2052 [ + + ]: 477 : do mu=1,3
2053 [ + + ]: 1120 : do nu=mu,3
2054 : 672 : dyewq0(mu,nu,ia)=(dyewq0(mu,nu,ia)+dyewq0(nu,mu,ia))/2
2055 : 1008 : dyewq0(nu,mu,ia)=dyewq0(mu,nu,ia)
2056 : : end do
2057 : : end do
2058 : : end do
2059 : : end if
2060 : :
2061 : 608 : end subroutine q0dy3_calc
2062 : : !!***
2063 : :
2064 : : !----------------------------------------------------------------------
2065 : :
2066 : : !!****f* m_dynmat/symdyma
2067 : : !!
2068 : : !! NAME
2069 : : !! symdyma
2070 : : !!
2071 : : !! FUNCTION
2072 : : !! Symmetrize the dynamical matrices
2073 : : !!
2074 : : !! INPUTS
2075 : : !! indsym(4,nsym*natom)=indirect indexing array : for each
2076 : : !! isym,iatom, fourth element is label of atom into which iatom is sent by
2077 : : !! INVERSE of symmetry operation isym; first three elements are the primitive
2078 : : !! translations which must be subtracted after the transformation to get back
2079 : : !! to the original unit cell.
2080 : : !! natom=number of atoms in unit cell
2081 : : !! nsym=number of space group symmetries
2082 : : !! qptn(3)=normalized phonon wavevector
2083 : : !! rprimd(3,3)=dimensional primitive translations (bohr)
2084 : : !! symrel(3,3,nsym)=3x3 matrices of the group symmetries (real space)
2085 : : !!
2086 : : !! SIDE EFFECTS
2087 : : !! Input/Output
2088 : : !! dmati(2*3*natom*3*natom)=dynamical matrices in cartesian coordinates relative to the q
2089 : : !! points of the B.Z. sampling
2090 : : !!
2091 : : !! NOTES
2092 : : !! the procedure of the symmetrization of the dynamical matrix follows the
2093 : : !! equations in: Hendrikse et al., Computer Phys. Comm. 86, 297 (1995) [[cite:Hendrikse1995]]
2094 : : !!
2095 : : !! TODO
2096 : : !! A full description of the equations should be included
2097 : : !!
2098 : : !! SOURCE
2099 : :
2100 : 185469 : subroutine symdyma(dmati,indsym,natom,nsym,qptn,rprimd,symrel,symafm)
2101 : :
2102 : : !Arguments -------------------------------
2103 : : !scalars
2104 : : integer,intent(in) :: natom,nsym
2105 : : !arrays
2106 : : integer,intent(in) :: indsym(4,nsym,natom),symrel(3,3,nsym)
2107 : : integer,intent(in) :: symafm(nsym)
2108 : : real(dp),intent(in) :: qptn(3),rprimd(3,3)
2109 : : real(dp),intent(inout) :: dmati(2*3*natom*3*natom)
2110 : :
2111 : : !Local variables -------------------------
2112 : : !scalars
2113 : : integer :: i1,i2,iat,idir,ii,index,isgn,isym,itirev,jat,jdir,jj,kk,ll
2114 : : integer :: niat,njat,timrev
2115 : : real(dp) :: arg1,arg2,dmint,im,re,sumi,sumr
2116 : : !arrays
2117 : 370938 : integer :: indij(natom,natom),symq(4,2,nsym),symrec(3,3,nsym)
2118 : 370938 : real(dp) :: TqR(3,3),TqS_(3,3),dynmat(2,3,natom,3,natom)
2119 : 370938 : real(dp) :: dynmatint(2*nsym,2,3,natom,3,natom),gprimd(3,3)
2120 : 370938 : real(dp) :: symcart(3,3,nsym)
2121 : : ! *********************************************************************
2122 : : !FIXME Disabling optimization with NVHPC in this routine
2123 : : ! because of significant numerical divergence
2124 : : !nvf$r opt=0
2125 : :
2126 : : ! 0) initializations
2127 : 185469 : call matr3inv(rprimd,gprimd)
2128 [ + + ]: 5012344 : do isym=1,nsym
2129 : 5012344 : call mati3inv(symrel(:,:,isym),symrec(:,:,isym))
2130 : : end do
2131 : :
2132 : : TqR=zero
2133 : : TqS_=zero
2134 [ + + + + : 31597195 : dynmat=zero
+ + + + +
+ ]
2135 : :
2136 : : !Note: dynmat is used as work space here
2137 : : i1=0
2138 [ + + ]: 546778 : do iat=1,natom
2139 [ + + ]: 1630705 : do idir=1,3
2140 : 1083927 : i1=i1+1
2141 : 1083927 : i2=0
2142 [ + + ]: 4441885 : do jat=1,natom
2143 [ + + ]: 13070523 : do jdir=1,3
2144 : 8989947 : i2=i2+1
2145 : 8989947 : index=i1+3*natom*(i2-1)
2146 : 8989947 : dynmat(1,idir,iat,jdir,jat)=dmati(2*index-1)
2147 : 11986596 : dynmat(2,idir,iat,jdir,jat)=dmati(2*index )
2148 : : end do
2149 : : end do
2150 : : end do
2151 : : end do
2152 : :
2153 : : !Transform symrel to cartesian coordinates (RC coding)
2154 : : !do isym=1,nsym
2155 : : !symcart(:,:,isym)=matmul(rprimd,matmul(dble(symrel(:,:,isym)),gprimd))
2156 : : !end do
2157 : :
2158 : : !Coding from symdm9
2159 [ + + ]: 5012344 : do isym=1,nsym
2160 [ + + ]: 19492969 : do jj=1,3
2161 [ + + ]: 57922500 : symcart(:,jj,isym)=zero
2162 [ + + ]: 62749375 : do kk=1,3
2163 [ + + ]: 188248125 : do ll=1,3
2164 [ + + ]: 564744375 : symcart(:,jj,isym)=symcart(:,jj,isym)+rprimd(:,kk)*gprimd(jj,ll)*symrel(kk,ll,isym)
2165 : : end do
2166 : : end do
2167 : : end do
2168 : : end do
2169 : :
2170 : : ! Get the symq of the CURRENT Q POINT
2171 : : ! mjv: set prtvol=0 for production runs.
2172 : 185469 : call littlegroup_q(nsym,qptn,symq,symrec,symafm,timrev,prtvol=0)
2173 : :
2174 [ + + + + ]: 1545661 : indij(:,:)=0
2175 [ + + + + : 662790919 : dynmatint=zero
+ + + + +
+ + + ]
2176 : :
2177 [ + + ]: 5012344 : do isym=1,nsym ! loop over all the symmetries
2178 : : ! write(std_out,*) 'current symmetry',isym
2179 [ + + ]: 14666094 : do itirev=1,2 ! loop over the time-reversal symmetry
2180 : 9653750 : isgn=3-2*itirev
2181 : : ! write(std_out,*) 'timereversal',isgn
2182 : :
2183 [ + + ]: 14480625 : if (symq(4,itirev,isym)==1) then ! isym belongs to the wave vector point group
2184 : : ! write(std_out,*) 'isym belongs to the wave vector point group'
2185 [ + + ]: 2266859 : do iat=1,natom
2186 [ + + ]: 6392247 : do jat=1,natom
2187 : 4125388 : niat=indsym(4,isym,iat) ! niat={R|t}iat
2188 : 4125388 : njat=indsym(4,isym,jat) ! njat={R|t}jat
2189 : 4125388 : indij(niat,njat)=indij(niat,njat)+1
2190 : : ! write(std_out,'(a,5i5)') 'current status:',iat,jat,niat,njat,indij(niat,njat)
2191 : : ! phase calculation, arg1 and arg2 because of two-atom derivative
2192 : : arg1=two_pi*( qptn(1)*indsym(1,isym,iat)+&
2193 : : qptn(2)*indsym(2,isym,iat)+&
2194 : 4125388 : qptn(3)*indsym(3,isym,iat) )
2195 : : arg2=two_pi*( qptn(1)*indsym(1,isym,jat)+&
2196 : : qptn(2)*indsym(2,isym,jat)+&
2197 : 4125388 : qptn(3)*indsym(3,isym,jat) )
2198 : :
2199 : 4125388 : re=cos(arg1)*cos(arg2)+sin(arg1)*sin(arg2)
2200 : 4125388 : im=isgn*(cos(arg2)*sin(arg1)-cos(arg1)*sin(arg2))
2201 : :
2202 [ + + ]: 17996858 : do idir=1,3 ! loop over displacements
2203 [ + + ]: 53630044 : do jdir=1,3 ! loop over displacements
2204 : : ! we pick the (iat,jat) (3x3) block of the dyn.mat.
2205 : : sumr=zero
2206 : : sumi=zero
2207 [ + + ]: 148513968 : do ii=1,3
2208 [ + + ]: 482670396 : do jj=1,3
2209 : 334156428 : sumr=sumr+symcart(idir,ii,isym)*dynmat(1,ii,niat,jj,njat)*symcart(jdir,jj,isym)
2210 : 445541904 : sumi=sumi+symcart(idir,ii,isym)*dynmat(2,ii,niat,jj,njat)*symcart(jdir,jj,isym)
2211 : : end do
2212 : : end do
2213 : 37128492 : sumi=isgn*sumi
2214 : :
2215 : 37128492 : dynmatint(nsym*(itirev-1)+isym,1,idir,iat,jdir,jat)=re*sumr-im*sumi
2216 : 49504656 : dynmatint(nsym*(itirev-1)+isym,2,idir,iat,jdir,jat)=re*sumi+im*sumr
2217 : : end do
2218 : : end do
2219 : : end do
2220 : : end do ! end treatment of the (iat,jat) (3x3) block of dynmat
2221 : : end if ! symmetry check
2222 : : end do ! time-reversal
2223 : : end do ! symmetries
2224 : :
2225 : : !4) make the average, get the final symmetric dynamical matrix
2226 [ + + ]: 546778 : do iat=1,natom
2227 [ + + ]: 1545661 : do jat=1,natom
2228 [ + + ]: 4356841 : do idir=1,3
2229 [ + + ]: 12985479 : do jdir=1,3
2230 : : dmint=zero
2231 [ + + ]: 324586809 : do isym=1,2*nsym
2232 : 324586809 : dmint=dmint+dynmatint(isym,1,idir,iat,jdir,jat)
2233 : : end do
2234 : 8989947 : dynmat(1,idir,iat,jdir,jat)=dmint/dble(indij(iat,jat))
2235 : 8989947 : dmint=zero
2236 [ + + ]: 324586809 : do isym=1,2*nsym
2237 : 324586809 : dmint=dmint+dynmatint(isym,2,idir,iat,jdir,jat)
2238 : : end do
2239 : 11986596 : dynmat(2,idir,iat,jdir,jat)=dmint/dble(indij(iat,jat))
2240 : : end do
2241 : : end do
2242 : : end do
2243 : : end do
2244 : :
2245 : : i1=0
2246 [ + + ]: 546778 : do iat=1,natom
2247 [ + + ]: 1630705 : do idir=1,3
2248 : 1083927 : i1=i1+1
2249 : 1083927 : i2=0
2250 [ + + ]: 4441885 : do jat=1,natom
2251 [ + + ]: 13070523 : do jdir=1,3
2252 : 8989947 : i2=i2+1
2253 : 8989947 : index=i1+3*natom*(i2-1)
2254 : 8989947 : dmati(2*index-1)=dynmat(1,idir,iat,jdir,jat)
2255 : 11986596 : dmati(2*index )=dynmat(2,idir,iat,jdir,jat)
2256 : : end do
2257 : : end do
2258 : : end do
2259 : : end do
2260 : :
2261 : 185469 : end subroutine symdyma
2262 : : !!***
2263 : :
2264 : : !!****f* m_dynmat/dfpt_sygra
2265 : : !!
2266 : : !! NAME
2267 : : !! dfpt_sygra
2268 : : !!
2269 : : !! FUNCTION
2270 : : !! Symmetrize derivatives of energy with respect to coordinates,
2271 : : !! as appearing in phonon calculations.
2272 : : !! Unsymmetrized gradients are input as deunsy; symmetrized grads are then placed in desym.
2273 : : !! If nsym=1 simply copy deunsy into desym (only symmetry is identity).
2274 : : !! The index of the initial perturbation is needed, in case there is a change
2275 : : !! of atom position (moved in another cell) due to the symmetry operation.
2276 : : !!
2277 : : !! INPUTS
2278 : : !! natom=number of atoms in cell
2279 : : !! deunsy(2,3,natom)=unsymmetrized gradients wrt dimensionless tn (hartree)
2280 : : !! note: there is a real and a imaginary part ...
2281 : : !! indsym(4,nsym,natom)=label given by subroutine symatm, indicating atom
2282 : : !! label which gets rotated into given atom by given symmetry
2283 : : !! (first three elements are related primitive translation--
2284 : : !! see symatm where this is computed)
2285 : : !! nsym=number of symmetry operators in group
2286 : : !! ipert=index of the initial perturbation
2287 : : !! qpt(3)= wavevector of the phonon, in reduced coordinates
2288 : : !! symrec(3,3,nsym)=symmetries of group in terms of operations on
2289 : : !! reciprocal space primitive translations--see comments below
2290 : : !!
2291 : : !! OUTPUT
2292 : : !! desym(2,3,natom)=symmetrized gradients wrt dimensionless tn (hartree)
2293 : : !!
2294 : : !! NOTES
2295 : : !! Written by X. Gonze starting from sygrad, written by D.C. Allan:
2296 : : !! introduction of the q vector for phonon symmetrization
2297 : : !! This routine should once be merged with sygrad...
2298 : : !!
2299 : : !! SOURCE
2300 : :
2301 : 2545 : subroutine dfpt_sygra(natom,desym,deunsy,indsym,ipert,nsym,qpt,symrec)
2302 : :
2303 : : !Arguments -------------------------------
2304 : : !scalars
2305 : : integer,intent(in) :: ipert,natom,nsym
2306 : : !arrays
2307 : : integer,intent(in) :: indsym(4,nsym,natom),symrec(3,3,nsym)
2308 : : real(dp),intent(in) :: deunsy(2,3,natom),qpt(3)
2309 : : real(dp),intent(out) :: desym(2,3,natom)
2310 : :
2311 : : !Local variables -------------------------
2312 : : !scalars
2313 : : integer :: ia,ind,isym,mu
2314 : : real(dp) :: arg,im,re,sumi,sumr
2315 : : ! *********************************************************************
2316 : :
2317 [ + + ]: 2545 : if (nsym==1) then
2318 : :
2319 : : ! Only symmetry is identity so simply copy
2320 [ + + + + : 46002 : desym(:,:,:)=deunsy(:,:,:)
+ + ]
2321 : :
2322 : : else
2323 : :
2324 : : ! Actually conduct symmetrization
2325 : : ! write(std_out,*)' dfpt_sygra : desym(:2,:3,:natom),qpt(:)',desym(:2,:3,:natom),qpt(:)
2326 [ + + ]: 2249 : do ia=1,natom
2327 : : ! write(std_out,*)' dfpt_sygra : ia=',ia
2328 [ + + ]: 7067 : do mu=1,3
2329 : : sumr=zero
2330 : : sumi=zero
2331 : : ! write(std_out,*)' dfpt_sygra : mu=',mu
2332 [ + + ]: 23760 : do isym=1,nsym
2333 : 18942 : ind=indsym(4,isym,ia)
2334 : : ! Must shift the atoms back to the unit cell.
2335 : : ! arg=two_pi*( qpt(1)*indsym(1,isym,ia)&
2336 : : ! & +qpt(2)*indsym(2,isym,ia)&
2337 : : ! & +qpt(3)*indsym(3,isym,ia) )
2338 : : ! Selection of non-zero q point, to avoid ipert being outside the 1 ... natom range
2339 [ + + ]: 18942 : if(qpt(1)**2+qpt(2)**2+qpt(3)**2 > tol16)then
2340 : : arg=two_pi*( qpt(1)*(indsym(1,isym,ia)-indsym(1,isym,ipert))&
2341 : : & +qpt(2)* (indsym(2,isym,ia)-indsym(2,isym,ipert))&
2342 : 1896 : & +qpt(3)* (indsym(3,isym,ia)-indsym(3,isym,ipert)))
2343 : : else
2344 : : arg=zero
2345 : : end if
2346 : :
2347 : : re=dble(symrec(mu,1,isym))*deunsy(1,1,ind)+&
2348 : : & dble(symrec(mu,2,isym))*deunsy(1,2,ind)+&
2349 : 18942 : & dble(symrec(mu,3,isym))*deunsy(1,3,ind)
2350 : : im=dble(symrec(mu,1,isym))*deunsy(2,1,ind)+&
2351 : : & dble(symrec(mu,2,isym))*deunsy(2,2,ind)+&
2352 : 18942 : & dble(symrec(mu,3,isym))*deunsy(2,3,ind)
2353 : 18942 : sumr=sumr+re*cos(arg)-im*sin(arg)
2354 : 23760 : sumi=sumi+re*sin(arg)+im*cos(arg)
2355 : : ! sumr=sumr+re
2356 : : ! sumi=sumi+im
2357 : : ! write(std_out,*)' dfpt_sygra : isym,indsym(4,isym,ia),arg,re,im,sumr,sumi',&
2358 : : ! & isym,indsym(4,isym,ia),arg,re,im,sumr,sumi
2359 : : end do
2360 : 4818 : desym(1,mu,ia)=sumr/dble(nsym)
2361 : 6424 : desym(2,mu,ia)=sumi/dble(nsym)
2362 : : ! write(std_out,*)' dfpt_sygra : desym(:,mu,ia)',desym(:,mu,ia)
2363 : : end do
2364 : : end do
2365 : : end if
2366 : :
2367 : 2545 : end subroutine dfpt_sygra
2368 : : !!***
2369 : :
2370 : : !!****f* m_dynmat/dfpt_sydy
2371 : : !! NAME
2372 : : !! dfpt_sydy
2373 : : !!
2374 : : !! FUNCTION
2375 : : !! Symmetrize dynamical matrix (eventually diagonal wrt to the atoms)
2376 : : !! Unsymmetrized dynamical matrix is input as dyfrow;
2377 : : !! symmetrized dynamical matrix is then placed in sdyfro.
2378 : : !! If nsym=1 simply copy dyfrow into sdyfro.
2379 : : !!
2380 : : !! INPUTS
2381 : : !! cplex=1 if dynamical matrix is real, 2 if it is complex
2382 : : !! dyfrow(3,3,natom,1+(natom-1)*nondiag)=unsymmetrized dynamical matrix
2383 : : !! indsym(4,msym*natom)=indirect indexing array: for each
2384 : : !! isym,iatom, fourth element is label of atom into which iatom is sent by
2385 : : !! INVERSE of symmetry operation isym; first three elements are the primitive
2386 : : !! translations which must be subtracted after the transformation to get back
2387 : : !! to the original unit cell.
2388 : : !! natom=number of atoms in cell.
2389 : : !! nondiag=0 if dynamical matrix is diagonal with respect to atoms
2390 : : ! 1 if dynamical matrix is non diagonal with respect to atoms
2391 : : !! nsym=number of symmetry operators in group.
2392 : : !! qphon(3)=wavevector of the phonon
2393 : : !! symq(4,2,nsym)=1 if symmetry preserves present qpoint. From littlegroup_q
2394 : : !! symrec(3,3,nsym)=symmetries of group in terms of operations on real
2395 : : !! space primitive translations (integers).
2396 : : !!
2397 : : !! OUTPUT
2398 : : !! sdyfro(3,3,natom,1+(natom-1)*nondiag)=symmetrized dynamical matrix
2399 : : !!
2400 : : !! NOTES
2401 : : !! Symmetrization of gradients with respect to reduced
2402 : : !! coordinates tn is conducted according to the expression
2403 : : !! $[d(e)/d(t(n,a))]_{symmetrized} = (1/Nsym)*Sum(S)*symrec(n,m,S)*
2404 : : !! [d(e)/d(t(m,b))]_{unsymmetrized}$
2405 : : !! where $t(m,b)= (symrel^{-1})(m,n)*(t(n,a)-tnons(n))$ and tnons
2406 : : !! is a possible nonsymmorphic translation. The label "b" here
2407 : : !! refers to the atom which gets rotated into "a" under symmetry "S".
2408 : : !! symrel is the symmetry matrix in real space, which is the inverse
2409 : : !! transpose of symrec. symrec is the symmetry matrix in reciprocal
2410 : : !! space. $sym_{cartesian} = R * symrel * R^{-1} = G * symrec * G^{-1}$
2411 : : !! where the columns of R and G are the dimensional primitive translations
2412 : : !! in real and reciprocal space respectively.
2413 : : !! Note the use of "symrec" in the symmetrization expression above.
2414 : : !!
2415 : : !! SOURCE
2416 : :
2417 : 1350 : subroutine dfpt_sydy(cplex,dyfrow,indsym,natom,nondiag,nsym,qphon,sdyfro,symq,symrec)
2418 : :
2419 : : !Arguments -------------------------------
2420 : : !scalars
2421 : : integer,intent(in) :: cplex,natom,nondiag,nsym
2422 : : !arrays
2423 : : integer,intent(in) :: indsym(4,nsym,natom),symq(4,2,nsym),symrec(3,3,nsym)
2424 : : real(dp),intent(in) :: dyfrow(cplex,3,3,natom,1+(natom-1)*nondiag),qphon(3)
2425 : : real(dp),intent(out) :: sdyfro(cplex,3,3,natom,1+(natom-1)*nondiag)
2426 : :
2427 : : !Local variables -------------------------
2428 : : !scalars
2429 : : integer :: ia,indi,indj,isym,ja,kappa,mu,natom_nondiag,nsym_used,nu
2430 : : logical :: qeq0
2431 : : real(dp) :: arg,div,phasei,phaser
2432 : : !arrays
2433 : 2700 : real(dp) :: work(cplex,3,3)
2434 : : ! *********************************************************************
2435 : :
2436 [ + + ]: 1350 : if (nsym==1) then
2437 : :
2438 : : ! Only symmetry is identity so simply copy
2439 [ + + + + : 17883 : sdyfro(:,:,:,:,:)=dyfrow(:,:,:,:,:)
+ + + + +
+ ]
2440 : :
2441 : : else
2442 : :
2443 : : ! Actually carry out symmetrization
2444 [ + + + + : 57491 : sdyfro(:,:,:,:,:)=zero
+ + + + +
+ ]
2445 : 999 : qeq0=(qphon(1)**2+qphon(2)**2+qphon(3)**2<1.d-14)
2446 : : ! === Diagonal dyn. matrix OR q=0
2447 [ + + + + ]: 999 : if (nondiag==0.or.qeq0) then
2448 [ + + ]: 985 : natom_nondiag=1;if (nondiag==1) natom_nondiag=natom
2449 [ + + ]: 2045 : do ja=1,natom_nondiag
2450 [ + + ]: 4493 : do ia=1,natom
2451 [ + + ]: 59594 : do isym=1,nsym
2452 : 56086 : indi=indsym(4,isym,ia)
2453 [ + + ]: 56086 : indj=1;if (nondiag==1) indj=indsym(4,isym,ja)
2454 [ + + + + : 1233892 : work(:,:,:)=zero
+ + ]
2455 [ + + ]: 224344 : do mu=1,3
2456 [ + + ]: 729118 : do nu=1,3
2457 [ + + ]: 2187354 : do kappa=1,3
2458 [ + + ]: 3533418 : work(:,mu,kappa)=work(:,mu,kappa)+symrec(mu,nu,isym)*dyfrow(:,nu,kappa,indi,indj)
2459 : : end do
2460 : : end do
2461 : : end do
2462 [ + + ]: 226792 : do mu=1,3
2463 [ + + ]: 729118 : do nu=1,3
2464 [ + + ]: 2187354 : do kappa=1,3
2465 [ + + ]: 3533418 : sdyfro(:,kappa,mu,ia,ja)=sdyfro(:,kappa,mu,ia,ja)+symrec(mu,nu,isym)*work(:,kappa,nu)
2466 : : end do
2467 : : end do
2468 : : end do
2469 : : end do
2470 : : end do
2471 : : end do
2472 : 985 : div=one/dble(nsym)
2473 [ + + + + : 55901 : sdyfro(:,:,:,:,:)=div*sdyfro(:,:,:,:,:)
+ + + + +
+ ]
2474 : : ! === Non diagonal dyn. matrix AND q<>0
2475 : : else
2476 [ + + ]: 40 : do ja=1,natom
2477 [ + + ]: 90 : do ia=1,natom
2478 : : nsym_used=0
2479 [ + + ]: 1298 : do isym=1,nsym
2480 [ + + ]: 1298 : if (symq(4,1,isym)==1) then
2481 : : arg=two_pi*(qphon(1)*(indsym(1,isym,ia)-indsym(1,isym,ja)) &
2482 : : & +qphon(2)*(indsym(2,isym,ia)-indsym(2,isym,ja)) &
2483 : 256 : & +qphon(3)*(indsym(3,isym,ia)-indsym(3,isym,ja)))
2484 : 256 : phaser=cos(arg);phasei=sin(arg)
2485 : 256 : nsym_used=nsym_used+1
2486 : 256 : indi=indsym(4,isym,ia)
2487 : 256 : indj=indsym(4,isym,ja)
2488 [ + + + + : 7936 : work(:,:,:)=zero
+ + ]
2489 [ + + ]: 1024 : do mu=1,3
2490 [ + + ]: 3328 : do nu=1,3
2491 [ + + ]: 9984 : do kappa=1,3
2492 [ + + ]: 23040 : work(:,mu,kappa)=work(:,mu,kappa)+symrec(mu,nu,isym)*dyfrow(:,nu,kappa,indi,indj)
2493 : : end do
2494 : : end do
2495 : : end do
2496 [ + + ]: 1024 : do mu=1,3
2497 [ + + ]: 3328 : do nu=1,3
2498 [ + + ]: 9984 : do kappa=1,3
2499 : : sdyfro(1,kappa,mu,ia,ja)=sdyfro(1,kappa,mu,ia,ja) &
2500 : 9216 : & +symrec(mu,nu,isym)*(work(1,kappa,nu)*phaser-work(2,kappa,nu)*phasei)
2501 : : end do
2502 : : end do
2503 : : end do
2504 [ + - ]: 256 : if (cplex==2) then
2505 [ + + ]: 1024 : do mu=1,3
2506 [ + + ]: 3328 : do nu=1,3
2507 [ + + ]: 9984 : do kappa=1,3
2508 : : sdyfro(2,kappa,mu,ia,ja)=sdyfro(2,kappa,mu,ia,ja) &
2509 : 9216 : & +symrec(mu,nu,isym)*(work(1,kappa,nu)*phasei+work(2,kappa,nu)*phaser)
2510 : : end do
2511 : : end do
2512 : : end do
2513 : : end if
2514 : : end if
2515 : : end do
2516 : 50 : div=one/dble(nsym_used)
2517 [ + + + + : 1576 : sdyfro(:,:,:,ia,ja)=div*sdyfro(:,:,:,ia,ja)
+ + ]
2518 : : end do
2519 : : end do
2520 : : end if
2521 : :
2522 : : end if
2523 : :
2524 : 1350 : end subroutine dfpt_sydy
2525 : : !!***
2526 : :
2527 : : ! CODE TO BE EVENTUALLY REUSED
2528 : : ! Sym preserves direction and atom
2529 : : ! if (symq(1,1,isym)==0.and.symq(2,1,isym)==0.and.symq(3,1,isym)==0.and.symq(4,1,isym)==1)then
2530 : : ! if (ipert==indsym(4,isym,ipert)) then
2531 : : ! tok=1
2532 : : ! do idir1=1,3
2533 : : ! if ((idir1==idir.and.symrec(idir,idir1,isym)/=1).or.&
2534 : : ! & (idir1/=idir.and.symrec(idir,idir1,isym)/=0)) tok=0
2535 : : ! end do
2536 : : ! end if
2537 : : ! end if
2538 : : ! div=one/dble(count(symq(4,1,:)==1))
2539 : :
2540 : : !----------------------------------------------------------------------
2541 : :
2542 : : !!****f* m_dynmat/wings3
2543 : : !! NAME
2544 : : !! wings3
2545 : : !!
2546 : : !! FUNCTION
2547 : : !! Suppress the wings of the cartesian 2DTE for which
2548 : : !! the diagonal element is not known
2549 : : !!
2550 : : !! INPUTS
2551 : : !! carflg(3,mpert,3,mpert)= ( 1 if the element of the cartesian
2552 : : !! 2DTE matrix has been calculated correctly ; 0 otherwise )
2553 : : !! d2cart(2,3,mpert,3,mpert)=
2554 : : !! dynamical matrix, effective charges, dielectric tensor,....
2555 : : !! all in cartesian coordinates
2556 : : !! mpert =maximum number of ipert
2557 : : !!
2558 : : !! OUTPUT
2559 : : !! d2cart(2,3,mpert,3,mpert) without the wings
2560 : : !!
2561 : : !! SOURCE
2562 : :
2563 : 382 : subroutine wings3(carflg,d2cart,mpert)
2564 : :
2565 : : !Arguments -------------------------------
2566 : : !scalars
2567 : : integer,intent(in) :: mpert
2568 : : !arrays
2569 : : integer,intent(inout) :: carflg(3,mpert,3,mpert)
2570 : : real(dp),intent(inout) :: d2cart(2,3,mpert,3,mpert)
2571 : :
2572 : : !Local variables -------------------------
2573 : : !scalars
2574 : : integer :: idir,idir1,ipert,ipert1
2575 : : ! *********************************************************************
2576 : :
2577 [ + + ]: 3849 : do ipert=1,mpert
2578 [ + + ]: 14250 : do idir=1,3
2579 [ + + ]: 13868 : if(carflg(idir,ipert,idir,ipert)==0)then
2580 [ + + ]: 85788 : do ipert1=1,mpert
2581 [ + + ]: 318444 : do idir1=1,3
2582 : 232656 : carflg(idir,ipert,idir1,ipert1)=0
2583 : 232656 : carflg(idir1,ipert1,idir,ipert)=0
2584 : 232656 : d2cart(1,idir,ipert,idir1,ipert1)=zero
2585 : 232656 : d2cart(2,idir,ipert,idir1,ipert1)=zero
2586 : 232656 : d2cart(1,idir1,ipert1,idir,ipert)=zero
2587 : 310208 : d2cart(2,idir1,ipert1,idir,ipert)=zero
2588 : : end do
2589 : : end do
2590 : : end if
2591 : : end do
2592 : : end do
2593 : :
2594 : 382 : end subroutine wings3
2595 : : !!***
2596 : :
2597 : : !----------------------------------------------------------------------
2598 : :
2599 : : !!****f* m_dynmat/asrif9
2600 : : !!
2601 : : !! NAME
2602 : : !! asrif9
2603 : : !!
2604 : : !! FUNCTION
2605 : : !! Imposes the Acoustic Sum Rule to Interatomic Forces
2606 : : !!
2607 : : !! INPUTS
2608 : : !! asr= Option for the imposition of the ASR
2609 : : !! 0 => no ASR,
2610 : : !! 1 => modify "asymmetrically" the diagonal element
2611 : : !! 2 => modify "symmetrically" the diagonal element
2612 : : !! natom= Number of atoms in the unit cell
2613 : : !! nrpt= Number of R points in the Big Box
2614 : : !! rpt(3,nprt)= Canonical coordinates of the R points in the unit cell
2615 : : !! These coordinates are normalized (=> * acell(3)!!)
2616 : : !! wghatm(natom,natom,nrpt)= Weight associated to the couple of atoms and the R vector
2617 : : !! atmfrc(3,natom,3,natom,nrpt)= Interatomic Forces
2618 : : !!
2619 : : !! OUTPUT
2620 : : !! atmfrc(3,natom,3,natom,nrpt)= ASR-imposed Interatomic Forces
2621 : : !!
2622 : : !! TODO
2623 : : !! List of ouput should be included.
2624 : : !!
2625 : : !! SOURCE
2626 : :
2627 : 269 : subroutine asrif9(asr,atmfrc,natom,nrpt,rpt,wghatm)
2628 : :
2629 : : !Arguments -------------------------------
2630 : : !scalars
2631 : : integer,intent(in) :: asr,natom,nrpt
2632 : : !arrays
2633 : : real(dp),intent(in) :: rpt(3,nrpt),wghatm(natom,natom,nrpt)
2634 : : real(dp),intent(inout) :: atmfrc(3,natom,3,natom,nrpt)
2635 : :
2636 : : !Local variables -------------------------
2637 : : !scalars
2638 : : integer :: found,ia,ib,irpt,izero,mu,nu
2639 : : real(dp) :: sumifc
2640 : : ! *********************************************************************
2641 : :
2642 [ + + ]: 269 : if(asr==1.or.asr==2)then
2643 : : found=0
2644 : : ! Search for the R vector which is equal to ( 0 , 0 , 0 )
2645 : : ! This vector leaves the atom a on itself !
2646 [ + - ]: 19687 : do irpt=1,nrpt
2647 [ + + + + : 23318 : if (all(abs(rpt(:,irpt))<=1.0d-10)) then
+ + ]
2648 : : found=1
2649 : : izero=irpt
2650 : : end if
2651 : 0 : if (found==1) exit
2652 : : end do
2653 : :
2654 [ - + ]: 268 : if(found==0)then
2655 : 0 : ABI_BUG('Not able to find the vector R=(0,0,0).')
2656 : : end if
2657 : :
2658 [ + + ]: 1072 : do mu=1,3
2659 [ + + ]: 3484 : do nu=1,3
2660 [ + + ]: 9867 : do ia=1,natom
2661 : : sumifc=zero
2662 [ + + ]: 36054 : do ib=1,natom
2663 : :
2664 : : ! Get the sumifc of interatomic forces acting on the atom ia,
2665 : : ! either in a symmetrical manner, or an unsymmetrical one.
2666 [ + + ]: 36054 : if(asr==1)then
2667 [ + + ]: 1831293 : do irpt=1,nrpt
2668 : 1831293 : sumifc=sumifc+wghatm(ia,ib,irpt)*atmfrc(mu,ia,nu,ib,irpt)
2669 : : end do
2670 : : else if(asr==2)then
2671 [ + + ]: 6377454 : do irpt=1,nrpt
2672 : : sumifc=sumifc+&
2673 : : (wghatm(ia,ib,irpt)*atmfrc(mu,ia,nu,ib,irpt)+&
2674 : 6377454 : wghatm(ia,ib,irpt)*atmfrc(nu,ia,mu,ib,irpt))/2
2675 : : end do
2676 : : end if
2677 : : end do
2678 : :
2679 : : ! Correct the self-interaction in order to fulfill the ASR
2680 : 6651 : atmfrc(mu,ia,nu,ia,izero)=atmfrc(mu,ia,nu,ia,izero)-sumifc
2681 [ + + ]: 9063 : if (asr==2) atmfrc(nu,ia,mu,ia,izero)=atmfrc(mu,ia,nu,ia,izero)
2682 : : end do
2683 : : end do
2684 : : end do
2685 : : end if
2686 : :
2687 : 269 : end subroutine asrif9
2688 : : !!***
2689 : :
2690 : : !----------------------------------------------------------------------
2691 : :
2692 : : !!****f* m_dynmat/get_bigbox_and_weights
2693 : : !! NAME
2694 : : !! get_bigbox_and_weights
2695 : : !!
2696 : : !! NOTE
2697 : : !! Not called anymore: m_dvdb.F90's prepare_ftinterp, this routine's only caller, now
2698 : : !! builds its own ifc_supercell_type instance directly (SC%init, SC%calc_ws_wghatm),
2699 : : !! the same construction below, rather than going through this wrapper -- see there for
2700 : : !! why (avoids folding xred_unit back and forth between reduced and cartesian coordinates
2701 : : !! across a subroutine boundary, and the unused Rsh_cart/r_inscribed_sphere outputs).
2702 : : !! Kept here, unused, for reference, and for any future caller that wants the same
2703 : : !! Wigner-Seitz box together with the cutmode filtering below in one call.
2704 : : !!
2705 : : !! FUNCTION
2706 : : !! Compute the Big Box containing the R points in the cartesian real space needed to Fourier Transform
2707 : : !! the dynamical matrix into its corresponding interatomic force.
2708 : : !!
2709 : : !! Brav/acell-independent: the R-points and their weights are obtained from
2710 : : !! ifc_supercell_type%calc_ws_wghatm (m_ifc_supercell.F90) -- the same Wigner-Seitz
2711 : : !! construction ifc_init uses -- instead of the historical brav-specific
2712 : : !! make_bigbox/wght9 pair, which needed a diagonal, cubic-equal ngqpt and the
2713 : : !! dimensionless rprim/gprim convention (see canat9's docstring for the bug that
2714 : : !! convention caused at this routine's former caller, m_dvdb.F90).
2715 : : !!
2716 : : !! INPUTS
2717 : : !! crystal<crystal_t>= Crystal structure of the unit cell (rprimd, xred, ...).
2718 : : !! qptrlatt(3,3)= Integer matrix of the q-point lattice (as kptrlatt for k-points):
2719 : : !! columns are the primitive vectors of the lattice reciprocal to the q-mesh.
2720 : : !! Diagonal(ngqpt) for a simple, single-shift Monkhorst-Pack mesh. Use
2721 : : !! m_kpts/qmesh_from_brav_ngqpt to build it from the historical (brav, ngqpt) input,
2722 : : !! and, if the q-mesh has several shifts, m_kpts/kptrlatt_merge_shifts beforehand to
2723 : : !! merge them into this single, finer qptrlatt (not done here: m_dynmat/44_abitools
2724 : : !! cannot depend on m_kpts/56_recipspace; the caller must already live in, or above,
2725 : : !! 56_recipspace to reach kptrlatt_merge_shifts -- m_dvdb.F90/72_response does).
2726 : : !! xred_unit(3,natom)= Reduced atomic coordinates folded into ]-1/2,1/2] (see canat9).
2727 : : !! cutmode=Define the cutoff used to filter the output R-points according to their weights.
2728 : : !! 0 --> No cutoff (mainly for debugging)
2729 : : !! 1 --> Include only those R-points for which sum(abs(wg(:,:,irpt)) < tol20
2730 : : !! This is the approach used for the dynamical matrix.
2731 : : !! 2 --> Include only those R-points for which the trace over iatom of abs(wg(iat,iat,irpt)) < tol20
2732 : : !! This option is used for objects that depend on a single atomic index.
2733 : : !! comm= MPI communicator (unused now that the retry-on-tolerance loop wght9 needed is gone;
2734 : : !! kept in the API for backward compatibility with the caller).
2735 : : !!
2736 : : !! OUTPUT
2737 : : !! nrpt= Total Number of R points in the Big Box
2738 : : !! R_red(3,nrpt) Give the index of the the R point and irpt
2739 : : !! R_cart(3,nrpt)= Cartesian (bohr) coordinates of the R points.
2740 : : !! r_inscribed_sphere
2741 : : !! wghatm(natom,natom,nrpt)= Weights associated to a pair of atoms and to a R vector
2742 : : !!
2743 : : !! SOURCE
2744 : :
2745 : 0 : subroutine get_bigbox_and_weights(crystal, qptrlatt, xred_unit, &
2746 : : cutmode, nrpt, R_cart, R_red, wghatm, r_inscribed_sphere, comm)
2747 : :
2748 : : !Arguments -------------------------------
2749 : : !scalars
2750 : : integer,intent(in) :: cutmode, comm
2751 : : integer,intent(out) :: nrpt
2752 : : real(dp),intent(out) :: r_inscribed_sphere
2753 : : type(crystal_t),intent(in) :: crystal
2754 : : !arrays
2755 : : integer,intent(in) :: qptrlatt(3,3)
2756 : : real(dp),intent(in) :: xred_unit(3, crystal%natom)
2757 : : integer,allocatable,intent(out) :: R_red(:,:)
2758 : : real(dp),allocatable,intent(out) :: R_cart(:,:), wghatm(:,:,:)
2759 : :
2760 : : !Local variables -------------------------
2761 : : !scalars
2762 : : integer :: ii, irpt, all_nrpt
2763 : 0 : type(ifc_supercell_type) :: SC
2764 : : !arrays
2765 : : real(dp) :: sc_matrix(3,3)
2766 : 0 : integer,allocatable :: all_R_red(:,:)
2767 : 0 : real(dp),allocatable :: all_wghatm(:,:,:)
2768 : : ! *********************************************************************
2769 : :
2770 : : ABI_UNUSED(comm)
2771 [ # # ]: 0 : ABI_CHECK(any(cutmode == [0, 1, 2]), "cutmode should be in [0, 1, 2]")
2772 : : ABI_UNUSED(xred_unit)
2773 : :
2774 : : ! Supercell (Born-von Karman box) dual to the q-mesh. If the q-mesh has several shifts, the
2775 : : ! caller must merge them beforehand into this single, finer qptrlatt (m_kpts/kptrlatt_merge_shifts
2776 : : ! -- not called from here, since m_dynmat/44_abitools cannot depend on m_kpts/56_recipspace).
2777 : : ! Rows of the supercell matrix are the supercell vectors, columns of kptrlatt.
2778 : : ! SC%init computes its own cartesian xcart_unit from crystal%xred (identical, by construction,
2779 : : ! to the caller's xred_unit folded and transformed by rprimd), so the argument is no longer needed.
2780 [ # # # # ]: 0 : sc_matrix = real(transpose(qptrlatt), kind=dp)
2781 : 0 : call SC%init(crystal, sc_matrix)
2782 : :
2783 : : ! Explicit list of R vectors in the Wigner-Seitz cell of the supercell for each atom pair,
2784 : : ! with 1/N weights for N tied images (see the docstring of calc_ws_wghatm).
2785 : 0 : call SC%calc_ws_wghatm(tol8, all_nrpt, all_R_red, all_wghatm)
2786 : 0 : r_inscribed_sphere = SC%shortest_vector_norm()
2787 : 0 : call SC%free()
2788 : :
2789 : : ! Only conserve the necessary points.
2790 : 0 : nrpt = 0
2791 [ # # ]: 0 : do irpt=1,all_nrpt
2792 [ # # ]: 0 : if (filterw(all_wghatm(:,:,irpt))) cycle
2793 : 0 : nrpt = nrpt + 1
2794 : : end do
2795 : :
2796 : : ! Allocate output arrays and transfer data.
2797 [ # # # # : 0 : ABI_MALLOC(R_cart, (3, nrpt))
# # # # #
# # # #
# ]
2798 [ # # # # : 0 : ABI_MALLOC(R_red, (3, nrpt))
# # # # #
# # # #
# ]
2799 [ # # # # : 0 : ABI_MALLOC(wghatm, (crystal%natom, crystal%natom, nrpt))
# # # # #
# # # # #
# # # # #
# # # ]
2800 : :
2801 : 0 : ii = 0
2802 [ # # ]: 0 : do irpt=1,all_nrpt
2803 [ # # ]: 0 : if (filterw(all_wghatm(:,:,irpt))) cycle
2804 : 0 : ii = ii + 1
2805 [ # # # # : 0 : R_cart(:, ii) = matmul(crystal%rprimd, real(all_R_red(:,irpt), kind=dp))
# # # # #
# ]
2806 [ # # # # ]: 0 : wghatm(:,:,ii) = all_wghatm(:,:,irpt)
2807 [ # # ]: 0 : R_red(:,ii) = all_R_red(:,irpt)
2808 : : end do
2809 : :
2810 [ # # ]: 0 : ABI_FREE(all_wghatm)
2811 [ # # # # : 0 : ABI_FREE(all_R_red)
# # # # #
# # # # #
# # ]
2812 : :
2813 : : contains
2814 : :
2815 : 0 : logical pure function filterw(wg)
2816 : :
2817 : : real(dp),intent(in) :: wg(crystal%natom,crystal%natom)
2818 : : integer :: iat
2819 : : real(dp) :: trace
2820 : :
2821 : 0 : select case (cutmode)
2822 : : case (1)
2823 [ # # # # ]: 0 : filterw = sum(abs(wg)) < tol20
2824 : : case (2)
2825 : : trace = zero
2826 [ # # ]: 0 : do iat=1,crystal%natom
2827 : 0 : trace = trace + abs(wg(iat,iat))
2828 : : end do
2829 : 0 : filterw = trace < tol20
2830 : : case default
2831 [ # # # ]: 0 : filterw = .False.
2832 : : end select
2833 : :
2834 : 0 : end function filterw
2835 : :
2836 : : end subroutine get_bigbox_and_weights
2837 : : !!***
2838 : :
2839 : : !----------------------------------------------------------------------
2840 : :
2841 : : !!****f* m_dynmat/make_bigbox
2842 : : !! NAME
2843 : : !! make_bigbox
2844 : : !!
2845 : : !! FUNCTION
2846 : : !! Helper functions to faciliate the generation of a Big Box containing
2847 : : !! all the R points in the cartesian real space needed to Fourier Transform
2848 : : !! the dynamical matrix into its corresponding interatomic force.
2849 : : !! See bigbx9 for the algorithm.
2850 : : !!
2851 : : !! INPUTS
2852 : : !! brav= Bravais Lattice (1 or -1=S.C.;2=F.C.C.;3=BCC;4=Hex.)
2853 : : !! ngqpt(3)= Numbers used to generate the q points to sample the
2854 : : !! Brillouin zone using an homogeneous grid
2855 : : !! nqshft= number of q-points in the repeated cell for the Brillouin zone sampling
2856 : : !! When nqshft is not 1, but 2 or 4 (only other allowed values),
2857 : : !! the limits for the big box have to be extended by a factor of 2.
2858 : : !! rprim(3,3)= Normalized coordinates in real space !!! IS THIS CORRECT?
2859 : : !!
2860 : : !! OUTPUT
2861 : : !! cell(3,nrpt)= integer coordinates of the cells (R points) in the rprim basis
2862 : : !! nprt= Number of cells (R points) in the Big Box
2863 : : !! rpt(3,mrpt)= canonical coordinates of the cells (R points)
2864 : : !! These coordinates are normalized (=> * acell(3)!!)
2865 : : !! The array is allocated here with the proper dimension. Client code is responsible
2866 : : !! for the deallocation.
2867 : : !!
2868 : : !! SOURCE
2869 : :
2870 : 0 : subroutine make_bigbox(brav, cell, ngqpt, nqshft, rprim, nrpt, rpt)
2871 : :
2872 : : !Arguments -------------------------------
2873 : : !scalars
2874 : : integer,intent(in) :: brav,nqshft
2875 : : integer,intent(out) :: nrpt
2876 : : !arrays
2877 : : integer,intent(in) :: ngqpt(3)
2878 : : real(dp),intent(in) :: rprim(3,3)
2879 : : real(dp),allocatable,intent(out) :: rpt(:,:)
2880 : : integer,allocatable,intent(out) :: cell(:,:)
2881 : :
2882 : : !Local variables -------------------------
2883 : : !scalars
2884 : : integer :: choice,mrpt
2885 : : !arrays
2886 : : real(dp) :: dummy_rpt(3,1)
2887 : : integer:: dummy_cell(1,3)
2888 : : ! *********************************************************************
2889 : :
2890 : : ! Compute the number of points (cells) in real space
2891 : 0 : choice=0
2892 : 0 : call bigbx9(brav,dummy_cell,choice,1,ngqpt,nqshft,mrpt,rprim,dummy_rpt)
2893 : :
2894 : : ! Now we can allocate and calculate the points and the weights.
2895 : 0 : nrpt = mrpt
2896 [ # # # # : 0 : ABI_MALLOC(rpt,(3,nrpt))
# # # # #
# # # #
# ]
2897 [ # # # # : 0 : ABI_MALLOC(cell,(3,nrpt))
# # # # #
# # # #
# ]
2898 : :
2899 : 0 : choice=1
2900 : 0 : call bigbx9(brav,cell,choice,mrpt,ngqpt,nqshft,nrpt,rprim,rpt)
2901 : :
2902 : 0 : end subroutine make_bigbox
2903 : : !!***
2904 : :
2905 : : !----------------------------------------------------------------------
2906 : :
2907 : : !!****f* m_dynmat/bigbx9
2908 : : !! NAME
2909 : : !! bigbx9
2910 : : !!
2911 : : !! FUNCTION
2912 : : !! Generation of a Big Box containing all the R points (cells) in the
2913 : : !! cartesian real space needed to Fourier Transforms the dynamical
2914 : : !! matrix into its corresponding interatomic force.
2915 : : !!
2916 : : !! INPUTS
2917 : : !! brav= Bravais Lattice (1 or -1=S.C.;2=F.C.C.;3=BCC;4=Hex.)
2918 : : !! choice= if 0, simply count nrpt ; if 1, checks that the input mrpt
2919 : : !! is the same as nrpt, and generate rpt(3,mrpt)
2920 : : !! mrpt=dimension of rpt
2921 : : !! ngqpt(3)= Numbers used to generate the q points to sample the
2922 : : !! Brillouin zone using an homogeneous grid
2923 : : !! nqshft= number of q-points in the repeated cell for the Brillouin zone sampling
2924 : : !! When nqshft is not 1, but 2 or 4 (only other allowed values),
2925 : : !! the limits for the big box have to be extended by a factor of 2.
2926 : : !! rprim(3,3)= Normalized coordinates in real space !!! IS THIS CORRECT?
2927 : : !!
2928 : : !! OUTPUT
2929 : : !! cell(3,nrpt)= integer coordinates of the cells (R points) in the rprim basis
2930 : : !! nprt= Number of cells (R points) in the Big Box
2931 : : !! rpt(3,mrpt)= canonical coordinates of the cells (R points)
2932 : : !! These coordinates are normalized (=> * acell(3)!!)
2933 : : !! (output only if choice=1)
2934 : : !!
2935 : : !! SOURCE
2936 : :
2937 : 0 : subroutine bigbx9(brav,cell,choice,mrpt,ngqpt,nqshft,nrpt,rprim,rpt)
2938 : :
2939 : : !Arguments -------------------------------
2940 : : !scalars
2941 : : integer,intent(in) :: brav,choice,mrpt,nqshft
2942 : : integer,intent(out) :: nrpt
2943 : : !arrays
2944 : : integer,intent(in) :: ngqpt(3)
2945 : : real(dp),intent(in) :: rprim(3,3)
2946 : : real(dp),intent(out) :: rpt(3,mrpt)
2947 : : integer,intent(out) :: cell(3,mrpt)
2948 : :
2949 : : !Local variables -------------------------
2950 : : !In some cases, the atoms coordinates are not packed in the
2951 : : ! [0,1]^3 cube. Then, the parameter "buffer" might be increased,
2952 : : !to search relevant pairs of atoms in bigger boxes than usual.
2953 : : !scalars
2954 : : integer,parameter :: buffer=1
2955 : : integer :: irpt,lim1,lim2,lim3,lqshft,r1,r2,r3
2956 : : character(len=500) :: msg
2957 : : ! *********************************************************************
2958 : :
2959 : 0 : lqshft=1
2960 [ # # ]: 0 : if(nqshft/=1)lqshft=2
2961 : :
2962 : :
2963 : : !Simple Cubic Lattice
2964 [ # # ]: 0 : if (abs(brav)==1) then
2965 : 0 : lim1=((ngqpt(1))+1)*lqshft+buffer
2966 : 0 : lim2=((ngqpt(2))+1)*lqshft+buffer
2967 : 0 : lim3=((ngqpt(3))+1)*lqshft+buffer
2968 : 0 : nrpt=(2*lim1+1)*(2*lim2+1)*(2*lim3+1)
2969 [ # # ]: 0 : if(choice/=0)then
2970 [ # # ]: 0 : if (nrpt/=mrpt) then
2971 : 0 : write(msg,'(2(a,i0))')' nrpt=',nrpt,' is not equal to mrpt= ',mrpt
2972 : 0 : ABI_BUG(msg)
2973 : : end if
2974 : 0 : irpt=0
2975 [ # # ]: 0 : do r1=-lim1,lim1
2976 [ # # ]: 0 : do r2=-lim2,lim2
2977 [ # # ]: 0 : do r3=-lim3,lim3
2978 : 0 : irpt=irpt+1
2979 : 0 : rpt(1,irpt)=r1*rprim(1,1)+r2*rprim(1,2)+r3*rprim(1,3)
2980 : 0 : rpt(2,irpt)=r1*rprim(2,1)+r2*rprim(2,2)+r3*rprim(2,3)
2981 : 0 : rpt(3,irpt)=r1*rprim(3,1)+r2*rprim(3,2)+r3*rprim(3,3)
2982 : 0 : cell(1,irpt)=r1;cell(2,irpt)=r2;cell(3,irpt)=r3
2983 : : end do
2984 : : end do
2985 : : end do
2986 : : end if
2987 : :
2988 : : ! Face Centered Cubic Lattice
2989 [ # # ]: 0 : else if (brav==2) then
2990 : 0 : lim1=((ngqpt(1)+3)/4)*lqshft+buffer
2991 : 0 : lim2=((ngqpt(2)+3)/4)*lqshft+buffer
2992 : 0 : lim3=((ngqpt(3)+3)/4)*lqshft+buffer
2993 : 0 : nrpt=(2*lim1+1)*(2*lim2+1)*(2*lim3+1)*4
2994 [ # # ]: 0 : if(choice/=0)then
2995 [ # # ]: 0 : if (nrpt/=mrpt) then
2996 : 0 : write(msg,'(2(a,i0))')' nrpt=',nrpt,' is not equal to mrpt= ',mrpt
2997 : 0 : ABI_BUG(msg)
2998 : : end if
2999 : 0 : irpt=0
3000 [ # # ]: 0 : do r1=-lim1,lim1
3001 [ # # ]: 0 : do r2=-lim2,lim2
3002 [ # # ]: 0 : do r3=-lim3,lim3
3003 : 0 : irpt=irpt+4
3004 : 0 : rpt(1,irpt-3)=r1
3005 : 0 : rpt(2,irpt-3)=r2
3006 : 0 : rpt(3,irpt-3)=r3
3007 : 0 : rpt(1,irpt-2)=r1
3008 : 0 : rpt(2,irpt-2)=r2+0.5
3009 : 0 : rpt(3,irpt-2)=r3+0.5
3010 : 0 : rpt(1,irpt-1)=r1+0.5
3011 : 0 : rpt(2,irpt-1)=r2
3012 : 0 : rpt(3,irpt-1)=r3+0.5
3013 : 0 : rpt(1,irpt)=r1+0.5
3014 : 0 : rpt(2,irpt)=r2+0.5
3015 : 0 : rpt(3,irpt)=r3
3016 : : !TEST_AM
3017 : : ! cell(irpt-3,1)=r1;cell(irpt-3,2)=r2;cell(irpt-3,3)=r3
3018 : 0 : cell(1,irpt)=r1;cell(2,irpt)=r2;cell(3,irpt)=r3
3019 : : end do
3020 : : end do
3021 : : end do
3022 : : end if
3023 : :
3024 : : ! Body Centered Cubic Lattice
3025 [ # # ]: 0 : else if (brav==3) then
3026 : 0 : lim1=((ngqpt(1)+3)/4)*lqshft+buffer
3027 : 0 : lim2=((ngqpt(2)+3)/4)*lqshft+buffer
3028 : 0 : lim3=((ngqpt(3)+3)/4)*lqshft+buffer
3029 : 0 : nrpt=(2*lim1+1)*(2*lim2+1)*(2*lim3+1)*2
3030 [ # # ]: 0 : if(choice/=0)then
3031 [ # # ]: 0 : if(nrpt/=mrpt) then
3032 : 0 : write(msg,'(2(a,i0))')' nrpt= ',nrpt,' is not equal to mrpt= ',mrpt
3033 : 0 : ABI_BUG(msg)
3034 : : end if
3035 : 0 : irpt=0
3036 [ # # ]: 0 : do r1=-lim1,lim1
3037 [ # # ]: 0 : do r2=-lim2,lim2
3038 [ # # ]: 0 : do r3=-lim3,lim3
3039 : 0 : irpt=irpt+2
3040 : 0 : rpt(1,irpt-1)=r1
3041 : 0 : rpt(2,irpt-1)=r2
3042 : 0 : rpt(3,irpt-1)=r3
3043 : 0 : rpt(1,irpt)=r1+0.5
3044 : 0 : rpt(2,irpt)=r2+0.5
3045 : 0 : rpt(3,irpt)=r3+0.5
3046 : : !TEST_AM
3047 : : ! cell(irpt-1,1)=r1;cell(irpt-1,2)=r2;cell(irpt-1,3)=r3
3048 : 0 : cell(1,irpt)=r1;cell(2,irpt)=r2;cell(3,irpt)=r3
3049 : : end do
3050 : : end do
3051 : : end do
3052 : : end if
3053 : :
3054 : : ! Hexagonal Lattice
3055 [ # # ]: 0 : else if (brav==4) then
3056 : 0 : lim1=(ngqpt(1)+1)*lqshft+buffer
3057 : 0 : lim2=(ngqpt(2)+1)*lqshft+buffer
3058 : 0 : lim3=((ngqpt(3)/2)+1)*lqshft+buffer
3059 : 0 : nrpt=(2*lim1+1)*(2*lim2+1)*(2*lim3+1)
3060 [ # # ]: 0 : if(choice/=0)then
3061 [ # # ]: 0 : if(nrpt/=mrpt)then
3062 : 0 : write(msg,'(2(a,i0))')' nrpt=',nrpt,' is not equal to mrpt=',mrpt
3063 : 0 : ABI_BUG(msg)
3064 : : end if
3065 : 0 : irpt=0
3066 [ # # ]: 0 : do r1=-lim1,lim1
3067 [ # # ]: 0 : do r2=-lim2,lim2
3068 [ # # ]: 0 : do r3=-lim3,lim3
3069 : 0 : irpt=irpt+1
3070 : 0 : rpt(1,irpt)=r1*rprim(1,1)+r2*rprim(1,2)+r3*rprim(1,3)
3071 : 0 : rpt(2,irpt)=r1*rprim(2,1)+r2*rprim(2,2)+r3*rprim(2,3)
3072 : 0 : rpt(3,irpt)=r1*rprim(3,1)+r2*rprim(3,2)+r3*rprim(3,3)
3073 : 0 : cell(1,irpt)=r1;cell(2,irpt)=r2;cell(3,irpt)=r3
3074 : : end do
3075 : : end do
3076 : : end do
3077 : : end if
3078 : :
3079 : : else
3080 : 0 : write(msg,'(a,i0,a)')' The value of brav= ',brav,' is not allowed (should be -1, 1, 2 or 4).'
3081 : 0 : ABI_BUG(msg)
3082 : : end if
3083 : :
3084 : 0 : end subroutine bigbx9
3085 : : !!***
3086 : :
3087 : : !----------------------------------------------------------------------
3088 : :
3089 : : !!****f* m_dynmat/canat9
3090 : : !! NAME
3091 : : !! canat9
3092 : : !!
3093 : : !! NOTE
3094 : : !! Not called anymore: m_dvdb.F90's prepare_ftinterp, this routine's former only caller,
3095 : : !! now inlines the two-line fold (wrap2_pmhalf + matmul(rprimd,...)) itself before building
3096 : : !! its own ifc_supercell_type instance, since the Rsh_cart output was unused there. Kept
3097 : : !! here, unused, for reference.
3098 : : !!
3099 : : !! FUNCTION
3100 : : !! Folds the reduced atomic coordinates into the unit cell ]-1/2,1/2], and
3101 : : !! returns the corresponding cartesian shift vector.
3102 : : !!
3103 : : !! Brav/acell-independent: unlike the historical implementation (still
3104 : : !! visible in the git history), the folding is a single generic
3105 : : !! component-wise wrap, valid for any Bravais lattice -- it does not need
3106 : : !! to know brav, and needs rprimd (dimensional, bohr) rather than the
3107 : : !! dimensionless rprim (which silently assumed the caller would later
3108 : : !! rescale by acell; see the docstring of get_bigbox_and_weights, which
3109 : : !! consumes xred_unit, for the bug this caused when acell(1:3) were not
3110 : : !! all equal or rprim was not diagonal).
3111 : : !!
3112 : : !! INPUTS
3113 : : !! natom= Number of atoms in the unit cell
3114 : : !! rprimd(3,3)= Dimensional primitive vectors (bohr)
3115 : : !! xred(3,natom)= Reduced atomic coordinates
3116 : : !!
3117 : : !! OUTPUT
3118 : : !! xred_unit(3,natom) = xred folded into ]-1/2,1/2] (reduced coordinates)
3119 : : !! Rsh_cart(3,natom) = Cartesian lattice vector such that
3120 : : !! xred(:,iatom) = xred_unit(:,iatom) + (reduced coordinates of Rsh_cart(:,iatom))
3121 : : !! i.e. matmul(rprimd, xred(:,iatom)) = matmul(rprimd, xred_unit(:,iatom)) + Rsh_cart(:,iatom)
3122 : : !!
3123 : : !! SOURCE
3124 : :
3125 : 0 : subroutine canat9(natom, rprimd, xred, xred_unit, Rsh_cart)
3126 : :
3127 : : !Arguments -------------------------------
3128 : : !scalars
3129 : : integer,intent(in) :: natom
3130 : : !arrays
3131 : : real(dp),intent(in) :: rprimd(3,3),xred(3,natom)
3132 : : real(dp),intent(out) :: xred_unit(3,natom),Rsh_cart(3,natom)
3133 : :
3134 : : !Local variables -------------------------
3135 : : !scalars
3136 : : integer :: iatom
3137 : : !arrays
3138 : 0 : real(dp) :: shift_red(3,natom)
3139 : : ! *********************************************************************
3140 : :
3141 : : ! Fold each reduced coordinate into ]-1/2,1/2]; shift_red is the (integer,
3142 : : ! in reduced units) lattice translation that was subtracted off.
3143 [ # # # # ]: 0 : call wrap2_pmhalf(xred, xred_unit, shift_red)
3144 : :
3145 [ # # ]: 0 : do iatom=1,natom
3146 [ # # # # : 0 : Rsh_cart(:,iatom) = matmul(rprimd, shift_red(:,iatom))
# # ]
3147 : : end do
3148 : :
3149 : 0 : end subroutine canat9
3150 : : !!***
3151 : :
3152 : : !----------------------------------------------------------------------
3153 : :
3154 : : !!****f* m_dynmat/canct9
3155 : : !!
3156 : : !! NAME
3157 : : !! canct9
3158 : : !!
3159 : : !! FUNCTION
3160 : : !! Convert from canonical coordinates to cartesian coordinates
3161 : : !! a vector defined by its index=ib+natom*(irpt-1)
3162 : : !!
3163 : : !! INPUTS
3164 : : !! index= index of the atom
3165 : : !! natom=number of atoms in unit cell
3166 : : !! nrpt= Number of R points in the Big Box
3167 : : !! rcan(3,natom)=cartesian coordinates of atoms
3168 : : !! rpt(3,nrpt)=cartesian coordinates of the points in the BigBox.
3169 : : !!
3170 : : !! OUTPUT
3171 : : !! ib=number of the atom in the unit cell
3172 : : !! irpt= number of the unit cell to which belong the atom
3173 : : !! rcart(3)=cartesian coordinate of the atom indexed by index.
3174 : : !!
3175 : : !! SOURCE
3176 : :
3177 : 20691 : subroutine canct9(ib,index,irpt,natom,nrpt,rcan,rcart,rpt)
3178 : :
3179 : : !Arguments -------------------------------
3180 : : !scalars
3181 : : integer,intent(in) :: index,natom,nrpt
3182 : : integer,intent(out) :: ib,irpt
3183 : : !arrays
3184 : : real(dp),intent(in) :: rcan(3,natom)
3185 : : real(dp),intent(in) :: rpt(3,nrpt)
3186 : : real(dp),intent(out) :: rcart(3)
3187 : :
3188 : : ! *********************************************************************
3189 : :
3190 : 20691 : irpt=(index-1)/natom+1
3191 : 20691 : ib=index-natom*(irpt-1)
3192 : :
3193 [ + + ]: 82764 : rcart(:) = rpt(:,irpt) + rcan(:,ib)
3194 : :
3195 : 20691 : end subroutine canct9
3196 : : !!***
3197 : :
3198 : : !----------------------------------------------------------------------
3199 : :
3200 : : !!****f* m_dynmat/chkrp9
3201 : : !! NAME
3202 : : !! chkrp9
3203 : : !!
3204 : : !! FUNCTION
3205 : : !! Check if the rprim used for the definition of the unit cell (in the
3206 : : !! inputs) are consistent with the rprim used in the routine generating
3207 : : !! the Big Box needed to generate the interatomic forces.
3208 : : !!
3209 : : !! INPUTS
3210 : : !! brav=bravais lattice (1 or -1=simple lattice,2=face centered lattice,
3211 : : !! 3=centered lattice,4=hexagonal lattice)
3212 : : !! rprimd(3,3)=dimensional primitive translations for real space (bohr)
3213 : : !!
3214 : : !! OUTPUT
3215 : : !! (only checking)
3216 : : !!
3217 : : !! SOURCE
3218 : :
3219 : 0 : subroutine chkrp9(brav,rprim)
3220 : :
3221 : : !Arguments -------------------------------
3222 : : !scalars
3223 : : integer,intent(in) :: brav
3224 : : !arrays
3225 : : real(dp),intent(in) :: rprim(3,3)
3226 : :
3227 : : !Local variables -------------------------
3228 : : !scalars
3229 : : integer :: ii,jj
3230 : : character(len=500) :: msg
3231 : : ! *********************************************************************
3232 : :
3233 [ # # ]: 0 : if (abs(brav)==1) then
3234 : : ! Simple Cubic Lattice No condition in this case !
3235 : : continue
3236 : :
3237 [ # # ]: 0 : else if (brav==2) then
3238 : : ! Face Centered Lattice
3239 [ # # ]: 0 : do ii=1,3
3240 [ # # ]: 0 : do jj=1,3
3241 [ # # # # : 0 : if ( ( ii==jj .and. abs(rprim(ii,jj))>tol10) .or. (ii/=jj .and. abs(rprim(ii,jj)-.5_dp)>tol10) ) then
# # # # ]
3242 : : write(msg, '(a,a,a,a,a,a,a,a,a,a,a)' )&
3243 : 0 : 'The input variable rprim does not correspond to the',ch10,&
3244 : 0 : 'fixed rprim to be used with brav=2 and ifcflag=1 :',ch10,&
3245 : 0 : ' 0 1/2 1/2',ch10,&
3246 : 0 : ' 1/2 0 1/2',ch10,&
3247 : 0 : ' 1/2 1/2 0 ',ch10,&
3248 : 0 : 'Action: rebuild your DDB by using the latter rprim.'
3249 : 0 : ABI_ERROR(msg)
3250 : : end if
3251 : : end do
3252 : : end do
3253 : :
3254 [ # # ]: 0 : else if (brav==3) then
3255 : : ! Body Centered Cubic Lattice
3256 [ # # ]: 0 : do ii=1,3
3257 [ # # ]: 0 : do jj=1,3
3258 [ # # # # : 0 : if ( ( ii==jj .and. abs(rprim(ii,jj)+.5_dp)>tol10) .or. (ii/=jj .and. abs(rprim(ii,jj)-.5_dp)>tol10) ) then
# # # # ]
3259 : : write(msg, '(a,a,a,a,a,a,a,a,a,a,a)' )&
3260 : 0 : 'The input variable rprim does not correspond to the',ch10,&
3261 : 0 : 'fixed rprim to be used with brav=3 and ifcflag=1 :',ch10,&
3262 : 0 : ' -1/2 1/2 1/2',ch10,&
3263 : 0 : ' 1/2 -1/2 1/2',ch10,&
3264 : 0 : ' 1/2 1/2 -1/2',ch10,&
3265 : 0 : 'Action: rebuild your DDB by using the latter rprim.'
3266 : 0 : ABI_ERROR(msg)
3267 : : end if
3268 : : end do
3269 : : end do
3270 : :
3271 [ # # ]: 0 : else if (brav==4) then
3272 : : ! Hexagonal Lattice
3273 : : if (abs(rprim(1,1)-1.0_dp)>tol10 .or. &
3274 : : abs(rprim(3,3)-1.0_dp)>tol10 .or. &
3275 : : abs(rprim(2,1) )>tol10 .or. &
3276 : : abs(rprim(3,1) )>tol10 .or. &
3277 : : abs(rprim(1,3) )>tol10 .or. &
3278 : : abs(rprim(2,3) )>tol10 .or. &
3279 : : abs(rprim(3,2) )>tol10 .or. &
3280 [ # # # # : 0 : abs(rprim(1,2)+0.5_dp)>tol10 .or. &
# # # # #
# # # # #
# # # # ]
3281 : : abs(rprim(2,2)-0.5_dp*sqrt(3.0_dp))>tol10 ) then
3282 : : write(msg, '(a,a,a,a,a,a,a,a,a,a,a)' )&
3283 : 0 : 'The input variable rprim does not correspond to the',ch10,&
3284 : 0 : 'fixed rprim to be used with brav=4 and ifcflag=1 :',ch10,&
3285 : 0 : ' 1 0 0',ch10,&
3286 : 0 : ' -1/2 sqrt[3]/2 0',ch10,&
3287 : 0 : ' 0 0 1',ch10,&
3288 : 0 : 'Action: rebuild your DDB by using the latter rprim.'
3289 : 0 : ABI_ERROR(msg)
3290 : : end if
3291 : :
3292 : : else
3293 : : write(msg, '(a,i4,a,a,a,a,a)' )&
3294 : 0 : 'The value of brav=',brav,' is not allowed.',ch10,&
3295 : 0 : 'Only -1, 1,2,3 or 4 are allowed.',ch10,&
3296 : 0 : 'Action: change the value of brav in your input file.'
3297 : 0 : ABI_ERROR(msg)
3298 : : end if
3299 : :
3300 : 0 : end subroutine chkrp9
3301 : : !!***
3302 : :
3303 : : !----------------------------------------------------------------------
3304 : :
3305 : : !!****f* m_dynmat/dist9
3306 : : !! NAME
3307 : : !! dist9
3308 : : !!
3309 : : !! FUNCTION
3310 : : !! Compute the distance between atoms
3311 : : !!
3312 : : !! INPUTS
3313 : : !! dist(natom,natom,nrpt)=distances between atoms
3314 : : !! natom=number of atoms in unit cell
3315 : : !! nrpt= Number of R points in the Big Box
3316 : : !! rcan(3,natom)=cartesian coordinates of atoms
3317 : : !! rpt(3,nrpt)=cartesian coordinates of the points in the BigBox.
3318 : : !!
3319 : : !! OUTPUT
3320 : : !! dist(natom,natom,nrpt)=distances between atoms
3321 : : !!
3322 : : !! SOURCE
3323 : :
3324 : 83 : subroutine dist9(dist,natom,nrpt,rcan,rpt)
3325 : :
3326 : : !Arguments -------------------------------
3327 : : !scalars
3328 : : integer,intent(in) :: natom,nrpt
3329 : : !arrays
3330 : : real(dp),intent(in) :: rcan(3,natom)
3331 : : real(dp),intent(in) :: rpt(3,nrpt)
3332 : : real(dp),intent(out) :: dist(natom,natom,nrpt)
3333 : :
3334 : : !Local variables -------------------------
3335 : : !scalars
3336 : : integer :: ia,ib,irpt
3337 : : !arrays
3338 : : real(dp) :: rdiff(3)
3339 : : ! *********************************************************************
3340 : :
3341 : : !BIG loop on all generic atoms
3342 [ + + ]: 344 : do ia=1,natom
3343 [ + + ]: 1727 : do ib=1,natom
3344 [ + + ]: 614092 : do irpt=1,nrpt
3345 [ + + ]: 2449792 : rdiff(:) = rcan(:,ia) - rcan(:,ib) - rpt(:,irpt)
3346 : 613831 : dist(ia,ib,irpt)=(rdiff(1)**2+rdiff(2)**2+rdiff(3)**2)**0.5
3347 : : end do
3348 : : end do
3349 : : end do
3350 : :
3351 : 83 : end subroutine dist9
3352 : : !!***
3353 : :
3354 : : !----------------------------------------------------------------------
3355 : :
3356 : : !!****f* m_dynmat/ftifc_q2r
3357 : : !!
3358 : : !! NAME
3359 : : !! ftifc_q2r
3360 : : !!
3361 : : !! FUNCTION
3362 : : !! Generates the Fourier transform of the dynamical matrices
3363 : : !! to obtain interatomic forces (real space).
3364 : : !!
3365 : : !! INPUTS
3366 : : !! dynmat(2,3,natom,3,natom,nqpt)= Dynamical matrices coming from the Derivative Data Base
3367 : : !! gprim(3,3)= Normalized coordinates in reciprocal space
3368 : : !! natom= Number of atoms in the unit cell
3369 : : !! nqpt= Number of q points in the Brillouin zone
3370 : : !! nrpt= Number of R points in the Big Box
3371 : : !! rpt(3,nprt)= Canonical coordinates of the R points in the unit cell
3372 : : !! These coordinates are normalized (=> * acell(3)!!)
3373 : : !! spqpt(3,nqpt)= Reduced coordinates of the q vectors in reciprocal space
3374 : : !! comm=MPI communicator.
3375 : : !!
3376 : : !! OUTPUT
3377 : : !! atmfrc(3,natom,3,natom,nrpt)= Interatomic Forces in real space.
3378 : : !!
3379 : : !! SOURCE
3380 : :
3381 : 201 : subroutine ftifc_q2r(atmfrc,dynmat,gprim,natom,nqpt,nrpt,rpt,spqpt,comm)
3382 : :
3383 : : !Arguments -------------------------------
3384 : : !scalars
3385 : : integer,intent(in) :: natom,nqpt,nrpt,comm
3386 : : !arrays
3387 : : real(dp),intent(in) :: gprim(3,3),rpt(3,nrpt),spqpt(3,nqpt)
3388 : : real(dp),intent(out) :: atmfrc(3,natom,3,natom,nrpt)
3389 : : real(dp),intent(in) :: dynmat(2,3,natom,3,natom,nqpt)
3390 : :
3391 : : !Local variables -------------------------
3392 : : !scalars
3393 : : integer :: ia,ib,iqpt,irpt,mu,nu,nprocs,my_rank,ierr
3394 : : real(dp) :: im,kr,re
3395 : : !arrays
3396 : : real(dp) :: kk(3)
3397 : : ! *********************************************************************
3398 : :
3399 : 201 : nprocs = xmpi_comm_size(comm); my_rank = xmpi_comm_rank(comm)
3400 : :
3401 : : ! Interatomic Forces from Dynamical Matrices
3402 [ + + + + : 4154000 : atmfrc = zero
+ + + + +
+ ]
3403 [ + + ]: 23976 : do irpt=1,nrpt
3404 [ + + ]: 23775 : if (mod(irpt, nprocs) /= my_rank) cycle ! mpi-parallelism
3405 [ + + ]: 5987958 : do iqpt=1,nqpt
3406 : :
3407 : : ! Calculation of the k coordinates in Normalized Reciprocal coordinates
3408 [ + + + + ]: 77533950 : kk(:) = matmul(gprim, spqpt(:, iqpt))
3409 : :
3410 : : ! Product of k and r
3411 [ + + ]: 23856600 : kr=dot_product(kk,rpt(:,irpt))
3412 : :
3413 : : ! Get the phase factor
3414 : 5964150 : re=cos(two_pi*kr)
3415 : 5964150 : im=sin(two_pi*kr)
3416 : :
3417 : : ! Now, big inner loops on atoms and directions
3418 : : ! The indices are ordered to give better speed
3419 [ + + ]: 29481642 : do ib=1,natom
3420 [ + + ]: 99939018 : do nu=1,3
3421 [ + + ]: 411406215 : do ia=1,natom
3422 [ + + ]: 1340206539 : do mu=1,3
3423 : : ! Real part of the interatomic forces
3424 : : atmfrc(mu,ia,nu,ib,irpt)=atmfrc(mu,ia,nu,ib,irpt) &
3425 : : +re*dynmat(1,mu,ia,nu,ib,iqpt)&
3426 : 1269725388 : +im*dynmat(2,mu,ia,nu,ib,iqpt)
3427 : : !The imaginary part should be equal to zero !!!!!!
3428 : : !atmfrc(2,mu,ia,nu,ib,irpt)=atmfrc(2,mu,ia,nu,ib,irpt) &
3429 : : ! +re*dynmat(2,mu,ia,nu,ib,iqpt) &
3430 : : ! -im*dynmat(1,mu,ia,nu,ib,iqpt)
3431 : : end do
3432 : : end do
3433 : : end do
3434 : : end do
3435 : :
3436 : : end do
3437 : : end do
3438 : :
3439 : 201 : call xmpi_sum(atmfrc, comm, ierr)
3440 : : !The sumifc has to be weighted by a normalization factor of 1/nqpt
3441 [ + + + + : 4154000 : atmfrc = atmfrc/nqpt
+ + + + +
+ ]
3442 : :
3443 : 201 : end subroutine ftifc_q2r
3444 : : !!***
3445 : :
3446 : : !----------------------------------------------------------------------
3447 : :
3448 : : !!****f* m_dynmat/ftifc_r2q
3449 : : !!
3450 : : !! NAME
3451 : : !! ftifc_r2q
3452 : : !!
3453 : : !! FUNCTION
3454 : : !! Generates the Fourier transform of the interatomic forces
3455 : : !! to obtain dynamical matrices in reciprocal space: R --> q.
3456 : : !!
3457 : : !! INPUTS
3458 : : !! atmfrc(3,natom,3,natom,nrpt)= Interatomic Forces in real space
3459 : : !! gprim(3,3)= Normalized coordinates in reciprocal space
3460 : : !! natom= Number of atoms in the unit cell
3461 : : !! nqpt= Number of q points in the Brillouin zone
3462 : : !! nrpt= Number of R points in the Big Box
3463 : : !! rpt(3,nprt)= Canonical coordinates of the R points in the unit cell
3464 : : !! These coordinates are normalized (=> * acell(3)!!)
3465 : : !! spqpt(3,nqpt)= Reduced coordinates of the q vectors in reciprocal space
3466 : : !! wghatm(natom,natom,nrpt)= Weights associated to a pair of atoms and to a R vector
3467 : : !! comm: MPI communicator
3468 : : !!
3469 : : !! OUTPUT
3470 : : !! dynmat(2,3,natom,3,natom,nqpt)= Dynamical matrices coming from the Derivative Data Base
3471 : : !!
3472 : : !! SOURCE
3473 : :
3474 : 197574 : subroutine ftifc_r2q(atmfrc, dynmat, gprim, natom, nqpt, nrpt, rpt, spqpt, wghatm, comm)
3475 : :
3476 : : !Arguments -------------------------------
3477 : : !scalars
3478 : : integer,intent(in) :: natom,nqpt,nrpt,comm
3479 : : !arrays
3480 : : real(dp),intent(in) :: gprim(3,3),rpt(3,nrpt),spqpt(3,nqpt)
3481 : : real(dp),intent(in) :: wghatm(natom,natom,nrpt)
3482 : : real(dp),intent(in) :: atmfrc(3,natom,3,natom,nrpt)
3483 : : real(dp),intent(out) :: dynmat(2,3,natom,3,natom,nqpt)
3484 : :
3485 : : !Local variables -------------------------
3486 : : !scalars
3487 : : integer :: ia,ib,iqpt,irpt,mu,nu,cnt,my_rank,nprocs, ierr
3488 : : real(dp) :: facti,factr,im,kr,re
3489 : : !real(dp) : w(2, natom, natom)
3490 : : !arrays
3491 : : real(dp) :: kk(3)
3492 : : ! *********************************************************************
3493 : :
3494 : 197574 : my_rank = xmpi_comm_rank(comm); nprocs = xmpi_comm_size(comm)
3495 [ + + + + : 35609520 : dynmat = zero; cnt = 0
+ + + + +
+ + + ]
3496 : :
3497 : : ! MG: This is an hotspot. I don'tknow whether one should rewrite with BLAS1 dot or not.
3498 : : ! Note, however, that simply removing the check on the weights inside the loop over atoms.
3499 : : ! leads to a non-negligible speedup with intel (~30% if dipdip -1 is used)
3500 [ + + ]: 395148 : do iqpt=1,nqpt
3501 : :
3502 : : ! Calculation of the k coordinates in Normalized Reciprocal coordinates
3503 [ + + + + ]: 2568462 : kk(:) = matmul(gprim, spqpt(:, iqpt))
3504 : :
3505 [ + + ]: 63710777 : do irpt=1,nrpt
3506 [ + - ]: 63315629 : cnt = cnt + 1; if (mod(cnt, nprocs) /= my_rank) cycle ! MPI parallelism.
3507 : :
3508 : : ! k.R
3509 [ + + ]: 253262516 : kr=dot_product(kk,rpt(:,irpt))
3510 : : ! Get phase factor
3511 : 63315629 : re = cos(two_pi*kr); im = sin(two_pi*kr)
3512 : :
3513 : : ! Inner loop on atoms and directions
3514 [ + + ]: 217064340 : do ib=1,natom
3515 [ + + ]: 716950481 : do ia=1,natom
3516 : : !if (abs(wghatm(ia,ib,irpt)) > tol10) then ! Commented by MG
3517 : 500083715 : factr = re * wghatm(ia,ib,irpt)
3518 : 500083715 : facti = im * wghatm(ia,ib,irpt)
3519 [ + + ]: 2153885997 : do nu=1,3
3520 [ + + ]: 6501088295 : do mu=1,3
3521 : : ! Real and imaginary part of the dynamical matrices
3522 : : ! Atmfrc should be real
3523 : 4500753435 : dynmat(1,mu,ia,nu,ib,iqpt) = dynmat(1,mu,ia,nu,ib,iqpt) + factr * atmfrc(mu,ia,nu,ib,irpt)
3524 : 6001004580 : dynmat(2,mu,ia,nu,ib,iqpt) = dynmat(2,mu,ia,nu,ib,iqpt) + facti * atmfrc(mu,ia,nu,ib,irpt)
3525 : : end do
3526 : : end do
3527 : : !end if
3528 : : end do
3529 : : end do
3530 : :
3531 : : ! MG: New version: I don't know if it's faster.
3532 : : !w(1,:,:) = re * wghatm(:,:,irpt)
3533 : : !w(2,:,:) = im * wghatm(:,:,irpt)
3534 : : !do ib=1,natom
3535 : : ! do nu=1,3
3536 : : ! do ia=1,natom
3537 : : ! do mu=1,3
3538 : : ! ! Real and imaginary part of the dynamical matrices
3539 : : ! ! Atmfrc should be real
3540 : : ! dynmat(1,mu,ia,nu,ib,iqpt) = dynmat(1,mu,ia,nu,ib,iqpt) + w(1,ia,ib) * atmfrc(mu,ia,nu,ib,irpt)
3541 : : ! dynmat(2,mu,ia,nu,ib,iqpt) = dynmat(2,mu,ia,nu,ib,iqpt) + w(2,ia,ib) * atmfrc(mu,ia,nu,ib,irpt)
3542 : : ! end do
3543 : : ! end do
3544 : : ! end do
3545 : : !end do
3546 : :
3547 : : end do
3548 : : end do
3549 : :
3550 [ - + ]: 197574 : if (nprocs > 1) call xmpi_sum(dynmat, comm, ierr)
3551 : :
3552 : 197574 : end subroutine ftifc_r2q
3553 : : !!***
3554 : :
3555 : : !----------------------------------------------------------------------
3556 : :
3557 : : !!****f* m_dynmat/dynmat_dq
3558 : : !!
3559 : : !! NAME
3560 : : !! dynmat_dq
3561 : : !!
3562 : : !! FUNCTION
3563 : : !! Compute the derivative D(q)/dq of the dynamical matrix via Fourier transform
3564 : : !! of the interatomic forces
3565 : : !!
3566 : : !! INPUTS
3567 : : !! qpt(3)= Reduced coordinates of the q vector in reciprocal space
3568 : : !! natom= Number of atoms in the unit cell
3569 : : !! gprim(3,3)= Primitive vectors of the reciprocal lattice, dual to the lattice of rpt (gprimd for cartesian rpt)
3570 : : !! nrpt= Number of R points in the Big Box
3571 : : !! rpt(3,nprt)= Coordinates of the R points (cartesian, in Bohr, for ifc_type)
3572 : : !! atmfrc(3,natom,3,natom,nrpt)= Interatomic Forces in real space
3573 : : !! wghatm(natom,natom,nrpt)= Weights associated to a pair of atoms and to a R vector
3574 : : !!
3575 : : !! OUTPUT
3576 : : !! dddq(2,3,natom,3,natom,3)= Derivate of the dynamical matrix, in the coordinates of rpt
3577 : : !! (cartesian for cartesian rpt). The three directions are stored in the last dimension.
3578 : : !!
3579 : : !! SOURCE
3580 : :
3581 : 129533 : subroutine dynmat_dq(qpt,natom,gprim,nrpt,rpt,atmfrc,wghatm,dddq)
3582 : :
3583 : : !Arguments -------------------------------
3584 : : !scalars
3585 : : integer,intent(in) :: natom,nrpt
3586 : : !arrays
3587 : : real(dp),intent(in) :: gprim(3,3),rpt(3,nrpt),qpt(3)
3588 : : real(dp),intent(in) :: wghatm(natom,natom,nrpt)
3589 : : real(dp),intent(in) :: atmfrc(3,natom,3,natom,nrpt)
3590 : : real(dp),intent(out) :: dddq(2,3,natom,3,natom,3)
3591 : :
3592 : : !Local variables -------------------------
3593 : : !scalars
3594 : : integer :: ia,ib,irpt,mu,nu,ii
3595 : : real(dp) :: im,kr,re
3596 : : !arrays
3597 : : real(dp) :: kk(3),fact(2,3)
3598 : : ! *********************************************************************
3599 : :
3600 [ + + + + : 46226078 : dddq = zero
+ + + + +
+ + + ]
3601 [ + + ]: 46717662 : do irpt=1,nrpt
3602 : : ! Calculation of the k coordinates in Normalized Reciprocal coordinates
3603 [ + + + + ]: 605645677 : kk(:) = matmul(gprim, qpt)
3604 : :
3605 : : ! Product of k and r
3606 [ + + ]: 186352516 : kr=dot_product(kk,rpt(:,irpt))
3607 : :
3608 : : ! Get phase factor
3609 : 46588129 : re=cos(two_pi*kr); im=sin(two_pi*kr)
3610 : :
3611 : : ! Inner loop on atoms and directions
3612 [ + + ]: 136178695 : do ib=1,natom
3613 [ + + ]: 317689899 : do ia=1,natom
3614 [ + + ]: 271101770 : if (abs(wghatm(ia,ib,irpt))>1.0d-10) then
3615 : : ! take into account rotation due to i.
3616 [ + + ]: 712541228 : fact(1,:) = -im * wghatm(ia,ib,irpt) * rpt(:,irpt)
3617 [ + + ]: 712541228 : fact(2,:) = re * wghatm(ia,ib,irpt) * rpt(:,irpt)
3618 [ + + ]: 712541228 : do nu=1,3
3619 [ + + ]: 2315758991 : do mu=1,3
3620 : : ! Real and imaginary part of the dynamical matrices
3621 : : ! Atmfrc should be real
3622 [ + + ]: 6947276973 : do ii=1,3
3623 : 4809653289 : dddq(1,mu,ia,nu,ib,ii) = dddq(1,mu,ia,nu,ib,ii) + fact(1,ii) * atmfrc(mu,ia,nu,ib,irpt)
3624 : 6412871052 : dddq(2,mu,ia,nu,ib,ii) = dddq(2,mu,ia,nu,ib,ii) + fact(2,ii) * atmfrc(mu,ia,nu,ib,irpt)
3625 : : end do
3626 : : end do
3627 : : end do
3628 : : end if
3629 : : end do
3630 : : end do
3631 : : end do
3632 : 129533 : end subroutine dynmat_dq
3633 : : !!***
3634 : :
3635 : : !----------------------------------------------------------------------
3636 : :
3637 : : !!****f* m_dynmat/ifclo9
3638 : : !! NAME
3639 : : !! ifclo9
3640 : : !!
3641 : : !! FUNCTION
3642 : : !! Convert from cartesian coordinates to local coordinates
3643 : : !! the 3*3 interatomic force constant matrix
3644 : : !!
3645 : : !! INPUTS
3646 : : !! ifccar(3,3)= matrix of interatomic force constants in cartesian
3647 : : !! coordinates
3648 : : !! vect1(3)= cartesian coordinates of the first local vector
3649 : : !! vect2(3)= cartesian coordinates of the second local vector
3650 : : !! vect3(3)= cartesian coordinates of the third local vector
3651 : : !!
3652 : : !! OUTPUT
3653 : : !! ifcloc(3,3)= matrix of interatomic force constants in local coordinates
3654 : : !!
3655 : : !! SOURCE
3656 : :
3657 : 29558 : subroutine ifclo9(ifccar,ifcloc,vect1,vect2,vect3)
3658 : :
3659 : : !Arguments -------------------------------
3660 : : !arrays
3661 : : real(dp),intent(in) :: ifccar(3,3),vect1(3),vect2(3),vect3(3)
3662 : : real(dp),intent(out) :: ifcloc(3,3)
3663 : :
3664 : : !Local variables -------------------------
3665 : : !scalars
3666 : : integer :: ii,jj
3667 : : !arrays
3668 : : real(dp) :: work(3,3)
3669 : : ! *********************************************************************
3670 : :
3671 [ + + ]: 118232 : do jj=1,3
3672 [ + + ]: 354696 : do ii=1,3
3673 : 354696 : work(jj,ii)=zero
3674 : : end do
3675 [ + + ]: 384254 : do ii=1,3
3676 : 266022 : work(jj,1)=work(jj,1)+ifccar(jj,ii)*vect1(ii)
3677 : 266022 : work(jj,2)=work(jj,2)+ifccar(jj,ii)*vect2(ii)
3678 : 354696 : work(jj,3)=work(jj,3)+ifccar(jj,ii)*vect3(ii)
3679 : : end do
3680 : : end do
3681 : :
3682 [ + + ]: 118232 : do jj=1,3
3683 [ + + ]: 354696 : do ii=1,3
3684 : 354696 : ifcloc(ii,jj)=zero
3685 : : end do
3686 [ + + ]: 384254 : do ii=1,3
3687 : 266022 : ifcloc(1,jj)=ifcloc(1,jj)+vect1(ii)*work(ii,jj)
3688 : 266022 : ifcloc(2,jj)=ifcloc(2,jj)+vect2(ii)*work(ii,jj)
3689 : 354696 : ifcloc(3,jj)=ifcloc(3,jj)+vect3(ii)*work(ii,jj)
3690 : : end do
3691 : : end do
3692 : :
3693 : 29558 : end subroutine ifclo9
3694 : : !!***
3695 : :
3696 : : !----------------------------------------------------------------------
3697 : :
3698 : : !!****f* m_dynmat/wght9
3699 : : !! NAME
3700 : : !! wght9
3701 : : !!
3702 : : !! NOTE
3703 : : !! Not called anymore: get_bigbox_and_weights (this module) now gets its R-points and
3704 : : !! weights from ifc_supercell_type%calc_ws_wghatm (m_ifc_supercell.F90), which is
3705 : : !! brav-independent and works for any supercell matrix, not just the diagonal,
3706 : : !! cubic-equal ngqpt this routine (and make_bigbox/bigbx9, its companion for the
3707 : : !! R-point list itself) requires. Kept here, unused, for reference.
3708 : : !!
3709 : : !! FUNCTION
3710 : : !! Generates a weight to each R point of the Big Box and for each pair of atoms
3711 : : !! For each R points included in the space generates by moving
3712 : : !! the unit cell around each atom; the weight will be one.
3713 : : !! Border conditions are provided.
3714 : : !! The R points outside the chosen space will have a 0 weight.
3715 : : !!
3716 : : !! INPUTS
3717 : : !! brav = Bravais lattice (1 or -1=S.C.;2=F.C.C.;4=Hex. -1 is for old algo to find weights, =1 is for Wigner-Seitz algo)
3718 : : !! gprim(3,3)= Normalized coordinates in reciprocal space
3719 : : !! natom= Number of atoms in the unit cell
3720 : : !! ngqpt(6)= Numbers used to sample the Brillouin zone
3721 : : !! nqpt= Number of q points used in the homogeneous grid
3722 : : !! sampling the Brillouin zone
3723 : : !! nqshft=number of shift vectors in the repeated cell
3724 : : !! nrpt=Number of R points in the Big Box
3725 : : !! qshft(3,nqshft)=vectors that will be used to determine
3726 : : !! the shifts from (0. 0. 0.)
3727 : : !! rcan(3,natom)=Atomic position in canonical coordinates
3728 : : !! rpt(3,nprt)=Canonical coordinates of the R points in the unit cell
3729 : : !! These coordinates are normalized (=> * acell(3))
3730 : : !! rprimd(3,3)=dimensional primitive translations for real space (bohr)
3731 : : !! toldist= Tolerance on the distance between two R points.
3732 : : !!
3733 : : !! OUTPUT
3734 : : !! wghatm(natom,natom,nrpt)= Weight associated to the couple of atoms and the R vector
3735 : : !! The vector r(atom2)-r(atom1)+rpt should be inside the moving box
3736 : : !! r_inscribed_sphere= The radius of the sphere inscribed inside the big box.
3737 : : !! ngqpt(6)= can be modified
3738 : : !!
3739 : : !! SOURCE
3740 : :
3741 : 0 : subroutine wght9(brav,gprim,natom,ngqpt,nqpt,nqshft,nrpt,qshft,rcan,rpt,rprimd,toldist,r_inscribed_sphere,wghatm,ierr)
3742 : :
3743 : : !Arguments -------------------------------
3744 : : !scalars
3745 : : integer,intent(in) :: brav,natom,nqpt,nqshft,nrpt
3746 : : integer,intent(out) :: ierr
3747 : : real(dp),intent(out) :: r_inscribed_sphere
3748 : : real(dp),intent(in) :: toldist
3749 : : !arrays
3750 : : integer,intent(inout) :: ngqpt(9)
3751 : : real(dp),intent(in) :: gprim(3,3),qshft(3,4),rcan(3,natom),rpt(3,nrpt),rprimd(3,3)
3752 : : real(dp),intent(out) :: wghatm(natom,natom,nrpt)
3753 : :
3754 : : !Local variables -------------------------
3755 : : !scalars
3756 : : integer :: ia,ib,ii,jj,kk,iqshft,irpt,jqshft,nbordh,tok,nptws,nreq,idir
3757 : : real(dp) :: factor,sumwght,normsq,proj
3758 : : character(len=500) :: msg
3759 : : !arrays
3760 : : integer :: nbord(9)
3761 : : real(dp) :: rdiff(9),red(3,3),ptws(4, 729),pp(3),rdiff_tmp(3)
3762 : : ! *********************************************************************
3763 : :
3764 : 0 : ierr = 0
3765 : :
3766 : : ! First analyze the vectors qshft
3767 [ # # ]: 0 : if (nqshft /= 1) then
3768 : :
3769 [ # # ]: 0 : if (brav == 4) then
3770 : : write(msg,'(3a,i0,3a)' )&
3771 : 0 : 'For the time being, only nqshft=1',ch10,&
3772 : 0 : 'is allowed with brav=4, while it is nqshft=',nqshft,'.',ch10,&
3773 : 0 : 'Action: in the input file, correct either brav or nqshft.'
3774 : 0 : ABI_ERROR(msg)
3775 : : end if
3776 : :
3777 [ # # ]: 0 : if (nqshft == 2) then
3778 : : ! Make sure that the q vectors form a BCC lattice
3779 [ # # ]: 0 : do ii=1,3
3780 [ # # ]: 0 : if(abs(abs(qshft(ii,1)-qshft(ii,2))-.5_dp)>1.d-10)then
3781 : : write(msg, '(a,a,a,a,a,a,a)' )&
3782 : 0 : 'The test of the q1shft vectors shows that they',ch10,&
3783 : 0 : 'do not generate a body-centered lattice, which',ch10,&
3784 : 0 : 'is mandatory for nqshft=2.',ch10,&
3785 : 0 : 'Action: change the q1shft vectors in your input file.'
3786 : 0 : ABI_ERROR(msg)
3787 : : end if
3788 : : end do
3789 [ # # ]: 0 : else if (nqshft == 4) then
3790 : : ! Make sure that the q vectors form a FCC lattice
3791 [ # # ]: 0 : do iqshft=1,3
3792 [ # # ]: 0 : do jqshft=iqshft+1,4
3793 : : tok=0
3794 [ # # ]: 0 : do ii=1,3
3795 : : ! Test on the presence of a +-0.5 difference
3796 [ # # ]: 0 : if(abs(abs(qshft(ii,iqshft)-qshft(ii,jqshft))-.5_dp) <1.d-10) tok=tok+1
3797 : : ! Test on the presence of a 0 or +-1.0 difference
3798 [ # # ]: 0 : if(abs(abs(qshft(ii,iqshft)-qshft(ii,jqshft))-1._dp) <1.d-10 .or.&
3799 [ # # ]: 0 : abs(qshft(ii,iqshft)-qshft(ii,jqshft)) < 1.d-10) tok=tok+4
3800 : : end do
3801 : : ! Test 1 should be satisfied twice, and test 2 once
3802 [ # # ]: 0 : if(tok/=6)then
3803 : : write(msg, '(7a)' )&
3804 : 0 : 'The test of the q1shft vectors shows that they',ch10,&
3805 : 0 : 'do not generate a face-centered lattice, which',ch10,&
3806 : 0 : 'is mandatory for nqshft=4.',ch10,&
3807 : 0 : 'Action: change the q1shft vectors in your input file.'
3808 : 0 : ABI_ERROR(msg)
3809 : : end if
3810 : : end do
3811 : : end do
3812 : : else
3813 : : write(msg, '(a,i4,3a)' )&
3814 : 0 : 'nqshft must be 1, 2 or 4. It is nqshft=',nqshft,'.',ch10,&
3815 : 0 : 'Action: change nqshft in your input file.'
3816 : 0 : ABI_ERROR(msg)
3817 : : end if
3818 : : end if
3819 : :
3820 : 0 : factor=0.5_dp
3821 [ # # ]: 0 : if(brav==2 .or. brav==3) factor=0.25_dp
3822 [ # # ]: 0 : if(nqshft/=1)factor=factor*2
3823 : :
3824 [ # # ]: 0 : if (brav==1) then
3825 : : ! Does not support multiple shifts
3826 [ # # ]: 0 : if (nqshft/=1) then
3827 : 0 : ABI_ERROR('This version of the weights does not support nqshft/=1.')
3828 : : end if
3829 : :
3830 : : ! Find the points of the lattice given by ngqpt*acell. These are used to define
3831 : : ! a Wigner-Seitz cell around the origin. The origin is excluded from the list.
3832 : : ! TODO : in principle this should be only -1 to +1 for ii jj kk!
3833 : : nptws=0
3834 [ # # ]: 0 : do ii=-2,2
3835 [ # # ]: 0 : do jj=-2,2
3836 [ # # ]: 0 : do kk=-2,2
3837 [ # # ]: 0 : do idir=1,3
3838 : 0 : pp(idir)=ii*ngqpt(1)*rprimd(idir,1)+ jj*ngqpt(2)*rprimd(idir,2)+ kk*ngqpt(3)*rprimd(idir,3)
3839 : : end do
3840 : 0 : normsq = pp(1)*pp(1)+pp(2)*pp(2)+pp(3)*pp(3)
3841 [ # # ]: 0 : if (normsq > tol6) then
3842 : 0 : nptws = nptws + 1
3843 [ # # ]: 0 : ptws(:3,nptws) = pp(:)
3844 : 0 : ptws(4,nptws) = half*normsq
3845 : : end if
3846 : : end do
3847 : : end do
3848 : : end do
3849 : : end if ! end new_wght
3850 : : !write(std_out,*)'factor,ngqpt',factor,ngqpt(1:3)
3851 : :
3852 [ # # # # : 0 : r_inscribed_sphere = sum((matmul(rprimd(:,:),ngqpt(1:3)))**2)
# # # # ]
3853 [ # # ]: 0 : do ii=-1,1
3854 [ # # ]: 0 : do jj=-1,1
3855 [ # # ]: 0 : do kk=-1,1
3856 [ # # ]: 0 : if (ii==0 .and. jj==0 .and. kk==0) cycle
3857 [ # # ]: 0 : do idir=1,3
3858 : 0 : pp(idir)=ii*ngqpt(1)*rprimd(idir,1)+ jj*ngqpt(2)*rprimd(idir,2)+ kk*ngqpt(3)*rprimd(idir,3)
3859 : : end do
3860 : 0 : normsq = pp(1)*pp(1)+pp(2)*pp(2)+pp(3)*pp(3)
3861 : 0 : r_inscribed_sphere = min(r_inscribed_sphere, normsq)
3862 : : end do
3863 : : end do
3864 : : end do
3865 : 0 : r_inscribed_sphere = sqrt(r_inscribed_sphere)
3866 : :
3867 : :
3868 : : !Begin the big loop on ia and ib
3869 [ # # ]: 0 : do ia=1,natom
3870 [ # # ]: 0 : do ib=1,natom
3871 : :
3872 : : ! Simple Lattice
3873 [ # # ]: 0 : if (abs(brav)==1) then
3874 : : ! In this case, it is better to work in reduced coordinates
3875 : : ! As rcan is in canonical coordinates, => multiplication by gprim
3876 [ # # ]: 0 : do ii=1,3
3877 : 0 : red(1,ii)= rcan(1,ia)*gprim(1,ii) +rcan(2,ia)*gprim(2,ii) +rcan(3,ia)*gprim(3,ii)
3878 : 0 : red(2,ii)= rcan(1,ib)*gprim(1,ii) +rcan(2,ib)*gprim(2,ii) +rcan(3,ib)*gprim(3,ii)
3879 : : end do
3880 : : end if
3881 : :
3882 [ # # ]: 0 : do irpt=1,nrpt
3883 : :
3884 : : ! Initialization of the weights to 1.0
3885 : 0 : wghatm(ia,ib,irpt)=1.0_dp
3886 : :
3887 : : ! Compute the difference vector
3888 : :
3889 : : ! Simple Cubic Lattice
3890 [ # # ]: 0 : if (abs(brav)==1) then
3891 : : ! Change of rpt to reduced coordinates
3892 [ # # ]: 0 : do ii=1,3
3893 : 0 : red(3,ii)= rpt(1,irpt)*gprim(1,ii) +rpt(2,irpt)*gprim(2,ii) +rpt(3,irpt)*gprim(3,ii)
3894 : 0 : rdiff(ii)=red(2,ii)-red(1,ii)+red(3,ii)
3895 : : end do
3896 [ # # ]: 0 : if (brav==1) then
3897 : : ! rdiff in cartesian coordinates
3898 [ # # ]: 0 : do ii=1,3
3899 : 0 : rdiff_tmp(ii)=rdiff(1)*rprimd(ii,1)+rdiff(2)*rprimd(ii,2)+rdiff(3)*rprimd(ii,3)
3900 : : end do
3901 [ # # ]: 0 : rdiff(1:3)=rdiff_tmp(1:3)
3902 : : end if
3903 : :
3904 : : else
3905 : : ! Other lattices
3906 [ # # ]: 0 : do ii=1,3
3907 : 0 : rdiff(ii)=rcan(ii,ib)-rcan(ii,ia)+rpt(ii,irpt)
3908 : : end do
3909 : : end if
3910 : :
3911 : : ! Assignement of weights
3912 : :
3913 [ # # # # ]: 0 : if(nqshft==1 .and. brav/=4)then
3914 : :
3915 [ # # ]: 0 : if (brav/=1) then
3916 [ # # ]: 0 : do ii=1,3
3917 : : ! If the rpt vector is greater than the allowed space => weight = 0.0
3918 [ # # ]: 0 : if (abs(rdiff(ii))-tol10>factor*ngqpt(ii)) then
3919 : 0 : wghatm(ia,ib,irpt)=zero
3920 [ # # ]: 0 : else if (abs(abs(rdiff(ii))-factor*ngqpt(ii)) <=1.0d-10) then
3921 : : ! If the point is in a boundary position => weight/2
3922 : 0 : wghatm(ia,ib,irpt)=wghatm(ia,ib,irpt)/2
3923 : : end if
3924 : : end do
3925 : : else
3926 : : ! new weights
3927 : 0 : wghatm(ia,ib,irpt)=zero
3928 : 0 : nreq = 1
3929 [ # # ]: 0 : do ii=1,nptws
3930 : 0 : proj = rdiff(1)*ptws(1,ii)+rdiff(2)*ptws(2,ii)+rdiff(3)*ptws(3,ii)
3931 : : ! if rdiff closer to ptws than the origin the weight is zero
3932 : : ! if rdiff close to the origin with respect to all the other ptws the weight is 1
3933 : : ! if rdiff is equidistant from the origin and N other ptws the weight is 1/(N+1)
3934 [ # # ]: 0 : if (proj - ptws(4,ii) > toldist) then
3935 : : nreq = 0
3936 : : EXIT
3937 [ # # ]: 0 : else if(abs(proj-ptws(4,ii)) <= toldist) then
3938 : 0 : nreq=nreq+1
3939 : : end if
3940 : : end do
3941 [ # # ]: 0 : if (nreq>0) then
3942 : 0 : wghatm(ia,ib,irpt)=one/DBLE(nreq)
3943 : : end if
3944 : : end if
3945 : :
3946 [ # # ]: 0 : else if(brav==4)then
3947 : : ! Hexagonal
3948 : : ! Examination of the X and Y boundaries in order to form an hexagon
3949 : : ! First generate the relevant boundaries
3950 : 0 : rdiff(4)=0.5_dp*( rdiff(1)+sqrt(3.0_dp)*rdiff(2) )
3951 : 0 : ngqpt(4)=ngqpt(1)
3952 : 0 : rdiff(5)=0.5_dp*( rdiff(1)-sqrt(3.0_dp)*rdiff(2) )
3953 : 0 : ngqpt(5)=ngqpt(1)
3954 : :
3955 : : ! Test the four inequalities
3956 [ # # ]: 0 : do ii=1,5
3957 [ # # ]: 0 : if(ii/=2)then
3958 : :
3959 : 0 : nbord(ii)=0
3960 : : ! If the rpt vector is greater than the allowed space => weight = 0.0
3961 [ # # ]: 0 : if (abs(rdiff(ii))-1.0d-10>factor*ngqpt(ii)) then
3962 : 0 : wghatm(ia,ib,irpt)=zero
3963 [ # # ]: 0 : else if (abs(abs(rdiff(ii))-factor*ngqpt(ii)) <=1.0d-10) then
3964 : : ! If the point is in a boundary position increment nbord(ii)
3965 : 0 : nbord(ii)=1
3966 : : end if
3967 : :
3968 : : end if
3969 : : end do
3970 : :
3971 : : ! Computation of weights
3972 : 0 : nbordh=nbord(1)+nbord(4)+nbord(5)
3973 [ # # ]: 0 : if (nbordh==1) then
3974 : 0 : wghatm(ia,ib,irpt)=wghatm(ia,ib,irpt)/2
3975 [ # # ]: 0 : else if (nbordh==2) then
3976 : 0 : wghatm(ia,ib,irpt)=wghatm(ia,ib,irpt)/3
3977 [ # # ]: 0 : else if (nbordh/=0) then
3978 : 0 : ABI_BUG('There is a problem of borders and weights (hex).')
3979 : : end if
3980 [ # # ]: 0 : if (nbord(3)==1)then
3981 : 0 : wghatm(ia,ib,irpt)=wghatm(ia,ib,irpt)/2
3982 : : end if
3983 : :
3984 [ # # ]: 0 : else if(nqshft==2 .and. brav/=4)then
3985 : :
3986 : : ! BCC packing of k-points
3987 : : ! First, generate the relevant boundaries
3988 : 0 : rdiff(4)= rdiff(1)+rdiff(2)
3989 : 0 : rdiff(5)= rdiff(1)-rdiff(2)
3990 : 0 : rdiff(6)= rdiff(1)+rdiff(3)
3991 : 0 : rdiff(7)= rdiff(1)-rdiff(3)
3992 : 0 : rdiff(8)= rdiff(3)+rdiff(2)
3993 : 0 : rdiff(9)= rdiff(3)-rdiff(2)
3994 [ # # # # ]: 0 : if(ngqpt(2)/=ngqpt(1) .or. ngqpt(3)/=ngqpt(1))then
3995 : : write(msg, '(a,a,a,3i6,a,a,a,a)' )&
3996 : 0 : 'In the BCC case, the three ngqpt numbers ',ch10,&
3997 : 0 : ' ',ngqpt(1),ngqpt(2),ngqpt(3),ch10,&
3998 : 0 : 'should be equal.',ch10,&
3999 : 0 : 'Action: use identical ngqpt(1:3) in your input file.'
4000 : 0 : ABI_ERROR(msg)
4001 : : end if
4002 [ # # ]: 0 : do ii=4,9
4003 : 0 : ngqpt(ii)=ngqpt(1)
4004 : : end do
4005 : :
4006 : : ! Test the relevant inequalities
4007 : 0 : nbord(1)=0
4008 [ # # ]: 0 : do ii=4,9
4009 : : ! If the rpt vector is greater than the allowed space => weight = 0.0
4010 [ # # ]: 0 : if (abs(rdiff(ii))-1.0d-10>factor*ngqpt(ii)) then
4011 : 0 : wghatm(ia,ib,irpt)=zero
4012 [ # # ]: 0 : else if (abs(abs(rdiff(ii))-factor*ngqpt(ii)) <=1.0d-10) then
4013 : : ! If the point is in a boundary position increment nbord(1)
4014 : 0 : nbord(1)=nbord(1)+1
4015 : : end if
4016 : : end do
4017 : :
4018 : : ! Computation of weights
4019 [ # # ]: 0 : if (nbord(1)==1) then
4020 : 0 : wghatm(ia,ib,irpt)=wghatm(ia,ib,irpt)/2
4021 [ # # ]: 0 : else if (nbord(1)==2) then
4022 : 0 : wghatm(ia,ib,irpt)=wghatm(ia,ib,irpt)/3
4023 [ # # ]: 0 : else if (nbord(1)==3) then
4024 : 0 : wghatm(ia,ib,irpt)=wghatm(ia,ib,irpt)/4
4025 [ # # ]: 0 : else if (nbord(1)==4) then
4026 : 0 : wghatm(ia,ib,irpt)=wghatm(ia,ib,irpt)/6
4027 [ # # ]: 0 : else if (nbord(1)/=0) then
4028 : 0 : ABI_ERROR(' There is a problem of borders and weights (BCC).')
4029 : : end if
4030 : :
4031 [ # # ]: 0 : else if(nqshft==4 .and. brav/=4)then
4032 : :
4033 : : ! FCC packing of k-points
4034 : : ! First, generate the relevant boundaries
4035 : 0 : rdiff(4)= (rdiff(1)+rdiff(2)+rdiff(3))*2._dp/3._dp
4036 : 0 : rdiff(5)= (rdiff(1)-rdiff(2)+rdiff(3))*2._dp/3._dp
4037 : 0 : rdiff(6)= (rdiff(1)+rdiff(2)-rdiff(3))*2._dp/3._dp
4038 : 0 : rdiff(7)= (rdiff(1)-rdiff(2)-rdiff(3))*2._dp/3._dp
4039 [ # # # # ]: 0 : if(ngqpt(2)/=ngqpt(1) .or. ngqpt(3)/=ngqpt(1))then
4040 : : write(msg, '(a,a,a,3i6,a,a,a,a)' )&
4041 : 0 : 'In the FCC case, the three ngqpt numbers ',ch10,&
4042 : 0 : ' ',ngqpt(1),ngqpt(2),ngqpt(3),ch10,&
4043 : 0 : 'should be equal.',ch10,&
4044 : 0 : 'Action: use identical ngqpt(1:3) in your input file.'
4045 : 0 : ABI_ERROR(msg)
4046 : : end if
4047 [ # # ]: 0 : do ii=4,7
4048 : 0 : ngqpt(ii)=ngqpt(1)
4049 : : end do
4050 : :
4051 : : ! Test the relevant inequalities
4052 : 0 : nbord(1)=0
4053 [ # # ]: 0 : do ii=1,7
4054 : : ! If the rpt vector is greater than the allowed space => weight = 0.0
4055 [ # # ]: 0 : if (abs(rdiff(ii))-1.0d-10>factor*ngqpt(ii)) then
4056 : 0 : wghatm(ia,ib,irpt)=zero
4057 : : ! If the point is in a boundary position increment nbord(1)
4058 [ # # ]: 0 : else if (abs(abs(rdiff(ii))-factor*ngqpt(ii)) <=1.0d-10) then
4059 : 0 : nbord(1)=nbord(1)+1
4060 : : end if
4061 : : end do
4062 : :
4063 : : ! Computation of weights
4064 [ # # ]: 0 : if (nbord(1)==1) then
4065 : 0 : wghatm(ia,ib,irpt)=wghatm(ia,ib,irpt)/2
4066 [ # # ]: 0 : else if (nbord(1)==2) then
4067 : 0 : wghatm(ia,ib,irpt)=wghatm(ia,ib,irpt)/3
4068 [ # # ]: 0 : else if (nbord(1)==3) then
4069 : 0 : wghatm(ia,ib,irpt)=wghatm(ia,ib,irpt)/4
4070 [ # # # # ]: 0 : else if (nbord(1)/=0 .and. wghatm(ia,ib,irpt)>1.d-10) then
4071 : : ! Interestingly nbord(1)==4 happens for some points outside of the volume
4072 : 0 : ABI_BUG(' There is a problem of borders and weights (FCC).')
4073 : : end if
4074 : :
4075 : : else
4076 : : write(msg, '(3a,i0,a)' )&
4077 : 0 : 'One should not arrive here ... ',ch10,&
4078 : 0 : 'The value nqshft ',nqshft,' is not available'
4079 : 0 : ABI_BUG(msg)
4080 : : end if
4081 : : end do ! Assignement of weights is done
4082 : : end do ! End of the double loop on ia and ib
4083 : : end do
4084 : :
4085 : : ! Check the results
4086 [ # # ]: 0 : do ia=1,natom
4087 [ # # ]: 0 : do ib=1,natom
4088 : : sumwght=zero
4089 [ # # ]: 0 : do irpt=1,nrpt
4090 : : ! Check if the sum of the weights is equal to the number of q points
4091 : 0 : sumwght=sumwght+wghatm(ia,ib,irpt)
4092 : : !write(std_out,'(a,3(i0,1x))' )' atom1, atom2, irpt ; rpt ; wghatm ',ia,ib,irpt
4093 : : !write(std_out,'(3es16.6,es18.6)' )rpt(1,irpt),rpt(2,irpt),rpt(3,irpt),wghatm(ia,ib,irpt)
4094 : : end do
4095 [ # # ]: 0 : if (abs(sumwght-nqpt)>tol10) ierr = 1
4096 : : end do
4097 : : end do
4098 : :
4099 : 0 : end subroutine wght9
4100 : : !!***
4101 : :
4102 : : !----------------------------------------------------------------------
4103 : :
4104 : : !!****f* m_dynmat/d3sym
4105 : : !! NAME
4106 : : !! d3sym
4107 : : !!
4108 : : !! FUNCTION
4109 : : !! Given a set of calculated elements of the 3DTE matrix,
4110 : : !! build (nearly) all the other matrix elements that can be build using symmetries.
4111 : : !!
4112 : : !! INPUTS
4113 : : !! indsym(4,nsym,natom)=indirect indexing array : for each
4114 : : !! isym,iatom, fourth element is label of atom into which iatom is sent by
4115 : : !! INVERSE of symmetry operation isym; first three elements are the primitive
4116 : : !! translations which must be subtracted after the transformation to get back
4117 : : !! to the original unit cell.
4118 : : !! mpert =maximum number of ipert
4119 : : !! natom= number of atoms
4120 : : !! nsym=number of space group symmetries
4121 : : !! symrec(3,3,nsym)=3x3 matrices of the group symmetries (reciprocal space)
4122 : : !! symrel(3,3,nsym)=3x3 matrices of the group symmetries (real space)
4123 : : !!
4124 : : !! SIDE EFFECTS
4125 : : !! Input/Output
4126 : : !! blkflg(3,mpert,3,mpert,3,mpert)= matrix that indicates if an
4127 : : !! element of d3 is available (1 if available, 0 otherwise)
4128 : : !! d3(2,3,mpert,3,mpert,3,mpert)= matrix of the 3DTE
4129 : : !!
4130 : : !! SOURCE
4131 : :
4132 : 41 : subroutine d3sym(blkflg,d3,indsym,mpert,natom,nsym,symrec,symrel)
4133 : :
4134 : : !Arguments -------------------------------
4135 : : !scalars
4136 : : integer,intent(in) :: mpert,natom,nsym
4137 : : !arrays
4138 : : integer,intent(in) :: indsym(4,nsym,natom),symrec(3,3,nsym),symrel(3,3,nsym)
4139 : : integer,intent(inout) :: blkflg(3,mpert,3,mpert,3,mpert)
4140 : : real(dp),intent(inout) :: d3(2,3,mpert,3,mpert,3,mpert)
4141 : :
4142 : : !Local variables -------------------------
4143 : : !scalars
4144 : : integer :: found,i1dir,i1pert,i2dir,i2pert,i3dir,i3pert,idisy1,idisy2,idisy3
4145 : : integer :: ipesy1,ipesy2,ipesy3,isym,ithree
4146 : : real(dp) :: sumi,sumr
4147 : : !arrays
4148 : : integer :: sym1(3,3),sym2(3,3),sym3(3,3)
4149 : : ! *********************************************************************
4150 : :
4151 : : !DEBUG
4152 : : !write(std_out,*)'d3sym : enter'
4153 : : !do i1dir = 1, 3
4154 : : !do i2dir = 1, 3
4155 : : !do i3dir = 1, 3
4156 : : !write(std_out,*)i1dir,i2dir,i3dir,blkflg(i1dir,natom+2,i2dir,natom+2,i3dir,natom+2)
4157 : : !end do
4158 : : !end do
4159 : : !end do
4160 : : !stop
4161 : : !ENDDEBUG
4162 : :
4163 : : !First, take into account the permutations symmetry of
4164 : : !(i1pert,i1dir) and (i3pert,i3dir)
4165 [ + + ]: 397 : do i1pert = 1, mpert
4166 [ + + ]: 3665 : do i2pert = 1, mpert
4167 [ + + ]: 36068 : do i3pert = 1, mpert
4168 : :
4169 [ + + ]: 133044 : do i1dir = 1, 3
4170 [ + + ]: 421772 : do i2dir = 1, 3
4171 [ + + ]: 1265316 : do i3dir = 1, 3
4172 : :
4173 [ + + + + ]: 875988 : if ((blkflg(i1dir,i1pert,i2dir,i2pert,i3dir,i3pert)==1).and. &
4174 : 291996 : & (blkflg(i3dir,i3pert,i2dir,i2pert,i1dir,i1pert)/=1)) then
4175 : :
4176 : : d3(:,i3dir,i3pert,i2dir,i2pert,i1dir,i1pert) = &
4177 [ + + ]: 3711 : & d3(:,i1dir,i1pert,i2dir,i2pert,i3dir,i3pert)
4178 : :
4179 : 1237 : blkflg(i3dir,i3pert,i2dir,i2pert,i1dir,i1pert) = 1
4180 : :
4181 : : end if
4182 : :
4183 : : end do
4184 : : end do
4185 : : end do
4186 : :
4187 : : end do
4188 : : end do
4189 : : end do
4190 : :
4191 : : !Big Big Loop : symmetrize three times, because
4192 : : !of some cases in which one element is not yet available
4193 : : !at the first pass, and even at the second one !
4194 : :
4195 [ + + ]: 164 : do ithree=1,3
4196 : :
4197 : : ! Loop over perturbations
4198 [ + + ]: 1232 : do i1pert = 1, mpert
4199 [ + + ]: 10995 : do i2pert = 1, mpert
4200 [ + + ]: 108204 : do i3pert = 1, mpert
4201 : :
4202 [ + + ]: 399132 : do i1dir = 1, 3
4203 [ + + ]: 1265316 : do i2dir = 1, 3
4204 [ + + ]: 3795948 : do i3dir = 1, 3
4205 : :
4206 : : ! Will get element (idir1,ipert1,idir2,ipert2)
4207 : : ! so this element should not yet be present ...
4208 [ + + ]: 3503952 : if(blkflg(i1dir,i1pert,i2dir,i2pert,i3dir,i3pert)/=1)then
4209 : :
4210 [ + + ]: 7831485 : d3(:,i1dir,i1pert,i2dir,i2pert,i3dir,i3pert) = 0_dp
4211 : :
4212 [ + + ]: 47609064 : do isym = 1, nsym
4213 : :
4214 : 44998569 : found = 1
4215 : :
4216 [ + + ]: 44998569 : if (i1pert <= natom) then
4217 : 8178639 : ipesy1 = indsym(4,isym,i1pert)
4218 [ + + + + ]: 106322307 : sym1(:,:) = symrec(:,:,isym)
4219 [ + + ]: 36819930 : else if (i1pert == natom + 2) then
4220 : 3953370 : ipesy1 = i1pert
4221 [ + + + + ]: 51393810 : sym1(:,:) = symrel(:,:,isym)
4222 : : else
4223 : : found = 0
4224 : : end if
4225 : :
4226 [ + + ]: 44998569 : if (i2pert <= natom) then
4227 : 8178639 : ipesy2 = indsym(4,isym,i2pert)
4228 [ + + + + ]: 106322307 : sym2(:,:) = symrec(:,:,isym)
4229 [ + + ]: 36819930 : else if (i2pert == natom + 2) then
4230 : 3953370 : ipesy2 = i2pert
4231 [ + + + + ]: 51393810 : sym2(:,:) = symrel(:,:,isym)
4232 : : else
4233 : : found = 0
4234 : : end if
4235 : :
4236 [ + + ]: 44998569 : if (i3pert <= natom) then
4237 : 8178639 : ipesy3 = indsym(4,isym,i3pert)
4238 [ + + + + ]: 106322307 : sym3(:,:) = symrec(:,:,isym)
4239 [ + + ]: 36819930 : else if (i3pert == natom + 2) then
4240 : 3953370 : ipesy3 = i3pert
4241 [ + + + + ]: 51393810 : sym3(:,:) = symrel(:,:,isym)
4242 : : else
4243 : : found = 0
4244 : : end if
4245 : :
4246 : 44998569 : sumr = 0_dp ; sumi = 0_dp;
4247 [ + + ]: 179994276 : do idisy1 = 1, 3
4248 [ + + ]: 584981397 : do idisy2 = 1, 3
4249 [ + + ]: 1754944191 : do idisy3 = 1, 3
4250 : :
4251 : : if ((sym1(i1dir,idisy1) /=0).and.(sym2(i2dir,idisy2) /=0) &
4252 [ + + + + : 1619948484 : & .and.(sym3(i3dir,idisy3) /=0)) then
+ + ]
4253 : :
4254 [ + + ]: 189920457 : if (blkflg(idisy1,ipesy1,idisy2,ipesy2,idisy3,ipesy3) == 1) then
4255 : :
4256 : : sumr = sumr + sym1(i1dir,idisy1)*sym2(i2dir,idisy2)*&
4257 : 144869984 : & sym3(i3dir,idisy3)*d3(1,idisy1,ipesy1,idisy2,ipesy2,idisy3,ipesy3)
4258 : : sumi = sumi + sym1(i1dir,idisy1)*sym2(i2dir,idisy2)*&
4259 : 144869984 : & sym3(i3dir,idisy3)*d3(2,idisy1,ipesy1,idisy2,ipesy2,idisy3,ipesy3)
4260 : :
4261 : : else
4262 : :
4263 : : found = 0
4264 : :
4265 : : end if
4266 : :
4267 : : end if
4268 : :
4269 : : end do
4270 : : end do
4271 : : end do
4272 : :
4273 [ + + ]: 47609064 : if (found == 1) then
4274 : 18245 : d3(1,i1dir,i1pert,i2dir,i2pert,i3dir,i3pert) = sumr
4275 : 18245 : d3(2,i1dir,i1pert,i2dir,i2pert,i3dir,i3pert) = sumi
4276 : 18245 : blkflg(i1dir,i1pert,i2dir,i2pert,i3dir,i3pert) = 1
4277 : : end if
4278 : :
4279 : : end do ! isym
4280 : :
4281 : : end if ! blkflg
4282 : :
4283 : : ! Close loop over perturbations
4284 : : end do
4285 : : end do
4286 : : end do
4287 : : end do
4288 : : end do
4289 : : end do
4290 : :
4291 : : end do ! close loop over ithree
4292 : :
4293 : 41 : end subroutine d3sym
4294 : : !!***
4295 : :
4296 : : !----------------------------------------------------------------------
4297 : :
4298 : : !!****f* m_dynmat/sytens
4299 : : !!
4300 : : !! NAME
4301 : : !! sytens
4302 : : !!
4303 : : !! FUNCTION
4304 : : !! Determines the set of irreductible elements of the non-linear
4305 : : !! optical susceptibility and Raman tensors
4306 : : !!
4307 : : !! INPUTS
4308 : : !! indsym(4,nsym,natom)=indirect indexing array described above: for each
4309 : : !! isym,iatom, fourth element is label of atom into which iatom is sent by
4310 : : !! INVERSE of symmetry operation isym; first three elements are the primitive
4311 : : !! translations which must be subtracted after the transformation to get back
4312 : : !! to the original unit cell.
4313 : : !! mpert =maximum number of ipert
4314 : : !! natom= number of atoms
4315 : : !! nsym=number of space group symmetries
4316 : : !! symrec(3,3,nsym)=3x3 matrices of the group symmetries (reciprocal space)
4317 : : !! symrel(3,3,nsym)=3x3 matrices of the group symmetries (real space)
4318 : : !!
4319 : : !! OUTPUT
4320 : : !! (see side effects)
4321 : : !!
4322 : : !! SIDE EFFECTS
4323 : : !! rfpert(3,mpert,3,mpert,3,mpert) = array defining the type of perturbations
4324 : : !! that have to be computed
4325 : : !! At the input :
4326 : : !! 1 -> element has to be computed explicitely
4327 : : !! At the output :
4328 : : !! 1 -> element has to be computed explicitely
4329 : : !! -1 -> use symmetry operations to obtain the corresponding element
4330 : : !! -2 -> element is zero by symmetry
4331 : : !!
4332 : : !! SOURCE
4333 : :
4334 : 46 : subroutine sytens(indsym,mpert,natom,nsym,rfpert,symrec,symrel)
4335 : :
4336 : : !Arguments -------------------------------
4337 : : !scalars
4338 : : integer,intent(in) :: mpert,natom,nsym
4339 : : !arrays
4340 : : integer,intent(in) :: indsym(4,nsym,natom),symrec(3,3,nsym),symrel(3,3,nsym)
4341 : : integer,intent(inout) :: rfpert(3,mpert,3,mpert,3,mpert)
4342 : :
4343 : : !Local variables -------------------------
4344 : : !scalars
4345 : : integer :: flag,found,i1dir,i1dir_,i1pert,i1pert_,i2dir,i2dir_,i2pert,i2pert_
4346 : : integer :: i3dir,i3dir_,i3pert,i3pert_,idisy1,idisy2,idisy3,ipesy1,ipesy2
4347 : : integer :: ipesy3,isym
4348 : : !arrays
4349 : : integer :: sym1(3,3),sym2(3,3),sym3(3,3)
4350 : 46 : integer,allocatable :: pertsy(:,:,:,:,:,:)
4351 : : !***********************************************************************
4352 : :
4353 [ - + + - : 322 : ABI_MALLOC(pertsy,(3,mpert,3,mpert,3,mpert))
+ - - + +
- + - - +
+ - + - +
- - + +
- ]
4354 [ + + + + : 1070750 : pertsy(:,:,:,:,:,:) = 0
+ + + + +
+ + + ]
4355 : :
4356 : : !Loop over perturbations
4357 : :
4358 [ + + ]: 386 : do i1pert_ = 1, mpert
4359 [ + + ]: 3302 : do i2pert_ = 1, mpert
4360 [ + + ]: 31988 : do i3pert_ = 1, mpert
4361 : :
4362 [ + + ]: 117844 : do i1dir_ = 1, 3
4363 [ + + ]: 373516 : do i2dir_ = 1, 3
4364 [ + + ]: 1120548 : do i3dir_ = 1, 3
4365 : :
4366 : 775764 : i1pert = (mpert - i1pert_ + 1)
4367 [ + + ]: 775764 : if (i1pert <= natom) i1pert = natom + 1 - i1pert
4368 : 775764 : i2pert = (mpert - i2pert_ + 1)
4369 [ + + ]: 775764 : if (i2pert <= natom) i2pert = natom + 1 - i2pert
4370 : 775764 : i3pert = (mpert - i3pert_ + 1)
4371 [ + + ]: 775764 : if (i3pert <= natom) i3pert = natom + 1 - i3pert
4372 : :
4373 [ + + ]: 775764 : if (i1pert <= natom) then
4374 : : i1dir = i1dir_ ; i2dir = i2dir_ ; i3dir = i3dir_
4375 [ + + ]: 618300 : else if (i2pert <= natom) then
4376 : : i1dir = i2dir_ ; i2dir = i1dir_ ; i3dir = i3dir_
4377 [ + + ]: 497556 : else if (i3pert <= natom) then
4378 : : i1dir = i3dir_ ; i2dir = i2dir_ ; i3dir = i1dir_
4379 : : else
4380 : 561060 : i1dir = i1dir_ ; i2dir = i2dir_ ; i3dir = i3dir_
4381 : : end if
4382 : :
4383 [ + + ]: 1034352 : if (rfpert(i1dir,i1pert,i2dir,i2pert,i3dir,i3pert) /= 0) then
4384 : :
4385 : : ! Loop over all symmetries
4386 : :
4387 : : flag = 0
4388 [ + + ]: 118983 : do isym = 1, nsym
4389 : :
4390 : 113997 : found = 1
4391 : :
4392 : : ! Select the symmetric element of i1pert,i2pert,i3pert
4393 : :
4394 [ + + ]: 113997 : if (i1pert <= natom) then
4395 : 31603 : ipesy1 = indsym(4,isym,i1pert)
4396 [ + + + + ]: 410839 : sym1(:,:) = symrec(:,:,isym)
4397 [ + - ]: 82394 : else if (i1pert == natom + 2) then
4398 : 82394 : ipesy1 = i1pert
4399 [ + + + + ]: 1071122 : sym1(:,:) = symrel(:,:,isym)
4400 : : else
4401 : : found = 0
4402 : : end if
4403 : :
4404 [ + + ]: 113997 : if (i2pert <= natom) then
4405 : 31603 : ipesy2 = indsym(4,isym,i2pert)
4406 [ + + + + ]: 410839 : sym2(:,:) = symrec(:,:,isym)
4407 [ + - ]: 82394 : else if (i2pert == natom + 2) then
4408 : 82394 : ipesy2 = i2pert
4409 [ + + + + ]: 1071122 : sym2(:,:) = symrel(:,:,isym)
4410 : : else
4411 : : found = 0
4412 : : end if
4413 : :
4414 [ + + ]: 113997 : if (i3pert <= natom) then
4415 : 31603 : ipesy3 = indsym(4,isym,i3pert)
4416 [ + + + + ]: 410839 : sym3(:,:) = symrec(:,:,isym)
4417 [ + - ]: 82394 : else if (i3pert == natom + 2) then
4418 : 82394 : ipesy3 = i3pert
4419 [ + + + + ]: 1071122 : sym3(:,:) = symrel(:,:,isym)
4420 : : else
4421 : : found = 0
4422 : : end if
4423 : :
4424 : : ! See if the symmetric element is available and check if some
4425 : : ! of the elements may be zeor. In the latter case, they do not need
4426 : : ! to be computed.
4427 : :
4428 : :
4429 : : if ((flag /= -1).and.&
4430 [ + - + - ]: 113997 : & (ipesy1==i1pert).and.(ipesy2==i2pert).and.(ipesy3==i3pert)) then
4431 : 113997 : flag = sym1(i1dir,i1dir)*sym2(i2dir,i2dir)*sym3(i3dir,i3dir)
4432 : : end if
4433 : :
4434 : :
4435 [ + + ]: 455988 : do idisy1 = 1, 3
4436 [ + + ]: 1481961 : do idisy2 = 1, 3
4437 [ + + ]: 4445883 : do idisy3 = 1, 3
4438 : :
4439 [ + + + + : 3077919 : if ((sym1(i1dir,idisy1) /= 0).and.(sym2(i2dir,idisy2) /= 0).and.&
+ + ]
4440 : : & (sym3(i3dir,idisy3) /= 0)) then
4441 [ + + ]: 394809 : if (pertsy(idisy1,ipesy1,idisy2,ipesy2,idisy3,ipesy3) == 0) then
4442 : 3077919 : found = 0
4443 : : ! exit ! exit loop over symmetries
4444 : : end if
4445 : : end if
4446 : :
4447 : :
4448 [ + + + + : 3077919 : if ((flag == -1).and.&
+ + ]
4449 : 1025973 : & ((idisy1/=i1dir).or.(idisy2/=i2dir).or.(idisy3/=i3dir))) then
4450 [ + + + + : 127890 : if ((sym1(i1dir,idisy1)/=0).and.(sym2(i2dir,idisy2)/=0).and.&
+ + ]
4451 : : & (sym3(i3dir,idisy3)/=0)) then
4452 : 3077919 : flag = 0
4453 : : end if
4454 : : end if
4455 : :
4456 : : end do
4457 : : end do
4458 : : end do
4459 : :
4460 [ + + ]: 113997 : if (found == 1) then
4461 : 42006 : pertsy(i1dir,i1pert,i2dir,i2pert,i3dir,i3pert) = -1
4462 : : end if
4463 : :
4464 : : ! In case a symmetry operation only changes the sign of an
4465 : : ! element, this element has to be equal to zero
4466 : :
4467 [ + + ]: 118983 : if (flag == -1) then
4468 : 2228 : pertsy(i1dir,i1pert,i2dir,i2pert,i3dir,i3pert) = -2
4469 : 2228 : exit
4470 : : end if
4471 : :
4472 : : end do ! close loop on symmetries
4473 : :
4474 : : ! If the elemetn i1pert,i2pert,i3pert is not symmetric
4475 : : ! to a basis element, it is a basis element
4476 : :
4477 [ + + ]: 7214 : if (pertsy(i1dir,i1pert,i2dir,i2pert,i3dir,i3pert) > -1) then
4478 : 2239 : pertsy(i1dir,i1pert,i2dir,i2pert,i3dir,i3pert) = 1
4479 : : end if
4480 : :
4481 : : end if ! rfpert /= 0
4482 : :
4483 : : end do ! close loop over perturbations
4484 : : end do
4485 : : end do
4486 : : end do
4487 : : end do
4488 : : end do
4489 : :
4490 : : !Now, take into account the permutation of (i1pert,i1dir)
4491 : : !and (i3pert,i3dir)
4492 : :
4493 [ + + ]: 386 : do i1pert = 1, mpert
4494 [ + + ]: 3302 : do i2pert = 1, mpert
4495 [ + + ]: 31988 : do i3pert = 1, mpert
4496 : :
4497 [ + + ]: 117844 : do i1dir = 1, 3
4498 [ + + ]: 373516 : do i2dir = 1, 3
4499 [ + + ]: 1120548 : do i3dir = 1, 3
4500 : :
4501 [ + + ]: 1034352 : if ((i1pert /= i3pert).or.(i1dir /= i3dir)) then
4502 : :
4503 [ + + + + ]: 749520 : if ((pertsy(i1dir,i1pert,i2dir,i2pert,i3dir,i3pert) == 1).and.&
4504 : : & (pertsy(i3dir,i3pert,i2dir,i2pert,i1dir,i1pert) == 1)) then
4505 : 899 : pertsy(i3dir,i3pert,i2dir,i2pert,i1dir,i1pert) = -1
4506 : : end if
4507 : :
4508 : : end if
4509 : :
4510 : : end do
4511 : : end do
4512 : : end do
4513 : :
4514 : : end do
4515 : : end do
4516 : : end do
4517 : :
4518 [ + + + + : 1070750 : rfpert(:,:,:,:,:,:) = pertsy(:,:,:,:,:,:)
+ + + + +
+ + + ]
4519 : :
4520 [ - + ]: 46 : ABI_FREE(pertsy)
4521 : :
4522 : 46 : end subroutine sytens
4523 : : !!***
4524 : :
4525 : :
4526 : : !----------------------------------------------------------------------
4527 : :
4528 : : !!****f* m_dynmat/axial9
4529 : : !!
4530 : : !! NAME
4531 : : !! axial9
4532 : : !!
4533 : : !! FUNCTION
4534 : : !! Generates the local coordinates system from the
4535 : : !! knowledge of the first vector (longitudinal) and
4536 : : !! the ifc matrix in cartesian coordinates
4537 : : !!
4538 : : !! INPUTS
4539 : : !! ifccar(3,3)= matrix of interatomic force constants in cartesian coordinates
4540 : : !! vect1(3)= cartesian coordinates of the first local vector
4541 : : !!
4542 : : !! OUTPUT
4543 : : !! vect2(3)= cartesian coordinates of the second local vector
4544 : : !! vect3(3)= cartesian coordinates of the third local vector
4545 : : !!
4546 : : !! SOURCE
4547 : :
4548 : 20196 : subroutine axial9(ifccar,vect1,vect2,vect3)
4549 : :
4550 : : !Arguments -------------------------------
4551 : : !arrays
4552 : : real(dp),intent(in) :: ifccar(3,3),vect1(3)
4553 : : real(dp),intent(out) :: vect2(3),vect3(3)
4554 : :
4555 : : !Local variables -------------------------
4556 : : !scalars
4557 : : integer :: flag,ii,itrial
4558 : : real(dp) :: innorm,scprod
4559 : : !arrays
4560 : : real(dp) :: work(3)
4561 : : ! *********************************************************************
4562 : :
4563 [ + + + + ]: 262548 : work (:) = matmul(ifccar,vect1)
4564 : :
4565 : : flag=0
4566 [ + - ]: 49015 : do itrial=1,4
4567 : : scprod=zero
4568 [ + + ]: 196060 : do ii=1,3
4569 : 196060 : scprod=scprod+work(ii)*vect1(ii)
4570 : : end do
4571 : :
4572 [ + + ]: 196060 : work(:)=work(:)-vect1(:)*scprod
4573 : :
4574 [ + + ]: 196060 : scprod=dot_product(work,work)
4575 : :
4576 [ + + ]: 49015 : if(scprod<1.0d-10)then
4577 : 28819 : work(1:3)=zero
4578 [ + + ]: 28819 : if(itrial>1)work(itrial-1)=1.0_dp
4579 : : else
4580 : : flag=1
4581 : : end if
4582 : :
4583 : 0 : if(flag==1)exit
4584 : : end do
4585 : :
4586 : 20196 : innorm=scprod**(-0.5_dp)
4587 [ + + ]: 80784 : vect2(:)=work(:)*innorm
4588 : :
4589 : 20196 : vect3(1)=vect1(2)*vect2(3)-vect1(3)*vect2(2)
4590 : 20196 : vect3(2)=vect1(3)*vect2(1)-vect1(1)*vect2(3)
4591 : 20196 : vect3(3)=vect1(1)*vect2(2)-vect1(2)*vect2(1)
4592 : :
4593 : 20196 : end subroutine axial9
4594 : : !!***
4595 : :
4596 : : !----------------------------------------------------------------------
4597 : :
4598 : : !!****f* m_dynmat/dymfz9
4599 : : !!
4600 : : !! NAME
4601 : : !! dymfz9
4602 : : !!
4603 : : !! FUNCTION
4604 : : !! As the subroutine canatm has transformed the coordinates of the
4605 : : !! atoms in normalized canonical coordinates, the corresponding
4606 : : !! dynamical matrix should be multiplied by a phase shift corresponding
4607 : : !! to the translation between New and Old coordinates of its two
4608 : : !! corresponding atoms.
4609 : : !!
4610 : : !! INPUTS
4611 : : !! dynmat = non-phase shifted dynamical matrices
4612 : : !! natom = number of atoms
4613 : : !! nqpt = number of qpoints
4614 : : !! gprim = reciprocal lattice vectors (cartesian but dimensionless)
4615 : : !! option=1 : the matrices are transformed from the old (tn)
4616 : : !! coordinate system to the new (normalized canonical)
4617 : : !! 2 : the matrices are restored from the normalized
4618 : : !! canonical coordinate system to the usual (tn) one...
4619 : : !! rcan = canonical coordinates of atoms
4620 : : !! spqpt = qpoint coordinates (reduced reciprocal)
4621 : : !! trans = Atomic translations : xred = rcan + trans
4622 : : !!
4623 : : !! OUTPUT
4624 : : !! dynmat = phase shifted dynamical matrices
4625 : : !!
4626 : : !! SOURCE
4627 : :
4628 : 586374 : subroutine dymfz9(dynmat,natom,nqpt,gprim,option,spqpt,trans)
4629 : :
4630 : : !Arguments -------------------------------
4631 : : !scalars
4632 : : integer,intent(in) :: natom,nqpt,option
4633 : : !arrays
4634 : : real(dp),intent(in) :: gprim(3,3),spqpt(3,nqpt),trans(3,natom)
4635 : : real(dp),intent(inout) :: dynmat(2,3,natom,3,natom,nqpt)
4636 : :
4637 : : !Local variables -------------------------
4638 : : !scalars
4639 : : integer :: ia,ib,iqpt,mu,nu
4640 : : real(dp) :: im,re,phase_re,phase_im
4641 : : !arrays
4642 : : real(dp) :: kk(3)
4643 : : ! *********************************************************************
4644 : :
4645 [ + + ]: 1185527 : do iqpt=1,nqpt
4646 : : ! Definition of q in normalized reciprocal space
4647 [ + + + + ]: 7788989 : kk(:) = matmul(gprim, spqpt(:, iqpt))
4648 : :
4649 : :
4650 [ + + ]: 599153 : if(option==1)then
4651 [ + + ]: 51920 : kk(:)=-kk(:)
4652 : : end if
4653 : :
4654 [ + + ]: 2318879 : do ia=1,natom
4655 [ + + ]: 4462491 : do ib=1,natom
4656 : : ! Phase factor associated with the differences between the two atomic translations
4657 [ + + ]: 10919944 : call ifc_atom_phase(kk, trans(:,ia)-trans(:,ib), phase_re, phase_im)
4658 [ + + ]: 12053296 : do mu=1,3
4659 [ + + ]: 35489818 : do nu=1,3
4660 : 24569874 : re=dynmat(1,mu,ia,nu,ib,iqpt)
4661 : 24569874 : im=dynmat(2,mu,ia,nu,ib,iqpt)
4662 : : ! Transformation of the Old dynamical matrices by New ones by multiplication by a phase shift
4663 : 24569874 : dynmat(1,mu,ia,nu,ib,iqpt)=re*phase_re-im*phase_im
4664 : 32759832 : dynmat(2,mu,ia,nu,ib,iqpt)=re*phase_im+im*phase_re
4665 : : end do
4666 : : end do
4667 : : end do
4668 : : end do
4669 : : end do
4670 : :
4671 : 586374 : end subroutine dymfz9
4672 : : !!***
4673 : :
4674 : : !----------------------------------------------------------------------
4675 : :
4676 : : !!****f* m_dynmat/ifc_atom_phase
4677 : : !! NAME
4678 : : !! ifc_atom_phase
4679 : : !!
4680 : : !! FUNCTION
4681 : : !! Phase factor e^{i 2pi k.dtau} associated with a dynamical-matrix element
4682 : : !! D(q)_{ia,ib}, where dtau is the difference between the (real-space,
4683 : : !! reduced-coordinate-like) positions of the two atoms ia, ib -- i.e. the
4684 : : !! atom-position phase e^{i q.(tau_i - tau_j)} that converts between the
4685 : : !! two conventions for the Fourier transform of the dynamical matrix
4686 : : !! discussed by Gonze & Lee, PRB 55, 10355 (1997) [[cite:Gonze1997a]]: one
4687 : : !! using only the lattice-vector part of the atom separation (as
4688 : : !! ftifc_q2r/ftifc_r2q do), the other using the full atom-to-atom
4689 : : !! separation. This is exactly dymfz9's per-atom-pair building block,
4690 : : !! factored out so the same phase-factor computation is not duplicated at
4691 : : !! its other call sites (e.g. m_lwf.F90's lattice-Wannier-function gauge).
4692 : : !!
4693 : : !! INPUTS
4694 : : !! k(3) = wavevector, already expressed in the coordinate system dual to
4695 : : !! dtau (e.g. gprim.qpt, as computed by dymfz9's caller; the two must be
4696 : : !! in mutually consistent units so that k.dtau is a dimensionless phase
4697 : : !! divided by 2pi -- this routine does not perform any basis conversion)
4698 : : !! dtau(3) = atom-position difference tau_i - tau_j
4699 : : !!
4700 : : !! OUTPUT
4701 : : !! phase_re, phase_im = real and imaginary parts of e^{i 2pi k.dtau}
4702 : : !!
4703 : : !! SOURCE
4704 : :
4705 : 2730946 : pure subroutine ifc_atom_phase(k, dtau, phase_re, phase_im)
4706 : :
4707 : : !Arguments -------------------------------
4708 : : !arrays
4709 : : real(dp),intent(in) :: k(3), dtau(3)
4710 : : real(dp),intent(out) :: phase_re, phase_im
4711 : :
4712 : : !Local variables -------------------------
4713 : : !scalars
4714 : : real(dp) :: kdtau
4715 : : ! *********************************************************************
4716 : :
4717 : 2730946 : kdtau = k(1)*dtau(1) + k(2)*dtau(2) + k(3)*dtau(3)
4718 : 2730946 : phase_re = cos(two_pi*kdtau)
4719 : 2730946 : phase_im = sin(two_pi*kdtau)
4720 : :
4721 : 2730946 : end subroutine ifc_atom_phase
4722 : : !!***
4723 : :
4724 : : !----------------------------------------------------------------------
4725 : :
4726 : : !!****f* m_dynmat/nanal9
4727 : : !!
4728 : : !! NAME
4729 : : !! nanal9
4730 : : !!
4731 : : !! FUNCTION
4732 : : !! If plus=0 then substracts the non-analytical part from one dynamical
4733 : : !! matrices, with number iqpt.
4734 : : !! If plus=1 then adds the non-analytical part to the dynamical
4735 : : !! matrices, with number iqpt.
4736 : : !!
4737 : : !! For plus=0, see Eq.(76) in Gonze&Lee PRB 55, 10355 (1997) [[cite:Gonze1997a]],
4738 : : !! get the left hand side.
4739 : : !!
4740 : : !! INPUTS
4741 : : !! dyew(2,3,natom,3,natom)= Non-analytical part
4742 : : !! natom= Number of atoms in the unit cell
4743 : : !! iqpt= Referenced q point for the dynamical matrix
4744 : : !! nqpt= Number of q points
4745 : : !! plus= (see above)
4746 : : !!
4747 : : !! OUTPUT
4748 : : !! dynmat(2,3,natom,3,natom,nqpt)= Dynamical matrices coming from the Derivative Data Base
4749 : : !!
4750 : : !! SOURCE
4751 : :
4752 : 74804 : subroutine nanal9(dyew,dynmat,iqpt,natom,nqpt,plus)
4753 : :
4754 : : !Arguments -------------------------------
4755 : : !scalars
4756 : : integer,intent(in) :: iqpt,natom,nqpt,plus
4757 : : !arrays
4758 : : real(dp),intent(in) :: dyew(2,3,natom,3,natom)
4759 : : real(dp),intent(inout) :: dynmat(2,3,natom,3,natom,nqpt)
4760 : :
4761 : : !Local variables -------------------------
4762 : : !scalars
4763 : : integer :: ia,ib,mu,nu
4764 : : character(len=500) :: msg
4765 : : ! *********************************************************************
4766 : :
4767 [ + + ]: 74804 : if (plus==0) then
4768 : :
4769 [ + + ]: 50715 : do ia=1,natom
4770 [ + + ]: 213548 : do ib=1,natom
4771 [ + + ]: 690463 : do mu=1,3
4772 [ + + ]: 2116829 : do nu=1,3
4773 : : ! The following four lines are OK
4774 : 1465497 : dynmat(1,mu,ia,nu,ib,iqpt)=dynmat(1,mu,ia,nu,ib,iqpt) - dyew(1,mu,ia,nu,ib)
4775 : 1953996 : dynmat(2,mu,ia,nu,ib,iqpt)=dynmat(2,mu,ia,nu,ib,iqpt) - dyew(2,mu,ia,nu,ib)
4776 : : end do
4777 : : end do
4778 : : end do
4779 : : end do
4780 : :
4781 [ + - ]: 63220 : else if (plus==1) then
4782 [ + + ]: 223272 : do ia=1,natom
4783 [ + + ]: 792728 : do ib=1,natom
4784 [ + + ]: 2437876 : do mu=1,3
4785 [ + + ]: 7402928 : do nu=1,3
4786 : 5125104 : dynmat(1,mu,ia,nu,ib,iqpt)=dynmat(1,mu,ia,nu,ib,iqpt) + dyew(1,mu,ia,nu,ib)
4787 : 6833472 : dynmat(2,mu,ia,nu,ib,iqpt)=dynmat(2,mu,ia,nu,ib,iqpt) + dyew(2,mu,ia,nu,ib)
4788 : : end do
4789 : : end do
4790 : : end do
4791 : : end do
4792 : :
4793 : : else
4794 : : write(msg,'(3a,i0,a)' )&
4795 : 0 : 'The argument "plus" must be equal to 0 or 1.',ch10,&
4796 : 0 : 'The value: ',plus,' is not available.'
4797 : 0 : ABI_BUG(msg)
4798 : : end if
4799 : :
4800 : 74804 : end subroutine nanal9
4801 : : !!***
4802 : :
4803 : : !----------------------------------------------------------------------
4804 : :
4805 : : !!****f* m_dynmat/gtdyn9
4806 : : !!
4807 : : !! NAME
4808 : : !! gtdyn9
4809 : : !!
4810 : : !! FUNCTION
4811 : : !! Generates a dynamical matrix from interatomic force
4812 : : !! constants and long-range electrostatic interactions.
4813 : : !!
4814 : : !! INPUTS
4815 : : !! atmfrc(3,natom,3,natom,nrpt) = Interatomic Forces in real space
4816 : : !! dielt(3,3) = dielectric tensor
4817 : : !! dipdip= if 0, no dipole-dipole interaction was subtracted in atmfrc
4818 : : !! if 1, atmfrc has been build without dipole-dipole part
4819 : : !! dyewq0(3,3,natom)= Ewald part of the dynamical matrix, at q=0.
4820 : : !! gmet(3,3)= metric tensor in reciprocal space.
4821 : : !! gprimd(3,3)= dimensional primitive translations in reciprocal space (bohr^-1)
4822 : : !! mpert =maximum number of ipert
4823 : : !! natom= Number of atoms in the unit cell
4824 : : !! nrpt= Number of R points in the Big Box
4825 : : !! qphnrm= Normalisation coefficient for qpt
4826 : : !! qpt(3)= Reduced coordinates of the q vectors in reciprocal space
4827 : : !! rmet(3,3)= Metric tensor in real space.
4828 : : !! rprimd(3,3)= dimensional primitive translations in real space (bohr)
4829 : : !! rpt(3,nprt)= cartesian coordinates of the R points in the unit cell
4830 : : !! trans(3,natom)= Atomic translations : xred = rcan + trans
4831 : : !! ucvol= unit cell volume
4832 : : !! wghatm(natom,natom,nrpt)= Weights associated to a pair of atoms and to a R vector
4833 : : !! xred(3,natom)= relative coords of atoms in unit cell (dimensionless)
4834 : : !! zeff(3,3,natom)=effective charge on each atom, versus electric field and atomic displacement
4835 : : !! comm=MPI communicator.
4836 : : !! [dipquad] = if 1, atmfrc has been build without dipole-quadrupole part
4837 : : !! [quadquad] = if 1, atmfrc has been build without quadrupole-quadrupole part
4838 : : !!
4839 : : !! OUTPUT
4840 : : !! d2cart(2,3,mpert,3,mpert)=dynamical matrix obtained for the wavevector qpt (normalized using qphnrm)
4841 : : !! eta: parameter used to split R and G-space summation
4842 : : !!
4843 : : !! SOURCE
4844 : :
4845 : 197574 : subroutine gtdyn9(atmfrc,dielt,dipdip,dyewq0,d2cart,gmet,gprimd,mpert,natom,&
4846 : 197574 : nrpt,qphnrm,qpt,rmet,rprimd,rpt,trans,ucvol,wghatm,xred,zeff,qdrp_cart,ewald_option,eta,comm,&
4847 : : sys_dim,dipquad,quadquad,dielt_env,dielt_thick) ! optional
4848 : :
4849 : : !Arguments -------------------------------
4850 : : !scalars
4851 : : integer,intent(in) :: dipdip,mpert,natom,nrpt,ewald_option,comm,sys_dim
4852 : : real(dp),intent(in) :: qphnrm,ucvol
4853 : : real(dp),optional,intent(in) :: dielt_env
4854 : : integer,optional,intent(in) :: dipquad, quadquad
4855 : : !arrays
4856 : : real(dp), optional,intent(in):: dielt_thick(2)
4857 : : real(dp),intent(in) :: dielt(3,3),gmet(3,3),gprimd(3,3),qpt(3)
4858 : : real(dp),intent(in) :: rmet(3,3),rprimd(3,3),rpt(3,nrpt)
4859 : : real(dp),intent(in) :: trans(3,natom),wghatm(natom,natom,nrpt),xred(3,natom)
4860 : : real(dp),intent(in) :: zeff(3,3,natom)
4861 : : real(dp),intent(in) :: qdrp_cart(3,3,3,natom)
4862 : : real(dp),intent(in) :: atmfrc(3,natom,3,natom,nrpt)
4863 : : real(dp),intent(in) :: dyewq0(3,3,natom)
4864 : : real(dp),intent(out) :: d2cart(2,3,mpert,3,mpert), eta
4865 : :
4866 : : !Local variables -------------------------
4867 : : !scalars
4868 : : integer,parameter :: nqpt1 = 1, option2 = 2, sumg0 = 0, plus1 = 1, iqpt1 = 1
4869 : : integer :: i1, i2, ib, nsize, dipquad_, quadquad_
4870 : : !arrays
4871 : : real(dp) :: qphon(3) !, tsec(2)
4872 : 197574 : real(dp),allocatable :: dq(:,:,:,:,:),dyew(:,:,:,:,:)
4873 : : ! *********************************************************************
4874 : :
4875 : : ! Keep track of time spent in gtdyn9
4876 : : !call timab(1750, 1, tsec)
4877 : :
4878 [ - + + - : 987870 : ABI_MALLOC(dq,(2,3,natom,3,natom))
+ - - + +
- + - + -
- + - + ]
4879 : :
4880 : : ! Define quadrupolar options
4881 [ + + ]: 197574 : dipquad_=0; if(present(dipquad)) dipquad_=dipquad
4882 [ + + ]: 197574 : quadquad_=0; if(present(quadquad)) quadquad_=quadquad
4883 : :
4884 : : ! Get the normalized wavevector
4885 [ + + ]: 197574 : if(abs(qphnrm)<1.0d-7)then
4886 : 18502 : qphon(1:3)=zero
4887 : : else
4888 [ + + ]: 716288 : qphon(1:3)=qpt(1:3)/qphnrm
4889 : : end if
4890 : :
4891 : : ! Generate the analytical part from the interatomic forces
4892 : 197574 : call ftifc_r2q(atmfrc, dq, gprimd, natom, nqpt1, nrpt, rpt, qphon, wghatm, comm)
4893 : :
4894 : : ! The analytical dynamical matrix dq has been generated
4895 : : ! in the normalized canonical coordinate system.
4896 : : ! Now, the phase is modified, in order to recover the usual (xred) coordinate of atoms.
4897 : 197574 : call dymfz9(dq,natom,nqpt1,gprimd,option2,qphon,trans)
4898 : :
4899 [ + + + + ]: 197574 : if (dipdip==1.or.dipquad_==1.or.quadquad_==1) then
4900 : : ! Add the non-analytical part
4901 : : ! Compute dyew(2,3,natom,3,natom)= Ewald part of the dynamical matrix,
4902 : : ! second energy derivative wrt xred(3,natom) in Hartrees (Denoted A-bar in the notes)
4903 [ - + + - : 189660 : ABI_MALLOC(dyew,(2,3,natom,3,natom))
- + + - -
+ - + ]
4904 [ + + ]: 63220 : if (sys_dim==1) then ! 3D case
4905 : : call ewald9(dielt,dyew,gmet,gprimd,natom,qphon,rmet,rprimd,sumg0,ucvol,xred,zeff,&
4906 : 62998 : qdrp_cart,eta,option=ewald_option,dipquad=dipquad_,quadquad=quadquad_)
4907 [ + - ]: 222 : elseif (sys_dim<5) then
4908 : 222 : call ewald9_2D(natom,rprimd,xred,dielt,dyew,qpt,zeff,qdrp_cart,dielt_env,dielt_thick,sys_dim)
4909 : : end if
4910 : :
4911 : 63220 : call q0dy3_apply(natom,dyewq0,dyew)
4912 : 63220 : call nanal9(dyew,dq,iqpt1,natom,nqpt1,plus1)
4913 : :
4914 [ - + ]: 63220 : ABI_FREE(dyew)
4915 : : end if
4916 : :
4917 : : ! Copy the dynamical matrix in the proper location
4918 : : ! First zero all the elements
4919 : 197574 : nsize=2*(3*mpert)**2
4920 [ + + + + : 799238072 : d2cart = zero
+ + + + +
+ ]
4921 : :
4922 : : ! Copy the elements from dq to d2cart
4923 [ + + + + : 35411946 : d2cart(:,:,1:natom,:,1:natom)=dq(:,:,1:natom,:,1:natom)
+ + + + +
+ ]
4924 : :
4925 : : ! In case we have the gamma point,
4926 [ + + ]: 197574 : if(qphon(1)**2+qphon(2)**2+qphon(3)**2<1.d-14)then
4927 : : ! Copy the effective charge and dielectric constant in the final array
4928 [ + + ]: 77924 : do i1=1,3
4929 [ + + ]: 253253 : do i2=1,3
4930 : 175329 : d2cart(1,i1,natom+2,i2,natom+2)=dielt(i1,i2)
4931 [ + + ]: 587607 : do ib=1,natom
4932 : 353835 : d2cart(1,i1,natom+2,i2,ib)=zeff(i1,i2,ib)
4933 : 529164 : d2cart(1,i2,ib,i1,natom+2)=zeff(i1,i2,ib)
4934 : : end do
4935 : : end do
4936 : : end do
4937 : : end if
4938 : :
4939 [ - + ]: 197574 : ABI_FREE(dq)
4940 : :
4941 : : !call timab(1750, 2, tsec)
4942 : :
4943 : 197574 : end subroutine gtdyn9
4944 : : !!***
4945 : :
4946 : : !----------------------------------------------------------------------
4947 : :
4948 : : !!****f* m_dynmat/dfpt_phfrq
4949 : : !! NAME
4950 : : !! dfpt_phfrq
4951 : : !!
4952 : : !! FUNCTION
4953 : : !! Get the phonon frequencies and eigenvectors (as well as the corresponding displacements)
4954 : : !! If q is at Gamma, the non-analytical behaviour can be included.
4955 : : !! Then, the effective dielectric tensor, the effective charges
4956 : : !! and oscillator strengths for the limiting direction are also returned
4957 : : !!
4958 : : !! INPUTS
4959 : : !! amu(ntypat)=mass of the atoms (atomic mass unit) matrix (diagonal in the atoms)
4960 : : !! d2cart(2,3,mpert,3,mpert)=dynamical matrix, effective charges, dielectric tensor,.... all in cartesian coordinates
4961 : : !! indsym(4,msym*natom)=indirect indexing array : for each
4962 : : !! isym,iatom, fourth element is label of atom into which iatom is sent by
4963 : : !! INVERSE of symmetry operation isym; first three elements are the primitive
4964 : : !! translations which must be subtracted after the transformation to get back to the original unit cell.
4965 : : !! mpert =maximum number of ipert
4966 : : !! msym=maximum number of symmetries
4967 : : !! natom=number of atoms in unit cell
4968 : : !! nsym=number of space group symmetries
4969 : : !! ntypat=number of atom types
4970 : : !! qphnrm=(described above)
4971 : : !! qphon(3)= to be divided by qphnrm, give the phonon wavevector;
4972 : : !! if qphnrm==0.0_dp, then the wavevector is zero (Gamma point)
4973 : : !! and qphon gives the direction of the induced electric field in **CARTESIAN** coordinates.
4974 : : !! in the latter case, if qphon is zero, no non-analytical contribution is included.
4975 : : !! rprimd(3,3)=dimensional primitive translations (bohr)
4976 : : !! symdynmat=if 1, (re)symmetrize the dynamical matrix, except if Gamma wavevector with electric field added.
4977 : : !! symrel(3,3,nsym)=matrices of the group symmetries (real space)
4978 : : !! typat(natom)=integer label of each type of atom (1,2,...)
4979 : : !! ucvol=unit cell volume
4980 : : !!
4981 : : !! OUTPUT
4982 : : !! displ(2*3*natom*3*natom)= at the end, contains the displacements of atoms in cartesian coordinates.
4983 : : !! The first index means either the real or the imaginary part,
4984 : : !! The second index runs on the direction and the atoms displaced
4985 : : !! The third index runs on the modes.
4986 : : !! eigval(3*natom)=contains the eigenvalues of the dynamical matrix
4987 : : !! eigvec(2*3*natom*3*natom)= at the end, contains the eigenvectors of the dynamical matrix in cartesian coordinates.
4988 : : !! phfrq(3*natom)=phonon frequencies (square root of the dynamical matrix eigenvalues,
4989 : : !! except if these are negative, and in this case, give minus the square root of the absolute value
4990 : : !! of the matrix eigenvalues). Hartree units.
4991 : : !!
4992 : : !! NOTES
4993 : : !! 1) One makes the dynamical matrix hermitian...
4994 : : !! 2) In case of q=Gamma, only the real part is used.
4995 : : !! (MR: Modified since at finite omega imaginary components may arise
4996 : : !! also at Gamma in broken time-reversal symmetry crystals)
4997 : : !!
4998 : : !! SOURCE
4999 : :
5000 : 256072 : subroutine dfpt_phfrq(amu,displ,d2cart,eigval,eigvec,indsym,&
5001 : 256072 : & mpert,msym,natom,nsym,ntypat,phfrq,qphnrm,qphon,rprimd,&
5002 : 256072 : & symdynmat,symrel,symafm,typat,ucvol)
5003 : :
5004 : : !Arguments -------------------------------
5005 : : !scalars
5006 : : integer,intent(in) :: mpert,msym,natom,nsym,ntypat,symdynmat
5007 : : real(dp),intent(in) :: qphnrm,ucvol
5008 : : !arrays
5009 : : integer,intent(in) :: indsym(4,msym*natom),symrel(3,3,nsym),typat(natom)
5010 : : integer,intent(in) :: symafm(nsym)
5011 : : real(dp),intent(in) :: amu(ntypat),d2cart(2,3,mpert,3,mpert),rprimd(3,3)
5012 : : real(dp),intent(inout) :: qphon(3)
5013 : : real(dp),intent(out) :: displ(2*3*natom*3*natom),eigval(3*natom)
5014 : : real(dp),intent(out) :: eigvec(2*3*natom*3*natom),phfrq(3*natom)
5015 : :
5016 : : !Local variables -------------------------
5017 : : !scalars
5018 : : integer :: analyt,i1,i2,idir1,idir2,ier,ii,imode,ipert1,ipert2
5019 : : integer :: jmode,indexi,indexj,index
5020 : : real(dp) :: epsq,qphon2
5021 : : logical,parameter :: debug = .False.
5022 : : real(dp) :: sc_prod
5023 : : !arrays
5024 : : real(dp) :: qptn(3),dum(2,0) !, tsec(2)
5025 : 256072 : real(dp),allocatable :: matrx(:,:),zeff(:,:),zhpev1(:,:),zhpev2(:)
5026 : : ! *********************************************************************
5027 : :
5028 : : ! Keep track of time spent in dfpt_phfrq
5029 : : !call timab(1751, 1, tsec)
5030 : :
5031 : : ! GA: I find it strange that both msym and nsym are needed here.
5032 : : ! Moreover, there is an inconsistency in the dimensions of indsym
5033 : : ! when it is passed to symdyma.
5034 : : ! TODO: eliminate msym.
5035 : :
5036 : : ! Prepare the diagonalisation: analytical part.
5037 : : ! Note: displ is used as work space here
5038 : 256072 : i1=0
5039 [ + + ]: 791841 : do ipert1=1,natom
5040 [ + + ]: 2399148 : do idir1=1,3
5041 : 1607307 : i1=i1+1
5042 : 1607307 : i2=0
5043 [ + + ]: 6475583 : do ipert2=1,natom
5044 [ + + ]: 18937335 : do idir2=1,3
5045 : 12997521 : i2=i2+1
5046 : 12997521 : index=i1+3*natom*(i2-1)
5047 : 12997521 : displ(2*index-1)=d2cart(1,idir1,ipert1,idir2,ipert2)
5048 : 17330028 : displ(2*index )=d2cart(2,idir1,ipert1,idir2,ipert2)
5049 : : end do
5050 : : end do
5051 : : end do
5052 : : end do
5053 : :
5054 : : ! Determine the analyticity of the matrix.
5055 [ + + ]: 256072 : analyt=1; if(abs(qphnrm)<tol8) analyt=0
5056 [ + + + + : 256072 : if(abs(qphon(1))<tol8.and.abs(qphon(2))<tol8.and.abs(qphon(3))<tol8) analyt=2
+ + ]
5057 : :
5058 : : ! In case of q=Gamma, only the real part is used
5059 [ + + ]: 256072 : if(analyt==0 .or. analyt==2)then
5060 [ + + ]: 621158 : do i1=1,3*natom
5061 [ + + ]: 4464266 : do i2=1,3*natom
5062 : 3843108 : index=i1+3*natom*(i2-1)
5063 [ + + ]: 4384344 : if (abs(displ(2*index)) < tol14) displ(2*index)=zero
5064 : : end do
5065 : : end do
5066 : : end if
5067 : :
5068 : : ! In the case the non-analyticity is required:
5069 : : ! the tensor is in cartesian coordinates and this means that qphon must be in given in Cartesian coordinates.
5070 [ + + ]: 79922 : if(analyt==0)then
5071 : :
5072 : : ! Normalize the limiting direction
5073 : 78727 : qphon2=qphon(1)**2+qphon(2)**2+qphon(3)**2
5074 [ + + ]: 314908 : qphon(:)=qphon(:)/sqrt(qphon2)
5075 : :
5076 : : ! Get the dielectric constant for the limiting direction
5077 : : epsq=zero
5078 [ + + ]: 314908 : do idir1=1,3
5079 [ + + ]: 1023451 : do idir2=1,3
5080 : 944724 : epsq= epsq + qphon(idir1)*qphon(idir2) * d2cart(1,idir1,natom+2,idir2,natom+2)
5081 : : end do
5082 : : end do
5083 : :
5084 [ - + + - : 236181 : ABI_MALLOC(zeff,(3,natom))
+ - + - -
+ - + ]
5085 : :
5086 : : ! Get the effective charges for the limiting direction
5087 [ + + ]: 314908 : do idir1=1,3
5088 [ + + ]: 847738 : do ipert1=1,natom
5089 : 532830 : zeff(idir1,ipert1)=zero
5090 [ + + ]: 2367501 : do idir2=1,3
5091 : 2131320 : zeff(idir1,ipert1) = zeff(idir1,ipert1) + qphon(idir2)* d2cart(1,idir1,ipert1,idir2,natom+2)
5092 : : end do
5093 : : end do
5094 : : end do
5095 : :
5096 : : ! Get the non-analytical part of the dynamical matrix, and suppress its imaginary part.
5097 : : i1=0
5098 [ + + ]: 256337 : do ipert1=1,natom
5099 [ + + ]: 789167 : do idir1=1,3
5100 : 532830 : i1=i1+1
5101 : 532830 : i2=0
5102 [ + + ]: 1958770 : do ipert2=1,natom
5103 [ + + ]: 5526150 : do idir2=1,3
5104 : 3744990 : i2=i2+1
5105 : 3744990 : index=i1+3*natom*(i2-1)
5106 : 3744990 : displ(2*index-1)=displ(2*index-1)+four_pi/ucvol*zeff(idir1,ipert1)*zeff(idir2,ipert2)/epsq
5107 [ + - ]: 4993320 : if (abs(displ(2*index)) < tol14) displ(2*index)=zero
5108 : : end do
5109 : : end do
5110 : : end do
5111 : : end do
5112 : :
5113 [ - + ]: 78727 : ABI_FREE(zeff)
5114 : : end if ! End of the non-analyticity treatment
5115 : :
5116 : : ! Multiply IFC(q) by masses
5117 : 256072 : call massmult_and_breaksym(natom, ntypat, typat, amu, displ)
5118 : : ! ***********************************************************************
5119 : : ! Diagonalize the dynamical matrix
5120 : :
5121 : : !Symmetrize the dynamical matrix
5122 : : !FIXME: swap the next 2 lines and update test files to include symmetrization
5123 : : ! for Gamma point too (except in non-analytic case)
5124 : : !if (symdynmat==1 .and. analyt > 0) then
5125 [ + + + + ]: 256072 : if (symdynmat==1 .and. analyt == 1) then
5126 : 170657 : qptn(:)=qphon(:)
5127 [ + + ]: 682628 : if (analyt==1) qptn(:)=qphon(:)/qphnrm
5128 : 170657 : call symdyma(displ,indsym,natom,nsym,qptn,rprimd,symrel,symafm)
5129 : : end if
5130 : :
5131 : 256072 : ii=1
5132 [ + - - + : 768216 : ABI_MALLOC(matrx,(2,(3*natom*(3*natom+1))/2))
+ - + - +
- - + -
+ ]
5133 [ + + ]: 1863379 : do i2=1,3*natom
5134 [ + + ]: 9165793 : do i1=1,i2
5135 : 7302414 : matrx(1,ii)=displ(1+2*(i1-1)+2*(i2-1)*3*natom)
5136 : 7302414 : matrx(2,ii)=displ(2+2*(i1-1)+2*(i2-1)*3*natom)
5137 : 8909721 : ii=ii+1
5138 : : end do
5139 : : end do
5140 : :
5141 [ + - - + : 768216 : ABI_MALLOC(zhpev1,(2,2*3*natom-1))
+ - + - +
- - + -
+ ]
5142 [ + - - + : 768216 : ABI_MALLOC(zhpev2,(3*3*natom-2))
+ - + - +
- - + -
+ ]
5143 : :
5144 : 256072 : call ZHPEV ('V','U',3*natom,matrx,eigval,eigvec,3*natom,zhpev1,zhpev2,ier)
5145 [ - + ]: 256072 : ABI_CHECK(ier == 0, sjoin('zhpev returned:', itoa(ier)))
5146 : :
5147 [ - + ]: 256072 : ABI_FREE(matrx)
5148 [ - + ]: 256072 : ABI_FREE(zhpev1)
5149 [ - + ]: 256072 : ABI_FREE(zhpev2)
5150 : :
5151 : : if (debug) then
5152 : : ! Check the orthonormality of the eigenvectors
5153 : : do imode=1,3*natom
5154 : : do jmode=imode,3*natom
5155 : : indexi=2*3*natom*(imode-1)
5156 : : indexj=2*3*natom*(jmode-1)
5157 : : sc_prod=sum(eigvec(indexi+1:indexi+6*natom)*eigvec(indexj+1:indexj+6*natom))
5158 : : write(std_out,'(a,2i4,a,es16.6)')' imode,jmode=',imode,jmode,' real scalar product =',sc_prod
5159 : : end do
5160 : : end do
5161 : : end if
5162 : : !***********************************************************************
5163 : :
5164 : : ! Get the phonon frequencies (negative by convention, if the eigenvalue of the dynamical matrix is negative)
5165 [ + + ]: 1863379 : do imode=1,3*natom
5166 [ + + ]: 1863379 : if(eigval(imode)>=1.0d-16)then
5167 : 1405917 : phfrq(imode)=sqrt(eigval(imode))
5168 [ + + ]: 201390 : else if(eigval(imode)>=-1.0d-16)then
5169 : 142723 : phfrq(imode)=zero
5170 : : else
5171 : 58667 : phfrq(imode)=-sqrt(-eigval(imode))
5172 : : end if
5173 : : end do
5174 : :
5175 : : ! Fix the phase of the eigenvectors
5176 : 256072 : call fxphas_seq(eigvec,dum, 0, 0, 1, 3*natom*3*natom, 0, 3*natom, 3*natom, 0)
5177 : :
5178 : : ! Normalise the eigenvectors
5179 : 256072 : call pheigvec_normalize(natom, eigvec)
5180 : :
5181 : : ! Get the phonon displacements
5182 : 256072 : call phdispl_from_eigvec(natom, ntypat, typat, amu, eigvec, displ)
5183 : :
5184 : : if (debug) then
5185 : : write(std_out,'(a)')' Phonon eigenvectors and displacements '
5186 : : do imode=1,3*natom
5187 : : indexi=2*3*natom*(imode-1)
5188 : : write(std_out,'(a,i4,a,12es16.6)')' imode=',imode,' eigvec(1:6*natom)=',eigvec(indexi+1:indexi+6*natom)
5189 : : write(std_out,'(a,i4,a,12es16.6)')' imode=',imode,' displ(1:6*natom)=',displ(indexi+1:indexi+6*natom)
5190 : : end do
5191 : :
5192 : : ! Check the orthonormality of the eigenvectors
5193 : : do imode=1,3*natom
5194 : : do jmode=imode,3*natom
5195 : : indexi=2*3*natom*(imode-1)
5196 : : indexj=2*3*natom*(jmode-1)
5197 : : sc_prod=sum(eigvec(indexi+1:indexi+6*natom)*eigvec(indexj+1:indexj+6*natom))
5198 : : write(std_out,'(a,2i4,a,es16.6)')' imode,jmode=',imode,jmode,' real scalar product =',sc_prod
5199 : : end do
5200 : : end do
5201 : : end if
5202 : :
5203 : : !call timab(1751, 2, tsec)
5204 : :
5205 : 256072 : end subroutine dfpt_phfrq
5206 : : !!***
5207 : :
5208 : : !----------------------------------------------------------------------
5209 : :
5210 : : !!****f* m_dynmat/pheigvec_normalize
5211 : : !!
5212 : : !! NAME
5213 : : !! pheigvec_normalize
5214 : : !!
5215 : : !! FUNCTION
5216 : : !! Normalize input eigenvectors in cartesian coordinates
5217 : : !!
5218 : : !! INPUTS
5219 : : !! natom: number of atoms in unit cell
5220 : : !!
5221 : : !! SIDE EFFECTS
5222 : : !! eigvec(2*3*natom*3*natom)=in output the normalized eigenvectors in cartesian coordinates.
5223 : : !!
5224 : : !! SOURCE
5225 : :
5226 : 256102 : pure subroutine pheigvec_normalize(natom, eigvec)
5227 : :
5228 : : !Arguments -------------------------------
5229 : : !scalars
5230 : : integer,intent(in) :: natom
5231 : : !arrays
5232 : : real(dp),intent(inout) :: eigvec(2*3*natom*3*natom)
5233 : :
5234 : : !Local variables -------------------------
5235 : : !scalars
5236 : : integer :: i1,idir1,imode,ipert1,index
5237 : : real(dp) :: norm
5238 : : ! *********************************************************************
5239 : :
5240 [ + + ]: 1863949 : do imode=1,3*natom
5241 : :
5242 : : norm=zero
5243 [ + + ]: 6431388 : do idir1=1,3
5244 [ + + ]: 19438629 : do ipert1=1,natom
5245 : 13007241 : i1=idir1+(ipert1-1)*3
5246 : 13007241 : index=i1+3*natom*(imode-1)
5247 : 17830782 : norm=norm+eigvec(2*index-1)**2+eigvec(2*index)**2
5248 : : end do
5249 : : end do
5250 : 1607847 : norm=sqrt(norm)
5251 : :
5252 [ + + ]: 6687490 : do idir1=1,3
5253 [ + + ]: 19438629 : do ipert1=1,natom
5254 : 13007241 : i1=idir1+(ipert1-1)*3
5255 : 13007241 : index=i1+3*natom*(imode-1)
5256 : 13007241 : eigvec(2*index-1)=eigvec(2*index-1)/norm
5257 : 17830782 : eigvec(2*index)=eigvec(2*index)/norm
5258 : : end do
5259 : : end do
5260 : :
5261 : : end do
5262 : :
5263 : 256102 : end subroutine pheigvec_normalize
5264 : : !!***
5265 : :
5266 : : !----------------------------------------------------------------------
5267 : :
5268 : : !!****f* m_dynmat/phdispl_from_eigvec
5269 : : !! NAME
5270 : : !! phdispl_from_eigvec
5271 : : !!
5272 : : !! FUNCTION
5273 : : !! Phonon displacements in cart coords from eigenvectors
5274 : : !!
5275 : : !! INPUTS
5276 : : !! natom: number of atoms in unit cell
5277 : : !! ntypat=number of atom types
5278 : : !! typat(natom)=integer label of each type of atom (1,2,...)
5279 : : !! amu(ntypat)=mass of the atoms (atomic mass unit) matrix (diagonal in the atoms)
5280 : : !! eigvec(2*3*natom*3*natom)= eigenvectors of the dynamical matrix in cartesian coordinates.
5281 : : !!
5282 : : !! OUTPUT
5283 : : !! displ(2*3*natom*3*natom)=displacements of atoms in cartesian coordinates.
5284 : : !!
5285 : : !! SOURCE
5286 : :
5287 : 262927 : pure subroutine phdispl_from_eigvec(natom, ntypat, typat, amu, eigvec, displ)
5288 : :
5289 : : !Arguments -------------------------------
5290 : : !scalars
5291 : : integer,intent(in) :: natom, ntypat
5292 : : !arrays
5293 : : integer,intent(in) :: typat(natom)
5294 : : real(dp),intent(in) :: amu(ntypat)
5295 : : real(dp),intent(in) :: eigvec(2*3*natom*3*natom)
5296 : : real(dp),intent(out) :: displ(2*3*natom*3*natom)
5297 : :
5298 : : !Local variables -------------------------
5299 : : !scalars
5300 : : integer :: i1,idir1,imode,ipert1, index
5301 : : ! *********************************************************************
5302 : :
5303 [ + + ]: 1909168 : do imode=1,3*natom
5304 : :
5305 [ + + ]: 6847891 : do idir1=1,3
5306 [ + + ]: 19814901 : do ipert1=1,natom
5307 : 13229937 : i1=idir1+(ipert1-1)*3
5308 : 13229937 : index=i1+3*natom*(imode-1)
5309 : 13229937 : displ(2*index-1)=eigvec(2*index-1) / sqrt(amu(typat(ipert1))*amu_emass)
5310 : 18168660 : displ(2*index )=eigvec(2*index ) / sqrt(amu(typat(ipert1))*amu_emass)
5311 : : end do
5312 : : end do
5313 : :
5314 : : end do
5315 : :
5316 : 262927 : end subroutine phdispl_from_eigvec
5317 : : !!***
5318 : :
5319 : : !!****f* m_dynmat/phangmom_from_eigvec
5320 : : !! NAME
5321 : : !! phangmom_from_eigvec
5322 : : !!
5323 : : !! FUNCTION
5324 : : !! Phonon angular momenta in cart coords from eigenvectors
5325 : : !!
5326 : : !! INPUTS
5327 : : !! natom: number of atoms in unit cell
5328 : : !! eigvec(2*3*natom*3*natom)= eigenvectors of the dynamical matrix in cartesian coordinates.
5329 : : !!
5330 : : !! OUTPUT
5331 : : !! phangmom(3*3*natom)= angular momentum of each phonon mode in cartesian coordinates.
5332 : : !! The first index runs on the direction,
5333 : : !! The second index runs on the modes.
5334 : : !!
5335 : : !! SOURCE
5336 : :
5337 : 3178 : pure subroutine phangmom_from_eigvec(natom, eigvec, phangmom)
5338 : :
5339 : : !Arguments -------------------------------
5340 : : !scalars
5341 : : integer,intent(in) :: natom
5342 : : !arrays
5343 : : real(dp),intent(in) :: eigvec(2*3*natom*3*natom)
5344 : : real(dp),intent(out) :: phangmom(3*3*natom)
5345 : :
5346 : : !Local variables -------------------------
5347 : : !scalars
5348 : : integer :: imode,ipert, index
5349 : : !arrays
5350 : : real(dp) :: eigvecatom(2*3)
5351 : : ! *********************************************************************
5352 : :
5353 [ + + ]: 75907 : phangmom = zero
5354 : :
5355 [ + + ]: 27421 : do imode=1,3*natom
5356 [ + + ]: 110704 : do ipert=1,natom
5357 : 83283 : index = 3*natom*(imode-1) + 3*(ipert-1)
5358 [ + + ]: 582981 : eigvecatom = eigvec(2*index+1 : 2*index + 2*3) ! = Re(u_x), Im(u_x), Re(u_y), Im(u_y), Re(u_z), Im(u_z)
5359 : : phangmom(3*(imode-1)+1) = phangmom(3*(imode-1)+1)&
5360 : 83283 : + two * (eigvecatom(3) * eigvecatom(6) - eigvecatom(4) * eigvecatom(5)) ! Re(u_y)*Im(u_z) - Im(u_y)*Re(u_z)
5361 : : phangmom(3*(imode-1)+2) = phangmom(3*(imode-1)+2)&
5362 : 83283 : + two * (eigvecatom(5) * eigvecatom(2) - eigvecatom(6) * eigvecatom(1)) ! Re(u_z)*Im(u_x) - Im(u_z)*Re(u_x)
5363 : : phangmom(3*(imode-1)+3) = phangmom(3*(imode-1)+3)&
5364 : 107526 : + two * (eigvecatom(1) * eigvecatom(4) - eigvecatom(2) * eigvecatom(3)) ! Re(u_x)*Im(u_y) - Im(u_x)*Re(u_y)
5365 : : end do
5366 : : end do
5367 : :
5368 : 3178 : end subroutine phangmom_from_eigvec
5369 : : !!***
5370 : :
5371 : : !!****f* m_dynmat/dfpt_prtph
5372 : : !! NAME
5373 : : !! dfpt_prtph
5374 : : !!
5375 : : !! FUNCTION
5376 : : !! Print the phonon frequencies, on unit 6 as well as the printing
5377 : : !! unit (except if the associated number -iout- is negative),
5378 : : !! and for the latter, in Hartree, meV, Thz, Kelvin or cm-1.
5379 : : !! If eivec==1,2, also print the eigenmodes : displacements in cartesian coordinates.
5380 : : !! If eivec==4, generate output files for band2eps (drawing tool for the phonon band structure
5381 : : !!
5382 : : !! INPUTS
5383 : : !! displ(2,3*natom,3*natom)= contains the displacements of atoms in cartesian coordinates.
5384 : : !! The first index means either the real or the imaginary part,
5385 : : !! The second index runs on the direction and the atoms displaced
5386 : : !! The third index runs on the modes.
5387 : : !! eivec=(if eivec==0, the eigendisplacements are not printed,
5388 : : !! if eivec==1,2, the eigendisplacements are printed,
5389 : : !! if eivec==4, files for band2eps
5390 : : !! enunit=units for output of the phonon frequencies :
5391 : : !! 0=> Hartree and cm-1, 1=> eV and Thz, other=> Ha,Thz,eV,cm-1 and K
5392 : : !! iout= unit for long print (if negative, the routine only print on unit 6, and in Hartree only).
5393 : : !! natom= number of atom
5394 : : !! phfrq(3*natom)= phonon frequencies in Hartree
5395 : : !! qphnrm=phonon wavevector normalisation factor
5396 : : !! qphon(3)=phonon wavevector
5397 : : !!
5398 : : !! OUTPUT
5399 : : !! Only printing
5400 : : !!
5401 : : !! NOTES
5402 : : !! called by one processor only
5403 : : !!
5404 : : !! SOURCE
5405 : :
5406 : 1967 : subroutine dfpt_prtph(displ,eivec,enunit,iout,natom,phfrq,qphnrm,qphon)
5407 : :
5408 : : !Arguments -------------------------------
5409 : : !scalars
5410 : : integer,intent(in) :: eivec,enunit,iout,natom
5411 : : real(dp),intent(in) :: qphnrm
5412 : : !arrays
5413 : : real(dp),intent(in) :: displ(2,3*natom,3*natom),phfrq(3*natom),qphon(3)
5414 : :
5415 : : !Local variables -------------------------
5416 : : !scalars
5417 : : integer :: i,idir,ii,imode,jj
5418 : : real(dp) :: tolerance
5419 : : logical :: t_degenerate
5420 : : character(len=500) :: msg
5421 : : !arrays
5422 : : real(dp) :: vecti(3),vectr(3)
5423 : 3934 : character(len=1) :: metacharacter(3*natom)
5424 : : ! *********************************************************************
5425 : :
5426 : : !Check the value of eivec
5427 [ + - + + : 3829 : if (all(eivec /= [0,1,2,4])) then
- + ]
5428 : : write(msg, '(a,i0,a,a)' )&
5429 : 0 : 'In the calling subroutine, eivec is',eivec,ch10,&
5430 : 0 : 'but allowed values are between 0 and 4.'
5431 : 0 : ABI_BUG(msg)
5432 : : end if
5433 : :
5434 : : !write the phonon frequencies on unit std_out
5435 : 1967 : write(msg,'(4a)' )' ',ch10,' phonon wavelength (reduced coordinates) , ','norm, and energies in hartree'
5436 : 1967 : call wrtout(std_out,msg)
5437 : :
5438 : : !The next format should be rewritten
5439 : 1967 : write(msg,'(a,4f5.2)' )' ',(qphon(i),i=1,3),qphnrm
5440 : 1967 : call wrtout(std_out,msg)
5441 [ + - + + ]: 6726 : do jj=1,3*natom,5
5442 [ + + ]: 4759 : if (3*natom-jj<5) then
5443 : 1967 : write(msg,'(5es17.9)') (phfrq(ii),ii=jj,3*natom)
5444 : : else
5445 : 2792 : write(msg,'(5es17.9)') (phfrq(ii),ii=jj,jj+4)
5446 : : end if
5447 : 6726 : call wrtout(std_out,msg)
5448 : : end do
5449 [ + + ]: 20657 : write(msg,'(a,a,es17.9)') ch10,' Zero Point Motion energy (sum of freqs/2)=',sum(phfrq(1:3*natom))/2
5450 : 1967 : call wrtout(std_out,msg)
5451 : :
5452 : : !Put the wavevector in nice format
5453 [ + + ]: 1967 : if(iout>=0)then
5454 : 1931 : call wrtout(iout,' ')
5455 [ + + ]: 1931 : if(qphnrm/=0.0_dp)then
5456 : : write(msg, '(a,3f9.5)' )&
5457 [ + - + + ]: 6632 : ' Phonon wavevector (reduced coordinates) :',(qphon(i)/qphnrm+tol10,i=1,3)
5458 : : else
5459 : : write(msg, '(3a,3f9.5)' )&
5460 : 273 : ' Phonon at Gamma, with non-analyticity in the',ch10,&
5461 [ + + ]: 1365 : ' direction (cartesian coordinates)',qphon(1:3)+tol10
5462 : : end if
5463 : 1931 : call wrtout(iout,msg)
5464 : :
5465 : : ! Write it, in different units.
5466 [ + - ]: 1931 : if(enunit/=1)then
5467 : 1931 : write(iout, '(a)' )' Phonon energies in Hartree :'
5468 [ + - + + ]: 6582 : do jj=1,3*natom,5
5469 [ + + ]: 4651 : if (3*natom-jj<5) then
5470 : 1931 : write(msg, '(1x,5es14.6)') (phfrq(ii),ii=jj,3*natom)
5471 : : else
5472 : 2720 : write(msg, '(1x,5es14.6)') (phfrq(ii),ii=jj,jj+4)
5473 : : end if
5474 : 6582 : call wrtout(iout,msg)
5475 : : end do
5476 : : end if
5477 [ + + ]: 1931 : if(enunit/=0)then
5478 : 158 : write(iout, '(a)' )' Phonon energies in meV :'
5479 [ + - + + ]: 388 : do jj=1,3*natom,5
5480 [ + + ]: 230 : if (3*natom-jj<5) then
5481 [ + - + + ]: 488 : write(msg, '("-",5es14.6)') (phfrq(ii)*Ha_eV*1.0d3,ii=jj,3*natom)
5482 : : else
5483 [ + - + + ]: 432 : write(msg, '("-",5es14.6)') (phfrq(ii)*Ha_eV*1.0d3,ii=jj,jj+4)
5484 : : end if
5485 : 388 : call wrtout(iout,msg)
5486 : : end do
5487 : : end if
5488 [ + - ]: 1931 : if(enunit/=1)then
5489 : 1931 : write(iout, '(a)' )' Phonon frequencies in cm-1 :'
5490 [ + - + + ]: 6582 : do jj=1,3*natom,5
5491 [ + + ]: 4651 : if (3*natom-jj<5) then
5492 [ + - + + ]: 6577 : write(msg, '("-",5es14.6)') (phfrq(ii)*Ha_cmm1,ii=jj,3*natom)
5493 : : else
5494 [ + - + + ]: 16320 : write(msg, '("-",5es14.6)') (phfrq(ii)*Ha_cmm1,ii=jj,jj+4)
5495 : : end if
5496 : 6582 : call wrtout(iout,msg)
5497 : : end do
5498 : : end if
5499 [ + + ]: 1931 : if(enunit/=0)then
5500 : 158 : write(iout, '(a)' )' Phonon frequencies in Thz :'
5501 [ + - + + ]: 388 : do jj=1,3*natom,5
5502 [ + + ]: 230 : if (3*natom-jj<5) then
5503 [ + - + + ]: 488 : write(msg, '("-",5es14.6)') (phfrq(ii)*Ha_THz,ii=jj,3*natom)
5504 : : else
5505 [ + - + + ]: 432 : write(msg, '("-",5es14.6)') (phfrq(ii)*Ha_THz,ii=jj,jj+4)
5506 : : end if
5507 : 388 : call wrtout(iout,msg)
5508 : : end do
5509 : : end if
5510 [ + + ]: 1931 : if(enunit/=0.and.enunit/=1)then
5511 : 158 : write(iout, '(a)' )' Phonon energies in Kelvin :'
5512 [ + - + + ]: 388 : do jj=1,3*natom,5
5513 [ + + ]: 230 : if (3*natom-jj<5) then
5514 [ + - + + ]: 488 : write(msg, '("-",5es14.6)') (phfrq(ii)/kb_HaK,ii=jj,3*natom)
5515 : : else
5516 [ + - + + ]: 432 : write(msg, '("-",5es14.6)') (phfrq(ii)/kb_HaK,ii=jj,jj+4)
5517 : : end if
5518 : 388 : call wrtout(iout,msg)
5519 : : end do
5520 : : end if
5521 : : end if
5522 : :
5523 : : !Take care of the eigendisplacements
5524 [ + + ]: 1967 : if(eivec==1 .or. eivec==2)then
5525 : 83 : write(msg, '(a,a,a,a,a,a,a,a)' ) ch10,&
5526 : 83 : ' Eigendisplacements ',ch10,&
5527 : 83 : ' (will be given, for each mode : in cartesian coordinates',ch10,&
5528 : 83 : ' for each atom the real part of the displacement vector,',ch10,&
5529 : 166 : ' then the imaginary part of the displacement vector - absolute values smaller than 1.0d-7 are set to zero)'
5530 : 83 : call wrtout(std_out,msg)
5531 [ + - ]: 83 : if(iout>=0) then
5532 : 83 : call wrtout(iout,msg)
5533 : : end if
5534 : :
5535 : : ! Examine the degeneracy of each mode. The portability of the echo of the eigendisplacements
5536 : : ! is very hard to obtain, and has not been attempted.
5537 [ + + ]: 452 : do imode=1,3*natom
5538 : : ! The degenerate modes are not portable
5539 : 369 : t_degenerate=.false.
5540 [ + + ]: 369 : if(imode>1)then
5541 [ + + ]: 286 : if(phfrq(imode)-phfrq(imode-1)<tol6)t_degenerate=.true.
5542 : : end if
5543 [ + + ]: 369 : if(imode<3*natom)then
5544 [ + + ]: 286 : if(phfrq(imode+1)-phfrq(imode)<tol6)t_degenerate=.true.
5545 : : end if
5546 [ + + ]: 452 : metacharacter(imode)=';'; if(t_degenerate)metacharacter(imode)='-'
5547 : : end do
5548 : :
5549 [ + + ]: 452 : do imode=1,3*natom
5550 : 369 : write(msg,'(a,i4,a,es16.6)' )' Mode number ',imode,' Energy',phfrq(imode)
5551 : 369 : call wrtout(std_out,msg)
5552 [ + - ]: 369 : if(iout>=0)then
5553 : 369 : write(msg, '(a,i4,a,es16.6)' )' Mode number ',imode,' Energy',phfrq(imode)
5554 : 369 : call wrtout(iout,msg)
5555 : : end if
5556 : 369 : tolerance=1.0d-7
5557 [ + + ]: 369 : if(abs(phfrq(imode))<1.0d-5)tolerance=2.0d-7
5558 [ + + ]: 369 : if(phfrq(imode)<1.0d-5)then
5559 : 202 : write(msg,'(3a)' )' Attention : low frequency mode.',ch10,&
5560 : 404 : ' (Could be unstable or acoustic mode)'
5561 : 202 : call wrtout(std_out,msg)
5562 [ + - ]: 202 : if(iout>=0)then
5563 : 202 : write(iout, '(3a)' )' Attention : low frequency mode.',ch10,&
5564 : 404 : ' (Could be unstable or acoustic mode)'
5565 : : end if
5566 : : end if
5567 [ + + ]: 1277 : do ii=1,natom
5568 [ + + ]: 3300 : do idir=1,3
5569 : 2475 : vectr(idir)=displ(1,idir+(ii-1)*3,imode)
5570 [ + + ]: 2475 : if(abs(vectr(idir))<tolerance)vectr(idir)=0.0_dp
5571 : 2475 : vecti(idir)=displ(2,idir+(ii-1)*3,imode)
5572 [ + - ]: 3300 : if(abs(vecti(idir))<tolerance)vecti(idir)=0.0_dp
5573 : : end do
5574 : 825 : write(msg,'(i4,3es16.8,a,4x,3es16.8)' ) ii,vectr(:),ch10,vecti(:)
5575 : 825 : call wrtout(std_out,msg)
5576 [ + - ]: 1194 : if(iout>=0)then
5577 : 825 : write(msg,'(a,i3,3es16.8,2a,3x,3es16.8)') metacharacter(imode),ii,vectr(:),ch10,&
5578 : 1650 : metacharacter(imode), vecti(:)
5579 : 825 : call wrtout(iout,msg)
5580 : : end if
5581 : : end do
5582 : : end do
5583 : : end if
5584 : :
5585 : 1967 : end subroutine dfpt_prtph
5586 : : !!***
5587 : :
5588 : : !!****f* m_dynmat/massmult_and_breaksym
5589 : : !! NAME
5590 : : !! mult_masses_and_break_symms
5591 : : !!
5592 : : !! FUNCTION
5593 : : !! Multiply the IFC(q) by the atomic masses, slightly break symmetry to make tests more
5594 : : !! portable and make the matrix hermitian before returning.
5595 : : !!
5596 : : !! INPUTS
5597 : : !! amu(ntypat)=mass of the atoms (atomic mass unit) matrix (diagonal in the atoms)
5598 : : !! natom=number of atoms in unit cell
5599 : : !! ntypat=number of atom types
5600 : : !! typat(natom)=integer label of each type of atom (1,2,...)
5601 : : !! [herm_opt]= 1 to hermitianize mat (default)
5602 : : !! 0 if no symmetrization should be performed
5603 : : !!
5604 : : !! SIDE EFFECTS
5605 : : !! mat(2*3*natom*3*natom)=Multiplies by atomic masses in output.
5606 : : !!
5607 : : !! SOURCE
5608 : :
5609 : 645355 : subroutine massmult_and_breaksym(natom, ntypat, typat, amu, mat, &
5610 : : herm_opt) ! optional
5611 : :
5612 : : !Arguments -------------------------------
5613 : : !scalars
5614 : : integer,intent(in) :: natom,ntypat
5615 : : integer,optional,intent(in) :: herm_opt
5616 : : !arrays
5617 : : integer,intent(in) :: typat(natom)
5618 : : real(dp),intent(in) :: amu(ntypat)
5619 : : real(dp),intent(inout) :: mat(2*3*natom*3*natom)
5620 : :
5621 : : !Local variables -------------------------
5622 : : !scalars
5623 : : integer :: i1,i2,idir1,idir2,index,ipert1,ipert2, herm_opt__
5624 : : real(dp),parameter :: break_symm=1.0d-12
5625 : : !real(dp),parameter :: break_symm=zero
5626 : : real(dp) :: fac
5627 : : !arrays
5628 : : real(dp) :: nearidentity(3,3)
5629 : : ! *********************************************************************
5630 : :
5631 [ - + ]: 645355 : herm_opt__ = 1; if (present(herm_opt)) herm_opt__ = herm_opt
5632 : :
5633 : : ! This slight breaking of the symmetry allows the results to be more portable between machines
5634 [ + + + + ]: 8389615 : nearidentity(:,:)=one
5635 : 645355 : nearidentity(1,1)=one+break_symm
5636 : 645355 : nearidentity(3,3)=one-break_symm
5637 : :
5638 : : ! Include the masses in the dynamical matrix
5639 [ + + ]: 1874445 : do ipert1=1,natom
5640 [ + + ]: 4756199 : do ipert2=1,natom
5641 : 2881754 : fac=1.0_dp/sqrt(amu(typat(ipert1))*amu(typat(ipert2)))/amu_emass
5642 [ + + ]: 12756106 : do idir1=1,3
5643 [ + + ]: 37462802 : do idir2=1,3
5644 : 25935786 : i1=idir1+(ipert1-1)*3
5645 : 25935786 : i2=idir2+(ipert2-1)*3
5646 : 25935786 : index=i1+3*natom*(i2-1)
5647 : 25935786 : mat(2*index-1)=mat(2*index-1)*fac*nearidentity(idir1,idir2)
5648 : 25935786 : mat(2*index )=mat(2*index )*fac*nearidentity(idir1,idir2)
5649 : : ! This is to break slightly the translation invariance, and make the automatic tests more portable
5650 [ + + ]: 34581048 : if(ipert1==ipert2 .and. idir1==idir2)then
5651 : 3687270 : mat(2*index-1)=mat(2*index-1)+break_symm*natom/amu_emass/idir1*0.01_dp
5652 : : end if
5653 : : end do
5654 : : end do
5655 : : end do
5656 : : end do
5657 : :
5658 : : ! Make the dynamical matrix hermitian
5659 [ + - ]: 645355 : if (herm_opt__ == 1) call mkherm(mat,3*natom)
5660 : :
5661 : 645355 : end subroutine massmult_and_breaksym
5662 : : !!***
5663 : :
5664 : : !!****f* m_dynmat/massmult_and_breaksym_cplx
5665 : : !! NAME
5666 : : !! mult_masses_and_break_symms_cplx
5667 : : !!
5668 : : !! FUNCTION
5669 : : !! Similar to massmult_and_breaksym, the only difference is that it receives complex array.
5670 : :
5671 : 0 : subroutine massmult_and_breaksym_cplx(natom, ntypat, typat, amu, cmat, &
5672 : : herm_opt) ! optional
5673 : :
5674 : : !Arguments -------------------------------
5675 : : !scalars
5676 : : integer,intent(in) :: natom,ntypat
5677 : : integer,optional,intent(in) :: herm_opt
5678 : : !arrays
5679 : : integer,intent(in) :: typat(natom)
5680 : : real(dp),intent(in) :: amu(ntypat)
5681 : : complex(dp),target,intent(inout) :: cmat(2*3*natom*3*natom)
5682 : :
5683 : : !Local variables -------------------------
5684 : : integer :: herm_opt__
5685 : : real(dp),pointer :: rmat_ptr(:)
5686 : : ! *************************************************************************
5687 : :
5688 [ # # ]: 0 : call C_F_pointer(c_loc(cmat), rmat_ptr, shape=[3*natom*3*natom])
5689 [ # # ]: 0 : herm_opt__ = 1; if (present(herm_opt)) herm_opt__ = herm_opt
5690 [ # # ]: 0 : call massmult_and_breaksym(natom, ntypat, typat, amu, rmat_ptr, herm_opt=herm_opt__)
5691 : :
5692 : 0 : end subroutine massmult_and_breaksym_cplx
5693 : : !!***
5694 : :
5695 : : !!****f* m_dynmat/ftgam
5696 : : !! NAME
5697 : : !! ftgam
5698 : : !!
5699 : : !! FUNCTION
5700 : : !! If qtor=1 (q->r):
5701 : : !! Generates the Fourier transform of the recip space gkk matrices
5702 : : !! to obtain the real space ones.
5703 : : !! If qtor=0 (r->q):
5704 : : !! Generates the Fourier transform of the real space gkk matrices
5705 : : !! to obtain the reciprocal space ones.
5706 : : !!
5707 : : !! INPUTS
5708 : : !! natom= Number of atoms in the unit cell
5709 : : !! nqpt= Number of q points in the Brillouin zone
5710 : : !! if qtor=0 this number is read in the input file
5711 : : !! nrpt= Number of R points in the Big Box
5712 : : !! qtor= ( q to r : see above )
5713 : : !! rpt(3,nprt)= Canonical coordinates of the R points in the unit cell
5714 : : !! These coordinates are normalized (=> * acell(3)!!)
5715 : : !! qpt_full(3,nqpt)= Reduced coordinates of the q vectors in reciprocal space
5716 : : !! if qtor=0 these vectors are read in the input file
5717 : : !! wghatm(natom,natom,nrpt)= Weights associated to a pair of atoms and to a R vector
5718 : : !!
5719 : : !! OUTPUT
5720 : : !! (see side effects)
5721 : : !!
5722 : : !! SIDE EFFECTS
5723 : : !! Input/output
5724 : : !! gam_qpt(2,3*natom*3*natom,nqpt)
5725 : : !! = gamma matrices in recip space coming from the Derivative Data Base
5726 : : !! gam_rpt(2,3*natom*3*natom,nrpt)
5727 : : !! = gamma matrices in real space stored in file unit_gkk_rpt
5728 : : !!
5729 : : !! NOTES
5730 : : !! copied from ftiaf9.f
5731 : : !! recip to real space: real space is forced to disk file unit_gkk_rpt
5732 : : !! recip space depends on gkqwrite and unitgkq3
5733 : : !! real to recip space: real space is forced to disk file unit_gkk_rpt
5734 : : !! recip space is necessarily in memory in gkk_qpt
5735 : : !!
5736 : : !! real space elements are complex, but could be reduced, as (-r) = (+r)*
5737 : : !!
5738 : : !! SOURCE
5739 : :
5740 : 26898 : subroutine ftgam (wghatm,gam_qpt,gam_rpt,natom,nqpt,nrpt,qtor,coskr, sinkr)
5741 : :
5742 : : !Arguments -------------------------------
5743 : : !scalars
5744 : : integer,intent(in) :: natom,nqpt,nrpt,qtor
5745 : : !arrays
5746 : : real(dp),intent(in) :: wghatm(natom,natom,nrpt)
5747 : : real(dp),intent(inout) :: gam_qpt(2,3*natom*3*natom,nqpt)
5748 : : real(dp),intent(inout) :: gam_rpt(2,3*natom*3*natom,nrpt)
5749 : : real(dp),intent(in) :: coskr(nqpt,nrpt)
5750 : : real(dp),intent(in) :: sinkr(nqpt,nrpt)
5751 : :
5752 : : !Local variables -------------------------
5753 : : !scalars
5754 : : integer :: iatom,idir,ip,iqpt,irpt,jatom,jdir
5755 : : real(dp) :: im,re
5756 : : character(len=500) :: msg
5757 : : ! *********************************************************************
5758 : :
5759 : 26898 : select case (qtor)
5760 : : case (1)
5761 : : ! Recip to real space
5762 [ + + + + : 428974 : gam_rpt(:,:,:) = zero
+ + ]
5763 [ + + ]: 11392 : do irpt=1,nrpt
5764 [ + + ]: 1387296 : do iqpt=1,nqpt
5765 : : ! Get the phase factor with normalization!
5766 : 1375904 : re=coskr(iqpt,irpt)
5767 : 1375904 : im=sinkr(iqpt,irpt)
5768 [ + + ]: 14078031 : do ip=1,3*natom*3*natom
5769 : : ! Real and imaginary part of the real-space gam matrices
5770 : 12690936 : gam_rpt(1,ip,irpt) = gam_rpt(1,ip,irpt) + re*gam_qpt(1,ip,iqpt) + im*gam_qpt(2,ip,iqpt)
5771 : 14066840 : gam_rpt(2,ip,irpt) = gam_rpt(2,ip,irpt) + re*gam_qpt(2,ip,iqpt) - im*gam_qpt(1,ip,iqpt)
5772 : : end do
5773 : : end do
5774 : : end do
5775 [ + + + + : 428974 : gam_rpt = gam_rpt/nqpt
+ + ]
5776 : :
5777 : : case (0)
5778 : : ! Recip space from real space
5779 [ + + + + : 1073346 : gam_qpt(:,:,:)=zero
+ + ]
5780 : :
5781 [ + + ]: 1590618 : do irpt=1,nrpt
5782 [ + + ]: 3154539 : do iqpt=1,nqpt
5783 : :
5784 [ + + ]: 4784088 : do iatom=1,natom
5785 [ + + ]: 5061063 : do jatom=1,natom
5786 : 1840896 : re = coskr(iqpt,irpt)*wghatm(iatom,jatom,irpt)
5787 : 1840896 : im = sinkr(iqpt,irpt)*wghatm(iatom,jatom,irpt)
5788 : :
5789 [ + + ]: 9019830 : do idir=1,3
5790 [ + + ]: 23931648 : do jdir=1,3
5791 : : ! Get phase factor
5792 : :
5793 : 16568064 : ip= jdir + (jatom-1)*3 + (idir-1)*3*natom + (iatom-1)*9*natom
5794 : : ! Real and imaginary part of the interatomic forces
5795 : 16568064 : gam_qpt(1,ip,iqpt) = gam_qpt(1,ip,iqpt) + re*gam_rpt(1,ip,irpt) - im*gam_rpt(2,ip,irpt)
5796 : 22090752 : gam_qpt(2,ip,iqpt) = gam_qpt(2,ip,iqpt) + im*gam_rpt(1,ip,irpt) + re*gam_rpt(2,ip,irpt)
5797 : : end do ! end jdir
5798 : : end do ! end idir
5799 : : end do
5800 : : end do ! end iatom
5801 : :
5802 : : end do ! end iqpt
5803 : : end do ! end irpt
5804 : :
5805 : : case default
5806 : 0 : write(msg,'(a,i0,a)' )'The only allowed values for qtor are 0 or 1, while qtor= ',qtor,' has been required.'
5807 [ + + - ]: 26898 : ABI_BUG(msg)
5808 : : end select
5809 : :
5810 : 26898 : end subroutine ftgam
5811 : : !!***
5812 : :
5813 : : !!****f* m_dynmat/ftgam_init
5814 : : !!
5815 : : !! NAME
5816 : : !! ftgam_init
5817 : : !!
5818 : : !! FUNCTION
5819 : : !! Generates the sin and cos phases for the Fourier transform of the gkk matrices
5820 : : !!
5821 : : !! INPUTS
5822 : : !! gprim = reciprocal space vectors to get cartesian coord for qpt
5823 : : !! nqpt= Number of q points in the Brillouin zone
5824 : : !! nrpt= Number of R points in the Big Box
5825 : : !! rpt(3,nprt)= Canonical coordinates of the R points in the unit cell
5826 : : !! These coordinates are normalized (=> * acell(3)!!)
5827 : : !! qpt_full(3,nqpt)= Reduced coordinates of the q vectors in reciprocal space
5828 : : !! if qtor=0 these vectors are read in the input file
5829 : : !!
5830 : : !! OUTPUT
5831 : : !! coskr, sinkr = cosine and sine of phase factors for given r and q points
5832 : : !!
5833 : : !! SOURCE
5834 : :
5835 : 1715 : subroutine ftgam_init (gprim,nqpt,nrpt,qpt_full,rpt,coskr, sinkr)
5836 : :
5837 : : !Arguments -------------------------------
5838 : : !scalars
5839 : : integer,intent(in) :: nqpt,nrpt
5840 : : !arrays
5841 : : real(dp),intent(in) :: gprim(3,3),rpt(3,nrpt),qpt_full(3,nqpt)
5842 : : real(dp),intent(out) :: coskr(nqpt,nrpt)
5843 : : real(dp),intent(out) :: sinkr(nqpt,nrpt)
5844 : :
5845 : : !Local variables -------------------------
5846 : : !scalars
5847 : : integer :: iqpt,irpt
5848 : : real(dp) :: kr
5849 : : !arrays
5850 : : real(dp) :: kk(3)
5851 : : ! *********************************************************************
5852 : :
5853 : : ! Prepare the phase factors
5854 [ + + ]: 10311 : do iqpt=1,nqpt
5855 : : ! Calculation of the k coordinates in Normalized Reciprocal coordinates
5856 [ + + + + ]: 111748 : kk(:) = matmul(gprim,qpt_full(:,iqpt))
5857 [ + + ]: 417383 : do irpt=1,nrpt
5858 : : ! Product of k and r
5859 [ + + ]: 1628288 : kr =dot_product(kk,rpt(:,irpt))
5860 : 407072 : coskr(iqpt,irpt)=cos(two_pi*kr)
5861 : 415668 : sinkr(iqpt,irpt)=sin(two_pi*kr)
5862 : : end do
5863 : : end do
5864 : :
5865 : 1715 : end subroutine ftgam_init
5866 : : !!***
5867 : :
5868 : : !----------------------------------------------------------------------
5869 : :
5870 : : !!****f* m_dynmat/msria_calc
5871 : : !! NAME
5872 : : !! msria_calc
5873 : : !!
5874 : : !! FUNCTION
5875 : : !! Calculate the corrections on the zone-center IFCs and their derivatives with respect to the phonon
5876 : : !! wavevector q to achieve both translational (acoustic sum rule) and rotational invariances,
5877 : : !! i.e. there is not remanent forces on the atoms if they are moved or rotated globablly.
5878 : : !! This function needs the dimensionality of the system (0D, 1D, 2D, ...) to work properly, as well
5879 : : !! as the moment of the IFCs, i.e. Phi^(1). It can be obtained by a long wave calculation
5880 : : !! or with the Fourier transform. Be careful for the second option that the non-analytical part
5881 : : !! is not (yet) treated for the 1D and 2D cases; ideally this routine should only impacts the
5882 : : !! short-range IFCs (and the long-range subtracted before entering this routine)
5883 : : !!
5884 : : !! INPUTS
5885 : : !! asr=(6 Impose accoustic sum rules + rotational invariance)
5886 : : !! crystal<type(crystal_t)>=Crystal structure parameters
5887 : : !! d2cart(2,3,natom,3,natom)= Dynamical matrices coming from the Derivative Data Base at Gamma
5888 : : !! d2dq (3,natom,3,natom,3): moment of IFCs (Phi^(1)) in cartesian coordinates
5889 : : !! sys_dim=System dimensionality (0D, 1D, ...) used for rotational invariance
5890 : : !! mpert =maximum number of ipert
5891 : : !! natom=number of atom
5892 : : !!
5893 : : !! OUTPUT
5894 : : !! d2asr= (2,3,natom,3,natom) matrix used to store the correction needed to fulfill
5895 : : !! the acoustic + rotational sum rule on IFCs.
5896 : : !! d2dqmsr= (3,natom,3,natom,3) matrix used to store the correction on IFCs moments
5897 : : !!
5898 : : !! SOURCE
5899 : :
5900 : : !!***
5901 : : !
5902 : 2 : subroutine msria_calc(asr,crystal,d2asr,d2cart,d2dq,d2dqdq,d2dqmsr,d2dqdqmsr,sys_dim,mpert,natom)
5903 : : !Arguments ------------------------------------
5904 : : !scalars
5905 : : integer,intent(in) :: sys_dim,asr,mpert,natom
5906 : : type(crystal_t),intent(in) :: crystal
5907 : : !arrays
5908 : : real(dp),intent(in) :: d2cart(2,3,mpert,3,mpert)
5909 : : real(dp),intent(in) :: d2dq(3,natom,3,natom,3)
5910 : : real(dp),intent(in) :: d2dqdq(3,natom,3,3,3)
5911 : : real(dp),intent(out) :: d2asr(2,3,natom,3,natom)
5912 : : real(dp),intent(out) :: d2dqmsr(3,natom,3,natom,3)
5913 : : real(dp),intent(out) :: d2dqdqmsr(3,natom,3,natom,3,3)
5914 : : !Local variables-------------------------------
5915 : : !scalars
5916 : : integer :: idir1,idir2,idir3,idir4,idir5,info,ipert1,ipert2,col,ncol,nrow,row
5917 : : character(len=500) :: msg,msg2
5918 : : integer :: bool_kdir(3), bool_ldir(3)
5919 : : !arrays
5920 : 4 : real(dp) :: tmp,tmp2,Levi_Civita(3,3,3), d2dqdqcart(3,natom,3,natom,3,3)
5921 : 4 : real(dp) :: d2dqred(3,natom,3,natom,3),d2dqdqred(3,natom,3,natom,3,3)
5922 : 2 : real(dp),allocatable :: msr(:,:,:),msr_init(:,:,:)
5923 : 2 : real(dp),allocatable :: d2cart_vec(:),rcond(:,:),cond(:)
5924 : 2 : real(dp),allocatable :: mat_tmp(:,:),mat_tmp2(:,:),mat_tmp3(:,:),d2cart_sol(:),umat(:,:),vtmat(:,:)
5925 : 2 : real(dp),allocatable :: vmat(:,:),sing(:),work(:),sing1(:,:),sing2(:,:)
5926 : :
5927 : : ! *********************************************************************
5928 [ - + ]: 2 : if(asr/=6)then
5929 : : write(msg,'(3a,i0)')&
5930 : 0 : 'The argument asr should be 6,',ch10, 'however, asr = ',asr
5931 : 0 : ABI_BUG(msg)
5932 : : end if
5933 : :
5934 [ + - ]: 2 : if (asr==6)then
5935 : 2 : write(msg, '(a,a,a,a,a,a,a,a)' ) ch10, &
5936 : 2 : ' Imposition of the ASR + rotational invariance for the interatomic forces (AMSR)', ch10, &
5937 : 2 : ' Rotational invariance impose conditions on the IFCs moments and their derivatives',ch10,&
5938 : 2 : ' At the moment, because of missing long-range contributions to the second IFCs derivatives',ch10,&
5939 : 4 : ' rotational invariance is only imposed on the first-derivatives (first-order condition)'
5940 : 2 : call wrtout(std_out,msg)
5941 : : end if
5942 : 2 : bool_kdir = 0
5943 : 2 : bool_ldir = 0
5944 : : ! When periodic, additional variable spaces coming from dynamical matrices derivatives
5945 [ - - - + : 2 : if (sys_dim == 1) then ! 3D
- - - +
- ]
5946 [ # # ]: 0 : bool_kdir = 0 ; bool_ldir = 1
5947 : 0 : msg2=' 3D treatment'
5948 : : elseif (sys_dim == 2) then ! 2D yz
5949 : 0 : bool_kdir(1) = 1 ; bool_ldir(2) = 1 ; bool_ldir(3) = 1
5950 : 0 : msg2=' 2D with x as out-of-plane direction'
5951 : : elseif (sys_dim == 3) then ! 2D xz
5952 : 0 : bool_kdir(2) = 1 ; bool_ldir(1) = 1 ; bool_ldir(3) = 1
5953 : 0 : msg2=' 2D with y as out-of-plane direction'
5954 : : elseif (sys_dim == 4) then ! 2D xy
5955 : 1 : bool_kdir(3) = 1 ; bool_ldir(1) = 1 ; bool_ldir(2) = 1
5956 : 1 : msg2=' 2D with z as out-of-plane direction'
5957 : : elseif (sys_dim == 5) then ! 1D x
5958 : 0 : bool_kdir(2) = 1 ; bool_kdir(3) = 1 ; bool_ldir(1) = 1
5959 : 0 : msg2=' 1D with x as periodic direction'
5960 : : elseif (sys_dim == 6) then ! 1D y
5961 : 0 : bool_kdir(1) = 1 ; bool_kdir(2) = 1 ; bool_ldir(2) = 1
5962 : 0 : msg2=' 1D with y as periodic direction'
5963 : : elseif (sys_dim == 7) then ! 1D z
5964 : 0 : bool_kdir(1) = 1 ; bool_kdir(2) = 1 ; bool_ldir(3) = 1
5965 : 0 : msg2=' 1D with z as periodic direction'
5966 : : elseif (sys_dim == 8) then ! Molecule
5967 [ + + ]: 4 : bool_kdir = 1 ; bool_ldir = 0
5968 : 1 : msg2=' 0D treatment (molecules)'
5969 : : else
5970 : : write(msg,'(3a,i0)')&
5971 : 0 : 'The argument sys_dim should be between 1 and 8,',ch10, 'however, sys_dim = ',sys_dim
5972 : 0 : ABI_BUG(msg)
5973 : : end if
5974 : :
5975 : 2 : write(msg, '(a,a)' ) ch10, trim(msg2)
5976 : 2 : call wrtout(std_out,msg)
5977 : :
5978 : : ! Matrix sizing for pseudoinverse and alocation of corresponding matrix
5979 : 2 : nrow = 3+2*3*3*natom ! 9*natom conditions for ASR, 9*natom+3 conditions for MSR
5980 : 2 : nrow = nrow +4*(3*natom)**2 ! + Hermiticity
5981 : :
5982 : : ncol = (3*natom)**2 ! 9*natom**2 variable workspace (for dynamical matrices, initial)
5983 : : ncol = ncol + 3*(3*natom)**2 ! Aditional variable space coming from dD/dq (only for periodic systems)
5984 : 2 : ncol = ncol + 9*(3*natom)**2 ! d2D/dqdq
5985 [ - + + - : 8 : ABI_MALLOC(msr,(1:3,1:natom,1:3))
+ - + - +
- - + -
+ ]
5986 [ - + + - : 4 : ABI_MALLOC(msr_init,(1:3,1:natom,1:3))
- + - + ]
5987 [ - + + - : 6 : ABI_MALLOC(d2cart_vec,(1:ncol))
+ - + - -
+ - + ]
5988 [ - + + - : 4 : ABI_MALLOC(d2cart_sol,(1:ncol))
- + - + ]
5989 [ - + + - : 6 : ABI_MALLOC(cond,(1:nrow))
+ - + - -
+ - + ]
5990 [ - + + - : 8 : ABI_MALLOC(rcond,(1:nrow,1:ncol))
- + + - +
- + - - +
- + ]
5991 [ + + ]: 2927 : d2cart_vec=0d0
5992 [ + + ]: 2927 : d2cart_sol=0d0
5993 [ + + ]: 1034 : cond = 0d0
5994 [ + + + + ]: 1622792 : rcond = 0d0
5995 : :
5996 : 2 : Levi_Civita(:,:,:)=zero
5997 : 2 : Levi_Civita(1,2,3)=+1 ; Levi_Civita(2,3,1)=+1 ; Levi_Civita(3,1,2)=+1
5998 : 2 : Levi_Civita(3,2,1)=-1 ; Levi_Civita(1,3,2)=-1 ; Levi_Civita(2,1,3)=-1
5999 : :
6000 : : ! We only have access to \sum d^2 Phi(kappa alpha, kappa' beta)/dqdq through the
6001 : : ! long-wavelength driver, we need to construct the full tensor. Here we split
6002 : : ! an equal contribution on all atoms
6003 [ + + + + : 2978 : d2dqdqcart(:,:,:,:,:,:)=zero
+ + + + +
+ + + ]
6004 [ + + ]: 9 : do ipert1=1,natom
6005 [ + + ]: 30 : do idir1=1,3
6006 [ + + ]: 91 : do idir2=1,3
6007 [ + + ]: 309 : do ipert2=1,natom
6008 [ + + ]: 963 : do idir3=1,3
6009 : : d2dqdqcart(idir1,ipert1,idir2,ipert1,idir3,idir3)=&
6010 : 900 : -two*d2dqdq(idir1,ipert1,idir2,idir3,idir3)/dble(natom)
6011 : : end do
6012 : : end do
6013 : : end do
6014 : : end do
6015 : : end do
6016 : : ! Convert d2dq and d2dqdq in relative coordinates with respect to q
6017 [ + + + + : 992 : d2dqred = zero
+ + + + +
+ ]
6018 [ + + + + : 2978 : d2dqdqred = zero
+ + + + +
+ + + ]
6019 [ + + ]: 8 : do idir1=1,3
6020 [ + + ]: 26 : do idir2=1,3
6021 [ + + + + : 2970 : d2dqred(:,:,:,:,idir1)=d2dqred(:,:,:,:,idir1)+d2dq(:,:,:,:,idir2)*crystal%gprimd(idir2,idir1)
+ + + + ]
6022 [ + + ]: 78 : do idir3=1,3
6023 [ + + ]: 234 : do idir4=1,3
6024 : : d2dqdqred(:,:,:,:,idir2,idir4)=d2dqdqred(:,:,:,:,idir2,idir4)+&
6025 [ + + + + : 26784 : d2dqdqcart(:,:,:,:,idir1,idir3)*crystal%gprimd(idir1,idir2)*crystal%gprimd(idir3,idir4)
+ + + + ]
6026 : : end do
6027 : : end do
6028 : : end do
6029 : : end do
6030 : : ! Now building the condition matrix
6031 [ + + ]: 8 : do idir1=1,3
6032 [ + + ]: 29 : do ipert1=1,natom
6033 [ + + ]: 90 : do idir2=1,3
6034 [ + + ]: 309 : do ipert2=1,natom
6035 : 225 : col= ipert2+natom*(idir2-1)+3*natom*(ipert1-1)+3*natom**2*(idir1-1)
6036 : 225 : d2cart_vec(col) = d2cart(1,idir1,ipert1,idir2,ipert2)
6037 : 225 : row= idir2+3*(ipert1-1)+3*natom*(idir1-1) ! Acoustic sum rule
6038 : 225 : rcond(row,col) = one ! Sum of IFCs along ipert2 = 0
6039 : : ! Rotational invariance
6040 [ + + ]: 900 : do idir3=1,3
6041 : : ! Treat separately confined and periodic directions
6042 [ + + ]: 675 : if ( bool_kdir(idir3) == 1) then ! confined direction
6043 [ + + ]: 1548 : do idir4 = 1,3
6044 : 1161 : col= ipert2+natom*(idir2-1)+3*natom*(ipert1-1)+3*natom**2*(idir1-1)
6045 : 1161 : row = 9*natom+idir4+3*(ipert1-1)+3*natom*(idir1-1)
6046 : : rcond(row,col) = rcond(row,col)+ & ! first moment of IFCs
6047 : 1548 : (crystal%xcart(idir3,ipert2)-crystal%xcart(idir3,ipert1))*Levi_Civita(idir2,idir3,idir4)
6048 : : end do
6049 : : ! Conditions on the second moments of IFCs
6050 : : ! In molecules, already fulfilled with rotational invariance
6051 : : ! For 1D systems, should only consider pair of direction when 1 is
6052 : : ! periodic, the other is not. Currently desactivated
6053 : : if (idir1 == idir2 .and. bool_ldir(idir1) ==1) then !
6054 : : col= ipert2+natom*(idir2-1)+3*natom*(ipert1-1)+3*natom**2*(idir1-1)
6055 : : row = 2*9*natom+idir2 ! second moment of IFCs
6056 : : ! Currently desactivated because long-range electrostatics, only need to uncomment
6057 : : ! when it will be available.
6058 : : !rcond(row,col) = -(crystal%xcart(idir3,ipert2)-crystal%xcart(idir3,ipert1))**2
6059 : : col= ipert1+natom*(idir1-1)+3*natom*(ipert2-1)+3*natom**2*(idir2-1)
6060 : : !rcond(row,col) = -(crystal%xcart(idir3,ipert2)-crystal%xcart(idir3,ipert1))**2
6061 : : end if
6062 : : end if
6063 [ + + ]: 900 : if ( bool_ldir(idir3) == 1 ) then ! periodic direction
6064 : : ! Initialize the IFCs derivatives
6065 : 288 : col= (3*natom)**2*idir3+ipert2+natom*(idir2-1)+3*natom*(ipert1-1)+3*natom**2*(idir1-1)
6066 : 288 : d2cart_vec(col) = d2dqred(idir1,ipert1,idir2,ipert2,idir3)
6067 [ + + ]: 1152 : do idir5 = 1,3
6068 [ + + ]: 3744 : do idir4 = 1,3
6069 : 2592 : row = 9*natom+idir4+3*(ipert1-1)+3*natom*(idir1-1)
6070 : 3456 : rcond(row,col) = rcond(row,col)+ Levi_Civita(idir2,idir5,idir4)*crystal%rprimd(idir5,idir3)!/two_pi
6071 : : end do
6072 : : end do
6073 [ + + ]: 1152 : do idir4=1,3
6074 : 288 : if ( bool_ldir(idir4) == 1 ) then ! periodic direction
6075 : : col= 4*(3*natom)**2+(3*natom)**2*3*(idir4-1)+&
6076 : 864 : (3*natom)**2*(idir3-1)+ipert2+natom*(idir2-1)+3*natom*(ipert1-1)+3*natom**2*(idir1-1)
6077 : : !d2cart_vec(col) = d2dqdqred(idir1,ipert1,idir2,ipert2,idir3,idir4)
6078 : : end if
6079 : : end do
6080 [ + + + + ]: 288 : if (idir2 == idir1 .and. bool_kdir(idir1)==1) then
6081 [ + + ]: 128 : do idir4=1,3
6082 : : col= 4*(3*natom)**2+(3*natom)**2*3*(idir4-1)+&
6083 : 96 : (3*natom)**2*(idir4-1)+ipert2+natom*(idir1-1)+3*natom*(ipert1-1)+3*natom**2*(idir1-1)
6084 : 96 : row = 2*9*natom+idir3 ! second moment of IFCs
6085 : : !rcond(row,col) = crystal%rprimd(idir4,idir3)**2!/two_pi
6086 : : col= 4*(3*natom)**2+(3*natom)**2*3*(idir4-1)+&
6087 : 128 : (3*natom)**2*(idir4-1)+ipert1+natom*(idir1-1)+3*natom*(ipert2-1)+3*natom**2*(idir1-1)
6088 : : !rcond(row,col) = crystal%rprimd(idir4,idir3)**2!/two_pi
6089 : : end do
6090 : : end if
6091 : : end if
6092 : : end do
6093 : : ! Additionally, add the condition of matrix Hermiticity, both on IFCs and their derivatives
6094 : 225 : col= ipert2+natom*(idir2-1)+3*natom*(ipert1-1)+3*natom**2*(idir1-1)
6095 : 225 : row= 3+2*(9*natom)+ipert2+natom*(idir2-1)+3*natom*(ipert1-1)+3*natom**2*(idir1-1)
6096 : 225 : rcond(row,col) = rcond(row,col)+ one ! Hermicity
6097 : 225 : col= ipert1+natom*(idir1-1)+3*natom*(ipert2-1)+3*natom**2*(idir2-1)
6098 : 225 : rcond(row,col) = rcond(row,col)- one ! Hermicity
6099 [ + + ]: 963 : do idir3=1,3
6100 : 675 : row= 3+2*(9*natom)+ipert2+natom*(idir2-1)+3*natom*(ipert1-1)+3*natom**2*(idir1-1)+9*natom**2*(idir3)
6101 : 675 : col= (3*natom)**2*idir3+ipert2+natom*(idir2-1)+3*natom*(ipert1-1)+3*natom**2*(idir1-1)
6102 : 675 : rcond(row,col) = rcond(row,col)+ one
6103 : 675 : col= (3*natom)**2*idir3+ipert1+natom*(idir1-1)+3*natom*(ipert2-1)+3*natom**2*(idir2-1)
6104 : 900 : rcond(row,col) = rcond(row,col)+ one
6105 : : end do
6106 : : end do
6107 : : end do
6108 : : end do
6109 : : end do
6110 : :
6111 : :
6112 : : ! Use LAPACK singular value decomposition
6113 [ - + + - : 4 : ABI_MALLOC(sing,(1:nrow))
- + - + ]
6114 [ - + + - : 8 : ABI_MALLOC(umat,(1:nrow,1:nrow))
- + + - +
- + - - +
- + ]
6115 [ - + + - : 8 : ABI_MALLOC(vtmat,(1:ncol,1:ncol))
- + + - +
- + - - +
- + ]
6116 [ - + + - : 6 : ABI_MALLOC(work,(1:5*max(nrow,ncol)))
+ - + - -
+ - + ]
6117 : : call dgesvd('A','A',nrow,ncol,rcond,nrow,sing,umat,nrow, &
6118 : 2 : vtmat, ncol, work,5*max(nrow,ncol),info)
6119 [ - + ]: 2 : ABI_CHECK(info == 0, sjoin('dgesvd returned:', itoa(info)))
6120 [ - + ]: 2 : ABI_FREE(umat)
6121 [ - + ]: 2 : ABI_FREE(work)
6122 : :
6123 : 2 : write(msg, '(a,es16.8,es16.8)' )' Largest and smallest values from Singular Value Decomposition', sing(1), sing(nrow)
6124 [ + + ]: 4 : call wrtout([std_out], msg)
6125 : :
6126 [ - + + - : 8 : ABI_MALLOC(vmat,(1:ncol,1:ncol))
- + + - +
- + - - +
- + ]
6127 [ - + + - : 8 : ABI_MALLOC(sing1,(1:nrow,1:ncol))
- + + - +
- + - - +
- + ]
6128 [ - + + - : 6 : ABI_MALLOC(sing2,(1:ncol,1:nrow))
- + + - -
+ - + ]
6129 [ + + + + ]: 4616120 : vmat = zero
6130 [ + + + + ]: 1622792 : sing1 = zero
6131 [ + + + + ]: 1620899 : sing2 = zero
6132 [ + + ]: 2927 : do ipert1=1,ncol
6133 [ + + ]: 4616120 : do ipert2 =1,ncol
6134 : 4616118 : vmat(ipert1,ipert2) = vtmat(ipert2,ipert1)
6135 : : end do
6136 : : end do
6137 : : ! To compute the pseudoinverse, product of the singular matrix with its inverse
6138 [ + + ]: 1034 : do ipert1=1,min(nrow,ncol)
6139 : 1032 : sing1(ipert1,ipert1) = sing(ipert1)
6140 [ + + ]: 1034 : if (sing(ipert1)>tol12) then ! Avoids numerical problems
6141 : 576 : sing2(ipert1,ipert1) = 1_dp/sing(ipert1)
6142 : : end if
6143 : : end do
6144 : :
6145 [ - + + - : 6 : ABI_MALLOC(mat_tmp,(1:ncol,1:ncol))
- + + - -
+ - + ]
6146 [ - + + - : 6 : ABI_MALLOC(mat_tmp2,(1:ncol,1:ncol))
- + + - -
+ - + ]
6147 [ - + + - : 6 : ABI_MALLOC(mat_tmp3,(1:ncol,1:ncol))
- + + - -
+ - + ]
6148 : :
6149 [ - + - - : 2 : mat_tmp = matmul(sing2,sing1)
- - - - -
- - - - -
- - - - -
- - - - -
- - - - ]
6150 [ - + - - : 2 : mat_tmp2 = matmul(vmat,mat_tmp)
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - -
- ]
6151 [ - + - - : 2 : mat_tmp3 = matmul(mat_tmp2,vtmat)
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - ]
6152 : :
6153 : : ! Change of IFCs and its derivatives
6154 [ + - - + : 4619045 : d2cart_sol = matmul(mat_tmp3,d2cart_vec)
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- + + + +
+ + ]
6155 [ - + ]: 2 : ABI_FREE(sing)
6156 [ - + ]: 2 : ABI_FREE(sing1)
6157 [ - + ]: 2 : ABI_FREE(vmat)
6158 [ - + ]: 2 : ABI_FREE(sing2)
6159 [ - + ]: 2 : ABI_FREE(mat_tmp)
6160 [ - + ]: 2 : ABI_FREE(mat_tmp2)
6161 [ - + ]: 2 : ABI_FREE(mat_tmp3)
6162 : :
6163 : : ! Now unravel the IFCs and derivatives in arrays
6164 : :
6165 [ + + + + : 780 : d2asr = zero
+ + + + +
+ ]
6166 [ + + + + : 992 : d2dqmsr = zero
+ + + + +
+ ]
6167 [ + + + + : 2978 : d2dqdqmsr = zero
+ + + + +
+ + + ]
6168 [ + + ]: 8 : do idir1=1,3
6169 [ + + ]: 29 : do ipert1=1, natom
6170 [ + + ]: 90 : do idir2=1,3
6171 [ + + ]: 309 : do ipert2=1, natom
6172 : 225 : col = ipert2+natom*(idir2-1)+3*natom*(ipert1-1)+3*natom**2*(idir1-1)
6173 : 225 : d2asr(1,idir1,ipert1,idir2,ipert2) = d2cart_sol(col)
6174 [ + + ]: 963 : do idir3=1,3
6175 : 675 : col = (3*natom)**2*idir3+ipert2+natom*(idir2-1)+3*natom*(ipert1-1)+3*natom**2*(idir1-1)
6176 : 675 : d2dqmsr(idir1,ipert1,idir2,ipert2,idir3) = d2cart_sol(col)
6177 [ + + ]: 2925 : do idir4=1,3
6178 : : col = 4*(3*natom)**2+3*(3*natom)**2*(idir4-1)+&
6179 : 2700 : (3*natom)**2*(idir3-1)+ipert2+natom*(idir2-1)+3*natom*(ipert1-1)+3*natom**2*(idir1-1)
6180 : : !d2dqdqmsr(idir1,ipert1,idir2,ipert2,idir3,idir4) = d2cart_sol(col)
6181 : : end do
6182 : : end do
6183 : : end do
6184 : : end do
6185 : : end do
6186 : : end do
6187 : :
6188 : :
6189 [ + + + + : 92 : msr = zero
+ + ]
6190 [ + + + + : 92 : msr_init = zero
+ + ]
6191 [ + + ]: 9 : do ipert1=1, natom
6192 [ + + ]: 30 : do idir1=1,3
6193 [ + + ]: 91 : do idir2=1,3
6194 [ + + ]: 309 : do ipert2=1, natom
6195 [ + + ]: 963 : do idir3=1,3
6196 [ + + ]: 675 : if ( bool_kdir(idir3) == 1) then ! Contribution from zone-center
6197 : 387 : tmp = d2cart(1,idir1,ipert1,idir2,ipert2)
6198 : 387 : tmp2 = tmp-d2asr(1,idir1,ipert1,idir2,ipert2)
6199 [ + + ]: 1548 : do idir4 = 1,3
6200 : : msr_init(idir1,ipert1,idir4)=msr_init(idir1,ipert1,idir4)+&
6201 : 1161 : tmp*(crystal%xcart(idir3,ipert2)-crystal%xcart(idir3,ipert1))*Levi_Civita(idir2,idir3,idir4)
6202 : : msr(idir1,ipert1,idir4)=msr(idir1,ipert1,idir4)+&
6203 : 1548 : tmp2*(crystal%xcart(idir3,ipert2)-crystal%xcart(idir3,ipert1))*Levi_Civita(idir2,idir3,idir4)
6204 : : end do
6205 : : end if
6206 [ + + ]: 900 : if ( bool_ldir(idir3) == 1 ) then ! Contribution from dC/dq
6207 : 288 : tmp =d2dqred(idir1,ipert1,idir2,ipert2,idir3)
6208 : 288 : tmp2=tmp-d2dqmsr(idir1,ipert1,idir2,ipert2,idir3)
6209 [ + + ]: 1152 : do idir4 = 1,3
6210 [ + + ]: 3744 : do idir5 = 1,3
6211 : : msr_init(idir1,ipert1,idir4)=msr_init(idir1,ipert1,idir4)+&
6212 : 2592 : tmp*crystal%rprimd(idir5,idir3)*Levi_Civita(idir2,idir5,idir4)
6213 : : msr(idir1,ipert1,idir4)=msr(idir1,ipert1,idir4)+&
6214 : 3456 : tmp2*crystal%rprimd(idir5,idir3)*Levi_Civita(idir2,idir5,idir4)
6215 : : end do
6216 : : end do
6217 : : end if
6218 : : end do
6219 : : end do
6220 : : end do
6221 : : end do
6222 : : end do
6223 : 2 : write(msg, '(a,a,a,a)' ) ch10, &
6224 : 2 : ' Rotational invariance breaking, before and after imposition', ch10, &
6225 : 4 : ' ipert1 idir1 idir2 torque initial [Ha/Bohr] torque final [Ha/Bohr]'
6226 [ + + ]: 6 : call wrtout([std_out, ab_out],msg)
6227 [ + + ]: 9 : do ipert1=1,natom
6228 [ + + ]: 30 : do idir1=1,3
6229 [ + + ]: 91 : do idir4=1,3
6230 : 63 : write(msg, '(a,i0,a,i0,a,i0,a, es16.8,a,es16.8)') ' ', ipert1,' ', idir1, &
6231 : 126 : ' ', idir4 , ' ', msr_init(idir1,ipert1,idir4),' ', msr(idir1,ipert1,idir4)
6232 [ + + ]: 210 : call wrtout([std_out, ab_out],msg)
6233 : : end do
6234 : : end do
6235 : : end do
6236 : :
6237 [ - + ]: 2 : ABI_FREE(msr)
6238 [ - + ]: 2 : ABI_FREE(msr_init)
6239 [ - + ]: 2 : ABI_FREE(d2cart_vec)
6240 [ - + ]: 2 : ABI_FREE(d2cart_sol)
6241 [ - + ]: 2 : ABI_FREE(vtmat)
6242 [ - + ]: 2 : ABI_FREE(cond)
6243 [ - + ]: 2 : ABI_FREE(rcond)
6244 : :
6245 : 2 : end subroutine msria_calc
6246 : :
6247 : : !----------------------------------------------------------------------
6248 : :
6249 : : !!****f* m_dynmat/msria_apply
6250 : : !! NAME
6251 : : !! msria_corr
6252 : : !!
6253 : : !! FUNCTION
6254 : : !! Imposition of the Accoustic sum rule and rotational invariance on the InterAtomic Forces
6255 : : !! respecting crystal symmetries. Note that when IFCs derivatives are estimated previously
6256 : : !! based on the Fourier transforms, they do not strictly respect them; this is only solved
6257 : : !! when using the IFCs derivatives from the LW driver. Eventually, if the latter are available,
6258 : : !! correct the IFCs to match the ones from the LW driver close to the zone-center
6259 : : !!
6260 : : !! INPUTS
6261 : : !! asr=(0 => no ASR, 1 or 2=> the diagonal element is modified to give the ASR,
6262 : : !! 5 => impose hermitian solution using lapack call, 6 => rotational invariance)
6263 : : !! d2asr=matrix used to store the correction needed to fulfill the acoustic sum rule.
6264 : : !! d2dqmsr = same, but for the first IFCs moment for rotational invariance
6265 : : !! d2dqdqmsr = same, but for the second IFCs moment for rotational invariance
6266 : : !! mpert =maximum number of ipert
6267 : : !! natom=number of atom
6268 : : !! qphon(3,3)=wavevectors for the three possible phonons
6269 : : !! crystal<type(crystal_t)>=Crystal structure parameters
6270 : : !!
6271 : : !! OUTPUT
6272 : : !! Input/Output:
6273 : : !! d2cart=matrix of second derivatives of total energy, in cartesian coordinates
6274 : : !!
6275 : : !! SOURCE
6276 : :
6277 : 162 : subroutine msria_apply(asr,d2asr,d2dqmsr,d2cart,mpert,natom,qphon,crystal)
6278 : :
6279 : : !Arguments -------------------------------
6280 : : !scalars
6281 : : integer,intent(in) :: asr,mpert,natom
6282 : : type(crystal_t),intent(in) :: crystal
6283 : : !arrays
6284 : : real(dp),intent(in) :: d2dqmsr(3,natom,3,natom,3)!, d2dqdqmsr(3,natom,3,natom,3,3)
6285 : : real(dp),intent(in) :: d2asr(2,3,natom,3,natom), qphon(3,3)
6286 : : real(dp),intent(inout) :: d2cart(2,3,mpert,3,mpert)
6287 : : !Local variables-------------------------------
6288 : : !scalars
6289 : : integer :: idir1,idir2,ipert1,ipert2,idir3,ii,jj
6290 : 0 : integer :: tiat,tjat,isym,indij(natom,natom),indij2(natom,natom,3)
6291 : : integer :: isgn, itirev,acc,acc2
6292 : 324 : real(dp) :: qsym(3), qsym2(3), symcart(3,3,crystal%nsym),arg1,arg2
6293 : : real(dp) :: re,im,re2,im2,sumr,sumi,valr,vali,carttmp
6294 : 162 : real(dp), allocatable :: pert(:,:,:,:,:,:), pert2(:,:,:,:,:,:,:)
6295 : : real(dp) :: Levi_Civita(3,3,3)
6296 : : ! *********************************************************************
6297 [ - + + - : 972 : ABI_MALLOC(pert,(1:2,1:3,1:natom,1:3,1:natom,1:2*crystal%nsym))
+ - - + +
- - + + -
+ - + - -
+ - + ]
6298 [ - + + - : 972 : ABI_MALLOC(pert2,(1:2,1:3,1:natom,1:3,1:natom,1:2*crystal%nsym,1:3))
- + + - -
+ + - + -
+ - + - -
+ - + ]
6299 [ - + ]: 162 : if (asr/=6) return
6300 : : Levi_Civita(:,:,:)=zero
6301 : : Levi_Civita(1,2,3)=+1 ; Levi_Civita(2,3,1)=+1 ; Levi_Civita(3,1,2)=+1
6302 : : Levi_Civita(3,2,1)=-1 ; Levi_Civita(1,3,2)=-1 ; Levi_Civita(2,1,3)=-1
6303 : : ! By convention, Fourier transform in ABINIT is only using the cell
6304 : : ! coordinates, not the reduced coordinates of the atoms
6305 : : ! The code that follows already take this into account
6306 : : ! for sake of legibility
6307 : : ! Define symmetry tensor for IFCs
6308 [ + + ]: 1454 : do isym=1,crystal%nsym
6309 [ + + ]: 5330 : do idir1=1,3
6310 [ + + ]: 15504 : symcart(:,idir1,isym)=zero
6311 [ + + ]: 16796 : do idir2=1,3
6312 [ + + ]: 50388 : do idir3=1,3
6313 : : symcart(:,idir1,isym)=symcart(:,idir1,isym)+crystal%rprimd(:,idir2)&
6314 [ + + ]: 151164 : *crystal%gprimd(idir1,idir3)*crystal%symrel(idir2,idir3,isym)
6315 : : end do
6316 : : end do
6317 : : end do
6318 : : end do
6319 [ + + + + : 5130792 : pert = zero; pert2 = zero
+ + + + +
+ + + + +
+ + + + +
+ + + + +
+ + ]
6320 [ + + + + : 13576 : indij = 0 ; indij2 = 0
+ + + + +
+ ]
6321 : : ! Need to loop over symmetries to properly impose rotational invariance
6322 [ + + ]: 1454 : do isym=1,crystal%nsym
6323 [ + + ]: 4038 : do itirev=1,2 ! loop over the time-reversal symmetry
6324 : 2584 : isgn=3-2*itirev
6325 [ + + ]: 14204 : do ipert1=1,natom
6326 [ + + ]: 54200 : do ipert2=1,natom
6327 : 41288 : tiat = crystal%indsym(4,isym,ipert1) ! symmetric atom of i
6328 : 41288 : tjat = crystal%indsym(4,isym,ipert2) ! symmetric atom of j
6329 [ + + ]: 165152 : qsym(:) = crystal%indsym(1:3,isym,ipert2)-crystal%indsym(1:3,isym,ipert1)
6330 [ + + ]: 165152 : qsym= -isgn*qsym
6331 [ + + ]: 165152 : arg1 = two_pi*DOT_PRODUCT(qsym,qphon(:,1))
6332 : 41288 : acc=indij(tiat,tjat)+1
6333 : 41288 : indij(tiat,tjat)=acc
6334 [ + + ]: 165152 : do idir1=1,3
6335 [ + + ]: 536744 : do idir2=1,3
6336 : 371592 : sumr=zero
6337 : 371592 : re = cos(arg1)
6338 : 371592 : im = sin(arg1)
6339 [ + + ]: 1486368 : do ii=1,3
6340 [ + + ]: 4830696 : do jj=1,3
6341 : : ! Correction from on-site and first-neighbors in the same cells (or images)
6342 : 4459104 : sumr=sumr+symcart(idir1,ii,isym)*symcart(idir2,jj,isym)*d2asr(1,ii,tiat,jj,tjat)
6343 : : ! Second order desactivated because of missing contribution from electrostatics
6344 : : ! simply uncomment when available
6345 : : !do idir3=1,3
6346 : : ! sumr=sumr-symcart(idir1,ii,isym)*symcart(idir2,jj,isym)*&
6347 : : ! d2dqdqmsr(ii,tiat,jj,tjat,idir3,idir3)/four
6348 : : !end do
6349 : : end do
6350 : : end do
6351 : 371592 : valr = re*sumr
6352 : 371592 : vali = im*sumr
6353 : 371592 : pert(1,idir1,ipert1,idir2,ipert2,crystal%nsym*(itirev-1)+isym) = valr
6354 : 495456 : pert(2,idir1,ipert1,idir2,ipert2,crystal%nsym*(itirev-1)+isym) = vali
6355 : : end do
6356 : : end do
6357 [ + + ]: 175480 : do idir3=1,3
6358 : 123864 : acc2=indij2(tiat,tjat,idir3)+1
6359 : 123864 : indij2(tiat,tjat,idir3)=acc2
6360 [ + + ]: 495456 : qsym2(:) = crystal%symrel(:,idir3,isym)
6361 [ + + ]: 495456 : qsym2(:)=-isgn*(qsym2(:))
6362 [ + + ]: 495456 : arg2 = two_pi*DOT_PRODUCT(qsym2,qphon(:,1))
6363 [ + + ]: 536744 : do idir1=1,3
6364 [ + + ]: 1610232 : do idir2=1,3
6365 : : sumi=zero
6366 : 4459104 : sumr=zero
6367 [ + + ]: 4459104 : do ii=1,3
6368 [ + + ]: 14492088 : do jj=1,3
6369 : : ! second order desactivated
6370 : : !sumr=sumr+symcart(idir1,ii,isym)*symcart(idir2,jj,isym)*&
6371 : : ! d2dqdqmsr(ii,tiat,jj,tjat,idir3,idir3)/four
6372 : : sumi=sumi+isgn*symcart(idir1,ii,isym)*symcart(idir2,jj,isym)*&
6373 : 13377312 : d2dqmsr(ii,tiat,jj,tjat,idir3)
6374 : : end do
6375 : : end do
6376 : 1114776 : im = -cos(arg1)*sin(arg2)
6377 : 1114776 : re = sin(arg1)*sin(arg2)
6378 : 1114776 : re2 = cos(arg1)*cos(two*arg2)
6379 : 1114776 : im2 = sin(arg1)*cos(two*arg2)
6380 : 1114776 : valr = re*sumi+re2*sumr
6381 : 1114776 : vali = im*sumi+im2*sumr
6382 : 1114776 : pert2(1,idir1,ipert1,idir2,ipert2,crystal%nsym*(itirev-1)+isym,idir3)= valr
6383 : 1486368 : pert2(2,idir1,ipert1,idir2,ipert2,crystal%nsym*(itirev-1)+isym,idir3)= vali
6384 : : end do !idir1
6385 : : end do !idir2
6386 : : end do !idir3
6387 : : end do !ipert2
6388 : : end do !ipert1
6389 : : end do !itirev
6390 : : end do !isym
6391 [ + + ]: 809 : do ipert1=1,natom
6392 [ + + ]: 2750 : do idir1 =1,3
6393 [ + + ]: 8411 : do idir2=1,3
6394 [ + + ]: 31029 : do ipert2=1,natom
6395 [ + + ]: 214884 : do isym=1,crystal%nsym
6396 [ + + ]: 580653 : do itirev=1,2 ! loop over the time-reversal symmetry
6397 : 371592 : isgn=3-2*itirev
6398 : : carttmp = d2cart(1,idir1,ipert1,idir2,ipert2)- &
6399 : 371592 : pert(1,idir1,ipert1,idir2,ipert2,crystal%nsym*(itirev-1)+isym)/dble(indij(ipert1,ipert2))
6400 : 371592 : d2cart(1,idir1,ipert1,idir2,ipert2) = carttmp
6401 : : carttmp = d2cart(2,idir1,ipert1,idir2,ipert2)- &
6402 : 371592 : pert(2,idir1,ipert1,idir2,ipert2,crystal%nsym*(itirev-1)+isym)/dble(indij(ipert1,ipert2))
6403 : 371592 : d2cart(2,idir1,ipert1,idir2,ipert2) = carttmp
6404 [ + + ]: 1672164 : do idir3=1,3
6405 : : carttmp = d2cart(1,idir1,ipert1,idir2,ipert2)- &
6406 : 1114776 : pert2(1,idir1,ipert1,idir2,ipert2,crystal%nsym*(itirev-1)+isym,idir3)/dble(indij2(ipert1,ipert2,idir3))
6407 : 1114776 : d2cart(1,idir1,ipert1,idir2,ipert2) = carttmp
6408 : : carttmp = d2cart(2,idir1,ipert1,idir2,ipert2)- &
6409 : 1114776 : pert2(2,idir1,ipert1,idir2,ipert2,crystal%nsym*(itirev-1)+isym,idir3)/dble(indij2(ipert1,ipert2,idir3))
6410 : 1486368 : d2cart(2,idir1,ipert1,idir2,ipert2) = carttmp
6411 : : end do
6412 : : end do
6413 : : end do
6414 : : end do
6415 : : end do
6416 : : end do
6417 : : end do
6418 [ - + ]: 162 : ABI_FREE(pert)
6419 [ - + ]: 162 : ABI_FREE(pert2)
6420 [ # # # # ]: 0 : end subroutine msria_apply
6421 : : !!***
6422 : 0 : end module m_dynmat
|
