Line data Source code
1 : !--------------------------------------------------------------------------------
2 : ! Copyright (c) 2022 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
3 : ! This file is part of FLEUR and available as free software under the conditions
4 : ! of the MIT license as expressed in the LICENSE file in more detail.
5 : !--------------------------------------------------------------------------------
6 : MODULE m_desymmetrizer
7 : USE m_types
8 :
9 : IMPLICIT NONE
10 :
11 : CONTAINS
12 0 : SUBROUTINE desymmetrize_pw(sym, stars, stars_nosym, rhopw, rhopw_nosym, rhopw_w, rhopw_w_nosym)
13 : USE m_spgrot
14 :
15 : TYPE(t_sym), INTENT(IN) :: sym
16 : TYPE(t_stars), INTENT(IN) :: stars, stars_nosym
17 :
18 : COMPLEX, INTENT(IN) :: rhopw(:,:)
19 : COMPLEX, INTENT(INOUT) :: rhopw_nosym(:,:)
20 :
21 : COMPLEX, OPTIONAL, INTENT(IN) :: rhopw_w(:,:)
22 : COMPLEX, OPTIONAL, INTENT(INOUT) :: rhopw_w_nosym(:,:)
23 :
24 : INTEGER :: iStar, iStar_nosym, iSym
25 0 : INTEGER :: kr(3,sym%nop)
26 :
27 0 : DO iStar = 1, stars%ng3
28 0 : CALL spgrot(sym%nop, sym%symor, sym%mrot, sym%tau, sym%invtab, stars%kv3(:, iStar), kr)
29 0 : DO iSym = 1, sym%nop
30 0 : iStar_nosym = stars_nosym%ig(kr(1,iSym),kr(2,iSym),kr(3,iSym))
31 0 : rhopw_nosym(iStar_nosym,:) = rhopw(iStar,:) * stars%rgphs(kr(1,iSym),kr(2,iSym),kr(3,iSym))
32 0 : IF (PRESENT(rhopw_w)) rhopw_w_nosym(iStar_nosym,:) = rhopw_w(iStar,:) * stars%rgphs(kr(1,iSym),kr(2,iSym),kr(3,iSym))
33 : END DO
34 : END DO
35 :
36 0 : END SUBROUTINE
37 :
38 0 : SUBROUTINE desymmetrize_mt(sym, sym_nosym, cell, atoms, atoms_nosym, sphhar, sphhar_nosym, rhomt, rhomt_nosym)
39 : USE m_dwigner
40 :
41 : TYPE(t_sym), INTENT(IN) :: sym, sym_nosym
42 : TYPE(t_cell), INTENT(IN) :: cell
43 : TYPE(t_atoms), INTENT(IN) :: atoms, atoms_nosym
44 : TYPE(t_sphhar), INTENT(IN) :: sphhar, sphhar_nosym
45 :
46 : REAL, INTENT(IN) :: rhomt(:,0:,:,:)
47 : REAL, INTENT(INOUT) :: rhomt_nosym(:,0:,:,:)
48 :
49 : INTEGER :: iAtom_new, iAtom_old, iType_old, nd_old, nd_new, iOp, m_wigner
50 : INTEGER :: iLH_new, llh_new, iMem_new, mlh_new, iLH_old, llh_old, iMem_old, mlh_old
51 : REAL :: tau_new(3), tau_old(3)
52 : COMPLEX :: clnu_new, clnu_old, d_wigner_elem
53 :
54 0 : COMPLEX :: d_wigner_full(-atoms%lmaxd:atoms%lmaxd, -atoms%lmaxd:atoms%lmaxd, 0:atoms%lmaxd, sym%nop)
55 :
56 0 : CALL d_wigner(sym%nop, sym%mrot, cell%bmat, atoms%lmaxd, d_wigner_full(:, :, 1:, :sym%nop))
57 0 : d_wigner_full(:, :, 0, :) = 1
58 :
59 0 : DO iAtom_new = 1, atoms_nosym%ntype ! Same as atoms_nosym%nat
60 0 : tau_new = atoms_nosym%pos(:, iAtom_new) ! Position of this atom in the unsymmetrized system
61 :
62 0 : DO iAtom_old = 1, atoms%nat
63 0 : tau_old = atoms%pos(:, iAtom_old)
64 0 : IF (norm2(tau_new-tau_old)<1e-5) EXIT
65 : END DO
66 :
67 0 : iType_old = atoms%itype(iAtom_old)
68 :
69 0 : nd_old = sym%ntypsy(iAtom_old)
70 0 : nd_new = sym_nosym%ntypsy(iAtom_new)
71 0 : iOp = sym%ngopr(iAtom_old)
72 :
73 0 : DO iLH_new = 0, sphhar_nosym%nlh(nd_new)
74 0 : llh_new = sphhar_nosym%llh(iLH_new,nd_new)
75 0 : DO iMem_new = 1, sphhar_nosym%nmem(iLH_new,nd_new)
76 0 : mlh_new = sphhar_nosym%mlh(iMem_new,iLH_new,nd_new)
77 0 : clnu_new = sphhar_nosym%clnu(iMem_new,iLH_new,nd_new)
78 0 : DO iLH_old = 0, sphhar%nlh(nd_old)
79 0 : llh_old = sphhar%llh(iLH_old,nd_old)
80 0 : DO iMem_old = 1, sphhar%nmem(iLH_old,nd_old)
81 0 : mlh_old = sphhar%mlh(iMem_old,iLH_old,nd_old)
82 0 : clnu_old = sphhar%clnu(iMem_old,iLH_old,nd_old)
83 0 : DO m_wigner = -llh_old, llh_old
84 0 : IF (llh_old==llh_new.AND.m_wigner==mlh_new) THEN
85 0 : d_wigner_elem = d_wigner_full(mlh_old, m_wigner, llh_old, iOp)
86 : rhomt_nosym(:atoms%jri(iType_old),iLH_new,iAtom_new,:) = &
87 : rhomt_nosym(:atoms%jri(iType_old),iLH_new,iAtom_new,:) + &
88 : CONJG(clnu_new) * clnu_old * CONJG(d_wigner_elem) * &
89 0 : rhomt(:atoms%jri(iType_old),iLH_old,iType_old,:)
90 : END IF ! L'=L, m''=m'(L'M')
91 : END DO ! m_wigner
92 : END DO ! iMem_old
93 : END DO ! iLH_old
94 : END DO ! iMem_new
95 : END DO ! iLH_new
96 : END DO ! iAtom_new
97 :
98 0 : END SUBROUTINE
99 :
100 0 : SUBROUTINE desymmetrize_types(input, input_nosym, atoms, atoms_nosym, noco, nococonv, nococonv_nosym, enpara, enpara_nosym, results, results_nosym)
101 : USE m_types_lapw
102 :
103 : TYPE(t_input), INTENT(IN) :: input, input_nosym
104 : TYPE(t_atoms), INTENT(IN) :: atoms, atoms_nosym
105 : TYPE(t_noco), INTENT(IN) :: noco
106 : TYPE(t_nococonv), INTENT(IN) :: nococonv
107 : TYPE(t_enpara), INTENT(IN) :: enpara
108 : TYPE(t_results), INTENT(IN) :: results
109 : TYPE(t_nococonv), INTENT(INOUT) :: nococonv_nosym
110 : TYPE(t_enpara), INTENT(INOUT) :: enpara_nosym
111 : TYPE(t_results), INTENT(INOUT) :: results_nosym
112 :
113 : INTEGER :: neigd2, neigd2_nosym, iAtom_new, iAtom_old, iType_old
114 : REAL :: tau_new(3), tau_old(3)
115 :
116 : ! TODO: Thes two should be identical!
117 0 : neigd2 = MIN(input%neig,lapw_dim_nbasfcn)
118 0 : neigd2_nosym = MIN(input_nosym%neig,lapw_dim_nbasfcn)
119 0 : IF (neigd2/=neigd2_nosym) WRITE(*,*) "neigd2 /= itself!!"
120 :
121 : IF (noco%l_soc.AND.(.NOT.noco%l_noco)) neigd2 = 2*neigd2
122 :
123 : ! Scalar/presized array quantities:
124 0 : nococonv_nosym%theta = nococonv%theta
125 0 : nococonv_nosym%phi = nococonv%phi
126 0 : nococonv_nosym%qss = nococonv%qss
127 :
128 0 : enpara_nosym%evac = enpara%evac
129 0 : enpara_nosym%evac1 = enpara%evac1
130 0 : enpara_nosym%enmix = enpara%enmix
131 0 : enpara_nosym%lchg_v = enpara%lchg_v
132 0 : enpara_nosym%epara_min = enpara%epara_min
133 0 : enpara_nosym%ready = enpara%ready
134 0 : enpara_nosym%floating = enpara%floating
135 :
136 0 : results_nosym%ef = results%ef
137 0 : results_nosym%seigc = results%seigc
138 0 : results_nosym%seigv = results%seigv
139 0 : results_nosym%ts = results%ts
140 0 : results_nosym%te_vcoul = results%te_vcoul
141 0 : results_nosym%te_veff = results%te_veff
142 0 : results_nosym%te_exc = results%te_exc
143 0 : results_nosym%e_ldau = results%e_ldau
144 0 : results_nosym%e_ldaopc = results%e_ldaopc
145 0 : results_nosym%e_vdw = results%e_vdw
146 0 : results_nosym%tote = results%tote
147 0 : results_nosym%bandgap = results%bandgap
148 0 : results_nosym%te_hfex = results%te_hfex
149 0 : results_nosym%tkb_loc = results%tkb_loc
150 0 : results_nosym%te_hfex_loc = results%te_hfex_loc
151 0 : results_nosym%last_distance = results%last_distance
152 0 : results_nosym%last_mmpMatdistance = results%last_mmpMatdistance
153 0 : results_nosym%last_occdistance = results%last_occdistance
154 :
155 : ! Allocated arrays:
156 0 : results_nosym%unfolding_weights = results%unfolding_weights
157 0 : results_nosym%w_iks = results%w_iks
158 0 : results_nosym%eig = results%eig
159 0 : results_nosym%neig = results%neig
160 : IF(input%l_rdmft) THEN
161 : results_nosym%w_iksRDMFT = results_nosym%w_iksRDMFT
162 : END IF
163 :
164 : ! Atom loop:
165 0 : DO iAtom_new = 1, atoms_nosym%ntype ! Same as atoms_nosym%nat
166 0 : tau_new = atoms_nosym%pos(:, iAtom_new) ! Position of this atom in the unsymmetrized system
167 :
168 0 : DO iAtom_old = 1, atoms%nat
169 0 : tau_old = atoms%pos(:, iAtom_old)
170 0 : IF (norm2(tau_new-tau_old)<1e-5) EXIT
171 : END DO
172 :
173 0 : iType_old = atoms%itype(iAtom_old)
174 :
175 0 : enpara_nosym%el0(:,iAtom_new,:) = enpara%el0(:,iType_old,:)
176 0 : enpara_nosym%el1(:,iAtom_new,:) = enpara%el1(:,iType_old,:)
177 0 : enpara_nosym%ello0(:,iAtom_new,:) = enpara%ello0(:,iType_old,:)
178 0 : enpara_nosym%ello1(:,iAtom_new,:) = enpara%ello1(:,iType_old,:)
179 :
180 0 : enpara_nosym%skiplo(iAtom_new,:) = enpara%skiplo(iType_old,:)
181 0 : enpara_nosym%lchange(:,iAtom_new,:) = enpara%lchange(:,iType_old,:)
182 0 : enpara_nosym%llochg(:,iAtom_new,:) = enpara%llochg(:,iType_old,:)
183 :
184 : ! TODO: This is most DEFINITELY faulty, but we shouldn't fix it until
185 : ! the noco rotation logic itself is 100% cleaned up.
186 0 : IF (noco%l_noco) THEN
187 0 : nococonv_nosym%alph(iAtom_new) = nococonv%alph(iType_old)
188 0 : nococonv_nosym%alphRlx(iAtom_new) = nococonv%alphRlx(iType_old)
189 0 : nococonv_nosym%alphPrev(iAtom_new) = nococonv%alphPrev(iType_old)
190 0 : nococonv_nosym%beta(iAtom_new) = nococonv%beta(iType_old)
191 0 : nococonv_nosym%betaRlx(iAtom_new) = nococonv%betaRlx(iType_old)
192 0 : nococonv_nosym%betaPrev(iAtom_new) = nococonv%betaPrev(iType_old)
193 :
194 0 : nococonv_nosym%b_con(2,iAtom_new) = nococonv%b_con(2,iType_old)
195 : END IF
196 : END DO
197 :
198 : ! Omitted:
199 : ! results%force already exists as a desymmetrization function in force_w(?)
200 : ! results%force_old/_vdw as above
201 :
202 0 : END SUBROUTINE
203 : END MODULE
|
