OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
ssurftag.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!|| ssurftag ../starter/source/groups/ssurftag.F
25!||--- called by ------------------------------------------------------
26!|| hm_read_surf ../starter/source/groups/hm_read_surf.F
27!||--- calls -----------------------------------------------------
28!|| ssurf10 ../starter/source/groups/ssurftag.F
29!||--- uses -----------------------------------------------------
30!|| surf_mod ../starter/share/modules1/surf_mod.F
31!||====================================================================
32 SUBROUTINE ssurftag(IXS ,IPARTS ,NSEG0 ,IGRSURF ,TAGBUF,
33 . NSEG ,KNOD2ELS,NOD2ELS ,IEXT ,FLAG ,
34 . IXS10 ,IXS16 ,IXS20 ,IFRE ,KEY ,
35 . KNOD2ELC,NOD2ELC ,KNOD2ELTG,NOD2ELTG,
36 . IXC ,IXTG ,IPARTC ,IPARTTG ,NINDX,
37 . NINDX_SOL, NINDX_SOL10, INDX, INDX_SOL, INDX_SOL10,
38 . SURF_ELM)
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..OR.'IABS(TAGBUF(IPARTS(JS))) == 1)
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.and. IF(FLAG == 0 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.and. ELSEIF(FLAG == 0 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..OR.'IABS(TAGBUF(IPARTS(JS))) == 1)
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.and. IF (FLAG == 1 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.and. ELSEIF (FLAG == 1 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.and. ELSEIF (FLAG == 1 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.and. ELSEIF (FLAG == 1 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
512 END
513
514!||====================================================================
515!|| ssurf10 ../starter/source/groups/ssurftag.F
516!||--- called by ------------------------------------------------------
517!|| ssurftag ../starter/source/groups/ssurftag.F
518!||====================================================================
519 SUBROUTINE SSURF10(N1 ,N2 ,N3 ,N4 ,JS ,
520 . NSEG0 ,ISEG ,SURF_NODES,SURF_ELTYP,SURF_ELEM)
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
541 END
542!||====================================================================
543!|| surfext_tagn ../starter/source/groups/ssurftag.F
544!||--- called by ------------------------------------------------------
545!|| lectur ../starter/source/starter/lectur.F
546!||====================================================================
547 SUBROUTINE SURFEXT_TAGN(IXS ,KNOD2ELS,NOD2ELS ,IXS10 ,FASTAG,itab)
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.AND. IF(NMIN==NS(IPERM)
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.OR. IF(KS==JS 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.AND. IF(MMIN==MS(IPERM)
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.AND. IF(MI(1)==NI(1)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
684 END
685
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
ssurftag
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)
Definition ssurftag.F:39