OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
inter_color_voxel.F File Reference
#include "implicit_f.inc"
#include "comlock.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "param_c.inc"
#include "task_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine inter_color_voxel (itask, nb_inter_sorted, list_inter_sorted, ipari, intbuf_tab, x, inter_struct, sort_comm)

Function/Subroutine Documentation

◆ inter_color_voxel()

subroutine inter_color_voxel ( integer, intent(in) itask,
integer, intent(in) nb_inter_sorted,
integer, dimension(nb_inter_sorted), intent(in) list_inter_sorted,
integer, dimension(npari,ninter), intent(in) ipari,
type(intbuf_struct_), dimension(ninter), intent(in) intbuf_tab,
intent(in) x,
type(inter_struct_type), dimension(ninter), intent(inout) inter_struct,
type(sorting_comm_type), dimension(ninter), intent(inout) sort_comm )

Definition at line 36 of file inter_color_voxel.F.

38!$COMMENT
39! INTER_COLOR_VOXEL description :
40! color the fine cell & coarse cell with main nodes
41!
42! INTER_COLOR_VOXEL organization :
43! loop over the interface and call of INTER_CELL_COLOR
44!$ENDCOMMENT
45C-----------------------------------------------
46C M o d u l e s
47C-----------------------------------------------
48 USE intbufdef_mod
49 USE multi_fvm_mod
50 USE inter_sorting_mod
51 USE inter_struct_mod
52C-----------------------------------------------
53C I m p l i c i t T y p e s
54C-----------------------------------------------
55#include "implicit_f.inc"
56#include "comlock.inc"
57C-----------------------------------------------
58C C o m m o n B l o c k s
59C-----------------------------------------------
60#include "com01_c.inc"
61#include "com04_c.inc"
62#include "param_c.inc"
63#include "task_c.inc"
64C-----------------------------------------------
65C D u m m y A r g u m e n t s
66C-----------------------------------------------
67 INTEGER, INTENT(in) :: ITASK ! thread ID
68 INTEGER, INTENT(in) :: NB_INTER_SORTED ! number of interfaces that need to be sorted
69 INTEGER, DIMENSION(NB_INTER_SORTED), INTENT(in) :: LIST_INTER_SORTED ! list of interfaces that need to be sorted
70 INTEGER, DIMENSION(NPARI,NINTER), INTENT(in) :: IPARI ! interface data
71 TYPE(INTBUF_STRUCT_),DIMENSION(NINTER), INTENT(in) :: INTBUF_TAB ! interface data
72 my_real, DIMENSION(3*NUMNOD), INTENT(in) :: x ! position
73 TYPE(inter_struct_type), DIMENSION(NINTER), INTENT(inout) :: INTER_STRUCT ! structure for interface
74 TYPE(sorting_comm_type), DIMENSION(NINTER), INTENT(inout) :: SORT_COMM ! structure for interface sorting comm
75C-----------------------------------------------
76C L o c a l V a r i a b l e s
77C-----------------------------------------------
78 INTEGER :: KK,I,J
79 INTEGER :: NIN
80 INTEGER :: IX,IY,IZ
81 INTEGER :: SIZE_INDEX_CELL,TOTAL_NB_CELL
82 INTEGER :: NRTM,NRTM_T
83 INTEGER :: ADRESS,ESHIFT,SHIFT
84 INTEGER, DIMENSION(:), ALLOCATABLE :: INDEX_CELL
85 LOGICAL :: TYPE18
86 INTEGER :: NTY,INACTI
87 INTEGER :: VALUE
88 my_real :: dgapload
89
90 my_real :: tzinf,gapmin,gapmax,gap,drad
91
92! ----------------------------------------
93 ! --------------------
94 ! allocation of global omp array
95 IF(itask==0) THEN
96 ALLOCATE(cell_bool(nb_cell_x,nb_cell_y,nb_cell_z))
97 cell_bool(1:nb_cell_x,1:nb_cell_y,1:nb_cell_z) = .true.
98 ALLOCATE( nb_local_cell(nthread) )
99 ENDIF
100 CALL my_barrier()
101 ! --------------------
102 ! allocation of local omp array
103 size_index_cell = nb_cell_x*nb_cell_y*nb_cell_z
104 ALLOCATE(index_cell(size_index_cell))
105 nb_local_cell(itask+1) = 0
106
107 ! --------------------
108 ! loop over the interface
109 DO kk=1,nb_inter_sorted
110 nin = list_inter_sorted(kk)
111 nrtm = ipari(4,nin)
112 nrtm_t = nrtm/nthread
113 eshift = itask*nrtm_t
114 adress = 1 + itask*(ipari(4,nin)/nthread)
115 IF(itask==nthread-1) nrtm_t= nrtm - adress + 1
116 nb_local_cell(itask+1) = 0
117
118 tzinf = intbuf_tab(nin)%VARIABLES(tzinf_index)
119 gap =intbuf_tab(nin)%VARIABLES(gap_index)
120 gapmin=intbuf_tab(nin)%VARIABLES(gapmin_index)
121 gapmax=intbuf_tab(nin)%VARIABLES(gapmax_index)
122 drad = zero
123 IF(ipari(7,nin)==7) drad =intbuf_tab(nin)%VARIABLES(drad_index)
124 dgapload = intbuf_tab(nin)%VARIABLES(bgapemx_index)
125
126 nty = ipari(7,nin)
127 inacti = ipari(22,nin)
128 type18=.false.
129 IF(nty==7 .AND. inacti==7)type18=.true.
130
131 IF(itask==0) THEN
132 coarse_grid = .false.
133 IF(sort_comm(nin)%PROC_NUMBER>nspmd/2) THEN
134 coarse_grid = .true.
135 IF(.NOT.ALLOCATED(sort_comm(nin)%MAIN_COARSE_GRID) ) THEN
136 ALLOCATE(sort_comm(nin)%MAIN_COARSE_GRID(
137 . nb_box_coarse_grid,nb_box_coarse_grid,nb_box_coarse_grid ) )
138 ENDIF
139 sort_comm(nin)%MAIN_COARSE_GRID(:,:,:) = 0
140 ENDIF
141 ENDIF
142
143 CALL my_barrier()
144 ! --------------------
145 ! cell coloration by omp threads
146 CALL inter_cell_color( x,ipari(21,nin) ,nrtm_t ,intbuf_tab(nin)%STFM(1+eshift) ,
147 2 tzinf,inter_struct(nin)%CURV_MAX(adress),
148 3 gapmin ,gapmax,intbuf_tab(nin)%GAP_M(1+eshift) ,
149 4 intbuf_tab(nin)%IRECTM(1+4*eshift),gap,intbuf_tab(nin)%VARIABLES(bgapsmx_index),drad,
150 5 nb_local_cell(itask+1),size_index_cell,index_cell,
151 6 coarse_grid,sort_comm(nin)%MAIN_COARSE_GRID,dgapload)
152
153 CALL my_barrier()
154 ! --------------------
155 ! reduction of number of colored cells
156 IF(itask==0) THEN
157 total_nb_cell = 0
158 DO i=1,nthread
159 total_nb_cell = total_nb_cell + nb_local_cell(i)
160 ENDDO
161 sort_comm(nin)%SIZE_CELL_LIST(1) = total_nb_cell
162 sort_comm(nin)%SIZE_CELL_LIST(2) = 0
163 ALLOCATE( sort_comm(nin)%CELL_LIST(total_nb_cell) )
164 ENDIF
165 ! --------------------
166 ! flush global array CELL_BOOL to true for the next interface
167 DO i=1,nb_local_cell(itask+1)
168
169 VALUE = index_cell(i)
170 iz = ( VALUE - mod(VALUE,1000000) ) / 1000000
171 VALUE = VALUE - iz * 1000000
172 iy = ( VALUE - mod(VALUE,1000) ) / 1000
173 VALUE = VALUE - iy * 1000
174 ix = VALUE
175 cell_bool(ix,iy,iz) = .true.
176 ENDDO
177 CALL my_barrier()
178 ! --------------------
179
180 ! --------------------
181 ! reduction of colored cells
182 shift = 0
183 IF(itask>0) THEN
184 DO j=1,itask
185 shift = shift + nb_local_cell(j)
186 ENDDO
187 ENDIF
188 sort_comm(nin)%CELL_LIST(1+shift:nb_local_cell(itask+1)+shift) = index_cell(1:nb_local_cell(itask+1))
189
190 CALL my_barrier()
191 ! --------------------
192 ENDDO
193
194 CALL my_barrier()
195 ! --------------------
196 ! deallocation
197 IF(itask==0) THEN
198 DEALLOCATE(cell_bool)
199 DEALLOCATE( nb_local_cell )
200 ENDIF
201 DEALLOCATE(index_cell)
202 ! --------------------
203 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
inter_cell_color
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)
Definition inter_cell_color.F:36
inter_sorting_mod
Definition inter_sorting_mod.F:57
inter_sorting_mod::coarse_grid
logical coarse_grid
Definition inter_sorting_mod.F:76
inter_sorting_mod::nb_local_cell
integer, dimension(:), allocatable nb_local_cell
Definition inter_sorting_mod.F:77
inter_sorting_mod::cell_bool
logical, dimension(:,:,:), allocatable cell_bool
Definition inter_sorting_mod.F:78
inter_sorting_mod::nb_box_coarse_grid
integer, parameter nb_box_coarse_grid
Definition inter_sorting_mod.F:70
inter_sorting_mod::nb_cell_z
integer nb_cell_z
Definition inter_sorting_mod.F:72
inter_sorting_mod::nb_cell_y
integer nb_cell_y
Definition inter_sorting_mod.F:72
inter_sorting_mod::nb_cell_x
integer nb_cell_x
Definition inter_sorting_mod.F:72
inter_struct_mod
Definition inter_struct_mod.F:49
my_barrier
subroutine my_barrier
Definition machine.F:31