inter_cell_color.F File Reference

#include "implicit_f.inc"
#include "comlock.inc"
#include "com04_c.inc"
#include "task_c.inc"

Go to the source code of this file.

Functions/Subroutines
subroutine	inter_cell_color (x, igap, nrtm, stf, tzinf, curv_max, gapmin, gapmax, gap_m, irect, gap, bgapsmx, drad, nb_index_cell, size_index_cell, index_cell, needed, main_coarse_grid, dgapload)

Function/Subroutine Documentation

inter_cell_color()

subroutine inter_cell_color	(		x,
		integer	igap,
		integer	nrtm,
			stf,
			tzinf,
			curv_max,
			gapmin,
			gapmax,
			gap_m,
		integer, dimension(4,nrtm)	irect,
			gap,
			bgapsmx,
			drad,
		integer, intent(inout)	nb_index_cell,
		integer, intent(in)	size_index_cell,
		integer, dimension(size_index_cell), intent(inout)	index_cell,
		logical, intent(in)	needed,
		integer, dimension(nb_box_coarse_grid,nb_box_coarse_grid,nb_box_coarse_grid), intent(inout)	main_coarse_grid,
		intent(in)	dgapload )

Definition at line 31 of file inter_cell_color.F.

!$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