starf.f 2.47 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
      MODULE m_starf
!     ********************************************************
!     synthesize 2-d and 3-d star function at point r, which
!     is given in internal coordinates
!     ********************************************************    
      USE m_constants
      USE m_spgrot
      IMPLICIT NONE
      CONTAINS
!     ********************************************************
      SUBROUTINE starf2(
     >                  nop2,ng2,kv2,mrot,symor,tau,r,invtab,
     <                  sf)
!     ..
!     .. Scalar Arguments ..
      INTEGER, INTENT (IN) :: nop2,ng2
      LOGICAL, INTENT (IN) :: symor
!     ..
!     .. Array Arguments ..
      INTEGER, INTENT (IN) :: kv2(2,ng2),mrot(3,3,nop2)
      INTEGER, INTENT (IN) :: invtab(nop2)
      REAL,    INTENT (IN) :: r(3),tau(3,nop2)
      COMPLEX, INTENT (OUT):: sf(ng2)
!     ..
!     .. Local Arrays ..
      INTEGER kr(3,nop2),kv(3),k,n
      REAL    arg
      COMPLEX ph(nop2)

    
      DO k = 1,ng2
         kv(1) = kv2(1,k)
         kv(2) = kv2(2,k)
         kv(3) = 0
         sf(k) = 0.0

         CALL spgrot(
     >               nop2,symor,mrot,tau,invtab,
     >               kv,
     <               kr,ph)

         DO n = 1,nop2
            arg = tpi_const* (kr(1,n)*r(1)+kr(2,n)*r(2))
            sf(k) = sf(k) + ph(n) * cmplx(cos(arg),sin(arg))
         ENDDO
         sf(k) = sf(k)/nop2
      ENDDO

      END SUBROUTINE starf2
!     ********************************************************
      SUBROUTINE starf3(
     >                  nop,ng3,symor,kv3,mrot,tau,r,invtab,
     <                  sf)
!     ..
!     .. Scalar Arguments ..
      INTEGER, INTENT (IN) :: nop,ng3
      LOGICAL, INTENT (IN) :: symor
!     ..
!     .. Array Arguments ..
      INTEGER, INTENT (IN) :: kv3(3,ng3),mrot(3,3,nop)
      INTEGER, INTENT (IN) :: invtab(nop)

      REAL,    INTENT (IN) :: tau(3,nop),r(3)
      COMPLEX, INTENT (OUT):: sf(ng3)
!     ..
!     .. Local Arrays ..
      INTEGER kr(3,nop),k,n
      REAL    arg
      COMPLEX ph(nop)

    
      DO k = 1,ng3
         CALL spgrot(
     >               nop,symor,mrot,tau,invtab,
     >               kv3(1,k),
     <               kr,ph)
         sf(k) = 0.0
         DO n = 1,nop
            arg = tpi_const* (kr(1,n)*r(1)+kr(2,n)*r(2)+kr(3,n)*r(3))
            sf(k) = sf(k) + ph(n) * cmplx(cos(arg),sin(arg))
         ENDDO
         sf(k) = sf(k)/nop
      ENDDO

      END SUBROUTINE starf3
!     ********************************************************
      END MODULE m_starf