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 34 of file find_surface_inter.F.

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