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 519 of file ssurftag.F.

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

◆ 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 547 of file ssurftag.F.

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