!--------------------------------------- LICENCE BEGIN -----------------------------------
!Environment Canada - Atmospheric Science and Technology License/Disclaimer,
!                     version 3; Last Modified: May 7, 2008.
!This is free but copyrighted software; you can use/redistribute/modify it under the terms
!of the Environment Canada - Atmospheric Science and Technology License/Disclaimer
!version 3 or (at your option) any later version that should be found at:
!http://collaboration.cmc.ec.gc.ca/science/rpn.comm/license.html
!
!This software 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 above mentioned License/Disclaimer for more details.
!You should have received a copy of the License/Disclaimer along with this software;
!if not, you can write to: EC-RPN COMM Group, 2121 TransCanada, suite 500, Dorval (Quebec),
!CANADA, H9P 1J3; or send e-mail to service.rpn@ec.gc.ca
!-------------------------------------- LICENCE END --------------------------------------


module mpi_mod 10
  implicit none
  save
  private

  ! public variables
  public :: mpi_myid,mpi_nprocs,mpi_myidx,mpi_myidy,mpi_npex,mpi_npey
  ! public procedures
  public :: mpi_initialize,mpi_getptopo,mpi_allreduce_sumreal8scalar

  integer :: mpi_myid   = 0
  integer :: mpi_nprocs = 0
  integer :: mpi_myidx  = 0
  integer :: mpi_myidy  = 0
  integer :: mpi_npex   = 0
  integer :: mpi_npey   = 0

  contains


  subroutine mpi_initialize() 3
    implicit none
    integer :: mythread,numthread,omp_get_thread_num,omp_get_num_threads,rpn_comm_mype
    integer :: npex,npey,ierr

    ! Initilize MPI
    npex=0
    npey=0
    call rpn_comm_init(mpi_getptopo,mpi_myid,mpi_nprocs,npex,npey)
    if(mpi_nprocs.lt.1) then
      mpi_nprocs=1
      mpi_npex=1
      mpi_npey=1
      mpi_myid=0
      mpi_myidx=0
      mpi_myidy=0
    else
      ierr = rpn_comm_mype(mpi_myid,mpi_myidx,mpi_myidy)
      mpi_npex=npex
      mpi_npey=npey
    endif

    write(*,*) 'mpi_initialize: mpi_myid, mpi_myidx, mpi_myidy = ', mpi_myid, mpi_myidx, mpi_myidy

!$OMP PARALLEL PRIVATE(numthread,mythread)
    mythread=omp_get_thread_num()
    numthread=omp_get_num_threads()
    if(mythread.eq.0) write(*,*) 'mpi_initialize: NUMBER OF THREADS=',numthread     
!$OMP END PARALLEL

  end subroutine mpi_initialize



  subroutine mpi_getptopo(npex,npey),2
    implicit none
    integer,intent(out) :: npex,npey

    integer :: ierr
    namelist /ptopo/npex,npey
    integer :: nulnam,fnom,fclos

    npex=1
    npey=1

    nulnam=0
    ierr=fnom(nulnam,'ptopo_nml','FTN+SEQ+R/O',0)
    if(ierr.ne.0) call abort3d('mpi_getptopo: Error opening file ptopo_nml')
    read(nulnam,nml=ptopo,iostat=ierr)
    if(ierr.ne.0) call abort3d('mpi_getptopo: Error reading namelist')
    write(*,nml=ptopo)
    ierr=fclos(nulnam)

  end subroutine mpi_getptopo 



  subroutine mpi_allreduce_sumreal8scalar(sendrecvbuf,com) 31
    implicit none
    real(8) :: sendrecvbuf
    character(len=*) :: com

    integer :: nsize, ierr, root, rank
    real(8), allocatable :: allvalues(:)

    ! do a barrier so that timing on reduce operation is accurate
    call rpn_comm_barrier(com,ierr)

    call tmg_start(16,'allreduce_sum8')

    ! determine number of processors in the communicating group
    call rpn_comm_size(com,nsize,ierr)

    ! determine where to gather the values: first task in group
    call rpn_comm_rank(com,rank,ierr)
    call rpn_comm_allreduce(rank,root,1,"MPI_INTEGER","MPI_MIN",com,ierr)

    ! gather values to be added onto 1 processor
    allocate(allvalues(nsize))
    call rpn_comm_gather(sendrecvbuf, 1, "MPI_DOUBLE_PRECISION", allvalues, 1, "MPI_DOUBLE_PRECISION", root, com, ierr)

    ! sum the values and broadcast to group
    if(rank.eq.root) sendrecvbuf = sum(allvalues(:))
    deallocate(allvalues)
    call rpn_comm_bcast(sendrecvbuf, 1, "MPI_DOUBLE_PRECISION", root, com, ierr)

    call tmg_stop(16)

  end subroutine mpi_allreduce_sumreal8scalar

end module mpi_mod