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