LCOV - code coverage report
Current view: top level - cdn - pwint.f90 (source / functions) Hit Total Coverage
Test: combined.info Lines: 31 104 29.8 %
Date: 2019-09-08 04:53:50 Functions: 2 3 66.7 %

          Line data    Source code
       1             :       MODULE m_pwint
       2             : !     ******************************************************************
       3             : !     calculate the integral of a star function over the interstial    *
       4             : !     region              c.l.fu                                       *
       5             : !     ******************************************************************
       6             :       CONTAINS
       7           0 :       SUBROUTINE pwint(&
       8             :      &                 stars,atoms,sym,oneD,&
       9             :      &                 cell,ng,&
      10             :      &                 x)
      11             : 
      12             :       USE m_spgrot
      13             :       USE m_od_cylbes
      14             :       use m_juDFT
      15             :       USE m_types 
      16             :       USE m_constants
      17             :       IMPLICIT NONE
      18             : !     ..
      19             : !     .. Scalar Arguments ..
      20             :       TYPE(t_stars),INTENT(IN) :: stars
      21             :       TYPE(t_atoms),INTENT(IN) :: atoms
      22             :       TYPE(t_sym),INTENT(IN)   :: sym
      23             :       TYPE(t_oneD),INTENT(IN)  :: oneD
      24             :       TYPE(t_cell),INTENT(IN)  :: cell
      25             :       INTEGER,INTENT(IN)       :: ng
      26             :       COMPLEX, INTENT (OUT):: x
      27             : !     ..
      28             : !     .. Array Arguments ..
      29             : !-odim
      30             : !+odim
      31             : !     ..
      32             : !     .. Local Scalars ..
      33             :       COMPLEX s1,sfs
      34             :       REAL arg,g,s,srmt,gr,fJ
      35             :       INTEGER ig2d,ig3d,n,nn,na,ii
      36             : !     ..
      37             : !     .. Local Arrays ..
      38           0 :       COMPLEX ph(sym%nop)
      39           0 :       INTEGER kr(3,sym%nop)
      40             : !     ..
      41             : !     .. Intrinsic Functions ..
      42             :       INTRINSIC cmplx,cos,exp,sin
      43             : !     ..
      44           0 :       ig3d = stars%ig(stars%kv3(1,ng),stars%kv3(2,ng),stars%kv3(3,ng))
      45           0 :       IF (ig3d.EQ.0) THEN
      46           0 :          x = (0.,0.)
      47           0 :          RETURN
      48             :       END IF
      49           0 :       IF (ig3d.EQ.1) THEN
      50           0 :          x = cmplx(cell%volint,0.0)
      51           0 :          RETURN
      52             :       ELSE
      53             : 
      54           0 :          IF (oneD%odi%d1) THEN
      55           0 :             IF (stars%kv3(3,ng).EQ.0) THEN
      56             :                g = (stars%kv3(1,ng)*cell%bmat(1,1) + stars%kv3(2,ng)*cell%bmat(2,1))**2 +&
      57           0 :      &             (stars%kv3(1,ng)*cell%bmat(1,2) + stars%kv3(2,ng)*cell%bmat(2,2))**2
      58           0 :                gr = sqrt(g)
      59           0 :                g  = gr*cell%z1
      60           0 :                CALL od_cylbes(1,g,fJ)
      61           0 :                x = cmplx(2*cell%vol*fJ/g,0.0)
      62             :             ELSE
      63           0 :                x = (0.0,0.0)
      64             :             END IF
      65             :           ELSE
      66           0 :              ig2d = stars%ig2(ig3d)
      67           0 :              IF (ig2d.EQ.1) THEN
      68           0 :                 g = stars%kv3(3,ng)*cell%bmat(3,3)*cell%z1
      69           0 :                 x = cmplx(cell%vol*sin(g)/g,0.0)
      70             :              ELSE
      71           0 :                 x = (0.0,0.0)
      72             :              END IF
      73             :           END IF
      74             : 
      75             :       END IF
      76             : !     -----> sphere contributions
      77           0 :       s = stars%sk3(ig3d)
      78           0 :       na = 1
      79             : 
      80           0 :       IF (.NOT.oneD%odi%d1) THEN
      81             :          CALL spgrot(&
      82             :      &           sym%nop,sym%symor,sym%mrot,sym%tau,sym%invtab,&
      83             :      &           stars%kv3,&
      84           0 :      &           kr,ph)
      85           0 :           DO  n = 1,atoms%ntype
      86           0 :             srmt = s*atoms%rmt(n)
      87           0 :             sfs = (0.0,0.0)
      88           0 :             DO  nn = 1,sym%nop
      89           0 :                arg = tpi_const * dot_product(real(kr(:,nn)),atoms%taual(:,na))
      90           0 :                sfs = sfs + cmplx(cos(arg),sin(arg))*ph(nn)
      91             :             ENDDO
      92           0 :             sfs = sfs/sym%nop
      93             : !     -----3*ji(gr)/gr term
      94           0 :             s1 = 3.* (sin(srmt)/srmt-cos(srmt))/ (srmt*srmt)
      95           0 :             x = x - atoms%volmts(n)*atoms%neq(n)*s1*sfs
      96           0 :             na = na + atoms%neq(n)
      97             :          ENDDO
      98             :       ELSE
      99             : !-odim
     100           0 :          DO 21 n = 1,atoms%ntype
     101           0 :             DO ii = 1,atoms%neq(n)
     102           0 :                srmt = s*atoms%rmt(n)
     103             :                CALL spgrot(&
     104             :      &              sym%nop,sym%symor,sym%mrot,sym%tau,sym%invtab,&
     105             :      &              stars%kv3,&
     106           0 :      &              kr,ph)
     107           0 :                sfs = (0.0,0.0)
     108           0 :                DO nn = 1,sym%nop
     109           0 :                  arg = tpi_const * dot_product(real(kr(:,nn)),atoms%taual(:,na))
     110           0 :                  sfs = sfs + cmplx(cos(arg),sin(arg))*ph(nn)
     111             :                ENDDO
     112           0 :                sfs = sfs/sym%nop
     113             : !     -----3*ji(gr)/gr term
     114           0 :                s1 = 3.* (sin(srmt)/srmt-cos(srmt))/ (srmt*srmt)
     115           0 :                x = x - atoms%volmts(n)*s1*sfs
     116           0 :                na = na + 1
     117             :             END DO
     118           0 :  21      CONTINUE
     119             : !+odim
     120             :       ENDIF
     121             : 
     122             :       END SUBROUTINE pwint
     123         654 :       SUBROUTINE pwint_all(&
     124             :      &                 stars,atoms,sym,oneD,&
     125             :      &                 cell,x_start,x_end,&
     126         654 :      &                 x)
     127             : 
     128             :       USE m_spgrot
     129             :       USE m_od_cylbes
     130             :       use m_juDFT
     131             :       USE m_types 
     132             :       USE m_constants
     133             :       IMPLICIT NONE
     134             : !     ..
     135             : 
     136             :       TYPE(t_stars),INTENT(IN) :: stars
     137             :       TYPE(t_atoms),INTENT(IN) :: atoms
     138             :       TYPE(t_sym),INTENT(IN)   :: sym
     139             :       TYPE(t_oneD),INTENT(IN)  :: oneD
     140             :       TYPE(t_cell),INTENT(IN)  :: cell
     141             :       INTEGER, INTENT (IN) :: x_start,x_end
     142             :       COMPLEX, INTENT (OUT):: x(:)
     143             : !     ..
     144             : !-odim
     145             : !+odim
     146             : !     ..
     147             : !     .. Local Scalars ..
     148             :       COMPLEX s1,sfs
     149             :       REAL arg,g,s,srmt,gr,fJ
     150             :       INTEGER ig2d,ig3d,n,nn,na,ii,ng
     151             : !     ..
     152             : !     .. Local Arrays ..
     153         654 :       COMPLEX ph(sym%nop)
     154         654 :       INTEGER kr(3,sym%nop)
     155             : !     ..
     156             : !     .. Intrinsic Functions ..
     157             :       INTRINSIC cmplx,cos,exp,sin
     158             : !     ..
     159             :       
     160             : !$OMP PARALLEL DO default(shared)  &
     161             : !$OMP PRIVATE(ng,ig3d,g,gr,fj,ig2d,s,na,kr,ph,n)&
     162         654 : !$OMP PRIVATE(srmt,nn,sfs,arg,s1,ii)
     163             :       starloop:DO ng=x_start,x_end
     164      788265 :       ig3d = stars%ig(stars%kv3(1,ng),stars%kv3(2,ng),stars%kv3(3,ng))
     165      788265 :       IF (ig3d.EQ.0) THEN
     166           0 :          x(ng) = (0.,0.)
     167           0 :          cycle starloop
     168             :       END IF
     169             : 
     170      788265 :       IF (ig3d.EQ.1) THEN
     171         654 :          x(ng) = cmplx(cell%volint,0.0)
     172         654 :          cycle starloop
     173             :       ELSE
     174             : 
     175      787611 :          IF (oneD%odi%d1) THEN
     176           0 :             IF (stars%kv3(3,ng).EQ.0) THEN
     177             :                g = (stars%kv3(1,ng)*cell%bmat(1,1) + stars%kv3(2,ng)*cell%bmat(2,1))**2 +&
     178           0 :      &             (stars%kv3(1,ng)*cell%bmat(1,2) + stars%kv3(2,ng)*cell%bmat(2,2))**2
     179           0 :                gr = sqrt(g)
     180           0 :                g  = gr*cell%z1
     181           0 :                CALL od_cylbes(1,g,fJ)
     182           0 :                x(ng) = cmplx(2*cell%vol*fJ/g,0.0)
     183             :             ELSE
     184           0 :                x(ng) = (0.0,0.0)
     185             :             END IF
     186             :           ELSE
     187      787611 :              ig2d = stars%ig2(ig3d)
     188      787611 :              IF (ig2d.EQ.1) THEN
     189        1019 :                 g = stars%kv3(3,ng)*cell%bmat(3,3)*cell%z1
     190        1019 :                 x(ng) = cmplx(cell%vol*sin(g)/g,0.0)
     191             :              ELSE
     192      786592 :                 x(ng) = (0.0,0.0)
     193             :              END IF
     194             :           END IF
     195             : 
     196             :       END IF
     197             : !     -----> sphere contributions
     198      787611 :       s = stars%sk3(ig3d)
     199      787611 :       na = 1
     200             : 
     201      788919 :       IF (.NOT.oneD%odi%d1) THEN
     202             :          CALL spgrot(&
     203             :      &           sym%nop,sym%symor,sym%mrot,sym%tau,sym%invtab,&
     204             :      &           stars%kv3(:,ng),&
     205      787611 :      &           kr,ph)
     206     1973506 :           DO  n = 1,atoms%ntype
     207     1185895 :             srmt = s*atoms%rmt(n)
     208     1185895 :             sfs = (0.0,0.0)
     209    10203443 :             DO  nn = 1,sym%nop
     210             :              arg = tpi_const* (kr(1,nn)*atoms%taual(1,na)+kr(2,nn)*atoms%taual(2,na)+&
     211     9017548 :      &              kr(3,nn)*atoms%taual(3,na))
     212    10203443 :                sfs = sfs + exp(cmplx(0.0,arg))*ph(nn)
     213             :             ENDDO
     214     1185895 :             sfs = sfs/sym%nop
     215             : !     -----3*ji(gr)/gr term
     216     1185895 :             s1 = 3.* (sin(srmt)/srmt-cos(srmt))/ (srmt*srmt)
     217     1185895 :             x(ng) = x(ng) - atoms%volmts(n)*atoms%neq(n)*s1*sfs
     218     1973506 :             na = na + atoms%neq(n)
     219             :          ENDDO
     220             :       ELSE
     221             : !-odim
     222           0 :          DO 21 n = 1,atoms%ntype
     223           0 :             DO ii = 1,atoms%neq(n)
     224           0 :                srmt = s*atoms%rmt(n)
     225             :                CALL spgrot(&
     226             :      &              sym%nop,sym%symor,sym%mrot,sym%tau,sym%invtab,&
     227             :      &              stars%kv3(:,ng),&
     228           0 :      &              kr,ph)
     229           0 :                sfs = (0.0,0.0)
     230           0 :                DO 11 nn = 1,sym%nop
     231             :                   arg = tpi_const* (kr(1,nn)*atoms%taual(1,na)+&
     232             :      &                 kr(2,nn)*atoms%taual(2,na)+&
     233           0 :      &                 kr(3,nn)*atoms%taual(3,na))
     234           0 :                   sfs = sfs + exp(cmplx(0.0,arg))*ph(nn)
     235           0 :  11            CONTINUE
     236           0 :                sfs = sfs/sym%nop
     237             : !     -----3*ji(gr)/gr term
     238           0 :                s1 = 3.* (sin(srmt)/srmt-cos(srmt))/ (srmt*srmt)
     239           0 :                x(ng) = x(ng) - atoms%volmts(n)*s1*sfs
     240           0 :                na = na + 1
     241             :             END DO
     242           0 :  21      CONTINUE
     243             : !+odim
     244             :       ENDIF
     245             :       ENDDO starloop
     246             : !$OMP end parallel do
     247             : 
     248         654 :       END SUBROUTINE pwint_all
     249             :       END MODULE m_pwint

Generated by: LCOV version 1.13