spmd_sphvox.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_sphvox           ../engine/source/mpi/sph/spmd_sphvox.F
!||--- called by ------------------------------------------------------
!||    sphtri0               ../engine/source/elements/sph/sphtri0.F
!||--- calls      -----------------------------------------------------
!||    ancmsg                ../engine/source/output/message/message.F
!||    arret                 ../engine/source/system/arret.F
!||    spmd_iallgather       ../engine/source/mpi/generic/spmd_iallgather.f
!||    spmd_iallgather_int   ../engine/source/mpi/generic/spmd_iallgather_int.F
!||    spmd_ialltoall_int    ../engine/source/mpi/generic/spmd_ialltoall_int.F
!||    spmd_ialltoallv       ../engine/source/mpi/generic/spmd_ialltoallv.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
!||    tri7box               ../engine/share/modules/tri7box.F
!||====================================================================
      SUBROUTINE spmd_sphvox(KXSP ,SPBUF,WSP2SORT,BMINMAL,X)
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      USE sphbox
      USE tri7box
      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      "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,*), WSP2SORT(*)
      my_real 
     .        x(3,*),bminmal(*), spbuf(nspbuf,*)
C-----------------------------------------------
C   L o c a l  V a r i a b l e s
C-----------------------------------------------
#ifdef MPI
      INTEGER P, KK, I, J, NOD, N, MSGTYP, LOC_PROC, NBIRECV,
     .        IERROR, IERROR1, L, LEN, IDEB, INDEXI, NB,
     .        NBX, NBY, NBZ,
     .        IX1, IX2, IY1, IY2, IZ1, IZ2, IX, IY, IZ,
     .        REQ_RB(NSPMD), REQ_SB(NSPMD), REQ_SD(NSPMD),
     .        REQ_RD(NSPMD), REQ_SD2(NSPMD), REQ_SC(NSPMD),
     .        REQ_RC(NSPMD),
     .        IRINDEXI(NSPMD), ISINDEXI(NSPMD), NBO(NSPMD), 
     .        INDEX(NSP2SORT), STATUS(MPI_STATUS_SIZE),
     .        MSGOFF,MSGOFF2,MSGOFF3,MSGOFF4
      my_real 
     .        bminma(6,nspmd),alpha_marge,
     .        xmaxb,ymaxb,zmaxb,xminb,yminb,zminb,
     .        aaa
      TYPE(real_pointer), DIMENSION(NSPMD) :: BUF
      my_real, dimension(:), allocatable :: sbuf,rbuf
      DATA msgoff/2023/
      DATA msgoff2/2024/
      DATA msgoff3/2025/
      DATA msgoff4/2026/
 
      INTEGER :: P_LOC
      INTEGER :: SEND_SIZE_BMINMA
      INTEGER :: REQUEST_BMINMA
      INTEGER :: RCV_SIZE_BMINMA,TOTAL_RCV_SIZE_BMINMA
 
      INTEGER :: SEND_SIZE_CRVOX
      INTEGER :: REQUEST_CRVOX
      INTEGER :: RCV_SIZE_CRVOX,TOTAL_RCV_SIZE_CRVOX
      INTEGER, DIMENSION(0:LRVOXEL,0:LRVOXEL) :: CRVOXEL_LOC
 
      INTEGER, DIMENSION(:,:), ALLOCATABLE :: INDEX_P
      INTEGER, DIMENSION(NSPMD) :: NB_P
      INTEGER :: REQUEST_NBO
 
      INTEGER, DIMENSION(NSPMD) :: SEND_SIZE_SBUF,DISPLS_SBUF
      INTEGER :: TOTAL_SEND_SIZE,TOTAL_RCV_SIZE_RBUF      
      INTEGER, DIMENSION(NSPMD) :: RCV_SIZE_RBUF,DISPLS_RBUF
      INTEGER :: REQUEST_SBUF
 
 
C-----------------------------------------------
C   S o u r c e  L i n e s
C-----------------------------------------------
C
C=======================================================================
C     tag des boites contenant des facettes
C     et creation des candidats
C=======================================================================
      ALLOCATE( index_p(nsp2sort,nspmd) )
      alpha_marge = sqrt(one +spasort)
      loc_proc = ispmd + 1
      psphs = 0
      nbx = lrvoxel
      nby = lrvoxel
      nbz = lrvoxel
 
C
C
      bminma(1,loc_proc) = bminmal(1)
      bminma(2,loc_proc) = bminmal(2)
      bminma(3,loc_proc) = bminmal(3)
      bminma(4,loc_proc) = bminmal(4)
      bminma(5,loc_proc) = bminmal(5)
      bminma(6,loc_proc) = bminmal(6)
C
C   envoi voxel + boite min/max
C
      send_size_bminma = 6
      rcv_size_bminma = 6
      total_rcv_size_bminma = 6*nspmd
!   -------------------------
!   allgather communication with uniform size
!   for real array : send : BMINMAL --> rcv : BMINMAL
      CALL spmd_iallgather(bminmal,bminma,send_size_bminma,
     .                     total_rcv_size_bminma,rcv_size_bminma, 
     .                     request_bminma,spmd_comm_world)
!   -------------------------
 
 
      send_size_crvox = (lrvoxel+1)*(lrvoxel+1)
      rcv_size_crvox = (lrvoxel+1)*(lrvoxel+1)
      total_rcv_size_crvox = (lrvoxel+1)*(lrvoxel+1)*nspmd
      crvoxel_loc(0:lrvoxel,0:lrvoxel) = crvoxel(0:lrvoxel,0:lrvoxel,loc_proc)
 
!   -------------------------
!   allgather communication with uniform size
!   for integer array : send : CRVOXEL_LOC --> rcv : CRVOXEL
      CALL spmd_iallgather_int(crvoxel_loc(0,0),crvoxel(0,0,1),send_size_crvox,
     .                         total_rcv_size_crvox,rcv_size_crvox, 
     .                         request_crvox,spmd_comm_world)
!   -------------------------
C
C   envoi de XREM
C
 
#if _PLMPI
!   -------------------------
!   PLMPI uses MPI-2.x version without non blocking allgather comm
!   -------------------------
#else
!   -------------------------
!   wait the previous comms : BMINMAL --> BMINMAL
!                             CRVOXEL_LOC --> CRVOXEL
      CALL mpi_wait(request_bminma,status,ierror)
      CALL mpi_wait(request_crvox,status,ierror)
!   -------------------------
#endif
 
 
!   -------------------------
!   fill the buffer NBO
      ideb = 1
      nb_p(1:nspmd) = 0
      nbo(1:nspmd) = 0
      DO p = 1, nspmd
        if(p==loc_proc) cycle
        l = ideb
        nb_p(p) = 0
        xmaxb = bminma(1,p)
        ymaxb = bminma(2,p)
        zmaxb = bminma(3,p)
        xminb = bminma(4,p)
        yminb = bminma(5,p)
        zminb = bminma(6,p)
 
        DO i=1, nsp2sort
            n=wsp2sort(i)
            nod=kxsp(3,n)
            aaa = spbuf(1,n)* alpha_marge
            ix1=int(nbx*(x(1,nod)-xminb-aaa)/(xmaxb-xminb))
            ix2=int(nbx*(x(1,nod)-xminb+aaa)/(xmaxb-xminb))
            IF(ix1 > nbx) cycle
            IF(ix2 < 0)   cycle
            iy1=int(nby*(x(2,nod)-yminb-aaa)/(ymaxb-yminb))
            iy2=int(nby*(x(2,nod)-yminb+aaa)/(ymaxb-yminb))
            IF(iy1 > nby) cycle
            IF(iy2 < 0)   cycle
            iz1=int(nbz*(x(3,nod)-zminb-aaa)/(zmaxb-zminb))
            iz2=int(nbz*(x(3,nod)-zminb+aaa)/(zmaxb-zminb))
            IF(iz1 > nbz) cycle
            IF(iz2 < 0)   cycle
 
            ix1=max(0,min(ix1,nbx))
            ix2=min(nbx,max(ix2,0))
            iy1=max(0,min(iy1,nby))
            iy2=min(nby,max(iy2,0))
            iz1=max(0,min(iz1,nbz))
            iz2=min(nbz,max(iz2,0))
 
 
            DO iz = iz1,iz2
             DO iy = iy1,iy2
              DO ix = ix1,ix2
                IF(btest(crvoxel(iy,iz,p),ix)) THEN
                  nb_p(p) = nb_p(p) + 1
                  index_p(nb_p(p),p) = n
                  GOTO 100
                ENDIF
              ENDDO
             ENDDO
            ENDDO
 
 100        CONTINUE
 
        ENDDO
        nbo(p) = nb_p(p)
        psphs(p) = nb_p(p)
      ENDDO
!   -------------------------
 
      psphr(1:nspmd) = 0    
!   -------------------------
!   alltoall communication with uniform size
!   for integer array : send : NBO --> rcv : PSPHR  
      CALL spmd_ialltoall_int(nbo,psphr,nspmd,1, 
     .                        nspmd,1,request_nbo,spmd_comm_world)
!   -------------------------
 
C
      l = 0
      DO p=1,nspmd
        l = l + sizspt*nb_p(p)
      ENDDO
      ALLOCATE(sbuf(l))
 
      l = 0
      DO p = 1, nspmd
        if(p==loc_proc) cycle
        IF (nb_p(p)>0) THEN
          DO j = 1, nb_p(p)
            n = index_p(j,p)
            nod = kxsp(3,n)
            sbuf(l+1) = n
            sbuf(l+2) = spbuf(1,n)
            sbuf(l+3) = x(1,nod)
            sbuf(l+4) = x(2,nod)
            sbuf(l+5) = x(3,nod)
            sbuf(l+6) = kxsp(8,n)
            l = l + sizspt
          END DO
        END IF  
      END DO
 
C
      ! total number of particules to send
      nsphs = 0 
      DO p = 1, nspmd  
         IF(loc_proc /=p) THEN
         nsphs = nsphs + psphs(p) 
         ENDIF
      ENDDO
 
 
      ! Array of local number of particules to send (sorted by proc)
      IF(ALLOCATED(lsphs))DEALLOCATE(lsphs)
      ALLOCATE(lsphs(nsphs),stat=ierror)
 
      IF(ALLOCATED(dks))DEALLOCATE(dks)
      ALLOCATE(dks(nsphs),stat=ierror1)
      ierror = ierror1 + ierror
 
 
      IF(ierror/=0) THEN
        CALL ancmsg(msgid=20,anmode=aninfo)
        CALL arret(2)
      END IF
      lsphs = 0
      dks = -one
      ! Fill LSPHS with local numbers 
      ideb = 0 
      l = 0
      DO p = 1, nspmd  
        IF(loc_proc /=p) THEN
#include "novectorize.inc"
           DO i = 1,psphs(p) 
             ideb = ideb + 1
             lsphs(ideb) = sbuf(l+1) !buf(p)%P(l+1)      
             l = l + sizspt
           ENDDO
        ENDIF
      ENDDO
 
C
      nsphr = 0
      l=0
#if _PLMPI
!   -------------------------
!   PLMPI uses MPI-2.x version without non blocking alltoall comm
!   -------------------------
#else
!   -------------------------
!   wait the previous comm : NBO --> PSPHR
      CALL mpi_wait(request_nbo,status,ierror)
!   -------------------------
#endif
 
      DO p = 1, nspmd
!        PSPHR(P) = 0
        IF(loc_proc/=p) THEN
          IF(psphr(p)>0) THEN
            l=l+1
            isindexi(l)=p
            nsphr = nsphr + psphr(p)
          END IF
        END IF
      END DO
      nbirecv=l
C
!   -------------------------
!   compute the displacement, number of element
!   and total number of element (send and rcv)
      send_size_sbuf(1:nspmd) = 0
      displs_sbuf(1:nspmd) = 0
      rcv_size_rbuf(1:nspmd) = 0
      displs_rbuf(1:nspmd) = 0
 
      displs_sbuf(1) = 0
      send_size_sbuf(1) = sizspt*nb_p(1)
      total_send_size = send_size_sbuf(1)
      DO p=2,nspmd
          send_size_sbuf(p) = sizspt*nb_p(p)
          displs_sbuf(p) = displs_sbuf(p-1) + send_size_sbuf(p-1)
          total_send_size = total_send_size + send_size_sbuf(p)
      ENDDO
 
      rcv_size_rbuf(1) = psphr(1)*sizspt
      total_rcv_size_rbuf = rcv_size_rbuf(1)
      displs_rbuf(1) = 0
      DO p=2,nspmd
          rcv_size_rbuf(p) = psphr(p)*sizspt
          displs_rbuf(p) = displs_rbuf(p-1) + rcv_size_rbuf(p-1)
          total_rcv_size_rbuf = total_rcv_size_rbuf + rcv_size_rbuf(p)
      ENDDO
!   -------------------------
 
      ierror = 0
      IF(ALLOCATED(xsphr))DEALLOCATE(xsphr)
      ALLOCATE(xsphr(sizspt,nsphr),stat=ierror1)
      ierror = ierror1 + ierror
 
      IF(ALLOCATED(dkr))DEALLOCATE(dkr)
      ALLOCATE(dkr(nsphr),stat=ierror1)
      ierror = ierror1 + ierror
 
      IF(ierror/=0) THEN
        CALL ancmsg(msgid=20,anmode=aninfo)
        CALL arret(2)
      END IF
      xsphr = 0
      dkr = -one
 
!   -------------------------
!   alltoall communication with non-uniform size
!   for real array : send : SBUF --> rcv : XSPHR
      CALL spmd_ialltoallv(sbuf,xsphr,send_size_sbuf,total_send_size,displs_sbuf,
     .                     total_rcv_size_rbuf,rcv_size_rbuf,displs_rbuf,
     .                     request_sbuf,spmd_comm_world,nspmd)
!   -------------------------
 
#if _PLMPI
!   -------------------------
!   PLMPI uses MPI-2.x version without non blocking alltoall comm
!   -------------------------
#else
!   -------------------------
!   wait the previous comm : SBUF --> XSPHR
      CALL mpi_wait(request_sbuf,status,ierror)
!   -------------------------
#endif
 
      DEALLOCATE( sbuf )
      DEALLOCATE( index_p )
 
#endif
      RETURN
      END