spmd_dparrby.F File Reference

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

Go to the source code of this file.

Functions/Subroutines
subroutine	spmd_dparrby (npby, lpby, fr_rby2, iad_rby2, sbufspm, sbufrecvm, sbufspo, sporby, nodglob, weight, itab)

Function/Subroutine Documentation

spmd_dparrby()

subroutine spmd_dparrby	(	integer, dimension(nnpby,*)	npby,
		integer, dimension(*)	lpby,
		integer, dimension(3,*)	fr_rby2,
		integer, dimension(4,*)	iad_rby2,
		integer	sbufspm,
		integer	sbufrecvm,
		integer	sbufspo,
		integer	sporby,
		integer, dimension(*)	nodglob,
		integer, dimension(*)	weight,
		integer, dimension(*)	itab )

Definition at line 33 of file spmd_dparrby.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      "com04_c.inc"
#include      "task_c.inc"
#include      "param_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER NPBY(NNPBY,*),LPBY(*),FR_RBY2(3,*),IAD_RBY2(4,*)
      INTEGER SBUFSPM,SBUFRECVM,SBUFSPO,NODGLOB(*),SPORBY,WEIGHT(*),
     .        ITAB(*)
C-----------------------------------------------
C   L o c a l  V a r i a b l e s
C-----------------------------------------------
#ifdef MPI
      INTEGER PMAIN,JENVOIE,I,J,K,L,S,B,M,P,N,
     .        RECOISDE(NSPMD),
     .        II(2),PTRPO(NSPMD+1),PTRPOO(NSPMD+1)
C
      INTEGER BUFSEND(NSPMD+1),BUFRECP(NSPMD+1),
     .        NBNOD,SIZ,LPO,NSN,PTR,NOD,NN,NR,
     .        SRBY
      INTEGER, DIMENSION(:), ALLOCATABLE :: BUFSPM,BUFRECVM,PORBY,BUFSPO
 
      INTEGER MAINND(NRBYKIN)
 
C   MPI variables
      INTEGER LOC_PROC
      INTEGER MSGOFF,MSGOFF2,MSGTYP,INFO,ATID,ATAG,ALEN
      INTEGER STATUS(MPI_STATUS_SIZE),IERROR,ISD(NSPMD)
C-----------------------------------------------
      DATA msgoff/7018/
      DATA msgoff2/7019/
C-----------------------------------------------
      ALLOCATE(bufspm(sbufspm))
      ALLOCATE(bufrecvm(sbufrecvm+nspmd+1))
      ALLOCATE(porby(sporby))
      ALLOCATE(bufspo(sbufspo))
 
      loc_proc = ispmd + 1
 
C SEND main NODES TO PROC 0
      DO j=1,nrbykin
        pmain = fr_rby2(3,j)
        IF (loc_proc==abs(pmain))THEN
          mainnd(j)=nodglob( npby(1,j) )-1
        ELSE
          mainnd(j)= 0
        ENDIF
      ENDDO
 
      CALL spmd_glob_isum9(mainnd,nrbykin)
      DO i=1,sbufrecvm
        bufrecvm(i)=0
      ENDDO
 
      l = 1
 
      DO i=1,nspmd
 
        bufsend(i)=l
        s = 1
C
        DO j=1,nrbykin
 
          pmain = fr_rby2(3,j)
          nbnod =  fr_rby2(1,j)
 
          IF ( nbnod/=0  .AND.
     .        abs(pmain)==i .AND. loc_proc/=i) THEN
 
            bufspm(l) = j
            bufspm(l+1) = nbnod
            l = l + 2
            nr = 1
            DO k=1,npby(2,j)
              IF (weight(lpby(k+s-1))==1) THEN
                bufspm(l+nr-1) = nodglob(lpby(k+s-1))-1
                nr = nr +1
              ENDIF
            ENDDO
            l = l+nbnod
          ENDIF
          s = s + npby(2,j)
        ENDDO
      ENDDO
      bufsend(nspmd+1)=l
 
      DO i=1,nspmd
 
        IF (iad_rby2(1,i)>0) THEN
 
          msgtyp = msgoff
          b = bufsend(i)
          siz = bufsend(i+1)-bufsend(i)
          CALL mpi_isend(bufspm(b),siz,mpi_integer,it_spmd(i),msgtyp,
     .       spmd_comm_world,isd(i),ierror)
 
        ENDIF
      ENDDO
      l=1
      DO i = 1, nspmd
 
        bufrecp(i)=l
        IF (iad_rby2(2,i)>0) THEN
 
          msgtyp = msgoff
          CALL mpi_probe(it_spmd(i),msgtyp,
     .                  spmd_comm_world,status,ierror)
          CALL mpi_get_count(status,mpi_integer,siz,ierror)
 
          CALL mpi_recv(bufrecvm(l),siz,mpi_integer,it_spmd(i),msgtyp,
     .                spmd_comm_world,status,ierror)
 
          l = l + siz
          bufrecvm(l)=0
          l=l+1
        ENDIF
      ENDDO
      DO i=1,nspmd
 
        IF (iad_rby2(1,i)>0) THEN
          CALL mpi_wait(isd(i),status,ierror)
        ENDIF
      ENDDO
      bufrecp(nspmd+1)=l
      l = 0
      k = 1
      DO i=1,nrbykin
        pmain = fr_rby2(3,i)
        IF (abs(pmain)==loc_proc) THEN
          nbnod = fr_rby2(1,i)
          nn = l+1
          l = l+2
          nr = 1
          DO j = 1,npby(2,i)
            IF (pmain<=0) THEN
              bufspo(l+nr)=nodglob(lpby(k+j-1))-1
              nr = nr+1
            ELSE
              IF (weight(lpby(k+j-1)) ==1) THEN
                bufspo(l+nr)=nodglob(lpby(k+j-1))-1
                nr = nr+1
              ENDIF
            ENDIF
          ENDDO
          l=l+nr-1
          srby = nr-1
          IF (pmain>0) THEN
            DO p=1,nspmd
 
              IF (iad_rby2(2,p)>0) THEN
                m = bufrecp(p)
                IF (bufrecvm(m)==i) THEN
 
                  nbnod=bufrecvm(m+1)
                  bufrecp(p)=bufrecp(p)+2
                  nr = 1
                  DO j=bufrecp(p),bufrecp(p)+nbnod-1
                    bufspo(l+nr)=bufrecvm(j)
                    nr=nr+1
                  ENDDO
                  l = l+nr-1
                  srby = srby + nr-1
                  bufrecp(p)=bufrecp(p)+nbnod
                ENDIF
              ENDIF
            ENDDO
          ENDIF
          bufspo(nn)=i
          bufspo(nn+1)=srby
        ENDIF
        k =k+npby(2,i)
 
      ENDDO
      IF (ispmd/=0 .and .l>0) THEN
        msgtyp = msgoff2
        CALL mpi_send(bufspo,l,mpi_integer,it_spmd(1),msgtyp,
     .       spmd_comm_world,ierror)
      ENDIF
 
      IF (ispmd==0) THEN
        DO i=1,nspmd
          recoisde(i)=0
        ENDDO
        DO i=1,nrbykin
          recoisde(abs(fr_rby2(3,i)))=1
        ENDDO
 
        lpo=1
        ptrpo(1)=lpo
        DO i=1,l
          porby(i)=bufspo(i)
        ENDDO
        lpo = lpo+l
 
        DO i=2,nspmd
 
          IF (recoisde(i)==1) THEN
            msgtyp = msgoff2
            ptrpo(i) = lpo
            CALL mpi_probe(it_spmd(i),msgtyp,
     .                   spmd_comm_world,status,ierror)
            CALL mpi_get_count(status,mpi_integer,siz,ierror)
 
            CALL mpi_recv(porby(lpo),siz,mpi_integer,it_spmd(i),
     .                msgtyp, spmd_comm_world,status,ierror)
            lpo=lpo+siz
          ELSE
            ptrpo(i) = lpo
          ENDIF
        ENDDO
        ptrpo(nspmd+1)=lpo
        ptrpoo=ptrpo
        DO i=1,nrbykin
          ii(1)=mainnd(i)
 
          DO p=1,nspmd
            ptr = ptrpo(p)
            IF(ptr<ptrpoo(p+1))THEN
              IF(porby(ptr)==i)THEN
                nsn = porby(ptr+1)
                ptr = ptr+2
                DO n=1,nsn
                  ii(2)=porby(ptr+n-1)
                  CALL write_i_c(ii,2)
                ENDDO
                ptrpo(p)=ptrpo(p) + nsn +2
              ENDIF
            ENDIF
          ENDDO
        ENDDO
      ENDIF
 
      DEALLOCATE(bufspm)
      DEALLOCATE(bufrecvm)
      DEALLOCATE(porby)
      DEALLOCATE(bufspo)
#endif
      RETURN