Line data Source code
1 : MODULE m_pwint
2 : ! ******************************************************************
3 : ! calculate the integral of a star function over the interstial *
4 : ! region c.l.fu *
5 : ! ******************************************************************
6 : CONTAINS
7 192720 : SUBROUTINE pwint(stars,atoms,sym,cell,ng,x)
8 :
9 : USE m_spgrot
10 :
11 : use m_juDFT
12 : USE m_types
13 : USE m_constants
14 : IMPLICIT NONE
15 : ! ..
16 : ! .. Scalar Arguments ..
17 : TYPE(t_stars),INTENT(IN) :: stars
18 : TYPE(t_atoms),INTENT(IN) :: atoms
19 : TYPE(t_sym),INTENT(IN) :: sym
20 : TYPE(t_cell),INTENT(IN) :: cell
21 : INTEGER,INTENT(IN) :: ng
22 : COMPLEX, INTENT (OUT):: x
23 : ! ..
24 : ! .. Array Arguments ..
25 : !-odim
26 : !+odim
27 : ! ..
28 : ! .. Local Scalars ..
29 : COMPLEX s1,sfs
30 : REAL arg,g,s,srmt,gr,fJ
31 : INTEGER ig2d,ig3d,n,nn,na,ii
32 : ! ..
33 : ! .. Local Arrays ..
34 192720 : COMPLEX ph(sym%nop)
35 192720 : INTEGER kr(3,sym%nop)
36 : ! ..
37 : ! .. Intrinsic Functions ..
38 : INTRINSIC cmplx,cos,exp,sin
39 : ! ..
40 192720 : ig3d = stars%ig(stars%kv3(1,ng),stars%kv3(2,ng),stars%kv3(3,ng))
41 192720 : IF (ig3d.EQ.0) THEN
42 0 : x = (0.,0.)
43 48 : RETURN
44 : END IF
45 192720 : IF (ig3d.EQ.1) THEN
46 48 : x = cmplx(cell%volint,0.0)
47 48 : RETURN
48 : ELSE
49 :
50 192672 : x = (0.0,0.0)
51 192672 : if (allocated(stars%ig2)) THEN !film
52 0 : ig2d = stars%ig2(ig3d)
53 0 : IF (ig2d.EQ.1) THEN
54 0 : g = stars%kv3(3,ng)*cell%bmat(3,3)*cell%z1
55 0 : x = cmplx(cell%vol*sin(g)/g,0.0)
56 : ENDIF
57 : END IF
58 :
59 : END IF
60 : ! -----> sphere contributions
61 192672 : s = stars%sk3(ig3d)
62 :
63 192672 : CALL spgrot(sym%nop,sym%symor,sym%mrot,sym%tau,sym%invtab,stars%kv3(:,ig3d),kr,ph)
64 385344 : DO n = 1,atoms%ntype
65 192672 : na = atoms%firstAtom(n)
66 192672 : srmt = s*atoms%rmt(n)
67 192672 : sfs = (0.0,0.0)
68 385344 : DO nn = 1,sym%nop
69 770688 : arg = tpi_const * dot_product(real(kr(:,nn)),atoms%taual(:,na))
70 385344 : sfs = sfs + cmplx(cos(arg),sin(arg))*ph(nn)
71 : ENDDO
72 192672 : sfs = sfs/sym%nop
73 : ! -----3*ji(gr)/gr term
74 192672 : s1 = 3.* (sin(srmt)/srmt-cos(srmt))/ (srmt*srmt)
75 385344 : x = x - atoms%volmts(n)*atoms%neq(n)*s1*sfs
76 : ENDDO
77 :
78 : END SUBROUTINE pwint
79 2446 : SUBROUTINE pwint_all(stars,atoms,sym,cell,x_start,x_end,x)
80 :
81 : USE m_spgrot
82 :
83 : use m_juDFT
84 : USE m_types
85 : USE m_constants
86 : IMPLICIT NONE
87 : ! ..
88 :
89 : TYPE(t_stars),INTENT(IN) :: stars
90 : TYPE(t_atoms),INTENT(IN) :: atoms
91 : TYPE(t_sym),INTENT(IN) :: sym
92 : TYPE(t_cell),INTENT(IN) :: cell
93 : INTEGER, INTENT (IN) :: x_start,x_end
94 : COMPLEX, INTENT (OUT):: x(x_start:x_end)
95 : ! ..
96 : !-odim
97 : !+odim
98 : ! ..
99 : ! .. Local Scalars ..
100 : COMPLEX s1,sfs
101 : REAL arg,g,s,srmt,gr,fJ
102 : INTEGER ig2d,ig3d,n,nn,na,ii,ng
103 : ! ..
104 : ! .. Local Arrays ..
105 2446 : COMPLEX ph(sym%nop)
106 2446 : INTEGER kr(3,sym%nop)
107 : ! ..
108 : ! .. Intrinsic Functions ..
109 : INTRINSIC cmplx,cos,exp,sin
110 : ! ..
111 :
112 : !$OMP PARALLEL DO default(shared) &
113 : !$OMP PRIVATE(ng,ig3d,g,gr,fj,ig2d,s,na,kr,ph,n)&
114 2446 : !$OMP PRIVATE(srmt,nn,sfs,arg,s1,ii)
115 : starloop:DO ng=x_start,x_end
116 : ! careful with the indeces, the array x can be parallelized
117 : ! over MPI ranks in the calling routine
118 : ig3d = stars%ig(stars%kv3(1,ng),stars%kv3(2,ng),stars%kv3(3,ng))
119 : IF (ig3d.EQ.0) THEN
120 : x(ng) = (0.,0.)
121 : cycle starloop
122 : END IF
123 :
124 : IF (ig3d.EQ.1) THEN
125 : x(ng) = cmplx(cell%volint,0.0)
126 : cycle starloop
127 : ELSE
128 : IF (allocated(stars%ig2)) THEN
129 : !Film calculation
130 : ig2d = stars%ig2(ig3d)
131 : IF (ig2d.EQ.1) THEN
132 : g = stars%kv3(3,ng)*cell%bmat(3,3)*cell%z1
133 : x(ng) = cmplx(cell%vol*sin(g)/g,0.0)
134 : ELSE
135 : x(ng) = (0.0,0.0)
136 : END IF
137 : ELSE
138 : x(ng)=0.0
139 : ENDIF
140 : END IF
141 : ! -----> sphere contributions
142 : s = stars%sk3(ig3d)
143 :
144 : CALL spgrot(sym%nop,sym%symor,sym%mrot,sym%tau,sym%invtab,stars%kv3(:,ng),kr,ph)
145 : DO n = 1,atoms%ntype
146 : na = atoms%firstAtom(n)
147 : srmt = s*atoms%rmt(n)
148 : sfs = (0.0,0.0)
149 : DO nn = 1,sym%nop
150 : arg = tpi_const* (kr(1,nn)*atoms%taual(1,na)+kr(2,nn)*atoms%taual(2,na)+kr(3,nn)*atoms%taual(3,na))
151 : sfs = sfs + exp(cmplx(0.0,arg))*ph(nn)
152 : ENDDO
153 : sfs = sfs/sym%nop
154 : ! -----3*ji(gr)/gr term
155 : s1 = 3.* (sin(srmt)/srmt-cos(srmt))/ (srmt*srmt)
156 : x(ng) = x(ng) - atoms%volmts(n)*atoms%neq(n)*s1*sfs
157 : ENDDO
158 : ENDDO starloop
159 : !$OMP end parallel do
160 :
161 2446 : END SUBROUTINE pwint_all
162 : END MODULE m_pwint
|