LCOV - code coverage report
Current view: top level - vgen - prp_xcfft_map.f90 (source / functions) Hit Total Coverage
Test: combined.info Lines: 36 39 92.3 %
Date: 2019-09-08 04:53:50 Functions: 1 1 100.0 %

          Line data    Source code
       1             : !--------------------------------------------------------------------------------
       2             : ! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
       3             : ! This file is part of FLEUR and available as free software under the conditions
       4             : ! of the MIT license as expressed in the LICENSE file in more detail.
       5             : !--------------------------------------------------------------------------------
       6             : 
       7             : MODULE m_prpxcfftmap
       8             :   USE m_juDFT
       9             :   !*********************************************************************
      10             :   !     this subroutine prepares the pointer which identifies a
      11             :   !     threedimensional g-vector in the positive domain of the
      12             :   !     xc (=charge density) fft-box in order to map a 3-d g-vector
      13             :   !     onto stars in case of the backtransform for fft of the
      14             :   !     charge density. correspondes  to igfft(*,2)
      15             :   !     Further it sets up the x,y, and z component of the 3-dimensional
      16             :   !     g-vector in the original domain of all g-vectors used for fft.
      17             :   !     it is independent of spin and k-point.
      18             :   !     pointer is built up when ever the chargedensity is calculated
      19             :   !     in order to save memory
      20             :   !
      21             :   !        s. bluegel, IFF, Aug. 97   
      22             :   !*********************************************************************
      23             : CONTAINS
      24         161 :   SUBROUTINE prp_xcfft_map(&
      25             :        &                         stars,sym,&
      26             :        &                         cell,&
      27             :        &                         igxc_fft,gxc_fft)
      28             :     !
      29             :     USE m_types
      30             :     IMPLICIT NONE
      31             :     TYPE(t_sym),INTENT(IN)   :: sym
      32             :     TYPE(t_stars),INTENT(IN) :: stars
      33             :     TYPE(t_cell),INTENT(IN)  :: cell
      34             :     !
      35             :     !
      36             :     INTEGER,INTENT(INOUT), ALLOCATABLE :: igxc_fft(:)
      37             :     REAL   ,INTENT(INOUT), ALLOCATABLE :: gxc_fft(:,:)
      38             :     !
      39             :     !---> local variables
      40             :     !
      41             :     LOGICAL NEW
      42             :     INTEGER istr,iop,iopm1,il,im,in,kidx,iv1d,ifftq1,ifftq2, ifftxc3
      43         322 :     INTEGER nop_local,norm,kr(3,sym%nop)
      44             : 
      45             :     !------->          abbreviations
      46             :     !
      47             :     !     kxc1d  : dimension of the charge density fft box in the pos. domain
      48             :     !     kxc2d  : defined in dimens.f program (subroutine apws).1,2,3 indic
      49             :     !     kxc3d  ; a_1, a_2, a_3 directions.
      50             :     !     kq(i) : i=1,2,3 actual length of the fft-box for which fft is done
      51             :     !     nstr  : number of members (arms) of reciprocal lattice (g) vector
      52             :     !             of each star.
      53             :     !     nxc3_fft: number of stars in the  charge density  fft-box
      54             :     !     kmxxc_fft: number of g-vectors forming the nxc3_fft stars in the
      55             :     !               charge density sphere
      56             :     !     gxc_fft : contains x,y,z components of g-vectors contributing to FFT.
      57             :     !
      58             :     !-----> prepare pointer which identifies a threedimensional g-vector
      59             :     !       in the positive domain of the charge density fft-box.
      60             :     !       correspondes  to igfft(*,2)
      61             :     !
      62             : 
      63             :     ! allocate output arrays
      64         161 :     ifftxc3 = stars%kxc1_fft*stars%kxc2_fft*stars%kxc3_fft
      65         161 :     IF(ALLOCATED(igxc_fft)) DEALLOCATE(igxc_fft)
      66         161 :     IF(ALLOCATED(gxc_fft))  DEALLOCATE(gxc_fft)
      67         161 :     ALLOCATE(igxc_fft(0:ifftxc3-1))
      68         161 :     ALLOCATE(gxc_fft(0:ifftxc3-1,3))
      69             : 
      70             : 
      71         161 :     kidx    = 0
      72         161 :     ifftq1  = stars%kxc1_fft
      73         161 :     ifftq2  = stars%kxc1_fft*stars%kxc2_fft
      74             :     !
      75       98699 :     DO istr = 1 , stars%nxc3_fft
      76             :        !
      77       98538 :        nop_local=sym%nop
      78       98538 :        IF (stars%kv3(3,istr).EQ.0) nop_local=sym%nop2
      79             :        !
      80      646272 :        DO iop = 1,nop_local
      81             :           kr(1,iop) = stars%kv3(1,istr)*sym%mrot(1,1,iop)&
      82             :                &                + stars%kv3(2,istr)*sym%mrot(2,1,iop)&
      83      547734 :                &                + stars%kv3(3,istr)*sym%mrot(3,1,iop)
      84             :           kr(2,iop) = stars%kv3(1,istr)*sym%mrot(1,2,iop)&
      85             :                &                + stars%kv3(2,istr)*sym%mrot(2,2,iop)&
      86      547734 :                &                + stars%kv3(3,istr)*sym%mrot(3,2,iop)
      87             :           kr(3,iop) = stars%kv3(1,istr)*sym%mrot(1,3,iop)&
      88             :                &                + stars%kv3(2,istr)*sym%mrot(2,3,iop)&
      89      646272 :                &                + stars%kv3(3,istr)*sym%mrot(3,3,iop)
      90             :        ENDDO
      91             :        !
      92     1194167 :        DO iop = 1 , nop_local
      93             :           NEW=.TRUE.
      94     7770656 :           DO iopm1 = 1 , iop - 1
      95             :              norm=(kr(1,iop)-kr(1,iopm1))**2 +&
      96             :                   &             (kr(2,iop)-kr(2,iopm1))**2 +&
      97     3611461 :                   &             (kr(3,iop)-kr(3,iopm1))**2
      98     4159195 :              IF(norm.EQ.0) NEW=.FALSE.
      99             :           ENDDO
     100             : 
     101      646272 :           IF (NEW) THEN
     102      404053 :              il=kr(1,iop)
     103      404053 :              im=kr(2,iop)
     104      404053 :              in=kr(3,iop)
     105      404053 :              gxc_fft(kidx,1) = cell%bmat(1,1)*il+cell%bmat(2,1)*im+cell%bmat(3,1)*in 
     106      404053 :              gxc_fft(kidx,2) = cell%bmat(1,2)*il+cell%bmat(2,2)*im+cell%bmat(3,2)*in
     107      404053 :              gxc_fft(kidx,3) = cell%bmat(1,3)*il+cell%bmat(2,3)*im+cell%bmat(3,3)*in
     108      404053 :              IF (il.LT.0) il=il+stars%kxc1_fft
     109      404053 :              IF (im.LT.0) im=im+stars%kxc2_fft
     110      404053 :              IF (in.LT.0) in=in+stars%kxc3_fft
     111      404053 :              iv1d = in*ifftq2 + im*ifftq1 + il
     112      404053 :              igxc_fft(kidx)=iv1d
     113      404053 :              kidx=kidx+1
     114             :           ENDIF
     115             :        ENDDO
     116             :     ENDDO
     117             :     !
     118         161 :     IF (kidx .NE. stars%kmxxc_fft) THEN
     119           0 :        WRITE (6,'('' something wrong with stars%kmxxc_fft or nxc3_fft'')')
     120             :        WRITE (6,'('' stars%kmxxc_fft, acutal kidx '',2i5)')&
     121           0 :             &                stars%kmxxc_fft, kidx
     122             :        CALL juDFT_error("kidx /= stars",calledby ="prp_xcfft_map"&
     123           0 :             &        ,hint ="something wrong with kmxxc_fft or nxc3_fft")
     124             :     ENDIF
     125             :     !
     126         161 :   END SUBROUTINE prp_xcfft_map
     127             : END MODULE m_prpxcfftmap

Generated by: LCOV version 1.13