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

external/chase/src/FLEUR/fleur_chase.cpp

@@ -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,

types/types_mpimat.F90

@@ -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)