mpi_tools_mod.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/.
!||====================================================================
!||    mpi_tools_mod   ../engine/share/modules/mpi_tools_mod.F
!||--- called by ------------------------------------------------------
!||    resol           ../engine/source/engine/resol.F
!||====================================================================
      MODULE mpi_tools_mod 
C-----------------------------------------------
C   m y _ r e a l
C-----------------------------------------------
#include      "my_real.inc"
C-----------------------------------------------
C   D e r i v e d   T y p e   D e f i n i t i o n s
C-----------------------------------------------
      TYPE mpi_min_real_struct 
          my_real :: val
          INTEGER, DIMENSION(:), POINTER  :: tab
          INTEGER :: length_tab
          INTEGER, DIMENSION(:,:), POINTER :: buffer_tab
          my_real, DIMENSION(:), POINTER :: buffer_val
          INTEGER, DIMENSION(:), POINTER :: rq_send_val
          INTEGER, DIMENSION(:), POINTER :: rq_send_tab
          INTEGER, DIMENSION(:), POINTER :: rq_recv_val
          INTEGER, DIMENSION(:), POINTER :: rq_recv_tab
      END TYPE mpi_min_real_struct 
 
      CONTAINS
 
C
C Find the minimum value over all processor
C  - Asynchronous MPI communications: these routines are relevant only
C  for cases where a lot of computations is done between the two calls.
C 
C  TAB = ISPMD 
C  VAL = ...
C  CALL MPI_MIN_REAL_BEGIN(VAL,TAB,1,MY_STRUCT)
C  ! a lot of computations
C  CALL MPI_MIN_REAL_END(VAL2,TAB2,1,MY_STRUCT)
C  ! VAL2 is the min of VAL over the processors
C  ! TAB2 is the TAB of the processor that has the minimum value of VAL
 
!||====================================================================
!||    mpi_min_real_begin    ../engine/share/modules/mpi_tools_mod.F
!||--- called by ------------------------------------------------------
!||    resol                 ../engine/source/engine/resol.F
!||--- calls      -----------------------------------------------------
!||--- uses       -----------------------------------------------------
!||    message_mod           ../engine/share/message_module/message_mod.F
!||    spmd_comm_world_mod   ../engine/source/mpi/spmd_comm_world.F90
!||====================================================================
      SUBROUTINE mpi_min_real_begin(VAL,TAB,STAB,MY_STRUCT) 
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      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"
#include      "r4r8_p.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      "scr02_c.inc"
#include      "scr18_c.inc"
#include      "task_c.inc"
#include      "units_c.inc"
#include      "warn_c.inc"
#include      "timeri_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      my_real, INTENT(IN) :: val  ! value to be minimized
      INTEGER, INTENT(IN) :: STAB !size of integer tab
      INTEGER, INTENT(IN) :: TAB(STAB) !Tab of integer to send
      TYPE(mpi_min_real_struct),  INTENT(INOUT) :: MY_STRUCT 
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER P,IERROR
      INTEGER MSGTYP
#ifdef MPI
 
!     Loop on send and Recv : NSPMD*NSPMD communications
!     Since there is not collective asynchronous communication
!     with msmpi.
 
      ALLOCATE(my_struct%TAB(stab),stat=ierror)
      ALLOCATE(my_struct%BUFFER_TAB(stab,nspmd),stat=ierror)
      ALLOCATE(my_struct%BUFFER_VAL(nspmd) ,stat=ierror)
      ALLOCATE(my_struct%RQ_SEND_VAL(nspmd),stat=ierror)
      ALLOCATE(my_struct%RQ_RECV_VAL(nspmd),stat=ierror)
      ALLOCATE(my_struct%RQ_SEND_TAB(nspmd),stat=ierror)
      ALLOCATE(my_struct%RQ_RECV_TAB(nspmd),stat=ierror)
 
      my_struct%LENGTH_TAB = stab
      my_struct%VAL = val 
      my_struct%TAB(1:stab) = tab(1:stab)
      my_struct%BUFFER_VAL(ispmd+1) = val 
      my_struct%BUFFER_TAB(1:stab,ispmd+1) = tab(1:stab)
 
 
      DO p = 1, nspmd
        IF( p /= ispmd +1 ) THEN
             msgtyp = 17000 
             CALL mpi_irecv(
     1        my_struct%BUFFER_VAL(p) ,1,real,it_spmd(p),msgtyp,
     2         spmd_comm_world,my_struct%RQ_RECV_VAL(p),ierror)
 
             msgtyp = 17001 
             CALL mpi_irecv(
     1        my_struct%BUFFER_TAB(1,p),my_struct%LENGTH_TAB,mpi_integer,it_spmd(p),msgtyp,
     2         spmd_comm_world,my_struct%RQ_RECV_TAB(p),ierror)
        ENDIF
      ENDDO
      DO p = 1, nspmd
        IF( p /= ispmd +1 ) THEN
             msgtyp = 17000 
             CALL mpi_isend(
     1        my_struct%VAL ,1,real,it_spmd(p),msgtyp,
     2         spmd_comm_world,my_struct%RQ_SEND_VAL(p),ierror)
 
             msgtyp = 17001 
             CALL mpi_isend(
     1        my_struct%TAB,my_struct%LENGTH_TAB,mpi_integer,it_spmd(p),msgtyp,
     2         spmd_comm_world,my_struct%RQ_SEND_TAB(p),ierror)
         ENDIF
      ENDDO
 
#endif
      RETURN
      END SUBROUTINE mpi_min_real_begin
 
!||====================================================================
!||    mpi_min_real_end      ../engine/share/modules/mpi_tools_mod.F
!||--- called by ------------------------------------------------------
!||    resol                 ../engine/source/engine/resol.F
!||--- calls      -----------------------------------------------------
!||--- uses       -----------------------------------------------------
!||    message_mod           ../engine/share/message_module/message_mod.F
!||    spmd_comm_world_mod   ../engine/source/mpi/spmd_comm_world.F90
!||====================================================================
      SUBROUTINE mpi_min_real_end(VAL,TAB,STAB,MY_STRUCT) 
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      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"
#include      "r4r8_p.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      "scr02_c.inc"
#include      "scr18_c.inc"
#include      "task_c.inc"
#include      "units_c.inc"
#include      "warn_c.inc"
#include      "timeri_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      my_real, INTENT(INOUT) :: val  ! value to be minimized
      INTEGER, INTENT(IN) :: STAB !size of integer tab
      INTEGER, INTENT(INOUT) :: TAB(STAB) !Tab of integer to send
      TYPE(mpi_min_real_struct),  INTENT(INOUT) :: MY_STRUCT 
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER P,PMIN,IERROR
#ifdef MPI
      INTEGER STATUS (MPI_STATUS_SIZE)
 
       ! WAIT SEND & RECV
      DO p=1,nspmd
        IF(ispmd + 1 /= p) THEN
          CALL mpi_wait(my_struct%RQ_SEND_VAL(p),status,ierror)
          CALL mpi_wait(my_struct%RQ_SEND_TAB(p),status,ierror)
          CALL mpi_wait(my_struct%RQ_RECV_VAL(p),status,ierror)
          CALL mpi_wait(my_struct%RQ_RECV_TAB(p),status,ierror)
        ENDIF
      ENDDO
 
      
      ! Find the minimum value of VAL and the processor that has it
      pmin = 1
      val = my_struct%BUFFER_VAL(1) 
      DO p=2,nspmd
        IF(val > my_struct%BUFFER_VAL(p)) THEN 
          val = my_struct%BUFFER_VAL(p)
          pmin = p
        ENDIF
      ENDDO
 
      ! TAB <- TAB of the processor that has the mini. value of VAL
      tab(1:stab) = my_struct%BUFFER_TAB(1:stab,pmin)
 
      DEALLOCATE(my_struct%TAB)
      DEALLOCATE(my_struct%BUFFER_TAB)
      DEALLOCATE(my_struct%BUFFER_VAL )
      DEALLOCATE(my_struct%RQ_SEND_VAL)
      DEALLOCATE(my_struct%RQ_RECV_VAL)
      DEALLOCATE(my_struct%RQ_SEND_TAB)
      DEALLOCATE(my_struct%RQ_RECV_TAB)
 
#endif
      RETURN
      END SUBROUTINE mpi_min_real_end
 
 
 
      END MODULE mpi_tools_mod