      module parallel

      use, INTRINSIC ::ISO_C_BINDING

      implicit none

      include 'mpif.h'

      !---  Parameters (They should not be changed ! )
      integer, parameter   :: mpmd_master = 0  ! - precise got the first procs
      integer, parameter   :: color       = 0  ! - LPT (0) Precise (1)
      integer, parameter   :: whoisroot   = 0  ! - Root always 0 here
      !---  General parallel
      integer              :: whoami                 ! - My rank
      integer              :: mpi_nproc              ! - no. of procs
      integer              :: mpierr                 ! - Error status
      integer              :: status(MPI_STATUS_SIZE)! - For MPI_RECV
      !---  Shared memory stuff
      integer              :: whoami_shm             ! - Local rank in shared memory group
      integer              :: mpi_shm_nproc          ! - No. of procs in Shared memory group
      integer              :: no_partners            ! - No. of partners for share memory
      integer              :: info_alloc             ! - (Non)contiguous processor partitioning
                                                     !   (The no. of processors from precise I need to share memory with)
      integer, allocatable :: partners(:)            ! - Rank no. of partners
      integer, allocatable :: partners_map(:)        ! - Global Partner rank no. (used in multi-node parallelisation)
      integer, allocatable :: this_shm_ranks(:)
      !---  MPI groups
      integer              :: world_group            ! - All procs accross all nodes
      integer              :: shared_group           ! - Only procs that share memory
      !---  MPI communicators
      integer              :: MPI_COMM_LPT           ! - The internal communicator (all processors in LPT)
      integer              :: MPI_COMM_SHM           ! - Shared memory communicators (for those in shared_group)
      integer              :: MPI_COMM_COUPLING       ! - Explicit communication line with Precise (Used for getting inputs etc)

      !---  Kind
      integer              :: MPI_REAL_LPT
      integer              :: MPI_INTEGER_LPT


      !---  SEND/RECV TAGS
      integer, parameter   :: stag_int_shm = 10000
      integer, parameter   :: rtag_int_shm = 10001

      !---  flags
      logical              :: contig_part = .false.

      interface CREATE_SHM_WIN
         module procedure CREATE_SHM_INT_WIN
         module procedure CREATE_SHM_REAL_WIN
      end interface


      interface QUERY_PARTNER_WIN
         module procedure QUERY_PARTNER_INT_WIN
         module procedure QUERY_PARTNER_FLT_WIN
      end interface


      type F_PTR_INT
         integer, pointer :: recvbuf(:)
      end type F_PTR_INT

      type F_PTR_FLT
         real, pointer    :: recvbuf(:)
      end type F_PTR_FLT

      CONTAINS

      subroutine PARALLEL_INIT

      implicit none

      integer              :: master_node

      call MPI_INIT        ( mpierr )
      call MPI_COMM_RANK   ( MPI_COMM_WORLD, whoami, mpierr )
      call MPI_COMM_SPLIT  ( MPI_COMM_WORLD, color, whoami
     &                     , MPI_COMM_LPT, mpierr )

      call MPI_COMM_RANK   ( MPI_COMM_LPT, whoami, mpierr )
      call MPI_COMM_SIZE   ( MPI_COMM_LPT, mpi_nproc, mpierr)


      if( mpmd_master == 1 )then
         master_node = mpi_nproc
      elseif( mpmd_master == 0 )then
         master_node = 0
      else
      !         call ERROR_MSG( __FILE__, __LINE__
      !     &                 , 'I am not supposed to happen' )
      endif

      call MPI_INTERCOMM_CREATE  ( MPI_COMM_LPT
     &                           , 0
     &                           , MPI_COMM_WORLD
     &                           , master_node
     &                           , 0
     &                           , MPI_COMM_COUPLING
     &                           , mpierr )

      call MPI_BARRIER           ( MPI_COMM_COUPLING, mpierr )


      call DEFINE_MPI_TYPES


      end subroutine PARALLEL_INIT

      subroutine CREATE_SHM_REAL_WIN( fptr, win, size_ )

      implicit none
      integer, intent(in)                         :: size_
      integer, intent(out)                        :: win
      real, pointer, asynchronous, intent(out)    :: fptr(:)
      type(C_PTR)                                 :: ptr_buf
      integer(kind = MPI_ADDRESS_KIND)    :: size_bytes, lb, disp_unit

      size_bytes = size_ * MPI_REAL_LPT
      disp_unit  = MPI_REAL_LPT
      size_bytes = size_*disp_unit

      call MPI_WIN_ALLOCATE_SHARED( size_bytes
     &                            , disp_unit
     &                            , info_alloc
     &                            , MPI_COMM_SHM
     &                            , ptr_buf
     &                            , win
     &                            , mpierr )

      call C_F_POINTER(ptr_buf, fptr, (/size_/) )


      end subroutine CREATE_SHM_REAL_WIN



      subroutine CREATE_SHM_INT_WIN( fptr, win, size_ )

      implicit none
      integer, intent(in)                         :: size_
      integer, intent(out)                        :: win
      integer, pointer, asynchronous, intent(out) :: fptr(:)
      type(C_PTR)                   :: ptr_buf
      integer(KIND=MPI_ADDRESS_KIND) :: size_bytes, lb, disp_unit

      call MPI_TYPE_GET_EXTENT( MPI_INTEGER_LPT, lb, disp_unit, mpierr )

      size_bytes = size_*disp_unit

      call MPI_WIN_ALLOCATE_SHARED( size_bytes
     &                            , disp_unit
     &                            , info_alloc
     &                            , MPI_COMM_SHM
     &                            , ptr_buf
     &                            , win
     &                            , mpierr )

      call C_F_POINTER(ptr_buf, fptr, (/size_/) )


      end subroutine CREATE_SHM_INT_WIN

      subroutine QUERY_PARTNER_INT_WIN( fptr, win, size_ )

      implicit none

      integer, intent(in)                         :: win
      integer, intent(in)                         :: size_
      type(F_PTR_INT), allocatable
     &               , asynchronous, intent(out)  :: fptr(:)
      integer                                     :: partner, i
      integer(KIND=MPI_ADDRESS_KIND)              :: size_bytes, lb
      integer                                     :: disp_unit
      type(C_PTR)                                 :: ptr_buf


      if(.not. allocated(fptr) )allocate(fptr(no_partners))

      size_bytes = size_*MPI_INTEGER_LPT
      disp_unit  = MPI_INTEGER_LPT

      do i = 1, no_partners
         ptr_buf = C_NULL_PTR ! - Defined Fortran variable to nullify c-pointer
         partner = partners(i)
         if(   partner         /= MPI_PROC_NULL
     &   .and. partners_map(i) /= MPI_UNDEFINED )then
            call MPI_WIN_SHARED_QUERY( win
     &                               , partners_map(i)
     &                               , size_bytes
     &                               , disp_unit
     &                               , ptr_buf
     &                               , mpierr )


            call C_F_POINTER( ptr_buf, fptr(i)% recvbuf, (/size_/) )

         endif
      enddo


      end subroutine QUERY_PARTNER_INT_WIN

      subroutine QUERY_PARTNER_FLT_WIN( fptr, win, size_)

      implicit none

      integer, intent(in)                         :: win
      integer, intent(in)                         :: size_
      type(F_PTR_FLT), allocatable
     &               , asynchronous, intent(out)  :: fptr(:)
      integer                                     :: partner, i
      integer(KIND=MPI_ADDRESS_KIND)              :: size_bytes, lb
      integer                                     :: disp_unit
      type(C_PTR)                                 :: ptr_buf


      if(.not. allocated(fptr) )allocate(fptr(no_partners))

      size_bytes = size_*MPI_REAL_LPT
      disp_unit  = MPI_REAL_LPT

      do i = 1, no_partners
         ptr_buf = C_NULL_PTR ! - Defined Fortran variable to nullify c-pointer
         partner = partners(i)
         if(   partner         /= MPI_PROC_NULL
     &   .and. partners_map(i) /= MPI_UNDEFINED )then
            call MPI_WIN_SHARED_QUERY( win
     &                               , partners_map(i)
     &                               , size_bytes
     &                               , disp_unit
     &                               , ptr_buf
     &                               , mpierr )


            call C_F_POINTER( ptr_buf, fptr(i)% recvbuf, (/size_/) )

         endif
      enddo


      end subroutine QUERY_PARTNER_FLT_WIN

      subroutine INIT_MPI_SHM

      implicit none

      integer              :: i, k, buf(2)
      integer, allocatable :: local_rank(:)


      call MPI_COMM_SPLIT_TYPE( MPI_COMM_WORLD
     &                        , MPI_COMM_TYPE_SHARED
     &                        , 0
     &                        , MPI_INFO_NULL
     &                        , MPI_COMM_SHM
     &                        , mpierr )

      call MPI_COMM_RANK( MPI_COMM_SHM, whoami_shm, mpierr )
      call MPI_COMM_SIZE( MPI_COMM_SHM, mpi_shm_nproc, mpierr )




      allocate( local_rank(mpi_nproc))
      allocate( this_shm_ranks(mpi_nproc) )

      local_rank( whoami+1 ) = whoami_shm

      call MPI_ALLREDUCE( local_rank
     &                 ,  this_shm_ranks
     &                 ,  mpi_nproc
     &                 ,  MPI_INTEGER_LPT
     &                 ,  MPI_SUM
     &                 ,  MPI_COMM_LPT
     &                 ,  mpierr )


      if(whoami == whoisroot )call MPI_SEND( mpi_nproc
     &                                     , 1
     &                                     , MPI_INTEGER_LPT
     &                                     , 0
     &                                     , stag_int_shm
     &                                     , MPI_COMM_COUPLING
     &                                     , mpierr )

      if(whoami == whoisroot )call MPI_RECV( no_partners
     &                                     , 1
     &                                     , MPI_INTEGER_LPT
     &                                     , 0
     &                                     , rtag_int_shm
     &                                     , MPI_COMM_COUPLING
     &                                     , status
     &                                     , mpierr )





      call MPI_BCAST( no_partners
     &              , 1
     &              , MPI_INTEGER_LPT
     &              , whoisroot
     &              , MPI_COMM_LPT
     &              , mpierr)

      allocate(partners(no_partners), partners_map(no_partners))

      k = 0
      do i = 0, mpi_shm_nproc - 1
         if( ANY(this_shm_ranks == i) )CYCLE
         k = k + 1
         partners(k) = i
      enddo

      call MPI_COMM_GROUP( MPI_COMM_WORLD, world_group, mpierr )
      call MPI_COMM_GROUP( MPI_COMM_SHM, shared_group, mpierr )

      ! - this call is redundant when for single computer node !
      !---  It is mapping for nodes <--> processors ranks
      call MPI_GROUP_TRANSLATE_RANKS( world_group
     &                              , no_partners
     &                              , partners
     &                              , shared_group
     &                              , partners_map
     &                              , mpierr )

      if( contig_part == .false. )then
         call MPI_INFO_CREATE( info_alloc, mpierr )
         call MPI_INFO_SET( info_alloc
     &                    , "alloc_shared_noncontig"
     &                    , "true"
     &                    , mpierr )
      else
         info_alloc = MPI_INFO_NULL
      endif

      end subroutine INIT_MPI_SHM



      subroutine DEFINE_MPI_TYPES

      implicit none

      real                             :: dummy_real
      integer                          :: dummy_integer
      integer( kind=MPI_ADDRESS_KIND ) :: lb

      dummy_real    = 0.
      dummy_integer = 1

      !---   Determine the kind of real
      if(KIND( dummy_real ) .eq. 4 )MPI_REAL_LPT = MPI_REAL4

      if(KIND( dummy_real ) .eq. 8 )MPI_REAL_LPT = MPI_REAL8

!---  Determine the kind of integer
      if(KIND( dummy_integer ) .eq. 4 )MPI_INTEGER_LPT = MPI_INTEGER4

      if(KIND( dummy_integer ) .eq. 8 )MPI_INTEGER_LPT = MPI_INTEGER8


      end subroutine DEFINE_MPI_TYPES

      subroutine MEASURE_LATENCY (  tend , fptr )

      implicit none

      double precision, intent(out) :: tend
      character, pointer, asynchronous, intent(inout) :: fptr(:)
      double precision              :: t1, t2
      character(len=1)              :: x
      integer                       :: win, i, no_of_msg
      type(C_PTR)                   :: ptr_buf
      integer(kind = MPI_ADDRESS_KIND)    :: size_bytes
      character ::

      tend       = 0.
      size_bytes = 1

      if(whoami == whoisroot )call MPI_RECV( no_of_msg
     &                                     , 1
     &                                     , MPI_INTEGER_LPT
     &                                     , 0
     &                                     , rtag_int_shm
     &                                     , MPI_COMM_COUPLING
     &                                     , status
     &                                     , mpierr )



      call MPI_WIN_ALLOCATE_SHARED( size_bytes
     &                            , size_bytes
     &                            , info_alloc
     &                            , MPI_COMM_SHM
     &                            , ptr_buf
     &                            , win
     &                            , mpierr )


      call C_F_POINTER(ptr_buf, fptr, (/1/) )

      do i = 1, no_of_msg
         t1 = MPI_WTIME()
         call MPI_BARRIER( mpi_comm_shm, mpierr)
         t2   = MPI_WTIME()
         tend = tend + t2-t1
         x = fptr(1)% recvbuf
      enddo

      call MPI_WIN_FREE( win, mpierr )
      print*, "TOTAL", tend*10e6

      tend =  tend / no_of_msg

      end subroutine MEASURE_LATENCY

      end module

      program TEST_MPISHM2

      use parallel

      implicit none

      integer                        :: win_int, size_intwindow
      integer                        :: win_flt, size_fltwindow
      integer, pointer, asynchronous :: share_int(:)!, ptr_rma_int(:)
      real, pointer, asynchronous    :: share_flt(:)!, ptr_rma_flt(:)

      type(F_PTR_INT),
     &   asynchronous, allocatable   :: rma_int(:)
      type(F_PTR_FLT),
     &   asynchronous, allocatable   :: rma_flt(:)


      integer                        :: size_share_int, size_rma_int
      integer                        :: size_share_flt, size_rma_flt

      integer, allocatable           :: work_array1(:)
      integer, allocatable           :: work_array2(:)

      real, allocatable              :: work1(:),work2(:),work3(:)
      real, allocatable              :: work4(:), work5(:)

      integer                        :: i, ncell
      real                           :: rr
      double precision               :: tend
      character, pointer, asynchronous :: fptr(:)

      call PARALLEL_INIT


!      ncell = 10
!
!      size_intwindow = 10
!      size_rma_int   = 20
!      size_share_int = 10
!
!      size_share_flt = ncell*5
!      size_fltwindow = ncell*5
!      size_rma_flt   = ncell*3
!
!      allocate(work_array1(size_share_int), work_array2(size_rma_int))
!      allocate(work1(size_share_flt), work2(size_share_flt))
!      allocate(work3(size_share_flt), work4(size_share_flt))
!      allocate(work5(size_share_flt))
!
!      do i = 1, size_share_int
!         work_array1(i) = i
!      enddo
!
!      do i = 1, size_share_flt
!         call RANDOM_NUMBER(rr)
!         work1(i) = rr
!         call RANDOM_NUMBER(rr)
!         work2(i) = rr
!         call RANDOM_NUMBER(rr)
!         work3(i) = rr
!         call RANDOM_NUMBER(rr)
!         work4(i) = rr
!         call RANDOM_NUMBER(rr)
!         work5(i) = rr
!      enddo

      call INIT_MPI_SHM

      call MEASURE_LATENCY( tend, fptr)
      print*, tend*10e6, "FF"

!      call CREATE_SHM_WIN( share_flt, win_flt, size_fltwindow )
!
!
!
!
!      call QUERY_PARTNER_WIN ( rma_flt, win_flt, size_rma_flt)
!   !   call MPI_WIN_lock_all (MPI_MODE_NOCHECK, win_flt, mpierr )
!
!
!
!
!
!      call MPI_BARRIER( mpi_comm_shm, mpierr)


   !   call MPI_Win_unlock_all ( win_flt, mpierr)

!      print*, sum(rma_flt(1)% recvbuf), "FROM 2 "


!      call MPI_WIN_FREE(win_flt, mpierr)

      call MPI_COMM_FREE         ( mpi_comm_lpt, mpierr )
      call MPI_COMM_FREE         ( mpi_comm_shm, mpierr )
      call MPI_COMM_FREE         ( MPI_COMM_COUPLING, mpierr )

      call MPI_FINALIZE          ( mpierr )




      end program TEST_MPISHM2
