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 2315 : subroutine cart29(blkflg,blkval,carflg,d2cart,&
696 2315 : & 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 4630 : integer :: mflg(3,mpert,3,mpert)
715 : real(dp) :: vec1(3),vec2(3)
716 : ! *********************************************************************
717 :
718 : !First, copy the data blok in place.
719 21429833 : d2cart(:,:,:,:,:)=blkval(:,:,:,:,:,iblok)
720 :
721 : !Cartesian coordinates transformation (in two steps)
722 : !First step
723 40862 : do ipert1=1,mpert
724 749973 : do ipert2=1,mpert
725 2165880 : do ii=1,2
726 6381999 : do idir1=1,3
727 17018664 : do idir2=1,3
728 12763998 : vec1(idir2)=d2cart(ii,idir1,ipert1,idir2,ipert2)
729 : ! Note here blkflg
730 17018664 : flg1(idir2)=blkflg(idir1,ipert1,idir2,ipert2,iblok)
731 : end do
732 4254666 : call cart39(flg1,flg2,gprimd,ipert2,natom,rprimd,vec1,vec2)
733 18436886 : do idir2=1,3
734 12763998 : d2cart(ii,idir1,ipert1,idir2,ipert2)=vec2(idir2)
735 : ! And here carflg
736 17018664 : 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 40862 : do ipert1=1,mpert
745 749973 : do ipert2=1,mpert
746 2165880 : do ii=1,2
747 6381999 : do idir2=1,3
748 17018664 : do idir1=1,3
749 12763998 : vec1(idir1)=d2cart(ii,idir1,ipert1,idir2,ipert2)
750 : ! Note here carflg
751 17018664 : flg1(idir1)=carflg(idir1,ipert1,idir2,ipert2)
752 : end do
753 4254666 : call cart39(flg1,flg2,gprimd,ipert1,natom,rprimd,vec1,vec2)
754 18436886 : do idir1=1,3
755 12763998 : d2cart(ii,idir1,ipert1,idir2,ipert2)=vec2(idir1)
756 : ! And here carflg again
757 17018664 : 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 9260 : do idir1=1,3
767 30095 : do idir2=1,3
768 69450 : do ii=1,2
769 : d2cart(ii,idir1,natom+2,idir2,natom+2)=&
770 62505 : & -four_pi/ucvol*d2cart(ii,idir1,natom+2,idir2,natom+2)
771 : end do
772 : end do
773 : end do
774 :
775 9260 : do idir1=1,3
776 : d2cart(1,idir1,natom+2,idir1,natom+2)=&
777 9260 : & 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 10172 : do ipert1=1,natom
782 33743 : do idir1=1,3
783 : d2cart(1,idir1,ipert1,idir1,natom+2)=&
784 31428 : & zion(typat(ipert1))+d2cart(1,idir1,ipert1,idir1,natom+2)
785 : end do
786 : end do
787 10172 : do ipert2=1,natom
788 33743 : do idir2=1,3
789 : d2cart(1,idir2,natom+2,idir2,ipert2)=&
790 31428 : & 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 6945 : do ipert2=natom+3,natom+4
796 20835 : do idir1=1,3
797 60190 : do idir2=1,3
798 138900 : do ii=1,2
799 : d2cart(ii,idir1,natom+2,idir2,ipert2)=&
800 83340 : & (1.0_dp/ucvol)*d2cart(ii,idir1,natom+2,idir2,ipert2)
801 : d2cart(ii,idir2,ipert2,idir1,natom+2)=&
802 125010 : & (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 8665835 : mflg= 0
811 2315 : ipert1=natom+5
812 9260 : do idir1=1,3
813 74501 : do ipert2= 1, natom+6 !exclude local Zeemans, to be done below
814 267909 : do idir2=1,3
815 195723 : if (mflg(idir1,ipert1,idir2,ipert2)==0) then
816 566334 : do ii=1,2
817 : d2cart(ii,idir1,ipert1,idir2,ipert2)=&
818 377556 : & -one*d2cart(ii,idir1,ipert1,idir2,ipert2)
819 566334 : mflg(idir1,ipert1,idir2,ipert2)=1
820 : end do
821 : end if
822 260964 : if (mflg(idir2,ipert2,idir1,ipert1)==0) then
823 545499 : do ii=1,2
824 : d2cart(ii,idir2,ipert2,idir1,ipert1)=&
825 363666 : & -one*d2cart(ii,idir2,ipert2,idir1,ipert1)
826 545499 : 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 2315 : 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 2315 : ipert1= natom + 2
861 2315 : ipert2= natom + 5
862 9260 : do idir1= 1, 3
863 30095 : do idir2= 1, 3
864 69450 : do ii=1,2
865 : d2cart(ii,idir1,ipert1,idir2,ipert2)=&
866 41670 : & d2cart(ii,idir1,ipert1,idir2,ipert2)/ucvol
867 : d2cart(ii,idir2,ipert2,idir1,ipert1)=&
868 41670 : & d2cart(ii,idir2,ipert2,idir1,ipert1)/ucvol
869 : d2cart(ii,idir1,ipert2,idir2,ipert2)=&
870 62505 : & d2cart(ii,idir1,ipert2,idir2,ipert2)/ucvol
871 : end do
872 : end do
873 : end do
874 :
875 2315 : 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 19173000 : 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 19173000 : if(ipert>=1.and.ipert<=natom)then
922 :
923 20667576 : do idir=1,3
924 15500682 : vec2(idir)=zero
925 15500682 : flg2(idir)=1
926 62002728 : do ii=1,3
927 62002728 : if(abs(gprimd(idir,ii))>1.0d-10)then
928 22552956 : if(flg1(ii)==1)then
929 8150317 : vec2(idir)=vec2(idir)+gprimd(idir,ii)*vec1(ii)
930 : else
931 14402639 : flg2(idir)=0
932 : end if
933 : end if
934 : end do
935 20667576 : if(flg2(idir)==0)vec2(idir)=zero
936 : end do
937 :
938 : ! Treat electric field and qvec perturbations
939 14006106 : else if(ipert==natom+2.or.ipert==natom+8) then
940 : ! OCL SCALAR
941 7958304 : do idir=1,3
942 5968728 : vec2(idir)=zero
943 5968728 : flg2(idir)=1
944 : ! OCL SCALAR
945 23874912 : do ii=1,3
946 23874912 : if(abs(rprimd(idir,ii))>1.0d-10)then
947 8750976 : if(flg1(ii)==1)then
948 1547889 : vec2(idir)=vec2(idir)+rprimd(idir,ii)*vec1(ii)/two_pi
949 : else
950 7203087 : flg2(idir)=0
951 : end if
952 : end if
953 : end do
954 7958304 : if(flg2(idir)==0)vec2(idir)=zero
955 : end do
956 :
957 : ! Treat other perturbations
958 : else
959 48066120 : do idir=1,3
960 36049590 : vec2(idir)=vec1(idir)
961 48066120 : flg2(idir)=flg1(idir)
962 : end do
963 : end if
964 :
965 19173000 : 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 2355 : subroutine d2cart_to_red(d2cart, d2red, gprimd, rprimd, mpert, natom, &
998 2355 : & 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 9420 : flg1 = one
1022 9420 : flg2 = one
1023 :
1024 7356547 : d2red = d2cart
1025 :
1026 : !Remove the ionic charges to z to get the change in effective charges
1027 10247 : do ipert1=1,natom
1028 33923 : do idir1=1,3
1029 : d2red(1,idir1,ipert1,idir1,natom+2)=&
1030 31568 : & d2red(1,idir1,ipert1,idir1,natom+2) - zion(typat(ipert1))
1031 : end do
1032 : end do
1033 10247 : do ipert2=1,natom
1034 33923 : do idir2=1,3
1035 : d2red(1,idir2,natom+2,idir2,ipert2)=&
1036 31568 : & 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 9420 : do idir1=1,3
1042 : d2red(1,idir1,natom+2,idir1,natom+2)=&
1043 9420 : & 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 9420 : do idir1=1,3
1048 30615 : do idir2=1,3
1049 70650 : do ii=1,2
1050 : d2red(ii,idir1,natom+2,idir2,natom+2)=&
1051 63585 : & - (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 7065 : do ipert2=natom+3,natom+4
1058 21195 : do idir1=1,3
1059 61230 : do idir2=1,3
1060 141300 : do ii=1,2
1061 : d2red(ii,idir1,natom+2,idir2,ipert2)=&
1062 84780 : & (ucvol)*d2red(ii,idir1,natom+2,idir2,ipert2)
1063 : d2red(ii,idir2,ipert2,idir1,natom+2)=&
1064 127170 : & (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 30615 : rprimdt = transpose(rprimd)
1075 30615 : gprimdt = transpose(gprimd)
1076 :
1077 : !First step
1078 24433 : do ipert1=1,mpert
1079 22078 : fac = one; if (ipert1==natom+2) fac = two_pi ** 2
1080 :
1081 266629 : do ipert2=1,mpert
1082 748666 : do ii=1,2
1083 2179764 : do idir1=1,3
1084 5812704 : do idir2=1,3
1085 5812704 : vec1(idir2)=d2red(ii,idir1,ipert1,idir2,ipert2)
1086 : end do
1087 : ! Transform vector from cartesian to reduced coordinates
1088 1453176 : call cart39(flg1,flg2,rprimdt,ipert1,natom,gprimdt,vec1,vec2)
1089 6297096 : do idir2=1,3
1090 5812704 : 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 24433 : do ipert1=1,mpert
1099 266629 : do ipert2=1,mpert
1100 242196 : fac = one; if (ipert2==natom+2) fac = two_pi ** 2
1101 :
1102 748666 : do ii=1,2
1103 2179764 : do idir2=1,3
1104 5812704 : do idir1=1,3
1105 5812704 : vec1(idir1)=d2red(ii,idir1,ipert1,idir2,ipert2)
1106 : end do
1107 : ! Transform vector from cartesian to reduced coordinates
1108 1453176 : call cart39(flg1,flg2,rprimdt,ipert2,natom,gprimdt,vec1,vec2)
1109 6297096 : do idir1=1,3
1110 5812704 : 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 2355 : 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 601 : 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 601 : send=0
1157 :
1158 : !Check the elements of the analytical part of the dynamical matrix
1159 1852 : do ipert2=1,natom
1160 5605 : do idir2=1,3
1161 14967 : do ipert1=1,natom
1162 43605 : do idir1=1,3
1163 39852 : 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 601 : 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 601 : 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 601 : 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 174682 : 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 174682 : integer,pointer :: sym1_(:,:,:),sym2_(:,:,:)
1510 174682 : real(dp),allocatable :: d2tmp1(:,:,:),d2tmp2(:,:,:),d2work(:,:,:,:,:)
1511 : ! *********************************************************************
1512 :
1513 174682 : 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 174682 : exch12=0
1518 174682 : if (qzero) then
1519 1467356 : do isym=1,nsym
1520 1466947 : exch12=1
1521 1466947 : if(symrel(1,1,isym)/=0)exch12=0
1522 1466947 : if(symrel(1,2,isym)/=1)exch12=0
1523 1466947 : if(symrel(1,3,isym)/=0)exch12=0
1524 1466947 : if(symrel(2,1,isym)/=1)exch12=0
1525 1466947 : if(symrel(2,2,isym)/=0)exch12=0
1526 1466947 : if(symrel(2,3,isym)/=0)exch12=0
1527 1466947 : if(symrel(3,1,isym)/=0)exch12=0
1528 1466947 : if(symrel(3,2,isym)/=0)exch12=0
1529 1466947 : if(symrel(3,3,isym)/=1)exch12=0
1530 : ! if(exch12==1) write(std_out,*)' d2sym3 : found exchange 1 2 =',isym
1531 390083 : if(exch12==1)exit
1532 : end do
1533 : end if
1534 :
1535 174682 : eta_=zero; if(present(eta)) eta_=eta
1536 :
1537 : !Consider two cases : either time-reversal symmetry
1538 : !conserves the wavevector, or not
1539 174682 : 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 233391 : do ipert1=1,mpert !See notes
1587 : ! do ipert1=1,min(natom+2,mpert)
1588 768159 : do idir1=1,3
1589 2623184 : do ipert2=1,mpert !See notes
1590 : ! do ipert2=1,min(natom+2,mpert)
1591 8175408 : do idir2=1,3
1592 5730480 : d2(2,idir1,ipert1,idir2,ipert2)=zero
1593 :
1594 : ! If an element exists
1595 7640640 : if(blkflg(idir1,ipert1,idir2,ipert2)==1)then
1596 :
1597 : ! Either complete the symmetric missing element
1598 777582 : if(blkflg(idir2,ipert2,idir1,ipert1)==0)then
1599 :
1600 7372 : d2(1,idir2,ipert2,idir1,ipert1)=d2(1,idir1,ipert1,idir2,ipert2)
1601 7372 : 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 698728 : do ithree=1,3
1623 :
1624 : ! Big loop on all elements
1625 2466463 : do ipert1=1,mpert !See notes
1626 : ! do ipert1=1,min(natom+2,mpert)
1627 :
1628 : ! Select the symmetries according to pertubation 1
1629 1767735 : if (ipert1<=natom)then
1630 642897 : sym1_ => symrec
1631 : else
1632 1124838 : sym1_ => symrel
1633 : end if
1634 :
1635 7594986 : do idir1=1,3
1636 29538927 : do ipert2=1,mpert !See notes
1637 : ! do ipert2=1,min(natom+2,mpert)
1638 :
1639 : ! Select the symmetries according to pertubation 2
1640 22467987 : if (ipert2<=natom)then
1641 7575489 : sym2_ => symrec
1642 : else
1643 14892498 : sym2_ => symrel
1644 : end if
1645 :
1646 95175153 : do idir2=1,3
1647 :
1648 : ! Will get element (idir1,ipert1,idir2,ipert2)
1649 : ! so this element should not yet be present ...
1650 89871948 : if(blkflg(idir1,ipert1,idir2,ipert2)/=1)then
1651 :
1652 57508094 : d2(1,idir1,ipert1,idir2,ipert2)=zero
1653 57508094 : d2(2,idir1,ipert1,idir2,ipert2)=zero
1654 :
1655 : ! Loop on all symmetries, including time-reversal
1656 57508094 : quit1=0
1657 2174508361 : do isym=1,nsym
1658 6351736674 : do itirev=1,2
1659 4234736407 : isgn=3-2*itirev
1660 :
1661 6351736674 : if(symq(4,itirev,isym)/=0)then
1662 1817820617 : found=1
1663 :
1664 : ! Here select the symmetric of ipert1
1665 1817820617 : if(ipert1<=natom)then
1666 415311059 : ipesy1=indsym(4,isym,ipert1)
1667 1402509558 : else if(ipert1==(natom+2).and.qzero)then
1668 : ipesy1=ipert1
1669 : else
1670 1122607581 : found=0
1671 : end if
1672 :
1673 : ! Here select the symmetric of ipert2
1674 1817820617 : if(ipert2<=natom)then
1675 417907445 : ipesy2=indsym(4,isym,ipert2)
1676 1399913172 : 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 695213036 : if( found==1 ) then
1686 :
1687 : sumr=zero
1688 : sumi=zero
1689 : noccur=0
1690 : nblkflg_is_one=0
1691 : quit=0
1692 505121346 : do idisy1=1,3
1693 1465486933 : do idisy2=1,3
1694 1465486933 : if(sym1_(idir1,idisy1,isym)/=0 .and. sym2_(idir2,idisy2,isym)/=0 )then
1695 273775434 : if(blkflg(idisy1,ipesy1,idisy2,ipesy2)==1)then
1696 40998557 : nblkflg_is_one=nblkflg_is_one+1
1697 : sumr=sumr+sym1_(idir1,idisy1,isym)*sym2_(idir2,idisy2,isym)*&
1698 40998557 : & d2(1,idisy1,ipesy1,idisy2,ipesy2)
1699 : sumi=sumi+sym1_(idir1,idisy1,isym)*sym2_(idir2,idisy2,isym)*&
1700 40998557 : & 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 232776877 : & .and.(isgn==1 .or. timrev==1 &
1710 : & .or. (idir1==idir2 .and. ipert1==ipert2)))&
1711 : & then
1712 58712890 : 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 174063987 : & .and.(isgn==-1 .or. timrev==1&
1716 : & .or. (idir1==idir2 .and. ipert1==ipert2)))&
1717 : & then
1718 12296011 : 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 161767976 : & .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 15375464 : 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 505121346 : 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 1817820617 : 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 1817786153 : 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 59422310 : sumi=isgn*sumi
1761 :
1762 59422310 : 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 199758 : & +qpt(3)*indsym(3,isym,ipert1) )
1767 : arg2=two_pi*( qpt(1)*indsym(1,isym,ipert2)&
1768 : & +qpt(2)*indsym(2,isym,ipert2)&
1769 199758 : & +qpt(3)*indsym(3,isym,ipert2) )
1770 199758 : re=cos(arg1)*cos(arg2)+sin(arg1)*sin(arg2)
1771 : ! XG010117 Must use isgn
1772 199758 : 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 59422310 : 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 735390 : if(noccur==0)then
1789 600529 : d2(1,idir1,ipert1,idir2,ipert2)=re*sumr-im*sumi
1790 600529 : 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 735390 : 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 56772704 : 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 174682 : ABI_MALLOC(d2tmp1,(2,3,3))
1832 174682 : ABI_MALLOC(d2tmp2,(2,3,3))
1833 873410 : ABI_MALLOC(d2work,(2,3,mpert,3,mpert))
1834 77424952 : d2work(:,:,:,:,:)=d2(:,:,:,:,:)
1835 763927 : do ipert1=1,mpert
1836 : !do ipert1=1,min(natom+2,mpert)
1837 589245 : if ((ipert1==natom+1.or.ipert1==natom+10.or.ipert1==natom+11).or.(ipert1==natom+2.and.(.not.qzero))) cycle
1838 291628 : if (ipert1<=natom)then
1839 214299 : sym1_ => symrec
1840 : else
1841 77329 : sym1_ => symrel
1842 : end if
1843 1894154 : do ipert2=1,mpert
1844 : !do ipert2=1,min(natom+2,mpert)
1845 : ! if (any(blkflg(:,ipert1,:,ipert2)==0)) cycle
1846 1427844 : if ((ipert2==natom+1.or.ipert2==natom+10.or.ipert2==natom+11).or.(ipert2==natom+2.and.(.not.qzero))) cycle
1847 913608 : if (ipert2<=natom)then
1848 464406 : sym2_ => symrec
1849 : else
1850 449202 : sym2_ => symrel
1851 : end if
1852 913608 : nsym_used=0
1853 28321848 : d2tmp2(:,:,:)=zero
1854 30619939 : do isym=1,nsym
1855 30619939 : if (symq(4,1,isym)==1) then
1856 16085572 : ipesy1=ipert1;if (ipert1<=natom) ipesy1=indsym(4,isym,ipert1)
1857 16085572 : 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 82408363 : if (all(blkflg(:,ipesy1,:,ipesy2)==1)) then
1864 5523960 : nsym_used=nsym_used+1
1865 5523960 : re=one;im=zero
1866 5523960 : 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 171242760 : d2tmp1(:,:,:)=zero
1873 22095840 : do idir2=1,3 !kappa
1874 71811480 : do idir1=1,3 !mu
1875 215434440 : do idisy1=1,3 !nu
1876 : d2tmp1(:,idir1,idir2)=d2tmp1(:,idir1,idir2) &
1877 497156400 : & +sym1_(idir1,idisy1,isym)*d2(:,idisy1,ipesy1,idir2,ipesy2)
1878 : end do
1879 : end do
1880 : end do
1881 22095840 : do idir2=1,3 !mu
1882 71811480 : do idir1=1,3 !kappa
1883 215434440 : do idisy2=1,3 !nu
1884 : d2tmp2(1,idir1,idir2)=d2tmp2(1,idir1,idir2) &
1885 149146920 : & +sym2_(idir2,idisy2,isym)*(d2tmp1(1,idir1,idisy2)*re-d2tmp1(2,idir1,idisy2)*im)
1886 : d2tmp2(2,idir1,idir2)=d2tmp2(2,idir1,idir2) &
1887 198862560 : & +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 10897233 : 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 10400248 : if (mpert>=natom) d2(:,1:3,1:natom,1:3,1:natom)=d2work(:,1:3,1:natom,1:3,1:natom)
1898 174682 : if (mpert>=natom+2) then
1899 6801530 : d2(:,1:3,natom+2,1:3,1:natom)=d2work(:,1:3,natom+2,1:3,1:natom)
1900 7111082 : d2(:,1:3,1:natom,1:3,natom+2)=d2work(:,1:3,1:natom,1:3,natom+2)
1901 5407733 : d2(:,1:3,natom+2,1:3,natom+2)=d2work(:,1:3,natom+2,1:3,natom+2)
1902 : end if
1903 174682 : ABI_FREE(d2tmp1)
1904 174682 : ABI_FREE(d2tmp2)
1905 174682 : ABI_FREE(d2work)
1906 : end if
1907 :
1908 174682 : 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 181435 : 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 725740 : do mu=1,3
1961 2358655 : do nu=1,3
1962 5821248 : do ia=1,natom
1963 5276943 : 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 181435 : 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 608 : 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 608 : if(option==1.or.option==2.or.option==6)then
2031 2432 : do mu=1,3
2032 7904 : do nu=1,3
2033 19419 : do ia=1,natom
2034 12123 : dyewq0(mu,nu,ia)=zero
2035 56160 : do ib=1,natom
2036 50688 : 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 608 : 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 608 : 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 302511 : 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 605022 : integer :: indij(natom,natom),symq(4,2,nsym),symrec(3,3,nsym)
2116 605022 : real(dp) :: TqR(3,3),TqS_(3,3),dynmat(2,3,natom,3,natom)
2117 605022 : real(dp) :: dynmatint(2*nsym,2,3,natom,3,natom),gprimd(3,3)
2118 605022 : 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 302511 : call matr3inv(rprimd,gprimd)
2126 8724728 : do isym=1,nsym
2127 8724728 : call mati3inv(symrel(:,:,isym),symrec(:,:,isym))
2128 : end do
2129 :
2130 : TqR=zero
2131 : TqS_=zero
2132 70867389 : dynmat=zero
2133 :
2134 : !Note: dynmat is used as work space here
2135 : i1=0
2136 955428 : do iat=1,natom
2137 2914179 : do idir=1,3
2138 1958751 : i1=i1+1
2139 1958751 : i2=0
2140 9406989 : do jat=1,natom
2141 29140035 : do jdir=1,3
2142 20385963 : i2=i2+1
2143 20385963 : index=i1+3*natom*(i2-1)
2144 20385963 : dynmat(1,idir,iat,jdir,jat)=dmati(2*index-1)
2145 27181284 : 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 8724728 : do isym=1,nsym
2158 33991379 : do jj=1,3
2159 101066604 : symcart(:,jj,isym)=zero
2160 109488821 : do kk=1,3
2161 328466463 : do ll=1,3
2162 985399389 : 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 302511 : call littlegroup_q(nsym,qptn,symq,symrec,symafm,timrev,prtvol=0)
2171 :
2172 3220535 : indij(:,:)=0
2173 1460580249 : dynmatint=zero
2174 :
2175 8724728 : do isym=1,nsym ! loop over all the symmetries
2176 : ! write(std_out,*) 'current symmetry',isym
2177 25569162 : do itirev=1,2 ! loop over the time-reversal symmetry
2178 16844434 : isgn=3-2*itirev
2179 : ! write(std_out,*) 'timereversal',isgn
2180 :
2181 25266651 : 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 3293629 : do iat=1,natom
2184 10551773 : do jat=1,natom
2185 7258144 : niat=indsym(4,isym,iat) ! niat={R|t}iat
2186 7258144 : njat=indsym(4,isym,jat) ! njat={R|t}jat
2187 7258144 : 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 7258144 : qptn(3)*indsym(3,isym,iat) )
2193 : arg2=two_pi*( qptn(1)*indsym(1,isym,jat)+&
2194 : qptn(2)*indsym(2,isym,jat)+&
2195 7258144 : qptn(3)*indsym(3,isym,jat) )
2196 :
2197 7258144 : re=cos(arg1)*cos(arg2)+sin(arg1)*sin(arg2)
2198 7258144 : im=isgn*(cos(arg2)*sin(arg1)-cos(arg1)*sin(arg2))
2199 :
2200 31266626 : do idir=1,3 ! loop over displacements
2201 94355872 : 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 261293184 : do ii=1,3
2206 849202848 : do jj=1,3
2207 587909664 : sumr=sumr+symcart(idir,ii,isym)*dynmat(1,ii,niat,jj,njat)*symcart(jdir,jj,isym)
2208 783879552 : sumi=sumi+symcart(idir,ii,isym)*dynmat(2,ii,niat,jj,njat)*symcart(jdir,jj,isym)
2209 : end do
2210 : end do
2211 65323296 : sumi=isgn*sumi
2212 :
2213 65323296 : dynmatint(nsym*(itirev-1)+isym,1,idir,iat,jdir,jat)=re*sumr-im*sumi
2214 87097728 : 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 955428 : do iat=1,natom
2225 3220535 : do jat=1,natom
2226 9713345 : do idir=1,3
2227 29446391 : do jdir=1,3
2228 : dmint=zero
2229 715242393 : do isym=1,2*nsym
2230 715242393 : dmint=dmint+dynmatint(isym,1,idir,iat,jdir,jat)
2231 : end do
2232 20385963 : dynmat(1,idir,iat,jdir,jat)=dmint/dble(indij(iat,jat))
2233 20385963 : dmint=zero
2234 715242393 : do isym=1,2*nsym
2235 715242393 : dmint=dmint+dynmatint(isym,2,idir,iat,jdir,jat)
2236 : end do
2237 27181284 : 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 955428 : do iat=1,natom
2245 2914179 : do idir=1,3
2246 1958751 : i1=i1+1
2247 1958751 : i2=0
2248 9406989 : do jat=1,natom
2249 29140035 : do jdir=1,3
2250 20385963 : i2=i2+1
2251 20385963 : index=i1+3*natom*(i2-1)
2252 20385963 : dmati(2*index-1)=dynmat(1,idir,iat,jdir,jat)
2253 27181284 : dmati(2*index )=dynmat(2,idir,iat,jdir,jat)
2254 : end do
2255 : end do
2256 : end do
2257 : end do
2258 :
2259 302511 : 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 2521 : 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 2521 : if (nsym==1) then
2316 :
2317 : ! Only symmetry is identity so simply copy
2318 45738 : 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 2249 : do ia=1,natom
2325 : ! write(std_out,*)' dfpt_sygra : ia=',ia
2326 7067 : do mu=1,3
2327 : sumr=zero
2328 : sumi=zero
2329 : ! write(std_out,*)' dfpt_sygra : mu=',mu
2330 23760 : do isym=1,nsym
2331 18942 : 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 18942 : 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 18942 : & 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 18942 : & dble(symrec(mu,3,isym))*deunsy(2,3,ind)
2351 18942 : sumr=sumr+re*cos(arg)-im*sin(arg)
2352 23760 : 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 4818 : desym(1,mu,ia)=sumr/dble(nsym)
2359 6424 : 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 2521 : 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 1350 : 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 2700 : real(dp) :: work(cplex,3,3)
2432 : ! *********************************************************************
2433 :
2434 1350 : 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 57491 : sdyfro(:,:,:,:,:)=zero
2443 999 : qeq0=(qphon(1)**2+qphon(2)**2+qphon(3)**2<1.d-14)
2444 : ! === Diagonal dyn. matrix OR q=0
2445 999 : if (nondiag==0.or.qeq0) then
2446 985 : natom_nondiag=1;if (nondiag==1) natom_nondiag=natom
2447 2045 : do ja=1,natom_nondiag
2448 4493 : do ia=1,natom
2449 59594 : do isym=1,nsym
2450 56086 : indi=indsym(4,isym,ia)
2451 56086 : indj=1;if (nondiag==1) indj=indsym(4,isym,ja)
2452 1233892 : work(:,:,:)=zero
2453 224344 : do mu=1,3
2454 729118 : do nu=1,3
2455 2187354 : do kappa=1,3
2456 3533418 : 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 226792 : do mu=1,3
2461 729118 : do nu=1,3
2462 2187354 : do kappa=1,3
2463 3533418 : 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 985 : div=one/dble(nsym)
2471 55901 : 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 1350 : 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 382 : 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 3849 : do ipert=1,mpert
2576 14250 : do idir=1,3
2577 13868 : if(carflg(idir,ipert,idir,ipert)==0)then
2578 85788 : do ipert1=1,mpert
2579 318444 : do idir1=1,3
2580 232656 : carflg(idir,ipert,idir1,ipert1)=0
2581 232656 : carflg(idir1,ipert1,idir,ipert)=0
2582 232656 : d2cart(1,idir,ipert,idir1,ipert1)=zero
2583 232656 : d2cart(2,idir,ipert,idir1,ipert1)=zero
2584 232656 : d2cart(1,idir1,ipert1,idir,ipert)=zero
2585 310208 : d2cart(2,idir1,ipert1,idir,ipert)=zero
2586 : end do
2587 : end do
2588 : end if
2589 : end do
2590 : end do
2591 :
2592 382 : 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 308 : 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 308 : 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 291166 : do irpt=1,nrpt
2645 311387 : 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 307 : if(found==0)then
2653 0 : ABI_BUG('Not able to find the vector R=(0,0,0).')
2654 : end if
2655 :
2656 1228 : do mu=1,3
2657 3991 : do nu=1,3
2658 11172 : do ia=1,natom
2659 : sumifc=zero
2660 41238 : 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 41238 : if(asr==1)then
2665 53477559 : do irpt=1,nrpt
2666 53477559 : 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 7488 : atmfrc(mu,ia,nu,ia,izero)=atmfrc(mu,ia,nu,ia,izero)-sumifc
2679 10251 : 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 308 : 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 242 : 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 242 : choice=0
2891 242 : 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 242 : nrpt = mrpt
2895 726 : ABI_MALLOC(rpt,(3,nrpt))
2896 726 : ABI_MALLOC(cell,(3,nrpt))
2897 :
2898 242 : choice=1
2899 242 : call bigbx9(brav,cell,choice,mrpt,ngqpt,nqshft,nrpt,rprim,rpt)
2900 :
2901 242 : 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 484 : 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 484 : lqshft=1
2959 484 : if(nqshft/=1)lqshft=2
2960 :
2961 :
2962 : !Simple Cubic Lattice
2963 484 : 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 86 : else if (brav==2) then
2989 58 : lim1=((ngqpt(1)+3)/4)*lqshft+buffer
2990 58 : lim2=((ngqpt(2)+3)/4)*lqshft+buffer
2991 58 : lim3=((ngqpt(3)+3)/4)*lqshft+buffer
2992 58 : nrpt=(2*lim1+1)*(2*lim2+1)*(2*lim3+1)*4
2993 58 : if(choice/=0)then
2994 29 : 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 29 : irpt=0
2999 220 : do r1=-lim1,lim1
3000 1497 : do r2=-lim2,lim2
3001 10107 : do r3=-lim3,lim3
3002 8639 : irpt=irpt+4
3003 8639 : rpt(1,irpt-3)=r1
3004 8639 : rpt(2,irpt-3)=r2
3005 8639 : rpt(3,irpt-3)=r3
3006 8639 : rpt(1,irpt-2)=r1
3007 8639 : rpt(2,irpt-2)=r2+0.5
3008 8639 : rpt(3,irpt-2)=r3+0.5
3009 8639 : rpt(1,irpt-1)=r1+0.5
3010 8639 : rpt(2,irpt-1)=r2
3011 8639 : rpt(3,irpt-1)=r3+0.5
3012 8639 : rpt(1,irpt)=r1+0.5
3013 8639 : rpt(2,irpt)=r2+0.5
3014 8639 : rpt(3,irpt)=r3
3015 : !TEST_AM
3016 : ! cell(irpt-3,1)=r1;cell(irpt-3,2)=r2;cell(irpt-3,3)=r3
3017 9916 : 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 28 : 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 14 : else if (brav==4) then
3055 14 : lim1=(ngqpt(1)+1)*lqshft+buffer
3056 14 : lim2=(ngqpt(2)+1)*lqshft+buffer
3057 14 : lim3=((ngqpt(3)/2)+1)*lqshft+buffer
3058 14 : nrpt=(2*lim1+1)*(2*lim2+1)*(2*lim3+1)
3059 14 : if(choice/=0)then
3060 7 : 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 7 : irpt=0
3065 124 : do r1=-lim1,lim1
3066 2275 : do r2=-lim2,lim2
3067 23871 : do r3=-lim3,lim3
3068 21603 : irpt=irpt+1
3069 21603 : rpt(1,irpt)=r1*rprim(1,1)+r2*rprim(1,2)+r3*rprim(1,3)
3070 21603 : rpt(2,irpt)=r1*rprim(2,1)+r2*rprim(2,2)+r3*rprim(2,3)
3071 21603 : rpt(3,irpt)=r1*rprim(3,1)+r2*rprim(3,2)+r3*rprim(3,3)
3072 23754 : 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 484 : 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 242 : 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 881 : do iatom=1,natom
3129 2798 : 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 242 : 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 43 : else if (brav==2) then
3151 : ! Face Centered Lattice
3152 : ! Special possible translations in the F.C.C. case
3153 29 : dontno(:,:)=zero
3154 29 : dontno(2,2)=0.5_dp
3155 29 : dontno(3,2)=0.5_dp
3156 29 : dontno(1,3)=0.5_dp
3157 29 : dontno(3,3)=0.5_dp
3158 29 : dontno(1,4)=0.5_dp
3159 29 : dontno(2,4)=0.5_dp
3160 87 : do iatom=1,natom
3161 : found=0
3162 164 : do ii=1,4
3163 131 : if (found==1) exit
3164 : ! Canon will produce these coordinate transformations
3165 77 : call wrap2_pmhalf(rcan(1,iatom)+dontno(1,ii),rok(1),shift(1))
3166 77 : call wrap2_pmhalf(rcan(2,iatom)+dontno(2,ii),rok(2),shift(2))
3167 77 : 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 77 : rok(1)=rok(1)-1.0d-10
3172 77 : rok(2)=rok(2)-2.0d-10
3173 77 : rok(3)=rok(3)-5.0d-10
3174 135 : if (abs(rok(1))+abs(rok(2))<=0.5_dp) then
3175 62 : if (abs(rok(1))+abs(rok(3))<=0.5_dp) then
3176 62 : if (abs(rok(2))+abs(rok(3))<=0.5_dp) then
3177 232 : tt(:)=rcan(:,iatom)
3178 : ! New coordinates : rcan
3179 58 : rcan(1,iatom)=rok(1)+1.0d-10
3180 58 : rcan(2,iatom)=rok(2)+2.0d-10
3181 58 : rcan(3,iatom)=rok(3)+5.0d-10
3182 : ! Translations between New and Old coordinates
3183 232 : 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 14 : 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 7 : else if (brav==4) then
3227 : ! Hexagonal Lattice
3228 : ! In this case, it is easier first to work in reduced coordinates space !
3229 35 : do iatom=1,natom
3230 : ! Passage from the reduced space to the "lozenge" cell
3231 28 : rec(1)=xred(1,iatom)-0.5_dp
3232 28 : rec(2)=xred(2,iatom)-0.5_dp
3233 28 : rec(3)=xred(3,iatom)
3234 : ! Canon will produces these coordinate transformations
3235 28 : call wrap2_pmhalf(rec(1),rok(1),shift(1))
3236 28 : call wrap2_pmhalf(rec(2),rok(2),shift(2))
3237 28 : call wrap2_pmhalf(rec(3),rok(3),shift(3))
3238 28 : rec(1)=rok(1)+0.5_dp
3239 28 : rec(2)=rok(2)+0.5_dp
3240 28 : rec(3)=rok(3)
3241 : ! Passage in Cartesian Normalized Coordinates
3242 112 : 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 28 : rcan(1,iatom)=rcan(1,iatom)-1.0d-10
3245 28 : rcan(2,iatom)=rcan(2,iatom)-2.0d-10
3246 : ! Passage to the honeycomb hexagonal unit cell !
3247 28 : if (rcan(1,iatom)>0.5_dp) then
3248 6 : rcan(1,iatom)=rcan(1,iatom)-1.0_dp
3249 : end if
3250 28 : if (rcan(1,iatom)>zero.and.rcan(1,iatom)+sqrt(3.0_dp)*rcan(2,iatom)>1.0_dp) then
3251 9 : rcan(1,iatom)=rcan(1,iatom)-0.5_dp
3252 9 : rcan(2,iatom)=rcan(2,iatom)-sqrt(3.0_dp)*0.5_dp
3253 : end if
3254 28 : 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 112 : tt(:)=xred(1,iatom)*rprim(:,1)+xred(2,iatom)*rprim(:,2)+xred(3,iatom)*rprim(:,3)
3260 119 : 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 242 : call wrtout(std_out,' Canonical Atomic Coordinates ')
3272 881 : do iatom=1,natom
3273 639 : write(msg, '(a,i5,3es18.8)' )' atom',iatom,rcan(1,iatom),rcan(2,iatom),rcan(3,iatom)
3274 881 : call wrtout(std_out,msg)
3275 : end do
3276 :
3277 242 : 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 24753 : 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 24753 : irpt=(index-1)/natom+1
3327 24753 : ib=index-natom*(irpt-1)
3328 :
3329 : !Transform the canonical coordinates to reduced coord.
3330 99012 : 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 99012 : & +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 99012 : do jj=1,3
3338 : rcart(jj)=xred(1)*acell(1)*rprim(jj,1)+&
3339 : & xred(2)*acell(2)*rprim(jj,2)+&
3340 99012 : & xred(3)*acell(3)*rprim(jj,3)
3341 : end do
3342 :
3343 24753 : 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 242 : 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 242 : if (abs(brav)==1) then
3382 : ! Simple Cubic Lattice No condition in this case !
3383 : continue
3384 :
3385 43 : else if (brav==2) then
3386 : ! Face Centered Lattice
3387 116 : do ii=1,3
3388 377 : do jj=1,3
3389 348 : 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 14 : 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 7 : 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 7 : 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 242 : 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 81 : 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 338 : do ia=1,natom
3494 : ! First transform canonical coordinates to reduced coordinates
3495 1028 : do ii=1,3
3496 1028 : 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 1028 : ra(:)=xred(1)*acell(1)*rprim(:,1)+xred(2)*acell(2)*rprim(:,2)+xred(3)*acell(3)*rprim(:,3)
3500 1713 : do ib=1,natom
3501 5500 : do ii=1,3
3502 5500 : xred(ii)=gprim(1,ii)*rcan(1,ib)+gprim(2,ii)*rcan(2,ib)+gprim(3,ii)*rcan(3,ib)
3503 : end do
3504 5500 : do ii=1,3
3505 5500 : 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 883797 : do irpt=1,nrpt
3508 : ! First transform it to reduced coordinates
3509 3528660 : do ii=1,3
3510 3528660 : 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 3528660 : do ii=1,3
3514 3528660 : 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 3528660 : do ii=1,3
3517 3528660 : rdiff(ii)=-rptcar(ii)+ra(ii)-rb(ii)
3518 : end do
3519 883540 : 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 81 : 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 242 : 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 242 : nprocs = xmpi_comm_size(comm); my_rank = xmpi_comm_rank(comm)
3573 :
3574 : ! Interatomic Forces from Dynamical Matrices
3575 112726196 : atmfrc = zero
3576 552916 : do irpt=1,nrpt
3577 552674 : if (mod(irpt, nprocs) /= my_rank) cycle ! mpi-parallelism
3578 162279051 : do iqpt=1,nqpt
3579 :
3580 : ! Calculation of the k coordinates in Normalized Reciprocal coordinates
3581 2102475427 : kk(:) = matmul(gprim, spqpt(:, iqpt))
3582 :
3583 : ! Product of k and r
3584 646915516 : kr=dot_product(kk,rpt(:,irpt))
3585 :
3586 : ! Get the phase factor
3587 161728879 : re=cos(two_pi*kr)
3588 161728879 : 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 753754264 : do ib=1,natom
3593 2527619723 : do nu=1,3
3594 12379941907 : do ia=1,natom
3595 41830622385 : 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 40056204252 : +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 242 : call xmpi_sum(atmfrc, comm, ierr)
3613 : !The sumifc has to be weighted by a normalization factor of 1/nqpt
3614 112726196 : atmfrc = atmfrc/nqpt
3615 :
3616 242 : 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 314611 : 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 314611 : my_rank = xmpi_comm_rank(comm); nprocs = xmpi_comm_size(comm)
3668 76157170 : 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 629222 : do iqpt=1,nqpt
3674 :
3675 : ! Calculation of the k coordinates in Normalized Reciprocal coordinates
3676 4089943 : kk(:) = matmul(gprim, spqpt(:, iqpt))
3677 :
3678 146606425 : do irpt=1,nrpt
3679 145977203 : cnt = cnt + 1; if (mod(cnt, nprocs) /= my_rank) cycle ! MPI parallelism.
3680 :
3681 : ! k.R
3682 583908812 : kr=dot_product(kk,rpt(:,irpt))
3683 : ! Get phase factor
3684 145977203 : re = cos(two_pi*kr); im = sin(two_pi*kr)
3685 :
3686 : ! Inner loop on atoms and directions
3687 524061670 : do ib=1,natom
3688 2101176939 : do ia=1,natom
3689 : !if (abs(wghatm(ia,ib,irpt)) > tol10) then ! Commented by MG
3690 1577429880 : factr = re * wghatm(ia,ib,irpt)
3691 1577429880 : facti = im * wghatm(ia,ib,irpt)
3692 6687489376 : do nu=1,3
3693 20506588440 : do mu=1,3
3694 : ! Real and imaginary part of the dynamical matrices
3695 : ! Atmfrc should be real
3696 14196868920 : dynmat(1,mu,ia,nu,ib,iqpt) = dynmat(1,mu,ia,nu,ib,iqpt) + factr * atmfrc(mu,ia,nu,ib,irpt)
3697 18929158560 : 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 314611 : if (nprocs > 1) call xmpi_sum(dynmat, comm, ierr)
3724 :
3725 314611 : 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 227649 : 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 138876162 : dddq = zero
3776 117105202 : do irpt=1,nrpt
3777 : ! Calculation of the k coordinates in Normalized Reciprocal coordinates
3778 1519408189 : kk(:) = matmul(gprim, qpt)
3779 :
3780 : ! Product of k and r
3781 467510212 : kr=dot_product(kk,rpt(:,irpt))
3782 :
3783 : ! Get phase factor
3784 116877553 : re=cos(two_pi*kr); im=sin(two_pi*kr)
3785 :
3786 : ! Inner loop on atoms and directions
3787 389265835 : do ib=1,natom
3788 1359078587 : do ia=1,natom
3789 1242201034 : if (abs(wghatm(ia,ib,irpt))>1.0d-10) then
3790 : ! take into account rotation due to i.
3791 3070003548 : fact(1,:) = -im * wghatm(ia,ib,irpt) * rpt(:,irpt)
3792 3070003548 : fact(2,:) = re * wghatm(ia,ib,irpt) * rpt(:,irpt)
3793 3070003548 : do nu=1,3
3794 9977511531 : do mu=1,3
3795 : ! Real and imaginary part of the dynamical matrices
3796 : ! Atmfrc should be real
3797 29932534593 : do ii=1,3
3798 20722523949 : dddq(1,mu,ia,nu,ib,ii) = dddq(1,mu,ia,nu,ib,ii) + fact(1,ii) * atmfrc(mu,ia,nu,ib,irpt)
3799 27630031932 : 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 227649 : 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 33615 : 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 134460 : do jj=1,3
3847 403380 : do ii=1,3
3848 403380 : work(jj,ii)=zero
3849 : end do
3850 436995 : do ii=1,3
3851 302535 : work(jj,1)=work(jj,1)+ifccar(jj,ii)*vect1(ii)
3852 302535 : work(jj,2)=work(jj,2)+ifccar(jj,ii)*vect2(ii)
3853 403380 : work(jj,3)=work(jj,3)+ifccar(jj,ii)*vect3(ii)
3854 : end do
3855 : end do
3856 :
3857 134460 : do jj=1,3
3858 403380 : do ii=1,3
3859 403380 : ifcloc(ii,jj)=zero
3860 : end do
3861 436995 : do ii=1,3
3862 302535 : ifcloc(1,jj)=ifcloc(1,jj)+vect1(ii)*work(ii,jj)
3863 302535 : ifcloc(2,jj)=ifcloc(2,jj)+vect2(ii)*work(ii,jj)
3864 403380 : ifcloc(3,jj)=ifcloc(3,jj)+vect3(ii)*work(ii,jj)
3865 : end do
3866 : end do
3867 :
3868 33615 : 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 243 : 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 243 : ierr = 0
3933 :
3934 : ! First analyze the vectors qshft
3935 243 : 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 243 : factor=0.5_dp
3989 243 : if(brav==2 .or. brav==3) factor=0.25_dp
3990 243 : if(nqshft/=1)factor=factor*2
3991 :
3992 243 : 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 4617 : r_inscribed_sphere = sum((matmul(rprimd(:,:),ngqpt(1:3)))**2)
4021 972 : do ii=-1,1
4022 3159 : do jj=-1,1
4023 9477 : do kk=-1,1
4024 6561 : if (ii==0 .and. jj==0 .and. kk==0) cycle
4025 25272 : do idir=1,3
4026 25272 : pp(idir)=ii*ngqpt(1)*rprimd(idir,1)+ jj*ngqpt(2)*rprimd(idir,2)+ kk*ngqpt(3)*rprimd(idir,3)
4027 : end do
4028 6318 : normsq = pp(1)*pp(1)+pp(2)*pp(2)+pp(3)*pp(3)
4029 8748 : r_inscribed_sphere = min(r_inscribed_sphere, normsq)
4030 : end do
4031 : end do
4032 : end do
4033 243 : r_inscribed_sphere = sqrt(r_inscribed_sphere)
4034 :
4035 :
4036 : !Begin the big loop on ia and ib
4037 886 : do ia=1,natom
4038 3665 : do ib=1,natom
4039 :
4040 : ! Simple Lattice
4041 2779 : 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 8878440 : do irpt=1,nrpt
4051 :
4052 : ! Initialization of the weights to 1.0
4053 8875018 : wghatm(ia,ib,irpt)=1.0_dp
4054 :
4055 : ! Compute the difference vector
4056 :
4057 : ! Simple Cubic Lattice
4058 8875018 : 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 1730992 : do ii=1,3
4075 1730992 : rdiff(ii)=rcan(ii,ib)-rcan(ii,ia)+rpt(ii,irpt)
4076 : end do
4077 : end if
4078 :
4079 : ! Assignement of weights
4080 :
4081 8877797 : if(nqshft==1 .and. brav/=4)then
4082 :
4083 8387270 : if (brav/=1) then
4084 476296 : do ii=1,3
4085 : ! If the rpt vector is greater than the allowed space => weight = 0.0
4086 476296 : if (abs(rdiff(ii))-tol10>factor*ngqpt(ii)) then
4087 173985 : wghatm(ia,ib,irpt)=zero
4088 183237 : 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 35058 : 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 487748 : 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 173730 : rdiff(4)=0.5_dp*( rdiff(1)+sqrt(3.0_dp)*rdiff(2) )
4119 173730 : ngqpt(4)=ngqpt(1)
4120 173730 : rdiff(5)=0.5_dp*( rdiff(1)-sqrt(3.0_dp)*rdiff(2) )
4121 173730 : ngqpt(5)=ngqpt(1)
4122 :
4123 : ! Test the four inequalities
4124 1042380 : do ii=1,5
4125 1042380 : if(ii/=2)then
4126 :
4127 694920 : nbord(ii)=0
4128 : ! If the rpt vector is greater than the allowed space => weight = 0.0
4129 694920 : if (abs(rdiff(ii))-1.0d-10>factor*ngqpt(ii)) then
4130 421728 : wghatm(ia,ib,irpt)=zero
4131 273192 : 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 30540 : nbord(ii)=1
4134 : end if
4135 :
4136 : end if
4137 : end do
4138 :
4139 : ! Computation of weights
4140 173730 : nbordh=nbord(1)+nbord(4)+nbord(5)
4141 173730 : if (nbordh==1) then
4142 18040 : wghatm(ia,ib,irpt)=wghatm(ia,ib,irpt)/2
4143 155690 : else if (nbordh==2) then
4144 1872 : wghatm(ia,ib,irpt)=wghatm(ia,ib,irpt)/3
4145 153818 : else if (nbordh/=0) then
4146 0 : ABI_BUG('There is a problem of borders and weights (hex).')
4147 : end if
4148 173730 : if (nbord(3)==1)then
4149 8756 : 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 886 : do ia=1,natom
4255 3665 : do ib=1,natom
4256 : sumwght=zero
4257 8877797 : do irpt=1,nrpt
4258 : ! Check if the sum of the weights is equal to the number of q points
4259 8877797 : 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 3422 : if (abs(sumwght-nqpt)>tol10) ierr = 1
4264 : end do
4265 : end do
4266 :
4267 243 : 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 24257 : 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 315341 : work (:) = matmul(ifccar,vect1)
4732 :
4733 : flag=0
4734 61603 : do itrial=1,4
4735 : scprod=zero
4736 246412 : do ii=1,3
4737 246412 : scprod=scprod+work(ii)*vect1(ii)
4738 : end do
4739 :
4740 246412 : work(:)=work(:)-vect1(:)*scprod
4741 :
4742 246412 : scprod=dot_product(work,work)
4743 :
4744 61603 : if(scprod<1.0d-10)then
4745 37346 : work(1:3)=zero
4746 37346 : 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 24257 : innorm=scprod**(-0.5_dp)
4755 97028 : vect2(:)=work(:)*innorm
4756 :
4757 24257 : vect3(1)=vect1(2)*vect2(3)-vect1(3)*vect2(2)
4758 24257 : vect3(2)=vect1(3)*vect2(1)-vect1(1)*vect2(3)
4759 24257 : vect3(3)=vect1(1)*vect2(2)-vect1(2)*vect2(1)
4760 :
4761 24257 : 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 997800 : 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 2021658 : do iqpt=1,nqpt
4814 : ! Definition of q in normalized reciprocal space
4815 13310154 : kk(:) = matmul(gprim, spqpt(:, iqpt))
4816 :
4817 :
4818 1023858 : if(option==1)then
4819 105200 : kk(:)=-kk(:)
4820 : end if
4821 :
4822 4207150 : do ia=1,natom
4823 10451434 : do ib=1,natom
4824 : ! Product of q with the differences between the two atomic translations
4825 7242084 : 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 31153828 : do mu=1,3
4827 94147092 : do nu=1,3
4828 65178756 : re=dynmat(1,mu,ia,nu,ib,iqpt)
4829 65178756 : 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 65178756 : dynmat(1,mu,ia,nu,ib,iqpt)=re*cos(two_pi*ktrans)-im*sin(two_pi*ktrans)
4832 86905008 : 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 997800 : 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 76903 : 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 76903 : 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 65535 : else if (plus==1) then
4900 230792 : do ia=1,natom
4901 812383 : do ib=1,natom
4902 2491621 : do mu=1,3
4903 7560683 : do nu=1,3
4904 5234319 : dynmat(1,mu,ia,nu,ib,iqpt)=dynmat(1,mu,ia,nu,ib,iqpt) + dyew(1,mu,ia,nu,ib)
4905 6979092 : 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 76903 : 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 314611 : subroutine gtdyn9(acell,atmfrc,dielt,dipdip,dyewq0,d2cart,gmet,gprim,mpert,natom,&
4966 314611 : 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 314611 : real(dp),allocatable :: dq(:,:,:,:,:),dyew(:,:,:,:,:)
4993 : ! *********************************************************************
4994 :
4995 : ! Keep track of time spent in gtdyn9
4996 : !call timab(1750, 1, tsec)
4997 :
4998 1573055 : ABI_MALLOC(dq,(2,3,natom,3,natom))
4999 :
5000 : ! Define quadrupolar options
5001 314611 : dipquad_=0; if(present(dipquad)) dipquad_=dipquad
5002 314611 : quadquad_=0; if(present(quadquad)) quadquad_=quadquad
5003 :
5004 : ! Get the normalized wavevector
5005 314611 : if(abs(qphnrm)<1.0d-7)then
5006 18502 : qphon(1:3)=zero
5007 : else
5008 1184436 : qphon(1:3)=qpt(1:3)/qphnrm
5009 : end if
5010 :
5011 : ! Generate the analytical part from the interatomic forces
5012 314611 : 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 314611 : call dymfz9(dq,natom,nqpt1,gprim,option2,qphon,trans)
5018 :
5019 314611 : 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 196605 : ABI_MALLOC(dyew,(2,3,natom,3,natom))
5024 65535 : if (sys_dim==1) then ! 3D case
5025 : call ewald9(acell,dielt,dyew,gmet,gprim,natom,qphon,rmet,rprim,sumg0,ucvol,xred,zeff,&
5026 65313 : 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 65535 : call q0dy3_apply(natom,dyewq0,dyew)
5032 65535 : call nanal9(dyew,dq,iqpt1,natom,nqpt1,plus1)
5033 :
5034 65535 : ABI_FREE(dyew)
5035 : end if
5036 :
5037 : ! Copy the dynamical matrix in the proper location
5038 : ! First zero all the elements
5039 314611 : nsize=2*(3*mpert)**2
5040 1074744173 : d2cart = zero
5041 :
5042 : ! Copy the elements from dq to d2cart
5043 75842559 : d2cart(:,:,1:natom,:,1:natom)=dq(:,:,1:natom,:,1:natom)
5044 :
5045 : ! In case we have the gamma point,
5046 314611 : 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 77368 : do i1=1,3
5049 251446 : do i2=1,3
5050 174078 : d2cart(1,i1,natom+2,i2,natom+2)=dielt(i1,i2)
5051 582960 : do ib=1,natom
5052 350856 : d2cart(1,i1,natom+2,i2,ib)=zeff(i1,i2,ib)
5053 524934 : 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 314611 : ABI_FREE(dq)
5060 :
5061 : !call timab(1750, 2, tsec)
5062 :
5063 314611 : 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 372977 : subroutine dfpt_phfrq(amu,displ,d2cart,eigval,eigvec,indsym,&
5121 372977 : & mpert,msym,natom,nsym,ntypat,phfrq,qphnrm,qphon,rprimd,&
5122 372977 : & 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 372977 : 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 372977 : i1=0
5159 1200027 : do ipert1=1,natom
5160 3681177 : do idir1=1,3
5161 2481150 : i1=i1+1
5162 2481150 : i2=0
5163 11434708 : do ipert2=1,natom
5164 34987182 : do idir2=1,3
5165 24379524 : i2=i2+1
5166 24379524 : index=i1+3*natom*(i2-1)
5167 24379524 : displ(2*index-1)=d2cart(1,idir1,ipert1,idir2,ipert2)
5168 32506032 : 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 372977 : analyt=1; if(abs(qphnrm)<tol8) analyt=0
5176 372977 : 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 372977 : if(analyt==0 .or. analyt==2)then
5180 620040 : do i1=1,3*natom
5181 4449135 : do i2=1,3*natom
5182 3829095 : index=i1+3*natom*(i2-1)
5183 4369350 : 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 79785 : 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 372977 : 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 372977 : if (symdynmat==1 .and. analyt == 1) then
5246 287699 : qptn(:)=qphon(:)
5247 1150796 : if (analyt==1) qptn(:)=qphon(:)/qphnrm
5248 287699 : call symdyma(displ,indsym,natom,nsym,qptn,rprimd,symrel,symafm)
5249 : end if
5250 :
5251 372977 : ii=1
5252 1118931 : ABI_MALLOC(matrx,(2,(3*natom*(3*natom+1))/2))
5253 2854127 : do i2=1,3*natom
5254 16284464 : do i1=1,i2
5255 13430337 : matrx(1,ii)=displ(1+2*(i1-1)+2*(i2-1)*3*natom)
5256 13430337 : matrx(2,ii)=displ(2+2*(i1-1)+2*(i2-1)*3*natom)
5257 15911487 : ii=ii+1
5258 : end do
5259 : end do
5260 :
5261 1118931 : ABI_MALLOC(zhpev1,(2,2*3*natom-1))
5262 1118931 : ABI_MALLOC(zhpev2,(3*3*natom-2))
5263 :
5264 372977 : call ZHPEV ('V','U',3*natom,matrx,eigval,eigvec,3*natom,zhpev1,zhpev2,ier)
5265 372977 : ABI_CHECK(ier == 0, sjoin('zhpev returned:', itoa(ier)))
5266 :
5267 372977 : ABI_FREE(matrx)
5268 372977 : ABI_FREE(zhpev1)
5269 372977 : 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 2854127 : do imode=1,3*natom
5286 2854127 : if(eigval(imode)>=1.0d-16)then
5287 2263797 : phfrq(imode)=sqrt(eigval(imode))
5288 217353 : else if(eigval(imode)>=-1.0d-16)then
5289 158407 : phfrq(imode)=zero
5290 : else
5291 58946 : phfrq(imode)=-sqrt(-eigval(imode))
5292 : end if
5293 : end do
5294 :
5295 : ! Fix the phase of the eigenvectors
5296 372977 : call fxphas_seq(eigvec,dum, 0, 0, 1, 3*natom*3*natom, 0, 3*natom, 3*natom, 0)
5297 :
5298 : ! Normalise the eigenvectors
5299 372977 : call pheigvec_normalize(natom, eigvec)
5300 :
5301 : ! Get the phonon displacements
5302 372977 : 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 372977 : 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 373007 : 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 2854697 : do imode=1,3*natom
5361 :
5362 : norm=zero
5363 9926760 : do idir1=1,3
5364 34316004 : do ipert1=1,natom
5365 24389244 : i1=idir1+(ipert1-1)*3
5366 24389244 : index=i1+3*natom*(imode-1)
5367 31834314 : norm=norm+eigvec(2*index-1)**2+eigvec(2*index)**2
5368 : end do
5369 : end do
5370 2481690 : norm=sqrt(norm)
5371 :
5372 10299767 : do idir1=1,3
5373 34316004 : do ipert1=1,natom
5374 24389244 : i1=idir1+(ipert1-1)*3
5375 24389244 : index=i1+3*natom*(imode-1)
5376 24389244 : eigvec(2*index-1)=eigvec(2*index-1)/norm
5377 31834314 : eigvec(2*index)=eigvec(2*index)/norm
5378 : end do
5379 : end do
5380 :
5381 : end do
5382 :
5383 373007 : 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 379832 : 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 2899916 : do imode=1,3*natom
5424 :
5425 10460168 : do idir1=1,3
5426 34692276 : do ipert1=1,natom
5427 24611940 : i1=idir1+(ipert1-1)*3
5428 24611940 : index=i1+3*natom*(imode-1)
5429 24611940 : displ(2*index-1)=eigvec(2*index-1) / sqrt(amu(typat(ipert1))*amu_emass)
5430 32172192 : displ(2*index )=eigvec(2*index ) / sqrt(amu(typat(ipert1))*amu_emass)
5431 : end do
5432 : end do
5433 :
5434 : end do
5435 :
5436 379832 : 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 1967 : 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 3934 : character(len=1) :: metacharacter(3*natom)
5544 : ! *********************************************************************
5545 :
5546 : !Check the value of eivec
5547 3829 : 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 1967 : write(msg,'(4a)' )' ',ch10,' phonon wavelength (reduced coordinates) , ','norm, and energies in hartree'
5556 1967 : call wrtout(std_out,msg)
5557 :
5558 : !The next format should be rewritten
5559 1967 : write(msg,'(a,4f5.2)' )' ',(qphon(i),i=1,3),qphnrm
5560 1967 : call wrtout(std_out,msg)
5561 6726 : do jj=1,3*natom,5
5562 4759 : if (3*natom-jj<5) then
5563 1967 : write(msg,'(5es17.9)') (phfrq(ii),ii=jj,3*natom)
5564 : else
5565 2792 : write(msg,'(5es17.9)') (phfrq(ii),ii=jj,jj+4)
5566 : end if
5567 6726 : call wrtout(std_out,msg)
5568 : end do
5569 20657 : write(msg,'(a,a,es17.9)') ch10,' Zero Point Motion energy (sum of freqs/2)=',sum(phfrq(1:3*natom))/2
5570 1967 : call wrtout(std_out,msg)
5571 :
5572 : !Put the wavevector in nice format
5573 1967 : if(iout>=0)then
5574 1931 : call wrtout(iout,' ')
5575 1931 : if(qphnrm/=0.0_dp)then
5576 : write(msg, '(a,3f9.5)' )&
5577 6632 : ' 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 1931 : call wrtout(iout,msg)
5584 :
5585 : ! Write it, in different units.
5586 1931 : if(enunit/=1)then
5587 1931 : write(iout, '(a)' )' Phonon energies in Hartree :'
5588 6582 : do jj=1,3*natom,5
5589 4651 : if (3*natom-jj<5) then
5590 1931 : write(msg, '(1x,5es14.6)') (phfrq(ii),ii=jj,3*natom)
5591 : else
5592 2720 : write(msg, '(1x,5es14.6)') (phfrq(ii),ii=jj,jj+4)
5593 : end if
5594 6582 : call wrtout(iout,msg)
5595 : end do
5596 : end if
5597 1931 : 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 1931 : if(enunit/=1)then
5609 1931 : write(iout, '(a)' )' Phonon frequencies in cm-1 :'
5610 6582 : do jj=1,3*natom,5
5611 4651 : if (3*natom-jj<5) then
5612 6577 : write(msg, '("-",5es14.6)') (phfrq(ii)*Ha_cmm1,ii=jj,3*natom)
5613 : else
5614 16320 : write(msg, '("-",5es14.6)') (phfrq(ii)*Ha_cmm1,ii=jj,jj+4)
5615 : end if
5616 6582 : call wrtout(iout,msg)
5617 : end do
5618 : end if
5619 1931 : 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 1931 : 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 1967 : 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 1967 : 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 1056608 : 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 1056608 : 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 13735904 : nearidentity(:,:)=one
5755 1056608 : nearidentity(1,1)=one+break_symm
5756 1056608 : nearidentity(3,3)=one-break_symm
5757 :
5758 : ! Include the masses in the dynamical matrix
5759 3297309 : do ipert1=1,natom
5760 10422940 : do ipert2=1,natom
5761 7125631 : fac=1.0_dp/sqrt(amu(typat(ipert1))*amu(typat(ipert2)))/amu_emass
5762 30743225 : do idir1=1,3
5763 92633203 : do idir2=1,3
5764 64130679 : i1=idir1+(ipert1-1)*3
5765 64130679 : i2=idir2+(ipert2-1)*3
5766 64130679 : index=i1+3*natom*(i2-1)
5767 64130679 : mat(2*index-1)=mat(2*index-1)*fac*nearidentity(idir1,idir2)
5768 64130679 : 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 85507572 : if(ipert1==ipert2 .and. idir1==idir2)then
5771 6722103 : 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 1056608 : if (herm_opt__ == 1) call mkherm(mat,3*natom)
5780 :
5781 1056608 : 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
|
