inter_color_voxel.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/.
!||====================================================================
!||    inter_color_voxel    ../engine/source/interfaces/generic/inter_color_voxel.f
!||--- called by ------------------------------------------------------
!||    inter_prepare_sort   ../engine/source/interfaces/generic/inter_prepare_sort.F
!||--- calls      -----------------------------------------------------
!||    inter_cell_color     ../engine/source/interfaces/generic/inter_cell_color.F
!||    my_barrier           ../engine/source/system/machine.F
!||--- uses       -----------------------------------------------------
!||    intbufdef_mod        ../common_source/modules/interfaces/intbufdef_mod.F90
!||    inter_sorting_mod    ../engine/share/modules/inter_sorting_mod.F
!||    inter_struct_mod     ../engine/share/modules/inter_struct_mod.F
!||    multi_fvm_mod        ../common_source/modules/ale/multi_fvm_mod.F90
!||====================================================================
        SUBROUTINE inter_color_voxel(ITASK,NB_INTER_SORTED,LIST_INTER_SORTED,IPARI,INTBUF_TAB,
     .                               X,INTER_STRUCT,SORT_COMM)
!$COMMENT
!       INTER_COLOR_VOXEL description :
!       color the fine cell & coarse cell with main nodes
!
!       INTER_COLOR_VOXEL organization :
!           loop over the interface and call of INTER_CELL_COLOR
!$ENDCOMMENT
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
        USE intbufdef_mod  
        USE multi_fvm_mod
        USE inter_sorting_mod
        USE inter_struct_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      "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) :: ITASK ! thread ID
        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, DIMENSION(NPARI,NINTER), INTENT(in) :: IPARI    !   interface data
        TYPE(intbuf_struct_),DIMENSION(NINTER), INTENT(in) :: INTBUF_TAB    ! interface data
        my_real, DIMENSION(3*NUMNOD), INTENT(in) :: x            !   position
        TYPE(inter_struct_type), DIMENSION(NINTER), INTENT(inout) :: INTER_STRUCT   !   structure for interface
        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-----------------------------------------------
        INTEGER :: KK,I,J
        INTEGER :: NIN
        INTEGER :: IX,IY,IZ
        INTEGER :: SIZE_INDEX_CELL,TOTAL_NB_CELL
        INTEGER :: NRTM,NRTM_T
        INTEGER :: ADRESS,ESHIFT,SHIFT
        INTEGER, DIMENSION(:), ALLOCATABLE :: INDEX_CELL
        LOGICAL :: TYPE18
        INTEGER :: NTY,INACTI
        INTEGER :: VALUE
        my_real :: dgapload
 
        my_real :: tzinf,gapmin,gapmax,gap,drad
 
!   ----------------------------------------
        ! --------------------
        ! allocation of global omp array
        IF(itask==0) THEN
            ALLOCATE(cell_bool(nb_cell_x,nb_cell_y,nb_cell_z))
            cell_bool(1:nb_cell_x,1:nb_cell_y,1:nb_cell_z) = .true.
            ALLOCATE( nb_local_cell(nthread) ) 
        ENDIF
        CALL my_barrier()
        ! --------------------
        ! allocation of local omp array
        size_index_cell = nb_cell_x*nb_cell_y*nb_cell_z
        ALLOCATE(index_cell(size_index_cell))
        nb_local_cell(itask+1) = 0
 
        ! --------------------
        ! loop over the interface
        DO kk=1,nb_inter_sorted
            nin = list_inter_sorted(kk)
            nrtm = ipari(4,nin)
            nrtm_t = nrtm/nthread
            eshift = itask*nrtm_t
            adress = 1 + itask*(ipari(4,nin)/nthread)
            IF(itask==nthread-1) nrtm_t= nrtm - adress + 1
            nb_local_cell(itask+1) = 0
            
            tzinf = intbuf_tab(nin)%VARIABLES(tzinf_index)
            gap   =intbuf_tab(nin)%VARIABLES(gap_index)
            gapmin=intbuf_tab(nin)%VARIABLES(gapmin_index)
            gapmax=intbuf_tab(nin)%VARIABLES(gapmax_index)
            drad = zero
            IF(ipari(7,nin)==7) drad =intbuf_tab(nin)%VARIABLES(drad_index)
            dgapload = intbuf_tab(nin)%VARIABLES(bgapemx_index)
 
            nty = ipari(7,nin)
            inacti = ipari(22,nin)
            type18=.false.
            IF(nty==7 .AND. inacti==7)type18=.true.
 
            IF(itask==0) THEN
                coarse_grid = .false.
                IF(sort_comm(nin)%PROC_NUMBER>nspmd/2) THEN
                    coarse_grid = .true.
                    IF(.NOT.ALLOCATED(sort_comm(nin)%MAIN_COARSE_GRID) ) THEN
                        ALLOCATE(sort_comm(nin)%MAIN_COARSE_GRID( 
     .                        nb_box_coarse_grid,nb_box_coarse_grid,nb_box_coarse_grid ) )
                   ENDIF
                   sort_comm(nin)%MAIN_COARSE_GRID(:,:,:) = 0
               ENDIF
            ENDIF
 
            CALL my_barrier()
            ! --------------------  
            ! cell coloration by omp threads  
            CALL inter_cell_color( x,ipari(21,nin)   ,nrtm_t  ,intbuf_tab(nin)%STFM(1+eshift)   ,
     2                 tzinf,inter_struct(nin)%CURV_MAX(adress),
     3                 gapmin ,gapmax,intbuf_tab(nin)%GAP_M(1+eshift) ,
     4                 intbuf_tab(nin)%IRECTM(1+4*eshift),gap,intbuf_tab(nin)%VARIABLES(bgapsmx_index),drad,
     5                 nb_local_cell(itask+1),size_index_cell,index_cell,
     6                 coarse_grid,sort_comm(nin)%MAIN_COARSE_GRID,dgapload)
 
            CALL my_barrier()
            ! --------------------   
            ! reduction of number of colored cells
            IF(itask==0) THEN
                total_nb_cell = 0
                DO i=1,nthread
                    total_nb_cell = total_nb_cell + nb_local_cell(i)
                ENDDO
                sort_comm(nin)%SIZE_CELL_LIST(1) = total_nb_cell
                sort_comm(nin)%SIZE_CELL_LIST(2) = 0
                ALLOCATE( sort_comm(nin)%CELL_LIST(total_nb_cell) )
            ENDIF
            ! --------------------   
            ! flush global array CELL_BOOL to true for the next interface
            DO i=1,nb_local_cell(itask+1)
 
                VALUE = index_cell(i)
                iz = ( VALUE - mod(VALUE,1000000) ) / 1000000
                VALUE = VALUE - iz * 1000000
                iy = ( VALUE - mod(VALUE,1000) ) / 1000
                VALUE = VALUE - iy * 1000
                ix = VALUE
                cell_bool(ix,iy,iz) = .true.
            ENDDO
            CALL my_barrier()
            ! --------------------   
 
            ! --------------------   
            ! reduction of colored cells
            shift = 0
            IF(itask>0) THEN
                DO j=1,itask
                    shift = shift + nb_local_cell(j)
                ENDDO
            ENDIF
            sort_comm(nin)%CELL_LIST(1+shift:nb_local_cell(itask+1)+shift) = index_cell(1:nb_local_cell(itask+1))
 
            CALL my_barrier()
            ! --------------------   
        ENDDO
 
        CALL my_barrier()
        ! --------------------
        ! deallocation
        IF(itask==0) THEN
            DEALLOCATE(cell_bool)
            DEALLOCATE( nb_local_cell ) 
        ENDIF
        DEALLOCATE(index_cell)
        ! --------------------
        RETURN
        END SUBROUTINE inter_color_voxel