OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
insert_clause_in_set.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!|| insert_clause_in_set ../starter/source/model/sets/insert_clause_in_set.F
25!||--- called by ------------------------------------------------------
26!|| create_set_clause ../starter/source/model/sets/create_set_clause.F
27!|| create_set_collect ../starter/source/model/sets/create_setcol_clause.F
28!|| create_setcol_clause ../starter/source/model/sets/create_setcol_clause.F
29!|| hm_set ../starter/source/model/sets/hm_set.F
30!||--- calls -----------------------------------------------------
31!|| create_line_from_element ../starter/source/model/sets/create_line_from_element.F
32!|| create_line_from_surface ../starter/source/model/sets/create_line_from_surface.F
33!|| create_surface_from_element ../starter/source/model/sets/create_surface_from_element.F
34!|| set_merge_simple ../starter/source/model/sets/set_merge_simple.F
35!|| surface_type ../starter/source/model/sets/surface_type.F90
36!||--- uses -----------------------------------------------------
37!|| hm_option_read_mod ../starter/share/modules1/hm_option_read_mod.F
38!|| message_mod ../starter/share/message_module/message_mod.F
39!|| set_mod ../starter/share/modules1/set_mod.f
40!|| surface_type_mod ../starter/source/model/sets/surface_type.F90
41!||====================================================================
42 SUBROUTINE insert_clause_in_set(SET ,CLAUSE ,CLAUSE_OPERATOR,
43 . IXS ,IXS10 , IXQ ,
44 . IXC ,IXTG ,IXT ,IXP ,IXR ,
45 . SH4TREE,
46 . SH3TREE ,KNOD2ELS ,NOD2ELS ,KNOD2ELC ,NOD2ELC,
47 . KNOD2ELTG ,NOD2ELTG ,IPARTC ,IPARTG ,IPARTS ,
48 . IPART ,OPT_A ,OPT_O ,KNOD2ELQ ,NOD2ELQ,
49 . X ,KEYSET ,OPT_E ,DELBUF ,IPARTQ)
50C-----------------------------------------------
51C ROUTINE DESCRIPTION :
52C ===================
53C Apply the clause to the current set
54C-----------------------------------------------
55C DUMMY ARGUMENTS DESCRIPTION:
56C ===================
57C
58C NAME DESCRIPTION
59C
60C SET Set Structure - Current SET
61C CLAUSE Filled CLAUSE
62C============================================================================
63C-----------------------------------------------
64C D e f i n i t i o n s
65C-----------------------------------------------
66C-----------------------------------------------
67C M o d u l e s
68C-----------------------------------------------
69 USE my_alloc_mod
70 USE hm_option_read_mod
71 USE setdef_mod
72 USE message_mod
73 USE set_scratch_mod
74 USE names_and_titles_mod , ONLY : ncharfield
75 USE set_mod , ONLY : set_add,set_delete,set_intersect
76 use surface_type_mod , only : surface_type
77 use element_mod , only : nixs,nixq,nixc,nixt,nixp,nixr,nixtg
78C-----------------------------------------------
79C I m p l i c i t T y p e s
80C-----------------------------------------------
81#include "implicit_f.inc"
82#include "param_c.inc"
83#include "sphcom.inc"
84#include "com04_c.inc"
85#include "scr17_c.inc"
86C-----------------------------------------------
87C D u m m y A r g u m e n t s
88C-----------------------------------------------
89 TYPE (SET_) :: SET
90 TYPE (SET_) :: CLAUSE
91 TYPE (SET_SCRATCH) :: DELBUF
92 INTEGER CLAUSE_OPERATOR
93
94 INTEGER OPT_A,OPT_O,OPT_E
95 INTEGER IXS(NIXS,*),IXS10(6,*),
96 . ixq(nixq,*),ixc(nixc,*),ixtg(nixtg,*),ixt(nixt,*),
97 . ixp(nixp,*),ixr(nixr,*),
98 . sh4tree(*),sh3tree(*),knod2els(*),knod2elc(*),knod2eltg(*),
99 . knod2elq(*),nod2els(*),nod2elc(*),nod2eltg(*),nod2elq(*),
100 . iparts(*),ipartc(*),ipartg(*),ipart(lipart1,*),ipartq(numelq)
101 my_real
102 . x(3,*)
103 CHARACTER(LEN=NCHARFIELD) :: KEYSET
104C-----------------------------------------------
105C L o c a l V a r i a b l e s
106C-----------------------------------------------
107 INTEGER, DIMENSION(:), ALLOCATABLE :: RESULT
108 INTEGER, DIMENSION(:), ALLOCATABLE :: NODES
109 INTEGER, DIMENSION(:,:), ALLOCATABLE :: SURF
110 INTEGER NEW_SIZE, NS
111 logical :: empty_condition
112C-----------------------------------------------
113C NODES
114C-----------------------------------------------
115 IF( clause%NB_NODE > 0) THEN
116
117 IF( set%NB_NODE > 0 ) THEN
118
119 ALLOCATE(result(set%NB_NODE + clause%NB_NODE )) ! Results SET
120
121 CALL set_merge_simple( set%NODE, set%NB_NODE ,
122 * clause%NODE, clause%NB_NODE ,
123 * result, new_size ,
124 * clause_operator)
125
126 IF (ALLOCATED(set%NODE)) DEALLOCATE (set%NODE)
127 ALLOCATE(set%NODE(new_size))
128
129 set%NODE(1:new_size) = result(1:new_size)
130 set%NB_NODE=new_size
131
132 DEALLOCATE(result)
133
134 ELSE ! SET is empty fill it with clause when ADD
135
136 IF ( clause_operator == set_add) THEN
137 IF (ALLOCATED(set%NODE)) DEALLOCATE (set%NODE)
138 ALLOCATE(set%NODE(clause%NB_NODE) )
139
140 set%NB_NODE=clause%NB_NODE
141 set%NODE(1:clause%NB_NODE)=clause%NODE(1:clause%NB_NODE)
142
143 ENDIF
144
145 ENDIF
146 ELSE
147 IF ( clause_operator == set_intersect) THEN ! SET Intersection with Empty clause gives Empty SET
148 IF (set%NB_NODE > 0)THEN
149 IF(ALLOCATED(set%NODE)) DEALLOCATE(set%NODE)
150 set%NB_NODE=0
151 ENDIF
152 ENDIF
153 ENDIF
154C-----------------------------------------------
155C NODENS
156C-----------------------------------------------
157 IF( clause%NB_NODENS > 0 ) THEN
158
159 IF( set%NB_NODENS > 0 ) THEN
160
161 ALLOCATE(result(set%NB_NODENS + clause%NB_NODENS )) ! Results SET
162
163 CALL set_merge_simple( set%NODENS, set%NB_NODENS ,
164 * clause%NODENS, clause%NB_NODENS ,
165 * result, new_size ,
166 * clause_operator)
167
168 IF (ALLOCATED(set%NODENS)) DEALLOCATE (set%NODENS)
169 ALLOCATE(set%NODENS(new_size))
170
171 set%NODENS(1:new_size) = result(1:new_size)
172 set%NB_NODENS=new_size
173
174 DEALLOCATE(result)
175
176 ELSE ! SET is empty fill it with clause when ADD
177
178 IF ( clause_operator == set_add) THEN
179 IF (ALLOCATED(set%NODENS)) DEALLOCATE (set%NODENS)
180 ALLOCATE(set%NODENS(clause%NB_NODENS) )
181
182 set%NB_NODENS=clause%NB_NODENS
183 set%NODENS(1:clause%NB_NODENS)=clause%NODENS(1:clause%NB_NODENS)
184
185 ENDIF
186
187 ENDIF
188 ELSE
189 IF ( clause_operator == set_intersect) THEN ! SET Intersection with Empty clause gives Empty SET
190 IF (set%NB_NODENS > 0)THEN
191 IF(ALLOCATED(set%NODENS)) DEALLOCATE(set%NODENS)
192 set%NB_NODENS=0
193 ENDIF
194 ENDIF
195 ENDIF
196C-----------------------------------------------
197C PARTS
198C-----------------------------------------------
199 IF( clause%NB_PART > 0) THEN
200
201 IF( set%NB_PART > 0 ) THEN
202
203 ALLOCATE(result(set%NB_PART + clause%NB_PART )) ! Results SET
204
205 CALL set_merge_simple( set%PART, set%NB_PART ,
206 * clause%PART, clause%NB_PART ,
207 * result, new_size ,
208 * clause_operator )
209
210 IF (ALLOCATED(set%PART)) DEALLOCATE (set%PART)
211 ALLOCATE(set%PART(new_size))
212
213 set%PART(1:new_size) = result(1:new_size)
214 set%NB_PART=new_size
215
216 DEALLOCATE(result)
217
218 ELSE ! SET is empty fill it with clause when ADD
219 IF ( clause_operator == set_add) THEN
220 IF (ALLOCATED(set%PART)) DEALLOCATE (set%PART)
221 ALLOCATE(set%PART(clause%NB_PART) )
222
223 set%NB_PART=clause%NB_PART
224 set%PART(1:set%NB_PART)=clause%PART(1:set%NB_PART)
225
226 ENDIF
227
228 ENDIF
229 ELSE
230 IF ( clause_operator == set_intersect) THEN ! SET Intersection with Empty clause gives Empty SET
231 IF (set%NB_PART > 0)THEN
232 IF(ALLOCATED(set%PART)) DEALLOCATE(set%PART)
233 set%NB_PART=0
234 ENDIF
235 ENDIF
236 ENDIF
237C-----------------------------------------------
238C SOLIDS
239C-----------------------------------------------
240 IF( clause%NB_SOLID > 0) THEN
241
242 IF( set%NB_SOLID > 0 ) THEN
243
244 ALLOCATE(result(set%NB_SOLID + clause%NB_SOLID )) ! Results SET
245
246 CALL set_merge_simple( set%SOLID, set%NB_SOLID ,
247 * clause%SOLID, clause%NB_SOLID ,
248 * result, new_size ,
249 * clause_operator)
250
251 IF (ALLOCATED(set%SOLID)) DEALLOCATE (set%SOLID)
252 ALLOCATE(set%SOLID(new_size))
253
254 set%SOLID(1:new_size) = result(1:new_size)
255 set%NB_SOLID=new_size
256
257 DEALLOCATE(result)
258
259 ELSE ! SET is empty fill it with clause when ADD
260
261 IF ( clause_operator == set_add) THEN
262 IF (ALLOCATED(set%SOLID)) DEALLOCATE (set%SOLID)
263 ALLOCATE(set%SOLID(clause%NB_SOLID) )
264
265 set%NB_SOLID=clause%NB_SOLID
266 set%SOLID(1:clause%NB_SOLID)=clause%SOLID(1:clause%NB_SOLID)
267
268 ENDIF
269
270 ENDIF
271 ELSE
272 IF ( clause_operator == set_intersect) THEN ! SET Intersection with Empty clause gives Empty SET
273 IF (set%NB_SOLID > 0)THEN
274 IF(ALLOCATED(set%SOLID)) DEALLOCATE(set%SOLID)
275 set%NB_SOLID=0
276 ENDIF
277 ENDIF
278 ENDIF
279C-----------------------------------------------
280C SH4N
281C-----------------------------------------------
282 IF( clause%NB_SH4N > 0) THEN
283
284 IF( set%NB_SH4N > 0 ) THEN
285
286 ALLOCATE(result(set%NB_SH4N + clause%NB_SH4N )) ! Results SET
287
288 CALL set_merge_simple( set%SH4N, set%NB_SH4N ,
289 * clause%SH4N, clause%NB_SH4N ,
290 * result, new_size ,
291 * clause_operator)
292
293 IF (ALLOCATED(set%SH4N)) DEALLOCATE (set%SH4N)
294 ALLOCATE(set%SH4N(new_size))
295
296 set%SH4N(1:new_size) = result(1:new_size)
297 set%NB_SH4N=new_size
298
299 DEALLOCATE(result)
300
301 ELSE ! SET is empty fill it with clause when ADD
302
303 IF ( clause_operator == set_add) THEN
304 IF (ALLOCATED(set%SH4N)) DEALLOCATE (set%SH4N)
305 ALLOCATE(set%SH4N(clause%NB_SH4N) )
306
307 set%NB_SH4N=clause%NB_SH4N
308 set%SH4N(1:clause%NB_SH4N)=clause%SH4N(1:clause%NB_SH4N)
309
310 ENDIF
311
312 ENDIF
313 ELSE
314 IF ( clause_operator == set_intersect) THEN ! SET Intersection with Empty clause gives Empty SET
315 IF (set%NB_SH4N > 0)THEN
316 IF(ALLOCATED(set%SH4N)) DEALLOCATE(set%SH4N)
317 set%NB_SH4N=0
318 ENDIF
319 ENDIF
320 ENDIF
321C-----------------------------------------------
322C SH3N
323C-----------------------------------------------
324 IF( clause%NB_SH3N > 0) THEN
325
326 IF( set%NB_SH3N > 0 ) THEN
327
328 ALLOCATE(result(set%NB_SH3N + clause%NB_SH3N )) ! Results SET
329
330 CALL set_merge_simple( set%SH3N, set%NB_SH3N ,
331 * clause%SH3N, clause%NB_SH3N ,
332 * result, new_size ,
333 * clause_operator)
334
335 IF (ALLOCATED(set%SH3N)) DEALLOCATE (set%SH3N)
336 ALLOCATE(set%SH3N(new_size))
337
338 set%SH3N(1:new_size) = result(1:new_size)
339 set%NB_SH3N=new_size
340
341 DEALLOCATE(result)
342
343 ELSE ! SET is empty fill it with clause when ADD
344
345 IF ( clause_operator == set_add) THEN
346 IF (ALLOCATED(set%SH3N)) DEALLOCATE (set%SH3N)
347 ALLOCATE(set%SH3N(clause%NB_SH3N) )
348
349 set%NB_SH3N=clause%NB_SH3N
350 set%SH3N(1:clause%NB_SH3N) = clause%SH3N(1:clause%NB_SH3N)
351
352 ENDIF
353
354 ENDIF
355 ELSE
356 IF ( clause_operator == set_intersect) THEN ! SET Intersection with Empty clause gives Empty SET
357 IF (set%NB_SH3N > 0)THEN
358 IF(ALLOCATED(set%SH3N)) DEALLOCATE(set%SH3N)
359 set%NB_SH3N=0
360 ENDIF
361 ENDIF
362 ENDIF
363C-----------------------------------------------
364C QUAD
365C-----------------------------------------------
366 IF( clause%NB_QUAD > 0) THEN
367
368 IF( set%NB_QUAD > 0 ) THEN
369
370 ALLOCATE(result(set%NB_QUAD + clause%NB_QUAD )) ! Results SET
371
372 CALL set_merge_simple( set%QUAD, set%NB_QUAD ,
373 * clause%QUAD, clause%NB_QUAD ,
374 * result, new_size ,
375 * clause_operator)
376
377 IF (ALLOCATED(set%QUAD)) DEALLOCATE (set%QUAD)
378 ALLOCATE(set%QUAD(new_size))
379
380 set%QUAD(1:new_size) = result(1:new_size)
381 set%NB_QUAD=new_size
382
383 DEALLOCATE(result)
384
385 ELSE ! SET is empty fill it with clause when ADD
386
387 IF ( clause_operator == set_add) THEN
388 IF (ALLOCATED(set%QUAD)) DEALLOCATE (set%QUAD)
389 ALLOCATE(set%QUAD(clause%NB_QUAD) )
390
391 set%NB_QUAD=clause%NB_QUAD
392 set%QUAD(1:clause%NB_QUAD)=clause%QUAD(1:clause%NB_QUAD)
393
394 ENDIF
395
396 ENDIF
397 ELSE
398 IF ( clause_operator == set_intersect) THEN ! SET Intersection with Empty clause gives Empty SET
399 IF (set%NB_QUAD > 0)THEN
400 IF(ALLOCATED(set%QUAD)) DEALLOCATE(set%QUAD)
401 set%NB_QUAD=0
402 ENDIF
403 ENDIF
404 ENDIF
405C-----------------------------------------------
406C TRIA
407C-----------------------------------------------
408 IF( clause%NB_TRIA > 0) THEN
409
410 IF( set%NB_TRIA > 0 ) THEN
411
412 ALLOCATE(result(set%NB_TRIA + clause%NB_TRIA )) ! Results SET
413
414 CALL set_merge_simple( set%TRIA, set%NB_TRIA ,
415 * clause%TRIA, clause%NB_TRIA ,
416 * result, new_size ,
417 * clause_operator)
418
419 IF (ALLOCATED(set%TRIA)) DEALLOCATE (set%TRIA)
420 ALLOCATE(set%TRIA(new_size))
421
422 set%TRIA(1:new_size) = result(1:new_size)
423 set%NB_TRIA=new_size
424
425 DEALLOCATE(result)
426
427 ELSE ! SET is empty fill it with clause when ADD
428
429 IF ( clause_operator == set_add) THEN
430 IF (ALLOCATED(set%TRIA)) DEALLOCATE (set%TRIA)
431 ALLOCATE(set%TRIA(clause%NB_TRIA) )
432
433 set%NB_TRIA=clause%NB_TRIA
434 set%TRIA(1:clause%NB_TRIA) = clause%TRIA(1:clause%NB_TRIA)
435
436 ENDIF
437
438 ENDIF
439 ELSE
440 IF ( clause_operator == set_intersect) THEN ! SET Intersection with Empty clause gives Empty SET
441 IF (set%NB_TRIA > 0)THEN
442 IF(ALLOCATED(set%TRIA)) DEALLOCATE(set%TRIA)
443 set%NB_TRIA=0
444 ENDIF
445 ENDIF
446 ENDIF
447C-----------------------------------------------
448C BEAM
449C-----------------------------------------------
450 IF( clause%NB_BEAM > 0) THEN
451
452 IF( set%NB_BEAM > 0 ) THEN
453
454 ALLOCATE(result(set%NB_BEAM + clause%NB_BEAM )) ! Results SET
455
456 CALL set_merge_simple( set%BEAM, set%NB_BEAM ,
457 * clause%BEAM, clause%NB_BEAM ,
458 * result, new_size ,
459 * clause_operator)
460
461 IF (ALLOCATED(set%BEAM)) DEALLOCATE (set%BEAM)
462 ALLOCATE(set%BEAM(new_size))
463
464 set%BEAM(1:new_size) = result(1:new_size)
465 set%NB_BEAM=new_size
466
467 DEALLOCATE(result)
468
469 ELSE ! SET is empty fill it with clause when ADD
470
471 IF ( clause_operator == set_add) THEN
472 IF (ALLOCATED(set%BEAM)) DEALLOCATE (set%BEAM)
473 ALLOCATE(set%BEAM(clause%NB_BEAM) )
474
475 set%NB_BEAM=clause%NB_BEAM
476 set%BEAM(1:clause%NB_BEAM) = clause%BEAM(1:clause%NB_BEAM)
477 ENDIF
478
479 ENDIF
480 ELSE
481 IF ( clause_operator == set_intersect) THEN ! SET Intersection with Empty clause gives Empty SET
482 IF (set%NB_BEAM > 0)THEN
483 IF(ALLOCATED(set%BEAM)) DEALLOCATE(set%BEAM)
484 set%NB_BEAM=0
485 ENDIF
486 ENDIF
487 ENDIF
488C-----------------------------------------------
489C TRUSS
490C-----------------------------------------------
491 IF( clause%NB_TRUSS > 0) THEN
492
493 IF( set%NB_TRUSS > 0 ) THEN
494
495 ALLOCATE(result(set%NB_TRUSS + clause%NB_TRUSS )) ! Results SET
496
497 CALL set_merge_simple( set%TRUSS, set%NB_TRUSS ,
498 * clause%TRUSS, clause%NB_TRUSS ,
499 * result, new_size ,
500 * clause_operator)
501
502 IF (ALLOCATED(set%TRUSS)) DEALLOCATE (set%TRUSS)
503 ALLOCATE(set%TRUSS(new_size))
504
505 set%TRUSS(1:new_size) = result(1:new_size)
506 set%NB_TRUSS=new_size
507
508 DEALLOCATE(result)
509
510 ELSE ! SET is empty fill it with clause when ADD
511
512 IF ( clause_operator == set_add) THEN
513 IF (ALLOCATED(set%TRUSS)) DEALLOCATE (set%TRUSS)
514 ALLOCATE(set%TRUSS(clause%NB_TRUSS) )
515
516 set%NB_TRUSS=clause%NB_TRUSS
517 set%TRUSS(1:clause%NB_TRUSS) = clause%TRUSS(1:clause%NB_TRUSS)
518
519 ENDIF
520
521 ENDIF
522 ELSE
523 IF ( clause_operator == set_intersect) THEN ! SET Intersection with Empty clause gives Empty SET
524 IF (set%NB_TRUSS > 0)THEN
525 IF(ALLOCATED(set%TRUSS)) DEALLOCATE(set%TRUSS)
526 set%NB_TRUSS=0
527 ENDIF
528 ENDIF
529 ENDIF
530C-----------------------------------------------
531C SPRING
532C-----------------------------------------------
533 IF( clause%NB_SPRING > 0) THEN
534
535 IF( set%NB_SPRING > 0 ) THEN
536
537 ALLOCATE(result(set%NB_SPRING + clause%NB_SPRING )) ! Results SET
538
539 CALL set_merge_simple( set%SPRING, set%NB_SPRING ,
540 * clause%SPRING, clause%NB_SPRING ,
541 * result, new_size ,
542 * clause_operator)
543
544 IF (ALLOCATED(set%SPRING)) DEALLOCATE (set%SPRING)
545 ALLOCATE(set%SPRING(new_size))
546
547 set%SPRING(1:new_size) = result(1:new_size)
548 set%NB_SPRING=new_size
549
550 DEALLOCATE(result)
551
552 ELSE ! SET is empty fill it with clause when ADD
553
554 IF ( clause_operator == set_add) THEN
555 IF (ALLOCATED(set%SPRING)) DEALLOCATE (set%SPRING)
556 ALLOCATE(set%SPRING(clause%NB_SPRING) )
557
558 set%NB_SPRING=clause%NB_SPRING
559 set%SPRING(1:clause%NB_SPRING)=clause%SPRING(1:clause%NB_SPRING)
560
561 ENDIF
562 ENDIF
563 ELSE
564 IF ( clause_operator == set_intersect) THEN ! SET Intersection with Empty clause gives Empty SET
565 IF (set%NB_SPRING > 0)THEN
566 IF(ALLOCATED(set%SPRING)) DEALLOCATE(set%SPRING)
567 set%NB_SPRING=0
568 ENDIF
569 ENDIF
570 ENDIF
571C-----------------------------------------------
572C SURFACES
573C-----------------------------------------------
574
575
576 !------------------------!
577 ! SURFACES -ELLIPSE- !
578 !------------------------!
579 IF ( set%NB_ELLIPSE > 0 ) THEN
580
581 set%ELLIPSE_IAD_BUFR = clause%ELLIPSE_IAD_BUFR
582 set%ELLIPSE_ID_MADYMO = clause%ELLIPSE_ID_MADYMO
583 set%ELLIPSE_N = clause%ELLIPSE_N
584 set%ELLIPSE_XC = clause%ELLIPSE_XC
585 set%ELLIPSE_YC = clause%ELLIPSE_YC
586 set%ELLIPSE_ZC = clause%ELLIPSE_ZC
587 set%ELLIPSE_A = clause%ELLIPSE_A
588 set%ELLIPSE_B = clause%ELLIPSE_B
589 set%ELLIPSE_C = clause%ELLIPSE_C
590 set%EXT_ALL = clause%EXT_ALL
591 CALL my_alloc(set%ELLIPSE_SKEW,9)
592 set%ELLIPSE_SKEW(1:9) = clause%ELLIPSE_SKEW(1:9)
593
594 !------------------------!
595 ! SURFACES -PLANE- !
596 !------------------------!
597 ELSEIF ( set%NB_PLANE > 0 ) THEN
598
599 set%PLANE_IAD_BUFR = clause%PLANE_IAD_BUFR
600 set%PLANE_XM = clause%PLANE_XM
601 set%PLANE_YM = clause%PLANE_YM
602 set%PLANE_ZM = clause%PLANE_ZM
603 set%PLANE_XM1 = clause%PLANE_XM1
604 set%PLANE_YM1 = clause%PLANE_YM1
605 set%PLANE_ZM1 = clause%PLANE_ZM1
606 set%EXT_ALL = clause%EXT_ALL
607 ELSE
608 !------------------------!
609 ! classic SURFACES !
610 !------------------------!
611 empty_condition = (clause%nb_surf_seg==0)
612 IF( clause%NB_SURF_SEG > 0) THEN
613 empty_condition = (set%nb_surf_seg==0)
614 IF( set%NB_SURF_SEG > 0 ) THEN
615
616 !
617 ! Low level CPP routines / One per operator
618 ! The result is held in CPP Structure
619 ! until SET is reallocated and unstacked
620 !
621 IF ( clause_operator == set_add) THEN
622
623 CALL union_surface( set%SURF_NODES(1,1), set%SURF_NODES(1,2),
624 . set%SURF_NODES(1,3), set%SURF_NODES(1,4),
625 . set%SURF_ELTYP, set%SURF_ELEM, set%NB_SURF_SEG,
626 . clause%SURF_NODES(1,1), clause%SURF_NODES(1,2),
627 . clause%SURF_NODES(1,3), clause%SURF_NODES(1,4),
628 . clause%SURF_ELTYP, clause%SURF_ELEM, clause%NB_SURF_SEG,
629 . ns )
630 call surface_type( empty_condition,clause_operator,clause,set )
631
632 ELSEIF ( clause_operator == set_delete) THEN
633
634 CALL delete_surface(set%SURF_NODES(1,1), set%SURF_NODES(1,2),
635 . set%SURF_NODES(1,3), set%SURF_NODES(1,4),
636 . set%SURF_ELTYP, set%SURF_ELEM, set%NB_SURF_SEG,
637 . clause%SURF_NODES(1,1), clause%SURF_NODES(1,2),
638 . clause%SURF_NODES(1,3), clause%SURF_NODES(1,4),
639 . clause%SURF_ELTYP, clause%SURF_ELEM, clause%NB_SURF_SEG,
640 . ns )
641 call surface_type( empty_condition,clause_operator,clause,set )
642
643 ELSEIF ( clause_operator == set_intersect)THEN
644
645 CALL intersect_surface( set%SURF_NODES(1,1), set%SURF_NODES(1,2),
646 . set%SURF_NODES(1,3), set%SURF_NODES(1,4),
647 . set%SURF_ELTYP, set%SURF_ELEM, set%NB_SURF_SEG,
648 . clause%SURF_NODES(1,1), clause%SURF_NODES(1,2),
649 . clause%SURF_NODES(1,3), clause%SURF_NODES(1,4),
650 . clause%SURF_ELTYP, clause%SURF_ELEM, clause%NB_SURF_SEG,
651 . ns )
652 call surface_type( empty_condition,clause_operator,clause,set )
653 ELSE
654 print*,'Unknown clause operator'
655 ENDIF
656
657 DEALLOCATE(set%SURF_NODES)
658 DEALLOCATE(set%SURF_ELTYP)
659 DEALLOCATE(set%SURF_ELEM)
660
661 CALL my_alloc(set%SURF_NODES,ns,4)
662 CALL my_alloc (set%SURF_ELTYP,ns)
663 CALL my_alloc (set%SURF_ELEM,ns)
664
665 set%NB_SURF_SEG = ns
666
667 CALL get_merged_surface(set%SURF_NODES(1,1),
668 . set%SURF_NODES(1,2),
669 . set%SURF_NODES(1,3),
670 . set%SURF_NODES(1,4),
671 . set%SURF_ELTYP,
672 . set%SURF_ELEM)
673
674 ELSE ! SET WAS EMPTY FILL it with Clause if SET_ADD operator
675
676 IF ( clause_operator == set_add) THEN
677 IF (ALLOCATED (set%SURF_NODES) ) DEALLOCATE(set%SURF_NODES)
678 IF (ALLOCATED (set%SURF_ELTYP) ) DEALLOCATE(set%SURF_ELTYP)
679 IF (ALLOCATED (set%SURF_ELEM) ) DEALLOCATE(set%SURF_ELEM)
680
681 new_size = clause%NB_SURF_SEG
682 CALL my_alloc(set%SURF_NODES,new_size,4)
683 CALL my_alloc (set%SURF_ELTYP,new_size)
684 CALL my_alloc (set%SURF_ELEM,new_size)
685
686 set%NB_SURF_SEG = new_size
687 set%SURF_NODES(1:new_size,1:4) = clause%SURF_NODES(1:new_size,1:4)
688 set%SURF_ELTYP(1:new_size) = clause%SURF_ELTYP(1:new_size)
689 set%SURF_ELEM(1:new_size) = clause%SURF_ELEM(1:new_size)
690 call surface_type( empty_condition,clause_operator,clause,set )
691 ENDIF
692 ENDIF
693 ELSE
694 IF ( clause_operator == set_intersect) THEN ! SET : Intersection with Empty clause gives Empty SET
695 IF (set%NB_SURF_SEG > 0)THEN
696 IF(ALLOCATED(set%SURF_NODES)) DEALLOCATE(set%SURF_NODES)
697 IF(ALLOCATED(set%SURF_ELTYP)) DEALLOCATE(set%SURF_ELTYP)
698 IF(ALLOCATED(set%SURF_ELEM)) DEALLOCATE(set%SURF_ELEM)
699 set%NB_SURF_SEG=0
700 call surface_type( empty_condition,clause_operator,clause,set )
701 ENDIF
702 ENDIF
703 ENDIF
704 ENDIF ! IF ( SET%NB_ELLIPSE > 0 )
705C-----------------------------------------------
706C LINES
707C-----------------------------------------------
708 IF( clause%NB_LINE_SEG > 0) THEN
709
710 IF( set%NB_LINE_SEG > 0 ) THEN
711
712 !
713 ! Low level CPP routines / One per operator
714 ! The result is held in CPP Structure
715 ! until SET is reallocated and unstacked
716 !
717 IF ( clause_operator == set_add) THEN
718
719 CALL union_line( set%LINE_NODES(1,1), set%LINE_NODES(1,2),
720 . set%LINE_ELTYP, set%LINE_ELEM, set%NB_LINE_SEG,
721 . clause%LINE_NODES(1,1), clause%LINE_NODES(1,2),
722 . clause%LINE_ELTYP, clause%LINE_ELEM, clause%NB_LINE_SEG,
723 . new_size )
724
725 ELSEIF ( clause_operator == set_delete) THEN
726
727 CALL delete_line ( set%LINE_NODES(1,1), set%LINE_NODES(1,2),
728 . set%LINE_ELTYP, set%LINE_ELEM, set%NB_LINE_SEG,
729 . clause%LINE_NODES(1,1), clause%LINE_NODES(1,2),
730 . clause%LINE_ELTYP, clause%LINE_ELEM, clause%NB_LINE_SEG,
731 . new_size )
732
733 ELSEIF ( clause_operator == set_intersect)THEN
734
735 CALL intersect_line ( set%LINE_NODES(1,1), set%LINE_NODES(1,2),
736 . set%LINE_ELTYP, set%LINE_ELEM, set%NB_LINE_SEG,
737 . clause%LINE_NODES(1,1), clause%LINE_NODES(1,2),
738 . clause%LINE_ELTYP, clause%LINE_ELEM, clause%NB_LINE_SEG,
739 . new_size )
740 ELSE
741 print*,'Unknown clause operator'
742 ENDIF
743
744 DEALLOCATE(set%LINE_NODES)
745 DEALLOCATE(set%LINE_ELTYP)
746 DEALLOCATE(set%LINE_ELEM)
747
748 CALL my_alloc(set%LINE_NODES,new_size,4)
749 CALL my_alloc (set%LINE_ELTYP,new_size)
750 CALL my_alloc (set%LINE_ELEM,new_size)
751
752 set%NB_LINE_SEG = new_size
753
754 CALL get_merged_lines (set%LINE_NODES(1,1),
755 . set%LINE_NODES(1,2),
756 . set%LINE_ELTYP,
757 . set%LINE_ELEM)
758
759 ELSE ! SET WAS EMPTY FILL it with Clause if SET_ADD operator
760
761 IF ( clause_operator == set_add) THEN
762 IF (ALLOCATED (set%LINE_NODES) ) DEALLOCATE(set%LINE_NODES)
763 IF (ALLOCATED (set%LINE_ELTYP) ) DEALLOCATE(set%LINE_ELTYP)
764 IF (ALLOCATED (set%LINE_ELEM) ) DEALLOCATE(set%LINE_ELEM)
765
766 new_size = clause%NB_LINE_SEG
767 CALL my_alloc(set%LINE_NODES,new_size,2)
768 CALL my_alloc (set%LINE_ELTYP,new_size)
769 CALL my_alloc (set%LINE_ELEM,new_size)
770
771 set%NB_LINE_SEG = new_size
772 set%LINE_NODES(1:new_size,1:2) = clause%LINE_NODES(1:new_size,1:2)
773 set%LINE_ELTYP(1:new_size) = clause%LINE_ELTYP(1:new_size)
774 set%LINE_ELEM(1:new_size) = clause%LINE_ELEM(1:new_size)
775
776 ENDIF
777 ENDIF
778 ELSE
779 IF ( clause_operator == set_intersect) THEN ! SET : Intersection with Empty clause gives Empty SET
780 IF (set%NB_LINE_SEG > 0)THEN
781 IF(ALLOCATED(set%LINE_NODES)) DEALLOCATE(set%LINE_NODES)
782 IF(ALLOCATED(set%LINE_ELTYP)) DEALLOCATE(set%LINE_ELTYP)
783 IF(ALLOCATED(set%LINE_ELEM)) DEALLOCATE(set%LINE_ELEM)
784 set%NB_LINE_SEG=0
785 ENDIF
786 ENDIF
787 ENDIF
788
789 ! -----------------------------------------------
790 ! IN CASE OF DELETE redo NODES_FROM_ELEM
791 ! SURFACE_FROM_ELEMENT
792 ! LINE_FROM_SURFACE
793 ! -----------------------------------------------
794 IF(clause_operator == set_delete)THEN
795
796 !---
797 ! Nodes reconstruction after delete
798 !---
799
800! ALLOCATE(NODES(NUMNOD))
801! ALLOCATE(RESULT(NUMNOD )) ! Results SET
802
803! CALL CREATE_NODE_FROM_ELEMENT(
804! . IXS ,IXS10 ,IXS20 ,IXS16 ,IXQ ,
805! . IXC ,IXTG ,IXT ,IXP ,IXR ,
806! . IXX ,KXX ,KXSP ,SET ,GEO ,
807! . NODES ,ND_SIZE,.TRUE. )
808! OPERATOR = SET_ADD
809! CALL SET_MERGE_SIMPLE( SET%NODE, SET%NB_NODE ,
810! . NODES, ND_SIZE ,
811! . RESULT, NEW_SIZE ,
812! . OPERATOR)
813
814
815! IF (ALLOCATED(SET%NODE)) DEALLOCATE (SET%NODE)
816! ALLOCATE(SET%NODE(NEW_SIZE))
817
818! SET%NODE(1:NEW_SIZE) = RESULT(1:NEW_SIZE)
819! SET%NB_NODE=NEW_SIZE
820
821! DEALLOCATE(RESULT)
822! DEALLOCATE(NODES)
823
824
825 !---
826 ! Surfs reconstruction after delete
827 !---
828
829
830 CALL create_surface_from_element(
831 . ixs ,ixs10 ,sh4tree ,sh3tree ,ixc ,
832 . ixtg ,knod2els ,nod2els ,knod2elc ,nod2elc ,
833 . knod2eltg ,nod2eltg ,ipartc ,ipartg ,iparts ,
834 . ipart ,set ,opt_a ,opt_o ,ixq ,
835 . knod2elq ,nod2elq ,x ,keyset ,delbuf ,
836 . .true. ,ipartq)
837
838 !--- void calling UNION_SURFACE with non allocated arrays
839 IF(.NOT. ALLOCATED(set%SURF_NODES))ALLOCATE(set%SURF_NODES(1,4))
840 IF(.NOT. ALLOCATED(set%SURF_ELTYP))ALLOCATE(set%SURF_ELTYP(1))
841 IF(.NOT. ALLOCATED(set%SURF_ELEM)) ALLOCATE(set%SURF_ELEM(1))
842 IF(.NOT. ALLOCATED(delbuf%SURF)) ALLOCATE(delbuf%SURF(1,6))
843
844 CALL union_surface(set%SURF_NODES(1,1), set%SURF_NODES(1,2),
845 . set%SURF_NODES(1,3), set%SURF_NODES(1,4),
846 . set%SURF_ELTYP, set%SURF_ELEM, set%NB_SURF_SEG,
847 . delbuf%SURF(1,1), delbuf%SURF(1,2),
848 . delbuf%SURF(1,3), delbuf%SURF(1,4),
849 . delbuf%SURF(1,5), delbuf%SURF(1,6), delbuf%SZ_SURF,
850 . ns )
851
852 IF(ALLOCATED(set%SURF_NODES))DEALLOCATE(set%SURF_NODES)
853 IF(ALLOCATED(set%SURF_ELTYP))DEALLOCATE(set%SURF_ELTYP)
854 IF(ALLOCATED(set%SURF_ELEM)) DEALLOCATE(set%SURF_ELEM)
855 IF(ALLOCATED(delbuf%SURF)) DEALLOCATE(delbuf%SURF)
856
857 CALL my_alloc(set%SURF_NODES,ns,4)
858 CALL my_alloc(set%SURF_ELTYP,ns)
859 CALL my_alloc(set%SURF_ELEM,ns)
860
861 set%NB_SURF_SEG = ns
862
863 CALL get_merged_surface(set%SURF_NODES(1,1),
864 . set%SURF_NODES(1,2),
865 . set%SURF_NODES(1,3),
866 . set%SURF_NODES(1,4),
867 . set%SURF_ELTYP,
868 . set%SURF_ELEM)
869
870 delbuf%SZ_SURF = 0
871 !---
872 ! Lines reconstruction after delete
873 !---
874
875 ! Line from 1D_ELEMENT
876 !-------------------
877 CALL create_line_from_element(ixt ,ixp ,ixr ,set ,delbuf ,
878 . .true. )
879 IF(.NOT. ALLOCATED(set%LINE_NODES))ALLOCATE(set%LINE_NODES(1,2))
880 IF(.NOT. ALLOCATED(set%LINE_ELTYP))ALLOCATE(set%LINE_ELTYP(1))
881 IF(.NOT. ALLOCATED(set%LINE_ELEM)) ALLOCATE(set%LINE_ELEM(1))
882 IF(.NOT. ALLOCATED(delbuf%LINE)) ALLOCATE(delbuf%LINE(1,4))
883
884 CALL union_line(set%LINE_NODES(1,1), set%LINE_NODES(1,2),
885 . set%LINE_ELTYP, set%LINE_ELEM, set%NB_LINE_SEG,
886 . delbuf%LINE(1,1), delbuf%LINE(1,2),
887 . delbuf%LINE(1,3), delbuf%LINE(1,4), delbuf%SZ_LINE,
888 . new_size )
889
890 IF(ALLOCATED(set%LINE_NODES))DEALLOCATE(set%LINE_NODES)
891 IF(ALLOCATED(set%LINE_ELTYP))DEALLOCATE(set%LINE_ELTYP)
892 IF(ALLOCATED(set%LINE_ELEM)) DEALLOCATE(set%LINE_ELEM)
893 IF(ALLOCATED(delbuf%LINE)) DEALLOCATE(delbuf%LINE)
894
895 CALL my_alloc(set%LINE_NODES,new_size,4)
896 CALL my_alloc (set%LINE_ELTYP,new_size)
897 CALL my_alloc (set%LINE_ELEM,new_size)
898
899 set%NB_LINE_SEG = new_size
900
901 CALL get_merged_lines (set%LINE_NODES(1,1),
902 . set%LINE_NODES(1,2),
903 . set%LINE_ELTYP,
904 . set%LINE_ELEM)
905
906 delbuf%SZ_LINE = 0
907
908
909 ! Line from SURFACE
910 CALL create_line_from_surface(set ,keyset,opt_a,opt_e,delbuf ,
911 . .true.)
912
913 IF(.NOT. ALLOCATED(set%LINE_NODES))ALLOCATE(set%LINE_NODES(1,2))
914 IF(.NOT. ALLOCATED(set%LINE_ELTYP))ALLOCATE(set%LINE_ELTYP(1))
915 IF(.NOT. ALLOCATED(set%LINE_ELEM)) ALLOCATE(set%LINE_ELEM(1))
916 IF(.NOT. ALLOCATED(delbuf%LINE)) ALLOCATE(delbuf%LINE(1,4))
917
918
919 CALL union_line(set%LINE_NODES(1,1), set%LINE_NODES(1,2),
920 . set%LINE_ELTYP, set%LINE_ELEM, set%NB_LINE_SEG,
921 . delbuf%LINE(1,1), delbuf%LINE(1,2),
922 . delbuf%LINE(1,3), delbuf%LINE(1,4), delbuf%SZ_LINE,
923 . new_size )
924
925 IF(ALLOCATED(set%LINE_NODES))DEALLOCATE(set%LINE_NODES)
926 IF(ALLOCATED(set%LINE_ELTYP))DEALLOCATE(set%LINE_ELTYP)
927 IF(ALLOCATED(set%LINE_ELEM)) DEALLOCATE(set%LINE_ELEM)
928 IF(ALLOCATED(delbuf%LINE)) DEALLOCATE(delbuf%LINE)
929
930 CALL my_alloc(set%LINE_NODES,new_size,4)
931 CALL my_alloc (set%LINE_ELTYP,new_size)
932 CALL my_alloc (set%LINE_ELEM,new_size)
933
934 set%NB_LINE_SEG = new_size
935
936 CALL get_merged_lines (set%LINE_NODES(1,1),
937 . set%LINE_NODES(1,2),
938 . set%LINE_ELTYP,
939 . set%LINE_ELEM)
940
941 delbuf%SZ_LINE = 0
942
943 ENDIF ! IF(CLAUSE_OPERATOR == SET_DELETE)
944
945
946 END
947
948
949
950
951
952
my_real
#define my_real
Definition cppsort.cpp:32
create_line_from_element
subroutine create_line_from_element(ixt, ixp, ixr, clause, delbuf, go_in_array)
Definition create_line_from_element.F:36
create_line_from_surface
subroutine create_line_from_surface(clause, keyset, opt_a, opt_e, delbuf, go_in_array)
Definition create_line_from_surface.F:35
create_surface_from_element
subroutine create_surface_from_element(ixs, ixs10, sh4tree, sh3tree, ixc, ixtg, knod2els, nod2els, knod2elc, nod2elc, knod2eltg, nod2eltg, ipartc, ipartg, iparts, ipart, clause, opt_a, opt_o, ixq, knod2elq, nod2elq, x, keyset, delbuf, go_in_array, ipartq)
Definition create_surface_from_element.F:42
insert_clause_in_set
subroutine insert_clause_in_set(set, clause, clause_operator, ixs, ixs10, ixq, ixc, ixtg, ixt, ixp, ixr, sh4tree, sh3tree, knod2els, nod2els, knod2elc, nod2elc, knod2eltg, nod2eltg, ipartc, ipartg, iparts, ipart, opt_a, opt_o, knod2elq, nod2elq, x, keyset, opt_e, delbuf, ipartq)
Definition insert_clause_in_set.F:50
hm_option_read_mod
Definition hm_option_read_mod.F:412
message_mod
Definition message_mod.F:1257
names_and_titles_mod
Definition names_and_titles_mod.F:1002
names_and_titles_mod::ncharfield
integer, parameter ncharfield
Definition names_and_titles_mod.F:1010
set_mod
Definition set_mod.F:43
set_mod::set_add
integer, parameter set_add
add operator
Definition set_mod.F:47
set_mod::set_intersect
integer, parameter set_intersect
intersection operator
Definition set_mod.F:49
set_mod::set_delete
integer, parameter set_delete
delete operator
Definition set_mod.F:48
set_scratch_mod
Definition setdef_mod.F:247
setdef_mod
Definition setdef_mod.F:107
set_merge_simple
subroutine set_merge_simple(set_entity, nb_set_entity, clause_entity, nb_clause_entity, result, nb_result, clause_operator)
Definition set_merge_simple.F:42
starter
program starter
Definition starter.F:39