phasy1.f90 2.16 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
      MODULE m_phasy1
!     ********************************************************************
!     calculate 4pi*i**l/nop(3)*sum(R){exp(iRG(taual-taur)*conjg(ylm(RG)) }
!     e. wimmer   oct.1984
!     ********************************************************************
      CONTAINS
      SUBROUTINE phasy1(atoms,stars,sym, cell,k, pylm)

      USE m_constants
      USE m_ylm
      USE m_spgrot
      USE m_types
      IMPLICIT NONE
!
!     .. Scalar Arguments ..
      TYPE(t_atoms),INTENT(IN)::atoms
      TYPE(t_stars),INTENT(IN)::stars
      TYPE(t_sym),INTENT(IN)  ::sym
      TYPE(t_cell),INTENT(IN) ::cell
      INTEGER, INTENT (IN) :: k
!     ..
!     .. Array Arguments ..
      COMPLEX, INTENT (OUT):: pylm(:,:)
!     ..
!     .. Local Scalars ..
26
      COMPLEX sf,csf
27 28 29 30 31 32 33 34 35 36 37 38 39
      REAL x
      INTEGER j,l,m,n,na,lm,ll1
!     ..
!     .. Local Arrays ..
      COMPLEX ciall(0:atoms%lmaxd)
      COMPLEX phas(sym%nop)
      REAL rg(3)
      INTEGER kr(3,sym%nop)
      COMPLEX, ALLOCATABLE :: ylm(:,:)
!     ..

      ciall(0) = fpi_const/sym%nop
      DO l = 1,atoms%lmaxd
40
         ciall(l) = ciall(0)*ImagUnit**l
41 42 43 44 45 46 47 48 49 50 51
      ENDDO

      CALL spgrot(&
     &           sym%nop,sym%symor,sym%mrot,sym%tau,sym%invtab,&
     &           stars%kv3(:,k),&
     &           kr,phas)
      ALLOCATE ( ylm( (atoms%lmaxd+1)**2, sym%nop ) )
      DO j = 1,sym%nop
          rg=matmul(kr(:,j),cell%bmat)
          CALL ylm4(&
     &              atoms%lmaxd,rg,&
52
     &              ylm(:,j) )!keep
53 54 55 56 57 58 59 60 61
      ENDDO
      ylm = conjg( ylm )

      na = 1
      DO n = 1,atoms%ntype
         DO lm = 1, (atoms%lmax(n)+1)**2
               pylm(lm,n) = cmplx(0.,0.)
         ENDDO
         DO j = 1,sym%nop
62
            x = tpi_const* dot_product(real(kr(:,j)),atoms%taual(:,na))
63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78
            sf = cmplx(cos(x),sin(x))*phas(j)
            DO l = 0,atoms%lmax(n)
               ll1 = l*(l+1) + 1
               csf = ciall(l)*sf
               DO m = -l,l
                  lm = ll1 + m
                  pylm(lm,n) = pylm(lm,n) + csf*ylm(lm,j)
               ENDDO
            ENDDO
         ENDDO
         na = na + atoms%neq(n)
      ENDDO
      DEALLOCATE ( ylm )

      END SUBROUTINE phasy1
      END MODULE m_phasy1