Commit f2df362c authored by Daniel Wortmann's avatar Daniel Wortmann
Browse files

Merge branch 'develop' into 'release'

Fix for Release MaX-R5

See merge request fleur/fleur!141
parents 1cd0ad24 0a64ed93
......@@ -17,6 +17,7 @@ CONTAINS
SUBROUTINE eigen_redist_matrix(fmpi,lapw,atoms,mat,mat_final,mat_final_templ)
USE m_types
USE m_types_mpimat
USE m_mingeselle
IMPLICIT NONE
TYPE(t_mpi),INTENT(IN) :: fmpi
TYPE(t_lapw),INTENT(IN) :: lapw
......@@ -50,8 +51,11 @@ CONTAINS
CALL mat(2,2)%free()
!Now collect off-diagonal parts
!CALL mingeselle(mat(2,1),mat(1,2))
CALL mat(1,2)%add_transpose(mat(2,1))
IF (fmpi%n_size == 1 ) THEN
CALL mat(1,2)%add_transpose(mat(2,1))
ELSE
CALL mingeselle(mat(2,1),mat(1,2))
ENDIF
CALL mat_final%copy(mat(1,2),1,lapw%nv(1)+atoms%nlotot+1)
CALL mat(1,2)%free()
CALL mat(2,1)%free()
......
......@@ -3,11 +3,11 @@ set(fleur_F90 ${fleur_F90}
mpi/setupMPI.F90
mpi/omp_checker.F90
mpi/mpi_bc_potden.F90
mpi/mingeselle2.F90
)
if (FLEUR_USE_MPI)
set(fleur_F90 ${fleur_F90}
mpi/mingeselle2.F90
mpi/mpi_bc_coreDen.F90
mpi/mpi_bc_st.F90
mpi/mpi_bc_pot.F90
......
......@@ -8,6 +8,9 @@ MODULE m_mingeselle
USE m_types_mat
USE m_types_mpimat
USE m_juDFT
#ifdef CPP_MPI
USE mpi
#endif
IMPLICIT NONE
CONTAINS
......@@ -55,7 +58,7 @@ CONTAINS
INTEGER SUB_COMM
! ..
! .. Local Arrays
INTEGER ierr(3)
INTEGER ierr
INTEGER, ALLOCATABLE :: c_help_size(:,:)
INTEGER, ALLOCATABLE :: n_send(:),nsr(:)
INTEGER, ALLOCATABLE :: n_recv(:),n_r(:)
......@@ -63,13 +66,13 @@ CONTAINS
COMPLEX, ALLOCATABLE :: cs_el(:,:),cr_el(:),b_b(:),c_help(:,:)
LOGICAL, ALLOCATABLE :: nsl(:)
INCLUDE 'mpif.h'
#ifdef CPP_MPI
INTEGER stt(MPI_STATUS_SIZE)
! check and initialize
IF (mat%l_real .OR. mat1%l_real) CALL juDFT_error("Matrices should be complex",calledby ="mingeselle")
SELECT TYPE (mat1)
TYPE IS (t_mpimat)
SELECT TYPE (mat)
......@@ -94,152 +97,159 @@ CONTAINS
mat1%data_c(i, ii) = 0.0
ENDIF
ENDDO
END SELECT
END SELECT
ALLOCATE(n_send(0:n_size-1),n_recv(0:n_size-1),n_r(0:n_size-1),nsr(0:n_size-1))
ALLOCATE(c_help_size(2,0:n_size-1),nsl(0:n_size-1))
ns_tot = 0
nr_tot = 0
n_send = 0
n_r = 0
c_help_size = 0
ALLOCATE(n_send(0:n_size-1),n_recv(0:n_size-1),n_r(0:n_size-1),nsr(0:n_size-1))
ALLOCATE(c_help_size(2,0:n_size-1),nsl(0:n_size-1))
ns_tot = 0
nr_tot = 0
n_send = 0
n_r = 0
c_help_size = 0
! determine number of elements to send to other pe's
! and calculate the dimensions of c_helpi
! rows of c_help correspond to columns of mat1 and vice versa
! determine number of elements to send to other pe's
! and calculate the dimensions of c_helpi
! rows of c_help correspond to columns of mat1 and vice versa
DO ki = 1, mat1%matsize2
kjj = n_rank + 1 + (ki-1)*n_size ! global column index
nsr = 0
nsl = .FALSE.
DO kj = 1, min(kjj-1,mat1%matsize1)
ns_tot = ns_tot + 1
n_p = MOD(kj-1,n_size)
n_send(n_p) = n_send(n_p) + 1
nsr(n_p) = nsr(n_p) + 1
nsl(n_p) = .TRUE.
ENDDO
DO n_p = 0,n_size-1
IF ( c_help_size(2,n_p) < nsr(n_p) ) c_help_size(2,n_p) = nsr(n_p)
IF ( nsl(n_p) ) c_help_size(1,n_p) = c_help_size(1,n_p) + 1
ENDDO
ENDDO
!print*, "send", n_rank, ns_tot, n_send
DO ki = 1, mat1%matsize2
kjj = n_rank + 1 + (ki-1)*n_size ! global column index
nsr = 0
nsl = .FALSE.
DO kj = 1, min(kjj-1,mat1%matsize1)
ns_tot = ns_tot + 1
n_p = MOD(kj-1,n_size)
n_send(n_p) = n_send(n_p) + 1
nsr(n_p) = nsr(n_p) + 1
nsl(n_p) = .TRUE.
ENDDO
DO n_p = 0,n_size-1
IF ( c_help_size(2,n_p) < nsr(n_p) ) c_help_size(2,n_p) = nsr(n_p)
IF ( nsl(n_p) ) c_help_size(1,n_p) = c_help_size(1,n_p) + 1
ENDDO
ENDDO
!print*, "send", n_rank, ns_tot, n_send
! determine number of elements to receive from other pe's
! determine number of elements to receive from other pe's
DO ki = 1, mat%matsize2
kjj = n_rank + 1 + (ki-1)*n_size ! global column index
DO kj = kjj+1, mat%matsize1
nr_tot = nr_tot + 1
n_p = MOD(kj-1,n_size)
n_r(n_p) = n_r(n_p) + 1
ENDDO
ENDDO
!print*, "recv", n_rank, nr_tot, n_r
DO ki = 1, mat%matsize2
kjj = n_rank + 1 + (ki-1)*n_size ! global column index
DO kj = kjj+1, mat%matsize1
nr_tot = nr_tot + 1
n_p = MOD(kj-1,n_size)
n_r(n_p) = n_r(n_p) + 1
ENDDO
ENDDO
!print*, "recv", n_rank, nr_tot, n_r
! determine the maximal number of s/r-counts and allocate s/r-arrays
! determine the maximal number of s/r-counts and allocate s/r-arrays
ns_max = 0
nr_max = 0
DO n_p = 0,n_size-1
ns_max = MAX(ns_max,n_send(n_p))
nr_max = MAX(nr_max,n_r(n_p))
ENDDO
! WRITE (*,*) ns_max ,nr_max , n_size, n_rank
ALLOCATE ( cs_el(ns_max,0:n_size-1),cr_el(nr_max) )
ALLOCATE ( in_pos(2,nr_max,0:n_size-1) )
ns_max = 0
nr_max = 0
DO n_p = 0,n_size-1
ns_max = MAX(ns_max,n_send(n_p))
nr_max = MAX(nr_max,n_r(n_p))
ENDDO
! WRITE (*,*) ns_max ,nr_max , n_size, n_rank
ALLOCATE ( cs_el(ns_max,0:n_size-1),cr_el(nr_max) )
ALLOCATE ( in_pos(2,nr_max,0:n_size-1) )
! for every send destination:
! put the elements of the mat1 into the c_help,
! resorting them on the way: rows <-> columns
! then put them in the send buffers
! for every send destination:
! put the elements of the mat1 into the c_help,
! resorting them on the way: rows <-> columns
! then put them in the send buffers
ALLOCATE ( c_help(mat1%matsize2,ceiling(real(mat1%matsize1)/n_size)) )
c_help = cmplx(0.0,0.0)
DO n_p = 0,n_size-1
ALLOCATE ( c_help(mat1%matsize2,ceiling(real(mat1%matsize1)/n_size)) )
c_help = cmplx(0.0,0.0)
DO n_p = 0,n_size-1
IF (c_help_size(2,n_p) > size(c_help,2)) CALL juDFT_error("allocated c_help is too small",calledby ="mingeselle")
IF (c_help_size(1,n_p) > size(c_help,1)) CALL juDFT_error("allocated c_help is too small",calledby ="mingeselle")
!print*, "c_help_size",n_rank, n_p,c_help_size(:,n_p)
IF (c_help_size(2,n_p) > size(c_help,2)) CALL juDFT_error("allocated c_help is too small",calledby ="mingeselle")
IF (c_help_size(1,n_p) > size(c_help,1)) CALL juDFT_error("allocated c_help is too small",calledby ="mingeselle")
!print*, "c_help_size",n_rank, n_p,c_help_size(:,n_p)
DO ki = 1, c_help_size(1,n_p)
DO kj = 1, min(ki,c_help_size(2,n_p))
kjj = (kj-1)*n_size+n_p+1 ! #row of the element in mat1
IF (n_rank-1 < n_p) THEN
c_help(ki,kj) = mat1%data_c(kjj,ki+1)
ELSE
c_help(ki,kj) = mat1%data_c(kjj,ki)
ENDIF
ENDDO
ENDDO
DO ki = 1, c_help_size(1,n_p)
DO kj = 1, min(ki,c_help_size(2,n_p))
kjj = (kj-1)*n_size+n_p+1 ! #row of the element in mat1
IF (n_rank-1 < n_p) THEN
c_help(ki,kj) = mat1%data_c(kjj,ki+1)
ELSE
c_help(ki,kj) = mat1%data_c(kjj,ki)
ENDIF
ENDDO
ENDDO
n_help = 0
DO kj = 1,c_help_size(2,n_p)
DO ki = kj ,c_help_size(1,n_p)
n_help = n_help + 1
cs_el(n_help,n_p) = CONJG(c_help(ki,kj))
ENDDO
ENDDO
IF ( n_help .NE. n_send(n_p)) CALL juDFT_error("Number of elements to send is wrong",calledby ="mingeselle")
n_help = 0
DO kj = 1,c_help_size(2,n_p)
DO ki = kj ,c_help_size(1,n_p)
n_help = n_help + 1
cs_el(n_help,n_p) = CONJG(c_help(ki,kj))
ENDDO
ENDDO
IF ( n_help .NE. n_send(n_p)) CALL juDFT_error("Number of elements to send is wrong",calledby ="mingeselle")
ENDDO
DEALLOCATE ( c_help )
ENDDO
DEALLOCATE ( c_help )
! now we look where to put in the received elements
! now we look where to put in the received elements
n_recv = 0
DO ki = 1, mat%matsize2
kjj = n_rank + 1 + (ki-1)*n_size ! global column index
DO kj = kjj+1, mat%matsize1
n_p = MOD(kj-1,n_size)
n_recv(n_p) = n_recv(n_p) + 1
in_pos(1,n_recv(n_p),n_p) = kj
in_pos(2,n_recv(n_p),n_p) = ki
ENDDO
ENDDO
DO n_p = 0,n_size-1
IF (n_recv(n_p)/=n_r(n_p)) CALL juDFT_error("n_recv.NE.n_s" ,calledby ="mingeselle")
ENDDO
n_recv = 0
DO ki = 1, mat%matsize2
kjj = n_rank + 1 + (ki-1)*n_size ! global column index
DO kj = kjj+1, mat%matsize1
n_p = MOD(kj-1,n_size)
n_recv(n_p) = n_recv(n_p) + 1
in_pos(1,n_recv(n_p),n_p) = kj
in_pos(2,n_recv(n_p),n_p) = ki
ENDDO
ENDDO
DO n_p = 0,n_size-1
IF (n_recv(n_p)/=n_r(n_p)) CALL juDFT_error("n_recv.NE.n_s" ,calledby ="mingeselle")
ENDDO
! Mandaliet, mandaliet, min geselle kumme niet
! Mandaliet, mandaliet, min geselle kumme niet
ifront = ibefore(n_size,n_rank)
inext = iafter (n_size,n_rank)
DO n_p = 0,n_size-1
ifront = ibefore(n_size,n_rank)
inext = iafter (n_size,n_rank)
DO n_p = 0,n_size-1
! determine pe's to send to and to receive from
! determine pe's to send to and to receive from
np_s = MOD(inext +n_p,n_size)
np_r = MOD(ifront-n_p,n_size)
IF (np_r.LT.0) np_r = np_r + n_size
np_s = MOD(inext +n_p,n_size)
np_r = MOD(ifront-n_p,n_size)
IF (np_r.LT.0) np_r = np_r + n_size
! send section: local rows i with mod(i-1,np) = np_s will be sent to proc np_s
! send section: local rows i with mod(i-1,np) = np_s will be sent to proc np_s
IF (np_s.NE.n_rank) THEN
CALL MPI_ISEND(cs_el(1,np_s),n_send(np_s), CPP_MPI_COMPLEX,&
np_s,n_rank,SUB_COMM,req_s,ierr)
ENDIF
IF (np_s.NE.n_rank) THEN
CALL MPI_ISEND(cs_el(1,np_s),n_send(np_s), CPP_MPI_COMPLEX,&
np_s,n_rank,SUB_COMM,req_s,ierr)
ENDIF
! receive section : local rows i with mod(i-1,np) = np_r will be received from np_r
! ... skipped, if update matrix from local data:
! receive section : local rows i with mod(i-1,np) = np_r will be received from np_r
! ... skipped, if update matrix from local data:
IF (np_r.NE.n_rank) THEN
CALL MPI_IRECV(cr_el,n_recv(np_r),CPP_MPI_COMPLEX, MPI_ANY_SOURCE,np_r,SUB_COMM,req_r,ierr)
CALL MPI_WAIT(req_s,stt,ierr)
CALL MPI_WAIT(req_r,stt,ierr)
DO ki = 1,n_recv(np_r)
mat%data_c(in_pos(1,ki,np_r),in_pos(2,ki,np_r)) = cr_el(ki)
IF (np_r.NE.n_rank) THEN
CALL MPI_IRECV(cr_el,n_recv(np_r),CPP_MPI_COMPLEX, MPI_ANY_SOURCE,np_r,SUB_COMM,req_r,ierr)
CALL MPI_WAIT(req_s,stt,ierr)
CALL MPI_WAIT(req_r,stt,ierr)
DO ki = 1,n_recv(np_r)
mat%data_c(in_pos(1,ki,np_r),in_pos(2,ki,np_r)) = cr_el(ki)
ENDDO
ELSE
DO ki = 1,n_recv(np_r)
mat%data_c(in_pos(1,ki,np_r),in_pos(2,ki,np_r)) = cs_el(ki,np_s)
ENDDO
ENDIF
ENDDO
ELSE
DO ki = 1,n_recv(np_r)
mat%data_c(in_pos(1,ki,np_r),in_pos(2,ki,np_r)) = cs_el(ki,np_s)
ENDDO
ENDIF
ENDDO
DEALLOCATE (cs_el,cr_el,in_pos)
DEALLOCATE (cs_el,cr_el,in_pos)
CLASS DEFAULT
call judft_error("Wrong type (1) in mingeselle")
END SELECT
CLASS DEFAULT
call judft_error("Wrong type (2) in mingeselle")
END SELECT
#endif
END SUBROUTINE mingeselle
!
!-------------------------------------------------------------
......
......@@ -80,7 +80,7 @@ CONTAINS
CLASS(t_xcpot_libxc), INTENT(INOUT) :: xcpot
INTEGER, INTENT(IN) :: jspins, func_vxc_id_x, func_vxc_id_c, func_exc_id_x, func_exc_id_c
LOGICAL :: same_functionals ! are vxc and exc equal
!INTEGER :: errors(4)
INTEGER :: errors(4)
#ifdef CPP_LIBXC
errors = -1
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment