Commit 1a4d83eb authored by Daniel Wortmann's avatar Daniel Wortmann

Changes to chase-MPI interface. Still not functional...

parent 6f927e33
This diff is collapsed.
......@@ -23,8 +23,10 @@ using namespace chase::mpi;
class ChASE_State {
public:
template <typename T>
static ChaseMpiProperties<T>* constructProperties(std::size_t N, std::size_t nev,
std::size_t nex, MPI_Comm comm);
static ChaseMpiProperties<T>* constructProperties(std::size_t N,
std::size_t nev,
std::size_t nex,
MPI_Comm comm);
template <typename T>
static ChaseMpiProperties<T>* getProperties();
......@@ -37,7 +39,7 @@ ChaseMpiProperties<std::complex<double>>* ChASE_State::complex_double_prec =
nullptr;
template <>
ChaseMpiProperties<double>* ChASE_State::constructProperties(std::size_t N,
ChaseMpiProperties<double>* ChASE_State::constructProperties(std::size_t N,
std::size_t nev,
std::size_t nex,
MPI_Comm comm) {
......@@ -88,10 +90,21 @@ void call_chase(T* H, int* N, T* V, Base<T>* ritzv, int* nev, int* nex,
template <typename T>
void chase_setup(MPI_Fint* fcomm, int* N, int* nev, int* nex, std::size_t* xoff,
std::size_t* yoff, std::size_t* xlen, std::size_t* ylen) {
std::size_t* yoff, std::size_t* xlen, std::size_t* ylen,
std::size_t* dimx, std::size_t* dimy, std::size_t* myx,
std::size_t* myy) {
std::size_t xoff_, yoff_, xlen_, ylen_;
MPI_Comm comm = MPI_Comm_f2c(*fcomm);
auto props = ChASE_State::constructProperties<T>(*N, *nev, *nex, comm);
props->get_off(xoff, yoff, xlen, ylen);
auto dims = props->get_dims();
*dimx = dims[0];
*dimy = dims[1];
auto coord = props->get_coord();
*myx = coord[0];
*myy = coord[1];
}
template <typename T>
......@@ -143,28 +156,39 @@ void dchase_(double* H, int* N, double* V, double* ritzv, int* nev, int* nex,
}
void zchase_init(MPI_Fint* fcomm, int* N, int* nev, int* nex, int* xoff,
int* yoff, int* xlen, int* ylen) {
std::size_t xoff_, yoff_, xlen_, ylen_;
int* yoff, int* xlen, int* ylen, int* dimx, int* dimy,
int* myx, int* myy) {
std::size_t xoff_, yoff_, xlen_, ylen_, dimx_, dimy_, myx_, myy_;
chase_setup<std::complex<double>>(fcomm, N, nev, nex, &xoff_, &yoff_, &xlen_,
&ylen_);
&ylen_, &dimx_, &dimy_, &myx_, &myy_);
*xoff = static_cast<int>(xoff_);
*yoff = static_cast<int>(yoff_);
*xlen = static_cast<int>(xlen_);
*ylen = static_cast<int>(xlen_);
*ylen = static_cast<int>(ylen_);
*dimx = static_cast<int>(dimx_);
*dimy = static_cast<int>(dimy_);
*myx = static_cast<int>(myx_);
*myy = static_cast<int>(myy_);
}
void dchase_init(MPI_Fint* fcomm, int* N, int* nev, int* nex, int* xoff,
int* yoff, int* xlen, int* ylen) {
std::size_t xoff_, yoff_, xlen_, ylen_;
int* yoff, int* xlen, int* ylen, int* dimx, int* dimy,
int* myx, int* myy) {
std::size_t xoff_, yoff_, xlen_, ylen_, dimx_, dimy_, myx_, myy_;
chase_setup<double>(fcomm, N, nev, nex, &xoff_, &yoff_, &xlen_, &ylen_);
chase_setup<double>(fcomm, N, nev, nex, &xoff_, &yoff_, &xlen_, &ylen_,
&dimx_, &dimy_, &myx_, &myy_);
*xoff = static_cast<int>(xoff_);
*yoff = static_cast<int>(yoff_);
*xlen = static_cast<int>(xlen_);
*ylen = static_cast<int>(xlen_);
*ylen = static_cast<int>(ylen_);
*dimx = static_cast<int>(dimx_);
*dimy = static_cast<int>(dimy_);
*myx = static_cast<int>(myx_);
*myy = static_cast<int>(myy_);
}
void zchase_solve(std::complex<double>* H, std::complex<double>* V,
......
......@@ -7,6 +7,7 @@
MODULE m_types_mpimat
USE m_judft
USE m_types_rcmat
IMPLICIT NONE
PRIVATE
INTEGER,PARAMETER :: DEFAULT_BLOCKSIZE=64
INTEGER, PARAMETER :: dlen_=9
......@@ -29,12 +30,102 @@ MODULE m_types_mpimat
PROCEDURE,PASS :: free => mpimat_free !<overwriten from t_mat, takes care of blacs-grids
PROCEDURE,PASS :: init => mpimat_init !<overwriten from t_mat, also calls alloc in t_mat
PROCEDURE,PASS :: add_transpose => mpimat_add_transpose !<overwriten from t_mat
PROCEDURE,PASS :: generate_full_matrix ! construct full matrix if only upper triangle of hermitian matrix is given
PROCEDURE,PASS :: print_matrix
END TYPE t_mpimat
PUBLIC t_mpimat
CONTAINS
SUBROUTINE print_matrix(mat,fileno)
CLASS(t_mpimat),INTENT(INOUT) ::mat
INTEGER:: fileno
#ifdef CPP_SCALAPACK
INCLUDE 'mpif.h'
INTEGER,EXTERNAL:: indxl2g
CHARACTER(len=10)::filename
INTEGER :: irank,isize,i,j,npr,npc,r,c,tmp,err,status(MPI_STATUS_SIZE)
CALL MPI_COMM_RANK(mat%mpi_com,irank,err)
CALL MPI_COMM_SIZE(mat%mpi_com,isize,err)
tmp=0
IF (irank>0) CALL MPI_RECV(tmp,1,MPI_INTEGER,irank-1,0,mat%mpi_com,status,err) !lock
WRITE(filename,"(a,i0)") "out.",fileno
OPEN(fileno,file=filename,access='append')
CALL blacs_gridinfo(mat%blacs_desc(2),npr,npc,r,c)
DO i=1,mat%matsize1
DO j=1,mat%matsize2
IF (mat%l_real) THEN
WRITE(fileno,"(5(i0,1x),2(f10.5,1x))") irank,i,j,indxl2g(i,mat%blacs_desc(5),r,0,npr),&
indxl2g(j,mat%blacs_desc(6),c,0,npc),mat%data_r(i,j)
ELSE
WRITE(fileno,"(5(i0,1x),2(f10.5,1x))") irank,i,j,indxl2g(i,mat%blacs_desc(5),r,0,npr),&
indxl2g(j,mat%blacs_desc(6),c,0,npc),mat%data_c(i,j)
END IF
ENDDO
ENDDO
CLOSE(fileno)
IF (irank+1<isize) CALL MPI_SEND(tmp,1,MPI_INTEGER,irank+1,0,mat%mpi_com,err)
#endif
END SUBROUTINE print_matrix
SUBROUTINE generate_full_matrix(mat)
CLASS(t_mpimat),INTENT(INOUT) ::mat
INTEGER :: i,n_col,n_row,myid,err,myrow,mycol,np
COMPLEX,ALLOCATABLE:: tmp_c(:,:)
REAL,ALLOCATABLE :: tmp_r(:,:)
#ifdef CPP_SCALAPACK
INCLUDE 'mpif.h'
INTEGER, EXTERNAL :: numroc, indxl2g !SCALAPACK functions
!CALL mat%print_matrix(432)
IF (mat%l_real) THEN
ALLOCATE(tmp_r(mat%matsize1,mat%matsize2))
ELSE
ALLOCATE(tmp_c(mat%matsize1,mat%matsize2))
END IF
CALL MPI_COMM_RANK(mat%mpi_com,myid,err)
CALL MPI_COMM_SIZE(mat%mpi_com,np,err)
myrow = myid/mat%npcol
mycol = myid -(myid/mat%npcol)*mat%npcol
IF (mat%l_real) THEN
CALL pdtran(mat%global_size1,mat%global_size1,1.d0,mat%data_r,1,1,&
mat%blacs_desc,0.d0,tmp_r,1,1,mat%blacs_desc)
ELSE
CALL pztranc(mat%global_size1,mat%global_size1,cmplx(1.0,0.0),mat%data_c,1,1,&
mat%blacs_desc,cmplx(0.d0,0.d0),tmp_c,1,1,mat%blacs_desc)
ENDIF
DO i=1,mat%matsize2
! Get global column corresponding to i and number of local rows up to
! and including the diagonal, these are unchanged in A
n_col = indxl2g(i, mat%blacs_desc(6), mycol, 0, mat%npcol)
n_row = numroc (n_col, mat%blacs_desc(5), myrow, 0, mat%nprow)
IF (mat%l_real) THEN
mat%data_r(n_row+1:,i) = tmp_r(n_row+1:,i)
ELSE
mat%data_c(n_row+1:,i) = tmp_c(n_row+1:,i)
ENDIF
ENDDO
#endif
END SUBROUTINE generate_full_matrix
SUBROUTINE mpimat_add_transpose(mat,mat1)
CLASS(t_mpimat),INTENT(INOUT) ::mat
CLASS(t_mat),INTENT(INOUT) ::mat1
......@@ -127,7 +218,8 @@ CONTAINS
LOGICAL,INTENT(IN),OPTIONAL :: l_real,l_2d
INTEGER,INTENT(IN),OPTIONAL :: nb_y,nb_x
INTEGER::nbx,nby
INTEGER::nbx,nby,irank,ierr
include 'mpif.h'
nbx=DEFAULT_BLOCKSIZE; nby=DEFAULT_BLOCKSIZE
IF (PRESENT(nb_x)) nbx=nb_x
IF (PRESENT(nb_y)) nby=nb_y
......@@ -141,9 +233,14 @@ CONTAINS
mat%matsize1,mat%matsize2,&
mat%npcol,mat%nprow)
CALL mat%alloc(l_real) !Attention,sizes determined in call to priv_create_blacsgrid
!check if this matrix is actually distributed over MPI_COMM_SELF
IF (mpi_subcom==MPI_COMM_SELF) THEN
CALL MPI_COMM_RANK(mpi_subcom,irank,ierr)
IF (irank>0) mat%blacs_desc(2)=-1
END IF
END SUBROUTINE mpimat_init
SUBROUTINE priv_create_blacsgrid(mpi_subcom,l_2d,m1,m2,nbc,nbr,ictextblacs,sc_desc,local_size1,local_size2,npcol,nprow)
SUBROUTINE priv_create_blacsgrid(mpi_subcom,l_2d,m1,m2,nbc,nbr,ictextblacs,sc_desc,local_size1,local_size2,nprow,npcol)
IMPLICIT NONE
INTEGER,INTENT(IN) :: mpi_subcom
INTEGER,INTENT(IN) :: m1,m2
......@@ -165,7 +262,7 @@ CONTAINS
EXTERNAL descinit, blacs_get
EXTERNAL blacs_pinfo, blacs_gridinit
!Determine rank and no of processors
CALL MPI_COMM_RANK(mpi_subcom,myid,ierr)
CALL MPI_COMM_SIZE(mpi_subcom,np,ierr)
......@@ -204,6 +301,7 @@ CONTAINS
myrowssca=(m1-1)/(nbr*nprow)*nbr+ MIN(MAX(m1-(m1-1)/(nbr*nprow)*nbr*nprow-nbr*myrow,0),nbr)
! Number of rows the local process gets in ScaLAPACK distribution
mycolssca=(m2-1)/(nbc*npcol)*nbc+ MIN(MAX(m2-(m2-1)/(nbc*npcol)*nbc*npcol-nbc*mycol,0),nbc)
!Get BLACS ranks for all MPI ranks
CALL BLACS_PINFO(iamblacs,npblacs) ! iamblacs = local process rank (e.g. myid)
......
Markdown is supported
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