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

Go to the source code of this file.

Functions/Subroutines

subroutine find_surface_inter (itab, shoot_struct, ixs, ixs10, ixc, ixtg, ngroup, nparg, igroups, iparg)

Function/Subroutine Documentation

◆ find_surface_inter()

subroutine find_surface_inter ( integer, dimension(numnod), intent(in) itab,
type(shooting_node_type), intent(inout) shoot_struct,
integer, dimension(nixs,numels), intent(in), target ixs,
integer, dimension(6,numels10), intent(in), target ixs10,
integer, dimension(nixc,numelc), intent(in), target ixc,
integer, dimension(nixtg,numeltg), intent(in), target ixtg,
integer, intent(in) ngroup,
integer, intent(in) nparg,
integer, dimension(numels), intent(in) igroups,
integer, dimension(nparg,ngroup), intent(in) iparg )
Parameters
[in]npargsize of iparg
[in]igroupsarray to point to the element group
[in]ipargelement group data

Definition at line 33 of file find_surface_inter.F.

36!$COMMENT
37! FIND_EDGE_INTER description
38! this routine finds the surface id and the interfaces id of a list of deleted elements
39! FIND_EDGE_INTER organization
40! loop over the deleted element:
41! intersection of the surface list for the x nodes of the element --> give the surface id where
42! the nodes are defined
43! intersection of the proc list for the x nodes of the element --> give the proc id where
44! the nodes are defined
45!$ENDCOMMENT
46 USE intbufdef_mod
47 USE shooting_node_mod
48C-----------------------------------------------
49C I m p l i c i t T y p e s
50C-----------------------------------------------
51#include "implicit_f.inc"
52C-----------------------------------------------
53C C o m m o n B l o c k s
54C-----------------------------------------------
55#include "task_c.inc"
56#include "com04_c.inc"
57C-----------------------------------------------
58C D u m m y A r g u m e n t s
59C-----------------------------------------------
60 INTEGER, DIMENSION(NIXS,NUMELS),TARGET, INTENT(in) :: IXS ! solid array
61 INTEGER, DIMENSION(6,NUMELS10),TARGET, INTENT(in) :: IXS10 ! tetra10 array
62 INTEGER, DIMENSION(NIXC,NUMELC),TARGET, INTENT(in) :: IXC ! shell array
63 INTEGER, DIMENSION(NIXTG,NUMELTG),TARGET, INTENT(in) :: IXTG! triangle array
64 INTEGER, DIMENSION(NUMNOD), INTENT(in) :: ITAB ! array to convert local id to global id
65 INTEGER, INTENT(in) :: NGROUP,NPARG !< size of iparg
66 INTEGER, DIMENSION(NUMELS), INTENT(in) :: IGROUPS !< array to point to the element group
67 INTEGER, DIMENSION(NPARG,NGROUP), INTENT(in) :: IPARG !< element group data
68 TYPE(shooting_node_type), INTENT(inout) :: SHOOT_STRUCT ! structure for shooting node algo
69C-----------------------------------------------
70C L o c a l V a r i a b l e s
71C-----------------------------------------------
72 INTEGER :: I,J,K,N,IJK
73 INTEGER :: NODE_ID,NODE_ID_2,ELEM_ID
74 INTEGER :: OFFSET_SOLID,OFFSET_QUAD,OFFSET_SHELL,OFFSET_TRUSS
75 INTEGER :: OFFSET_BEAM,OFFSET_SPRING,OFFSET_TRIANGLE,OFFSET_UR
76 INTEGER, DIMENSION(4,6), TARGET :: FACES ! definition of faces for solid
77 INTEGER, DIMENSION(4,5), TARGET :: FACES6 ! definition of faces for penta6
78 INTEGER, DIMENSION(3,4), TARGET :: FACES4 ! definition of faces for tetra10
79 INTEGER, DIMENSION(3,16), TARGET :: FACES10 ! definition of faces for tetra10
80 INTEGER, DIMENSION(4,1), TARGET :: FACES_SHELL ! definition of face for shell/quad/triangle
81 INTEGER,DIMENSION(:,:), POINTER :: POINTER_FACE,IX,IX_TETRA10
82
83 LOGICAL :: DO_COMPUTATION
84 INTEGER :: SHIFT,SHIFT_ELM,OLD_SIZE
85 INTEGER :: SURFACE_NUMBER
86 INTEGER :: NB_PROC_1,NB_PROC_2,NODE_SURF_NB,SEVERAL_PROC,SEVERAL_SURF
87 INTEGER :: NB_RESULT_INTERSECT,NB_RESULT_INTERSECT_2,NB_SURFACE_1,NB_SURFACE_2
88 INTEGER, DIMENSION(:), ALLOCATABLE :: RESULT_INTERSECT,INTERSECT_1,INTERSECT_2
89 INTEGER, DIMENSION(:), ALLOCATABLE :: RESULT_INTERSECT_2,INTERSECT_3,INTERSECT_4
90 INTEGER, DIMENSION(:), ALLOCATABLE :: TMP_ARRAY
91 INTEGER, DIMENSION(4) :: LOCAL_NODE
92 INTEGER :: DICHOTOMIC_SEARCH_I_ASC ! function
93 INTEGER :: GROUP_NUMBER
94 INTEGER :: KIND_SOLID,OLD_J,MERGED_NODE,ERROR
95 INTEGER, DIMENSION(4) :: LIST_NODE_ID,PERM_LIST_NODE_ID,NB_APPAREANCE
96 LOGICAL :: NEED_COMPUTE
97 INTEGER :: N1,N2,N3,N4
98C-----------------------------------------------
99
100 faces_shell(1:4,1) = (/1,2,3,4/)
101
102 faces(1:4,1) = (/1,2,3,4/)
103 faces(1:4,2) = (/1,2,6,5/)
104 faces(1:4,3) = (/2,3,7,6/)
105 faces(1:4,4) = (/3,4,8,7/)
106 faces(1:4,5) = (/1,5,8,4/)
107 faces(1:4,6) = (/5,6,7,8/)
108
109 faces4(1:3,1) = (/2,3,6/)
110 faces4(1:3,2) = (/2,3,5/)
111 faces4(1:3,3) = (/2,6,5/)
112 faces4(1:3,4) = (/3,6,5/)
113
114 faces6(1:4,1) = (/1,2,3,1/) !-> tri
115 faces6(1:4,2) = (/1,2,6,5/) !->quad
116 faces6(1:4,3) = (/2,3,7,6/) !->quad
117 faces6(1:4,4) = (/3,4,8,7/) !->quad
118 faces6(1:4,5) = (/5,6,7,5/) !->tri
119
120 faces10(1:3,1) = (/1,11,14/)
121 faces10(1:3,2) = (/3,11,15/)
122 faces10(1:3,3) = (/5,14,15/)
123 faces10(1:3,4) = (/11,14,15/)
124 faces10(1:3,5) = (/1,13,14/)
125 faces10(1:3,6) = (/6,13,16/)
126 faces10(1:3,7) = (/5,14,16/)
127 faces10(1:3,8) = (/13,14,16/)
128 faces10(1:3,9) = (/3,11,12/)
129 faces10(1:3,10) = (/6,12,13/)
130 faces10(1:3,11) = (/1,11,13/)
131 faces10(1:3,12) = (/11,12,13/)
132 faces10(1:3,13) = (/3,12,15/)
133 faces10(1:3,14) = (/6,12,16/)
134 faces10(1:3,15) = (/5,15,16/)
135 faces10(1:3,16) = (/12,15,16/)
136
137 ! --------------------------
138 offset_solid = 0
139 offset_quad=offset_solid+numels
140 offset_shell=offset_quad+numelq
141 offset_truss=offset_shell+numelc
142 offset_beam=offset_truss+numelt
143 offset_spring=offset_beam+numelp
144 offset_triangle=offset_spring+numelr
145 offset_ur=offset_triangle+numeltg
146 ! --------------------------
147
148 ! --------------------------
149 ! allocation of SAVE_SURFACE : index of deactivated surface
150 shoot_struct%S_SAVE_SURFACE = 4*shoot_struct%S_GLOBAL_ELEM_INDEX ! size of SAVE_SURFACE array
151 ALLOCATE( shoot_struct%SAVE_SURFACE( shoot_struct%S_SAVE_SURFACE ) )
152 shoot_struct%SAVE_SURFACE_NB = 0 ! number of deactivated surface
153 shoot_struct%SAVE_SURFACE( 1:shoot_struct%S_SAVE_SURFACE ) = 0
154 ! --------------------------
155 ! allocation of SAVE_PROC : index of processor with the 4 nodes + 4 node ids
156 shoot_struct%S_SAVE_PROC = 5*shoot_struct%S_GLOBAL_ELEM_INDEX ! size of SAVE_PROC array
157 ALLOCATE( shoot_struct%SAVE_PROC( shoot_struct%S_SAVE_PROC ) )
158 shoot_struct%SAVE_PROC_NB = 0 ! number of processor + 4 nodes of deactivated surface
159 shoot_struct%SAVE_PROC( 1:shoot_struct%S_SAVE_PROC ) = 0
160 ! --------------------------
161 ! working array : surface
162 ALLOCATE( result_intersect( shoot_struct%MAX_SURF_NB ) )
163 ALLOCATE( intersect_1( shoot_struct%MAX_SURF_NB ) )
164 ALLOCATE( intersect_2( shoot_struct%MAX_SURF_NB ) )
165 ! working array : processor
166 ALLOCATE( result_intersect_2( shoot_struct%MAX_PROC_NB ) )
167 ALLOCATE( intersect_3( shoot_struct%MAX_PROC_NB ) )
168 ALLOCATE( intersect_4( shoot_struct%MAX_PROC_NB ) )
169 ! --------------------------
170 DO i=1,shoot_struct%S_GLOBAL_ELEM_INDEX
171 elem_id = shoot_struct%GLOBAL_ELEM_INDEX(i) ! get the id of the deleted element
172 do_computation = .true.
173 kind_solid = 0
174 ix_tetra10 => null()
175 ! ----------------------
176 IF(elem_id<=numels8) THEN
177 ! solid element : 8 nodes --> 6 surfaces
178 ! o----o
179 ! /+ /|
180 ! o-+--o |
181 ! | o++|+o
182 ! |+ |/
183 ! o----o
184 ! penta element : 6 nodes --> 5 surfaces
185 ! o
186 ! /+\
187 ! o+ \
188 ! /\o++/o
189 ! /+ \ /
190 ! o----o
191 ! tetra4 element : 4 nodes --> 4 surfaces
192 ! o
193 ! /+\
194 ! / + \
195 ! / + \
196 ! / o \
197 ! / + + \
198 ! o-----------o
199 group_number = igroups(elem_id)
200 kind_solid = iparg(28,group_number)
201 ! -------------
202 ! tetra4
203 IF(kind_solid==4) THEN
204 surface_number = 4 ! number of surface
205 node_surf_nb = 3 ! number of node per surface
206 pointer_face => faces4(1:3,1:4)
207 ! -------------
208 ! penta6
209 ELSEIF(kind_solid==6) THEN
210 surface_number = 5 ! number of surface
211 node_surf_nb = 4 ! number of node per surface(3 surface with 4 nodes, 2 with 3 nodes)
212 pointer_face => faces6(1:4,1:5)
213 ! -------------
214 ! solid8
215 ELSE
216 kind_solid = 8
217 surface_number = 6 ! number of surface
218 node_surf_nb = 4 ! number of node per surface
219 pointer_face => faces(1:4,1:6)
220 ENDIF
221 ! -------------
222 ix => ixs(1:nixs,1:numels)
223 shift_elm = offset_solid
224 ELSEIF(elem_id<=numels8+numels10) THEN
225 ! solid element : tetra10 --> 10 surfaces
226 ! 4 internal surfaces per "real surfaces"
227 ! tetra4 --> tetra10
228 ! 3d view 2d view (draw a tetra10 with 3d view is really hard :) )
229 ! o o
230 ! /+\ / \
231 ! / + \ / \
232 ! / + \ o-----o
233 ! / o \ / \ / \
234 ! / + + \ / \ / \
235 ! o-----------o o---- o ----o
236 surface_number = 16 ! number of surface
237 ix => ixs(1:nixs,1:numels)
238 ix_tetra10 => ixs10(1:6,1:numels10)
239 pointer_face => faces10(1:3,1:16)
240 node_surf_nb = 3 ! number of node per surface
241 shift_elm = numels8
242 kind_solid = 10
243 ELSEIF(elem_id<=numels) THEN
244 ! other solid element : at least 8 nodes --> 6 surfaces
245 ! o----o
246 ! /| /|
247 ! o----o |
248 ! | o--|-o
249 ! |/ |/
250 ! o----o
251 surface_number = 6 ! number of surface
252 ix => ixs(1:nixs,1:numels)
253 pointer_face => faces(1:4,1:6)
254 node_surf_nb = 4 ! number of node per surface
255 shift_elm = offset_solid
256 ELSEIF(elem_id<=offset_shell) THEN
257 ! quad element
258 do_computation = .false.
259 ELSEIF(elem_id<=offset_truss) THEN
260 ! shell element
261 ! 4 nodes / 1 surface
262 ! o----o
263 ! | |
264 ! | |
265 ! o----o
266 surface_number = 1 ! number of surface
267 ix => ixc(1:nixc,1:numelc)
268 pointer_face => faces_shell(1:4,1:1)
269 node_surf_nb = 4 ! number of node per surface
270 shift_elm = offset_shell
271 ELSEIF(elem_id<=offset_beam) THEN
272 ! truss element
273 do_computation = .false.
274 ELSEIF(elem_id<=offset_spring) THEN
275 ! beam element
276 do_computation = .false.
277 ELSEIF(elem_id<=offset_triangle) THEN
278 ! spring element
279 do_computation = .false.
280 ELSEIF(elem_id<=offset_ur) THEN
281 ! triangle element
282 ! 3 nodes / 1 surface
283 ! o
284 ! / \
285 ! / \
286 ! o-----o
287 surface_number = 1 ! number of surface
288 ix => ixtg(1:nixtg,1:numeltg)
289 pointer_face => faces_shell(1:4,1:1)
290 node_surf_nb = 3 ! number of node per surface
291 shift_elm = offset_triangle
292 ELSE
293 ! user element
294 do_computation = .false.
295 ENDIF
296 ! ----------------------
297 IF(do_computation) THEN
298 ! ----------------------
299 ! loop over the surfaces of the element
300 DO k=1,surface_number
301 several_proc = 0
302 several_surf = 0
303 need_compute = .true.
304 ! ---------------------------
305 ! solid element 8 can be degenerated (penta, pyramid...)
306 ! --> need to check if the face of the element is a real face
307 IF(kind_solid==8) THEN
308 ! ----------------
309 ! sort the node id list
310 DO j=1,4
311 n = pointer_face(j,k)
312 list_node_id(j) = ix(n+1,elem_id-shift_elm)
313 ENDDO
314 CALL myqsort_int(4,list_node_id,perm_list_node_id,error)
315 ! ----------------
316
317 ! ----------------
318 ! check if the face has 3 or 4 nodes
319 node_id = list_node_id(1)
320 old_j = 1
321 nb_appareance(1) = 1
322 nb_appareance(2:4) = 0
323 ! ----------------
324 ! number of appareance of the node
325 DO j=2,4
326 IF(node_id/=list_node_id(j)) THEN
327 nb_appareance(j) = nb_appareance(j) + 1
328 node_id = list_node_id(j)
329 old_j = j
330 ELSE
331 nb_appareance(old_j) = nb_appareance(old_j) + 1
332 ENDIF
333 ENDDO
334 ! ----------------
335
336 ! ----------------
337 ! check the number of nodes
338 merged_node = 0
339 DO j=1,4
340 IF(nb_appareance(j)>=3) need_compute=.false. ! only 2 nodes or 1 node
341 IF(nb_appareance(j)==2) merged_node = merged_node + 1 ! check if there are 2 nodes
342 ENDDO
343 IF(merged_node>1) need_compute=.false. ! only 2 nodes
344 ! ----------------
345 ENDIF
346 ! ---------------------------
347 IF(need_compute) THEN
348
349 ! ------------------
350 ! get the node ids
351 DO j=1,node_surf_nb
352 n = pointer_face(j,k) ! get the node of the surfaces
353 IF(n<10) THEN
354 node_id = ix(n+1,elem_id-shift_elm) ! get the node ID
355 ELSE
356 node_id = ix_tetra10(n-10,elem_id-shift_elm) ! get the node ID
357 ENDIF
358 local_node(j) = node_id
359 ENDDO
360 IF(node_surf_nb==3) local_node(4) = local_node(3)
361 ! ------------------
362
363 ! ------------------
364 ! first node of the surface face(1:4,k)
365 node_id = local_node(1)
366
367 nb_result_intersect = shoot_struct%SHIFT_M_NODE_SURF(node_id+1) - shoot_struct%SHIFT_M_NODE_SURF(node_id) ! get the number of surface of the node
368 shift = shoot_struct%SHIFT_M_NODE_SURF(node_id)
369 result_intersect(1:nb_result_intersect) = shoot_struct%M_NODE_SURF( shift+1:shift+nb_result_intersect )
370
371 nb_result_intersect_2 = shoot_struct%SHIFT_M_NODE_PROC(node_id+1) - shoot_struct%SHIFT_M_NODE_PROC(node_id) ! get the number of processor of the node
372 shift = shoot_struct%SHIFT_M_NODE_PROC(node_id)
373 result_intersect_2(1:nb_result_intersect_2) = shoot_struct%M_NODE_PROC( shift+1:shift+nb_result_intersect_2 )
374
375 IF(nb_result_intersect_2>1) THEN
376 several_proc = several_proc + 1
377 ELSEIF(nb_result_intersect_2<1) THEN
378 ! this case is not possible, i hope i'm not here :)
379 ENDIF
380 ! ------------------
381
382 DO j=2,node_surf_nb
383 nb_surface_1 = nb_result_intersect
384 intersect_1(1:nb_surface_1) = result_intersect(1:nb_result_intersect)
385
386 n = pointer_face(j,k) ! get the node of the surfaces
387 node_id = local_node(j) ! get the node ID
388 ! -----------------------
389 ! intersection of surface
390 nb_surface_2 = shoot_struct%SHIFT_M_NODE_SURF(node_id+1) - shoot_struct%SHIFT_M_NODE_SURF(node_id) ! get the number of surface of the node
391 shift = shoot_struct%SHIFT_M_NODE_SURF(node_id)
392 intersect_2(1:nb_surface_2) = shoot_struct%M_NODE_SURF( shift+1:shift+nb_surface_2 )
393 IF(nb_surface_1>0.AND.nb_surface_2>0) THEN
394 CALL intersect_2_sorted_sets( intersect_1,nb_surface_1,
395 . intersect_2,nb_surface_2,
396 . result_intersect,nb_result_intersect )
397 ELSE
398 nb_result_intersect = 0
399 ENDIF
400 ! end : intersection of surface
401 ! -----------------------
402
403 ! -----------------------
404 ! intersection of processor
405 nb_proc_1 = nb_result_intersect_2
406 intersect_3(1:nb_proc_1) = result_intersect_2(1:nb_proc_1)
407
408 nb_proc_2 = shoot_struct%SHIFT_M_NODE_PROC(node_id+1) - shoot_struct%SHIFT_M_NODE_PROC(node_id) ! get the number of processor of the node
409 IF(nb_proc_1>1.AND.nb_proc_2>1) THEN
410 several_proc = several_proc + 1
411 ! -----------------------
412 ! intersection of processor
413 shift = shoot_struct%SHIFT_M_NODE_PROC(node_id)
414 intersect_4(1:nb_proc_2) = shoot_struct%M_NODE_PROC( shift+1:shift+nb_proc_2 )
415
416 CALL intersect_2_sorted_sets( intersect_3,nb_proc_1,
417 . intersect_4,nb_proc_2,
418 . result_intersect_2,nb_result_intersect_2 )
419 ! -----------------------
420 ELSEIF(nb_proc_2<1) THEN
421 ! this case is not possible, i hope i'm not here :)
422 ELSE
423 nb_result_intersect_2 = 0
424 ENDIF
425
426
427 ! end : intersection of processor
428 ! -----------------------
429 ENDDO
430
431 IF(nb_result_intersect>0) THEN
432 ! one or several surface on the current processor
433 ! save the surface id
434
435 IF( shoot_struct%SAVE_SURFACE_NB+nb_result_intersect>shoot_struct%S_SAVE_SURFACE) THEN
436 ALLOCATE( tmp_array(shoot_struct%S_SAVE_SURFACE) )
437 tmp_array(1:shoot_struct%S_SAVE_SURFACE) =
438 . shoot_struct%SAVE_SURFACE(1:shoot_struct%S_SAVE_SURFACE)
439
440 DEALLOCATE( shoot_struct%SAVE_SURFACE )
441 old_size = shoot_struct%S_SAVE_SURFACE
442 shoot_struct%S_SAVE_SURFACE = 1.20*(shoot_struct%S_SAVE_SURFACE+5*nb_result_intersect)
443 ALLOCATE( shoot_struct%SAVE_SURFACE( shoot_struct%S_SAVE_SURFACE ) )
444 shoot_struct%SAVE_SURFACE(1:old_size) = tmp_array(1:old_size)
445 DEALLOCATE( tmp_array )
446 ENDIF
447 DO j=1,nb_result_intersect
448 shoot_struct%SAVE_SURFACE_NB = shoot_struct%SAVE_SURFACE_NB + 1
449 shoot_struct%SAVE_SURFACE( shoot_struct%SAVE_SURFACE_NB ) = result_intersect(j)
450 ENDDO
451 ENDIF
452 IF(nb_result_intersect_2>1) THEN !SEVERAL_PROC==NODE_SURF_NB) THEN
453 ! one or several surface on a remote processor :
454 ! save the remote proc id & the node id
455 ! | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 |
456 ! pi n1 n2 n3 n4 pj n1 n2 n3 n3
457 ! proc id & the 4 nodes | proc id & the 3 nodes of triangle + n4=n3
458
459 IF( shoot_struct%SAVE_PROC_NB+5*(nb_result_intersect_2-1)>shoot_struct%S_SAVE_PROC) THEN
460 ALLOCATE( tmp_array(shoot_struct%S_SAVE_PROC) )
461 tmp_array(1:shoot_struct%S_SAVE_PROC) =
462 . shoot_struct%SAVE_PROC(1:shoot_struct%S_SAVE_PROC)
463
464 DEALLOCATE( shoot_struct%SAVE_PROC )
465 old_size = shoot_struct%S_SAVE_PROC
466 shoot_struct%S_SAVE_PROC = 1.20*(shoot_struct%SAVE_PROC_NB+5*(nb_result_intersect_2-1))
467 ALLOCATE( shoot_struct%SAVE_PROC( shoot_struct%S_SAVE_PROC ) )
468 shoot_struct%SAVE_PROC(1:old_size) = tmp_array(1:old_size)
469 DEALLOCATE( tmp_array )
470 ENDIF
471
472 DO j=1,nb_result_intersect_2
473 IF(result_intersect_2(j)/=ispmd+1) THEN
474 shoot_struct%SAVE_PROC_NB = shoot_struct%SAVE_PROC_NB + 1
475 shoot_struct%SAVE_PROC( shoot_struct%SAVE_PROC_NB ) = result_intersect_2(j) ! save the remote proc id
476
477 IF(node_surf_nb==3) local_node(4) = local_node(3)
478 DO ijk=1,4
479 shoot_struct%SAVE_PROC_NB = shoot_struct%SAVE_PROC_NB + 1
480 shoot_struct%SAVE_PROC( shoot_struct%SAVE_PROC_NB ) = itab(local_node(ijk)) ! convert local id to global id
481
482 ENDDO
483 ENDIF
484 ENDDO
485 ELSE
486 ! no surface on the current processor or on a remote processor
487 ENDIF
488 ENDIF
489 ! ---------------------------
490 ENDDO
491 ! end : loop over the surfaces of the element
492 ! ----------------------
493 ENDIF
494 ENDDO
495 ! --------------------------
496
497 ! --------------------------
498 ! working array : surface
499 DEALLOCATE( result_intersect )
500 DEALLOCATE( intersect_1 )
501 DEALLOCATE( intersect_2 )
502 ! working array : processor
503 DEALLOCATE( result_intersect_2 )
504 DEALLOCATE( intersect_3 )
505 DEALLOCATE( intersect_4 )
506 ! --------------------------
507
508 RETURN
myqsort_int
subroutine myqsort_int(n, a, perm, error)
Definition myqsort_int.F:36
shooting_node_mod
Definition shooting_node_mod.F:46