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

Go to the source code of this file.

Functions/Subroutines

subroutine polyhedr1 (ipoly, rpoly, polb, npolb, polh, npolh, nrpmax, nphmax, ibric, lmin, info, npolhmax, nppmax, nel, inz, tagela)

Function/Subroutine Documentation

◆ polyhedr1()

subroutine polyhedr1 ( integer, dimension(6+nppmax,*) ipoly,
rpoly,
integer, dimension(*) polb,
integer npolb,
integer, dimension(nphmax+2,*) polh,
integer npolh,
integer nrpmax,
integer nphmax,
integer ibric,
lmin,
integer info,
integer npolhmax,
integer nppmax,
integer nel,
integer inz,
integer, dimension(*) tagela )

Definition at line 31 of file polyhedr1.F.

35C-----------------------------------------------
36C I m p l i c i t T y p e s
37C-----------------------------------------------
38#include "implicit_f.inc"
39C-----------------------------------------------
40C C o m m o n B l o c k s
41C-----------------------------------------------
42#include "units_c.inc"
43C-----------------------------------------------
44C D u m m y A r g u m e n t s
45C-----------------------------------------------
46 INTEGER NPPMAX, IPOLY(6+NPPMAX,*), POLB(*), NPOLB, NPHMAX,
47 . POLH(NPHMAX+2,*),NPOLH, NRPMAX, IBRIC, INFO, NPOLHMAX
48 INTEGER TAGELA(*)
49 INTEGER NEL, INZ
50 my_real
51 . rpoly(nrpmax,*), lmin
52C-----------------------------------------------
53C L o c a l V a r i a b l e s
54C-----------------------------------------------
55 INTEGER I, ICMAX, II, J, JJ, K, KK, IEL
56 INTEGER L, LL, ITY, JMIN, PMIN, POLD, NEDGE, NVERTEX
57 INTEGER IMIN, IMAX, I1, I2, I3, I4, N1, N2, K1, K2
58 INTEGER M1, M2, L1, L2
59 INTEGER ITAG(2,NPOLB), POLEDG(NPOLB,NPPMAX+1), ITYP(NPOLB)
60 INTEGER NTYP(3), REDIR(4), TEMP1(4), TEMP2(4)
61 INTEGER NNP, NHOL, NSEG, NELP, JTAG(3), NTRI3(NPOLB,NPPMAX)
62 INTEGER, ALLOCATABLE :: EDGPOL(:,:)
63 INTEGER, ALLOCATABLE :: EDGVER(:,:)
64 INTEGER, ALLOCATABLE :: EDGLOC(:,:)
65 INTEGER, ALLOCATABLE :: PSEG(:,:),PTRI(:,:)
66 my_real
67 . x1, y1, z1, x2, y2, z2, xx1, yy1, zz1, xx2, yy2, zz2,
68 . dd11, dd12, dd21, dd22, tole
69 my_real
70 . tst12, tst13, tst21, tst32, tst14,
71 . nx, ny, nz, nx1, ny1, nz1
72 my_real
73 . x0, y0, z0, nrm1, vx1, vy1, vz1, vx2, vy2, vz2,
74 . vx, vy, vz
75 my_real
76 . alpha13, alpha14
77 my_real, ALLOCATABLE :: xx(:), yy(:), zz(:)
78 my_real, ALLOCATABLE :: pnodes(:,:), pholes(:,:)
79C
80 tole=epsilon(zero)*0.5*lmin*lmin
81C--------------------------------
82C Triangularisation des polygones
83C--------------------------------
84 DO ii=1,npolb
85 i=polb(ii)
86 nnp=ipoly(2,i)
87 nhol=0
88 ALLOCATE(pnodes(2,nnp), pseg(2,nnp),ptri(3,2*nnp),pholes(2,1))
89 ptri(1:3,1:2*nnp) = 0
90C
91C Coordonnees des sommets dans le plan du polygone
92 nx=rpoly(2,i)
93 ny=rpoly(3,i)
94 nz=rpoly(4,i)
95C
96 x0=rpoly(5,i)
97 y0=rpoly(6,i)
98 z0=rpoly(7,i)
99 x1=rpoly(8,i)
100 y1=rpoly(9,i)
101 z1=rpoly(10,i)
102 nrm1=sqrt((x1-x0)**2+(y1-y0)**2+(z1-z0)**2)
103 vx1=(x1-x0)/nrm1
104 vy1=(y1-y0)/nrm1
105 vz1=(z1-z0)/nrm1
106 vx2=ny*vz1-nz*vy1
107 vy2=nz*vx1-nx*vz1
108 vz2=nx*vy1-ny*vx1
109C
110 pnodes(1,1)=zero
111 pnodes(2,1)=zero
112 DO j=2,nnp
113 x1=rpoly(4+3*(j-1)+1,i)
114 y1=rpoly(4+3*(j-1)+2,i)
115 z1=rpoly(4+3*(j-1)+3,i)
116 vx=x1-x0
117 vy=y1-y0
118 vz=z1-z0
119 pnodes(1,j)=vx*vx1+vy*vy1+vz*vz1
120 pnodes(2,j)=vx*vx2+vy*vy2+vz*vz2
121 pseg(1,j-1)=j-1
122 pseg(2,j-1)=j
123 ENDDO
124 pseg(1,nnp)=nnp
125 pseg(2,nnp)=1
126 nseg=nnp
127C
128 nelp = 0
129 CALL c_tricall(pnodes, pseg, pholes, ptri, nnp,
130 . nseg, nhol, nelp )
131CFA IF(NELP > NNP) THEN
132CFA WRITE(IOUT,'(A,I5,A,I2,2(I5,A))') 'BRICK',IBRIC,
133CFA . ' POLYGONE', I, NNP,' SOMMETS',NELP,' TRIANGLES'
134CFA DO J=1,NELP
135CFA WRITE(IOUT,'(4I5)') J,PTRI(1,J),PTRI(2,J),PTRI(3,J)
136CFA ENDDO
137CFA ENDIF
138C--------------------------------------------------------------------------------
139C Calcul pour chaque arete du 3eme noeud du triangle associe, stockage dans NTRI3
140C--------------------------------------------------------------------------------
141 DO j=1,nnp
142 n1=j
143 n2=j+1
144 IF(j==nnp) n2=1
145 DO k=1,nelp
146 jtag(k)=0
147 DO l=1,3
148 IF(ptri(l,k) == n1) jtag(k)=jtag(k)+1
149 IF(ptri(l,k) == n2) jtag(k)=jtag(k)+1
150 ENDDO
151 ENDDO
152 DO k=1,nelp
153 IF(jtag(k) /= 2) cycle
154 DO l=1,3
155 IF(ptri(l,k) == n1 .OR. ptri(l,k) == n2) cycle
156 ntri3(ii,j) = ptri(l,k)
157 ENDDO
158 ENDDO
159 ENDDO ! II=1,NPOLB
160C
161 DEALLOCATE(pnodes, pseg, ptri, pholes)
162 ENDDO
163C--------------------------------------------------------------
164C Construction polygone-arete
165C POLEDG(i,1) donne le nombre d'aretes connectees au polygone i
166C POLEDG(i,j+1) donne le numero de la jeme arete
167C EDGVER(i,1) numero du premier sommet de l'arete i
168C EDGVER(i,2) numero du deuxieme sommet de l'arete i
169C--------------------------------------------------------------
170 ALLOCATE (xx(npolb*nppmax*2))
171 ALLOCATE (yy(npolb*nppmax*2))
172 ALLOCATE (zz(npolb*nppmax*2))
173 ALLOCATE (edgver(npolb*nppmax,2))
174 DO i=1,npolb
175 DO j=1,nppmax+1
176 poledg(i,j)=0
177 ENDDO
178 ENDDO
179 nedge=0
180 nvertex=0
181 DO i=1,npolb
182 ii=polb(i)
183 poledg(i,1)=ipoly(2,ii)
184 DO j=1,ipoly(2,ii)
185 jj=j+1
186 IF(poledg(i,jj) > 0) cycle
187 nedge=nedge+1
188 poledg(i,jj)=nedge
189 x1=rpoly(4+3*(j-1)+1,ii)
190 y1=rpoly(4+3*(j-1)+2,ii)
191 z1=rpoly(4+3*(j-1)+3,ii)
192 nvertex=nvertex+1
193 edgver(nedge,1)=nvertex
194 xx(nvertex)=x1
195 yy(nvertex)=y1
196 zz(nvertex)=z1
197 IF (j==ipoly(2,ii)) jj=1
198 x2=rpoly(4+3*(jj-1)+1,ii)
199 y2=rpoly(4+3*(jj-1)+2,ii)
200 z2=rpoly(4+3*(jj-1)+3,ii)
201 nvertex=nvertex+1
202 edgver(nedge,2)=nvertex
203 xx(nvertex)=x2
204 yy(nvertex)=y2
205 zz(nvertex)=z2
206 DO k=1,npolb
207 IF (k==i) cycle
208 kk=polb(k)
209 DO l=1,ipoly(2,kk)
210 ll=l+1
211 IF (l==ipoly(2,kk)) ll=1
212 xx1=rpoly(4+3*(l-1)+1,kk)
213 yy1=rpoly(4+3*(l-1)+2,kk)
214 zz1=rpoly(4+3*(l-1)+3,kk)
215 xx2=rpoly(4+3*(ll-1)+1,kk)
216 yy2=rpoly(4+3*(ll-1)+2,kk)
217 zz2=rpoly(4+3*(ll-1)+3,kk)
218 dd11=(xx1-x1)**2+(yy1-y1)**2+(zz1-z1)**2
219 dd21=(xx2-x1)**2+(yy2-y1)**2+(zz2-z1)**2
220 dd12=(xx1-x2)**2+(yy1-y2)**2+(zz1-z2)**2
221 dd22=(xx2-x2)**2+(yy2-y2)**2+(zz2-z2)**2
222 IF ((dd11<=tole.AND.dd22<=tole).OR.
223 . (dd21<=tole.AND.dd12<=tole)) THEN
224 poledg(k,l+1)=nedge
225 ENDIF
226 ENDDO
227 ENDDO
228 ENDDO
229 ENDDO
230C---------------------------------------------------------------
231C Construction arete-polygone
232C EDGPOL(i,1) donne le nombre de polygones connectes a l'arete i
233C EDGPOL(i,j+1) donne le numero du jeme polygone
234C EDGLOC(i,k) donne la position de l'arete i dans POLEDG
235C---------------------------------------------------------------
236 ALLOCATE(edgpol(nedge,5))
237 ALLOCATE(edgloc(nedge,4))
238 DO i=1,nedge
239 DO j=1,4
240 edgpol(i,j)=0
241 edgloc(i,j)=0
242 ENDDO
243 edgpol(i,5)=0
244 ENDDO
245 DO i=1,npolb
246 DO j=1,poledg(i,1)
247 k=poledg(i,j+1)
248 IF(k==0) cycle
249 kk=edgpol(k,1)
250 kk=kk+1
251 IF(kk > 4) THEN
252 n1=edgver(k,1)
253 n2=edgver(k,2)
254 WRITE(iout,'(A,I5,A /A,1P3G20.13,A/A,1P3G20.13,A)')
255 . ' FVMBAG MESH ERROR : EDGE N1N2 IS CONNECTED TO ',kk,
256 . ' POLYGONS BUT THE LIMIT IS 4',
257 . ' N1 = (',xx(n1),yy(n1),zz(n1),')',
258 . ' N2 = (',xx(n2),yy(n2),zz(n2),')'
259 CALL arret(2)
260 ENDIF
261 edgpol(k,1)=kk
262 edgpol(k,kk+1)=i
263 edgloc(k,kk)=j
264 ENDDO
265 ENDDO
266C
267 DO i=1,npolb
268 itag(1,i)=0
269 itag(2,i)=0
270 ii=polb(i)
271 ity=ipoly(1,ii)
272 iel=ipoly(3,ii)
273 IF(ity == 1 .AND. tagela(iel) > nel) ity=3
274 ityp(i)=ity
275 ENDDO
276C-------
277C Checks
278C-------
279 DO j=1,nedge
280 n1=edgver(j,1)
281 n2=edgver(j,2)
282 DO k=1,3
283 ntyp(k)=0
284 ENDDO
285 l=edgpol(j,1)
286 DO k=1,l
287 ii=edgpol(j,k+1)
288 IF(ityp(ii) == 1) ntyp(1)=ntyp(1)+1
289 IF(ityp(ii) == 2) ntyp(2)=ntyp(2)+1
290 IF(ityp(ii) == 3) ntyp(3)=ntyp(3)+1
291 ENDDO
292 IF(l == 1) THEN
293 WRITE(iout,'(/2(A,I5),A,2(/A,1P3G20.13,A))')
294 . ' FVMBAG MESH ERROR : BRICK ',ibric,' LAYER ',inz,
295 . ' EDGE N1N2 IS CONNECTED TO ONLY 1 POLYGON',
296 . ' N1 = (',xx(n1),yy(n1),zz(n1),')',
297 . ' N2 = (',xx(n2),yy(n2),zz(n2),')'
298 CALL arret(2)
299 ELSEIF(l == 2 .AND. ntyp(3) == 1) THEN
300 WRITE(iout,'(/2(A,I5),2A,2(/A,1P3G20.13,A))')
301 . ' FVMBAG MESH ERROR : BRICK ',ibric,' LAYER ',inz,
302 . ' EDGE N1N2 IS CONNECTED TO 2 POLYGONS BUT ONLY 1',
303 . ' INTERNAL POLYGON',
304 . ' N1 = (',xx(n1),yy(n1),zz(n1),')',
305 . ' N2 = (',xx(n2),yy(n2),zz(n2),')'
306 CALL arret(2)
307 ELSEIF(l == 3 .AND. ntyp(3) == 2) THEN
308 WRITE(iout,'(/2(A,I5),2A,2(/A,1P3G20.13,A))')
309 . ' FVMBAG MESH ERROR : BRICK ',ibric,' LAYER ',inz,
310 . ' EDGE N1N2 IS CONNECTED TO 3 POLYGONS 2 BEING',
311 . ' INTERNAL POLYGONS',
312 . ' N1 = (',xx(n1),yy(n1),zz(n1),')',
313 . ' N2 = (',xx(n2),yy(n2),zz(n2),')'
314 CALL arret(2)
315 ELSEIF(l == 4) THEN
316 IF(ntyp(3) == 1) THEN
317 WRITE(iout,'(/2(A,I5),2A,2(/A,1P3G20.13,A))')
318 . ' FVMBAG MESH ERROR : BRICK ',ibric,' LAYER ',inz,
319 . ' EDGE N1N2 IS CONNECTED TO 4 POLYGONS ONLY 1 BEING',
320 . ' INTERNAL POLYGON',
321 . ' N1 = (',xx(n1),yy(n1),zz(n1),')',
322 . ' N2 = (',xx(n2),yy(n2),zz(n2),')'
323 CALL arret(2)
324 ELSEIF( ntyp(3) >= 3) THEN
325 WRITE(iout,'(/2(A,I5),2A,2(/A,1P3G20.13,A))')
326 . ' FVMBAG MESH ERROR : BRICK ',ibric,' LAYER ',inz,
327 . ' EDGE N1N2 IS CONNECTED TO 4 POLYGONS 3 BEING',
328 . ' INTERNAL POLYGONS',
329 . ' N1 = (',xx(n1),yy(n1),zz(n1),')',
330 . ' N2 = (',xx(n2),yy(n2),zz(n2),')'
331 CALL arret(2)
332 ENDIF
333 ELSEIF(l >= 5) THEN
334 WRITE(iout,'(/2(A,I5),A,2(/A,1P3G20.13,A))')
335 . ' FVMBAG MESH ERROR : BRICK ',ibric,' LAYER ',inz,
336 . ' EDGE N1N2 IS CONNECTED TO MORE THAN 4 POLYGONS',
337 . ' N1 = (',xx(n1),yy(n1),zz(n1),')',
338 . ' N2 = (',xx(n2),yy(n2),zz(n2),')'
339 CALL arret(2)
340 ENDIF
341 ENDDO ! J=1,NEDGE
342C---------------------------------------------------
343C Mettre les polygones internes en premiere position
344C---------------------------------------------------
345 DO j=1,nedge
346 IF(edgpol(j,1) == 2 ) cycle
347 DO k=1,edgpol(j,1)
348 temp1(k)=edgpol(j,k+1)
349 temp2(k)=edgloc(j,k)
350 ENDDO
351 i=1
352 DO k=1,edgpol(j,1)
353 l=edgpol(j,k+1)
354 IF(ityp(l) == 3) THEN
355 redir(i)=k
356 i=i+1
357 ENDIF
358 ENDDO
359 DO k=1,edgpol(j,1)
360 l=edgpol(j,k+1)
361 IF(ityp(l) /= 3) THEN
362 redir(i)=k
363 i=i+1
364 ENDIF
365 ENDDO
366 DO k=1,edgpol(j,1)
367 edgpol(j,k+1)=temp1(redir(k))
368 edgloc(j,k) =temp2(redir(k))
369 ENDDO
370 ENDDO ! J=1,NEDGE
371C--------------------------------------------------------------------
372C Construction des polyedres
373C ITAG(1,i) le polyedre est du cote oppose a la normale au polygone
374C ITAG(2,i) le polyedre est du cote de la normale au polygone
375C--------------------------------------------------------------------
376 icmax=0
377C------------------------------
378C Arete connectee a 4 polygones
379C------------------------------
380 DO j=1,nedge
381 IF(edgpol(j,1) < 4) cycle
382 i1=edgpol(j,2)
383 i2=edgpol(j,3)
384 i3=edgpol(j,4)
385 i4=edgpol(j,5)
386 ii=polb(i1)
387 nx=rpoly(2,ii)
388 ny=rpoly(3,ii)
389 nz=rpoly(4,ii)
390 n1=edgver(j,1)
391 x1=xx(n1)
392 y1=yy(n1)
393 z1=zz(n1)
394 jj=edgloc(j,2)
395 jj=ntri3(i2,jj)
396 ii=polb(i2)
397 x2=rpoly(4+3*(jj-1)+1,ii)
398 y2=rpoly(4+3*(jj-1)+2,ii)
399 z2=rpoly(4+3*(jj-1)+3,ii)
400 tst12=nx*(x2-x1)+ny*(y2-y1)+nz*(z2-z1)
401C
402 jj=edgloc(j,3)
403 jj=ntri3(i3,jj)
404 ii=polb(i3)
405 nx1=rpoly(2,ii)
406 ny1=rpoly(3,ii)
407 nz1=rpoly(4,ii)
408 x2=rpoly(4+3*(jj-1)+1,ii)
409 y2=rpoly(4+3*(jj-1)+2,ii)
410 z2=rpoly(4+3*(jj-1)+3,ii)
411 vx=x2-x1
412 vy=y2-y1
413 vz=z2-z1
414 tst13=nx*vx+ny*vy+nz*vz
415 alpha13=acos(nx*nx1+ny*ny1+nz*nz1)
416C
417 jj=edgloc(j,4)
418 jj=ntri3(i4,jj)
419 ii=polb(i4)
420 nx1=rpoly(2,ii)
421 ny1=rpoly(3,ii)
422 nz1=rpoly(4,ii)
423 x2=rpoly(4+3*(jj-1)+1,ii)
424 y2=rpoly(4+3*(jj-1)+2,ii)
425 z2=rpoly(4+3*(jj-1)+3,ii)
426 vx=x2-x1
427 vy=y2-y1
428 vz=z2-z1
429 tst14=nx*vx+ny*vy+nz*vz
430 alpha14=acos(nx*nx1+ny*ny1+nz*nz1)
431C
432 ii=polb(i2)
433 nx=rpoly(2,ii)
434 ny=rpoly(3,ii)
435 nz=rpoly(4,ii)
436 jj=edgloc(j,1)
437 jj=ntri3(i1,jj)
438 ii=polb(i1)
439 x2=rpoly(4+3*(jj-1)+1,ii)
440 y2=rpoly(4+3*(jj-1)+2,ii)
441 z2=rpoly(4+3*(jj-1)+3,ii)
442 tst21=nx*(x2-x1)+ny*(y2-y1)+nz*(z2-z1)
443C
444 IF(tst12*tst21 < zero) THEN
445 n2=edgver(j,2)
446 WRITE(iout,'(/2(A,I5),2A,2(/A,1P3G20.13,A))')
447 . ' FVMBAG MESH ERROR : BRICK ',ibric,' LAYER ',inz,
448 . ' WRONG NORMAL ORIENTATION OF INTERNAL SURFACE ELEMENTS',
449 . ' CONNECTED TO EDGE N1N2',
450 . ' N1 = (',xx(n1),yy(n1),zz(n1),')',
451 . ' N2 = (',xx(n2),yy(n2),zz(n2),')'
452 CALL arret(2)
453 ELSE
454 icmax=icmax+1
455 itag(1,i1)=icmax
456 itag(1,i2)=icmax
457 ENDIF
458C
459 IF(tst13 > zero .AND. tst14 > zero) THEN
460 IF(alpha13 < alpha14) THEN
461 icmax=icmax+1
462 itag(2,i1)=icmax
463 itag(1,i3)=icmax
464 icmax=icmax+1
465 itag(2,i2)=icmax
466 itag(1,i4)=icmax
467 ELSE
468 icmax=icmax+1
469 itag(2,i1)=icmax
470 itag(1,i4)=icmax
471 icmax=icmax+1
472 itag(2,i2)=icmax
473 itag(1,i3)=icmax
474 ENDIF
475 ELSEIF(tst13 < zero .AND. tst14 < zero) THEN
476 IF(alpha13 < alpha14) THEN
477 icmax=icmax+1
478 itag(2,i1)=icmax
479 itag(1,i4)=icmax
480 icmax=icmax+1
481 itag(2,i2)=icmax
482 itag(1,i3)=icmax
483 ELSE
484 icmax=icmax+1
485 itag(2,i1)=icmax
486 itag(1,i3)=icmax
487 icmax=icmax+1
488 itag(2,i2)=icmax
489 itag(1,i4)=icmax
490 ENDIF
491 ELSEIF(tst13 > zero .AND. tst14 < zero) THEN
492 icmax=icmax+1
493 itag(2,i1)=icmax
494 itag(1,i3)=icmax
495 icmax=icmax+1
496 itag(2,i2)=icmax
497 itag(1,i4)=icmax
498 ELSEIF(tst13 < zero .AND. tst14 > zero) THEN
499 icmax=icmax+1
500 itag(2,i1)=icmax
501 itag(1,i4)=icmax
502 icmax=icmax+1
503 itag(2,i2)=icmax
504 itag(1,i3)=icmax
505 ENDIF
506 ENDDO ! J=1,NEDGE
507C---------------------------------------
508C Arete connectee a 3 polygones internes
509C---------------------------------------
510 DO j=1,nedge
511 IF(edgpol(j,1) /= 3) cycle
512 i1=edgpol(j,2)
513 i2=edgpol(j,3)
514 IF(ityp(i2) /= 3) cycle
515 i3=edgpol(j,4)
516 n1=edgver(j,1)
517 x1=xx(n1)
518 y1=yy(n1)
519 z1=zz(n1)
520C Position du polygone I2 par rapport au polygone I1
521 ii=polb(i1)
522 nx=rpoly(2,ii)
523 ny=rpoly(3,ii)
524 nz=rpoly(4,ii)
525 jj=edgloc(j,2)
526 jj=ntri3(i2,jj)
527 ii=polb(i2)
528 x2=rpoly(4+3*(jj-1)+1,ii)
529 y2=rpoly(4+3*(jj-1)+2,ii)
530 z2=rpoly(4+3*(jj-1)+3,ii)
531 tst12=nx*(x2-x1)+ny*(y2-y1)+nz*(z2-z1)
532 IF(tst12 < zero) THEN
533 k1=1
534 k2=2
535 ELSE
536 k1=2
537 k2=1
538 ENDIF
539C Position du polygone I1 par rapport au polygone I2
540 ii=polb(i2)
541 nx=rpoly(2,ii)
542 ny=rpoly(3,ii)
543 nz=rpoly(4,ii)
544 jj=edgloc(j,2)
545 jj=ntri3(i1,jj)
546 ii=polb(i1)
547 x2=rpoly(4+3*(jj-1)+1,ii)
548 y2=rpoly(4+3*(jj-1)+2,ii)
549 z2=rpoly(4+3*(jj-1)+3,ii)
550 tst21=nx*(x2-x1)+ny*(y2-y1)+nz*(z2-z1)
551 IF(tst21 < zero) THEN
552 l1=1
553 l2=2
554 ELSE
555 l1=2
556 l2=1
557 ENDIF
558C Position du polygone I2 par rapport au polygone I3
559 ii=polb(i3)
560 nx=rpoly(2,ii)
561 ny=rpoly(3,ii)
562 nz=rpoly(4,ii)
563 jj=edgloc(j,2)
564 jj=ntri3(i2,jj)
565 ii=polb(i2)
566 x2=rpoly(4+3*(jj-1)+1,ii)
567 y2=rpoly(4+3*(jj-1)+2,ii)
568 z2=rpoly(4+3*(jj-1)+3,ii)
569 tst32=nx*(x2-x1)+ny*(y2-y1)+nz*(z2-z1)
570 IF(tst32 < zero) THEN
571 m1=1
572 m2=2
573 ELSE
574 m1=2
575 m2=1
576 ENDIF
577C Premier polyedre
578 IF (itag(k1,i1) == 0 .AND. itag(l1,i2) == 0) THEN
579 icmax=icmax+1
580 itag(k1,i1)=icmax
581 itag(l1,i2)=icmax
582 ELSEIF(itag(k1,i1) == 0 .AND. itag(l1,i2) /= 0) THEN
583 itag(k1,i1)=itag(l1,i2)
584 ELSEIF(itag(k1,i1) /= 0. and. itag(l1,i2) == 0) THEN
585 itag(l1,i2)=itag(k1,i1)
586 ELSEIF(itag(k1,i1) /= 0 .AND. itag(l1,i2) /= 0) THEN
587 IF(itag(k1,i1) /= itag(l1,i2)) THEN
588 imin=min(itag(l1,i2),itag(k1,i1))
589 imax=max(itag(l1,i2),itag(k1,i1))
590 DO i=1,npolb
591 IF(itag(1,i) == imax) itag(1,i)=imin
592 IF(ityp(i) /= 3) cycle
593 IF(itag(2,i) == imax) itag(2,i)=imin
594 ENDDO
595 ENDIF
596 ENDIF
597C Deuxieme polyedre
598 IF(itag(m1,i3) == 0 .AND. itag(l2,i2) == 0) THEN
599 icmax=icmax+1
600 itag(m1,i3)=icmax
601 itag(l2,i2)=icmax
602 ELSEIF(itag(m1,i3) /= 0 .AND. itag(l2,i2) == 0) THEN
603 itag(l2,i2)=itag(m1,i3)
604 ELSEIF(itag(m1,i3) == 0 .AND. itag(l2,i2) /= 0) THEN
605 itag(m1,i3)=itag(l2,i2)
606 ELSEIF(itag(m1,i3) /= 0 .AND. itag(l2,i2) /= 0) THEN
607 IF(itag(m1,i3) /= itag(l2,i2)) THEN
608 imin=min(itag(m1,i3),itag(l2,i2))
609 imax=max(itag(m1,i3),itag(l2,i2))
610 DO i=1,npolb
611 IF(itag(1,i) == imax) itag(1,i)=imin
612 IF(ityp(i) /= 3) cycle
613 IF(itag(2,i) == imax) itag(2,i)=imin
614 ENDDO
615 ENDIF
616 ENDIF
617C Troisieme polyedre
618 IF(itag(m2,i3) == 0 .AND. itag(k2,i1) == 0) THEN
619 icmax=icmax+1
620 itag(m2,i3)=icmax
621 itag(k2,i1)=icmax
622 ELSEIF(itag(m2,i3) /= 0 .AND. itag(k2,i1) == 0) THEN
623 itag(k2,i1)=itag(m2,i3)
624 ELSEIF(itag(m2,i3) == 0 .AND. itag(k2,i1) /= 0) THEN
625 itag(m2,i3)=itag(k2,i1)
626 ELSEIF(itag(m2,i3) /= 0 .AND. itag(k2,i1) /= 0) THEN
627 IF(itag(m2,i3) /= itag(k2,i1)) THEN
628 imin=min(itag(m2,i3),itag(k2,i1))
629 imax=max(itag(m2,i3),itag(k2,i1))
630 DO i=1,npolb
631 IF(itag(1,i) == imax) itag(1,i)=imin
632 IF(ityp(i) /= 3) cycle
633 IF(itag(2,i) == imax) itag(2,i)=imin
634 ENDDO
635 ENDIF
636 ENDIF
637 ENDDO ! J=1,NEDGE
638C-------------------------------------------------------
639C Arete connectee a 3 polygones (1 interne + 2 externes)
640C-------------------------------------------------------
641 DO j=1,nedge
642 IF(edgpol(j,1) /= 3) cycle
643 i1=edgpol(j,2)
644 i2=edgpol(j,3)
645 IF(ityp(i2) == 3) cycle
646 i3=edgpol(j,4)
647 ii=polb(i1)
648 nx=rpoly(2,ii)
649 ny=rpoly(3,ii)
650 nz=rpoly(4,ii)
651 n1=edgver(j,1)
652 x1=xx(n1)
653 y1=yy(n1)
654 z1=zz(n1)
655 jj=edgloc(j,2)
656 jj=ntri3(i2,jj)
657 ii=polb(i2)
658 x2=rpoly(4+3*(jj-1)+1,ii)
659 y2=rpoly(4+3*(jj-1)+2,ii)
660 z2=rpoly(4+3*(jj-1)+3,ii)
661 tst12=nx*(x2-x1)+ny*(y2-y1)+nz*(z2-z1)
662 IF(tst12 < zero) THEN
663 k1=1
664 k2=2
665 ELSE
666 k1=2
667 k2=1
668 ENDIF
669 IF (itag(k1,i1) == 0 .AND. itag(1,i2) == 0) THEN
670 icmax=icmax+1
671 itag(k1,i1)=icmax
672 itag(1,i2)=icmax
673 IF(itag(1,i3) == 0) THEN
674 icmax=icmax+1
675 itag(k2,i1)=icmax
676 itag(1,i3)=icmax
677 ELSE
678 itag(k2,i1)=itag(1,i3)
679 ENDIF
680 ELSEIF(itag(k1,i1) == 0 .AND. itag(1,i2) /= 0) THEN
681 itag(k1,i1)=itag(1,i2)
682 IF(itag(1,i3) == 0) THEN
683 icmax=icmax+1
684 itag(k2,i1)=icmax
685 itag(1,i3)=icmax
686 ELSE
687 itag(k2,i1)=itag(1,i3)
688 ENDIF
689 ELSEIF(itag(k1,i1) /= 0. and. itag(1,i2) == 0) THEN
690 itag(1,i2)=itag(k1,i1)
691 IF(itag(1,i3) == 0) THEN
692 itag(1,i3)=itag(k2,i1)
693 ELSEIF(itag(1,i3) /= itag(k2,i1)) THEN
694 imin=min(itag(1,i3),itag(k2,i1))
695 imax=max(itag(1,i3),itag(k2,i1))
696 DO i=1,npolb
697 IF(itag(1,i) == imax) itag(1,i)=imin
698 IF(ityp(i) /= 3) cycle
699 IF(itag(2,i) == imax) itag(2,i)=imin
700 ENDDO
701 ENDIF
702 ELSEIF(itag(k1,i1) /= 0 .AND. itag(1,i2) /= 0) THEN
703 IF(itag(k1,i1) /= itag(1,i2)) THEN
704 imin=min(itag(1,i2),itag(k1,i1))
705 imax=max(itag(1,i2),itag(k1,i1))
706 DO i=1,npolb
707 IF(itag(1,i) == imax) itag(1,i)=imin
708 IF(ityp(i) /= 3) cycle
709 IF(itag(2,i) == imax) itag(2,i)=imin
710 ENDDO
711 ENDIF
712 IF(itag(1,i3) == 0) THEN
713 itag(1,i3)=itag(k2,i1)
714 ELSEIF(itag(1,i3) /= itag(k2,i1)) THEN
715 imin=min(itag(1,i3),itag(k2,i1))
716 imax=max(itag(1,i3),itag(k2,i1))
717 DO i=1,npolb
718 IF(itag(1,i) == imax) itag(1,i)=imin
719 IF(ityp(i) /= 3) cycle
720 IF(itag(2,i) == imax) itag(2,i)=imin
721 ENDDO
722 ENDIF
723 ENDIF
724 ENDDO ! J=1,NEDGE
725C------------------------------------------------
726C Arete connectee a 2 polygones
727C Les 2 polygones appartiennent au meme polyedre
728C------------------------------------------------
729 DO j=1,nedge
730 IF(edgpol(j,1) > 2) cycle
731 i1=edgpol(j,2)
732 i2=edgpol(j,3)
733 IF((ityp(i1) /= 3 .AND. ityp(i2) /= 3) .OR.
734 . (ityp(i1) == 3 .AND. ityp(i2) == 3) ) THEN
735 IF (itag(1,i1) == 0 .AND. itag(1,i2) == 0) THEN
736 icmax=icmax+1
737 itag(1,i1)=icmax
738 itag(1,i2)=icmax
739 ELSEIF(itag(1,i1) == 0 .AND. itag(1,i2) /= 0) THEN
740 itag(1,i1)=itag(1,i2)
741 ELSEIF(itag(1,i1) /= 0. and. itag(1,i2) == 0) THEN
742 itag(1,i2)=itag(1,i1)
743 ELSEIF(itag(1,i1) /= itag(1,i2)) THEN
744 imin=min(itag(1,i1),itag(1,i2))
745 imax=max(itag(1,i1),itag(1,i2))
746 DO i=1,npolb
747 IF(itag(1,i) == imax) itag(1,i)=imin
748 IF(ityp(i) /= 3) cycle
749 IF(itag(2,i) == imax) itag(2,i)=imin
750 ENDDO
751 ENDIF
752 ENDIF
753C
754 IF(ityp(i1) == 3 .AND. ityp(i2) == 3) THEN
755 IF (itag(2,i1) == 0 .AND. itag(2,i2) == 0) THEN
756 icmax=icmax+1
757 itag(2,i1)=icmax
758 itag(2,i2)=icmax
759 ELSEIF(itag(2,i1) == 0 .AND. itag(2,i2) /= 0) THEN
760 itag(2,i1)=itag(2,i2)
761 ELSEIF(itag(2,i1) /= 0. and. itag(2,i2) == 0) THEN
762 itag(2,i2)=itag(2,i1)
763 ELSEIF(itag(2,i1) /= itag(2,i2)) THEN
764 imin=min(itag(2,i1),itag(2,i2))
765 imax=max(itag(2,i1),itag(2,i2))
766 DO i=1,npolb
767 IF(itag(1,i) == imax) itag(1,i)=imin
768 IF(ityp(i) /= 3) cycle
769 IF(itag(2,i) == imax) itag(2,i)=imin
770 ENDDO
771 ENDIF
772 ENDIF
773 ENDDO ! J=1,NEDGE
774C
775 DEALLOCATE (edgpol)
776 DEALLOCATE (edgloc)
777 DEALLOCATE (edgver)
778 DEALLOCATE (xx,yy,zz)
779C
780 npolh=0
781 DO i=1,icmax
782 ii=0
783 DO j=1,npolb
784 IF (itag(1,j) == i .OR. itag(2,j) == i) ii=ii+1
785 ENDDO
786 IF (ii/=0) npolh=npolh+1
787 ENDDO
788 IF (npolh>npolhmax) THEN
789 info=1
790 npolhmax=npolh
791 RETURN
792 ENDIF
793C
794 npolh=0
795 DO i=1,icmax
796 ii=0
797 DO j=1,npolb
798 IF (itag(1,j) == i .OR. itag(2,j) == i) ii=ii+1
799 ENDDO
800 IF (ii/=0) THEN
801 npolh=npolh+1
802 polh(1,npolh)=ii
803 polh(2,npolh)=ibric
804 ii=0
805 DO j=1,npolb
806 IF (itag(1,j) == i .OR. itag(2,j) == i) THEN
807 ii=ii+1
808 jj=polb(j)
809 polh(2+ii,npolh)=jj
810 ity=ityp(j)
811 IF (ity == 1) THEN
812 ipoly(5,jj)=npolh
813 ELSEIF(ity == 2) THEN
814 IF (ipoly(5,jj)==0) THEN
815 ipoly(5,jj)=npolh
816 ELSE
817 ipoly(6,jj)=npolh
818 ENDIF
819 ELSEIF(ity == 3) THEN
820 IF(itag(1,j) == i) THEN
821 ipoly(5,jj)=npolh
822 ELSEIF(itag(2,j) == i) THEN
823 ipoly(6,jj)=npolh
824 ENDIF
825 ENDIF
826 ENDIF
827 ENDDO
828C-------------------------------------------------------
829C Tri de POLH par ordre croissant de numero de polygones
830C-------------------------------------------------------
831 DO j=1,polh(1,npolh)
832 jmin=j
833 pmin=polh(2+j,npolh)
834 DO k=j+1,polh(1,npolh)
835 IF (polh(2+k,npolh)<pmin) THEN
836 jmin=k
837 pmin=polh(2+k,npolh)
838 ENDIF
839 ENDDO
840 pold=polh(2+j,npolh)
841 polh(2+j,npolh)=pmin
842 polh(2+jmin,npolh)=pold
843 ENDDO !J=1,NPOLB
844 ENDIF
845 ENDDO !I=1,ICMAX
846C
847 info=0
848 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
arret
subroutine arret(nn)
Definition arret.F:87
c_tricall
subroutine c_tricall(pnodes, pseg, pholes, ptri, nnp, nseg, nhol, nelp)
Definition fvmbags_stub.F:34