sympsi.F90 8 KB
Newer Older
1
2
3
4
5
6
!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------

7
8
9
10
11
12
13
14
15
16
17
18
19
20
MODULE m_sympsi

  ! Calculates the irreducible represetantions of the wave functions.
  ! if k-point is in Brillouin zone boundary results are correct only for
  ! non-symmorphic groups (factor groups would be needed for that...). 
  ! jsym contains the number of irreducible rep., corresponding character
  ! tables are given in the file syminfo.
  !
  ! Double groups work only with non-collinear calculations, for normal spin-orbit 
  ! calculations both spin up and down components would be needed...

  ! Jussi Enkovaara, Juelich 2004

CONTAINS
21
  SUBROUTINE sympsi(lapw,jspin,sym,DIMENSION,ne,cell,eig,noco, ksym,jsym,zMat)
22
23
24
25

    USE m_grp_k
    USE m_inv3
    USE m_types
26
    USE m_juDFT
27
28
    IMPLICIT NONE

29
    TYPE(t_lapw),INTENT(IN)        :: lapw
30
31
32
33
    TYPE(t_dimension),INTENT(IN)   :: DIMENSION
    TYPE(t_noco),INTENT(IN)        :: noco
    TYPE(t_sym),INTENT(IN)         :: sym
    TYPE(t_cell),INTENT(IN)        :: cell
34
    TYPE(t_mat),INTENT(IN)         :: zMat
35
36
    !
    !     .. Scalar Arguments ..
37
    INTEGER, INTENT (IN) :: ne,jspin
38
39
    !     ..
    !     .. Array Arguments ..
40
    REAL,    INTENT (IN) :: eig(DIMENSION%neigd)
41

42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
    INTEGER, INTENT (OUT):: jsym(DIMENSION%neigd),ksym(DIMENSION%neigd)
    !     ..
    !     .. Local Scalars ..
    REAL degthre
    INTEGER i,k,n,c
    INTEGER nclass,nirr,n1,n2 ,ndeg
    LOGICAL soc, char_written
    !     ..
    !     .. Local Arrays ..
    INTEGER mrot_k(3,3,2*sym%nop)
    INTEGER :: mtmpinv(3,3),d
    INTEGER :: gmap(DIMENSION%nvd,sym%nop)
    REAL ::    kv(3),kvtest(3)
    INTEGER :: deg(ne)

    REAL :: norm(ne)
    LOGICAL :: symdone(ne)

    COMPLEX, ALLOCATABLE :: csum(:,:,:),chars(:,:)
    COMPLEX, SAVE, ALLOCATABLE :: char_table(:,:)
    CHARACTER(LEN=7) :: grpname
    CHARACTER(LEN=5) :: irrname(2*sym%nop)
    COMPLEX          :: c_table(2*sym%nop,2*sym%nop)
    COMPLEX, ALLOCATABLE :: su(:,:,:)
    !
    REAL,PARAMETER:: small=1.0e-4

    soc=noco%l_soc.AND.noco%l_noco
    jsym=0
    ksym=0
    IF (noco%l_soc.AND.(.NOT.noco%l_noco)) RETURN

74
75
    CALL timestart("sympsi")

76
77
    IF (soc) THEN
       ALLOCATE(su(2,2,2*sym%nop))
78
       CALL grp_k(sym,mrot_k,cell,lapw%bkpt,nclass,nirr,c_table, grpname,irrname,su)
79
    ELSE
80
       CALL grp_k(sym,mrot_k,cell,lapw%bkpt,nclass,nirr,c_table, grpname,irrname)
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
    ENDIF
    ALLOCATE(csum(ne,ne,nclass))
    ALLOCATE(chars(ne,nclass))
    chars=0.0
    !>

    IF (ALLOCATED(char_table)) THEN
       IF (SIZE(char_table,2).NE.nclass) THEN
          DEALLOCATE(char_table)
          ALLOCATE(char_table(nirr,nclass))
          char_written=.FALSE.
       ENDIF
    ELSE
       ALLOCATE(char_table(nirr,nclass))
       char_written=.FALSE.
    ENDIF
    char_table(:,:) = c_table(1:nirr,1:nclass)

    !<--map the (k+g)-vectors related by inv(rot)
    gmap=0
    DO c=1,nclass
       CALL inv3(mrot_k(:,:,c),mtmpinv,d)
103
104
105
106
107
       kloop: DO k=1,lapw%nv(jspin)
          kv(1)=lapw%k1(k,jspin)
          kv(2)=lapw%k2(k,jspin)
          kv(3)=lapw%k3(k,jspin)
          kv=kv+lapw%bkpt
108
109
          kvtest=MATMUL(kv,mtmpinv)
          !         kvtest=MATMUL(kv,mrot_k(:,:,c))
110
111
112
113
114
          DO i = 1,lapw%nv(jspin)
             kv(1)=lapw%k1(i,jspin)
             kv(2)=lapw%k2(i,jspin)
             kv(3)=lapw%k3(i,jspin)
             kv=kv+lapw%bkpt
115
             IF (ABS(kvtest(1)-kv(1)).LT.small.AND.&
116
                  ABS(kvtest(2)-kv(2)).LT.small.AND. ABS(kvtest(3)-kv(3)).LT.small) THEN
117
118
119
120
                gmap(k,c)=i
                CYCLE kloop
             ENDIF
          ENDDO
121
          WRITE(6,*) 'Problem in symcheck, cannot find rotated kv for', k,lapw%k1(k,jspin),lapw%k2(k,jspin),lapw%k3(k,jspin)
122
          CALL timestart("sympsi")
123
124
125
126
127
128
129
130
          RETURN
       ENDDO kloop
    ENDDO

    !norms
    DO i=1,ne
       norm(i)=0.0
       IF (soc) THEN
131
          DO k=1,lapw%nv(jspin)*2
132
             norm(i)=norm(i)+ABS(zMat%data_c(k,i))**2
133
134
          ENDDO
       ELSE
135
          IF (zmat%l_real) THEN
136
             DO k=1,lapw%nv(jspin)
137
                norm(i)=norm(i)+ABS(zMat%data_r(k,i))**2
138
139
             ENDDO
          ELSE
140
             DO k=1,lapw%nv(jspin)
141
                norm(i)=norm(i)+ABS(zMat%data_c(k,i))**2
142
143
             ENDDO
          ENDIF
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
       ENDIF
       norm(i)=SQRT(norm(i))
    ENDDO


    !<-- Calculate the characters
    symdone=.FALSE.
    stateloop: DO i=1,ne
       IF (symdone(i)) CYCLE stateloop
       ndeg=0
       deg=0
       degthre=0.0001
       DO n=1,ne
          IF (ABS(eig(i)-eig(n)).LT.degthre) THEN
             ndeg=ndeg+1
             deg(ndeg)=n
          ENDIF
       ENDDO

       csum=0.0
       DO c=1,nclass
          DO n1=1,ndeg
             DO n2=1,ndeg
167
                IF (zmat%l_real) THEN
168
                   DO k=1,lapw%nv(jspin)
169
170
                      csum(n1,n2,c)=csum(n1,n2,c)+zMat%data_r(k,deg(n1))*&
                           zMat%data_r(gmap(k,c),deg(n2))/(norm(deg(n1))*norm(deg(n2)))
171
172
173
                   END DO
                ELSE
                   IF (soc) THEN  
174
                      DO k=1,lapw%nv(jspin)
175

176
177
178
179
                         csum(n1,n2,c)=csum(n1,n2,c)+(CONJG(zMat%data_c(k,deg(n1)))*&
                              (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)))+&
                              CONJG(zMat%data_c(k+lapw%nv(jspin),deg(n1)))* (su(2,1,c)*zMat%data_c(gmap(k,c),deg(n2))+&
                              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
                      DO k=1,lapw%nv(jspin)
183
184
                         csum(n1,n2,c)=csum(n1,n2,c)+CONJG(zMat%data_c(k,deg(n1)))*&
                              zMat%data_c(gmap(k,c),deg(n2))/(norm(deg(n1))*norm(deg(n2)))
185
                      END DO
186
                   ENDIF
187
                ENDIF
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
             ENDDO
          ENDDO
       ENDDO
       ! We might have taken degenerate states which are not degenerate due to symmetry
       ! so look for irreducible reps
       DO n1=1,ndeg
          chars(deg(n1),:)=0.0
          DO n2=1,ndeg
             IF (ANY(ABS(csum(n1,n2,:)).GT.0.01)) THEN
                chars(deg(n1),:)=chars(deg(n1),:)+csum(n2,n2,:)
             ENDIF
          ENDDO
          symdone(deg(n1))=.TRUE.
       ENDDO


       ! determine the irreducible presentation
       irrloop: DO n1=1,ndeg 
          !        write(*,'(2i3,6(2f6.3,2x))') n1,i,chars(deg(n1),1:nclass)
          DO c=1,nirr
             IF (ALL(ABS(chars(deg(n1),1:nclass)-&
                  &             char_table(c,1:nclass)).LT.0.001)) THEN
                jsym(deg(n1))=c
                CYCLE irrloop
             ELSE IF (ALL(ABS(char_table(c,1:nclass)).LT.0.001)) THEN
                char_table(c,:)=chars(deg(n1),:)
                jsym(deg(n1))=c
                CYCLE irrloop
             ENDIF
          ENDDO
       ENDDO irrloop

    ENDDO stateloop
    !>

    IF (.NOT.char_written) THEN
224
       WRITE(444,124) lapw%bkpt
225
226
       WRITE(444,*) 'Group is ' ,grpname
       DO c=1,nirr
227
          IF (zmat%l_real)THEN
228
229
230
231
232
             IF (ANY(ABS(char_table).GT.0.001)) THEN
                WRITE(444,123) c,irrname(c),(char_table(c,n),n=1,nclass)
             ELSE
                WRITE(444,123) c,irrname(c),(REAL(char_table(c,n)),n=1,nclass)
             ENDIF
233
          ELSE
234
235
236
237
238
             IF (ANY(AIMAG(char_table).GT.0.001)) THEN
                WRITE(444,123) c,irrname(c),(char_table(c,n),n=1,nclass)
             ELSE
                WRITE(444,123) c,irrname(c),(REAL(char_table(c,n)),n=1,nclass)
             ENDIF
239
240
241
242
          ENDIF
       ENDDO
       char_written=.TRUE.
    ENDIF
243
244
123 FORMAT(i3,1x,a5,1x,20f7.3)
124 FORMAT('Character table for k: ',3f8.4)
245
246
247
248

    DEALLOCATE(csum)
    DEALLOCATE(chars)

249
250
    CALL timestop("sympsi")

251
  END SUBROUTINE sympsi
252
253

END  MODULE m_sympsi