sympsi.F90 7.66 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(bkpt,nv,kx,ky,kz,sym,DIMENSION,ne,cell,eig,noco, ksym,jsym,zMat,l_real)
22 23 24 25 26 27 28 29 30 31

    USE m_grp_k
    USE m_inv3
    USE m_types
    IMPLICIT NONE

    TYPE(t_dimension),INTENT(IN)   :: DIMENSION
    TYPE(t_noco),INTENT(IN)        :: noco
    TYPE(t_sym),INTENT(IN)         :: sym
    TYPE(t_cell),INTENT(IN)        :: cell
32
    TYPE(t_zMat),INTENT(IN)        :: zMat
33 34 35 36 37 38
    !
    !     .. Scalar Arguments ..
    INTEGER, INTENT (IN) :: nv,ne
    !     ..
    !     .. Array Arguments ..
    INTEGER, INTENT (IN) :: kx(:),ky(:),kz(:)!(nvd) 
39
    REAL,    INTENT (IN) :: bkpt(3),eig(DIMENSION%neigd)
40

41
    INTEGER, INTENT (OUT):: jsym(DIMENSION%neigd),ksym(DIMENSION%neigd)
42
    LOGICAL,INTENT(IN)   :: l_real
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 74 75
    !     ..
    !     .. 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

    IF (soc) THEN
       ALLOCATE(su(2,2,2*sym%nop))
76
       CALL grp_k(sym,mrot_k,cell,bkpt,nclass,nirr,c_table, grpname,irrname,su)
77
    ELSE
78
       CALL grp_k(sym,mrot_k,cell,bkpt,nclass,nirr,c_table, grpname,irrname)
79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113
    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)
       kloop: DO k=1,nv
          kv(1)=kx(k)
          kv(2)=ky(k)
          kv(3)=kz(k)
          kv=kv+bkpt
          kvtest=MATMUL(kv,mtmpinv)
          !         kvtest=MATMUL(kv,mrot_k(:,:,c))
          DO i = 1,nv
             kv(1)=kx(i)
             kv(2)=ky(i)
             kv(3)=kz(i)
             kv=kv+bkpt
             IF (ABS(kvtest(1)-kv(1)).LT.small.AND.&
114
                  ABS(kvtest(2)-kv(2)).LT.small.AND. ABS(kvtest(3)-kv(3)).LT.small) THEN
115 116 117 118
                gmap(k,c)=i
                CYCLE kloop
             ENDIF
          ENDDO
119
          WRITE(6,*) 'Problem in symcheck, cannot find rotated kv for', k,kx(k),ky(k),kz(k)
120 121 122 123 124 125 126 127 128
          RETURN
       ENDDO kloop
    ENDDO

    !norms
    DO i=1,ne
       norm(i)=0.0
       IF (soc) THEN
          DO k=1,nv*2
129
             norm(i)=norm(i)+ABS(zMat%z_c(k,i))**2
130 131
          ENDDO
       ELSE
132 133
          IF (l_real) THEN
             DO k=1,nv
134
                norm(i)=norm(i)+ABS(zMat%z_r(k,i))**2
135 136 137
             ENDDO
          ELSE
             DO k=1,nv
138
                norm(i)=norm(i)+ABS(zMat%z_c(k,i))**2
139 140
             ENDDO
          ENDIF
141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163
       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
164 165
                IF (l_real) THEN
                   DO k=1,nv
166 167
                      csum(n1,n2,c)=csum(n1,n2,c)+zMat%z_r(k,deg(n1))*&
                           zMat%z_r(gmap(k,c),deg(n2))/(norm(deg(n1))*norm(deg(n2)))
168 169 170 171 172
                   END DO
                ELSE
                   IF (soc) THEN  
                      DO k=1,nv

173 174 175 176
                         csum(n1,n2,c)=csum(n1,n2,c)+(CONJG(zMat%z_c(k,deg(n1)))*&
                              (su(1,1,c)*zMat%z_c(gmap(k,c),deg(n2))+ su(1,2,c)*zMat%z_c(gmap(k,c)+nv,deg(n2)))+&
                              CONJG(zMat%z_c(k+nv,deg(n1)))* (su(2,1,c)*zMat%z_c(gmap(k,c),deg(n2))+&
                              su(2,2,c)*zMat%z_c(gmap(k,c)+nv,deg(n2))))/ (norm(deg(n1))*norm(deg(n2)))
177
                      END DO
178
                   ELSE
179
                      DO k=1,nv
180 181
                         csum(n1,n2,c)=csum(n1,n2,c)+CONJG(zMat%z_c(k,deg(n1)))*&
                              zMat%z_c(gmap(k,c),deg(n2))/(norm(deg(n1))*norm(deg(n2)))
182
                      END DO
183
                   ENDIF
184
                ENDIF
185 186 187 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
       WRITE(444,124) bkpt
       WRITE(444,*) 'Group is ' ,grpname
       DO c=1,nirr
224 225 226 227 228 229
          IF (l_real)THEN
             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
230
          ELSE
231 232 233 234 235
             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
236 237 238 239
          ENDIF
       ENDDO
       char_written=.TRUE.
    ENDIF
240 241
123 FORMAT(i3,1x,a5,1x,20f7.3)
124 FORMAT('Character table for k: ',3f8.4)
242 243 244 245

    DEALLOCATE(csum)
    DEALLOCATE(chars)

246
  END SUBROUTINE sympsi
247 248

END  MODULE m_sympsi