Add error handler to windows

hybrid/calc_hybrid.F90

@@ -49,7 +49,7 @@ CONTAINS
       INTEGER, ALLOCATABLE :: my_k_list(:), k_owner(:)
 
       CALL timestart("hybrid code")
-      call sync_eig(eig_id)
+      call sync_eig(eig_id, fi)
 
       call hybmpi%copy_mpi(mpi)
       call split_k_to_comm(fi, hybmpi, my_k_list, k_owner)
@@ -139,7 +139,7 @@ CONTAINS
       call timestop("Hybrid imbalance")
 #endif
 
-      call sync_eig(eig_id)
+      call sync_eig(eig_id, fi)
       CALL timestop("hybrid code")
    CONTAINS
       subroutine first_iteration_alloc(fi, hybdat)

io/eig66_mpi.F90

@@ -81,6 +81,7 @@ CONTAINS
       CALL timestop("create data spaces in ei66_mpi")
    CONTAINS
       SUBROUTINE priv_create_memory(slot_size, local_slots, handle, int_data_ptr, real_data_ptr, cmplx_data_ptr)
+         use m_types_mpi, only: judft_win_create
          IMPLICIT NONE
          INTEGER, INTENT(IN)           :: slot_size, local_slots
          INTEGER, POINTER, OPTIONAL, ASYNCHRONOUS  :: int_data_ptr(:)
@@ -120,24 +121,21 @@ CONTAINS
 #else
             ALLOCATE (real_data_ptr(length))
 #endif
-            CALL MPI_WIN_CREATE(real_data_ptr, length*type_size, slot_size*type_size, Mpi_INFO_NULL, MPI_COMM, handle, e)
-            if(e /= 0) call judft_error("Can't create MPI_Win for real_data_ptr")
+            call judft_win_create(real_data_ptr, length*type_size, slot_size*type_size, Mpi_INFO_NULL, MPI_COMM, handle)
          ELSEIF (PRESENT(int_data_ptr)) THEN
 #ifdef CPP_MPI_ALLOC
             CALL C_F_POINTER(ptr, int_data_ptr, (/length/type_size/))
 #else
             ALLOCATE (int_data_ptr(length))
 #endif
-            CALL MPI_WIN_CREATE(int_data_ptr, length*type_size, slot_size*type_size, Mpi_INFO_NULL, MPI_COMM, handle, e)
-            if(e /= 0) call judft_error("Can't create MPI_Win for int_data_ptr")
+            call judft_win_create(int_data_ptr, length*type_size, slot_size*type_size, Mpi_INFO_NULL, MPI_COMM, handle)
          ELSE
 #ifdef CPP_MPI_ALLOC
             CALL C_F_POINTER(ptr, cmplx_data_ptr, (/length/type_size/))
 #else
             ALLOCATE (cmplx_data_ptr(length))
 #endif
-            CALL MPI_WIN_CREATE(cmplx_data_ptr, length*type_size, slot_size*type_size, Mpi_INFO_NULL, MPI_COMM, handle, e)
-            if(e /= 0) call judft_error("Can't create MPI_Win for cmplx_data_ptr")
+            call judft_win_create(cmplx_data_ptr, length*type_size, slot_size*type_size, Mpi_INFO_NULL, MPI_COMM, handle)
          ENDIF
 #endif
       END SUBROUTINE priv_create_memory
@@ -285,26 +283,36 @@ CONTAINS
 #endif
    END SUBROUTINE read_eig
 
-   SUBROUTINE sync_eig(id)
+   SUBROUTINE sync_eig(id, fi)
       use m_judft
 #ifdef CPP_MPI 
       use mpi 
 #endif
+      type(t_fleurinput) :: fi
       INTEGER, INTENT(IN)    :: id
 
+      logical                                 :: l_real, l_soc
       TYPE(t_data_MPI), POINTER, ASYNCHRONOUS :: d
       INTEGER:: err
 #if defined(CPP_MPI3) && defined(CPP_MPI)
       CALL priv_find_data(id, d)
 
+      l_real=fi%sym%invs.AND..NOT.fi%noco%l_noco.AND..NOT.(fi%noco%l_soc.AND.fi%atoms%n_u+fi%atoms%n_hia>0)
+      l_soc =fi%noco%l_soc
+
       IF (d%read_epoch) THEN
          d%read_epoch = .FALSE.
          CALL MPI_Win_fence(MPI_MODE_NOSTORE, d%eig_handle, err)
          if(err /= 0) call juDFT_error("MPI_Win_fence isn't happy. No. 1")
-         CALL MPI_Win_fence(MPI_MODE_NOSTORE, d%zr_handle, err)
-         if(err /= 0) call juDFT_error("MPI_Win_fence isn't happy. No. 2")
-         CALL MPI_Win_fence(MPI_MODE_NOSTORE, d%zc_handle, err)
-         if(err /= 0) call juDFT_error("MPI_Win_fence isn't happy. No. 3")
+
+         IF (l_real .AND. .NOT. l_soc) THEN
+            CALL MPI_Win_fence(MPI_MODE_NOSTORE, d%zr_handle, err)
+            if(err /= 0) call juDFT_error("MPI_Win_fence isn't happy. No. 2")
+         ELSE
+            CALL MPI_Win_fence(MPI_MODE_NOSTORE, d%zc_handle, err)
+            if(err /= 0) call juDFT_error("MPI_Win_fence isn't happy. No. 3")
+         ENDIF
+
          CALL MPI_Win_fence(MPI_MODE_NOSTORE, d%neig_handle, err)
          if(err /= 0) call juDFT_error("MPI_Win_fence isn't happy. No. 4")
          CALL MPI_Win_fence(MPI_MODE_NOSTORE, d%w_iks_handle, err)
@@ -313,10 +321,13 @@ CONTAINS
          d%read_epoch = .TRUE.
          CALL MPI_Win_fence(MPI_MODE_NOPUT, d%eig_handle, err)
          if(err /= 0) call juDFT_error("MPI_Win_fence isn't happy. No. 6")
-         CALL MPI_Win_fence(MPI_MODE_NOPUT, d%zr_handle, err)
-         if(err /= 0) call juDFT_error("MPI_Win_fence isn't happy. No. 7")
-         CALL MPI_Win_fence(MPI_MODE_NOPUT, d%zc_handle, err)
-         if(err /= 0) call juDFT_error("MPI_Win_fence isn't happy. No. 8")
+         IF (l_real .AND. .NOT. l_soc) THEN
+            CALL MPI_Win_fence(MPI_MODE_NOPUT, d%zr_handle, err)
+            if(err /= 0) call juDFT_error("MPI_Win_fence isn't happy. No. 7")
+         ELSE
+            CALL MPI_Win_fence(MPI_MODE_NOPUT, d%zc_handle, err)
+            if(err /= 0) call juDFT_error("MPI_Win_fence isn't happy. No. 8")
+         ENDIF
          CALL MPI_Win_fence(MPI_MODE_NOPUT, d%neig_handle, err)
          if(err /= 0) call juDFT_error("MPI_Win_fence isn't happy. No. 9")
          CALL MPI_Win_fence(MPI_MODE_NOPUT, d%w_iks_handle, err)

types/types_mpi.F90

@@ -21,6 +21,13 @@ MODULE m_types_mpi
       procedure :: set_errhandler    => t_mpi_set_errhandler
       procedure :: is_root => mpi_is_root
    END TYPE t_mpi
+
+   INTERFACE juDFT_win_create
+      MODULE PROCEDURE  juDFT_win_create_real, juDFT_win_create_cmplx, juDFT_win_create_int
+   END INTERFACE juDFT_win_create
+
+   PRIVATE
+   PUBLIC :: juDFT_win_create, t_mpi
 contains
    function mpi_is_root(mpi) result(is_root)
       implicit none 
@@ -29,6 +36,81 @@ contains
       is_root = mpi%irank == 0
    end function mpi_is_root
 
+   subroutine juDFT_win_create_real(base, size, disp_unit, info, comm, win)
+      use m_judft
+#ifdef CPP_MPI
+      use mpi
+#endif
+      implicit none 
+      real, POINTER, ASYNCHRONOUS, intent(inout) :: base(:)
+      integer, intent(in)      :: disp_unit, info, comm
+      integer, intent(inout)   :: win
+
+#ifdef CPP_MPI
+      INTEGER(KIND=MPI_ADDRESS_KIND) :: SIZE 
+      integer                  :: err, err_handler
+
+      CALL MPI_WIN_CREATE(base, size, disp_unit, info, comm, win, err)
+      if(err /= 0) call judft_error("Can't create MPI_Win for real_data_ptr")
+
+      call MPI_Win_create_errhandler(judft_mpi_error_handler, err_handler, err)
+      if(err /= 0) call judft_error("Can't create Error handler")
+
+      CALL MPI_WIN_SET_ERRHANDLER(win, err_handler, err)
+      if(err /= 0) call judft_error("Can't assign Error handler to Win")
+#endif
+   end subroutine juDFT_win_create_real
+
+   subroutine juDFT_win_create_cmplx(base, size, disp_unit, info, comm, win)
+      use m_judft
+#ifdef CPP_MPI
+      use mpi
+#endif
+      implicit none 
+      complex, POINTER, ASYNCHRONOUS, intent(inout):: base(:)
+      integer, intent(in)      :: disp_unit, info, comm
+      integer, intent(inout)   :: win
+
+#ifdef CPP_MPI
+      INTEGER(KIND=MPI_ADDRESS_KIND) :: SIZE 
+      integer                  :: err, err_handler
+
+      CALL MPI_WIN_CREATE(base, size, disp_unit, info, comm, win, err)
+      if(err /= 0) call judft_error("Can't create MPI_Win for cmplx_data_ptr")
+
+      call MPI_Win_create_errhandler(judft_mpi_error_handler, err_handler, err)
+      if(err /= 0) call judft_error("Can't create Error handler")
+
+      CALL MPI_WIN_SET_ERRHANDLER(win, err_handler, err)
+      if(err /= 0) call judft_error("Can't assign Error handler to Win")
+#endif
+   end subroutine juDFT_win_create_cmplx
+
+   subroutine juDFT_win_create_int(base, size, disp_unit, info, comm, win)
+      use m_judft
+#ifdef CPP_MPI
+      use mpi
+#endif
+      implicit none 
+      integer, POINTER, ASYNCHRONOUS, intent(inout) :: base(:)
+      integer, intent(in)      :: disp_unit, info, comm
+      integer, intent(inout)   :: win
+
+#ifdef CPP_MPI
+      INTEGER(KIND=MPI_ADDRESS_KIND) :: SIZE 
+      integer                  :: err, err_handler
+
+      CALL MPI_WIN_CREATE(base, size, disp_unit, info, comm, win, err)
+      if(err /= 0) call judft_error("Can't create MPI_Win for cmplx_data_ptr")
+
+      call MPI_Win_create_errhandler(judft_mpi_error_handler, err_handler, err)
+      if(err /= 0) call judft_error("Can't create Error handler")
+
+      CALL MPI_WIN_SET_ERRHANDLER(win, err_handler, err)
+      if(err /= 0) call judft_error("Can't assign Error handler to Win")
+#endif
+   end subroutine juDFT_win_create_int
+
    subroutine t_mpi_set_errhandler(self)
       use m_judft
 #ifdef CPP_MPI
@@ -55,10 +137,19 @@ contains
    end subroutine t_mpi_set_errhandler
 
    subroutine judft_mpi_error_handler(comm, error_code) 
+#ifdef CPP_MPI
+      use mpi
+#endif
       use m_judft
       implicit none 
       integer, intent(in) :: comm, error_code 
+      integer             :: str_len, ierr
+      character(len=3000) :: error_str
 
-      call judft_error("MPI failed with Error_code = " // int2str(error_code))
+#ifdef CPP_MPI  
+      call MPI_ERROR_STRING(error_code, error_str, str_len, ierr)
+      call judft_error("MPI failed with Error_code = " // int2str(error_code) // new_line("A") // &
+                       error_str(1:str_len))
+#endif
    end subroutine judft_mpi_error_handler
 END MODULE m_types_mpi