sll_m_collective.F90

Go to the documentation of this file.

!**************************************************************
!  Copyright INRIA
!  Authors :
!     CALVI project team
!
!  This code SeLaLib (for Semi-Lagrangian-Library)
!  is a parallel library for simulating the plasma turbulence
!  in a tokamak.
!
!  This software is governed by the CeCILL-B license
!  under French law and abiding by the rules of distribution
!  of free software.  You can  use, modify and redistribute
!  the software under the terms of the CeCILL-B license as
!  circulated by CEA, CNRS and INRIA at the following URL
!  "http://www.cecill.info".
!**************************************************************
 
!------------------------------------------------------------------------------
! Selalib
!------------------------------------------------------------------------------
! MODULE: sll_m_collective
!
! DESCRIPTION:
! REVISION HISTORY:
! DD Mmm YYYY - Initial Version
! TODO_dd_mmm_yyyy - TODO_describe_appropriate_changes - TODO_name
!------------------------------------------------------------------------------
 
! ***************************************************************************
! sll_m_collective is a module that encapsulates our calls to the MPI library.
! Any module that wants to access distributed multiprocessing capabilities
! must use sll_m_collective instead of MPI directly. If one were to desire
! some MPI capability that is not included here, such capability should not
! be plugged in directly but rather this module should be expanded.
!
! By centralizing the interaction with the MPI library we achieve several
! things:
! - obtain an explicitely reduced 'parallel' vocabulary to build our
!   application,
! - centralize argument checking and some error handling, and
! - adjust the interface to our wishes.
!
! ***************************************************************************
 
module sll_m_collective
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
#include "sll_assert.h"
#include "sll_memory.h"
#include "sll_working_precision.h"
 
   use mpi, only: &
      mpi_allgather, &
      mpi_allgatherv, &
      mpi_allreduce, &
      mpi_alltoall, &
      mpi_alltoallv, &
      mpi_barrier, &
      mpi_bcast, &
      mpi_comm_rank, &
      mpi_comm_size, &
      mpi_comm_split, &
      mpi_comm_world, &
      mpi_complex, &
      mpi_double_complex, &
      mpi_double_precision, &
      mpi_finalize, &
      mpi_gather, &
      mpi_gatherv, &
      mpi_init_thread, &
      mpi_integer, &
      mpi_integer8, &
      mpi_logical, &
      mpi_real, &
      mpi_real8, &
      mpi_reduce, &
      mpi_scatter, &
      mpi_scatterv, &
      mpi_success, &
      mpi_sum, &
      mpi_thread_funneled, &
      mpi_byte
 
   implicit none
 
   public :: &
      sll_f_collectives_are_same, &
      sll_s_boot_collective, &
      sll_s_allocate_collective, &
      sll_s_set_communicator_collective, &
      sll_o_collective_allgather, &
      sll_o_collective_allgatherv, &
      sll_s_collective_allgatherv_real64, &
      sll_o_collective_allreduce, &
      sll_s_collective_allreduce_logical, &
      sll_s_collective_allreduce_real32, &
      sll_s_collective_allreduce_sum_3d_real64, &
      sll_o_collective_alltoall, &
      sll_s_collective_alltoall_int, &
      sll_o_collective_alltoallv, &
      sll_s_collective_alltoallv_double, &
      sll_s_collective_alltoallv_int, &
      sll_s_collective_alltoallv_int_simple, &
      sll_s_collective_alltoallv_real, &
      sll_s_collective_barrier, &
      sll_o_collective_bcast, &
      sll_s_collective_bcast_real64, &
      sll_s_collective_bcast_3d_real64, &
      sll_o_collective_gather, &
      sll_s_collective_gatherv_real, &
      sll_s_collective_gatherv_real64, &
      sll_o_collective_globalsum, &
      sll_s_collective_globalsum_array_comp64, &
      sll_s_collective_globalsum_array_real64, &
      sll_o_collective_reduce, &
      sll_s_collective_reduce_int, &
      sll_s_collective_reduce_logical, &
      sll_s_collective_reduce_real32, &
      sll_s_collective_reduce_real64, &
      sll_o_collective_scatter, &
      sll_s_collective_scatterv_real, &
      sll_t_collective_t, &
      sll_f_get_collective_rank, &
      sll_f_get_collective_size, &
      sll_s_halt_collective, &
      sll_f_new_collective, &
      sll_s_test_mpi_error, &
      sll_v_world_collective, &
      sll_f_create_collective
 
   private
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   ! This is the only place in the prototype that should have to include
   ! the mpi header file.
   !include 'mpif.h'
   !implicit none
 
   ! **********************************************************************
   ! The sll_t_collective_t is essentially a wrapper around an MPI
   ! communicator. We store some of the most frequently accessed values
   ! to save a little on the overhead of the corresponding function calls.
   !
   ! The original idea was to have this as an opaque type. But how to
   ! do this in Fortran without forward declarations? Any help would be
   ! appreciated... In any case, the only means allowed to interact with
   ! this type, outside of this module, are the functions/subroutines
   ! defined herein.
   !
   !***********************************************************************
 
   type sll_t_collective_t
      type(sll_t_collective_t), pointer :: parent => null() 
      sll_int32                       :: comm   
      sll_int32                       :: color
      sll_int32                       :: key 
      sll_int32                       :: rank 
      sll_int32                       :: size 
      sll_int32                       :: thread_level_required
      sll_int32                       :: thread_level_provided
   end type sll_t_collective_t
 
   ! **********************************************************************
   ! A few rare global variables.
   ! The sll_v_world_collective just wraps around MPI_WORLD_COMM. This gets
   ! initialized in the call to sll_s_boot_collective().
   !
   ! **********************************************************************
 
   type(sll_t_collective_t), pointer    :: sll_v_world_collective
 
   interface sll_o_collective_bcast
      module procedure sll_collective_bcast_int32
      module procedure sll_collective_bcast_int64
      module procedure sll_collective_bcast_real32
      module procedure sll_collective_bcast_real64
      module procedure sll_s_collective_bcast_real64 ! TODO: delete (use subr above)
      module procedure sll_collective_bcast_comp32   ! TODO: remove 'size' argument
      module procedure sll_collective_bcast_comp64   ! TODO: remove 'size' argument
      module procedure sll_collective_bcast_logical
   end interface
 
   interface sll_o_collective_gather
      module procedure sll_collective_gather_real32
      module procedure sll_collective_gather_real64
      module procedure sll_collective_gather_logical
   end interface
 
   interface sll_o_collective_allgather
      module procedure sll_collective_allgather_int, &
         sll_collective_allgather_real64
   end interface
 
   interface sll_o_collective_allgatherv
      module procedure sll_collective_allgatherv_real32, &
         sll_s_collective_allgatherv_real64
   end interface
 
   interface sll_collective_gatherv
      module procedure sll_s_collective_gatherv_real, &
         sll_s_collective_gatherv_real64
   end interface
 
   interface sll_o_collective_scatter
      module procedure sll_collective_scatter_real
      module procedure sll_collective_scatter_real64
      module procedure sll_collective_scatter_int32
   end interface
 
   interface sll_collective_scatterv
      module procedure sll_s_collective_scatterv_real
   end interface
 
   interface sll_o_collective_allreduce
      module procedure sll_s_collective_allreduce_real32, &
         sll_collective_allreduce_real64, &
         sll_collective_allreduce_real64_2darray, &
         sll_s_collective_allreduce_logical, &
         sll_collective_allreduce_comp64, &
         sll_collective_allreduce_comp32, &
         sll_collective_allreduce_int32
   end interface
 
   interface sll_o_collective_reduce
      module procedure sll_s_collective_reduce_real32, &
         sll_s_collective_reduce_real64, &
         sll_s_collective_reduce_int, &
         sll_s_collective_reduce_logical, &
         sll_collective_reduce_comp64, &
         sll_collective_reduce_comp32, &
         sll_collective_reduce_real64_2d
   end interface
 
   interface sll_o_collective_alltoall
      module procedure sll_s_collective_alltoall_int, &
         sll_collective_alltoall_double, &
         sll_collective_alltoall_complex_double
   end interface
 
   interface sll_o_collective_alltoallv
      module procedure sll_s_collective_alltoallv_int, &
         sll_s_collective_alltoallv_real, &
         sll_s_collective_alltoallv_double, &
         sll_collective_alltoallv_complex_double
   end interface
 
   interface sll_o_collective_globalsum
      module procedure sll_s_collective_globalsum_array_real64, &
         sll_collective_globalsum_array_real32, &
         sll_collective_globalsum_real64, &
         sll_s_collective_globalsum_array_comp64, &
         sll_collective_globalsum_array_comp32, &
         sll_collective_globalsum_comp64, &
         sll_collective_globalsum_array_int32, &
         sll_collective_globalsum_int32, &
         sll_collective_globalsum_comp32, &
         sll_collective_globalsum_real32
   end interface
 
contains !************************** Operations **************************
 
   ! First a couple of utilities for this module
   subroutine sll_check_collective_ptr(ptr)
      type(sll_t_collective_t), pointer :: ptr
      if (.not. associated(ptr)) then
         write (*, '(a)') 'sll_check_collective_ptr: non-associated pointer'
         stop 'SLL_CHECK_COLLECTIVE_PTR'
      end if
   end subroutine sll_check_collective_ptr
 
   subroutine sll_s_test_mpi_error(ierr, descriptor)
      sll_int32, intent(in)        :: ierr
      character(len=*), intent(in) :: descriptor
 
      if (ierr .ne. mpi_success) then
         write (*, '(a, a)') 'MPI error code failure: ', descriptor
      end if
   end subroutine sll_s_test_mpi_error
 
   ! Following what is exposed to the users of the module.
 
   ! The following function is a little tricky. The only test of equality we
   ! use is the identifier of the underlying communicator. Can the collective
   ! differ in any other way?
   function sll_f_collectives_are_same(col1, col2)
      logical :: sll_f_collectives_are_same
      type(sll_t_collective_t), pointer :: col1
      type(sll_t_collective_t), pointer :: col2
      sll_assert(associated(col1))
      sll_assert(associated(col2))
      if (col1%comm == col2%comm) then
         sll_f_collectives_are_same = .true.
      else
         sll_f_collectives_are_same = .false.
      end if
   end function sll_f_collectives_are_same
 
   ! sll_s_boot_collective allocates and initializes the global variable
   ! sll_v_world_collective and boots the MPI environment.
 
   subroutine sll_s_boot_collective(required)
      sll_int32, intent(in), optional :: required
      sll_int32 :: ierr
 
      call sll_s_allocate_collective()
 
      if (present(required)) then
         sll_v_world_collective%thread_level_required = required
      else
         sll_v_world_collective%thread_level_required = mpi_thread_funneled
      end if
 
      call mpi_init_thread(sll_v_world_collective%thread_level_required, &
                           sll_v_world_collective%thread_level_provided, &
                           ierr)
      call sll_s_set_communicator_collective(mpi_comm_world)
   end subroutine sll_s_boot_collective
 
   subroutine sll_s_allocate_collective() bind(C,name='sll_s_allocate_collective')
     sll_int32 :: ierr
     sll_allocate( sll_v_world_collective, ierr )
   end subroutine sll_s_allocate_collective
 
   subroutine sll_s_set_communicator_collective(communicator_in) bind(C,name='sll_s_set_communicator_collective')
     sll_int32, intent(in) :: communicator_in
     sll_int32 :: ierr
 
     sll_v_world_collective%comm     = communicator_in
     sll_v_world_collective%color    = 0
     sll_v_world_collective%key      = 0
     call mpi_comm_rank( communicator_in, sll_v_world_collective%rank, ierr )
     call sll_s_test_mpi_error( ierr, 'sll_s_boot_collective(): MPI_COMM_RANK()' )
     call mpi_comm_size( communicator_in, sll_v_world_collective%size, ierr )
     call sll_s_test_mpi_error( ierr, 'sll_s_boot_collective(): MPI_COMM_SIZE()')
   end subroutine sll_s_set_communicator_collective
 
   subroutine sll_s_halt_collective() bind(C,name='sll_s_halt_collective')
      sll_int32 :: ierr
      call mpi_barrier(mpi_comm_world, ierr)
      call sll_s_test_mpi_error(ierr, &
                                'sll_s_halt_collective(): MPI_BARRIER()')
      call mpi_finalize(ierr)
   end subroutine sll_s_halt_collective
 
   ! sll_f_new_collective follows a somewhat similar calling convention as
   ! MPI_COMM_SPLIT() and is a wrapper around it. Error checking
   ! is done internally. The departure from the standard syntax is to permit
   ! a call like:
   !
   ! type(sll_t_collective_t), pointer :: new_col
   !
   ! followed by
   !
   ! new_col = sll_f_new_collective( parent, color, key )
   !
   ! Note that the library's basic types are always pointers. The alternative
   ! syntax would be:
   !
   ! type(sll_t_collective_t), pointer :: new_col
   !
   ! call sll_f_new_collective( parent, color, key, new_col )
   !
   ! The collective stores the information:
   ! - a pointer to the parent collective from which it was split
   ! - the values of color and key used for the splitting
   ! - the other fields, rank and size are pre-populated for convenience.
 
   function sll_f_new_collective(parent, color, key)
      type(sll_t_collective_t), pointer  :: parent
      sll_int32, intent(in)            :: color
      sll_int32, intent(in)            :: key
      sll_int32                        :: ierr
      type(sll_t_collective_t), pointer  :: sll_f_new_collective
 
      call sll_check_collective_ptr(parent)
      sll_allocate(sll_f_new_collective, ierr)
      sll_f_new_collective%parent => parent
      sll_f_new_collective%color = color
      sll_f_new_collective%key = key
      call mpi_comm_split(parent%comm, color, key, sll_f_new_collective%comm, &
                          ierr)
      call sll_s_test_mpi_error(ierr, 'sll_f_new_collective(): MPI_COMM_SPLIT()')
      ! fill out the rest of the fields.
      call mpi_comm_rank(sll_f_new_collective%comm, sll_f_new_collective%rank, ierr)
      call sll_s_test_mpi_error(ierr, 'sll_f_new_collective(): MPI_COMM_RANK()')
      call mpi_comm_size(sll_f_new_collective%comm, sll_f_new_collective%size, ierr)
      call sll_s_test_mpi_error(ierr, 'sll_f_new_collective(): MPI_COMM_RANK()')
   end function sll_f_new_collective
 
   subroutine sll_delete_collective(col)
      type(sll_t_collective_t), pointer :: col
      sll_int32                       :: ierr
      ! Why don't use MPI_COMM_FREE(col%comm,ierr)
      call sll_check_collective_ptr(col)
      sll_deallocate(col, ierr)
   end subroutine sll_delete_collective
 
   function sll_get_collective_comm(col)
      type(sll_t_collective_t), pointer :: col
      sll_int32                       :: sll_get_collective_comm
      call sll_check_collective_ptr(col)
      sll_get_collective_comm = col%comm
   end function sll_get_collective_comm
 
   function sll_f_get_collective_rank(col)
      type(sll_t_collective_t), pointer :: col
      sll_int32                       :: sll_f_get_collective_rank
      call sll_check_collective_ptr(col)
      sll_f_get_collective_rank = col%rank
   end function sll_f_get_collective_rank
 
   function sll_get_collective_color(col)
      type(sll_t_collective_t), pointer :: col
      sll_int32                       :: sll_get_collective_color
      call sll_check_collective_ptr(col)
      sll_get_collective_color = col%color
   end function sll_get_collective_color
 
   function sll_f_get_collective_size(col)
      type(sll_t_collective_t), pointer :: col
      sll_int32                       :: sll_f_get_collective_size
      call sll_check_collective_ptr(col)
      sll_f_get_collective_size = col%size
   end function sll_f_get_collective_size
 
   function sll_get_collective_parent(col)
      type(sll_t_collective_t), pointer :: col
      type(sll_t_collective_t), pointer :: sll_get_collective_parent
      call sll_check_collective_ptr(col)
      sll_get_collective_parent => col%parent
   end function sll_get_collective_parent
 
   subroutine sll_s_collective_barrier(col)
      type(sll_t_collective_t), pointer :: col
      sll_int32                         :: ierr
      call sll_check_collective_ptr(col)
      call mpi_barrier(col%comm, ierr)
      call sll_s_test_mpi_error(ierr, &
                                'sll_s_collective_barrier(): MPI_BARRIER()')
   end subroutine sll_s_collective_barrier
 
   subroutine sll_collective_bcast_logical(col, buffer, root)
      type(sll_t_collective_t), pointer :: col
      logical, intent(inout) :: buffer(:)
      sll_int32, intent(in) :: root
      sll_int32 :: ierr
      call mpi_bcast(buffer, size(buffer), mpi_logical, root, col%comm, ierr)
      call sll_s_test_mpi_error(ierr, 'sll_collective_bcast_logical(): MPI_BCAST()')
   end subroutine sll_collective_bcast_logical
 
   subroutine sll_collective_bcast_int32(col, buffer, root)
      type(sll_t_collective_t), pointer       :: col
      sll_int32, intent(inout) :: buffer(:)
      sll_int32, intent(in)    :: root
 
      sll_int32 :: ierr
 
      call mpi_bcast(buffer, size(buffer), mpi_integer, root, col%comm, ierr)
      call sll_s_test_mpi_error(ierr, &
                                'sll_collective_bcast_int32(): MPI_BCAST()')
   end subroutine sll_collective_bcast_int32
 
   subroutine sll_collective_bcast_int64(col, buffer, root)
      type(sll_t_collective_t), pointer       :: col
      sll_int64, intent(inout) :: buffer(:)
      sll_int32, intent(in)    :: root
 
      sll_int32 :: ierr
 
      call mpi_bcast(buffer, size(buffer), mpi_integer8, root, col%comm, ierr)
      call sll_s_test_mpi_error(ierr, &
                                'sll_collective_bcast_int64(): MPI_BCAST()')
   end subroutine sll_collective_bcast_int64
 
   subroutine sll_collective_bcast_real64(col, buffer, root)
      type(sll_t_collective_t), pointer       :: col
      sll_real64, intent(inout) :: buffer(:)
      sll_int32, intent(in)    :: root
 
      sll_int32 :: ierr
 
      call mpi_bcast(buffer, size(buffer), mpi_real8, root, col%comm, ierr)
      call sll_s_test_mpi_error(ierr, &
                                'sll_collective_bcast_real64(): MPI_BCAST()')
   end subroutine sll_collective_bcast_real64
 
   subroutine sll_collective_bcast_real32(col, buffer, size, root)
      type(sll_t_collective_t), pointer       :: col
      sll_real32, intent(inout) :: buffer(:)
      sll_int32, intent(in)    :: size
      sll_int32, intent(in)    :: root
 
      sll_int32 :: ierr
 
      call mpi_bcast(buffer, size, mpi_real, root, col%comm, ierr)
      call sll_s_test_mpi_error(ierr, &
                                'sll_collective_bcast_real32(): MPI_BCAST()')
   end subroutine sll_collective_bcast_real32
 
   subroutine sll_s_collective_bcast_real64(col, buffer, size, root)
      type(sll_t_collective_t), pointer       :: col
      sll_real64, intent(inout) :: buffer(:)
      sll_int32, intent(in)    :: size
      sll_int32, intent(in)    :: root
 
      sll_int32 :: ierr
 
      call mpi_bcast(buffer, size, mpi_real8, root, col%comm, ierr)
      call sll_s_test_mpi_error(ierr, &
                                'sll_s_collective_bcast_real64(): MPI_BCAST()')
   end subroutine sll_s_collective_bcast_real64
 
   subroutine sll_collective_bcast_comp64(col, buffer, size, root)
      type(sll_t_collective_t), pointer       :: col
      sll_comp64, intent(inout) :: buffer(:)
      sll_int32, intent(in)    :: size
      sll_int32, intent(in)    :: root
 
      sll_int32 :: ierr
 
      call mpi_bcast(buffer, size, mpi_double_complex, root, col%comm, ierr)
      call sll_s_test_mpi_error(ierr, &
                                'sll_collective_bcast_comp64(): MPI_BCAST()')
   end subroutine sll_collective_bcast_comp64
 
   subroutine sll_collective_bcast_comp32(col, buffer, size, root)
      type(sll_t_collective_t), pointer       :: col
      sll_comp32, intent(inout) :: buffer(:)
      sll_int32, intent(in)    :: size
      sll_int32, intent(in)    :: root
 
      sll_int32 :: ierr
 
      call mpi_bcast(buffer, size, mpi_complex, root, col%comm, ierr)
      call sll_s_test_mpi_error(ierr, &
                                'sll_collective_bcast_comp32(): MPI_BCAST()')
   end subroutine sll_collective_bcast_comp32
 
   subroutine sll_s_collective_bcast_3d_real64(col, buffer, root)
      type(sll_t_collective_t) :: col
      sll_real64, dimension(:, :, :), intent(inout) :: buffer
      sll_int32, intent(in) :: root
      sll_int32 :: count, ierr
      count = size(buffer)
      call mpi_bcast(buffer, count, mpi_double_precision, root, col%comm, ierr)
      sll_assert(ierr == mpi_success)
   end subroutine sll_s_collective_bcast_3d_real64
 
   ! Consider joining the next 'gather' interfaces into a single one.
   subroutine sll_collective_gather_real32(col, send_buf, send_sz, root, &
                                           rec_buf)
      type(sll_t_collective_t), pointer      :: col
      sll_real32, dimension(:), intent(in) :: send_buf ! what would change...
      sll_int32                            :: send_sz
      sll_real32, dimension(:), intent(out) :: rec_buf  ! would also change
      sll_int32, intent(in)                :: root
      sll_int32                            :: ierr
      !sll_int32                            :: rec_count ! size of receive buf
      ! FIXME: add some argument checking here
      !rec_count = send_sz*col%size
      !Note that the 5th argument at the root indicates the number of items
      !it receives from each task. It is not the total number of items received.
      call mpi_gather(send_buf, send_sz, mpi_real, rec_buf, send_sz, &
                      mpi_real, root, col%comm, ierr)
      call sll_s_test_mpi_error(ierr, &
                                'sll_collective_gather_real(): MPI_GATHER()')
   end subroutine sll_collective_gather_real32
 
   subroutine sll_collective_gather_real64(col, send_buf, send_sz, root, &
                                           rec_buf)
      type(sll_t_collective_t), pointer      :: col
      sll_real64, dimension(:), intent(in) :: send_buf ! what would change...
      sll_int32                            :: send_sz
      sll_real64, dimension(:), intent(out) :: rec_buf  ! would also change
      sll_int32, intent(in)                :: root
      sll_int32                            :: ierr
      !sll_int32                            :: rec_count ! size of receive buf
      ! FIXME: add some argument checking here
      !rec_count = send_sz*col%size
      !Note that the 5th argument at the root indicates the number of items
      !it receives from each task. It is not the total number of items received.
      call mpi_gather(send_buf, send_sz, mpi_double_precision, rec_buf, send_sz, &
                      mpi_double_precision, root, col%comm, ierr)
      call sll_s_test_mpi_error(ierr, &
                                'sll_collective_gather_real(): MPI_GATHER()')
   end subroutine sll_collective_gather_real64
 
   subroutine sll_collective_gather_logical(col, send_buf, root, rec_buf)
      type(sll_t_collective_t), pointer    :: col
      logical, intent(in) :: send_buf(:)
      sll_int32, intent(in) :: root
      logical, intent(out) :: rec_buf(:)
 
      sll_int32 :: send_sz, ierr
 
      ! Get message size
      send_sz = size(send_buf)
 
      ! Root: Verify that receive buffer is of correct size
      if (col%rank == root) then
         sll_assert(size(rec_buf) == send_sz*col%size)
      end if
 
      !Note that the 5th argument at the root indicates the number of items
      !it receives from each task. It is not the total number of items received.
      call mpi_gather(send_buf, send_sz, mpi_logical, rec_buf, send_sz, &
                      mpi_logical, root, col%comm, ierr)
      call sll_s_test_mpi_error(ierr, &
                                'sll_collective_gather_real(): MPI_GATHER()')
   end subroutine sll_collective_gather_logical
 
   subroutine sll_s_collective_gatherv_real(col, send_buf, send_count, &
                                            recvcnts, displs, root, rec_buf)
      type(sll_t_collective_t), pointer      :: col
      sll_real32, dimension(:), intent(in) :: send_buf ! what would change...
      sll_int32, intent(in)                :: send_count
      sll_int32, dimension(:), intent(in)  :: recvcnts
      sll_int32, dimension(:), intent(in)  :: displs
      sll_real32, dimension(:), intent(out) :: rec_buf  ! would also change
      sll_int32, intent(in)                :: root
      sll_int32                            :: ierr
      ! FIXME: Argument checking
      call sll_check_collective_ptr(col)
      ! displs, rec_buf and recvcnts significant only for root
      if (col%rank .eq. root) then
         sll_assert(SIZE(recvcnts) .eq. col%size)
         sll_assert(SIZE(displs) .eq. col%size)
         sll_assert(SIZE(rec_buf) .eq. sum(recvcnts))
      end if
      call mpi_gatherv( &
         send_buf, &
         send_count, &
         mpi_real, &
         rec_buf, &
         recvcnts, &
         displs, &
         mpi_real, &
         root, &
         col%comm, &
         ierr)
      call sll_s_test_mpi_error(ierr, &
                                'sll_s_collective_gatherv_real(): MPI_GATHERV()')
   end subroutine sll_s_collective_gatherv_real
 
   subroutine sll_s_collective_gatherv_real64(col, send_buf, send_count, &
                                              recvcnts, displs, root, rec_buf)
      type(sll_t_collective_t), pointer      :: col
      sll_real64, dimension(:), intent(in) :: send_buf ! what would change...
      sll_int32, intent(in)                :: send_count
      sll_int32, dimension(:), intent(in)  :: recvcnts
      sll_int32, dimension(:), intent(in)  :: displs
      sll_real64, dimension(:), intent(out) :: rec_buf  ! would also change
      sll_int32, intent(in)                :: root
      sll_int32                            :: ierr
      ! FIXME: Argument checking
      call sll_check_collective_ptr(col)
      ! displs, rec_buf and recvcnts significant only for root
      if (col%rank .eq. root) then
         sll_assert(SIZE(recvcnts) .eq. col%size)
         sll_assert(SIZE(displs) .eq. col%size)
         sll_assert(SIZE(rec_buf) .eq. sum(recvcnts))
      end if
      call mpi_gatherv(send_buf, send_count, mpi_real8, rec_buf, recvcnts, &
                       displs, mpi_real8, root, col%comm, ierr)
      call sll_s_test_mpi_error(ierr, &
                                'sll_s_collective_gatherv_real64(): MPI_GATHERV()')
   end subroutine sll_s_collective_gatherv_real64
 
   subroutine sll_collective_allgather_int(col, send_buf, send_sz, &
                                           recv_buf, recv_sz)
      type(sll_t_collective_t), pointer        :: col
      sll_int32, dimension(:), intent(in)    :: send_buf ! what would change...
      sll_int32, intent(in)                  :: send_sz
      sll_int32, dimension(:), intent(inout) :: recv_buf ! would also change
      sll_int32, intent(in)                  :: recv_sz
      sll_int32                              :: ierr
      ! FIXME: Argument checking
      call sll_check_collective_ptr(col)
      call mpi_allgather(send_buf(:), send_sz, mpi_integer, &
                         recv_buf(:), recv_sz, mpi_integer, col%comm, ierr)
      call sll_s_test_mpi_error(ierr, &
                                'sll_collective_allgather_int(): MPI_ALLGATHER()')
 
   end subroutine
 
   subroutine sll_collective_allgather_real64( &
      col, &
      send_buf, &
      send_sz, &
      recv_buf, &
      recv_sz)
 
      type(sll_t_collective_t), pointer         :: col
      sll_real64, dimension(:), intent(in)    :: send_buf
      sll_int32, intent(in)                   :: send_sz
      sll_real64, dimension(:), intent(out)   :: recv_buf ! would change
      sll_int32, intent(in)                   :: recv_sz
      sll_int32                               :: ierr
      ! FIXME: Argument checking
      call sll_check_collective_ptr(col)
      call mpi_allgather(send_buf(:), send_sz, mpi_real8, &
                         recv_buf(:), recv_sz, mpi_real8, &
                         col%comm, ierr)
      call sll_s_test_mpi_error(ierr, &
                                'sll_collective_allgather_int(): MPI_ALLGATHER()')
 
   end subroutine sll_collective_allgather_real64
 
   subroutine sll_collective_allgatherv_real32(col, send_buf, send_cnt, &
                                               rec_cnt, displs, rec_buf)
      type(sll_t_collective_t), pointer      :: col
      sll_real32, dimension(:), intent(in) :: send_buf ! what would change...
      sll_int32, intent(in)                :: send_cnt
      sll_int32, dimension(:), intent(in)  :: rec_cnt
      sll_int32, dimension(:), intent(in)  :: displs
      sll_real32, dimension(:), intent(out) :: rec_buf  ! would also change
      sll_int32                            :: ierr
      ! FIXME: argument checking
      sll_assert(col%size .eq. SIZE(displs))
      sll_assert(col%size .eq. SIZE(rec_cnt))
      call mpi_allgatherv(send_buf, send_cnt, mpi_real, rec_buf, rec_cnt, &
                          displs, mpi_real, col%comm, ierr)
      call sll_s_test_mpi_error(ierr, &
                                'sll_collective_allgatherv_real32(): MPI_ALLGATHERV()')
   end subroutine sll_collective_allgatherv_real32
 
   subroutine sll_s_collective_allgatherv_real64( &
      col, &
      send_buf, &
      send_cnt, &
      rec_cnt, &
      displs, &
      rec_buf)
 
      type(sll_t_collective_t), pointer       :: col
      sll_real64, dimension(:), intent(in)  :: send_buf ! what would change...
      sll_int32, intent(in)                 :: send_cnt
      sll_int32, dimension(:), intent(in)   :: rec_cnt
      sll_int32, dimension(:), intent(in)   :: displs
      sll_real64, dimension(:), intent(out) :: rec_buf  ! would also change
      sll_int32                             :: ierr
      ! FIXME: argument checking
      sll_assert(col%size .eq. SIZE(displs))
      sll_assert(col%size .eq. SIZE(rec_cnt))
      call mpi_allgatherv( &
         send_buf, &
         send_cnt, &
         mpi_double_precision, &
         rec_buf, &
         rec_cnt, &
         displs, &
         mpi_double_precision, &
         col%comm, &
         ierr)
      call sll_s_test_mpi_error(ierr, &
                                'sll_s_collective_allgatherv_real64(): MPI_ALLGATHERV()')
   end subroutine sll_s_collective_allgatherv_real64
 
   subroutine sll_collective_scatter_real(col, send_buf, send_count, root, &
                                          rec_buf)
      type(sll_t_collective_t), pointer      :: col
      sll_real32, dimension(:), intent(in) :: send_buf ! what would change...
      sll_int32, intent(in)                :: send_count
      sll_int32, intent(in)                :: root
      sll_real32, dimension(:), intent(in) :: rec_buf  ! would also change
      sll_int32                            :: ierr
      !sll_int32                            :: recvcount
      ! FIXME: argument checking
      ! recvcount = size/col%size
      !send_buf and send_count significant only at root
      if (col%rank .eq. root) then
         sll_assert(SIZE(send_buf) .eq. (send_count*(col%size)))
      end if
      call mpi_scatter(send_buf, send_count, mpi_real, rec_buf, send_count, &
                       mpi_real, root, col%comm, ierr)
      call sll_s_test_mpi_error(ierr, &
                                'sll_collective_scatter_real(): MPI_SCATTER()')
   end subroutine sll_collective_scatter_real
 
   subroutine sll_collective_scatter_real64(col, send_buf, send_count, root, &
                                            rec_buf)
      type(sll_t_collective_t), pointer      :: col
      sll_real64, dimension(:), intent(in) :: send_buf ! what would change...
      sll_int32, intent(in)                :: send_count
      sll_int32, intent(in)                :: root
      sll_real64, dimension(:), intent(in) :: rec_buf  ! would also change
      sll_int32                            :: ierr
      !sll_int32                            :: recvcount
      ! FIXME: argument checking
      ! recvcount = size/col%size
      !send_buf and send_count significant only at root
      if (col%rank .eq. root) then
         sll_assert(SIZE(send_buf) .eq. (send_count*(col%size)))
      end if
      call mpi_scatter(send_buf, send_count, mpi_double_precision, rec_buf, send_count, &
                       mpi_double_precision, root, col%comm, ierr)
      call sll_s_test_mpi_error(ierr, &
                                'sll_collective_scatter_real64(): MPI_SCATTER()')
   end subroutine sll_collective_scatter_real64
 
   subroutine sll_collective_scatter_int32(col, send_buf, send_count, root, &
                                           rec_buf)
      type(sll_t_collective_t), pointer      :: col
      sll_int32, dimension(:), intent(in) :: send_buf ! what would change...
      sll_int32, intent(in)                :: send_count
      sll_int32, intent(in)                :: root
      sll_int32, dimension(:), intent(in) :: rec_buf  ! would also change
      sll_int32                            :: ierr
      !sll_int32                            :: recvcount
      ! FIXME: argument checking
      ! recvcount = size/col%size
      !send_buf and send_count significant only at root
      if (col%rank .eq. root) then
         sll_assert(SIZE(send_buf) .eq. (send_count*(col%size)))
      end if
      call mpi_scatter(send_buf, send_count, mpi_double_precision, rec_buf, send_count, &
                       mpi_integer, root, col%comm, ierr)
      call sll_s_test_mpi_error(ierr, &
                                'sll_collective_scatter_real64(): MPI_SCATTER()')
   end subroutine sll_collective_scatter_int32
 
   subroutine sll_s_collective_scatterv_real(col, send_buf, send_count, &
                                             displs, recv_count, root, rec_buf)
      type(sll_t_collective_t), pointer      :: col
      sll_real32, dimension(:), intent(in) :: send_buf ! what would change...
      sll_int32, dimension(:), intent(in)  :: send_count
      sll_int32, dimension(:), intent(in)  :: displs
      sll_int32, intent(in)                :: recv_count
      sll_real32, dimension(:), intent(out) :: rec_buf  ! would also change
      sll_int32, intent(in)                :: root
      sll_int32                            :: ierr
      ! FIXME: ARG CHECKING!
      sll_assert(SIZE(send_count) .eq. col%size)
      sll_assert(SIZE(displs) .eq. col%size)
      call mpi_scatterv(send_buf, send_count, displs, mpi_real, rec_buf, &
                        recv_count, mpi_real, root, col%comm, ierr)
      call sll_s_test_mpi_error(ierr, &
                                'sll_s_collective_scatterv_real(): MPI_SCATTERV()')
   end subroutine sll_s_collective_scatterv_real
 
   subroutine sll_s_collective_allreduce_real32(col, send_buf, count, op, &
                                                rec_buf)
      type(sll_t_collective_t), pointer       :: col
      sll_real32, dimension(:), intent(in)  :: send_buf ! what would change...
      sll_int32, intent(in)                 :: count
      sll_int32, intent(in)                :: op
      sll_real32, dimension(:), intent(out) :: rec_buf  ! would also change
      sll_int32                             :: ierr
      ! FIXME: ARG CHECKING!
      call sll_check_collective_ptr(col)
      call mpi_allreduce( &
         send_buf, &
         rec_buf, &
         count, &
         mpi_real, &
         op, &
         col%comm, &
         ierr)
      call sll_s_test_mpi_error( &
         ierr, &
         'sll_s_collective_allreduce_real32(): MPI_ALLREDUCE()')
   end subroutine sll_s_collective_allreduce_real32
 
   subroutine sll_collective_allreduce_real64(col, send_buf, count, op, &
                                              rec_buf)
      type(sll_t_collective_t), pointer       :: col
      sll_real64, dimension(:), intent(in)  :: send_buf ! what would change...
      sll_int32, intent(in)                 :: count
      sll_int32, intent(in)                :: op
      sll_real64, dimension(:), intent(out) :: rec_buf  ! would also change
      sll_int32                             :: ierr
      ! FIXME: ARG CHECKING!
      call sll_check_collective_ptr(col)
      call mpi_allreduce( &
         send_buf, &
         rec_buf, &
         count, &
         mpi_double_precision, &
         op, &
         col%comm, &
         ierr)
      call sll_s_test_mpi_error( &
         ierr, &
         'sll_collective_allreduce_real64(): MPI_ALLREDUCE()')
   end subroutine sll_collective_allreduce_real64
 
   subroutine sll_collective_allreduce_real64_2darray(col, send_buf, count, op, &
                                                      rec_buf)
      type(sll_t_collective_t), pointer       :: col
      sll_real64, dimension(:, :), intent(in)  :: send_buf ! what would change...
      sll_int32, intent(in)                 :: count
      sll_int32, intent(in)                :: op
      sll_real64, dimension(:, :), intent(out) :: rec_buf  ! would also change
      sll_int32                             :: ierr
      ! FIXME: ARG CHECKING!
      call sll_check_collective_ptr(col)
      call mpi_barrier(col%comm, ierr)
      call mpi_allreduce( &
         send_buf, &
         rec_buf, &
         count, &
         mpi_double_precision, &
         op, &
         col%comm, &
         ierr)
      call sll_s_test_mpi_error( &
         ierr, &
         'sll_collective_allreduce_real64(): MPI_ALLREDUCE()')
   end subroutine sll_collective_allreduce_real64_2darray
 
   subroutine sll_collective_allreduce_comp64(col, send_buf, count, op, &
                                              rec_buf)
      type(sll_t_collective_t), pointer       :: col
      sll_comp64, dimension(:), intent(in)  :: send_buf ! what would change...
      sll_int32, intent(in)                 :: count
      sll_int32, intent(in)                :: op
      sll_comp64, dimension(:), intent(out) :: rec_buf  ! would also change
      sll_int32                             :: ierr
      ! FIXME: ARG CHECKING!
      call sll_check_collective_ptr(col)
      call mpi_allreduce( &
         send_buf, &
         rec_buf, &
         count, &
         mpi_double_complex, &
         op, &
         col%comm, &
         ierr)
      call sll_s_test_mpi_error( &
         ierr, &
         'sll_collective_allreduce_comp64(): MPI_ALLREDUCE()')
   end subroutine sll_collective_allreduce_comp64
 
   subroutine sll_collective_allreduce_comp32(col, send_buf, count, op, &
                                              rec_buf)
      type(sll_t_collective_t), pointer       :: col
      sll_comp32, dimension(:), intent(in)  :: send_buf ! what would change...
      sll_int32, intent(in)                 :: count
      sll_int32, intent(in)                :: op
      sll_comp32, dimension(:), intent(out) :: rec_buf  ! would also change
      sll_int32                             :: ierr
      ! FIXME: ARG CHECKING!
      call sll_check_collective_ptr(col)
      call mpi_allreduce( &
         send_buf, &
         rec_buf, &
         count, &
         mpi_complex, &
         op, &
         col%comm, &
         ierr)
      call sll_s_test_mpi_error( &
         ierr, &
         'sll_collective_allreduce_comp32(): MPI_ALLREDUCE()')
   end subroutine sll_collective_allreduce_comp32
 
   subroutine sll_collective_allreduce_int32(col, send_buf, count, op, &
                                             rec_buf)
      type(sll_t_collective_t), pointer       :: col
      sll_int32, dimension(:), intent(in)  :: send_buf ! what would change...
      sll_int32, intent(in)                 :: count
      sll_int32, intent(in)                :: op
      sll_int32, dimension(:), intent(out) :: rec_buf  ! would also change
      sll_int32                             :: ierr
      ! FIXME: ARG CHECKING!
      call sll_check_collective_ptr(col)
      call mpi_allreduce( &
         send_buf, &
         rec_buf, &
         count, &
         mpi_integer, &
         op, &
         col%comm, &
         ierr)
      call sll_s_test_mpi_error( &
         ierr, &
         'sll_collective_allreduce_int32(): MPI_ALLREDUCE()')
   end subroutine sll_collective_allreduce_int32
 
   subroutine sll_s_collective_allreduce_logical(col, send_buf, count, op, &
                                                 rec_buf)
      type(sll_t_collective_t), pointer       :: col
      logical, dimension(:), intent(in)     :: send_buf ! what would change...
      sll_int32, intent(in)                 :: count
      sll_int32, intent(in)                 :: op
      logical, dimension(:), intent(out)    :: rec_buf  ! would also change
      sll_int32                             :: ierr
      ! FIXME: MORE ARG CHECKING!
      call sll_check_collective_ptr(col)
      call mpi_allreduce(send_buf, rec_buf, count, mpi_logical, op, &
                         col%comm, ierr)
      call sll_s_test_mpi_error(ierr, &
                                'sll_s_collective_allreduce_logical(): MPI_ALLREDUCE()')
   end subroutine sll_s_collective_allreduce_logical
 
   subroutine sll_s_collective_allreduce_sum_3d_real64(col, buffer)
      use mpi
      type(sll_t_collective_t) :: col
      sll_real64, dimension(:, :, :), intent(inout) :: buffer
      sll_real64, dimension(:, :, :), allocatable :: temp
      sll_int32 :: count, ierr
      count = size(buffer)
      allocate (temp(size(buffer, dim=1), size(buffer, dim=2), size(buffer, dim=3)))
      call mpi_allreduce(buffer, temp, count, mpi_double_precision, mpi_sum, &
                         col%comm, ierr)
      sll_assert(ierr == mpi_success)
      buffer = temp
      deallocate (temp)
   end subroutine sll_s_collective_allreduce_sum_3d_real64
 
   subroutine sll_s_collective_reduce_int(col, send_buf, size, op, root_rank, &
                                          rec_buf)
      type(sll_t_collective_t), pointer      :: col
      sll_int32, dimension(:), intent(in) :: send_buf ! what would change...
      sll_int32, intent(in)               :: size
      sll_int32, intent(in)               :: op
      sll_int32, intent(in)                :: root_rank
      sll_int32, dimension(:), intent(in) :: rec_buf  ! would also change
 
      sll_int32                            :: ierr
      ! FIXME: ARG CHECKING!
      call mpi_reduce(send_buf, rec_buf, size, mpi_integer, op, root_rank, &
                      col%comm, ierr)
      call sll_s_test_mpi_error(ierr, &
                                'sll_collective_reduce_real(): MPI_REDUCE()')
   end subroutine sll_s_collective_reduce_int
 
   subroutine sll_s_collective_reduce_real32(col, send_buf, size, op, root_rank, &
                                             rec_buf)
      type(sll_t_collective_t), pointer      :: col
      sll_real32, dimension(:), intent(in) :: send_buf ! what would change...
      sll_int32, intent(in)               :: size
      sll_int32, intent(in)               :: op
      sll_int32, intent(in)                :: root_rank
      sll_real32, dimension(:), intent(in) :: rec_buf  ! would also change
 
      sll_int32                            :: ierr
      ! FIXME: ARG CHECKING!
      call mpi_reduce(send_buf, rec_buf, size, mpi_real, op, root_rank, &
                      col%comm, ierr)
      call sll_s_test_mpi_error(ierr, &
                                'sll_collective_reduce_real(): MPI_REDUCE()')
   end subroutine sll_s_collective_reduce_real32
 
   subroutine sll_s_collective_reduce_real64(col, send_buf, size, op, root_rank, &
                                             rec_buf)
      type(sll_t_collective_t), pointer       :: col
      sll_real64, dimension(:), intent(in)  :: send_buf
      sll_int32, intent(in)                 :: size
      sll_int32, intent(in)                 :: op
      sll_int32, intent(in)                 :: root_rank
      sll_real64, dimension(:), intent(out) :: rec_buf
      sll_int32                             :: ierr
 
      ! FIXME: ARG CHECKING!
      call mpi_reduce(send_buf, rec_buf, size, mpi_double_precision, op, &
                      root_rank, col%comm, ierr)
      call sll_s_test_mpi_error(ierr, &
                                'sll_s_collective_reduce_real64(): MPI_REDUCE()')
   end subroutine sll_s_collective_reduce_real64
 
   subroutine sll_collective_reduce_real64_2d(col, send_buf, size, op, root_rank, &
                                              rec_buf)
      type(sll_t_collective_t), pointer       :: col
      sll_real64, dimension(:, :), intent(in)  :: send_buf
      sll_int32, intent(in)                 :: size
      sll_int32, intent(in)                 :: op
      sll_int32, intent(in)                 :: root_rank
      sll_real64, dimension(:, :), intent(out) :: rec_buf
      sll_int32                             :: ierr
 
      ! FIXME: ARG CHECKING!
      call mpi_reduce(send_buf, rec_buf, size, mpi_double_precision, op, &
                      root_rank, col%comm, ierr)
      call sll_s_test_mpi_error(ierr, &
                                'sll_collective_reduce_real64_2d(): MPI_REDUCE()')
   end subroutine sll_collective_reduce_real64_2d
 
   subroutine sll_collective_reduce_comp64(col, send_buf, size, op, root_rank, &
                                           rec_buf)
      type(sll_t_collective_t), pointer       :: col
      sll_comp64, dimension(:), intent(in)  :: send_buf
      sll_int32, intent(in)                 :: size
      sll_int32, intent(in)                 :: op
      sll_int32, intent(in)                 :: root_rank
      sll_comp64, dimension(:), intent(out) :: rec_buf
      sll_int32                             :: ierr
 
      ! FIXME: ARG CHECKING!
      call mpi_reduce(send_buf, rec_buf, size, mpi_double_complex, op, &
                      root_rank, col%comm, ierr)
      call sll_s_test_mpi_error(ierr, &
                                'sll_collective_reduce_comp64(): MPI_REDUCE()')
   end subroutine sll_collective_reduce_comp64
 
   subroutine sll_collective_reduce_comp32(col, send_buf, size, op, root_rank, &
                                           rec_buf)
      type(sll_t_collective_t), pointer       :: col
      sll_comp32, dimension(:), intent(in)  :: send_buf
      sll_int32, intent(in)                 :: size
      sll_int32, intent(in)                 :: op
      sll_int32, intent(in)                 :: root_rank
      sll_comp32, dimension(:), intent(out) :: rec_buf
      sll_int32                             :: ierr
 
      ! FIXME: ARG CHECKING!
      call mpi_reduce(send_buf, rec_buf, size, mpi_complex, op, &
                      root_rank, col%comm, ierr)
      call sll_s_test_mpi_error(ierr, &
                                'sll_collective_reduce_comp32(): MPI_REDUCE()')
   end subroutine sll_collective_reduce_comp32
 
   subroutine sll_s_collective_reduce_logical(col, send_buf, size, op, root_rank, &
                                              rec_buf)
      type(sll_t_collective_t), pointer      :: col
      LOGICAL, DIMENSION(:), intent(in) :: send_buf ! what would change...
      sll_int32, intent(in)               :: size
      sll_int32, intent(in)               :: op
      sll_int32, intent(in)                :: root_rank
      LOGICAL, DIMENSION(:), intent(in) :: rec_buf  ! would also change
 
      sll_int32                            :: ierr
      ! FIXME: ARG CHECKING!
      call mpi_reduce(send_buf, rec_buf, size, mpi_logical, op, root_rank, &
                      col%comm, ierr)
      call sll_s_test_mpi_error(ierr, &
                                'sll_collective_reduce_real(): MPI_REDUCE()')
   end subroutine sll_s_collective_reduce_logical
 
   subroutine sll_s_collective_alltoall_int(send_buf, send_count, &
                                            recv_count, recv_buf, col)
      sll_int32, dimension(:), intent(in)  :: send_buf
      sll_int32, intent(in)                :: send_count
      sll_int32, intent(in)                :: recv_count
      sll_int32, dimension(:), intent(out) :: recv_buf
      type(sll_t_collective_t), pointer      :: col
      sll_int32                            :: ierr
      call sll_check_collective_ptr(col)
      ! FIXME: MORE ARG CHECKING
      call mpi_alltoall(send_buf, send_count, mpi_integer, &
                        recv_buf, recv_count, mpi_integer, col%comm, ierr)
      call sll_s_test_mpi_error(ierr, &
                                'sll_s_collective_alltoall_int(): MPI_ALLTOALLV()')
 
   end subroutine sll_s_collective_alltoall_int
 
   subroutine sll_collective_alltoall_double(send_buf, send_count, &
                                             recv_count, recv_buf, col)
      sll_real64, dimension(:), intent(in)  :: send_buf
      sll_int32, intent(in)                 :: send_count
      sll_int32, intent(in)                 :: recv_count
      sll_real64, dimension(:), intent(out) :: recv_buf
      type(sll_t_collective_t), pointer       :: col
      sll_int32                             :: ierr
      call sll_check_collective_ptr(col)
      ! FIXME: MORE ARG CHECKING
      call mpi_alltoall(send_buf, send_count, mpi_double_precision, &
                        recv_buf, recv_count, mpi_double_precision, &
                        col%comm, ierr)
      call sll_s_test_mpi_error(ierr, &
                                'sll_collective_alltoall_double(): MPI_ALLTOALL()')
   end subroutine sll_collective_alltoall_double
 
   subroutine sll_collective_alltoall_complex_double(send_buf, send_count, &
                                                     recv_count, recv_buf, col)
      sll_comp64, dimension(:), intent(in)  :: send_buf
      sll_int32, intent(in)                 :: send_count
      sll_int32, intent(in)                 :: recv_count
      sll_comp64, dimension(:), intent(out) :: recv_buf
      type(sll_t_collective_t), pointer       :: col
      sll_int32                             :: ierr
      call sll_check_collective_ptr(col)
      ! FIXME: MORE ARG CHECKING
      call mpi_alltoall(send_buf, send_count, mpi_double_complex, &
                        recv_buf, recv_count, mpi_double_complex, &
                        col%comm, ierr)
      call sll_s_test_mpi_error(ierr, &
                                'sll_collective_alltoall_complex_double(): MPI_ALLTOALL()')
 
   end subroutine sll_collective_alltoall_complex_double
 
   ! Explore making this effectively typeless... need a macro implementation;
   ! pointer arguments won't work...
   subroutine sll_s_collective_alltoallv_real(send_buf, send_cnts, &
                                              send_displs, &
                                              recv_buf, recv_cnts, &
                                              recv_displs, col)
      sll_real32, dimension(:), intent(in) :: send_buf
      sll_int32, dimension(:), intent(in) :: send_cnts
      sll_int32, dimension(:), intent(in) :: send_displs
      sll_real32, dimension(:), intent(out) :: recv_buf
      sll_int32, dimension(:), intent(in) :: recv_cnts
      sll_int32, dimension(:), intent(in) :: recv_displs
      type(sll_t_collective_t), pointer      :: col
      sll_int32                            :: ierr
      ! FIXME: ARG CHECKING!
      call sll_check_collective_ptr(col)
      call mpi_alltoallv(send_buf, send_cnts, send_displs, mpi_real, &
                         recv_buf, recv_cnts, recv_displs, mpi_real, &
                         col%comm, ierr)
      call sll_s_test_mpi_error(ierr, &
                                'sll_s_collective_alltoallv_real(): MPI_ALLTOALLV()')
 
   end subroutine sll_s_collective_alltoallv_real
 
   subroutine sll_s_collective_alltoallv_double(send_buf, send_cnts, &
                                                send_displs, &
                                                recv_buf, recv_cnts, &
                                                recv_displs, col)
      sll_real64, dimension(:), intent(in)  :: send_buf
      sll_int32, dimension(:), intent(in)  :: send_cnts
      sll_int32, dimension(:), intent(in)  :: send_displs
      sll_real64, dimension(:), intent(out) :: recv_buf
      sll_int32, dimension(:), intent(in)  :: recv_cnts
      sll_int32, dimension(:), intent(in)  :: recv_displs
      type(sll_t_collective_t), pointer       :: col
      sll_int32                             :: ierr
      ! FIXME: ARG CHECKING!
      call sll_check_collective_ptr(col)
      call mpi_alltoallv(send_buf, send_cnts, send_displs, &
                         mpi_double_precision, &
                         recv_buf, recv_cnts, recv_displs, &
                         mpi_double_precision, &
                         col%comm, ierr)
      call sll_s_test_mpi_error(ierr, &
                                'sll_s_collective_alltoallv_double(): MPI_ALLTOALLV()')
 
   end subroutine sll_s_collective_alltoallv_double
 
   subroutine sll_collective_alltoallv_complex_double(send_buf, send_cnts, &
                                                      send_displs, &
                                                      recv_buf, recv_cnts, &
                                                      recv_displs, col)
      sll_comp64, dimension(:), intent(in)  :: send_buf
      sll_int32, dimension(:), intent(in)  :: send_cnts
      sll_int32, dimension(:), intent(in)  :: send_displs
      sll_comp64, dimension(:), intent(out) :: recv_buf
      sll_int32, dimension(:), intent(in)  :: recv_cnts
      sll_int32, dimension(:), intent(in)  :: recv_displs
      type(sll_t_collective_t), pointer       :: col
      sll_int32                             :: ierr
      ! FIXME: ARG CHECKING!
      call sll_check_collective_ptr(col)
      call mpi_alltoallv(send_buf, send_cnts, send_displs, &
                         mpi_double_complex, &
                         recv_buf, recv_cnts, recv_displs, &
                         mpi_double_complex, &
                         col%comm, ierr)
      call sll_s_test_mpi_error(ierr, &
                                'sll_collective_alltoallV_complex_double(): MPI_ALLTOALLV()')
 
   end subroutine sll_collective_alltoallv_complex_double
 
   subroutine sll_s_collective_alltoallv_int(send_buf, send_cnts, &
                                             send_displs, &
                                             recv_buf, recv_cnts, &
                                             recv_displs, col)
      sll_int32, dimension(:), intent(in) :: send_buf
      sll_int32, dimension(:), intent(in) :: send_cnts
      sll_int32, dimension(:), intent(in) :: send_displs
      sll_int32, dimension(:), intent(out) :: recv_buf
      sll_int32, dimension(:), intent(in) :: recv_cnts
      sll_int32, dimension(:), intent(in) :: recv_displs
      type(sll_t_collective_t), pointer     :: col
      sll_int32                           :: ierr
      ! FIXME: ARG CHECKING!
      call sll_check_collective_ptr(col)
      call mpi_alltoallv(send_buf(:), send_cnts(:), send_displs(:), mpi_integer, &
                         recv_buf(:), recv_cnts(:), recv_displs(:), mpi_integer, &
                         col%comm, ierr)
      call sll_s_test_mpi_error(ierr, &
                                'sll_s_collective_alltoallv_int(): MPI_ALLTOALLV()')
 
   end subroutine sll_s_collective_alltoallv_int
 
!
!FOR SOME REASON THIS ARGUMENT OF THIS FUNCTION IS DECLARED ALLOCATBLE AND
!POSING PROBLEM WITH F95 STANDARD. WE SHOULD COME BACK TO THIS
!
!warning sll_s_collective_alltoallv_int_simple is not fixed
 
   ! This toutine is a simpler version of the sll_s_collective_alltoallv_int subroutine
   subroutine sll_s_collective_alltoallv_int_simple(send_buf, send_cnts, &
                                                    recv_buf, col)
      sll_int32, dimension(:), intent(in) :: send_buf
      sll_int32, dimension(:), intent(in) :: send_cnts
      !sll_int32, ,allocatable dimension(:) :: recv_buf
      sll_int32, pointer, dimension(:) :: recv_buf
      sll_int32, allocatable, dimension(:) :: send_displs
      sll_int32, allocatable, dimension(:) :: recv_cnts
      sll_int32, allocatable, dimension(:) :: recv_displs
      type(sll_t_collective_t), pointer     :: col
      sll_int32                          :: ierr, size_comm, i, sendcnts_size
      sll_int32                          :: dum
      sendcnts_size = size(send_cnts)
 
      ! FIXME: ARG CHECKING!
      call sll_check_collective_ptr(col)
 
      size_comm = sll_f_get_collective_size(col)
      sll_assert(sendcnts_size .eq. size_comm)
 
      ! Define RECV_CNTS
      sll_allocate(recv_cnts(size_comm), ierr)
      call sll_s_collective_alltoall_int(send_cnts, 1, 1, &
                                         recv_cnts, col)
 
      ! Define RECV_BUF
      dum = sum(recv_cnts)
      sll_allocate(recv_buf(dum), ierr)
 
      ! Define SEND_DISPLS
      sll_allocate(send_displs(size_comm), ierr)
      send_displs(1) = 0
      do i = 2, size_comm
         send_displs(i) = send_displs(i - 1) + send_cnts(i - 1)
      end do
 
      ! Define RECV_DISPLS
      sll_allocate(recv_displs(size_comm), ierr)
      recv_displs(1) = 0
      do i = 2, size_comm
         recv_displs(i) = recv_displs(i - 1) + recv_cnts(i - 1)
      end do
 
      call mpi_alltoallv(send_buf(:), send_cnts(:), send_displs(:), mpi_integer, &
                         recv_buf(:), recv_cnts(:), recv_displs(:), mpi_integer, &
                         col%comm, ierr)
      call sll_s_test_mpi_error(ierr, &
                                'sll_s_collective_alltoallv_int(): MPI_ALLTOALLV()')
      sll_deallocate_array(recv_displs, ierr)
      sll_deallocate_array(send_displs, ierr)
      sll_deallocate_array(recv_cnts, ierr)
   end subroutine sll_s_collective_alltoallv_int_simple
 
   ! Explore if the Irecv calls can be made into collective calls in this module
   !  subroutine sll_collective_Irecv( )
 
   subroutine sll_s_collective_globalsum_array_real64(col, summand, root_rank)
      type(sll_t_collective_t), pointer      :: col
      sll_real64, dimension(:), intent(inout) :: summand
      sll_int32, intent(in), optional                :: root_rank
      sll_real64, dimension(:), allocatable        :: recvsum
      sll_int32:: summand_size
      sll_int32     :: ierr
 
      summand_size = size(summand)
      sll_allocate(recvsum(1:summand_size), ierr)
 
      if (present(root_rank)) then
         !Write the result only to node with root_rank
         call sll_s_collective_reduce_real64(col, summand, summand_size, mpi_sum, root_rank, &
                                             recvsum)
      else
         !Write the result to all nodes
         call sll_collective_allreduce_real64(col, summand, summand_size, mpi_sum, &
                                              recvsum)
      end if
      summand = recvsum
      sll_deallocate_array(recvsum, ierr)
   end subroutine sll_s_collective_globalsum_array_real64
 
   subroutine sll_s_collective_globalsum_array_comp64(col, summand, root_rank)
      type(sll_t_collective_t), pointer      :: col
      sll_comp64, dimension(:), intent(inout) :: summand
      sll_int32, intent(in), optional                :: root_rank
      sll_comp64, dimension(:), allocatable        :: recvsum
      sll_int32:: summand_size
      sll_int32     :: ierr
 
      summand_size = size(summand)
      sll_allocate(recvsum(1:summand_size), ierr)
 
      if (present(root_rank)) then
         !Write the result only to node with root_rank
         call sll_collective_reduce_comp64(col, summand, summand_size, mpi_sum, root_rank, &
                                           recvsum)
      else
         !Write the result to all nodes
         call sll_collective_allreduce_comp64(col, summand, summand_size, mpi_sum, &
                                              recvsum)
      end if
      summand = recvsum
      sll_deallocate_array(recvsum, ierr)
   end subroutine sll_s_collective_globalsum_array_comp64
 
   subroutine sll_collective_globalsum_real64(col, summand, root_rank)
      type(sll_t_collective_t), pointer      :: col
      sll_real64, intent(inout) :: summand
      sll_int32, optional, intent(in)    :: root_rank
      sll_real64, dimension(1) :: summand_tmp
 
      !Promote the scalar to an array
      summand_tmp(1) = summand
      if (present(root_rank)) then
         call sll_s_collective_globalsum_array_real64(col, summand_tmp, root_rank)
      else
         call sll_s_collective_globalsum_array_real64(col, summand_tmp)
      end if
 
      summand = summand_tmp(1)
   end subroutine sll_collective_globalsum_real64
 
   subroutine sll_collective_globalsum_array_real32(col, summand, root_rank)
      type(sll_t_collective_t), pointer      :: col
      sll_real32, dimension(:), intent(inout) :: summand
      sll_int32, intent(in), optional                :: root_rank
      sll_real32, dimension(:), allocatable        :: recvsum
      sll_int32:: summand_size
      sll_int32     :: ierr
 
      summand_size = size(summand)
      sll_allocate(recvsum(1:summand_size), ierr)
 
      if (present(root_rank)) then
         !Write the result only to node with root_rank
         call sll_s_collective_reduce_real32(col, summand, summand_size, mpi_sum, root_rank, &
                                             recvsum)
      else
         !Write the result to all nodes
         call sll_s_collective_allreduce_real32(col, summand, summand_size, mpi_sum, &
                                                recvsum)
      end if
      summand = recvsum
      sll_deallocate_array(recvsum, ierr)
   end subroutine sll_collective_globalsum_array_real32
 
   subroutine sll_collective_globalsum_array_comp32(col, summand, root_rank)
      type(sll_t_collective_t), pointer      :: col
      sll_comp32, dimension(:), intent(inout) :: summand
      sll_int32, intent(in), optional                :: root_rank
      sll_comp32, dimension(:), allocatable        :: recvsum
      sll_int32:: summand_size
      sll_int32     :: ierr
 
      summand_size = size(summand)
      sll_allocate(recvsum(1:summand_size), ierr)
 
      if (present(root_rank)) then
         !Write the result only to node with root_rank
         call sll_collective_reduce_comp32(col, summand, summand_size, mpi_sum, root_rank, &
                                           recvsum)
      else
         !Write the result to all nodes
         call sll_collective_allreduce_comp32(col, summand, summand_size, mpi_sum, &
                                              recvsum)
      end if
      summand = recvsum
      sll_deallocate_array(recvsum, ierr)
   end subroutine sll_collective_globalsum_array_comp32
 
   subroutine sll_collective_globalsum_array_int32(col, summand, root_rank)
      type(sll_t_collective_t), pointer      :: col
      sll_int32, dimension(:), intent(inout) :: summand
      sll_int32, intent(in), optional                :: root_rank
      sll_int32, dimension(:), allocatable        :: recvsum
      sll_int32:: summand_size
      sll_int32     :: ierr
 
      summand_size = size(summand)
      sll_allocate(recvsum(1:summand_size), ierr)
 
      if (present(root_rank)) then
         !Write the result only to node with root_rank
         call sll_s_collective_reduce_int(col, summand, summand_size, mpi_sum, root_rank, &
                                          recvsum)
      else
         !Write the result to all nodes
         call sll_collective_allreduce_int32(col, summand, summand_size, mpi_sum, &
                                             recvsum)
      end if
      summand = recvsum
      sll_deallocate_array(recvsum, ierr)
   end subroutine sll_collective_globalsum_array_int32
 
   subroutine sll_collective_globalsum_comp64(col, summand, root_rank)
      type(sll_t_collective_t), pointer      :: col
      sll_comp64, intent(inout) :: summand
      sll_int32, optional, intent(in)    :: root_rank
      sll_comp64, dimension(1) :: summand_tmp
 
      !Promote the scalar to an array
      summand_tmp(1) = summand
      if (present(root_rank)) then
         call sll_s_collective_globalsum_array_comp64(col, summand_tmp, root_rank)
      else
         call sll_s_collective_globalsum_array_comp64(col, summand_tmp)
      end if
 
      summand = summand_tmp(1)
   end subroutine sll_collective_globalsum_comp64
 
   subroutine sll_collective_globalsum_int32(col, summand, root_rank)
      type(sll_t_collective_t), pointer      :: col
      sll_int32, intent(inout) :: summand
      sll_int32, optional, intent(in)    :: root_rank
      sll_int32, dimension(1) :: summand_tmp
 
      !Promote the scalar to an array
      summand_tmp(1) = summand
      if (present(root_rank)) then
         call sll_collective_globalsum_array_int32(col, summand_tmp, root_rank)
      else
         call sll_collective_globalsum_array_int32(col, summand_tmp)
      end if
 
      summand = summand_tmp(1)
   end subroutine sll_collective_globalsum_int32
 
   subroutine sll_collective_globalsum_comp32(col, summand, root_rank)
      type(sll_t_collective_t), pointer      :: col
      sll_comp32, intent(inout) :: summand
      sll_int32, optional, intent(in)    :: root_rank
      sll_comp32, dimension(1) :: summand_tmp
 
      !Promote the scalar to an array
      summand_tmp(1) = summand
      if (present(root_rank)) then
         call sll_collective_globalsum_array_comp32(col, summand_tmp, root_rank)
      else
         call sll_collective_globalsum_array_comp32(col, summand_tmp)
      end if
 
      summand = summand_tmp(1)
   end subroutine sll_collective_globalsum_comp32
 
   subroutine sll_collective_globalsum_real32(col, summand, root_rank)
      type(sll_t_collective_t), pointer      :: col
      sll_real32, intent(inout) :: summand
      sll_int32, optional, intent(in)    :: root_rank
      sll_real32, dimension(1) :: summand_tmp
 
      !Promote the scalar to an array
      summand_tmp(1) = summand
      if (present(root_rank)) then
         call sll_collective_globalsum_array_real32(col, summand_tmp, root_rank)
      else
         call sll_collective_globalsum_array_real32(col, summand_tmp)
      end if
 
      summand = summand_tmp(1)
   end subroutine sll_collective_globalsum_real32
 
   function sll_f_create_collective(comm)
      use mpi
      type(sll_t_collective_t), pointer :: sll_f_create_collective
      sll_int32, intent(in) :: comm 
 
      sll_int32 :: ierr
 
      sll_allocate(sll_f_create_collective, ierr)
      sll_assert(ierr == mpi_success)
      sll_f_create_collective%comm = comm
      sll_f_create_collective%color = 0
      sll_f_create_collective%key = 0
      ! plain MPI calls will be fine inside "sll_m_collective.F90"
      call mpi_comm_rank(sll_f_create_collective%comm, sll_f_create_collective%rank, ierr)
      sll_assert(ierr == mpi_success)
      call mpi_comm_size(sll_f_create_collective%comm, sll_f_create_collective%size, ierr)
      sll_assert(ierr == mpi_success)
   end function sll_f_create_collective
 
end module sll_m_collective