spmd_gather_nodal_scalar.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_gather_nodal_scalar_mod   ../engine/source/mpi/nodes/spmd_gather_nodal_scalar.f
!||--- called by ------------------------------------------------------
!||    spmd_exch_output_noda_pext     ../engine/source/mpi/output/spmd_exch_output_noda_pext.F
!||====================================================================
      module spmd_gather_nodal_scalar_mod
      contains
! ======================================================================================================================
!                                                   procedures
! ======================================================================================================================
!! \brief generic subroutine gather all domain array to domain 0 in a global array v_glob(num)
!! \details
!||====================================================================
!||    spmd_gather_nodal_scalar     ../engine/source/mpi/nodes/spmd_gather_nodal_scalar.F
!||--- called by ------------------------------------------------------
!||    spmd_exch_output_noda_pext   ../engine/source/mpi/output/spmd_exch_output_noda_pext.F
!||--- calls      -----------------------------------------------------
!||--- uses       -----------------------------------------------------
!||    constant_mod                 ../common_source/modules/constant_mod.F
!||    precision_mod                ../common_source/modules/precision_mod.F90
!||    spmd_comm_world_mod          ../engine/source/mpi/spmd_comm_world.F90
!||    spmd_recv_mod                ../engine/source/mpi/spmd_recv.F90
!||    spmd_send_mod                ../engine/source/mpi/spmd_send.F90
!||====================================================================
       subroutine spmd_gather_nodal_scalar(v_glob,num,v,numnod,weight,nodglob)
! ----------------------------------------------------------------------------------------------------------------------
!                                                   Modules
! ----------------------------------------------------------------------------------------------------------------------
        use spmd_comm_world_mod, only : spmd_comm_world
        use precision_mod , only : wp
        use spmd_send_mod, only: spmd_send
        use spmd_recv_mod, only: spmd_recv
        use constant_mod , only : zero
! ----------------------------------------------------------------------------------------------------------------------
!                                                   Implicit none
! ----------------------------------------------------------------------------------------------------------------------
          implicit none
! ----------------------------------------------------------------------------------------------------------------------
!                                                   included files
! ----------------------------------------------------------------------------------------------------------------------
#include "spmd.inc"
#include "com01_c.inc"
#include "spmd_c.inc"
#include "task_c.inc"
! ----------------------------------------------------------------------------------------------------------------------
!                                                   Arguments
! ----------------------------------------------------------------------------------------------------------------------
       real(kind=wp) :: v(*)
       INTEGER :: WEIGHT(*),NODGLOB(*),NUM
       integer,intent(in) :: numnod
       real(kind=wp) :: v_glob(num)
! ----------------------------------------------------------------------------------------------------------------------
!                                                   Local Variables
! ----------------------------------------------------------------------------------------------------------------------
#ifdef MPI
      INTEGER STATUS(MPI_STATUS_SIZE),IERROR,MSGOFF
      INTEGER SIZ,MSGTYP,I,K,NG,NREC,MSGOFF2
 
      DATA msgoff/7014/
      DATA msgoff2/7015/
      real(kind=wp), DIMENSION(:) , ALLOCATABLE :: bufsr
      INTEGER, DIMENSION(:) , ALLOCATABLE :: IBUF
! ----------------------------------------------------------------------------------------------------------------------
!                                                   Body
! ----------------------------------------------------------------------------------------------------------------------
       ALLOCATE(bufsr(numnodm), ibuf(numnodm))
       bufsr = zero
       IF (ispmd /= 0) THEN
         siz = 0
         DO i=1,numnod
           IF (weight(i)==1) THEN
             siz = siz + 1
             ibuf(siz) = nodglob(i)
             bufsr(siz) = v(i) 
           END IF
         END DO 
 
         msgtyp = msgoff2
         CALL spmd_send(ibuf,siz,it_spmd(1),msgtyp)
         msgtyp = msgoff 
         CALL spmd_send(bufsr,siz,it_spmd(1),msgtyp)
 
       ELSE
 
          siz = 0
          DO i=1,numnod
            IF (weight(i)==1) THEN 
              siz = siz +1
              ng = nodglob(i)
              v_glob(ng) = v(i)
            ENDIF
          ENDDO
 
          DO i=2,nspmd
            !--- Receiving the full buffer of NODGLOB addresses
            msgtyp = msgoff2
            CALL mpi_probe(it_spmd(i),msgtyp,spmd_comm_world,status,ierror)
            CALL mpi_get_count(status,mpi_integer,siz,ierror)
            CALL spmd_recv(ibuf,siz,it_spmd(i),msgtyp)
            !--- Receiving the floating buffer of NODGLOB addresses
            msgtyp = msgoff 
            CALL spmd_recv(bufsr,siz,it_spmd(i),msgtyp)
            nrec = siz
            DO k = 1, nrec
              ng = ibuf(k)
              v_glob(ng) = bufsr(k)
            ENDDO
          ENDDO
 
       ENDIF
       DEALLOCATE(bufsr,ibuf)
#endif
 
       end subroutine spmd_gather_nodal_scalar
       end module spmd_gather_nodal_scalar_mod