!===============================================================================
!
! xbound_d_proj_mpi.F90 - boundary exchange with MPI
!                       - exchanges projections to two-component spinors
!                       - buffers for the projections are in module_xbound_d_proj
!                       - this approach needs certain zero entries in the halos
!                         (see comment in xbound_d_proj)
!
!-------------------------------------------------------------------------------
!
! Copyright (C) 2010 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_d_proj

  use module_xbound
  implicit none

  integer, parameter :: nodagger = 0
  integer, parameter :: dagger = 1

  type type_d_proj
     COMPLEX, dimension(:, :, :), pointer :: a
  end type type_d_proj

  type(type_d_proj), save  :: d_proj(DIM, FWD:BWD)

  integer, dimension(DIM, FWD:BWD, EVEN:ODD, nodagger:dagger), save :: &
           i_source, i_target, j_target, pe_source, pe_target, size, type
end

!-------------------------------------------------------------------------------
subroutine init_xbound_d_proj()

  use module_xbound_d_proj
  use module_lattice
  use module_nnpe
  use module_surface
  use module_vol
  implicit none

  integer :: eo, mu, fb, i, ii, j, nsites, maxsites
  integer :: count, blocklength, stride, datatype
  integer, external :: xyzt2i
  integer :: s
  integer, dimension(:), pointer :: blocklengths, displacements

  allocate(blocklengths(volh * NCOL))
  allocate(displacements(volh * NCOL))

  ! allocate buffers for projections:

  do mu = 1, DIM
     if (npe(mu) == 1) cycle

     do fb = FWD, BWD
        maxsites = max(surface(EVEN, mu, fb)%nsites, &
                       surface(ODD, mu, fb)%nsites) 
        ASSERT(maxsites > 0)
        allocate(d_proj(mu, fb)%a(2, NCOL, maxsites))
     enddo
  enddo

  ! offsets, processes, datatypes:

  i_source(:, :, :, :) = 1

  i_source(4, FWD, :, :) = xyzt2i((/0, 0, 0, 0/))
  i_source(4, BWD, :, :) = xyzt2i((/0, 0, 0, nt - 1/))

  i_target(1, :, :, :) = 1  ! offset is included in MPI indexed type

  i_target(2, FWD, :, :) = xyzt2i((/0, ny, 0, 0/))
  i_target(2, BWD, :, :) = xyzt2i((/0, -1, 0, 0/))

  i_target(3, FWD, :, :) = xyzt2i((/0, 0, nz, 0/))
  i_target(3, BWD, :, :) = xyzt2i((/0, 0, -1, 0/))

  i_target(4, FWD, :, :) = xyzt2i((/0, 0, 0, nt/))
  i_target(4, BWD, :, :) = xyzt2i((/0, 0, 0, -1/))

  j_target(:, :, :, :) = 1
  
  j_target(4, FWD, :, nodagger) = 3   
  j_target(4, BWD, :,   dagger) = 3   

  pe_source(1, FWD, :, :) = nnpe( 1, 0, 0, 0)
  pe_source(1, BWD, :, :) = nnpe(-1, 0, 0, 0)
  pe_target(1, FWD, :, :) = nnpe(-1, 0, 0, 0)
  pe_target(1, BWD, :, :) = nnpe( 1, 0, 0, 0)

  pe_source(2, FWD, :, :) = nnpe(0,  1, 0, 0)
  pe_source(2, BWD, :, :) = nnpe(0, -1, 0, 0)
  pe_target(2, FWD, :, :) = nnpe(0, -1, 0, 0)
  pe_target(2, BWD, :, :) = nnpe(0,  1, 0, 0)

  pe_source(3, FWD, :, :) = nnpe(0, 0,  1, 0)
  pe_source(3, BWD, :, :) = nnpe(0, 0, -1, 0)
  pe_target(3, FWD, :, :) = nnpe(0, 0, -1, 0)
  pe_target(3, BWD, :, :) = nnpe(0, 0,  1, 0)

  pe_source(4, FWD, :, :) = nnpe(0, 0, 0,  1)
  pe_source(4, BWD, :, :) = nnpe(0, 0, 0, -1)
  pe_target(4, FWD, :, :) = nnpe(0, 0, 0, -1)
  pe_target(4, BWD, :, :) = nnpe(0, 0, 0,  1)

  do eo = EVEN, ODD
     do mu = 1, DIM
        if (npe(mu) ==  1) cycle

        do fb = FWD, BWD

           blocklength = 2 * SIZE_COMPLEX

           nsites = surface(eo, mu, fb)%nsites
           count = nsites * NCOL
           size(mu, fb, eo, :) = count * blocklength
           stride = 2 * blocklength

           if (mu == 1) then
              ii = 1
              do i = 1, nsites
                 j = surface_halo(eo, mu, fb)%site(i)
                 j = (j - 1) * stride * NCOL
                 displacements(ii)     = j
                 displacements(ii + 1) = j + stride
                 displacements(ii + 2) = j + stride * 2
                 ii = ii + NCOL
              enddo

              ASSERT((ii - 1) == count)

#ifdef MPI_1
              blocklengths(1:count) = blocklength
              call mpi_type_indexed( &
                   count, blocklengths, displacements, BQCD_REAL, datatype, ierror)
#else               
              call mpi_type_create_indexed_block( &
                   count, blocklength, displacements, BQCD_REAL, datatype, ierror)
#endif

           else
              
              call mpi_type_vector( &
                   count, blocklength, stride, BQCD_REAL, datatype, ierror)
           endif

           call mpi_type_commit(datatype, ierror)           
           type(mu, fb, eo, :) = datatype
              
        enddo
     enddo
  enddo

  deallocate(displacements)
  deallocate(blocklengths)
end

!-------------------------------------------------------------------------------
subroutine xbound_d_proj(a, eo, dag)

  use module_xbound_d_proj
  use module_input
  use module_vol
  implicit none

  SPINCOL_FIELD, intent(inout) :: a
  integer, intent(in)          :: eo  !// EVEN or ODD
  integer, intent(in)          :: dag !// nodagger(0) or dagger(1)

  !! - this routine should only be called from "d" (d-slash) routines
  !! - a generic routine is xbound_sc_field which copies full spinors
  !!
  !!call sc_zero_halo(a) -> has to be carefully handled in the rest of the program
  !!        - should no be called here because this routine is part of the kernel
  !!        - recipe: call sc_zero_halo after xbound_sc_field
  !!          (ie after data copied with xbound_sc_field is no longer needed)

  call sc_zero_halo(a)

  if (dag == 1) then
     call d_dag_proj_xf(eo, d_proj(1, FWD)%a, a)
     call d_dag_proj_xb(eo, d_proj(1, BWD)%a, a)
     call d_dag_proj_yf(eo, d_proj(2, FWD)%a, a)
     call d_dag_proj_yb(eo, d_proj(2, BWD)%a, a)
     call d_dag_proj_zf(eo, d_proj(3, FWD)%a, a)
     call d_dag_proj_zb(eo, d_proj(3, BWD)%a, a)
     !!call d_dag_proj_tf(eo, d_proj(4, FWD)%a, a)
     !!call d_dag_proj_tb(eo, d_proj(4, BWD)%a, a)
  else
     call d_proj_xf(eo, d_proj(1, FWD)%a, a)
     call d_proj_xb(eo, d_proj(1, BWD)%a, a)
     call d_proj_yf(eo, d_proj(2, FWD)%a, a)
     call d_proj_yb(eo, d_proj(2, BWD)%a, a)
     call d_proj_zf(eo, d_proj(3, FWD)%a, a)
     call d_proj_zb(eo, d_proj(3, BWD)%a, a)
     !!call d_proj_tf(eo, d_proj(4, FWD)%a, a)
     !!call d_proj_tb(eo, d_proj(4, BWD)%a, a)
  endif

  if (input%tuning_xbound_sc_i == 0) then
     call xbound_d_proj_sr(a, eo, dag)
  else
     call xbound_d_proj_i(a, eo, dag)
  endif

end

!-------------------------------------------------------------------------------
subroutine xbound_d_proj_sr(a, eo, dag)  ! sendrecv

  use module_xbound_d_proj
  use module_lattice
  use module_vol
  implicit none

  SPINCOL_FIELD, intent(inout) :: a
  integer, intent(in)          :: eo  !// EVEN or ODD
  integer, intent(in)          :: dag !// nodagger(0) or dagger(1)

  integer :: mu, fb

  do mu = 1, DIM
     if (npe(mu) == 1) cycle

     if (mu == 4) then
        do fb = FWD, BWD
           call mpi_sendrecv( &
              a(j_target(mu, fb, eo, dag), 1, i_source(mu, fb, eo, dag)), 1, &
                    type(mu, fb, eo, dag), &
               pe_target(mu, fb, eo, dag), 0, &
              a(j_target(mu, fb, eo, dag), 1, i_target(mu, fb, eo, dag)), 1, &
                    type(mu, fb, eo, dag), &
               pe_source(mu, fb, eo, dag), 0, &
                        MPI_COMM_WORLD, status, ierror)
        enddo

     else

        do fb = FWD, BWD
           call mpi_sendrecv( &
                  d_proj(mu, fb)%a, &
                    size(mu, fb, eo, dag), BQCD_REAL, &
               pe_target(mu, fb, eo, dag), 0, &
              a(j_target(mu, fb, eo, dag), 1, i_target(mu, fb, eo, dag)), 1, &
                    type(mu, fb, eo, dag), &
               pe_source(mu, fb, eo, dag), 0, &
                        MPI_COMM_WORLD, status, ierror)
        enddo

     endif
  enddo

end

!-------------------------------------------------------------------------------
subroutine xbound_d_proj_i(a, eo, dag)  ! "i"mmediate 

  use module_xbound_d_proj
  use module_lattice
  use module_vol
  implicit none

  SPINCOL_FIELD, intent(inout) :: a
  integer, intent(in)          :: eo  !// EVEN or ODD
  integer, intent(in)          :: dag !// nodagger(0) or dagger(1)

  integer :: mu, fb, n_request

  n_request = 0

  do mu = 1, DIM
     if (npe(mu) == 1) cycle

     do fb = FWD, BWD
        n_request = n_request + 1
        call mpi_irecv( &
           a(j_target(mu, fb, eo, dag), 1, i_target(mu, fb, eo, dag)), 1, &
                 type(mu, fb, eo, dag), &
            pe_source(mu, fb, eo, dag), 0, &
                     MPI_COMM_WORLD, request(n_request), ierror)
     enddo
  enddo

  do mu = 1, DIM
     if (npe(mu) == 1) cycle

     if (mu == 4 ) then

        do fb = FWD, BWD
           n_request = n_request + 1
           call mpi_isend( &
              a(j_target(mu, fb, eo, dag), 1, i_source(mu, fb, eo, dag)), 1, &
                    type(mu, fb, eo, dag), &
               pe_target(mu, fb, eo, dag), 0, &
                        MPI_COMM_WORLD, request(n_request), ierror)
        enddo

     else

        do fb = FWD, BWD
           n_request = n_request + 1
           call mpi_isend( &
                  d_proj(mu, fb)%a, &
                    size(mu, fb, eo, dag), BQCD_REAL, &
               pe_target(mu, fb, eo, dag), 0, &
                        MPI_COMM_WORLD, request(n_request), ierror)
        enddo

     endif
  enddo

  call mpi_waitall(n_request, request, status, ierror)

end

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