inter_cell_color.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_cell_color    ../engine/source/interfaces/generic/inter_cell_color.F
!||--- called by ------------------------------------------------------
!||    inter_color_voxel   ../engine/source/interfaces/generic/inter_color_voxel.F
!||--- uses       -----------------------------------------------------
!||    inter_sorting_mod   ../engine/share/modules/inter_sorting_mod.F
!||    inter_struct_mod    ../engine/share/modules/inter_struct_mod.F
!||====================================================================
        SUBROUTINE inter_cell_color(X,IGAP   ,NRTM  ,STF   ,
     2              TZINF  ,CURV_MAX,
     3              GAPMIN ,GAPMAX,GAP_M ,
     4             IRECT  ,GAP     ,BGAPSMX,DRAD  ,NB_INDEX_CELL,SIZE_INDEX_CELL,INDEX_CELL,
     5             NEEDED,MAIN_COARSE_GRID,DGAPLOAD)
!$COMMENT
!       INTER_CELL_COLOR description :
!       color the fine cell & coarse cell with main nodes
!
!       INTER_CELL_COLOR organization :
!           loop over the active MAIN surface and :
!               * computation of fine grid index IX/IY/IZ
!               * color the fine grid IX/IY/IZ
!               * if the interface is a large interface : computation of coarse grid index and coloration of coarse grid
!$ENDCOMMENT
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
        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      "com04_c.inc"
#include      "task_c.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        LOGICAL, INTENT(in) :: NEEDED
        INTEGER :: IGAP, NRTM, IRECT(4,NRTM)
        my_real :: X(3,NUMNOD),STF(NRTM), GAP_M(NRTM), BGAPSMX,DRAD
        my_real :: TZINF,GAPMIN,GAPMAX,GAP,CURV_MAX(NRTM)
        INTEGER, INTENT(inout) :: NB_INDEX_CELL
        INTEGER, INTENT(in) :: SIZE_INDEX_CELL
        INTEGER, DIMENSION(SIZE_INDEX_CELL),INTENT(inout) :: INDEX_CELL
        INTEGER, DIMENSION(NB_BOX_COARSE_GRID,NB_BOX_COARSE_GRID,NB_BOX_COARSE_GRID), INTENT(inout) :: MAIN_COARSE_GRID
        my_real , INTENT(IN) :: dgapload
C-----------------------------------------------
C   L o c a l  V a r i a b l e s
C-----------------------------------------------
        INTEGER LOC_PROC,
     .        NBX,NBY,NBZ,NE,M1,M2,M3,M4,
     .        IX1,IY1,IZ1,IX2,IY2,IZ2,IX,IY,IZ
        my_real
     .        aaa, marge,
     .        xmaxb,ymaxb,zmaxb,xminb,yminb,zminb,
     .        xmine,ymine,zmine,xmaxe,ymaxe,zmaxe,
     .        xx1,xx2,xx3,xx4,yy1,yy2,yy3,yy4,zz1,zz2,zz3,zz4
        INTEGER :: IX_COARSE,IY_COARSE,IZ_COARSE
        my_real :: VALUE,real_value
C-----------------------------------------------
C   S o u r c e  L i n e s
C-----------------------------------------------
        loc_proc = ispmd + 1
        marge = tzinf-max(gap+dgapload,drad)
 
        nbx = nb_cell_x
        nby = nb_cell_y
        nbz = nb_cell_z
 
        xmaxb = box_limit(1)
        ymaxb = box_limit(2)
        zmaxb = box_limit(3)
        xminb = box_limit(4)
        yminb = box_limit(5)
        zminb = box_limit(6)
        ! ------------------------------
        ! loop over the main surface
        DO ne=1,nrtm
            !   skip the deleted surfaces
            IF(stf(ne) == zero)cycle
 
            IF(igap == 0)THEN
                aaa = tzinf+curv_max(ne)
            ELSE
                aaa = marge+curv_max(ne)+
     .           max(min(gapmax,max(gapmin,bgapsmx+gap_m(ne)))+dgapload,drad)
            ENDIF
            !   nodes of the surface
            m1 = irect(1,ne)
            m2 = irect(2,ne)
            m3 = irect(3,ne)
            m4 = irect(4,ne)
            xx1=x(1,m1)
            xx2=x(1,m2)
            xx3=x(1,m3)
            xx4=x(1,m4)
            xmaxe=max(xx1,xx2,xx3,xx4)
            xmine=min(xx1,xx2,xx3,xx4)
 
            yy1=x(2,m1)
            yy2=x(2,m2)
            yy3=x(2,m3)
            yy4=x(2,m4)
            ymaxe=max(yy1,yy2,yy3,yy4)
            ymine=min(yy1,yy2,yy3,yy4)
 
            zz1=x(3,m1)
            zz2=x(3,m2)
            zz3=x(3,m3)
            zz4=x(3,m4)
            zmaxe=max(zz1,zz2,zz3,zz4)
            zmine=min(zz1,zz2,zz3,zz4)
 
            !   cell index computation
            ix1=int(nbx*(xmine-aaa-xminb)/(xmaxb-xminb))
            iy1=int(nby*(ymine-aaa-yminb)/(ymaxb-yminb))
            iz1=int(nbz*(zmine-aaa-zminb)/(zmaxb-zminb))
 
            ix1=max(1,min(nbx,ix1))
            iy1=max(1,min(nby,iy1))
            iz1=max(1,min(nbz,iz1))
 
            ix2=int(nbx*(xmaxe+aaa-xminb)/(xmaxb-xminb))
            iy2=int(nby*(ymaxe+aaa-yminb)/(ymaxb-yminb))
            iz2=int(nbz*(zmaxe+aaa-zminb)/(zmaxb-zminb))
 
            ix2=max(1,min(nbx,ix2))
            iy2=max(1,min(nby,iy2))
            iz2=max(1,min(nbz,iz2))
 
            real_value = float(nb_box_coarse_grid)
 
            !   loop over the cell and cell coloration
            DO iz = iz1, iz2             
                VALUE = real_value*float(iz)/float(nb_cell_z)
                iz_coarse = min(int(VALUE),nb_box_coarse_grid)
                iz_coarse = max(iz_coarse,1)
                DO iy = iy1, iy2
                    VALUE = real_value*float(iy)/float(nb_cell_y)
                    iy_coarse = min(int(VALUE),nb_box_coarse_grid)
                    iy_coarse = max(iy_coarse,1)
                    DO ix = ix1, ix2
                        VALUE = real_value*float(ix)/float(nb_cell_x)
                        ix_coarse = min(int(VALUE),nb_box_coarse_grid)
                        ix_coarse = max(ix_coarse,1)
                        IF(cell_bool(ix,iy,iz)) THEN
                            nb_index_cell = nb_index_cell + 1
                            index_cell(nb_index_cell) = ix + 1000*iy +1000**2 * iz
                            cell_bool(ix,iy,iz) = .false.
                            IF(needed) main_coarse_grid(ix_coarse,iy_coarse,iz_coarse) = 1
                        ENDIF
                    END DO
                END DO
            END DO
        ENDDO
        ! ------------------------------
C
        RETURN
        END SUBROUTINE inter_cell_color