OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
monvol_check_delete_duplicated.F
Go to the documentation of this file.
1Copyright> OpenRadioss
2Copyright> Copyright (C) 1986-2025 Altair Engineering Inc.
3Copyright>
4Copyright> This program is free software: you can redistribute it and/or modify
5Copyright> it under the terms of the GNU Affero General Public License as published by
6Copyright> the Free Software Foundation, either version 3 of the License, or
7Copyright> (at your option) any later version.
8Copyright>
9Copyright> This program is distributed in the hope that it will be useful,
10Copyright> but WITHOUT ANY WARRANTY; without even the implied warranty of
11Copyright> MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12Copyright> GNU Affero General Public License for more details.
13Copyright>
14Copyright> You should have received a copy of the GNU Affero General Public License
15Copyright> along with this program. If not, see <https://www.gnu.org/licenses/>.
16Copyright>
17Copyright>
18Copyright> Commercial Alternative: Altair Radioss Software
19Copyright>
20Copyright> As an alternative to this open-source version, Altair also offers Altair Radioss
21Copyright> software under a commercial license. Contact Altair to discuss further if the
22Copyright> commercial version may interest you: https://www.altair.com/radioss/.
23!||====================================================================
24!|| monvol_check_delete_duplicated ../starter/source/airbag/monvol_check_delete_duplicated.F
25!||--- called by ------------------------------------------------------
26!|| init_monvol ../starter/source/airbag/init_monvol.F
27!||--- calls -----------------------------------------------------
28!|| ancmsg ../starter/source/output/message/message.F
29!||--- uses -----------------------------------------------------
30!|| message_mod ../starter/share/message_module/message_mod.F
31!|| monvol_struct_mod ../starter/share/modules1/monvol_struct_mod.F
32!||====================================================================
33 SUBROUTINE monvol_check_delete_duplicated(T_MONVOLN, NTG, NTGI, ITAB)
34C-----------------------------------------------
35C M o d u l e s
36C-----------------------------------------------
37 USE my_alloc_mod
38 USE monvol_struct_mod
39 USE message_mod
40C-----------------------------------------------
41C I m p l i c i t T y p e s
42C-----------------------------------------------
43#include "implicit_f.inc"
44C-----------------------------------------------
45C C o m m o n B l o c k s
46C-----------------------------------------------
47#include "com04_c.inc"
48C-----------------------------------------------
49C D u m m y A r g u m e n t s
50C-----------------------------------------------
51 TYPE(monvol_struct_), INTENT(INOUT) :: T_MONVOLN
52 INTEGER, INTENT(INOUT) :: NTG, NTGI
53 INTEGER, DIMENSION(NUMNOD), INTENT(IN) :: ITAB
54C-----------------------------------------------
55C L o c a l V a r i a b l e s
56C-----------------------------------------------
57 INTEGER(8) :: EDGE_PTR, PAIR_VEC_PTR, GRAPH_PTR, LIST_PTR
58 INTEGER :: II, JJ, KK, IDX, NEDGE
59 INTEGER, DIMENSION(:), ALLOCATABLE :: EDGE_ARRAY_N1, EDGE_ARRAY_N2,
60 . EDGE_ARRAY_ELEM, NB_CONNECT, EDGE_ELEM, IAD_EDGE_ELEM, PAIR_LIST,
61 . SIZES, INV_LIST, LIST
62 INTEGER :: NB_DUPLICATED_ELTS, NODE_LIST1(3), NODE_LIST2(3), IAD1, IAD2, NB_CON,
63 . IELEM1, IELEM2, NB_COMMON_NODE, ELEM_ID1, ELEM_ID2, NPAIR
64 INTEGER :: NB_CONNEX_COMP, ICOMP, PATH_SIZE
65 INTEGER, DIMENSION(:), ALLOCATABLE :: FLAG_ELEM, PATHS
66 INTEGER :: NTG_NEW, NTGI_NEW
67 INTEGER, DIMENSION(:, :), ALLOCATABLE :: ELEM
68 INTEGER, DIMENSION(:), ALLOCATABLE :: ISAVE
69
70 CALL my_alloc(isave, (ntg + ntgi))
71! Resize and copy ELTG
72 DO ii = 1, ntg + ntgi
73 isave(ii) = t_monvoln%ELTG(ii)
74 ENDDO
75 DEALLOCATE(t_monvoln%ELTG)
76 CALL my_alloc(t_monvoln%ELTG, (ntg + ntgi))
77 DO ii = 1, ntg + ntgi
78 t_monvoln%ELTG(ii) = isave(ii)
79 ENDDO
80! Build edges of the elements
81 CALL my_alloc(edge_array_n1, (3 * (ntg + ntgi)))
82 CALL my_alloc(edge_array_n2, (3 * (ntg + ntgi)))
83 CALL my_alloc(edge_array_elem, (3 * (ntg + ntgi)))
84 idx = 0
85 DO ii = 1, ntg + ntgi
86 edge_array_n1(idx + 1) = min(t_monvoln%ELEM(1, ii), t_monvoln%ELEM(2, ii))
87 edge_array_n2(idx + 1) = max(t_monvoln%ELEM(1, ii), t_monvoln%ELEM(2, ii))
88 edge_array_n1(idx + 2) = min(t_monvoln%ELEM(2, ii), t_monvoln%ELEM(3, ii))
89 edge_array_n2(idx + 2) = max(t_monvoln%ELEM(2, ii), t_monvoln%ELEM(3, ii))
90 edge_array_n1(idx + 3) = min(t_monvoln%ELEM(3, ii), t_monvoln%ELEM(1, ii))
91 edge_array_n2(idx + 3) = max(t_monvoln%ELEM(3, ii), t_monvoln%ELEM(1, ii))
92 edge_array_elem(idx + 1 : idx + 3) = ii
93 idx = idx + 3
94 ENDDO
95 nedge = idx
96
97! Edge sorting and compaction
98 edge_ptr = 0
99 CALL edge_sort(edge_ptr, edge_array_n1, edge_array_n2, edge_array_elem, nedge)
100
101 CALL my_alloc(nb_connect, (nedge))
102 CALL edge_get_nb_connect(edge_ptr, nb_connect)
103 CALL my_alloc(edge_elem, (sum(nb_connect)))
104 CALL my_alloc(iad_edge_elem, (nedge + 1))
105 CALL edge_get_connect(edge_ptr, edge_elem)
106
107 iad_edge_elem(1) = 1
108 DO ii = 2, nedge + 1
109 iad_edge_elem(ii) = iad_edge_elem(ii - 1) + nb_connect(ii - 1)
110 ENDDO
111
112! Check for duplicated elements
113 CALL intvector_create(pair_vec_ptr)
114 DO ii = 1, nedge
115 iad1 = iad_edge_elem(ii)
116 iad2 = iad_edge_elem(ii + 1) - 1
117 nb_con = iad2 - iad1 + 1
118 IF (nb_con > 2) THEN
119! T-connection, or worse, or simply duplicated elements
120 DO ielem1 = iad1, iad2
121 DO ielem2 = iad1, iad2
122 elem_id1 = edge_elem(ielem1)
123 elem_id2 = edge_elem(ielem2)
124 IF (elem_id1 /= elem_id2) THEN
125 node_list1(1:3) = t_monvoln%ELEM(1:3, elem_id1)
126 node_list2(1:3) = t_monvoln%ELEM(1:3, elem_id2)
127 nb_common_node = 0
128 DO jj = 1, 3
129 DO kk = 1, 3
130 IF (node_list1(jj) == node_list2(kk)) THEN
131 nb_common_node = nb_common_node + 1
132 EXIT
133 ENDIF
134 ENDDO
135 ENDDO
136 IF (nb_common_node == 3) THEN
137! IELEM2 is duplicated from IELEM1
138 CALL intvector_push_back(pair_vec_ptr, elem_id1)
139 CALL intvector_push_back(pair_vec_ptr, elem_id2)
140 ENDIF
141 ENDIF
142 ENDDO
143 ENDDO
144 ENDIF
145 ENDDO
146
147! Get pairs of duplicated elements
148 CALL intvector_get_size(pair_vec_ptr, npair)
149 CALL my_alloc(pair_list, (npair))
150 CALL intvector_copy_to(pair_vec_ptr, pair_list)
151 npair = npair / 2
152
153! Reduce
154 CALL my_alloc(flag_elem, (ntg + ntgi))
155 flag_elem(1:ntg + ntgi) = 0
156 CALL my_alloc(inv_list, (ntg + ntgi))
157 inv_list(1:ntg + ntgi) = 0
158
159 nb_duplicated_elts = 0
160 CALL intvector_create(list_ptr)
161 DO ii = 1, npair
162 IF (flag_elem(pair_list(2 * (ii - 1) + 1)) == 0) THEN
163 CALL intvector_push_back(list_ptr, pair_list(2 * (ii - 1) + 1))
164 nb_duplicated_elts = nb_duplicated_elts + 1
165 inv_list(pair_list(2 * (ii - 1) + 1)) = nb_duplicated_elts
166 flag_elem(pair_list(2 * (ii - 1) + 1)) = 1
167 ENDIF
168 IF (flag_elem(pair_list(2 * (ii - 1) + 2)) == 0) THEN
169 CALL intvector_push_back(list_ptr, pair_list(2 * (ii - 1) + 2))
170 nb_duplicated_elts = nb_duplicated_elts + 1
171 inv_list(pair_list(2 * (ii - 1) + 2)) = nb_duplicated_elts
172 flag_elem(pair_list(2 * (ii - 1) + 2)) = 1
173 ENDIF
174 ENDDO
175
176 IF (nb_duplicated_elts == 0) THEN
177 RETURN
178 ENDIF
179
180 CALL intvector_get_size(list_ptr, nb_duplicated_elts)
181 CALL my_alloc(list, (nb_duplicated_elts))
182 CALL intvector_copy_to(list_ptr, list)
183
184 DO ii = 1, npair
185 pair_list(2 * (ii - 1) + 1) = inv_list(pair_list(2 * (ii - 1) + 1)) - 1
186 pair_list(2 * (ii - 1) + 2) = inv_list(pair_list(2 * (ii - 1) + 2)) - 1
187 ENDDO
188
189 graph_ptr = 0
190 CALL graph_build_path(nb_duplicated_elts, npair, pair_list, nb_connex_comp, graph_ptr)
191 CALL my_alloc(sizes, (nb_connex_comp))
192 CALL graph_get_sizes(graph_ptr, sizes)
193 path_size = sum(sizes)
194 CALL my_alloc(paths, (path_size))
195 CALL graph_get_path(graph_ptr, paths)
196
197 DO ii = 1, path_size
198 paths(ii) = list(paths(ii) + 1)
199 ENDDO
200
201
202! Flag Elems to suppress
203 flag_elem(1:ntg + ntgi) = 1
204 iad1 = 1
205 DO icomp = 1, nb_connex_comp
206 iad2 = iad1 + sizes(icomp) - 1
207 CALL quicksort_i(paths(iad1:iad2), iad1, iad2)
208 elem_id1 = paths(iad1)
209 node_list1(1:3) = 0
210
211 !NODE_LIST1(1:3) = ITAB(T_MONVOLN%ELEM(1:3, ELEM_ID1))
212 IF(t_monvoln%ELEM(1, elem_id1) > 0 .AND. t_monvoln%ELEM(1,elem_id1) <= numnod)
213 . node_list1(1) = itab(t_monvoln%ELEM(1, elem_id1))
214 IF(t_monvoln%ELEM(2, elem_id1) > 0 .AND. t_monvoln%ELEM(2,elem_id1) <= numnod)
215 . node_list1(2) = itab(t_monvoln%ELEM(2, elem_id1))
216 IF(t_monvoln%ELEM(3, elem_id1) > 0 .AND. t_monvoln%ELEM(3,elem_id1) <= numnod)
217 . node_list1(3) = itab(t_monvoln%ELEM(3, elem_id1))
218
219 CALL ancmsg(msgid = 2072, anmode = aninfo, msgtype = msgwarning,
220 . i1 = t_monvoln%ID, c1 = t_monvoln%TITLE,
221 . i2 = node_list1(1), i3 = node_list1(2), i4 = node_list1(3), i5 = sizes(icomp)-1)
222 DO ii = iad1 + 1, iad2
223 flag_elem(paths(ii)) = 0
224 ENDDO
225 iad1 = iad1 + sizes(icomp)
226 ENDDO
227
228 ntg_new = sum(flag_elem(1:ntg))
229 ntgi_new = sum(flag_elem(ntg + 1:ntg + ntgi))
230
231 CALL my_alloc(elem, 3, ntg_new + ntgi_new)
232 iad1 = 1
233 DO ii = 1, ntg + ntgi
234 IF (flag_elem(ii) == 1) THEN
235 elem(1:3, iad1) = t_monvoln%ELEM(1:3, ii)
236 iad1 = iad1 + 1
237 ENDIF
238 ENDDO
239 DEALLOCATE(t_monvoln%ELEM)
240! Resize and copy FVBAG_ELEMID
241 DO ii = 1, ntg + ntgi
242 isave(ii) = t_monvoln%FVBAG_ELEMID(ii)
243 ENDDO
244 DEALLOCATE(t_monvoln%FVBAG_ELEMID)
245 CALL my_alloc(t_monvoln%FVBAG_ELEMID, ntg_new + ntgi_new)
246 iad1 = 1
247 DO ii = 1, ntg + ntgi
248 IF (flag_elem(ii) == 1) THEN
249 t_monvoln%FVBAG_ELEMID(iad1) = isave(ii)
250 iad1 = iad1 + 1
251 ENDIF
252 ENDDO
253! Resize and copy ELTG
254 DO ii = 1, ntg + ntgi
255 isave(ii) = t_monvoln%ELTG(ii)
256 ENDDO
257 DEALLOCATE(t_monvoln%ELTG)
258 CALL my_alloc(t_monvoln%ELTG, (ntg_new + ntgi_new))
259 iad1 = 1
260 DO ii = 1, ntg + ntgi
261 IF (flag_elem(ii) == 1) THEN
262 t_monvoln%ELTG(iad1) = isave(ii)
263 iad1 = iad1 + 1
264 ENDIF
265 ENDDO
266
267 t_monvoln%NTG = ntg_new
268 t_monvoln%NTGI = ntgi_new
269 ntg = ntg_new
270 ntgi = ntgi_new
271 CALL my_alloc(t_monvoln%ELEM, 3, ntg + ntgi)
272 DO ii = 1, ntg + ntgi
273 t_monvoln%ELEM(1:3, ii) = elem(1:3, ii)
274 ENDDO
275
276! *********************** !
277! * Memory deallocation * !
278! *********************** !
279 CALL edge_free_memory(edge_ptr)
280 CALL intvector_delete(pair_vec_ptr)
281 CALL intvector_delete(list_ptr)
282 DEALLOCATE(isave)
283 DEALLOCATE(edge_array_n1)
284 DEALLOCATE(edge_array_n2)
285 DEALLOCATE(edge_array_elem)
286 DEALLOCATE(nb_connect)
287 DEALLOCATE(edge_elem)
288 DEALLOCATE(iad_edge_elem)
289 DEALLOCATE(pair_list)
290 DEALLOCATE(flag_elem)
291 DEALLOCATE(sizes)
292 DEALLOCATE(paths)
293 DEALLOCATE(elem)
294 END SUBROUTINE monvol_check_delete_duplicated
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
monvol_check_delete_duplicated
subroutine monvol_check_delete_duplicated(t_monvoln, ntg, ntgi, itab)
Definition monvol_check_delete_duplicated.F:34
message_mod
Definition message_mod.F:1249
monvol_struct_mod
Definition monvol_struct_mod.F:66
quicksort_i
recursive subroutine quicksort_i(a, first, last)
Definition quicksort.F:92
ancmsg
subroutine ancmsg(msgid, msgtype, anmode, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, r1, r2, r3, r4, r5, r6, r7, r8, r9, c1, c2, c3, c4, c5, c6, c7, c8, c9, prmode)
Definition message.F:889
monvol_struct_mod::monvol_struct_
Definition monvol_struct_mod.F:84