OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
solid_surface_buffer.F File Reference
#include "implicit_f.inc"
#include "com04_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine solid_surface_buffer (ixs, ixs10, ixc, ixtg, clause, knod2els, nod2els, knod2elc, nod2elc, knod2eltg, nod2eltg, nseg, iext, buftmpsurf, iparts, iad_surf, keyset)
subroutine surf_segment (n1, n2, n3, n4, elem, buftmpsurf, iad_surf, eltyp)

Function/Subroutine Documentation

◆ solid_surface_buffer()

subroutine solid_surface_buffer ( integer, dimension(nixs,*) ixs,
integer, dimension(6,*) ixs10,
integer, dimension(nixc,*) ixc,
integer, dimension(nixtg,*) ixtg,
type (set_) clause,
integer, dimension(*) knod2els,
integer, dimension(*) nod2els,
integer, dimension(*) knod2elc,
integer, dimension(*) nod2elc,
integer, dimension(*) knod2eltg,
integer, dimension(*) nod2eltg,
integer nseg,
integer iext,
integer, dimension(*) buftmpsurf,
integer, dimension(*) iparts,
integer iad_surf,
character(len=ncharfield) keyset )

Definition at line 31 of file solid_surface_buffer.F.

36C-----------------------------------------------
37C M o d u l e s
38C-----------------------------------------------
39 USE my_alloc_mod
40 USE setdef_mod
41 USE names_and_titles_mod , ONLY : ncharfield
42C-----------------------------------------------
43C I m p l i c i t T y p e s
44C-----------------------------------------------
45#include "implicit_f.inc"
46#include "com04_c.inc"
47C-----------------------------------------------
48C D u m m y A r g u m e n t s
49C-----------------------------------------------
50 INTEGER IEXT,NSEG,IAD_SURF
51 INTEGER IXS(NIXS,*),IXS10(6,*),IXC(NIXC,*),IXTG(NIXTG,*),
52 . KNOD2ELS(*),NOD2ELS(*),KNOD2ELC(*),NOD2ELC(*),
53 . KNOD2ELTG(*),NOD2ELTG(*),BUFTMPSURF(*),IPARTS(*)
54 CHARACTER(LEN=NCHARFIELD) :: KEYSET
55!
56 TYPE (SET_) :: CLAUSE
57C-----------------------------------------------
58C L o c a l V a r i a b l e s
59C-----------------------------------------------
60 INTEGER N,J,K,JS,KS,II,JJ,K1,K2,LL,FACE(4),FC10(3),NN,KK,I1,
61 . NI(4),NS(4),MI(4),MS(4),NMIN,MMIN,NF,MF,IPERM,N1,N2,I
62 INTEGER FACES(4,6),PWR(7),
63 . FACES10(3,6),NNS,ISHEL,ISEG,NB_SOLID,IND
64 INTEGER, DIMENSION(:), ALLOCATABLE:: SOLID_TAG,PART_TAG
65 INTEGER, DIMENSION(:), ALLOCATABLE :: NODTAG
66 INTEGER, DIMENSION(:), ALLOCATABLE :: FASTAG
67
68!
69 DATA faces/4,3,2,1,
70 . 5,6,7,8,
71 . 1,2,6,5,
72 . 3,4,8,7,
73 . 2,3,7,6,
74 . 1,5,8,4/
75 DATA faces10/0,0,0,
76 . 0,0,0,
77 . 3,6,4,
78 . 5,6,2,
79 . 1,2,3,
80 . 4,5,1/
81 DATA pwr/1,2,4,8,16,32,64/
82C=======================================================================
83 CALL my_alloc(solid_tag,numels)
84 CALL my_alloc(part_tag,npart)
85 CALL my_alloc(nodtag,numnod)
86 CALL my_alloc(fastag,numels)
87
88 solid_tag(1:numels)=0
89 part_tag(1:npart)=0
90
91 DO i=1, clause%NB_PART
92 part_tag(clause%PART(i))=1
93 ENDDO
94
95 DO i=1, clause%NB_SOLID
96 solid_tag(clause%SOLID(i))=1
97 ENDDO
98
99 fastag=0
100C
101 IF (iext == 1) THEN
102C
103 nb_solid = clause%NB_SOLID
104 DO ind=1,nb_solid
105 js = clause%SOLID(ind)
106 IF (solid_tag(js)==0) cycle !case of tagged elems
107 DO jj=1,6
108 DO ii=1,4
109 ns(ii)=ixs(faces(ii,jj)+1,js)
110 END DO
111C
112C keep only 1 occurrence of each node (triangles, degenerated cases...)
113C
114 DO k1=1,3
115 DO k2=k1+1,4
116 IF(ns(k2)==ns(k1))ns(k2)=0
117 END DO
118 END DO
119 nf=0
120 DO k1=1,4
121 n1=ns(k1)
122 IF(n1/=0)THEN
123 nf=nf+1
124 ns(nf)=n1
125 END IF
126 END DO
127 IF (nf < 3)cycle
128C
129C permute
130C
131 nmin=ns(1)
132 DO ii=2,nf
133 nmin=min(nmin,ns(ii))
134 END DO
135 DO iperm=1,nf
136 IF(nmin==ns(iperm).AND.
137 . ns(mod(iperm,nf)+1)/=ns(iperm))THEN
138 DO ii=1,nf
139 ni(ii)=ns(mod(ii+iperm-2,nf)+1)
140 END DO
141 EXIT
142 END IF
143 END DO
144C
145C looks for an elt sharing the face.
146C
147 DO k=knod2els(ni(1))+1,knod2els(ni(1)+1)
148 ks=nod2els(k)
149 IF (ks==js .OR. ks > numels8+numels10) cycle
150 IF (keyset == 'SOLID' .AND. solid_tag(ks)==0) cycle
151 IF (keyset == 'PART' .AND. part_tag(iparts(ks))==0) cycle
152!
153 DO ii=1,nf
154 nodtag(ni(ii))=0
155 END DO
156 DO ii=1,8
157 nodtag(ixs(ii+1,ks))=1
158 END DO
159 nn=0
160 DO ii=1,nf
161 nn=nn+nodtag(ni(ii))
162 END DO
163 IF(nn==nf)THEN
164 DO kk=1,6
165 DO ii=1,4
166 ms(ii)=ixs(faces(ii,kk)+1,ks)
167 END DO
168C
169C keep only 1 occurrence of each node (triangles, degenerated cases...)
170C
171 DO k1=1,3
172 DO k2=k1+1,4
173 IF(ms(k2)==ms(k1))ms(k2)=0
174 END DO
175 END DO
176 mf=0
177 DO k1=1,4
178 n1=ms(k1)
179 IF(n1/=0)THEN
180 mf=mf+1
181 ms(mf)=n1
182 END IF
183 END DO
184 IF(mf /= nf)cycle
185C
186C permute
187C
188 mmin=ms(1)
189 DO ii=2,mf
190 mmin=min(mmin,ms(ii))
191 END DO
192 DO iperm=1,mf
193 IF(mmin==ms(iperm).AND.
194 . ms(mod(iperm,mf)+1)/=ms(iperm))THEN
195 DO ii=1,mf
196 mi(ii)=ms(mod(ii+iperm-2,mf)+1)
197 END DO
198 EXIT
199 END IF
200 END DO
201 IF(mi(1)==ni(1).AND.mi(nf)==ni(2))THEN
202C FACTAG(JS) moins face jj
203 fastag(js)=fastag(js)+pwr(jj)
204 GO TO 300
205 END IF
206 END DO
207 END IF
208 END DO
209 300 CONTINUE
210 END DO
211 END DO ! DO IND=1,NB_SOLID
212 END IF ! IF(IEXT==1)THEN
213C-----------
214
215
216
217!-------
218! HEXA8
219!-------
220
221
222
223 nb_solid = clause%NB_SOLID
224 DO ind=1,nb_solid
225 js = clause%SOLID(ind)
226 IF (solid_tag(js)==0) cycle
227!
228 IF (js > numels8) cycle ! HEXA8 ONLY
229!
230 ll=fastag(js)
231 DO jj=1,6
232 IF(mod(ll,pwr(jj+1))/pwr(jj)/=0)cycle
233C
234C still needs to filter degenerated faces
235 DO k1=1,4
236 i1 =faces(k1,jj)+1
237 face(k1)=ixs(i1,js)
238 END DO
239 DO k1=1,4
240 n1=face(k1)
241 DO k2=1,4
242 IF(k2/=k1)THEN
243 n2=face(k2)
244 IF(n2==n1)face(k2)=0
245 END IF
246 END DO
247 END DO
248 nn=0
249 DO k1=1,4
250 n1=face(k1)
251 IF(n1/=0)THEN
252 nn=nn+1
253 face(nn)=n1
254 END IF
255 END DO
256C--- find shells SURF/PART/EXT
257 IF(nn==3)THEN
258 ks = 0
259 ishel = 0
260 DO k=knod2eltg(face(1))+1,knod2eltg(face(1)+1)
261 ks=nod2eltg(k)
262 ishel = 0
263 DO i=1,3
264 DO j=1,3
265 IF(face(i) == ixtg(j+1,ks)) ishel = ishel + 1
266 ENDDO
267 ENDDO
268 IF (ishel == 3)EXIT
269 ks = 0
270 ENDDO
271 !print*,'Surf from solid ...',KS,PART_TAG(IPARTG(KS))
272 IF(ks == 0 .OR. ishel == 3)THEN
273 nseg = nseg + 1
274 CALL surf_segment(face(1) ,face(2) ,face(3) ,face(3) ,js ,
275 . buftmpsurf ,iad_surf ,1)
276 ENDIF
277 ELSEIF(nn==4)THEN
278 ks = 0
279 ishel = 0
280 DO k=knod2elc(face(1))+1,knod2elc(face(1)+1)
281 ks=nod2elc(k)
282 ishel = 0
283 DO i=1,4
284 DO j=1,4
285 IF(face(i) == ixc(j+1,ks)) ishel = ishel + 1
286 ENDDO
287 ENDDO
288 IF (ishel == 4)EXIT
289 ks = 0
290 ENDDO
291 IF(ks == 0 .OR. ishel == 4)THEN
292 nseg = nseg + 1
293 CALL surf_segment(face(1) ,face(2) ,face(3) ,face(4) ,js ,
294 . buftmpsurf ,iad_surf ,1)
295 ENDIF
296 END IF
297C---
298 END DO ! DO JJ=1,6
299 END DO ! DO IND=1,NB_SOLID
300
301
302
303
304!-------
305! TETRA10
306!-------
307
308
309
310 nb_solid = clause%NB_SOLID
311 DO ind=1,nb_solid
312 js = clause%SOLID(ind)
313 IF (solid_tag(js)==0) cycle
314!
315 j = js - numels8 ! TETRA10 ONLY
316 IF (j <= 0) cycle ! TETRA10 ONLY
317!
318 ll=fastag(js)
319 DO jj=3,6
320 IF(mod(ll,pwr(jj+1))/pwr(jj) /= 0)cycle
321C
322C still needs to filter degenerated faces
323C
324 DO k1=1,4
325 face(k1)=ixs(faces(k1,jj)+1,js)
326 END DO
327 DO k1=1,3
328 DO k2=k1+1,4
329 IF(face(k2) == face(k1)) face(k2)=0
330 END DO
331 END DO
332 nn=0
333 DO k1=1,4
334 IF(face(k1) /= 0)THEN
335 nn=nn+1
336 face(nn)=face(k1)
337 END IF
338 END DO
339C---
340 IF(nn == 3)THEN
341 nns=1
342 fc10(1)=ixs10(faces10(1,jj),j)
343 fc10(2)=ixs10(faces10(2,jj),j)
344 fc10(3)=ixs10(faces10(3,jj),j)
345 IF(fc10(1) /= 0)nns=nns+1
346 IF(fc10(2) /= 0)nns=nns+1
347 IF(fc10(3) /= 0)nns=nns+1
348 IF(nns == 3)nns=2
349 nseg=nseg+nns
350 IF (nns == 4) THEN
351c 4 triangles
352 CALL surf_segment(face(1) ,fc10(1) ,fc10(3) ,fc10(3) ,js ,
353 . buftmpsurf ,iad_surf ,1)
354 CALL surf_segment(face(2) ,fc10(2) ,fc10(1) ,fc10(1) ,js ,
355 . buftmpsurf ,iad_surf ,1)
356 CALL surf_segment(face(3) ,fc10(3) ,fc10(2) ,fc10(2) ,js ,
357 . buftmpsurf ,iad_surf ,1)
358 CALL surf_segment(fc10(1) ,fc10(2) ,fc10(3) ,fc10(3) ,js ,
359 . buftmpsurf ,iad_surf ,1)
360 ELSEIF (nns == 3) THEN
361c 1 quadrangle, 1 triangle
362 IF(fc10(1) == 0)THEN
363 CALL surf_segment(face(1) ,face(2) ,fc10(2) ,fc10(3) ,js ,
364 . buftmpsurf ,iad_surf ,1)
365 CALL surf_segment(face(3) ,fc10(3) ,fc10(2) ,fc10(2) ,js ,
366 . buftmpsurf ,iad_surf ,1)
367 ELSEIF(fc10(2) == 0)THEN
368 CALL surf_segment(face(2) ,face(3) ,fc10(3) ,fc10(1) ,js ,
369 . buftmpsurf ,iad_surf ,1)
370 CALL surf_segment(face(1) ,fc10(1) ,fc10(3) ,fc10(3) ,js ,
371 . buftmpsurf ,iad_surf ,1)
372 ELSEIF(fc10(3) == 0)THEN
373 CALL surf_segment(face(3) ,face(1) ,fc10(1) ,fc10(2) ,js ,
374 . buftmpsurf ,iad_surf ,1)
375 CALL surf_segment(face(2) ,fc10(2) ,fc10(1) ,fc10(1) ,js ,
376 . buftmpsurf ,iad_surf ,1)
377 ENDIF
378 ELSEIF (nns == 2) THEN
379c 2 triangles
380 IF(fc10(1) /= 0)THEN
381 CALL surf_segment(face(3) ,face(1) ,fc10(1) ,fc10(1) ,js ,
382 . buftmpsurf ,iad_surf ,1)
383 CALL surf_segment(face(2) ,face(3) ,fc10(1) ,fc10(1) ,js ,
384 . buftmpsurf ,iad_surf ,1)
385 ELSEIF(fc10(2) /= 0)THEN
386 CALL surf_segment(face(1) ,face(2) ,fc10(2) ,fc10(2) ,js ,
387 . buftmpsurf ,iad_surf ,1)
388 CALL surf_segment(face(3) ,face(1) ,fc10(2) ,fc10(2) ,js ,
389 . buftmpsurf ,iad_surf ,1)
390 ELSEIF(fc10(3) /= 0)THEN
391 CALL surf_segment(face(2) ,face(3) ,fc10(3) ,fc10(3) ,js ,
392 . buftmpsurf ,iad_surf ,1)
393 CALL surf_segment(face(1) ,face(2) ,fc10(3) ,fc10(3) ,js ,
394 . buftmpsurf ,iad_surf ,1)
395 ENDIF
396 ELSEIF (nns == 1) THEN
397c 1 triangle
398 CALL surf_segment(face(1) ,face(2) ,face(3) ,face(3) ,js ,
399 . buftmpsurf ,iad_surf ,1)
400 END IF
401 END IF
402C---
403 END DO ! DO JJ=3,6
404 END DO ! DO IND=1,NB_SOLID
405C-----------
406 DEALLOCATE(nodtag)
407 DEALLOCATE(fastag)
408 RETURN
min
#define min(a, b)
Definition macros.h:20
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
setdef_mod
Definition setdef_mod.F:107
surf_segment
subroutine surf_segment(n1, n2, n3, n4, elem, buftmpsurf, iad_surf, eltyp)
Definition solid_surface_buffer.F:418

◆ surf_segment()

subroutine surf_segment ( integer n1,
integer n2,
integer n3,
integer n4,
integer elem,
integer, dimension(*) buftmpsurf,
integer iad_surf,
integer eltyp )

Definition at line 416 of file solid_surface_buffer.F.

418C-----------------------------------------------
419C I m p l i c i t T y p e s
420C-----------------------------------------------
421#include "implicit_f.inc"
422C-----------------------------------------------
423C D u m m y A r g u m e n t s
424C-----------------------------------------------
425 INTEGER N1,N2,N3,N4,ELEM,BUFTMPSURF(*),IAD_SURF,ELTYP
426C-----------------------------------------------
427!---
428! seg to add
429 buftmpsurf(iad_surf) = n1
430 iad_surf=iad_surf+1
431 buftmpsurf(iad_surf) = n2
432 iad_surf=iad_surf+1
433 buftmpsurf(iad_surf) = n3
434 iad_surf=iad_surf+1
435 buftmpsurf(iad_surf) = n4
436 iad_surf=iad_surf+1
437 buftmpsurf(iad_surf) = eltyp
438 iad_surf=iad_surf+1
439 buftmpsurf(iad_surf) = elem ! ELEM
440 iad_surf=iad_surf+1
441!---
442 RETURN