sympsi.F90 7.35 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 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 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 74 75 76 77 78 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 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 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 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245
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
  SUBROUTINE sympsi(bkpt,nv,kx,ky,kz,sym,DIMENSION,ne,cell,z,eig,noco, ksym,jsym)

    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
    !
    !     .. Scalar Arguments ..
    INTEGER, INTENT (IN) :: nv,ne
    !     ..
    !     .. Array Arguments ..
    INTEGER, INTENT (IN) :: kx(:),ky(:),kz(:)!(nvd) 
    REAL,    INTENT (IN) :: bkpt(3),eig(DIMENSION%neigd) 
#if ( defined(CPP_INVERSION) && !defined(CPP_SOC) )
     REAL,    INTENT (IN) :: z(DIMENSION%nbasfcn,DIMENSION%neigd)
#else
    COMPLEX, INTENT (IN) :: z(DIMENSION%nbasfcn,DIMENSION%neigd)
#endif
    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)

#ifdef CPP_INVERSION
    REAL, ALLOCATABLE :: csum(:,:,:),overlap(:,:),chars(:,:)
    REAL, SAVE,ALLOCATABLE :: char_table(:,:)
#else
    COMPLEX, ALLOCATABLE :: csum(:,:,:),chars(:,:)
    COMPLEX, SAVE, ALLOCATABLE :: char_table(:,:)
#endif
    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))
       CALL grp_k(sym,mrot_k,cell,bkpt,nclass,nirr,c_table,&
            &     grpname,irrname,su)
    ELSE
       CALL grp_k(sym,mrot_k,cell,bkpt,nclass,nirr,c_table,&
            &        grpname,irrname)
    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.&
                  &           ABS(kvtest(2)-kv(2)).LT.small.AND.&
                  &           ABS(kvtest(3)-kv(3)).LT.small) THEN
                gmap(k,c)=i
                CYCLE kloop
             ENDIF
          ENDDO
          WRITE(6,*) 'Problem in symcheck, cannot find rotated kv for'&
               &          , k,kx(k),ky(k),kz(k)
          RETURN
       ENDDO kloop
    ENDDO

    !norms
    DO i=1,ne
       norm(i)=0.0
       IF (soc) THEN
          DO k=1,nv*2
             norm(i)=norm(i)+ABS(z(k,i))**2
          ENDDO
       ELSE
          DO k=1,nv
             norm(i)=norm(i)+ABS(z(k,i))**2
          ENDDO
       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
                DO k=1,nv
#ifdef CPP_INVERSION
                   csum(n1,n2,c)=csum(n1,n2,c)+z(k,deg(n1))*&
                        z(gmap(k,c),deg(n2))/(norm(deg(n1))*norm(deg(n2)))
#else
                   IF (soc) THEN
                      csum(n1,n2,c)=csum(n1,n2,c)+(CONJG(z(k,deg(n1)))*&
                           (su(1,1,c)*z(gmap(k,c),deg(n2))+ su(1,2,c)*z(gmap(k,c)+nv,deg(n2)))+&
                           CONJG(z(k+nv,deg(n1)))* (su(2,1,c)*z(gmap(k,c),deg(n2))+&
                           su(2,2,c)*z(gmap(k,c)+nv,deg(n2))))/ (norm(deg(n1))*norm(deg(n2)))
                   ELSE
                      csum(n1,n2,c)=csum(n1,n2,c)+CONJG(z(k,deg(n1)))*&
                           z(gmap(k,c),deg(n2))/(norm(deg(n1))*norm(deg(n2)))
                   ENDIF
#endif
                ENDDO
             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
#ifdef CPP_INVERSION
          IF (ANY((char_table).GT.0.001)) THEN
#else
          IF (ANY(AIMAG(char_table).GT.0.001)) THEN
#endif
             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
       ENDDO
       char_written=.TRUE.
    ENDIF
123    FORMAT(i3,1x,a5,1x,20f7.3)
124    FORMAT('Character table for k: ',3f8.4)

    DEALLOCATE(csum)
    DEALLOCATE(chars)

  END SUBROUTINE

END  MODULE m_sympsi