! This file is generated by 'scripts/generate.py' using
!    /src/xbeachlibrary/variables.def
!    /src/xbeachlibrary/params.def
!    src/xbeachlibray/templates/genmpi_coll.mako
! Advice: do not edit this file, but above mentioned files.

! to be used in matrix_coll_real8 matrix_coll_integer in file general_mpi.F90
! variables used from these subroutines:
! a, b

subroutine doit_coll(is,lm,js,ln,islowy,ishighy,islowx,ishighx,root,basic_type,comm,w_only)
   implicit none
   integer, intent(in)                  :: is(:),lm(:),js(:),ln(:)
   logical, intent(in), dimension(:)    :: islowy, ishighy, islowx, ishighx
   integer, intent(in)                  :: root,basic_type,comm
   logical, intent(in), optional        :: w_only
!
   integer                              :: sz,ier,ra,i
   integer, allocatable                 :: recvtypes(:), sendtypes(:), recvcounts(:), sendcounts(:)
   integer, allocatable                 :: sdispls(:), rdispls(:)
   integer                              :: sizes(2),subsizes(2),starts(2)
   logical                              :: w
   ! nbord is number of borders.

   integer, parameter                   :: nbord = 2

   w = .false.
   if (present(w_only)) w = w_only

   call MPI_Comm_size(comm, sz, ier)
   call MPI_Comm_rank(comm, ra, ier)

   if (root /= 0) then
      print *,'Error in matrix_distr_real8: root must be 0, but is:',root
      call MPI_Abort(MPI_COMM_WORLD,1,ier)
   endif

   allocate(recvtypes(sz))
   allocate(sendtypes(sz))
   allocate(recvcounts(sz))
   allocate(sendcounts(sz))
   allocate(sdispls(sz))
   allocate(rdispls(sz))

   sdispls    = 0
   rdispls    = 0
   recvtypes  = MPI_CHARACTER
   sendtypes  = MPI_CHARACTER
   recvcounts = 0
   sendcounts = 0

!
! Create MPI types
!

! MPI_TYPE_CREATE_SUBARRAY(NDIMS, ARRAY_OF_SIZES, ARRAY_OF_SUBSIZES,
!   ARRAY_OF_STARTS, ORDER, OLDTYPE, NEWTYPE, IERROR)
!   INTEGER    NDIMS, ARRAY_OF_SIZES(*), ARRAY_OF_SUBSIZES(*),
!   ARRAY_OF_STARTS(*), ORDER, OLDTYPE, NEWTYPE, IERROR

! determine mpi_types for the receive matrices

   if(ra == 0) then
      if (w) then
         ! the root process will receive from itself
         ! and will receive from everybody else
         ! comm is the communicator for the workers
         do i=1,sz
            sizes    = shape(a)
            subsizes = (/ lm(i) - 2*nbord     , ln(i) - 2*nbord     /)
            starts   = (/ is(i) +   nbord - 1 , js(i) +   nbord - 1 /)
            if (islowx(i)) then
               subsizes(1) = subsizes(1) + nbord
               starts(1)   = starts(1)   - nbord
            endif
            if (ishighx(i)) then
               subsizes(1) = subsizes(1) + nbord
            endif
            if (islowy(i)) then
               subsizes(2) = subsizes(2) + nbord
               starts(2)   = starts(2)   - nbord
            endif
            if (ishighy(i)) then
               subsizes(2) = subsizes(2) + nbord
            endif
            call MPI_Type_create_subarray(2,sizes,subsizes,starts,  &
               MPI_ORDER_FORTRAN, basic_type,recvtypes(i),ier)
            call MPI_Type_commit(recvtypes(i),ier)
            recvcounts(i) = 1
         enddo
      else

         ! the root process will not receive from itself
         ! but will receive from everybody else
         ! comm is the communicator for all processes ( output and workers)
         do i=2,sz
            sizes    = shape(a)
            subsizes = (/ lm(i-1) - 2*nbord   , ln(i-1) - 2*nbord    /)
            starts   = (/ is(i-1) +   nbord -1, js(i-1) +   nbord -1 /)
            if (islowx(i-1)) then
               subsizes(1) = subsizes(1) + nbord
               starts(1)   = starts(1)   - nbord
            endif
            if (ishighx(i-1)) then
               subsizes(1) = subsizes(1) + nbord
            endif
            if (islowy(i-1)) then
               subsizes(2) = subsizes(2) + nbord
               starts(2)   = starts(2)   - nbord
            endif
            if (ishighy(i-1)) then
               subsizes(2) = subsizes(2) + nbord
            endif
            call MPI_Type_create_subarray(2,sizes,subsizes,starts,  &
               MPI_ORDER_FORTRAN, basic_type,recvtypes(i),ier)
            call MPI_Type_commit(recvtypes(i),ier)
            recvcounts(i) = 1
         enddo
      endif
   endif

   if (w) then
! determine mpi types for the senders
! root does send to itself
! processes send to root
      sizes = shape(b)
      subsizes   = (/ lm(ra+1) - 2*nbord    , ln(ra+1) - 2*nbord     /)
      starts     = (/ nbord, nbord/)
      if (islowx(ra+1)) then
         subsizes(1) = subsizes(1) + nbord
         starts(1)   = starts(1)   - nbord
      endif
      if (ishighx(ra+1)) then
         subsizes(1) = subsizes(1) + nbord
      endif
      if (islowy(ra+1)) then
         subsizes(2) = subsizes(2) + nbord
         starts(2)   = starts(2)   - nbord
      endif
      if (ishighy(ra+1)) then
         subsizes(2) = subsizes(2) + nbord
      endif
      call MPI_Type_create_subarray(2,sizes,subsizes,starts,  &
         MPI_ORDER_FORTRAN, basic_type,sendtypes(1),ier)
      call MPI_Type_commit(sendtypes(1),ier)
      sendcounts(1) = 1
      continue
   else
! determine mpi types for the senders
! root does not send anythink
      if(ra /= 0) then
         ! non-root processes send only to root
         sizes      = shape(b)
         subsizes   = (/ lm(ra) - 2*nbord    , ln(ra) - 2*nbord     /)
         starts     = (/ nbord, nbord/)
         if (islowx(ra)) then
            subsizes(1) = subsizes(1) + nbord
            starts(1)   = starts(1)   - nbord
         endif
         if (ishighx(ra)) then
            subsizes(1) = subsizes(1) + nbord
         endif
         if (islowy(ra)) then
            subsizes(2) = subsizes(2) + nbord
            starts(2)   = starts(2)   - nbord
         endif
         if (ishighy(ra)) then
            subsizes(2) = subsizes(2) + nbord
         endif
         call MPI_Type_create_subarray(2,sizes,subsizes,starts,  &
            MPI_ORDER_FORTRAN, basic_type,sendtypes(1),ier)
         call MPI_Type_commit(sendtypes(1),ier)
         sendcounts(1) = 1
      endif
   endif

   call MPI_Alltoallw(b,sendcounts,sdispls,sendtypes, &
      a,recvcounts,rdispls,recvtypes,comm,ier)

   do i=1,sz
      if (sendtypes(i) /= MPI_CHARACTER) then
         call MPI_Type_free(sendtypes(i),ier)
      endif
      if (recvtypes(i) /= MPI_CHARACTER) then
         call MPI_Type_free(recvtypes(i),ier)
      endif
   enddo
end subroutine doit_coll

! vim: filetype=fortran