Commit 23e34990 authored by Matthias Redies's avatar Matthias Redies

next batch

parent ae120b84
......@@ -15,12 +15,11 @@ MODULE m_hubbard1_setup
#ifdef CPP_EDSOLVER
USE EDsolver, only: EDsolver_from_cfg
#endif
IMPLICIT NONE
#ifdef CPP_MPI
INCLUDE 'mpif.h'
use mpi
#endif
IMPLICIT NONE
#include"cpp_double.h"
CHARACTER(len=30), PARAMETER :: hubbard1CalcFolder = "Hubbard1"
......@@ -28,13 +27,13 @@ MODULE m_hubbard1_setup
CONTAINS
SUBROUTINE hubbard1_setup(atoms,gfinp,hub1inp,input,mpi,noco,pot,gdft,hub1data,results,den)
SUBROUTINE hubbard1_setup(atoms,gfinp,hub1inp,input,fmpi,noco,pot,gdft,hub1data,results,den)
TYPE(t_atoms), INTENT(IN) :: atoms
TYPE(t_gfinp), INTENT(IN) :: gfinp
TYPE(t_hub1inp), INTENT(IN) :: hub1inp
TYPE(t_input), INTENT(IN) :: input
TYPE(t_mpi), INTENT(IN) :: mpi
TYPE(t_mpi), INTENT(IN) :: fmpi
TYPE(t_noco), INTENT(IN) :: noco
TYPE(t_potden), INTENT(IN) :: pot
TYPE(t_greensf), INTENT(IN) :: gdft(:) !green's function calculated from the Kohn-Sham system
......@@ -71,7 +70,7 @@ MODULE m_hubbard1_setup
CALL juDFT_error("No solver linked for Hubbard 1", hint="Link the edsolver library",calledby="hubbard1_setup")
#endif
IF(mpi%irank.EQ.0) THEN
IF(fmpi%irank.EQ.0) THEN
!-------------------------------------------
! Create the Input for the Hubbard 1 Solver
!-------------------------------------------
......@@ -161,7 +160,7 @@ MODULE m_hubbard1_setup
! V_AMF = U n/2 + 2l/[2(2l+1)] (U-J) n
!--------------------------------------------------------------------------
mu_dc = doubleCountingPot(U,J,l,l_amf,.NOT.hub1inp%l_dftspinpol,occDFT(i_hia,:),&
l_write=mpi%irank==0)
l_write=fmpi%irank==0)
!-------------------------------------------------------
! Check for additional input files
......@@ -180,14 +179,14 @@ MODULE m_hubbard1_setup
CALL write_hubbard1_input(xPath,i_hia,l,f0(i_hia),f2(i_hia),f4(i_hia),f6(i_hia),&
hub1inp,hub1data,mu_dc(1),occDFT_INT,l_bathexist,l_firstIT_HIA)
ENDDO
ENDIF !mpi%irank == 0
ENDIF !fmpi%irank == 0
IF(mpi%irank.EQ.0) THEN
IF(fmpi%irank.EQ.0) THEN
WRITE(*,*) "Calculating new density matrix ..."
ENDIF
!Argument order different because occDFT is not allocatable
CALL mpi_bc(0,mpi%mpi_comm,occDFT)
CALL mpi_bc(0,fmpi%mpi_comm,occDFT)
!Initializations
ALLOCATE(gu(atoms%n_hia))
......@@ -200,13 +199,13 @@ MODULE m_hubbard1_setup
#ifdef CPP_MPI
!distribute the individual hubbard1 elements over the ranks
n_hia_task = FLOOR(REAL(atoms%n_hia)/(mpi%isize))
extra = atoms%n_hia - n_hia_task*mpi%isize
i_hia_start = mpi%irank*n_hia_task + 1 + extra
i_hia_end =(mpi%irank+1)*n_hia_task + extra
IF(mpi%irank < extra) THEN
i_hia_start = i_hia_start - (extra - mpi%irank)
i_hia_end = i_hia_end - (extra - mpi%irank - 1)
n_hia_task = FLOOR(REAL(atoms%n_hia)/(fmpi%isize))
extra = atoms%n_hia - n_hia_task*fmpi%isize
i_hia_start = fmpi%irank*n_hia_task + 1 + extra
i_hia_end =(fmpi%irank+1)*n_hia_task + extra
IF(fmpi%irank < extra) THEN
i_hia_start = i_hia_start - (extra - fmpi%irank)
i_hia_end = i_hia_end - (extra - fmpi%irank - 1)
ENDIF
#else
i_hia_start = 1
......@@ -215,7 +214,7 @@ MODULE m_hubbard1_setup
#ifdef CPP_MPI
!Make sure that the ranks are synchronized
CALL MPI_BARRIER(mpi%mpi_comm,ierr)
CALL MPI_BARRIER(fmpi%mpi_comm,ierr)
#endif
mmpMat = cmplx_0
......@@ -291,15 +290,15 @@ MODULE m_hubbard1_setup
ENDDO
IF(mpi%irank.EQ.0) THEN
IF(fmpi%irank.EQ.0) THEN
WRITE(oUnit,*)
WRITE(oUnit,'(A)') "Calculated mu to match Self-energy to DFT-GF"
ENDIF
!Collect the impurity Green's Function
DO i_hia = 1, atoms%n_hia
CALL gu(i_hia)%collect(mpi%mpi_comm)
CALL selfen(i_hia)%collect(mpi%mpi_comm)
IF(mpi%irank.EQ.0) THEN
CALL gu(i_hia)%collect(fmpi%mpi_comm)
CALL selfen(i_hia)%collect(fmpi%mpi_comm)
IF(fmpi%irank.EQ.0) THEN
!We found the chemical potential to within the desired accuracy
WRITE(oUnit,*) 'i_hia: ',i_hia, " muMatch = ", selfen(i_hia)%muMatch(:)
ENDIF
......@@ -307,7 +306,7 @@ MODULE m_hubbard1_setup
#ifdef CPP_HDF
IF(mpi%irank.EQ.0) THEN
IF(fmpi%irank.EQ.0) THEN
!------------------------------
!Write out DFT Green's Function
!------------------------------
......@@ -334,7 +333,7 @@ MODULE m_hubbard1_setup
n = SIZE(mmpMat)
ALLOCATE(ctmp(n))
CALL MPI_REDUCE(mmpMat,ctmp,n,CPP_MPI_COMPLEX,MPI_SUM,0,MPI_COMM_WORLD,ierr)
IF(mpi%irank.EQ.0) CALL CPP_BLAS_ccopy(n,ctmp,1,mmpMat,1)
IF(fmpi%irank.EQ.0) CALL CPP_BLAS_ccopy(n,ctmp,1,mmpMat,1)
DEALLOCATE(ctmp)
#endif
......@@ -344,7 +343,7 @@ MODULE m_hubbard1_setup
results%last_mmpMatdistance = 0.0
results%last_occdistance = 0.0
IF(mpi%irank.EQ.0) THEN
IF(fmpi%irank.EQ.0) THEN
DO i_hia = 1, atoms%n_hia
CALL hubbard1Distance(den%mmpMat(:,:,atoms%n_u+i_hia,:),mmpMat(:,:,i_hia,:),results)
DO ispin = 1, MERGE(3,input%jspins,gfinp%l_mperp)
......@@ -354,11 +353,11 @@ MODULE m_hubbard1_setup
ENDIF
!Broadcast the density matrix
CALL mpi_bc(den%mmpMat,0,mpi%mpi_comm)
CALL mpi_bc(results%last_occdistance,0,mpi%mpi_comm)
CALL mpi_bc(results%last_mmpMatdistance,0,mpi%mpi_comm)
CALL mpi_bc(den%mmpMat,0,fmpi%mpi_comm)
CALL mpi_bc(results%last_occdistance,0,fmpi%mpi_comm)
CALL mpi_bc(results%last_mmpMatdistance,0,fmpi%mpi_comm)
IF(mpi%irank.EQ.0) THEN
IF(fmpi%irank.EQ.0) THEN
WRITE(*,*) "Hubbard 1 Iteration: ", hub1data%iter
WRITE(*,*) "Distances: "
WRITE(*,*) "-----------------------------------------------------"
......
......@@ -4,9 +4,12 @@
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------
MODULE m_cdngen
#ifdef CPP_MPI
use mpi
#endif
CONTAINS
SUBROUTINE cdngen(eig_id,mpi,input,banddos,sliceplot,vacuum,&
SUBROUTINE cdngen(eig_id,fmpi,input,banddos,sliceplot,vacuum,&
kpts,atoms,sphhar,stars,sym,gfinp,hub1inp,&
enpara,cell,noco,nococonv,vTot,results,oneD,coreSpecInput,&
archiveType, xcpot,outDen,EnergyDen,greensFunction,hub1data)
......@@ -48,13 +51,9 @@ SUBROUTINE cdngen(eig_id,mpi,input,banddos,sliceplot,vacuum,&
IMPLICIT NONE
#ifdef CPP_MPI
INCLUDE 'mpif.h'
#endif
! Type instance arguments
TYPE(t_results),INTENT(INOUT) :: results
TYPE(t_mpi),INTENT(IN) :: mpi
TYPE(t_mpi),INTENT(IN) :: fmpi
TYPE(t_oneD),INTENT(IN) :: oneD
TYPE(t_enpara),INTENT(INOUT) :: enpara
......@@ -110,7 +109,7 @@ SUBROUTINE cdngen(eig_id,mpi,input,banddos,sliceplot,vacuum,&
CALL regCharges%init(input,atoms)
CALL dos%init(input,atoms,kpts,vacuum)
CALL moments%init(mpi,input,sphhar,atoms)
CALL moments%init(fmpi,input,sphhar,atoms)
CALL mcd%init1(banddos,input,atoms,kpts)
CALL slab%init(banddos,atoms,cell,input,kpts)
CALL orbcomp%init(input,banddos,atoms,kpts)
......@@ -121,17 +120,17 @@ SUBROUTINE cdngen(eig_id,mpi,input,banddos,sliceplot,vacuum,&
DO i_gf = 1, gfinp%n
IF(.NOT.greensFunction(i_gf)%l_calc) CYCLE
iContour = gfinp%elem(i_gf)%iContour
CALL greensFunction(i_gf)%contour%eContour(gfinp%contour(iContour),results%ef,mpi%irank)
CALL greensFunction(i_gf)%contour%eContour(gfinp%contour(iContour),results%ef,fmpi%irank)
CALL greensFunction(i_gf)%reset()
ENDDO
CALL greensfImagPart%init(gfinp,input,noco,ANY(greensFunction(:)%l_calc))
IF(atoms%n_hia.GT.0 .AND. mpi%irank==0 .AND.PRESENT(hub1data)) hub1data%mag_mom = 0.0
IF(atoms%n_hia.GT.0 .AND. fmpi%irank==0 .AND.PRESENT(hub1data)) hub1data%mag_mom = 0.0
ENDIF
CALL outDen%init(stars, atoms, sphhar, vacuum, noco, input%jspins, POTDEN_TYPE_DEN)
CALL EnergyDen%init(stars, atoms, sphhar, vacuum, noco, input%jspins, POTDEN_TYPE_EnergyDen)
IF (mpi%irank == 0) CALL openXMLElementNoAttributes('valenceDensity')
IF (fmpi%irank == 0) CALL openXMLElementNoAttributes('valenceDensity')
!In a non-collinear calcuation where the off-diagonal part of the
!density matrix in the muffin-tins is calculated, the a- and
......@@ -141,9 +140,9 @@ SUBROUTINE cdngen(eig_id,mpi,input,banddos,sliceplot,vacuum,&
jspmax = input%jspins
IF (noco%l_mperp.OR.banddos%l_jDOS) jspmax = 1
DO jspin = 1,jspmax
CALL cdnvalJob%init(mpi,input,kpts,noco,results,jspin)
CALL cdnvalJob%init(fmpi,input,kpts,noco,results,jspin)
IF (sliceplot%slice) CALL cdnvalJob%select_slice(sliceplot,results,input,kpts,noco,jspin)
CALL cdnval(eig_id,mpi,kpts,jspin,noco,nococonv,input,banddos,cell,atoms,enpara,stars,vacuum,&
CALL cdnval(eig_id,fmpi,kpts,jspin,noco,nococonv,input,banddos,cell,atoms,enpara,stars,vacuum,&
sphhar,sym,vTot,oneD,cdnvalJob,outDen,regCharges,dos,results,moments,gfinp,&
hub1inp,hub1data,coreSpecInput,mcd,slab,orbcomp,jDOS,greensfImagPart)
END DO
......@@ -151,11 +150,11 @@ SUBROUTINE cdngen(eig_id,mpi,input,banddos,sliceplot,vacuum,&
call val_den%copyPotDen(outDen)
! calculate kinetic energy density for MetaGGAs
if(xcpot%exc_is_metagga()) then
CALL calc_EnergyDen(eig_id, mpi, kpts, noco, nococonv,input, banddos, cell, atoms, enpara, stars,&
CALL calc_EnergyDen(eig_id, fmpi, kpts, noco, nococonv,input, banddos, cell, atoms, enpara, stars,&
vacuum, sphhar, sym, gfinp, hub1inp, vTot, oneD, results, EnergyDen)
endif
IF (mpi%irank == 0) THEN
IF (fmpi%irank == 0) THEN
IF (banddos%dos.or.banddos%vacdos.or.input%cdinf) THEN
IF (banddos%unfoldband) THEN
eFermiPrev = 0.0
......@@ -177,36 +176,36 @@ SUBROUTINE cdngen(eig_id,mpi,input,banddos,sliceplot,vacuum,&
END IF
END IF
IF ((banddos%dos.OR.banddos%vacdos).AND.(banddos%ndir/=-2)) CALL juDFT_end("DOS OK",mpi%irank)
IF (vacuum%nstm == 3) CALL juDFT_end("VACWAVE OK",mpi%irank)
IF ((banddos%dos.OR.banddos%vacdos).AND.(banddos%ndir/=-2)) CALL juDFT_end("DOS OK",fmpi%irank)
IF (vacuum%nstm == 3) CALL juDFT_end("VACWAVE OK",fmpi%irank)
CALL cdntot(stars,atoms,sym,vacuum,input,cell,oneD,outDen,.TRUE.,qtot,dummy,mpi,.TRUE.)
IF (mpi%irank.EQ.0) THEN
CALL cdntot(stars,atoms,sym,vacuum,input,cell,oneD,outDen,.TRUE.,qtot,dummy,fmpi,.TRUE.)
IF (fmpi%irank.EQ.0) THEN
CALL closeXMLElement('valenceDensity')
END IF ! mpi%irank = 0
END IF ! fmpi%irank = 0
IF (sliceplot%slice) THEN
IF (mpi%irank == 0) THEN
IF (fmpi%irank == 0) THEN
IF(noco%l_alignMT) CALL juDFT_error("Relaxation of SQA and sliceplot not implemented. To perfom a sliceplot of the correct cdn deactivate realaxation.", calledby = "cdngen" )
CALL writeDensity(stars,noco,vacuum,atoms,cell,sphhar,input,sym,oneD,CDN_ARCHIVE_TYPE_CDN_const,CDN_INPUT_DEN_const,&
0,-1.0,0.0,.FALSE.,outDen,'cdn_slice')
END IF
#ifdef CPP_MPI
CALL mpi_bc_potden(mpi,stars,sphhar,atoms,input,vacuum,oneD,noco,outDen)
CALL mpi_bc_potden(fmpi,stars,sphhar,atoms,input,vacuum,oneD,noco,outDen)
#endif
CALL juDFT_end("slice OK",mpi%irank)
CALL juDFT_end("slice OK",fmpi%irank)
END IF
!IF (sliceplot%iplot.NE.0) THEN
! CALL makeplots(stars, atoms, sphhar, vacuum, input, mpi,oneD, sym, cell, noco,nococonv, outDen, PLOT_OUTDEN_Y_CORE, sliceplot)
! CALL makeplots(stars, atoms, sphhar, vacuum, input, fmpi,oneD, sym, cell, noco,nococonv, outDen, PLOT_OUTDEN_Y_CORE, sliceplot)
!END IF
IF(PRESENT(greensFunction) .AND.gfinp%n.GT.0) THEN
IF(greensfImagPart%l_calc) THEN
CALL greensfPostProcess(greensFunction,greensfImagPart,atoms,gfinp,input,sym,noco,mpi,&
CALL greensfPostProcess(greensFunction,greensfImagPart,atoms,gfinp,input,sym,noco,fmpi,&
nococonv,vTot,enpara,hub1inp,hub1data,results)
ELSE
IF(mpi%irank.EQ.0) THEN
IF(fmpi%irank.EQ.0) THEN
WRITE(oUnit,'(/,A)') "Green's Functions are not calculated: "
WRITE(oUnit,'(A,f12.7,TR5,A,f12.7/)') "lastDistance: ", results%last_distance,&
"minCalcDistance: ", gfinp%minCalcDistance
......@@ -217,25 +216,25 @@ SUBROUTINE cdngen(eig_id,mpi,input,banddos,sliceplot,vacuum,&
CALL timestart("cdngen: cdncore")
if(xcpot%exc_is_MetaGGA()) then
CALL cdncore(mpi,oneD,input,vacuum,noco,nococonv,sym,&
CALL cdncore(fmpi,oneD,input,vacuum,noco,nococonv,sym,&
stars,cell,sphhar,atoms,vTot,outDen,moments,results, EnergyDen)
else
CALL cdncore(mpi,oneD,input,vacuum,noco,nococonv,sym,&
CALL cdncore(fmpi,oneD,input,vacuum,noco,nococonv,sym,&
stars,cell,sphhar,atoms,vTot,outDen,moments,results)
endif
call core_den%subPotDen(outDen, val_den)
CALL timestop("cdngen: cdncore")
IF(.FALSE.) CALL denMultipoleExp(input, mpi, atoms, sphhar, stars, sym, cell, oneD, outDen) ! There should be a switch in the inp file for this
IF(mpi%irank.EQ.0) THEN
IF(.FALSE.) CALL denMultipoleExp(input, fmpi, atoms, sphhar, stars, sym, cell, oneD, outDen) ! There should be a switch in the inp file for this
IF(fmpi%irank.EQ.0) THEN
IF(input%lResMax>0) CALL resMoms(sym,input,atoms,sphhar,noco,nococonv,outDen,moments%rhoLRes) ! There should be a switch in the inp file for this
END IF
CALL enpara%calcOutParams(input,atoms,vacuum,regCharges)
IF (mpi%irank == 0) CALL openXMLElementNoAttributes('allElectronCharges')
CALL qfix(mpi,stars,atoms,sym,vacuum,sphhar,input,cell,oneD,outDen,noco%l_noco,.TRUE.,l_par=.TRUE.,force_fix=.TRUE.,fix=fix)
IF (mpi%irank == 0) THEN
IF (fmpi%irank == 0) CALL openXMLElementNoAttributes('allElectronCharges')
CALL qfix(fmpi,stars,atoms,sym,vacuum,sphhar,input,cell,oneD,outDen,noco%l_noco,.TRUE.,l_par=.TRUE.,force_fix=.TRUE.,fix=fix)
IF (fmpi%irank == 0) THEN
CALL closeXMLElement('allElectronCharges')
IF (input%jspins == 2) THEN
......@@ -255,7 +254,7 @@ SUBROUTINE cdngen(eig_id,mpi,input,banddos,sliceplot,vacuum,&
IF (noco%l_soc) CALL orbMagMoms(input,atoms,noco,nococonv,moments%clmom)
END IF
END IF ! mpi%irank == 0
END IF ! fmpi%irank == 0
Perform_metagga = Allocated(Energyden%Mt) &
.And. (Xcpot%Exc_is_metagga() .Or. Xcpot%Vx_is_metagga())
If(Perform_metagga) Then
......@@ -266,12 +265,12 @@ SUBROUTINE cdngen(eig_id,mpi,input,banddos,sliceplot,vacuum,&
#ifdef CPP_MPI
CALL MPI_BCAST(nococonv%alph,atoms%ntype,MPI_DOUBLE_PRECISION,0,mpi%mpi_comm,ierr)
CALL MPI_BCAST(nococonv%beta,atoms%ntype,MPI_DOUBLE_PRECISION,0,mpi%mpi_comm,ierr)
CALL MPI_BCAST(nococonv%b_con,atoms%ntype*2,MPI_DOUBLE_PRECISION,0,mpi%mpi_comm,ierr)
CALL MPI_BCAST(nococonv%qss,3,MPI_DOUBLE_PRECISION,0,mpi%mpi_comm,ierr)
CALL MPI_BCAST(nococonv%alph,atoms%ntype,MPI_DOUBLE_PRECISION,0,fmpi%mpi_comm,ierr)
CALL MPI_BCAST(nococonv%beta,atoms%ntype,MPI_DOUBLE_PRECISION,0,fmpi%mpi_comm,ierr)
CALL MPI_BCAST(nococonv%b_con,atoms%ntype*2,MPI_DOUBLE_PRECISION,0,fmpi%mpi_comm,ierr)
CALL MPI_BCAST(nococonv%qss,3,MPI_DOUBLE_PRECISION,0,fmpi%mpi_comm,ierr)
CALL mpi_bc_potden(mpi,stars,sphhar,atoms,input,vacuum,oneD,noco,outDen)
CALL mpi_bc_potden(fmpi,stars,sphhar,atoms,input,vacuum,oneD,noco,outDen)
#endif
END SUBROUTINE cdngen
......
......@@ -5,8 +5,11 @@
!--------------------------------------------------------------------------------
MODULE m_optional
USE m_juDFT
#ifdef CPP_MPI
use mpi
#endif
CONTAINS
SUBROUTINE OPTIONAL(mpi, atoms,sphhar,vacuum,&
SUBROUTINE OPTIONAL(fmpi, atoms,sphhar,vacuum,&
stars,input,sym, cell, sliceplot, xcpot, noco, oneD)
!
!----------------------------------------
......@@ -59,7 +62,7 @@ CONTAINS
! ..
! .. Scalar Arguments ..
TYPE(t_mpi),INTENT(IN) :: mpi
TYPE(t_mpi),INTENT(IN) :: fmpi
TYPE(t_atoms),INTENT(IN) :: atoms
TYPE(t_sphhar),INTENT(IN) :: sphhar
......@@ -79,7 +82,6 @@ CONTAINS
LOGICAL :: strho
LOGICAL :: stateCheck=.TRUE.
#ifdef CPP_MPI
include 'mpif.h'
INTEGER :: ierr(2)
#endif
! ..
......@@ -97,11 +99,11 @@ CONTAINS
ELSE IF (noco%l_noco) THEN
archiveType = CDN_ARCHIVE_TYPE_NOCO_const
END IF
IF (mpi%irank == 0) THEN
IF (fmpi%irank == 0) THEN
strho = .NOT.isDensityFilePresent(archiveType)
END IF
#ifdef CPP_MPI
CALL MPI_BCAST(strho,1,MPI_LOGICAL,0,mpi%mpi_comm,ierr)
CALL MPI_BCAST(strho,1,MPI_LOGICAL,0,fmpi%mpi_comm,ierr)
#endif
ENDIF
IF (strho) THEN
......@@ -115,13 +117,13 @@ CONTAINS
END DO
END IF
IF (stateCheck.AND.(input%jspins.EQ.2)) CALL juDFT_warn("You're setting up a spin-polarized calculation (jspins=2) without any acutal polarization given in the systems occupation. You're sure you want that?", calledby = "optional")
CALL stden(mpi,sphhar,stars,atoms,sym,vacuum,&
CALL stden(fmpi,sphhar,stars,atoms,sym,vacuum,&
input,cell,xcpot,noco,oneD)
!
!input%total=strho
CALL timestop("generation of start-density")
END IF
IF (mpi%irank == 0) THEN
IF (fmpi%irank == 0) THEN
!
! --->generate spin polarized charge density
!
......@@ -148,12 +150,12 @@ CONTAINS
CALL bmt(stars,input,noco,atoms,sphhar,vacuum,cell,sym,oneD)
ENDIF
ENDIF ! mpi%irank == 0
ENDIF ! fmpi%irank == 0
IF (input%strho) CALL juDFT_end("starting density generated",mpi%irank)
IF (input%swsp) CALL juDFT_end("spin polarised density generated",mpi%irank)
IF (input%lflip) CALL juDFT_end("magnetic moments flipped",mpi%irank)
IF (input%l_bmt) CALL juDFT_end('"cdnbmt" written',mpi%irank)
IF (input%strho) CALL juDFT_end("starting density generated",fmpi%irank)
IF (input%swsp) CALL juDFT_end("spin polarised density generated",fmpi%irank)
IF (input%lflip) CALL juDFT_end("magnetic moments flipped",fmpi%irank)
IF (input%l_bmt) CALL juDFT_end('"cdnbmt" written',fmpi%irank)
END SUBROUTINE OPTIONAL
END MODULE m_optional
......@@ -14,7 +14,7 @@ MODULE m_mpi_col_den
use mpi
#endif
CONTAINS
SUBROUTINE mpi_col_den(mpi_var,sphhar,atoms,oneD,stars,vacuum,input,noco,jspin,regCharges,dos,&
SUBROUTINE mpi_col_den(fmpi,sphhar,atoms,oneD,stars,vacuum,input,noco,jspin,regCharges,dos,&
results,denCoeffs,orb,denCoeffsOffdiag,den,mcd,slab,orbcomp,jDOS)
#include"cpp_double.h"
......@@ -24,7 +24,7 @@ CONTAINS
IMPLICIT NONE
TYPE(t_results),INTENT(INOUT):: results
TYPE(t_mpi),INTENT(IN) :: mpi_var
TYPE(t_mpi),INTENT(IN) :: fmpi
TYPE(t_oneD),INTENT(IN) :: oneD
TYPE(t_input),INTENT(IN) :: input
TYPE(t_vacuum),INTENT(IN) :: vacuum
......@@ -77,7 +77,7 @@ CONTAINS
n=size(den%vacxy(:,:,:,jspin))
ALLOCATE(c_b(n))
CALL MPI_REDUCE(den%vacxy(:,:,:,jspin),c_b,n,CPP_MPI_COMPLEX,MPI_SUM,0, MPI_COMM_WORLD,ierr)
IF (mpi_var%irank.EQ.0) CALL CPP_BLAS_ccopy(n, c_b, 1, den%vacxy(:,:,:,jspin), 1)
IF (fmpi%irank.EQ.0) CALL CPP_BLAS_ccopy(n, c_b, 1, den%vacxy(:,:,:,jspin), 1)
DEALLOCATE (c_b)
! -> Collect den%vacz(:,:,jspin)
......@@ -85,7 +85,7 @@ CONTAINS
n=size(den%vacz(:,:,jspin))
ALLOCATE(r_b(n))
CALL MPI_REDUCE(den%vacz(:,:,jspin),r_b,n,CPP_MPI_REAL,MPI_SUM,0, MPI_COMM_WORLD,ierr)
IF (mpi_var%irank.EQ.0) CALL CPP_BLAS_scopy(n, r_b, 1, den%vacz(:,:,jspin), 1)
IF (fmpi%irank.EQ.0) CALL CPP_BLAS_scopy(n, r_b, 1, den%vacz(:,:,jspin), 1)
DEALLOCATE (r_b)
ENDIF
......@@ -137,7 +137,7 @@ CONTAINS
n = SIZE(dos%jsym,1)*SIZE(dos%jsym,2)
ALLOCATE(i_b(n))
CALL MPI_REDUCE(dos%jsym(:,:,jspin),i_b,n,MPI_INTEGER,MPI_SUM,0, MPI_COMM_WORLD,ierr)
IF (mpi_var%irank.EQ.0) THEN
IF (fmpi%irank.EQ.0) THEN
DO i = 1, SIZE(dos%jsym,2)
dos%jsym(:,i,jspin) = i_b((i-1)*SIZE(dos%jsym,1)+1:i*SIZE(dos%jsym,1))
END DO
......@@ -147,7 +147,7 @@ CONTAINS
n = SIZE(dos%ksym,1)*SIZE(dos%ksym,2)
ALLOCATE(i_b(n))
CALL MPI_REDUCE(dos%ksym(:,:,jspin),i_b,n,MPI_INTEGER,MPI_SUM,0, MPI_COMM_WORLD,ierr)
IF (mpi_var%irank.EQ.0) THEN
IF (fmpi%irank.EQ.0) THEN
DO i = 1, SIZE(dos%ksym,2)
dos%ksym(:,i,jspin) = i_b((i-1)*SIZE(dos%ksym,1)+1:i*SIZE(dos%ksym,1))
END DO
......@@ -157,31 +157,31 @@ CONTAINS
n = SIZE(dos%qis,1)*SIZE(dos%qis,2)
ALLOCATE(r_b(n))
CALL MPI_REDUCE(dos%qis(:,:,jspin),r_b,n,CPP_MPI_REAL,MPI_SUM,0, MPI_COMM_WORLD,ierr)
IF (mpi_var%irank.EQ.0) CALL CPP_BLAS_scopy(n, r_b, 1, dos%qis(:,:,jspin), 1)
IF (fmpi%irank.EQ.0) CALL CPP_BLAS_scopy(n, r_b, 1, dos%qis(:,:,jspin), 1)
DEALLOCATE (r_b)
n = SIZE(dos%qal,1)*SIZE(dos%qal,2)*SIZE(dos%qal,3)*SIZE(dos%qal,4)
ALLOCATE(r_b(n))
CALL MPI_REDUCE(dos%qal(0:,:,:,:,jspin),r_b,n,CPP_MPI_REAL,MPI_SUM,0, MPI_COMM_WORLD,ierr)
IF (mpi_var%irank.EQ.0) CALL CPP_BLAS_scopy(n, r_b, 1, dos%qal(0:,:,:,:,jspin), 1)
IF (fmpi%irank.EQ.0) CALL CPP_BLAS_scopy(n, r_b, 1, dos%qal(0:,:,:,:,jspin), 1)
DEALLOCATE (r_b)
n = SIZE(dos%qvac,1)*SIZE(dos%qvac,2)*SIZE(dos%qvac,3)
ALLOCATE(r_b(n))
CALL MPI_REDUCE(dos%qvac(:,:,:,jspin),r_b,n,CPP_MPI_REAL,MPI_SUM,0, MPI_COMM_WORLD,ierr)
IF (mpi_var%irank.EQ.0) CALL CPP_BLAS_scopy(n, r_b, 1, dos%qvac(:,:,:,jspin), 1)
IF (fmpi%irank.EQ.0) CALL CPP_BLAS_scopy(n, r_b, 1, dos%qvac(:,:,:,jspin), 1)
DEALLOCATE (r_b)
n = SIZE(dos%qvlay,1)*SIZE(dos%qvlay,2)*SIZE(dos%qvlay,3)*SIZE(dos%qvlay,4)
ALLOCATE(r_b(n))
CALL MPI_REDUCE(dos%qvlay(:,:,:,:,jspin),r_b,n,CPP_MPI_REAL,MPI_SUM,0, MPI_COMM_WORLD,ierr)
IF (mpi_var%irank.EQ.0) CALL CPP_BLAS_scopy(n, r_b, 1, dos%qvlay(:,:,:,:,jspin), 1)
IF (fmpi%irank.EQ.0) CALL CPP_BLAS_scopy(n, r_b, 1, dos%qvlay(:,:,:,:,jspin), 1)
DEALLOCATE (r_b)
n = SIZE(dos%qstars,1)*SIZE(dos%qstars,2)*SIZE(dos%qstars,3)*SIZE(dos%qstars,4)*SIZE(dos%qstars,5)
ALLOCATE(c_b(n))
CALL MPI_REDUCE(dos%qstars(:,:,:,:,:,jspin),c_b,n,CPP_MPI_COMPLEX,MPI_SUM,0, MPI_COMM_WORLD,ierr)
IF (mpi_var%irank.EQ.0) CALL CPP_BLAS_ccopy(n, c_b, 1, dos%qstars(:,:,:,:,:,jspin), 1)
IF (fmpi%irank.EQ.0) CALL CPP_BLAS_ccopy(n, c_b, 1, dos%qstars(:,:,:,:,:,jspin), 1)
DEALLOCATE (c_b)
! Collect mcd%mcd
......@@ -189,7 +189,7 @@ CONTAINS
n = SIZE(mcd%mcd,1)*SIZE(mcd%mcd,2)*SIZE(mcd%mcd,3)*SIZE(mcd%mcd,4)
ALLOCATE(r_b(n))
CALL MPI_REDUCE(mcd%mcd(:,:,:,:,jspin),r_b,n,CPP_MPI_REAL,MPI_SUM,0, MPI_COMM_WORLD,ierr)
IF (mpi_var%irank.EQ.0) CALL CPP_BLAS_scopy(n, r_b, 1, mcd%mcd(:,:,:,:,jspin), 1)
IF (fmpi%irank.EQ.0) CALL CPP_BLAS_scopy(n, r_b, 1, mcd%mcd(:,:,:,:,jspin), 1)
DEALLOCATE (r_b)
END IF
......@@ -198,13 +198,13 @@ CONTAINS
n = SIZE(slab%qintsl,1)*SIZE(slab%qintsl,2)*SIZE(slab%qintsl,3)
ALLOCATE(r_b(n))
CALL MPI_REDUCE(slab%qintsl(:,:,:,jspin),r_b,n,CPP_MPI_REAL,MPI_SUM,0, MPI_COMM_WORLD,ierr)
IF (mpi_var%irank.EQ.0) CALL CPP_BLAS_scopy(n, r_b, 1, slab%qintsl(:,:,:,jspin), 1)
IF (fmpi%irank.EQ.0) CALL CPP_BLAS_scopy(n, r_b, 1, slab%qintsl(:,:,:,jspin), 1)
DEALLOCATE (r_b)
n = SIZE(slab%qmtsl,1)*SIZE(slab%qmtsl,2)*SIZE(slab%qmtsl,3)
ALLOCATE(r_b(n))
CALL MPI_REDUCE(slab%qmtsl(:,:,:,jspin),r_b,n,CPP_MPI_REAL,MPI_SUM,0, MPI_COMM_WORLD,ierr)
IF (mpi_var%irank.EQ.0) CALL CPP_BLAS_scopy(n, r_b, 1, slab%qmtsl(:,:,:,jspin), 1)
IF (fmpi%irank.EQ.0) CALL CPP_BLAS_scopy(n, r_b, 1, slab%qmtsl(:,:,:,jspin), 1)
DEALLOCATE (r_b)
END IF
......@@ -213,13 +213,13 @@ CONTAINS
n = SIZE(orbcomp%comp,1)*SIZE(orbcomp%comp,2)*SIZE(orbcomp%comp,3)*SIZE(orbcomp%comp,4)
ALLOCATE(r_b(n))
CALL MPI_REDUCE(orbcomp%comp(:,:,:,:,jspin),r_b,n,CPP_MPI_REAL,MPI_SUM,0, MPI_COMM_WORLD,ierr)
IF (mpi_var%irank.EQ.0) CALL CPP_BLAS_scopy(n, r_b, 1, orbcomp%comp(:,:,:,:,jspin), 1)
IF (fmpi%irank.EQ.0) CALL CPP_BLAS_scopy(n, r_b, 1, orbcomp%comp(:,:,:,:,jspin), 1)
DEALLOCATE (r_b)
n = SIZE(orbcomp%qmtp,1)*SIZE(orbcomp%qmtp,2)*SIZE(orbcomp%qmtp,3)
ALLOCATE(r_b(n))
CALL MPI_REDUCE(orbcomp%qmtp(:,:,:,jspin),r_b,n,CPP_MPI_REAL,MPI_SUM,0, MPI_COMM_WORLD,ierr)
IF (mpi_var%irank.EQ.0) CALL CPP_BLAS_scopy(n, r_b, 1, orbcomp%qmtp(:,:,:,jspin), 1)
IF (fmpi%irank.EQ.0) CALL CPP_BLAS_scopy(n, r_b, 1, orbcomp%qmtp(:,:,:,jspin), 1)
DEALLOCATE (r_b)
END IF
......@@ -230,19 +230,19 @@ CONTAINS
n = SIZE(jDOS%comp)
ALLOCATE(r_b(n))
CALL MPI_REDUCE(jDOS%comp,r_b,n,CPP_MPI_REAL,MPI_SUM,0,MPI_COMM_WORLD,ierr)
IF(mpi_var%irank.EQ.0) CALL CPP_BLAS_scopy(n,r_b,1,jDOS%comp,1)
IF(fmpi%irank.EQ.0) CALL CPP_BLAS_scopy(n,r_b,1,jDOS%comp,1)
DEALLOCATE(r_b)
n = SIZE(jDOS%qmtp)
ALLOCATE(r_b(n))
CALL MPI_REDUCE(jDOS%qmtp,r_b,n,CPP_MPI_REAL,MPI_SUM,0,MPI_COMM_WORLD,ierr)
IF(mpi_var%irank.EQ.0) CALL CPP_BLAS_scopy(n,r_b,1,jDOS%qmtp,1)
IF(fmpi%irank.EQ.0) CALL CPP_BLAS_scopy(n,r_b,1,jDOS%qmtp,1)
DEALLOCATE(r_b)
n = SIZE(jDOS%occ)
ALLOCATE(r_b(n))
CALL MPI_REDUCE(jDOS%occ,r_b,n,CPP_MPI_REAL,MPI_SUM,0,MPI_COMM_WORLD,ierr)
IF(mpi_var%irank.EQ.0) CALL CPP_BLAS_scopy(n,r_b,1,jDOS%occ,1)
IF(fmpi%irank.EQ.0) CALL CPP_BLAS_scopy(n,r_b,1,jDOS%occ,1)
DEALLOCATE(r_b)
ENDIF
......@@ -254,7 +254,7 @@ CONTAINS
n=3*atoms%ntype
ALLOCATE(r_b(n))
CALL MPI_REDUCE(results%force(1,1,jspin),r_b,n,CPP_MPI_REAL,MPI_SUM,0, MPI_COMM_WORLD,ierr)
IF (mpi_var%irank.EQ.0) CALL CPP_BLAS_scopy(n, r_b, 1, results%force(1,1,jspin), 1)
IF (fmpi%irank.EQ.0) CALL CPP_BLAS_scopy(n, r_b, 1, results%force(1,1,jspin), 1)
DEALLOCATE (r_b)
ENDIF
......@@ -357,7 +357,7 @@ CONTAINS
n = stars%ng3
ALLOCATE(c_b(n))
CALL MPI_REDUCE(den%pw(:,3),c_b,n,CPP_MPI_COMPLEX,MPI_SUM,0, MPI_COMM_WORLD,ierr)
IF (mpi_var%irank.EQ.0) THEN
IF (fmpi%irank.EQ.0) THEN
den%pw(:,3)=RESHAPE(c_b,(/n/))
ENDIF
DEALLOCATE (c_b)
......@@ -368,7 +368,7 @@ CONTAINS
n=size(den%vacxy(:,:,:,3))
ALLOCATE(c_b(n))
CALL MPI_REDUCE(den%vacxy(:,:,:,3),c_b,n,CPP_MPI_COMPLEX,MPI_SUM,0, MPI_COMM_WORLD,ierr)