spmd_coarse_cell_exchange.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_coarse_cell_exchange   ../engine/source/mpi/interfaces/spmd_coarse_cell_exchange.F
!||--- calls      -----------------------------------------------------
!||    check_coarse_grid           ../engine/source/interfaces/generic/check_coarse_grid.F
!||    spmd_ialltoallv_int         ../engine/source/mpi/generic/spmd_ialltoallv_int.F
!||--- uses       -----------------------------------------------------
!||    inter_sorting_mod           ../engine/share/modules/inter_sorting_mod.F
!||====================================================================
        SUBROUTINE spmd_coarse_cell_exchange(NB_INTER_SORTED,LIST_INTER_SORTED,IRECVFROM,ISENDTO,MODE,
     .              IPARI,SORT_COMM,NB_REQUEST_COARSE_CELL,ARRAY_REQUEST_COARSE_CELL,LIST_INTER_COARSE_CELL)
!$COMMENT
!       SPMD_COARSE_CELL_EXCHANGE description :
!       for large interfaces : communication of coarse cells with alltoll mpi comm 
!       and check if 2 procs need to echange data
!
!       SPMD_COARSE_CELL_EXCHANGE organization :
!           First part MODE=1 : alltoall comm --> exchange of coarse cell
!           Second part MODE=2 : wait & check if 2 processors for a given interface need to echange data
!$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"
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      "param_c.inc"
#include      "task_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        INTEGER, INTENT(in) :: NB_INTER_SORTED        !   number of interfaces that need to be sorted
        INTEGER, DIMENSION(NB_INTER_SORTED), INTENT(in) :: LIST_INTER_SORTED   !   list of interfaces that need to be sorted
        INTEGER, INTENT(in) :: MODE ! mode : 1 --> end/rcv / 2 --> wait + computation
        INTEGER, DIMENSION(NINTER+1,NSPMD+1), INTENT(in) :: ISENDTO,IRECVFROM ! array for S and R : isendto = nsn ; IRECVFROM = nmn
        INTEGER, DIMENSION(NPARI,NINTER), INTENT(in) ::  IPARI !   interface data
        TYPE(sorting_comm_type), DIMENSION(NINTER), INTENT(inout) :: SORT_COMM   ! structure for interface sorting comm
        INTEGER, INTENT(inout) :: NB_REQUEST_COARSE_CELL ! number of request
        INTEGER, DIMENSION(NB_INTER_SORTED), INTENT(inout) :: ARRAY_REQUEST_COARSE_CELL ! array of request
        INTEGER, DIMENSION(NB_INTER_SORTED), INTENT(inout) :: LIST_INTER_COARSE_CELL    ! list of interface
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
#ifdef MPI        
        INTEGER :: KK,NIN,I,J
        INTEGER :: P,P_LOC,LOCAL_RANK
        INTEGER :: MY_SIZE,OLD_POINTER
        INTEGER :: ADRESS,SHIFT_
 
        INTEGER IERROR1,STATUS(MPI_STATUS_SIZE),IERROR
        INTEGER :: SIZE_CELL_LIST,TOTAL_RCV_SIZE,TOTAL_SEND_SIZE
        INTEGER :: LOC_PROC,ID_PROC
        INTEGER :: COUNT_COMM_SIZE_CELL,ID_COMM
        INTEGER :: ITIED
!   ----------------------------------------
        loc_proc = ispmd + 1
        !   -------------------------
        !   MODE=1 : alltoall comm --> exchange of coarse cell
        IF(mode==1) THEN
          nb_request_coarse_cell = 0
          DO kk=1,nb_inter_sorted
            nin = list_inter_sorted(kk)
            array_request_coarse_cell(kk) = mpi_request_null
            IF(sort_comm(nin)%PROC_NUMBER>nspmd/2) THEN
                IF(irecvfrom(nin,loc_proc)==0.AND.isendto(nin,loc_proc)==0) cycle
 
                IF(.NOT.ALLOCATED(sort_comm(nin)%SEND_SIZE_COARSE_CELL)) THEN
                    my_size = sort_comm(nin)%PROC_NUMBER
                    ALLOCATE(sort_comm(nin)%SEND_SIZE_COARSE_CELL(my_size))
                ENDIF
 
                IF(.NOT.ALLOCATED(sort_comm(nin)%RCV_SIZE_COARSE_CELL)) THEN
                    my_size = sort_comm(nin)%PROC_NUMBER
                    ALLOCATE(sort_comm(nin)%RCV_SIZE_COARSE_CELL(my_size))
                ENDIF
 
                IF(.NOT.ALLOCATED(sort_comm(nin)%SEND_DISPLS_COARSE_CELL)) THEN
                    my_size = sort_comm(nin)%PROC_NUMBER
                    ALLOCATE(sort_comm(nin)%SEND_DISPLS_COARSE_CELL(my_size))
                ENDIF
 
                IF(.NOT.ALLOCATED(sort_comm(nin)%RCV_DISPLS_COARSE_CELL)) THEN
                    my_size = sort_comm(nin)%PROC_NUMBER
                    ALLOCATE(sort_comm(nin)%RCV_DISPLS_COARSE_CELL(my_size))
                ENDIF
 
!isendto = nsn
!IRECVFROM = nmn
                total_rcv_size = 0
                DO i=1,sort_comm(nin)%PROC_NUMBER
                    id_proc = sort_comm(nin)%PROC_LIST(i)
                    sort_comm(nin)%SEND_SIZE_COARSE_CELL(i) = 0
                    IF(isendto(nin,loc_proc)>0.AND.irecvfrom(nin,id_proc)>0) THEN    !   nmn of proc ID_PROC >0
                        sort_comm(nin)%SEND_SIZE_COARSE_CELL(i) = nb_box_coarse_grid**3 + 1
                    ENDIF
                    sort_comm(nin)%SEND_DISPLS_COARSE_CELL(i) = 0
 
                    sort_comm(nin)%RCV_SIZE_COARSE_CELL(i) = 0
                    IF(irecvfrom(nin,loc_proc)>0.AND.isendto(nin,id_proc)>0) THEN   !   nmn of current proc >0
                        sort_comm(nin)%RCV_SIZE_COARSE_CELL(i) = nb_box_coarse_grid**3 + 1
                    ENDIF
                    sort_comm(nin)%RCV_DISPLS_COARSE_CELL(i) = total_rcv_size
                    IF(irecvfrom(nin,loc_proc)>0.AND.isendto(nin,id_proc)>0) THEN   !   nmn of current proc >0
                        total_rcv_size = total_rcv_size + nb_box_coarse_grid**3 + 1
                    ENDIF
                ENDDO
 
                IF(.NOT.ALLOCATED(sort_comm(nin)%GLOBAL_COARSE_CELL ) )THEN                
                    ALLOCATE(sort_comm(nin)%GLOBAL_COARSE_CELL(total_rcv_size))
                ENDIF
                sort_comm(nin)%SIZE_GLOBAL_COARSE_CELL = total_rcv_size
 
                IF(isendto(nin,loc_proc)>0) total_send_size = nb_box_coarse_grid**3 + 1
       
                nb_request_coarse_cell = nb_request_coarse_cell + 1
                list_inter_coarse_cell(nb_request_coarse_cell) = nin
 
                CALL spmd_ialltoallv_int(sort_comm(nin)%COARSE_GRID,
     .            sort_comm(nin)%GLOBAL_COARSE_CELL,sort_comm(nin)%SEND_SIZE_COARSE_CELL,total_send_size,
     .            sort_comm(nin)%SEND_DISPLS_COARSE_CELL,
     .            total_rcv_size,sort_comm(nin)%RCV_SIZE_COARSE_CELL,
     .            sort_comm(nin)%RCV_DISPLS_COARSE_CELL,array_request_coarse_cell(nb_request_coarse_cell),
     .            sort_comm(nin)%COMM,sort_comm(nin)%PROC_NUMBER)
            ENDIF               
          ENDDO
        ENDIF
        !   -------------------------
        !   MODE=2 : - wait the previous comm
        !            - check if current proc and remote proc need to communicate
        IF(mode==2) THEN
            DO kk=1,nb_request_coarse_cell
                CALL mpi_wait(array_request_coarse_cell(kk),status,ierror)  
                nin = list_inter_coarse_cell(kk)
                itied = ipari(85,nin)
                CALL check_coarse_grid(nin,sort_comm(nin)%MAIN_COARSE_GRID,sort_comm,itied)
 
                DEALLOCATE( sort_comm(nin)%GLOBAL_COARSE_CELL )
                DEALLOCATE( sort_comm(nin)%COARSE_GRID )
            ENDDO 
            nb_request_coarse_cell = 0                   
        ENDIF
!   -------------------------
 
#endif
        END SUBROUTINE spmd_coarse_cell_exchange