! To compile and run 
! mpif90 MPIDTTest.F90
! mpirun -n 3 ./a.out
module precision_m
  integer, parameter :: SP=kind(1.0E0)
  integer, parameter :: DP = kind(1.0D0)
  integer, parameter :: WP = DP
end module precision_m
module mpiDerivedType
  use precision_m
  implicit none
  integer :: MPIVectorType
  integer :: MPIVector_SUM
contains
  subroutine InitMpiDerivedType(VecLen)
    implicit none
#include 'mpif.h'
    integer, intent(in) :: VecLen
    integer :: ierr
    external :: VectorSum
          ! Create MPIVector Type for parallel sum
    if(WP==SP) then
      !call MPI_TYPE_VECTOR(this%mDataPtr%num_vertex,1,1,MPI_REAL, &
      !                     MPIVectorType, ierr)
      call MPI_TYPE_CONTIGUOUS(VecLen,MPI_REAL,MPIVectorType,ierr)
      !print*,'I am creating a sp cont type'
    else
      !call MPI_TYPE_VECTOR(this%mDataPtr%num_vertex,1,1,MPI_DOUBLE_PRECISION, &
      !                     MPIVectorType, ierr)
      call MPI_TYPE_CONTIGUOUS(VecLen,MPI_DOUBLE_PRECISION,MPIVectorType,ierr)
      !print*,'I am creating a dp cont type'
    end if
    call MPI_TYPE_COMMIT(MPIVectorType, ierr)
    !print*,'ierr', ierr
    ! Create Sum operation for this Vector
    call MPI_Op_create(VectorSum,.true.,MPIVector_SUM,ierr)
    !print*,'Sucessfully creaded type and op',MPIVectorType,MPIVector_SUM
  end subroutine InitMpiDerivedType
end module mpiDerivedType

program TestMPIDataType
  use mpiDerivedType
  implicit none
#include 'mpif.h'
  integer :: ierr
  integer :: VecLen
  real(WP), allocatable :: phi(:)
  real(WP), allocatable :: phi_root(:)
  integer :: ic
  integer :: rank, root
  integer :: tag,source,numProc
  integer :: stat(MPI_STATUS_SIZE)

  call MPI_Init(ierr)
  call MPI_Comm_rank(MPI_COMM_WORLD,rank,ierr)
  call MPI_COMM_SIZE(MPI_COMM_WORLD,numProc,ierr)
  vecLen = 3
  call InitMpiDerivedType(VecLen)

  root = 0

  if(rank == root) then
    allocate(phi_root(VecLen))
    do ic=1,VecLen
      phi_root(ic) = (rank+1)*1.0
    end do
  end if
  allocate(phi(VecLen))
  phi=0.0
  tag = 1
  ! Use MPIVectorType for Send and Recv test
  if (rank == root) then
    do ic=1, numProc-1
      !print*,'Sending data to rank',ic
      phi_root = ic*5.0
      call MPI_SEND(phi_root,1, MPIVectorType, ic, tag,MPI_COMM_WORLD,ierr)
      !print*,'Sucessfully sent data to rank',ic
    end do
  endif
  if(rank > 0) then
    !call MPI_RECV(phi,VecLen, MPI_DOUBLE_PRECISION, source, tag,MPI_COMM_WORLD, stat, ierr)
    call MPI_RECV(phi,1, MPIVectorType,root, tag,MPI_COMM_WORLD, stat, ierr)
  end if
  if(rank>0) then
    print *, 'rank= ',rank,' phi= ',phi
    !print*,'Sucess :: MPIVectorType for Send and Recv test',rank
  end if
  if(rank == root)then
    print*,'Testing MPI Reduce operation with derived Type'
    print*,'Add phi from all Procs to phi_root on root proc'
  end if
  call MPI_Reduce(phi,phi_root,1,MPIVectorType,MPIVector_SUM, &
  ROOT,MPI_COMM_WORLD,ierr)
  if(rank == root) then
    print*,'Sucesfully reduce the all phi to root'
    print*,phi_root
  end if
  call MPI_Finalize(ierr)
end program TestMPIDatatype

subroutine VectorSum(inVec,inoutVec,lengt,type)
  use precision_m
  real(WP), intent(in) :: inVec(:)
  real(WP), intent(inout) :: inoutVec(:)
  integer, intent(in) :: lengt
  integer, intent(in) :: type
  integer :: ic
  integer :: inVecLen
  inVecLen = size(inVec,dim=1)
  print*,'Length of inVecLen',inVecLen,lengt
  if(inVecLen/=lengt) then
    print*,'problem with length'
    print*,'type of the problem is',type
    stop
  end if
  do ic=1,lengt
    inoutvec(ic) = inoutvec(ic)+inVec(ic)
  end do
end subroutine VectorSum