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! Wind 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! Address 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 addresses 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
662 use element_mod , only : nixc,nixtg
663C-----------------------------------------------
664C I m p l i c i t T y p e s
665C-----------------------------------------------
666#include "implicit_f.inc"
667C-----------------------------------------------
668C C o m m o n B l o c k s
669C-----------------------------------------------
670C NSURF
671#include "com04_c.inc"
672C NIMV
673#include "param_c.inc"
674C nchartitle
675#include "scr17_c.inc"
676C IOUT
677#include "units_c.inc"
678C-----------------------------------------------
679C D u m m y A r g u m e n t s
680C-----------------------------------------------
681 TYPE(monvol_struct_), INTENT(IN) :: T_MONVOLN
682 CHARACTER(LEN = nchartitle), INTENT(IN) :: TITLE
683 INTEGER, INTENT(IN) :: IVOLU(NIMV), ITAB(*), IXC(NIXC, *), IXTG(NIXTG, *)
684 TYPE(surf_), INTENT(IN) :: SURF
685 my_real, INTENT(IN) :: node_coord(3, *), geo(npropg, *), pm(npropm, *)
686 my_real, INTENT(INOUT) :: sa, rot, vol, vmin, veps, sv
687C-----------------------------------------------
688C L o c a l V a r i a b l e s
689C-----------------------------------------------
690 INTEGER :: J, I
691 INTEGER :: IJET, NN, I1, I2, I3, I4, ISH34
692 my_real :: sx, sy, sz, dir
693 my_real :: xx, yy, zz, x13, y13, z13, x24, y24, z24, nx, ny, nz, ds
694C-----------------------------------------------
695C B e g i n n i n g o f s o u r c e
696C-----------------------------------------------
697 nn = surf%NSEG
698
699 ijet= 0
700 vol = zero
701 rot = zero
702 sx = zero
703 sy = zero
704 sz = zero
705 sa = zero
706
707 DO j = 1, nn
708 dir = half
709 i1 = surf%NODES(j,1)
710 i2 = surf%NODES(j,2)
711 i3 = surf%NODES(j,3)
712 i4 = surf%NODES(j,4)
713 ish34 = surf%ELTYP(j)
714 i = surf%ELEM(j)
715 IF(ish34==7)i4 = i3
716 xx =half*(node_coord(1,i1)+node_coord(1,i2))
717 yy =half*(node_coord(2,i1)+node_coord(2,i2))
718 zz =half*(node_coord(3,i1)+node_coord(3,i2))
719
720 x13=node_coord(1,i3)-node_coord(1,i1)
721 y13=node_coord(2,i3)-node_coord(2,i1)
722 z13=node_coord(3,i3)-node_coord(3,i1)
723 x24=node_coord(1,i4)-node_coord(1,i2)
724 y24=node_coord(2,i4)-node_coord(2,i2)
725 z24=node_coord(3,i4)-node_coord(3,i2)
726 nx=dir*(y13*z24-y24*z13)
727 ny=dir*(z13*x24-z24*x13)
728 nz=dir*(x13*y24-x24*y13)
729 vol = vol+third*( nx*xx+ny*yy+nz*zz )
730 sx = sx + nx
731 sy = sy + ny
732 sz = sz + nz
733 ds = sqrt(nx*nx+ny*ny+nz*nz)
734 sa = sa + ds
735 IF(ish34==3)THEN
736 rot = rot + pm(1,ixc(1,i))*geo(1,ixc(6,i))*ds
737 ELSEIF(ish34==7)THEN
738 rot = rot + pm(1,ixtg(1,i))*geo(1,ixtg(5,i))*ds
739 ENDIF
740 ENDDO
741
742 DO j = 1, t_monvoln%NB_FILL_TRI
743 dir = half
744 i1 = t_monvoln%FILL_TRI(3 * (j - 1) + 1)
745 i2 = t_monvoln%FILL_TRI(3 * (j - 1) + 2)
746 i3 = t_monvoln%FILL_TRI(3 * (j - 1) + 3)
747 i4 = i3
748
749 xx =half*(node_coord(1,i1)+node_coord(1,i2))
750 yy =half*(node_coord(2,i1)+node_coord(2,i2))
751 zz =half*(node_coord(3,i1)+node_coord(3,i2))
752
753 x13=node_coord(1,i3)-node_coord(1,i1)
754 y13=node_coord(2,i3)-node_coord(2,i1)
755 z13=node_coord(3,i3)-node_coord(3,i1)
756 x24=node_coord(1,i4)-node_coord(1,i2)
757 y24=node_coord(2,i4)-node_coord(2,i2)
758 z24=node_coord(3,i4)-node_coord(3,i2)
759 nx=dir*(y13*z24-y24*z13)
760 ny=dir*(z13*x24-z24*x13)
761 nz=dir*(x13*y24-x24*y13)
762 vol = vol+third*( nx*xx+ny*yy+nz*zz )
763 sx = sx + nx
764 sy = sy + ny
765 sz = sz + nz
766 ds = sqrt(nx*nx+ny*ny+nz*nz)
767 sa = sa + ds
768 ENDDO
769C
770 rot = rot/sa
771C
772 sv = sqrt(sx*sx+sy*sy+sz*sz)
773 vmin = em4*sa**three_half
774 veps = max(zero,vmin-abs(vol))
775C-----------------------------------------------
776C E n d o f s o u r c e
777C-----------------------------------------------
778 RETURN
779 END SUBROUTINE monvol_compute_volume
780
781!||====================================================================
782!|| monvol_check_venthole_surf ../starter/share/modules1/monvol_struct_mod.F
783!||--- called by ------------------------------------------------------
784!|| hm_read_monvol_type11 ../starter/source/airbag/hm_read_monvol_type11.F
785!|| hm_read_monvol_type4 ../starter/source/airbag/hm_read_monvol_type4.F
786!|| hm_read_monvol_type5 ../starter/source/airbag/hm_read_monvol_type5.F
787!|| hm_read_monvol_type6 ../starter/source/airbag/hm_read_monvol_type6.F
788!|| hm_read_monvol_type7 ../starter/source/airbag/hm_read_monvol_type7.F
789!|| hm_read_monvol_type8 ../starter/source/airbag/hm_read_monvol_type8.F
790!|| hm_read_monvol_type9 ../starter/source/airbag/hm_read_monvol_type9.F
791!||--- calls -----------------------------------------------------
792!|| ancmsg ../starter/source/output/message/message.F
793!||--- uses -----------------------------------------------------
794!|| message_mod ../starter/share/message_module/message_mod.F
795!||====================================================================
796 SUBROUTINE monvol_check_venthole_surf(IPRI, T_MONVOLN, IGRSURF, IHOL, SHOL, X, IXC, IXTG)
797 USE groupdef_mod
798 USE message_mod
799 use element_mod , only : nixc,nixtg
800C-----------------------------------------------
801C I m p l i c i t T y p e s
802C-----------------------------------------------
803#include "implicit_f.inc"
804#include "units_c.inc"
805#include "param_c.inc"
806#include "com04_c.inc"
807C-----------------------------------------------
808C D u m m y A r g u m e n t s
809C-----------------------------------------------
810 TYPE(monvol_struct_), INTENT(IN) :: T_MONVOLN
811 INTEGER, INTENT(IN) :: IHOL, IPRI
812 INTEGER, INTENT(IN) :: IXC(NIXC, *), IXTG(NIXTG, *)
813 my_real, INTENT(IN) :: x(3, *)
814 my_real, INTENT(OUT) :: shol
815 TYPE (SURF_), DIMENSION(NSURF), INTENT(IN) :: IGRSURF
816C-----------------------------------------------
817C L o c a l V a r i a b l e s
818C-----------------------------------------------
819 INTEGER :: ISUR, IPVENT, NN, J
820 my_real :: DIR, XX, YY, ZZ, X13, Y13, Z13, X24, Y24, Z24,
821 . nx, ny, nz, ds
822 INTEGER :: I1, I2, I3, I4, ISH34, CHKSURF, J1, ITY
823 LOGICAL :: FOUND
824 INTEGER :: EXT_SURFID, INT_SURFID, JI, NN1, JI1, ITY1, IVENTYP, ITYPE, NEL
825 CHARACTER (LEN = nchartitle) :: TITR1, TITR2, TITR3
826
827 itype = t_monvoln%TYPE
828 isur = t_monvoln%IBAGHOL(2, ihol)
829 iventyp = t_monvoln%IBAGHOL(13, ihol)
830 ipvent = igrsurf(isur)%ID
831 IF(iventyp == 0) THEN
832 titr1='VENT HOLE SURFACE'
833 ELSE
834 titr1='POROUS SURFACE'
835 ENDIF
836 shol = zero
837 nn = igrsurf(isur)%NSEG
838 DO j=1,nn
839 dir = half
840 i1 = igrsurf(isur)%NODES(j,1)
841 i2 = igrsurf(isur)%NODES(j,2)
842 i3 = igrsurf(isur)%NODES(j,3)
843 i4 = igrsurf(isur)%NODES(j,4)
844 ish34 = igrsurf(isur)%ELTYP(j)
845 IF(ish34==7)i4 = i3
846 IF(ish34/=3.AND.ish34/=7)
847 . CALL ancmsg(msgid=18,anmode=aninfo,msgtype=msgerror,i2=igrsurf(isur)%ID,i1=t_monvoln%ID,c1=t_monvoln%TITLE)
848 xx=half*(x(1,i1)+x(1,i2))
849 yy=half*(x(2,i1)+x(2,i2))
850 zz=half*(x(3,i1)+x(3,i2))
851 x13=x(1,i3)-x(1,i1)
852 y13=x(2,i3)-x(2,i1)
853 z13=x(3,i3)-x(3,i1)
854 x24=x(1,i4)-x(1,i2)
855 y24=x(2,i4)-x(2,i2)
856 z24=x(3,i4)-x(3,i2)
857 nx=dir*(y13*z24-y24*z13)
858 ny=dir*(z13*x24-z24*x13)
859 nz=dir*(x13*y24-x24*y13)
860 ds = sqrt(nx*nx+ny*ny+nz*nz)
861 shol = shol + ds
862 ENDDO
863C------------------------------------------------
864C Adding Svent Save Include in Surf Airbag
865C------------------------------------------------
866 chksurf=0
867 nn =igrsurf(isur)%NSEG
868 ext_surfid = t_monvoln%EXT_SURFID
869 DO j=1,nn
870 ji =igrsurf(isur)%ELEM(j)
871 ity=igrsurf(isur)%ELTYP(j)
872 IF(ity == 7) ji=ji+numelc
873 nn1 =igrsurf(ext_surfid)%NSEG
874 found = .false.
875C External surface test
876 DO j1=1,nn1
877 ji1 =igrsurf(ext_surfid)%ELEM(j1)
878 ity1=igrsurf(ext_surfid)%ELTYP(j1)
879 IF(ity1 == 7) ji1=ji1+numelc
880 IF(ji == ji1) THEN
881 found = .true.
882 EXIT
883 END IF
884 ENDDO
885 IF (.NOT. found) THEN
886 int_surfid = t_monvoln%IVOLU(67)
887 IF((itype == 8 .OR. itype == 11) .AND. int_surfid > 0 .AND. iventyp == 1) THEN
888 nn1 =igrsurf(int_surfid)%NSEG
889C Test surface interne
890 DO j1=1,nn1
891 ji1 =igrsurf(int_surfid)%ELEM(j1)
892 ity1=igrsurf(int_surfid)%ELTYP(j1)
893 IF(ity1 == 7) ji1=ji1+numelc
894 IF(ji == ji1) THEN
895 found = .true.
896 EXIT
897 END IF
898 ENDDO
899 ENDIF
900 ENDIF
901 IF(.NOT. found) chksurf = chksurf+1
902 IF (ipri >= 5.AND..NOT. found) THEN
903 IF(chksurf == 1) THEN
904 titr2 = igrsurf(isur)%TITLE
905 titr3 = igrsurf(ext_surfid)%TITLE
906 CALL ancmsg(msgid=41,anmode=aninfo,msgtype=msgerror,
907 . i1=t_monvoln%ID,
908 . c1=t_monvoln%TITLE,
909 . c2=titr1,
910 . i2=igrsurf(isur)%ID,
911 . c3=titr1,
912 . c4=titr2,
913 . i3=igrsurf(ext_surfid)%ID,
914 . c5=titr3)
915 IF((itype == 8 .OR. itype == 11) .AND. int_surfid > 0 .AND. iventyp == 1) THEN
916 titr3 = igrsurf(int_surfid)%TITLE
917 CALL ancmsg(msgid=41,anmode=aninfo,msgtype=msgerror,
918 . i1=t_monvoln%ID,
919 . c1=t_monvoln%TITLE,
920 . c2=titr1,
921 . i2=igrsurf(isur)%ID,
922 . c3=titr1,
923 . c4=titr2,
924 . i3=igrsurf(int_surfid)%ID,
925 . c5=titr3)
926 ENDIF
927 ENDIF
928 IF(ity == 3)THEN
929 nel=ixc(nixc,ji)
930 WRITE(iout,1486) nel,trim(titr1),ipvent
931 ELSEIF(ity == 7)THEN
932 nel=ixtg(nixtg,ji-numelc)
933 WRITE(iout,1487) nel,trim(titr1),ipvent
934 ENDIF
935 ENDIF
936 ENDDO
937C
938 IF (chksurf > 0) THEN
939 CALL ancmsg(msgid=903,anmode=aninfo,msgtype=msgerror,
940 . i2=igrsurf(isur)%ID,i3=igrsurf(ext_surfid)%ID,
941 . i1=t_monvoln%ID,c1=t_monvoln%TITLE,c2=titr1)
942 IF((itype == 8 .OR. itype == 11) .AND. int_surfid > 0 .AND. iventyp == 1) THEN
943 CALL ancmsg(msgid=903,anmode=aninfo,msgtype=msgerror,
944 . i2=igrsurf(isur)%ID,i3=igrsurf(int_surfid)%ID,
945 . i1=t_monvoln%ID,c1=t_monvoln%TITLE,c2=titr1)
946 ENDIF
947 END IF
948 RETURN
949 1486 FORMAT(6x,'SHELL ELEMENT ID=',i10,' OF ',a17,1x,i10,' DOES NOT BELONG TO THE AIRBAG SURFACE')
950 1487 FORMAT(6x,'SH3N ELEMENT ID=',i10,' OF ',a17,1x,i10,' DOES NOT BELONG TO THE AIRBAG SURFACE')
951 END SUBROUTINE monvol_check_venthole_surf
952
953!||====================================================================
954!|| monvol_allocate ../starter/share/modules1/monvol_struct_mod.F
955!||--- called by ------------------------------------------------------
956!|| lectur ../starter/source/starter/lectur.F
957!||====================================================================
958 SUBROUTINE monvol_allocate(NVOLU, T_MONVOL, T_MONVOL_METADATA)
959C-----------------------------------------------
960C I m p l i c i t T y p e s
961C-----------------------------------------------
962#include "implicit_f.inc"
963#include "param_c.inc"
964C-----------------------------------------------
965C D u m m y A r g u m e n t s
966C-----------------------------------------------
967 INTEGER, INTENT(IN) :: NVOLU
968 TYPE(MONVOL_STRUCT_), DIMENSION(NVOLU), INTENT(INOUT) :: T_MONVOL
969 TYPE(monvol_metadata_), INTENT(INOUT) :: T_MONVOL_METADATA
970C-----------------------------------------------
971C L o c a l V a r i a b l e s
972C-----------------------------------------------
973 INTEGER :: II
974
975 ! ----------------------------------
976 ! initialization of T_MONVOL
977 t_monvol(1:nvolu)%TYPE = 0
978 t_monvol(1:nvolu)%ID = 0
979 t_monvol(1:nvolu)%NCA = 0
980 t_monvol(1:nvolu)%EXT_SURFID = 0
981 t_monvol(1:nvolu)%INT_SURFID = 0
982 t_monvol(1:nvolu)%NJET = 0
983 t_monvol(1:nvolu)%NVENT = 0
984 t_monvol(1:nvolu)%NPORSURF = 0
985 t_monvol(1:nvolu)%NNS = 0
986 t_monvol(1:nvolu)%NNI = 0
987 t_monvol(1:nvolu)%NTG = 0
988 t_monvol(1:nvolu)%NTGI = 0
989 t_monvol(1:nvolu)%NBRIC = 0
990 t_monvol(1:nvolu)%NNA = 0
991 t_monvol(1:nvolu)%NTGA = 0
992 t_monvol(1:nvolu)%IMESH_ALL = 0
993 t_monvol(1:nvolu)%KMESH = 0
994 t_monvol(1:nvolu)%NB_FILL_TRI = 0
995 t_monvol(1:nvolu)%NEDGE = 0
996 t_monvol(1:nvolu)%IADALE = 0
997 t_monvol(1:nvolu)%IADALE2 = 0
998 t_monvol(1:nvolu)%IADALE3 = 0
999 t_monvol(1:nvolu)%IADALE4 = 0
1000 t_monvol(1:nvolu)%IADALE5 = 0
1001 t_monvol(1:nvolu)%IADALE6 = 0
1002 t_monvol(1:nvolu)%IADALE7 = 0
1003 t_monvol(1:nvolu)%IADALE8 = 0
1004 t_monvol(1:nvolu)%IADALE9 = 0
1005 t_monvol(1:nvolu)%IADALE10 = 0
1006 t_monvol(1:nvolu)%IADALE11 = 0
1007 t_monvol(1:nvolu)%IADALE12 = 0
1008 t_monvol(1:nvolu)%IADALE13 = 0
1009 t_monvol(1:nvolu)%KRA5 = 0
1010 t_monvol(1:nvolu)%KRA6 = 0
1011 t_monvol(1:nvolu)%KR5 = 0
1012 ! ----------------------------------
1013
1014 t_monvol_metadata%NVOLU = nvolu
1015 ALLOCATE(t_monvol_metadata%ICBAG(nicbag, nvolu * nvolu))
1016 ALLOCATE(t_monvol_metadata%RCBAG(nrcbag, nvolu * nvolu))
1017 t_monvol_metadata%RCBAG(:, :) = zero
1018 t_monvol_metadata%ICBAG(:, :) = 0
1019 DO ii = 1, nvolu
1020 ALLOCATE(t_monvol(ii)%IVOLU(nimv))
1021 t_monvol(ii)%IVOLU(1:nimv) = 0
1022 ALLOCATE(t_monvol(ii)%RVOLU(nrvolu))
1023 t_monvol(ii)%RVOLU(1:nrvolu) = zero
1024 t_monvol(ii)%NVENT = 0
1025 t_monvol(ii)%NPORSURF = 0
1026 t_monvol(ii)%EXT_SURFID = 0
1027 t_monvol(ii)%INT_SURFID = 0
1028 t_monvol(ii)%NCA = 0
1029 t_monvol(ii)%KR5 = 0
1030 t_monvol(ii)%KRA5 = 0
1031 t_monvol(ii)%EDGES_BUILT = .false.
1032 t_monvol(ii)%NB_FILL_TRI = 0
1033 t_monvol(ii)%OK_REORIENT = .true.
1034 ENDDO
1035 END SUBROUTINE monvol_allocate
1036!||====================================================================
1037!|| monvol_deallocate ../starter/share/modules1/monvol_struct_mod.F
1038!||--- called by ------------------------------------------------------
1039!|| lectur ../starter/source/starter/lectur.F
1040!||====================================================================
1041 SUBROUTINE monvol_deallocate(NVOLU, T_MONVOL)
1042C-----------------------------------------------
1043C I m p l i c i t T y p e s
1044C-----------------------------------------------
1045#include "implicit_f.inc"
1046C-----------------------------------------------
1047C D u m m y A r g u m e n t s
1048C-----------------------------------------------
1049 INTEGER, INTENT(IN) :: NVOLU
1050 TYPE(MONVOL_STRUCT_), DIMENSION(NVOLU), INTENT(INOUT) :: T_MONVOL
1051C-----------------------------------------------
1052C L o c a l V a r i a b l e s
1053C-----------------------------------------------
1054 INTEGER :: II
1055
1056 DO ii = 1, nvolu
1057 IF (ALLOCATED(t_monvol(ii)%IVOLU)) DEALLOCATE(t_monvol(ii)%IVOLU)
1058 IF (ALLOCATED(t_monvol(ii)%RVOLU)) DEALLOCATE(t_monvol(ii)%RVOLU)
1059 IF (ALLOCATED(t_monvol(ii)%IBAGJET)) DEALLOCATE(t_monvol(ii)%IBAGJET)
1060 IF (ALLOCATED(t_monvol(ii)%RBAGJET)) DEALLOCATE(t_monvol(ii)%RBAGJET)
1061 IF (ALLOCATED(t_monvol(ii)%IBAGHOL)) DEALLOCATE(t_monvol(ii)%IBAGHOL)
1062 IF (ALLOCATED(t_monvol(ii)%RBAGHOL)) DEALLOCATE(t_monvol(ii)%RBAGHOL)
1063 IF (ALLOCATED(t_monvol(ii)%NODES)) DEALLOCATE(t_monvol(ii)%NODES)
1064 IF (ALLOCATED(t_monvol(ii)%ELEM)) DEALLOCATE(t_monvol(ii)%ELEM)
1065 IF (ALLOCATED(t_monvol(ii)%ITAGEL)) DEALLOCATE(t_monvol(ii)%ITAGEL)
1066 IF (ALLOCATED(t_monvol(ii)%ELTG)) DEALLOCATE(t_monvol(ii)%ELTG)
1067 IF (ALLOCATED(t_monvol(ii)%MATTG)) DEALLOCATE(t_monvol(ii)%MATTG)
1068 IF (ALLOCATED(t_monvol(ii)%TBRIC)) DEALLOCATE(t_monvol(ii)%TBRIC)
1069 IF (ALLOCATED(t_monvol(ii)%TFAC)) DEALLOCATE(t_monvol(ii)%TFAC)
1070 IF (ALLOCATED(t_monvol(ii)%TAGELS)) DEALLOCATE(t_monvol(ii)%TAGELS)
1071 IF (ALLOCATED(t_monvol(ii)%IBUFA)) DEALLOCATE(t_monvol(ii)%IBUFA)
1072 IF (ALLOCATED(t_monvol(ii)%ELEMA)) DEALLOCATE(t_monvol(ii)%ELEMA)
1073 IF (ALLOCATED(t_monvol(ii)%BRNA)) DEALLOCATE(t_monvol(ii)%BRNA)
1074 IF (ALLOCATED(t_monvol(ii)%TAGELA)) DEALLOCATE(t_monvol(ii)%TAGELA)
1075 IF (ALLOCATED(t_monvol(ii)%NCONA)) DEALLOCATE(t_monvol(ii)%NCONA)
1076 IF (ALLOCATED(t_monvol(ii)%VELOCITY)) DEALLOCATE(t_monvol(ii)%VELOCITY)
1077 IF (ALLOCATED(t_monvol(ii)%NODE_COORD)) DEALLOCATE(t_monvol(ii)%NODE_COORD)
1078 IF (ALLOCATED(t_monvol(ii)%POROSITY)) DEALLOCATE(t_monvol(ii)%POROSITY)
1079 IF (ALLOCATED(t_monvol(ii)%THSURF_TAG)) DEALLOCATE(t_monvol(ii)%THSURF_TAG)
1080 IF (ALLOCATED(t_monvol(ii)%ELAREA)) DEALLOCATE(t_monvol(ii)%ELAREA)
1081 IF (ALLOCATED(t_monvol(ii)%FILL_TRI)) DEALLOCATE(t_monvol(ii)%FILL_TRI)
1082 IF (ALLOCATED(t_monvol(ii)%EDGE_NODE1)) DEALLOCATE(t_monvol(ii)%EDGE_NODE1)
1083 IF (ALLOCATED(t_monvol(ii)%EDGE_NODE2)) DEALLOCATE(t_monvol(ii)%EDGE_NODE2)
1084 IF (ALLOCATED(t_monvol(ii)%EDGE_ELEM)) DEALLOCATE(t_monvol(ii)%EDGE_ELEM)
1085 IF (ALLOCATED(t_monvol(ii)%IAD_EDGE_ELEM)) DEALLOCATE(t_monvol(ii)%IAD_EDGE_ELEM)
1086 ENDDO
1087 END SUBROUTINE monvol_deallocate
1088 END
1089!||====================================================================
1090!|| monvol_orient_surf ../starter/share/modules1/monvol_struct_mod.F
1091!||--- called by ------------------------------------------------------
1092!|| hm_read_monvol_type1 ../starter/source/airbag/hm_read_monvol_type1.F
1093!|| hm_read_monvol_type10 ../starter/source/airbag/hm_read_monvol_type10.F
1094!|| hm_read_monvol_type11 ../starter/source/airbag/hm_read_monvol_type11.F
1095!|| hm_read_monvol_type2 ../starter/source/airbag/hm_read_monvol_type2.F
1096!|| hm_read_monvol_type3 ../starter/source/airbag/hm_read_monvol_type3.F
1097!|| hm_read_monvol_type4 ../starter/source/airbag/hm_read_monvol_type4.F
1098!|| hm_read_monvol_type5 ../starter/source/airbag/hm_read_monvol_type5.F
1099!|| hm_read_monvol_type6 ../starter/source/airbag/hm_read_monvol_type6.F
1100!|| hm_read_monvol_type7 ../starter/source/airbag/hm_read_monvol_type7.F
1101!|| hm_read_monvol_type8 ../starter/source/airbag/hm_read_monvol_type8.F
1102!|| hm_read_monvol_type9 ../starter/source/airbag/hm_read_monvol_type9.F
1103!||--- calls -----------------------------------------------------
1104!|| ancmsg ../starter/source/output/message/message.F
1105!|| arret ../starter/source/system/arret.F
1106!|| monvol_build_edges ../starter/share/modules1/monvol_struct_mod.F
1107!||--- uses -----------------------------------------------------
1108!|| message_mod ../starter/share/message_module/message_mod.F
1109!|| monvol_struct_mod ../starter/share/modules1/monvol_struct_mod.F
1110!||====================================================================
1111 SUBROUTINE monvol_orient_surf(T_MONVOLN, TITLE, IVOLU, ITAB, SURF, IXC, IXTG, X, ITYPE)
1112 use element_mod , only : nixc,nixtg
1113C-----------------------------------------------
1114C D e s c r i p t i o n
1115C-----------------------------------------------
1116C This subroutines ensures that all normal from monvol surface are
1117C oriented on same side.
1118C volume sign of resulting oriented surface is not ensured
1119C
1120C FIND ADJACENT ELEMS (by pair)
1121C -----------------------------
1122C
1123C 10 9 8 RUN THGROUGH ELEM SORTING 1st COLUMN SORTING 2nd COLUMN FOR EACH BLOCK (siz > 2)
1124C +----+----+ node1 node2 elem_id node1 node2 elem_id
1125C | | | 1 2 17 1 10 17 } BLOCK
1126C | 17 | 11 | 2 9 17 1 2 17 }
1127C | | | 9 10 17 SORT.1 ---------------- ----------------
1128C +----+----+ 1 10 17 -----> 2 9 17 } SORT.2 2 3 11 }
1129C 1 2 3 2 3 11 2 3 11 BLOCK -----> 2 9 17 ONE COMMON EDGE IN BLOCK : 2,3
1130C 3 8 11 2 9 11 } 2 9 11 } => elem 17 & 11 are adjacent
1131C 8 9 11 ---------------- ----------------
1132C 9 10 11 3 8 11
1133C ^ ^ ^ ----------------
1134C EDGE_ARRAY_N1 ^ ^ 8 9 11
1135C EDGE_ARRAY_N2 ^ ----------------
1136C EDGE_ARRAY_ELEM 9 10 17
1137C
1138C
1139C CHECK CONNECTIVITY
1140C -----------------
1141C
1142C 10 9 8
1143C +-----+----+ EXAMPLE :
1144C | | | reference elem : {09,10,01,02} U {09}
1145C | REF | 11 | elem to treat : {08,03,02,09} U {08}
1146C | | |
1147C +-----+----+ 1. check pattern [09,10] in elem to treat : not found
1148C 1 2 3 2. check pattern [10,01] in elem to treat : not found
1149C 3. check pattern [01,02] in elem to treat : not found
1150C 4. check pattern [02,09] in elem to treat : found => reverse connectivity
1151C
1152C REVERSE CONNECTIVITY
1153C --------------------
1154C
1155C 1 2 1 2
1156C +-------+ +---------+
1157C | | \ SH3N /
1158C | SHELL | \ / SHELL : switch 2<->4
1159C | | \ / SH3N : switch 1<->2
1160C +-------+ \ /
1161C 4 3 +3
1162C
1163C
1164C-----------------------------------------------
1165C M o d u l e s
1166C-----------------------------------------------
1167 USE groupdef_mod
1168 USE message_mod
1169 USE monvol_struct_mod
1170C-----------------------------------------------
1171C I m p l i c i t T y p e s
1172C-----------------------------------------------
1173#include "implicit_f.inc"
1174C-----------------------------------------------
1175C C o m m o n B l o c k s
1176C-----------------------------------------------
1177#include "param_c.inc"
1178#include "com04_c.inc"
1179C-----------------------------------------------
1180C D u m m y A r g u m e n t s
1181C-----------------------------------------------
1182 CHARACTER(LEN = nchartitle), INTENT(IN) :: TITLE
1183 INTEGER, INTENT(IN) :: IVOLU(NIMV), ITAB(*),ITYPE, IXC(NIXC, NUMELC), IXTG(NIXTG, NUMELTG)
1184 my_real :: x(3,numnod)
1185 TYPE(surf_), INTENT(INOUT) :: SURF
1186 TYPE(monvol_struct_), INTENT(INOUT) :: T_MONVOLN
1187C-----------------------------------------------
1188C L o c a l v a r i a b l e s
1189C-----------------------------------------------
1190 INTEGER NSEG,ISH34,JJ,II(4),KK, IELEM_ADJ,IDX,IDX_A,IDX_B,IPAIR,NPAIR,LL
1191 INTEGER IDX1,IDX2
1192 INTEGER NEDG, SUM_ADJ
1193 !temporary memory
1194 INTEGER, ALLOCATABLE,DIMENSION(:) :: PATHS, SIZES, CHECK_FLAG_ELEM, NB_ADJ,IAD_ADJ, LIST_ADJ_TAB
1195 INTEGER,ALLOCATABLE,DIMENSION(:) :: db_reversed, db_path
1196 INTEGER, DIMENSION(:), ALLOCATABLE :: PAIR_LIST, NB_PAIR_BY_EDGE
1197 INTEGER :: NB_NOEUD, NB_ARC, NB_COMP_CONNEXE, SUM_SIZES
1198 INTEGER(8) :: graph_ptr
1199 INTEGER :: IELEM,ICOMP, EDGES_A(5),EDGES_B(5), NB_REVERSED
1200 INTEGER :: NPT_A, NPT_B, IELEM1, IELEM2, ELTYP1, ELTYP2, NB_COMMON_NODE,
1201 . nodelist1(4), nodelist2(4), elem1id, elem2id, elemtg, elemc, ielemtg, ielemc
1202 LOGICAL :: lFOUND, lFOUND_ADJ
1203 INTEGER :: NB_DUPLICATED_ELTS
1204 INTEGER, DIMENSION(:), ALLOCATABLE :: DUPLICATED_ELTS
1205 CHARACTER(LEN=1024) :: FILENAME
1206 INTEGER(8) :: duplicate_ptr
1207 LOGICAL debug_output
1208 INTEGER :: NTRI, NB_CON
1209 INTEGER, DIMENSION(:), ALLOCATABLE :: IAD_COMP_CONNEX
1210C-----------------------------------------------
1211C P r e C o n d i t i o n
1212C-----------------------------------------------
1213C! only type 'PRES' (2) and type 'AIRBAG1' (7) FVMBAG1 (8)
1214C! otherwise : unplug
1215C IF(ITYPE /= 2 .AND.
1216C . ITYPE /= 7 .AND.
1217C . ITYPE /= 8 )RETURN
1218C-----------------------------------------------
1219C S o u r c e L i n e s
1220C-----------------------------------------------
1221
1222 graph_ptr = 0
1223 nseg = surf%NSEG
1224 ntri = t_monvoln%NB_FILL_TRI
1225 t_monvoln%OK_REORIENT = .true.
1226
1227! ********************************* !
1228! ** Edge connectivity if needed ** !
1229! ********************************* !
1230
1231 IF (.NOT. t_monvoln%EDGES_BUILT) THEN
1232 CALL monvol_build_edges(t_monvoln, surf)
1233 ENDIF
1234 nedg = t_monvoln%NEDGE
1235
1236! ********************************* !
1237! ** Find any duplicated element ** !
1238! ********************************* !
1239! REMOVE ONE OF EACH THEM FROM THE EDGE CONNECTIVITY
1240 nb_duplicated_elts = 0
1241 duplicate_ptr = 0
1242 CALL tab1_init(duplicate_ptr)
1243 DO jj = 1, nedg
1244 nb_con = t_monvoln%IAD_EDGE_ELEM(jj + 1) - t_monvoln%IAD_EDGE_ELEM(jj)
1245 IF (nb_con > 2) THEN
1246! T connection or worse
1247 DO ielem1 = t_monvoln%IAD_EDGE_ELEM(jj), t_monvoln%IAD_EDGE_ELEM(jj + 1) - 1
1248 IF (t_monvoln%EDGE_ELEM(ielem1) /= 0) THEN
1249 DO ielem2 = t_monvoln%IAD_EDGE_ELEM(jj), t_monvoln%IAD_EDGE_ELEM(jj + 1) -1
1250 IF (ielem1 /= ielem2) THEN
1251 elem1id = t_monvoln%EDGE_ELEM(ielem1)
1252 elem2id = t_monvoln%EDGE_ELEM(ielem2)
1253 IF (elem1id * elem2id == 0) THEN
1254! One of the element have already been suppressed as duplicated from another element
1255! connected to the same edge
1256 cycle
1257 ENDIF
1258 eltyp1 = surf%ELTYP(elem1id)
1259 eltyp2 = surf%ELTYP(elem2id)
1260 IF (eltyp1 == eltyp2) THEN
1261 IF (eltyp1 == 7) THEN
1262! Two triangles
1263 nb_common_node = 0
1264 nodelist1(1:4) = (/0, ixtg(2:4,surf%ELEM(elem1id))/)
1265 nodelist2(1:4) = (/0, ixtg(2:4,surf%ELEM(elem2id))/)
1266 DO kk = 2, 4
1267 DO ll = 2, 4
1268 IF (nodelist1(kk) == nodelist2(ll)) THEN
1269 nb_common_node = nb_common_node + 1
1270 EXIT
1271 ENDIF
1272 ENDDO
1273 ENDDO
1274 IF (nb_common_node == 3) THEN
1275! Get rid of ELEM2
1276 t_monvoln%EDGE_ELEM(ielem2) = 0
1277 nb_duplicated_elts = nb_duplicated_elts + 1
1278 CALL tab1_append(duplicate_ptr, elem1id)
1279 CALL tab1_append(duplicate_ptr, elem2id)
1280 ENDIF
1281 ENDIF
1282 ELSEIF (eltyp1 == 3) THEN
1283! Two QUADS
1284 nb_common_node = 0
1285 nodelist1(1:4) = (/ixc(2:5,surf%ELEM(elem1id))/)
1286 nodelist2(1:4) = (/ixc(2:5,surf%ELEM(elem2id))/)
1287 DO kk = 1, 4
1288 DO ll = 1, 4
1289 IF (nodelist1(kk) == nodelist2(ll)) THEN
1290 nb_common_node = nb_common_node + 1
1291 EXIT
1292 ENDIF
1293 ENDDO
1294 ENDDO
1295 IF (nb_common_node == 4) THEN
1296! Get rid of ELEM2
1297 t_monvoln%EDGE_ELEM(ielem2) = 0
1298 nb_duplicated_elts = nb_duplicated_elts + 1
1299 CALL tab1_append(duplicate_ptr, elem1id)
1300 CALL tab1_append(duplicate_ptr, elem2id)
1301 ENDIF
1302 ELSE
1303! One triangle, one quad
1304 ielemtg = ielem2
1305 elemtg = elem2id
1306 ielemc = ielem1
1307 elemc = elem1id
1308 IF (eltyp1 == 7) THEN
1309 ielemtg = ielem1
1310 elemtg = elem1id
1311 ielemc = ielem2
1312 elemc = elem2id
1313 ENDIF
1314 nb_common_node = 0
1315 nodelist1(1:4) = (/0, ixtg(2:4,surf%ELEM(elemtg))/)
1316 nodelist2(1:4) = (/ixc(2:5,surf%ELEM(elemc))/)
1317 DO kk = 2, 4
1318 DO ll = 1, 4
1319 IF (nodelist1(kk) == nodelist2(ll)) THEN
1320 nb_common_node = nb_common_node + 1
1321 EXIT
1322 ENDIF
1323 ENDDO
1324 ENDDO
1325 IF (nb_common_node == 3) THEN
1326! Get rid of the triangle
1327 t_monvoln%EDGE_ELEM(ielemtg) = 0
1328 nb_duplicated_elts = nb_duplicated_elts + 1
1329 CALL tab1_append(duplicate_ptr, elemc)
1330 CALL tab1_append(duplicate_ptr, ielemtg)
1331 ENDIF
1332 ENDIF
1333 ENDIF
1334 ENDDO
1335 ENDIF
1336 ENDDO
1337 ENDIF
1338 ENDDO
1339
1340 !--------------------------------------------!
1341 ! 4. BUILD PAIRS FOR GRAPH PATH CONSTRUCTION !
1342 !--------------------------------------------!
1343! Number of pairs by edge
1344 ALLOCATE(nb_pair_by_edge(nedg))
1345 DO jj = 1, nedg
1346 nb_pair_by_edge(jj) = 0
1347 DO kk = t_monvoln%IAD_EDGE_ELEM(jj), t_monvoln%IAD_EDGE_ELEM(jj + 1) - 1
1348 IF (t_monvoln%EDGE_ELEM(kk) /= 0) THEN
1349 nb_pair_by_edge(jj) = nb_pair_by_edge(jj) + 1
1350 ENDIF
1351 ENDDO
1352 nb_pair_by_edge(jj) = (nb_pair_by_edge(jj) - 1) * nb_pair_by_edge(jj) / 2
1353 IF (nb_pair_by_edge(jj) > 1) THEN
1354 t_monvoln%OK_REORIENT = .false.
1355 ENDIF
1356 ENDDO
1357 npair = sum(nb_pair_by_edge)
1358 ALLOCATE(pair_list(2 * npair))
1359 ipair = 0
1360 DO jj = 1, nedg
1361 nb_con = t_monvoln%IAD_EDGE_ELEM(jj + 1) - t_monvoln%IAD_EDGE_ELEM(jj)
1362 DO kk = 1, nb_con
1363 DO ll = kk + 1, nb_con
1364 elem1id = t_monvoln%EDGE_ELEM(t_monvoln%IAD_EDGE_ELEM(jj) + kk - 1)
1365 elem2id = t_monvoln%EDGE_ELEM(t_monvoln%IAD_EDGE_ELEM(jj) + ll - 1)
1366 IF (elem1id .NE.0 .AND. elem2id .NE. 0) THEN
1367 pair_list(ipair + 1) = elem1id - 1
1368 pair_list(ipair + 2) = elem2id - 1
1369 ipair = ipair + 2
1370 ENDIF
1371 ENDDO
1372 ENDDO
1373 ENDDO
1374
1375 !------------------------------------!
1376 ! 5. BUILD GRAPH !
1377 !------------------------------------!
1378 ! result : graph_ptr
1379 !------------------------------------!
1380 nb_noeud=nseg+ntri
1381 nb_arc=npair
1382 nb_comp_connexe = 0
1383 CALL graph_build_path(nb_noeud, nb_arc, pair_list, nb_comp_connexe, graph_ptr)
1384
1385 !------------------------------------!
1386 ! 6. GET PATH !
1387 !------------------------------------!
1388 ! result : PATHS(1:SIZE(1),SIZE(1)+1..SIZE(2),...)
1389 !------------------------------------!
1390 IF(.NOT.ALLOCATED(sizes))ALLOCATE(sizes(0:nb_comp_connexe))
1391 ALLOCATE(iad_comp_connex(nb_comp_connexe+1))
1392 CALL graph_get_sizes(graph_ptr, sizes(1))
1393 sum_sizes=sum(sizes(1:nb_comp_connexe),1)
1394 sizes(0)=0
1395 iad_comp_connex(1) = 1
1396 DO jj = 2, nb_comp_connexe + 1
1397 iad_comp_connex(jj) = iad_comp_connex(jj - 1) + sizes(jj - 1)
1398 ENDDO
1399 IF(.NOT.ALLOCATED(paths))ALLOCATE(paths(sum_sizes))
1400 CALL graph_get_path(graph_ptr, paths)
1401
1402 !----------------------------------------!
1403 ! 7. DEBUG : HM TCL SCRIPT TO CHECK PATH !
1404 !----------------------------------------!
1405 debug_output=.false.
1406C if(debug_output)then
1407C WRITE(FILENAME1, "(A,I0,A)") "surfmesh_",T_MONVOLN%ID,"_list_ids.tcl"
1408C OPEN(UNIT = 220582, FILE = FILENAME1, FORM ='formatted')
1409C write (220582,FMT='(A)')"set ids { \"
1410C kk=0
1411C do while (kk < sizes(1))
1412C if(kk+1<sizes(1))then
1413C ISH34 = SURF%ELTYP(1+PATHS(kk+1))
1414C IF(ISH34==3)THEN
1415C write (220582,FMT='(I10,A,I10,A)')IXC(7,SURF%ELEM(1+PATHS(kk+1)) ) ," ",10000000+IXC(7,SURF%ELEM(1+PATHS(kk+1)) ),' \'
1416C ELSE
1417C write (220582,FMT='(I10,A,I10,A)')IXTG(6,SURF%ELEM(1+PATHS(kk+1)) )," ",10000000+IXTG(6,SURF%ELEM(1+PATHS(kk+1)) ),' \'
1418C ENDIF
1419C endif
1420C kk=kk+1
1421C enddo
1422C write (220582,FMT='(A)') " } ; "
1423C CLOSE(220582)
1424C
1425C WRITE(FILENAME2, "(A,I0,A)") "surfmesh_",T_MONVOLN%ID,"_list_types.tcl"
1426C OPEN(UNIT = 220582, FILE = FILENAME2, FORM ='formatted')
1427C write (220582,FMT='(A)')"set types { \"
1428C kk=0
1429C do while (kk < sizes(1))
1430C if(kk+1<sizes(1))then
1431C ISH34 = SURF%ELTYP(1+PATHS(kk+1))
1432C IF(ISH34==3)THEN
1433C write (*,FMT='(I10,A,I10,A)')3 ," ",3,' \'
1434C ELSE
1435C write (*,FMT='(I10,A,I10,A)')7," ",7,' \'
1436C ENDIF
1437C endif
1438C kk=kk+1
1439C enddo
1440C CLOSE(220582)
1441C
1442C WRITE(FILENAME, "(A,I0,A)") "surfmesh_",T_MONVOLN%ID,"_HM_TCL_MACTO.tcl"
1443C OPEN(UNIT = 220582, FILE = FILENAME, FORM ='formatted')
1444C write (220582,FMT='(A)') '#--$ids '
1445C write (220582,FMT='(A)') '::hwt::Source "'//FILENAME1//'";'
1446C write (220582,FMT='(A)') '#--$types '
1447C write (220582,FMT='(A)') '::hwt::Source "'//FILENAME2//'";'
1448C write (220582,FMT='(A)') ' '
1449C write (220582,FMT='(A)') 'for {set i 0} {$i < [llength $ids]} {incr i 2} { '
1450C write (220582,FMT='(A)') ' set ityp [lindex $types $i] '
1451C write (220582,FMT='(A)') ' set id [lindex $ids $i] '
1452C write (220582,FMT='(A)') ' '
1453C write (220582,FMT='(A)') ' if {$ityp == 3} { '
1454C write (220582,FMT='(A)') ' *createmark elements 1 [hm_getinternalid shell_idpool $id -bypoolname] ;'
1455C write (220582,FMT='(A)') ' } elseif {$ityp == 7} { '
1456C write (220582,FMT='(A)') ' *createmark elements 1 [hm_getinternalid sh3n_idpool $id -bypoolname] ; '
1457C write (220582,FMT='(A)') ' } '
1458C write (220582,FMT='(A)') ' hm_redraw; '
1459C write (220582,FMT='(A)') ' *movemark elements 1 \"COLOR\"; '
1460C write (220582,FMT='(A)') '} '
1461C CLOSE(220582)
1462C endif !(debug_output)
1463
1464 !------------------------------------!
1465 ! 8. GET PATH !
1466 !------------------------------------!
1467 IF(.NOT.ALLOCATED(nb_adj))ALLOCATE(nb_adj(nseg+ntri))
1468 IF(.NOT.ALLOCATED(iad_adj))ALLOCATE(iad_adj(nseg+ntri+1))
1469 CALL graph_get_nb_adj(graph_ptr, nb_adj)
1470 sum_adj=sum(nb_adj)
1471 iad_adj(1)=1
1472 DO kk=2,nseg+ntri+1
1473 iad_adj(kk)=iad_adj(kk-1)+nb_adj(kk-1)
1474 ENDDO
1475 IF(.NOT.ALLOCATED(list_adj_tab))ALLOCATE(list_adj_tab(sum_adj))
1476 CALL graph_get_adj(graph_ptr, list_adj_tab)
1477 DO kk=1,sum_adj
1478 list_adj_tab(kk)=list_adj_tab(kk)+1
1479 ENDDO
1480 !------------------------------------!
1481 ! 7. DEBUG OUTPUT : SURF IN FILE !
1482 !------------------------------------!
1483 !--write a Radioss input file to check final surface
1484 debug_output=.false.
1485 if(debug_output)then
1486 nseg=surf%NSEG
1487 WRITE(filename, "(A,I0,A)") "surfmesh_before_",t_monvoln%ID,"_0000.rad"
1488 OPEN(unit = 210486, file = trim(filename), form ='formatted')
1489 WRITE(210486, '(A)') "#RADIOSS STARTER"
1490 WRITE(210486, '(A)') "/BEGIN"
1491 WRITE(210486, '(A)') "ORIENTED_SURFACE "
1492 WRITE(210486, '(A)') " 100 0"
1493 WRITE(210486, '(A)') " g mm ms"
1494 WRITE(210486, '(A)') " g mm ms"
1495 WRITE(210486, "(A5)") "/NODE"
1496 DO kk = 1, numnod
1497 WRITE(210486, "(I10, 1PG20.13, 1PG20.13, 1PG20.13)") itab(kk),x(1, kk), x(2, kk), x(3, kk)
1498 ENDDO
1499 DO kk = 1, nseg
1500 ii(1:4) = surf%NODES(kk,1:4)
1501 ish34 = surf%ELTYP(kk)
1502 IF (ish34 == 3) THEN
1503 WRITE(210486, "(A6)") "/SHELL"
1504 WRITE(210486, '(I10,I10,I10,I10,I10)') ixc(7,surf%ELEM(kk)), itab(ii(1)), itab(ii(2)),itab(ii(3)), itab(ii(4))
1505 ENDIF
1506 ENDDO
1507 DO kk = 1, nseg
1508 ii(1:4) = surf%NODES(kk,1:4)
1509 ish34 = surf%ELTYP(kk)
1510 IF (ish34 == 7) THEN
1511 WRITE(210486, "(A5)") "/SH3N"
1512 WRITE(210486, '(I10,I10,I10,I10)') ixtg(6,surf%ELEM(kk)), itab(ii(1)), itab(ii(2)),itab(ii(3))
1513 ENDIF
1514 ENDDO
1515 IF (t_monvoln%NB_FILL_TRI > 0) THEN
1516 WRITE(210486, "(A5)") "/SH3N"
1517 ENDIF
1518 DO kk = 1, t_monvoln%NB_FILL_TRI
1519 WRITE(210486, '(I10,I10,I10,I10)') kk + nseg, itab(t_monvoln%FILL_TRI(3 * (kk - 1) + 1)),
1520 . itab(t_monvoln%FILL_TRI(3 * (kk - 1) + 2)), itab(t_monvoln%FILL_TRI(3 * (kk - 1) + 3))
1521 ENDDO
1522 CLOSE (210486)
1523 endif !debug_output
1524 !------------------------------------!
1525 ! 9. SPREAD NORMAL !
1526 !------------------------------------!
1527 ! result : SIZES(1:NB_COMP_CONNEXE)
1528 !------------------------------------!
1529 IF(.NOT.ALLOCATED(check_flag_elem))ALLOCATE(check_flag_elem(nseg+ntri))
1530 check_flag_elem(:)=0
1531
1532 IF (t_monvoln%OK_REORIENT) THEN
1533 DO icomp=1,nb_comp_connexe
1534
1535!--REFERENCE ELEM (FIRST ONE)
1536 jj = 1 + paths(iad_comp_connex(icomp))
1537
1538 check_flag_elem(jj)=1 !already traveled
1539 nb_reversed = 0
1540
1541 DO ielem=iad_comp_connex(icomp) + 1, iad_comp_connex(icomp + 1) - 1
1542
1543!--CURRENT ELEM
1544 jj=1+paths(ielem)
1545
1546 IF (jj <= nseg) THEN
1547 ii(1:4) = surf%NODES(jj,1:4)
1548 ish34 = surf%ELTYP(jj)
1549 IF(ish34==3.AND.ii(3)/=ii(4))THEN
1550 edges_a(1:5)=(/ ii(1:4), ii(1) /)
1551 npt_a=4
1552 ELSE
1553 edges_a(1:5)=(/ ii(1:3), ii(1), 0 /)
1554 npt_a=3
1555 ENDIF
1556 ELSE
1557 ii(1:3) = t_monvoln%FILL_TRI(3 * (jj - nseg - 1) + 1 : 3 * (jj - nseg - 1) + 3)
1558 ii(4) = ii(3)
1559 edges_a(1:5) = (/ ii(1:3), ii(1), 0 /)
1560 npt_a = 3
1561 ENDIF
1562
1563!--CHECK ADJACENT ELEM ALREADY TREATED ( KK : CHECK_FLAG_ELEM(KK) = 1)
1564!need to get KK
1565 idx1 = iad_adj(jj)
1566 idx2 = iad_adj(jj+1)-1
1567 lfound_adj = .false.
1568 DO kk=idx1,idx2
1569 ielem_adj = list_adj_tab(kk)
1570 IF(check_flag_elem(ielem_adj) /= 0 )THEN
1571 lfound_adj = .true.
1572 EXIT
1573 ENDIF
1574 ENDDO
1575 IF(.NOT. lfound_adj)THEN
1576 print *, "**error when forcing monvol surface orientation"
1577 CALL arret(2);
1578 return;
1579 ENDIF
1580 kk = ielem_adj
1581!print *, "found adjacent element already treated =", IXTG(6, SURF%ELEM(KK) )
1582
1583!--LIST OF EDGES FOR ADJACENT ELEM
1584 IF (kk <= nseg) THEN
1585 ii(1:4) = surf%NODES(kk,1:4)
1586 ish34 = surf%ELTYP(kk)
1587 IF(ish34==3.AND.ii(3)/=ii(4))THEN
1588 edges_b(1:5)=(/ ii(1:4), ii(1) /)
1589 npt_b=4
1590 ELSE
1591 edges_b(1:5)=(/ ii(1:3), ii(1), 0 /)
1592 npt_b=3
1593 ENDIF
1594 ELSE
1595 ii(1:3) = t_monvoln%FILL_TRI(3 * (kk - nseg - 1) + 1 : 3 * (kk - nseg - 1) + 3)
1596 ii(4) = ii(3)
1597 edges_b(1:5) = (/ ii(1:3), ii(1), 0 /)
1598 npt_b = 3
1599 ENDIF
1600
1601!--CHECK PATTERN (CURRENT vs ADJACENT)
1602 lfound = .false.
1603 DO idx_a=1,npt_a
1604 DO idx_b=1,npt_b
1605 IF(edges_b(idx_b)==edges_a(idx_a))THEN
1606 IF(edges_b(idx_b+1)==edges_a(idx_a+1))THEN
1607 lfound = .true.
1608 EXIT
1609 ENDIF
1610 ENDIF
1611 ENDDO
1612 IF(lfound)EXIT
1613 ENDDO
1614
1615!--REVERSE IF NEEDED (CURRENT ELEM)
1616 IF(lfound)THEN
1617 IF (jj <= nseg) THEN
1618 ii(1:4) = surf%NODES(jj,1:4)
1619 IF(npt_a == 4)THEN
1620 surf%NODES(jj,1:4)=(/ ii(1), ii(4), ii(3), ii(2) /)
1621 ELSE
1622 surf%NODES(jj,1:4)=(/ ii(2), ii(1), ii(3), ii(4) /)
1623 ENDIF
1624 ELSE
1625 ii(1:3) = t_monvoln%FILL_TRI(3 * (jj - nseg - 1) + 1 : 3 * (jj - nseg - 1) + 3)
1626 ii(4) = ii(3)
1627 t_monvoln%FILL_TRI(3 * (jj - nseg - 1) + 1 : 3 * (jj - nseg - 1) + 3) = (/ ii(2), ii(1), ii(3) /)
1628 ENDIF
1629!print *, "--> reversed normal =", IXTG(6, SURF%ELEM(JJ) )
1630 nb_reversed = nb_reversed + 1
1631 check_flag_elem(jj)=-1
1632 ENDIF
1633
1634!MARK ELEM AS TREATED & NEXT
1635 check_flag_elem(jj)=1 !treated and unchanged
1636 IF(lfound)check_flag_elem(jj)=-1 !treated and reversed
1637
1638 ENDDO !next IELEM
1639 ENDDO
1640 ELSE
1641 CALL ancmsg(msgid = 1882, anmode = aninfo, msgtype = msgwarning,
1642 . i1 = t_monvoln%ID, c1 = t_monvoln%TITLE)
1643 ENDIF
1644
1645 !----------------------------------------------------!
1646 ! 10. CONSISTENT ORIENTATION OF DUPLICATED ELEMENTS
1647 !----------------------------------------------------!
1648 ALLOCATE(duplicated_elts(nb_duplicated_elts * 2))
1649 CALL tab1_get(duplicate_ptr, duplicated_elts)
1650 DO jj = 1, nb_duplicated_elts
1651 elem1id = surf%ELEM(duplicated_elts(2 * (jj - 1) + 1))
1652 elem2id = surf%ELEM(duplicated_elts(2 * (jj - 1) + 2))
1653! ELEM1D is already oriented, ELEM2ID has to be oriented reversely
1654 eltyp1 = surf%ELTYP(duplicated_elts(2 * (jj - 1) + 1))
1655 eltyp2 = surf%ELTYP(duplicated_elts(2 * (jj - 1) + 2))
1656 IF (eltyp1 == eltyp2) THEN
1657 ii(1:4) = surf%NODES(elem1id, 1:4)
1658 IF (eltyp1 == 7) THEN
1659! Triangles
1660 surf%NODES(elem2id, 1:4) = (/ ii(2), ii(1), ii(3), ii(4) /)
1661 ELSE
1662! Quads
1663 surf%NODES(elem2id, 1:4) = (/ ii(1), ii(4), ii(3), ii(2) /)
1664 ENDIF
1665 ELSE
1666! Target element is necessarily the triangle
1667 ii(1:4) = surf%NODES(elem2id,1:4)
1668 edges_a(1:5) = (/ ii(1:3), ii(1), 0 /)
1669 npt_a = 3
1670 ii(1:4) = surf%NODES(elem1id,1:4)
1671 edges_b(1:5) = (/ ii(1:4), ii(1) /)
1672 npt_b = 4
1673 !--CHECK PATTERN (CURRENT vs ADJACENT)
1674 lfound = .false.
1675 DO idx_a=1,npt_a
1676 DO idx_b=1,npt_b
1677 IF(edges_b(idx_b)==edges_a(idx_a))THEN
1678 IF(edges_b(idx_b+1)==edges_a(idx_a+1))THEN
1679 lfound = .true.
1680 EXIT
1681 ENDIF
1682 ENDIF
1683 ENDDO
1684 IF(lfound)EXIT
1685 ENDDO
1686 IF(lfound)THEN
1687 ii(1:4) = surf%NODES(elem2id, 1:4)
1688 IF(npt_a == 4)THEN
1689 surf%NODES(elem2id,1:4)=(/ ii(1), ii(4), ii(3), ii(2) /)
1690 ELSE
1691 surf%NODES(elem2id,1:4)=(/ ii(2), ii(1), ii(3), ii(4) /)
1692 ENDIF
1693 ENDIF
1694 ENDIF
1695 ENDDO
1696 CALL tab1_free_memory(duplicate_ptr)
1697
1698 !-------------------------------------!
1699 ! 11. DEBUG OUTPUT : RESULT ON SCREEN !
1700 !-------------------------------------!
1701 !--display on screen the element path (possible mixed SHELL,SH3N)
1702 debug_output=.false.
1703 if(debug_output)then
1704 icomp=1
1705 ALLOCATE(db_path(sizes(icomp)))
1706 do ielem=1,sizes(icomp)
1707 jj=1+paths(ielem)
1708 ii(1:4) = surf%NODES(jj,1:4)
1709 ish34 = surf%ELTYP(jj)
1710 IF(ish34==3.AND.ii(3)/=ii(4))THEN
1711 db_path(jj) = ixc(7,surf%ELEM((jj)))
1712 else
1713 db_path(jj) = ixtg(6,surf%ELEM((jj)))
1714 endif
1715 enddo
1716 print *,"____________________________________________________"
1717 print *, "there are ",sizes(icomp)," elements along the path"
1718 print *, db_path(1:sizes(icomp))
1719 print *,"____________________________________________________"
1720 deallocate(db_path)
1721 endif !debug_output
1722
1723 debug_output=.false.
1724 if(debug_output)then
1725 !--display on screen the reversed elems (possible mixed SHELL,SH3N)
1726 idx=0
1727 ALLOCATE(db_reversed(sizes(icomp)))
1728 do ielem=1,sizes(icomp)
1729 jj=1+paths(ielem)
1730 ii(1:4) = surf%NODES(jj,1:4)
1731 ish34 = surf%ELTYP(jj)
1732 IF(check_flag_elem(jj)==-1)THEN
1733 idx=idx+1
1734 IF(ish34==3.AND.ii(3)/=ii(4))THEN
1735 db_reversed(idx) = ixc(7,surf%ELEM((jj)))
1736 else
1737 db_reversed(idx) = ixtg(6,surf%ELEM((jj)))
1738 endif
1739 ENDIF
1740 enddo
1741 print *, "there were ",nb_reversed," element(s) reversed along the path"
1742 print *, db_reversed(1:nb_reversed)
1743 print *,"____________________________________________________"
1744 DEALLOCATE(db_reversed)
1745 endif !debug_output
1746
1747 !------------------------------------!
1748 ! 8. FREE MEMORY !
1749 !------------------------------------!
1750 IF(ALLOCATED(nb_adj))DEALLOCATE(nb_adj)
1751 IF(ALLOCATED(iad_adj))DEALLOCATE(iad_adj)
1752 IF(ALLOCATED(check_flag_elem))DEALLOCATE(check_flag_elem)
1753 IF(ALLOCATED(list_adj_tab))DEALLOCATE(list_adj_tab)
1754 IF(ALLOCATED(paths))DEALLOCATE(paths)
1755 IF(ALLOCATED(sizes))DEALLOCATE(sizes)
1756 IF(ALLOCATED(duplicated_elts)) DEALLOCATE(duplicated_elts)
1757 IF(ALLOCATED(pair_list)) DEALLOCATE(pair_list)
1758 IF(ALLOCATED(nb_pair_by_edge)) DEALLOCATE(nb_pair_by_edge)
1759 IF (ALLOCATED(iad_comp_connex)) DEALLOCATE(iad_comp_connex)
1760 CALL graph_free_memory(graph_ptr)
1761
1762
1763 END SUBROUTINE
1764!||====================================================================
1765!|| monvol_reverse_normals ../starter/share/modules1/monvol_struct_mod.F
1766!||--- called by ------------------------------------------------------
1767!|| hm_read_monvol_type1 ../starter/source/airbag/hm_read_monvol_type1.F
1768!|| hm_read_monvol_type10 ../starter/source/airbag/hm_read_monvol_type10.F
1769!|| hm_read_monvol_type11 ../starter/source/airbag/hm_read_monvol_type11.F
1770!|| hm_read_monvol_type2 ../starter/source/airbag/hm_read_monvol_type2.F
1771!|| hm_read_monvol_type3 ../starter/source/airbag/hm_read_monvol_type3.F
1772!|| hm_read_monvol_type4 ../starter/source/airbag/hm_read_monvol_type4.F
1773!|| hm_read_monvol_type5 ../starter/source/airbag/hm_read_monvol_type5.F
1774!|| hm_read_monvol_type6 ../starter/source/airbag/hm_read_monvol_type6.F
1775!|| hm_read_monvol_type7 ../starter/source/airbag/hm_read_monvol_type7.F
1776!|| hm_read_monvol_type8 ../starter/source/airbag/hm_read_monvol_type8.F
1777!|| hm_read_monvol_type9 ../starter/source/airbag/hm_read_monvol_type9.F
1778!||--- uses -----------------------------------------------------
1779!|| message_mod ../starter/share/message_module/message_mod.F
1780!|| monvol_struct_mod ../starter/share/modules1/monvol_struct_mod.F
1781!||====================================================================
1782 SUBROUTINE monvol_reverse_normals(T_MONVOLN, TITLE, IVOLU, ITAB, SURF, IXC, IXTG, VOL, X, ITYPE)
1783C-----------------------------------------------
1784C D e s c r i p t i o n
1785C-----------------------------------------------
1786C This subroutine reverse all normals composing a given surface.
1787C Pre-condition : volume must be negative, otherwise normal are consider
1788C to be correctly oriented.
1789C-----------------------------------------------
1790C M o d u l e s
1791C-----------------------------------------------
1792 USE groupdef_mod
1793 USE message_mod
1794 USE monvol_struct_mod
1795 use element_mod , only : nixc,nixtg
1796C-----------------------------------------------
1797C I m p l i c i t T y p e s
1798C-----------------------------------------------
1799#include "implicit_f.inc"
1800C-----------------------------------------------
1801C C o m m o n B l o c k s
1802C-----------------------------------------------
1803#include "param_c.inc"
1804#include "com04_c.inc"
1805C-----------------------------------------------
1806C D u m m y A r g u m e n t s
1807C-----------------------------------------------
1808 CHARACTER(LEN = nchartitle), INTENT(IN) :: TITLE
1809 INTEGER, INTENT(IN) :: IVOLU(NIMV), ITAB(*), ITYPE
1810 TYPE(surf_), INTENT(INOUT) :: SURF
1811 my_real, INTENT(INOUT) :: vol
1812 my_real, INTENT(IN) :: x(3,numnod)
1813 INTEGER,INTENT(IN) :: IXC(NIXC, NUMELC), IXTG(NIXTG, NUMELTG)
1814 TYPE(monvol_struct_), INTENT(INOUT) :: T_MONVOLN
1815C-----------------------------------------------
1816C L o c a l v a r i a b l e s
1817C-----------------------------------------------
1818 INTEGER JJ,ISH34,II(4),KK,NSEG
1819 CHARACTER(LEN=1024) :: FILENAME
1820 LOGICAL debug_output
1821C-----------------------------------------------
1822C P r e C o n d i t i o n
1823C-----------------------------------------------
1824! nothing to do if vol>0.0, normal are already correctly oriented.
1825C IF(VOL > ZERO) RETURN !commented to get debug output (surf in file)
1826C-----------------------------------------------
1827C S o u r c e L i n e s
1828C-----------------------------------------------
1829
1830 IF (.NOT. t_monvoln%OK_REORIENT) RETURN
1831 nseg = surf%NSEG
1832 IF(vol<zero)THEN
1833!print *, "VOLUME IS NEGATIVE, SURFACE IS REVERTED" .
1834 vol = -vol
1835 DO jj=1,nseg
1836 ish34 = surf%ELTYP(jj)
1837 ii(1:4) = surf%NODES(jj,1:4)
1838 IF(ish34 == 3)THEN
1839!SHELL
1840 surf%NODES(jj,1:4)=(/ ii(1), ii(4), ii(3), ii(2) /)
1841 ELSEIF(ish34 == 7)THEN
1842!SH3N
1843 surf%NODES(jj,1:4)=(/ ii(2), ii(1), ii(3), ii(4) /)
1844 ENDIF
1845 ENDDO
1846 DO jj = 1, t_monvoln%NB_FILL_TRI
1847 ii(1:3) = t_monvoln%FILL_TRI(3 * (jj - 1) + 1 : 3 * (jj - 1) + 3)
1848 ii(4) = ii(3)
1849 t_monvoln%FILL_TRI(3 * (jj - 1) + 1 : 3 * (jj - 1) + 3) = (/ ii(2), ii(1), ii(3) /)
1850 ENDDO
1851 ENDIF
1852
1853 !------------------------------------!
1854 ! 7. DEBUG OUTPUT : SURF IN FILE !
1855 !------------------------------------!
1856 !--write a Radioss input file to check final surface
1857 debug_output=.false.
1858 if(debug_output)then
1859 nseg=surf%NSEG
1860 WRITE(filename, "(A,I0,A)") "surfmesh_after_",t_monvoln%ID,"_0000.rad"
1861 OPEN(unit = 210486, file = trim(filename), form ='formatted')
1862 WRITE(210486, '(A)') "#RADIOSS STARTER"
1863 WRITE(210486, '(A)') "/BEGIN"
1864 WRITE(210486, '(A)') "ORIENTED_SURFACE "
1865 WRITE(210486, '(A)') " 100 0"
1866 WRITE(210486, '(A)') " g mm ms"
1867 WRITE(210486, '(A)') " g mm ms"
1868 WRITE(210486, "(A5)") "/NODE"
1869 DO kk = 1, numnod
1870 WRITE(210486, "(I10, 1PG20.13, 1PG20.13, 1PG20.13)") itab(kk),x(1, kk), x(2, kk), x(3, kk)
1871 ENDDO
1872 DO kk = 1, nseg
1873 ii(1:4) = surf%NODES(kk,1:4)
1874 ish34 = surf%ELTYP(kk)
1875 IF (ish34 == 3) THEN
1876 WRITE(210486, "(A6)") "/SHELL"
1877 WRITE(210486, '(I10,I10,I10,I10,I10)') ixc(7,surf%ELEM(kk)), itab(ii(1)), itab(ii(2)),itab(ii(3)), itab(ii(4))
1878 ENDIF
1879 ENDDO
1880 DO kk = 1, nseg
1881 ii(1:4) = surf%NODES(kk,1:4)
1882 ish34 = surf%ELTYP(kk)
1883 IF (ish34 == 7) THEN
1884 WRITE(210486, "(A5)") "/SH3N"
1885 WRITE(210486, '(I10,I10,I10,I10)') ixtg(6,surf%ELEM(kk)), itab(ii(1)), itab(ii(2)),itab(ii(3))
1886 ENDIF
1887 ENDDO
1888 IF (t_monvoln%NB_FILL_TRI > 0) THEN
1889 WRITE(210486, "(A5)") "/SH3N"
1890 ENDIF
1891 DO kk = 1, t_monvoln%NB_FILL_TRI
1892 WRITE(210486, '(I10,I10,I10,I10)') kk + nseg, itab(t_monvoln%FILL_TRI(3 * (kk - 1) + 1)),
1893 . itab(t_monvoln%FILL_TRI(3 * (kk - 1) + 2)), itab(t_monvoln%FILL_TRI(3 * (kk - 1) + 3))
1894 ENDDO
1895 CLOSE (210486)
1896 endif !debug_output
1897
1898 END SUBROUTINE
1899
1900
1901!||====================================================================
1902!|| monvol_build_edges ../starter/share/modules1/monvol_struct_mod.F
1903!||--- called by ------------------------------------------------------
1904!|| monvol_check_surfclose ../starter/share/modules1/monvol_struct_mod.F
1905!|| monvol_orient_surf ../starter/share/modules1/monvol_struct_mod.F
1906!||--- calls -----------------------------------------------------
1907!||--- uses -----------------------------------------------------
1908!|| message_mod ../starter/share/message_module/message_mod.F
1909!|| monvol_struct_mod ../starter/share/modules1/monvol_struct_mod.F
1910!||====================================================================
1911 SUBROUTINE monvol_build_edges(T_MONVOLN, SURF)
1912C-----------------------------------------------
1913C D e s c r i p t i o n
1914C-----------------------------------------------
1915C Build edges connectivity of monvol external surface
1916C-----------------------------------------------
1917C M o d u l e s
1918C-----------------------------------------------
1919 USE groupdef_mod
1920 USE message_mod
1921 USE monvol_struct_mod
1922C-----------------------------------------------
1923C I m p l i c i t T y p e s
1924C-----------------------------------------------
1925#include "implicit_f.inc"
1926C-----------------------------------------------
1927C C o m m o n B l o c k s
1928C-----------------------------------------------
1929#include "param_c.inc"
1930#include "com04_c.inc"
1931C-----------------------------------------------
1932C D u m m y a r g u m e n t s
1933C-----------------------------------------------
1934 TYPE(surf_), INTENT(IN) :: SURF
1935 TYPE(MONVOL_STRUCT_), INTENT(INOUT) :: T_MONVOLN
1936C-----------------------------------------------
1937C L o c a l v a r i a b l e s
1938C-----------------------------------------------
1939 INTEGER :: NSEG, NTRI
1940 INTEGER, DIMENSION(:), ALLOCATABLE :: EDGE_ARRAY_N1, EDGE_ARRAY_N2, EDGE_ARRAY_ELEM,
1941 . nb_connect
1942 INTEGER(8) :: edge_ptr
1943 INTEGER :: JJ, II(4), IDX, ELTYP, NEDG
1944C-----------------------------------------------
1945C S o u r c e L i n e s
1946C-----------------------------------------------
1947 IF (ALLOCATED(t_monvoln%EDGE_NODE1)) DEALLOCATE(t_monvoln%EDGE_NODE1)
1948 IF (ALLOCATED(t_monvoln%EDGE_NODE2)) DEALLOCATE(t_monvoln%EDGE_NODE2)
1949 IF (ALLOCATED(t_monvoln%EDGE_ELEM)) DEALLOCATE(t_monvoln%EDGE_ELEM)
1950 IF (ALLOCATED(t_monvoln%IAD_EDGE_ELEM)) DEALLOCATE(t_monvoln%IAD_EDGE_ELEM)
1951 t_monvoln%NEDGE = 0
1952
1953 nseg = surf%NSEG
1954 ntri = t_monvoln%NB_FILL_TRI
1955
1956 ALLOCATE(edge_array_n1(4 * (nseg + ntri)))
1957 ALLOCATE(edge_array_n2(4 * (nseg + ntri)))
1958 ALLOCATE(edge_array_elem(4 * (nseg + ntri)))
1959
1960! ******************************* !
1961! ** External surface elements ** !
1962! ******************************* !
1963 idx = 0
1964 DO jj = 1, nseg
1965 ii(1:4) = surf%NODES(jj, 1:4)
1966 eltyp = surf%ELTYP(jj)
1967 SELECT CASE (eltyp)
1968 CASE (3)
1969! Quads
1970 edge_array_n1(idx + 1) = min(ii(1), ii(2))
1971 edge_array_n2(idx + 1) = max(ii(1), ii(2))
1972 edge_array_n1(idx + 2) = min(ii(2), ii(3))
1973 edge_array_n2(idx + 2) = max(ii(2), ii(3))
1974 edge_array_n1(idx + 3) = min(ii(3), ii(4))
1975 edge_array_n2(idx + 3) = max(ii(3), ii(4))
1976 edge_array_n1(idx + 4) = min(ii(4), ii(1))
1977 edge_array_n2(idx + 4) = max(ii(4), ii(1))
1978 edge_array_elem(idx + 1:idx + 4) = jj
1979 idx = idx + 4
1980 CASE (7)
1981! Tri
1982 edge_array_n1(idx + 1) = min(ii(1), ii(2))
1983 edge_array_n2(idx + 1) = max(ii(1), ii(2))
1984 edge_array_n1(idx + 2) = min(ii(2), ii(3))
1985 edge_array_n2(idx + 2) = max(ii(2), ii(3))
1986 edge_array_n1(idx + 3) = min(ii(3), ii(1))
1987 edge_array_n2(idx + 3) = max(ii(3), ii(1))
1988 edge_array_elem(idx + 1:idx + 3) = jj
1989 idx = idx + 3
1990 CASE DEFAULT
1991
1992 END SELECT
1993 ENDDO
1994
1995! **************************** !
1996! ** Filling hole triangles ** !
1997! **************************** !
1998 DO jj = 1, ntri
1999 ii(1:3) = t_monvoln%FILL_TRI(3 * (jj - 1) + 1 : 3 * (jj - 1) + 3)
2000 edge_array_n1(idx + 1) = min(ii(1), ii(2))
2001 edge_array_n2(idx + 1) = max(ii(1), ii(2))
2002 edge_array_n1(idx + 2) = min(ii(2), ii(3))
2003 edge_array_n2(idx + 2) = max(ii(2), ii(3))
2004 edge_array_n1(idx + 3) = min(ii(3), ii(1))
2005 edge_array_n2(idx + 3) = max(ii(3), ii(1))
2006 edge_array_elem(idx + 1:idx + 3) = jj + nseg
2007 idx = idx + 3
2008 ENDDO
2009 nedg = idx
2010
2011! ********************************* !
2012! ** Edge sorting and compaction ** !
2013! ********************************* !
2014
2015 edge_ptr = 0
2016 CALL edge_sort(edge_ptr, edge_array_n1, edge_array_n2, edge_array_elem, nedg)
2017 ALLOCATE(nb_connect(nedg))
2018 CALL edge_get_nb_connect(edge_ptr, nb_connect)
2019
2020 ALLOCATE(t_monvoln%EDGE_NODE1(nedg))
2021 ALLOCATE(t_monvoln%EDGE_NODE2(nedg))
2022 ALLOCATE(t_monvoln%EDGE_ELEM(sum(nb_connect)))
2023 ALLOCATE(t_monvoln%IAD_EDGE_ELEM(nedg + 1))
2024
2025 CALL edge_get_connect(edge_ptr, t_monvoln%EDGE_ELEM)
2026
2027 t_monvoln%IAD_EDGE_ELEM(1) = 1
2028 DO jj = 2, nedg + 1
2029 t_monvoln%IAD_EDGE_ELEM(jj) = t_monvoln%IAD_EDGE_ELEM(jj - 1) + nb_connect(jj - 1)
2030 ENDDO
2031 DO jj = 1, nedg
2032 t_monvoln%EDGE_NODE1(jj) = edge_array_n1(jj)
2033 t_monvoln%EDGE_NODE2(jj) = edge_array_n2(jj)
2034 ENDDO
2035
2036 CALL edge_free_memory(edge_ptr)
2037 t_monvoln%NEDGE = nedg
2038 t_monvoln%EDGES_BUILT = .true.
2039
2040! ************************* !
2041! ** Memory deallocation ** !
2042! ************************* !
2043 DEALLOCATE(edge_array_n1)
2044 DEALLOCATE(edge_array_n2)
2045 DEALLOCATE(edge_array_elem)
2046 DEALLOCATE(nb_connect)
2047C-----------------------------------------------
2048C E n d O f S u b r o u t i n e
2049C-----------------------------------------------
2050 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:668
message_mod
Definition message_mod.F:1257
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:797
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:959
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:1042
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:1002
names_and_titles_mod::nchartitle
integer, parameter nchartitle
Definition names_and_titles_mod.F:1008
monvol_orient_surf
subroutine monvol_orient_surf(t_monvoln, title, ivolu, itab, surf, ixc, ixtg, x, itype)
Definition monvol_struct_mod.F:1112
monvol_reverse_normals
subroutine monvol_reverse_normals(t_monvoln, title, ivolu, itab, surf, ixc, ixtg, vol, x, itype)
Definition monvol_struct_mod.F:1783
monvol_build_edges
subroutine monvol_build_edges(t_monvoln, surf)
Definition monvol_struct_mod.F:1912
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:895
arret
subroutine arret(nn)
Definition arret.F:86
starter
program starter
Definition starter.F:39
groupdef_mod::surf_
Definition groupdef_mod.F:751
monvol_struct_mod::monvol_metadata_
Definition monvol_struct_mod.F:76
monvol_struct_mod::monvol_struct_
Definition monvol_struct_mod.F:84
velocity
subroutine velocity(a, ar, v, vr, fzero, itab, nale)
Definition velocity.F:29