LCOV - code coverage report
Current view: top level - cdn - prp_qfft_map.f90 (source / functions) Hit Total Coverage
Test: combined.info Lines: 33 36 91.7 %
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_prpqfftmap
       8             :   use m_juDFT
       9             : CONTAINS
      10          76 :   SUBROUTINE prp_qfft_map(stars,sym,input, igq2_fft,igq_fft)
      11             :     !*********************************************************************
      12             :     !     This subroutine prepares the pointer which identifies a 
      13             :     !     threedimensional g-vector in the positive domain of the 
      14             :     !     charge density fft-box in order to map a 3-d g-vector
      15             :     !     onto stars in case of the backtransform for fft of the 
      16             :     !     charge density. correspondes  to igfft(*,2)     
      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, JRCAT, Feb. 97
      22             :     !*********************************************************************
      23             :     !
      24             :     USE m_types
      25             :     IMPLICIT NONE
      26             :     TYPE(t_input),INTENT(IN)   :: input
      27             :     TYPE(t_sym),INTENT(IN)     :: sym
      28             :     TYPE(t_stars),INTENT(IN)   :: stars
      29             :     !
      30             :     !
      31             :     INTEGER igq2_fft(0:stars%kq1_fft*stars%kq2_fft-1),igq_fft(0:stars%kq1_fft*stars%kq2_fft*stars%kq3_fft-1)
      32             :     !
      33             :     !---> local variables
      34             :     !
      35             :     LOGICAL new
      36             :     INTEGER istr,iop,iopm1,il,im,in,kid2x,kidx,iv1d,ifftq1,ifftq2
      37         152 :     INTEGER norm,kr(3,sym%nop),nop_local
      38             : 
      39             :     !------->          ABBREVIATIONS
      40             :     !
      41             :     !     kq1d  : dimension of the charge density FFT box in the pos. domain
      42             :     !     kq2d  : defined in dimens.f program (subroutine apws).1,2,3 indicate
      43             :     !     kq3d  ; a_1, a_2, a_3 directions.
      44             :     !     kq(i) : i=1,2,3 actual length of the fft-box for which FFT is done.
      45             :     !     nstr  : number of members (arms) of reciprocal lattice (g) vector
      46             :     !             of each star.
      47             :     !     nq3_fft: number of stars in the  charge density  FFT-box
      48             :     !     kmxq_fft: number of g-vectors forming the nq3_fft stars in the
      49             :     !               charge density sphere
      50             :     !
      51             :     !-----> prepare pointer which identifies a threedimensional g-vector
      52             :     !       in the positive domain of the charge density fft-box.
      53             :     !       correspondes  to igfft(*,2)     
      54             :     !
      55          76 :     kidx    = 0
      56          76 :     kid2x   = 0
      57          76 :     ifftq1  = stars%kq1_fft
      58          76 :     ifftq2  = stars%kq1_fft*stars%kq2_fft
      59             :     !
      60       43336 :     DO istr = 1 , stars%ng3_fft
      61             :        !
      62       43260 :        nop_local=sym%nop
      63       43260 :        IF (stars%kv3(3,istr).EQ.0) nop_local=sym%nop2
      64             :        !
      65      289758 :        DO iop = 1,nop_local
      66             :           kr(1,iop) = stars%kv3(1,istr)*sym%mrot(1,1,iop) &
      67      246498 :                + stars%kv3(2,istr)*sym%mrot(2,1,iop)+ stars%kv3(3,istr)*sym%mrot(3,1,iop)
      68             :           kr(2,iop) = stars%kv3(1,istr)*sym%mrot(1,2,iop) &
      69      246498 :                + stars%kv3(2,istr)*sym%mrot(2,2,iop)+ stars%kv3(3,istr)*sym%mrot(3,2,iop)
      70             :           kr(3,iop) = stars%kv3(1,istr)*sym%mrot(1,3,iop) &
      71      289758 :                + stars%kv3(2,istr)*sym%mrot(2,3,iop) + stars%kv3(3,istr)*sym%mrot(3,3,iop)
      72             :        ENDDO
      73             :        !
      74      536332 :        DO iop = 1 , nop_local
      75             :           new=.true.
      76     2693154 :           DO iopm1 = 1 , iop - 1
      77             :              norm=(kr(1,iop)-kr(1,iopm1))**2 +&
      78     1223328 :                   (kr(2,iop)-kr(2,iopm1))**2 +(kr(3,iop)-kr(3,iopm1))**2
      79     1469826 :              IF (norm.EQ.0) new=.false.
      80             :           ENDDO
      81             : 
      82      289758 :           IF (new) THEN
      83      189348 :              il=kr(1,iop)
      84      189348 :              im=kr(2,iop)
      85      189348 :              in=kr(3,iop)
      86      189348 :              if(il.lt.0) il=il+stars%kq1_fft
      87      189348 :              if(im.lt.0) im=im+stars%kq2_fft
      88      189348 :              if(in.lt.0) in=in+stars%kq3_fft
      89      189348 :              iv1d = in*ifftq2 + im*ifftq1 + il
      90      189348 :              igq_fft(kidx)=iv1d 
      91      189348 :              kidx=kidx+1
      92      189348 :              IF (input%film.AND.(stars%kv3(3,istr).EQ.0)) THEN
      93        2414 :                 iv1d = im*ifftq1 + il
      94        2414 :                 igq2_fft(kid2x)=iv1d 
      95        2414 :                 kid2x=kid2x+1
      96             :              ENDIF
      97             :           ENDIF
      98             :        ENDDO
      99             :        !
     100             :     ENDDO
     101             :     !
     102          76 :     IF (kidx .NE. stars%kmxq_fft) THEN
     103           0 :        WRITE (6,'('' something wrong with stars%kmxq_fft or nq3_fft'')')
     104             :        WRITE (6,'('' stars%kmxq_fft, acutal kidx '',2i5)') &
     105           0 :             &                stars%kmxq_fft, kidx
     106             :        CALL juDFT_error("something wrong with stars or nq3_fft"&
     107           0 :             &        ,calledby ="prp_qfft_map")
     108             :     ENDIF
     109             : 
     110          76 :   END SUBROUTINE prp_qfft_map
     111             : END MODULE m_prpqfftmap

Generated by: LCOV version 1.13