spmd_getstif25_edg.F File Reference

Go to the source code of this file.

Functions/Subroutines
subroutine	spmd_get_stif25_edg (stfe, nedge, ledge, nin, isendto, ircvfrom, comm, rank, comsize)

Function/Subroutine Documentation

spmd_get_stif25_edg()

subroutine spmd_get_stif25_edg	(		stfe,
		integer, intent(in)	nedge,
		integer, dimension(nledge,nedge), intent(inout)	ledge,
		integer, intent(in)	nin,
		integer, dimension(ninter+1,*), intent(in)	isendto,
		integer, dimension(ninter+1,*), intent(in)	ircvfrom,
		integer	comm,
		integer	rank,
		integer	comsize )

Definition at line 33 of file spmd_getstif25_edg.F.

C-----------------------------------------------
C Description: 
C A domain that own an edge warn others when
C - This edge is deleted
C - this edge is now free (one of the segment is
C   deleted)
C Comment:
C The two communications are done using ALLGATHERV
C to remote domain's LEDGE_FIE even when _SI structures
C are not updated yet according to SPMD_IFRONT
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE tri25ebox
      USE tri7box
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#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      "param_c.inc"
#include      "i25edge_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER, INTENT(IN) :: NEDGE
      INTEGER, INTENT(INOUT) :: LEDGE(NLEDGE,NEDGE)
      INTEGER, INTENT(IN) ::  NIN,
     .        ISENDTO(NINTER+1,*), IRCVFROM(NINTER+1,*)
      INTEGER :: COMM,RANK,COMSIZE
      my_real
     .        stfe(nedge)
C-----------------------------------------------
C   L o c a l  V a r i a b l e s
C-----------------------------------------------
 
      INTEGER, DIMENSION(:), ALLOCATABLE :: BUFFER_SEND,BUFFER_RECV
      INTEGER :: LOCAL_SIZE(COMSIZE,2), TOTAL_SIZE
      INTEGER :: DISPL(COMSIZE)
      INTEGER :: I,J, UID
      INTEGER :: COMSIZE2,LS
      INTEGER :: S_LEFT,S_RIGHT
      INTEGER :: ID_LEFT,ID_RIGHT
#ifdef MPI
      INTEGER DATA MSGOFF/1001/
      INTEGER STATUS(MPI_STATUS_SIZE),IERROR
C-----------------------------------------------
C   S o u r c e  L i n e s
C-----------------------------------------------
C
      IF(.NOT. (nspmd == 1 .OR. comm == mpi_comm_null)) THEN 
!       Count fully broken edge
        local_size(1:comsize,1:2) = 0
        local_size(rank+1,1) = count(stfe(1:nedge) < zero)
       
!       count new free edges
        DO i = 1,nedge
           IF(ledge(ledge_global_id,i) < 0) THEN
             local_size(rank+1,2) = local_size(rank+1,2) + 1 
           ENDIF
        ENDDO
       
        comsize2 = comsize * 2 
        CALL mpi_allreduce(mpi_in_place,
     .                   local_size,
     .                   comsize2,
     .                   mpi_integer,
     .                   mpi_sum,
     .                   comm,
     .                   ierror)
 
 
C
C     Send broken edges 
C 
        total_size = sum(local_size(1:comsize,1))
        IF(total_size > 0) THEN
          ALLOCATE(buffer_send(local_size(rank+1,1)))
          ALLOCATE(buffer_recv(total_size))
          j = 0
          DO i = 1, nedge
            IF( stfe(i) < 0 ) THEN
              j = j + 1 
Cfill with global ID 
            buffer_send(j) = abs(ledge(ledge_global_id,i))
#ifdef D_ES
              IF(abs(ledge(ledge_global_id,i)) == d_es) THEN
                WRITE(6,*) __file__,d_es,"is deleted",stfe(i)
              ENDIF
#endif      
            ENDIF
          ENDDO
          displ(1)=0
          DO i=2,comsize
            displ(i)=local_size(i-1,1)+displ(i-1)
          ENDDO
          CALL mpi_allgatherv(buffer_send,
     .                      local_size(rank+1,1),
     .                      mpi_integer,
     .                      buffer_recv,
     .                      local_size(:,1),
     .                      displ,
     .                      mpi_integer,
     .                      comm,
     .                      ierror)
 
          DEALLOCATE(buffer_send)
C hash table would be better here (UID -> index in LEDEG_FIE)
          DO j = 1, total_size 
            uid = buffer_recv(j)
            DO i = 1,nedge_remote
              IF(ledge_fie(nin)%P(e_global_id,i) == uid) THEN
                stifie(nin)%P(i) = zero
#ifdef D_ES
               IF(uid == d_es) WRITE(6,*) __file__,"STF <- 0"
#endif
              ENDIF
            ENDDO
          ENDDO
          DEALLOCATE(buffer_recv)
        ENDIF
C
C     Send Free edges 
C 
        total_size = sum(local_size(1:comsize,2))
        IF(total_size > 0) THEN
          ALLOCATE(buffer_send(5*local_size(rank+1,2)))
          ALLOCATE(buffer_recv(5*total_size))
          j = 0
          DO i = 1, nedge
            IF( ledge(ledge_global_id,i) < 0 ) THEN
              j = j + 1 
Cfill with global ID 
              buffer_send(5*(j-1)+1) = abs(ledge(ledge_global_id,i))
              buffer_send(5*(j-1)+2) = ledge(ledge_left_seg,i)
              buffer_send(5*(j-1)+3) = ledge(ledge_right_seg,i)
              buffer_send(5*(j-1)+2) = ledge(ledge_left_id,i)
              buffer_send(5*(j-1)+3) = ledge(ledge_right_id,i)
#ifdef D_ES
              IF(abs(ledge(ledge_global_id,i)) == d_es) THEN
                WRITE(6,*) __file__,d_es,"is Free"
              ENDIF
#endif    
            ENDIF
          ENDDO
          DO i=1,comsize
            local_size(i,2) = local_size(i,2) * 5 
          ENDDO
          displ(1)=0
          DO i=2,comsize
            displ(i)=local_size(i-1,2)+displ(i-1)
          ENDDO
          ls = local_size(rank+1,2)
          CALL mpi_allgatherv(buffer_send,
     .                      ls,
     .                      mpi_integer,
     .                      buffer_recv,
     .                      local_size(:,2),
     .                      displ,
     .                      mpi_integer,
     .                      comm,
     .                      ierror)
 
          DEALLOCATE(buffer_send)
C hash table would be better here (UID -> index in LEDEG_FIE)
          DO j = 1, total_size 
            uid =      buffer_recv(5*(j-1)+1)
            s_left =   buffer_recv(5*(j-1)+2)
            s_right =  buffer_recv(5*(j-1)+3)
            id_left =  buffer_recv(5*(j-1)+4)
            id_right = buffer_recv(5*(j-1)+5)
        
            DO i = 1,nedge_remote
              IF(ledge_fie(nin)%P(e_global_id,i) == uid) THEN
                ledge_fie(nin)%P(e_left_seg,i)  = s_left
                ledge_fie(nin)%P(e_right_seg,i) = s_right
                ledge_fie(nin)%P(e_left_id,i)   = id_left 
                ledge_fie(nin)%P(e_right_id,i)  = id_right
              ENDIF
            ENDDO
          ENDDO
          DEALLOCATE(buffer_recv)
        ENDIF
      ENDIF ! NSPMD > 0 and MPI_COMM EXIST
#endif
 
      WHERE(stfe < zero) stfe = zero
      DO i = 1,nedge
         IF(ledge(ledge_global_id,i) < 0) THEN
            ledge(ledge_global_id,i) = abs(ledge(ledge_global_id,i))
         ENDIF
      ENDDO
 
C     DO i = 1,nedge
C       IF(STFE(i) < ZERO) STFE(i) = ZERO
C     ENDDO
      RETURN