source: CPL/oasis3-mct/branches/OASIS3-MCT_2.0_branch/lib/mct/mct/m_Transfer.F90 @ 4775

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!    Math and Computer Science Division, Argonne National Laboratory   !
!-----------------------------------------------------------------------
! CVS m_Transfer.F90,v 1.13 2008-01-28 06:48:03 jacob Exp
! CVS MCT_2_8_0 
!BOP -------------------------------------------------------------------
!
! !MODULE: m_Transfer - Routines for the MxN transfer of Attribute Vectors
!
! !DESCRIPTION:
! This module provides routines for doing MxN transfer of data in an
! Attribute Vector between two components on separate sets of MPI processes.
! Uses the Router datatype.
!
! !SEE ALSO:
! m_Rearranger

! !INTERFACE:

 module m_Transfer

! !USES:
  use m_MCTWorld, only : MCTWorld
  use m_MCTWorld, only : ThisMCTWorld
  use m_AttrVect, only : AttrVect
  use m_AttrVect, only : nIAttr,nRAttr
  use m_AttrVect, only : Permute, Unpermute
  use m_AttrVect, only : AttrVect_init => init
  use m_AttrVect, only : AttrVect_copy => copy 
  use m_AttrVect, only : AttrVect_clean => clean
  use m_AttrVect, only : lsize
  use m_Router,   only : Router

  use m_mpif90
  use m_die
  use m_stdio

  implicit none

  private ! except

! !PUBLIC MEMBER FUNCTIONS:

  public  :: isend
  public  :: send
  public  :: waitsend
  public  :: irecv
  public  :: recv
  public  :: waitrecv


  interface isend    ; module procedure isend_    ; end interface
  interface send     ; module procedure send_     ; end interface
  interface waitsend ; module procedure waitsend_ ; end interface
  interface irecv    ; module procedure irecv_    ; end interface
  interface recv     ; module procedure recv_     ; end interface
  interface waitrecv ; module procedure waitrecv_ ; end interface

! !DEFINED PARAMETERS:

  integer,parameter                    :: DefaultTag = 600

! !REVISION HISTORY:
! 08Nov02 - R. Jacob <jacob@mcs.anl.gov> - make new module by combining
!           MCT_Send, MCT_Recv and MCT_Recvsum
! 11Nov02 - R. Jacob <jacob@mcs.anl.gov> - Remove MCT_Recvsum and use
!           optional argument in recv_ to do the same thing.
! 23Jul03 - R. Jacob <jacob@mcs.anl.gov> - Move buffers for data and
!           MPI_Reqest and MPI_Status arrays to Router.  Use them.
! 24Jul03 - R. Jacob <jacob@mcs.anl.gov> - Split send_ into isend_ and
!           waitsend_.  Redefine send_.
! 22Jan08 - R. Jacob <jacob@mcs.anl.gov> - Handle unordered GSMaps
!EOP ___________________________________________________________________

  character(len=*),parameter :: myname='MCT::m_Transfer'

  contains

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!    Math and Computer Science Division, Argonne National Laboratory   !
!BOP -------------------------------------------------------------------
!
! !IROUTINE: isend_ - Distributed non-blocking send of an Attribute Vector
!
! !DESCRIPTION:
! Send the the data in the {\tt AttrVect} {\tt aV} to the 
! component specified in the {\tt Router} {\tt Rout}.  An error will 
! result if the size of the attribute vector does not match the size
! parameter stored in the {\tt Router}.
!
! Requires a corresponding {\tt recv\_} or {\tt irecv\_} to be called on the other component.
!
! The optional argument {\tt Tag} can be used to set the tag value used in
! the data transfer.  DefaultTag will be used otherwise. {\tt Tag} must be
! the same in the matching {\tt recv\_} or {\tt irecv\_}.
!
! {\bf N.B.:} The {\tt AttrVect} argument in the corresponding
! {\tt recv\_} call is assumed to have exactly the same attributes
! in exactly the same order as {\tt aV}.
!
! !INTERFACE:

 subroutine isend_(aVin, Rout, Tag)

!
! !USES:
!
      implicit none

! !INPUT PARAMETERS:
!

      Type(AttrVect),target,intent(in)    :: aVin
      Type(Router),         intent(inout) :: Rout
      integer,optional,     intent(in) :: Tag

! !REVISION HISTORY:
! 07Feb01 - R. Jacob <jacob@mcs.anl.gov> - initial prototype
! 08Feb01 - R. Jacob <jacob@mcs.anl.gov> - First working code
! 18May01 - R. Jacob <jacob@mcs.anl.gov> - use MP_Type to determine type in mpi_send
! 07Jun01 - R. Jacob <jacob@mcs.anl.gov> - remove logic to check "direction" of Router.  
!           remove references to ThisMCTWorld%mylrank
! 03Aug01 - E. Ong <eong@mcs.anl.gov> - Explicitly specify the starting address in mpi_send.  
! 15Feb02 - R. Jacob <jacob@mcs.anl.gov> - Use MCT_comm
! 26Mar02 - E. Ong <eong@mcs.anl.gov> - Apply faster copy order
! 26Sep02 - R. Jacob <jacob@mcs.anl.gov> - Check Av against Router lAvsize
! 05Nov02 - R. Jacob <jacob@mcs.anl.gov> - Remove iList, rList arguments.
! 08Nov02 - R. Jacob <jacob@mcs.anl.gov> - MCT_Send is now send_ in m_Transfer
! 11Nov02 - R. Jacob <jacob@mcs.anl.gov> - Use DefaultTag and add optional Tag argument
! 25Jul03 - R. Jacob <jacob@mcs.anl.gov> - Split into isend_ and waitsend_
! 22Jan08 - R. Jacob <jacob@mcs.anl.gov> - Handle unordered GSMaps by permuting before send.
!           remove special case for sending one segment directly from Av which probably
!           wasn't safe.
!EOP ___________________________________________________________________

  character(len=*),parameter :: myname_=myname//'::isend_'
  integer ::    numi,numr,i,j,k,ier
  integer ::    mycomp,othercomp
  integer ::    AttrIndex,VectIndex,seg_start,seg_end
  integer ::    proc,nseg,mytag
  integer ::    mp_Type_rp1
  logical ::    unordered
  type(AttrVect),pointer :: Av
  type(AttrVect),target  :: Avtmp

!--------------------------------------------------------

! Return if no one to send to
  if(Rout%nprocs .eq. 0 ) RETURN

! set up Av to send from
  unordered = associated(Rout%permarr)
  if (unordered) then
     call AttrVect_init(Avtmp,Avin,lsize(Avin))
     call AttrVect_copy(Avin,aVtmp)
     call Permute(aVtmp,Rout%permarr)
     Av => Avtmp
  else
     Av => Avin
  endif

!check Av size against Router
!
  if(lsize(aV) /= Rout%lAvsize) then
    write(stderr,'(2a)') myname_, &
    ' MCTERROR:  AV size not appropriate for this Router...exiting'
    call die(myname_)
  endif

! get ids of components involved in this communication
  mycomp=Rout%comp1id
  othercomp=Rout%comp2id


! find total number of real and integer vectors
! for now, assume we are sending all of them
  Rout%numiatt = nIAttr(aV)
  Rout%numratt = nRAttr(aV)
  numi = Rout%numiatt
  numr = Rout%numratt

!!!!!!!!!!!!!! IF SENDING INTEGER DATA
  if(numi .ge. 1) then

! allocate buffers to hold all outgoing data
  do proc=1,Rout%nprocs
     allocate(Rout%ip1(proc)%pi(Rout%locsize(proc)*numi),stat=ier)
     if(ier/=0) call die(myname_,'allocate(Rout%ip1%pi)',ier)
  enddo

  endif

!!!!!!!!!!!!!! IF SENDING REAL DATA
  if(numr .ge. 1) then

! allocate buffers to hold all outgoing data
  do proc=1,Rout%nprocs
     allocate(Rout%rp1(proc)%pr(Rout%locsize(proc)*numr),stat=ier)
     if(ier/=0) call die(myname_,'allocate(Rout%rp1%pr)',ier)
  enddo

  mp_Type_rp1=MP_Type(Rout%rp1(1)%pr(1))

  endif


  ! Load data going to each processor
  do proc = 1,Rout%nprocs
    
     j=1
     k=1

     ! load the correct pieces of the integer and real vectors
     ! if Rout%num_segs(proc)=1, then this will do one loop
     do nseg = 1,Rout%num_segs(proc)
         seg_start = Rout%seg_starts(proc,nseg)
         seg_end = seg_start + Rout%seg_lengths(proc,nseg)-1
         do VectIndex = seg_start,seg_end
            do AttrIndex = 1,numi
                Rout%ip1(proc)%pi(j) = aV%iAttr(AttrIndex,VectIndex)
                j=j+1
            enddo
            do AttrIndex = 1,numr
                Rout%rp1(proc)%pr(k) = aV%rAttr(AttrIndex,VectIndex)
                k=k+1
            enddo
         enddo
     enddo



     ! Send the integer data
     if(numi .ge. 1) then

        ! set tag
        mytag = DefaultTag
        if(present(Tag)) mytag=Tag


        call MPI_ISEND(Rout%ip1(proc)%pi(1), &
             Rout%locsize(proc)*numi,MP_INTEGER,Rout%pe_list(proc), &
             mytag,ThisMCTWorld%MCT_comm,Rout%ireqs(proc),ier)
           
        if(ier /= 0) call MP_perr_die(myname_,'MPI_ISEND(ints)',ier)

     endif

     ! Send the real data
     if(numr .ge. 1) then

       ! set tag
       mytag = DefaultTag + 1 
       if(present(Tag)) mytag=Tag +1


       call MPI_ISEND(Rout%rp1(proc)%pr(1), &
            Rout%locsize(proc)*numr,mp_Type_rp1,Rout%pe_list(proc), &
            mytag,ThisMCTWorld%MCT_comm,Rout%rreqs(proc),ier)


       if(ier /= 0) call MP_perr_die(myname_,'MPI_ISEND(reals)',ier)

    endif

  enddo

  if (unordered) then
     call AttrVect_clean(aVtmp)
     nullify(aV)
  else
     nullify(aV)
  endif

end subroutine isend_

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!    Math and Computer Science Division, Argonne National Laboratory   !
!BOP -------------------------------------------------------------------
!
! !IROUTINE: waitsend_ - Wait for a distributed non-blocking send to complete
!
! !DESCRIPTION:
! Wait for the data being sent with the {\tt Router} {\tt Rout} to complete.
!
! !INTERFACE:

 subroutine waitsend_(Rout)

!
! !USES:
!
      implicit none

! !INPUT PARAMETERS:
!
      Type(Router),         intent(inout) :: Rout

! !REVISION HISTORY:
! 24Jul03 - R. Jacob <jacob@mcs.anl.gov> - First working version is
!           the wait part of original send_
!EOP ___________________________________________________________________
  character(len=*),parameter :: myname_=myname//'::waitsend_'
  integer ::   proc,ier

! Return if nothing to wait for
  if(Rout%nprocs .eq. 0 ) RETURN

  ! wait for all sends to complete
  if(Rout%numiatt .ge. 1) then

     call MPI_WAITALL(Rout%nprocs,Rout%ireqs,Rout%istatus,ier)
     if(ier /= 0) call MP_perr_die(myname_,'MPI_WAITALL(ints)',ier)

     do proc=1,Rout%nprocs
        deallocate(Rout%ip1(proc)%pi,stat=ier)
        if(ier/=0) call die(myname_,'deallocate(ip1%pi)',ier)
     enddo

  endif

  if(Rout%numratt .ge. 1) then

     call MPI_WAITALL(Rout%nprocs,Rout%rreqs,Rout%rstatus,ier)
     if(ier /= 0) call MP_perr_die(myname_,'MPI_WAITALL(reals)',ier)

     do proc=1,Rout%nprocs
        deallocate(Rout%rp1(proc)%pr,stat=ier)
        if(ier/=0) call die(myname_,'deallocate(rp1%pi)',ier)
     enddo

  endif


end subroutine waitsend_

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!    Math and Computer Science Division, Argonne National Laboratory   !
!BOP -------------------------------------------------------------------
!
! !IROUTINE: send_ - Distributed blocking send of an Attribute Vector
!
! !DESCRIPTION:
! Send the the data in the {\tt AttrVect} {\tt aV} to the 
! component specified in the {\tt Router} {\tt Rout}.  An error will 
! result if the size of the attribute vector does not match the size
! parameter stored in the {\tt Router}.
!
! Requires a corresponding {\tt recv\_} or {\tt irecv\_} to be called on the other
! component.
!
! The optional argument {\tt Tag} can be used to set the tag value used in
! the data transfer.  DefaultTag will be used otherwise. {\tt Tag} must be
! the same in the matching {\tt recv\_} or {\tt irecv\_}.
!
! {\bf N.B.:} The {\tt AttrVect} argument in the corresponding
! {\tt recv} call is assumed to have exactly the same attributes
! in exactly the same order as {\tt aV}.
!
! !INTERFACE:

 subroutine send_(aV, Rout, Tag)

!
! !USES:
!
      implicit none

! !INPUT PARAMETERS:
!

      Type(AttrVect),       intent(in)    :: aV 
      Type(Router),         intent(inout) :: Rout
      integer,optional,     intent(in)    :: Tag

! !REVISION HISTORY:
! 24Jul03 - R. Jacob <jacob@mcs.anl.gov> - New version uses isend and waitsend
!EOP ___________________________________________________________________
  character(len=*),parameter :: myname_=myname//'::send_'

  call isend_(aV,Rout,Tag)

  call waitsend_(Rout)

end subroutine send_

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!    Math and Computer Science Division, Argonne National Laboratory   !
!BOP -------------------------------------------------------------------
!
! !IROUTINE: irecv_ - Distributed receive of an Attribute Vector
!
! !DESCRIPTION:
! Recieve into the {\tt AttrVect} {\tt aV} the data coming from the 
! component specified in the {\tt Router} {\tt Rout}.  An error will 
! result if the size of the attribute vector does not match the size
! parameter stored in the {\tt Router}.
!
! Requires a corresponding {\tt send\_} or {\tt isend\_} to be called 
! on the other component.
!
! The optional argument {\tt Tag} can be used to set the tag value used in
! the data transfer.  DefaultTag will be used otherwise. {\tt Tag} must be
! the same in the matching {\tt send\_} or {\tt isend\_}.
!
! If data for a grid point is coming from more than one process, {\tt recv\_}
! will overwrite the duplicate values leaving the last received value
! in the output aV.  If the optional argument {\tt Sum} is invoked, the output
! will contain the sum of any duplicate values received for the same grid point.
!
! Will return as soon as MPI\_IRECV's are posted.  Call {\tt waitrecv\_} to
! complete the receive operation.
!
! {\bf N.B.:} The {\tt AttrVect} argument in the corresponding
! {\tt send\_} call is assumed to have exactly the same attributes
! in exactly the same order as {\tt aV}.
!
! !INTERFACE:

 subroutine irecv_(aV, Rout, Tag, Sum)
!
! !USES:
!
      implicit none

! !INPUT/OUTPUT PARAMETERS:
!
      Type(AttrVect),       intent(inout) :: aV

! !INPUT PARAMETERS:
!
      Type(Router),         intent(inout) :: Rout
      integer,optional,     intent(in)    :: Tag
      logical,optional,     intent(in)    :: Sum

! !REVISION HISTORY:
! 07Feb01 - R. Jacob <jacob@mcs.anl.gov> - initial prototype
! 07Jun01 - R. Jacob <jacob@mcs.anl.gov> - remove logic to
!           check "direction" of Router.  remove references
!           to ThisMCTWorld%mylrank
! 03Aug01 - E.T. Ong <eong@mcs.anl.gov> - explicity specify starting
!           address in MPI_RECV
! 27Nov01 - E.T. Ong <eong@mcs.anl.gov> - deallocated to prevent
!           memory leaks
! 15Feb02 - R. Jacob <jacob@mcs.anl.gov> - Use MCT_comm
! 26Mar02 - E. Ong <eong@mcs.anl.gov> - Apply faster copy order.
! 26Sep02 - R. Jacob <jacob@mcs.anl.gov> - Check Av against Router lAvsize
! 08Nov02 - R. Jacob <jacob@mcs.anl.gov> - MCT_Recv is now recv_ in m_Transfer
! 11Nov02 - R. Jacob <jacob@mcs.anl.gov> - Add optional Sum argument to
!           tell recv_ to sum data for the same point received from multiple
!           processors.  Replaces recvsum_ which had replaced MCT_Recvsum.
!           Use DefaultTag and add optional Tag argument
! 25Jul03 - R. Jacob <jacob@mcs.anl.gov> - break into irecv_ and waitrecv_
!EOP ___________________________________________________________________

  character(len=*),parameter :: myname_=myname//'::irecv_'
  integer ::    numi,numr,i,j,k,ier
  integer ::    mycomp,othercomp
  integer ::    seg_start,seg_end
  integer ::    proc,numprocs,nseg,mytag
  integer ::    mp_Type_rp1
  logical ::    DoSum

!--------------------------------------------------------

! Return if no one to receive from
  if(Rout%nprocs .eq. 0 ) RETURN

!check Av size against Router
!
  if(lsize(aV) /= Rout%lAvsize) then
    write(stderr,'(2a)') myname_, &
    ' MCTERROR:  AV size not appropriate for this Router...exiting'
    call die(myname_)
  endif

  DoSum = .false.
  if(present(Sum)) DoSum=Sum


  mycomp=Rout%comp1id
  othercomp=Rout%comp2id

!  find total number of real and integer vectors
! for now, assume we are receiving all of them
  Rout%numiatt = nIAttr(aV)
  Rout%numratt = nRAttr(aV)
  numi = Rout%numiatt
  numr = Rout%numratt

!!!!!!!!!!!!!! IF RECEVING INTEGER DATA
  if(numi .ge. 1) then

! allocate buffers to hold all incoming data
  do proc=1,Rout%nprocs
     allocate(Rout%ip1(proc)%pi(Rout%locsize(proc)*numi),stat=ier)
     if(ier/=0) call die(myname_,'allocate(Rout%ip1%pi)',ier)
  enddo

  endif

!!!!!!!!!!!!!! IF RECEIVING REAL DATA
  if(numr .ge. 1) then

! allocate buffers to hold all incoming data
  do proc=1,Rout%nprocs
     allocate(Rout%rp1(proc)%pr(Rout%locsize(proc)*numr),stat=ier)
     if(ier/=0) call die(myname_,'allocate(Rout%rp1%pr)',ier)
  enddo

  mp_Type_rp1=MP_Type(Rout%rp1(1)%pr(1))

  endif

  ! Post all MPI_IRECV
  do proc=1,Rout%nprocs

     ! receive the integer data
     if(numi .ge. 1) then

        ! set tag
        mytag = DefaultTag
        if(present(Tag)) mytag=Tag

        if( Rout%num_segs(proc) > 1 .or. DoSum ) then

           call MPI_IRECV(Rout%ip1(proc)%pi(1), &
                Rout%locsize(proc)*numi,MP_INTEGER,Rout%pe_list(proc), &
                mytag,ThisMCTWorld%MCT_comm,Rout%ireqs(proc),ier)

        else

           call MPI_IRECV(aV%iAttr(1,Rout%seg_starts(proc,1)), &
                Rout%locsize(proc)*numi,MP_INTEGER,Rout%pe_list(proc), &
                mytag,ThisMCTWorld%MCT_comm,Rout%ireqs(proc),ier)

        endif

        if(ier /= 0) call MP_perr_die(myname_,'MPI_IRECV(ints)',ier)

     endif

     ! receive the real data
     if(numr .ge. 1) then

        ! corresponding tag logic must be in send_
        mytag = DefaultTag + 1
        if(present(Tag)) mytag=Tag +1

        if( Rout%num_segs(proc) > 1 .or. DoSum ) then

           call MPI_IRECV(Rout%rp1(proc)%pr(1), &
                Rout%locsize(proc)*numr,mp_Type_rp1,Rout%pe_list(proc), &
                mytag,ThisMCTWorld%MCT_comm,Rout%rreqs(proc),ier)

        else

           call MPI_IRECV(aV%rAttr(1,Rout%seg_starts(proc,1)), &
                Rout%locsize(proc)*numr,mp_Type_rp1,Rout%pe_list(proc), &
                mytag,ThisMCTWorld%MCT_comm,Rout%rreqs(proc),ier)

        endif

        if(ier /= 0) call MP_perr_die(myname_,'MPI_IRECV(reals)',ier)

     endif

  enddo

end subroutine irecv_

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!    Math and Computer Science Division, Argonne National Laboratory   !
!BOP -------------------------------------------------------------------
!
! !IROUTINE: waitrecv_ - Wait for a distributed non-blocking recv to complete
!
! !DESCRIPTION:
! Wait for the data being received with the {\tt Router} {\tt Rout} to complete.
! When done, copy the data into the {\tt AttrVect} {\tt aV}.
!
! !INTERFACE:

 subroutine waitrecv_(aV, Rout, Sum)

!
! !USES:
!
      implicit none

! !INPUT/OUTPUT PARAMETERS:
!
      Type(AttrVect),       intent(inout) :: aV
      Type(Router),         intent(inout) :: Rout

! !INPUT PARAMETERS:
!
      logical,optional,     intent(in)    :: Sum


! !REVISION HISTORY:
! 25Jul03 - R. Jacob <jacob@mcs.anl.gov> - First working version is the wait
!           and copy parts from old recv_.
! 25Jan08 - R. Jacob <jacob@mcs.anl.gov> - Handle unordered GSMaps by
!           applying permutation to received array.
!EOP ___________________________________________________________________
  character(len=*),parameter :: myname_=myname//'::waitrecv_'
  integer ::   proc,ier,j,k,nseg
  integer ::   AttrIndex,VectIndex,seg_start,seg_end
  logical ::   DoSum
  logical ::   unordered

! Return if nothing to wait for
  if(Rout%nprocs .eq. 0 ) RETURN

!check Av size against Router
!
  if(lsize(aV) /= Rout%lAvsize) then
    write(stderr,'(2a)') myname_, &
    ' MCTERROR:  AV size not appropriate for this Router...exiting'
    call die(myname_)
  endif

  unordered = associated(Rout%permarr)

  DoSum = .false.
  if(present(Sum)) DoSum=Sum

  ! wait for all recieves to complete
  if(Rout%numiatt .ge. 1)  then

    call MPI_WAITALL(Rout%nprocs,Rout%ireqs,Rout%istatus,ier)
    if(ier /= 0) call MP_perr_die(myname_,'MPI_WAITALL(ints)',ier)

  endif

  if(Rout%numratt .ge. 1) then

    call MPI_WAITALL(Rout%nprocs,Rout%rreqs,Rout%rstatus,ier)
    if(ier /= 0) call MP_perr_die(myname_,'MPI_WAITALL(reals)',ier)

  endif

  ! Load data which came from each processor
  do proc=1,Rout%nprocs

     if( (Rout%num_segs(proc) > 1) .or. DoSum ) then

        j=1
        k=1

        if(DoSum) then
        ! sum the correct pieces of the integer and real vectors
          do nseg = 1,Rout%num_segs(proc)
           seg_start = Rout%seg_starts(proc,nseg)
           seg_end = seg_start + Rout%seg_lengths(proc,nseg)-1
           do VectIndex = seg_start,seg_end
              do AttrIndex = 1,Rout%numiatt
                 aV%iAttr(AttrIndex,VectIndex)= &
                 aV%iAttr(AttrIndex,VectIndex)+Rout%ip1(proc)%pi(j)
                 j=j+1
              enddo
              do AttrIndex = 1,Rout%numratt
                 aV%rAttr(AttrIndex,VectIndex)= &
                 aV%rAttr(AttrIndex,VectIndex)+Rout%rp1(proc)%pr(k)
                 k=k+1
              enddo
           enddo
          enddo
        else
        ! load the correct pieces of the integer and real vectors
          do nseg = 1,Rout%num_segs(proc)
           seg_start = Rout%seg_starts(proc,nseg)
           seg_end = seg_start + Rout%seg_lengths(proc,nseg)-1
           do VectIndex = seg_start,seg_end
              do AttrIndex = 1,Rout%numiatt
                 aV%iAttr(AttrIndex,VectIndex)=Rout%ip1(proc)%pi(j)
                 j=j+1
              enddo
              do AttrIndex = 1,Rout%numratt
                 aV%rAttr(AttrIndex,VectIndex)=Rout%rp1(proc)%pr(k)
                 k=k+1
              enddo
           enddo
          enddo
        endif
        
     endif

  enddo

!........................WAITANY METHOD................................
!
!....NOTE: Make status argument a 1-dimensional array
!  ! Load data which came from each processor
!  do numprocs = 1,Rout%nprocs
!     ! Load the integer data
!     if(Rout%numiatt .ge. 1) then
!       call MPI_WAITANY(Rout%nprocs,Rout%ireqs,proc,Rout%istatus,ier)
!       if(ier /= 0) call MP_perr_die(myname_,'MPI_WAITANY(ints)',ier)
!       j=1
!       ! load the correct pieces of the integer vectors
!       do nseg = 1,Rout%num_segs(proc)
!          seg_start = Rout%seg_starts(proc,nseg)
!          seg_end = seg_start + Rout%seg_lengths(proc,nseg)-1
!          do VectIndex = seg_start,seg_end
!             do AttrIndex = 1,Rout%numiatt
!                aV%iAttr(AttrIndex,VectIndex)=Rout%ip1(proc)%pi(j)
!                j=j+1
!             enddo
!          enddo
!       enddo
!     endif
!     ! Load the real data
!     if(numr .ge. 1) then
!       call MPI_WAITANY(Rout%nprocs,Rout%rreqs,proc,Rout%rstatus,ier)
!       if(ier /= 0) call MP_perr_die(myname_,'MPI_WAITANY(reals)',ier)
!       k=1
!       ! load the correct pieces of the real vectors
!       do nseg = 1,Rout%num_segs(proc)
!          seg_start = Rout%seg_starts(proc,nseg)
!          seg_end = seg_start + Rout%seg_lengths(proc,nseg)-1
!          do VectIndex = seg_start,seg_end
!             do AttrIndex = 1,numr
!                aV%rAttr(AttrIndex,VectIndex)=Rout%rp1(proc)%pr(k)
!                k=k+1
!             enddo
!          enddo
!       enddo
!     endif
!  enddo
!........................................................................

  ! Deallocate all structures
  if(Rout%numiatt .ge. 1) then

     ! Deallocate the receive buffers
     do proc=1,Rout%nprocs
        deallocate(Rout%ip1(proc)%pi,stat=ier)
        if(ier/=0) call die(myname_,'deallocate(Rout%ip1%pi)',ier)
     enddo

  endif

  if(Rout%numratt .ge. 1) then

     ! Deallocate the receive buffers
     do proc=1,Rout%nprocs
        deallocate(Rout%rp1(proc)%pr,stat=ier)
        if(ier/=0) call die(myname_,'deallocate(Rout%rp1%pr)',ier)
     enddo

  endif

  if (unordered) call Unpermute(aV,Rout%permarr)

end subroutine waitrecv_

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!    Math and Computer Science Division, Argonne National Laboratory   !
!BOP -------------------------------------------------------------------
!
! !IROUTINE: recv_ - Distributed receive of an Attribute Vector
!
! !DESCRIPTION:
! Recieve into the {\tt AttrVect} {\tt aV} the data coming from the 
! component specified in the {\tt Router} {\tt Rout}.  An error will 
! result if the size of the attribute vector does not match the size
! parameter stored in the {\tt Router}.
!
! Requires a corresponding {\tt send\_} or {\tt isend\_}to be called 
! on the other component.
!
! The optional argument {\tt Tag} can be used to set the tag value used in
! the data transfer.  DefaultTag will be used otherwise. {\tt Tag} must be
! the same in the matching {\tt send\_}
!
! If data for a grid point is coming from more than one process, {\tt recv\_}
! will overwrite the duplicate values leaving the last received value
! in the output aV.  If the optional argument {\tt Sum} is invoked, the output
! will contain the sum of any duplicate values received for the same grid point.
!
! Will not return until all data has been received.
!
! {\bf N.B.:} The {\tt AttrVect} argument in the corresponding
! {\tt send\_} call is assumed to have exactly the same attributes
! in exactly the same order as {\tt aV}.
!
! !INTERFACE:

 subroutine recv_(aV, Rout, Tag, Sum)
!
! !USES:
!
      implicit none

! !INPUT/OUTPUT PARAMETERS:
!
      Type(AttrVect),       intent(inout) :: aV

! !INPUT PARAMETERS:
!
      Type(Router),         intent(inout)    :: Rout
      integer,optional,     intent(in)    :: Tag
      logical,optional,     intent(in)    :: Sum

! !REVISION HISTORY:
! 25Jul03 - R. Jacob <jacob@mcs.anl.gov> - Rewrite using irecv and waitrecv
!EOP ___________________________________________________________________
  character(len=*),parameter :: myname_=myname//'::recv_'

  call irecv_(aV,Rout,Tag,Sum)

  call waitrecv_(aV,Rout,Sum)

end subroutine recv_


end module m_Transfer