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_dfpt_hsmt
7 : USE m_juDFT
8 :
9 : IMPLICIT NONE
10 :
11 : CONTAINS
12 0 : SUBROUTINE dfpt_hsmt(atoms, sym, juphon, enpara, iSpin, iDir, iDtype, input, fmpi, &
13 0 : & noco, nococonv, cell, lapw, lapwq, usdus, td, tdV1, hmat, smat, nk, killcont)
14 :
15 : !> Setup of the MT part of the Hamiltonian and the overlap perturbation matrices
16 : !! Adapted from hsmt()
17 : !!
18 : !! There are two parts to this. For each atom, the part from the perturbed
19 : !! potential is calculated via
20 : !! 1. The non-spherical part in hsmt_nonsph()
21 : !! 2. The LO part in hsmt_lo() [with no smat passed]
22 : !!
23 : !! Additionally, ONLY for the perturbed atom, we need the unperturbed Hamiltonian
24 : !! and overlap with a prefactor of i(G'-G-q). This is done by first evaluating them
25 : !! and then passing the prefactor in a postprocess routine.
26 : !!
27 : !! The necessary noco logic is already implemented here similar to the base case
28 : !! in hsmt().
29 : !!
30 : !! DFPT-specific variables:
31 : !! - td, tdV1: Local matrix elements for the unperturbed Hamiltonian and
32 : !! the perturbed potential respectively.
33 : !! - lapwq: Set of LAPW basis vectors shifted by q.
34 : !! - iDir: Displacement direction.
35 : !! - iDtype: Type of the displaced atom.
36 :
37 : USE m_types
38 : USE m_types_mpimat
39 : USE m_hsmt_nonsph
40 : USE m_hsmt_sph
41 : USE m_hsmt_lo
42 : USE m_hsmt_distspins
43 : USE m_hsmt_fjgj
44 : USE m_hsmt_spinor
45 : USE m_hsmt_offdiag
46 : USE m_matrix_pref
47 :
48 : IMPLICIT NONE
49 :
50 : TYPE(t_mpi), INTENT(IN) :: fmpi
51 : TYPE(t_input), INTENT(IN) :: input
52 : TYPE(t_noco), INTENT(IN) :: noco
53 : TYPE(t_nococonv), INTENT(IN) :: nococonv
54 : TYPE(t_sym), INTENT(IN) :: sym
55 : TYPE(t_juphon), INTENT(IN) :: juphon
56 : TYPE(t_cell), INTENT(IN) :: cell
57 : TYPE(t_atoms), INTENT(IN) :: atoms
58 : TYPE(t_enpara), INTENT(IN) :: enpara
59 : TYPE(t_lapw), INTENT(IN) :: lapw, lapwq
60 : TYPE(t_tlmplm), INTENT(IN) :: td, tdV1
61 : TYPE(t_usdus), INTENT(IN) :: usdus
62 : CLASS(t_mat), INTENT(INOUT) :: smat(:,:),hmat(:,:)
63 :
64 : INTEGER, INTENT(IN) :: iSpin, iDir, iDtype, nk, killcont(3)
65 :
66 0 : TYPE(t_fjgj) :: fjgj, fjgjq
67 :
68 : INTEGER :: ilSpinPr, ilSpin, nspins, i, j
69 : INTEGER :: igSpinPr, igSpin, n
70 : COMPLEX :: chi(2,2),chi_one
71 :
72 0 : CLASS(t_mat), ALLOCATABLE :: smat_tmp, hmat_tmp, s1mat_tmp(:,:), h1mat_tmp(:,:)
73 :
74 : !TODO: All of the openACC is most certainly scuffed for DFPT. Fix it someday.
75 : ! But wait until it is right and proper in the main code!
76 0 : IF (noco%l_noco.AND..NOT.noco%l_ss) THEN
77 0 : IF (fmpi%n_size==1) THEN
78 0 : ALLOCATE(t_mat::hmat_tmp)
79 0 : ALLOCATE(t_mat::smat_tmp)
80 : ELSE
81 0 : ALLOCATE(t_mpimat::hmat_tmp)
82 0 : ALLOCATE(t_mpimat::smat_tmp)
83 : END IF
84 0 : CALL smat_tmp%init(hmat(1,1))
85 0 : CALL hmat_tmp%init(hmat(1,1))
86 : !$acc enter data copyin(smat_tmp,hmat_tmp)create(smat_tmp%data_c,smat_tmp%data_r,hmat_tmp%data_c,hmat_tmp%data_r)
87 : END IF
88 :
89 0 : nspins = MERGE(2, 1, noco%l_noco)
90 0 : IF (fmpi%n_size == 1) THEN
91 0 : ALLOCATE (t_mat::s1mat_tmp(nspins, nspins), h1mat_tmp(nspins, nspins))
92 : ELSE
93 0 : ALLOCATE (t_mpimat::s1mat_tmp(nspins, nspins), h1mat_tmp(nspins, nspins))
94 : END IF
95 :
96 0 : DO i = 1, nspins
97 0 : DO j = 1, nspins
98 0 : CALL s1mat_tmp(i, j)%init(.FALSE., lapwq%nv(i) + atoms%nlotot, lapw%nv(j) + atoms%nlotot, fmpi%sub_comm, .false.)
99 0 : CALL h1mat_tmp(i, j)%init(s1mat_tmp(i, j))
100 : END DO
101 : END DO
102 :
103 0 : CALL fjgj%alloc(MAXVAL(lapw%nv),atoms%lmaxd,iSpin,noco)
104 0 : CALL fjgjq%alloc(MAXVAL(lapwq%nv),atoms%lmaxd,iSpin,noco)
105 : !!$acc data copyin(fjgj) create(fjgj%fj,fjgj%gj)
106 : !!$acc data copyin(fjgjq) create(fjgjq%fj,fjgjq%gj)
107 0 : igSpinPr = 1; igSpin = 1; chi_one = 1.0 ! Defaults in non-noco case
108 0 : DO n = 1, atoms%ntype
109 0 : DO ilSpinPr = MERGE(1,iSpin,noco%l_noco), MERGE(2,iSpin,noco%l_noco)
110 0 : CALL timestart("fjgj coefficients")
111 0 : CALL fjgjq%calculate(input,atoms,cell,lapwq,noco,usdus,n,ilSpinPr)
112 : !$acc update device(fjgjq%fj,fjgjq%gj)
113 0 : CALL timestop("fjgj coefficients")
114 0 : DO ilSpin = ilSpinPr, MERGE(2,iSpin,noco%l_noco)
115 0 : CALL timestart("fjgjq coefficients")
116 0 : CALL fjgj%calculate(input,atoms,cell,lapw,noco,usdus,n,ilSpin)
117 0 : CALL timestop("fjgjq coefficients")
118 :
119 0 : IF (.NOT.noco%l_noco) THEN
120 0 : IF (n.EQ.iDtype .AND. juphon%l_phonon) THEN
121 0 : CALL hsmt_nonsph(n,fmpi,sym,atoms,ilSpinPr,ilSpin,1,1,chi_one,noco,nococonv,cell,lapw,td,fjgj,h1mat_tmp(1,1),.TRUE.,lapwq,fjgjq)
122 0 : CALL hsmt_sph(n,atoms,fmpi,ilSpinPr,input,nococonv,1,1,chi_one,lapw,enpara%el0,td%e_shift(n,ilSpinPr),usdus,fjgj,s1mat_tmp(1,1),h1mat_tmp(1,1),.TRUE.,.TRUE.,lapwq,fjgjq)
123 0 : CALL hsmt_lo(input,atoms,sym,cell,fmpi,noco,nococonv,lapw,usdus,td,fjgj,n,chi_one,ilSpinPr,ilSpin,igSpinPr,igSpin,h1mat_tmp(1,1),.FALSE.,.TRUE.,.TRUE.,s1mat_tmp(1,1),lapwq,fjgjq)
124 : END IF
125 0 : IF (killcont(1)/=0) THEN
126 0 : CALL hsmt_nonsph(n,fmpi,sym,atoms,ilSpinPr,ilSpin,1,1,chi_one,noco,nococonv,cell,lapw,tdV1,fjgj,hmat(1,1),.FALSE.,lapwq,fjgjq)
127 0 : CALL hsmt_lo(input,atoms,sym,cell,fmpi,noco,nococonv,lapw,usdus,tdV1,fjgj,n,chi_one,ilSpinPr,ilSpin,igSpinPr,igSpin,hmat(1,1),.FALSE.,.TRUE.,.FALSE.,lapwq=lapwq,fjgjq=fjgjq)
128 : !CALL hsmt_lo(input,atoms,sym,cell,fmpi,noco,nococonv,lapw,usdus,td,fjgj,n,chi_one,ilSpinPr,ilSpin,igSpinPr,igSpin,hmat(1,1),.FALSE.,smat(1,1))
129 : END IF
130 : ELSE
131 : ! TODO: Everything from here onwards most certainly has the wrong spin logic.
132 0 : IF (ilSpinPr==ilSpin) THEN !local spin-diagonal contribution
133 0 : CALL hsmt_spinor(ilSpinPr,n,nococonv,chi)
134 0 : IF (n.EQ.iDtype .AND. juphon%l_phonon) THEN
135 0 : CALL hsmt_nonsph(n,fmpi,sym,atoms,ilSpinPr,ilSpinPr,1,1,chi_one,noco,nococonv,cell,lapw,td,fjgj,hmat_tmp,.TRUE.,lapwq,fjgjq)
136 0 : CALL hsmt_sph(n,atoms,fmpi,ilSpinPr,input,nococonv,1,1,chi_one,lapw,enpara%el0,td%e_shift(n,ilSpinPr),usdus,fjgj,smat_tmp,hmat_tmp,.TRUE.,.TRUE.,lapwq,fjgjq)
137 0 : CALL hsmt_lo(input,atoms,sym,cell,fmpi,noco,nococonv,lapw,usdus,td,fjgj,n,chi_one,ilSpinPr,ilSpin,igSpinPr,igSpin,hmat_tmp,.TRUE.,.TRUE.,.TRUE.,smat_tmp,lapwq,fjgjq)
138 0 : CALL timestart("hsmt_distspins")
139 0 : CALL hsmt_distspins(chi,smat_tmp,s1mat_tmp)
140 0 : CALL hsmt_distspins(chi,hmat_tmp,h1mat_tmp)
141 0 : CALL timestop("hsmt_distspins")
142 : END IF
143 0 : IF (killcont(1)/=0) THEN
144 0 : CALL hsmt_nonsph(n,fmpi,sym,atoms,ilSpinPr,ilSpinPr,1,1,chi_one,noco,nococonv,cell,lapw,tdV1,fjgj,hmat_tmp,.TRUE.,lapwq,fjgjq)
145 0 : CALL hsmt_lo(input,atoms,sym,cell,fmpi,noco,nococonv,lapw,usdus,tdV1,fjgj,n,chi_one,ilSpinPr,ilSpin,igSpinPr,igSpin,hmat_tmp,.TRUE.,.TRUE.,.FALSE.,lapwq=lapwq,fjgjq=fjgjq)
146 0 : CALL timestart("hsmt_distspins")
147 0 : CALL hsmt_distspins(chi,smat_tmp,smat)
148 0 : CALL hsmt_distspins(chi,hmat_tmp,hmat)
149 0 : CALL timestop("hsmt_distspins")
150 : END IF
151 0 : ELSE IF (noco%l_unrestrictMT(n)) THEN
152 : !2,1
153 0 : CALL hsmt_spinor(3,n,nococonv,chi)
154 0 : IF (n.EQ.iDtype .AND. juphon%l_phonon) THEN
155 0 : CALL hsmt_nonsph(n,fmpi,sym,atoms,ilSpinPr,ilSpinPr,2,1,chi_one,noco,nococonv,cell,lapw,td,fjgj,hmat_tmp,.TRUE.,lapwq,fjgjq)
156 0 : CALL hsmt_lo(input,atoms,sym,cell,fmpi,noco,nococonv,lapw,usdus,td,fjgj,n,chi_one,2,1,igSpinPr,igSpin,hmat_tmp,.TRUE.,.TRUE.,.FALSE.,lapwq=lapwq,fjgjq=fjgjq)
157 0 : CALL timestart("hsmt_distspins")
158 0 : CALL hsmt_distspins(chi,smat_tmp,s1mat_tmp)
159 0 : CALL hsmt_distspins(chi,hmat_tmp,h1mat_tmp)
160 0 : CALL timestop("hsmt_distspins")
161 : END IF
162 0 : IF (killcont(1)/=0) THEN
163 0 : CALL hsmt_nonsph(n,fmpi,sym,atoms,ilSpinPr,ilSpinPr,2,1,chi_one,noco,nococonv,cell,lapw,tdV1,fjgj,hmat_tmp,.TRUE.,lapwq,fjgjq)
164 0 : CALL hsmt_lo(input,atoms,sym,cell,fmpi,noco,nococonv,lapw,usdus,tdV1,fjgj,n,chi_one,2,1,igSpinPr,igSpin,hmat_tmp,.FALSE.,.TRUE.,.FALSE.,lapwq=lapwq,fjgjq=fjgjq)
165 0 : CALL timestart("hsmt_distspins")
166 0 : CALL hsmt_distspins(chi,smat_tmp,smat)
167 0 : CALL hsmt_distspins(chi,hmat_tmp,hmat)
168 0 : CALL timestop("hsmt_distspins")
169 : END IF
170 :
171 : !1,2
172 0 : CALL hsmt_spinor(4,n,nococonv,chi)
173 0 : IF (n.EQ.iDtype .AND. juphon%l_phonon) THEN
174 0 : CALL hsmt_nonsph(n,fmpi,sym,atoms,ilSpinPr,ilSpinPr,1,2,chi_one,noco,nococonv,cell,lapw,td,fjgj,hmat_tmp,.TRUE.,lapwq,fjgjq)
175 0 : CALL hsmt_lo(input,atoms,sym,cell,fmpi,noco,nococonv,lapw,usdus,td,fjgj,n,chi_one,1,2,igSpinPr,igSpin,hmat_tmp,.TRUE.,.TRUE.,.FALSE.,lapwq=lapwq,fjgjq=fjgjq)
176 0 : CALL timestart("hsmt_distspins")
177 0 : CALL hsmt_distspins(chi,smat_tmp,s1mat_tmp)
178 0 : CALL hsmt_distspins(chi,hmat_tmp,h1mat_tmp)
179 0 : CALL timestop("hsmt_distspins")
180 : END IF
181 0 : IF (killcont(1)/=0) THEN
182 0 : CALL hsmt_nonsph(n,fmpi,sym,atoms,ilSpinPr,ilSpinPr,1,2,chi_one,noco,nococonv,cell,lapw,tdV1,fjgj,hmat_tmp,.TRUE.,lapwq,fjgjq)
183 0 : CALL hsmt_lo(input,atoms,sym,cell,fmpi,noco,nococonv,lapw,usdus,tdV1,fjgj,n,chi_one,1,2,igSpinPr,igSpin,hmat_tmp,.FALSE.,.TRUE.,.FALSE.,lapwq=lapwq,fjgjq=fjgjq)
184 0 : CALL timestart("hsmt_distspins")
185 0 : CALL hsmt_distspins(chi,smat_tmp,smat)
186 0 : CALL hsmt_distspins(chi,hmat_tmp,hmat)
187 0 : CALL timestop("hsmt_distspins")
188 : END IF
189 : END IF
190 : END IF
191 : END DO
192 : END DO
193 : END DO
194 : !!$acc end data
195 :
196 : ! TODO: Does this need some ACC magic?
197 0 : IF (juphon%l_phonon) THEN
198 0 : DO igSpinPr=MERGE(1,1,noco%l_noco),MERGE(2,1,noco%l_noco)
199 0 : DO igSpin=MERGE(1,1,noco%l_noco),MERGE(2,1,noco%l_noco)
200 : CALL matrix_pref(fmpi, atoms, cell%bmat, lapwq%gvec(:, :, igSpinPr), lapw%gvec(:,:,igSpin), lapwq, lapw, &
201 : & nk, lapwq%nv(igSpinPr), lapw%nv(igSpin), iDtype, iDir, &
202 0 : & h1mat_tmp(igSpinPr,igSpin), s1mat_tmp(igSpinPr,igSpin), hmat(igSpinPr,igSpin), smat(igSpinPr,igSpin),killcont(2:3))
203 0 : CALL h1mat_tmp(igSpinPr,igSpin)%free()
204 0 : CALL s1mat_tmp(igSpinPr,igSpin)%free()
205 : END DO
206 : END DO
207 : END IF
208 : IF (noco%l_noco) THEN
209 : !$acc exit data delete(smat_tmp%data_c,smat_tmp%data_r,hmat_tmp%data_c,hmat_tmp%data_r)
210 : !$acc exit data delete(smat_tmp,hmat_tmp)
211 : END IF
212 0 : RETURN
213 0 : END SUBROUTINE dfpt_hsmt
214 :
215 0 : SUBROUTINE dfpt_dynmat_hsmt(atoms, sym, enpara, iSpin, iDir_row, iDtype_row, iDir_col, iDtype_col, input, fmpi, &
216 : & noco, nococonv, cell, lapw, lapwq, usdus, td, tdV1,&
217 0 : hmat1, smat1, hmat1q, smat1q, hmat2, smat2, nk, killcont, vmat2)
218 :
219 : USE m_types
220 : USE m_types_mpimat
221 : USE m_hsmt_nonsph
222 : USE m_hsmt_sph
223 : USE m_hsmt_lo
224 : USE m_hsmt_distspins
225 : USE m_hsmt_fjgj
226 : USE m_hsmt_spinor
227 : USE m_matrix_pref
228 :
229 : IMPLICIT NONE
230 :
231 : TYPE(t_mpi), INTENT(IN) :: fmpi
232 : TYPE(t_input), INTENT(IN) :: input
233 : TYPE(t_noco), INTENT(IN) :: noco
234 : TYPE(t_nococonv), INTENT(IN) :: nococonv
235 : TYPE(t_sym), INTENT(IN) :: sym
236 : TYPE(t_cell), INTENT(IN) :: cell
237 : TYPE(t_atoms), INTENT(IN) :: atoms
238 : TYPE(t_enpara), INTENT(IN) :: enpara
239 : TYPE(t_lapw), INTENT(IN) :: lapw, lapwq
240 : TYPE(t_tlmplm), INTENT(IN) :: td, tdV1
241 : TYPE(t_usdus), INTENT(IN) :: usdus
242 : CLASS(t_mat), INTENT(INOUT) :: hmat1(:,:),smat1(:,:), hmat1q(:,:),smat1q(:,:), hmat2(:,:),smat2(:,:)
243 :
244 : CLASS(t_mat), OPTIONAL, INTENT(INOUT) :: vmat2(:,:)
245 :
246 : INTEGER, INTENT(IN) :: iSpin, iDir_row, iDtype_row, iDir_col, iDtype_col, nk, killcont(7)
247 :
248 0 : TYPE(t_fjgj) :: fjgj, fjgjq
249 :
250 : INTEGER :: ilSpinPr, ilSpin, nspins, i, j
251 : INTEGER :: igSpinPr, igSpin
252 : COMPLEX :: chi(2,2),chi_one
253 :
254 0 : CLASS(t_mat), ALLOCATABLE :: smat_tmp, hmat_tmp, s1mat_tmp(:,:), h1mat_tmp(:,:)
255 0 : CLASS(t_mat), ALLOCATABLE :: s1qmat_tmp(:,:), h1qmat_tmp(:,:), s2mat_tmp(:,:), h2mat_tmp(:,:)
256 :
257 0 : IF (noco%l_noco.AND..NOT.noco%l_ss) THEN
258 0 : IF (fmpi%n_size==1) THEN
259 0 : ALLOCATE(t_mat::hmat_tmp)
260 0 : ALLOCATE(t_mat::smat_tmp)
261 : ELSE
262 0 : ALLOCATE(t_mpimat::hmat_tmp)
263 0 : ALLOCATE(t_mpimat::smat_tmp)
264 : END IF
265 0 : CALL smat_tmp%init(hmat1(1,1))
266 0 : CALL hmat_tmp%init(hmat1(1,1))
267 : !$acc enter data copyin(smat_tmp,hmat_tmp)create(smat_tmp%data_c,smat_tmp%data_r,hmat_tmp%data_c,hmat_tmp%data_r)
268 : END IF
269 :
270 0 : nspins = MERGE(2, 1, noco%l_noco)
271 0 : IF (fmpi%n_size == 1) THEN
272 0 : ALLOCATE (t_mat::s1mat_tmp(nspins, nspins), h1mat_tmp(nspins, nspins))
273 0 : ALLOCATE (t_mat::s1qmat_tmp(nspins, nspins), h1qmat_tmp(nspins, nspins))
274 0 : ALLOCATE (t_mat::s2mat_tmp(nspins, nspins), h2mat_tmp(nspins, nspins))
275 : ELSE
276 0 : ALLOCATE (t_mpimat::s1mat_tmp(nspins, nspins), h1mat_tmp(nspins, nspins))
277 0 : ALLOCATE (t_mpimat::s1qmat_tmp(nspins, nspins), h1qmat_tmp(nspins, nspins))
278 0 : ALLOCATE (t_mpimat::s2mat_tmp(nspins, nspins), h2mat_tmp(nspins, nspins))
279 : END IF
280 :
281 0 : DO i = 1, nspins
282 0 : DO j = 1, nspins
283 0 : CALL s1mat_tmp(i, j)%init(.FALSE., lapw%nv(i) + atoms%nlotot, lapw%nv(j) + atoms%nlotot, fmpi%sub_comm, .false.)
284 0 : CALL h1mat_tmp(i, j)%init(s1mat_tmp(i, j))
285 0 : CALL s1qmat_tmp(i, j)%init(.FALSE., lapwq%nv(i) + atoms%nlotot, lapw%nv(j) + atoms%nlotot, fmpi%sub_comm, .false.)
286 0 : CALL h1qmat_tmp(i, j)%init(s1qmat_tmp(i, j))
287 0 : IF (.NOT.PRESENT(vmat2)) THEN
288 0 : CALL s2mat_tmp(i, j)%init(.FALSE., lapw%nv(i) + atoms%nlotot, lapw%nv(j) + atoms%nlotot, fmpi%sub_comm, .false.)
289 : ELSE
290 0 : CALL s2mat_tmp(i, j)%init(.FALSE., lapwq%nv(i) + atoms%nlotot, lapw%nv(j) + atoms%nlotot, fmpi%sub_comm, .false.)
291 : END IF
292 0 : CALL h2mat_tmp(i, j)%init(s2mat_tmp(i, j))
293 : END DO
294 : END DO
295 :
296 0 : CALL fjgj%alloc(MAXVAL(lapw%nv),atoms%lmaxd,iSpin,noco)
297 0 : CALL fjgjq%alloc(MAXVAL(lapwq%nv),atoms%lmaxd,iSpin,noco)
298 : !$acc data copyin(fjgj) create(fjgj%fj,fjgj%gj)
299 : !$acc data copyin(fjgjq) create(fjgjq%fj,fjgjq%gj)
300 0 : igSpinPr = 1; igSpin = 1; chi_one = 1.0 ! Defaults in non-noco case
301 0 : DO ilSpinPr = MERGE(1,iSpin,noco%l_noco), MERGE(2,iSpin,noco%l_noco)
302 0 : CALL timestart("fjgj coefficients")
303 0 : CALL fjgjq%calculate(input,atoms,cell,lapwq,noco,usdus,iDtype_col,ilSpinPr)
304 : !$acc update device(fjgjq%fj,fjgjq%gj)
305 0 : CALL timestop("fjgj coefficients")
306 0 : DO ilSpin = ilSpinPr, MERGE(2,iSpin,noco%l_noco)
307 0 : CALL timestart("fjgjq coefficients")
308 0 : CALL fjgj%calculate(input,atoms,cell,lapw,noco,usdus,iDtype_col,ilSpin)
309 0 : CALL timestop("fjgjq coefficients")
310 0 : IF (.NOT.noco%l_noco) THEN
311 0 : CALL hsmt_sph(iDtype_col,atoms,fmpi,ilSpinPr,input,nococonv,1,1,chi_one,lapw,enpara%el0,td%e_shift(iDtype_col,ilSpinPr),usdus,fjgj,s1qmat_tmp(1,1),h1qmat_tmp(1,1),.TRUE.,.TRUE.,lapwq,fjgjq)
312 0 : CALL hsmt_nonsph(iDtype_col,fmpi,sym,atoms,ilSpinPr,ilSpin,1,1,chi_one,noco,nococonv,cell,lapw,td,fjgj,h1qmat_tmp(1,1),.FALSE.,lapwq,fjgjq)
313 0 : CALL hsmt_lo(input,atoms,sym,cell,fmpi,noco,nococonv,lapw,usdus,td,fjgj,iDtype_col,chi_one,ilSpinPr,ilSpin,igSpinPr,igSpin,h1qmat_tmp(1,1),.FALSE.,.TRUE.,.TRUE.,s1qmat_tmp(1,1),lapwq,fjgjq)
314 :
315 0 : CALL hsmt_sph(iDtype_col,atoms,fmpi,ilSpinPr,input,nococonv,1,1,chi_one,lapw,enpara%el0,td%e_shift(iDtype_col,ilSpinPr),usdus,fjgj,s1mat_tmp(1,1),h1mat_tmp(1,1),.TRUE.,.TRUE.,lapw,fjgj)
316 0 : CALL hsmt_nonsph(iDtype_col,fmpi,sym,atoms,ilSpinPr,ilSpin,1,1,chi_one,noco,nococonv,cell,lapw,td,fjgj,h1mat_tmp(1,1),.FALSE.,lapw,fjgj)
317 0 : CALL hsmt_lo(input,atoms,sym,cell,fmpi,noco,nococonv,lapw,usdus,td,fjgj,iDtype_col,chi_one,ilSpinPr,ilSpin,igSpinPr,igSpin,h1mat_tmp(1,1),.FALSE.,.TRUE.,.TRUE.,s1mat_tmp(1,1),lapw,fjgj)
318 0 : IF (killcont(1)/=0) THEN
319 0 : IF (.NOT.PRESENT(vmat2)) THEN
320 0 : CALL hsmt_nonsph(iDtype_col,fmpi,sym,atoms,ilSpinPr,ilSpin,1,1,chi_one,noco,nococonv,cell,lapw,tdV1,fjgj,h2mat_tmp(1,1),.FALSE.,lapw,fjgj)
321 0 : CALL hsmt_lo(input,atoms,sym,cell,fmpi,noco,nococonv,lapw,usdus,tdV1,fjgj,iDtype_col,chi_one,ilSpinPr,ilSpin,igSpinPr,igSpin,h2mat_tmp(1,1),.FALSE.,.TRUE.,.FALSE.,lapwq=lapw,fjgjq=fjgj)
322 : ELSE
323 0 : CALL hsmt_nonsph(iDtype_col,fmpi,sym,atoms,ilSpinPr,ilSpin,1,1,chi_one,noco,nococonv,cell,lapw,tdV1,fjgj,h2mat_tmp(1,1),.FALSE.,lapwq,fjgjq)
324 0 : CALL hsmt_lo(input,atoms,sym,cell,fmpi,noco,nococonv,lapw,usdus,tdV1,fjgj,iDtype_col,chi_one,ilSpinPr,ilSpin,igSpinPr,igSpin,h2mat_tmp(1,1),.FALSE.,.TRUE.,.FALSE.,lapwq=lapwq,fjgjq=fjgjq)
325 : END IF
326 : END IF
327 : ELSE
328 : RETURN
329 : ! NOCO_DFPT
330 : ! TODO: I did not even try to do the right logic here yet.
331 : IF (ilSpinPr==ilSpin) THEN !local spin-diagonal contribution
332 : CALL hsmt_spinor(ilSpinPr,iDtype_col,nococonv,chi)
333 : CALL hsmt_nonsph(iDtype_col,fmpi,sym,atoms,ilSpinPr,ilSpinPr,1,1,chi_one,noco,nococonv,cell,lapw,td,fjgj,hmat_tmp,.TRUE.,lapwq,fjgjq)
334 : CALL hsmt_sph(iDtype_col,atoms,fmpi,ilSpinPr,input,nococonv,1,1,chi_one,lapw,enpara%el0,td%e_shift(iDtype_col,ilSpinPr),usdus,fjgj,smat_tmp,hmat_tmp,.TRUE.,.TRUE.,lapwq,fjgjq)
335 : CALL hsmt_lo(input,atoms,sym,cell,fmpi,noco,nococonv,lapw,usdus,td,fjgj,iDtype_col,chi_one,ilSpinPr,ilSpin,igSpinPr,igSpin,hmat_tmp,.TRUE.,.TRUE.,.TRUE.,smat_tmp,lapwq,fjgjq)
336 : CALL timestart("hsmt_distspins")
337 : CALL hsmt_distspins(chi,smat_tmp,s1mat_tmp)
338 : CALL hsmt_distspins(chi,hmat_tmp,h1mat_tmp)
339 : CALL timestop("hsmt_distspins")
340 : IF (killcont(1)/=0) THEN
341 : CALL hsmt_nonsph(iDtype_col,fmpi,sym,atoms,ilSpinPr,ilSpinPr,1,1,chi_one,noco,nococonv,cell,lapw,tdV1,fjgj,hmat_tmp,.TRUE.,lapwq,fjgjq)
342 : CALL hsmt_lo(input,atoms,sym,cell,fmpi,noco,nococonv,lapw,usdus,tdV1,fjgj,iDtype_col,chi_one,ilSpinPr,ilSpin,igSpinPr,igSpin,hmat_tmp,.TRUE.,.TRUE.,.FALSE.,lapwq=lapwq,fjgjq=fjgjq)
343 : CALL timestart("hsmt_distspins")
344 : CALL hsmt_distspins(chi,smat_tmp,smat1)
345 : CALL hsmt_distspins(chi,hmat_tmp,hmat1)
346 : CALL timestop("hsmt_distspins")
347 : END IF
348 : ELSE IF (noco%l_unrestrictMT(iDtype_col)) THEN
349 : !2,1
350 : CALL hsmt_spinor(3,iDtype_col,nococonv,chi)
351 : CALL hsmt_nonsph(iDtype_col,fmpi,sym,atoms,ilSpinPr,ilSpinPr,2,1,chi_one,noco,nococonv,cell,lapw,td,fjgj,hmat_tmp,.TRUE.,lapwq,fjgjq)
352 : CALL hsmt_lo(input,atoms,sym,cell,fmpi,noco,nococonv,lapw,usdus,td,fjgj,iDtype_col,chi_one,2,1,igSpinPr,igSpin,hmat_tmp,.TRUE.,.TRUE.,.FALSE.,lapwq=lapwq,fjgjq=fjgjq)
353 : CALL timestart("hsmt_distspins")
354 : CALL hsmt_distspins(chi,smat_tmp,s1mat_tmp)
355 : CALL hsmt_distspins(chi,hmat_tmp,h1mat_tmp)
356 : CALL timestop("hsmt_distspins")
357 : IF (killcont(1)/=0) THEN
358 : CALL hsmt_nonsph(iDtype_col,fmpi,sym,atoms,ilSpinPr,ilSpinPr,2,1,chi_one,noco,nococonv,cell,lapw,tdV1,fjgj,hmat_tmp,.TRUE.,lapwq,fjgjq)
359 : CALL hsmt_lo(input,atoms,sym,cell,fmpi,noco,nococonv,lapw,usdus,tdV1,fjgj,iDtype_col,chi_one,2,1,igSpinPr,igSpin,hmat_tmp,.FALSE.,.TRUE.,.FALSE.,lapwq=lapwq,fjgjq=fjgjq)
360 : CALL timestart("hsmt_distspins")
361 : CALL hsmt_distspins(chi,smat_tmp,smat1)
362 : CALL hsmt_distspins(chi,hmat_tmp,hmat1)
363 : CALL timestop("hsmt_distspins")
364 : END IF
365 :
366 : !1,2
367 : CALL hsmt_spinor(4,iDtype_col,nococonv,chi)
368 : CALL hsmt_nonsph(iDtype_col,fmpi,sym,atoms,ilSpinPr,ilSpinPr,1,2,chi_one,noco,nococonv,cell,lapw,td,fjgj,hmat_tmp,.TRUE.,lapwq,fjgjq)
369 : CALL hsmt_lo(input,atoms,sym,cell,fmpi,noco,nococonv,lapw,usdus,td,fjgj,iDtype_col,chi_one,1,2,igSpinPr,igSpin,hmat_tmp,.TRUE.,.TRUE.,.FALSE.,lapwq=lapwq,fjgjq=fjgjq)
370 : CALL timestart("hsmt_distspins")
371 : CALL hsmt_distspins(chi,smat_tmp,s1mat_tmp)
372 : CALL hsmt_distspins(chi,hmat_tmp,h1mat_tmp)
373 : CALL timestop("hsmt_distspins")
374 : IF (killcont(1)/=0) THEN
375 : CALL hsmt_nonsph(iDtype_col,fmpi,sym,atoms,ilSpinPr,ilSpinPr,1,2,chi_one,noco,nococonv,cell,lapw,tdV1,fjgj,hmat_tmp,.TRUE.,lapwq,fjgjq)
376 : CALL hsmt_lo(input,atoms,sym,cell,fmpi,noco,nococonv,lapw,usdus,tdV1,fjgj,iDtype_col,chi_one,1,2,igSpinPr,igSpin,hmat_tmp,.FALSE.,.TRUE.,.FALSE.,lapwq=lapwq,fjgjq=fjgjq)
377 : CALL timestart("hsmt_distspins")
378 : CALL hsmt_distspins(chi,smat_tmp,smat1)
379 : CALL hsmt_distspins(chi,hmat_tmp,hmat1)
380 : CALL timestop("hsmt_distspins")
381 : END IF
382 : END IF
383 : END IF
384 : END DO
385 : END DO
386 : !$acc end data
387 : !$acc end data
388 :
389 : ! TODO: Does this need some ACC magic?
390 0 : DO igSpinPr=MERGE(1,1,noco%l_noco),MERGE(2,1,noco%l_noco)
391 0 : DO igSpin=MERGE(1,1,noco%l_noco),MERGE(2,1,noco%l_noco)
392 : CALL matrix_pref(fmpi, atoms, cell%bmat, lapwq%gvec(:, :, igSpinPr), lapw%gvec(:,:,igSpin), lapwq, lapw, &
393 : & nk, lapwq%nv(igSpinPr), lapw%nv(igSpin), iDtype_col, iDir_col, &
394 0 : & h1qmat_tmp(igSpinPr,igSpin), s1qmat_tmp(igSpinPr,igSpin), hmat1q(igSpinPr,igSpin), smat1q(igSpinPr,igSpin),killcont(2:3))
395 0 : CALL h1qmat_tmp(igSpinPr,igSpin)%free()
396 0 : CALL s1qmat_tmp(igSpinPr,igSpin)%free()
397 : CALL matrix_pref(fmpi, atoms, cell%bmat, lapw%gvec(:, :, igSpinPr), lapw%gvec(:,:,igSpin), lapw, lapw, &
398 : & nk, lapw%nv(igSpinPr), lapw%nv(igSpin), iDtype_col, iDir_col, &
399 0 : & h1mat_tmp(igSpinPr,igSpin), s1mat_tmp(igSpinPr,igSpin), hmat1(igSpinPr,igSpin), smat1(igSpinPr,igSpin),killcont(4:5))
400 0 : CALL h1mat_tmp(igSpinPr,igSpin)%free()
401 0 : CALL s1mat_tmp(igSpinPr,igSpin)%free()
402 0 : IF (.NOT.PRESENT(vmat2)) THEN
403 : CALL matrix_pref(fmpi, atoms, cell%bmat, lapw%gvec(:, :, igSpinPr), lapw%gvec(:,:,igSpin), lapw, lapw, &
404 : & nk, lapw%nv(igSpinPr), lapw%nv(igSpin), iDtype_col, iDir_col, &
405 0 : & h2mat_tmp(igSpinPr,igSpin), s2mat_tmp(igSpinPr,igSpin), hmat2(igSpinPr,igSpin), smat2(igSpinPr,igSpin),[1,0])
406 : ELSE
407 : CALL matrix_pref(fmpi, atoms, cell%bmat, lapwq%gvec(:, :, igSpinPr), lapw%gvec(:,:,igSpin), lapwq, lapw, &
408 : & nk, lapwq%nv(igSpinPr), lapw%nv(igSpin), iDtype_col, iDir_col, &
409 0 : & h2mat_tmp(igSpinPr,igSpin), s2mat_tmp(igSpinPr,igSpin), vmat2(igSpinPr,igSpin), smat1q(igSpinPr,igSpin),[1,0])
410 : END IF
411 0 : CALL h2mat_tmp(igSpinPr,igSpin)%free()
412 0 : CALL s2mat_tmp(igSpinPr,igSpin)%free()
413 0 : IF (iDtype_row==iDtype_col) THEN
414 : CALL matrix_pref(fmpi, atoms, cell%bmat, lapw%gvec(:, :, igSpinPr), lapw%gvec(:,:,igSpin), lapw, lapw, &
415 : & nk, lapw%nv(igSpinPr), lapw%nv(igSpin), iDtype_row, iDir_row, &
416 0 : & hmat1(igSpinPr,igSpin), smat1(igSpinPr,igSpin), hmat2(igSpinPr,igSpin), smat2(igSpinPr,igSpin),killcont(6:7))
417 : END IF
418 : END DO
419 : END DO
420 : IF (noco%l_noco) THEN
421 : !$acc exit data delete(smat_tmp%data_c,smat_tmp%data_r,hmat_tmp%data_c,hmat_tmp%data_r)
422 : !$acc exit data delete(smat_tmp,hmat_tmp)
423 : END IF
424 : RETURN
425 0 : END SUBROUTINE dfpt_dynmat_hsmt
426 : END MODULE m_dfpt_hsmt
|
