check_coarse_grid.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/.
!||====================================================================
!||    check_coarse_grid           ../engine/source/interfaces/generic/check_coarse_grid.F
!||--- called by ------------------------------------------------------
!||    spmd_coarse_cell_exchange   ../engine/source/mpi/interfaces/spmd_coarse_cell_exchange.F
!||--- uses       -----------------------------------------------------
!||    inter_sorting_mod           ../engine/share/modules/inter_sorting_mod.F
!||====================================================================
        SUBROUTINE check_coarse_grid(NIN,MAIN_COARSE_GRID,SORT_COMM,ITIED)
!$COMMENT
!       CHECK_COARSE_GRID description :
!       for a given interface, check if the correct processor needs to communicate with a remote processor
!
!       CHECK_COARSE_GRID organization :
!           loop over the processor P and :
!               * if P and the current processor ISPMD colored a common cell --> ISPMD and P need to communicate
!               * if P and the current processor ISPMD did not colored a common cell --> ISPMD and P don't need to communicate
!$ENDCOMMENT
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
        USE inter_sorting_mod
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
#include      "comlock.inc"
C-----------------------------------------------
C   C o m m o n   B l o c k s
C-----------------------------------------------
#include      "com04_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        INTEGER, INTENT(in) :: NIN
        INTEGER, INTENT(in) :: ITIED
        INTEGER, DIMENSION(NB_BOX_COARSE_GRID**3), INTENT(in) :: MAIN_COARSE_GRID
        TYPE(sorting_comm_type), DIMENSION(NINTER), INTENT(inout) :: SORT_COMM   ! structure for interface sorting comm
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------       
        LOGICAL :: KEEP_THIS_PROC,BREAK_
        INTEGER :: I,J,IJK
        INTEGER :: ID_PROC,DISPL        
!   ----------------------------------------
 
        !   allocatio of KEEP_PROC : true if need to send/rcv to proc P
        IF(.NOT.ALLOCATED(sort_comm(nin)%KEEP_PROC)) THEN
            ALLOCATE(sort_comm(nin)%KEEP_PROC(sort_comm(nin)%PROC_NUMBER) )
        ENDIF
        !   loop over the processor of the interface : keep P if at least 1 common cell between P and current proc
        DO i=1,sort_comm(nin)%PROC_NUMBER
            id_proc = sort_comm(nin)%PROC_LIST(i)
            displ = sort_comm(nin)%RCV_DISPLS_COARSE_CELL(i)
            sort_comm(nin)%KEEP_PROC(i) = .false.
            keep_this_proc = .false.
            break_ = .false.
            j = 1
            !   no cell from P --> keep = false
            IF(sort_comm(nin)%RCV_SIZE_COARSE_CELL(i)==0) break_ = .true.
 
            IF(.NOT.break_) THEN
                IF(sort_comm(nin)%GLOBAL_COARSE_CELL(displ+nb_box_coarse_grid**3+1)==0) break_ = .true.
            ENDIF
 
            IF(.NOT.break_) THEN
                ! loop voer the cell of P and check if 1 common cell
                DO j=1,sort_comm(nin)%GLOBAL_COARSE_CELL(displ+nb_box_coarse_grid**3+1)
                    ijk = sort_comm(nin)%GLOBAL_COARSE_CELL(displ+j)
                    IF(main_coarse_grid(ijk)==1) keep_this_proc = .true.
                ENDDO
            ENDIF
            IF(itied/=0) keep_this_proc=.true.
            IF(keep_this_proc) sort_comm(nin)%KEEP_PROC(i) = .true.
        ENDDO
        !   ------------------
        RETURN
        END SUBROUTINE check_coarse_grid