local_sym.f 7.33 KB
Newer Older
1 2 3 4 5 6 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
      MODULE m_localsym
!*********************************************************************
!     generate the lattice harmonics appropriate to the local symmetry
!     of the atoms, given the space group  operations, bravias lattice,
!     and the atomic positions.
!
!     the coordinate system for vector and operations must be given.
!     here it is assumed that vectors and operations are given in
!     terms of INTERNAL coordinates, i.e., in terms of a1,a2,a3. this
!     is the more complicated case; for everything in cartesian
!     coordinates, the needed changes are rather obvious.
!
!     input:
!        lmax     max. l to calculate for each atom type
!        lmaxd    max. l (needed to set array sizes)
!        a1,a2,a3 primitive translation vectors; CARTESIAN coord.
!
!        nops     number of operations in space group
!        mrot     rotation matrices in INTERNAL coordinates:
!                      ( 1,1 1,2 1,3 )( t_1 )   ( t_1' )
!                      ( 2,1 2,2 2,3 )( t_2 ) = ( t_2' )
!                      ( 3,1 3,2 3,3 )( t_3 )   ( t_3' )
!        tau      non-primitive translations, in INTERNAL coord.
!
!        ntype    number of atom types
!        neq      number of equivalent atoms of each type
!        ntyrep   representative atom for each type
!        pos      atomic positions in INTERNAL coord. (in fleur: taual)
!
!     the results for the lattice harmonics and local symmetry
!     information is put into the module mod_harmonics which can then
!     be use'd as needed.
!                                              m. weinert 12-99
!*********************************************************************
      CONTAINS
      SUBROUTINE local_sym(
     >                     lmaxd,lmax,nops,mrot,tau,
     >                     natd,ntype,neq,amat,bmat,pos,
     X                     nlhd,memd,ntypsd,l_dim,
     <                     nlhtyp,ntypsy,nlh,llh,nmem,mlh,clnu)

      USE m_ptsym
      USE m_lhcal
      USE m_constants, ONLY : pimach
      IMPLICIT NONE

!---> Arguments
      INTEGER, INTENT (IN) :: lmaxd,nops,ntype,natd
      INTEGER, INTENT (IN) :: neq(ntype),lmax(ntype),mrot(3,3,nops)
      REAL,    INTENT (IN) :: tau(3,nops),pos(3,natd)
      REAL,    INTENT (IN) :: amat(3,3),bmat(3,3)
      LOGICAL, INTENT (IN) :: l_dim
      INTEGER              :: nlhd,memd,ntypsd
      INTEGER              :: nlhtyp(ntype)
      INTEGER, INTENT(OUT) :: ntypsy(natd)
      INTEGER, INTENT(OUT) :: llh(0:nlhd,ntypsd),nmem(0:nlhd,ntypsd)
      INTEGER, INTENT(OUT) ::  mlh(memd,0:nlhd,ntypsd),nlh(ntypsd)
      COMPLEX, INTENT(OUT) :: clnu(memd,0:nlhd,ntypsd)

!---> Locals
      INTEGER :: lmax0,mem_maxd,nlhd_max
      INTEGER :: lh,lm0,m,n,nsym,na,nsymt,nn
      REAL    :: orth(3,3,nops),amatinv(3,3)
      INTEGER :: nlhs(natd),locops(nops,natd),nrot(natd)
      INTEGER :: lnu((lmaxd+1)**2,natd)
      INTEGER :: mem((lmaxd+1)**2,natd)
      INTEGER :: lmnu(2*lmaxd+1,(lmaxd+1)**2,natd)
      COMPLEX :: c(2*lmaxd+1,(lmaxd+1)**2,natd)

      INTEGER, ALLOCATABLE :: typsym(:)

      amatinv = bmat / ( 2 * pimach() )
      mem_maxd = 2*lmaxd+1
      nlhd_max = (lmaxd+1)**2
      ALLOCATE ( typsym(natd) )

      WRITE (6,'(//," Local symmetries:",/,1x,17("-"))')
!
!===> determine the point group symmetries for each atom given
!===> the space group operations and atomic positions
!===> operations and positions are in internal (lattice) coordinates
!
      CALL ptsym(
     >           ntype,natd,neq,pos,nops,mrot,tau,lmax,
     <           nsymt,typsym,nrot,locops)

      WRITE (6,'("   symmetry kinds =",i4)') nsymt
      DO nsym = 1, nsymt
         WRITE (6,'(/,"   symmetry",i3,":",i4," operations in",
     &       " local point group",/,8x,"atoms:")') nsym,nrot(nsym)
         na = 0
         DO n=1,ntype
           DO nn = 1, neq(n)
             na = na + 1 
             IF ( typsym(na) == nsym ) WRITE (6,'(i14)') na
           ENDDO
         ENDDO
      ENDDO
!
!===>  generate the lattice harmonics for each local symmetry
!
      DO nsym = 1, nsymt

!--->    need to generate transformation matrices in cartesian
!--->    coordinates (rotations in real space)
         DO n = 1, nrot(nsym)
            orth(:,:,n) = matmul( amat,
     &         matmul( real( mrot(:,:,locops(n,nsym))),amatinv ) )
         ENDDO

!--->    get max. l for this symmetry type
         lmax0 = 0
         na = 0
         DO n=1,ntype
           DO nn = 1, neq(n)
             na = na + 1
             IF (typsym(na).EQ.nsym) lmax0 = max(lmax0,lmax(n))
           ENDDO
         ENDDO

!--->     generate the lattice harmonics
         CALL lhcal(
     >              mem_maxd,nlhd_max,lmax0,nrot(nsym),orth,
     <              nlhs(nsym),lnu(1,nsym),mem(1,nsym),
     <              lmnu(1,1,nsym),c(1,1,nsym))

      ENDDO
!
!====>  allocate arrays in module mod_harmonics and store for later use
!====>  this part can be changed depending on program to interface to;
!====>  this version is consistent with fleur.
!
      nlhd = 0
      memd = 0
      DO nsym = 1, nsymt
         nlhd = max(nlhd,nlhs(nsym))
         DO lh=1,nlhs(nsym)
            memd = max(memd,mem(lh,nsym))
         ENDDO
      ENDDO
      nlhd = nlhd - 1

      IF ( nsymt > ntypsd ) ntypsd = nsymt
      IF ( l_dim ) THEN
         DEALLOCATE ( typsym )
         RETURN
      ENDIF
      clnu = cmplx( 0.0,0.0 )
      mlh = 0
      DO nsym = 1,nsymt
         nlh(nsym) = nlhs(nsym)-1
         DO lh = 1, nlhs(nsym)
            llh(lh-1,nsym)  = lnu(lh,nsym)
            nmem(lh-1,nsym) = mem(lh,nsym)
            lm0 = lnu(lh,nsym)*(lnu(lh,nsym)+1) + 1
            DO m = 1, mem(lh,nsym)
               mlh(m,lh-1,nsym) = lmnu(m,lh,nsym) - lm0
               clnu(m,lh-1,nsym) = c(m,lh,nsym)
            ENDDO
         ENDDO
      ENDDO

      WHERE ( abs(aimag(clnu)) < 1.e-13 ) clnu = cmplx( real(clnu),0.0)
      WHERE ( abs( real(clnu)) < 1.e-13 ) clnu = cmplx(0.0,aimag(clnu))
!
!--->    different atom types may have the same symmetry, but different
!--->    lmax. to deal with this possibility, define nlhtyp(ntype) to
!--->    give the number of harmonics for each atom type.
!
      na = 0
      DO n = 1, ntype
         nlhtyp(n) = 0
         DO nn = 1,neq(n)
            na = na + 1
            DO lh = 1, nlh( typsym(na) )
               IF ( llh(lh,typsym(na)) .GT. lmax(n) ) EXIT
               nlhtyp(n) = nlhtyp(n) + 1
            ENDDO
         ENDDO
      ENDDO

      na = 0
      DO n = 1, ntype
         DO nn = 1,neq(n)
            na = na + 1
            ntypsy(na) = typsym(na)
!            ntypsy(na) = typsym(na-nn+1)
         ENDDO
      ENDDO

!---> output results
      DO n = 1, nsymt
        WRITE (6,'(/," --- Local symmetry",i3,":",i4,
     &       " lattice harmonics ",30("-"))') n,nlh(n)+1
        DO lh = 0,nlh(n)
          WRITE (6,'(/,5x,"lattice harmonic",i4,":  l=",i2,
     &         ",",i3," members:")') lh+1,llh(lh,n),nmem(lh,n)
          IF ( mod(nmem(lh,n),2)==1 ) THEN
            WRITE (6,'(5x,i5,2f14.8,5x,i5,2f14.8)')
     &                     mlh(1,lh,n),clnu(1,lh,n)
            IF ( nmem(lh,n) > 1 ) THEN
              WRITE (6,'(5x,i5,2f14.8,5x,i5,2f14.8)')
     &             (mlh(m,lh,n),clnu(m,lh,n),m=2,nmem(lh,n))
            ENDIF
          ELSE
            WRITE (6,'(5x,i5,2f14.8,5x,i5,2f14.8)')
     &            (mlh(m,lh,n),clnu(m,lh,n),m=1,nmem(lh,n))
          ENDIF
        ENDDO
      ENDDO

      DEALLOCATE ( typsym )
      RETURN
      END SUBROUTINE local_sym
      END MODULE m_localsym