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

Go to the source code of this file.

Functions/Subroutines

subroutine ssurftag (ixs, iparts, nseg0, igrsurf, tagbuf, nseg, knod2els, nod2els, iext, flag, ixs10, ixs16, ixs20, ifre, key, knod2elc, nod2elc, knod2eltg, nod2eltg, ixc, ixtg, ipartc, iparttg, nindx, nindx_sol, nindx_sol10, indx, indx_sol, indx_sol10, surf_elm)
subroutine ssurf10 (n1, n2, n3, n4, js, nseg0, iseg, surf_nodes, surf_eltyp, surf_elem)
subroutine surfext_tagn (ixs, knod2els, nod2els, ixs10, fastag, itab)

Function/Subroutine Documentation

◆ ssurf10()

subroutine ssurf10 ( integer n1,
integer n2,
integer n3,
integer n4,
integer js,
integer nseg0,
integer iseg,
integer, dimension(nseg0,4) surf_nodes,
integer, dimension(nseg0) surf_eltyp,
integer, dimension(nseg0) surf_elem )

Definition at line 520 of file ssurftag.F.

522C-----------------------------------------------
523C I m p l i c i t T y p e s
524C-----------------------------------------------
525#include "implicit_f.inc"
526C-----------------------------------------------
527C D u m m y A r g u m e n t s
528C-----------------------------------------------
529 INTEGER N1,N2,N3,N4,JS,NSEG0,ISEG
530 INTEGER SURF_NODES(NSEG0,4),SURF_ELTYP(NSEG0),SURF_ELEM(NSEG0)
531C-----------------------------------------------
532!---
533 surf_nodes(iseg,1) = n1
534 surf_nodes(iseg,2) = n2
535 surf_nodes(iseg,3) = n3
536 surf_nodes(iseg,4) = n4
537!
538 surf_eltyp(iseg) = 1
539 surf_elem(iseg) = js
540!---
541 RETURN

◆ ssurftag()

subroutine ssurftag ( integer, dimension(nixs,*) ixs,
integer, dimension(*) iparts,
integer nseg0,
type (surf_) igrsurf,
integer, dimension(*) tagbuf,
integer nseg,
integer, dimension(*) knod2els,
integer, dimension(*) nod2els,
integer iext,
integer flag,
integer, dimension(6,*) ixs10,
integer, dimension(8,*) ixs16,
integer, dimension(12,*) ixs20,
integer ifre,
character(len=ncharkey) key,
integer, dimension(*) knod2elc,
integer, dimension(*) nod2elc,
integer, dimension(*) knod2eltg,
integer, dimension(*) nod2eltg,
integer, dimension(nixc,*) ixc,
integer, dimension(nixtg,*) ixtg,
integer, dimension(*) ipartc,
integer, dimension(*) iparttg,
integer nindx,
integer nindx_sol,
integer nindx_sol10,
integer, dimension(*) indx,
integer, dimension(*) indx_sol,
integer, dimension(*) indx_sol10,
type(part_type), dimension(*) surf_elm )

Definition at line 32 of file ssurftag.F.

39C-----------------------------------------------
40C M o d u l e s
41C-----------------------------------------------
42 USE groupdef_mod
43 USE surf_mod
44 USE names_and_titles_mod , ONLY : ncharkey
45 use element_mod , only : nixs,nixc,nixtg
46C-----------------------------------------------
47C I m p l i c i t T y p e s
48C-----------------------------------------------
49#include "implicit_f.inc"
50#include "com04_c.inc"
51C-----------------------------------------------
52C D u m m y A r g u m e n t s
53C-----------------------------------------------
54 INTEGER IXS(NIXS,*),IPARTS(*),TAGBUF(*),
55 . KNOD2ELS(*),NOD2ELS(*),
56 . IXS10(6,*),IXS16(8,*),IXS20(12,*),
57 . KNOD2ELC(*),NOD2ELC(*),KNOD2ELTG(*),NOD2ELTG(*),
58 . IXC(NIXC,*),IXTG(NIXTG,*),IPARTC(*),IPARTTG(*)
59 INTEGER IEXT,NSEG,FLAG,IFRE,NSEG0
60 CHARACTER(LEN=NCHARKEY) :: KEY
61 INTEGER :: NINDX, NINDX_SOL, NINDX_SOL10
62 INTEGER, DIMENSION(*) :: INDX,INDX_SOL, INDX_SOL10
63 TYPE(PART_TYPE), DIMENSION(*) :: SURF_ELM
64!
65 TYPE (SURF_) :: IGRSURF
66! *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
67! FLAG_GRBRIC : flag to initialize the INDX_SOL(10) arrays
68! and optimize an old and expensive treatment in SSURFTAG
69! = true for /SURF/GCBRIC
70! = false if /SURF/XXX is different from /SURF/GCBRIC
71! ----------------
72! FLAG_GRBRIC = false (/SURF/XXX/ /= /SURF/GCBRIC) :
73! NINDX : number of tagged part
74! INDX : tagged part
75! ----------------
76! FLAG_GRBRIC = true (/SURF/XXX/ = SURF/GCBRIC) :
77! NINDX_SOL(10) : number of the tagged solid(10) element
78! --> need to split solid and solid10
79! for a treatment in the SSURFTAG routine
80! only useful for /SURF/GRBRIC
81! INDX_SOL(10) : ID of the tagged solid(10) element
82! --> need to split solid and solid10
83! for a treatment in the SSURFTAG routine
84! only useful for /SURF/GRBRIC
85! SURF_ELM : PART_TYPE structure
86! %NSOL(10) : number of element per part
87! %SOL(10)_PART : ID of the element
88! ----------------
89! *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
90C-----------------------------------------------
91C L o c a l V a r i a b l e s
92C-----------------------------------------------
93 INTEGER N,J,K,JS,KS,II,JJ,K1,K2,LL,FACE(4),FC10(3),NN,KK,I1,
94 . NI(4),NS(4),MI(4),MS(4),NMIN,MMIN,NF,MF,IPERM,N1,N2,I
95 INTEGER FACES(4,6),PWR(7),
96 . FACES10(3,6),NNS,ISHEL,ISEG
97 INTEGER, DIMENSION(:), ALLOCATABLE :: NODTAG,FASTAG
98! FLAG_PART : check for tagged part
99 LOGICAL :: FLAG_PART
100! NUM_PART : number of tagged part
101! NUM_ELM : number of element in the tagged part
102 INTEGER :: NUM_PART,NUM_ELM
103 INTEGER :: ID_PART,JS_PART, JS_ELM ! index
104 DATA faces/4,3,2,1,
105 . 5,6,7,8,
106 . 1,2,6,5,
107 . 3,4,8,7,
108 . 2,3,7,6,
109 . 1,5,8,4/
110 DATA faces10/0,0,0,
111 . 0,0,0,
112 . 3,6,4,
113 . 5,6,2,
114 . 1,2,3,
115 . 4,5,1/
116 DATA pwr/1,2,4,8,16,32,64/
117C=======================================================================
118 ALLOCATE(nodtag(numnod),fastag(numels))
119
120 fastag=0
121C
122 IF(iext==1)THEN
123C
124C External surface only.
125 DO js=1,numels8+numels10
126 IF(key(1:6)=='GRBRIC')THEN
127 IF (tagbuf(js)==0) cycle !case of tagged elems
128 ELSE
129 IF (tagbuf(iparts(js))==0) cycle !case of tagged parts
130 END IF
131 DO jj=1,6
132 DO ii=1,4
133 ns(ii)=ixs(faces(ii,jj)+1,js)
134 END DO
135C
136C keep only 1 occurrence of each node (triangles, degenerated cases...)
137 DO k1=1,3
138 DO k2=k1+1,4
139 IF(ns(k2)==ns(k1))ns(k2)=0
140 END DO
141 END DO
142 nf=0
143 DO k1=1,4
144 n1=ns(k1)
145 IF(n1/=0)THEN
146 nf=nf+1
147 ns(nf)=n1
148 END IF
149 END DO
150 IF (nf < 3)cycle
151C
152C permute
153 nmin=ns(1)
154 DO ii=2,nf
155 nmin=min(nmin,ns(ii))
156 END DO
157 DO iperm=1,nf
158 IF(nmin==ns(iperm).AND.
159 . ns(mod(iperm,nf)+1)/=ns(iperm))THEN
160 DO ii=1,nf
161 ni(ii)=ns(mod(ii+iperm-2,nf)+1)
162 END DO
163 EXIT
164 END IF
165 END DO
166C
167C looks for an elt sharing the face.
168 DO k=knod2els(ni(1))+1,knod2els(ni(1)+1)
169 ks=nod2els(k)
170 IF(ks==js .OR. ks > numels8+numels10)cycle
171 IF (key(1:6)=='GRBRIC'.AND.tagbuf(ks)==0.AND.ifre==0)cycle ! if IFRE=0 we only look for connectivity with the elements marked by the group (cycle), otherwise if IFRE=1 we look for connectivity with everyone
172 IF (key(1:6)/='GRBRIC'.AND.tagbuf(iparts(ks))==0)cycle
173 DO ii=1,nf
174 nodtag(ni(ii))=0
175 END DO
176 DO ii=1,8
177 nodtag(ixs(ii+1,ks))=1
178 END DO
179 nn=0
180 DO ii=1,nf
181 nn=nn+nodtag(ni(ii))
182 END DO
183 IF(nn==nf)THEN
184 DO kk=1,6
185 DO ii=1,4
186 ms(ii)=ixs(faces(ii,kk)+1,ks)
187 END DO
188C
189C keep only 1 occurrence of each node (triangles, degenerated cases...)
190 DO k1=1,3
191 DO k2=k1+1,4
192 IF(ms(k2)==ms(k1))ms(k2)=0
193 END DO
194 END DO
195 mf=0
196 DO k1=1,4
197 n1=ms(k1)
198 IF(n1/=0)THEN
199 mf=mf+1
200 ms(mf)=n1
201 END IF
202 END DO
203 IF(mf /= nf)cycle
204C
205C permute
206 mmin=ms(1)
207 DO ii=2,mf
208 mmin=min(mmin,ms(ii))
209 END DO
210 DO iperm=1,mf
211 IF(mmin==ms(iperm).AND.
212 . ms(mod(iperm,mf)+1)/=ms(iperm))THEN
213 DO ii=1,mf
214 mi(ii)=ms(mod(ii+iperm-2,mf)+1)
215 END DO
216 EXIT
217 END IF
218 END DO
219 IF(mi(1)==ni(1).AND.mi(nf)==ni(2))THEN
220C Factag (JS) Less Face JJ
221 fastag(js)=fastag(js)+pwr(jj)
222 GO TO 300
223 END IF
224 END DO
225 END IF
226 END DO
227 300 CONTINUE
228 END DO
229 END DO
230 END IF
231C-----------
232 IF(key(1:6)/='GRBRIC') THEN
233 flag_part=.true.
234 num_part = nindx
235 ELSE
236 flag_part=.false.
237 num_part = 1
238 num_elm = nindx_sol
239 ENDIF
240 DO js_part=1,num_part
241 IF(flag_part) THEN
242 id_part = indx(js_part)
243 num_elm = surf_elm(id_part)%NSOL
244 ENDIF
245 DO js_elm=1,num_elm
246 IF(flag_part) THEN
247 js = surf_elm(id_part)%SOL_PART( js_elm )
248 ELSE
249 js = indx_sol( js_elm )
250
251 ENDIF
252
253! DO JS=1,NUMELS8
254! IF ((KEY(1:6)/='GRBRIC'.AND.IABS(TAGBUF(IPARTS(JS))) == 1).OR.
255! . (KEY(1:6)=='GRBRIC'.AND.IABS(TAGBUF(JS)) == 1) ) THEN
256 ll=fastag(js)
257 DO jj=1,6
258 IF(mod(ll,pwr(jj+1))/pwr(jj)/=0)cycle
259C
260C still needs to filter degenerated faces
261 DO k1=1,4
262 i1 =faces(k1,jj)+1
263 face(k1)=ixs(i1,js)
264 END DO
265 DO k1=1,4
266 n1=face(k1)
267 DO k2=1,4
268 IF(k2/=k1)THEN
269 n2=face(k2)
270 IF(n2==n1)face(k2)=0
271 END IF
272 END DO
273 END DO
274 nn=0
275 DO k1=1,4
276 n1=face(k1)
277 IF(n1/=0)THEN
278 nn=nn+1
279 face(nn)=n1
280 END IF
281 END DO
282C--- find shells SURF/PART/EXT
283 IF(flag == 0 .and. nn == 3) THEN
284 ks = 0
285 ishel = 0
286 DO k=knod2eltg(face(1))+1,knod2eltg(face(1)+1)
287 ks=nod2eltg(k)
288 ishel = 0
289 DO i=1,3
290 DO j=1,3
291 IF(face(i) == ixtg(j+1,ks)) ishel = ishel + 1
292 ENDDO
293 ENDDO
294 IF (ishel == 3)EXIT
295 ks = 0
296 ENDDO
297 IF(ks == 0)THEN
298 nseg = nseg + 1
299 ELSEIF (iabs(tagbuf(iparttg(ks))) /= 1) THEN
300 nseg = nseg + 1
301 ENDIF
302 ELSEIF(flag == 0 .and. nn == 4) THEN
303 ks = 0
304 ishel = 0
305 DO k=knod2elc(face(1))+1,knod2elc(face(1)+1)
306 ks=nod2elc(k)
307 ishel = 0
308 DO i=1,4
309 DO j=1,4
310 IF(face(i) == ixc(j+1,ks)) ishel = ishel + 1
311 ENDDO
312 ENDDO
313 IF (ishel == 4)EXIT
314 ks = 0
315 ENDDO
316 IF(ks == 0)THEN
317 nseg = nseg + 1
318 ELSEIF (iabs(tagbuf(ipartc(ks))) /= 1)THEN
319 nseg = nseg + 1
320 ENDIF
321 ELSEIF(nn==3)THEN
322 ks = 0
323 ishel = 0
324 DO k=knod2eltg(face(1))+1,knod2eltg(face(1)+1)
325 ks=nod2eltg(k)
326 ishel = 0
327 DO i=1,3
328 DO j=1,3
329 IF(face(i) == ixtg(j+1,ks)) ishel = ishel + 1
330 ENDDO
331 ENDDO
332 IF (ishel == 3)EXIT
333 ks = 0
334 ENDDO
335 IF(ks == 0)THEN
336 nseg = nseg + 1
337 iseg = nseg
338 CALL ssurf10(face(1),face(2),face(3),face(3),js,
339 . nseg0 ,iseg ,igrsurf%NODES,igrsurf%ELTYP,igrsurf%ELEM)
340 ELSEIF (iabs(tagbuf(iparttg(ks))) /= 1)THEN
341 nseg = nseg + 1
342 iseg = nseg
343 CALL ssurf10(face(1),face(2),face(3),face(3),js,
344 . nseg0 ,iseg ,igrsurf%NODES,igrsurf%ELTYP,igrsurf%ELEM)
345 ENDIF
346 ELSEIF(nn==4)THEN
347 ks = 0
348 ishel = 0
349 DO k=knod2elc(face(1))+1,knod2elc(face(1)+1)
350 ks=nod2elc(k)
351 ishel = 0
352 DO i=1,4
353 DO j=1,4
354 IF(face(i) == ixc(j+1,ks)) ishel = ishel + 1
355 ENDDO
356 ENDDO
357 IF (ishel == 4)EXIT
358 ks = 0
359 ENDDO
360 IF(ks == 0)THEN
361 nseg = nseg + 1
362 iseg = nseg
363 CALL ssurf10(face(1),face(2),face(3),face(4),js,
364 . nseg0 ,iseg ,igrsurf%NODES,igrsurf%ELTYP,igrsurf%ELEM)
365 ELSEIF (iabs(tagbuf(ipartc(ks))) /= 1 ) THEN
366 nseg = nseg + 1
367 iseg = nseg
368 CALL ssurf10(face(1),face(2),face(3),face(4),js,
369 . nseg0 ,iseg ,igrsurf%NODES,igrsurf%ELTYP,igrsurf%ELEM)
370 ENDIF
371 END IF
372C---
373 END DO
374! ENDIF
375 ENDDO ! end of JS_ELM=1,NUM_ELM
376 ENDDO ! end JS_PART=1,NUM_PART
377!
378 IF(key(1:6)/='GRBRIC') THEN
379 flag_part=.true.
380 num_part = nindx
381 ELSE
382 flag_part=.false.
383 num_part = 1
384 num_elm = nindx_sol10
385 ENDIF
386
387 DO js_part=1,num_part
388 IF(flag_part) THEN
389 id_part = indx(js_part)
390 num_elm = surf_elm(id_part)%NSOL10
391 ENDIF
392
393 DO js_elm=1,num_elm
394 IF(flag_part) THEN
395 js = surf_elm(id_part)%SOL10_PART( js_elm )
396 ELSE
397 js = indx_sol10( js_elm )
398 ENDIF
399 j = js - numels8
400
401! DO J=1,NUMELS10
402! JS = J+NUMELS8
403! IF ((KEY(1:6)/='GRBRIC'.AND.IABS(TAGBUF(IPARTS(JS))) == 1).OR.
404! . (KEY(1:6)=='GRBRIC'.AND.IABS(TAGBUF(JS)) == 1) ) THEN
405 ll=fastag(js)
406 DO jj=3,6
407 IF(mod(ll,pwr(jj+1))/pwr(jj) /= 0)cycle
408C
409C still needs to filter degenerated faces
410 DO k1=1,4
411 face(k1)=ixs(faces(k1,jj)+1,js)
412 END DO
413 DO k1=1,3
414 DO k2=k1+1,4
415 IF(face(k2) == face(k1)) face(k2)=0
416 END DO
417 END DO
418 nn=0
419 DO k1=1,4
420 IF(face(k1) /= 0)THEN
421 nn=nn+1
422 face(nn)=face(k1)
423 END IF
424 END DO
425C---
426 IF(nn == 3)THEN
427 nns=1
428 fc10(1)=ixs10(faces10(1,jj),j)
429 fc10(2)=ixs10(faces10(2,jj),j)
430 fc10(3)=ixs10(faces10(3,jj),j)
431 IF(fc10(1) /= 0)nns=nns+1
432 IF(fc10(2) /= 0)nns=nns+1
433 IF(fc10(3) /= 0)nns=nns+1
434 IF(nns == 3)nns=2
435 nseg=nseg+nns
436 IF (flag == 1 .and. nns == 4) THEN
437c 4 triangles
438 iseg = nseg-nns+1
439 CALL ssurf10(face(1),fc10(1),fc10(3),fc10(3),js,
440 . nseg0 ,iseg ,igrsurf%NODES,igrsurf%ELTYP,igrsurf%ELEM)
441 iseg = nseg-nns+2
442 CALL ssurf10(face(2),fc10(2),fc10(1),fc10(1),js,
443 . nseg0 ,iseg ,igrsurf%NODES,igrsurf%ELTYP,igrsurf%ELEM)
444 iseg = nseg-nns+3
445 CALL ssurf10(face(3),fc10(3),fc10(2),fc10(2),js,
446 . nseg0 ,iseg ,igrsurf%NODES,igrsurf%ELTYP,igrsurf%ELEM)
447 iseg = nseg-nns+4
448 CALL ssurf10(fc10(1),fc10(2),fc10(3),fc10(3),js,
449 . nseg0 ,iseg ,igrsurf%NODES,igrsurf%ELTYP,igrsurf%ELEM)
450 ELSEIF (flag == 1 .and. nns == 3) THEN
451c 1 quadrangle, 1 triangle
452 IF(fc10(1) == 0)THEN
453 iseg = nseg-nns+1
454 CALL ssurf10(face(1),face(2),fc10(2),fc10(3),js,
455 . nseg0 ,iseg ,igrsurf%NODES,igrsurf%ELTYP,igrsurf%ELEM)
456 iseg = nseg-nns+2
457 CALL ssurf10(face(3),fc10(3),fc10(2),fc10(2),js,
458 . nseg0 ,iseg ,igrsurf%NODES,igrsurf%ELTYP,igrsurf%ELEM)
459 ELSEIF(fc10(2) == 0)THEN
460 iseg = nseg-nns+1
461 CALL ssurf10(face(2),face(3),fc10(3),fc10(1),js,
462 . nseg0 ,iseg ,igrsurf%NODES,igrsurf%ELTYP,igrsurf%ELEM)
463 iseg = nseg-nns+2
464 CALL ssurf10(face(1),fc10(1),fc10(3),fc10(3),js,
465 . nseg0 ,iseg ,igrsurf%NODES,igrsurf%ELTYP,igrsurf%ELEM)
466 ELSEIF(fc10(3) == 0)THEN
467 iseg = nseg-nns+1
468 CALL ssurf10(face(3),face(1),fc10(1),fc10(2),js,
469 . nseg0 ,iseg ,igrsurf%NODES,igrsurf%ELTYP,igrsurf%ELEM)
470 iseg = nseg-nns+2
471 CALL ssurf10(face(2),fc10(2),fc10(1),fc10(1),js,
472 . nseg0 ,iseg ,igrsurf%NODES,igrsurf%ELTYP,igrsurf%ELEM)
473 ENDIF
474 ELSEIF (flag == 1 .and. nns == 2) THEN
475c 2 triangles
476 IF(fc10(1) /= 0)THEN
477 iseg = nseg-nns+1
478 CALL ssurf10(face(3),face(1),fc10(1),fc10(1),js,
479 . nseg0 ,iseg ,igrsurf%NODES,igrsurf%ELTYP,igrsurf%ELEM)
480 iseg = nseg-nns+2
481 CALL ssurf10(face(2),face(3),fc10(1),fc10(1),js,
482 . nseg0 ,iseg ,igrsurf%NODES,igrsurf%ELTYP,igrsurf%ELEM)
483 ELSEIF(fc10(2) /= 0)THEN
484 iseg = nseg-nns+1
485 CALL ssurf10(face(1),face(2),fc10(2),fc10(2),js,
486 . nseg0 ,iseg ,igrsurf%NODES,igrsurf%ELTYP,igrsurf%ELEM)
487 iseg = nseg-nns+2
488 CALL ssurf10(face(3),face(1),fc10(2),fc10(2),js,
489 . nseg0 ,iseg ,igrsurf%NODES,igrsurf%ELTYP,igrsurf%ELEM)
490 ELSEIF(fc10(3) /= 0)THEN
491 iseg = nseg-nns+1
492 CALL ssurf10(face(2),face(3),fc10(3),fc10(3),js,
493 . nseg0 ,iseg ,igrsurf%NODES,igrsurf%ELTYP,igrsurf%ELEM)
494 iseg = nseg-nns+2
495 CALL ssurf10(face(1),face(2),fc10(3),fc10(3),js,
496 . nseg0 ,iseg ,igrsurf%NODES,igrsurf%ELTYP,igrsurf%ELEM)
497 ENDIF
498 ELSEIF (flag == 1 .and. nns == 1) THEN
499c 1 triangle
500 iseg = nseg-nns+1
501 CALL ssurf10(face(1),face(2),face(3),face(3),js,
502 . nseg0 ,iseg ,igrsurf%NODES,igrsurf%ELTYP,igrsurf%ELEM)
503 END IF
504 END IF
505C---
506 END DO
507! ENDIF
508 ENDDO ! end of JS_ELM=1,NUM_ELM
509 ENDDO ! end JS_PART=1,NUM_PART
510C-----------
511 DEALLOCATE(nodtag,fastag)
512 RETURN
min
#define min(a, b)
Definition macros.h:20
groupdef_mod
Definition groupdef_mod.F:668
names_and_titles_mod
Definition names_and_titles_mod.F:1002
names_and_titles_mod::ncharkey
integer, parameter ncharkey
Definition names_and_titles_mod.F:1005
surf_mod
Definition surf_mod.F:37
ssurf10
subroutine ssurf10(n1, n2, n3, n4, js, nseg0, iseg, surf_nodes, surf_eltyp, surf_elem)
Definition ssurftag.F:522

◆ surfext_tagn()

subroutine surfext_tagn ( integer, dimension(nixs,*) ixs,
integer, dimension(*) knod2els,
integer, dimension(*) nod2els,
integer, dimension(6,*) ixs10,
integer, dimension(numels) fastag,
integer, dimension(*) itab )

Definition at line 549 of file ssurftag.F.

550 use element_mod , only : nixs
551C-----------------------------------------------
552C I m p l i c i t T y p e s
553C-----------------------------------------------
554#include "implicit_f.inc"
555#include "com04_c.inc"
556C-----------------------------------------------
557C D u m m y A r g u m e n t s
558C-----------------------------------------------
559 INTEGER IXS(NIXS,*),KNOD2ELS(*),NOD2ELS(*),
560 . IXS10(6,*),FASTAG(NUMELS),itab(*)
561C-----------------------------------------------
562C L o c a l V a r i a b l e s
563C-----------------------------------------------
564 INTEGER N,J,K,JS,KS,II,JJ,K1,K2,LL,FACE(4),FC10(3),NN,KK,I1,
565 . NI(4),NS(4),MI(4),MS(4),NMIN,MMIN,NF,MF,IPERM,N1,N2,I
566 INTEGER FACES(4,6),PWR(7)
567 INTEGER, DIMENSION(:), ALLOCATABLE :: NODTAG
568 INTEGER :: FACES10(3,6),NNS
569 DATA faces/4,3,2,1,
570 . 5,6,7,8,
571 . 1,2,6,5,
572 . 3,4,8,7,
573 . 2,3,7,6,
574 . 1,5,8,4/
575 DATA faces10/0,0,0,
576 . 0,0,0,
577 . 3,6,4,
578 . 5,6,2,
579 . 1,2,3,
580 . 4,5,1/
581 DATA pwr/1,2,4,8,16,32,64/
582Co=======================================================================
583 ALLOCATE(nodtag(numnod))
584 fastag=0
585C Tag nodes External surface (solid)
586 DO js=1,numels
587 DO jj=1,6
588 DO ii=1,4
589 ns(ii)=ixs(faces(ii,jj)+1,js)
590 END DO
591C
592C keep only 1 occurrence of each node (triangles, degenerated cases...)
593 DO k1=1,3
594 DO k2=k1+1,4
595 IF(ns(k2)==ns(k1))ns(k2)=0
596 END DO
597 END DO
598 nf=0
599 DO k1=1,4
600 n1=ns(k1)
601 IF(n1/=0)THEN
602 nf=nf+1
603 ns(nf)=n1
604 END IF
605 END DO
606 IF (nf < 3)cycle
607C
608C permute
609 nmin=ns(1)
610 DO ii=2,nf
611 nmin=min(nmin,ns(ii))
612 END DO
613 DO iperm=1,nf
614 IF(nmin==ns(iperm).AND.
615 . ns(mod(iperm,nf)+1)/=ns(iperm))THEN
616 DO ii=1,nf
617 ni(ii)=ns(mod(ii+iperm-2,nf)+1)
618 END DO
619 EXIT
620 END IF
621 END DO
622C
623C looks for an elt sharing the face.
624 DO k=knod2els(ni(1))+1,knod2els(ni(1)+1)
625 ks=nod2els(k)
626 IF(ks==js .OR. ks > numels8+numels10)cycle
627 DO ii=1,nf
628 nodtag(ni(ii))=0
629 END DO
630 DO ii=1,8
631 nodtag(ixs(ii+1,ks))=1
632 END DO
633 nn=0
634 DO ii=1,nf
635 nn=nn+nodtag(ni(ii))
636 END DO
637 IF(nn==nf)THEN
638 DO kk=1,6
639 DO ii=1,4
640 ms(ii)=ixs(faces(ii,kk)+1,ks)
641 END DO
642C
643C keep only 1 occurrence of each node (triangles, degenerated cases...)
644 DO k1=1,3
645 DO k2=k1+1,4
646 IF(ms(k2)==ms(k1))ms(k2)=0
647 END DO
648 END DO
649 mf=0
650 DO k1=1,4
651 n1=ms(k1)
652 IF(n1/=0)THEN
653 mf=mf+1
654 ms(mf)=n1
655 END IF
656 END DO
657 IF(mf /= nf)cycle
658C
659C permute
660 mmin=ms(1)
661 DO ii=2,mf
662 mmin=min(mmin,ms(ii))
663 END DO
664 DO iperm=1,mf
665 IF(mmin==ms(iperm).AND.
666 . ms(mod(iperm,mf)+1)/=ms(iperm))THEN
667 DO ii=1,mf
668 mi(ii)=ms(mod(ii+iperm-2,mf)+1)
669 END DO
670 EXIT
671 END IF
672 END DO
673 IF(mi(1)==ni(1).AND.mi(nf)==ni(2))THEN
674C Factag (JS) Less Face JJ
675 fastag(js)=fastag(js)+pwr(jj)
676 GO TO 300
677 END IF
678 END DO
679 END IF
680 END DO
681 300 CONTINUE
682 END DO
683 END DO
684C-----------
685 DEALLOCATE(nodtag)
686 RETURN