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