OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
monvol_struct_mod.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_struct_mod ../starter/share/modules1/monvol_struct_mod.F
25!||--- called by ------------------------------------------------------
26!|| aleno ../starter/source/airbag/fvmbag1.F
27!|| applysort2fvm ../starter/source/airbag/fvmesh0.F
28!|| ddsplit ../starter/source/restart/ddsplit/ddsplit.F
29!|| deallocate_igrsurf_split ../starter/source/spmd/deallocate_igrsurf_split.F
30!|| domdec2 ../starter/source/spmd/domdec2.F
31!|| dometis ../starter/source/spmd/domain_decomposition/grid2mat.F
32!|| fillcne ../starter/source/spmd/domdec2.F
33!|| fvbag_vertex ../starter/source/spmd/domain_decomposition/grid2mat.F
34!|| fvbric1 ../starter/source/airbag/fvbric1.F
35!|| fvdim ../starter/source/airbag/fvmesh.F
36!|| fvmesh0 ../starter/source/airbag/fvmesh0.F
37!|| fvnodi ../starter/source/airbag/fvmbag1.F
38!|| hm_read_monvol_type1 ../starter/source/airbag/hm_read_monvol_type1.F
39!|| hm_read_monvol_type10 ../starter/source/airbag/hm_read_monvol_type10.F
40!|| hm_read_monvol_type11 ../starter/source/airbag/hm_read_monvol_type11.F
41!|| hm_read_monvol_type2 ../starter/source/airbag/hm_read_monvol_type2.F
42!|| hm_read_monvol_type3 ../starter/source/airbag/hm_read_monvol_type3.F
43!|| hm_read_monvol_type4 ../starter/source/airbag/hm_read_monvol_type4.F
44!|| hm_read_monvol_type5 ../starter/source/airbag/hm_read_monvol_type5.F
45!|| hm_read_monvol_type6 ../starter/source/airbag/hm_read_monvol_type6.F
46!|| hm_read_monvol_type7 ../starter/source/airbag/hm_read_monvol_type7.F
47!|| hm_read_monvol_type8 ../starter/source/airbag/hm_read_monvol_type8.F
48!|| hm_read_monvol_type9 ../starter/source/airbag/hm_read_monvol_type9.F
49!|| hm_read_thgrou ../starter/source/output/th/hm_read_thgrou.F
50!|| hm_thgrki_vent ../starter/source/output/th/hm_thgrki_vent.F
51!|| hypermesh_tetra ../starter/stub/fvmbags_stub.F
52!|| igrsurf_split ../starter/source/spmd/igrsurf_split.F
53!|| init_monvol ../starter/source/airbag/init_monvol.F
54!|| lectur ../starter/source/starter/lectur.F
55!|| monvol_build_edges ../starter/share/modules1/monvol_struct_mod.F
56!|| monvol_check_delete_duplicated ../starter/source/airbag/monvol_check_delete_duplicated.F
57!|| monvol_orient_surf ../starter/share/modules1/monvol_struct_mod.F
58!|| monvol_reverse_normals ../starter/share/modules1/monvol_struct_mod.F
59!|| monvol_triangulate_surface ../starter/source/airbag/monvol_triangulate_surface.F
60!|| read_monvol ../starter/source/airbag/read_monvol.F
61!|| st_qaprint_driver ../starter/source/output/qaprint/st_qaprint_driver.F
62!|| st_qaprint_monvol ../starter/source/output/qaprint/st_qaprint_monvol.F
63!|| w_monvol ../starter/source/restart/ddsplit/w_monvol.F
64!||--- uses -----------------------------------------------------
65!||====================================================================
66 MODULE monvol_struct_mod
67C-----------------------------------------------
68C M o d u l e s
69C-----------------------------------------------
70 USE names_and_titles_mod , ONLY : nchartitle
71C-----------------------------------------------
72C I m p l i c i t T y p e s
73C-----------------------------------------------
74#include "my_real.inc"
75C-----------------------------------------------
76 TYPE monvol_metadata_
77 INTEGER :: nvolu
78! Temporary
79 INTEGER :: lca
80 INTEGER, DIMENSION(:, :), ALLOCATABLE :: icbag
81 my_real, DIMENSION(:, :), ALLOCATABLE :: rcbag
82 END TYPE monvol_metadata_
83
84 TYPE monvol_struct_
85! Monvol type
86 INTEGER :: type
87! Monvol ID
88 INTEGER :: id
89!
90 INTEGER :: nca
91! Monvol name
92 CHARACTER(LEN = nchartitle) :: title
93! External surface Id, Internal surface id (internal numbering)
94 INTEGER :: ext_surfid, int_surfid
95! IVOLU -> integer attributes
96 INTEGER, DIMENSION(:), ALLOCATABLE :: ivolu
97! RVOLU -> double precision attributes
98 my_real, DIMENSION(:), ALLOCATABLE :: rvolu
99! Number of injectors
100 INTEGER :: njet
101! Integer info on injectors (NJET x NIBJET)
102 INTEGER, DIMENSION(:, :), ALLOCATABLE :: ibagjet
103! Real info on injectors (NJET x NRBJET)
104 my_real, DIMENSION(:, :), ALLOCATABLE :: rbagjet
105! Vent holes and porous surfaces
106 INTEGER :: nvent, nporsurf
107! Integer data
108 INTEGER, DIMENSION(:, :), ALLOCATABLE :: ibaghol
109! Real data
110 my_real, DIMENSION(:, :), ALLOCATABLE :: rbaghol
111! BUFALEI
112 INTEGER :: nns, nni ! Number of external, internal surface node
113 INTEGER, DIMENSION(:), ALLOCATABLE :: nodes
114 INTEGER :: ntg, ntgi
115 INTEGER, DIMENSION(:, :), ALLOCATABLE :: elem
116 INTEGER, DIMENSION(:), ALLOCATABLE :: itagel
117 INTEGER, DIMENSION(:), ALLOCATABLE :: fvbag_elemid
118! Adress of element inside IXC and IXTG
119 INTEGER, DIMENSION(:), ALLOCATABLE :: eltg
120! Store mat number of triagnel surface
121 INTEGER, DIMENSION(:), ALLOCATABLE :: mattg
122!
123 INTEGER :: nbric
124 INTEGER, DIMENSION(:, :), ALLOCATABLE :: tbric, tfac
125! TAGELS
126 INTEGER, DIMENSION(:), ALLOCATABLE :: tagels
127!
128 INTEGER :: nna
129 INTEGER, DIMENSION(:), ALLOCATABLE :: ibufa
130!
131 INTEGER :: ntga
132 INTEGER, DIMENSION(:, :), ALLOCATABLE :: elema, brna
133 INTEGER, DIMENSION(:), ALLOCATABLE :: tagela
134 INTEGER, DIMENSION(:, :), ALLOCATABLE :: ncona
135!
136 my_real, DIMENSION(:, :), ALLOCATABLE :: velocity, node_coord
137 my_real, DIMENSION(:), ALLOCATABLE :: porosity, elarea
138 INTEGER, DIMENSION(:, :), ALLOCATABLE :: thsurf_tag
139! Automatic meshing
140 INTEGER :: imesh_all, kmesh
141! Automatic surface hole filling
142 INTEGER :: nb_fill_tri
143 INTEGER, DIMENSION(:), ALLOCATABLE :: fill_tri
144! Edges connectivity
145 LOGICAL :: edges_built
146 INTEGER :: nedge
147 INTEGER, DIMENSION(:), ALLOCATABLE :: edge_node1, edge_node2, edge_elem, iad_edge_elem
148! Keep old adresses until full conversion is done
149 INTEGER :: iadale, iadale2, iadale3, iadale4, iadale5, iadale6, iadale7, iadale8, iadale9,
150 . iadale10, iadale11, iadale12, iadale13, kra5, kra6, kr5
151 LOGICAL :: ok_reorient
152
153 INTEGER, DIMENSION(:), ALLOCATABLE :: number_tri_per_proc
154 END TYPE monvol_struct_
155
156 CONTAINS
157!||====================================================================
158!|| copy_to_monvol ../starter/share/modules1/monvol_struct_mod.F
159!||--- called by ------------------------------------------------------
160!|| lectur ../starter/source/starter/lectur.F
161!||====================================================================
162 SUBROUTINE copy_to_monvol(T_MONVOL, LICBAG, ICBAG, SMONVOL, MONVOL)
163C-----------------------------------------------
164C I m p l i c i t T y p e s
165C-----------------------------------------------
166#include "implicit_f.inc"
167C-----------------------------------------------
168C C o m m o n B l o c k s
169C-----------------------------------------------
170#include "param_c.inc"
171#include "com04_c.inc"
172C-----------------------------------------------
173C D u m m y A r g u m e n t s
174C-----------------------------------------------
175 INTEGER, INTENT(IN) :: SMONVOL, LICBAG
176 INTEGER, DIMENSION(LICBAG), INTENT(IN) :: ICBAG
177 INTEGER, DIMENSION(SMONVOL), INTENT(INOUT) :: MONVOL
178 TYPE(monvol_struct_), DIMENSION(NVOLU), INTENT(IN) :: T_MONVOL
179C-----------------------------------------------
180C L o c a l v a r i a b l e s
181C-----------------------------------------------
182 INTEGER :: II, JJ, KK, I, ICOPY, N
183 INTEGER :: NVENT
184 INTEGER :: SHIFT
185
186 shift = licbag
187 DO n = 1, nvolu
188 shift = shift + nimv
189 shift = shift + nibjet * t_monvol(n)%NJET
190 shift = shift + nibhol * t_monvol(n)%NVENT
191 ENDDO
192
193 i = 1
194 DO ii = 1, nvolu
195 DO jj = 1, nimv
196 monvol(i) = t_monvol(ii)%IVOLU(jj)
197 i = i + 1
198 ENDDO
199 ENDDO
200 monvol(i:i + licbag - 1) = icbag(1:licbag)
201 i = i + licbag
202 DO ii = 1, nvolu
203 DO jj = 1, t_monvol(ii)%NJET
204 DO kk = 1, nibjet
205 monvol(i) = t_monvol(ii)%IBAGJET(kk, jj)
206 i = i + 1
207 ENDDO
208 ENDDO
209 ENDDO
210 DO ii = 1, nvolu
211 nvent = t_monvol(ii)%NVENT
212 DO jj = 1, nvent
213 DO kk = 1, nibhol
214 monvol(i) = t_monvol(ii)%IBAGHOL(kk, jj)
215 i = i + 1
216 ENDDO
217 ENDDO
218 ENDDO
219 icopy = i
220 DO n = 1, nvolu
221 IF (t_monvol(n)%TYPE == 6 .OR. t_monvol(n)%TYPE == 8) THEN
222 icopy = shift + t_monvol(n)%IADALE
223 ENDIF
224 DO i = 1, t_monvol(n)%NNS + t_monvol(n)%NNI
225 monvol(icopy) = t_monvol(n)%NODES(i)
226 icopy = icopy + 1
227 ENDDO
228 DO i = 1, t_monvol(n)%NTG + t_monvol(n)%NTGI
229 monvol(icopy) = t_monvol(n)%ELEM(1, i)
230 icopy = icopy + 1
231 monvol(icopy) = t_monvol(n)%ELEM(2, i)
232 icopy = icopy + 1
233 monvol(icopy) = t_monvol(n)%ELEM(3, i)
234 icopy = icopy + 1
235 ENDDO
236 DO i = 1, t_monvol(n)%NTG + t_monvol(n)%NTGI
237 monvol(icopy) = t_monvol(n)%ITAGEL(i)
238 icopy = icopy + 1
239 ENDDO
240 DO i = 1, t_monvol(n)%NTG + t_monvol(n)%NTGI
241 monvol(icopy) = t_monvol(n)%ELTG(i)
242 icopy = icopy + 1
243 ENDDO
244 DO i = 1, t_monvol(n)%NTG + t_monvol(n)%NTGI
245 monvol(icopy) = t_monvol(n)%MATTG(i)
246 icopy = icopy + 1
247 ENDDO
248 DO i = 1, t_monvol(n)%NBRIC
249 DO ii = 1, 2
250 monvol(icopy) = t_monvol(n)%TBRIC(ii, i)
251 icopy = icopy + 1
252 ENDDO
253 ENDDO
254 DO i = 1, t_monvol(n)%NBRIC
255 DO ii = 1, 12
256 monvol(icopy) = t_monvol(n)%TFAC(ii, i)
257 icopy = icopy + 1
258 ENDDO
259 ENDDO
260 DO i = 1, t_monvol(n)%NTG + 2 * t_monvol(n)%NTGI
261 monvol(icopy) = t_monvol(n)%TAGELS(i)
262 icopy = icopy + 1
263 ENDDO
264 icopy = t_monvol(n)%IADALE8 + shift
265 IF (t_monvol(n)%IADALE8 == 0) icopy = icopy + 1
266 DO i = 1, t_monvol(n)%NNA
267 monvol(icopy) = t_monvol(n)%IBUFA(i)
268 icopy = icopy + 1
269 ENDDO
270 IF (t_monvol(n)%NBRIC == 0) THEN
271 icopy = t_monvol(n)%IADALE9 + shift
272 IF (t_monvol(n)%IADALE9 == 0) icopy = icopy + 1
273 ENDIF
274 DO i = 1, t_monvol(n)%NTGA
275 DO ii = 1, 3
276 monvol(icopy) = t_monvol(n)%ELEMA(ii, i)
277 icopy = icopy + 1
278 ENDDO
279 ENDDO
280 DO i = 1, t_monvol(n)%NTGA
281 monvol(icopy) = t_monvol(n)%TAGELA(i)
282 icopy = icopy + 1
283 ENDDO
284 DO i = 1, t_monvol(n)%NBRIC
285 DO ii = 1, 8
286 monvol(icopy) = t_monvol(n)%BRNA(ii, i)
287 icopy = icopy + 1
288 ENDDO
289 ENDDO
290 DO i = 1, t_monvol(n)%NNA
291 DO ii = 1, 16
292 monvol(icopy) = t_monvol(n)%NCONA(ii, i)
293 icopy = icopy + 1
294 ENDDO
295 ENDDO
296 IF (t_monvol(n)%NTGI > 0) THEN
297 DO jj = 1, nsurf
298 DO i = 1, t_monvol(n)%NTGI + 1
299 monvol(icopy) = t_monvol(n)%THSURF_TAG(jj, i)
300 icopy = icopy + 1
301 ENDDO
302 ENDDO
303 ENDIF
304 ENDDO
305 END SUBROUTINE copy_to_monvol
306
307!||====================================================================
308!|| copy_to_volmon ../starter/share/modules1/monvol_struct_mod.F
309!||--- called by ------------------------------------------------------
310!|| lectur ../starter/source/starter/lectur.F
311!||====================================================================
312 SUBROUTINE copy_to_volmon(T_MONVOL, LRCBAG, RCBAG, SVOLMON, VOLMON)
313C-----------------------------------------------
314C I m p l i c i t T y p e s
315C-----------------------------------------------
316#include "implicit_f.inc"
317C-----------------------------------------------
318C C o m m o n B l o c k s
319C-----------------------------------------------
320#include "param_c.inc"
321#include "com04_c.inc"
322C-----------------------------------------------
323C D u m m y A r g u m e n t s
324C-----------------------------------------------
325 INTEGER, INTENT(IN) :: SVOLMON, LRCBAG
326 my_real, DIMENSION(LRCBAG), INTENT(IN) :: rcbag
327 my_real, DIMENSION(SVOLMON), INTENT(INOUT) :: volmon
328 TYPE(monvol_struct_), DIMENSION(NVOLU), INTENT(IN) :: T_MONVOL
329C-----------------------------------------------
330C L o c a l v a r i a b l e s
331C-----------------------------------------------
332 INTEGER :: II, JJ, KK, I, ICOPY
333 INTEGER :: NVENT, NJET
334! ***** !
335! RVOLU !
336! ***** !
337 icopy = 1
338 DO ii = 1, nvolu
339 DO jj = 1, nrvolu
340 volmon(icopy) = t_monvol(ii)%RVOLU(jj)
341 icopy = icopy + 1
342 ENDDO
343 ENDDO
344 DO i = 1, lrcbag
345 volmon(icopy) = rcbag(i)
346 icopy = icopy + 1
347 ENDDO
348
349 DO ii = 1, nvolu
350 njet = t_monvol(ii)%NJET
351 DO jj = 1, njet
352 DO kk = 1, nrbjet
353 volmon(icopy) = t_monvol(ii)%RBAGJET(kk, jj)
354 icopy = icopy + 1
355 ENDDO
356 ENDDO
357 ENDDO
358! RBAGHOL
359 DO ii = 1, nvolu
360 nvent = t_monvol(ii)%NVENT
361 DO jj = 1, nvent
362 DO kk = 1, nrbhol
363 volmon(icopy) = t_monvol(ii)%RBAGHOL(kk, jj)
364 icopy = icopy + 1
365 ENDDO
366 ENDDO
367 ENDDO
368
369! ******* !
370! BUFALER !
371! ******* !
372 DO ii = 1, nvolu
373! Velocities and node coordinates
374 IF (t_monvol(ii)%KR5 > 0) THEN
375 icopy = t_monvol(ii)%KR5
376 DO jj = 1, t_monvol(ii)%NTG + t_monvol(ii)%NTGI
377 volmon(icopy) = t_monvol(ii)%ELAREA(jj)
378 icopy = icopy + 1
379 ENDDO
380 ENDIF
381 IF (t_monvol(ii)%KRA5 > 0) THEN
382 icopy = t_monvol(ii)%KRA5
383 DO jj = 1, t_monvol(ii)%NNA
384 volmon(icopy) = t_monvol(ii)%NODE_COORD(1, jj)
385 icopy = icopy + 1
386 volmon(icopy) = t_monvol(ii)%NODE_COORD(2, jj)
387 icopy = icopy + 1
388 volmon(icopy) = t_monvol(ii)%NODE_COORD(3, jj)
389 icopy = icopy + 1
390 ENDDO
391 icopy = icopy + 3 * t_monvol(ii)%NNA
392 DO jj = 1, t_monvol(ii)%NTGI
393 volmon(icopy) = t_monvol(ii)%POROSITY(jj)
394 icopy = icopy + 1
395 ENDDO
396 ENDIF
397 ENDDO
398 END SUBROUTINE copy_to_volmon
399
400!||====================================================================
401!|| monvol_check_surfclose ../starter/share/modules1/monvol_struct_mod.F
402!||--- called by ------------------------------------------------------
403!|| hm_read_monvol_type1 ../starter/source/airbag/hm_read_monvol_type1.F
404!|| hm_read_monvol_type10 ../starter/source/airbag/hm_read_monvol_type10.F
405!|| hm_read_monvol_type11 ../starter/source/airbag/hm_read_monvol_type11.F
406!|| hm_read_monvol_type2 ../starter/source/airbag/hm_read_monvol_type2.F
407!|| hm_read_monvol_type3 ../starter/source/airbag/hm_read_monvol_type3.F
408!|| hm_read_monvol_type4 ../starter/source/airbag/hm_read_monvol_type4.F
409!|| hm_read_monvol_type5 ../starter/source/airbag/hm_read_monvol_type5.F
410!|| hm_read_monvol_type6 ../starter/source/airbag/hm_read_monvol_type6.F
411!|| hm_read_monvol_type7 ../starter/source/airbag/hm_read_monvol_type7.F
412!|| hm_read_monvol_type8 ../starter/source/airbag/hm_read_monvol_type8.F
413!|| hm_read_monvol_type9 ../starter/source/airbag/hm_read_monvol_type9.F
414!||--- calls -----------------------------------------------------
415!|| ancmsg ../starter/source/output/message/message.F
416!|| monvol_build_edges ../starter/share/modules1/monvol_struct_mod.F
417!||--- uses -----------------------------------------------------
418!|| message_mod ../starter/share/message_module/message_mod.F
419!||====================================================================
420 SUBROUTINE monvol_check_surfclose(T_MONVOLN, ITAB, SURF, X)
421C-----------------------------------------------
422C M o d u l e s
423C-----------------------------------------------
424 USE groupdef_mod
425 USE message_mod
426C-----------------------------------------------
427C I m p l i c i t T y p e s
428C-----------------------------------------------
429#include "implicit_f.inc"
430C-----------------------------------------------
431C C o m m o n B l o c k s
432C-----------------------------------------------
433C NSURF
434#include "com04_c.inc"
435C NIMV
436#include "param_c.inc"
437C nchartitle
438#include "scr17_c.inc"
439C IOUT
440#include "units_c.inc"
441C-----------------------------------------------
442C D u m m y A r g u m e n t s
443C-----------------------------------------------
444 INTEGER, INTENT(IN) :: ITAB(*)
445 TYPE(surf_), INTENT(IN) :: SURF
446 TYPE(monvol_struct_), INTENT(INOUT) :: T_MONVOLN
447 my_real, INTENT(IN) :: x(3, *)
448C-----------------------------------------------
449C L o c a l V a r i a b l e s
450C-----------------------------------------------
451 INTEGER :: JJ, NEDGE, NELEM, IEDGE, NODE1, NODE2, INODE
452 INTEGER :: NB_FREE_EDGE
453 INTEGER(8) :: graph_ptr, tri_ptr, tri_ptr_global
454 INTEGER, DIMENSION(:), ALLOCATABLE :: FREE_EDGES_ID, FREE_EDGES, LOCAL_NODE_ID, GLOBAL_NODE_ID
455 INTEGER :: NB_CONNECTED_COMPS, TOTAL_SIZE, II
456 INTEGER, DIMENSION(:), ALLOCATABLE :: PATHS, SIZES, CYCLES, SHIFT
457 INTEGER :: NPT,NTRI
458 my_real, DIMENSION(:), ALLOCATABLE :: node_coord
459 INTEGER, DIMENSION(:), ALLOCATABLE :: TRI_LIST
460 !CHARACTER(LEN=1024) :: FILENAME
461C-----------------------------------------------
462C B e g i n n i n g o f s o u r c e
463C-----------------------------------------------
464
465! ******************** !
466! ** Initialization ** !
467! ******************** !
468 graph_ptr = 0
469 tri_ptr = 0
470 tri_ptr_global = 0
471
472! ***************************** !
473! ** Build edge connectivity ** !
474! ***************************** !
475 CALL monvol_build_edges(t_monvoln, surf)
476
477! ************************* !
478! ** Identify free edges ** !
479! ************************* !
480 nedge = t_monvoln%NEDGE
481 nb_free_edge = 0
482 DO jj = 1, nedge
483 nelem = t_monvoln%IAD_EDGE_ELEM(jj + 1) - t_monvoln%IAD_EDGE_ELEM(jj)
484 IF (nelem == 1) THEN
485 nb_free_edge = nb_free_edge + 1
486 ENDIF
487 ENDDO
488
489! ************************ !
490! ** Recover free edges ** !
491! ************************ !
492 IF (nb_free_edge > 0) THEN
493 ALLOCATE(free_edges_id(nb_free_edge))
494 ALLOCATE(free_edges(2 * nb_free_edge))
495 ALLOCATE(local_node_id(numnod))
496 local_node_id(1:numnod) = 0
497 iedge = 0
498 inode = 0
499 DO jj = 1, nedge
500 nelem = t_monvoln%IAD_EDGE_ELEM(jj + 1) - t_monvoln%IAD_EDGE_ELEM(jj)
501 IF (nelem == 1) THEN
502 iedge = iedge + 1
503 node1 = t_monvoln%EDGE_NODE1(jj)
504 node2 = t_monvoln%EDGE_NODE2(jj)
505 free_edges(2 * (iedge - 1) + 1) = node1
506 free_edges(2 * (iedge - 1) + 2) = node2
507 IF (local_node_id(node1) == 0) THEN
508 inode = inode + 1
509 local_node_id(node1) = inode
510 ENDIF
511 IF (local_node_id(node2) == 0) THEN
512 inode = inode + 1
513 local_node_id(node2) = inode
514 ENDIF
515 ENDIF
516 ENDDO
517 ALLOCATE(global_node_id(inode))
518 DO ii = 1, numnod
519 IF(local_node_id(ii) > 0) THEN
520 global_node_id(local_node_id(ii)) = ii
521 ENDIF
522 ENDDO
523! change edges node id to local node id
524 DO iedge = 1, nb_free_edge
525 free_edges(2 * (iedge - 1) + 1) = local_node_id(free_edges(2 * (iedge - 1) + 1)) - 1
526 free_edges(2 * (iedge - 1) + 2) = local_node_id(free_edges(2 * (iedge - 1) + 2)) - 1
527 ENDDO
528 CALL graph_build_path(inode, nb_free_edge, free_edges,
529 . nb_connected_comps, graph_ptr)
530
531 ALLOCATE(sizes(nb_connected_comps), cycles(nb_connected_comps))
532 CALL graph_build_cycles(graph_ptr, cycles)
533 CALL graph_get_sizes(graph_ptr, sizes)
534 total_size = 0
535 ALLOCATE(shift(nb_connected_comps + 1))
536 shift(1) = 0
537 DO ii = 1, nb_connected_comps
538 shift(ii + 1) = shift(ii) + sizes(ii)
539 total_size = total_size + sizes(ii)
540 ENDDO
541 ALLOCATE(paths(total_size))
542 CALL graph_get_path(graph_ptr, paths)
543 CALL graph_free_memory(graph_ptr)
544
545 CALL tab1_init(tri_ptr_global)
546#ifdef DNC
547 DO ii = 1, nb_connected_comps
548 IF (cycles(ii) == 0) THEN
549! The connected component is not a hole -> cannot be closed
550 cycle
551 ENDIF
552 npt = sizes(ii)
553 ALLOCATE(node_coord(3 * npt))
554 DO jj = 1, npt
555 node_coord(3 * (jj - 1) + 1) = x(1, global_node_id(1+paths(jj + shift(ii))))
556 node_coord(3 * (jj - 1) + 2) = x(2, global_node_id(1+paths(jj + shift(ii))))
557 node_coord(3 * (jj - 1) + 3) = x(3, global_node_id(1+paths(jj + shift(ii))))
558 ENDDO
559 CALL hm_fill_loop(npt, node_coord, ntri, tri_ptr)
560 ALLOCATE(tri_list(3 * ntri))
561 CALL hm_fill_loop_get_tri(tri_list, tri_ptr)
562 DO jj = 1, 3 * ntri
563 tri_list(jj) = global_node_id(1+paths(shift(ii) + tri_list(jj) + 1))
564 ENDDO
565 CALL tri_free_memory(tri_ptr)
566 CALL tab1_append_tab(tri_ptr_global, 3 * ntri, tri_list)
567 DEALLOCATE(tri_list)
568 DEALLOCATE(node_coord)
569 ENDDO
570#endif
571
572 CALL tab1_get_size(tri_ptr_global, ntri)
573 IF (ntri > 0) THEN
574 t_monvoln%NB_FILL_TRI = ntri / 3
575 ALLOCATE(t_monvoln%FILL_TRI(ntri))
576 WRITE(iout, 1000) nb_free_edge, nb_connected_comps
577 WRITE(iout, 1001) t_monvoln%NB_FILL_TRI
578 CALL tab1_get(tri_ptr_global, t_monvoln%FILL_TRI)
579 CALL tab1_free_memory(tri_ptr_global)
580
581! **************************************** !
582! ** Build edge connectivity once again ** !
583! **************************************** !
584 CALL monvol_build_edges(t_monvoln, surf)
585
586! ************************* !
587! ** Identify free edges ** !
588! ************************* !
589 nedge = t_monvoln%NEDGE
590 nb_free_edge = 0
591 DO jj = 1, nedge
592 nelem = t_monvoln%IAD_EDGE_ELEM(jj + 1) - t_monvoln%IAD_EDGE_ELEM(jj)
593 IF (nelem == 1) THEN
594 nb_free_edge = nb_free_edge + 1
595 ENDIF
596 ENDDO
597
598 IF (nb_free_edge > 0) THEN
599 CALL ancmsg(msgid = 1875, anmode = aninfo, msgtype = msgwarning,
600 . i1 = t_monvoln%ID, c1 = t_monvoln%TITLE)
601 WRITE(iout, 1002) nb_free_edge
602 ENDIF
603 ELSE
604 IF (nb_free_edge > 0) THEN
605 CALL ancmsg(msgid = 1875, anmode = aninfo, msgtype = msgwarning,
606 . i1 = t_monvoln%ID, c1 = t_monvoln%TITLE)
607 WRITE(iout, 1002) nb_free_edge
608 ENDIF
609 ENDIF
610 ENDIF
611! ************************* !
612! ** Memory deallocation ** !
613! ************************* !
614 IF (ALLOCATED(free_edges_id)) DEALLOCATE(free_edges_id)
615 IF (ALLOCATED(free_edges)) DEALLOCATE(free_edges)
616 IF (ALLOCATED(local_node_id)) DEALLOCATE(local_node_id)
617 IF (ALLOCATED(global_node_id)) DEALLOCATE(global_node_id)
618 IF (ALLOCATED(sizes)) DEALLOCATE(sizes)
619 IF (ALLOCATED(shift)) DEALLOCATE(shift)
620 IF (ALLOCATED(paths)) DEALLOCATE(paths)
621 IF (ALLOCATED(cycles)) DEALLOCATE(cycles)
622C-----------------------------------------------
623C E n d o f s o u r c e
624C-----------------------------------------------
625 1000 FORMAT(
626 . /5x,'EXTERNAL SURFACE OF THE MONITORED VOLUME IS NOT A CLOSED SURFACE',
627 . /5x, ' NUMBER OF FREE EDGES: ',i10,
628 . /5x, ' NUMBER OF HOLES: ', i10)
629 1001 FORMAT(
630 . 5x,' ----> AUTOMATIC CLOSURE ACTIVATED'
631 . /5x,' ----> SURFACE CLOSE WITH: ',i10,' TRIANGLES')
632 1002 FORMAT(
633 . /5x, ' NUMBER OF REMAINING FREE EDGES: ',i10)
634 END SUBROUTINE monvol_check_surfclose
635
636!||====================================================================
637!|| monvol_compute_volume ../starter/share/modules1/monvol_struct_mod.F
638!||--- called by ------------------------------------------------------
639!|| hm_read_monvol_type1 ../starter/source/airbag/hm_read_monvol_type1.F
640!|| hm_read_monvol_type10 ../starter/source/airbag/hm_read_monvol_type10.F
641!|| hm_read_monvol_type11 ../starter/source/airbag/hm_read_monvol_type11.F
642!|| hm_read_monvol_type2 ../starter/source/airbag/hm_read_monvol_type2.F
643!|| hm_read_monvol_type3 ../starter/source/airbag/hm_read_monvol_type3.F
644!|| hm_read_monvol_type4 ../starter/source/airbag/hm_read_monvol_type4.F
645!|| hm_read_monvol_type5 ../starter/source/airbag/hm_read_monvol_type5.F
646!|| hm_read_monvol_type6 ../starter/source/airbag/hm_read_monvol_type6.F
647!|| hm_read_monvol_type7 ../starter/source/airbag/hm_read_monvol_type7.F
648!|| hm_read_monvol_type8 ../starter/source/airbag/hm_read_monvol_type8.F
649!|| hm_read_monvol_type9 ../starter/source/airbag/hm_read_monvol_type9.F
650!||--- uses -----------------------------------------------------
651!|| message_mod ../starter/share/message_module/message_mod.F
652!||====================================================================
653 SUBROUTINE monvol_compute_volume(T_MONVOLN, TITLE, IVOLU, SURF,
654 . ITAB, NODE_COORD, PM, GEO, IXC, IXTG,
655 . SA, ROT, VOL, VMIN, VEPS, SV)
656C-----------------------------------------------
657C M o d u l e s
658C-----------------------------------------------
659 USE groupdef_mod
660 USE message_mod
661 USE names_and_titles_mod , ONLY : nchartitle
662C-----------------------------------------------
663C I m p l i c i t T y p e s
664C-----------------------------------------------
665#include "implicit_f.inc"
666C-----------------------------------------------
667C C o m m o n B l o c k s
668C-----------------------------------------------
669C NSURF
670#include "com04_c.inc"
671C NIMV
672#include "param_c.inc"
673C nchartitle
674#include "scr17_c.inc"
675C IOUT
676#include "units_c.inc"
677C-----------------------------------------------
678C D u m m y A r g u m e n t s
679C-----------------------------------------------
680 TYPE(monvol_struct_), INTENT(IN) :: T_MONVOLN
681 CHARACTER(LEN = nchartitle), INTENT(IN) :: TITLE
682 INTEGER, INTENT(IN) :: IVOLU(NIMV), ITAB(*), IXC(NIXC, *), IXTG(NIXTG, *)
683 TYPE(surf_), INTENT(IN) :: SURF
684 my_real, INTENT(IN) :: node_coord(3, *), geo(npropg, *), pm(npropm, *)
685 my_real, INTENT(INOUT) :: sa, rot, vol, vmin, veps, sv
686C-----------------------------------------------
687C L o c a l V a r i a b l e s
688C-----------------------------------------------
689 INTEGER :: J, I
690 INTEGER :: IJET, NN, I1, I2, I3, I4, ISH34
691 my_real :: sx, sy, sz, dir
692 my_real :: xx, yy, zz, x13, y13, z13, x24, y24, z24, nx, ny, nz, ds
693C-----------------------------------------------
694C B e g i n n i n g o f s o u r c e
695C-----------------------------------------------
696 nn = surf%NSEG
697
698 ijet= 0
699 vol = zero
700 rot = zero
701 sx = zero
702 sy = zero
703 sz = zero
704 sa = zero
705
706 DO j = 1, nn
707 dir = half
708 i1 = surf%NODES(j,1)
709 i2 = surf%NODES(j,2)
710 i3 = surf%NODES(j,3)
711 i4 = surf%NODES(j,4)
712 ish34 = surf%ELTYP(j)
713 i = surf%ELEM(j)
714 IF(ish34==7)i4 = i3
715 xx =half*(node_coord(1,i1)+node_coord(1,i2))
716 yy =half*(node_coord(2,i1)+node_coord(2,i2))
717 zz =half*(node_coord(3,i1)+node_coord(3,i2))
718
719 x13=node_coord(1,i3)-node_coord(1,i1)
720 y13=node_coord(2,i3)-node_coord(2,i1)
721 z13=node_coord(3,i3)-node_coord(3,i1)
722 x24=node_coord(1,i4)-node_coord(1,i2)
723 y24=node_coord(2,i4)-node_coord(2,i2)
724 z24=node_coord(3,i4)-node_coord(3,i2)
725 nx=dir*(y13*z24-y24*z13)
726 ny=dir*(z13*x24-z24*x13)
727 nz=dir*(x13*y24-x24*y13)
728 vol = vol+third*( nx*xx+ny*yy+nz*zz )
729 sx = sx + nx
730 sy = sy + ny
731 sz = sz + nz
732 ds = sqrt(nx*nx+ny*ny+nz*nz)
733 sa = sa + ds
734 IF(ish34==3)THEN
735 rot = rot + pm(1,ixc(1,i))*geo(1,ixc(6,i))*ds
736 ELSEIF(ish34==7)THEN
737 rot = rot + pm(1,ixtg(1,i))*geo(1,ixtg(5,i))*ds
738 ENDIF
739 ENDDO
740
741 DO j = 1, t_monvoln%NB_FILL_TRI
742 dir = half
743 i1 = t_monvoln%FILL_TRI(3 * (j - 1) + 1)
744 i2 = t_monvoln%FILL_TRI(3 * (j - 1) + 2)
745 i3 = t_monvoln%FILL_TRI(3 * (j - 1) + 3)
746 i4 = i3
747
748 xx =half*(node_coord(1,i1)+node_coord(1,i2))
749 yy =half*(node_coord(2,i1)+node_coord(2,i2))
750 zz =half*(node_coord(3,i1)+node_coord(3,i2))
751
752 x13=node_coord(1,i3)-node_coord(1,i1)
753 y13=node_coord(2,i3)-node_coord(2,i1)
754 z13=node_coord(3,i3)-node_coord(3,i1)
755 x24=node_coord(1,i4)-node_coord(1,i2)
756 y24=node_coord(2,i4)-node_coord(2,i2)
757 z24=node_coord(3,i4)-node_coord(3,i2)
758 nx=dir*(y13*z24-y24*z13)
759 ny=dir*(z13*x24-z24*x13)
760 nz=dir*(x13*y24-x24*y13)
761 vol = vol+third*( nx*xx+ny*yy+nz*zz )
762 sx = sx + nx
763 sy = sy + ny
764 sz = sz + nz
765 ds = sqrt(nx*nx+ny*ny+nz*nz)
766 sa = sa + ds
767 ENDDO
768C
769 rot = rot/sa
770C
771 sv = sqrt(sx*sx+sy*sy+sz*sz)
772 vmin = em4*sa**three_half
773 veps = max(zero,vmin-abs(vol))
774C-----------------------------------------------
775C E n d o f s o u r c e
776C-----------------------------------------------
777 RETURN
778 END SUBROUTINE monvol_compute_volume
779
780!||====================================================================
781!|| monvol_check_venthole_surf ../starter/share/modules1/monvol_struct_mod.F
782!||--- called by ------------------------------------------------------
783!|| hm_read_monvol_type11 ../starter/source/airbag/hm_read_monvol_type11.F
784!|| hm_read_monvol_type4 ../starter/source/airbag/hm_read_monvol_type4.F
785!|| hm_read_monvol_type5 ../starter/source/airbag/hm_read_monvol_type5.F
786!|| hm_read_monvol_type6 ../starter/source/airbag/hm_read_monvol_type6.F
787!|| hm_read_monvol_type7 ../starter/source/airbag/hm_read_monvol_type7.F
788!|| hm_read_monvol_type8 ../starter/source/airbag/hm_read_monvol_type8.F
789!|| hm_read_monvol_type9 ../starter/source/airbag/hm_read_monvol_type9.F
790!||--- calls -----------------------------------------------------
791!|| ancmsg ../starter/source/output/message/message.F
792!||--- uses -----------------------------------------------------
793!|| message_mod ../starter/share/message_module/message_mod.F
794!||====================================================================
795 SUBROUTINE monvol_check_venthole_surf(IPRI, T_MONVOLN, IGRSURF, IHOL, SHOL, X, IXC, IXTG)
796 USE groupdef_mod
797 USE message_mod
798C-----------------------------------------------
799C I m p l i c i t T y p e s
800C-----------------------------------------------
801#include "implicit_f.inc"
802#include "units_c.inc"
803#include "param_c.inc"
804#include "com04_c.inc"
805C-----------------------------------------------
806C D u m m y A r g u m e n t s
807C-----------------------------------------------
808 TYPE(monvol_struct_), INTENT(IN) :: T_MONVOLN
809 INTEGER, INTENT(IN) :: IHOL, IPRI
810 INTEGER, INTENT(IN) :: IXC(NIXC, *), IXTG(NIXTG, *)
811 my_real, INTENT(IN) :: x(3, *)
812 my_real, INTENT(OUT) :: shol
813 TYPE (SURF_), DIMENSION(NSURF), INTENT(IN) :: IGRSURF
814C-----------------------------------------------
815C L o c a l V a r i a b l e s
816C-----------------------------------------------
817 INTEGER :: ISUR, IPVENT, NN, J
818 my_real :: DIR, XX, YY, ZZ, X13, Y13, Z13, X24, Y24, Z24,
819 . nx, ny, nz, ds
820 INTEGER :: I1, I2, I3, I4, ISH34, CHKSURF, J1, ITY
821 LOGICAL :: FOUND
822 INTEGER :: EXT_SURFID, INT_SURFID, JI, NN1, JI1, ITY1, IVENTYP, ITYPE, NEL
823 CHARACTER (LEN = nchartitle) :: TITR1, TITR2, TITR3
824
825 itype = t_monvoln%TYPE
826 isur = t_monvoln%IBAGHOL(2, ihol)
827 iventyp = t_monvoln%IBAGHOL(13, ihol)
828 ipvent = igrsurf(isur)%ID
829 IF(iventyp == 0) THEN
830 titr1='VENT HOLE SURFACE'
831 ELSE
832 titr1='POROUS SURFACE'
833 ENDIF
834 shol = zero
835 nn = igrsurf(isur)%NSEG
836 DO j=1,nn
837 dir = half
838 i1 = igrsurf(isur)%NODES(j,1)
839 i2 = igrsurf(isur)%NODES(j,2)
840 i3 = igrsurf(isur)%NODES(j,3)
841 i4 = igrsurf(isur)%NODES(j,4)
842 ish34 = igrsurf(isur)%ELTYP(j)
843 IF(ish34==7)i4 = i3
844 IF(ish34/=3.AND.ish34/=7)
845 . CALL ancmsg(msgid=18,anmode=aninfo,msgtype=msgerror,i2=igrsurf(isur)%ID,i1=t_monvoln%ID,c1=t_monvoln%TITLE)
846 xx=half*(x(1,i1)+x(1,i2))
847 yy=half*(x(2,i1)+x(2,i2))
848 zz=half*(x(3,i1)+x(3,i2))
849 x13=x(1,i3)-x(1,i1)
850 y13=x(2,i3)-x(2,i1)
851 z13=x(3,i3)-x(3,i1)
852 x24=x(1,i4)-x(1,i2)
853 y24=x(2,i4)-x(2,i2)
854 z24=x(3,i4)-x(3,i2)
855 nx=dir*(y13*z24-y24*z13)
856 ny=dir*(z13*x24-z24*x13)
857 nz=dir*(x13*y24-x24*y13)
858 ds = sqrt(nx*nx+ny*ny+nz*nz)
859 shol = shol + ds
860 ENDDO
861C------------------------------------------------
862C Ajout condition Svent incluse dans Surf airbag
863C------------------------------------------------
864 chksurf=0
865 nn =igrsurf(isur)%NSEG
866 ext_surfid = t_monvoln%EXT_SURFID
867 DO j=1,nn
868 ji =igrsurf(isur)%ELEM(j)
869 ity=igrsurf(isur)%ELTYP(j)
870 IF(ity == 7) ji=ji+numelc
871 nn1 =igrsurf(ext_surfid)%NSEG
872 found = .false.
873C Test surface externe
874 DO j1=1,nn1
875 ji1 =igrsurf(ext_surfid)%ELEM(j1)
876 ity1=igrsurf(ext_surfid)%ELTYP(j1)
877 IF(ity1 == 7) ji1=ji1+numelc
878 IF(ji == ji1) THEN
879 found = .true.
880 EXIT
881 END IF
882 ENDDO
883 IF (.NOT. found) THEN
884 int_surfid = t_monvoln%IVOLU(67)
885 IF((itype == 8 .OR. itype == 11) .AND. int_surfid > 0 .AND. iventyp == 1) THEN
886 nn1 =igrsurf(int_surfid)%NSEG
887C Test surface interne
888 DO j1=1,nn1
889 ji1 =igrsurf(int_surfid)%ELEM(j1)
890 ity1=igrsurf(int_surfid)%ELTYP(j1)
891 IF(ity1 == 7) ji1=ji1+numelc
892 IF(ji == ji1) THEN
893 found = .true.
894 EXIT
895 END IF
896 ENDDO
897 ENDIF
898 ENDIF
899 IF(.NOT. found) chksurf = chksurf+1
900 IF (ipri >= 5.AND..NOT. found) THEN
901 IF(chksurf == 1) THEN
902 titr2 = igrsurf(isur)%TITLE
903 titr3 = igrsurf(ext_surfid)%TITLE
904 CALL ancmsg(msgid=41,anmode=aninfo,msgtype=msgerror,
905 . i1=t_monvoln%ID,
906 . c1=t_monvoln%TITLE,
907 . c2=titr1,
908 . i2=igrsurf(isur)%ID,
909 . c3=titr1,
910 . c4=titr2,
911 . i3=igrsurf(ext_surfid)%ID,
912 . c5=titr3)
913 IF((itype == 8 .OR. itype == 11) .AND. int_surfid > 0 .AND. iventyp == 1) THEN
914 titr3 = igrsurf(int_surfid)%TITLE
915 CALL ancmsg(msgid=41,anmode=aninfo,msgtype=msgerror,
916 . i1=t_monvoln%ID,
917 . c1=t_monvoln%TITLE,
918 . c2=titr1,
919 . i2=igrsurf(isur)%ID,
920 . c3=titr1,
921 . c4=titr2,
922 . i3=igrsurf(int_surfid)%ID,
923 . c5=titr3)
924 ENDIF
925 ENDIF
926 IF(ity == 3)THEN
927 nel=ixc(nixc,ji)
928 WRITE(iout,1486) nel,trim(titr1),ipvent
929 ELSEIF(ity == 7)THEN
930 nel=ixtg(nixtg,ji-numelc)
931 WRITE(iout,1487) nel,trim(titr1),ipvent
932 ENDIF
933 ENDIF
934 ENDDO
935C
936 IF (chksurf > 0) THEN
937 CALL ancmsg(msgid=903,anmode=aninfo,msgtype=msgerror,
938 . i2=igrsurf(isur)%ID,i3=igrsurf(ext_surfid)%ID,
939 . i1=t_monvoln%ID,c1=t_monvoln%TITLE,c2=titr1)
940 IF((itype == 8 .OR. itype == 11) .AND. int_surfid > 0 .AND. iventyp == 1) THEN
941 CALL ancmsg(msgid=903,anmode=aninfo,msgtype=msgerror,
942 . i2=igrsurf(isur)%ID,i3=igrsurf(int_surfid)%ID,
943 . i1=t_monvoln%ID,c1=t_monvoln%TITLE,c2=titr1)
944 ENDIF
945 END IF
946 RETURN
947 1486 FORMAT(6x,'SHELL ELEMENT ID=',i10,' OF ',a17,1x,i10,' DOES NOT BELONG TO THE AIRBAG SURFACE')
948 1487 FORMAT(6x,'SH3N ELEMENT ID=',i10,' OF ',a17,1x,i10,' DOES NOT BELONG TO THE AIRBAG SURFACE')
949 END SUBROUTINE monvol_check_venthole_surf
950
951!||====================================================================
952!|| monvol_allocate ../starter/share/modules1/monvol_struct_mod.F
953!||--- called by ------------------------------------------------------
954!|| lectur ../starter/source/starter/lectur.F
955!||====================================================================
956 SUBROUTINE monvol_allocate(NVOLU, T_MONVOL, T_MONVOL_METADATA)
957C-----------------------------------------------
958C I m p l i c i t T y p e s
959C-----------------------------------------------
960#include "implicit_f.inc"
961#include "param_c.inc"
962C-----------------------------------------------
963C D u m m y A r g u m e n t s
964C-----------------------------------------------
965 INTEGER, INTENT(IN) :: NVOLU
966 TYPE(MONVOL_STRUCT_), DIMENSION(NVOLU), INTENT(INOUT) :: T_MONVOL
967 TYPE(monvol_metadata_), INTENT(INOUT) :: T_MONVOL_METADATA
968C-----------------------------------------------
969C L o c a l V a r i a b l e s
970C-----------------------------------------------
971 INTEGER :: II
972
973 ! ----------------------------------
974 ! initialization of T_MONVOL
975 t_monvol(1:nvolu)%TYPE = 0
976 t_monvol(1:nvolu)%ID = 0
977 t_monvol(1:nvolu)%NCA = 0
978 t_monvol(1:nvolu)%EXT_SURFID = 0
979 t_monvol(1:nvolu)%INT_SURFID = 0
980 t_monvol(1:nvolu)%NJET = 0
981 t_monvol(1:nvolu)%NVENT = 0
982 t_monvol(1:nvolu)%NPORSURF = 0
983 t_monvol(1:nvolu)%NNS = 0
984 t_monvol(1:nvolu)%NNI = 0
985 t_monvol(1:nvolu)%NTG = 0
986 t_monvol(1:nvolu)%NTGI = 0
987 t_monvol(1:nvolu)%NBRIC = 0
988 t_monvol(1:nvolu)%NNA = 0
989 t_monvol(1:nvolu)%NTGA = 0
990 t_monvol(1:nvolu)%IMESH_ALL = 0
991 t_monvol(1:nvolu)%KMESH = 0
992 t_monvol(1:nvolu)%NB_FILL_TRI = 0
993 t_monvol(1:nvolu)%NEDGE = 0
994 t_monvol(1:nvolu)%IADALE = 0
995 t_monvol(1:nvolu)%IADALE2 = 0
996 t_monvol(1:nvolu)%IADALE3 = 0
997 t_monvol(1:nvolu)%IADALE4 = 0
998 t_monvol(1:nvolu)%IADALE5 = 0
999 t_monvol(1:nvolu)%IADALE6 = 0
1000 t_monvol(1:nvolu)%IADALE7 = 0
1001 t_monvol(1:nvolu)%IADALE8 = 0
1002 t_monvol(1:nvolu)%IADALE9 = 0
1003 t_monvol(1:nvolu)%IADALE10 = 0
1004 t_monvol(1:nvolu)%IADALE11 = 0
1005 t_monvol(1:nvolu)%IADALE12 = 0
1006 t_monvol(1:nvolu)%IADALE13 = 0
1007 t_monvol(1:nvolu)%KRA5 = 0
1008 t_monvol(1:nvolu)%KRA6 = 0
1009 t_monvol(1:nvolu)%KR5 = 0
1010 ! ----------------------------------
1011
1012 t_monvol_metadata%NVOLU = nvolu
1013 ALLOCATE(t_monvol_metadata%ICBAG(nicbag, nvolu * nvolu))
1014 ALLOCATE(t_monvol_metadata%RCBAG(nrcbag, nvolu * nvolu))
1015 t_monvol_metadata%RCBAG(:, :) = zero
1016 t_monvol_metadata%ICBAG(:, :) = 0
1017 DO ii = 1, nvolu
1018 ALLOCATE(t_monvol(ii)%IVOLU(nimv))
1019 t_monvol(ii)%IVOLU(1:nimv) = 0
1020 ALLOCATE(t_monvol(ii)%RVOLU(nrvolu))
1021 t_monvol(ii)%RVOLU(1:nrvolu) = zero
1022 t_monvol(ii)%NVENT = 0
1023 t_monvol(ii)%NPORSURF = 0
1024 t_monvol(ii)%EXT_SURFID = 0
1025 t_monvol(ii)%INT_SURFID = 0
1026 t_monvol(ii)%NCA = 0
1027 t_monvol(ii)%KR5 = 0
1028 t_monvol(ii)%KRA5 = 0
1029 t_monvol(ii)%EDGES_BUILT = .false.
1030 t_monvol(ii)%NB_FILL_TRI = 0
1031 t_monvol(ii)%OK_REORIENT = .true.
1032 ENDDO
1033 END SUBROUTINE monvol_allocate
1034!||====================================================================
1035!|| monvol_deallocate ../starter/share/modules1/monvol_struct_mod.F
1036!||--- called by ------------------------------------------------------
1037!|| lectur ../starter/source/starter/lectur.F
1038!||====================================================================
1039 SUBROUTINE monvol_deallocate(NVOLU, T_MONVOL)
1040C-----------------------------------------------
1041C I m p l i c i t T y p e s
1042C-----------------------------------------------
1043#include "implicit_f.inc"
1044C-----------------------------------------------
1045C D u m m y A r g u m e n t s
1046C-----------------------------------------------
1047 INTEGER, INTENT(IN) :: NVOLU
1048 TYPE(MONVOL_STRUCT_), DIMENSION(NVOLU), INTENT(INOUT) :: T_MONVOL
1049C-----------------------------------------------
1050C L o c a l V a r i a b l e s
1051C-----------------------------------------------
1052 INTEGER :: II
1053
1054 DO ii = 1, nvolu
1055 IF (ALLOCATED(t_monvol(ii)%IVOLU)) DEALLOCATE(t_monvol(ii)%IVOLU)
1056 IF (ALLOCATED(t_monvol(ii)%RVOLU)) DEALLOCATE(t_monvol(ii)%RVOLU)
1057 IF (ALLOCATED(t_monvol(ii)%IBAGJET)) DEALLOCATE(t_monvol(ii)%IBAGJET)
1058 IF (ALLOCATED(t_monvol(ii)%RBAGJET)) DEALLOCATE(t_monvol(ii)%RBAGJET)
1059 IF (ALLOCATED(t_monvol(ii)%IBAGHOL)) DEALLOCATE(t_monvol(ii)%IBAGHOL)
1060 IF (ALLOCATED(t_monvol(ii)%RBAGHOL)) DEALLOCATE(t_monvol(ii)%RBAGHOL)
1061 IF (ALLOCATED(t_monvol(ii)%NODES)) DEALLOCATE(t_monvol(ii)%NODES)
1062 IF (ALLOCATED(t_monvol(ii)%ELEM)) DEALLOCATE(t_monvol(ii)%ELEM)
1063 IF (ALLOCATED(t_monvol(ii)%ITAGEL)) DEALLOCATE(t_monvol(ii)%ITAGEL)
1064 IF (ALLOCATED(t_monvol(ii)%ELTG)) DEALLOCATE(t_monvol(ii)%ELTG)
1065 IF (ALLOCATED(t_monvol(ii)%MATTG)) DEALLOCATE(t_monvol(ii)%MATTG)
1066 IF (ALLOCATED(t_monvol(ii)%TBRIC)) DEALLOCATE(t_monvol(ii)%TBRIC)
1067 IF (ALLOCATED(t_monvol(ii)%TFAC)) DEALLOCATE(t_monvol(ii)%TFAC)
1068 IF (ALLOCATED(t_monvol(ii)%TAGELS)) DEALLOCATE(t_monvol(ii)%TAGELS)
1069 IF (ALLOCATED(t_monvol(ii)%IBUFA)) DEALLOCATE(t_monvol(ii)%IBUFA)
1070 IF (ALLOCATED(t_monvol(ii)%ELEMA)) DEALLOCATE(t_monvol(ii)%ELEMA)
1071 IF (ALLOCATED(t_monvol(ii)%BRNA)) DEALLOCATE(t_monvol(ii)%BRNA)
1072 IF (ALLOCATED(t_monvol(ii)%TAGELA)) DEALLOCATE(t_monvol(ii)%TAGELA)
1073 IF (ALLOCATED(t_monvol(ii)%NCONA)) DEALLOCATE(t_monvol(ii)%NCONA)
1074 IF (ALLOCATED(t_monvol(ii)%VELOCITY)) DEALLOCATE(t_monvol(ii)%VELOCITY)
1075 IF (ALLOCATED(t_monvol(ii)%NODE_COORD)) DEALLOCATE(t_monvol(ii)%NODE_COORD)
1076 IF (ALLOCATED(t_monvol(ii)%POROSITY)) DEALLOCATE(t_monvol(ii)%POROSITY)
1077 IF (ALLOCATED(t_monvol(ii)%THSURF_TAG)) DEALLOCATE(t_monvol(ii)%THSURF_TAG)
1078 IF (ALLOCATED(t_monvol(ii)%ELAREA)) DEALLOCATE(t_monvol(ii)%ELAREA)
1079 IF (ALLOCATED(t_monvol(ii)%FILL_TRI)) DEALLOCATE(t_monvol(ii)%FILL_TRI)
1080 IF (ALLOCATED(t_monvol(ii)%EDGE_NODE1)) DEALLOCATE(t_monvol(ii)%EDGE_NODE1)
1081 IF (ALLOCATED(t_monvol(ii)%EDGE_NODE2)) DEALLOCATE(t_monvol(ii)%EDGE_NODE2)
1082 IF (ALLOCATED(t_monvol(ii)%EDGE_ELEM)) DEALLOCATE(t_monvol(ii)%EDGE_ELEM)
1083 IF (ALLOCATED(t_monvol(ii)%IAD_EDGE_ELEM)) DEALLOCATE(t_monvol(ii)%IAD_EDGE_ELEM)
1084 ENDDO
1085 END SUBROUTINE monvol_deallocate
1086 END
1087!||====================================================================
1088!|| monvol_orient_surf ../starter/share/modules1/monvol_struct_mod.F
1089!||--- called by ------------------------------------------------------
1090!|| hm_read_monvol_type1 ../starter/source/airbag/hm_read_monvol_type1.F
1091!|| hm_read_monvol_type10 ../starter/source/airbag/hm_read_monvol_type10.F
1092!|| hm_read_monvol_type11 ../starter/source/airbag/hm_read_monvol_type11.F
1093!|| hm_read_monvol_type2 ../starter/source/airbag/hm_read_monvol_type2.F
1094!|| hm_read_monvol_type3 ../starter/source/airbag/hm_read_monvol_type3.F
1095!|| hm_read_monvol_type4 ../starter/source/airbag/hm_read_monvol_type4.F
1096!|| hm_read_monvol_type5 ../starter/source/airbag/hm_read_monvol_type5.F
1097!|| hm_read_monvol_type6 ../starter/source/airbag/hm_read_monvol_type6.F
1098!|| hm_read_monvol_type7 ../starter/source/airbag/hm_read_monvol_type7.F
1099!|| hm_read_monvol_type8 ../starter/source/airbag/hm_read_monvol_type8.F
1100!|| hm_read_monvol_type9 ../starter/source/airbag/hm_read_monvol_type9.F
1101!||--- calls -----------------------------------------------------
1102!|| ancmsg ../starter/source/output/message/message.F
1103!|| arret ../starter/source/system/arret.F
1104!|| monvol_build_edges ../starter/share/modules1/monvol_struct_mod.F
1105!||--- uses -----------------------------------------------------
1106!|| message_mod ../starter/share/message_module/message_mod.F
1107!|| monvol_struct_mod ../starter/share/modules1/monvol_struct_mod.F
1108!||====================================================================
1109 SUBROUTINE monvol_orient_surf(T_MONVOLN, TITLE, IVOLU, ITAB, SURF, IXC, IXTG, X, ITYPE)
1110C-----------------------------------------------
1111C D e s c r i p t i o n
1112C-----------------------------------------------
1113C This subroutines ensures that all normal from monvol surface are
1114C oriented on same side.
1115C volume sign of resulting oriented surface is not ensured
1116C
1117C FIND ADJACENT ELEMS (by pair)
1118C -----------------------------
1119C
1120C 10 9 8 RUN THGROUGH ELEM SORTING 1st COLUMN SORTING 2nd COLUMN FOR EACH BLOCK (siz > 2)
1121C +----+----+ node1 node2 elem_id node1 node2 elem_id
1122C | | | 1 2 17 1 10 17 } BLOCK
1123C | 17 | 11 | 2 9 17 1 2 17 }
1124C | | | 9 10 17 SORT.1 ---------------- ----------------
1125C +----+----+ 1 10 17 -----> 2 9 17 } SORT.2 2 3 11 }
1126C 1 2 3 2 3 11 2 3 11 BLOCK -----> 2 9 17 ONE COMMON EDGE IN BLOCK : 2,3
1127C 3 8 11 2 9 11 } 2 9 11 } => elem 17 & 11 are adjacent
1128C 8 9 11 ---------------- ----------------
1129C 9 10 11 3 8 11
1130C ^ ^ ^ ----------------
1131C EDGE_ARRAY_N1 ^ ^ 8 9 11
1132C EDGE_ARRAY_N2 ^ ----------------
1133C EDGE_ARRAY_ELEM 9 10 17
1134C
1135C
1136C CHECK CONNECTIVITY
1137C -----------------
1138C
1139C 10 9 8
1140C +-----+----+ EXAMPLE :
1141C | | | reference elem : {09,10,01,02} U {09}
1142C | REF | 11 | elem to treat : {08,03,02,09} U {08}
1143C | | |
1144C +-----+----+ 1. check pattern [09,10] in elem to treat : not found
1145C 1 2 3 2. check pattern [10,01] in elem to treat : not found
1146C 3. check pattern [01,02] in elem to treat : not found
1147C 4. check pattern [02,09] in elem to treat : found => reverse connectivity
1148C
1149C REVERSE CONNECTIVITY
1150C --------------------
1151C
1152C 1 2 1 2
1153C +-------+ +---------+
1154C | | \ SH3N /
1155C | SHELL | \ / SHELL : switch 2<->4
1156C | | \ / SH3N : switch 1<->2
1157C +-------+ \ /
1158C 4 3 +3
1159C
1160C
1161C-----------------------------------------------
1162C M o d u l e s
1163C-----------------------------------------------
1164 USE groupdef_mod
1165 USE message_mod
1166 USE monvol_struct_mod
1167C-----------------------------------------------
1168C I m p l i c i t T y p e s
1169C-----------------------------------------------
1170#include "implicit_f.inc"
1171C-----------------------------------------------
1172C C o m m o n B l o c k s
1173C-----------------------------------------------
1174#include "param_c.inc"
1175#include "com04_c.inc"
1176C-----------------------------------------------
1177C D u m m y A r g u m e n t s
1178C-----------------------------------------------
1179 CHARACTER(LEN = nchartitle), INTENT(IN) :: TITLE
1180 INTEGER, INTENT(IN) :: IVOLU(NIMV), ITAB(*),ITYPE, IXC(NIXC, NUMELC), IXTG(NIXTG, NUMELTG)
1181 my_real :: x(3,numnod)
1182 TYPE(surf_), INTENT(INOUT) :: SURF
1183 TYPE(monvol_struct_), INTENT(INOUT) :: T_MONVOLN
1184C-----------------------------------------------
1185C L o c a l v a r i a b l e s
1186C-----------------------------------------------
1187 INTEGER NSEG,ISH34,JJ,II(4),KK, IELEM_ADJ,IDX,IDX_A,IDX_B,IPAIR,NPAIR,LL
1188 INTEGER IDX1,IDX2
1189 INTEGER NEDG, SUM_ADJ
1190 !temporary memory
1191 INTEGER, ALLOCATABLE,DIMENSION(:) :: PATHS, SIZES, CHECK_FLAG_ELEM, NB_ADJ,IAD_ADJ, LIST_ADJ_TAB
1192 INTEGER,ALLOCATABLE,DIMENSION(:) :: db_reversed, db_path
1193 INTEGER, DIMENSION(:), ALLOCATABLE :: PAIR_LIST, NB_PAIR_BY_EDGE
1194 INTEGER :: NB_NOEUD, NB_ARC, NB_COMP_CONNEXE, SUM_SIZES
1195 INTEGER(8) :: graph_ptr
1196 INTEGER :: IELEM,ICOMP, EDGES_A(5),EDGES_B(5), NB_REVERSED
1197 INTEGER :: NPT_A, NPT_B, IELEM1, IELEM2, ELTYP1, ELTYP2, NB_COMMON_NODE,
1198 . nodelist1(4), nodelist2(4), elem1id, elem2id, elemtg, elemc, ielemtg, ielemc
1199 LOGICAL :: lFOUND, lFOUND_ADJ
1200 INTEGER :: NB_DUPLICATED_ELTS
1201 INTEGER, DIMENSION(:), ALLOCATABLE :: DUPLICATED_ELTS
1202 CHARACTER(LEN=1024) :: FILENAME
1203 INTEGER(8) :: duplicate_ptr
1204 LOGICAL debug_output
1205 INTEGER :: NTRI, NB_CON
1206 INTEGER, DIMENSION(:), ALLOCATABLE :: IAD_COMP_CONNEX
1207C-----------------------------------------------
1208C P r e C o n d i t i o n
1209C-----------------------------------------------
1210C! only type 'PRES' (2) and type 'AIRBAG1' (7) FVMBAG1 (8)
1211C! otherwise : unplug
1212C IF(ITYPE /= 2 .AND.
1213C . ITYPE /= 7 .AND.
1214C . ITYPE /= 8 )RETURN
1215C-----------------------------------------------
1216C S o u r c e L i n e s
1217C-----------------------------------------------
1218
1219 graph_ptr = 0
1220 nseg = surf%NSEG
1221 ntri = t_monvoln%NB_FILL_TRI
1222 t_monvoln%OK_REORIENT = .true.
1223
1224! ********************************* !
1225! ** Edge connectivity if needed ** !
1226! ********************************* !
1227
1228 IF (.NOT. t_monvoln%EDGES_BUILT) THEN
1229 CALL monvol_build_edges(t_monvoln, surf)
1230 ENDIF
1231 nedg = t_monvoln%NEDGE
1232
1233! ********************************* !
1234! ** Find any duplicated element ** !
1235! ********************************* !
1236! REMOVE ONE OF EACH THEM FROM THE EDGE CONNECTIVITY
1237 nb_duplicated_elts = 0
1238 duplicate_ptr = 0
1239 CALL tab1_init(duplicate_ptr)
1240 DO jj = 1, nedg
1241 nb_con = t_monvoln%IAD_EDGE_ELEM(jj + 1) - t_monvoln%IAD_EDGE_ELEM(jj)
1242 IF (nb_con > 2) THEN
1243! T connection or worse
1244 DO ielem1 = t_monvoln%IAD_EDGE_ELEM(jj), t_monvoln%IAD_EDGE_ELEM(jj + 1) - 1
1245 IF (t_monvoln%EDGE_ELEM(ielem1) /= 0) THEN
1246 DO ielem2 = t_monvoln%IAD_EDGE_ELEM(jj), t_monvoln%IAD_EDGE_ELEM(jj + 1) -1
1247 IF (ielem1 /= ielem2) THEN
1248 elem1id = t_monvoln%EDGE_ELEM(ielem1)
1249 elem2id = t_monvoln%EDGE_ELEM(ielem2)
1250 IF (elem1id * elem2id == 0) THEN
1251! One of the element have already been suppressed as duplicated from another element
1252! connected to the same edge
1253 cycle
1254 ENDIF
1255 eltyp1 = surf%ELTYP(elem1id)
1256 eltyp2 = surf%ELTYP(elem2id)
1257 IF (eltyp1 == eltyp2) THEN
1258 IF (eltyp1 == 7) THEN
1259! Two triangles
1260 nb_common_node = 0
1261 nodelist1(1:4) = (/0, ixtg(2:4,surf%ELEM(elem1id))/)
1262 nodelist2(1:4) = (/0, ixtg(2:4,surf%ELEM(elem2id))/)
1263 DO kk = 2, 4
1264 DO ll = 2, 4
1265 IF (nodelist1(kk) == nodelist2(ll)) THEN
1266 nb_common_node = nb_common_node + 1
1267 EXIT
1268 ENDIF
1269 ENDDO
1270 ENDDO
1271 IF (nb_common_node == 3) THEN
1272! Get rid of ELEM2
1273 t_monvoln%EDGE_ELEM(ielem2) = 0
1274 nb_duplicated_elts = nb_duplicated_elts + 1
1275 CALL tab1_append(duplicate_ptr, elem1id)
1276 CALL tab1_append(duplicate_ptr, elem2id)
1277 ENDIF
1278 ENDIF
1279 ELSEIF (eltyp1 == 3) THEN
1280! Two QUADS
1281 nb_common_node = 0
1282 nodelist1(1:4) = (/ixc(2:5,surf%ELEM(elem1id))/)
1283 nodelist2(1:4) = (/ixc(2:5,surf%ELEM(elem2id))/)
1284 DO kk = 1, 4
1285 DO ll = 1, 4
1286 IF (nodelist1(kk) == nodelist2(ll)) THEN
1287 nb_common_node = nb_common_node + 1
1288 EXIT
1289 ENDIF
1290 ENDDO
1291 ENDDO
1292 IF (nb_common_node == 4) THEN
1293! Get rid of ELEM2
1294 t_monvoln%EDGE_ELEM(ielem2) = 0
1295 nb_duplicated_elts = nb_duplicated_elts + 1
1296 CALL tab1_append(duplicate_ptr, elem1id)
1297 CALL tab1_append(duplicate_ptr, elem2id)
1298 ENDIF
1299 ELSE
1300! One triangle, one quad
1301 ielemtg = ielem2
1302 elemtg = elem2id
1303 ielemc = ielem1
1304 elemc = elem1id
1305 IF (eltyp1 == 7) THEN
1306 ielemtg = ielem1
1307 elemtg = elem1id
1308 ielemc = ielem2
1309 elemc = elem2id
1310 ENDIF
1311 nb_common_node = 0
1312 nodelist1(1:4) = (/0, ixtg(2:4,surf%ELEM(elemtg))/)
1313 nodelist2(1:4) = (/ixc(2:5,surf%ELEM(elemc))/)
1314 DO kk = 2, 4
1315 DO ll = 1, 4
1316 IF (nodelist1(kk) == nodelist2(ll)) THEN
1317 nb_common_node = nb_common_node + 1
1318 EXIT
1319 ENDIF
1320 ENDDO
1321 ENDDO
1322 IF (nb_common_node == 3) THEN
1323! Get rid of the triangle
1324 t_monvoln%EDGE_ELEM(ielemtg) = 0
1325 nb_duplicated_elts = nb_duplicated_elts + 1
1326 CALL tab1_append(duplicate_ptr, elemc)
1327 CALL tab1_append(duplicate_ptr, ielemtg)
1328 ENDIF
1329 ENDIF
1330 ENDIF
1331 ENDDO
1332 ENDIF
1333 ENDDO
1334 ENDIF
1335 ENDDO
1336
1337 !--------------------------------------------!
1338 ! 4. BUILD PAIRS FOR GRAPH PATH CONSTRUCTION !
1339 !--------------------------------------------!
1340! Number of pairs by edge
1341 ALLOCATE(nb_pair_by_edge(nedg))
1342 DO jj = 1, nedg
1343 nb_pair_by_edge(jj) = 0
1344 DO kk = t_monvoln%IAD_EDGE_ELEM(jj), t_monvoln%IAD_EDGE_ELEM(jj + 1) - 1
1345 IF (t_monvoln%EDGE_ELEM(kk) /= 0) THEN
1346 nb_pair_by_edge(jj) = nb_pair_by_edge(jj) + 1
1347 ENDIF
1348 ENDDO
1349 nb_pair_by_edge(jj) = (nb_pair_by_edge(jj) - 1) * nb_pair_by_edge(jj) / 2
1350 IF (nb_pair_by_edge(jj) > 1) THEN
1351 t_monvoln%OK_REORIENT = .false.
1352 ENDIF
1353 ENDDO
1354 npair = sum(nb_pair_by_edge)
1355 ALLOCATE(pair_list(2 * npair))
1356 ipair = 0
1357 DO jj = 1, nedg
1358 nb_con = t_monvoln%IAD_EDGE_ELEM(jj + 1) - t_monvoln%IAD_EDGE_ELEM(jj)
1359 DO kk = 1, nb_con
1360 DO ll = kk + 1, nb_con
1361 elem1id = t_monvoln%EDGE_ELEM(t_monvoln%IAD_EDGE_ELEM(jj) + kk - 1)
1362 elem2id = t_monvoln%EDGE_ELEM(t_monvoln%IAD_EDGE_ELEM(jj) + ll - 1)
1363 IF (elem1id .NE.0 .AND. elem2id .NE. 0) THEN
1364 pair_list(ipair + 1) = elem1id - 1
1365 pair_list(ipair + 2) = elem2id - 1
1366 ipair = ipair + 2
1367 ENDIF
1368 ENDDO
1369 ENDDO
1370 ENDDO
1371
1372 !------------------------------------!
1373 ! 5. BUILD GRAPH !
1374 !------------------------------------!
1375 ! result : graph_ptr
1376 !------------------------------------!
1377 nb_noeud=nseg+ntri
1378 nb_arc=npair
1379 nb_comp_connexe = 0
1380 CALL graph_build_path(nb_noeud, nb_arc, pair_list, nb_comp_connexe, graph_ptr)
1381
1382 !------------------------------------!
1383 ! 6. GET PATH !
1384 !------------------------------------!
1385 ! result : PATHS(1:SIZE(1),SIZE(1)+1..SIZE(2),...)
1386 !------------------------------------!
1387 IF(.NOT.ALLOCATED(sizes))ALLOCATE(sizes(0:nb_comp_connexe))
1388 ALLOCATE(iad_comp_connex(nb_comp_connexe+1))
1389 CALL graph_get_sizes(graph_ptr, sizes(1))
1390 sum_sizes=sum(sizes(1:nb_comp_connexe),1)
1391 sizes(0)=0
1392 iad_comp_connex(1) = 1
1393 DO jj = 2, nb_comp_connexe + 1
1394 iad_comp_connex(jj) = iad_comp_connex(jj - 1) + sizes(jj - 1)
1395 ENDDO
1396 IF(.NOT.ALLOCATED(paths))ALLOCATE(paths(sum_sizes))
1397 CALL graph_get_path(graph_ptr, paths)
1398
1399 !----------------------------------------!
1400 ! 7. DEBUG : HM TCL SCRIPT TO CHECK PATH !
1401 !----------------------------------------!
1402 debug_output=.false.
1403C if(debug_output)then
1404C WRITE(FILENAME1, "(A,I0,A)") "surfmesh_",T_MONVOLN%ID,"_list_ids.tcl"
1405C OPEN(UNIT = 220582, FILE = FILENAME1, FORM ='formatted')
1406C write (220582,FMT='(A)')"set ids { \"
1407C kk=0
1408C do while (kk < sizes(1))
1409C if(kk+1<sizes(1))then
1410C ISH34 = SURF%ELTYP(1+PATHS(kk+1))
1411C IF(ISH34==3)THEN
1412C write (220582,FMT='(I10,A,I10,A)')IXC(7,SURF%ELEM(1+PATHS(kk+1)) ) ," ",10000000+IXC(7,SURF%ELEM(1+PATHS(kk+1)) ),' \'
1413C ELSE
1414C write (220582,FMT='(I10,A,I10,A)')IXTG(6,SURF%ELEM(1+PATHS(kk+1)) )," ",10000000+IXTG(6,SURF%ELEM(1+PATHS(kk+1)) ),' \'
1415C ENDIF
1416C endif
1417C kk=kk+1
1418C enddo
1419C write (220582,FMT='(A)') " } ; "
1420C CLOSE(220582)
1421C
1422C WRITE(FILENAME2, "(A,I0,A)") "surfmesh_",T_MONVOLN%ID,"_list_types.tcl"
1423C OPEN(UNIT = 220582, FILE = FILENAME2, FORM ='formatted')
1424C write (220582,FMT='(A)')"set types { \"
1425C kk=0
1426C do while (kk < sizes(1))
1427C if(kk+1<sizes(1))then
1428C ISH34 = SURF%ELTYP(1+PATHS(kk+1))
1429C IF(ISH34==3)THEN
1430C write (*,FMT='(I10,A,I10,A)')3 ," ",3,' \'
1431C ELSE
1432C write (*,FMT='(I10,A,I10,A)')7," ",7,' \'
1433C ENDIF
1434C endif
1435C kk=kk+1
1436C enddo
1437C CLOSE(220582)
1438C
1439C WRITE(FILENAME, "(A,I0,A)") "surfmesh_",T_MONVOLN%ID,"_HM_TCL_MACTO.tcl"
1440C OPEN(UNIT = 220582, FILE = FILENAME, FORM ='formatted')
1441C write (220582,FMT='(A)') '#--$ids '
1442C write (220582,FMT='(A)') '::hwt::Source "'//FILENAME1//'";'
1443C write (220582,FMT='(A)') '#--$types '
1444C write (220582,FMT='(A)') '::hwt::Source "'//FILENAME2//'";'
1445C write (220582,FMT='(A)') ' '
1446C write (220582,FMT='(A)') 'for {set i 0} {$i < [llength $ids]} {incr i 2} { '
1447C write (220582,FMT='(A)') ' set ityp [lindex $types $i] '
1448C write (220582,FMT='(A)') ' set id [lindex $ids $i] '
1449C write (220582,FMT='(A)') ' '
1450C write (220582,FMT='(A)') ' if {$ityp == 3} { '
1451C write (220582,FMT='(A)') ' *createmark elements 1 [hm_getinternalid shell_idpool $id -bypoolname] ;'
1452C write (220582,FMT='(A)') ' } elseif {$ityp == 7} { '
1453C write (220582,FMT='(A)') ' *createmark elements 1 [hm_getinternalid sh3n_idpool $id -bypoolname] ; '
1454C write (220582,FMT='(A)') ' } '
1455C write (220582,FMT='(A)') ' hm_redraw; '
1456C write (220582,FMT='(A)') ' *movemark elements 1 \"COLOR\"; '
1457C write (220582,FMT='(A)') '} '
1458C CLOSE(220582)
1459C endif !(debug_output)
1460
1461 !------------------------------------!
1462 ! 8. GET PATH !
1463 !------------------------------------!
1464 IF(.NOT.ALLOCATED(nb_adj))ALLOCATE(nb_adj(nseg+ntri))
1465 IF(.NOT.ALLOCATED(iad_adj))ALLOCATE(iad_adj(nseg+ntri+1))
1466 CALL graph_get_nb_adj(graph_ptr, nb_adj)
1467 sum_adj=sum(nb_adj)
1468 iad_adj(1)=1
1469 DO kk=2,nseg+ntri+1
1470 iad_adj(kk)=iad_adj(kk-1)+nb_adj(kk-1)
1471 ENDDO
1472 IF(.NOT.ALLOCATED(list_adj_tab))ALLOCATE(list_adj_tab(sum_adj))
1473 CALL graph_get_adj(graph_ptr, list_adj_tab)
1474 DO kk=1,sum_adj
1475 list_adj_tab(kk)=list_adj_tab(kk)+1
1476 ENDDO
1477 !------------------------------------!
1478 ! 7. DEBUG OUTPUT : SURF IN FILE !
1479 !------------------------------------!
1480 !--write a Radioss input file to check final surface
1481 debug_output=.false.
1482 if(debug_output)then
1483 nseg=surf%NSEG
1484 WRITE(filename, "(A,I0,A)") "surfmesh_before_",t_monvoln%ID,"_0000.rad"
1485 OPEN(unit = 210486, file = trim(filename), form ='formatted')
1486 WRITE(210486, '(A)') "#RADIOSS STARTER"
1487 WRITE(210486, '(A)') "/BEGIN"
1488 WRITE(210486, '(A)') "ORIENTED_SURFACE "
1489 WRITE(210486, '(A)') " 100 0"
1490 WRITE(210486, '(A)') " g mm ms"
1491 WRITE(210486, '(A)') " g mm ms"
1492 WRITE(210486, "(A5)") "/NODE"
1493 DO kk = 1, numnod
1494 WRITE(210486, "(I10, 1PG20.13, 1PG20.13, 1PG20.13)") itab(kk),x(1, kk), x(2, kk), x(3, kk)
1495 ENDDO
1496 DO kk = 1, nseg
1497 ii(1:4) = surf%NODES(kk,1:4)
1498 ish34 = surf%ELTYP(kk)
1499 IF (ish34 == 3) THEN
1500 WRITE(210486, "(A6)") "/SHELL"
1501 WRITE(210486, '(I10,I10,I10,I10,I10)') ixc(7,surf%ELEM(kk)), itab(ii(1)), itab(ii(2)),itab(ii(3)), itab(ii(4))
1502 ENDIF
1503 ENDDO
1504 DO kk = 1, nseg
1505 ii(1:4) = surf%NODES(kk,1:4)
1506 ish34 = surf%ELTYP(kk)
1507 IF (ish34 == 7) THEN
1508 WRITE(210486, "(A5)") "/SH3N"
1509 WRITE(210486, '(I10,I10,I10,I10)') ixtg(6,surf%ELEM(kk)), itab(ii(1)), itab(ii(2)),itab(ii(3))
1510 ENDIF
1511 ENDDO
1512 IF (t_monvoln%NB_FILL_TRI > 0) THEN
1513 WRITE(210486, "(A5)") "/SH3N"
1514 ENDIF
1515 DO kk = 1, t_monvoln%NB_FILL_TRI
1516 WRITE(210486, '(I10,I10,I10,I10)') kk + nseg, itab(t_monvoln%FILL_TRI(3 * (kk - 1) + 1)),
1517 . itab(t_monvoln%FILL_TRI(3 * (kk - 1) + 2)), itab(t_monvoln%FILL_TRI(3 * (kk - 1) + 3))
1518 ENDDO
1519 CLOSE (210486)
1520 endif !debug_output
1521 !------------------------------------!
1522 ! 9. SPREAD NORMAL !
1523 !------------------------------------!
1524 ! result : SIZES(1:NB_COMP_CONNEXE)
1525 !------------------------------------!
1526 IF(.NOT.ALLOCATED(check_flag_elem))ALLOCATE(check_flag_elem(nseg+ntri))
1527 check_flag_elem(:)=0
1528
1529 IF (t_monvoln%OK_REORIENT) THEN
1530 DO icomp=1,nb_comp_connexe
1531
1532!--REFERENCE ELEM (FIRST ONE)
1533 jj = 1 + paths(iad_comp_connex(icomp))
1534
1535 check_flag_elem(jj)=1 !already traveled
1536 nb_reversed = 0
1537
1538 DO ielem=iad_comp_connex(icomp) + 1, iad_comp_connex(icomp + 1) - 1
1539
1540!--CURRENT ELEM
1541 jj=1+paths(ielem)
1542
1543 IF (jj <= nseg) THEN
1544 ii(1:4) = surf%NODES(jj,1:4)
1545 ish34 = surf%ELTYP(jj)
1546 IF(ish34==3.AND.ii(3)/=ii(4))THEN
1547 edges_a(1:5)=(/ ii(1:4), ii(1) /)
1548 npt_a=4
1549 ELSE
1550 edges_a(1:5)=(/ ii(1:3), ii(1), 0 /)
1551 npt_a=3
1552 ENDIF
1553 ELSE
1554 ii(1:3) = t_monvoln%FILL_TRI(3 * (jj - nseg - 1) + 1 : 3 * (jj - nseg - 1) + 3)
1555 ii(4) = ii(3)
1556 edges_a(1:5) = (/ ii(1:3), ii(1), 0 /)
1557 npt_a = 3
1558 ENDIF
1559
1560!--CHECK ADJACENT ELEM ALREADY TREATED ( KK : CHECK_FLAG_ELEM(KK) = 1)
1561!need to get KK
1562 idx1 = iad_adj(jj)
1563 idx2 = iad_adj(jj+1)-1
1564 lfound_adj = .false.
1565 DO kk=idx1,idx2
1566 ielem_adj = list_adj_tab(kk)
1567 IF(check_flag_elem(ielem_adj) /= 0 )THEN
1568 lfound_adj = .true.
1569 EXIT
1570 ENDIF
1571 ENDDO
1572 IF(.NOT. lfound_adj)THEN
1573 print *, "**error when forcing monvol surface orientation"
1574 CALL arret(2);
1575 return;
1576 ENDIF
1577 kk = ielem_adj
1578!print *, "found adjacent element already treated =", IXTG(6, SURF%ELEM(KK) )
1579
1580!--LIST OF EDGES FOR ADJACENT ELEM
1581 IF (kk <= nseg) THEN
1582 ii(1:4) = surf%NODES(kk,1:4)
1583 ish34 = surf%ELTYP(kk)
1584 IF(ish34==3.AND.ii(3)/=ii(4))THEN
1585 edges_b(1:5)=(/ ii(1:4), ii(1) /)
1586 npt_b=4
1587 ELSE
1588 edges_b(1:5)=(/ ii(1:3), ii(1), 0 /)
1589 npt_b=3
1590 ENDIF
1591 ELSE
1592 ii(1:3) = t_monvoln%FILL_TRI(3 * (kk - nseg - 1) + 1 : 3 * (kk - nseg - 1) + 3)
1593 ii(4) = ii(3)
1594 edges_b(1:5) = (/ ii(1:3), ii(1), 0 /)
1595 npt_b = 3
1596 ENDIF
1597
1598!--CHECK PATTERN (CURRENT vs ADJACENT)
1599 lfound = .false.
1600 DO idx_a=1,npt_a
1601 DO idx_b=1,npt_b
1602 IF(edges_b(idx_b)==edges_a(idx_a))THEN
1603 IF(edges_b(idx_b+1)==edges_a(idx_a+1))THEN
1604 lfound = .true.
1605 EXIT
1606 ENDIF
1607 ENDIF
1608 ENDDO
1609 IF(lfound)EXIT
1610 ENDDO
1611
1612!--REVERSE IF NEEDED (CURRENT ELEM)
1613 IF(lfound)THEN
1614 IF (jj <= nseg) THEN
1615 ii(1:4) = surf%NODES(jj,1:4)
1616 IF(npt_a == 4)THEN
1617 surf%NODES(jj,1:4)=(/ ii(1), ii(4), ii(3), ii(2) /)
1618 ELSE
1619 surf%NODES(jj,1:4)=(/ ii(2), ii(1), ii(3), ii(4) /)
1620 ENDIF
1621 ELSE
1622 ii(1:3) = t_monvoln%FILL_TRI(3 * (jj - nseg - 1) + 1 : 3 * (jj - nseg - 1) + 3)
1623 ii(4) = ii(3)
1624 t_monvoln%FILL_TRI(3 * (jj - nseg - 1) + 1 : 3 * (jj - nseg - 1) + 3) = (/ ii(2), ii(1), ii(3) /)
1625 ENDIF
1626!print *, "--> reversed normal =", IXTG(6, SURF%ELEM(JJ) )
1627 nb_reversed = nb_reversed + 1
1628 check_flag_elem(jj)=-1
1629 ENDIF
1630
1631!MARK ELEM AS TREATED & NEXT
1632 check_flag_elem(jj)=1 !treated and unchanged
1633 IF(lfound)check_flag_elem(jj)=-1 !treated and reversed
1634
1635 ENDDO !next IELEM
1636 ENDDO
1637 ELSE
1638 CALL ancmsg(msgid = 1882, anmode = aninfo, msgtype = msgwarning,
1639 . i1 = t_monvoln%ID, c1 = t_monvoln%TITLE)
1640 ENDIF
1641
1642 !----------------------------------------------------!
1643 ! 10. CONSISTENT ORIENTATION OF DUPLICATED ELEMENTS
1644 !----------------------------------------------------!
1645 ALLOCATE(duplicated_elts(nb_duplicated_elts * 2))
1646 CALL tab1_get(duplicate_ptr, duplicated_elts)
1647 DO jj = 1, nb_duplicated_elts
1648 elem1id = surf%ELEM(duplicated_elts(2 * (jj - 1) + 1))
1649 elem2id = surf%ELEM(duplicated_elts(2 * (jj - 1) + 2))
1650! ELEM1D is already oriented, ELEM2ID has to be oriented reversely
1651 eltyp1 = surf%ELTYP(duplicated_elts(2 * (jj - 1) + 1))
1652 eltyp2 = surf%ELTYP(duplicated_elts(2 * (jj - 1) + 2))
1653 IF (eltyp1 == eltyp2) THEN
1654 ii(1:4) = surf%NODES(elem1id, 1:4)
1655 IF (eltyp1 == 7) THEN
1656! Triangles
1657 surf%NODES(elem2id, 1:4) = (/ ii(2), ii(1), ii(3), ii(4) /)
1658 ELSE
1659! Quads
1660 surf%NODES(elem2id, 1:4) = (/ ii(1), ii(4), ii(3), ii(2) /)
1661 ENDIF
1662 ELSE
1663! Target element is necessarily the triangle
1664 ii(1:4) = surf%NODES(elem2id,1:4)
1665 edges_a(1:5) = (/ ii(1:3), ii(1), 0 /)
1666 npt_a = 3
1667 ii(1:4) = surf%NODES(elem1id,1:4)
1668 edges_b(1:5) = (/ ii(1:4), ii(1) /)
1669 npt_b = 4
1670 !--CHECK PATTERN (CURRENT vs ADJACENT)
1671 lfound = .false.
1672 DO idx_a=1,npt_a
1673 DO idx_b=1,npt_b
1674 IF(edges_b(idx_b)==edges_a(idx_a))THEN
1675 IF(edges_b(idx_b+1)==edges_a(idx_a+1))THEN
1676 lfound = .true.
1677 EXIT
1678 ENDIF
1679 ENDIF
1680 ENDDO
1681 IF(lfound)EXIT
1682 ENDDO
1683 IF(lfound)THEN
1684 ii(1:4) = surf%NODES(elem2id, 1:4)
1685 IF(npt_a == 4)THEN
1686 surf%NODES(elem2id,1:4)=(/ ii(1), ii(4), ii(3), ii(2) /)
1687 ELSE
1688 surf%NODES(elem2id,1:4)=(/ ii(2), ii(1), ii(3), ii(4) /)
1689 ENDIF
1690 ENDIF
1691 ENDIF
1692 ENDDO
1693 CALL tab1_free_memory(duplicate_ptr)
1694
1695 !-------------------------------------!
1696 ! 11. DEBUG OUTPUT : RESULT ON SCREEN !
1697 !-------------------------------------!
1698 !--display on screen the element path (possible mixed SHELL,SH3N)
1699 debug_output=.false.
1700 if(debug_output)then
1701 icomp=1
1702 ALLOCATE(db_path(sizes(icomp)))
1703 do ielem=1,sizes(icomp)
1704 jj=1+paths(ielem)
1705 ii(1:4) = surf%NODES(jj,1:4)
1706 ish34 = surf%ELTYP(jj)
1707 IF(ish34==3.AND.ii(3)/=ii(4))THEN
1708 db_path(jj) = ixc(7,surf%ELEM((jj)))
1709 else
1710 db_path(jj) = ixtg(6,surf%ELEM((jj)))
1711 endif
1712 enddo
1713 print *,"____________________________________________________"
1714 print *, "there are ",sizes(icomp)," elements along the path"
1715 print *, db_path(1:sizes(icomp))
1716 print *,"____________________________________________________"
1717 deallocate(db_path)
1718 endif !debug_output
1719
1720 debug_output=.false.
1721 if(debug_output)then
1722 !--display on screen the reversed elems (possible mixed SHELL,SH3N)
1723 idx=0
1724 ALLOCATE(db_reversed(sizes(icomp)))
1725 do ielem=1,sizes(icomp)
1726 jj=1+paths(ielem)
1727 ii(1:4) = surf%NODES(jj,1:4)
1728 ish34 = surf%ELTYP(jj)
1729 IF(check_flag_elem(jj)==-1)THEN
1730 idx=idx+1
1731 IF(ish34==3.AND.ii(3)/=ii(4))THEN
1732 db_reversed(idx) = ixc(7,surf%ELEM((jj)))
1733 else
1734 db_reversed(idx) = ixtg(6,surf%ELEM((jj)))
1735 endif
1736 ENDIF
1737 enddo
1738 print *, "there were ",nb_reversed," element(s) reversed along the path"
1739 print *, db_reversed(1:nb_reversed)
1740 print *,"____________________________________________________"
1741 DEALLOCATE(db_reversed)
1742 endif !debug_output
1743
1744 !------------------------------------!
1745 ! 8. FREE MEMORY !
1746 !------------------------------------!
1747 IF(ALLOCATED(nb_adj))DEALLOCATE(nb_adj)
1748 IF(ALLOCATED(iad_adj))DEALLOCATE(iad_adj)
1749 IF(ALLOCATED(check_flag_elem))DEALLOCATE(check_flag_elem)
1750 IF(ALLOCATED(list_adj_tab))DEALLOCATE(list_adj_tab)
1751 IF(ALLOCATED(paths))DEALLOCATE(paths)
1752 IF(ALLOCATED(sizes))DEALLOCATE(sizes)
1753 IF(ALLOCATED(duplicated_elts)) DEALLOCATE(duplicated_elts)
1754 IF(ALLOCATED(pair_list)) DEALLOCATE(pair_list)
1755 IF(ALLOCATED(nb_pair_by_edge)) DEALLOCATE(nb_pair_by_edge)
1756 IF (ALLOCATED(iad_comp_connex)) DEALLOCATE(iad_comp_connex)
1757 CALL graph_free_memory(graph_ptr)
1758
1759
1760 END SUBROUTINE
1761!||====================================================================
1762!|| monvol_reverse_normals ../starter/share/modules1/monvol_struct_mod.f
1763!||--- called by ------------------------------------------------------
1764!|| hm_read_monvol_type1 ../starter/source/airbag/hm_read_monvol_type1.F
1765!|| hm_read_monvol_type10 ../starter/source/airbag/hm_read_monvol_type10.F
1766!|| hm_read_monvol_type11 ../starter/source/airbag/hm_read_monvol_type11.F
1767!|| hm_read_monvol_type2 ../starter/source/airbag/hm_read_monvol_type2.F
1768!|| hm_read_monvol_type3 ../starter/source/airbag/hm_read_monvol_type3.F
1769!|| hm_read_monvol_type4 ../starter/source/airbag/hm_read_monvol_type4.F
1770!|| hm_read_monvol_type5 ../starter/source/airbag/hm_read_monvol_type5.F
1771!|| hm_read_monvol_type6 ../starter/source/airbag/hm_read_monvol_type6.F
1772!|| hm_read_monvol_type7 ../starter/source/airbag/hm_read_monvol_type7.F
1773!|| hm_read_monvol_type8 ../starter/source/airbag/hm_read_monvol_type8.F
1774!|| hm_read_monvol_type9 ../starter/source/airbag/hm_read_monvol_type9.F
1775!||--- uses -----------------------------------------------------
1776!|| message_mod ../starter/share/message_module/message_mod.f
1777!|| monvol_struct_mod ../starter/share/modules1/monvol_struct_mod.F
1778!||====================================================================
1779 SUBROUTINE monvol_reverse_normals(T_MONVOLN, TITLE, IVOLU, ITAB, SURF, IXC, IXTG, VOL, X, ITYPE)
1780C-----------------------------------------------
1781C D e s c r i p t i o n
1782C-----------------------------------------------
1783C This subroutine reverse all normals composing a given surface.
1784C Pre-condition : volume must be negative, otherwise normal are consider
1785C to be correctly oriented.
1786C-----------------------------------------------
1787C M o d u l e s
1788C-----------------------------------------------
1789 USE groupdef_mod
1790 USE message_mod
1791 USE monvol_struct_mod
1792C-----------------------------------------------
1793C I m p l i c i t T y p e s
1794C-----------------------------------------------
1795#include "implicit_f.inc"
1796C-----------------------------------------------
1797C C o m m o n B l o c k s
1798C-----------------------------------------------
1799#include "param_c.inc"
1800#include "com04_c.inc"
1801C-----------------------------------------------
1802C D u m m y A r g u m e n t s
1803C-----------------------------------------------
1804 CHARACTER(LEN = nchartitle), INTENT(IN) :: TITLE
1805 INTEGER, INTENT(IN) :: IVOLU(NIMV), ITAB(*), ITYPE
1806 TYPE(surf_), INTENT(INOUT) :: SURF
1807 my_real, INTENT(INOUT) :: vol
1808 my_real, INTENT(IN) :: x(3,numnod)
1809 INTEGER,INTENT(IN) :: IXC(NIXC, NUMELC), IXTG(NIXTG, NUMELTG)
1810 TYPE(monvol_struct_), INTENT(INOUT) :: T_MONVOLN
1811C-----------------------------------------------
1812C L o c a l v a r i a b l e s
1813C-----------------------------------------------
1814 INTEGER JJ,ISH34,II(4),KK,NSEG
1815 CHARACTER(LEN=1024) :: FILENAME
1816 LOGICAL debug_output
1817C-----------------------------------------------
1818C P r e C o n d i t i o n
1819C-----------------------------------------------
1820! nothing to do if vol>0.0, normal are already correctly oriented.
1821C IF(VOL > ZERO) RETURN !commented to get debug output (surf in file)
1822C-----------------------------------------------
1823C S o u r c e L i n e s
1824C-----------------------------------------------
1825
1826 IF (.NOT. t_monvoln%OK_REORIENT) RETURN
1827 nseg = surf%NSEG
1828 IF(vol<zero)THEN
1829!print *, "VOLUME IS NEGATIVE, SURFACE IS REVERTED" .
1830 vol = -vol
1831 DO jj=1,nseg
1832 ish34 = surf%ELTYP(jj)
1833 ii(1:4) = surf%NODES(jj,1:4)
1834 IF(ish34 == 3)THEN
1835!SHELL
1836 surf%NODES(jj,1:4)=(/ ii(1), ii(4), ii(3), ii(2) /)
1837 ELSEIF(ish34 == 7)THEN
1838!SH3N
1839 surf%NODES(jj,1:4)=(/ ii(2), ii(1), ii(3), ii(4) /)
1840 ENDIF
1841 ENDDO
1842 DO jj = 1, t_monvoln%NB_FILL_TRI
1843 ii(1:3) = t_monvoln%FILL_TRI(3 * (jj - 1) + 1 : 3 * (jj - 1) + 3)
1844 ii(4) = ii(3)
1845 t_monvoln%FILL_TRI(3 * (jj - 1) + 1 : 3 * (jj - 1) + 3) = (/ ii(2), ii(1), ii(3) /)
1846 ENDDO
1847 ENDIF
1848
1849 !------------------------------------!
1850 ! 7. DEBUG OUTPUT : SURF IN FILE !
1851 !------------------------------------!
1852 !--write a Radioss input file to check final surface
1853 debug_output=.false.
1854 if(debug_output)then
1855 nseg=surf%NSEG
1856 WRITE(filename, "(A,I0,A)") "surfmesh_after_",t_monvoln%ID,"_0000.rad"
1857 OPEN(unit = 210486, file = trim(filename), form ='formatted')
1858 WRITE(210486, '(A)') "#RADIOSS STARTER"
1859 WRITE(210486, '(A)') "/BEGIN"
1860 WRITE(210486, '(A)') "ORIENTED_SURFACE "
1861 WRITE(210486, '(A)') " 100 0"
1862 WRITE(210486, '(A)') " g mm ms"
1863 WRITE(210486, '(A)') " g mm ms"
1864 WRITE(210486, "(A5)") "/NODE"
1865 DO kk = 1, numnod
1866 WRITE(210486, "(I10, 1PG20.13, 1PG20.13, 1PG20.13)") itab(kk),x(1, kk), x(2, kk), x(3, kk)
1867 ENDDO
1868 DO kk = 1, nseg
1869 ii(1:4) = surf%NODES(kk,1:4)
1870 ish34 = surf%ELTYP(kk)
1871 IF (ish34 == 3) THEN
1872 WRITE(210486, "(A6)") "/SHELL"
1873 WRITE(210486, '(I10,I10,I10,I10,I10)') ixc(7,surf%ELEM(kk)), itab(ii(1)), itab(ii(2)),itab(ii(3)), itab(ii(4))
1874 ENDIF
1875 ENDDO
1876 DO kk = 1, nseg
1877 ii(1:4) = surf%NODES(kk,1:4)
1878 ish34 = surf%ELTYP(kk)
1879 IF (ish34 == 7) THEN
1880 WRITE(210486, "(A5)") "/SH3N"
1881 WRITE(210486, '(I10,I10,I10,I10)') ixtg(6,surf%ELEM(kk)), itab(ii(1)), itab(ii(2)),itab(ii(3))
1882 ENDIF
1883 ENDDO
1884 IF (t_monvoln%NB_FILL_TRI > 0) THEN
1885 WRITE(210486, "(A5)") "/SH3N"
1886 ENDIF
1887 DO kk = 1, t_monvoln%NB_FILL_TRI
1888 WRITE(210486, '(I10,I10,I10,I10)') kk + nseg, itab(t_monvoln%FILL_TRI(3 * (kk - 1) + 1)),
1889 . itab(t_monvoln%FILL_TRI(3 * (kk - 1) + 2)), itab(t_monvoln%FILL_TRI(3 * (kk - 1) + 3))
1890 ENDDO
1891 CLOSE (210486)
1892 endif !debug_output
1893
1894 END SUBROUTINE
1895
1896
1897!||====================================================================
1898!|| monvol_build_edges ../starter/share/modules1/monvol_struct_mod.F
1899!||--- called by ------------------------------------------------------
1900!|| monvol_check_surfclose ../starter/share/modules1/monvol_struct_mod.F
1901!|| monvol_orient_surf ../starter/share/modules1/monvol_struct_mod.F
1902!||--- calls -----------------------------------------------------
1903!||--- uses -----------------------------------------------------
1904!|| message_mod ../starter/share/message_module/message_mod.F
1905!|| monvol_struct_mod ../starter/share/modules1/monvol_struct_mod.F
1906!||====================================================================
1907 SUBROUTINE monvol_build_edges(T_MONVOLN, SURF)
1908C-----------------------------------------------
1909C D e s c r i p t i o n
1910C-----------------------------------------------
1911C Build edges connectivity of monvol external surface
1912C-----------------------------------------------
1913C M o d u l e s
1914C-----------------------------------------------
1915 USE groupdef_mod
1916 USE message_mod
1917 USE monvol_struct_mod
1918C-----------------------------------------------
1919C I m p l i c i t T y p e s
1920C-----------------------------------------------
1921#include "implicit_f.inc"
1922C-----------------------------------------------
1923C C o m m o n B l o c k s
1924C-----------------------------------------------
1925#include "param_c.inc"
1926#include "com04_c.inc"
1927C-----------------------------------------------
1928C D u m m y a r g u m e n t s
1929C-----------------------------------------------
1930 TYPE(surf_), INTENT(IN) :: SURF
1931 TYPE(MONVOL_STRUCT_), INTENT(INOUT) :: T_MONVOLN
1932C-----------------------------------------------
1933C L o c a l v a r i a b l e s
1934C-----------------------------------------------
1935 INTEGER :: NSEG, NTRI
1936 INTEGER, DIMENSION(:), ALLOCATABLE :: EDGE_ARRAY_N1, EDGE_ARRAY_N2, EDGE_ARRAY_ELEM,
1937 . nb_connect
1938 INTEGER(8) :: edge_ptr
1939 INTEGER :: JJ, II(4), IDX, ELTYP, NEDG
1940C-----------------------------------------------
1941C S o u r c e L i n e s
1942C-----------------------------------------------
1943 IF (ALLOCATED(t_monvoln%EDGE_NODE1)) DEALLOCATE(t_monvoln%EDGE_NODE1)
1944 IF (ALLOCATED(t_monvoln%EDGE_NODE2)) DEALLOCATE(t_monvoln%EDGE_NODE2)
1945 IF (ALLOCATED(t_monvoln%EDGE_ELEM)) DEALLOCATE(t_monvoln%EDGE_ELEM)
1946 IF (ALLOCATED(t_monvoln%IAD_EDGE_ELEM)) DEALLOCATE(t_monvoln%IAD_EDGE_ELEM)
1947 t_monvoln%NEDGE = 0
1948
1949 nseg = surf%NSEG
1950 ntri = t_monvoln%NB_FILL_TRI
1951
1952 ALLOCATE(edge_array_n1(4 * (nseg + ntri)))
1953 ALLOCATE(edge_array_n2(4 * (nseg + ntri)))
1954 ALLOCATE(edge_array_elem(4 * (nseg + ntri)))
1955
1956! ******************************* !
1957! ** External surface elements ** !
1958! ******************************* !
1959 idx = 0
1960 DO jj = 1, nseg
1961 ii(1:4) = surf%NODES(jj, 1:4)
1962 eltyp = surf%ELTYP(jj)
1963 SELECT CASE (eltyp)
1964 CASE (3)
1965! Quads
1966 edge_array_n1(idx + 1) = min(ii(1), ii(2))
1967 edge_array_n2(idx + 1) = max(ii(1), ii(2))
1968 edge_array_n1(idx + 2) = min(ii(2), ii(3))
1969 edge_array_n2(idx + 2) = max(ii(2), ii(3))
1970 edge_array_n1(idx + 3) = min(ii(3), ii(4))
1971 edge_array_n2(idx + 3) = max(ii(3), ii(4))
1972 edge_array_n1(idx + 4) = min(ii(4), ii(1))
1973 edge_array_n2(idx + 4) = max(ii(4), ii(1))
1974 edge_array_elem(idx + 1:idx + 4) = jj
1975 idx = idx + 4
1976 CASE (7)
1977! Tri
1978 edge_array_n1(idx + 1) = min(ii(1), ii(2))
1979 edge_array_n2(idx + 1) = max(ii(1), ii(2))
1980 edge_array_n1(idx + 2) = min(ii(2), ii(3))
1981 edge_array_n2(idx + 2) = max(ii(2), ii(3))
1982 edge_array_n1(idx + 3) = min(ii(3), ii(1))
1983 edge_array_n2(idx + 3) = max(ii(3), ii(1))
1984 edge_array_elem(idx + 1:idx + 3) = jj
1985 idx = idx + 3
1986 CASE DEFAULT
1987
1988 END SELECT
1989 ENDDO
1990
1991! **************************** !
1992! ** Filling hole triangles ** !
1993! **************************** !
1994 DO jj = 1, ntri
1995 ii(1:3) = t_monvoln%FILL_TRI(3 * (jj - 1) + 1 : 3 * (jj - 1) + 3)
1996 edge_array_n1(idx + 1) = min(ii(1), ii(2))
1997 edge_array_n2(idx + 1) = max(ii(1), ii(2))
1998 edge_array_n1(idx + 2) = min(ii(2), ii(3))
1999 edge_array_n2(idx + 2) = max(ii(2), ii(3))
2000 edge_array_n1(idx + 3) = min(ii(3), ii(1))
2001 edge_array_n2(idx + 3) = max(ii(3), ii(1))
2002 edge_array_elem(idx + 1:idx + 3) = jj + nseg
2003 idx = idx + 3
2004 ENDDO
2005 nedg = idx
2006
2007! ********************************* !
2008! ** Edge sorting and compaction ** !
2009! ********************************* !
2010
2011 edge_ptr = 0
2012 CALL edge_sort(edge_ptr, edge_array_n1, edge_array_n2, edge_array_elem, nedg)
2013 ALLOCATE(nb_connect(nedg))
2014 CALL edge_get_nb_connect(edge_ptr, nb_connect)
2015
2016 ALLOCATE(t_monvoln%EDGE_NODE1(nedg))
2017 ALLOCATE(t_monvoln%EDGE_NODE2(nedg))
2018 ALLOCATE(t_monvoln%EDGE_ELEM(sum(nb_connect)))
2019 ALLOCATE(t_monvoln%IAD_EDGE_ELEM(nedg + 1))
2020
2021 CALL edge_get_connect(edge_ptr, t_monvoln%EDGE_ELEM)
2022
2023 t_monvoln%IAD_EDGE_ELEM(1) = 1
2024 DO jj = 2, nedg + 1
2025 t_monvoln%IAD_EDGE_ELEM(jj) = t_monvoln%IAD_EDGE_ELEM(jj - 1) + nb_connect(jj - 1)
2026 ENDDO
2027 DO jj = 1, nedg
2028 t_monvoln%EDGE_NODE1(jj) = edge_array_n1(jj)
2029 t_monvoln%EDGE_NODE2(jj) = edge_array_n2(jj)
2030 ENDDO
2031
2032 CALL edge_free_memory(edge_ptr)
2033 t_monvoln%NEDGE = nedg
2034 t_monvoln%EDGES_BUILT = .true.
2035
2036! ************************* !
2037! ** Memory deallocation ** !
2038! ************************* !
2039 DEALLOCATE(edge_array_n1)
2040 DEALLOCATE(edge_array_n2)
2041 DEALLOCATE(edge_array_elem)
2042 DEALLOCATE(nb_connect)
2043C-----------------------------------------------
2044C E n d O f S u b r o u t i n e
2045C-----------------------------------------------
2046 END SUBROUTINE
my_real
#define my_real
Definition cppsort.cpp:32
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
id
initmumps id
Definition multiplerhs_example.m:4
groupdef_mod
Definition groupdef_mod.F:662
message_mod
Definition message_mod.F:1249
monvol_struct_mod
Definition monvol_struct_mod.F:66
monvol_struct_mod::monvol_check_venthole_surf
subroutine monvol_check_venthole_surf(ipri, t_monvoln, igrsurf, ihol, shol, x, ixc, ixtg)
Definition monvol_struct_mod.F:796
monvol_struct_mod::copy_to_monvol
subroutine copy_to_monvol(t_monvol, licbag, icbag, smonvol, monvol)
Definition monvol_struct_mod.F:163
monvol_struct_mod::monvol_allocate
subroutine monvol_allocate(nvolu, t_monvol, t_monvol_metadata)
Definition monvol_struct_mod.F:957
monvol_struct_mod::copy_to_volmon
subroutine copy_to_volmon(t_monvol, lrcbag, rcbag, svolmon, volmon)
Definition monvol_struct_mod.F:313
monvol_struct_mod::monvol_deallocate
subroutine monvol_deallocate(nvolu, t_monvol)
Definition monvol_struct_mod.F:1040
monvol_struct_mod::monvol_compute_volume
subroutine monvol_compute_volume(t_monvoln, title, ivolu, surf, itab, node_coord, pm, geo, ixc, ixtg, sa, rot, vol, vmin, veps, sv)
Definition monvol_struct_mod.F:656
monvol_struct_mod::monvol_check_surfclose
subroutine monvol_check_surfclose(t_monvoln, itab, surf, x)
Definition monvol_struct_mod.F:421
names_and_titles_mod
Definition names_and_titles_mod.F:997
names_and_titles_mod::nchartitle
integer, parameter nchartitle
Definition names_and_titles_mod.F:1003
monvol_orient_surf
subroutine monvol_orient_surf(t_monvoln, title, ivolu, itab, surf, ixc, ixtg, x, itype)
Definition monvol_struct_mod.F:1110
monvol_reverse_normals
subroutine monvol_reverse_normals(t_monvoln, title, ivolu, itab, surf, ixc, ixtg, vol, x, itype)
Definition monvol_struct_mod.F:1780
monvol_build_edges
subroutine monvol_build_edges(t_monvoln, surf)
Definition monvol_struct_mod.F:1908
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
arret
subroutine arret(nn)
Definition arret.F:87
starter
program starter
Definition starter.F:39
groupdef_mod::surf_
Definition groupdef_mod.F:745
monvol_struct_mod::monvol_metadata_
Definition monvol_struct_mod.F:76
monvol_struct_mod::monvol_struct_
Definition monvol_struct_mod.F:84