spmd_sphgetv.F File Reference

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

Go to the source code of this file.

Functions/Subroutines
subroutine	spmd_sphgetv (kxsp, spbuf, v, ms, isortsp, ipartsp)

Function/Subroutine Documentation

spmd_sphgetv()

subroutine spmd_sphgetv	(	integer, dimension(nisp,*)	kxsp,
			spbuf,
			v,
			ms,
		integer	isortsp,
		integer, dimension(*)	ipartsp )

Definition at line 34 of file spmd_sphgetv.F.

C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE sphbox
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"
ctmp+1
#include      "task_c.inc"
#include      "sphcom.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER KXSP(NISP,*), ISORTSP, IPARTSP(*)
       my_real
     .        spbuf(nspbuf,*), v(3,*), ms(*)
C-----------------------------------------------
C   L o c a l  V a r i a b l e s
C-----------------------------------------------
#ifdef MPI
      INTEGER P, I, NN, N, IDEB, MSGTYP, LOC_PROC,
     .        IERROR, ICELL, INOD,
     .        REQ_SD(NSPMD), REQ_SD2(NSPMD),
     .        STATUS(MPI_STATUS_SIZE),MSGOFF,MSGOFF2
       my_real, DIMENSION(:,:), ALLOCATABLE :: bufs, bufr
 
      INTEGER, DIMENSION(NSPMD) :: DISPLS_ISPHR,DISPLS_ISPHS
      INTEGER, DIMENSION(NSPMD) :: SEND_SIZE_ISPHR,RCV_SIZE_ISPHS
      INTEGER :: TOTAL_SEND_SIZE_ISPHR,TOTAL_RCV_SIZE_ISPHS
      INTEGER :: REQUEST_ISPHR
 
      INTEGER, DIMENSION(NSPMD) :: DISPLS_BUFS,DISPLS_BUFR
      INTEGER, DIMENSION(NSPMD) :: SEND_SIZE_BUFS,RCV_SIZE_BUFR
      INTEGER :: TOTAL_SEND_SIZE_BUFS,TOTAL_RCV_SIZE_BUFR
      INTEGER :: REQUEST_BUFS
       DATA msgoff/2008/
       DATA msgoff2/2009/
C-----------------------------------------------
C   S o u r c e  L i n e s
C-----------------------------------------------
      loc_proc = ispmd+1
C
C Envoi flag cellules actives
C      
!   -------------------------
!   compute the displacement, number of element
!   and total number of element (send and rcv)
      displs_isphr(1:nspmd) = 0
      displs_isphs(1:nspmd) = 0
      send_size_isphr(1:nspmd) = 0
      rcv_size_isphs(1:nspmd) = 0
      total_send_size_isphr = 0
      total_rcv_size_isphs = 0
 
 
      displs_isphr(1) = 0
      displs_isphs(1) = 0
      DO p=1,nspmd
          send_size_isphr(p) = psphr(p)
          rcv_size_isphs(p) = psphs(p)
          total_send_size_isphr = total_send_size_isphr + send_size_isphr(p)
          total_rcv_size_isphs = total_rcv_size_isphs + rcv_size_isphs(p)
      ENDDO
      DO p=2,nspmd
          displs_isphr(p) = displs_isphr(p-1) + send_size_isphr(p-1)
          displs_isphs(p) = displs_isphs(p-1) + rcv_size_isphs(p-1)
      ENDDO
!   -------------------------
 
!   -------------------------
!   alltoall communication with non-uniform size
!   for integer array : send : ISPHR --> rcv : ISPHS
      CALL spmd_ialltoallv_int(isphr,isphs,
     .          send_size_isphr,total_send_size_isphr,displs_isphr,
     .          total_rcv_size_isphs,rcv_size_isphs,displs_isphs,
     .          request_isphr,spmd_comm_world,nspmd)
!   -------------------------
 
C Envoi V, M, RHO sur cellules actives
C
 
!   -------------------------
!   compute the displacement, number of element
!   and total number of element (send and rcv)
      displs_bufs(1:nspmd) = 0
      displs_bufr(1:nspmd) = 0
      send_size_bufs(1:nspmd) = 0
      rcv_size_bufr(1:nspmd) = 0
      total_send_size_bufs = 0
      total_rcv_size_bufr = 0
 
 
      displs_bufs(1) = 0
      displs_bufr(1) = 0
 
      DO p=1,nspmd
          send_size_bufs(p) = psphs(p)
          rcv_size_bufr(p) = psphr(p)
          total_send_size_bufs = total_send_size_bufs + send_size_bufs(p)
          total_rcv_size_bufr = total_rcv_size_bufr + rcv_size_bufr(p)
      ENDDO
 
      DO p=2,nspmd
          displs_bufs(p) = displs_bufs(p-1) + 7*send_size_bufs(p-1)
          displs_bufr(p) = displs_bufr(p-1) + 7*rcv_size_bufr(p-1)
      ENDDO
 
      ALLOCATE( bufs(7,total_send_size_bufs) )
      ALLOCATE( bufr(7,total_rcv_size_bufr) )
 
      total_send_size_bufs = 7*total_send_size_bufs
      total_rcv_size_bufr = 7*total_rcv_size_bufr
      send_size_bufs(1:nspmd) = 7*send_size_bufs(1:nspmd)
      rcv_size_bufr(1:nspmd) = 7*rcv_size_bufr(1:nspmd)
!   -------------------------
 
#if _PLMPI
!   -------------------------
!   PLMPI uses MPI-2.x version without non blocking alltoallv comm
!   -------------------------
#else
!   -------------------------
!   wait the previous comm : ISPHR --> ISPHS
      CALL mpi_wait(request_isphr,status,ierror)
!   -------------------------
#endif
 
!   -------------------------
!   fill the buffer
      ideb = 0
      nn = 0
      DO p = 1, nspmd
ctmp+1
       nn = 0
       IF(psphs(p)/=0)THEN
        DO n = 1, psphs(p)
          IF(isortsp == 1)THEN
            nn = nn + 1
            icell = lsphs(ideb+n)
            inod = kxsp(3,icell)
            bufs(1,ideb+nn) = spbuf(2,icell)
            bufs(2,ideb+nn) = spbuf(12,icell)
            bufs(3,ideb+nn) = v(1,inod)
            bufs(4,ideb+nn) = v(2,inod)
            bufs(5,ideb+nn) = v(3,inod)
            bufs(6,ideb+nn) = kxsp(2,icell)
            bufs(7,ideb+nn) = ipartsp(icell)
          ELSEIF(isphs(ideb+n)==1) THEN
            nn = nn + 1
            icell = lsphs(ideb+n)
            inod = kxsp(3,icell)
            bufs(1,ideb+nn) = spbuf(2,icell)
            bufs(2,ideb+nn) = spbuf(12,icell)
            bufs(3,ideb+nn) = v(1,inod)
            bufs(4,ideb+nn) = v(2,inod)
            bufs(5,ideb+nn) = v(3,inod)
            bufs(6,ideb+nn) = kxsp(2,icell)      
            bufs(7,ideb+nn) = ipartsp(icell)      
          END IF
        END DO
        ideb = ideb + psphs(p)
ctmp+1
       END IF
      END DO
!   -------------------------
 
!   -------------------------
!   alltoall communication with non-uniform size
!   for real array : send : BUFS --> rcv : BUFR
      CALL spmd_ialltoallv(bufs,bufr,
     .          send_size_bufs,total_send_size_bufs,displs_bufs,
     .          total_rcv_size_bufr,rcv_size_bufr,displs_bufr,
     .          request_bufs,spmd_comm_world,nspmd)
!   -------------------------
C
C Reception V, M, RHO
 
#if _PLMPI
!   -------------------------
!   PLMPI uses MPI-2.x version without non blocking alltoallv comm
!   -------------------------
#else
!   -------------------------
!   wait the previous comm : BUFS --> BUFR
      CALL mpi_wait(request_bufs,status,ierror)
!   -------------------------
#endif
 
C
      ideb = 0
      nn = 0
      DO p = 1, nspmd
 
        IF(psphr(p)/=0)THEN
         nn = 0
          DO n = 1, psphr(p)
            IF(isortsp == 1)THEN
              nn = nn + 1
              xsphr(7,ideb+n) = bufr(1,ideb+nn)
              xsphr(8,ideb+n) = bufr(2,ideb+nn)
              xsphr(9,ideb+n) = bufr(3,ideb+nn)
              xsphr(10,ideb+n)= bufr(4,ideb+nn)
              xsphr(11,ideb+n)= bufr(5,ideb+nn) 
                    xsphr(13,ideb+n)= bufr(6,ideb+nn)
                    xsphr(14,ideb+n)= bufr(7,ideb+nn)
            ELSEIF(isphr(ideb+n)==1) THEN
              nn = nn + 1
              xsphr(7,ideb+n) = bufr(1,ideb+nn)
              xsphr(8,ideb+n) = bufr(2,ideb+nn)
              xsphr(9,ideb+n) = bufr(3,ideb+nn)
              xsphr(10,ideb+n)= bufr(4,ideb+nn)
              xsphr(11,ideb+n)= bufr(5,ideb+nn)
                    xsphr(13,ideb+n)= bufr(6,ideb+nn)      
                    xsphr(14,ideb+n)= bufr(7,ideb+nn)   
            END IF
          END DO
          ideb = ideb + psphr(p)
        END IF
      END DO 
 
      DEALLOCATE( bufs )
      DEALLOCATE( bufr )
 
#endif
      RETURN