spmd_sphgat.F

Go to the documentation of this file.

Copyright>        OpenRadioss
Copyright>        Copyright (C) 1986-2025 Altair Engineering Inc.
Copyright>
Copyright>        This program is free software: you can redistribute it and/or modify
Copyright>        it under the terms of the GNU Affero General Public License as published by
Copyright>        the Free Software Foundation, either version 3 of the License, or
Copyright>        (at your option) any later version.
Copyright>
Copyright>        This program is distributed in the hope that it will be useful,
Copyright>        but WITHOUT ANY WARRANTY; without even the implied warranty of
Copyright>        MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
Copyright>        GNU Affero General Public License for more details.
Copyright>
Copyright>        You should have received a copy of the GNU Affero General Public License
Copyright>        along with this program.  If not, see <https://www.gnu.org/licenses/>.
Copyright>
Copyright>
Copyright>        Commercial Alternative: Altair Radioss Software
Copyright>
Copyright>        As an alternative to this open-source version, Altair also offers Altair Radioss
Copyright>        software under a commercial license.  Contact Altair to discuss further if the
Copyright>        commercial version may interest you: https://www.altair.com/radioss/.
!||====================================================================
!||    spmd_sphgat           ../engine/source/mpi/sph/spmd_sphgat.F
!||--- called by ------------------------------------------------------
!||    sphprep               ../engine/source/elements/sph/sphprep.F
!||--- calls      -----------------------------------------------------
!||    ancmsg                ../engine/source/output/message/message.F
!||    arret                 ../engine/source/system/arret.F
!||    spmd_ialltoall        ../engine/source/mpi/generic/spmd_ialltoall.F
!||    spmd_ialltoallv_int   ../engine/source/mpi/generic/spmd_ialltoallv_int.F
!||--- uses       -----------------------------------------------------
!||    message_mod           ../engine/share/message_module/message_mod.F
!||    sphbox                ../engine/share/modules/sphbox.F
!||    spmd_comm_world_mod   ../engine/source/mpi/spmd_comm_world.F90
!||====================================================================
      SUBROUTINE spmd_sphgat(KXSP ,IXSP, WSP2SORT, IREDUCE, LGAUGE)
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE sphbox
      USE message_mod
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      "sphcom.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER KXSP(NISP,*),IXSP(KVOISPH,*),
     .        WSP2SORT(*), IREDUCE, LGAUGE(3,*)
C-----------------------------------------------
C   L o c a l  V a r i a b l e s
C-----------------------------------------------
#ifdef MPI
      INTEGER P, I, NN, N, NN0, NSP, IDEB, INITV, IG,
     .        MSGTYP, LOC_PROC, NBIRECV,
     .        IERROR, IERROR1, LEN, NVOIS1, NVOIS2,
     .        REQ_SD(NSPMD), REQ_SD2(NSPMD),
     .        INDEX(NSPHR), STATUS(MPI_STATUS_SIZE),
     .        MSGOFF,MSGOFF2
       my_real
     .        xsphtmp(sizspt,nsphr), sbufcom(2,nspmd),bufcom(2,nspmd)
 
       INTEGER :: REQUEST_SBUF
 
       INTEGER :: REQUEST_INDEX
       INTEGER, DIMENSION(NSPMD) :: DISPLS_INDEX,DISPLS_LSPHS
       INTEGER, DIMENSION(NSPMD) :: SEND_SIZE_INDEX,RCV_SIZE_LSPHS
       INTEGER ::TOTAL_SEND_SIZE_INDEX,TOTAL_RCV_SIZE_LSPHS
       DATA msgoff/2004/
       DATA msgoff2/2005/
C-----------------------------------------------
C   S o u r c e  L i n e s
C-----------------------------------------------
      loc_proc = ispmd+1
 
C Compactage des structures
C
      ideb = 0
      nn = 0
      DO p = 1, nspmd
        IF(p/=loc_proc)THEN
          sbufcom(1,p) = ireduce
          nsp = psphr(p)
          nn0 = nn
          DO i = 1, nsp
            IF(xsphr(1,i+ideb)<zero)THEN
              nn = nn + 1
              index(i+ideb) = nn
              xsphtmp(1,nn) = -xsphr(1,i+ideb)
              xsphtmp(2,nn) =  xsphr(2,i+ideb)
              xsphtmp(3,nn) =  xsphr(3,i+ideb)
              xsphtmp(4,nn) =  xsphr(4,i+ideb)
              xsphtmp(5,nn) =  xsphr(5,i+ideb)
              xsphtmp(6,nn) =  xsphr(6,i+ideb)
            END IF
          END DO
          ideb = ideb + nsp
          psphr(p) = nn-nn0
          msgtyp = msgoff
          sbufcom(2,p) = psphr(p) 
        ELSE
          sbufcom(1:2,p) = zero
        END IF
      END DO
 
!   -------------------------
!   alltoall communication with uniform size
!   for real array : send : SBUFCOM --> rcv : BUFCOM
      CALL spmd_ialltoall(sbufcom,bufcom,2*nspmd,2, 
     .                     2*nspmd,2,request_sbuf,spmd_comm_world)
!   -------------------------
 
 
      nsphr = nn
C
      ierror = 0
      IF(ALLOCATED(xsphr))DEALLOCATE(xsphr)
C reallocation avec nouveau NSPHR sur la taille totale
      ALLOCATE(xsphr(sizspc,nsphr),stat=ierror1)
      ierror = ierror + ierror1
      IF(ALLOCATED(wacompr))DEALLOCATE(wacompr)
C reallocation WACOMPR en prevision echange spforcp et splissv
      ALLOCATE(wacompr(sizspw,nsphr),stat=ierror1)
      ierror = ierror + ierror1
C reallocation des tags cellule active a recevoir
      IF(ALLOCATED(isphr))DEALLOCATE(isphr)
         
      ALLOCATE(isphr(nsphr),stat=ierror1)
      ierror = ierror + ierror1
      IF(nspcond>0) THEN
C reallocation du tableau gerant les particules symetrisees
        IF(ALLOCATED(ispsymr))DEALLOCATE(ispsymr)
        ALLOCATE(ispsymr(nspcond,nsphr),stat=ierror1)
        ierror = ierror + ierror1
      END IF
      IF(ierror/=0) THEN
        CALL ancmsg(msgid=20,anmode=aninfo)
        CALL arret(2)
      END IF
      xsphr = 0
 
C recopie + init
      IF(nspcond>0)THEN
C si condition de symetrie alors pas d'optimisation sur particules active
C car particule symetrique de particule inactive eventuellement active
        initv = 1
      ELSE
        initv = 0
      END IF
      DO i = 1, nsphr
        xsphr(1,i) = xsphtmp(1,i)
        xsphr(2,i) = xsphtmp(2,i)
        xsphr(3,i) = xsphtmp(3,i)
        xsphr(4,i) = xsphtmp(4,i)
        xsphr(5,i) = xsphtmp(5,i)
        xsphr(6,i) = xsphtmp(6,i)
        isphr(i) = initv
      END DO
C
C Renumerotation + selection particules actives
C
      DO i=1, nsp2sort
        n=wsp2sort(i)
        nvois1 = kxsp(4,n)
        nvois2 = kxsp(5,n)
        DO nn = 1, nvois1
          IF(ixsp(nn,n)<zero) THEN
C renumerotation
            ixsp(nn,n) = -index(-ixsp(nn,n))
C flag differenciant les cellules actives des autres
            isphr(-ixsp(nn,n)) = 1
          END IF
        END DO
        DO nn = nvois1+1,nvois2
          IF(ixsp(nn,n)<zero) THEN
C renumerotation
            ixsp(nn,n) = -index(-ixsp(nn,n))
          END IF
        END DO
      END DO
C
C Gauges : Renumerotation + selection particules actives
C
      DO ig=1, nbgauge
        IF(lgauge(1,ig) > -(numels+1))cycle
        n=numsph+ig
        nvois1 = kxsp(4,n)
        nvois2 = kxsp(5,n)
        DO nn = 1, nvois1
          IF(ixsp(nn,n)<zero) THEN
C renumerotation
            ixsp(nn,n) = -index(-ixsp(nn,n))
C flag differenciant les cellules actives des autres
            isphr(-ixsp(nn,n)) = 1
          END IF
        END DO
        DO nn = nvois1+1,nvois2
          IF(ixsp(nn,n)<zero) THEN
C renumerotation
            ixsp(nn,n) = -index(-ixsp(nn,n))
          END IF
        END DO
      END DO
C
C Renvoi frontiere
C
      ideb = 0
      DO p = 1, nspmd
        nsp = psphr(p)
        IF(loc_proc/=p.AND.nsp>0)THEN
          DO i = 1, nsp
            index(ideb+i) = nint(xsphr(1,i+ideb))
          END DO
          msgtyp = msgoff2                
          ideb = ideb + nsp
        END IF 
      END DO
C
C Reception
C
 
#if _PLMPI
!   -------------------------
!   PLMPI uses MPI-2.x version without non blocking alltoallv comm
!   -------------------------
#else
!   -------------------------
!   wait the previous comm : SBUFCOM/RBUFCOM
      CALL mpi_wait(request_sbuf,status,ierror)
!   -------------------------
#endif
 
      nsphs = 0
      DO p = 1, nspmd
        IF(p/=loc_proc)THEN
          msgtyp = msgoff
          ireduce = max(ireduce,nint(bufcom(1,p)))
          psphs(p) = nint(bufcom(2,p))
          nsphs = nsphs + psphs(p)
        END IF
      END DO
C reallocation liste cellule a envoyer
      IF(ALLOCATED(lsphs))DEALLOCATE(lsphs)
      ALLOCATE(lsphs(nsphs),stat=ierror)
C reallocation des tags cellule active a envoyer
      IF(ALLOCATED(isphs))DEALLOCATE(isphs)
      ALLOCATE(isphs(nsphs),stat=ierror1)
      ierror = ierror + ierror1
      IF(ierror/=0) THEN
        CALL ancmsg(msgid=20,anmode=aninfo)
        CALL arret(2)
      END IF
      ideb = 1
      DO p = 1, nspmd
        IF(p/=loc_proc.AND.psphs(p)>0)THEN
          msgtyp = msgoff2 
          ideb = ideb + psphs(p)
        END IF
      END DO
 
!   -------------------------
!   compute the displacement, number of element
!   and total number of element (send and rcv)
      displs_index(1:nspmd) = 0
      displs_lsphs(1:nspmd) = 0
      send_size_index(1:nspmd) = 0
      rcv_size_lsphs(1:nspmd) = 0
      total_send_size_index = 0
      total_rcv_size_lsphs = 0
 
 
      displs_index(1) = 0
      displs_lsphs(1) = 0
      DO p=1,nspmd
          IF(p/=loc_proc) THEN
            send_size_index(p) = psphr(p)
            rcv_size_lsphs(p) = psphs(p)
          ENDIF
          total_send_size_index = total_send_size_index + send_size_index(p)
          total_rcv_size_lsphs = total_rcv_size_lsphs + rcv_size_lsphs(p)
      ENDDO
      DO p=2,nspmd
          displs_index(p) = displs_index(p-1) + send_size_index(p-1)
          displs_lsphs(p) = displs_lsphs(p-1) + rcv_size_lsphs(p-1)
      ENDDO
!   -------------------------
 
 
!   -------------------------
!   alltoall communication with non-uniform size
!   for integer array : send : INDEX --> rcv : LSPHS
      CALL spmd_ialltoallv_int(index,lsphs,
     .          send_size_index,total_send_size_index,displs_index,
     .          total_rcv_size_lsphs,rcv_size_lsphs,displs_lsphs,
     .          request_index,spmd_comm_world,nspmd)
!   -------------------------
 
#if _PLMPI
!   -------------------------
!   PLMPI uses MPI-2.x version without non blocking alltoallv comm
!   -------------------------
#else
!   -------------------------
!   wait the previous comm
      CALL mpi_wait(request_index,status,ierror)
!   -------------------------
#endif
C        
#endif
      RETURN
      END