LCOV - code coverage report
Current view: top level - cdn - pwint.f90 (source / functions) Hit Total Coverage
Test: FLEUR test coverage Lines: 28 33 84.8 %
Date: 2024-03-29 04:21:46 Functions: 2 2 100.0 %

          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      192720 :       SUBROUTINE pwint(stars,atoms,sym,cell,ng,x)
       8             : 
       9             :       USE m_spgrot
      10             :        
      11             :       use m_juDFT
      12             :       USE m_types 
      13             :       USE m_constants
      14             :       IMPLICIT NONE
      15             : !     ..
      16             : !     .. Scalar Arguments ..
      17             :       TYPE(t_stars),INTENT(IN) :: stars
      18             :       TYPE(t_atoms),INTENT(IN) :: atoms
      19             :       TYPE(t_sym),INTENT(IN)   :: sym
      20             :       TYPE(t_cell),INTENT(IN)  :: cell
      21             :       INTEGER,INTENT(IN)       :: ng
      22             :       COMPLEX, INTENT (OUT):: x
      23             : !     ..
      24             : !     .. Array Arguments ..
      25             : !-odim
      26             : !+odim
      27             : !     ..
      28             : !     .. Local Scalars ..
      29             :       COMPLEX s1,sfs
      30             :       REAL arg,g,s,srmt,gr,fJ
      31             :       INTEGER ig2d,ig3d,n,nn,na,ii
      32             : !     ..
      33             : !     .. Local Arrays ..
      34      192720 :       COMPLEX ph(sym%nop)
      35      192720 :       INTEGER kr(3,sym%nop)
      36             : !     ..
      37             : !     .. Intrinsic Functions ..
      38             :       INTRINSIC cmplx,cos,exp,sin
      39             : !     ..
      40      192720 :       ig3d = stars%ig(stars%kv3(1,ng),stars%kv3(2,ng),stars%kv3(3,ng))
      41      192720 :       IF (ig3d.EQ.0) THEN
      42           0 :          x = (0.,0.)
      43          48 :          RETURN
      44             :       END IF
      45      192720 :       IF (ig3d.EQ.1) THEN
      46          48 :          x = cmplx(cell%volint,0.0)
      47          48 :          RETURN
      48             :       ELSE
      49             : 
      50      192672 :             x = (0.0,0.0)
      51      192672 :             if (allocated(stars%ig2)) THEN !film
      52           0 :                  ig2d = stars%ig2(ig3d)
      53           0 :                  IF (ig2d.EQ.1) THEN
      54           0 :                     g = stars%kv3(3,ng)*cell%bmat(3,3)*cell%z1
      55           0 :                     x = cmplx(cell%vol*sin(g)/g,0.0)
      56             :                  ENDIF
      57             :             END IF
      58             :          
      59             :       END IF
      60             : !     -----> sphere contributions
      61      192672 :       s = stars%sk3(ig3d)
      62             : 
      63      192672 :       CALL spgrot(sym%nop,sym%symor,sym%mrot,sym%tau,sym%invtab,stars%kv3(:,ig3d),kr,ph)
      64      385344 :       DO n = 1,atoms%ntype
      65      192672 :          na = atoms%firstAtom(n)
      66      192672 :          srmt = s*atoms%rmt(n)
      67      192672 :          sfs = (0.0,0.0)
      68      385344 :          DO  nn = 1,sym%nop
      69      770688 :             arg = tpi_const * dot_product(real(kr(:,nn)),atoms%taual(:,na))
      70      385344 :             sfs = sfs + cmplx(cos(arg),sin(arg))*ph(nn)
      71             :          ENDDO
      72      192672 :          sfs = sfs/sym%nop
      73             : !     -----3*ji(gr)/gr term
      74      192672 :          s1 = 3.* (sin(srmt)/srmt-cos(srmt))/ (srmt*srmt)
      75      385344 :          x = x - atoms%volmts(n)*atoms%neq(n)*s1*sfs
      76             :       ENDDO
      77             : 
      78             :       END SUBROUTINE pwint
      79        2446 :       SUBROUTINE pwint_all(stars,atoms,sym,cell,x_start,x_end,x)
      80             : 
      81             :       USE m_spgrot
      82             :        
      83             :       use m_juDFT
      84             :       USE m_types 
      85             :       USE m_constants
      86             :       IMPLICIT NONE
      87             : !     ..
      88             : 
      89             :       TYPE(t_stars),INTENT(IN) :: stars
      90             :       TYPE(t_atoms),INTENT(IN) :: atoms
      91             :       TYPE(t_sym),INTENT(IN)   :: sym
      92             :       TYPE(t_cell),INTENT(IN)  :: cell
      93             :       INTEGER, INTENT (IN) :: x_start,x_end
      94             :       COMPLEX, INTENT (OUT):: x(x_start:x_end)
      95             : !     ..
      96             : !-odim
      97             : !+odim
      98             : !     ..
      99             : !     .. Local Scalars ..
     100             :       COMPLEX s1,sfs
     101             :       REAL arg,g,s,srmt,gr,fJ
     102             :       INTEGER ig2d,ig3d,n,nn,na,ii,ng
     103             : !     ..
     104             : !     .. Local Arrays ..
     105        2446 :       COMPLEX ph(sym%nop)
     106        2446 :       INTEGER kr(3,sym%nop)
     107             : !     ..
     108             : !     .. Intrinsic Functions ..
     109             :       INTRINSIC cmplx,cos,exp,sin
     110             : !     ..
     111             :       
     112             : !$OMP PARALLEL DO default(shared)  &
     113             : !$OMP PRIVATE(ng,ig3d,g,gr,fj,ig2d,s,na,kr,ph,n)&
     114        2446 : !$OMP PRIVATE(srmt,nn,sfs,arg,s1,ii)
     115             :       starloop:DO ng=x_start,x_end    
     116             :          ! careful with the indeces, the array x can be parallelized
     117             :          ! over MPI ranks in the calling routine
     118             :          ig3d = stars%ig(stars%kv3(1,ng),stars%kv3(2,ng),stars%kv3(3,ng))
     119             :          IF (ig3d.EQ.0) THEN
     120             :             x(ng) = (0.,0.)
     121             :             cycle starloop
     122             :          END IF
     123             : 
     124             :          IF (ig3d.EQ.1) THEN
     125             :             x(ng) = cmplx(cell%volint,0.0)
     126             :             cycle starloop
     127             :          ELSE
     128             :             IF (allocated(stars%ig2)) THEN
     129             :                !Film calculation
     130             :                 ig2d = stars%ig2(ig3d)
     131             :                 IF (ig2d.EQ.1) THEN
     132             :                    g = stars%kv3(3,ng)*cell%bmat(3,3)*cell%z1
     133             :                    x(ng) = cmplx(cell%vol*sin(g)/g,0.0)
     134             :                 ELSE
     135             :                    x(ng) = (0.0,0.0)
     136             :                 END IF
     137             :             ELSE
     138             :                x(ng)=0.0  
     139             :             ENDIF
     140             :          END IF
     141             : !        -----> sphere contributions
     142             :          s = stars%sk3(ig3d)
     143             : 
     144             :          CALL spgrot(sym%nop,sym%symor,sym%mrot,sym%tau,sym%invtab,stars%kv3(:,ng),kr,ph)
     145             :          DO n = 1,atoms%ntype
     146             :             na = atoms%firstAtom(n)
     147             :             srmt = s*atoms%rmt(n)
     148             :             sfs = (0.0,0.0)
     149             :             DO nn = 1,sym%nop
     150             :                arg = tpi_const* (kr(1,nn)*atoms%taual(1,na)+kr(2,nn)*atoms%taual(2,na)+kr(3,nn)*atoms%taual(3,na))
     151             :                sfs = sfs + exp(cmplx(0.0,arg))*ph(nn)
     152             :             ENDDO
     153             :             sfs = sfs/sym%nop
     154             : !     -----3*ji(gr)/gr term
     155             :             s1 = 3.* (sin(srmt)/srmt-cos(srmt))/ (srmt*srmt)
     156             :             x(ng) = x(ng) - atoms%volmts(n)*atoms%neq(n)*s1*sfs
     157             :          ENDDO
     158             :       ENDDO starloop
     159             : !$OMP end parallel do
     160             : 
     161        2446 :       END SUBROUTINE pwint_all
     162             :       END MODULE m_pwint

Generated by: LCOV version 1.14