spmd_igath.F File Reference

#include "implicit_f.inc"
#include "spmd.inc"
#include "com01_c.inc"
#include "task_c.inc"

Go to the source code of this file.

Functions/Subroutines
subroutine	spmd_igath (srbuf, len, lrecv)

Function/Subroutine Documentation

spmd_igath()

subroutine spmd_igath	(	integer, dimension(*)	srbuf,
		integer	len,
		integer	lrecv )

Definition at line 33 of file spmd_igath.F.

C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
        USE spmd_comm_world_mod, ONLY : spmd_comm_world
#include      "implicit_f.inc"
C-----------------------------------------------------------------
C   M e s s a g e   P a s s i n g
C-----------------------------------------------
#include "spmd.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com01_c.inc"
#include      "task_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER SRBUF(*), LEN, LRECV
C-----------------------------------------------
C   L o c a l  V a r i a b l e s
C-----------------------------------------------
#ifdef MPI
      INTEGER MSGOFF,MSGOFF2,MSGTYP,INFO,I,K,ATID,ATAG,ALEN,RLEN,S1
      INTEGER STATUS(MPI_STATUS_SIZE),IERROR
      DATA msgoff/7013/
      DATA msgoff2/7068/
C-----------------------------------------------
C   S o u r c e  L i n e s
C-----------------------------------------------
      s1 = 1
      IF (ispmd/=0) THEN
        msgtyp=msgoff2
 
        CALL mpi_send(len,s1,mpi_integer,
     .                it_spmd(1),msgtyp,
     .                spmd_comm_world,ierror)
 
        msgtyp=msgoff
        IF(len > 0 ) THEN
          CALL mpi_send(srbuf,len,mpi_integer,
     .                it_spmd(1),msgtyp,
     .                spmd_comm_world,ierror)
        ENDIF
 
      ELSE
 
        lrecv = len
 
        DO i=2,nspmd
            msgtyp=msgoff2
            CALL mpi_recv(rlen,s1,mpi_integer,
     .                    it_spmd(i),msgtyp,
     .                    spmd_comm_world,status,ierror)
            msgtyp=msgoff
 
            IF(rlen > 0 ) THEN
              ! Even though Receive of length = 0 can cost nothing
              ! SRBUF(LRECV+1) must exist
              CALL mpi_recv(srbuf(lrecv+1),rlen,mpi_integer,
     .                    it_spmd(i),msgtyp,
     .                    spmd_comm_world,status,ierror)
 
            ENDIF
            lrecv = lrecv + rlen 
 
        END DO
 
      ENDIF
C
#endif
      RETURN