Commit af0fc01e authored by Daniel Wortmann's avatar Daniel Wortmann

Merge branch 'develop' of iffgit.fz-juelich.de:fleur/fleur into develop

parents 3a5fa2e4 7bdd45b6
......@@ -6,7 +6,6 @@ Testing/*
build
build.*
*.o
*.mod
*.x
*.swp
tags
......@@ -4,7 +4,78 @@ MODULE m_cdntot
! vacuum, and mt regions c.l.fu
! ********************************************************
CONTAINS
SUBROUTINE cdntot(mpi,stars,atoms,sym,vacuum,input,cell,oneD,&
SUBROUTINE cdntot_integrate(stars,atoms,sym,vacuum,input,cell,oneD, integrand, &
q, qis, qmt, qvac, qtot, qistot)
USE m_intgr, ONLY : intgr3
USE m_constants
USE m_qsf
USE m_pwint
USE m_types
USE m_juDFT
USE m_convol
IMPLICIT NONE
TYPE(t_stars),INTENT(IN) :: stars
TYPE(t_atoms),INTENT(IN) :: atoms
TYPE(t_sym),INTENT(IN) :: sym
TYPE(t_vacuum),INTENT(IN) :: vacuum
TYPE(t_input),INTENT(IN) :: input
TYPE(t_cell),INTENT(IN) :: cell
TYPE(t_oneD),INTENT(IN) :: oneD
TYPE(t_potden),INTENT(IN) :: integrand
REAL, INTENT(out) :: q(input%jspins), qis(input%jspins), qmt(atoms%ntype,input%jspins),&
qvac(2,input%jspins), qtot, qistot
INTEGER :: jsp, j, ivac, nz, n
REAL :: q2(vacuum%nmz), w, rht1(vacuum%nmzd,2,input%jspins)
COMPLEX :: x(stars%ng3)
CALL timestart("cdntot")
qtot = 0.0
qistot = 0.0
DO jsp = 1,input%jspins
q(jsp) = 0.0
! -----mt charge
CALL timestart("MT")
DO n = 1,atoms%ntype
CALL intgr3(integrand%mt(:,0,n,jsp),atoms%rmsh(:,n),atoms%dx(n),atoms%jri(n),w)
qmt(n, jsp) = w*sfp_const
q(jsp) = q(jsp) + atoms%neq(n)*qmt(n,jsp)
ENDDO
CALL timestop("MT")
! -----vacuum region
IF (input%film) THEN
DO ivac = 1,vacuum%nvac
DO nz = 1,vacuum%nmz
IF (oneD%odi%d1) THEN
rht1(nz,ivac,jsp) = (cell%z1+(nz-1)*vacuum%delz)*&
integrand%vacz(nz,ivac,jsp)
ELSE
rht1(nz,ivac,jsp) = integrand%vacz(nz,ivac,jsp)
END IF
END DO
CALL qsf(vacuum%delz,rht1(1,ivac,jsp),q2,vacuum%nmz,0)
qvac(ivac,jsp) = q2(1)*cell%area
IF (.NOT.oneD%odi%d1) THEN
q(jsp) = q(jsp) + qvac(ivac,jsp)*2./real(vacuum%nvac)
ELSE
q(jsp) = q(jsp) + cell%area*q2(1)
END IF
ENDDO
END IF
! -----is region
qis(jsp) = 0.
CALL pwint_all(stars,atoms,sym,oneD,cell,1,stars%ng3,x)
DO j = 1,stars%ng3
qis(jsp) = qis(jsp) + integrand%pw(j,jsp)*x(j)*stars%nstr(j)
ENDDO
qistot = qistot + qis(jsp)
q(jsp) = q(jsp) + qis(jsp)
qtot = qtot + q(jsp)
END DO ! loop over spins
END SUBROUTINE cdntot_integrate
SUBROUTINE cdntot(stars,atoms,sym,vacuum,input,cell,oneD,&
den,l_printData,qtot,qistot)
USE m_intgr, ONLY : intgr3
......@@ -18,7 +89,6 @@ CONTAINS
IMPLICIT NONE
! .. Scalar Arguments ..
TYPE(t_mpi),INTENT(IN) :: mpi
TYPE(t_stars),INTENT(IN) :: stars
TYPE(t_atoms),INTENT(IN) :: atoms
TYPE(t_sym),INTENT(IN) :: sym
......@@ -32,82 +102,36 @@ CONTAINS
! .. Local Scalars ..
COMPLEX x(stars%ng3)
REAL q,qis,w,mtCharge
INTEGER i,ivac,j,jspin,n,nz
REAL q(input%jspins),qis(input%jspins),w,mtCharge
INTEGER i,ivac,j,jsp,n,nz
! ..
! .. Local Arrays ..
REAL qmt(atoms%ntype),qvac(2),q2(vacuum%nmz),rht1(vacuum%nmzd,2,input%jspins)
REAL qmt(atoms%ntype,input%jspins),qvac(2,input%jspins)
INTEGER, ALLOCATABLE :: lengths(:,:)
CHARACTER(LEN=20) :: attributes(6), names(6)
! ..
! .. Intrinsic Functions ..
INTRINSIC real
! ..
!
call cdntot_integrate(stars,atoms,sym,vacuum,input,cell,oneD, den, &
q, qis, qmt, qvac, qtot, qistot)
IF (input%film) THEN
ALLOCATE(lengths(4+vacuum%nvac,2))
ELSE
ALLOCATE(lengths(4,2))
END IF
CALL timestart("cdntot")
qtot = 0.e0
qistot = 0.e0
DO jspin = 1,input%jspins
q = 0.e0
! -----mt charge
CALL timestart("MT")
DO n = 1,atoms%ntype
CALL intgr3(den%mt(:,0,n,jspin),atoms%rmsh(:,n),atoms%dx(n),atoms%jri(n),w)
qmt(n) = w*sfp_const
q = q + atoms%neq(n)*qmt(n)
ENDDO
CALL timestop("MT")
! -----vacuum region
IF (input%film) THEN
DO ivac = 1,vacuum%nvac
DO nz = 1,vacuum%nmz
IF (oneD%odi%d1) THEN
rht1(nz,ivac,jspin) = (cell%z1+(nz-1)*vacuum%delz)*&
den%vacz(nz,ivac,jspin)
ELSE
rht1(nz,ivac,jspin) = den%vacz(nz,ivac,jspin)
END IF
END DO
CALL qsf(vacuum%delz,rht1(1,ivac,jspin),q2,vacuum%nmz,0)
qvac(ivac) = q2(1)*cell%area
IF (.NOT.oneD%odi%d1) THEN
q = q + qvac(ivac)*2./real(vacuum%nvac)
ELSE
q = q + cell%area*q2(1)
END IF
ENDDO
END IF
! -----is region
IF (.FALSE.) THEN !Change this for old way of determination of int-charge
CALL convol(stars,x,den%pw(:,jspin),stars%ufft)
qis = x(1)*cell%omtil
ELSE
qis = 0.
CALL pwint_all(stars,atoms,sym,oneD,cell,1,stars%ng3,x)
DO j = 1,stars%ng3
qis = qis + den%pw(j,jspin)*x(j)*stars%nstr(j)
ENDDO
endif
qistot = qistot + qis
q = q + qis
WRITE (6,FMT=8000) jspin,q,qis, (qmt(n),n=1,atoms%ntype)
IF (input%film) WRITE (6,FMT=8010) (i,qvac(i),i=1,vacuum%nvac)
mtCharge = SUM(qmt(1:atoms%ntype) * atoms%neq(1:atoms%ntype))
names(1) = 'spin' ; WRITE(attributes(1),'(i0)') jspin ; lengths(1,1)=4 ; lengths(1,2)=1
names(2) = 'total' ; WRITE(attributes(2),'(f14.7)') q ; lengths(2,1)=5 ; lengths(2,2)=14
names(3) = 'interstitial' ; WRITE(attributes(3),'(f14.7)') qis ; lengths(3,1)=12 ; lengths(3,2)=14
DO jsp = 1,input%jspins
WRITE (6,FMT=8000) jsp,q(jsp),qis, (qmt(n,jsp),n=1,atoms%ntype)
IF (input%film) WRITE (6,FMT=8010) (i,qvac(i,jsp),i=1,vacuum%nvac)
mtCharge = SUM(qmt(1:atoms%ntype,jsp) * atoms%neq(1:atoms%ntype))
names(1) = 'spin' ; WRITE(attributes(1),'(i0)') jsp ; lengths(1,1)=4 ; lengths(1,2)=1
names(2) = 'total' ; WRITE(attributes(2),'(f14.7)') q(jsp) ; lengths(2,1)=5 ; lengths(2,2)=14
names(3) = 'interstitial' ; WRITE(attributes(3),'(f14.7)') qis(jsp) ; lengths(3,1)=12 ; lengths(3,2)=14
names(4) = 'mtSpheres' ; WRITE(attributes(4),'(f14.7)') mtCharge ; lengths(4,1)=9 ; lengths(4,2)=14
IF(l_printData) THEN
IF(input%film) THEN
DO i = 1, vacuum%nvac
WRITE(names(4+i),'(a6,i0)') 'vacuum', i
WRITE(attributes(4+i),'(f14.7)') qvac(i)
WRITE(attributes(4+i),'(f14.7)') qvac(i,jsp)
lengths(4+i,1)=7
lengths(4+i,2)=14
END DO
......@@ -117,9 +141,7 @@ CONTAINS
CALL writeXMLElementFormPoly('spinDependentCharge',names(1:4),attributes(1:4),lengths)
END IF
END IF
qtot = qtot + q
END DO ! loop over spins
DEALLOCATE (lengths)
WRITE (6,FMT=8020) qtot
IF(l_printData) THEN
CALL writeXMLElementFormPoly('totalCharge',(/'value'/),(/qtot/),reshape((/5,20/),(/1,2/)))
......
......@@ -12,6 +12,7 @@ SUBROUTINE cdncore(mpi,dimension,oneD,input,vacuum,noco,sym,&
stars,cell,sphhar,atoms,vTot,outDen,moments,results)
USE m_constants
USE m_judft
USE m_cdn_io
USE m_cdnovlp
USE m_cored
......
......@@ -59,7 +59,7 @@ kpoints/tetcon.f kpoints/kvecon.f init/boxdim.f global/radsra.f math/intgr.F glo
)
set(inpgen_F90 ${inpgen_F90} global/constants.f90 io/xsf_io.f90
eigen/orthoglo.F90 juDFT/usage_data.F90 math/ylm4.F90
eigen/orthoglo.F90 juDFT/usage_data.F90 math/ylm4.F90 mpi/mpi_bc_tool.F90
global/sort.f90 global/chkmt.f90 inpgen/inpgen.f90 inpgen/set_inp.f90 inpgen/inpgen_help.f90 io/rw_inp.f90 juDFT/juDFT.F90 global/find_enpara.f90
inpgen/closure.f90 inpgen/inpgen_arguments.F90
juDFT/info.F90 juDFT/stop.F90 juDFT/args.F90 juDFT/time.F90 juDFT/init.F90 juDFT/sysinfo.F90 juDFT/string.f90 io/w_inpXML.f90 kpoints/julia.f90 global/utility.F90
......
......@@ -12,7 +12,11 @@ if (${CMAKE_Fortran_COMPILER_ID} MATCHES "Intel")
set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -mkl -r8 -qopenmp -assume byterecl")
endif()
set(CMAKE_Fortran_FLAGS_RELEASE "${CMAKE_Fortran_FLAGS_RELEASE} -xHost -O2 -g")
set(CMAKE_Fortran_FLAGS_DEBUG "${CMAKE_Fortran_FLAGS_DEBUG} -C -traceback -O0 -g -ftrapuv -check uninit -check pointers -CB -DCPP_DEBUG")
if (${CMAKE_Fortran_COMPILER_VERSION} VERSION_LESS "19.0.0.0")
set(CMAKE_Fortran_FLAGS_DEBUG "${CMAKE_Fortran_FLAGS_DEBUG} -C -traceback -O0 -g -ftrapuv -check uninit -check pointers -DCPP_DEBUG")
else()
set(CMAKE_Fortran_FLAGS_DEBUG "${CMAKE_Fortran_FLAGS_DEBUG} -CB -traceback -O0 -g -ftrapuv -check uninit -check pointers -DCPP_DEBUG")
endif()
elseif(${CMAKE_Fortran_COMPILER_ID} MATCHES "PGI")
message("PGI Fortran detected")
set(CMAKE_SHARED_LIBRARY_LINK_Fortran_FLAGS "") #fix problem in cmake
......
......@@ -4,6 +4,8 @@ Contributors guide
Everyone is very welcome to contribute to the enhancement of FLEUR.
Please use the [gitlab service] (https://iffgit.fz-juelich.de/fleur/fleur) to obtain the
latest development version of FLEUR.
- The
##Coding rules for FLEUR:
In no particular order we try to collect items to consider when writing code for FLEUR
......
MODULE m_tlmplm_cholesky
use m_judft
IMPLICIT NONE
!*********************************************************************
! sets up the local Hamiltonian, i.e. the Hamiltonian in the
......
......@@ -21,12 +21,13 @@ MODULE m_constants
REAL, PARAMETER :: eVac0Default_const = -0.25
CHARACTER(len=9), PARAMETER :: version_const = 'fleur 27'
INTEGER, PARAMETER :: POTDEN_TYPE_OTHER = 0 ! POTDEN_TYPE <= 0 ==> undefined
INTEGER, PARAMETER :: POTDEN_TYPE_POTTOT = 1 ! 0 < POTDEN_TYPE <= 1000 ==> potential
INTEGER, PARAMETER :: POTDEN_TYPE_POTCOUL = 2
INTEGER, PARAMETER :: POTDEN_TYPE_POTX = 3
INTEGER, PARAMETER :: POTDEN_TYPE_POTYUK = 4
INTEGER, PARAMETER :: POTDEN_TYPE_DEN = 1001 ! 1000 < POTDEN_TYPE ==> density
INTEGER, PARAMETER :: POTDEN_TYPE_OTHER = 0 ! POTDEN_TYPE <= 0 ==> undefined
INTEGER, PARAMETER :: POTDEN_TYPE_POTTOT = 1 ! 0 < POTDEN_TYPE <= 1000 ==> potential
INTEGER, PARAMETER :: POTDEN_TYPE_POTCOUL = 2
INTEGER, PARAMETER :: POTDEN_TYPE_POTX = 3
INTEGER, PARAMETER :: POTDEN_TYPE_POTYUK = 4
INTEGER, PARAMETER :: POTDEN_TYPE_EnergyDen = 5
INTEGER, PARAMETER :: POTDEN_TYPE_DEN = 1001 ! 1000 < POTDEN_TYPE ==> density
CHARACTER(2),DIMENSION(0:103),PARAMETER :: namat_const=(/&
'va',' H','He','Li','Be',' B',' C',' N',' O',' F','Ne',&
......@@ -65,21 +66,23 @@ MODULE m_constants
CONTAINS
REAL PURE FUNCTION pimach()
! This subprogram supplies the value of the constant PI correct to
! machine precision where
IMPLICIT NONE
! This subprogram supplies the value of the constant PI correct to
! machine precision where
! PI=3.1415926535897932384626433832795028841971693993751058209749446
! PI=3.1415926535897932384626433832795028841971693993751058209749446
pimach = 3.1415926535897932
pimach = 3.1415926535897932
END FUNCTION pimach
REAL ELEMENTAL FUNCTION c_light(fac)
! This subprogram supplies the value of c according to
! NIST standard 13.1.99
! Hartree and Rydbergs changed by fac = 1.0 or 2.0
IMPLICIT NONE
! This subprogram supplies the value of c according to
! NIST standard 13.1.99
! Hartree and Rydbergs changed by fac = 1.0 or 2.0
REAL, INTENT (IN) :: fac
c_light = 137.0359895e0 * fac
REAL, INTENT (IN) :: fac
c_light = 137.0359895e0 * fac
END FUNCTION c_light
END MODULE m_constants
......@@ -52,7 +52,7 @@ CONTAINS
! qfix==0 means no qfix was given in inp.xml.
! In this case do nothing except when forced to fix!
CALL cdntot(mpi,stars,atoms,sym,vacuum,input,cell,oneD,den,.TRUE.,qtot,qis)
CALL cdntot(stars,atoms,sym,vacuum,input,cell,oneD,den,.TRUE.,qtot,qis)
!The total nucleii charge
zc=SUM(atoms%neq(:)*atoms%zatom(:))
......@@ -93,7 +93,7 @@ CONTAINS
IF (ABS(fix-1.0)<1.E-6) RETURN !no second calculation of cdntot as nothing was fixed
CALL openXMLElementNoAttributes('fixedCharges')
CALL cdntot(mpi,stars,atoms,sym,vacuum,input,cell,oneD,den,l_printData,qtot,qis)
CALL cdntot(stars,atoms,sym,vacuum,input,cell,oneD,den,l_printData,qtot,qis)
CALL closeXMLElement('fixedCharges')
IF (fix>1.1) CALL juDFT_WARN("You lost too much charge")
......
......@@ -264,11 +264,11 @@
! New format
ALLOCATE(E%sigEF(3*k1d, 3*k2d, nvac))
E%sigEF = 0.0
if (allocated(e%shapes)) then
DO i=1,SIZE(e%shapes)
CALL read_shape (E, e%shapes(i), nvac)
END DO
endif
IF (e%l_eV) THEN
E%sig_b(:) = E%sig_b/hartree_to_ev_const
E%sigEF(:,:,:) = E%sigEF/hartree_to_ev_const
......
......@@ -21,7 +21,6 @@ io/cdnpot_io_common.F90
io/cdn_io.F90
io/pot_io.F90
io/banddos_io.F90
io/broyd_io.F90
io/rw_inp.f90
io/rw_noco.f90
io/r_inpXML.F90
......
......@@ -6,6 +6,7 @@
MODULE m_io_matrix
USE m_types
USE m_judft
IMPLICIT NONE
private
INTEGER:: mode=1
......
......@@ -330,6 +330,14 @@ CONTAINS
input%imix = 5
CASE ('Anderson')
input%imix = 7
CASE ("Pulay")
input%imix = 9
CASE ("pPulay")
input%imix = 11
CASE ("rPulay")
input%imix = 13
CASE ("aPulay")
input%imix = 15
CASE DEFAULT
STOP 'Error: unknown mixing scheme selected!'
END SELECT
......
......@@ -885,6 +885,10 @@
<xsd:enumeration value="Broyden1"/>
<xsd:enumeration value="Broyden2"/>
<xsd:enumeration value="Anderson"/>
<xsd:enumeration value="Pulay"/>
<xsd:enumeration value="rPulay"/>
<xsd:enumeration value="pPulay"/>
<xsd:enumeration value="aPulay"/>
</xsd:restriction>
</xsd:simpleType>
......
......@@ -212,6 +212,7 @@ CONTAINS
CALL send_usage_data()
#ifdef CPP_MPI
IF(PRESENT(irank)) THEN
write (*,*) "Going into post send barrier"
CALL MPI_BARRIER(MPI_COMM_WORLD,ierr)
CALL MPI_FINALIZE(ierr)
ELSE
......
......@@ -137,7 +137,7 @@ SUBROUTINE cdngen(eig_id,mpi,input,banddos,sliceplot,vacuum,&
IF (vacuum%nstm.EQ.3) CALL juDFT_end("VACWAVE OK",mpi%irank)
IF (mpi%irank.EQ.0) THEN
CALL cdntot(mpi,stars,atoms,sym,vacuum,input,cell,oneD,outDen,.TRUE.,qtot,dummy)
CALL cdntot(stars,atoms,sym,vacuum,input,cell,oneD,outDen,.TRUE.,qtot,dummy)
CALL closeXMLElement('valenceDensity')
END IF ! mpi%irank = 0
......
......@@ -41,7 +41,7 @@ CONTAINS
USE m_fleur_init
USE m_optional
USE m_cdn_io
USE m_broyd_io
USE m_mixing_history
USE m_qfix
USE m_vgen
USE m_writexcstuff
......@@ -212,7 +212,7 @@ CONTAINS
cell,oneD,enpara,results,sym,xcpot,vTot,iter,iterHF)
END SELECT
IF(hybrid%l_calhf) THEN
CALL system("rm broyd*")
call mixing_history_reset(mpi)
iter = 0
END IF
ENDIF
......@@ -411,10 +411,9 @@ CONTAINS
field2 = field
! mix input and output densities
CALL timestart("mixing")
CALL mix(field2,xcpot,dimension,obsolete,sliceplot,mpi,stars,atoms,sphhar,vacuum,input,&
sym,cell,noco,oneD,hybrid,archiveType,inDen,outDen,results)
CALL timestop("mixing")
CALL mix_charge(field2,DIMENSION,mpi,(iter==input%itmax.OR.judft_was_argument("-mix_io")),&
stars,atoms,sphhar,vacuum,input,&
sym,cell,noco,oneD,archiveType,inDen,outDen,results)
IF(mpi%irank == 0) THEN
WRITE (6,FMT=8130) iter
......@@ -485,7 +484,7 @@ CONTAINS
CLOSE(2)
PRINT *,"qfix set to F"
ENDIF
CALL resetBroydenHistory()
call mixing_history_reset(mpi)
ENDIF
CALL juDFT_end(" GEO new inp.xml created ! ",mpi%irank)
END SUBROUTINE priv_geo_end
......
......@@ -13,7 +13,7 @@ MODULE m_fleur_arguments
CHARACTER(len=200) :: values
END TYPE t_fleur_param
INTEGER,PARAMETER:: no_params=24
INTEGER,PARAMETER:: no_params=25
TYPE(t_fleur_param) :: fleur_param(no_params)=(/&
!Input options
t_fleur_param(0,"-toXML","Convert an old 'inp' file into the new XML format",""),&
......@@ -58,6 +58,7 @@ MODULE m_fleur_arguments
t_fleur_param(0,"-trace","Try to generate a stacktrace in case of an error",""),&
t_fleur_param(0,"-debugtime","Write the start/stop of all timers to the console",""),&
!Output
t_fleur_param(0,"-mix_io","Do not store mixing history in memory but do IO in each iteration",""),&
t_fleur_param(0,"-no_out","Do not open the 'out' file but write to stdout",""),&
t_fleur_param(0,"-genEnpara","Generate an 'enpara' file for the energy parameters",""),&
t_fleur_param(0,"-kpts_gw","add alternative k point set for GW in all outputs for the XML input file",""),&
......
......@@ -28,7 +28,7 @@
USE m_setupMPI
USE m_cdn_io
USE m_fleur_info
USE m_broyd_io
USE m_mixing_history
USE m_checks
USE m_prpqfftmap
USE m_writeOutHeader
......@@ -531,7 +531,7 @@
CALL results%init(dimension,input,atoms,kpts,noco)
IF (mpi%irank.EQ.0) THEN
IF(input%gw.NE.0) CALL resetBroydenHistory()
IF(input%gw.NE.0) CALL mixing_history_reset(mpi)
CALL setStartingDensity(noco%l_noco)
END IF
......
This diff is collapsed.
set(fleur_F77 ${fleur_F77}
math/angle.f
math/cfft.F
math/clebsch.f
math/cylbes.f
math/cylpts.f
......@@ -22,6 +21,7 @@ math/util.F
math/difcub.f
)
set(fleur_F90 ${fleur_F90}
math/cfft.F90
math/rfft.f90
math/differentiate.f90
math/fft2d.F90
......
This diff is collapsed.
MODULE m_fft3d
CONTAINS
SUBROUTINE fft3d(&
& afft,bfft,fg3,&
& stars,isn,scaled)
MODULE m_fft3d
CONTAINS
SUBROUTINE fft3d(&
& afft, bfft, fg3,&
& stars, isn, scaled)
!************************************************************
!* *
......@@ -19,74 +19,74 @@
USE m_types
USE m_fft_interface
IMPLICIT NONE
INTEGER, INTENT (IN) :: isn
TYPE(t_stars),INTENT(IN):: stars
REAL, INTENT (INOUT) :: afft(0:27*stars%mx1*stars%mx2*stars%mx3-1)
REAL, INTENT (INOUT) :: bfft(0:27*stars%mx1*stars%mx2*stars%mx3-1)
INTEGER, INTENT(IN) :: isn
TYPE(t_stars), INTENT(IN):: stars
REAL, INTENT(INOUT) :: afft(0:27*stars%mx1*stars%mx2*stars%mx3 - 1)
REAL, INTENT(INOUT) :: bfft(0:27*stars%mx1*stars%mx2*stars%mx3 - 1)
COMPLEX :: fg3(stars%ng3)
LOGICAL,INTENT(IN),OPTIONAL :: scaled !< determines if coefficients are scaled by stars%nstr
LOGICAL, INTENT(IN), OPTIONAL :: scaled !< determines if coefficients are scaled by stars%nstr
INTEGER i,ifftd
INTEGER i, ifftd
REAL scale
COMPLEX ctmp
LOGICAL forw
INTEGER length_zfft(3)
complex :: zfft(0:27*stars%mx1*stars%mx2*stars%mx3-1)
complex :: zfft(0:27*stars%mx1*stars%mx2*stars%mx3 - 1)
ifftd = 27*stars%mx1*stars%mx2*stars%mx3
ifftd=27*stars%mx1*stars%mx2*stars%mx3
IF (isn.GT.0) THEN
IF (isn > 0) THEN
!
! ---> put stars onto the fft-grid
! ---> put stars onto the fft-grid
!
afft=0.0
bfft=0.0
DO i=0,stars%kimax
ctmp = fg3(stars%igfft(i,1))*stars%pgfft(i)
afft(stars%igfft(i,2))=real(ctmp)
bfft(stars%igfft(i,2))=aimag(ctmp)
ENDDO
afft = 0.0
bfft = 0.0
DO i = 0, stars%kimax
ctmp = fg3(stars%igfft(i, 1))*stars%pgfft(i)
afft(stars%igfft(i, 2)) = real(ctmp)
bfft(stars%igfft(i, 2)) = aimag(ctmp)
ENDDO
ENDIF
!---> now do the fft (isn=+1 : G -> r ; isn=-1 : r -> G)
zfft = cmplx(afft,bfft)
zfft = cmplx(afft, bfft)
if (isn == -1) then
forw = .true.
forw = .true.
else
forw = .false.
forw = .false.
end if
length_zfft(1) = 3*stars%mx1
length_zfft(2) = 3*stars%mx2
length_zfft(3) = 3*stars%mx3
call fft_interface(3,length_zfft,zfft,forw)
call fft_interface(3, length_zfft, zfft, forw)
afft = real(zfft)
bfft = aimag(zfft)
IF (isn.LT.0) THEN
IF (isn < 0) THEN
!
! ---> collect stars from the fft-grid
!
DO i=1,stars%ng3
fg3(i) = cmplx(0.0,0.0)
ENDDO
DO i=0,stars%kimax
fg3(stars%igfft(i,1)) = fg3(stars%igfft(i,1)) + CONJG( stars%pgfft(i) ) * &
& zfft(stars%igfft(i,2))
ENDDO
scale=1.0/ifftd
IF (PRESENT(scaled)) THEN
IF (scaled) THEN
fg3=scale*fg3/stars%nstr
ELSE
fg3=scale*fg3
ENDIF
ELSE
fg3=scale*fg3/stars%nstr
ENDIF
DO i = 1, stars%ng3
fg3(i) = cmplx(0.0, 0.0)
ENDDO
DO i = 0, stars%kimax
fg3(stars%igfft(i, 1)) = fg3(stars%igfft(i, 1)) + CONJG(stars%pgfft(i))* &
& zfft(stars%igfft(i, 2))
ENDDO
scale = 1.0/ifftd
IF (PRESENT(scaled)) THEN
IF (scaled) THEN
fg3 = scale*fg3/stars%nstr
ELSE
fg3 = scale*fg3
ENDIF
ELSE
fg3 = scale*fg3/stars%nstr
ENDIF
ENDIF
END SUBROUTINE fft3d
END MODULE m_fft3d
END SUBROUTINE fft3d
END MODULE m_fft3d
......@@ -2,11 +2,17 @@ set(fleur_F77 ${fleur_F77}
mix/metr_z0.f