!===============================================================================
!
! xbound_mpi.F90 - boundary exchange with MPI
!
!-------------------------------------------------------------------------------
!
! Copyright (C) 1998-2006 Hinnerk Stueben
!
! This file is part of BQCD -- Berlin Quantum ChromoDynamics program
!
! BQCD is free software: you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation, either version 3 of the License, or
! (at your option) any later version.
!
! BQCD is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License
! along with BQCD.  If not, see <http://www.gnu.org/licenses/>.
!
!-------------------------------------------------------------------------------
# include "defs.h"

!-------------------------------------------------------------------------------
module module_xbound
  
  implicit none
  integer, parameter :: max_bound = 3 * 3 * 3 * 3

  type type_xbound
     integer :: i_source
     integer :: i_target
     integer :: size        ! total size
     integer :: mu1
     integer :: mu2
     integer :: n
     integer, dimension(:), allocatable :: offs
  end type type_xbound
end

!-------------------------------------------------------------------------------
module module_xbound_g

  use module_xbound
  implicit none
  integer, save            :: n_bound = 0
  integer, save            :: n_bound2 = 0
  type (type_xbound), save :: b2(max_bound)
end

!-------------------------------------------------------------------------------
module module_xbound_sc

  use module_xbound
  implicit none
  integer, save            :: n_bound = 0
  integer, save            :: i_bound(DIM, FWD:BWD)
  integer, save            :: n_bound2 = 0
  type (type_xbound), save :: b2(max_bound)
end

!-------------------------------------------------------------------------------
subroutine init_xbound()

  implicit none
  integer, external :: version_of_d

  call init_xbound_g()
  call init_xbound_sc()
end

!-------------------------------------------------------------------------------
subroutine init_xbound_g()

  use module_xbound_g
  implicit none

! nearest neighbours must come first  
  call init_xch_bound(n_bound2, b2, NCOL * NCOL * SIZE_COMPLEX, 1, 0, 0, 0)
  call init_xch_bound(n_bound2, b2, NCOL * NCOL * SIZE_COMPLEX,-1, 0, 0, 0)
  call init_xch_bound(n_bound2, b2, NCOL * NCOL * SIZE_COMPLEX, 0, 1, 0, 0)
  call init_xch_bound(n_bound2, b2, NCOL * NCOL * SIZE_COMPLEX, 0,-1, 0, 0)
  call init_xch_bound(n_bound2, b2, NCOL * NCOL * SIZE_COMPLEX, 0, 0, 1, 0)
  call init_xch_bound(n_bound2, b2, NCOL * NCOL * SIZE_COMPLEX, 0, 0,-1, 0)
  call init_xch_bound(n_bound2, b2, NCOL * NCOL * SIZE_COMPLEX, 0, 0, 0, 1)
  call init_xch_bound(n_bound2, b2, NCOL * NCOL * SIZE_COMPLEX, 0, 0, 0,-1)

  call init_xch_bound(n_bound2, b2, NCOL * NCOL * SIZE_COMPLEX, 1, 1, 0, 0)
  call init_xch_bound(n_bound2, b2, NCOL * NCOL * SIZE_COMPLEX, 1,-1, 0, 0)
  call init_xch_bound(n_bound2, b2, NCOL * NCOL * SIZE_COMPLEX, 1, 0, 1, 0)
  call init_xch_bound(n_bound2, b2, NCOL * NCOL * SIZE_COMPLEX, 1, 0,-1, 0)
  call init_xch_bound(n_bound2, b2, NCOL * NCOL * SIZE_COMPLEX, 1, 0, 0, 1)
  call init_xch_bound(n_bound2, b2, NCOL * NCOL * SIZE_COMPLEX, 1, 0, 0,-1)
 
  call init_xch_bound(n_bound2, b2, NCOL * NCOL * SIZE_COMPLEX,-1, 1, 0, 0)
  call init_xch_bound(n_bound2, b2, NCOL * NCOL * SIZE_COMPLEX,-1,-1, 0, 0)
  call init_xch_bound(n_bound2, b2, NCOL * NCOL * SIZE_COMPLEX,-1, 0, 1, 0)
  call init_xch_bound(n_bound2, b2, NCOL * NCOL * SIZE_COMPLEX,-1, 0,-1, 0)
  call init_xch_bound(n_bound2, b2, NCOL * NCOL * SIZE_COMPLEX,-1, 0, 0, 1)
  call init_xch_bound(n_bound2, b2, NCOL * NCOL * SIZE_COMPLEX,-1, 0, 0,-1)
 
  call init_xch_bound(n_bound2, b2, NCOL * NCOL * SIZE_COMPLEX, 0, 1, 1, 0)
  call init_xch_bound(n_bound2, b2, NCOL * NCOL * SIZE_COMPLEX, 0, 1,-1, 0)
  call init_xch_bound(n_bound2, b2, NCOL * NCOL * SIZE_COMPLEX, 0, 1, 0, 1)
  call init_xch_bound(n_bound2, b2, NCOL * NCOL * SIZE_COMPLEX, 0, 1, 0,-1)
 
  call init_xch_bound(n_bound2, b2, NCOL * NCOL * SIZE_COMPLEX, 0,-1, 1, 0)
  call init_xch_bound(n_bound2, b2, NCOL * NCOL * SIZE_COMPLEX, 0,-1,-1, 0)
  call init_xch_bound(n_bound2, b2, NCOL * NCOL * SIZE_COMPLEX, 0,-1, 0, 1)
  call init_xch_bound(n_bound2, b2, NCOL * NCOL * SIZE_COMPLEX, 0,-1, 0,-1)
 
  call init_xch_bound(n_bound2, b2, NCOL * NCOL * SIZE_COMPLEX, 0, 0, 1, 1)
  call init_xch_bound(n_bound2, b2, NCOL * NCOL * SIZE_COMPLEX, 0, 0, 1,-1)
 
  call init_xch_bound(n_bound2, b2, NCOL * NCOL * SIZE_COMPLEX, 0, 0,-1, 1)
  call init_xch_bound(n_bound2, b2, NCOL * NCOL * SIZE_COMPLEX, 0, 0,-1,-1)
 
end

!-------------------------------------------------------------------------------
subroutine init_xbound_sc()

  use module_xbound_sc
  use module_lattice
  implicit none

  integer :: mu, block

 
   block = NDIRAC * NCOL * SIZE_COMPLEX
 

  call init_xch_bound(n_bound2, b2, block,-1, 0, 0, 0);  i_bound(1, BWD) = n_bound2
  call init_xch_bound(n_bound2, b2, block, 1, 0, 0, 0);  i_bound(1, FWD) = n_bound2
  call init_xch_bound(n_bound2, b2, block, 0,-1, 0, 0);  i_bound(2, BWD) = n_bound2
  call init_xch_bound(n_bound2, b2, block, 0, 1, 0, 0);  i_bound(2, FWD) = n_bound2
  call init_xch_bound(n_bound2, b2, block, 0, 0,-1, 0);  i_bound(3, BWD) = n_bound2
  call init_xch_bound(n_bound2, b2, block, 0, 0, 1, 0);  i_bound(3, FWD) = n_bound2
  call init_xch_bound(n_bound2, b2, block, 0, 0, 0,-1);  i_bound(4, BWD) = n_bound2
  call init_xch_bound(n_bound2, b2, block, 0, 0, 0, 1);  i_bound(4, FWD) = n_bound2

 
   do mu = 1, DIM
      if (npe(mu) == 1) then
         i_bound(mu, FWD) = 0
         i_bound(mu, BWD) = 0
      endif
   enddo
end


subroutine init_xch_bound(n_bound, b, block_size, xx, yy, zz, tt)

  use      module_xbound
  use      module_function_decl
  use      module_nnpe
  use      module_offset
  use      module_lattice
  use      module_vol
  implicit none

  integer, intent(inout)            :: n_bound
  type (type_xbound), intent(inout) :: b(max_bound)
  integer, intent(in)               :: block_size, xx, yy, zz, tt

  integer, dimension (DIM) :: dir, m, i, target, source
  integer, external        :: xyzt2i, n_sites, e_o
  integer                  :: x, y, z, t, size, mu, stride, block_count, ierror, cnt, cnt_i1

  logical                  :: special


  integer :: n_reals, h, j, k, mu1, mu2, nonz, i1

  if (nnpe(xx, yy, zz, tt) == my_pe()) return

  if (xx /= 0 .and. yy == 0 .and. zz /= 0 .and. tt == 0) then
     special = .true.
  else
     special = .false.
  endif


  dir = (/ xx, yy, zz, tt /)

  mu1=-1
  mu2=-1
  nonz=0
  do mu = 1, DIM
    if (dir(mu) /= 0) then
      m(mu) = 1
      if (mu1==-1) then
        mu1=2*(mu-1)+(1+dir(mu))/2
      else
        mu2=2*(mu-1)+(1+dir(mu))/2
      endif
      nonz=nonz+1
    else
      m(mu) = NH(mu)
    endif

    if (dir(mu) == -1) then
      target(mu) = -1
      source(mu) = N(mu) - 1
    elseif (dir(mu) == +1) then
      target(mu) = N(mu)
      source(mu) = 0
    else
      target(mu) = 0
      source(mu) = 0
    endif
  enddo
  
  size = block_size
  do mu = 1, DIM
    if (dir(mu) == 0) then
      size = size * NH(mu)
      m(mu) = 1
    else
      exit
    endif
  enddo
  
  if (dir(1) /= 0) then
    ASSERT(size == block_size)
  endif
  
  stride = block_size
  do mu = 1, DIM
    if (m(mu) == 1) then
      stride = stride * NH(mu)
    else
      exit
    endif
  enddo
  
  if (dir(1) /= 0) then
    ASSERT(stride >= NXH)
  endif
  
  block_count = 1
  do mu = 1, DIM
    block_count = block_count * m(mu)
  enddo
  
  if (nonz<=2) then
    n_bound = n_bound + 1
    if (nonz==2) then
      i1=-1
      do cnt=1, 8
        if (b(cnt)%mu1 == mu1) then
          i1=cnt
          exit
        endif
       
      enddo
      ASSERT(i1>0)
      b(n_bound)%mu1=mu2
      b(n_bound)%mu2=-1
    else
      b(n_bound)%mu1=mu1
      b(n_bound)%mu2=mu2
    endif
  
    ASSERT(n_bound <= max_bound)

  
    if (special) then  ! (y,t)-plane
  
       ! MPY-type for y-line:
  
       block_count = NY
       size = block_size
       stride = block_size * NXH
  
       block_count = NT
       size = 1
       stride = block_size * NXH * NY * NZ
       b(n_bound)%size = block_size * NY * NT
  
       n_reals= block_size * NY * NT
  
    else
  
       b(n_bound)%size = block_count * size
       n_reals=block_count * size
    endif
  

    b(n_bound)%i_source  = xyzt2i(source)
    b(n_bound)%i_target  = xyzt2i(target)
  
  
    ASSERT(b(n_bound)%size == block_size * n_sites(DIM, dir, NH, NPE))
    ASSERT(n_reals == block_size * n_sites(DIM, dir, NH, NPE))
  
  
    b(n_bound)%n=n_reals/block_size
    allocate(b(n_bound)%offs(b(n_bound)%n))
  
    cnt=1

    if (special) then
      do h=1, NT
        if (h>1) then
          b(n_bound)%offs(cnt)=NXH*NY*(NZ-1)+NXH-1
          cnt=cnt+1
        endif
        do j=1, NY
          if (j>1) then
            b(n_bound)%offs(cnt)=NXH-1
            cnt=cnt+1
          endif
        enddo
      enddo
    else
      do h=1, block_count
        if (h>1) then
          b(n_bound)%offs(cnt)=(stride-size)/block_size
          cnt=cnt+1
        endif
        do j=1, (size/block_size)-1
          b(n_bound)%offs(cnt)=0
          cnt=cnt+1
        enddo
      enddo
    endif
    ASSERT(cnt == n_reals/block_size)


    if (nonz==2) then
      cnt_i1=1
      h=0
      k=0
      do while (h /= (b(n_bound)%i_source-b(i1)%i_source))
        h=h+b(i1)%offs(cnt_i1)+1
        cnt_i1=cnt_i1+1
        k=k+1
      enddo
      b(n_bound)%i_source=b(i1)%i_target+k
      do j=1, n_reals/block_size-1
        h=b(i1)%offs(cnt_i1)
        cnt_i1=cnt_i1+1
        k=0
        do while (h/=b(n_bound)%offs(j))
          h=h+b(i1)%offs(cnt_i1)+1
          cnt_i1=cnt_i1+1
          k=k+1
        enddo
        b(n_bound)%offs(j)=k
      enddo
    endif
  endif
end


!-------------------------------------------------------------------------------
subroutine xbound_g_field(u)

  use module_function_decl
  use module_vol
  implicit none

  GAUGE_FIELD :: u
  integer :: mu, eo, x, y, z, t

  if (num_pes() == 1) return

  do mu = 1, DIM
  do eo = EVEN, ODD
     call xbound_g(u, eo, mu)
  enddo
  enddo
end




subroutine xbound_g(u, eo, mu)

  use module_xbound_g
  use module_function_decl
  use module_vol
  use module_nn
  use module_nnpe
  use module_lattice
  implicit none

  integer :: eo, mu, i
  GAUGE_FIELD :: u

  if (num_pes() == 1) return

  do i = 1, n_bound2
    call bgl_send_u_nb(b2(i)%mu1, b2(i)%mu2, b2(i)%n, b2(i)%offs, u(1,1, b2(i)%i_source, eo,mu), u(1,1, b2(i)%i_target, eo,mu), 0)
  call global_sum_torus(0.)	
  enddo
end




!
!-------------------------------------------------------------------------------
subroutine xbound_sc_field(a)

  use module_function_decl
  use module_vol
  implicit none

  integer :: i
  integer :: mu, fb
  SPINCOL_FIELD :: a

  if (num_pes() == 1) return

  do mu = 1, DIM
     call xbound_sc(a, mu)
  enddo
end


!-------------------------------------------------------------------------------
 subroutine xbound_sc(a, direction)
 
   use module_xbound_sc
   use module_function_decl
   use module_vol
   implicit none
 
   integer :: i
   integer :: direction, mu, fb
   SPINCOL_FIELD :: a
 
   if (num_pes() == 1) return
 
   mu = direction
   do fb = FWD, BWD
      i = i_bound(mu, fb)
      if (i /= 0) then
         call bgl_send_u_nb(b2(i)%mu1, b2(i)%mu2, b2(i)%n, b2(i)%offs, a(1,1, b2(i)%i_source), a(1,1, b2(i)%i_target), 1)
      endif
   enddo
 call global_sum_torus(0.)	
 end

!===============================================================================
