Branch data Line data Source code
1 : : !!****m* ABINIT/m_tdep_phi4
2 : : !! NAME
3 : : !! m_tdep_phi4
4 : : !!
5 : : !! FUNCTION
6 : : !! This module contains the routines building and writing the fourth-order IFC.
7 : : !!
8 : : !! COPYRIGHT
9 : : !! Copyright (C) 2011-2026 ABINIT group (GA,FB,JB)
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 : : !! SOURCE
15 : :
16 : : #if defined HAVE_CONFIG_H
17 : : #include "config.h"
18 : : #endif
19 : :
20 : : #include "abi_common.h"
21 : :
22 : : module m_tdep_phi4
23 : :
24 : : use defs_basis
25 : : use m_errors
26 : : use m_abicore
27 : : use m_numeric_tools
28 : : use m_linalg_interfaces
29 : : use m_io_tools
30 : : use m_crystal, only : crystal_t
31 : : use m_tdep_dataset, only : atdep_dataset_type, MPI_enreg_type
32 : : use m_tdep_latt, only : Lattice_type
33 : : use m_tdep_shell, only : Shell_type
34 : : use m_tdep_sym, only : Symmetries_type
35 : : use m_tdep_sampling, only : tdep_Sampling_type
36 : : use m_tdep_constraints, only : Constraints_type
37 : : use m_tdep_supercell, only : tdep_Supercell_type
38 : :
39 : : implicit none
40 : : !!***
41 : :
42 : : public :: tdep_write_phi4
43 : : public :: tdep_build_phi4_3333
44 : :
45 : : contains
46 : :
47 : : !=====================================================================================================
48 : :
49 : : !!****f* ABINIT/m_tdep_phi4/tdep_write_phi4
50 : : !! NAME
51 : : !! tdep_write_phi4
52 : : !!
53 : : !! FUNCTION
54 : : !! Write the fourth-order IFC in the output file: for each shell, the
55 : : !! 3x3x3x3 IFC of every quadruplet of atoms of the shell (built from the
56 : : !! reference IFC of the shell, see tdep_build_phi4_3333), and the vectors
57 : : !! between the four atoms.
58 : : !!
59 : : !! INPUTS
60 : : !! Phi4_ref(3,3,3,3,nshell) = Fourth-order IFC for the reference quadruplet of each shell.
61 : : !! SC = Supercell object, used for the interatomic distances (SC%dij).
62 : : !! Shell4at = Shell object for fourth-order interactions.
63 : : !! Sym = Symmetries object describing all the symmetry operations of the crystal.
64 : : !!
65 : : !! OUTPUT
66 : : !! Only writing.
67 : : !!
68 : : !! SOURCE
69 : :
70 : 9 : subroutine tdep_write_phi4(Phi4_ref,SC,Shell4at,Sym)
71 : :
72 : : type(tdep_Supercell_type),intent(in) :: SC
73 : : type(Symmetries_type),intent(in) :: Sym
74 : : type(Shell_type),intent(in) :: Shell4at
75 : : double precision, intent(in) :: Phi4_ref(3,3,3,3,Shell4at%nshell)
76 : :
77 : : integer :: ishell,isym,jatom,katom,latom
78 : : integer :: iatref,jatref,katref,latref,iatshell,itrans
79 : : integer :: ii,jj,kk
80 : : double precision :: tmp1,tmp2,tmp3
81 : 9 : double precision, allocatable :: Phi4_3333(:,:,:,:)
82 : :
83 : 9 : write(ab_out,*) ' '
84 : 9 : write(ab_out,*) '#############################################################################'
85 : 9 : write(ab_out,*) '#### For each shell, list of coefficients (IFC), number of neighbours... ####'
86 : 9 : write(ab_out,*) '#############################################################################'
87 : :
88 : : ! Write the IFCs in the data.out file (with others specifications:
89 : : ! number of atoms in a shell, Trace...)
90 [ + - + + : 1098 : ABI_MALLOC(Phi4_3333,(3,3,3,3)) ; Phi4_3333(:,:,:,:)=0.d0
+ + + + +
+ ]
91 [ + + ]: 58 : do ishell=1,Shell4at%nshell
92 : 49 : iatref=Shell4at%iatref(ishell)
93 [ + - ]: 58 : if (Shell4at%neighbours(iatref,ishell)%n_interactions.ne.0) then
94 : 49 : jatref=Shell4at%jatref(ishell)
95 : 49 : katref=Shell4at%katref(ishell)
96 : 49 : latref=Shell4at%latref(ishell)
97 : 49 : write(ab_out,'(a,i4,a,i4,a)') ' ======== NEW SHELL (ishell=',ishell,&
98 : 98 : & '): There are',Shell4at%neighbours(iatref,ishell)%n_interactions,' atoms on this shell'
99 [ + + ]: 1709 : do iatshell=1,Shell4at%neighbours(iatref,ishell)%n_interactions
100 : 1660 : jatom =Shell4at%neighbours(iatref,ishell)%atomj_in_shell(iatshell)
101 : 1660 : katom =Shell4at%neighbours(iatref,ishell)%atomk_in_shell(iatshell)
102 : 1660 : latom =Shell4at%neighbours(iatref,ishell)%atoml_in_shell(iatshell)
103 : 1660 : isym =Shell4at%neighbours(iatref,ishell)%sym_in_shell(iatshell)
104 : 1660 : itrans=Shell4at%neighbours(iatref,ishell)%transpose_in_shell(iatshell)
105 : 1660 : call tdep_build_phi4_3333(isym,Phi4_ref(:,:,:,:,ishell),Phi4_3333,Sym,itrans)
106 : 1660 : write(ab_out,'(a,i4,a,i4)') ' For iatcell=',iatref,' ,with type=',mod(iatref-1,SC%natom_unitcell)+1
107 : 1660 : write(ab_out,'(a,i4,a,i4)') ' For jatom =',jatom ,' ,with type=',mod(jatom -1,SC%natom_unitcell)+1
108 : 1660 : write(ab_out,'(a,i4,a,i4)') ' For katom =',katom ,' ,with type=',mod(katom -1,SC%natom_unitcell)+1
109 : 1660 : write(ab_out,'(a,i4,a,i4)') ' For latom =',latom ,' ,with type=',mod(latom -1,SC%natom_unitcell)+1
110 [ + + ]: 6640 : do ii=1,3
111 [ + + ]: 21580 : do jj=1,3
112 : : #if defined FC_NVHPC
113 : : if (itrans == -1) write(std_out, *)"NVHPC freezes here that is fixed by this print statement."
114 : : #endif
115 : :
116 : 14940 : write(ab_out,'(a,i2,i2,a)') ' Phi4^{',ii,jj,'kl}='
117 [ + + ]: 64740 : do kk=1,3
118 [ + + ]: 44820 : if (abs(Phi4_3333(ii,jj,1,kk)).lt.5.d-7) then
119 : 7436 : tmp1=0.d0
120 : : else
121 : 37384 : tmp1=Phi4_3333(ii,jj,1,kk)
122 : : end if
123 [ + + ]: 44820 : if (abs(Phi4_3333(ii,jj,2,kk)).lt.5.d-7) then
124 : 7326 : tmp2=0.d0
125 : : else
126 : 37494 : tmp2=Phi4_3333(ii,jj,2,kk)
127 : : end if
128 [ + + ]: 44820 : if (abs(Phi4_3333(ii,jj,3,kk)).lt.5.d-7) then
129 : 7430 : tmp3=0.d0
130 : : else
131 : 37390 : tmp3=Phi4_3333(ii,jj,3,kk)
132 : : end if
133 : 59760 : write(ab_out,'(2x,3(f9.6,1x))') tmp1,tmp2,tmp3
134 : : end do
135 : : end do
136 : : end do
137 [ + - + + ]: 6640 : write(ab_out,'(a,3(f9.6,1x))') ' (i,j) vector components:', (SC%dij(iatref,jatom,jj+1),jj=1,3)
138 [ + - + + ]: 6640 : write(ab_out,'(a,3(f9.6,1x))') ' (j,k) vector components:', (SC%dij(jatom ,katom,jj+1),jj=1,3)
139 [ + - + + ]: 6640 : write(ab_out,'(a,3(f9.6,1x))') ' (j,k) vector components:', (SC%dij(katom ,latom,jj+1),jj=1,3)
140 [ + - + + ]: 6640 : write(ab_out,'(a,3(f9.6,1x))') ' (k,i) vector components:', (SC%dij(latom,iatref,jj+1),jj=1,3)
141 : 1709 : write(ab_out,*) ' '
142 : : end do !iatshell
143 : : end if !n_interactions
144 : : end do !ishell
145 [ - + ]: 9 : ABI_FREE(Phi4_3333)
146 : :
147 : 9 : end subroutine tdep_write_phi4
148 : : !!***
149 : :
150 : : !=====================================================================================================
151 : :
152 : : !!****f* ABINIT/m_tdep_phi4/tdep_build_phi4_3333
153 : : !! NAME
154 : : !! tdep_build_phi4_3333
155 : : !!
156 : : !! FUNCTION
157 : : !! Build the 3x3x3x3 fourth-order IFC of one atom quadruplet in a shell, from
158 : : !! the shell's reference IFC, a symmetry operation and a permutation index.
159 : : !! The symmetry operation S is applied to each of the four cartesian indices
160 : : !! of the reference IFC, then the indices are permuted according to itrans.
161 : : !!
162 : : !! INPUTS
163 : : !! isym = Index of the symmetry operation.
164 : : !! Phi4_ref(3,3,3,3) = Fourth-order IFC of the reference quadruplet of the shell.
165 : : !! Sym = Symmetries object describing all the symmetry operations of the crystal.
166 : : !! itrans = Index of the permutation of the four atoms (1 to 24).
167 : : !!
168 : : !! OUTPUT
169 : : !! Phi4_3333(3,3,3,3) = Fourth-order IFC of the quadruplet.
170 : : !!
171 : : !! SOURCE
172 : :
173 : 251656 : subroutine tdep_build_phi4_3333(isym,Phi4_ref,Phi4_3333,Sym,itrans)
174 : :
175 : : type(Symmetries_type),intent(in) :: Sym
176 : : double precision, intent(in) :: Phi4_ref(3,3,3,3)
177 : : double precision, intent(out) :: Phi4_3333(3,3,3,3)
178 : : integer,intent(in) :: isym,itrans
179 : :
180 : : integer :: alpha,beta,gama,delta
181 : : integer :: ii,jj,kk,ll,ee,ff,gg,hh,mu,nu,xi,zeta
182 : : double precision :: Phi4_tmp(3,3,3,3)
183 : :
184 : :
185 : : ! Transform in the new basis wrt S_ref
186 : 251656 : Phi4_3333(:,:,:,:)=zero
187 [ + + ]: 1006624 : do mu=1,3
188 [ + + ]: 3271528 : do alpha=1,3
189 [ + + ]: 9814584 : do nu=1,3
190 [ + + ]: 29443752 : do beta=1,3
191 [ + + ]: 88331256 : do xi=1,3
192 [ + + ]: 264993768 : do gama=1,3
193 [ + + ]: 794981304 : do zeta=1,3
194 [ + + ]: 2384943912 : do delta=1,3
195 : : #if defined FC_NVHPC
196 : : if (itrans == -1) write(std_out, *)"NVHPC freezes here that is fixed by this print statement."
197 : : #endif
198 : : Phi4_3333(mu,nu,xi,zeta)=Phi4_3333(mu,nu,xi,zeta)+&
199 : : & Sym%S_ref(mu,alpha,isym,1)*Sym%S_ref(nu ,beta ,isym,1)*&
200 : 2201486688 : & Sym%S_ref(xi,gama ,isym,1)*Sym%S_ref(zeta,delta,isym,1)*Phi4_ref(alpha,beta,gama,delta)
201 : : end do
202 : : end do
203 : : end do
204 : : end do
205 : : end do
206 : : end do
207 : : end do
208 : : end do
209 : :
210 : : ! Take into account the 6 allowed permutations
211 : 251656 : Phi4_tmp(:,:,:,:)=Phi4_3333(:,:,:,:)
212 [ - + ]: 251656 : if ((itrans.lt.1).or.(itrans.gt.24)) then
213 : 0 : ABI_BUG('This value of the symmetry index is not permitted')
214 : : end if
215 [ + + ]: 1006624 : do ii=1,3
216 [ + + ]: 3271528 : do jj=1,3
217 [ + + ]: 9814584 : do kk=1,3
218 [ + + ]: 29443752 : do ll=1,3
219 : : #if defined FC_NVHPC
220 : : if (itrans == -1) write(std_out, *)"NVHPC freezes here that is fixed by this print statement."
221 : : #endif
222 : :
223 [ + + ]: 20384136 : if (itrans==1) then ; ee=ii ; ff=jj ; gg=kk ; hh=ll ; endif !\Phi4_ijkl
224 [ + + ]: 20384136 : if (itrans==2) then ; ee=ii ; ff=kk ; gg=jj ; hh=ll ; endif !\Phi4_ikjl
225 [ + + ]: 20384136 : if (itrans==3) then ; ee=jj ; ff=ii ; gg=kk ; hh=ll ; endif !\Phi4_jikl
226 [ + + ]: 20384136 : if (itrans==4) then ; ee=jj ; ff=kk ; gg=ii ; hh=ll ; endif !\Phi4_jkil
227 [ + + ]: 20384136 : if (itrans==5) then ; ee=kk ; ff=ii ; gg=jj ; hh=ll ; endif !\Phi4_kijl
228 [ + + ]: 20384136 : if (itrans==6) then ; ee=kk ; ff=jj ; gg=ii ; hh=ll ; endif !\Phi4_kjil
229 : :
230 [ + + ]: 20384136 : if (itrans==7 ) then ; ee=ii ; ff=jj ; gg=ll ; hh=kk ; endif !\Phi4_ijlk
231 [ + + ]: 20384136 : if (itrans==8 ) then ; ee=ii ; ff=kk ; gg=ll ; hh=jj ; endif !\Phi4_iklj
232 [ + + ]: 20384136 : if (itrans==9 ) then ; ee=jj ; ff=ii ; gg=ll ; hh=kk ; endif !\Phi4_jilk
233 [ + + ]: 20384136 : if (itrans==10) then ; ee=jj ; ff=kk ; gg=ll ; hh=ii ; endif !\Phi4_jkli
234 [ + + ]: 20384136 : if (itrans==11) then ; ee=kk ; ff=ii ; gg=ll ; hh=jj ; endif !\Phi4_kilj
235 [ + + ]: 20384136 : if (itrans==12) then ; ee=kk ; ff=jj ; gg=ll ; hh=ii ; endif !\Phi4_kjli
236 : :
237 [ + + ]: 20384136 : if (itrans==13) then ; ee=ii ; ff=ll ; gg=jj ; hh=kk ; endif !\Phi4_iljk
238 [ + + ]: 20384136 : if (itrans==14) then ; ee=ii ; ff=ll ; gg=kk ; hh=jj ; endif !\Phi4_ilkj
239 [ + + ]: 20384136 : if (itrans==15) then ; ee=jj ; ff=ll ; gg=ii ; hh=kk ; endif !\Phi4_jlik
240 [ + + ]: 20384136 : if (itrans==16) then ; ee=jj ; ff=ll ; gg=kk ; hh=ii ; endif !\Phi4_jlki
241 [ + + ]: 20384136 : if (itrans==17) then ; ee=kk ; ff=ll ; gg=ii ; hh=jj ; endif !\Phi4_klij
242 [ + + ]: 20384136 : if (itrans==18) then ; ee=kk ; ff=ll ; gg=jj ; hh=ii ; endif !\Phi4_klji
243 : :
244 [ + + ]: 20384136 : if (itrans==19) then ; ee=ll ; ff=ii ; gg=jj ; hh=kk ; endif !\Phi4_lijk
245 [ + + ]: 20384136 : if (itrans==20) then ; ee=ll ; ff=ii ; gg=kk ; hh=jj ; endif !\Phi4_likj
246 [ + + ]: 20384136 : if (itrans==21) then ; ee=ll ; ff=jj ; gg=ii ; hh=kk ; endif !\Phi4_ljik
247 [ + + ]: 20384136 : if (itrans==22) then ; ee=ll ; ff=jj ; gg=kk ; hh=ii ; endif !\Phi4_ljki
248 [ + + ]: 20384136 : if (itrans==23) then ; ee=ll ; ff=kk ; gg=ii ; hh=jj ; endif !\Phi4_lkij
249 [ + + ]: 20384136 : if (itrans==24) then ; ee=ll ; ff=kk ; gg=jj ; hh=ii ; endif !\Phi4_lkji
250 : :
251 : 27178848 : Phi4_3333(ee,ff,gg,hh)=Phi4_tmp(ii,jj,kk,ll)
252 : : end do
253 : : end do
254 : : end do
255 : : end do
256 : :
257 : 251656 : end subroutine tdep_build_phi4_3333
258 : : !!***
259 : :
260 : : !=====================================================================================================
261 : :
262 : : end module m_tdep_phi4
263 : : !!***
|
