Line data Source code
1 : !--------------------------------------------------------------------------------
2 : ! Copyright (c) 2016 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_types_mixvector
7 : !TODO!!!
8 : ! LDA+U
9 : ! Noco (third spin)
10 : #ifdef CPP_MPI
11 : use mpi
12 : #endif
13 : USE m_types
14 : IMPLICIT NONE
15 :
16 : PRIVATE
17 : !Here we store the pointers used for metric
18 : TYPE(t_stars), POINTER :: stars
19 : TYPE(t_cell), POINTER :: cell
20 : TYPE(t_sphhar), POINTER :: sphhar
21 : TYPE(t_atoms), POINTER :: atoms => NULL()
22 : TYPE(t_sym), POINTER :: sym => NULL()
23 : INTEGER :: jspins, nvac
24 : LOGICAL :: l_noco, invs, invs2, l_mtnocopot, l_spinoffd_ldau
25 : INTEGER :: pw_length !The shape of the local arrays
26 : INTEGER :: pw_start(3) = 0, pw_stop(3) !First and last index for spin
27 : INTEGER :: mt_length, mt_length_g
28 : INTEGER :: mt_start(3) = 0, mt_stop(3) !First and last index for spin
29 : INTEGER :: vac_length, vac_length_g
30 : INTEGER :: vac_start(3) = 0, vac_stop(3) !First and last index for spin
31 : INTEGER :: misc_length = 0, misc_length_g
32 : INTEGER :: misc_start(3) = 0, misc_stop(3) !First and last index for spin
33 : INTEGER :: mix_mpi_comm !Communicator for all PEs doing mixing
34 : LOGICAL :: spin_here(3) = .TRUE.
35 : LOGICAL :: pw_here = .TRUE.
36 : LOGICAL :: mt_here = .TRUE.
37 : LOGICAL :: vac_here = .TRUE.
38 : LOGICAL :: misc_here = .TRUE.
39 : INTEGER :: mt_rank = 0
40 : INTEGER :: mt_size = 1
41 : LOGICAL :: l_pot = .FALSE. !Is this a potential?
42 : REAL, ALLOCATABLE :: g_mt(:), g_vac(:), g_misc(:)
43 :
44 : TYPE, PUBLIC:: t_mixvector
45 : REAL, ALLOCATABLE :: vec_pw(:)
46 : REAL, ALLOCATABLE :: vec_mt(:)
47 : REAL, ALLOCATABLE :: vec_vac(:)
48 : REAL, ALLOCATABLE :: vec_misc(:)
49 : CONTAINS
50 : PROCEDURE :: alloc => mixvector_alloc
51 : PROCEDURE :: from_density => mixvector_from_density
52 : PROCEDURE :: to_density => mixvector_to_density
53 : PROCEDURE :: apply_metric => mixvector_metric
54 : PROCEDURE :: multiply_dot_mask
55 : PROCEDURE :: dfpt_multiply_dot_mask
56 : PROCEDURE :: read_unformatted
57 : PROCEDURE :: write_unformatted
58 : PROCEDURE :: allocated => mixvector_allocated
59 : END TYPE t_mixvector
60 :
61 : INTERFACE OPERATOR(*)
62 : MODULE PROCEDURE multiply_scalar
63 : MODULE PROCEDURE multiply_scalar_spin
64 : END INTERFACE OPERATOR(*)
65 : INTERFACE OPERATOR(+)
66 : MODULE PROCEDURE add_vectors
67 : END INTERFACE OPERATOR(+)
68 : INTERFACE OPERATOR(-)
69 : MODULE PROCEDURE subtract_vectors
70 : END INTERFACE OPERATOR(-)
71 : INTERFACE OPERATOR(.dot.)
72 : MODULE PROCEDURE multiply_dot
73 : END INTERFACE OPERATOR(.dot.)
74 :
75 : PUBLIC :: OPERATOR(+), OPERATOR(-), OPERATOR(*), OPERATOR(.dot.)
76 : PUBLIC :: mixvector_init, mixvector_reset
77 :
78 : CONTAINS
79 :
80 76 : SUBROUTINE READ_unformatted(this, unit)
81 : IMPLICIT NONE
82 : CLASS(t_mixvector), INTENT(INOUT)::this
83 : INTEGER, INTENT(IN)::unit
84 76 : call timestart("read_mixing")
85 76 : CALL this%alloc()
86 76 : IF (pw_here) READ (unit) this%vec_pw
87 76 : IF (mt_here) READ (unit) this%vec_mt
88 76 : IF (vac_here) READ (unit) this%vec_vac
89 76 : IF (misc_here) READ (unit) this%vec_misc
90 76 : call timestop("read_mixing")
91 76 : END SUBROUTINE READ_unformatted
92 :
93 832 : SUBROUTINE write_unformatted(this, unit)
94 : IMPLICIT NONE
95 : CLASS(t_mixvector), INTENT(IN)::this
96 : INTEGER, INTENT(IN)::unit
97 832 : call timestart("write_mixing")
98 832 : IF (pw_here) WRITE (unit) this%vec_pw
99 832 : IF (mt_here) WRITE (unit) this%vec_mt
100 832 : IF (vac_here) WRITE (unit) this%vec_vac
101 832 : IF (misc_here) WRITE (unit) this%vec_misc
102 832 : call timestop("write_mixing")
103 832 : END SUBROUTINE write_unformatted
104 :
105 146 : SUBROUTINE mixvector_reset(fullreset)
106 : IMPLICIT NONE
107 : LOGICAL, OPTIONAL, INTENT(IN) :: fullreset
108 146 : atoms => NULL()
109 146 : sym => NULL()
110 146 : IF (PRESENT(fullreset)) stars => NULL()
111 146 : IF (ALLOCATED(g_mt)) DEALLOCATE (g_mt)
112 146 : IF (ALLOCATED(g_vac)) DEALLOCATE (g_vac)
113 146 : IF (ALLOCATED(g_misc)) DEALLOCATE (g_misc)
114 : !restore defaults
115 146 : pw_start = 0
116 146 : mt_start = 0
117 146 : vac_start = 0
118 146 : misc_length = 0
119 146 : misc_start = 0
120 584 : spin_here = .TRUE.
121 146 : pw_here = .TRUE.
122 146 : mt_here = .TRUE.
123 146 : vac_here = .TRUE.
124 146 : misc_here = .TRUE.
125 146 : mt_rank = 0
126 146 : mt_size = 1
127 146 : l_pot = .FALSE. !Is this a potential?
128 146 : END SUBROUTINE mixvector_reset
129 :
130 2098 : SUBROUTINE mixvector_from_density(vec, den, nmzxyd, swapspin, denIm)
131 : USE m_types
132 : IMPLICIT NONE
133 : CLASS(t_mixvector), INTENT(INOUT) :: vec
134 : TYPE(t_potden), INTENT(inout) :: Den
135 : INTEGER, INTENT(IN) :: nmzxyd
136 : LOGICAL, INTENT(IN), OPTIONAL :: swapspin
137 : TYPE(t_potden), INTENT(INOUT), OPTIONAL :: denIm
138 : INTEGER:: js, ii, n, l, iv, jspin, mmpSize, nIJ_llp_mmpSize, offset
139 :
140 2098 : CALL den%DISTRIBUTE(mix_mpi_comm)
141 2098 : IF (PRESENT(denIm)) CALL denIm%DISTRIBUTE(mix_mpi_comm)
142 6538 : DO js = 1, MERGE(jspins, 3,.NOT. l_noco)
143 4440 : jspin = js
144 4440 : IF (PRESENT(swapspin)) THEN
145 1952 : IF (swapspin .AND. js < 3) jspin = MERGE(1, 2, js == 2)
146 : ENDIF
147 6538 : IF (spin_here(js)) THEN
148 : !PW part
149 2482 : IF (pw_here) THEN
150 5324754 : vec%vec_pw(pw_start(js):pw_start(js) + stars%ng3 - 1) = REAL(den%pw(:, jspin))
151 2220 : IF ((.NOT. sym%invs) .OR. (js == 3).OR.PRESENT(denIm)) THEN
152 4539080 : vec%vec_pw(pw_start(js) + stars%ng3:pw_start(js) + 2*stars%ng3 - 1) = AIMAG(den%pw(:, jspin))
153 : ENDIF
154 2220 : IF ((js == 3).AND.PRESENT(denIm)) THEN
155 0 : vec%vec_pw(pw_start(js) + 2*stars%ng3:pw_start(js) + 3*stars%ng3 - 1) = REAL(den%pw(:, 4))
156 0 : vec%vec_pw(pw_start(js) + 3*stars%ng3:pw_start(js) + 4*stars%ng3 - 1) = AIMAG(den%pw(:, 4))
157 : END IF
158 : ENDIF
159 2482 : IF (vac_here) THEN
160 : !This PE stores vac-data
161 156 : ii = vac_start(js) - 1
162 392 : DO iv = 1, nvac
163 59236 : vec%vec_vac(ii + 1:ii + SIZE(den%vac, 1)) = REAL(den%vac(:, 1, iv, jspin))
164 236 : ii = ii + SIZE(den%vac, 1)
165 236 : IF (PRESENT(denIm)) THEN
166 0 : vec%vec_vac(ii + 1:ii + SIZE(den%vac, 1)) = AIMAG(den%vac(:, 1, iv, jspin))
167 : ii = ii + SIZE(den%vac, 1)
168 : END IF
169 : vec%vec_vac(ii + 1:ii + nmzxyd*(SIZE(den%vac,2)-1)) = RESHAPE(REAL(den%vac(:nmzxyd, 2:, iv, jspin)), &
170 10954570 : (/nmzxyd*(SIZE(den%vac,2)-1)/))
171 236 : ii = ii + nmzxyd*(SIZE(den%vac,2)-1)
172 236 : IF ((.NOT. sym%invs2) .OR. (js == 3)) THEN
173 : vec%vec_vac(ii + 1:ii + nmzxyd*(SIZE(den%vac,2)-1)) = RESHAPE(AIMAG(den%vac(:nmzxyd, 2:, iv, jspin)), &
174 10693636 : (/nmzxyd*(SIZE(den%vac,2)-1)/))
175 218 : ii = ii + nmzxyd*(SIZE(den%vac,2)-1)
176 : ENDIF
177 392 : IF (js > 2) THEN
178 0 : vec%vec_vac(ii + 1:ii + SIZE(den%vac, 1)) = AIMAG(den%vac(:, 1, iv, 3))
179 : ii = ii + SIZE(den%vac, 1)
180 : ENDIF
181 : ENDDO
182 : ENDIF
183 2482 : IF (mt_here .AND. (js < 3 .OR. l_mtnocopot)) THEN
184 : !This PE stores some(or all) MT data
185 1880 : ii = mt_start(js) - 1
186 1880 : IF (.NOT.PRESENT(denIm)) THEN
187 5062 : DO n = mt_rank + 1, atoms%ntype, mt_size
188 98960 : DO l = 0, sphhar%nlh(sym%ntypsy(atoms%firstAtom(n)))
189 67436212 : vec%vec_mt(ii + 1:ii + atoms%jri(n)) = den%mt(:atoms%jri(n), l, n, jspin)
190 97080 : ii = ii + atoms%jri(n)
191 : ENDDO
192 : ENDDO
193 1880 : IF (js == 3) THEN !Imaginary part
194 112 : DO n = mt_rank + 1, atoms%ntype, mt_size
195 5560 : DO l = 0, sphhar%nlh(sym%ntypsy(atoms%firstAtom(n)))
196 4126944 : vec%vec_mt(ii + 1:ii + atoms%jri(n)) = den%mt(:atoms%jri(n), l, n, 4)
197 5516 : ii = ii + atoms%jri(n)
198 : ENDDO
199 : ENDDO
200 : ENDIF
201 : ELSE ! DFPT mixing
202 0 : DO n = mt_rank + 1, atoms%ntype, mt_size
203 0 : DO l = 0, sphhar%nlh(sym%ntypsy(atoms%firstAtom(n)))
204 0 : vec%vec_mt(ii + 1:ii + atoms%jri(n)) = den%mt(:atoms%jri(n), l, n, jspin)
205 0 : ii = ii + atoms%jri(n)
206 : END DO
207 : END DO
208 0 : DO n = mt_rank + 1, atoms%ntype, mt_size
209 0 : DO l = 0, sphhar%nlh(sym%ntypsy(atoms%firstAtom(n)))
210 0 : vec%vec_mt(ii + 1:ii + atoms%jri(n)) = denIm%mt(:atoms%jri(n), l, n, jspin)
211 0 : ii = ii + atoms%jri(n)
212 : END DO
213 : END DO
214 0 : IF (js == 3) THEN !Imaginary part
215 0 : DO n = mt_rank + 1, atoms%ntype, mt_size
216 0 : DO l = 0, sphhar%nlh(sym%ntypsy(atoms%firstAtom(n)))
217 0 : vec%vec_mt(ii + 1:ii + atoms%jri(n)) = den%mt(:atoms%jri(n), l, n, 4)
218 0 : ii = ii + atoms%jri(n)
219 : END DO
220 : END DO
221 0 : DO n = mt_rank + 1, atoms%ntype, mt_size
222 0 : DO l = 0, sphhar%nlh(sym%ntypsy(atoms%firstAtom(n)))
223 0 : vec%vec_mt(ii + 1:ii + atoms%jri(n)) = denIm%mt(:atoms%jri(n), l, n, 4)
224 0 : ii = ii + atoms%jri(n)
225 : END DO
226 : END DO
227 : END IF
228 : END IF
229 : ENDIF
230 2482 : IF (misc_here .AND. (js < 3 .OR. l_spinoffd_ldau)) THEN
231 640 : mmpSize = SIZE(den%mmpMat(:, :, 1:atoms%n_u, jspin))
232 34240 : vec%vec_misc(misc_start(js):misc_start(js) + mmpSize - 1) = RESHAPE(REAL(den%mmpMat(:, :, 1:atoms%n_u, jspin)), (/mmpSize/))
233 34240 : vec%vec_misc(misc_start(js) + mmpSize:misc_start(js) + 2*mmpSize - 1) = RESHAPE(AIMAG(den%mmpMat(:, :, 1:atoms%n_u, jspin)), (/mmpSize/))
234 160 : IF (atoms%n_v.GT.0) THEN
235 0 : nIJ_llp_mmpSize = SIZE(den%nIJ_llp_mmp(:,:,:,jspin))
236 0 : offset = misc_start(js) + 2*mmpSize
237 0 : vec%vec_misc(offset:offset + nIJ_llp_mmpSize - 1) = RESHAPE(REAL(den%nIJ_llp_mmp(:,:,:,jspin)), (/nIJ_llp_mmpSize/))
238 0 : vec%vec_misc(offset+nIJ_llp_mmpSize:offset + 2*nIJ_llp_mmpSize - 1) = RESHAPE(AIMAG(den%nIJ_llp_mmp(:,:,:,jspin)), (/nIJ_llp_mmpSize/))
239 : END IF
240 : END IF
241 : END IF
242 : END DO
243 :
244 2098 : END SUBROUTINE mixvector_from_density
245 :
246 654 : SUBROUTINE mixvector_to_density(vec, den, nmzxyd, denIm)
247 : USE m_types
248 : IMPLICIT NONE
249 : CLASS(t_mixvector), INTENT(IN) :: vec
250 : TYPE(t_potden), INTENT(INOUT) :: den
251 : TYPE(t_potden), INTENT(INOUT), OPTIONAL :: denIm
252 : INTEGER,INTENT(IN) :: nmzxyd
253 : INTEGER:: js, i, ii, n, l, iv, mmpSize, nIJ_llp_mmpSize, offset
254 :
255 : LOGICAL :: l_dfpt
256 654 : REAL :: vacOffdiagTemp(SIZE(den%vac, 1))
257 :
258 654 : l_dfpt = PRESENT(denIm)
259 :
260 1892 : DO js = 1, MERGE(jspins, 3,.NOT. l_noco)
261 1892 : IF (spin_here(js)) THEN
262 : !PW part
263 750 : IF (pw_here) THEN
264 619 : IF (sym%invs .AND. js < 3 .AND. .NOT. l_dfpt) THEN
265 207403 : den%pw(:, js) = vec%vec_pw(pw_start(js):pw_start(js) + stars%ng3 - 1)
266 : ELSE
267 1266540 : den%pw(:, js) = CMPLX(vec%vec_pw(pw_start(js):pw_start(js) + stars%ng3 - 1), vec%vec_pw(pw_start(js) + stars%ng3:pw_start(js) + 2*stars%ng3 - 1))
268 329 : IF (l_dfpt.AND.js==3) THEN
269 0 : den%pw(:, 4) = CMPLX(vec%vec_pw(pw_start(js) + 2*stars%ng3:pw_start(js) + 3*stars%ng3 - 1), vec%vec_pw(pw_start(js) + 3*stars%ng3:pw_start(js) + 4*stars%ng3 - 1))
270 : END IF
271 : ENDIF
272 : ENDIF
273 750 : IF (mt_here .AND. (js < 3 .OR. l_mtnocopot)) THEN
274 : !This PE stores some(or all) MT data
275 534 : ii = mt_start(js)
276 1445 : DO n = mt_rank + 1, atoms%ntype, mt_size
277 27193 : DO l = 0, sphhar%nlh(sym%ntypsy(atoms%firstAtom(n)))
278 18494780 : den%mt(:atoms%jri(n), l, n, js) = vec%vec_mt(ii:ii + atoms%jri(n) - 1)
279 26659 : ii = ii + atoms%jri(n)
280 : ENDDO
281 : ENDDO
282 534 : IF (l_dfpt) THEN
283 0 : DO n = mt_rank + 1, atoms%ntype, mt_size
284 0 : DO l = 0, sphhar%nlh(sym%ntypsy(atoms%firstAtom(n)))
285 0 : denIm%mt(:atoms%jri(n), l, n, js) = vec%vec_mt(ii:ii + atoms%jri(n) - 1)
286 0 : ii = ii + atoms%jri(n)
287 : ENDDO
288 : ENDDO
289 : END IF
290 534 : IF (js == 3) THEN !Imaginary part comes as 4th spin
291 28 : DO n = mt_rank + 1, atoms%ntype, mt_size
292 1390 : DO l = 0, sphhar%nlh(sym%ntypsy(atoms%firstAtom(n)))
293 1031736 : den%mt(:atoms%jri(n), l, n, 4) = vec%vec_mt(ii:ii + atoms%jri(n) - 1)
294 1379 : ii = ii + atoms%jri(n)
295 : ENDDO
296 : ENDDO
297 11 : IF (l_dfpt) THEN
298 0 : DO n = mt_rank + 1, atoms%ntype, mt_size
299 0 : DO l = 0, sphhar%nlh(sym%ntypsy(atoms%firstAtom(n)))
300 0 : denIm%mt(:atoms%jri(n), l, n, 4) = vec%vec_mt(ii:ii + atoms%jri(n) - 1)
301 0 : ii = ii + atoms%jri(n)
302 : ENDDO
303 : ENDDO
304 : END IF
305 : ENDIF
306 : ENDIF
307 750 : IF (vac_here) THEN
308 : !This PE stores vac-data
309 50 : ii = vac_start(js) - 1
310 120 : DO iv = 1, nvac
311 17570 : den%vac(:, 1, iv, js) = vec%vec_vac(ii + 1:ii + SIZE(den%vac, 1))
312 70 : ii = ii + SIZE(den%vac, 1)
313 70 : IF (l_dfpt) THEN
314 0 : den%vac(:, 1, iv, js) = den%vac(:, 1, iv, js) + ImagUnit*vec%vec_vac(ii + 1:ii + SIZE(den%vac, 1))
315 : ii = ii + SIZE(den%vac, 1)
316 : END IF
317 70 : IF (sym%invs2 .AND. js < 3) THEN
318 36880 : den%vac(:nmzxyd, 2:, iv, js) = RESHAPE(vec%vec_vac(ii + 1:ii + nmzxyd*(SIZE(den%vac,2)-1)), SHAPE(den%vac(:nmzxyd, 2:, iv, js)))
319 5 : ii = ii + nmzxyd*(SIZE(den%vac,2)-1)
320 : ELSE
321 : den%vac(:nmzxyd, 2:, iv, js) = RESHAPE(CMPLX(vec%vec_vac(ii + 1:ii + nmzxyd*(SIZE(den%vac,2)-1)), &
322 : vec%vec_vac(ii + nmzxyd*(SIZE(den%vac,2)-1) + 1:ii + 2*nmzxyd*(SIZE(den%vac,2)-1))), &
323 3759764 : SHAPE(den%vac(:nmzxyd, 2:, iv, js)))
324 65 : ii = ii + 2*nmzxyd*(SIZE(den%vac,2)-1)
325 : ENDIF
326 120 : IF (js > 2) THEN
327 0 : vacOffdiagTemp(:) = vec%vec_vac(ii + 1:ii + SIZE(den%vac, 1))
328 0 : DO i = 1, SIZE(den%vac, 1)
329 0 : den%vac(i, 1, iv, 3) = CMPLX(REAL(den%vac(i, 1, iv, 3)),vacOffdiagTemp(i))
330 : END DO
331 : ii = ii + SIZE(den%vac, 1)
332 : ENDIF
333 : ENDDO
334 : ENDIF
335 750 : IF (misc_here .AND. (js < 3 .OR. l_spinoffd_ldau)) THEN
336 184 : mmpSize = SIZE(den%mmpMat(:, :, 1:atoms%n_u, js))
337 : den%mmpMat(:, :, 1:atoms%n_u, js) = RESHAPE(CMPLX(vec%vec_misc(misc_start(js):misc_start(js) + mmpSize - 1), &
338 : vec%vec_misc(misc_start(js) + mmpSize:misc_start(js) + 2*mmpSize - 1)), &
339 11254 : SHAPE(den%mmpMat(:, :, 1:atoms%n_u, js)))
340 46 : IF (atoms%n_v.GT.0) THEN
341 0 : nIJ_llp_mmpSize = SIZE(den%nIJ_llp_mmp(:,:,:,js))
342 0 : offset = misc_start(js) + 2*mmpSize
343 : den%nIJ_llp_mmp(:,:,:,js) = RESHAPE(CMPLX(vec%vec_misc(offset:offset + nIJ_llp_mmpSize - 1), &
344 : vec%vec_misc(offset + nIJ_llp_mmpSize:offset + 2*nIJ_llp_mmpSize - 1)), &
345 0 : SHAPE(den%nIJ_llp_mmp(:,:,:,js)))
346 : END IF
347 : END IF
348 : END IF
349 : ENDDO
350 :
351 654 : IF (.NOT.l_dfpt) THEN
352 654 : CALL den%collect(mix_mpi_comm)
353 : ELSE
354 0 : CALL den%collect(mix_mpi_comm,denIm)
355 : END IF
356 :
357 654 : END SUBROUTINE mixvector_to_density
358 :
359 4244 : FUNCTION mixvector_metric(vec,l_dfpt) RESULT(mvec)
360 : USE m_types
361 : USE m_convol
362 : IMPLICIT NONE
363 : CLASS(t_mixvector), INTENT(IN) :: vec
364 : LOGICAL, INTENT(IN) :: l_dfpt
365 :
366 : TYPE(t_mixvector) :: mvec
367 :
368 : INTEGER:: js, ii, n, l, iv
369 4244 : COMPLEX, ALLOCATABLE::pw(:), pw_w(:)
370 4244 : call timestart("metric")
371 4244 : mvec = vec
372 14012 : IF (pw_here) ALLOCATE (pw(stars%ng3), pw_w(stars%ng3))
373 :
374 12060 : DO js = 1, MERGE(jspins, 3,.NOT. l_noco)
375 12060 : IF (spin_here(js)) THEN
376 : !PW part
377 4896 : IF (pw_here) THEN
378 : !Put back on g-grid and use convol
379 3908 : IF (sym%invs .AND. js < 3 .AND. .NOT. l_dfpt) THEN
380 612658 : pw(:) = vec%vec_pw(pw_start(js):pw_start(js) + stars%ng3 - 1)
381 : ELSE
382 4847235 : pw(:) = CMPLX(vec%vec_pw(pw_start(js):pw_start(js) + stars%ng3 - 1), vec%vec_pw(pw_start(js) + stars%ng3:pw_start(js) + 2*stars%ng3 - 1))
383 : ENDIF
384 3908 : CALL convol(stars, pw_w, pw)
385 5459893 : pw_w = pw_w*cell%omtil
386 5459893 : mvec%vec_pw(pw_start(js):pw_start(js) + stars%ng3 - 1) = REAL(pw_w)
387 3908 : IF ((.NOT. sym%invs) .OR. (js == 3) .OR. l_dfpt) THEN
388 4847235 : mvec%vec_pw(pw_start(js) + stars%ng3:pw_start(js) + 2*stars%ng3 - 1) = AIMAG(pw_w)
389 : ENDIF
390 3908 : IF ((js == 3) .AND. l_dfpt) THEN
391 0 : pw(:) = CMPLX(vec%vec_pw(pw_start(js) + 2*stars%ng3:pw_start(js) + 3*stars%ng3 - 1), vec%vec_pw(pw_start(js) + 3*stars%ng3:pw_start(js) + 4*stars%ng3 - 1))
392 0 : CALL convol(stars, pw_w, pw)
393 0 : pw_w = pw_w*cell%omtil
394 0 : mvec%vec_pw(pw_start(js) + 2*stars%ng3:pw_start(js) + 3*stars%ng3 - 1) = REAL(pw_w)
395 0 : mvec%vec_pw(pw_start(js) + 3*stars%ng3:pw_start(js) + 4*stars%ng3 - 1) = AIMAG(pw_w)
396 : END IF
397 : ENDIF
398 4896 : IF (mt_here .AND. (js < 3 .OR. l_mtnocopot)) THEN
399 : !This PE stores some(or all) MT data
400 3272 : IF (.NOT.l_dfpt) THEN
401 85987622 : mvec%vec_mt(mt_start(js):mt_start(js) + SIZE(g_mt) - 1) = g_mt*vec%vec_mt(mt_start(js):mt_start(js) + SIZE(g_mt) - 1)
402 3272 : IF (js == 3) THEN
403 : !Here we have a the imaginary part as well
404 1520926 : mvec%vec_mt(mt_start(js) + SIZE(g_mt):mt_stop(js)) = g_mt*vec%vec_mt(mt_start(js) + SIZE(g_mt):mt_stop(js))
405 : ENDIF
406 : ELSE
407 0 : mvec%vec_mt(mt_start(js):mt_start(js) + SIZE(g_mt) - 1) = g_mt*vec%vec_mt(mt_start(js):mt_start(js) + SIZE(g_mt) - 1)
408 0 : mvec%vec_mt(mt_start(js) + SIZE(g_mt):mt_start(js) + 2*SIZE(g_mt) - 1) = g_mt*vec%vec_mt(mt_start(js) + SIZE(g_mt):mt_start(js) + 2*SIZE(g_mt) - 1)
409 0 : IF (js == 3) THEN
410 0 : mvec%vec_mt(mt_start(js) + 2*SIZE(g_mt):mt_start(js) + 3*SIZE(g_mt) - 1) = g_mt*vec%vec_mt(mt_start(js) + 2*SIZE(g_mt):mt_start(js) + 3*SIZE(g_mt) - 1)
411 0 : mvec%vec_mt(mt_start(js) + 3*SIZE(g_mt):mt_start(js) + 4*SIZE(g_mt) - 1) = g_mt*vec%vec_mt(mt_start(js) + 3*SIZE(g_mt):mt_start(js) + 4*SIZE(g_mt) - 1)
412 : ENDIF
413 : END IF
414 : ENDIF
415 4896 : IF (vac_here) THEN
416 25649811 : mvec%vec_vac(vac_start(js):vac_start(js) + SIZE(g_vac) - 1) = g_vac*vec%vec_vac(vac_start(js):vac_start(js) + SIZE(g_vac) - 1)
417 261 : IF (js == 3) THEN !We have some extra data that corresponds to first part of metric
418 0 : mvec%vec_vac(vac_start(js) + SIZE(g_vac):vac_stop(js)) = g_vac(:vac_stop(js) - vac_start(js) - SIZE(g_vac) + 1)*vec%vec_vac(vac_start(js) + SIZE(g_vac):vac_stop(js))
419 : ENDIF
420 : ENDIF
421 4896 : IF (misc_here .AND. (js < 3 .OR. l_spinoffd_ldau)) THEN
422 46623 : mvec%vec_misc(misc_start(js):misc_stop(js)) = g_misc*vec%vec_misc(misc_start(js):misc_stop(js))
423 : END IF
424 : ENDIF
425 : END DO
426 4244 : call timestop("metric")
427 8488 : END FUNCTION mixvector_metric
428 :
429 144 : SUBROUTINE init_metric(vacuum, stars, l_dfpt)
430 : USE m_metrz0
431 : IMPLICIT NONE
432 : !
433 : TYPE(t_vacuum), INTENT(in) :: vacuum
434 : TYPE(t_stars), INTENT(in) :: stars
435 : LOGICAL, INTENT(in) :: l_dfpt
436 :
437 : INTEGER:: i, n, l, j, ivac, iz, iv2c, k2, iv2
438 : REAL:: dxn, dxn2, dxn4, dvol, volnstr2
439 144 : REAL, ALLOCATABLE:: wght(:)
440 :
441 144 : IF (mt_here) THEN
442 : !This PE stores some(or all) MT data
443 369 : ALLOCATE (g_mt(mt_length_g))
444 123 : i = 0
445 328 : DO n = mt_rank + 1, atoms%ntype, mt_size
446 205 : dxn = atoms%neq(n)*atoms%dx(n)/3.0
447 205 : dxn2 = 2.0*dxn
448 205 : dxn4 = 4.0*dxn
449 7906 : DO l = 0, sphhar%nlh(sym%ntypsy(atoms%firstAtom(n)))
450 7578 : i = i + 1
451 7578 : g_mt(i) = dxn/atoms%rmsh(1, n)
452 7783 : IF (.NOT. l_pot) THEN
453 7578 : DO j = 2, atoms%jri(n) - 1, 2
454 2756920 : i = i + 2
455 2756920 : g_mt(i - 1) = dxn4/atoms%rmsh(j, n)
456 2756920 : g_mt(i) = dxn2/atoms%rmsh(j + 1, n)
457 : END DO
458 : ! CHANGE JR 96/12/01
459 : ! take care when jri(n) is even
460 7578 : i = i + 1 - MOD(atoms%jri(n), 2)
461 7578 : g_mt(i) = dxn/atoms%rmsh(atoms%jri(n), n)
462 : ELSE
463 : ! for the potential multiply by r^4
464 0 : DO j = 2, atoms%jri(n) - 1, 2
465 0 : i = i + 2
466 0 : g_mt(i - 1) = dxn4*atoms%rmsh(j, n)**3
467 0 : g_mt(i) = dxn2*atoms%rmsh(j + 1, n)**3
468 : END DO
469 0 : i = i + 1 - MOD(atoms%jri(n), 2)
470 0 : g_mt(i) = dxn*atoms%rmsh(atoms%jri(n), n)**3
471 : END IF
472 : END DO
473 : END DO
474 : ENDIF
475 144 : i = 0
476 144 : IF (vac_here) THEN
477 16 : iv2 = 2
478 16 : IF (sym%invs2) iv2 = 1
479 :
480 80 : ALLOCATE (g_vac(vac_length_g), wght(vacuum%nmzd))
481 710316 : g_vac(:) = 0.0
482 16 : dvol = cell%area*vacuum%delz
483 : ! nvac=1 if (zrfs.or.invs)
484 16 : IF (vacuum%nvac .EQ. 1) dvol = dvol + dvol
485 36 : DO ivac = 1, vacuum%nvac
486 : ! G||=0 components
487 : !
488 : ! use 7-point simpson integration in accordance to intgz0.f
489 : ! calculate weights for integration
490 20 : CALL metr_z0(vacuum%nmz, wght)
491 5020 : DO iz = 1, vacuum%nmz
492 5000 : i = i + 1
493 : !
494 5020 : g_vac(i) = wght(iz)*dvol
495 : !
496 : END DO
497 20 : IF (l_dfpt) THEN
498 0 : DO iz = 1, vacuum%nmz
499 0 : i = i + 1
500 : !
501 0 : g_vac(i) = wght(iz)*dvol
502 : !
503 : END DO
504 : END IF
505 : ! G||.ne.0 components
506 : !
507 : ! calculate weights for integration
508 20 : CALL metr_z0(vacuum%nmzxy, wght)
509 71 : DO iv2c = 1, iv2
510 7108 : DO k2 = 1, stars%ng2 - 1
511 : !
512 7053 : volnstr2 = dvol*stars%nstr2(k2)
513 712388 : DO iz = 1, vacuum%nmzxy
514 705300 : i = i + 1
515 712353 : g_vac(i) = wght(iz)*volnstr2
516 : END DO
517 : !
518 : END DO
519 : END DO
520 : END DO
521 : END IF
522 144 : IF (misc_here) THEN
523 33 : ALLOCATE (g_misc(misc_length_g))
524 1775 : g_misc = 1.0
525 : END IF
526 :
527 144 : END SUBROUTINE init_metric
528 :
529 144 : SUBROUTINE init_storage_mpi(comm_mpi)
530 : IMPLICIT NONE
531 : INTEGER, INTENT(in):: comm_mpi
532 : INTEGER :: irank, isize, err, js, new_comm
533 144 : mix_mpi_comm = comm_mpi
534 : #ifdef CPP_MPI
535 :
536 144 : CALL mpi_comm_rank(comm_mpi, irank, err)
537 144 : CALL mpi_comm_size(comm_mpi, isize, err)
538 :
539 288 : IF (isize == 1) RETURN !No parallelization
540 144 : js = MERGE(jspins, 3,.NOT. l_noco)!distribute spins
541 144 : js = MIN(js, isize)
542 144 : CALL judft_comm_split(comm_mpi, MOD(irank, js), irank, new_comm)
543 648 : spin_here = (/MOD(irank, js) == 0, MOD(irank, js) == 1, (isize == 2 .AND. irank == 0) .OR. MOD(irank, js) == 2/)
544 :
545 144 : CALL mpi_comm_rank(new_comm, irank, err)
546 144 : CALL mpi_comm_size(new_comm, isize, err)
547 144 : CALL mpi_comm_free(new_comm, err)
548 :
549 : !Now distribute data
550 144 : IF (isize == 1) RETURN !No further parallelism
551 : !Split off the pw-part
552 42 : pw_here = (irank == 0)
553 42 : mt_here = (irank > 0)
554 42 : vac_here = vac_here .AND. (irank > 0)
555 42 : misc_here = misc_here .AND. (irank > 0)
556 42 : isize = isize - 1
557 42 : irank = irank - 1
558 42 : mt_rank = irank
559 42 : mt_size = isize
560 42 : IF (isize == 1 .OR. irank < 0) RETURN !No further parallelism
561 0 : IF (vac_here .OR. misc_here) THEN !split off-vacuum&misc part
562 0 : vac_here = vac_here .AND. (irank == 0)
563 0 : misc_here = misc_here .AND. (irank == 0)
564 0 : mt_here = (irank > 0)
565 0 : isize = isize - 1
566 0 : irank = irank - 1
567 : ENDIF
568 0 : mt_rank = irank
569 0 : mt_size = isize
570 : #endif
571 288 : END SUBROUTINE init_storage_mpi
572 :
573 654 : SUBROUTINE mixvector_init(comm_mpi, l_densitymatrix, l_densitymatrixV, input, vacuum, noco, stars_i, cell_i, sphhar_i, atoms_i, sym_i, l_dfpt)
574 : USE m_types
575 : IMPLICIT NONE
576 : INTEGER, INTENT(IN) :: comm_mpi
577 : LOGICAL, INTENT(IN) :: l_densitymatrix
578 : LOGICAL, INTENT(IN) :: l_densitymatrixV
579 :
580 : TYPE(t_input), INTENT(IN) :: input
581 : TYPE(t_vacuum), INTENT(IN), TARGET :: vacuum
582 : TYPE(t_noco), INTENT(IN) :: noco
583 : TYPE(t_stars), INTENT(IN), TARGET :: stars_i
584 : TYPE(t_cell), INTENT(IN), TARGET :: cell_i
585 : TYPE(t_sphhar), INTENT(IN), TARGET :: sphhar_i
586 : TYPE(t_atoms), INTENT(IN), TARGET :: atoms_i
587 : TYPE(t_sym), INTENT(IN), TARGET :: sym_i
588 :
589 : LOGICAL, INTENT(IN) :: l_dfpt
590 :
591 : INTEGER :: js, n, len, i_v, natom2
592 :
593 : !Store pointers to data-types
594 654 : IF (ASSOCIATED(atoms)) RETURN !was done before...
595 144 : jspins = input%jspins
596 144 : nvac = vacuum%nvac
597 144 : l_noco = noco%l_noco
598 372 : l_mtnocopot = any(noco%l_unrestrictMT)
599 622 : l_spinoffd_ldau = any(noco%l_unrestrictMT).OR.any(noco%l_spinoffd_ldau)
600 144 : stars => stars_i; cell => cell_i; sphhar => sphhar_i; atoms => atoms_i; sym => sym_i
601 :
602 144 : vac_here = input%film
603 144 : misc_here = l_densitymatrix.OR.l_densitymatrixV
604 144 : CALL init_storage_mpi(comm_mpi)
605 :
606 144 : pw_length = 0; mt_length = 0; vac_length = 0; misc_length = 0
607 144 : mt_length_g = 0; vac_length_g = 0; misc_length_g = 0
608 436 : DO js = 1, MERGE(jspins, 3,.NOT. l_noco)
609 436 : IF (spin_here(js)) THEN
610 : !Now calculate the length of the vectors
611 167 : IF (pw_here) THEN
612 146 : pw_start(js) = pw_length + 1
613 146 : IF (sym%invs .AND. js < 3 .AND. .NOT. l_dfpt) THEN
614 73 : pw_length = pw_length + stars%ng3
615 : ELSE
616 73 : pw_length = pw_length + 2*stars%ng3
617 : ENDIF
618 146 : IF (l_dfpt.AND.js==3) pw_length = pw_length + 2*stars%ng3
619 : ENDIF
620 167 : pw_stop(js) = pw_length
621 167 : IF (mt_here) THEN
622 351 : IF (js < 3 .OR. any(noco%l_unrestrictMT)) mt_start(js) = mt_length + 1
623 146 : len = 0
624 : !This PE stores some(or all) MT data
625 384 : DO n = mt_rank + 1, atoms%ntype, mt_size
626 384 : IF (l_dfpt) THEN
627 0 : len = len + 2*(sphhar%nlh(sym%ntypsy(atoms%firstAtom(n))) + 1)*atoms%jri(n)
628 : ELSE
629 238 : len = len + (sphhar%nlh(sym%ntypsy(atoms%firstAtom(n))) + 1)*atoms%jri(n)
630 : END IF
631 : ENDDO
632 146 : mt_length_g = MAX(len, mt_length_g)
633 146 : IF (l_dfpt) mt_length_g = mt_length_g / 2
634 146 : IF (js == 3) THEN
635 : !need to store imaginary part as well...
636 56 : DO n = mt_rank + 1, atoms%ntype, mt_size
637 56 : IF (l_dfpt) THEN
638 0 : len = len + 2*(sphhar%nlh(sym%ntypsy(atoms%firstAtom(n))) + 1)*atoms%jri(n)
639 : ELSE
640 33 : len = len + (sphhar%nlh(sym%ntypsy(atoms%firstAtom(n))) + 1)*atoms%jri(n)
641 : END IF
642 : ENDDO
643 : ENDIF
644 351 : IF (js < 3 .OR. any(noco%l_unrestrictMT)) mt_length = mt_length + len
645 146 : mt_stop(js) = mt_length
646 : END IF
647 167 : IF (vac_here) THEN
648 : !This PE stores vac-data
649 16 : vac_start(js) = vac_length + 1
650 16 : len = 0
651 16 : IF (sym%invs2 .AND. js < 3) THEN
652 5 : len = len + vacuum%nmzxyd*(stars%ng2 - 1)*vacuum%nvac + vacuum%nmzd*vacuum%nvac
653 : ELSE
654 11 : len = len + 2*vacuum%nmzxyd*(stars%ng2 - 1)*vacuum%nvac + vacuum%nmzd*vacuum%nvac
655 : ENDIF
656 16 : IF (l_dfpt) len = len + vacuum%nmzd*vacuum%nvac !vacz is complex
657 16 : vac_length_g = MAX(vac_length_g, len)
658 16 : IF (js == 3) len = len + vacuum%nmzd*vacuum%nvac !Offdiagnal potential is complex
659 16 : vac_length = vac_length + len
660 16 : vac_stop(js) = vac_length
661 : ENDIF
662 167 : IF (misc_here .AND. (js < 3 .OR. l_spinoffd_ldau)) THEN
663 11 : len = 7*7*2*atoms%n_u
664 11 : DO i_v = 1, atoms%n_v !loop over pairs which are corrected by U+V
665 11 : DO natom2 = 1, atoms%lda_v(i_v)%numOtherAtoms
666 0 : len = len + 7*7*2
667 : END DO
668 : END DO
669 11 : misc_start(js) = misc_length + 1
670 11 : misc_length = misc_length + len
671 11 : misc_stop(js) = misc_length
672 11 : misc_length_g = MAX(len, misc_length_g)
673 : END IF
674 : END IF
675 : END DO
676 144 : CALL init_metric(vacuum, stars, l_dfpt)
677 : END SUBROUTINE mixvector_init
678 11650 : SUBROUTINE mixvector_alloc(vec)
679 : IMPLICIT NONE
680 : CLASS(t_mixvector), INTENT(OUT) :: vec
681 34950 : ALLOCATE (vec%vec_pw(pw_length))
682 34950 : ALLOCATE (vec%vec_mt(mt_length))
683 34950 : ALLOCATE (vec%vec_vac(vac_length))
684 34950 : ALLOCATE (vec%vec_misc(misc_length))
685 11650 : END SUBROUTINE mixvector_alloc
686 :
687 42302 : FUNCTION multiply_scalar(scalar, vec) RESULT(vecout)
688 : TYPE(t_mixvector), INTENT(IN)::vec
689 : REAL, INTENT(IN) ::scalar
690 : TYPE(t_mixvector) ::vecout
691 :
692 42302 : vecout = vec
693 81962441 : vecout%vec_pw = vecout%vec_pw*scalar
694 734459678 : vecout%vec_mt = vecout%vec_mt*scalar
695 270407102 : vecout%vec_vac = vecout%vec_vac*scalar
696 321014 : vecout%vec_misc = vecout%vec_misc*scalar
697 42302 : END FUNCTION multiply_scalar
698 :
699 0 : FUNCTION multiply_scalar_spin(scalar, vec) RESULT(vecout)
700 : TYPE(t_mixvector), INTENT(IN)::vec
701 : REAL, INTENT(IN) ::scalar(:)
702 : TYPE(t_mixvector) ::vecout
703 :
704 : INTEGER:: js
705 : REAL:: fac
706 :
707 0 : vecout = vec
708 0 : DO js = 1, MERGE(jspins, 3,.NOT. l_noco)
709 0 : IF (SIZE(scalar) < js) THEN
710 : fac = 0.0
711 : ELSE
712 0 : fac = scalar(js)
713 : ENDIF
714 0 : IF (pw_start(js) > 0) vecout%vec_pw(pw_start(js):pw_stop(js)) = vecout%vec_pw(pw_start(js):pw_stop(js))*fac
715 0 : IF (mt_start(js) > 0) vecout%vec_mt(mt_start(js):mt_stop(js)) = vecout%vec_mt(mt_start(js):mt_stop(js))*fac
716 0 : IF (vac_start(js) > 0) vecout%vec_vac(vac_start(js):vac_stop(js)) = vecout%vec_vac(vac_start(js):vac_stop(js))*fac
717 0 : IF (misc_start(js) > 0) vecout%vec_misc(misc_start(js):misc_stop(js)) = vecout%vec_misc(misc_start(js):misc_stop(js))*fac
718 : END DO
719 0 : END FUNCTION multiply_scalar_spin
720 :
721 4244 : FUNCTION add_vectors(vec1, vec2) RESULT(vecout)
722 : TYPE(t_mixvector), INTENT(IN)::vec1, vec2
723 : TYPE(t_mixvector) ::vecout
724 :
725 4244 : vecout = vec1
726 10309567 : vecout%vec_pw = vecout%vec_pw + vec2%vec_pw
727 87513748 : vecout%vec_mt = vecout%vec_mt + vec2%vec_mt
728 25658038 : vecout%vec_vac = vecout%vec_vac + vec2%vec_vac
729 54940 : vecout%vec_misc = vecout%vec_misc + vec2%vec_misc
730 4244 : END FUNCTION add_vectors
731 :
732 42694 : FUNCTION subtract_vectors(vec1, vec2) RESULT(vecout)
733 : TYPE(t_mixvector), INTENT(IN)::vec1, vec2
734 : TYPE(t_mixvector) ::vecout
735 :
736 42694 : vecout = vec1
737 84192391 : vecout%vec_pw = vecout%vec_pw - vec2%vec_pw
738 750578564 : vecout%vec_mt = vecout%vec_mt - vec2%vec_mt
739 272069788 : vecout%vec_vac = vecout%vec_vac - vec2%vec_vac
740 369588 : vecout%vec_misc = vecout%vec_misc - vec2%vec_misc
741 42694 : END FUNCTION subtract_vectors
742 :
743 21334 : FUNCTION multiply_dot(vec1, vec2) RESULT(dprod)
744 : TYPE(t_mixvector), INTENT(IN)::vec1, vec2
745 : REAL ::dprod, dprod_tmp
746 : INTEGER ::ierr
747 41331446 : dprod = DOT_PRODUCT(vec1%vec_pw, vec2%vec_pw)
748 370127566 : dprod = dprod + DOT_PRODUCT(vec1%vec_mt, vec2%vec_mt)
749 136390834 : dprod = dprod + DOT_PRODUCT(vec1%vec_vac, vec2%vec_vac)
750 164022 : dprod = dprod + DOT_PRODUCT(vec1%vec_misc, vec2%vec_misc)
751 : #ifdef CPP_MPI
752 21334 : CALL MPI_ALLREDUCE(dprod, dprod_tmp, 1, MPI_DOUBLE_PRECISION, MPI_SUM, mix_mpi_comm, ierr)
753 21334 : dprod = dprod_tmp
754 : #endif
755 21334 : END FUNCTION multiply_dot
756 :
757 1630 : FUNCTION multiply_dot_mask(vec1, vec2, mask, spin) RESULT(dprod)
758 : CLASS(t_mixvector), INTENT(IN)::vec1
759 : TYPE(t_mixvector), INTENT(IN)::vec2
760 : LOGICAL, INTENT(IN) ::mask(4)
761 : INTEGER, INTENT(IN) ::spin
762 : REAL ::dprod, dprod_tmp
763 :
764 : INTEGER:: js, ierr
765 :
766 1630 : dprod = 0.0
767 :
768 6520 : DO js = 1, 3
769 4890 : IF (mask(1) .AND. (spin == js .OR. spin == 0) .AND. pw_start(js) > 0) &
770 : dprod = dprod + DOT_PRODUCT(vec1%vec_pw(pw_start(js):pw_stop(js)), &
771 3523430 : vec2%vec_pw(pw_start(js):pw_stop(js)))
772 4890 : IF (mask(2) .AND. (spin == js .OR. spin == 0) .AND. mt_start(js) > 0) &
773 : dprod = dprod + DOT_PRODUCT(vec1%vec_mt(mt_start(js):mt_stop(js)), &
774 26507662 : vec2%vec_mt(mt_start(js):mt_stop(js)))
775 4890 : IF (mask(3) .AND. (spin == js .OR. spin == 0) .AND. vac_start(js) > 0) &
776 : dprod = dprod + DOT_PRODUCT(vec1%vec_vac(vac_start(js):vac_stop(js)), &
777 4604664 : vec2%vec_vac(vac_start(js):vac_stop(js)))
778 4890 : IF (mask(4) .AND. (spin == js .OR. spin == 0) .AND. misc_start(js) > 0) &
779 : dprod = dprod + DOT_PRODUCT(vec1%vec_misc(misc_start(js):misc_stop(js)), &
780 1630 : vec2%vec_misc(misc_start(js):misc_stop(js)))
781 : ENDDO
782 :
783 : #ifdef CPP_MPI
784 1630 : CALL MPI_ALLREDUCE(dprod, dprod_tmp, 1, MPI_DOUBLE_PRECISION, MPI_SUM, mix_mpi_comm, ierr)
785 1630 : dprod = dprod_tmp
786 : #endif
787 1630 : END FUNCTION multiply_dot_mask
788 :
789 0 : SUBROUTINE dfpt_multiply_dot_mask(vec1, vec2, mask, spin, dprod1, dprod2)
790 : CLASS(t_mixvector), INTENT(IN)::vec1
791 : TYPE(t_mixvector), INTENT(IN)::vec2
792 :
793 : LOGICAL, INTENT(IN) :: mask(3)
794 : INTEGER, INTENT(IN) :: spin
795 : REAL, INTENT(INOUT) :: dprod1(2)
796 :
797 : REAL, OPTIONAL, INTENT(INOUT) :: dprod2(2)
798 :
799 : REAL :: dprod1_tmp(2), dprod2_tmp(2)
800 : INTEGER:: js, ierr
801 :
802 0 : dprod1 = 0.0
803 0 : IF (PRESENT(dprod2)) dprod2 = 0.0
804 :
805 0 : DO js = 1, 2
806 0 : IF (mask(1) .AND. (spin == js) .AND. pw_start(js) > 0) THEN
807 : dprod1(1) = dprod1(1) + DOT_PRODUCT(vec1%vec_pw(pw_start(js):pw_stop(js)/2), &
808 0 : vec2%vec_pw(pw_start(js):pw_stop(js)/2))
809 : dprod1(2) = dprod1(2) + DOT_PRODUCT(vec1%vec_pw(pw_stop(js)/2+1:pw_stop(js)), &
810 0 : vec2%vec_pw(pw_stop(js)/2+1:pw_stop(js)))
811 : END IF
812 0 : IF (mask(2) .AND. (spin == js) .AND. mt_start(js) > 0) THEN
813 : dprod1(1) = dprod1(1) + DOT_PRODUCT(vec1%vec_mt(mt_start(js):mt_stop(js)/2), &
814 0 : vec2%vec_mt(mt_start(js):mt_stop(js)/2))
815 : dprod1(2) = dprod1(2) + DOT_PRODUCT(vec1%vec_mt(mt_stop(js)/2+1:mt_stop(js)), &
816 0 : vec2%vec_mt(mt_stop(js)/2+1:mt_stop(js)))
817 : END IF
818 0 : IF (mask(3) .AND. (spin == js) .AND. vac_start(js) > 0) THEN
819 : dprod1(1) = dprod1(1) + DOT_PRODUCT(vec1%vec_vac(vac_start(js):vac_stop(js)), &
820 0 : vec2%vec_vac(vac_start(js):vac_stop(js)))
821 : END IF
822 : END DO
823 :
824 0 : IF (js==3.AND.PRESENT(dprod2)) THEN
825 0 : IF (mask(1) .AND. pw_start(js) > 0) THEN
826 : dprod1(1) = dprod1(1) + DOT_PRODUCT(vec1%vec_pw(pw_start(js):pw_stop(js)/4), &
827 0 : vec2%vec_pw(pw_start(js):pw_stop(js)/4))
828 : dprod1(2) = dprod1(2) + DOT_PRODUCT(vec1%vec_pw(pw_stop(js)/4+1:pw_stop(js)/2), &
829 0 : vec2%vec_pw(pw_stop(js)/4+1:pw_stop(js)/2))
830 : dprod2(1) = dprod2(1) + DOT_PRODUCT(vec1%vec_pw(pw_stop(js)/2+1:3*pw_stop(js)/4), &
831 0 : vec2%vec_pw(pw_stop(js)/2+1:3*pw_stop(js)/4))
832 : dprod2(2) = dprod2(2) + DOT_PRODUCT(vec1%vec_pw(3*pw_stop(js)/4+1:pw_stop(js)), &
833 0 : vec2%vec_pw(3*pw_stop(js)/4+1:pw_stop(js)))
834 : END IF
835 0 : IF (mask(2) .AND. pw_start(js) > 0) THEN
836 : dprod1(1) = dprod1(1) + DOT_PRODUCT(vec1%vec_mt(mt_start(js):mt_stop(js)/4), &
837 0 : vec2%vec_mt(mt_start(js):mt_stop(js)/4))
838 : dprod1(2) = dprod1(2) + DOT_PRODUCT(vec1%vec_mt(mt_stop(js)/4+1:mt_stop(js)/2), &
839 0 : vec2%vec_mt(mt_stop(js)/4+1:mt_stop(js)/2))
840 : dprod2(1) = dprod2(1) + DOT_PRODUCT(vec1%vec_mt(mt_stop(js)/2+1:3*mt_stop(js)/4), &
841 0 : vec2%vec_mt(mt_stop(js)/2+1:3*mt_stop(js)/4))
842 : dprod2(2) = dprod2(2) + DOT_PRODUCT(vec1%vec_mt(3*mt_stop(js)/4+1:mt_stop(js)), &
843 0 : vec2%vec_mt(3*mt_stop(js)/4+1:mt_stop(js)))
844 : END IF
845 : END IF
846 :
847 : #ifdef CPP_MPI
848 0 : CALL MPI_ALLREDUCE(dprod1, dprod1_tmp, 2, MPI_DOUBLE_PRECISION, MPI_SUM, mix_mpi_comm, ierr)
849 0 : dprod1 = dprod1_tmp
850 0 : IF (PRESENT(dprod2)) THEN
851 0 : CALL MPI_ALLREDUCE(dprod2, dprod2_tmp, 2, MPI_DOUBLE_PRECISION, MPI_SUM, mix_mpi_comm, ierr)
852 0 : dprod2 = dprod2_tmp
853 : END IF
854 : #endif
855 0 : END SUBROUTINE dfpt_multiply_dot_mask
856 :
857 0 : FUNCTION mixvector_allocated(self) RESULT(l_array)
858 : IMPLICIT NONE
859 : CLASS(t_mixvector), INTENT(in) :: self
860 : LOGICAL, ALLOCATABLE :: l_array(:)
861 :
862 : l_array = [ALLOCATED(self%vec_pw), &
863 : ALLOCATED(self%vec_mt), &
864 : ALLOCATED(self%vec_vac), &
865 0 : ALLOCATED(self%vec_misc)]
866 0 : END FUNCTION mixvector_allocated
867 34950 : END MODULE m_types_mixvector
|
