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 :
7 : MODULE m_sympsi
8 :
9 : ! Calculates the irreducible represetantions of the wave functions.
10 : ! if k-point is in Brillouin zone boundary results are correct only for
11 : ! non-symmorphic groups (factor groups would be needed for that...).
12 : ! jsym contains the number of irreducible rep., corresponding character
13 : ! tables are given in the file syminfo.
14 : !
15 : ! Double groups work only with non-collinear calculations, for normal spin-orbit
16 : ! calculations both spin up and down components would be needed...
17 :
18 : ! Jussi Enkovaara, Juelich 2004
19 :
20 : CONTAINS
21 0 : SUBROUTINE sympsi(lapw,jspin,sym,ne,cell,eig,noco, jsym,zMat)
22 :
23 : USE m_constants
24 : USE m_grp_k
25 : USE m_inv3
26 : USE m_types
27 : USE m_juDFT
28 : IMPLICIT NONE
29 :
30 : TYPE(t_lapw),INTENT(IN) :: lapw
31 :
32 : TYPE(t_noco),INTENT(IN) :: noco
33 : TYPE(t_sym),INTENT(IN) :: sym
34 : TYPE(t_cell),INTENT(IN) :: cell
35 : TYPE(t_mat),INTENT(IN) :: zMat
36 : !
37 : ! .. Scalar Arguments ..
38 : INTEGER, INTENT (IN) :: ne,jspin
39 : ! ..
40 : ! .. Array Arguments ..
41 : REAL, INTENT (IN) :: eig(:)
42 :
43 : INTEGER, INTENT (OUT):: jsym(:)
44 : ! ..
45 : ! .. Local Scalars ..
46 : REAL degthre
47 : INTEGER i,k,n,c
48 : INTEGER nclass,nirr,n1,n2 ,ndeg
49 : LOGICAL soc, char_written
50 : ! ..
51 : ! .. Local Arrays ..
52 0 : INTEGER mrot_k(3,3,2*sym%nop)
53 : INTEGER :: mtmpinv(3,3),d
54 0 : INTEGER :: gmap(lapw%dim_nvd(),sym%nop)
55 : REAL :: kv(3),kvtest(3)
56 0 : INTEGER :: deg(ne)
57 :
58 0 : REAL :: norm(ne)
59 0 : LOGICAL :: symdone(ne)
60 :
61 0 : COMPLEX, ALLOCATABLE :: csum(:,:,:),chars(:,:)
62 : COMPLEX, SAVE, ALLOCATABLE :: char_table(:,:)
63 : CHARACTER(LEN=7) :: grpname
64 0 : CHARACTER(LEN=5) :: irrname(2*sym%nop)
65 0 : COMPLEX :: c_table(2*sym%nop,2*sym%nop)
66 0 : COMPLEX, ALLOCATABLE :: su(:,:,:)
67 : !
68 : REAL,PARAMETER:: small=1.0e-4
69 :
70 0 : soc=noco%l_soc.AND.noco%l_noco
71 0 : jsym=0
72 0 : IF (noco%l_soc.AND.(.NOT.noco%l_noco)) RETURN
73 :
74 0 : CALL timestart("sympsi")
75 :
76 0 : IF (soc) THEN
77 0 : ALLOCATE(su(2,2,2*sym%nop))
78 0 : CALL grp_k(sym,mrot_k,cell,lapw%bkpt,nclass,nirr,c_table, grpname,irrname,su)
79 : ELSE
80 0 : CALL grp_k(sym,mrot_k,cell,lapw%bkpt,nclass,nirr,c_table, grpname,irrname)
81 : ENDIF
82 0 : ALLOCATE(csum(ne,ne,nclass))
83 0 : ALLOCATE(chars(ne,nclass))
84 0 : chars=0.0
85 : !>
86 0 : char_written=.TRUE.
87 0 : IF (ALLOCATED(char_table)) THEN
88 0 : IF (SIZE(char_table,2).NE.nclass) THEN
89 0 : DEALLOCATE(char_table)
90 0 : ALLOCATE(char_table(nirr,nclass))
91 0 : char_written=.FALSE.
92 : ENDIF
93 : ELSE
94 0 : ALLOCATE(char_table(nirr,nclass))
95 0 : char_written=.FALSE.
96 : ENDIF
97 0 : char_table(:,:) = c_table(1:nirr,1:nclass)
98 :
99 : !<--map the (k+g)-vectors related by inv(rot)
100 0 : gmap=0
101 0 : DO c=1,nclass
102 0 : CALL inv3(mrot_k(:,:,c),mtmpinv,d)
103 0 : kloop: DO k=1,lapw%nv(jspin)
104 0 : kv(1)=lapw%k1(k,jspin)
105 0 : kv(2)=lapw%k2(k,jspin)
106 0 : kv(3)=lapw%k3(k,jspin)
107 0 : kv=kv+lapw%bkpt
108 0 : kvtest=MATMUL(kv,mtmpinv)
109 : ! kvtest=MATMUL(kv,mrot_k(:,:,c))
110 0 : DO i = 1,lapw%nv(jspin)
111 0 : kv(1)=lapw%k1(i,jspin)
112 0 : kv(2)=lapw%k2(i,jspin)
113 0 : kv(3)=lapw%k3(i,jspin)
114 0 : kv=kv+lapw%bkpt
115 : IF (ABS(kvtest(1)-kv(1)).LT.small.AND.&
116 0 : ABS(kvtest(2)-kv(2)).LT.small.AND. ABS(kvtest(3)-kv(3)).LT.small) THEN
117 0 : gmap(k,c)=i
118 0 : CYCLE kloop
119 : ENDIF
120 : ENDDO
121 0 : WRITE(oUnit,*) 'Problem in symcheck, cannot find rotated kv for', k,lapw%k1(k,jspin),lapw%k2(k,jspin),lapw%k3(k,jspin)
122 0 : CALL timestart("sympsi")
123 0 : RETURN
124 : ENDDO kloop
125 : ENDDO
126 :
127 : !norms
128 0 : DO i=1,ne
129 0 : norm(i)=0.0
130 0 : IF (soc) THEN
131 0 : DO k=1,lapw%nv(jspin)*2
132 0 : norm(i)=norm(i)+ABS(zMat%data_c(k,i))**2
133 : ENDDO
134 : ELSE
135 0 : IF (zmat%l_real) THEN
136 0 : DO k=1,lapw%nv(jspin)
137 0 : norm(i)=norm(i)+ABS(zMat%data_r(k,i))**2
138 : ENDDO
139 : ELSE
140 0 : DO k=1,lapw%nv(jspin)
141 0 : norm(i)=norm(i)+ABS(zMat%data_c(k,i))**2
142 : ENDDO
143 : ENDIF
144 : ENDIF
145 0 : norm(i)=SQRT(norm(i))
146 : ENDDO
147 :
148 :
149 : !<-- Calculate the characters
150 0 : symdone=.FALSE.
151 0 : stateloop: DO i=1,ne
152 0 : IF (symdone(i)) CYCLE stateloop
153 0 : ndeg=0
154 0 : deg=0
155 : degthre=0.0001
156 0 : DO n=1,ne
157 0 : IF (ABS(eig(i)-eig(n)).LT.degthre) THEN
158 0 : ndeg=ndeg+1
159 0 : deg(ndeg)=n
160 : ENDIF
161 : ENDDO
162 :
163 0 : csum=0.0
164 0 : DO c=1,nclass
165 0 : DO n1=1,ndeg
166 0 : DO n2=1,ndeg
167 0 : IF (zmat%l_real) THEN
168 0 : DO k=1,lapw%nv(jspin)
169 : csum(n1,n2,c)=csum(n1,n2,c)+zMat%data_r(k,deg(n1))*&
170 0 : zMat%data_r(gmap(k,c),deg(n2))/(norm(deg(n1))*norm(deg(n2)))
171 : END DO
172 : ELSE
173 0 : IF (soc) THEN
174 0 : DO k=1,lapw%nv(jspin)
175 :
176 : csum(n1,n2,c)=csum(n1,n2,c)+(CONJG(zMat%data_c(k,deg(n1)))*&
177 : (su(1,1,c)*zMat%data_c(gmap(k,c),deg(n2))+ su(1,2,c)*zMat%data_c(gmap(k,c)+lapw%nv(jspin),deg(n2)))+&
178 : CONJG(zMat%data_c(k+lapw%nv(jspin),deg(n1)))* (su(2,1,c)*zMat%data_c(gmap(k,c),deg(n2))+&
179 0 : su(2,2,c)*zMat%data_c(gmap(k,c)+lapw%nv(jspin),deg(n2))))/ (norm(deg(n1))*norm(deg(n2)))
180 : END DO
181 : ELSE
182 0 : DO k=1,lapw%nv(jspin)
183 : csum(n1,n2,c)=csum(n1,n2,c)+CONJG(zMat%data_c(k,deg(n1)))*&
184 0 : zMat%data_c(gmap(k,c),deg(n2))/(norm(deg(n1))*norm(deg(n2)))
185 : END DO
186 : ENDIF
187 : ENDIF
188 : ENDDO
189 : ENDDO
190 : ENDDO
191 : ! We might have taken degenerate states which are not degenerate due to symmetry
192 : ! so look for irreducible reps
193 0 : DO n1=1,ndeg
194 0 : chars(deg(n1),:)=0.0
195 0 : DO n2=1,ndeg
196 0 : IF (ANY(ABS(csum(n1,n2,:)).GT.0.01)) THEN
197 0 : chars(deg(n1),:)=chars(deg(n1),:)+csum(n2,n2,:)
198 : ENDIF
199 : ENDDO
200 0 : symdone(deg(n1))=.TRUE.
201 : ENDDO
202 :
203 :
204 : ! determine the irreducible presentation
205 0 : irrloop: DO n1=1,ndeg
206 : ! write(*,'(2i3,6(2f6.3,2x))') n1,i,chars(deg(n1),1:nclass)
207 0 : DO c=1,nirr
208 0 : IF (ALL(ABS(chars(deg(n1),1:nclass)-&
209 0 : & char_table(c,1:nclass)).LT.0.001)) THEN
210 0 : jsym(deg(n1))=c
211 0 : CYCLE irrloop
212 0 : ELSE IF (ALL(ABS(char_table(c,1:nclass)).LT.0.001)) THEN
213 0 : char_table(c,:)=chars(deg(n1),:)
214 0 : jsym(deg(n1))=c
215 0 : CYCLE irrloop
216 : ENDIF
217 : ENDDO
218 : ENDDO irrloop
219 :
220 : ENDDO stateloop
221 : !>
222 :
223 0 : IF (.NOT.char_written) THEN
224 0 : WRITE(444,124) lapw%bkpt
225 0 : WRITE(444,*) 'Group is ' ,grpname
226 0 : DO c=1,nirr
227 0 : IF (zmat%l_real)THEN
228 0 : IF (ANY(ABS(char_table).GT.0.001)) THEN
229 0 : WRITE(444,123) c,irrname(c),(char_table(c,n),n=1,nclass)
230 : ELSE
231 0 : WRITE(444,123) c,irrname(c),(REAL(char_table(c,n)),n=1,nclass)
232 : ENDIF
233 : ELSE
234 0 : IF (ANY(AIMAG(char_table).GT.0.001)) THEN
235 0 : WRITE(444,123) c,irrname(c),(char_table(c,n),n=1,nclass)
236 : ELSE
237 0 : WRITE(444,123) c,irrname(c),(REAL(char_table(c,n)),n=1,nclass)
238 : ENDIF
239 : ENDIF
240 : ENDDO
241 0 : char_written=.TRUE.
242 : ENDIF
243 : 123 FORMAT(i3,1x,a5,1x,20f7.3)
244 : 124 FORMAT('Character table for k: ',3f8.4)
245 :
246 0 : DEALLOCATE(csum)
247 0 : DEALLOCATE(chars)
248 :
249 0 : CALL timestop("sympsi")
250 :
251 0 : END SUBROUTINE sympsi
252 :
253 : END MODULE m_sympsi
|
