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