grfft.F90

Go to the documentation of this file.

! This file is part of the 'atomes' software.
!
! 'atomes' is free software: you can redistribute it and/or modify it under the terms
! of the GNU Affero General Public License as published by the Free Software Foundation,
! either version 3 of the License, or (at your option) any later version.
!
! 'atomes' is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
! without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
! See the GNU General Public License for more details.
!
! You should have received a copy of the GNU Affero General Public License along with 'atomes'.
! If not, see <https://www.gnu.org/licenses/>
!
! Copyright (C) 2022-2024 by CNRS and University of Strasbourg
!
 
INTEGER (KIND=c_int) FUNCTION g_of_r_fft (NDR, DTR, MMX) bind (c,name='g_of_r_fft_')
 
USE parameters
 
IMPLICIT NONE
 
INTEGER (KIND=c_int), INTENT(IN) :: ndr
real(kind=c_double), INTENT(IN) :: dtr, mmx
INTERFACE
  INTEGER FUNCTION recup_data (i, j)
    INTEGER, INTENT(IN) :: i, j
  END FUNCTION
  LOGICAL FUNCTION grbt(GrToBT, NDTR)
    USE parameters
    INTEGER, INTENT(IN) :: ndtr
    DOUBLE PRECISION, DIMENSION(NDTR,NSP,NSP), INTENT(IN) :: grtobt
  END FUNCTION
END INTERFACE
 
qvmax = mmx
number_of_i = ndr
 
if (allocated(gfft)) deallocate(gfft)
allocate(gfft(ndr), stat=err)
if (err .ne. 0) then
  call show_error ("Impossible to allocate memory"//char(0), &
                   "Function: g_of_r_fft"//char(0), "Table: GFFT"//char(0))
  g_of_r_fft=0
  goto 001
endif
if (allocated(dfft)) deallocate(dfft)
allocate(dfft(ndr), stat=err)
if (err .ne. 0) then
  call show_error ("Impossible to allocate memory"//char(0), &
                   "Function: g_of_r_fft"//char(0), "Table: DFFT"//char(0))
  g_of_r_fft=0
  goto 001
endif
if (allocated(tdfft)) deallocate(tdfft)
allocate(tdfft(ndr), stat=err)
if (err .ne. 0) then
  call show_error ("Impossible to allocate memory"//char(0), &
                   "Function: g_of_r_fft"//char(0), "Table: TDFFT"//char(0))
  g_of_r_fft=0
  goto 001
endif
 
if (allocated(r_pfft)) deallocate(r_pfft)
allocate(r_pfft(ndr), stat=err)
if (err .ne. 0) then
  call show_error ("Impossible to allocate memory"//char(0), &
                   "Function: g_of_r_fft"//char(0), "Table: R_PFFT"//char(0))
  g_of_r_fft=0
  goto 001
endif
 
do i=1, ndr
  r_pfft(i)= 0.0d0
  r_pfft(i)= 1.0 / (2.0*pi*pi*na/meanvol*(i-0.5)*dtr)
enddo
 
j=0
l=0
if (recup_data(j, idsk) .ne. 1) then
  g_of_r_fft=0
  goto 001
endif
 
j=4
if (recup_data(j, idsk) .ne. 1) then
  g_of_r_fft=0
  goto 001
endif
 
if (nsp .eq. 2) then
  if (allocated(gqbt)) deallocate(gqbt)
  allocate(gqbt(ndr,nsp,nsp), stat=err)
  if (err .ne. 0) then
    call show_error ("Impossible to allocate memory"//char(0), &
                     "Function: g_of_r_fft"//char(0), "Table: GQBT"//char(0))
    g_of_r_fft=0
    goto 001
  endif
endif
 
j=j+nsp*nsp*2+2
do n=1, nsp
do m=1, nsp
  j=j+2
  if (recup_data(j, idsk) .ne. 1) then
    g_of_r_fft=0
    goto 001
  endif
enddo
enddo
 
if (nsp .eq. 2) then
  if (grbt(gqbt, ndr)) then
    do k=1, ndr
      gfft(k)=btij(k,1)
    enddo
    call save_curve (ndr, gfft, l, idgrfft)
    l = l+2
    do k=1, ndr
      gfft(k)=btij(k,2)
    enddo
    call save_curve (ndr, gfft, l, idgrfft)
    l = l+2
    do k=1, ndr
      gfft(k)=btij(k,3)
    enddo
    call save_curve (ndr, gfft, l, idgrfft)
  endif
  if (allocated(btij)) deallocate(btij)
endif
 
g_of_r_fft=1
 
001 continue
 
if (allocated(gfft)) deallocate(gfft)
if (allocated(dfft)) deallocate(dfft)
if (allocated(tdfft)) deallocate(tdfft)
if (allocated(r_pfft)) deallocate(r_pfft)
if (allocated(gqbt)) deallocate(gqbt)
 
END FUNCTION
 
INTEGER FUNCTION send_sq (IC, VAL, DTR, KDATA, SDATA)
 
USE parameters
 
IMPLICIT NONE
 
INTEGER, INTENT(IN) :: ic, val
DOUBLE PRECISION, INTENT(IN) :: dtr
DOUBLE PRECISION, DIMENSION(VAL), INTENT(IN) :: kdata, sdata
DOUBLE PRECISION :: suml
 
j = ic
 
call fft_to_gr (val, kdata, sdata, gfft)
 
call save_curve (number_of_i, gfft, l, idgrfft)
l=l+2
 
if (j.gt.4) then
 
  if (nsp .eq. 2) then
    do i=1, number_of_i
      gqbt(i,n,m) = gfft(i)
    enddo
  endif
  do i=1, number_of_i
    dfft(i)= 4.0*pi*(((i-0.5)*dtr)**2)*dtr*gfft(i)/meanvol
    if (i .gt. 1) dfft(i)= dfft(i) + dfft(i-1)
  enddo
  if (n .eq. m) then
    k = (nbspbs(n)-1)
  else
    k = nbspbs(m)
  endif
  do i=1, number_of_i
    dfft(i)= dfft(i)*k
  enddo
  do i=1, number_of_i
    gfft(i)=(gfft(i)-1.0)*4.0*pi*(na/meanvol)*(i-0.5)*dtr
  enddo
  call save_curve (number_of_i, gfft, l, idgrfft)
  l=l+2
  call save_curve (number_of_i, dfft, l, idgrfft)
  l=l+1
 
else
 
  suml=0.0d0
  do k=1, nsp
    if (j .eq. 0) then
      suml=suml+nscattl(k)*xi(k)
    else
      suml=suml+xscattl(k)*xi(k)
    endif
  enddo
  suml=suml*suml
  do i=1, number_of_i
    gfft(i)=(gfft(i)-1.0)*4.0*pi*(na/meanvol)*(i-0.5)*dtr
  enddo
  call save_curve (number_of_i, gfft, l, idgrfft)
  l=l+2
  do i=1, number_of_i
    tdfft(i) = gfft(i)*suml
  enddo
  call save_curve (number_of_i, tdfft, l, idgrfft)
  l=l+2
  do i=1, number_of_i
    tdfft(i) = tdfft(i) + 4.0*pi*(na/meanvol)*(i-0.5)*dtr*suml
  enddo
  call save_curve (number_of_i, tdfft, l, idgrfft)
  l=l+2
 
endif
 
send_sq = 1
 
CONTAINS
 
SUBROUTINE fft_to_gr (LTAB, KTAB, TAB, RTAB)
 
USE parameters
 
INTEGER, INTENT(IN) :: LTAB
DOUBLE PRECISION, DIMENSION(LTAB), INTENT(IN) :: KTAB, TAB
DOUBLE PRECISION, DIMENSION(NUMBER_OF_I), INTENT(INOUT) :: RTAB
 
do i=1, number_of_i
  rtab(i)= 0.0d0
  do k=1, ltab-1
    phi = ktab(k)*(i-0.5)*dtr
    rtab(i) = rtab(i) + ktab(k)*(tab(k) - 1.0)*sin(phi)*(ktab(k+1) - ktab(k))
  enddo
  rtab(i) = 1.0 + r_pfft(i) * rtab(i)
enddo
 
END SUBROUTINE
 
END FUNCTION