pwdft  0.1
PW-DFT code for education
libtetrabz_dos_mod.F90
Go to the documentation of this file.
1 !
2 ! Copyright (c) 2014 Mitsuaki Kawamura
3 !
4 ! Permission is hereby granted, free of charge, to any person obtaining a
5 ! copy of this software and associated documentation files (the
6 ! "Software"), to deal in the Software without restriction, including
7 ! without limitation the rights to use, copy, modify, merge, publish,
8 ! distribute, sublicense, and/or sell copies of the Software, and to
9 ! permit persons to whom the Software is furnished to do so, subject to
10 ! the following conditions:
11 !
12 ! The above copyright notice and this permission notice shall be included
13 ! in all copies or substantial portions of the Software.
14 !
15 ! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
16 ! OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
17 ! MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
18 ! IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
19 ! CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
20 ! TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
21 ! SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
22 !
24  !
25  IMPLICIT NONE
26  !
27  PRIVATE
29  !
30 CONTAINS
31 !
32 ! Compute DOS
33 !
34 SUBROUTINE libtetrabz_dos(ltetra,bvec,nb,nge,eig,ngw,wght,ne,e0,comm) BIND(C)
35  !
36  USE iso_c_binding
38  IMPLICIT NONE
39  !
40  INTEGER(C_INT),INTENT(IN) :: ltetra, nb, nge(3), ngw(3), ne
41  REAL(c_double),INTENT(IN) :: bvec(9), eig(nb,product(nge(1:3))), e0(ne)
42  REAL(c_double),INTENT(OUT) :: wght(ne*nb,product(ngw(1:3)))
43  INTEGER(C_INT),INTENT(IN),OPTIONAL :: comm
44  !
45  LOGICAL :: linterpol
46  INTEGER :: nt_local, nk_local, nkbz, ik, kintp(8)
47  INTEGER,ALLOCATABLE :: ik_global(:,:), ik_local(:,:)
48  REAL(8) :: wlsm(4,20), wintp(1,8)
49  REAL(8),ALLOCATABLE :: wghtd(:,:,:), kvec(:,:)
50  !
51  IF(PRESENT(comm)) THEN
52  CALL libtetrabz_initialize(ltetra,nge,ngw,bvec,linterpol,wlsm,nk_local,&
53  & nt_local,nkbz,ik_global,ik_local,kvec,comm)
54  ELSE
55  CALL libtetrabz_initialize(ltetra,nge,ngw,bvec,linterpol,wlsm,nk_local,&
56  & nt_local,nkbz,ik_global,ik_local,kvec)
57  END IF
58  !
59  IF(linterpol) THEN
60  !
61  ALLOCATE(wghtd(ne*nb,1,nk_local))
62  CALL libtetrabz_dos_main(wlsm,nt_local,ik_global,ik_local,nb,nkbz,eig,ne,e0,nk_local,wghtd)
63  !
64  ! Interpolation
65  !
66  wght(1:ne*nb,1:product(ngw(1:3))) = 0d0
67  DO ik = 1, nk_local
68  CALL libtetrabz_interpol_indx(ngw,kvec(1:3,ik),kintp,wintp)
69  wght(1:ne*nb,kintp(1:8)) = wght(1:ne*nb, kintp(1:8)) &
70  & + matmul(wghtd(1:ne*nb,1:1,ik), wintp(1:1,1:8))
71  END DO ! ik = 1, nk_local
72  DEALLOCATE(wghtd, kvec)
73  !
74  IF(PRESENT(comm)) CALL libtetrabz_mpisum_dv(comm, ne*nb*product(ngw(1:3)), wght)
75  !
76  ELSE
77  CALL libtetrabz_dos_main(wlsm,nt_local,ik_global,ik_local,nb,nkbz,eig,ne,e0,nk_local,wght)
78  END IF
79  !
80  DEALLOCATE(ik_global, ik_local)
81  !
82 END SUBROUTINE libtetrabz_dos
83 !
84 ! Compute Integrated DOS
85 !
86 SUBROUTINE libtetrabz_intdos(ltetra,bvec,nb,nge,eig,ngw,wght,ne,e0,comm) BIND(C)
87  !
88  USE iso_c_binding
90  IMPLICIT NONE
91  !
92  INTEGER(C_INT),INTENT(IN) :: ltetra, nb, nge(3), ngw(3), ne
93  REAL(c_double),INTENT(IN) :: bvec(9), eig(nb,product(nge(1:3))), e0(ne)
94  REAL(c_double),INTENT(OUT) :: wght(ne*nb,product(ngw(1:3)))
95  INTEGER(C_INT),INTENT(IN),OPTIONAL :: comm
96  !
97  LOGICAL :: linterpol
98  INTEGER :: nt_local, nk_local, nkbz, ik, kintp(8)
99  INTEGER,ALLOCATABLE :: ik_global(:,:), ik_local(:,:)
100  REAL(8) :: wlsm(4,20), wintp(1,8)
101  REAL(8),ALLOCATABLE :: wghtd(:,:,:), kvec(:,:)
102  !
103  IF(PRESENT(comm)) THEN
104  CALL libtetrabz_initialize(ltetra,nge,ngw,bvec,linterpol,wlsm,nk_local,&
105  & nt_local,nkbz,ik_global,ik_local,kvec,comm)
106  ELSE
107  CALL libtetrabz_initialize(ltetra,nge,ngw,bvec,linterpol,wlsm,nk_local,&
108  & nt_local,nkbz,ik_global,ik_local,kvec)
109  END IF
110  !
111  IF(linterpol) THEN
112  !
113  ALLOCATE(wghtd(ne*nb,1,nk_local))
114  CALL libtetrabz_intdos_main(wlsm,nt_local,ik_global,ik_local,nb,nkbz,eig,ne,e0,nk_local,wghtd)
115  !
116  ! Interpolation
117  !
118  wght(1:ne*nb,1:product(ngw(1:3))) = 0d0
119  DO ik = 1, nk_local
120  CALL libtetrabz_interpol_indx(ngw,kvec(1:3,ik),kintp,wintp)
121  wght(1:ne*nb,kintp(1:8)) = wght(1:ne*nb, kintp(1:8)) &
122  & + matmul(wghtd(1:ne*nb,1:1,ik), wintp(1:1,1:8))
123  END DO ! ik = 1, nk_local
124  DEALLOCATE(wghtd, kvec)
125  !
126  IF(PRESENT(comm)) CALL libtetrabz_mpisum_dv(comm, ne*nb*product(ngw(1:3)), wght)
127  !
128  ELSE
129  CALL libtetrabz_intdos_main(wlsm,nt_local,ik_global,ik_local,nb,nkbz,eig,ne,e0,nk_local,wght)
130  END IF
131  !
132  DEALLOCATE(ik_global, ik_local)
133  !
134 END SUBROUTINE libtetrabz_intdos
135 !
136 ! Main SUBROUTINE for Dos : Delta(E - E1)
137 !
138 SUBROUTINE libtetrabz_dos_main(wlsm,nt_local,ik_global,ik_local,nb,nkBZ,eig,ne,e0,nk_local,dos)
139  !
140  USE libtetrabz_common, ONLY : libtetrabz_sort, &
143  IMPLICIT NONE
144  !
145  INTEGER,INTENT(IN) :: nt_local, nb, nkBZ, nk_local, ne, &
146  & ik_global(20,nt_local), ik_local(20,nt_local)
147  REAL(8),INTENT(IN) :: wlsm(4,20), eig(nb,nkBZ), e0(ne)
148  REAL(8),INTENT(OUT) :: dos(ne,nb,nk_local)
149  !
150  INTEGER :: ib, it, ie, indx(4)
151  REAL(8) :: e(4), ei1(4,nb), tsmall(3,4), V, w1(ne,4)
152  !
153  dos(1:ne, 1:nb, 1:nk_local) = 0d0
154  !
155  !$OMP PARALLEL DEFAULT(NONE) &
156  !$OMP & SHARED(dos,eig,e0,ik_global,ik_local,nb,ne,nt_local,wlsm) &
157  !$OMP & PRIVATE(e,ei1,ib,ie,indx,it,tsmall,V,w1)
158  !
159  DO it = 1, nt_local
160  !
161  DO ib = 1, nb
162  ei1(1:4,ib) = matmul(wlsm(1:4,1:20), eig(ib,ik_global(1:20,it)))
163  END DO
164  !
165  !$OMP DO
166  DO ib = 1, nb
167  !
168  w1(1:ne,1:4) = 0d0
169  e(1:4) = ei1(1:4, ib)
170  CALL libtetrabz_sort(4,e,indx)
171  !
172  DO ie = 1, ne
173  !
174  IF((e(1) < e0(ie) .AND. e0(ie) <= e(2)) .OR. &
175  & (e(1) <= e0(ie) .AND. e0(ie) < e(2))) THEN
176  !
177  CALL libtetrabz_triangle_a1(e(1:4) - e0(ie),v,tsmall)
178  w1(ie,indx(1:4)) = w1(ie,indx(1:4)) + v * sum(tsmall(1:3,1:4), 1) / 3d0
179  !
180  ELSE IF((e(2) < e0(ie) .AND. e0(ie) <= e(3)) .OR. &
181  & (e(2) <= e0(ie) .AND. e0(ie) < e(3))) THEN
182  !
183  CALL libtetrabz_triangle_b1(e(1:4) - e0(ie),v,tsmall)
184  w1(ie,indx(1:4)) = w1(ie,indx(1:4)) + v * sum(tsmall(1:3,1:4), 1) / 3d0
185  !
186  CALL libtetrabz_triangle_b2(e(1:4) - e0(ie),v,tsmall)
187  w1(ie,indx(1:4)) = w1(ie,indx(1:4)) + v * sum(tsmall(1:3,1:4), 1) / 3d0
188  !
189  ELSE IF((e(3) < e0(ie) .AND. e0(ie) <= e(4)) .OR. &
190  & (e(3) <= e0(ie) .AND. e0(ie) < e(4))) THEN
191  !
192  CALL libtetrabz_triangle_c1(e(1:4) - e0(ie),v,tsmall)
193  w1(ie,indx(1:4)) = w1(ie,indx(1:4)) + v * sum(tsmall(1:3,1:4), 1) / 3d0
194  !
195  END IF
196  !
197  END DO ! ie
198  !
199  dos(1:ne,ib,ik_local(1:20,it)) = dos(1:ne,ib, ik_local(1:20,it)) &
200  & + matmul(w1(1:ne, 1:4), wlsm(1:4,1:20))
201  !
202  END DO ! ib
203  !$OMP END DO NOWAIT
204  !
205  END DO ! it
206  !
207  !$OMP END PARALLEL
208  !
209  dos(1:ne,1:nb,1:nk_local) = dos(1:ne,1:nb,1:nk_local) / dble(6 * nkbz)
210  !
211 END SUBROUTINE libtetrabz_dos_main
212 !
213 ! Main SUBROUTINE for integrated Dos : theta(E - E1)
214 !
215 SUBROUTINE libtetrabz_intdos_main(wlsm,nt_local,ik_global,ik_local,nb,nkBZ,eig,ne,e0,nk_local,intdos)
216  !
217  USE libtetrabz_common, ONLY : libtetrabz_sort, &
222  IMPLICIT NONE
223  !
224  INTEGER,INTENT(IN) :: nt_local, nb, nkBZ, nk_local, ne, &
225  & ik_global(20,nt_local), ik_local(20,nt_local)
226  REAL(8),INTENT(IN) :: wlsm(4,20), eig(nb,nkBZ), e0(ne)
227  REAL(8),INTENT(OUT) :: intdos(ne,nb,nk_local)
228  !
229  INTEGER :: ib, it, ie, indx(4)
230  REAL(8) :: e(4), ei1(4,nb), tsmall(4,4), V, w1(ne,4)
231  !
232  intdos(1:ne, 1:nb, 1:nk_local) = 0d0
233  !
234  !$OMP PARALLEL DEFAULT(NONE) &
235  !$OMP & SHARED(eig,e0,ik_global,ik_local,intdos,nb,ne,nt_local,wlsm) &
236  !$OMP & PRIVATE(e,ei1,ib,ie,indx,it,tsmall,V,w1)
237  !
238  DO it = 1, nt_local
239  !
240  DO ib = 1, nb
241  ei1(1:4,ib) = matmul(wlsm(1:4,1:20), eig(ib,ik_global(1:20,it)))
242  END DO
243  !
244  !$OMP DO
245  DO ib = 1, nb
246  !
247  w1(1:ne,1:4) = 0d0
248  e(1:4) = ei1(1:4, ib)
249  CALL libtetrabz_sort(4,e,indx)
250  !
251  DO ie = 1, ne
252  !
253  IF((e(1) <= e0(ie) .AND. e0(ie) < e(2)) .OR. &
254  & (e(1) < e0(ie) .AND. e0(ie) <= e(2))) THEN
255  !
256  CALL libtetrabz_tsmall_a1(e - e0(ie),v,tsmall)
257  w1(ie,indx(1:4)) = w1(ie,indx(1:4)) + v * sum(tsmall(1:4,1:4), 1) * 0.25d0
258  !
259  ELSE IF((e(2) <= e0(ie) .AND. e0(ie) < e(3)) .OR. &
260  & (e(2) < e0(ie) .AND. e0(ie) <= e(3))) THEN
261  !
262  CALL libtetrabz_tsmall_b1(e - e0(ie),v,tsmall)
263  w1(ie,indx(1:4)) = w1(ie,indx(1:4)) + v * sum(tsmall(1:4,1:4), 1) * 0.25d0
264  !
265  CALL libtetrabz_tsmall_b2(e - e0(ie),v,tsmall)
266  w1(ie,indx(1:4)) = w1(ie,indx(1:4)) + v * sum(tsmall(1:4,1:4), 1) * 0.25d0
267  !
268  CALL libtetrabz_tsmall_b3(e - e0(ie),v,tsmall)
269  w1(ie,indx(1:4)) = w1(ie,indx(1:4)) + v * sum(tsmall(1:4,1:4), 1) * 0.25d0
270  !
271  ELSE IF((e(3) <= e0(ie) .AND. e0(ie) < e(4)) .OR. &
272  & (e(3) < e0(ie) .AND. e0(ie) <= e(4))) THEN
273  !
274  CALL libtetrabz_tsmall_c1(e - e0(ie),v,tsmall)
275  w1(ie,indx(1:4)) = w1(ie,indx(1:4)) + v * sum(tsmall(1:4,1:4), 1) * 0.25d0
276  !
277  CALL libtetrabz_tsmall_c2(e - e0(ie),v,tsmall)
278  w1(ie,indx(1:4)) = w1(ie,indx(1:4)) + v * sum(tsmall(1:4,1:4), 1) * 0.25d0
279  !
280  CALL libtetrabz_tsmall_c3(e - e0(ie),v,tsmall)
281  w1(ie,indx(1:4)) = w1(ie,indx(1:4)) + v * sum(tsmall(1:4,1:4), 1) * 0.25d0
282  !
283  ELSE IF(e(4) <= e0(ie)) THEN
284  !
285  w1(ie,1:4) = 0.25d0
286  !
287  ELSE
288  !
289  cycle
290  !
291  END IF
292  !
293  END DO ! ie
294  !
295  intdos(1:ne,ib,ik_local(1:20,it)) = intdos(1:ne,ib, ik_local(1:20,it)) &
296  & + matmul(w1(1:ne, 1:4), wlsm(1:4,1:20))
297  !
298  END DO ! ib
299  !$OMP END DO NOWAIT
300  !
301  END DO ! it
302  !
303  !$OMP END PARALLEL
304  !
305  intdos(1:ne,1:nb,1:nk_local) = intdos(1:ne,1:nb,1:nk_local) / dble(6 * nkbz)
306  !
307 END SUBROUTINE libtetrabz_intdos_main
308 !
309 END MODULE libtetrabz_dos_mod
libtetrabz_common::libtetrabz_triangle_b2
subroutine, public libtetrabz_triangle_b2(e, V, tsmall)
Definition: libtetrabz_common.F90:614
libtetrabz_common::libtetrabz_tsmall_b2
subroutine, public libtetrabz_tsmall_b2(e, V, tsmall)
Definition: libtetrabz_common.F90:432
libtetrabz_dos_mod::libtetrabz_dos_main
subroutine libtetrabz_dos_main(wlsm, nt_local, ik_global, ik_local, nb, nkBZ, eig, ne, e0, nk_local, dos)
Definition: libtetrabz_dos_mod.F90:139
libtetrabz_common::libtetrabz_tsmall_c1
subroutine, public libtetrabz_tsmall_c1(e, V, tsmall)
Definition: libtetrabz_common.F90:484
libtetrabz_common::libtetrabz_mpisum_dv
subroutine, public libtetrabz_mpisum_dv(comm, ndim, vector)
Definition: libtetrabz_common.F90:687
libtetrabz_dos_mod
Definition: libtetrabz_dos_mod.F90:23
libtetrabz_dos_mod::libtetrabz_intdos
subroutine, public libtetrabz_intdos(ltetra, bvec, nb, nge, eig, ngw, wght, ne, e0, comm)
Definition: libtetrabz_dos_mod.F90:87
libtetrabz_common::libtetrabz_triangle_c1
subroutine, public libtetrabz_triangle_c1(e, V, tsmall)
Definition: libtetrabz_common.F90:640
libtetrabz_common::libtetrabz_tsmall_a1
subroutine, public libtetrabz_tsmall_a1(e, V, tsmall)
Definition: libtetrabz_common.F90:380
libtetrabz_common::libtetrabz_tsmall_b1
subroutine, public libtetrabz_tsmall_b1(e, V, tsmall)
Definition: libtetrabz_common.F90:406
libtetrabz_common::libtetrabz_initialize
subroutine, public libtetrabz_initialize(ltetra, nge, ngw, bvec, linterpol, wlsm, nk_local, nt_local, nkBZ, ik_global, ik_local, kvec, comm)
Definition: libtetrabz_common.F90:40
libtetrabz_common::libtetrabz_interpol_indx
subroutine, public libtetrabz_interpol_indx(ng, kvec, kintp, wintp)
Definition: libtetrabz_common.F90:340
libtetrabz_dos_mod::libtetrabz_intdos_main
subroutine libtetrabz_intdos_main(wlsm, nt_local, ik_global, ik_local, nb, nkBZ, eig, ne, e0, nk_local, intdos)
Definition: libtetrabz_dos_mod.F90:216
libtetrabz_common::libtetrabz_triangle_a1
subroutine, public libtetrabz_triangle_a1(e, V, tsmall)
Definition: libtetrabz_common.F90:562
libtetrabz_common::libtetrabz_tsmall_c3
subroutine, public libtetrabz_tsmall_c3(e, V, tsmall)
Definition: libtetrabz_common.F90:536
libtetrabz_common::libtetrabz_tsmall_c2
subroutine, public libtetrabz_tsmall_c2(e, V, tsmall)
Definition: libtetrabz_common.F90:510
libtetrabz_common
Definition: libtetrabz_common.F90:23
libtetrabz_common::libtetrabz_tsmall_b3
subroutine, public libtetrabz_tsmall_b3(e, V, tsmall)
Definition: libtetrabz_common.F90:458
libtetrabz_dos_mod::libtetrabz_dos
subroutine, public libtetrabz_dos(ltetra, bvec, nb, nge, eig, ngw, wght, ne, e0, comm)
Definition: libtetrabz_dos_mod.F90:35
libtetrabz_common::libtetrabz_sort
subroutine, public libtetrabz_sort(n, key, indx)
Definition: libtetrabz_common.F90:308
libtetrabz_common::libtetrabz_triangle_b1
subroutine, public libtetrabz_triangle_b1(e, V, tsmall)
Definition: libtetrabz_common.F90:588