EXCHANGE_DOUBLE.f90

Go to the documentation of this file.

!    Copyright (C) 2012 The SPEED FOUNDATION
!    Author: Ilario Mazzieri
!
!    This file is part of SPEED.
!
!    SPEED is free software; you can redistribute it and/or modify it
!    under the terms of the GNU Affero General Public License as
!    published by the Free Software Foundation, either version 3 of the
!    License, or (at your option) any later version.
!
!    SPEED 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
!    Affero General Public License for more details.
!
!    You should have received a copy of the GNU Affero General Public License
!    along with SPEED.  If not, see <http://www.gnu.org/licenses/>.
 
 
     
     subroutine exchange_double(nsend,buff_send,nrecv,buff_recv,&
                                     nproc,proc_send,proc_recv,&
                                     comm,status,ierr,myid)
     
     implicit none
     include 'SPEED.MPI'
     
     integer*4 :: nsend,nrecv,nproc,comm,ierr,tag,myid
     integer*4 :: ip,ir,is
     
     integer*4, dimension(nproc) :: proc_send,proc_recv
     integer*4, dimension(SPEED_STATUS_SIZE) :: status
     integer*4, dimension(nproc) :: request,requests
 
!     real*8, dimension(*) :: buff_send,buff_recv
     real*8, dimension(nsend) :: buff_send
     real*8, dimension(nrecv) :: buff_recv
    
     tag=2120
     
     is = 1
     do ip = 1, nproc
         if (proc_send(ip).gt.0) then
            call mpi_isend(buff_send(is:(is +proc_send(ip) -1)),&
                 proc_send(ip),speed_double,(ip -1),&
                tag,comm,requests(ip),ierr)
         endif
         is = is +proc_send(ip)
      enddo
 
      ir = 1
      do ip = 1, nproc
         if (proc_recv(ip).gt.0) then
            call mpi_irecv(buff_recv(ir:(ir +proc_recv(ip) -1)),&
                 proc_recv(ip),speed_double,(ip -1),&
                 mpi_any_tag,comm,request(ip),ierr)
         endif
         ir = ir +proc_recv(ip)
      enddo
    
     do ip = 1, nproc 
         if (proc_send(ip).gt.0) then 
            call mpi_wait(requests(ip),status,ierr)
         endif
     enddo 
     do ip = 1, nproc
        if (proc_recv(ip).gt.0) then
           call mpi_wait(request(ip),status,ierr)
        endif
     enddo
     
     speed_tag = speed_tag +1
     if (speed_tag.gt.speed_tag_max) speed_tag = speed_tag_min
     
     return
     
     end subroutine exchange_double