OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
check_surface_state.F File Reference
#include "implicit_f.inc"
#include "task_c.inc"
#include "com04_c.inc"
#include "scr17_c.inc"
#include "param_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine check_surface_state (itask, surfarce_nb, surface_id, shift_interface, intbuf_tab, ipari, geo, ixs, ixc, ixt, ixp, ixr, ixtg, ixs10, addcnel, cnel, tag_node, tag_elem, shoot_struct)

Function/Subroutine Documentation

◆ check_surface_state()

subroutine check_surface_state ( integer, intent(in) itask,
integer, intent(in) surfarce_nb,
integer, dimension(surfarce_nb), intent(in) surface_id,
integer, dimension(ninter+1,2), intent(in) shift_interface,
type(intbuf_struct_), dimension(ninter), intent(inout) intbuf_tab,
integer, dimension(npari,ninter), intent(in) ipari,
intent(in) geo,
integer, dimension(nixs,numels), intent(in) ixs,
integer, dimension(nixc,numelc), intent(in) ixc,
integer, dimension(nixt,numelt), intent(in) ixt,
integer, dimension(nixp,numelp), intent(in) ixp,
integer, dimension(nixr,numelr), intent(in) ixr,
integer, dimension(nixtg,numeltg), intent(in) ixtg,
integer, dimension(6,numels10), intent(in) ixs10,
integer, dimension(0:numnod+1), intent(in) addcnel,
integer, dimension(0:lcnel), intent(in) cnel,
integer, dimension(numnod), intent(inout) tag_node,
integer, dimension(numels+numelq+numelc+numelt+numelp+numelr+numeltg), intent(inout) tag_elem,
type(shooting_node_type), intent(inout) shoot_struct )
Parameters
[in]ixs10tetra10 data

Definition at line 36 of file check_surface_state.F.

40!$COMMENT
41! CHECK_SURFACE_STATE description
42! check the state of an surface (active or not)
43! CHECK_SURFACE_STATE organization
44! loop over a list of surface :
45! -check if 1 or more element associated to the surface is/are active
46! - if there is no active element, the surface is deactivate
47! - additional treatment for interface type 24 & 25 : save the list of deactivated surface
48! --> need to send them to remote proc for neighbouring surface deactivation
49!$ENDCOMMENT
50 USE intbufdef_mod
51 USE shooting_node_mod
52 use element_mod , only : nixs,nixc,nixt,nixp,nixr,nixtg
53C-----------------------------------------------
54C I m p l i c i t T y p e s
55C-----------------------------------------------
56#include "implicit_f.inc"
57C-----------------------------------------------
58C C o m m o n B l o c k s
59C-----------------------------------------------
60#include "task_c.inc"
61#include "com04_c.inc"
62#include "scr17_c.inc"
63#include "param_c.inc"
64C-----------------------------------------------
65C D u m m y A r g u m e n t s
66C-----------------------------------------------
67 INTEGER, INTENT(in) :: ITASK ! omp thread ID
68 INTEGER, INTENT(in) :: SURFARCE_NB ! number of local deactivated surface
69 INTEGER, DIMENSION(SURFARCE_NB), INTENT(in) :: SURFACE_ID ! id of surface that need to be deactivated
70 INTEGER, DIMENSION(NINTER+1,2), INTENT(in) :: SHIFT_INTERFACE ! interface shift
71 TYPE(INTBUF_STRUCT_), DIMENSION(NINTER), INTENT(inout) :: INTBUF_TAB ! interface data
72 INTEGER, DIMENSION(NPARI,NINTER), INTENT(in) :: IPARI
73
74 INTEGER, DIMENSION(NIXS,NUMELS), INTENT(in) :: IXS ! solid array
75 INTEGER, DIMENSION(NIXC,NUMELC), INTENT(in) :: IXC ! shell array
76 INTEGER, DIMENSION(NIXT,NUMELT), INTENT(in) :: IXT! truss array
77 INTEGER, DIMENSION(NIXP,NUMELP), INTENT(in) :: IXP! beam array
78 INTEGER, DIMENSION(NIXR,NUMELR), INTENT(in) :: IXR! spring array
79 INTEGER, DIMENSION(NIXTG,NUMELTG), INTENT(in) :: IXTG! triangle array
80 INTEGER, DIMENSION(6,NUMELS10), INTENT(in) :: IXS10!< tetra10 data
81 INTEGER, DIMENSION(0:NUMNOD+1), INTENT(in) :: ADDCNEL ! address for the CNEL array
82 my_real, DIMENSION(NPROPG,NUMGEO), INTENT(in) :: geo
83 INTEGER, DIMENSION(0:LCNEL), INTENT(in) :: CNEL ! connectivity node-->element
84 INTEGER, DIMENSION(NUMNOD), INTENT(inout) :: TAG_NODE
85 INTEGER, DIMENSION(NUMELS+NUMELQ+NUMELC+NUMELT+NUMELP+NUMELR+NUMELTG), INTENT(inout) :: TAG_ELEM
86 TYPE(shooting_node_type), INTENT(inout) :: SHOOT_STRUCT ! structure for shooting node algo
87C-----------------------------------------------
88C L o c a l V a r i a b l e s
89C-----------------------------------------------
90 LOGICAL :: DEACTIVATION,ACTIVATION,TYPE_INTER
91 INTEGER :: I,K,FIRST,LAST
92 INTEGER :: NIN,ID_INTER,NUMBER_INTER
93 INTEGER :: ITY,IDEL
94 INTEGER :: N1,N2,N3,N4
95 INTEGER :: NUMBER_NODE
96 INTEGER :: DICHOTOMIC_SEARCH_I_ASC ! function
97 INTEGER :: MY_REAL_TASK_ID ! real task id : itask is used in a strange way here : -1 if there is no omp // (in the mpi comm)
98 INTEGER, DIMENSION(:), ALLOCATABLE :: NUMBER_SAVED_SURFACE_TYP24_25 ! number of deactivated surface for interface type 24 or 25
99 INTEGER, DIMENSION(SURFARCE_NB) :: SAVED_SURFACE_TYP24_25 ! list of deactivated surface for interface type 24 or 25
100 SAVE number_saved_surface_typ24_25
101 INTEGER :: OFFSET_TASK ! offset to point to the right place in the array SHOOT_STRUCT%REMOTE_SURF
102 INTEGER :: LOW_BOUND,UP_BOUND ! bounds
103 INTEGER :: TOTAL_NUMBER_SURFACE ! total number of deleted surface
104 INTEGER, DIMENSION(:), ALLOCATABLE :: SAVED_SURFACE ! temporary array
105 INTEGER :: NB_CONNECTED_ELM ! number of element connected to a sefment/surface
106 INTEGER :: TOTAL_NUMBER_NEW_SURFACE ! total number of new active surface/
107 INTEGER, DIMENSION(:), ALLOCATABLE :: NUMBER_NEW_SURFACE ! number of new active surface
108 SAVE number_new_surface
109 INTEGER, DIMENSION(SURFARCE_NB) :: NEW_SURFACE ! list of new surface
110C-----------------------------------------------
111 IF(itask==-1) THEN
112 first = 1
113 last = surfarce_nb
114 my_real_task_id = 1
115 ELSE
116 first = 1 + itask * (surfarce_nb / nthread)
117 last = (itask + 1) * (surfarce_nb / nthread)
118 IF((itask+1)==nthread) last = surfarce_nb
119 my_real_task_id = itask+1
120 ENDIF
121 IF(my_real_task_id==1) THEN
122 ALLOCATE( number_saved_surface_typ24_25(nthread) )
123 ALLOCATE( number_new_surface(nthread) )
124 ENDIF
125 IF(itask/=-1) CALL my_barrier( )
126 number_inter = shift_interface(ninter+1,2)
127 number_saved_surface_typ24_25(my_real_task_id) = 0
128 number_new_surface(my_real_task_id) = 0
129 ! --------------------------
130 ! loop over the deactivated surface
131 DO i=first,last
132 k = surface_id(i) ! get the global surface id
133 id_inter = dichotomic_search_i_asc(k, shift_interface(1,1), number_inter+1) ! find the interface of the surface
134 nin = shift_interface(id_inter,2)
135 k = k - shift_interface(id_inter,1) + 1 ! get the surface id in the NIN interface
136 ity = ipari(7,nin)
137 idel = ipari(17,nin)
138 activation =.false.
139 type_inter = (ity==7.OR.ity==10.OR.ity==22.OR.ity==24.OR.(ipari(100,nin)==0.AND.ity==25))
140 ! --------------
141 IF(itask==-1) THEN
142 IF((type_inter.AND.idel==1).OR.(ipari(100,nin)/=0.AND.ity==25)) THEN
143 shoot_struct%INTER(nin)%REMOTE_ELM_M(k) = shoot_struct%INTER(nin)%REMOTE_ELM_M(k) - 1
144 ENDIF
145 ENDIF
146 ! --------------
147
148 ! --------------
149 IF(ipari(100,nin)/=0.AND.ity==25) THEN
150 shoot_struct%INTER(nin)%NB_ELM_M(k) = shoot_struct%INTER(nin)%NB_ELM_M(k) - 1
151 ENDIF
152 ! --------------
153 ! --------------
154 deactivation = .false.
155 IF((type_inter.AND.idel==1).OR.(ipari(100,nin)/=0.AND.ity==25)) THEN
156 n1 = intbuf_tab(nin)%IRECTM((k-1)*4+1)
157 n2 = intbuf_tab(nin)%IRECTM((k-1)*4+2)
158 n3 = intbuf_tab(nin)%IRECTM((k-1)*4+3)
159 n4 = intbuf_tab(nin)%IRECTM((k-1)*4+4)
160 number_node = 4
161 IF(n3==n4) number_node = 3
162 IF(shoot_struct%INTER(nin)%REMOTE_ELM_M(k)<1) THEN
163 CALL check_active_elem_edge( number_node, n1,n2,n3,n4,
164 . deactivation,geo,ixs,ixc,
165 . ixt,ixp,ixr,ixtg,ixs10,addcnel,cnel,
166 . tag_node,tag_elem)
167 ELSE
168 deactivation = .false.
169 ENDIF
170 ELSEIF(type_inter.AND.idel==2) THEN
171 deactivation = .true.
172 ENDIF
173
174 IF(.NOT.deactivation.AND.(ipari(100,nin)/=0.AND.ity==25)) THEN
175 nb_connected_elm = shoot_struct%INTER(nin)%NB_ELM_M(k)
176 ! ---------
177c IF((NB_CONNECTED_ELM<1).AND.(INTBUF_TAB(NIN)%STFM(k)>ZERO)) THEN
178c DEACTIVATION=.TRUE.
179 IF(nb_connected_elm==1.AND.(intbuf_tab(nin)%STFM(k)<zero)) THEN
180 activation = .true.
181 ENDIF
182 ! ---------
183 ENDIF
184 ! --------------
185
186 ! --------------
187 ! check if the surface is active, if yes --> deactivate it
188 IF(deactivation) THEN
189 intbuf_tab(nin)%STFM(k) = zero
190 IF(ity==24.OR.ity==25) THEN
191 number_saved_surface_typ24_25(my_real_task_id) = number_saved_surface_typ24_25(my_real_task_id) + 1
192 saved_surface_typ24_25(number_saved_surface_typ24_25(my_real_task_id)) = surface_id(i)
193 ENDIF
194 ENDIF
195 ! --------------
196
197 ! --------------
198 ! the surface was not active, need to active it
199 IF(activation) THEN
200 intbuf_tab(nin)%STFM(k) = abs(intbuf_tab(nin)%STFM(k))
201 number_new_surface(my_real_task_id) = number_new_surface(my_real_task_id) + 1
202 new_surface(number_new_surface(my_real_task_id)) = surface_id(i)
203 ENDIF
204 ! --------------
205
206 ENDDO
207 ! --------------------------
208
209 ! --------------------------
210 ! Only for interface type 24 & 25 :
211 ! need to save the surface id and send it to a remote processor
212 ! the remote processor will also deactivated the surface for a neighbourhood question
213 offset_task = shoot_struct%NUMBER_REMOTE_SURF
214 IF(itask/=-1) THEN
215 CALL my_barrier()
216 IF(itask>0) THEN
217 DO i=1,itask
218 offset_task = offset_task + number_saved_surface_typ24_25(i)
219 ENDDO
220 ENDIF
221 total_number_surface = 0
222 DO i=1,nthread
223 total_number_surface = total_number_surface + number_saved_surface_typ24_25(i)
224 ENDDO
225 ELSE
226 total_number_surface = number_saved_surface_typ24_25(my_real_task_id)
227 ENDIF
228 ! --------------------------
229 IF(total_number_surface>0) THEN
230 IF(my_real_task_id==1) THEN
231 IF( total_number_surface+shoot_struct%NUMBER_REMOTE_SURF > shoot_struct%SIZE_REMOTE_SURF) THEN
232 ALLOCATE( saved_surface(shoot_struct%NUMBER_REMOTE_SURF) )
233 saved_surface(1:shoot_struct%NUMBER_REMOTE_SURF) = shoot_struct%REMOTE_SURF(1:shoot_struct%NUMBER_REMOTE_SURF)
234 DEALLOCATE( shoot_struct%REMOTE_SURF )
235 shoot_struct%SIZE_REMOTE_SURF = total_number_surface+shoot_struct%NUMBER_REMOTE_SURF
236 ALLOCATE( shoot_struct%REMOTE_SURF(shoot_struct%SIZE_REMOTE_SURF) )
237 shoot_struct%REMOTE_SURF(1:shoot_struct%NUMBER_REMOTE_SURF) = saved_surface(1:shoot_struct%NUMBER_REMOTE_SURF)
238 DEALLOCATE( saved_surface )
239 ENDIF
240 ENDIF
241
242 IF(itask/=-1) CALL my_barrier()
243 low_bound = 1
244 up_bound = number_saved_surface_typ24_25(my_real_task_id)
245 shoot_struct%REMOTE_SURF(low_bound+offset_task:up_bound+offset_task) = saved_surface_typ24_25(low_bound:up_bound)
246 IF(itask/=-1) CALL my_barrier()
247 IF(my_real_task_id==1) shoot_struct%NUMBER_REMOTE_SURF = shoot_struct%NUMBER_REMOTE_SURF + total_number_surface
248 ENDIF
249 ! --------------------------
250
251 ! --------------------------
252 ! Only for interface type 25 :
253 ! need to save the new surface id to find the new neighbours
254 offset_task = shoot_struct%NUMBER_NEW_SURF
255 IF(itask/=-1) THEN
256 CALL my_barrier()
257 IF(itask>0) THEN
258 DO i=1,itask
259 offset_task = offset_task + number_new_surface(i)
260 ENDDO
261 ENDIF
262 total_number_new_surface = 0
263 DO i=1,nthread
264 total_number_new_surface = total_number_new_surface + number_new_surface(i)
265 ENDDO
266 ELSE
267 total_number_new_surface = number_new_surface(my_real_task_id)
268 ENDIF
269 ! --------------------------
270 IF(total_number_new_surface>0) THEN
271 IF(my_real_task_id==1) THEN
272 IF( total_number_new_surface+shoot_struct%NUMBER_NEW_SURF > shoot_struct%SIZE_NEW_SURF) THEN
273 ALLOCATE( saved_surface(shoot_struct%NUMBER_NEW_SURF) )
274 saved_surface(1:shoot_struct%NUMBER_NEW_SURF) = shoot_struct%NEW_SURF(1:shoot_struct%NUMBER_NEW_SURF)
275 DEALLOCATE( shoot_struct%NEW_SURF )
276 shoot_struct%SIZE_NEW_SURF = total_number_new_surface+shoot_struct%NUMBER_NEW_SURF
277 ALLOCATE( shoot_struct%NEW_SURF(shoot_struct%SIZE_NEW_SURF) )
278 shoot_struct%NEW_SURF(1:shoot_struct%NUMBER_NEW_SURF) = saved_surface(1:shoot_struct%NUMBER_NEW_SURF)
279 DEALLOCATE( saved_surface )
280 ENDIF
281 ENDIF
282 IF(itask/=-1) CALL my_barrier()
283 low_bound = 1
284 up_bound = number_new_surface(my_real_task_id)
285 shoot_struct%NEW_SURF(low_bound+offset_task:up_bound+offset_task) = new_surface(low_bound:up_bound)
286 IF(itask/=-1) CALL my_barrier()
287 IF(my_real_task_id==1) shoot_struct%NUMBER_NEW_SURF = shoot_struct%NUMBER_NEW_SURF + total_number_new_surface
288 ENDIF
289 ! --------------------------
290
291
292 IF(itask/=-1) CALL my_barrier( )
293
294 IF(my_real_task_id==1) THEN
295 DEALLOCATE( number_saved_surface_typ24_25 )
296 DEALLOCATE( number_new_surface )
297 ENDIF
298
299 RETURN
check_active_elem_edge
subroutine check_active_elem_edge(number_node, n1, n2, n3, n4, deactivation, geo, ixs, ixc, ixt, ixp, ixr, ixtg, ixs10, addcnel, cnel, tag_node, tag_elem)
Definition check_active_elem_edge.F:35
my_real
#define my_real
Definition cppsort.cpp:32
the
end diagonal values have been computed in the(sparse) matrix id.SOL
dichotomic_search_i_asc
integer function dichotomic_search_i_asc(val, array, len)
Definition dichotomic_search_i_asc.F:27
my_barrier
subroutine my_barrier
Definition machine.F:31